summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore7
-rw-r--r--.gitlab-ci.yml2
-rw-r--r--GNUmakefile5
-rw-r--r--INSTALL2
-rw-r--r--INSTALL.REPO23
-rw-r--r--Makefile.in50
-rw-r--r--README2
-rw-r--r--admin/CPP-DEFINES2
-rw-r--r--admin/MAINTAINERS4
-rw-r--r--admin/authors.el2
-rwxr-xr-xadmin/automerge29
-rwxr-xr-xadmin/emake7
-rw-r--r--admin/gitmerge.el96
-rw-r--r--admin/notes/emba34
-rw-r--r--admin/notes/git-workflow8
-rw-r--r--admin/notes/unicode13
-rwxr-xr-xadmin/nt/dist-build/build-dep-zips.py46
-rw-r--r--admin/unidata/Makefile.in8
-rw-r--r--admin/unidata/README4
-rw-r--r--admin/unidata/emoji-test.txt4991
-rw-r--r--admin/unidata/emoji-zwj.awk6
-rwxr-xr-xadmin/update_autogen88
-rwxr-xr-xbuild-aux/config.guess7
-rwxr-xr-xbuild-aux/config.sub7
-rw-r--r--configure.ac399
-rw-r--r--doc/emacs/Makefile.in1
-rw-r--r--doc/emacs/abbrevs.texi2
-rw-r--r--doc/emacs/cmdargs.texi9
-rw-r--r--doc/emacs/custom.texi161
-rw-r--r--doc/emacs/dired.texi35
-rw-r--r--doc/emacs/display.texi49
-rw-r--r--doc/emacs/emacs.texi23
-rw-r--r--doc/emacs/files.texi8
-rw-r--r--doc/emacs/haiku.texi124
-rw-r--r--doc/emacs/help.texi41
-rw-r--r--doc/emacs/killing.texi10
-rw-r--r--doc/emacs/kmacro.texi2
-rw-r--r--doc/emacs/m-x.texi9
-rw-r--r--doc/emacs/maintaining.texi19
-rw-r--r--doc/emacs/misc.texi83
-rw-r--r--doc/emacs/msdos-xtra.texi2
-rw-r--r--doc/emacs/msdos.texi8
-rw-r--r--doc/emacs/mule.texi44
-rw-r--r--doc/emacs/programs.texi11
-rw-r--r--doc/emacs/regs.texi30
-rw-r--r--doc/emacs/text.texi7
-rw-r--r--doc/emacs/xresources.texi8
-rw-r--r--doc/lispintro/emacs-lisp-intro.texi132
-rw-r--r--doc/lispref/commands.texi254
-rw-r--r--doc/lispref/control.texi9
-rw-r--r--doc/lispref/customize.texi2
-rw-r--r--doc/lispref/display.texi381
-rw-r--r--doc/lispref/edebug.texi2
-rw-r--r--doc/lispref/elisp.texi9
-rw-r--r--doc/lispref/errors.texi4
-rw-r--r--doc/lispref/files.texi37
-rw-r--r--doc/lispref/frames.texi90
-rw-r--r--doc/lispref/functions.texi9
-rw-r--r--doc/lispref/help.texi9
-rw-r--r--doc/lispref/internals.texi8
-rw-r--r--doc/lispref/keymaps.texi502
-rw-r--r--doc/lispref/loading.texi4
-rw-r--r--doc/lispref/modes.texi63
-rw-r--r--doc/lispref/objects.texi15
-rw-r--r--doc/lispref/os.texi29
-rw-r--r--doc/lispref/processes.texi9
-rw-r--r--doc/lispref/searching.texi22
-rw-r--r--doc/lispref/strings.texi4
-rw-r--r--doc/lispref/text.texi259
-rw-r--r--doc/lispref/tips.texi7
-rw-r--r--doc/lispref/variables.texi190
-rw-r--r--doc/lispref/windows.texi54
-rw-r--r--doc/man/emacsclient.15
-rw-r--r--doc/misc/cc-mode.texi1
-rw-r--r--doc/misc/cl.texi8
-rw-r--r--doc/misc/efaq.texi4
-rw-r--r--doc/misc/eieio.texi17
-rw-r--r--doc/misc/emacs-mime.texi3
-rw-r--r--doc/misc/erc.texi33
-rw-r--r--doc/misc/ert.texi168
-rw-r--r--doc/misc/eshell.texi366
-rw-r--r--doc/misc/eww.texi31
-rw-r--r--doc/misc/flymake.texi4
-rw-r--r--doc/misc/gnus.texi19
-rw-r--r--doc/misc/htmlfontify.texi4
-rw-r--r--doc/misc/mairix-el.texi12
-rw-r--r--doc/misc/mh-e.texi8
-rw-r--r--doc/misc/modus-themes.org579
-rw-r--r--doc/misc/pcl-cvs.texi4
-rw-r--r--doc/misc/rcirc.texi19
-rw-r--r--doc/misc/texinfo.tex14
-rw-r--r--doc/misc/tramp.texi47
-rw-r--r--doc/misc/trampver.texi4
-rw-r--r--doc/misc/vhdl-mode.texi6
-rw-r--r--etc/ERC-NEWS8
-rw-r--r--etc/MACHINES28
-rw-r--r--etc/NEWS4844
-rw-r--r--etc/NEWS.284603
-rw-r--r--etc/PROBLEMS136
-rw-r--r--etc/TODO4
-rw-r--r--etc/compilation.txt3
-rw-r--r--etc/e/README18
-rw-r--r--etc/e/eterm-colorbin1179 -> 1296 bytes
-rw-r--r--etc/e/eterm-color.ti19
-rw-r--r--etc/e/eterm-directbin0 -> 1375 bytes
-rw-r--r--etc/images/README1
-rw-r--r--etc/images/connect-to-url.pbmbin0 -> 81 bytes
-rw-r--r--etc/images/connect-to-url.xpm281
-rw-r--r--etc/org.gnu.emacs.defaults.gschema.xml51
-rw-r--r--etc/publicsuffix.txt27
-rw-r--r--etc/refcards/ru-refcard.tex2
-rw-r--r--etc/themes/adwaita-theme.el3
-rw-r--r--etc/themes/deeper-blue-theme.el2
-rw-r--r--etc/themes/dichromacy-theme.el3
-rw-r--r--etc/themes/leuven-theme.el2
-rw-r--r--etc/themes/light-blue-theme.el2
-rw-r--r--etc/themes/manoj-dark-theme.el4
-rw-r--r--etc/themes/modus-operandi-theme.el4
-rw-r--r--etc/themes/modus-themes.el472
-rw-r--r--etc/themes/modus-vivendi-theme.el4
-rw-r--r--etc/themes/whiteboard-theme.el2
-rw-r--r--etc/tutorials/TUTORIAL18
-rw-r--r--etc/tutorials/TUTORIAL.he15
-rw-r--r--etc/tutorials/TUTORIAL.it13
-rw-r--r--etc/tutorials/TUTORIAL.sv14
-rw-r--r--leim/SKK-DIC/SKK-JISYO.L2
-rw-r--r--lib-src/Makefile.in21
-rw-r--r--lib-src/be_resources.cc144
-rw-r--r--lib-src/emacsclient.c27
-rw-r--r--lib-src/etags.c9
-rw-r--r--lib-src/ntlib.c13
-rw-r--r--lib/cdefs.h67
-rw-r--r--lib/gettext.h13
-rw-r--r--lib/gnulib.mk.in223
-rw-r--r--lib/intprops.h15
-rw-r--r--lib/nproc.c5
-rw-r--r--lib/nstrftime.c9
-rw-r--r--lib/regcomp.c813
-rw-r--r--lib/regex_internal.c40
-rw-r--r--lib/regex_internal.h49
-rw-r--r--lib/regexec.c84
-rw-r--r--lib/string.in.h29
-rw-r--r--lib/sys_random.in.h6
-rw-r--r--lisp/Makefile.in38
-rw-r--r--lisp/abbrev.el5
-rw-r--r--lisp/align.el46
-rw-r--r--lisp/allout.el15
-rw-r--r--lisp/ansi-color.el359
-rw-r--r--lisp/apropos.el29
-rw-r--r--lisp/arc-mode.el16
-rw-r--r--lisp/autoinsert.el1
-rw-r--r--lisp/bindings.el24
-rw-r--r--lisp/bookmark.el155
-rw-r--r--lisp/button.el14
-rw-r--r--lisp/calc/calc-ext.el38
-rw-r--r--lisp/calc/calc-graph.el3
-rw-r--r--lisp/calc/calc-help.el31
-rw-r--r--lisp/calc/calc-math.el5
-rw-r--r--lisp/calc/calc-misc.el42
-rw-r--r--lisp/calc/calc-mode.el9
-rw-r--r--lisp/calc/calc-prog.el9
-rw-r--r--lisp/calc/calc-store.el43
-rw-r--r--lisp/calc/calc-units.el39
-rw-r--r--lisp/calc/calc.el7
-rw-r--r--lisp/calculator.el42
-rw-r--r--lisp/calendar/icalendar.el14
-rw-r--r--lisp/calendar/time-date.el13
-rw-r--r--lisp/cedet/mode-local.el4
-rw-r--r--lisp/cedet/semantic/bovine/c.el40
-rw-r--r--lisp/cedet/semantic/complete.el9
-rw-r--r--lisp/cedet/semantic/decorate/mode.el1
-rw-r--r--lisp/cedet/semantic/dep.el1
-rw-r--r--lisp/cedet/semantic/fw.el2
-rw-r--r--lisp/cedet/semantic/grm-wy-boot.el8
-rw-r--r--lisp/cedet/semantic/lex-spp.el9
-rw-r--r--lisp/cedet/semantic/lex.el17
-rw-r--r--lisp/cedet/semantic/wisent.el2
-rw-r--r--lisp/char-fold.el146
-rw-r--r--lisp/cmuscheme.el3
-rw-r--r--lisp/comint.el117
-rw-r--r--lisp/completion.el4
-rw-r--r--lisp/composite.el2
-rw-r--r--lisp/cus-edit.el14
-rw-r--r--lisp/cus-face.el38
-rw-r--r--lisp/cus-start.el21
-rw-r--r--lisp/cus-theme.el34
-rw-r--r--lisp/custom.el25
-rw-r--r--lisp/descr-text.el9
-rw-r--r--lisp/dired-aux.el110
-rw-r--r--lisp/dired-x.el49
-rw-r--r--lisp/dired.el414
-rw-r--r--lisp/doc-view.el96
-rw-r--r--lisp/edmacro.el105
-rw-r--r--lisp/elec-pair.el78
-rw-r--r--lisp/electric.el10
-rw-r--r--lisp/emacs-lisp/autoload.el18
-rw-r--r--lisp/emacs-lisp/backtrace.el24
-rw-r--r--lisp/emacs-lisp/byte-opt.el10
-rw-r--r--lisp/emacs-lisp/byte-run.el7
-rw-r--r--lisp/emacs-lisp/bytecomp.el31
-rw-r--r--lisp/emacs-lisp/cconv.el38
-rw-r--r--lisp/emacs-lisp/checkdoc.el13
-rw-r--r--lisp/emacs-lisp/cl-generic.el31
-rw-r--r--lisp/emacs-lisp/cl-lib.el5
-rw-r--r--lisp/emacs-lisp/cl-macs.el3
-rw-r--r--lisp/emacs-lisp/comp-cstr.el64
-rw-r--r--lisp/emacs-lisp/comp.el16
-rw-r--r--lisp/emacs-lisp/crm.el47
-rw-r--r--lisp/emacs-lisp/debug.el6
-rw-r--r--lisp/emacs-lisp/derived.el7
-rw-r--r--lisp/emacs-lisp/easy-mmode.el3
-rw-r--r--lisp/emacs-lisp/edebug.el6
-rw-r--r--lisp/emacs-lisp/eieio-compat.el5
-rw-r--r--lisp/emacs-lisp/eieio-core.el29
-rw-r--r--lisp/emacs-lisp/eieio-opt.el1
-rw-r--r--lisp/emacs-lisp/eieio.el11
-rw-r--r--lisp/emacs-lisp/eldoc.el10
-rw-r--r--lisp/emacs-lisp/elp.el25
-rw-r--r--lisp/emacs-lisp/ert-x.el113
-rw-r--r--lisp/emacs-lisp/ert.el464
-rw-r--r--lisp/emacs-lisp/generator.el25
-rw-r--r--lisp/emacs-lisp/gv.el2
-rw-r--r--lisp/emacs-lisp/lisp-mode.el86
-rw-r--r--lisp/emacs-lisp/macroexp.el11
-rw-r--r--lisp/emacs-lisp/map-ynp.el12
-rw-r--r--lisp/emacs-lisp/memory-report.el5
-rw-r--r--lisp/emacs-lisp/multisession.el446
-rw-r--r--lisp/emacs-lisp/package.el218
-rw-r--r--lisp/emacs-lisp/pp.el242
-rw-r--r--lisp/emacs-lisp/re-builder.el21
-rw-r--r--lisp/emacs-lisp/shadow.el3
-rw-r--r--lisp/emacs-lisp/shortdoc.el70
-rw-r--r--lisp/emacs-lisp/subr-x.el112
-rw-r--r--lisp/emacs-lisp/tabulated-list.el41
-rw-r--r--lisp/emacs-lisp/timer.el16
-rw-r--r--lisp/emacs-lisp/warnings.el4
-rw-r--r--lisp/emulation/cua-base.el33
-rw-r--r--lisp/emulation/cua-rect.el6
-rw-r--r--lisp/emulation/viper-cmd.el48
-rw-r--r--lisp/emulation/viper-ex.el1
-rw-r--r--lisp/emulation/viper-init.el12
-rw-r--r--lisp/emulation/viper-mous.el8
-rw-r--r--lisp/emulation/viper-util.el50
-rw-r--r--lisp/emulation/viper.el1
-rw-r--r--lisp/epa-hook.el18
-rw-r--r--lisp/epa-ks.el15
-rw-r--r--lisp/epa.el12
-rw-r--r--lisp/epg.el3
-rw-r--r--lisp/erc/erc-backend.el54
-rw-r--r--lisp/erc/erc-compat.el2
-rw-r--r--lisp/erc/erc-dcc.el7
-rw-r--r--lisp/erc/erc-goodies.el2
-rw-r--r--lisp/erc/erc-imenu.el3
-rw-r--r--lisp/erc/erc-replace.el3
-rw-r--r--lisp/erc/erc.el60
-rw-r--r--lisp/eshell/esh-mode.el19
-rw-r--r--lisp/eshell/esh-util.el4
-rw-r--r--lisp/ezimage.el1
-rw-r--r--lisp/facemenu.el4
-rw-r--r--lisp/faces.el133
-rw-r--r--lisp/ffap.el2
-rw-r--r--lisp/filenotify.el8
-rw-r--r--lisp/files.el313
-rw-r--r--lisp/finder.el22
-rw-r--r--lisp/font-lock.el2
-rw-r--r--lisp/format.el4
-rw-r--r--lisp/frame.el82
-rw-r--r--lisp/gnus/gmm-utils.el1
-rw-r--r--lisp/gnus/gnus-agent.el82
-rw-r--r--lisp/gnus/gnus-art.el251
-rw-r--r--lisp/gnus/gnus-bookmark.el49
-rw-r--r--lisp/gnus/gnus-dired.el20
-rw-r--r--lisp/gnus/gnus-draft.el15
-rw-r--r--lisp/gnus/gnus-eform.el11
-rw-r--r--lisp/gnus/gnus-group.el408
-rw-r--r--lisp/gnus/gnus-html.el26
-rw-r--r--lisp/gnus/gnus-icalendar.el59
-rw-r--r--lisp/gnus/gnus-kill.el21
-rw-r--r--lisp/gnus/gnus-ml.el17
-rw-r--r--lisp/gnus/gnus-msg.el72
-rw-r--r--lisp/gnus/gnus-registry.el11
-rw-r--r--lisp/gnus/gnus-rmail.el142
-rw-r--r--lisp/gnus/gnus-salt.el48
-rw-r--r--lisp/gnus/gnus-score.el46
-rw-r--r--lisp/gnus/gnus-search.el48
-rw-r--r--lisp/gnus/gnus-srvr.el135
-rw-r--r--lisp/gnus/gnus-start.el3
-rw-r--r--lisp/gnus/gnus-sum.el1015
-rw-r--r--lisp/gnus/gnus-topic.el105
-rw-r--r--lisp/gnus/gnus-undo.el15
-rw-r--r--lisp/gnus/gnus-util.el146
-rw-r--r--lisp/gnus/gnus.el58
-rw-r--r--lisp/gnus/mail-source.el19
-rw-r--r--lisp/gnus/message.el229
-rw-r--r--lisp/gnus/mm-decode.el23
-rw-r--r--lisp/gnus/mm-util.el2
-rw-r--r--lisp/gnus/mml.el100
-rw-r--r--lisp/gnus/nndiary.el4
-rw-r--r--lisp/gnus/nnimap.el38
-rw-r--r--lisp/gnus/nnrss.el16
-rw-r--r--lisp/gnus/nnselect.el9
-rw-r--r--lisp/gnus/nntp.el4
-rw-r--r--lisp/gnus/spam.el14
-rw-r--r--lisp/help-at-pt.el10
-rw-r--r--lisp/help-fns.el551
-rw-r--r--lisp/help-macro.el4
-rw-r--r--lisp/help-mode.el62
-rw-r--r--lisp/help.el438
-rw-r--r--lisp/htmlfontify.el5
-rw-r--r--lisp/ibuf-ext.el5
-rw-r--r--lisp/ibuffer.el4
-rw-r--r--lisp/icomplete.el23
-rw-r--r--lisp/ido.el10
-rw-r--r--lisp/ielm.el38
-rw-r--r--lisp/image-dired.el1764
-rw-r--r--lisp/image-file.el2
-rw-r--r--lisp/image-mode.el132
-rw-r--r--lisp/image.el124
-rw-r--r--lisp/image/exif.el22
-rw-r--r--lisp/image/gravatar.el4
-rw-r--r--lisp/indent.el17
-rw-r--r--lisp/info-look.el114
-rw-r--r--lisp/info.el69
-rw-r--r--lisp/international/ccl.el2
-rw-r--r--lisp/international/characters.el122
-rw-r--r--lisp/international/emoji.el688
-rw-r--r--lisp/international/fontset.el13
-rw-r--r--lisp/international/iso-transl.el23
-rw-r--r--lisp/international/mule-cmds.el365
-rw-r--r--lisp/international/mule-conf.el1
-rw-r--r--lisp/international/mule-diag.el364
-rw-r--r--lisp/international/mule.el4
-rw-r--r--lisp/international/quail.el2
-rw-r--r--lisp/international/robin.el8
-rw-r--r--lisp/international/ucs-normalize.el92
-rw-r--r--lisp/isearch.el32
-rw-r--r--lisp/keymap.el457
-rw-r--r--lisp/language/cyril-util.el2
-rw-r--r--lisp/language/hanja-util.el4
-rw-r--r--lisp/language/lao.el10
-rw-r--r--lisp/ldefs-boot.el645
-rw-r--r--lisp/leim/quail/hangul.el4
-rw-r--r--lisp/leim/quail/ipa.el8
-rw-r--r--lisp/leim/quail/latin-post.el18
-rw-r--r--lisp/leim/quail/latin-pre.el18
-rw-r--r--lisp/loadup.el14
-rw-r--r--lisp/ls-lisp.el13
-rw-r--r--lisp/mail/feedmail.el18
-rw-r--r--lisp/mail/footnote.el2
-rw-r--r--lisp/mail/mail-utils.el15
-rw-r--r--lisp/mail/rmail.el10
-rw-r--r--lisp/mail/rmailedit.el4
-rw-r--r--lisp/mail/rmailkwd.el13
-rw-r--r--lisp/mail/rmailmm.el6
-rw-r--r--lisp/mail/rmailmsc.el4
-rw-r--r--lisp/mail/rmailout.el5
-rw-r--r--lisp/mail/rmailsort.el4
-rw-r--r--lisp/mail/rmailsum.el16
-rw-r--r--lisp/mail/sendmail.el14
-rw-r--r--lisp/mail/supercite.el2
-rw-r--r--lisp/mail/uce.el51
-rw-r--r--lisp/man.el36
-rw-r--r--lisp/menu-bar.el75
-rw-r--r--lisp/mh-e/mh-acros.el39
-rw-r--r--lisp/mh-e/mh-alias.el39
-rw-r--r--lisp/mh-e/mh-comp.el59
-rw-r--r--lisp/mh-e/mh-compat.el364
-rw-r--r--lisp/mh-e/mh-e.el529
-rw-r--r--lisp/mh-e/mh-folder.el450
-rw-r--r--lisp/mh-e/mh-funcs.el2
-rw-r--r--lisp/mh-e/mh-gnus.el149
-rw-r--r--lisp/mh-e/mh-identity.el27
-rw-r--r--lisp/mh-e/mh-letter.el184
-rw-r--r--lisp/mh-e/mh-limit.el8
-rw-r--r--lisp/mh-e/mh-mime.el192
-rw-r--r--lisp/mh-e/mh-scan.el11
-rw-r--r--lisp/mh-e/mh-search.el103
-rw-r--r--lisp/mh-e/mh-seq.el38
-rw-r--r--lisp/mh-e/mh-show.el298
-rw-r--r--lisp/mh-e/mh-speed.el85
-rw-r--r--lisp/mh-e/mh-thread.el50
-rw-r--r--lisp/mh-e/mh-tool-bar.el217
-rw-r--r--lisp/mh-e/mh-utils.el150
-rw-r--r--lisp/mh-e/mh-xface.el107
-rw-r--r--lisp/midnight.el2
-rw-r--r--lisp/minibuffer.el4
-rw-r--r--lisp/mouse.el320
-rw-r--r--lisp/mwheel.el92
-rw-r--r--lisp/net/ange-ftp.el5
-rw-r--r--lisp/net/browse-url.el267
-rw-r--r--lisp/net/dbus.el24
-rw-r--r--lisp/net/eudc.el7
-rw-r--r--lisp/net/eww.el419
-rw-r--r--lisp/net/hmac-def.el1
-rw-r--r--lisp/net/mailcap.el67
-rw-r--r--lisp/net/newst-backend.el52
-rw-r--r--lisp/net/newst-plainview.el6
-rw-r--r--lisp/net/nsm.el3
-rw-r--r--lisp/net/puny.el1
-rw-r--r--lisp/net/rcirc.el37
-rw-r--r--lisp/net/sasl.el23
-rw-r--r--lisp/net/shr.el349
-rw-r--r--lisp/net/soap-client.el7
-rw-r--r--lisp/net/tramp-adb.el38
-rw-r--r--lisp/net/tramp-archive.el9
-rw-r--r--lisp/net/tramp-cache.el9
-rw-r--r--lisp/net/tramp-cmds.el7
-rw-r--r--lisp/net/tramp-compat.el158
-rw-r--r--lisp/net/tramp-crypt.el12
-rw-r--r--lisp/net/tramp-ftp.el9
-rw-r--r--lisp/net/tramp-fuse.el8
-rw-r--r--lisp/net/tramp-gvfs.el86
-rw-r--r--lisp/net/tramp-integration.el23
-rw-r--r--lisp/net/tramp-rclone.el26
-rw-r--r--lisp/net/tramp-sh.el167
-rw-r--r--lisp/net/tramp-smb.el58
-rw-r--r--lisp/net/tramp-sshfs.el15
-rw-r--r--lisp/net/tramp-sudoedit.el46
-rw-r--r--lisp/net/tramp.el440
-rw-r--r--lisp/net/trampver.el10
-rw-r--r--lisp/nxml/rng-cmpct.el2
-rw-r--r--lisp/nxml/xmltok.el10
-rw-r--r--lisp/nxml/xsd-regexp.el9
-rw-r--r--lisp/obsolete/cl-compat.el1
-rw-r--r--lisp/obsolete/cl.el9
-rw-r--r--lisp/obsolete/crisp.el22
-rw-r--r--lisp/obsolete/eieio-compat.el277
-rw-r--r--lisp/obsolete/eudcb-ph.el4
-rw-r--r--lisp/obsolete/fast-lock.el35
-rw-r--r--lisp/obsolete/iswitchb.el20
-rw-r--r--lisp/obsolete/otodo-mode.el3
-rw-r--r--lisp/obsolete/pgg-parse.el3
-rw-r--r--lisp/obsolete/pgg.el3
-rw-r--r--lisp/obsolete/tpu-edt.el23
-rw-r--r--lisp/obsolete/tpu-mapper.el54
-rw-r--r--lisp/obsolete/vc-arch.el2
-rw-r--r--lisp/org/ol.el2
-rw-r--r--lisp/org/org-capture.el11
-rw-r--r--lisp/org/org-clock.el15
-rw-r--r--lisp/org/org-colview.el2
-rw-r--r--lisp/org/org-compat.el3
-rw-r--r--lisp/org/org-id.el3
-rw-r--r--lisp/org/org-macro.el2
-rw-r--r--lisp/org/org-macs.el4
-rw-r--r--lisp/org/org-refile.el12
-rw-r--r--lisp/org/org-table.el2
-rw-r--r--lisp/org/org.el8
-rw-r--r--lisp/org/ox-icalendar.el7
-rw-r--r--lisp/outline.el118
-rw-r--r--lisp/paren.el21
-rw-r--r--lisp/pcomplete.el14
-rw-r--r--lisp/pixel-scroll.el405
-rw-r--r--lisp/play/animate.el14
-rw-r--r--lisp/play/snake.el47
-rw-r--r--lisp/play/tetris.el38
-rw-r--r--lisp/proced.el70
-rw-r--r--lisp/progmodes/bug-reference.el14
-rw-r--r--lisp/progmodes/cc-cmds.el25
-rw-r--r--lisp/progmodes/cc-engine.el71
-rw-r--r--lisp/progmodes/cc-fonts.el49
-rw-r--r--lisp/progmodes/cc-mode.el81
-rw-r--r--lisp/progmodes/cc-styles.el12
-rw-r--r--lisp/progmodes/cc-vars.el2
-rw-r--r--lisp/progmodes/compile.el10
-rw-r--r--lisp/progmodes/cperl-mode.el14
-rw-r--r--lisp/progmodes/cpp.el7
-rw-r--r--lisp/progmodes/ebrowse.el42
-rw-r--r--lisp/progmodes/elisp-mode.el58
-rw-r--r--lisp/progmodes/erts-mode.el225
-rw-r--r--lisp/progmodes/etags.el24
-rw-r--r--lisp/progmodes/f90.el7
-rw-r--r--lisp/progmodes/gdb-mi.el13
-rw-r--r--lisp/progmodes/grep.el8
-rw-r--r--lisp/progmodes/gud.el12
-rw-r--r--lisp/progmodes/hideif.el42
-rw-r--r--lisp/progmodes/idlw-shell.el7
-rw-r--r--lisp/progmodes/js.el1179
-rw-r--r--lisp/progmodes/octave.el8
-rw-r--r--lisp/progmodes/pascal.el4
-rw-r--r--lisp/progmodes/prog-mode.el8
-rw-r--r--lisp/progmodes/project.el100
-rw-r--r--lisp/progmodes/prolog.el7
-rw-r--r--lisp/progmodes/python.el57
-rw-r--r--lisp/progmodes/scheme.el1
-rw-r--r--lisp/progmodes/sh-script.el72
-rw-r--r--lisp/progmodes/sql.el71
-rw-r--r--lisp/progmodes/verilog-mode.el34
-rw-r--r--lisp/progmodes/vhdl-mode.el5
-rw-r--r--lisp/progmodes/xref.el145
-rw-r--r--lisp/progmodes/xscheme.el5
-rw-r--r--lisp/ps-mule.el4
-rw-r--r--lisp/ps-print.el146
-rw-r--r--lisp/recentf.el50
-rw-r--r--lisp/register.el7
-rw-r--r--lisp/repeat.el51
-rw-r--r--lisp/replace.el36
-rw-r--r--lisp/rot13.el32
-rw-r--r--lisp/saveplace.el17
-rw-r--r--lisp/select.el52
-rw-r--r--lisp/server.el174
-rw-r--r--lisp/ses.el24
-rw-r--r--lisp/shell.el3
-rw-r--r--lisp/simple.el151
-rw-r--r--lisp/skeleton.el3
-rw-r--r--lisp/sort.el4
-rw-r--r--lisp/speedbar.el32
-rw-r--r--lisp/sqlite-mode.el216
-rw-r--r--lisp/sqlite.el43
-rw-r--r--lisp/startup.el123
-rw-r--r--lisp/strokes.el15
-rw-r--r--lisp/subr.el261
-rw-r--r--lisp/tab-bar.el74
-rw-r--r--lisp/tab-line.el17
-rw-r--r--lisp/tar-mode.el4
-rw-r--r--lisp/term.el348
-rw-r--r--lisp/term/haiku-win.el139
-rw-r--r--lisp/term/ns-win.el8
-rw-r--r--lisp/term/pgtk-win.el516
-rw-r--r--lisp/term/w32-win.el2
-rw-r--r--lisp/textmodes/artist.el5
-rw-r--r--lisp/textmodes/bibtex.el25
-rw-r--r--lisp/textmodes/etc-authors-mode.el10
-rw-r--r--lisp/textmodes/fill.el14
-rw-r--r--lisp/textmodes/flyspell.el13
-rw-r--r--lisp/textmodes/glyphless-mode.el68
-rw-r--r--lisp/textmodes/ispell.el82
-rw-r--r--lisp/textmodes/pixel-fill.el240
-rw-r--r--lisp/textmodes/reftex-global.el6
-rw-r--r--lisp/textmodes/reftex-index.el2
-rw-r--r--lisp/textmodes/reftex-parse.el12
-rw-r--r--lisp/textmodes/reftex-vars.el37
-rw-r--r--lisp/textmodes/sgml-mode.el38
-rw-r--r--lisp/textmodes/table.el102
-rw-r--r--lisp/textmodes/tex-mode.el2
-rw-r--r--lisp/textmodes/texinfo.el59
-rw-r--r--lisp/thingatpt.el15
-rw-r--r--lisp/thumbs.el22
-rw-r--r--lisp/time.el12
-rw-r--r--lisp/timezone.el14
-rw-r--r--lisp/tooltip.el7
-rw-r--r--lisp/tree-widget.el4
-rw-r--r--lisp/tutorial.el8
-rw-r--r--lisp/url/url-privacy.el1
-rw-r--r--lisp/userlock.el64
-rw-r--r--lisp/vc/cvs-status.el27
-rw-r--r--lisp/vc/diff-mode.el149
-rw-r--r--lisp/vc/diff.el8
-rw-r--r--lisp/vc/ediff-help.el4
-rw-r--r--lisp/vc/ediff-init.el4
-rw-r--r--lisp/vc/ediff-ptch.el29
-rw-r--r--lisp/vc/ediff-util.el6
-rw-r--r--lisp/vc/ediff.el4
-rw-r--r--lisp/vc/log-edit.el28
-rw-r--r--lisp/vc/log-view.el51
-rw-r--r--lisp/vc/pcvs-defs.el154
-rw-r--r--lisp/vc/pcvs.el147
-rw-r--r--lisp/vc/smerge-mode.el45
-rw-r--r--lisp/vc/vc-cvs.el9
-rw-r--r--lisp/vc/vc-dav.el4
-rw-r--r--lisp/vc/vc-dir.el7
-rw-r--r--lisp/vc/vc-dispatcher.el21
-rw-r--r--lisp/vc/vc-git.el38
-rw-r--r--lisp/vc/vc-hg.el7
-rw-r--r--lisp/vc/vc-hooks.el3
-rw-r--r--lisp/vc/vc-rcs.el9
-rw-r--r--lisp/vc/vc-sccs.el10
-rw-r--r--lisp/vc/vc.el44
-rw-r--r--lisp/vcursor.el6
-rw-r--r--lisp/version.el4
-rw-r--r--lisp/view.el124
-rw-r--r--lisp/whitespace.el53
-rw-r--r--lisp/wid-edit.el12
-rw-r--r--lisp/widget.el4
-rw-r--r--lisp/windmove.el2
-rw-r--r--lisp/window.el206
-rw-r--r--lisp/xdg.el29
-rw-r--r--lisp/xml.el10
-rw-r--r--lisp/xwidget.el609
-rw-r--r--lisp/yank-media.el194
-rw-r--r--lwlib/xlwmenu.c36
-rw-r--r--lwlib/xlwmenu.h2
-rw-r--r--lwlib/xlwmenuP.h1
-rw-r--r--m4/alloca.m410
-rw-r--r--m4/byteswap.m48
-rw-r--r--m4/errno_h.m410
-rw-r--r--m4/execinfo.m412
-rw-r--r--m4/getopt.m410
-rw-r--r--m4/gnulib-common.m432
-rw-r--r--m4/gnulib-comp.m439
-rw-r--r--m4/gsettings.m488
-rw-r--r--m4/ieee754-h.m46
-rw-r--r--m4/include_next.m46
-rw-r--r--m4/inttypes.m44
-rw-r--r--m4/libgmp.m47
-rw-r--r--m4/limits-h.m49
-rw-r--r--m4/stdalign.m47
-rw-r--r--m4/stddef_h.m414
-rw-r--r--m4/stdint.m48
-rw-r--r--m4/sys_socket_h.m47
-rw-r--r--msdos/sed2v2.inp2
-rw-r--r--nextstep/templates/Info.plist.in2
-rw-r--r--nt/INSTALL17
-rw-r--r--nt/INSTALL.W641
-rw-r--r--nt/Makefile.in1
-rw-r--r--nt/README.W322
-rw-r--r--nt/addpm.c4
-rw-r--r--nt/cmdproxy.c3
-rw-r--r--nt/ddeclient.c3
-rw-r--r--nt/preprep.c3
-rw-r--r--nt/runemacs.c3
-rw-r--r--src/.gdbinit8
-rw-r--r--src/Makefile.in96
-rw-r--r--src/alloc.c55
-rw-r--r--src/atimer.c47
-rw-r--r--src/bidi.c29
-rw-r--r--src/bignum.c9
-rw-r--r--src/buffer.c12
-rw-r--r--src/callproc.c3
-rw-r--r--src/casefiddle.c57
-rw-r--r--src/comp.c46
-rw-r--r--src/data.c2
-rw-r--r--src/dispextern.h63
-rw-r--r--src/dispnew.c33
-rw-r--r--src/dynlib.c12
-rw-r--r--src/dynlib.h1
-rw-r--r--src/emacs-module.h.in13
-rw-r--r--src/emacs.c95
-rw-r--r--src/emacsgtkfixed.c116
-rw-r--r--src/emacsgtkfixed.h9
-rw-r--r--src/eval.c43
-rw-r--r--src/fileio.c16
-rw-r--r--src/filelock.c2
-rw-r--r--src/floatfns.c15
-rw-r--r--src/fns.c8
-rw-r--r--src/font.c113
-rw-r--r--src/font.h4
-rw-r--r--src/frame.c26
-rw-r--r--src/frame.h25
-rw-r--r--src/fringe.c23
-rw-r--r--src/ftcrfont.c81
-rw-r--r--src/ftfont.c6
-rw-r--r--src/ftfont.h7
-rw-r--r--src/gtkutil.c723
-rw-r--r--src/gtkutil.h29
-rw-r--r--src/haiku.c286
-rw-r--r--src/haiku_draw_support.cc488
-rw-r--r--src/haiku_font_support.cc596
-rw-r--r--src/haiku_io.c207
-rw-r--r--src/haiku_select.cc229
-rw-r--r--src/haiku_support.cc2928
-rw-r--r--src/haiku_support.h869
-rw-r--r--src/haikufns.c2449
-rw-r--r--src/haikufont.c1072
-rw-r--r--src/haikugui.h106
-rw-r--r--src/haikuimage.c109
-rw-r--r--src/haikumenu.c656
-rw-r--r--src/haikuselect.c180
-rw-r--r--src/haikuselect.h74
-rw-r--r--src/haikuterm.c3647
-rw-r--r--src/haikuterm.h296
-rw-r--r--src/image.c940
-rw-r--r--src/indent.c1
-rw-r--r--src/intervals.c20
-rw-r--r--src/keyboard.c268
-rw-r--r--src/keyboard.h2
-rw-r--r--src/keymap.c230
-rw-r--r--src/lisp.h110
-rw-r--r--src/lread.c23
-rw-r--r--src/macfont.m36
-rw-r--r--src/menu.c31
-rw-r--r--src/menu.h6
-rw-r--r--src/minibuf.c107
-rw-r--r--src/module-env-29.h3
-rw-r--r--src/msdos.c2
-rw-r--r--src/nsfns.m55
-rw-r--r--src/nsfont.m1215
-rw-r--r--src/nsmenu.m76
-rw-r--r--src/nsselect.m84
-rw-r--r--src/nsterm.h15
-rw-r--r--src/nsterm.m542
-rw-r--r--src/pdumper.c21
-rw-r--r--src/pdumper.h5
-rw-r--r--src/pgtkfns.c4144
-rw-r--r--src/pgtkgui.h119
-rw-r--r--src/pgtkim.c311
-rw-r--r--src/pgtkmenu.c1159
-rw-r--r--src/pgtkselect.c632
-rw-r--r--src/pgtkselect.h33
-rw-r--r--src/pgtkterm.c7115
-rw-r--r--src/pgtkterm.h664
-rw-r--r--src/print.c40
-rw-r--r--src/process.c43
-rw-r--r--src/search.c88
-rw-r--r--src/sound.c24
-rw-r--r--src/sqlite.c753
-rw-r--r--src/sysdep.c34
-rw-r--r--src/sysstdio.h2
-rw-r--r--src/systime.h3
-rw-r--r--src/term.c26
-rw-r--r--src/termhooks.h45
-rw-r--r--src/terminal.c4
-rw-r--r--src/timefns.c73
-rw-r--r--src/verbose.mk.in4
-rw-r--r--src/w32.c77
-rw-r--r--src/w32.h6
-rw-r--r--src/w32fns.c158
-rw-r--r--src/w32font.c33
-rw-r--r--src/w32inevt.c14
-rw-r--r--src/w32proc.c21
-rw-r--r--src/w32term.c123
-rw-r--r--src/window.h2
-rw-r--r--src/xdisp.c831
-rw-r--r--src/xfaces.c111
-rw-r--r--src/xfns.c87
-rw-r--r--src/xmenu.c4
-rw-r--r--src/xsettings.c54
-rw-r--r--src/xsettings.h15
-rw-r--r--src/xterm.c1778
-rw-r--r--src/xterm.h56
-rw-r--r--src/xwidget.c2260
-rw-r--r--src/xwidget.h46
-rw-r--r--test/Makefile.in32
-rw-r--r--test/README8
-rw-r--r--test/data/image/black.gifbin0 -> 143 bytes
-rw-r--r--test/data/image/black.webpbin0 -> 37780 bytes
-rw-r--r--test/infra/Dockerfile.emba22
-rw-r--r--test/infra/Makefile.in100
-rw-r--r--test/infra/gitlab-ci.yml183
-rw-r--r--test/infra/test-jobs.yml545
-rw-r--r--test/lisp/abbrev-tests.el60
-rw-r--r--test/lisp/ansi-color-tests.el94
-rw-r--r--test/lisp/auth-source-tests.el180
-rw-r--r--test/lisp/autoinsert-tests.el19
-rw-r--r--test/lisp/autorevert-tests.el829
-rw-r--r--test/lisp/bookmark-tests.el18
-rw-r--r--test/lisp/buff-menu-tests.el21
-rw-r--r--test/lisp/calc/calc-tests.el6
-rw-r--r--test/lisp/calendar/icalendar-tests.el142
-rw-r--r--test/lisp/calendar/time-date-tests.el24
-rw-r--r--test/lisp/calendar/todo-mode-tests.el37
-rw-r--r--test/lisp/cedet/semantic/bovine/gcc-tests.el5
-rw-r--r--test/lisp/cedet/srecode/fields-tests.el23
-rw-r--r--test/lisp/comint-tests.el1
-rw-r--r--test/lisp/custom-tests.el37
-rw-r--r--test/lisp/dired-aux-tests.el62
-rw-r--r--test/lisp/dired-resources/insert-directory/test_dir/bar0
-rw-r--r--test/lisp/dired-resources/insert-directory/test_dir/foo0
-rw-r--r--test/lisp/dired-resources/insert-directory/test_dir_other/bar0
-rw-r--r--test/lisp/dired-resources/insert-directory/test_dir_other/foo0
-rw-r--r--test/lisp/dired-tests.el439
-rw-r--r--test/lisp/dired-x-tests.el40
-rw-r--r--test/lisp/edmacro-tests.el47
-rw-r--r--test/lisp/electric-tests.el22
-rw-r--r--test/lisp/emacs-lisp/backtrace-tests.el2
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el17
-rw-r--r--test/lisp/emacs-lisp/bytecomp-tests.el224
-rw-r--r--test/lisp/emacs-lisp/cconv-tests.el152
-rw-r--r--test/lisp/emacs-lisp/check-declare-tests.el96
-rw-r--r--test/lisp/emacs-lisp/cl-generic-tests.el9
-rw-r--r--test/lisp/emacs-lisp/cl-lib-tests.el12
-rw-r--r--test/lisp/emacs-lisp/cl-macs-tests.el23
-rw-r--r--test/lisp/emacs-lisp/derived-tests.el4
-rw-r--r--test/lisp/emacs-lisp/edebug-tests.el51
-rw-r--r--test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el282
-rw-r--r--test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el2
-rw-r--r--test/lisp/emacs-lisp/eieio-tests/eieio-tests.el387
-rw-r--r--test/lisp/emacs-lisp/ert-tests.el151
-rw-r--r--test/lisp/emacs-lisp/ert-x-tests.el108
-rw-r--r--test/lisp/emacs-lisp/generator-tests.el11
-rw-r--r--test/lisp/emacs-lisp/gv-tests.el19
-rw-r--r--test/lisp/emacs-lisp/let-alist-tests.el2
-rw-r--r--test/lisp/emacs-lisp/lisp-tests.el5
-rw-r--r--test/lisp/emacs-lisp/multisession-tests.el201
-rw-r--r--test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el12
-rw-r--r--test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el21
-rw-r--r--test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el16
-rw-r--r--test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el30
-rw-r--r--test/lisp/emacs-lisp/package-tests.el168
-rw-r--r--test/lisp/emacs-lisp/pp-resources/code-formats.erts124
-rw-r--r--test/lisp/emacs-lisp/pp-tests.el4
-rw-r--r--test/lisp/emacs-lisp/ring-tests.el2
-rw-r--r--test/lisp/emacs-lisp/seq-tests.el22
-rw-r--r--test/lisp/emacs-lisp/subr-x-tests.el100
-rw-r--r--test/lisp/emacs-lisp/testcover-resources/testcases.el2
-rw-r--r--test/lisp/emacs-lisp/testcover-tests.el108
-rw-r--r--test/lisp/emacs-lisp/timer-tests.el3
-rw-r--r--test/lisp/emulation/viper-tests.el80
-rw-r--r--test/lisp/epg-tests.el77
-rw-r--r--test/lisp/erc/erc-tests.el71
-rw-r--r--test/lisp/eshell/em-hist-tests.el17
-rw-r--r--test/lisp/eshell/em-ls-tests.el38
-rw-r--r--test/lisp/eshell/eshell-tests.el32
-rw-r--r--test/lisp/ffap-tests.el31
-rw-r--r--test/lisp/filenotify-tests.el31
-rw-r--r--test/lisp/files-tests.el310
-rw-r--r--test/lisp/format-spec-tests.el4
-rw-r--r--test/lisp/gnus/gnus-group-tests.el52
-rw-r--r--test/lisp/gnus/gnus-icalendar-tests.el2
-rw-r--r--test/lisp/help-fns-tests.el4
-rw-r--r--test/lisp/help-tests.el138
-rw-r--r--test/lisp/image-dired-tests.el37
-rw-r--r--test/lisp/image-tests.el64
-rw-r--r--test/lisp/image/exif-tests.el21
-rw-r--r--test/lisp/info-tests.el39
-rw-r--r--test/lisp/info-xref-tests.el80
-rw-r--r--test/lisp/ls-lisp-tests.el36
-rw-r--r--test/lisp/mail/mail-utils-tests.el3
-rw-r--r--test/lisp/mail/uudecode-tests.el26
-rw-r--r--test/lisp/mh-e/mh-thread-tests.el131
-rw-r--r--test/lisp/mh-e/mh-utils-tests.el112
-rwxr-xr-xtest/lisp/mh-e/test-all-mh-variants.sh6
-rw-r--r--test/lisp/net/browse-url-tests.el6
-rw-r--r--test/lisp/net/netrc-tests.el2
-rw-r--r--test/lisp/net/ntlm-tests.el2
-rw-r--r--test/lisp/net/puny-tests.el7
-rw-r--r--test/lisp/net/tramp-archive-tests.el57
-rw-r--r--test/lisp/net/tramp-tests.el510
-rw-r--r--test/lisp/obsolete/cl-tests.el9
-rw-r--r--test/lisp/paren-tests.el31
-rw-r--r--test/lisp/progmodes/bug-reference-tests.el128
-rw-r--r--test/lisp/progmodes/compile-tests.el3
-rw-r--r--test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts88
-rw-r--r--test/lisp/progmodes/elisp-mode-resources/flet.erts353
-rw-r--r--test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el2
-rw-r--r--test/lisp/progmodes/elisp-mode-tests.el75
-rw-r--r--test/lisp/progmodes/etags-tests.el31
-rw-r--r--test/lisp/progmodes/flymake-tests.el32
-rw-r--r--test/lisp/progmodes/perl-mode-tests.el2
-rw-r--r--test/lisp/progmodes/project-tests.el20
-rw-r--r--test/lisp/progmodes/python-tests.el23
-rw-r--r--test/lisp/progmodes/sql-tests.el100
-rw-r--r--test/lisp/replace-tests.el11
-rw-r--r--test/lisp/saveplace-tests.el67
-rw-r--r--test/lisp/ses-tests.el4
-rw-r--r--test/lisp/so-long-tests/so-long-tests.el4
-rw-r--r--test/lisp/so-long-tests/spelling-tests.el30
-rw-r--r--test/lisp/subr-tests.el246
-rw-r--r--test/lisp/tar-mode-tests.el3
-rw-r--r--test/lisp/term-tests.el38
-rw-r--r--test/lisp/textmodes/fill-tests.el22
-rw-r--r--test/lisp/textmodes/reftex-tests.el101
-rw-r--r--test/lisp/textmodes/texinfo-resources/fill.erts70
-rw-r--r--test/lisp/textmodes/texinfo-tests.el33
-rw-r--r--test/lisp/thingatpt-tests.el10
-rw-r--r--test/lisp/thumbs-tests.el10
-rw-r--r--test/lisp/time-stamp-tests.el10
-rw-r--r--test/lisp/vc/diff-mode-tests.el56
-rw-r--r--test/lisp/vc/ediff-ptch-tests.el60
-rw-r--r--test/lisp/vc/vc-bzr-tests.el172
-rw-r--r--test/lisp/vc/vc-git-tests.el67
-rw-r--r--test/lisp/vc/vc-tests.el876
-rw-r--r--test/lisp/wdired-tests.el274
-rw-r--r--test/manual/cedet/cedet-utests.el4
-rw-r--r--test/src/buffer-tests.el195
-rw-r--r--test/src/casefiddle-tests.el16
-rw-r--r--test/src/comp-tests.el100
-rw-r--r--test/src/data-tests.el45
-rw-r--r--test/src/editfns-tests.el61
-rw-r--r--test/src/emacs-module-tests.el27
-rw-r--r--test/src/emacs-tests.el30
-rw-r--r--test/src/eval-tests.el19
-rw-r--r--test/src/filelock-tests.el49
-rw-r--r--test/src/floatfns-tests.el62
-rw-r--r--test/src/fns-tests.el67
-rw-r--r--test/src/image-tests.el245
-rw-r--r--test/src/inotify-tests.el34
-rw-r--r--test/src/keymap-tests.el92
-rw-r--r--test/src/lread-tests.el14
-rw-r--r--test/src/process-tests.el50
-rw-r--r--test/src/search-tests.el2
-rw-r--r--test/src/sqlite-tests.el218
-rw-r--r--test/src/timefns-tests.el12
-rw-r--r--test/src/undo-tests.el20
-rw-r--r--test/src/xdisp-tests.el71
874 files changed, 81130 insertions, 24575 deletions
diff --git a/.gitignore b/.gitignore
index c7a6ec56d0f..78557a5e876 100644
--- a/.gitignore
+++ b/.gitignore
@@ -159,6 +159,7 @@ test/manual/etags/CTAGS
test/manual/indent/*.new
test/lisp/gnus/mml-sec-resources/random_seed
test/lisp/play/fortune-resources/fortunes.dat
+test/**/*.xml
# ctags, etags.
TAGS
@@ -182,6 +183,7 @@ ID
# Executables.
*.exe
a.out
+lib-src/be-resources
lib-src/blessmail
lib-src/ctags
lib-src/ebrowse
@@ -203,6 +205,7 @@ nextstep/GNUstep/Emacs.base/Resources/Info-gnustep.plist
src/bootstrap-emacs
src/emacs
src/emacs-[0-9]*
+src/Emacs
src/temacs
src/dmpstruct.h
src/*.pdmp
@@ -215,6 +218,7 @@ lisp/international/charprop.el
lisp/international/charscript.el
lisp/international/cp51932.el
lisp/international/emoji-zwj.el
+lisp/international/emoji-labels.el
lisp/international/eucjp-ms.el
lisp/international/uni-*.el
lisp/language/pinyin.el
@@ -313,3 +317,6 @@ lib-src/seccomp-filter.bpf
lib-src/seccomp-filter.pfc
lib-src/seccomp-filter-exec.bpf
lib-src/seccomp-filter-exec.pfc
+
+# gsettings schema
+/etc/*.gschema.valid
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 3138f4184e6..402c17ddb85 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -15,7 +15,7 @@
# You should have received a copy of the GNU General Public License
# along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-# GNU Emacs support for the GitLab protocol for CI
+# GNU Emacs support for the GitLab protocol for CI.
# The presence of this file does not imply any FSF/GNU endorsement of
# any particular service that uses that protocol. Also, it is intended for
diff --git a/GNUmakefile b/GNUmakefile
index 5155487de28..76fd77ba1b0 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -104,8 +104,13 @@ configure:
Makefile: configure
@echo >&2 'There seems to be no Makefile in this directory.'
+ifeq ($(configure),default)
@echo >&2 'Running ./configure ...'
./configure
+else
+ @echo >&2 'Running ./configure '$(configure)'...'
+ ./configure $(configure)
+endif
@echo >&2 'Makefile built.'
# 'make bootstrap' in a fresh checkout needn't run 'configure' twice.
diff --git a/INSTALL b/INSTALL
index 6207f43cecb..21298422af7 100644
--- a/INSTALL
+++ b/INSTALL
@@ -187,6 +187,7 @@ X11 is being used.
X libtiff for TIFF: http://www.simplesystems.org/libtiff/
X libgif for GIF: http://giflib.sourceforge.net/
librsvg2 for SVG: https://wiki.gnome.org/Projects/LibRsvg
+ libwebp for WebP: https://developers.google.com/speed/webp/
If you supply the appropriate --without-LIB option, 'configure' will
omit the corresponding library from Emacs, even if that makes for a
@@ -313,6 +314,7 @@ or more of these options:
--without-gif for GIF image support
--without-png for PNG image support
--without-rsvg for SVG image support
+ --without-webp for WebP image support
Although ImageMagick support is disabled by default due to security
and stability concerns, you can enable it with --with-imagemagick.
diff --git a/INSTALL.REPO b/INSTALL.REPO
index da56d7611b2..182c2e95341 100644
--- a/INSTALL.REPO
+++ b/INSTALL.REPO
@@ -8,9 +8,15 @@ directory on your local machine:
To build the repository code, simply run 'make' in the 'emacs'
directory. This should work if your files are freshly checked out
-from the repository, and if you have the proper tools installed. If
-it doesn't work, or if you have special build requirements, the
-following information may be helpful.
+from the repository, and if you have the proper tools installed; the
+default configuration options will be used. Other configuration
+options can be specified by setting a 'configure' variable, for
+example:
+
+ $ make configure="--prefix=/opt/emacs CFLAGS='-O0 -g3'"
+
+If the above doesn't work, or if you have special build requirements,
+the following information may be helpful.
Building Emacs from the source-code repository requires some tools
that are not needed when building from a release. You will need:
@@ -58,7 +64,16 @@ To update loaddefs.el (and similar files), do:
If either of the above partial procedures fails, try 'make bootstrap'.
If CPU time is not an issue, 'make bootstrap' is a more thorough way
-to rebuild, avoiding spurious problems.
+to rebuild, avoiding spurious problems. 'make bootstrap' rebuilds
+Emacs with the same configuration options as the previous build; it
+can also be used to rebuild Emacs with other configuration options by
+setting a 'configure' variable, for example:
+
+ $ make bootstrap configure="CFLAGS='-O0 -g3'"
+
+To rebuild Emacs with the default configuration options, you can use:
+
+ $ make bootstrap configure=default
Occasionally, there are changes that 'make bootstrap' won't be able to
handle. The most thorough cleaning can be achieved by 'git clean -fdx'
diff --git a/Makefile.in b/Makefile.in
index c36882d5bea..202665ea9d0 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -102,6 +102,8 @@ HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
USE_STARTUP_NOTIFICATION = @USE_STARTUP_NOTIFICATION@
+HAVE_BE_APP = @HAVE_BE_APP@
+
# ==================== Where To Install Things ====================
# Location to install Emacs.app under GNUstep / macOS.
@@ -210,6 +212,9 @@ icondir=$(datarootdir)/icons
# The source directory for the icon files.
iconsrcdir=$(srcdir)/etc/images/icons
+# Where to install the gsettings schema file.
+gsettingsschemadir = @gsettingsschemadir@
+
# ==================== Emacs-specific directories ====================
# These variables hold the values Emacs will actually use. They are
@@ -304,6 +309,8 @@ LN_S_FILEONLY = @LN_S_FILEONLY@
# We use gzip to compress installed .el and some .txt files.
GZIP_PROG = @GZIP_PROG@
+GLIB_COMPILE_SCHEMAS = glib-compile-schemas
+
# ============================= Targets ==============================
# Program name transformation.
@@ -313,6 +320,7 @@ TRANSFORM = @program_transform_name@
EMACS_NAME = `echo emacs | sed '$(TRANSFORM)'`
EMACS = ${EMACS_NAME}${EXEEXT}
EMACSFULL = `echo emacs-${version} | sed '$(TRANSFORM)'`${EXEEXT}
+EMACS_PDMP = `./src/emacs${EXEEXT} --fingerprint`.pdmp
# Subdirectories to make recursively.
SUBDIR = $(NTDIR) lib lib-src src lisp
@@ -342,7 +350,9 @@ BIN_DESTDIR='${ns_appbindir}/'
ELN_DESTDIR = ${ns_applibdir}/
endif
-all: ${SUBDIR} info
+gsettings_SCHEMAS = etc/org.gnu.emacs.defaults.gschema.xml
+
+all: ${SUBDIR} info $(gsettings_SCHEMAS:.xml=.valid)
.PHONY: all ${SUBDIR} blessmail epaths-force epaths-force-w32 epaths-force-ns-self-contained etc-emacsver
@@ -424,6 +434,10 @@ epaths-force-ns-self-contained: epaths-force
-e 's;${ns_appdir}/;;') && \
${srcdir}/build-aux/move-if-change epaths.h.$$$$ src/epaths.h
+ifneq ($(NTDIR),)
+$(NTDIR): lib
+endif
+
lib-src src: $(NTDIR) lib
src: lib-src
@@ -494,7 +508,7 @@ $(srcdir)/configure: $(srcdir)/configure.ac $(srcdir)/m4/*.m4
## don't have to duplicate the list of utilities to install in
## this Makefile as well.
-install: all install-arch-indep install-etcdoc install-arch-dep install-$(NTDIR) blessmail install-eln
+install: all install-arch-indep install-etcdoc install-arch-dep install-$(NTDIR) blessmail install-eln install-gsettings-schemas
@true
## Ensure that $subdir contains a subdirs.el file.
@@ -520,8 +534,14 @@ install-arch-dep: src install-arch-indep install-etcdoc install-$(NTDIR)
$(MAKE) -C lib-src install
ifeq (${ns_self_contained},no)
${INSTALL_PROGRAM} $(INSTALL_STRIP) src/emacs${EXEEXT} "$(DESTDIR)${bindir}/$(EMACSFULL)"
+ifeq (${HAVE_BE_APP},yes)
+ ${INSTALL_PROGRAM} $(INSTALL_STRIP) src/Emacs "$(DESTDIR)${prefix}/apps/Emacs"
+endif
ifeq (${DUMPING},pdumper)
- ${INSTALL_DATA} src/emacs.pdmp "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}"/emacs.pdmp
+ifeq (${HAVE_BE_APP},yes)
+ ${INSTALL_DATA} src/Emacs.pdmp "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}"/Emacs.pdmp
+endif
+ ${INSTALL_DATA} src/emacs.pdmp "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}"/emacs-${EMACS_PDMP}
endif
-chmod 755 "$(DESTDIR)${bindir}/$(EMACSFULL)"
ifndef NO_BIN_LINK
@@ -808,7 +828,7 @@ install-strip:
### create (but not the noninstalled files such as 'make all' would create).
###
### Don't delete the lisp and etc directories if they're in the source tree.
-uninstall: uninstall-$(NTDIR) uninstall-doc
+uninstall: uninstall-$(NTDIR) uninstall-doc uninstall-gsettings-schemas
rm -f "$(DESTDIR)$(includedir)/emacs-module.h"
$(MAKE) -C lib-src uninstall
-unset CDPATH; \
@@ -904,7 +924,7 @@ clean_dirs = $(mostlyclean_dirs) nextstep admin/charsets admin/unidata
$(foreach dir,$(clean_dirs),$(eval $(call submake_template,$(dir),clean)))
-clean: $(clean_dirs:=_clean)
+clean: $(clean_dirs:=_clean) clean-gsettings-schemas
-rm -f ./*.tmp etc/*.tmp*
-rm -rf info-dir.*
-rm -rf native-lisp
@@ -1136,14 +1156,23 @@ check-info: info
.PHONY: bootstrap
-# Bootstrapping does the following:
+# Without a 'configure' variable, bootstrapping does the following:
# * Remove files to start from a bootstrap-clean slate.
# * Run autogen.sh.
# * Rebuild Makefile, to update the build procedure itself.
# * Do the actual build.
-bootstrap: bootstrap-clean
+# With a 'configure' variable, bootstrapping does the following:
+# * Remove files to start from an extraclean slate.
+# * Do the actual build, during which the 'configure' variable is
+# used (see the Makefile goal in GNUmakefile).
+bootstrap:
+ifndef configure
+ $(MAKE) bootstrap-clean
cd $(srcdir) && ./autogen.sh autoconf
$(MAKE) MAKEFILE_NAME=force-Makefile force-Makefile
+else
+ $(MAKE) extraclean
+endif
$(MAKE) all
.PHONY: ChangeLog change-history change-history-commit change-history-nocommit
@@ -1215,3 +1244,10 @@ gitmerge:
${GITMERGE_EMACS} -batch --no-site-file --no-site-lisp \
-l ${srcdir}/admin/gitmerge.el \
--eval '(setq gitmerge-minimum-missing ${GITMERGE_NMIN})' -f gitmerge
+
+@GSETTINGS_RULES@
+
+install-gsettings-schemas:
+uninstall-gsettings-schemas:
+clean-gsettings-schemas:
+$(gsettings_SCHEMAS:.xml=.valid):
diff --git a/README b/README
index 83382f1b281..6329a7775e9 100644
--- a/README
+++ b/README
@@ -2,7 +2,7 @@ Copyright (C) 2001-2021 Free Software Foundation, Inc.
See the end of the file for license conditions.
-This directory tree holds version 28.0.90 of GNU Emacs, the extensible,
+This directory tree holds version 29.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
diff --git a/admin/CPP-DEFINES b/admin/CPP-DEFINES
index 68c12438f5a..620ab0bed05 100644
--- a/admin/CPP-DEFINES
+++ b/admin/CPP-DEFINES
@@ -287,6 +287,8 @@ HAVE_UTIMENSAT
HAVE_UTMP_H
HAVE_VFORK
HAVE_VFORK_H
+HAVE_WEBP
+HAVE_SQLITE3
HAVE_WCHAR_H
HAVE_WCHAR_T
HAVE_WINDOW_SYSTEM
diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS
index 02b8cf39bd6..33aeb528651 100644
--- a/admin/MAINTAINERS
+++ b/admin/MAINTAINERS
@@ -138,6 +138,9 @@ Andrea Corallo
lisp/emacs-lisp/comp-cstr.el
test/src/comp-*.el
+Stefan Kangas
+ admin/automerge
+
==============================================================================
2. Areas that someone is willing to maintain, although he would not
necessarily mind if someone else was the official maintainer.
@@ -228,6 +231,7 @@ Michael Albinus
lisp/net/ange-ftp.el
lisp/notifications.el
lisp/shadowfile.el
+ test/infra/*
test/lisp/autorevert-tests.el
test/lisp/files-tests.el (file-name-non-special)
test/lisp/shadowfile-tests.el
diff --git a/admin/authors.el b/admin/authors.el
index adf6d22a88e..d44bb9bf8e4 100644
--- a/admin/authors.el
+++ b/admin/authors.el
@@ -391,6 +391,8 @@ Changes to files matching one of the regexps in this list are not listed.")
"autogen/missing" "autogen"
"autogen/copy_autogen" ; not generated, but trivial and now removed
"dir_top"
+ ;; Imported into Emacs but externally maintained.
+ "publicsuffix.txt" "SKK-JISYO.L"
;; Only existed briefly, then renamed:
"images/icons/allout-widgets-dark-bg"
"images/icons/allout-widgets-light-bg"
diff --git a/admin/automerge b/admin/automerge
index 61570587d6b..81082f7dc68 100755
--- a/admin/automerge
+++ b/admin/automerge
@@ -4,7 +4,7 @@
## Copyright (C) 2018-2021 Free Software Foundation, Inc.
## Author: Glenn Morris <rgm@gnu.org>
-## Maintainer: emacs-devel@gnu.org
+## Maintainer: Stefan Kangas <stefan@marxist.se>
## This file is part of GNU Emacs.
@@ -37,7 +37,7 @@
die () # write error to stderr and exit
{
- [ $# -gt 0 ] && echo "$PN: $@" >&2
+ [ $# -gt 0 ] && echo "$PN: $*" >&2
exit 1
}
@@ -108,7 +108,8 @@ OPTIND=1
[ "$nocd" ] || {
- cd $PD # this should be the admin directory
+ # $PD should be the admin directory
+ cd $PD || die "Could not change directory to $PD"
cd ../
}
@@ -126,9 +127,13 @@ OPTIND=1
[ "$test" ] && build=1
-tempfile=/tmp/$PN.$$
+if [ -x "$(command -v mktemp)" ]; then
+ tempfile=$(mktemp "/tmp/$PN.XXXXXXXXXX")
+else
+ tempfile=/tmp/$PN.$$
+fi
-trap "rm -f $tempfile 2> /dev/null" EXIT
+trap 'rm -f $tempfile 2> /dev/null' EXIT
[ -e Makefile ] && [ "$build" ] && {
@@ -148,7 +153,7 @@ trap "rm -f $tempfile 2> /dev/null" EXIT
rev=$(git rev-parse HEAD)
-[ $(git rev-parse @{u}) = $rev ] || die "Local state does not match origin"
+[ "$(git rev-parse @{u})" = "$rev" ] || die "Local state does not match origin"
merge ()
@@ -157,12 +162,12 @@ merge ()
if $emacs --batch -Q -l ./admin/gitmerge.el \
--eval "(setq gitmerge-minimum-missing $nmin)" -f gitmerge \
- >| $tempfile 2>&1; then
+ >| "$tempfile" 2>&1; then
echo "merged ok"
return 0
else
- grep -E "Nothing to merge|Number of missing commits" $tempfile && \
+ grep -E "Nothing to merge|Number of missing commits" "$tempfile" && \
exit 0
cat "$tempfile" 1>&2
@@ -186,13 +191,13 @@ git diff --stat --cached origin/master | grep -q "etc/NEWS " && \
echo "Running autoreconf..."
-autoreconf -i -I m4 2>| $tempfile
+autoreconf -i -I m4 2>| "$tempfile"
retval=$?
## Annoyingly, autoreconf puts the "installing `./foo' messages on stderr.
if [ "$quiet" ]; then
- grep -v 'installing `\.' $tempfile 1>&2
+ grep -v 'installing `\.' "$tempfile" 1>&2
else
cat "$tempfile" 1>&2
fi
@@ -231,7 +236,7 @@ echo "Tests finished ok"
echo "Checking for remote changes..."
git fetch || die "fetch error"
-[ $(git rev-parse @{u}) = $rev ] || {
+[ "$(git rev-parse @{u})" = "$rev" ] || {
echo "Upstream has changed"
@@ -240,7 +245,7 @@ git fetch || die "fetch error"
## Ref eg https://lists.gnu.org/r/emacs-devel/2014-12/msg01435.html
## Instead, we throw away what we just did, and do the merge again.
echo "Resetting..."
- git reset --hard $rev
+ git reset --hard "$rev"
echo "Pulling..."
git pull --ff-only || die "pull error"
diff --git a/admin/emake b/admin/emake
index bdaabc026b3..2ff553289da 100755
--- a/admin/emake
+++ b/admin/emake
@@ -13,7 +13,7 @@ cores=1
# Determine the number of cores.
if [ -f /proc/cpuinfo ]; then
- cores=$(($(egrep "^physical id|^cpu cores" /proc/cpuinfo |\
+ cores=$(($(grep -E "^physical id|^cpu cores" /proc/cpuinfo |\
awk '{ print $4; }' |\
sed '$!N;s/\n/ /' |\
uniq |\
@@ -28,8 +28,9 @@ s#^Installing git hooks...# Installing git hooks...#
s#^Running # Running #
s#^Configured for # Configured for #
s#^./temacs.*# \\& #
+s#^make.*Error# \\& #
' | \
-egrep --line-buffered -v "^make|\
+grep -E --line-buffered -v "^make|\
^Loading|\
SCRAPE|\
INFO.*Scraping.*[.] ?\$|\
@@ -92,4 +93,4 @@ done
# changed since last time.
make -j$cores check-maybe 2>&1 | \
sed -n '/contained unexpected results/,$p' | \
- egrep --line-buffered -v "^make"
+ grep -E --line-buffered -v "^make"
diff --git a/admin/gitmerge.el b/admin/gitmerge.el
index 851212c7bb1..658ceb77f49 100644
--- a/admin/gitmerge.el
+++ b/admin/gitmerge.el
@@ -37,10 +37,10 @@
;; up-to-date).
;; - Mark commits you'd like to skip, meaning to only merge their
;; metadata (merge strategy 'ours').
-;; - Hit 'm' to start merging. Skipped commits will be merged separately.
+;; - Hit 'm' to start merging. Skipped commits will be merged separately.
;; - If conflicts cannot be resolved automatically, you'll have to do
-;; it manually. In that case, resolve the conflicts and restart
-;; gitmerge, which will automatically resume. It will add resolved
+;; it manually. In that case, resolve the conflicts and restart
+;; gitmerge, which will automatically resume. It will add resolved
;; files, commit the pending merge and continue merging the rest.
;; - Inspect master branch, and if everything looks OK, push.
@@ -68,8 +68,7 @@ bump Emacs version\\|Auto-commit"))
(defvar gitmerge-minimum-missing 10
"Minimum number of missing commits to consider merging in batch mode.")
-(defvar gitmerge-status-file (expand-file-name "gitmerge-status"
- user-emacs-directory)
+(defvar gitmerge-status-file (locate-user-emacs-file "gitmerge-status")
"File where missing commits will be saved between sessions.")
(defvar gitmerge-ignore-branches-regexp
@@ -122,13 +121,14 @@ If nil, the function `gitmerge-default-branch' guesses.")
(with-temp-buffer
(if (not branch)
(insert-file-contents "configure.ac")
- (call-process "git" nil t nil "show" (format "%s:configure.ac" branch))
+ (let ((coding-system-for-read vc-git-log-output-coding-system))
+ (call-process "git" nil t nil "show" (format "%s:configure.ac" branch)))
(goto-char (point-min)))
(re-search-forward "^AC_INIT([^,]+, \\([0-9]+\\)\\.")
(string-to-number (match-string 1))))
(defun gitmerge-default-branch ()
- "Default for branch that should be merged; eg \"origin/emacs-26\"."
+ "Default for branch that should be merged; e.g. \"origin/emacs-28\"."
(or gitmerge-default-branch
(format "origin/emacs-%s" (1- (gitmerge-emacs-version)))))
@@ -148,7 +148,8 @@ If nil, the function `gitmerge-default-branch' guesses.")
(pop-to-buffer (get-buffer-create gitmerge-output-buffer))
(fundamental-mode)
(erase-buffer)
- (call-process "git" nil t nil "log" "-1" commit)
+ (let ((coding-system-for-read vc-git-log-output-coding-system))
+ (call-process "git" nil t nil "log" "-1" commit))
(goto-char (point-min))
(gitmerge-highlight-skip-regexp)))))
@@ -160,7 +161,8 @@ If nil, the function `gitmerge-default-branch' guesses.")
(when commit
(pop-to-buffer (get-buffer-create gitmerge-output-buffer))
(erase-buffer)
- (call-process "git" nil t nil "diff-tree" "-p" commit)
+ (let ((coding-system-for-read vc-git-log-output-coding-system))
+ (call-process "git" nil t nil "diff-tree" "-p" commit))
(goto-char (point-min))
(diff-mode)))))
@@ -173,7 +175,9 @@ If nil, the function `gitmerge-default-branch' guesses.")
(pop-to-buffer (get-buffer-create gitmerge-output-buffer))
(erase-buffer)
(fundamental-mode)
- (call-process "git" nil t nil "diff" "--name-only" (concat commit "^!"))
+ (let ((coding-system-for-read vc-git-log-output-coding-system))
+ (call-process "git" nil t nil "diff" "--name-only"
+ (concat commit "^!")))
(goto-char (point-min))))))
(defun gitmerge-toggle-skip ()
@@ -216,9 +220,10 @@ if and why this commit should be skipped."
;; Go through the log and remember all commits that match
;; `gitmerge-skip-regexp' or are marked by --cherry-mark.
(with-temp-buffer
- (call-process "git" nil t nil "log" "--cherry-mark" "--left-only"
- "--no-decorate"
- (concat from "..." (car (vc-git-branches))))
+ (let ((coding-system-for-read vc-git-log-output-coding-system))
+ (call-process "git" nil t nil "log" "--cherry-mark" "--left-only"
+ "--no-decorate"
+ (concat from "..." (car (vc-git-branches)))))
(goto-char (point-max))
(while (re-search-backward "^commit \\(.+\\) \\([0-9a-f]+\\).*" nil t)
(let ((cherrymark (match-string 1))
@@ -241,9 +246,10 @@ if and why this commit should be skipped."
"Create the buffer for choosing commits."
(with-current-buffer (get-buffer-create gitmerge-buffer)
(erase-buffer)
- (call-process "git" nil t nil "log" "--left-only"
- "--pretty=format:%h %<(20,trunc) %an: %<(100,trunc) %s"
- (concat from "..." (car (vc-git-branches))))
+ (let ((coding-system-for-read vc-git-log-output-coding-system))
+ (call-process "git" nil t nil "log" "--left-only"
+ "--pretty=format:%h %<(20,trunc) %an: %<(100,trunc) %s"
+ (concat from "..." (car (vc-git-branches)))))
(goto-char (point-min))
(while (looking-at "^\\([a-f0-9]+\\)")
(let ((skipreason (gitmerge-skip-commit-p (match-string 1) commits)))
@@ -326,7 +332,8 @@ Returns non-nil if conflicts remain."
;; (pop-to-buffer (current-buffer)) (debug 'before-resolve)
))
;; Try to resolve the conflicts.
- (let (temp)
+ (let ((coding-system-for-read vc-git-log-output-coding-system)
+ temp)
(cond
;; FIXME when merging release branch to master, we still
;; need to detect and handle the case where NEWS was modified
@@ -392,9 +399,10 @@ is nil, only the single commit BEG is merged."
(if end "s were " " was ")
"skipped:\n\n")
""))
- (apply #'call-process "git" nil t nil "log" "--oneline"
- (if end (list (concat beg "~.." end))
- `("-1" ,beg)))
+ (let ((coding-system-for-read vc-git-log-output-coding-system))
+ (apply #'call-process "git" nil t nil "log" "--oneline"
+ (if end (list (concat beg "~.." end))
+ `("-1" ,beg))))
(insert "\n")
;; Truncate to 72 chars so that the resulting ChangeLog line fits in 80.
(goto-char (point-min))
@@ -408,8 +416,9 @@ MISSING must be a list of SHA1 strings."
(with-current-buffer (get-buffer-create gitmerge-output-buffer)
(erase-buffer)
(let* ((skip (cdar missing))
+ (coding-system-for-read vc-git-log-output-coding-system)
(beg (car (pop missing)))
- end commitmessage)
+ end commitmessage commitmessage1 commitmessage-file status)
;; Determine last revision with same boolean skip status.
(while (and missing
(eq (null (cdar missing))
@@ -423,12 +432,32 @@ MISSING must be a list of SHA1 strings."
(if end (concat ".." (substring end 0 6)) ""))
(unless end
(setq end beg))
- (unless (zerop
- (apply #'call-process "git" nil t nil "merge" "--no-ff"
- (append (when skip '("-s" "ours"))
- `("-m" ,commitmessage ,end))))
+ (when (eq system-type 'windows-nt)
+ ;; Command lines on MS-Windows cannot include newlines.
+ ;; Since "git merge" doesn't accept a -F FILE option, we
+ ;; commit the merge with a shortened single-line log message,
+ ;; and then invoke "git commit --amend" with the full log
+ ;; message from a temporary file.
+ (setq commitmessage1
+ ;; Make sure the commit message is at most a single line.
+ (car (split-string commitmessage "[\f\n\r\v]+")))
+ (setq commitmessage-file (make-nearby-temp-file "gitmerge-msg"))
+ (let ((coding-system-for-write vc-git-commits-coding-system))
+ (write-region commitmessage nil commitmessage-file nil 'silent)))
+ (unless (setq status
+ (zerop
+ (apply #'call-process "git" nil t nil "merge" "--no-ff"
+ (append (when skip '("-s" "ours"))
+ (if commitmessage-file
+ `("-m" ,commitmessage1 ,end)
+ `("-m" ,commitmessage ,end))))))
(gitmerge-write-missing missing from)
- (gitmerge-resolve-unmerged)))
+ (gitmerge-resolve-unmerged))
+ (when (and commitmessage-file (file-exists-p commitmessage-file))
+ (if status
+ (call-process "git" nil t nil
+ "commit" "--amend" "-F" commitmessage-file))
+ (delete-file commitmessage-file)))
missing))
(defun gitmerge-resolve-unmerged ()
@@ -436,12 +465,13 @@ MISSING must be a list of SHA1 strings."
Throw an user-error if we cannot resolve automatically."
(with-current-buffer (get-buffer-create gitmerge-output-buffer)
(erase-buffer)
- (let (files conflicted)
+ (let ((coding-system-for-read vc-git-log-output-coding-system)
+ files conflicted)
;; List unmerged files
(if (not (zerop
(call-process "git" nil t nil
"diff" "--name-only" "--diff-filter=U")))
- (error "Error listing unmerged files. Resolve manually.")
+ (error "Error listing unmerged files. Resolve manually.")
(goto-char (point-min))
(while (not (eobp))
(push (buffer-substring (point) (line-end-position)) files)
@@ -479,17 +509,19 @@ Throw an user-error if we cannot resolve automatically."
(defun gitmerge-repo-clean ()
"Return non-nil if repository is clean."
(with-temp-buffer
+ (let ((coding-system-for-read vc-git-log-output-coding-system))
(call-process "git" nil t nil
"diff" "--staged" "--name-only")
(call-process "git" nil t nil
"diff" "--name-only")
- (zerop (buffer-size))))
+ (zerop (buffer-size)))))
(defun gitmerge-commit ()
"Commit, and return non-nil if it succeeds."
(with-current-buffer (get-buffer-create gitmerge-output-buffer)
- (erase-buffer)
- (eq 0 (call-process "git" nil t nil "commit" "--no-edit"))))
+ (let ((coding-system-for-read vc-git-log-output-coding-system))
+ (erase-buffer)
+ (eq 0 (call-process "git" nil t nil "commit" "--no-edit")))))
(defun gitmerge-maybe-resume ()
"Check if we have to resume a merge.
@@ -603,7 +635,7 @@ Branch FROM will be prepended to the list."
"(s) Toggle skip, (l) Show log, (d) Show diff, "
"(f) Show files, (m) Start merge\n"
(propertize "Flags: " 'font-lock-face 'bold)
- "(C) Detected backport (cherry-mark), (R) Log matches "
+ "(C) Detected backport (cherry-mark), (R) Matches skip "
"regexp, (M) Manually picked\n\n")
(gitmerge-mode)
(pop-to-buffer (current-buffer))
diff --git a/admin/notes/emba b/admin/notes/emba
index 36b126e7735..2135c7a97cc 100644
--- a/admin/notes/emba
+++ b/admin/notes/emba
@@ -28,29 +28,45 @@ The messages contain a URL to the log file of the failed job, like
* Emacs jobset
The Emacs jobset is defined in the Emacs source tree, file
-'.gitlab-ci.yml'. It could be adapted for every Emacs branch, see
+'.gitlab-ci.yml'. All related files are located in directory
+'test/infra'. They could be adapted for every Emacs branch, see
<https://emba.gnu.org/help/ci/yaml/README.md>.
+A jobset on Gitlab is called pipeline. Emacs pipelines run through
+the stages 'build-images', 'platform-images' and 'native-comp-images'
+(create an Emacs instance by 'make bootstrap' with different
+configuration parameters) as well as 'normal', 'platforms' and
+'native-comp' (run respective test jobs based on the produced images).
+
+The jobs for stage 'normal' are contained in the file
+'test/infra/test-jobs.yml'. This file is generated by calling 'make
+-C test generate-test-jobs' in the Emacs source tree, and the
+resulting file shall be pushed to the Emacs git repository afterwards.
+
Every job runs in a Debian docker container. It uses the local clone
of the Emacs git repository to perform a bootstrap and test of Emacs.
This could happen for several jobs with changed configuration, compile
and test parameters.
-There are different types of jobs: 'prep-image-base' is responsible to
-prepare the environment for the following jobs. 'build-image-*' jobs
-are responsible to compile Emacs in different configuration. The
-corresponding 'test-*' jobs run the ert tests.
+The 'build-image-*' jobs of the different '*-images' stages run only
+if there are severe changes in the Emacs sources, like in Makefiles
+etc. Otherwise they are skipped, and the corresponding 'test-*' jobs
+run just 'make -C test ...' in the respective Docker image from a
+previous build run.
-A special job is 'test-all-inotify', which runs 'make check-expensive'.
-While most of the jobs run as soon as a respective file has been
-committed into the Emacs git repository, this test job runs scheduled,
-every 8 hours.
+Jobs in the 'build-images' and 'normal' stages are triggered by
+changes of respective files in the Emacs git repository. All other
+jobs run scheduled in a pipeline every 8 hours.
The log files for every test job are kept on the server for a week.
They can be downloaded from the server, visiting the URL
<https://emba.gnu.org/emacs/emacs/-/pipelines>, and selecting the job
in question.
+Every pipeline generates a JUnit test report for the respective test
+jobs, which can be inspected on the pipeline web page. This test
+report counts completed ERT tests, aborted tests are not counted.
+
* Emba configuration
The emba configuration files are hosted on
diff --git a/admin/notes/git-workflow b/admin/notes/git-workflow
index d109cdaa354..265a106bad5 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-27).
+(eg emacs-28).
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-27 emacs-27
+git worktree add ../emacs-28 emacs-28
You now have both branches conveniently accessible, and you can do
"git pull" in them once in a while to keep updated.
@@ -67,7 +67,7 @@ which will look like
commit 958b768a6534ae6e77a8547a56fc31b46b63710b
-cd ~/emacs/emacs-27
+cd ~/emacs/emacs-28
git cherry-pick -xe 958b768a6534ae6e77a8547a56fc31b46b63710b
and add "Backport:" to the commit string. Then
@@ -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-27', which you should accept. Merging a local tracking
+(eg) 'origin/emacs-28', 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/unicode b/admin/notes/unicode
index c41b9a6d26d..be51d09d37a 100644
--- a/admin/notes/unicode
+++ b/admin/notes/unicode
@@ -21,11 +21,14 @@ Emacs uses the following files from the Unicode Character Database
. emoji-sequences.txt
. BidiCharacterTest.txt
-First, the first 10 files need to be copied into admin/unidata/, and
-the file https://www.unicode.org/copyright.html should be copied over
-copyright.html in admin/unidata (some of them might need trailing
-whitespace removed before they can be committed to the Emacs
-repository).
+Emacs also uses the file emoji-test.txt which should be imported from
+the Unicode's Public/emoji/ directory.
+
+First, the first 10 files and emoji-test.txt need to be copied into
+admin/unidata/, and the file https://www.unicode.org/copyright.html
+should be copied over copyright.html in admin/unidata (some of them
+might need trailing whitespace removed before they can be committed to
+the Emacs repository).
Then Emacs should be rebuilt for them to take effect. Rebuilding
Emacs updates several derived files elsewhere in the Emacs source
diff --git a/admin/nt/dist-build/build-dep-zips.py b/admin/nt/dist-build/build-dep-zips.py
index 19168e7ff25..dfff493b640 100755
--- a/admin/nt/dist-build/build-dep-zips.py
+++ b/admin/nt/dist-build/build-dep-zips.py
@@ -20,6 +20,8 @@ import argparse
import os
import shutil
import re
+import functools
+import operator
from subprocess import check_output
@@ -112,7 +114,7 @@ def ntldd_munge(out):
## Packages to fiddle with
## Source for gcc-libs is part of gcc
SKIP_SRC_PKGS=["mingw-w64-gcc-libs"]
-SKIP_DEP_PKGS=["mingw-w64-glib2"]
+SKIP_DEP_PKGS=frozenset(["mingw-w64-x86_64-glib2"])
MUNGE_SRC_PKGS={"mingw-w64-libwinpthread-git":"mingw-w64-winpthreads-git"}
MUNGE_DEP_PKGS={
"mingw-w64-x86_64-libwinpthread":"mingw-w64-x86_64-libwinpthread-git",
@@ -121,19 +123,17 @@ MUNGE_DEP_PKGS={
## Currently no packages seem to require this!
ARCH_PKGS=[]
-SRC_REPO="https://sourceforge.net/projects/msys2/files/REPOS/MINGW/Sources"
+SRC_REPO="https://repo.msys2.org/mingw/sources"
-def immediate_deps(pkg):
- package_info = check_output(["pacman", "-Si", pkg]).decode("utf-8").split("\n")
+def immediate_deps(pkgs):
+ package_info = check_output(["pacman", "-Si"] + pkgs).decode("utf-8").splitlines()
- ## Extract the "Depends On" line
- depends_on = [x for x in package_info if x.startswith("Depends On")][0]
- ## Remove "Depends On" prefix
- dependencies = depends_on.split(":")[1]
-
- ## Split into dependencies
- dependencies = dependencies.strip().split(" ")
+ ## Extract the packages listed for "Depends On:" lines.
+ dependencies = [line.split(":")[1].split() for line in package_info
+ if line.startswith("Depends On")]
+ ## Flatten dependency lists from multiple packages into one list.
+ dependencies = functools.reduce(operator.iconcat, dependencies, [])
## Remove > signs TODO can we get any other punctuation here?
dependencies = [d.split(">")[0] for d in dependencies if d]
@@ -149,16 +149,18 @@ def extract_deps():
print( "Extracting deps" )
# Get a list of all dependencies needed for packages mentioned above.
- pkgs = PKG_REQ[:]
- n = 0
- while n < len(pkgs):
- subdeps = immediate_deps(pkgs[n])
- for p in subdeps:
- if not (p in pkgs or p in SKIP_DEP_PKGS):
- pkgs.append(p)
- n = n + 1
+ pkgs = set(PKG_REQ)
+ newdeps = pkgs
+ print("adding...")
+ while True:
+ subdeps = frozenset(immediate_deps(list(newdeps)))
+ newdeps = subdeps - SKIP_DEP_PKGS - pkgs
+ if not newdeps:
+ break
+ print('\n'.join(newdeps))
+ pkgs |= newdeps
- return sorted(pkgs)
+ return list(pkgs)
def download_source(tarball):
@@ -167,7 +169,7 @@ def download_source(tarball):
if not os.path.exists("../emacs-src-cache/{}".format(tarball)):
print("Downloading {}...".format(tarball))
check_output_maybe(
- "wget -a ../download.log -O ../emacs-src-cache/{} {}/{}/download"
+ "wget -a ../download.log -O ../emacs-src-cache/{} {}/{}"
.format(tarball, SRC_REPO, tarball),
shell=True
)
@@ -255,7 +257,7 @@ DRY_RUN=args.d
if( args.l ):
print("List of dependencies")
- print( extract_deps() )
+ print( deps )
exit(0)
if args.s:
diff --git a/admin/unidata/Makefile.in b/admin/unidata/Makefile.in
index a953044a115..701fb92b817 100644
--- a/admin/unidata/Makefile.in
+++ b/admin/unidata/Makefile.in
@@ -41,7 +41,7 @@ unifiles = $(addprefix ${unidir}/,$(sort $(shell sed -n 's/^[ \t][ \t]*${lparen}
.PHONY: all
all: ${top_srcdir}/src/macuvs.h ${unifiles} ${unidir}/charscript.el \
- ${unidir}/charprop.el ${unidir}/emoji-zwj.el
+ ${unidir}/charprop.el ${unidir}/emoji-zwj.el ${unidir}/emoji-labels.el
## Specify .elc as an order-only prereq so as to not needlessly rebuild
## target just because the .elc is missing.
@@ -72,9 +72,12 @@ ${unifiles}: ${srcdir}/unidata-gen.el \
${srcdir}/BidiBrackets.txt | \
${srcdir}/unidata-gen.elc unidata.txt
$(AM_V_at)[ ! -f $@ ] || chmod +w $@
- $(AM_V_GEN)${emacs} -L ${srcdir} -l unidata-gen \
+ $(AM_V_at)${emacs} -L ${srcdir} -l unidata-gen \
-f unidata-gen-file $@ ${srcdir}
+${unidir}/emoji-labels.el: ${unidir}/../international/emoji.el \
+ ${srcdir}/emoji-test.txt
+ $(AM_V_at)${emacs} -l emoji.el -f emoji--generate-file $@
.PHONY: charscript.el
charscript.el: ${unidir}/charscript.el
@@ -113,6 +116,7 @@ gen-clean:
rm -f ${unidir}/charscript.el*
rm -f ${unidir}/emoji-zwj.el*
rm -f ${unifiles} ${unidir}/charprop.el
+ rm -f ${unidir}/emoji-labels.el*
## ref: https://lists.gnu.org/r/emacs-devel/2013-11/msg01029.html
maintainer-clean: gen-clean distclean
diff --git a/admin/unidata/README b/admin/unidata/README
index 656ee15c54c..4b8444b0fec 100644
--- a/admin/unidata/README
+++ b/admin/unidata/README
@@ -44,3 +44,7 @@ https://www.unicode.org/Public/emoji/14.0/emoji-zwj-sequences.txt
emoji-sequences.txt
https://www.unicode.org/Public/emoji/14.0/emoji-sequences.txt
2020-08-26
+
+emoji-test.txt
+https://unicode.org/Public/emoji/14.0/emoji-test.txt
+2021-10-28
diff --git a/admin/unidata/emoji-test.txt b/admin/unidata/emoji-test.txt
new file mode 100644
index 00000000000..42e6210cd28
--- /dev/null
+++ b/admin/unidata/emoji-test.txt
@@ -0,0 +1,4991 @@
+# emoji-test.txt
+# Date: 2021-08-26, 17:22:23 GMT
+# © 2021 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 http://www.unicode.org/terms_of_use.html
+#
+# Emoji Keyboard/Display Test Data for UTS #51
+# Version: 14.0
+#
+# For documentation and usage, see http://www.unicode.org/reports/tr51
+#
+# This file provides data for testing which emoji forms should be in keyboards and which should also be displayed/processed.
+# Format: code points; status # emoji name
+# Code points — list of one or more hex code points, separated by spaces
+# Status
+# component — an Emoji_Component,
+# excluding Regional_Indicators, ASCII, and non-Emoji.
+# fully-qualified — a fully-qualified emoji (see ED-18 in UTS #51),
+# excluding Emoji_Component
+# minimally-qualified — a minimally-qualified emoji (see ED-18a in UTS #51)
+# unqualified — a unqualified emoji (See ED-19 in UTS #51)
+# Notes:
+# • This includes the emoji components that need emoji presentation (skin tone and hair)
+# when isolated, but omits the components that need not have an emoji
+# presentation when isolated.
+# • The RGI set is covered by the listed fully-qualified emoji.
+# • The listed minimally-qualified and unqualified cover all cases where an
+# element of the RGI set is missing one or more emoji presentation selectors.
+# • The file is in CLDR order, not codepoint order. This is recommended (but not required!) for keyboard palettes.
+# • The groups and subgroups are illustrative. See the Emoji Order chart for more information.
+
+
+# group: Smileys & Emotion
+
+# subgroup: face-smiling
+1F600 ; fully-qualified # 😀 E1.0 grinning face
+1F603 ; fully-qualified # 😃 E0.6 grinning face with big eyes
+1F604 ; fully-qualified # 😄 E0.6 grinning face with smiling eyes
+1F601 ; fully-qualified # 😁 E0.6 beaming face with smiling eyes
+1F606 ; fully-qualified # 😆 E0.6 grinning squinting face
+1F605 ; fully-qualified # 😅 E0.6 grinning face with sweat
+1F923 ; fully-qualified # 🤣 E3.0 rolling on the floor laughing
+1F602 ; fully-qualified # 😂 E0.6 face with tears of joy
+1F642 ; fully-qualified # 🙂 E1.0 slightly smiling face
+1F643 ; fully-qualified # 🙃 E1.0 upside-down face
+1FAE0 ; fully-qualified # 🫠 E14.0 melting face
+1F609 ; fully-qualified # 😉 E0.6 winking face
+1F60A ; fully-qualified # 😊 E0.6 smiling face with smiling eyes
+1F607 ; fully-qualified # 😇 E1.0 smiling face with halo
+
+# subgroup: face-affection
+1F970 ; fully-qualified # 🥰 E11.0 smiling face with hearts
+1F60D ; fully-qualified # 😍 E0.6 smiling face with heart-eyes
+1F929 ; fully-qualified # 🤩 E5.0 star-struck
+1F618 ; fully-qualified # 😘 E0.6 face blowing a kiss
+1F617 ; fully-qualified # 😗 E1.0 kissing face
+263A FE0F ; fully-qualified # ☺️ E0.6 smiling face
+263A ; unqualified # ☺ E0.6 smiling face
+1F61A ; fully-qualified # 😚 E0.6 kissing face with closed eyes
+1F619 ; fully-qualified # 😙 E1.0 kissing face with smiling eyes
+1F972 ; fully-qualified # 🥲 E13.0 smiling face with tear
+
+# subgroup: face-tongue
+1F60B ; fully-qualified # 😋 E0.6 face savoring food
+1F61B ; fully-qualified # 😛 E1.0 face with tongue
+1F61C ; fully-qualified # 😜 E0.6 winking face with tongue
+1F92A ; fully-qualified # 🤪 E5.0 zany face
+1F61D ; fully-qualified # 😝 E0.6 squinting face with tongue
+1F911 ; fully-qualified # 🤑 E1.0 money-mouth face
+
+# subgroup: face-hand
+1F917 ; fully-qualified # 🤗 E1.0 smiling face with open hands
+1F92D ; fully-qualified # 🤭 E5.0 face with hand over mouth
+1FAE2 ; fully-qualified # 🫢 E14.0 face with open eyes and hand over mouth
+1FAE3 ; fully-qualified # 🫣 E14.0 face with peeking eye
+1F92B ; fully-qualified # 🤫 E5.0 shushing face
+1F914 ; fully-qualified # 🤔 E1.0 thinking face
+1FAE1 ; fully-qualified # 🫡 E14.0 saluting face
+
+# subgroup: face-neutral-skeptical
+1F910 ; fully-qualified # 🤐 E1.0 zipper-mouth face
+1F928 ; fully-qualified # 🤨 E5.0 face with raised eyebrow
+1F610 ; fully-qualified # 😐 E0.7 neutral face
+1F611 ; fully-qualified # 😑 E1.0 expressionless face
+1F636 ; fully-qualified # 😶 E1.0 face without mouth
+1FAE5 ; fully-qualified # 🫥 E14.0 dotted line face
+1F636 200D 1F32B FE0F ; fully-qualified # 😶‍🌫️ E13.1 face in clouds
+1F636 200D 1F32B ; minimally-qualified # 😶‍🌫 E13.1 face in clouds
+1F60F ; fully-qualified # 😏 E0.6 smirking face
+1F612 ; fully-qualified # 😒 E0.6 unamused face
+1F644 ; fully-qualified # 🙄 E1.0 face with rolling eyes
+1F62C ; fully-qualified # 😬 E1.0 grimacing face
+1F62E 200D 1F4A8 ; fully-qualified # 😮‍💨 E13.1 face exhaling
+1F925 ; fully-qualified # 🤥 E3.0 lying face
+
+# subgroup: face-sleepy
+1F60C ; fully-qualified # 😌 E0.6 relieved face
+1F614 ; fully-qualified # 😔 E0.6 pensive face
+1F62A ; fully-qualified # 😪 E0.6 sleepy face
+1F924 ; fully-qualified # 🤤 E3.0 drooling face
+1F634 ; fully-qualified # 😴 E1.0 sleeping face
+
+# subgroup: face-unwell
+1F637 ; fully-qualified # 😷 E0.6 face with medical mask
+1F912 ; fully-qualified # 🤒 E1.0 face with thermometer
+1F915 ; fully-qualified # 🤕 E1.0 face with head-bandage
+1F922 ; fully-qualified # 🤢 E3.0 nauseated face
+1F92E ; fully-qualified # 🤮 E5.0 face vomiting
+1F927 ; fully-qualified # 🤧 E3.0 sneezing face
+1F975 ; fully-qualified # 🥵 E11.0 hot face
+1F976 ; fully-qualified # 🥶 E11.0 cold face
+1F974 ; fully-qualified # 🥴 E11.0 woozy face
+1F635 ; fully-qualified # 😵 E0.6 face with crossed-out eyes
+1F635 200D 1F4AB ; fully-qualified # 😵‍💫 E13.1 face with spiral eyes
+1F92F ; fully-qualified # 🤯 E5.0 exploding head
+
+# subgroup: face-hat
+1F920 ; fully-qualified # 🤠 E3.0 cowboy hat face
+1F973 ; fully-qualified # 🥳 E11.0 partying face
+1F978 ; fully-qualified # 🥸 E13.0 disguised face
+
+# subgroup: face-glasses
+1F60E ; fully-qualified # 😎 E1.0 smiling face with sunglasses
+1F913 ; fully-qualified # 🤓 E1.0 nerd face
+1F9D0 ; fully-qualified # 🧐 E5.0 face with monocle
+
+# subgroup: face-concerned
+1F615 ; fully-qualified # 😕 E1.0 confused face
+1FAE4 ; fully-qualified # 🫤 E14.0 face with diagonal mouth
+1F61F ; fully-qualified # 😟 E1.0 worried face
+1F641 ; fully-qualified # 🙁 E1.0 slightly frowning face
+2639 FE0F ; fully-qualified # ☹️ E0.7 frowning face
+2639 ; unqualified # ☹ E0.7 frowning face
+1F62E ; fully-qualified # 😮 E1.0 face with open mouth
+1F62F ; fully-qualified # 😯 E1.0 hushed face
+1F632 ; fully-qualified # 😲 E0.6 astonished face
+1F633 ; fully-qualified # 😳 E0.6 flushed face
+1F97A ; fully-qualified # 🥺 E11.0 pleading face
+1F979 ; fully-qualified # 🥹 E14.0 face holding back tears
+1F626 ; fully-qualified # 😦 E1.0 frowning face with open mouth
+1F627 ; fully-qualified # 😧 E1.0 anguished face
+1F628 ; fully-qualified # 😨 E0.6 fearful face
+1F630 ; fully-qualified # 😰 E0.6 anxious face with sweat
+1F625 ; fully-qualified # 😥 E0.6 sad but relieved face
+1F622 ; fully-qualified # 😢 E0.6 crying face
+1F62D ; fully-qualified # 😭 E0.6 loudly crying face
+1F631 ; fully-qualified # 😱 E0.6 face screaming in fear
+1F616 ; fully-qualified # 😖 E0.6 confounded face
+1F623 ; fully-qualified # 😣 E0.6 persevering face
+1F61E ; fully-qualified # 😞 E0.6 disappointed face
+1F613 ; fully-qualified # 😓 E0.6 downcast face with sweat
+1F629 ; fully-qualified # 😩 E0.6 weary face
+1F62B ; fully-qualified # 😫 E0.6 tired face
+1F971 ; fully-qualified # 🥱 E12.0 yawning face
+
+# subgroup: face-negative
+1F624 ; fully-qualified # 😤 E0.6 face with steam from nose
+1F621 ; fully-qualified # 😡 E0.6 pouting face
+1F620 ; fully-qualified # 😠 E0.6 angry face
+1F92C ; fully-qualified # 🤬 E5.0 face with symbols on mouth
+1F608 ; fully-qualified # 😈 E1.0 smiling face with horns
+1F47F ; fully-qualified # 👿 E0.6 angry face with horns
+1F480 ; fully-qualified # 💀 E0.6 skull
+2620 FE0F ; fully-qualified # ☠️ E1.0 skull and crossbones
+2620 ; unqualified # ☠ E1.0 skull and crossbones
+
+# subgroup: face-costume
+1F4A9 ; fully-qualified # 💩 E0.6 pile of poo
+1F921 ; fully-qualified # 🤡 E3.0 clown face
+1F479 ; fully-qualified # 👹 E0.6 ogre
+1F47A ; fully-qualified # 👺 E0.6 goblin
+1F47B ; fully-qualified # 👻 E0.6 ghost
+1F47D ; fully-qualified # 👽 E0.6 alien
+1F47E ; fully-qualified # 👾 E0.6 alien monster
+1F916 ; fully-qualified # 🤖 E1.0 robot
+
+# subgroup: cat-face
+1F63A ; fully-qualified # 😺 E0.6 grinning cat
+1F638 ; fully-qualified # 😸 E0.6 grinning cat with smiling eyes
+1F639 ; fully-qualified # 😹 E0.6 cat with tears of joy
+1F63B ; fully-qualified # 😻 E0.6 smiling cat with heart-eyes
+1F63C ; fully-qualified # 😼 E0.6 cat with wry smile
+1F63D ; fully-qualified # 😽 E0.6 kissing cat
+1F640 ; fully-qualified # 🙀 E0.6 weary cat
+1F63F ; fully-qualified # 😿 E0.6 crying cat
+1F63E ; fully-qualified # 😾 E0.6 pouting cat
+
+# subgroup: monkey-face
+1F648 ; fully-qualified # 🙈 E0.6 see-no-evil monkey
+1F649 ; fully-qualified # 🙉 E0.6 hear-no-evil monkey
+1F64A ; fully-qualified # 🙊 E0.6 speak-no-evil monkey
+
+# subgroup: emotion
+1F48B ; fully-qualified # 💋 E0.6 kiss mark
+1F48C ; fully-qualified # 💌 E0.6 love letter
+1F498 ; fully-qualified # 💘 E0.6 heart with arrow
+1F49D ; fully-qualified # 💝 E0.6 heart with ribbon
+1F496 ; fully-qualified # 💖 E0.6 sparkling heart
+1F497 ; fully-qualified # 💗 E0.6 growing heart
+1F493 ; fully-qualified # 💓 E0.6 beating heart
+1F49E ; fully-qualified # 💞 E0.6 revolving hearts
+1F495 ; fully-qualified # 💕 E0.6 two hearts
+1F49F ; fully-qualified # 💟 E0.6 heart decoration
+2763 FE0F ; fully-qualified # ❣️ E1.0 heart exclamation
+2763 ; unqualified # ❣ E1.0 heart exclamation
+1F494 ; fully-qualified # 💔 E0.6 broken heart
+2764 FE0F 200D 1F525 ; fully-qualified # ❤️‍🔥 E13.1 heart on fire
+2764 200D 1F525 ; unqualified # ❤‍🔥 E13.1 heart on fire
+2764 FE0F 200D 1FA79 ; fully-qualified # ❤️‍🩹 E13.1 mending heart
+2764 200D 1FA79 ; unqualified # ❤‍🩹 E13.1 mending heart
+2764 FE0F ; fully-qualified # ❤️ E0.6 red heart
+2764 ; unqualified # ❤ E0.6 red heart
+1F9E1 ; fully-qualified # 🧡 E5.0 orange heart
+1F49B ; fully-qualified # 💛 E0.6 yellow heart
+1F49A ; fully-qualified # 💚 E0.6 green heart
+1F499 ; fully-qualified # 💙 E0.6 blue heart
+1F49C ; fully-qualified # 💜 E0.6 purple heart
+1F90E ; fully-qualified # 🤎 E12.0 brown heart
+1F5A4 ; fully-qualified # 🖤 E3.0 black heart
+1F90D ; fully-qualified # 🤍 E12.0 white heart
+1F4AF ; fully-qualified # 💯 E0.6 hundred points
+1F4A2 ; fully-qualified # 💢 E0.6 anger symbol
+1F4A5 ; fully-qualified # 💥 E0.6 collision
+1F4AB ; fully-qualified # 💫 E0.6 dizzy
+1F4A6 ; fully-qualified # 💦 E0.6 sweat droplets
+1F4A8 ; fully-qualified # 💨 E0.6 dashing away
+1F573 FE0F ; fully-qualified # 🕳️ E0.7 hole
+1F573 ; unqualified # 🕳 E0.7 hole
+1F4A3 ; fully-qualified # 💣 E0.6 bomb
+1F4AC ; fully-qualified # 💬 E0.6 speech balloon
+1F441 FE0F 200D 1F5E8 FE0F ; fully-qualified # 👁️‍🗨️ E2.0 eye in speech bubble
+1F441 200D 1F5E8 FE0F ; unqualified # 👁‍🗨️ E2.0 eye in speech bubble
+1F441 FE0F 200D 1F5E8 ; unqualified # 👁️‍🗨 E2.0 eye in speech bubble
+1F441 200D 1F5E8 ; unqualified # 👁‍🗨 E2.0 eye in speech bubble
+1F5E8 FE0F ; fully-qualified # 🗨️ E2.0 left speech bubble
+1F5E8 ; unqualified # 🗨 E2.0 left speech bubble
+1F5EF FE0F ; fully-qualified # 🗯️ E0.7 right anger bubble
+1F5EF ; unqualified # 🗯 E0.7 right anger bubble
+1F4AD ; fully-qualified # 💭 E1.0 thought balloon
+1F4A4 ; fully-qualified # 💤 E0.6 zzz
+
+# Smileys & Emotion subtotal: 177
+# Smileys & Emotion subtotal: 177 w/o modifiers
+
+# group: People & Body
+
+# subgroup: hand-fingers-open
+1F44B ; fully-qualified # 👋 E0.6 waving hand
+1F44B 1F3FB ; fully-qualified # 👋🏻 E1.0 waving hand: light skin tone
+1F44B 1F3FC ; fully-qualified # 👋🏼 E1.0 waving hand: medium-light skin tone
+1F44B 1F3FD ; fully-qualified # 👋🏽 E1.0 waving hand: medium skin tone
+1F44B 1F3FE ; fully-qualified # 👋🏾 E1.0 waving hand: medium-dark skin tone
+1F44B 1F3FF ; fully-qualified # 👋🏿 E1.0 waving hand: dark skin tone
+1F91A ; fully-qualified # 🤚 E3.0 raised back of hand
+1F91A 1F3FB ; fully-qualified # 🤚🏻 E3.0 raised back of hand: light skin tone
+1F91A 1F3FC ; fully-qualified # 🤚🏼 E3.0 raised back of hand: medium-light skin tone
+1F91A 1F3FD ; fully-qualified # 🤚🏽 E3.0 raised back of hand: medium skin tone
+1F91A 1F3FE ; fully-qualified # 🤚🏾 E3.0 raised back of hand: medium-dark skin tone
+1F91A 1F3FF ; fully-qualified # 🤚🏿 E3.0 raised back of hand: dark skin tone
+1F590 FE0F ; fully-qualified # 🖐️ E0.7 hand with fingers splayed
+1F590 ; unqualified # 🖐 E0.7 hand with fingers splayed
+1F590 1F3FB ; fully-qualified # 🖐🏻 E1.0 hand with fingers splayed: light skin tone
+1F590 1F3FC ; fully-qualified # 🖐🏼 E1.0 hand with fingers splayed: medium-light skin tone
+1F590 1F3FD ; fully-qualified # 🖐🏽 E1.0 hand with fingers splayed: medium skin tone
+1F590 1F3FE ; fully-qualified # 🖐🏾 E1.0 hand with fingers splayed: medium-dark skin tone
+1F590 1F3FF ; fully-qualified # 🖐🏿 E1.0 hand with fingers splayed: dark skin tone
+270B ; fully-qualified # ✋ E0.6 raised hand
+270B 1F3FB ; fully-qualified # ✋🏻 E1.0 raised hand: light skin tone
+270B 1F3FC ; fully-qualified # ✋🏼 E1.0 raised hand: medium-light skin tone
+270B 1F3FD ; fully-qualified # ✋🏽 E1.0 raised hand: medium skin tone
+270B 1F3FE ; fully-qualified # ✋🏾 E1.0 raised hand: medium-dark skin tone
+270B 1F3FF ; fully-qualified # ✋🏿 E1.0 raised hand: dark skin tone
+1F596 ; fully-qualified # 🖖 E1.0 vulcan salute
+1F596 1F3FB ; fully-qualified # 🖖🏻 E1.0 vulcan salute: light skin tone
+1F596 1F3FC ; fully-qualified # 🖖🏼 E1.0 vulcan salute: medium-light skin tone
+1F596 1F3FD ; fully-qualified # 🖖🏽 E1.0 vulcan salute: medium skin tone
+1F596 1F3FE ; fully-qualified # 🖖🏾 E1.0 vulcan salute: medium-dark skin tone
+1F596 1F3FF ; fully-qualified # 🖖🏿 E1.0 vulcan salute: dark skin tone
+1FAF1 ; fully-qualified # 🫱 E14.0 rightwards hand
+1FAF1 1F3FB ; fully-qualified # 🫱🏻 E14.0 rightwards hand: light skin tone
+1FAF1 1F3FC ; fully-qualified # 🫱🏼 E14.0 rightwards hand: medium-light skin tone
+1FAF1 1F3FD ; fully-qualified # 🫱🏽 E14.0 rightwards hand: medium skin tone
+1FAF1 1F3FE ; fully-qualified # 🫱🏾 E14.0 rightwards hand: medium-dark skin tone
+1FAF1 1F3FF ; fully-qualified # 🫱🏿 E14.0 rightwards hand: dark skin tone
+1FAF2 ; fully-qualified # 🫲 E14.0 leftwards hand
+1FAF2 1F3FB ; fully-qualified # 🫲🏻 E14.0 leftwards hand: light skin tone
+1FAF2 1F3FC ; fully-qualified # 🫲🏼 E14.0 leftwards hand: medium-light skin tone
+1FAF2 1F3FD ; fully-qualified # 🫲🏽 E14.0 leftwards hand: medium skin tone
+1FAF2 1F3FE ; fully-qualified # 🫲🏾 E14.0 leftwards hand: medium-dark skin tone
+1FAF2 1F3FF ; fully-qualified # 🫲🏿 E14.0 leftwards hand: dark skin tone
+1FAF3 ; fully-qualified # 🫳 E14.0 palm down hand
+1FAF3 1F3FB ; fully-qualified # 🫳🏻 E14.0 palm down hand: light skin tone
+1FAF3 1F3FC ; fully-qualified # 🫳🏼 E14.0 palm down hand: medium-light skin tone
+1FAF3 1F3FD ; fully-qualified # 🫳🏽 E14.0 palm down hand: medium skin tone
+1FAF3 1F3FE ; fully-qualified # 🫳🏾 E14.0 palm down hand: medium-dark skin tone
+1FAF3 1F3FF ; fully-qualified # 🫳🏿 E14.0 palm down hand: dark skin tone
+1FAF4 ; fully-qualified # 🫴 E14.0 palm up hand
+1FAF4 1F3FB ; fully-qualified # 🫴🏻 E14.0 palm up hand: light skin tone
+1FAF4 1F3FC ; fully-qualified # 🫴🏼 E14.0 palm up hand: medium-light skin tone
+1FAF4 1F3FD ; fully-qualified # 🫴🏽 E14.0 palm up hand: medium skin tone
+1FAF4 1F3FE ; fully-qualified # 🫴🏾 E14.0 palm up hand: medium-dark skin tone
+1FAF4 1F3FF ; fully-qualified # 🫴🏿 E14.0 palm up hand: dark skin tone
+
+# subgroup: hand-fingers-partial
+1F44C ; fully-qualified # 👌 E0.6 OK hand
+1F44C 1F3FB ; fully-qualified # 👌🏻 E1.0 OK hand: light skin tone
+1F44C 1F3FC ; fully-qualified # 👌🏼 E1.0 OK hand: medium-light skin tone
+1F44C 1F3FD ; fully-qualified # 👌🏽 E1.0 OK hand: medium skin tone
+1F44C 1F3FE ; fully-qualified # 👌🏾 E1.0 OK hand: medium-dark skin tone
+1F44C 1F3FF ; fully-qualified # 👌🏿 E1.0 OK hand: dark skin tone
+1F90C ; fully-qualified # 🤌 E13.0 pinched fingers
+1F90C 1F3FB ; fully-qualified # 🤌🏻 E13.0 pinched fingers: light skin tone
+1F90C 1F3FC ; fully-qualified # 🤌🏼 E13.0 pinched fingers: medium-light skin tone
+1F90C 1F3FD ; fully-qualified # 🤌🏽 E13.0 pinched fingers: medium skin tone
+1F90C 1F3FE ; fully-qualified # 🤌🏾 E13.0 pinched fingers: medium-dark skin tone
+1F90C 1F3FF ; fully-qualified # 🤌🏿 E13.0 pinched fingers: dark skin tone
+1F90F ; fully-qualified # 🤏 E12.0 pinching hand
+1F90F 1F3FB ; fully-qualified # 🤏🏻 E12.0 pinching hand: light skin tone
+1F90F 1F3FC ; fully-qualified # 🤏🏼 E12.0 pinching hand: medium-light skin tone
+1F90F 1F3FD ; fully-qualified # 🤏🏽 E12.0 pinching hand: medium skin tone
+1F90F 1F3FE ; fully-qualified # 🤏🏾 E12.0 pinching hand: medium-dark skin tone
+1F90F 1F3FF ; fully-qualified # 🤏🏿 E12.0 pinching hand: dark skin tone
+270C FE0F ; fully-qualified # ✌️ E0.6 victory hand
+270C ; unqualified # ✌ E0.6 victory hand
+270C 1F3FB ; fully-qualified # ✌🏻 E1.0 victory hand: light skin tone
+270C 1F3FC ; fully-qualified # ✌🏼 E1.0 victory hand: medium-light skin tone
+270C 1F3FD ; fully-qualified # ✌🏽 E1.0 victory hand: medium skin tone
+270C 1F3FE ; fully-qualified # ✌🏾 E1.0 victory hand: medium-dark skin tone
+270C 1F3FF ; fully-qualified # ✌🏿 E1.0 victory hand: dark skin tone
+1F91E ; fully-qualified # 🤞 E3.0 crossed fingers
+1F91E 1F3FB ; fully-qualified # 🤞🏻 E3.0 crossed fingers: light skin tone
+1F91E 1F3FC ; fully-qualified # 🤞🏼 E3.0 crossed fingers: medium-light skin tone
+1F91E 1F3FD ; fully-qualified # 🤞🏽 E3.0 crossed fingers: medium skin tone
+1F91E 1F3FE ; fully-qualified # 🤞🏾 E3.0 crossed fingers: medium-dark skin tone
+1F91E 1F3FF ; fully-qualified # 🤞🏿 E3.0 crossed fingers: dark skin tone
+1FAF0 ; fully-qualified # 🫰 E14.0 hand with index finger and thumb crossed
+1FAF0 1F3FB ; fully-qualified # 🫰🏻 E14.0 hand with index finger and thumb crossed: light skin tone
+1FAF0 1F3FC ; fully-qualified # 🫰🏼 E14.0 hand with index finger and thumb crossed: medium-light skin tone
+1FAF0 1F3FD ; fully-qualified # 🫰🏽 E14.0 hand with index finger and thumb crossed: medium skin tone
+1FAF0 1F3FE ; fully-qualified # 🫰🏾 E14.0 hand with index finger and thumb crossed: medium-dark skin tone
+1FAF0 1F3FF ; fully-qualified # 🫰🏿 E14.0 hand with index finger and thumb crossed: dark skin tone
+1F91F ; fully-qualified # 🤟 E5.0 love-you gesture
+1F91F 1F3FB ; fully-qualified # 🤟🏻 E5.0 love-you gesture: light skin tone
+1F91F 1F3FC ; fully-qualified # 🤟🏼 E5.0 love-you gesture: medium-light skin tone
+1F91F 1F3FD ; fully-qualified # 🤟🏽 E5.0 love-you gesture: medium skin tone
+1F91F 1F3FE ; fully-qualified # 🤟🏾 E5.0 love-you gesture: medium-dark skin tone
+1F91F 1F3FF ; fully-qualified # 🤟🏿 E5.0 love-you gesture: dark skin tone
+1F918 ; fully-qualified # 🤘 E1.0 sign of the horns
+1F918 1F3FB ; fully-qualified # 🤘🏻 E1.0 sign of the horns: light skin tone
+1F918 1F3FC ; fully-qualified # 🤘🏼 E1.0 sign of the horns: medium-light skin tone
+1F918 1F3FD ; fully-qualified # 🤘🏽 E1.0 sign of the horns: medium skin tone
+1F918 1F3FE ; fully-qualified # 🤘🏾 E1.0 sign of the horns: medium-dark skin tone
+1F918 1F3FF ; fully-qualified # 🤘🏿 E1.0 sign of the horns: dark skin tone
+1F919 ; fully-qualified # 🤙 E3.0 call me hand
+1F919 1F3FB ; fully-qualified # 🤙🏻 E3.0 call me hand: light skin tone
+1F919 1F3FC ; fully-qualified # 🤙🏼 E3.0 call me hand: medium-light skin tone
+1F919 1F3FD ; fully-qualified # 🤙🏽 E3.0 call me hand: medium skin tone
+1F919 1F3FE ; fully-qualified # 🤙🏾 E3.0 call me hand: medium-dark skin tone
+1F919 1F3FF ; fully-qualified # 🤙🏿 E3.0 call me hand: dark skin tone
+
+# subgroup: hand-single-finger
+1F448 ; fully-qualified # 👈 E0.6 backhand index pointing left
+1F448 1F3FB ; fully-qualified # 👈🏻 E1.0 backhand index pointing left: light skin tone
+1F448 1F3FC ; fully-qualified # 👈🏼 E1.0 backhand index pointing left: medium-light skin tone
+1F448 1F3FD ; fully-qualified # 👈🏽 E1.0 backhand index pointing left: medium skin tone
+1F448 1F3FE ; fully-qualified # 👈🏾 E1.0 backhand index pointing left: medium-dark skin tone
+1F448 1F3FF ; fully-qualified # 👈🏿 E1.0 backhand index pointing left: dark skin tone
+1F449 ; fully-qualified # 👉 E0.6 backhand index pointing right
+1F449 1F3FB ; fully-qualified # 👉🏻 E1.0 backhand index pointing right: light skin tone
+1F449 1F3FC ; fully-qualified # 👉🏼 E1.0 backhand index pointing right: medium-light skin tone
+1F449 1F3FD ; fully-qualified # 👉🏽 E1.0 backhand index pointing right: medium skin tone
+1F449 1F3FE ; fully-qualified # 👉🏾 E1.0 backhand index pointing right: medium-dark skin tone
+1F449 1F3FF ; fully-qualified # 👉🏿 E1.0 backhand index pointing right: dark skin tone
+1F446 ; fully-qualified # 👆 E0.6 backhand index pointing up
+1F446 1F3FB ; fully-qualified # 👆🏻 E1.0 backhand index pointing up: light skin tone
+1F446 1F3FC ; fully-qualified # 👆🏼 E1.0 backhand index pointing up: medium-light skin tone
+1F446 1F3FD ; fully-qualified # 👆🏽 E1.0 backhand index pointing up: medium skin tone
+1F446 1F3FE ; fully-qualified # 👆🏾 E1.0 backhand index pointing up: medium-dark skin tone
+1F446 1F3FF ; fully-qualified # 👆🏿 E1.0 backhand index pointing up: dark skin tone
+1F595 ; fully-qualified # 🖕 E1.0 middle finger
+1F595 1F3FB ; fully-qualified # 🖕🏻 E1.0 middle finger: light skin tone
+1F595 1F3FC ; fully-qualified # 🖕🏼 E1.0 middle finger: medium-light skin tone
+1F595 1F3FD ; fully-qualified # 🖕🏽 E1.0 middle finger: medium skin tone
+1F595 1F3FE ; fully-qualified # 🖕🏾 E1.0 middle finger: medium-dark skin tone
+1F595 1F3FF ; fully-qualified # 🖕🏿 E1.0 middle finger: dark skin tone
+1F447 ; fully-qualified # 👇 E0.6 backhand index pointing down
+1F447 1F3FB ; fully-qualified # 👇🏻 E1.0 backhand index pointing down: light skin tone
+1F447 1F3FC ; fully-qualified # 👇🏼 E1.0 backhand index pointing down: medium-light skin tone
+1F447 1F3FD ; fully-qualified # 👇🏽 E1.0 backhand index pointing down: medium skin tone
+1F447 1F3FE ; fully-qualified # 👇🏾 E1.0 backhand index pointing down: medium-dark skin tone
+1F447 1F3FF ; fully-qualified # 👇🏿 E1.0 backhand index pointing down: dark skin tone
+261D FE0F ; fully-qualified # ☝️ E0.6 index pointing up
+261D ; unqualified # ☝ E0.6 index pointing up
+261D 1F3FB ; fully-qualified # ☝🏻 E1.0 index pointing up: light skin tone
+261D 1F3FC ; fully-qualified # ☝🏼 E1.0 index pointing up: medium-light skin tone
+261D 1F3FD ; fully-qualified # ☝🏽 E1.0 index pointing up: medium skin tone
+261D 1F3FE ; fully-qualified # ☝🏾 E1.0 index pointing up: medium-dark skin tone
+261D 1F3FF ; fully-qualified # ☝🏿 E1.0 index pointing up: dark skin tone
+1FAF5 ; fully-qualified # 🫵 E14.0 index pointing at the viewer
+1FAF5 1F3FB ; fully-qualified # 🫵🏻 E14.0 index pointing at the viewer: light skin tone
+1FAF5 1F3FC ; fully-qualified # 🫵🏼 E14.0 index pointing at the viewer: medium-light skin tone
+1FAF5 1F3FD ; fully-qualified # 🫵🏽 E14.0 index pointing at the viewer: medium skin tone
+1FAF5 1F3FE ; fully-qualified # 🫵🏾 E14.0 index pointing at the viewer: medium-dark skin tone
+1FAF5 1F3FF ; fully-qualified # 🫵🏿 E14.0 index pointing at the viewer: dark skin tone
+
+# subgroup: hand-fingers-closed
+1F44D ; fully-qualified # 👍 E0.6 thumbs up
+1F44D 1F3FB ; fully-qualified # 👍🏻 E1.0 thumbs up: light skin tone
+1F44D 1F3FC ; fully-qualified # 👍🏼 E1.0 thumbs up: medium-light skin tone
+1F44D 1F3FD ; fully-qualified # 👍🏽 E1.0 thumbs up: medium skin tone
+1F44D 1F3FE ; fully-qualified # 👍🏾 E1.0 thumbs up: medium-dark skin tone
+1F44D 1F3FF ; fully-qualified # 👍🏿 E1.0 thumbs up: dark skin tone
+1F44E ; fully-qualified # 👎 E0.6 thumbs down
+1F44E 1F3FB ; fully-qualified # 👎🏻 E1.0 thumbs down: light skin tone
+1F44E 1F3FC ; fully-qualified # 👎🏼 E1.0 thumbs down: medium-light skin tone
+1F44E 1F3FD ; fully-qualified # 👎🏽 E1.0 thumbs down: medium skin tone
+1F44E 1F3FE ; fully-qualified # 👎🏾 E1.0 thumbs down: medium-dark skin tone
+1F44E 1F3FF ; fully-qualified # 👎🏿 E1.0 thumbs down: dark skin tone
+270A ; fully-qualified # ✊ E0.6 raised fist
+270A 1F3FB ; fully-qualified # ✊🏻 E1.0 raised fist: light skin tone
+270A 1F3FC ; fully-qualified # ✊🏼 E1.0 raised fist: medium-light skin tone
+270A 1F3FD ; fully-qualified # ✊🏽 E1.0 raised fist: medium skin tone
+270A 1F3FE ; fully-qualified # ✊🏾 E1.0 raised fist: medium-dark skin tone
+270A 1F3FF ; fully-qualified # ✊🏿 E1.0 raised fist: dark skin tone
+1F44A ; fully-qualified # 👊 E0.6 oncoming fist
+1F44A 1F3FB ; fully-qualified # 👊🏻 E1.0 oncoming fist: light skin tone
+1F44A 1F3FC ; fully-qualified # 👊🏼 E1.0 oncoming fist: medium-light skin tone
+1F44A 1F3FD ; fully-qualified # 👊🏽 E1.0 oncoming fist: medium skin tone
+1F44A 1F3FE ; fully-qualified # 👊🏾 E1.0 oncoming fist: medium-dark skin tone
+1F44A 1F3FF ; fully-qualified # 👊🏿 E1.0 oncoming fist: dark skin tone
+1F91B ; fully-qualified # 🤛 E3.0 left-facing fist
+1F91B 1F3FB ; fully-qualified # 🤛🏻 E3.0 left-facing fist: light skin tone
+1F91B 1F3FC ; fully-qualified # 🤛🏼 E3.0 left-facing fist: medium-light skin tone
+1F91B 1F3FD ; fully-qualified # 🤛🏽 E3.0 left-facing fist: medium skin tone
+1F91B 1F3FE ; fully-qualified # 🤛🏾 E3.0 left-facing fist: medium-dark skin tone
+1F91B 1F3FF ; fully-qualified # 🤛🏿 E3.0 left-facing fist: dark skin tone
+1F91C ; fully-qualified # 🤜 E3.0 right-facing fist
+1F91C 1F3FB ; fully-qualified # 🤜🏻 E3.0 right-facing fist: light skin tone
+1F91C 1F3FC ; fully-qualified # 🤜🏼 E3.0 right-facing fist: medium-light skin tone
+1F91C 1F3FD ; fully-qualified # 🤜🏽 E3.0 right-facing fist: medium skin tone
+1F91C 1F3FE ; fully-qualified # 🤜🏾 E3.0 right-facing fist: medium-dark skin tone
+1F91C 1F3FF ; fully-qualified # 🤜🏿 E3.0 right-facing fist: dark skin tone
+
+# subgroup: hands
+1F44F ; fully-qualified # 👏 E0.6 clapping hands
+1F44F 1F3FB ; fully-qualified # 👏🏻 E1.0 clapping hands: light skin tone
+1F44F 1F3FC ; fully-qualified # 👏🏼 E1.0 clapping hands: medium-light skin tone
+1F44F 1F3FD ; fully-qualified # 👏🏽 E1.0 clapping hands: medium skin tone
+1F44F 1F3FE ; fully-qualified # 👏🏾 E1.0 clapping hands: medium-dark skin tone
+1F44F 1F3FF ; fully-qualified # 👏🏿 E1.0 clapping hands: dark skin tone
+1F64C ; fully-qualified # 🙌 E0.6 raising hands
+1F64C 1F3FB ; fully-qualified # 🙌🏻 E1.0 raising hands: light skin tone
+1F64C 1F3FC ; fully-qualified # 🙌🏼 E1.0 raising hands: medium-light skin tone
+1F64C 1F3FD ; fully-qualified # 🙌🏽 E1.0 raising hands: medium skin tone
+1F64C 1F3FE ; fully-qualified # 🙌🏾 E1.0 raising hands: medium-dark skin tone
+1F64C 1F3FF ; fully-qualified # 🙌🏿 E1.0 raising hands: dark skin tone
+1FAF6 ; fully-qualified # 🫶 E14.0 heart hands
+1FAF6 1F3FB ; fully-qualified # 🫶🏻 E14.0 heart hands: light skin tone
+1FAF6 1F3FC ; fully-qualified # 🫶🏼 E14.0 heart hands: medium-light skin tone
+1FAF6 1F3FD ; fully-qualified # 🫶🏽 E14.0 heart hands: medium skin tone
+1FAF6 1F3FE ; fully-qualified # 🫶🏾 E14.0 heart hands: medium-dark skin tone
+1FAF6 1F3FF ; fully-qualified # 🫶🏿 E14.0 heart hands: dark skin tone
+1F450 ; fully-qualified # 👐 E0.6 open hands
+1F450 1F3FB ; fully-qualified # 👐🏻 E1.0 open hands: light skin tone
+1F450 1F3FC ; fully-qualified # 👐🏼 E1.0 open hands: medium-light skin tone
+1F450 1F3FD ; fully-qualified # 👐🏽 E1.0 open hands: medium skin tone
+1F450 1F3FE ; fully-qualified # 👐🏾 E1.0 open hands: medium-dark skin tone
+1F450 1F3FF ; fully-qualified # 👐🏿 E1.0 open hands: dark skin tone
+1F932 ; fully-qualified # 🤲 E5.0 palms up together
+1F932 1F3FB ; fully-qualified # 🤲🏻 E5.0 palms up together: light skin tone
+1F932 1F3FC ; fully-qualified # 🤲🏼 E5.0 palms up together: medium-light skin tone
+1F932 1F3FD ; fully-qualified # 🤲🏽 E5.0 palms up together: medium skin tone
+1F932 1F3FE ; fully-qualified # 🤲🏾 E5.0 palms up together: medium-dark skin tone
+1F932 1F3FF ; fully-qualified # 🤲🏿 E5.0 palms up together: dark skin tone
+1F91D ; fully-qualified # 🤝 E3.0 handshake
+1F91D 1F3FB ; fully-qualified # 🤝🏻 E3.0 handshake: light skin tone
+1F91D 1F3FC ; fully-qualified # 🤝🏼 E3.0 handshake: medium-light skin tone
+1F91D 1F3FD ; fully-qualified # 🤝🏽 E3.0 handshake: medium skin tone
+1F91D 1F3FE ; fully-qualified # 🤝🏾 E3.0 handshake: medium-dark skin tone
+1F91D 1F3FF ; fully-qualified # 🤝🏿 E3.0 handshake: dark skin tone
+1FAF1 1F3FB 200D 1FAF2 1F3FC ; fully-qualified # 🫱🏻‍🫲🏼 E14.0 handshake: light skin tone, medium-light skin tone
+1FAF1 1F3FB 200D 1FAF2 1F3FD ; fully-qualified # 🫱🏻‍🫲🏽 E14.0 handshake: light skin tone, medium skin tone
+1FAF1 1F3FB 200D 1FAF2 1F3FE ; fully-qualified # 🫱🏻‍🫲🏾 E14.0 handshake: light skin tone, medium-dark skin tone
+1FAF1 1F3FB 200D 1FAF2 1F3FF ; fully-qualified # 🫱🏻‍🫲🏿 E14.0 handshake: light skin tone, dark skin tone
+1FAF1 1F3FC 200D 1FAF2 1F3FB ; fully-qualified # 🫱🏼‍🫲🏻 E14.0 handshake: medium-light skin tone, light skin tone
+1FAF1 1F3FC 200D 1FAF2 1F3FD ; fully-qualified # 🫱🏼‍🫲🏽 E14.0 handshake: medium-light skin tone, medium skin tone
+1FAF1 1F3FC 200D 1FAF2 1F3FE ; fully-qualified # 🫱🏼‍🫲🏾 E14.0 handshake: medium-light skin tone, medium-dark skin tone
+1FAF1 1F3FC 200D 1FAF2 1F3FF ; fully-qualified # 🫱🏼‍🫲🏿 E14.0 handshake: medium-light skin tone, dark skin tone
+1FAF1 1F3FD 200D 1FAF2 1F3FB ; fully-qualified # 🫱🏽‍🫲🏻 E14.0 handshake: medium skin tone, light skin tone
+1FAF1 1F3FD 200D 1FAF2 1F3FC ; fully-qualified # 🫱🏽‍🫲🏼 E14.0 handshake: medium skin tone, medium-light skin tone
+1FAF1 1F3FD 200D 1FAF2 1F3FE ; fully-qualified # 🫱🏽‍🫲🏾 E14.0 handshake: medium skin tone, medium-dark skin tone
+1FAF1 1F3FD 200D 1FAF2 1F3FF ; fully-qualified # 🫱🏽‍🫲🏿 E14.0 handshake: medium skin tone, dark skin tone
+1FAF1 1F3FE 200D 1FAF2 1F3FB ; fully-qualified # 🫱🏾‍🫲🏻 E14.0 handshake: medium-dark skin tone, light skin tone
+1FAF1 1F3FE 200D 1FAF2 1F3FC ; fully-qualified # 🫱🏾‍🫲🏼 E14.0 handshake: medium-dark skin tone, medium-light skin tone
+1FAF1 1F3FE 200D 1FAF2 1F3FD ; fully-qualified # 🫱🏾‍🫲🏽 E14.0 handshake: medium-dark skin tone, medium skin tone
+1FAF1 1F3FE 200D 1FAF2 1F3FF ; fully-qualified # 🫱🏾‍🫲🏿 E14.0 handshake: medium-dark skin tone, dark skin tone
+1FAF1 1F3FF 200D 1FAF2 1F3FB ; fully-qualified # 🫱🏿‍🫲🏻 E14.0 handshake: dark skin tone, light skin tone
+1FAF1 1F3FF 200D 1FAF2 1F3FC ; fully-qualified # 🫱🏿‍🫲🏼 E14.0 handshake: dark skin tone, medium-light skin tone
+1FAF1 1F3FF 200D 1FAF2 1F3FD ; fully-qualified # 🫱🏿‍🫲🏽 E14.0 handshake: dark skin tone, medium skin tone
+1FAF1 1F3FF 200D 1FAF2 1F3FE ; fully-qualified # 🫱🏿‍🫲🏾 E14.0 handshake: dark skin tone, medium-dark skin tone
+1F64F ; fully-qualified # 🙏 E0.6 folded hands
+1F64F 1F3FB ; fully-qualified # 🙏🏻 E1.0 folded hands: light skin tone
+1F64F 1F3FC ; fully-qualified # 🙏🏼 E1.0 folded hands: medium-light skin tone
+1F64F 1F3FD ; fully-qualified # 🙏🏽 E1.0 folded hands: medium skin tone
+1F64F 1F3FE ; fully-qualified # 🙏🏾 E1.0 folded hands: medium-dark skin tone
+1F64F 1F3FF ; fully-qualified # 🙏🏿 E1.0 folded hands: dark skin tone
+
+# subgroup: hand-prop
+270D FE0F ; fully-qualified # ✍️ E0.7 writing hand
+270D ; unqualified # ✍ E0.7 writing hand
+270D 1F3FB ; fully-qualified # ✍🏻 E1.0 writing hand: light skin tone
+270D 1F3FC ; fully-qualified # ✍🏼 E1.0 writing hand: medium-light skin tone
+270D 1F3FD ; fully-qualified # ✍🏽 E1.0 writing hand: medium skin tone
+270D 1F3FE ; fully-qualified # ✍🏾 E1.0 writing hand: medium-dark skin tone
+270D 1F3FF ; fully-qualified # ✍🏿 E1.0 writing hand: dark skin tone
+1F485 ; fully-qualified # 💅 E0.6 nail polish
+1F485 1F3FB ; fully-qualified # 💅🏻 E1.0 nail polish: light skin tone
+1F485 1F3FC ; fully-qualified # 💅🏼 E1.0 nail polish: medium-light skin tone
+1F485 1F3FD ; fully-qualified # 💅🏽 E1.0 nail polish: medium skin tone
+1F485 1F3FE ; fully-qualified # 💅🏾 E1.0 nail polish: medium-dark skin tone
+1F485 1F3FF ; fully-qualified # 💅🏿 E1.0 nail polish: dark skin tone
+1F933 ; fully-qualified # 🤳 E3.0 selfie
+1F933 1F3FB ; fully-qualified # 🤳🏻 E3.0 selfie: light skin tone
+1F933 1F3FC ; fully-qualified # 🤳🏼 E3.0 selfie: medium-light skin tone
+1F933 1F3FD ; fully-qualified # 🤳🏽 E3.0 selfie: medium skin tone
+1F933 1F3FE ; fully-qualified # 🤳🏾 E3.0 selfie: medium-dark skin tone
+1F933 1F3FF ; fully-qualified # 🤳🏿 E3.0 selfie: dark skin tone
+
+# subgroup: body-parts
+1F4AA ; fully-qualified # 💪 E0.6 flexed biceps
+1F4AA 1F3FB ; fully-qualified # 💪🏻 E1.0 flexed biceps: light skin tone
+1F4AA 1F3FC ; fully-qualified # 💪🏼 E1.0 flexed biceps: medium-light skin tone
+1F4AA 1F3FD ; fully-qualified # 💪🏽 E1.0 flexed biceps: medium skin tone
+1F4AA 1F3FE ; fully-qualified # 💪🏾 E1.0 flexed biceps: medium-dark skin tone
+1F4AA 1F3FF ; fully-qualified # 💪🏿 E1.0 flexed biceps: dark skin tone
+1F9BE ; fully-qualified # 🦾 E12.0 mechanical arm
+1F9BF ; fully-qualified # 🦿 E12.0 mechanical leg
+1F9B5 ; fully-qualified # 🦵 E11.0 leg
+1F9B5 1F3FB ; fully-qualified # 🦵🏻 E11.0 leg: light skin tone
+1F9B5 1F3FC ; fully-qualified # 🦵🏼 E11.0 leg: medium-light skin tone
+1F9B5 1F3FD ; fully-qualified # 🦵🏽 E11.0 leg: medium skin tone
+1F9B5 1F3FE ; fully-qualified # 🦵🏾 E11.0 leg: medium-dark skin tone
+1F9B5 1F3FF ; fully-qualified # 🦵🏿 E11.0 leg: dark skin tone
+1F9B6 ; fully-qualified # 🦶 E11.0 foot
+1F9B6 1F3FB ; fully-qualified # 🦶🏻 E11.0 foot: light skin tone
+1F9B6 1F3FC ; fully-qualified # 🦶🏼 E11.0 foot: medium-light skin tone
+1F9B6 1F3FD ; fully-qualified # 🦶🏽 E11.0 foot: medium skin tone
+1F9B6 1F3FE ; fully-qualified # 🦶🏾 E11.0 foot: medium-dark skin tone
+1F9B6 1F3FF ; fully-qualified # 🦶🏿 E11.0 foot: dark skin tone
+1F442 ; fully-qualified # 👂 E0.6 ear
+1F442 1F3FB ; fully-qualified # 👂🏻 E1.0 ear: light skin tone
+1F442 1F3FC ; fully-qualified # 👂🏼 E1.0 ear: medium-light skin tone
+1F442 1F3FD ; fully-qualified # 👂🏽 E1.0 ear: medium skin tone
+1F442 1F3FE ; fully-qualified # 👂🏾 E1.0 ear: medium-dark skin tone
+1F442 1F3FF ; fully-qualified # 👂🏿 E1.0 ear: dark skin tone
+1F9BB ; fully-qualified # 🦻 E12.0 ear with hearing aid
+1F9BB 1F3FB ; fully-qualified # 🦻🏻 E12.0 ear with hearing aid: light skin tone
+1F9BB 1F3FC ; fully-qualified # 🦻🏼 E12.0 ear with hearing aid: medium-light skin tone
+1F9BB 1F3FD ; fully-qualified # 🦻🏽 E12.0 ear with hearing aid: medium skin tone
+1F9BB 1F3FE ; fully-qualified # 🦻🏾 E12.0 ear with hearing aid: medium-dark skin tone
+1F9BB 1F3FF ; fully-qualified # 🦻🏿 E12.0 ear with hearing aid: dark skin tone
+1F443 ; fully-qualified # 👃 E0.6 nose
+1F443 1F3FB ; fully-qualified # 👃🏻 E1.0 nose: light skin tone
+1F443 1F3FC ; fully-qualified # 👃🏼 E1.0 nose: medium-light skin tone
+1F443 1F3FD ; fully-qualified # 👃🏽 E1.0 nose: medium skin tone
+1F443 1F3FE ; fully-qualified # 👃🏾 E1.0 nose: medium-dark skin tone
+1F443 1F3FF ; fully-qualified # 👃🏿 E1.0 nose: dark skin tone
+1F9E0 ; fully-qualified # 🧠 E5.0 brain
+1FAC0 ; fully-qualified # 🫀 E13.0 anatomical heart
+1FAC1 ; fully-qualified # 🫁 E13.0 lungs
+1F9B7 ; fully-qualified # 🦷 E11.0 tooth
+1F9B4 ; fully-qualified # 🦴 E11.0 bone
+1F440 ; fully-qualified # 👀 E0.6 eyes
+1F441 FE0F ; fully-qualified # 👁️ E0.7 eye
+1F441 ; unqualified # 👁 E0.7 eye
+1F445 ; fully-qualified # 👅 E0.6 tongue
+1F444 ; fully-qualified # 👄 E0.6 mouth
+1FAE6 ; fully-qualified # 🫦 E14.0 biting lip
+
+# subgroup: person
+1F476 ; fully-qualified # 👶 E0.6 baby
+1F476 1F3FB ; fully-qualified # 👶🏻 E1.0 baby: light skin tone
+1F476 1F3FC ; fully-qualified # 👶🏼 E1.0 baby: medium-light skin tone
+1F476 1F3FD ; fully-qualified # 👶🏽 E1.0 baby: medium skin tone
+1F476 1F3FE ; fully-qualified # 👶🏾 E1.0 baby: medium-dark skin tone
+1F476 1F3FF ; fully-qualified # 👶🏿 E1.0 baby: dark skin tone
+1F9D2 ; fully-qualified # 🧒 E5.0 child
+1F9D2 1F3FB ; fully-qualified # 🧒🏻 E5.0 child: light skin tone
+1F9D2 1F3FC ; fully-qualified # 🧒🏼 E5.0 child: medium-light skin tone
+1F9D2 1F3FD ; fully-qualified # 🧒🏽 E5.0 child: medium skin tone
+1F9D2 1F3FE ; fully-qualified # 🧒🏾 E5.0 child: medium-dark skin tone
+1F9D2 1F3FF ; fully-qualified # 🧒🏿 E5.0 child: dark skin tone
+1F466 ; fully-qualified # 👦 E0.6 boy
+1F466 1F3FB ; fully-qualified # 👦🏻 E1.0 boy: light skin tone
+1F466 1F3FC ; fully-qualified # 👦🏼 E1.0 boy: medium-light skin tone
+1F466 1F3FD ; fully-qualified # 👦🏽 E1.0 boy: medium skin tone
+1F466 1F3FE ; fully-qualified # 👦🏾 E1.0 boy: medium-dark skin tone
+1F466 1F3FF ; fully-qualified # 👦🏿 E1.0 boy: dark skin tone
+1F467 ; fully-qualified # 👧 E0.6 girl
+1F467 1F3FB ; fully-qualified # 👧🏻 E1.0 girl: light skin tone
+1F467 1F3FC ; fully-qualified # 👧🏼 E1.0 girl: medium-light skin tone
+1F467 1F3FD ; fully-qualified # 👧🏽 E1.0 girl: medium skin tone
+1F467 1F3FE ; fully-qualified # 👧🏾 E1.0 girl: medium-dark skin tone
+1F467 1F3FF ; fully-qualified # 👧🏿 E1.0 girl: dark skin tone
+1F9D1 ; fully-qualified # 🧑 E5.0 person
+1F9D1 1F3FB ; fully-qualified # 🧑🏻 E5.0 person: light skin tone
+1F9D1 1F3FC ; fully-qualified # 🧑🏼 E5.0 person: medium-light skin tone
+1F9D1 1F3FD ; fully-qualified # 🧑🏽 E5.0 person: medium skin tone
+1F9D1 1F3FE ; fully-qualified # 🧑🏾 E5.0 person: medium-dark skin tone
+1F9D1 1F3FF ; fully-qualified # 🧑🏿 E5.0 person: dark skin tone
+1F471 ; fully-qualified # 👱 E0.6 person: blond hair
+1F471 1F3FB ; fully-qualified # 👱🏻 E1.0 person: light skin tone, blond hair
+1F471 1F3FC ; fully-qualified # 👱🏼 E1.0 person: medium-light skin tone, blond hair
+1F471 1F3FD ; fully-qualified # 👱🏽 E1.0 person: medium skin tone, blond hair
+1F471 1F3FE ; fully-qualified # 👱🏾 E1.0 person: medium-dark skin tone, blond hair
+1F471 1F3FF ; fully-qualified # 👱🏿 E1.0 person: dark skin tone, blond hair
+1F468 ; fully-qualified # 👨 E0.6 man
+1F468 1F3FB ; fully-qualified # 👨🏻 E1.0 man: light skin tone
+1F468 1F3FC ; fully-qualified # 👨🏼 E1.0 man: medium-light skin tone
+1F468 1F3FD ; fully-qualified # 👨🏽 E1.0 man: medium skin tone
+1F468 1F3FE ; fully-qualified # 👨🏾 E1.0 man: medium-dark skin tone
+1F468 1F3FF ; fully-qualified # 👨🏿 E1.0 man: dark skin tone
+1F9D4 ; fully-qualified # 🧔 E5.0 person: beard
+1F9D4 1F3FB ; fully-qualified # 🧔🏻 E5.0 person: light skin tone, beard
+1F9D4 1F3FC ; fully-qualified # 🧔🏼 E5.0 person: medium-light skin tone, beard
+1F9D4 1F3FD ; fully-qualified # 🧔🏽 E5.0 person: medium skin tone, beard
+1F9D4 1F3FE ; fully-qualified # 🧔🏾 E5.0 person: medium-dark skin tone, beard
+1F9D4 1F3FF ; fully-qualified # 🧔🏿 E5.0 person: dark skin tone, beard
+1F9D4 200D 2642 FE0F ; fully-qualified # 🧔‍♂️ E13.1 man: beard
+1F9D4 200D 2642 ; minimally-qualified # 🧔‍♂ E13.1 man: beard
+1F9D4 1F3FB 200D 2642 FE0F ; fully-qualified # 🧔🏻‍♂️ E13.1 man: light skin tone, beard
+1F9D4 1F3FB 200D 2642 ; minimally-qualified # 🧔🏻‍♂ E13.1 man: light skin tone, beard
+1F9D4 1F3FC 200D 2642 FE0F ; fully-qualified # 🧔🏼‍♂️ E13.1 man: medium-light skin tone, beard
+1F9D4 1F3FC 200D 2642 ; minimally-qualified # 🧔🏼‍♂ E13.1 man: medium-light skin tone, beard
+1F9D4 1F3FD 200D 2642 FE0F ; fully-qualified # 🧔🏽‍♂️ E13.1 man: medium skin tone, beard
+1F9D4 1F3FD 200D 2642 ; minimally-qualified # 🧔🏽‍♂ E13.1 man: medium skin tone, beard
+1F9D4 1F3FE 200D 2642 FE0F ; fully-qualified # 🧔🏾‍♂️ E13.1 man: medium-dark skin tone, beard
+1F9D4 1F3FE 200D 2642 ; minimally-qualified # 🧔🏾‍♂ E13.1 man: medium-dark skin tone, beard
+1F9D4 1F3FF 200D 2642 FE0F ; fully-qualified # 🧔🏿‍♂️ E13.1 man: dark skin tone, beard
+1F9D4 1F3FF 200D 2642 ; minimally-qualified # 🧔🏿‍♂ E13.1 man: dark skin tone, beard
+1F9D4 200D 2640 FE0F ; fully-qualified # 🧔‍♀️ E13.1 woman: beard
+1F9D4 200D 2640 ; minimally-qualified # 🧔‍♀ E13.1 woman: beard
+1F9D4 1F3FB 200D 2640 FE0F ; fully-qualified # 🧔🏻‍♀️ E13.1 woman: light skin tone, beard
+1F9D4 1F3FB 200D 2640 ; minimally-qualified # 🧔🏻‍♀ E13.1 woman: light skin tone, beard
+1F9D4 1F3FC 200D 2640 FE0F ; fully-qualified # 🧔🏼‍♀️ E13.1 woman: medium-light skin tone, beard
+1F9D4 1F3FC 200D 2640 ; minimally-qualified # 🧔🏼‍♀ E13.1 woman: medium-light skin tone, beard
+1F9D4 1F3FD 200D 2640 FE0F ; fully-qualified # 🧔🏽‍♀️ E13.1 woman: medium skin tone, beard
+1F9D4 1F3FD 200D 2640 ; minimally-qualified # 🧔🏽‍♀ E13.1 woman: medium skin tone, beard
+1F9D4 1F3FE 200D 2640 FE0F ; fully-qualified # 🧔🏾‍♀️ E13.1 woman: medium-dark skin tone, beard
+1F9D4 1F3FE 200D 2640 ; minimally-qualified # 🧔🏾‍♀ E13.1 woman: medium-dark skin tone, beard
+1F9D4 1F3FF 200D 2640 FE0F ; fully-qualified # 🧔🏿‍♀️ E13.1 woman: dark skin tone, beard
+1F9D4 1F3FF 200D 2640 ; minimally-qualified # 🧔🏿‍♀ E13.1 woman: dark skin tone, beard
+1F468 200D 1F9B0 ; fully-qualified # 👨‍🦰 E11.0 man: red hair
+1F468 1F3FB 200D 1F9B0 ; fully-qualified # 👨🏻‍🦰 E11.0 man: light skin tone, red hair
+1F468 1F3FC 200D 1F9B0 ; fully-qualified # 👨🏼‍🦰 E11.0 man: medium-light skin tone, red hair
+1F468 1F3FD 200D 1F9B0 ; fully-qualified # 👨🏽‍🦰 E11.0 man: medium skin tone, red hair
+1F468 1F3FE 200D 1F9B0 ; fully-qualified # 👨🏾‍🦰 E11.0 man: medium-dark skin tone, red hair
+1F468 1F3FF 200D 1F9B0 ; fully-qualified # 👨🏿‍🦰 E11.0 man: dark skin tone, red hair
+1F468 200D 1F9B1 ; fully-qualified # 👨‍🦱 E11.0 man: curly hair
+1F468 1F3FB 200D 1F9B1 ; fully-qualified # 👨🏻‍🦱 E11.0 man: light skin tone, curly hair
+1F468 1F3FC 200D 1F9B1 ; fully-qualified # 👨🏼‍🦱 E11.0 man: medium-light skin tone, curly hair
+1F468 1F3FD 200D 1F9B1 ; fully-qualified # 👨🏽‍🦱 E11.0 man: medium skin tone, curly hair
+1F468 1F3FE 200D 1F9B1 ; fully-qualified # 👨🏾‍🦱 E11.0 man: medium-dark skin tone, curly hair
+1F468 1F3FF 200D 1F9B1 ; fully-qualified # 👨🏿‍🦱 E11.0 man: dark skin tone, curly hair
+1F468 200D 1F9B3 ; fully-qualified # 👨‍🦳 E11.0 man: white hair
+1F468 1F3FB 200D 1F9B3 ; fully-qualified # 👨🏻‍🦳 E11.0 man: light skin tone, white hair
+1F468 1F3FC 200D 1F9B3 ; fully-qualified # 👨🏼‍🦳 E11.0 man: medium-light skin tone, white hair
+1F468 1F3FD 200D 1F9B3 ; fully-qualified # 👨🏽‍🦳 E11.0 man: medium skin tone, white hair
+1F468 1F3FE 200D 1F9B3 ; fully-qualified # 👨🏾‍🦳 E11.0 man: medium-dark skin tone, white hair
+1F468 1F3FF 200D 1F9B3 ; fully-qualified # 👨🏿‍🦳 E11.0 man: dark skin tone, white hair
+1F468 200D 1F9B2 ; fully-qualified # 👨‍🦲 E11.0 man: bald
+1F468 1F3FB 200D 1F9B2 ; fully-qualified # 👨🏻‍🦲 E11.0 man: light skin tone, bald
+1F468 1F3FC 200D 1F9B2 ; fully-qualified # 👨🏼‍🦲 E11.0 man: medium-light skin tone, bald
+1F468 1F3FD 200D 1F9B2 ; fully-qualified # 👨🏽‍🦲 E11.0 man: medium skin tone, bald
+1F468 1F3FE 200D 1F9B2 ; fully-qualified # 👨🏾‍🦲 E11.0 man: medium-dark skin tone, bald
+1F468 1F3FF 200D 1F9B2 ; fully-qualified # 👨🏿‍🦲 E11.0 man: dark skin tone, bald
+1F469 ; fully-qualified # 👩 E0.6 woman
+1F469 1F3FB ; fully-qualified # 👩🏻 E1.0 woman: light skin tone
+1F469 1F3FC ; fully-qualified # 👩🏼 E1.0 woman: medium-light skin tone
+1F469 1F3FD ; fully-qualified # 👩🏽 E1.0 woman: medium skin tone
+1F469 1F3FE ; fully-qualified # 👩🏾 E1.0 woman: medium-dark skin tone
+1F469 1F3FF ; fully-qualified # 👩🏿 E1.0 woman: dark skin tone
+1F469 200D 1F9B0 ; fully-qualified # 👩‍🦰 E11.0 woman: red hair
+1F469 1F3FB 200D 1F9B0 ; fully-qualified # 👩🏻‍🦰 E11.0 woman: light skin tone, red hair
+1F469 1F3FC 200D 1F9B0 ; fully-qualified # 👩🏼‍🦰 E11.0 woman: medium-light skin tone, red hair
+1F469 1F3FD 200D 1F9B0 ; fully-qualified # 👩🏽‍🦰 E11.0 woman: medium skin tone, red hair
+1F469 1F3FE 200D 1F9B0 ; fully-qualified # 👩🏾‍🦰 E11.0 woman: medium-dark skin tone, red hair
+1F469 1F3FF 200D 1F9B0 ; fully-qualified # 👩🏿‍🦰 E11.0 woman: dark skin tone, red hair
+1F9D1 200D 1F9B0 ; fully-qualified # 🧑‍🦰 E12.1 person: red hair
+1F9D1 1F3FB 200D 1F9B0 ; fully-qualified # 🧑🏻‍🦰 E12.1 person: light skin tone, red hair
+1F9D1 1F3FC 200D 1F9B0 ; fully-qualified # 🧑🏼‍🦰 E12.1 person: medium-light skin tone, red hair
+1F9D1 1F3FD 200D 1F9B0 ; fully-qualified # 🧑🏽‍🦰 E12.1 person: medium skin tone, red hair
+1F9D1 1F3FE 200D 1F9B0 ; fully-qualified # 🧑🏾‍🦰 E12.1 person: medium-dark skin tone, red hair
+1F9D1 1F3FF 200D 1F9B0 ; fully-qualified # 🧑🏿‍🦰 E12.1 person: dark skin tone, red hair
+1F469 200D 1F9B1 ; fully-qualified # 👩‍🦱 E11.0 woman: curly hair
+1F469 1F3FB 200D 1F9B1 ; fully-qualified # 👩🏻‍🦱 E11.0 woman: light skin tone, curly hair
+1F469 1F3FC 200D 1F9B1 ; fully-qualified # 👩🏼‍🦱 E11.0 woman: medium-light skin tone, curly hair
+1F469 1F3FD 200D 1F9B1 ; fully-qualified # 👩🏽‍🦱 E11.0 woman: medium skin tone, curly hair
+1F469 1F3FE 200D 1F9B1 ; fully-qualified # 👩🏾‍🦱 E11.0 woman: medium-dark skin tone, curly hair
+1F469 1F3FF 200D 1F9B1 ; fully-qualified # 👩🏿‍🦱 E11.0 woman: dark skin tone, curly hair
+1F9D1 200D 1F9B1 ; fully-qualified # 🧑‍🦱 E12.1 person: curly hair
+1F9D1 1F3FB 200D 1F9B1 ; fully-qualified # 🧑🏻‍🦱 E12.1 person: light skin tone, curly hair
+1F9D1 1F3FC 200D 1F9B1 ; fully-qualified # 🧑🏼‍🦱 E12.1 person: medium-light skin tone, curly hair
+1F9D1 1F3FD 200D 1F9B1 ; fully-qualified # 🧑🏽‍🦱 E12.1 person: medium skin tone, curly hair
+1F9D1 1F3FE 200D 1F9B1 ; fully-qualified # 🧑🏾‍🦱 E12.1 person: medium-dark skin tone, curly hair
+1F9D1 1F3FF 200D 1F9B1 ; fully-qualified # 🧑🏿‍🦱 E12.1 person: dark skin tone, curly hair
+1F469 200D 1F9B3 ; fully-qualified # 👩‍🦳 E11.0 woman: white hair
+1F469 1F3FB 200D 1F9B3 ; fully-qualified # 👩🏻‍🦳 E11.0 woman: light skin tone, white hair
+1F469 1F3FC 200D 1F9B3 ; fully-qualified # 👩🏼‍🦳 E11.0 woman: medium-light skin tone, white hair
+1F469 1F3FD 200D 1F9B3 ; fully-qualified # 👩🏽‍🦳 E11.0 woman: medium skin tone, white hair
+1F469 1F3FE 200D 1F9B3 ; fully-qualified # 👩🏾‍🦳 E11.0 woman: medium-dark skin tone, white hair
+1F469 1F3FF 200D 1F9B3 ; fully-qualified # 👩🏿‍🦳 E11.0 woman: dark skin tone, white hair
+1F9D1 200D 1F9B3 ; fully-qualified # 🧑‍🦳 E12.1 person: white hair
+1F9D1 1F3FB 200D 1F9B3 ; fully-qualified # 🧑🏻‍🦳 E12.1 person: light skin tone, white hair
+1F9D1 1F3FC 200D 1F9B3 ; fully-qualified # 🧑🏼‍🦳 E12.1 person: medium-light skin tone, white hair
+1F9D1 1F3FD 200D 1F9B3 ; fully-qualified # 🧑🏽‍🦳 E12.1 person: medium skin tone, white hair
+1F9D1 1F3FE 200D 1F9B3 ; fully-qualified # 🧑🏾‍🦳 E12.1 person: medium-dark skin tone, white hair
+1F9D1 1F3FF 200D 1F9B3 ; fully-qualified # 🧑🏿‍🦳 E12.1 person: dark skin tone, white hair
+1F469 200D 1F9B2 ; fully-qualified # 👩‍🦲 E11.0 woman: bald
+1F469 1F3FB 200D 1F9B2 ; fully-qualified # 👩🏻‍🦲 E11.0 woman: light skin tone, bald
+1F469 1F3FC 200D 1F9B2 ; fully-qualified # 👩🏼‍🦲 E11.0 woman: medium-light skin tone, bald
+1F469 1F3FD 200D 1F9B2 ; fully-qualified # 👩🏽‍🦲 E11.0 woman: medium skin tone, bald
+1F469 1F3FE 200D 1F9B2 ; fully-qualified # 👩🏾‍🦲 E11.0 woman: medium-dark skin tone, bald
+1F469 1F3FF 200D 1F9B2 ; fully-qualified # 👩🏿‍🦲 E11.0 woman: dark skin tone, bald
+1F9D1 200D 1F9B2 ; fully-qualified # 🧑‍🦲 E12.1 person: bald
+1F9D1 1F3FB 200D 1F9B2 ; fully-qualified # 🧑🏻‍🦲 E12.1 person: light skin tone, bald
+1F9D1 1F3FC 200D 1F9B2 ; fully-qualified # 🧑🏼‍🦲 E12.1 person: medium-light skin tone, bald
+1F9D1 1F3FD 200D 1F9B2 ; fully-qualified # 🧑🏽‍🦲 E12.1 person: medium skin tone, bald
+1F9D1 1F3FE 200D 1F9B2 ; fully-qualified # 🧑🏾‍🦲 E12.1 person: medium-dark skin tone, bald
+1F9D1 1F3FF 200D 1F9B2 ; fully-qualified # 🧑🏿‍🦲 E12.1 person: dark skin tone, bald
+1F471 200D 2640 FE0F ; fully-qualified # 👱‍♀️ E4.0 woman: blond hair
+1F471 200D 2640 ; minimally-qualified # 👱‍♀ E4.0 woman: blond hair
+1F471 1F3FB 200D 2640 FE0F ; fully-qualified # 👱🏻‍♀️ E4.0 woman: light skin tone, blond hair
+1F471 1F3FB 200D 2640 ; minimally-qualified # 👱🏻‍♀ E4.0 woman: light skin tone, blond hair
+1F471 1F3FC 200D 2640 FE0F ; fully-qualified # 👱🏼‍♀️ E4.0 woman: medium-light skin tone, blond hair
+1F471 1F3FC 200D 2640 ; minimally-qualified # 👱🏼‍♀ E4.0 woman: medium-light skin tone, blond hair
+1F471 1F3FD 200D 2640 FE0F ; fully-qualified # 👱🏽‍♀️ E4.0 woman: medium skin tone, blond hair
+1F471 1F3FD 200D 2640 ; minimally-qualified # 👱🏽‍♀ E4.0 woman: medium skin tone, blond hair
+1F471 1F3FE 200D 2640 FE0F ; fully-qualified # 👱🏾‍♀️ E4.0 woman: medium-dark skin tone, blond hair
+1F471 1F3FE 200D 2640 ; minimally-qualified # 👱🏾‍♀ E4.0 woman: medium-dark skin tone, blond hair
+1F471 1F3FF 200D 2640 FE0F ; fully-qualified # 👱🏿‍♀️ E4.0 woman: dark skin tone, blond hair
+1F471 1F3FF 200D 2640 ; minimally-qualified # 👱🏿‍♀ E4.0 woman: dark skin tone, blond hair
+1F471 200D 2642 FE0F ; fully-qualified # 👱‍♂️ E4.0 man: blond hair
+1F471 200D 2642 ; minimally-qualified # 👱‍♂ E4.0 man: blond hair
+1F471 1F3FB 200D 2642 FE0F ; fully-qualified # 👱🏻‍♂️ E4.0 man: light skin tone, blond hair
+1F471 1F3FB 200D 2642 ; minimally-qualified # 👱🏻‍♂ E4.0 man: light skin tone, blond hair
+1F471 1F3FC 200D 2642 FE0F ; fully-qualified # 👱🏼‍♂️ E4.0 man: medium-light skin tone, blond hair
+1F471 1F3FC 200D 2642 ; minimally-qualified # 👱🏼‍♂ E4.0 man: medium-light skin tone, blond hair
+1F471 1F3FD 200D 2642 FE0F ; fully-qualified # 👱🏽‍♂️ E4.0 man: medium skin tone, blond hair
+1F471 1F3FD 200D 2642 ; minimally-qualified # 👱🏽‍♂ E4.0 man: medium skin tone, blond hair
+1F471 1F3FE 200D 2642 FE0F ; fully-qualified # 👱🏾‍♂️ E4.0 man: medium-dark skin tone, blond hair
+1F471 1F3FE 200D 2642 ; minimally-qualified # 👱🏾‍♂ E4.0 man: medium-dark skin tone, blond hair
+1F471 1F3FF 200D 2642 FE0F ; fully-qualified # 👱🏿‍♂️ E4.0 man: dark skin tone, blond hair
+1F471 1F3FF 200D 2642 ; minimally-qualified # 👱🏿‍♂ E4.0 man: dark skin tone, blond hair
+1F9D3 ; fully-qualified # 🧓 E5.0 older person
+1F9D3 1F3FB ; fully-qualified # 🧓🏻 E5.0 older person: light skin tone
+1F9D3 1F3FC ; fully-qualified # 🧓🏼 E5.0 older person: medium-light skin tone
+1F9D3 1F3FD ; fully-qualified # 🧓🏽 E5.0 older person: medium skin tone
+1F9D3 1F3FE ; fully-qualified # 🧓🏾 E5.0 older person: medium-dark skin tone
+1F9D3 1F3FF ; fully-qualified # 🧓🏿 E5.0 older person: dark skin tone
+1F474 ; fully-qualified # 👴 E0.6 old man
+1F474 1F3FB ; fully-qualified # 👴🏻 E1.0 old man: light skin tone
+1F474 1F3FC ; fully-qualified # 👴🏼 E1.0 old man: medium-light skin tone
+1F474 1F3FD ; fully-qualified # 👴🏽 E1.0 old man: medium skin tone
+1F474 1F3FE ; fully-qualified # 👴🏾 E1.0 old man: medium-dark skin tone
+1F474 1F3FF ; fully-qualified # 👴🏿 E1.0 old man: dark skin tone
+1F475 ; fully-qualified # 👵 E0.6 old woman
+1F475 1F3FB ; fully-qualified # 👵🏻 E1.0 old woman: light skin tone
+1F475 1F3FC ; fully-qualified # 👵🏼 E1.0 old woman: medium-light skin tone
+1F475 1F3FD ; fully-qualified # 👵🏽 E1.0 old woman: medium skin tone
+1F475 1F3FE ; fully-qualified # 👵🏾 E1.0 old woman: medium-dark skin tone
+1F475 1F3FF ; fully-qualified # 👵🏿 E1.0 old woman: dark skin tone
+
+# subgroup: person-gesture
+1F64D ; fully-qualified # 🙍 E0.6 person frowning
+1F64D 1F3FB ; fully-qualified # 🙍🏻 E1.0 person frowning: light skin tone
+1F64D 1F3FC ; fully-qualified # 🙍🏼 E1.0 person frowning: medium-light skin tone
+1F64D 1F3FD ; fully-qualified # 🙍🏽 E1.0 person frowning: medium skin tone
+1F64D 1F3FE ; fully-qualified # 🙍🏾 E1.0 person frowning: medium-dark skin tone
+1F64D 1F3FF ; fully-qualified # 🙍🏿 E1.0 person frowning: dark skin tone
+1F64D 200D 2642 FE0F ; fully-qualified # 🙍‍♂️ E4.0 man frowning
+1F64D 200D 2642 ; minimally-qualified # 🙍‍♂ E4.0 man frowning
+1F64D 1F3FB 200D 2642 FE0F ; fully-qualified # 🙍🏻‍♂️ E4.0 man frowning: light skin tone
+1F64D 1F3FB 200D 2642 ; minimally-qualified # 🙍🏻‍♂ E4.0 man frowning: light skin tone
+1F64D 1F3FC 200D 2642 FE0F ; fully-qualified # 🙍🏼‍♂️ E4.0 man frowning: medium-light skin tone
+1F64D 1F3FC 200D 2642 ; minimally-qualified # 🙍🏼‍♂ E4.0 man frowning: medium-light skin tone
+1F64D 1F3FD 200D 2642 FE0F ; fully-qualified # 🙍🏽‍♂️ E4.0 man frowning: medium skin tone
+1F64D 1F3FD 200D 2642 ; minimally-qualified # 🙍🏽‍♂ E4.0 man frowning: medium skin tone
+1F64D 1F3FE 200D 2642 FE0F ; fully-qualified # 🙍🏾‍♂️ E4.0 man frowning: medium-dark skin tone
+1F64D 1F3FE 200D 2642 ; minimally-qualified # 🙍🏾‍♂ E4.0 man frowning: medium-dark skin tone
+1F64D 1F3FF 200D 2642 FE0F ; fully-qualified # 🙍🏿‍♂️ E4.0 man frowning: dark skin tone
+1F64D 1F3FF 200D 2642 ; minimally-qualified # 🙍🏿‍♂ E4.0 man frowning: dark skin tone
+1F64D 200D 2640 FE0F ; fully-qualified # 🙍‍♀️ E4.0 woman frowning
+1F64D 200D 2640 ; minimally-qualified # 🙍‍♀ E4.0 woman frowning
+1F64D 1F3FB 200D 2640 FE0F ; fully-qualified # 🙍🏻‍♀️ E4.0 woman frowning: light skin tone
+1F64D 1F3FB 200D 2640 ; minimally-qualified # 🙍🏻‍♀ E4.0 woman frowning: light skin tone
+1F64D 1F3FC 200D 2640 FE0F ; fully-qualified # 🙍🏼‍♀️ E4.0 woman frowning: medium-light skin tone
+1F64D 1F3FC 200D 2640 ; minimally-qualified # 🙍🏼‍♀ E4.0 woman frowning: medium-light skin tone
+1F64D 1F3FD 200D 2640 FE0F ; fully-qualified # 🙍🏽‍♀️ E4.0 woman frowning: medium skin tone
+1F64D 1F3FD 200D 2640 ; minimally-qualified # 🙍🏽‍♀ E4.0 woman frowning: medium skin tone
+1F64D 1F3FE 200D 2640 FE0F ; fully-qualified # 🙍🏾‍♀️ E4.0 woman frowning: medium-dark skin tone
+1F64D 1F3FE 200D 2640 ; minimally-qualified # 🙍🏾‍♀ E4.0 woman frowning: medium-dark skin tone
+1F64D 1F3FF 200D 2640 FE0F ; fully-qualified # 🙍🏿‍♀️ E4.0 woman frowning: dark skin tone
+1F64D 1F3FF 200D 2640 ; minimally-qualified # 🙍🏿‍♀ E4.0 woman frowning: dark skin tone
+1F64E ; fully-qualified # 🙎 E0.6 person pouting
+1F64E 1F3FB ; fully-qualified # 🙎🏻 E1.0 person pouting: light skin tone
+1F64E 1F3FC ; fully-qualified # 🙎🏼 E1.0 person pouting: medium-light skin tone
+1F64E 1F3FD ; fully-qualified # 🙎🏽 E1.0 person pouting: medium skin tone
+1F64E 1F3FE ; fully-qualified # 🙎🏾 E1.0 person pouting: medium-dark skin tone
+1F64E 1F3FF ; fully-qualified # 🙎🏿 E1.0 person pouting: dark skin tone
+1F64E 200D 2642 FE0F ; fully-qualified # 🙎‍♂️ E4.0 man pouting
+1F64E 200D 2642 ; minimally-qualified # 🙎‍♂ E4.0 man pouting
+1F64E 1F3FB 200D 2642 FE0F ; fully-qualified # 🙎🏻‍♂️ E4.0 man pouting: light skin tone
+1F64E 1F3FB 200D 2642 ; minimally-qualified # 🙎🏻‍♂ E4.0 man pouting: light skin tone
+1F64E 1F3FC 200D 2642 FE0F ; fully-qualified # 🙎🏼‍♂️ E4.0 man pouting: medium-light skin tone
+1F64E 1F3FC 200D 2642 ; minimally-qualified # 🙎🏼‍♂ E4.0 man pouting: medium-light skin tone
+1F64E 1F3FD 200D 2642 FE0F ; fully-qualified # 🙎🏽‍♂️ E4.0 man pouting: medium skin tone
+1F64E 1F3FD 200D 2642 ; minimally-qualified # 🙎🏽‍♂ E4.0 man pouting: medium skin tone
+1F64E 1F3FE 200D 2642 FE0F ; fully-qualified # 🙎🏾‍♂️ E4.0 man pouting: medium-dark skin tone
+1F64E 1F3FE 200D 2642 ; minimally-qualified # 🙎🏾‍♂ E4.0 man pouting: medium-dark skin tone
+1F64E 1F3FF 200D 2642 FE0F ; fully-qualified # 🙎🏿‍♂️ E4.0 man pouting: dark skin tone
+1F64E 1F3FF 200D 2642 ; minimally-qualified # 🙎🏿‍♂ E4.0 man pouting: dark skin tone
+1F64E 200D 2640 FE0F ; fully-qualified # 🙎‍♀️ E4.0 woman pouting
+1F64E 200D 2640 ; minimally-qualified # 🙎‍♀ E4.0 woman pouting
+1F64E 1F3FB 200D 2640 FE0F ; fully-qualified # 🙎🏻‍♀️ E4.0 woman pouting: light skin tone
+1F64E 1F3FB 200D 2640 ; minimally-qualified # 🙎🏻‍♀ E4.0 woman pouting: light skin tone
+1F64E 1F3FC 200D 2640 FE0F ; fully-qualified # 🙎🏼‍♀️ E4.0 woman pouting: medium-light skin tone
+1F64E 1F3FC 200D 2640 ; minimally-qualified # 🙎🏼‍♀ E4.0 woman pouting: medium-light skin tone
+1F64E 1F3FD 200D 2640 FE0F ; fully-qualified # 🙎🏽‍♀️ E4.0 woman pouting: medium skin tone
+1F64E 1F3FD 200D 2640 ; minimally-qualified # 🙎🏽‍♀ E4.0 woman pouting: medium skin tone
+1F64E 1F3FE 200D 2640 FE0F ; fully-qualified # 🙎🏾‍♀️ E4.0 woman pouting: medium-dark skin tone
+1F64E 1F3FE 200D 2640 ; minimally-qualified # 🙎🏾‍♀ E4.0 woman pouting: medium-dark skin tone
+1F64E 1F3FF 200D 2640 FE0F ; fully-qualified # 🙎🏿‍♀️ E4.0 woman pouting: dark skin tone
+1F64E 1F3FF 200D 2640 ; minimally-qualified # 🙎🏿‍♀ E4.0 woman pouting: dark skin tone
+1F645 ; fully-qualified # 🙅 E0.6 person gesturing NO
+1F645 1F3FB ; fully-qualified # 🙅🏻 E1.0 person gesturing NO: light skin tone
+1F645 1F3FC ; fully-qualified # 🙅🏼 E1.0 person gesturing NO: medium-light skin tone
+1F645 1F3FD ; fully-qualified # 🙅🏽 E1.0 person gesturing NO: medium skin tone
+1F645 1F3FE ; fully-qualified # 🙅🏾 E1.0 person gesturing NO: medium-dark skin tone
+1F645 1F3FF ; fully-qualified # 🙅🏿 E1.0 person gesturing NO: dark skin tone
+1F645 200D 2642 FE0F ; fully-qualified # 🙅‍♂️ E4.0 man gesturing NO
+1F645 200D 2642 ; minimally-qualified # 🙅‍♂ E4.0 man gesturing NO
+1F645 1F3FB 200D 2642 FE0F ; fully-qualified # 🙅🏻‍♂️ E4.0 man gesturing NO: light skin tone
+1F645 1F3FB 200D 2642 ; minimally-qualified # 🙅🏻‍♂ E4.0 man gesturing NO: light skin tone
+1F645 1F3FC 200D 2642 FE0F ; fully-qualified # 🙅🏼‍♂️ E4.0 man gesturing NO: medium-light skin tone
+1F645 1F3FC 200D 2642 ; minimally-qualified # 🙅🏼‍♂ E4.0 man gesturing NO: medium-light skin tone
+1F645 1F3FD 200D 2642 FE0F ; fully-qualified # 🙅🏽‍♂️ E4.0 man gesturing NO: medium skin tone
+1F645 1F3FD 200D 2642 ; minimally-qualified # 🙅🏽‍♂ E4.0 man gesturing NO: medium skin tone
+1F645 1F3FE 200D 2642 FE0F ; fully-qualified # 🙅🏾‍♂️ E4.0 man gesturing NO: medium-dark skin tone
+1F645 1F3FE 200D 2642 ; minimally-qualified # 🙅🏾‍♂ E4.0 man gesturing NO: medium-dark skin tone
+1F645 1F3FF 200D 2642 FE0F ; fully-qualified # 🙅🏿‍♂️ E4.0 man gesturing NO: dark skin tone
+1F645 1F3FF 200D 2642 ; minimally-qualified # 🙅🏿‍♂ E4.0 man gesturing NO: dark skin tone
+1F645 200D 2640 FE0F ; fully-qualified # 🙅‍♀️ E4.0 woman gesturing NO
+1F645 200D 2640 ; minimally-qualified # 🙅‍♀ E4.0 woman gesturing NO
+1F645 1F3FB 200D 2640 FE0F ; fully-qualified # 🙅🏻‍♀️ E4.0 woman gesturing NO: light skin tone
+1F645 1F3FB 200D 2640 ; minimally-qualified # 🙅🏻‍♀ E4.0 woman gesturing NO: light skin tone
+1F645 1F3FC 200D 2640 FE0F ; fully-qualified # 🙅🏼‍♀️ E4.0 woman gesturing NO: medium-light skin tone
+1F645 1F3FC 200D 2640 ; minimally-qualified # 🙅🏼‍♀ E4.0 woman gesturing NO: medium-light skin tone
+1F645 1F3FD 200D 2640 FE0F ; fully-qualified # 🙅🏽‍♀️ E4.0 woman gesturing NO: medium skin tone
+1F645 1F3FD 200D 2640 ; minimally-qualified # 🙅🏽‍♀ E4.0 woman gesturing NO: medium skin tone
+1F645 1F3FE 200D 2640 FE0F ; fully-qualified # 🙅🏾‍♀️ E4.0 woman gesturing NO: medium-dark skin tone
+1F645 1F3FE 200D 2640 ; minimally-qualified # 🙅🏾‍♀ E4.0 woman gesturing NO: medium-dark skin tone
+1F645 1F3FF 200D 2640 FE0F ; fully-qualified # 🙅🏿‍♀️ E4.0 woman gesturing NO: dark skin tone
+1F645 1F3FF 200D 2640 ; minimally-qualified # 🙅🏿‍♀ E4.0 woman gesturing NO: dark skin tone
+1F646 ; fully-qualified # 🙆 E0.6 person gesturing OK
+1F646 1F3FB ; fully-qualified # 🙆🏻 E1.0 person gesturing OK: light skin tone
+1F646 1F3FC ; fully-qualified # 🙆🏼 E1.0 person gesturing OK: medium-light skin tone
+1F646 1F3FD ; fully-qualified # 🙆🏽 E1.0 person gesturing OK: medium skin tone
+1F646 1F3FE ; fully-qualified # 🙆🏾 E1.0 person gesturing OK: medium-dark skin tone
+1F646 1F3FF ; fully-qualified # 🙆🏿 E1.0 person gesturing OK: dark skin tone
+1F646 200D 2642 FE0F ; fully-qualified # 🙆‍♂️ E4.0 man gesturing OK
+1F646 200D 2642 ; minimally-qualified # 🙆‍♂ E4.0 man gesturing OK
+1F646 1F3FB 200D 2642 FE0F ; fully-qualified # 🙆🏻‍♂️ E4.0 man gesturing OK: light skin tone
+1F646 1F3FB 200D 2642 ; minimally-qualified # 🙆🏻‍♂ E4.0 man gesturing OK: light skin tone
+1F646 1F3FC 200D 2642 FE0F ; fully-qualified # 🙆🏼‍♂️ E4.0 man gesturing OK: medium-light skin tone
+1F646 1F3FC 200D 2642 ; minimally-qualified # 🙆🏼‍♂ E4.0 man gesturing OK: medium-light skin tone
+1F646 1F3FD 200D 2642 FE0F ; fully-qualified # 🙆🏽‍♂️ E4.0 man gesturing OK: medium skin tone
+1F646 1F3FD 200D 2642 ; minimally-qualified # 🙆🏽‍♂ E4.0 man gesturing OK: medium skin tone
+1F646 1F3FE 200D 2642 FE0F ; fully-qualified # 🙆🏾‍♂️ E4.0 man gesturing OK: medium-dark skin tone
+1F646 1F3FE 200D 2642 ; minimally-qualified # 🙆🏾‍♂ E4.0 man gesturing OK: medium-dark skin tone
+1F646 1F3FF 200D 2642 FE0F ; fully-qualified # 🙆🏿‍♂️ E4.0 man gesturing OK: dark skin tone
+1F646 1F3FF 200D 2642 ; minimally-qualified # 🙆🏿‍♂ E4.0 man gesturing OK: dark skin tone
+1F646 200D 2640 FE0F ; fully-qualified # 🙆‍♀️ E4.0 woman gesturing OK
+1F646 200D 2640 ; minimally-qualified # 🙆‍♀ E4.0 woman gesturing OK
+1F646 1F3FB 200D 2640 FE0F ; fully-qualified # 🙆🏻‍♀️ E4.0 woman gesturing OK: light skin tone
+1F646 1F3FB 200D 2640 ; minimally-qualified # 🙆🏻‍♀ E4.0 woman gesturing OK: light skin tone
+1F646 1F3FC 200D 2640 FE0F ; fully-qualified # 🙆🏼‍♀️ E4.0 woman gesturing OK: medium-light skin tone
+1F646 1F3FC 200D 2640 ; minimally-qualified # 🙆🏼‍♀ E4.0 woman gesturing OK: medium-light skin tone
+1F646 1F3FD 200D 2640 FE0F ; fully-qualified # 🙆🏽‍♀️ E4.0 woman gesturing OK: medium skin tone
+1F646 1F3FD 200D 2640 ; minimally-qualified # 🙆🏽‍♀ E4.0 woman gesturing OK: medium skin tone
+1F646 1F3FE 200D 2640 FE0F ; fully-qualified # 🙆🏾‍♀️ E4.0 woman gesturing OK: medium-dark skin tone
+1F646 1F3FE 200D 2640 ; minimally-qualified # 🙆🏾‍♀ E4.0 woman gesturing OK: medium-dark skin tone
+1F646 1F3FF 200D 2640 FE0F ; fully-qualified # 🙆🏿‍♀️ E4.0 woman gesturing OK: dark skin tone
+1F646 1F3FF 200D 2640 ; minimally-qualified # 🙆🏿‍♀ E4.0 woman gesturing OK: dark skin tone
+1F481 ; fully-qualified # 💁 E0.6 person tipping hand
+1F481 1F3FB ; fully-qualified # 💁🏻 E1.0 person tipping hand: light skin tone
+1F481 1F3FC ; fully-qualified # 💁🏼 E1.0 person tipping hand: medium-light skin tone
+1F481 1F3FD ; fully-qualified # 💁🏽 E1.0 person tipping hand: medium skin tone
+1F481 1F3FE ; fully-qualified # 💁🏾 E1.0 person tipping hand: medium-dark skin tone
+1F481 1F3FF ; fully-qualified # 💁🏿 E1.0 person tipping hand: dark skin tone
+1F481 200D 2642 FE0F ; fully-qualified # 💁‍♂️ E4.0 man tipping hand
+1F481 200D 2642 ; minimally-qualified # 💁‍♂ E4.0 man tipping hand
+1F481 1F3FB 200D 2642 FE0F ; fully-qualified # 💁🏻‍♂️ E4.0 man tipping hand: light skin tone
+1F481 1F3FB 200D 2642 ; minimally-qualified # 💁🏻‍♂ E4.0 man tipping hand: light skin tone
+1F481 1F3FC 200D 2642 FE0F ; fully-qualified # 💁🏼‍♂️ E4.0 man tipping hand: medium-light skin tone
+1F481 1F3FC 200D 2642 ; minimally-qualified # 💁🏼‍♂ E4.0 man tipping hand: medium-light skin tone
+1F481 1F3FD 200D 2642 FE0F ; fully-qualified # 💁🏽‍♂️ E4.0 man tipping hand: medium skin tone
+1F481 1F3FD 200D 2642 ; minimally-qualified # 💁🏽‍♂ E4.0 man tipping hand: medium skin tone
+1F481 1F3FE 200D 2642 FE0F ; fully-qualified # 💁🏾‍♂️ E4.0 man tipping hand: medium-dark skin tone
+1F481 1F3FE 200D 2642 ; minimally-qualified # 💁🏾‍♂ E4.0 man tipping hand: medium-dark skin tone
+1F481 1F3FF 200D 2642 FE0F ; fully-qualified # 💁🏿‍♂️ E4.0 man tipping hand: dark skin tone
+1F481 1F3FF 200D 2642 ; minimally-qualified # 💁🏿‍♂ E4.0 man tipping hand: dark skin tone
+1F481 200D 2640 FE0F ; fully-qualified # 💁‍♀️ E4.0 woman tipping hand
+1F481 200D 2640 ; minimally-qualified # 💁‍♀ E4.0 woman tipping hand
+1F481 1F3FB 200D 2640 FE0F ; fully-qualified # 💁🏻‍♀️ E4.0 woman tipping hand: light skin tone
+1F481 1F3FB 200D 2640 ; minimally-qualified # 💁🏻‍♀ E4.0 woman tipping hand: light skin tone
+1F481 1F3FC 200D 2640 FE0F ; fully-qualified # 💁🏼‍♀️ E4.0 woman tipping hand: medium-light skin tone
+1F481 1F3FC 200D 2640 ; minimally-qualified # 💁🏼‍♀ E4.0 woman tipping hand: medium-light skin tone
+1F481 1F3FD 200D 2640 FE0F ; fully-qualified # 💁🏽‍♀️ E4.0 woman tipping hand: medium skin tone
+1F481 1F3FD 200D 2640 ; minimally-qualified # 💁🏽‍♀ E4.0 woman tipping hand: medium skin tone
+1F481 1F3FE 200D 2640 FE0F ; fully-qualified # 💁🏾‍♀️ E4.0 woman tipping hand: medium-dark skin tone
+1F481 1F3FE 200D 2640 ; minimally-qualified # 💁🏾‍♀ E4.0 woman tipping hand: medium-dark skin tone
+1F481 1F3FF 200D 2640 FE0F ; fully-qualified # 💁🏿‍♀️ E4.0 woman tipping hand: dark skin tone
+1F481 1F3FF 200D 2640 ; minimally-qualified # 💁🏿‍♀ E4.0 woman tipping hand: dark skin tone
+1F64B ; fully-qualified # 🙋 E0.6 person raising hand
+1F64B 1F3FB ; fully-qualified # 🙋🏻 E1.0 person raising hand: light skin tone
+1F64B 1F3FC ; fully-qualified # 🙋🏼 E1.0 person raising hand: medium-light skin tone
+1F64B 1F3FD ; fully-qualified # 🙋🏽 E1.0 person raising hand: medium skin tone
+1F64B 1F3FE ; fully-qualified # 🙋🏾 E1.0 person raising hand: medium-dark skin tone
+1F64B 1F3FF ; fully-qualified # 🙋🏿 E1.0 person raising hand: dark skin tone
+1F64B 200D 2642 FE0F ; fully-qualified # 🙋‍♂️ E4.0 man raising hand
+1F64B 200D 2642 ; minimally-qualified # 🙋‍♂ E4.0 man raising hand
+1F64B 1F3FB 200D 2642 FE0F ; fully-qualified # 🙋🏻‍♂️ E4.0 man raising hand: light skin tone
+1F64B 1F3FB 200D 2642 ; minimally-qualified # 🙋🏻‍♂ E4.0 man raising hand: light skin tone
+1F64B 1F3FC 200D 2642 FE0F ; fully-qualified # 🙋🏼‍♂️ E4.0 man raising hand: medium-light skin tone
+1F64B 1F3FC 200D 2642 ; minimally-qualified # 🙋🏼‍♂ E4.0 man raising hand: medium-light skin tone
+1F64B 1F3FD 200D 2642 FE0F ; fully-qualified # 🙋🏽‍♂️ E4.0 man raising hand: medium skin tone
+1F64B 1F3FD 200D 2642 ; minimally-qualified # 🙋🏽‍♂ E4.0 man raising hand: medium skin tone
+1F64B 1F3FE 200D 2642 FE0F ; fully-qualified # 🙋🏾‍♂️ E4.0 man raising hand: medium-dark skin tone
+1F64B 1F3FE 200D 2642 ; minimally-qualified # 🙋🏾‍♂ E4.0 man raising hand: medium-dark skin tone
+1F64B 1F3FF 200D 2642 FE0F ; fully-qualified # 🙋🏿‍♂️ E4.0 man raising hand: dark skin tone
+1F64B 1F3FF 200D 2642 ; minimally-qualified # 🙋🏿‍♂ E4.0 man raising hand: dark skin tone
+1F64B 200D 2640 FE0F ; fully-qualified # 🙋‍♀️ E4.0 woman raising hand
+1F64B 200D 2640 ; minimally-qualified # 🙋‍♀ E4.0 woman raising hand
+1F64B 1F3FB 200D 2640 FE0F ; fully-qualified # 🙋🏻‍♀️ E4.0 woman raising hand: light skin tone
+1F64B 1F3FB 200D 2640 ; minimally-qualified # 🙋🏻‍♀ E4.0 woman raising hand: light skin tone
+1F64B 1F3FC 200D 2640 FE0F ; fully-qualified # 🙋🏼‍♀️ E4.0 woman raising hand: medium-light skin tone
+1F64B 1F3FC 200D 2640 ; minimally-qualified # 🙋🏼‍♀ E4.0 woman raising hand: medium-light skin tone
+1F64B 1F3FD 200D 2640 FE0F ; fully-qualified # 🙋🏽‍♀️ E4.0 woman raising hand: medium skin tone
+1F64B 1F3FD 200D 2640 ; minimally-qualified # 🙋🏽‍♀ E4.0 woman raising hand: medium skin tone
+1F64B 1F3FE 200D 2640 FE0F ; fully-qualified # 🙋🏾‍♀️ E4.0 woman raising hand: medium-dark skin tone
+1F64B 1F3FE 200D 2640 ; minimally-qualified # 🙋🏾‍♀ E4.0 woman raising hand: medium-dark skin tone
+1F64B 1F3FF 200D 2640 FE0F ; fully-qualified # 🙋🏿‍♀️ E4.0 woman raising hand: dark skin tone
+1F64B 1F3FF 200D 2640 ; minimally-qualified # 🙋🏿‍♀ E4.0 woman raising hand: dark skin tone
+1F9CF ; fully-qualified # 🧏 E12.0 deaf person
+1F9CF 1F3FB ; fully-qualified # 🧏🏻 E12.0 deaf person: light skin tone
+1F9CF 1F3FC ; fully-qualified # 🧏🏼 E12.0 deaf person: medium-light skin tone
+1F9CF 1F3FD ; fully-qualified # 🧏🏽 E12.0 deaf person: medium skin tone
+1F9CF 1F3FE ; fully-qualified # 🧏🏾 E12.0 deaf person: medium-dark skin tone
+1F9CF 1F3FF ; fully-qualified # 🧏🏿 E12.0 deaf person: dark skin tone
+1F9CF 200D 2642 FE0F ; fully-qualified # 🧏‍♂️ E12.0 deaf man
+1F9CF 200D 2642 ; minimally-qualified # 🧏‍♂ E12.0 deaf man
+1F9CF 1F3FB 200D 2642 FE0F ; fully-qualified # 🧏🏻‍♂️ E12.0 deaf man: light skin tone
+1F9CF 1F3FB 200D 2642 ; minimally-qualified # 🧏🏻‍♂ E12.0 deaf man: light skin tone
+1F9CF 1F3FC 200D 2642 FE0F ; fully-qualified # 🧏🏼‍♂️ E12.0 deaf man: medium-light skin tone
+1F9CF 1F3FC 200D 2642 ; minimally-qualified # 🧏🏼‍♂ E12.0 deaf man: medium-light skin tone
+1F9CF 1F3FD 200D 2642 FE0F ; fully-qualified # 🧏🏽‍♂️ E12.0 deaf man: medium skin tone
+1F9CF 1F3FD 200D 2642 ; minimally-qualified # 🧏🏽‍♂ E12.0 deaf man: medium skin tone
+1F9CF 1F3FE 200D 2642 FE0F ; fully-qualified # 🧏🏾‍♂️ E12.0 deaf man: medium-dark skin tone
+1F9CF 1F3FE 200D 2642 ; minimally-qualified # 🧏🏾‍♂ E12.0 deaf man: medium-dark skin tone
+1F9CF 1F3FF 200D 2642 FE0F ; fully-qualified # 🧏🏿‍♂️ E12.0 deaf man: dark skin tone
+1F9CF 1F3FF 200D 2642 ; minimally-qualified # 🧏🏿‍♂ E12.0 deaf man: dark skin tone
+1F9CF 200D 2640 FE0F ; fully-qualified # 🧏‍♀️ E12.0 deaf woman
+1F9CF 200D 2640 ; minimally-qualified # 🧏‍♀ E12.0 deaf woman
+1F9CF 1F3FB 200D 2640 FE0F ; fully-qualified # 🧏🏻‍♀️ E12.0 deaf woman: light skin tone
+1F9CF 1F3FB 200D 2640 ; minimally-qualified # 🧏🏻‍♀ E12.0 deaf woman: light skin tone
+1F9CF 1F3FC 200D 2640 FE0F ; fully-qualified # 🧏🏼‍♀️ E12.0 deaf woman: medium-light skin tone
+1F9CF 1F3FC 200D 2640 ; minimally-qualified # 🧏🏼‍♀ E12.0 deaf woman: medium-light skin tone
+1F9CF 1F3FD 200D 2640 FE0F ; fully-qualified # 🧏🏽‍♀️ E12.0 deaf woman: medium skin tone
+1F9CF 1F3FD 200D 2640 ; minimally-qualified # 🧏🏽‍♀ E12.0 deaf woman: medium skin tone
+1F9CF 1F3FE 200D 2640 FE0F ; fully-qualified # 🧏🏾‍♀️ E12.0 deaf woman: medium-dark skin tone
+1F9CF 1F3FE 200D 2640 ; minimally-qualified # 🧏🏾‍♀ E12.0 deaf woman: medium-dark skin tone
+1F9CF 1F3FF 200D 2640 FE0F ; fully-qualified # 🧏🏿‍♀️ E12.0 deaf woman: dark skin tone
+1F9CF 1F3FF 200D 2640 ; minimally-qualified # 🧏🏿‍♀ E12.0 deaf woman: dark skin tone
+1F647 ; fully-qualified # 🙇 E0.6 person bowing
+1F647 1F3FB ; fully-qualified # 🙇🏻 E1.0 person bowing: light skin tone
+1F647 1F3FC ; fully-qualified # 🙇🏼 E1.0 person bowing: medium-light skin tone
+1F647 1F3FD ; fully-qualified # 🙇🏽 E1.0 person bowing: medium skin tone
+1F647 1F3FE ; fully-qualified # 🙇🏾 E1.0 person bowing: medium-dark skin tone
+1F647 1F3FF ; fully-qualified # 🙇🏿 E1.0 person bowing: dark skin tone
+1F647 200D 2642 FE0F ; fully-qualified # 🙇‍♂️ E4.0 man bowing
+1F647 200D 2642 ; minimally-qualified # 🙇‍♂ E4.0 man bowing
+1F647 1F3FB 200D 2642 FE0F ; fully-qualified # 🙇🏻‍♂️ E4.0 man bowing: light skin tone
+1F647 1F3FB 200D 2642 ; minimally-qualified # 🙇🏻‍♂ E4.0 man bowing: light skin tone
+1F647 1F3FC 200D 2642 FE0F ; fully-qualified # 🙇🏼‍♂️ E4.0 man bowing: medium-light skin tone
+1F647 1F3FC 200D 2642 ; minimally-qualified # 🙇🏼‍♂ E4.0 man bowing: medium-light skin tone
+1F647 1F3FD 200D 2642 FE0F ; fully-qualified # 🙇🏽‍♂️ E4.0 man bowing: medium skin tone
+1F647 1F3FD 200D 2642 ; minimally-qualified # 🙇🏽‍♂ E4.0 man bowing: medium skin tone
+1F647 1F3FE 200D 2642 FE0F ; fully-qualified # 🙇🏾‍♂️ E4.0 man bowing: medium-dark skin tone
+1F647 1F3FE 200D 2642 ; minimally-qualified # 🙇🏾‍♂ E4.0 man bowing: medium-dark skin tone
+1F647 1F3FF 200D 2642 FE0F ; fully-qualified # 🙇🏿‍♂️ E4.0 man bowing: dark skin tone
+1F647 1F3FF 200D 2642 ; minimally-qualified # 🙇🏿‍♂ E4.0 man bowing: dark skin tone
+1F647 200D 2640 FE0F ; fully-qualified # 🙇‍♀️ E4.0 woman bowing
+1F647 200D 2640 ; minimally-qualified # 🙇‍♀ E4.0 woman bowing
+1F647 1F3FB 200D 2640 FE0F ; fully-qualified # 🙇🏻‍♀️ E4.0 woman bowing: light skin tone
+1F647 1F3FB 200D 2640 ; minimally-qualified # 🙇🏻‍♀ E4.0 woman bowing: light skin tone
+1F647 1F3FC 200D 2640 FE0F ; fully-qualified # 🙇🏼‍♀️ E4.0 woman bowing: medium-light skin tone
+1F647 1F3FC 200D 2640 ; minimally-qualified # 🙇🏼‍♀ E4.0 woman bowing: medium-light skin tone
+1F647 1F3FD 200D 2640 FE0F ; fully-qualified # 🙇🏽‍♀️ E4.0 woman bowing: medium skin tone
+1F647 1F3FD 200D 2640 ; minimally-qualified # 🙇🏽‍♀ E4.0 woman bowing: medium skin tone
+1F647 1F3FE 200D 2640 FE0F ; fully-qualified # 🙇🏾‍♀️ E4.0 woman bowing: medium-dark skin tone
+1F647 1F3FE 200D 2640 ; minimally-qualified # 🙇🏾‍♀ E4.0 woman bowing: medium-dark skin tone
+1F647 1F3FF 200D 2640 FE0F ; fully-qualified # 🙇🏿‍♀️ E4.0 woman bowing: dark skin tone
+1F647 1F3FF 200D 2640 ; minimally-qualified # 🙇🏿‍♀ E4.0 woman bowing: dark skin tone
+1F926 ; fully-qualified # 🤦 E3.0 person facepalming
+1F926 1F3FB ; fully-qualified # 🤦🏻 E3.0 person facepalming: light skin tone
+1F926 1F3FC ; fully-qualified # 🤦🏼 E3.0 person facepalming: medium-light skin tone
+1F926 1F3FD ; fully-qualified # 🤦🏽 E3.0 person facepalming: medium skin tone
+1F926 1F3FE ; fully-qualified # 🤦🏾 E3.0 person facepalming: medium-dark skin tone
+1F926 1F3FF ; fully-qualified # 🤦🏿 E3.0 person facepalming: dark skin tone
+1F926 200D 2642 FE0F ; fully-qualified # 🤦‍♂️ E4.0 man facepalming
+1F926 200D 2642 ; minimally-qualified # 🤦‍♂ E4.0 man facepalming
+1F926 1F3FB 200D 2642 FE0F ; fully-qualified # 🤦🏻‍♂️ E4.0 man facepalming: light skin tone
+1F926 1F3FB 200D 2642 ; minimally-qualified # 🤦🏻‍♂ E4.0 man facepalming: light skin tone
+1F926 1F3FC 200D 2642 FE0F ; fully-qualified # 🤦🏼‍♂️ E4.0 man facepalming: medium-light skin tone
+1F926 1F3FC 200D 2642 ; minimally-qualified # 🤦🏼‍♂ E4.0 man facepalming: medium-light skin tone
+1F926 1F3FD 200D 2642 FE0F ; fully-qualified # 🤦🏽‍♂️ E4.0 man facepalming: medium skin tone
+1F926 1F3FD 200D 2642 ; minimally-qualified # 🤦🏽‍♂ E4.0 man facepalming: medium skin tone
+1F926 1F3FE 200D 2642 FE0F ; fully-qualified # 🤦🏾‍♂️ E4.0 man facepalming: medium-dark skin tone
+1F926 1F3FE 200D 2642 ; minimally-qualified # 🤦🏾‍♂ E4.0 man facepalming: medium-dark skin tone
+1F926 1F3FF 200D 2642 FE0F ; fully-qualified # 🤦🏿‍♂️ E4.0 man facepalming: dark skin tone
+1F926 1F3FF 200D 2642 ; minimally-qualified # 🤦🏿‍♂ E4.0 man facepalming: dark skin tone
+1F926 200D 2640 FE0F ; fully-qualified # 🤦‍♀️ E4.0 woman facepalming
+1F926 200D 2640 ; minimally-qualified # 🤦‍♀ E4.0 woman facepalming
+1F926 1F3FB 200D 2640 FE0F ; fully-qualified # 🤦🏻‍♀️ E4.0 woman facepalming: light skin tone
+1F926 1F3FB 200D 2640 ; minimally-qualified # 🤦🏻‍♀ E4.0 woman facepalming: light skin tone
+1F926 1F3FC 200D 2640 FE0F ; fully-qualified # 🤦🏼‍♀️ E4.0 woman facepalming: medium-light skin tone
+1F926 1F3FC 200D 2640 ; minimally-qualified # 🤦🏼‍♀ E4.0 woman facepalming: medium-light skin tone
+1F926 1F3FD 200D 2640 FE0F ; fully-qualified # 🤦🏽‍♀️ E4.0 woman facepalming: medium skin tone
+1F926 1F3FD 200D 2640 ; minimally-qualified # 🤦🏽‍♀ E4.0 woman facepalming: medium skin tone
+1F926 1F3FE 200D 2640 FE0F ; fully-qualified # 🤦🏾‍♀️ E4.0 woman facepalming: medium-dark skin tone
+1F926 1F3FE 200D 2640 ; minimally-qualified # 🤦🏾‍♀ E4.0 woman facepalming: medium-dark skin tone
+1F926 1F3FF 200D 2640 FE0F ; fully-qualified # 🤦🏿‍♀️ E4.0 woman facepalming: dark skin tone
+1F926 1F3FF 200D 2640 ; minimally-qualified # 🤦🏿‍♀ E4.0 woman facepalming: dark skin tone
+1F937 ; fully-qualified # 🤷 E3.0 person shrugging
+1F937 1F3FB ; fully-qualified # 🤷🏻 E3.0 person shrugging: light skin tone
+1F937 1F3FC ; fully-qualified # 🤷🏼 E3.0 person shrugging: medium-light skin tone
+1F937 1F3FD ; fully-qualified # 🤷🏽 E3.0 person shrugging: medium skin tone
+1F937 1F3FE ; fully-qualified # 🤷🏾 E3.0 person shrugging: medium-dark skin tone
+1F937 1F3FF ; fully-qualified # 🤷🏿 E3.0 person shrugging: dark skin tone
+1F937 200D 2642 FE0F ; fully-qualified # 🤷‍♂️ E4.0 man shrugging
+1F937 200D 2642 ; minimally-qualified # 🤷‍♂ E4.0 man shrugging
+1F937 1F3FB 200D 2642 FE0F ; fully-qualified # 🤷🏻‍♂️ E4.0 man shrugging: light skin tone
+1F937 1F3FB 200D 2642 ; minimally-qualified # 🤷🏻‍♂ E4.0 man shrugging: light skin tone
+1F937 1F3FC 200D 2642 FE0F ; fully-qualified # 🤷🏼‍♂️ E4.0 man shrugging: medium-light skin tone
+1F937 1F3FC 200D 2642 ; minimally-qualified # 🤷🏼‍♂ E4.0 man shrugging: medium-light skin tone
+1F937 1F3FD 200D 2642 FE0F ; fully-qualified # 🤷🏽‍♂️ E4.0 man shrugging: medium skin tone
+1F937 1F3FD 200D 2642 ; minimally-qualified # 🤷🏽‍♂ E4.0 man shrugging: medium skin tone
+1F937 1F3FE 200D 2642 FE0F ; fully-qualified # 🤷🏾‍♂️ E4.0 man shrugging: medium-dark skin tone
+1F937 1F3FE 200D 2642 ; minimally-qualified # 🤷🏾‍♂ E4.0 man shrugging: medium-dark skin tone
+1F937 1F3FF 200D 2642 FE0F ; fully-qualified # 🤷🏿‍♂️ E4.0 man shrugging: dark skin tone
+1F937 1F3FF 200D 2642 ; minimally-qualified # 🤷🏿‍♂ E4.0 man shrugging: dark skin tone
+1F937 200D 2640 FE0F ; fully-qualified # 🤷‍♀️ E4.0 woman shrugging
+1F937 200D 2640 ; minimally-qualified # 🤷‍♀ E4.0 woman shrugging
+1F937 1F3FB 200D 2640 FE0F ; fully-qualified # 🤷🏻‍♀️ E4.0 woman shrugging: light skin tone
+1F937 1F3FB 200D 2640 ; minimally-qualified # 🤷🏻‍♀ E4.0 woman shrugging: light skin tone
+1F937 1F3FC 200D 2640 FE0F ; fully-qualified # 🤷🏼‍♀️ E4.0 woman shrugging: medium-light skin tone
+1F937 1F3FC 200D 2640 ; minimally-qualified # 🤷🏼‍♀ E4.0 woman shrugging: medium-light skin tone
+1F937 1F3FD 200D 2640 FE0F ; fully-qualified # 🤷🏽‍♀️ E4.0 woman shrugging: medium skin tone
+1F937 1F3FD 200D 2640 ; minimally-qualified # 🤷🏽‍♀ E4.0 woman shrugging: medium skin tone
+1F937 1F3FE 200D 2640 FE0F ; fully-qualified # 🤷🏾‍♀️ E4.0 woman shrugging: medium-dark skin tone
+1F937 1F3FE 200D 2640 ; minimally-qualified # 🤷🏾‍♀ E4.0 woman shrugging: medium-dark skin tone
+1F937 1F3FF 200D 2640 FE0F ; fully-qualified # 🤷🏿‍♀️ E4.0 woman shrugging: dark skin tone
+1F937 1F3FF 200D 2640 ; minimally-qualified # 🤷🏿‍♀ E4.0 woman shrugging: dark skin tone
+
+# subgroup: person-role
+1F9D1 200D 2695 FE0F ; fully-qualified # 🧑‍⚕️ E12.1 health worker
+1F9D1 200D 2695 ; minimally-qualified # 🧑‍⚕ E12.1 health worker
+1F9D1 1F3FB 200D 2695 FE0F ; fully-qualified # 🧑🏻‍⚕️ E12.1 health worker: light skin tone
+1F9D1 1F3FB 200D 2695 ; minimally-qualified # 🧑🏻‍⚕ E12.1 health worker: light skin tone
+1F9D1 1F3FC 200D 2695 FE0F ; fully-qualified # 🧑🏼‍⚕️ E12.1 health worker: medium-light skin tone
+1F9D1 1F3FC 200D 2695 ; minimally-qualified # 🧑🏼‍⚕ E12.1 health worker: medium-light skin tone
+1F9D1 1F3FD 200D 2695 FE0F ; fully-qualified # 🧑🏽‍⚕️ E12.1 health worker: medium skin tone
+1F9D1 1F3FD 200D 2695 ; minimally-qualified # 🧑🏽‍⚕ E12.1 health worker: medium skin tone
+1F9D1 1F3FE 200D 2695 FE0F ; fully-qualified # 🧑🏾‍⚕️ E12.1 health worker: medium-dark skin tone
+1F9D1 1F3FE 200D 2695 ; minimally-qualified # 🧑🏾‍⚕ E12.1 health worker: medium-dark skin tone
+1F9D1 1F3FF 200D 2695 FE0F ; fully-qualified # 🧑🏿‍⚕️ E12.1 health worker: dark skin tone
+1F9D1 1F3FF 200D 2695 ; minimally-qualified # 🧑🏿‍⚕ E12.1 health worker: dark skin tone
+1F468 200D 2695 FE0F ; fully-qualified # 👨‍⚕️ E4.0 man health worker
+1F468 200D 2695 ; minimally-qualified # 👨‍⚕ E4.0 man health worker
+1F468 1F3FB 200D 2695 FE0F ; fully-qualified # 👨🏻‍⚕️ E4.0 man health worker: light skin tone
+1F468 1F3FB 200D 2695 ; minimally-qualified # 👨🏻‍⚕ E4.0 man health worker: light skin tone
+1F468 1F3FC 200D 2695 FE0F ; fully-qualified # 👨🏼‍⚕️ E4.0 man health worker: medium-light skin tone
+1F468 1F3FC 200D 2695 ; minimally-qualified # 👨🏼‍⚕ E4.0 man health worker: medium-light skin tone
+1F468 1F3FD 200D 2695 FE0F ; fully-qualified # 👨🏽‍⚕️ E4.0 man health worker: medium skin tone
+1F468 1F3FD 200D 2695 ; minimally-qualified # 👨🏽‍⚕ E4.0 man health worker: medium skin tone
+1F468 1F3FE 200D 2695 FE0F ; fully-qualified # 👨🏾‍⚕️ E4.0 man health worker: medium-dark skin tone
+1F468 1F3FE 200D 2695 ; minimally-qualified # 👨🏾‍⚕ E4.0 man health worker: medium-dark skin tone
+1F468 1F3FF 200D 2695 FE0F ; fully-qualified # 👨🏿‍⚕️ E4.0 man health worker: dark skin tone
+1F468 1F3FF 200D 2695 ; minimally-qualified # 👨🏿‍⚕ E4.0 man health worker: dark skin tone
+1F469 200D 2695 FE0F ; fully-qualified # 👩‍⚕️ E4.0 woman health worker
+1F469 200D 2695 ; minimally-qualified # 👩‍⚕ E4.0 woman health worker
+1F469 1F3FB 200D 2695 FE0F ; fully-qualified # 👩🏻‍⚕️ E4.0 woman health worker: light skin tone
+1F469 1F3FB 200D 2695 ; minimally-qualified # 👩🏻‍⚕ E4.0 woman health worker: light skin tone
+1F469 1F3FC 200D 2695 FE0F ; fully-qualified # 👩🏼‍⚕️ E4.0 woman health worker: medium-light skin tone
+1F469 1F3FC 200D 2695 ; minimally-qualified # 👩🏼‍⚕ E4.0 woman health worker: medium-light skin tone
+1F469 1F3FD 200D 2695 FE0F ; fully-qualified # 👩🏽‍⚕️ E4.0 woman health worker: medium skin tone
+1F469 1F3FD 200D 2695 ; minimally-qualified # 👩🏽‍⚕ E4.0 woman health worker: medium skin tone
+1F469 1F3FE 200D 2695 FE0F ; fully-qualified # 👩🏾‍⚕️ E4.0 woman health worker: medium-dark skin tone
+1F469 1F3FE 200D 2695 ; minimally-qualified # 👩🏾‍⚕ E4.0 woman health worker: medium-dark skin tone
+1F469 1F3FF 200D 2695 FE0F ; fully-qualified # 👩🏿‍⚕️ E4.0 woman health worker: dark skin tone
+1F469 1F3FF 200D 2695 ; minimally-qualified # 👩🏿‍⚕ E4.0 woman health worker: dark skin tone
+1F9D1 200D 1F393 ; fully-qualified # 🧑‍🎓 E12.1 student
+1F9D1 1F3FB 200D 1F393 ; fully-qualified # 🧑🏻‍🎓 E12.1 student: light skin tone
+1F9D1 1F3FC 200D 1F393 ; fully-qualified # 🧑🏼‍🎓 E12.1 student: medium-light skin tone
+1F9D1 1F3FD 200D 1F393 ; fully-qualified # 🧑🏽‍🎓 E12.1 student: medium skin tone
+1F9D1 1F3FE 200D 1F393 ; fully-qualified # 🧑🏾‍🎓 E12.1 student: medium-dark skin tone
+1F9D1 1F3FF 200D 1F393 ; fully-qualified # 🧑🏿‍🎓 E12.1 student: dark skin tone
+1F468 200D 1F393 ; fully-qualified # 👨‍🎓 E4.0 man student
+1F468 1F3FB 200D 1F393 ; fully-qualified # 👨🏻‍🎓 E4.0 man student: light skin tone
+1F468 1F3FC 200D 1F393 ; fully-qualified # 👨🏼‍🎓 E4.0 man student: medium-light skin tone
+1F468 1F3FD 200D 1F393 ; fully-qualified # 👨🏽‍🎓 E4.0 man student: medium skin tone
+1F468 1F3FE 200D 1F393 ; fully-qualified # 👨🏾‍🎓 E4.0 man student: medium-dark skin tone
+1F468 1F3FF 200D 1F393 ; fully-qualified # 👨🏿‍🎓 E4.0 man student: dark skin tone
+1F469 200D 1F393 ; fully-qualified # 👩‍🎓 E4.0 woman student
+1F469 1F3FB 200D 1F393 ; fully-qualified # 👩🏻‍🎓 E4.0 woman student: light skin tone
+1F469 1F3FC 200D 1F393 ; fully-qualified # 👩🏼‍🎓 E4.0 woman student: medium-light skin tone
+1F469 1F3FD 200D 1F393 ; fully-qualified # 👩🏽‍🎓 E4.0 woman student: medium skin tone
+1F469 1F3FE 200D 1F393 ; fully-qualified # 👩🏾‍🎓 E4.0 woman student: medium-dark skin tone
+1F469 1F3FF 200D 1F393 ; fully-qualified # 👩🏿‍🎓 E4.0 woman student: dark skin tone
+1F9D1 200D 1F3EB ; fully-qualified # 🧑‍🏫 E12.1 teacher
+1F9D1 1F3FB 200D 1F3EB ; fully-qualified # 🧑🏻‍🏫 E12.1 teacher: light skin tone
+1F9D1 1F3FC 200D 1F3EB ; fully-qualified # 🧑🏼‍🏫 E12.1 teacher: medium-light skin tone
+1F9D1 1F3FD 200D 1F3EB ; fully-qualified # 🧑🏽‍🏫 E12.1 teacher: medium skin tone
+1F9D1 1F3FE 200D 1F3EB ; fully-qualified # 🧑🏾‍🏫 E12.1 teacher: medium-dark skin tone
+1F9D1 1F3FF 200D 1F3EB ; fully-qualified # 🧑🏿‍🏫 E12.1 teacher: dark skin tone
+1F468 200D 1F3EB ; fully-qualified # 👨‍🏫 E4.0 man teacher
+1F468 1F3FB 200D 1F3EB ; fully-qualified # 👨🏻‍🏫 E4.0 man teacher: light skin tone
+1F468 1F3FC 200D 1F3EB ; fully-qualified # 👨🏼‍🏫 E4.0 man teacher: medium-light skin tone
+1F468 1F3FD 200D 1F3EB ; fully-qualified # 👨🏽‍🏫 E4.0 man teacher: medium skin tone
+1F468 1F3FE 200D 1F3EB ; fully-qualified # 👨🏾‍🏫 E4.0 man teacher: medium-dark skin tone
+1F468 1F3FF 200D 1F3EB ; fully-qualified # 👨🏿‍🏫 E4.0 man teacher: dark skin tone
+1F469 200D 1F3EB ; fully-qualified # 👩‍🏫 E4.0 woman teacher
+1F469 1F3FB 200D 1F3EB ; fully-qualified # 👩🏻‍🏫 E4.0 woman teacher: light skin tone
+1F469 1F3FC 200D 1F3EB ; fully-qualified # 👩🏼‍🏫 E4.0 woman teacher: medium-light skin tone
+1F469 1F3FD 200D 1F3EB ; fully-qualified # 👩🏽‍🏫 E4.0 woman teacher: medium skin tone
+1F469 1F3FE 200D 1F3EB ; fully-qualified # 👩🏾‍🏫 E4.0 woman teacher: medium-dark skin tone
+1F469 1F3FF 200D 1F3EB ; fully-qualified # 👩🏿‍🏫 E4.0 woman teacher: dark skin tone
+1F9D1 200D 2696 FE0F ; fully-qualified # 🧑‍⚖️ E12.1 judge
+1F9D1 200D 2696 ; minimally-qualified # 🧑‍⚖ E12.1 judge
+1F9D1 1F3FB 200D 2696 FE0F ; fully-qualified # 🧑🏻‍⚖️ E12.1 judge: light skin tone
+1F9D1 1F3FB 200D 2696 ; minimally-qualified # 🧑🏻‍⚖ E12.1 judge: light skin tone
+1F9D1 1F3FC 200D 2696 FE0F ; fully-qualified # 🧑🏼‍⚖️ E12.1 judge: medium-light skin tone
+1F9D1 1F3FC 200D 2696 ; minimally-qualified # 🧑🏼‍⚖ E12.1 judge: medium-light skin tone
+1F9D1 1F3FD 200D 2696 FE0F ; fully-qualified # 🧑🏽‍⚖️ E12.1 judge: medium skin tone
+1F9D1 1F3FD 200D 2696 ; minimally-qualified # 🧑🏽‍⚖ E12.1 judge: medium skin tone
+1F9D1 1F3FE 200D 2696 FE0F ; fully-qualified # 🧑🏾‍⚖️ E12.1 judge: medium-dark skin tone
+1F9D1 1F3FE 200D 2696 ; minimally-qualified # 🧑🏾‍⚖ E12.1 judge: medium-dark skin tone
+1F9D1 1F3FF 200D 2696 FE0F ; fully-qualified # 🧑🏿‍⚖️ E12.1 judge: dark skin tone
+1F9D1 1F3FF 200D 2696 ; minimally-qualified # 🧑🏿‍⚖ E12.1 judge: dark skin tone
+1F468 200D 2696 FE0F ; fully-qualified # 👨‍⚖️ E4.0 man judge
+1F468 200D 2696 ; minimally-qualified # 👨‍⚖ E4.0 man judge
+1F468 1F3FB 200D 2696 FE0F ; fully-qualified # 👨🏻‍⚖️ E4.0 man judge: light skin tone
+1F468 1F3FB 200D 2696 ; minimally-qualified # 👨🏻‍⚖ E4.0 man judge: light skin tone
+1F468 1F3FC 200D 2696 FE0F ; fully-qualified # 👨🏼‍⚖️ E4.0 man judge: medium-light skin tone
+1F468 1F3FC 200D 2696 ; minimally-qualified # 👨🏼‍⚖ E4.0 man judge: medium-light skin tone
+1F468 1F3FD 200D 2696 FE0F ; fully-qualified # 👨🏽‍⚖️ E4.0 man judge: medium skin tone
+1F468 1F3FD 200D 2696 ; minimally-qualified # 👨🏽‍⚖ E4.0 man judge: medium skin tone
+1F468 1F3FE 200D 2696 FE0F ; fully-qualified # 👨🏾‍⚖️ E4.0 man judge: medium-dark skin tone
+1F468 1F3FE 200D 2696 ; minimally-qualified # 👨🏾‍⚖ E4.0 man judge: medium-dark skin tone
+1F468 1F3FF 200D 2696 FE0F ; fully-qualified # 👨🏿‍⚖️ E4.0 man judge: dark skin tone
+1F468 1F3FF 200D 2696 ; minimally-qualified # 👨🏿‍⚖ E4.0 man judge: dark skin tone
+1F469 200D 2696 FE0F ; fully-qualified # 👩‍⚖️ E4.0 woman judge
+1F469 200D 2696 ; minimally-qualified # 👩‍⚖ E4.0 woman judge
+1F469 1F3FB 200D 2696 FE0F ; fully-qualified # 👩🏻‍⚖️ E4.0 woman judge: light skin tone
+1F469 1F3FB 200D 2696 ; minimally-qualified # 👩🏻‍⚖ E4.0 woman judge: light skin tone
+1F469 1F3FC 200D 2696 FE0F ; fully-qualified # 👩🏼‍⚖️ E4.0 woman judge: medium-light skin tone
+1F469 1F3FC 200D 2696 ; minimally-qualified # 👩🏼‍⚖ E4.0 woman judge: medium-light skin tone
+1F469 1F3FD 200D 2696 FE0F ; fully-qualified # 👩🏽‍⚖️ E4.0 woman judge: medium skin tone
+1F469 1F3FD 200D 2696 ; minimally-qualified # 👩🏽‍⚖ E4.0 woman judge: medium skin tone
+1F469 1F3FE 200D 2696 FE0F ; fully-qualified # 👩🏾‍⚖️ E4.0 woman judge: medium-dark skin tone
+1F469 1F3FE 200D 2696 ; minimally-qualified # 👩🏾‍⚖ E4.0 woman judge: medium-dark skin tone
+1F469 1F3FF 200D 2696 FE0F ; fully-qualified # 👩🏿‍⚖️ E4.0 woman judge: dark skin tone
+1F469 1F3FF 200D 2696 ; minimally-qualified # 👩🏿‍⚖ E4.0 woman judge: dark skin tone
+1F9D1 200D 1F33E ; fully-qualified # 🧑‍🌾 E12.1 farmer
+1F9D1 1F3FB 200D 1F33E ; fully-qualified # 🧑🏻‍🌾 E12.1 farmer: light skin tone
+1F9D1 1F3FC 200D 1F33E ; fully-qualified # 🧑🏼‍🌾 E12.1 farmer: medium-light skin tone
+1F9D1 1F3FD 200D 1F33E ; fully-qualified # 🧑🏽‍🌾 E12.1 farmer: medium skin tone
+1F9D1 1F3FE 200D 1F33E ; fully-qualified # 🧑🏾‍🌾 E12.1 farmer: medium-dark skin tone
+1F9D1 1F3FF 200D 1F33E ; fully-qualified # 🧑🏿‍🌾 E12.1 farmer: dark skin tone
+1F468 200D 1F33E ; fully-qualified # 👨‍🌾 E4.0 man farmer
+1F468 1F3FB 200D 1F33E ; fully-qualified # 👨🏻‍🌾 E4.0 man farmer: light skin tone
+1F468 1F3FC 200D 1F33E ; fully-qualified # 👨🏼‍🌾 E4.0 man farmer: medium-light skin tone
+1F468 1F3FD 200D 1F33E ; fully-qualified # 👨🏽‍🌾 E4.0 man farmer: medium skin tone
+1F468 1F3FE 200D 1F33E ; fully-qualified # 👨🏾‍🌾 E4.0 man farmer: medium-dark skin tone
+1F468 1F3FF 200D 1F33E ; fully-qualified # 👨🏿‍🌾 E4.0 man farmer: dark skin tone
+1F469 200D 1F33E ; fully-qualified # 👩‍🌾 E4.0 woman farmer
+1F469 1F3FB 200D 1F33E ; fully-qualified # 👩🏻‍🌾 E4.0 woman farmer: light skin tone
+1F469 1F3FC 200D 1F33E ; fully-qualified # 👩🏼‍🌾 E4.0 woman farmer: medium-light skin tone
+1F469 1F3FD 200D 1F33E ; fully-qualified # 👩🏽‍🌾 E4.0 woman farmer: medium skin tone
+1F469 1F3FE 200D 1F33E ; fully-qualified # 👩🏾‍🌾 E4.0 woman farmer: medium-dark skin tone
+1F469 1F3FF 200D 1F33E ; fully-qualified # 👩🏿‍🌾 E4.0 woman farmer: dark skin tone
+1F9D1 200D 1F373 ; fully-qualified # 🧑‍🍳 E12.1 cook
+1F9D1 1F3FB 200D 1F373 ; fully-qualified # 🧑🏻‍🍳 E12.1 cook: light skin tone
+1F9D1 1F3FC 200D 1F373 ; fully-qualified # 🧑🏼‍🍳 E12.1 cook: medium-light skin tone
+1F9D1 1F3FD 200D 1F373 ; fully-qualified # 🧑🏽‍🍳 E12.1 cook: medium skin tone
+1F9D1 1F3FE 200D 1F373 ; fully-qualified # 🧑🏾‍🍳 E12.1 cook: medium-dark skin tone
+1F9D1 1F3FF 200D 1F373 ; fully-qualified # 🧑🏿‍🍳 E12.1 cook: dark skin tone
+1F468 200D 1F373 ; fully-qualified # 👨‍🍳 E4.0 man cook
+1F468 1F3FB 200D 1F373 ; fully-qualified # 👨🏻‍🍳 E4.0 man cook: light skin tone
+1F468 1F3FC 200D 1F373 ; fully-qualified # 👨🏼‍🍳 E4.0 man cook: medium-light skin tone
+1F468 1F3FD 200D 1F373 ; fully-qualified # 👨🏽‍🍳 E4.0 man cook: medium skin tone
+1F468 1F3FE 200D 1F373 ; fully-qualified # 👨🏾‍🍳 E4.0 man cook: medium-dark skin tone
+1F468 1F3FF 200D 1F373 ; fully-qualified # 👨🏿‍🍳 E4.0 man cook: dark skin tone
+1F469 200D 1F373 ; fully-qualified # 👩‍🍳 E4.0 woman cook
+1F469 1F3FB 200D 1F373 ; fully-qualified # 👩🏻‍🍳 E4.0 woman cook: light skin tone
+1F469 1F3FC 200D 1F373 ; fully-qualified # 👩🏼‍🍳 E4.0 woman cook: medium-light skin tone
+1F469 1F3FD 200D 1F373 ; fully-qualified # 👩🏽‍🍳 E4.0 woman cook: medium skin tone
+1F469 1F3FE 200D 1F373 ; fully-qualified # 👩🏾‍🍳 E4.0 woman cook: medium-dark skin tone
+1F469 1F3FF 200D 1F373 ; fully-qualified # 👩🏿‍🍳 E4.0 woman cook: dark skin tone
+1F9D1 200D 1F527 ; fully-qualified # 🧑‍🔧 E12.1 mechanic
+1F9D1 1F3FB 200D 1F527 ; fully-qualified # 🧑🏻‍🔧 E12.1 mechanic: light skin tone
+1F9D1 1F3FC 200D 1F527 ; fully-qualified # 🧑🏼‍🔧 E12.1 mechanic: medium-light skin tone
+1F9D1 1F3FD 200D 1F527 ; fully-qualified # 🧑🏽‍🔧 E12.1 mechanic: medium skin tone
+1F9D1 1F3FE 200D 1F527 ; fully-qualified # 🧑🏾‍🔧 E12.1 mechanic: medium-dark skin tone
+1F9D1 1F3FF 200D 1F527 ; fully-qualified # 🧑🏿‍🔧 E12.1 mechanic: dark skin tone
+1F468 200D 1F527 ; fully-qualified # 👨‍🔧 E4.0 man mechanic
+1F468 1F3FB 200D 1F527 ; fully-qualified # 👨🏻‍🔧 E4.0 man mechanic: light skin tone
+1F468 1F3FC 200D 1F527 ; fully-qualified # 👨🏼‍🔧 E4.0 man mechanic: medium-light skin tone
+1F468 1F3FD 200D 1F527 ; fully-qualified # 👨🏽‍🔧 E4.0 man mechanic: medium skin tone
+1F468 1F3FE 200D 1F527 ; fully-qualified # 👨🏾‍🔧 E4.0 man mechanic: medium-dark skin tone
+1F468 1F3FF 200D 1F527 ; fully-qualified # 👨🏿‍🔧 E4.0 man mechanic: dark skin tone
+1F469 200D 1F527 ; fully-qualified # 👩‍🔧 E4.0 woman mechanic
+1F469 1F3FB 200D 1F527 ; fully-qualified # 👩🏻‍🔧 E4.0 woman mechanic: light skin tone
+1F469 1F3FC 200D 1F527 ; fully-qualified # 👩🏼‍🔧 E4.0 woman mechanic: medium-light skin tone
+1F469 1F3FD 200D 1F527 ; fully-qualified # 👩🏽‍🔧 E4.0 woman mechanic: medium skin tone
+1F469 1F3FE 200D 1F527 ; fully-qualified # 👩🏾‍🔧 E4.0 woman mechanic: medium-dark skin tone
+1F469 1F3FF 200D 1F527 ; fully-qualified # 👩🏿‍🔧 E4.0 woman mechanic: dark skin tone
+1F9D1 200D 1F3ED ; fully-qualified # 🧑‍🏭 E12.1 factory worker
+1F9D1 1F3FB 200D 1F3ED ; fully-qualified # 🧑🏻‍🏭 E12.1 factory worker: light skin tone
+1F9D1 1F3FC 200D 1F3ED ; fully-qualified # 🧑🏼‍🏭 E12.1 factory worker: medium-light skin tone
+1F9D1 1F3FD 200D 1F3ED ; fully-qualified # 🧑🏽‍🏭 E12.1 factory worker: medium skin tone
+1F9D1 1F3FE 200D 1F3ED ; fully-qualified # 🧑🏾‍🏭 E12.1 factory worker: medium-dark skin tone
+1F9D1 1F3FF 200D 1F3ED ; fully-qualified # 🧑🏿‍🏭 E12.1 factory worker: dark skin tone
+1F468 200D 1F3ED ; fully-qualified # 👨‍🏭 E4.0 man factory worker
+1F468 1F3FB 200D 1F3ED ; fully-qualified # 👨🏻‍🏭 E4.0 man factory worker: light skin tone
+1F468 1F3FC 200D 1F3ED ; fully-qualified # 👨🏼‍🏭 E4.0 man factory worker: medium-light skin tone
+1F468 1F3FD 200D 1F3ED ; fully-qualified # 👨🏽‍🏭 E4.0 man factory worker: medium skin tone
+1F468 1F3FE 200D 1F3ED ; fully-qualified # 👨🏾‍🏭 E4.0 man factory worker: medium-dark skin tone
+1F468 1F3FF 200D 1F3ED ; fully-qualified # 👨🏿‍🏭 E4.0 man factory worker: dark skin tone
+1F469 200D 1F3ED ; fully-qualified # 👩‍🏭 E4.0 woman factory worker
+1F469 1F3FB 200D 1F3ED ; fully-qualified # 👩🏻‍🏭 E4.0 woman factory worker: light skin tone
+1F469 1F3FC 200D 1F3ED ; fully-qualified # 👩🏼‍🏭 E4.0 woman factory worker: medium-light skin tone
+1F469 1F3FD 200D 1F3ED ; fully-qualified # 👩🏽‍🏭 E4.0 woman factory worker: medium skin tone
+1F469 1F3FE 200D 1F3ED ; fully-qualified # 👩🏾‍🏭 E4.0 woman factory worker: medium-dark skin tone
+1F469 1F3FF 200D 1F3ED ; fully-qualified # 👩🏿‍🏭 E4.0 woman factory worker: dark skin tone
+1F9D1 200D 1F4BC ; fully-qualified # 🧑‍💼 E12.1 office worker
+1F9D1 1F3FB 200D 1F4BC ; fully-qualified # 🧑🏻‍💼 E12.1 office worker: light skin tone
+1F9D1 1F3FC 200D 1F4BC ; fully-qualified # 🧑🏼‍💼 E12.1 office worker: medium-light skin tone
+1F9D1 1F3FD 200D 1F4BC ; fully-qualified # 🧑🏽‍💼 E12.1 office worker: medium skin tone
+1F9D1 1F3FE 200D 1F4BC ; fully-qualified # 🧑🏾‍💼 E12.1 office worker: medium-dark skin tone
+1F9D1 1F3FF 200D 1F4BC ; fully-qualified # 🧑🏿‍💼 E12.1 office worker: dark skin tone
+1F468 200D 1F4BC ; fully-qualified # 👨‍💼 E4.0 man office worker
+1F468 1F3FB 200D 1F4BC ; fully-qualified # 👨🏻‍💼 E4.0 man office worker: light skin tone
+1F468 1F3FC 200D 1F4BC ; fully-qualified # 👨🏼‍💼 E4.0 man office worker: medium-light skin tone
+1F468 1F3FD 200D 1F4BC ; fully-qualified # 👨🏽‍💼 E4.0 man office worker: medium skin tone
+1F468 1F3FE 200D 1F4BC ; fully-qualified # 👨🏾‍💼 E4.0 man office worker: medium-dark skin tone
+1F468 1F3FF 200D 1F4BC ; fully-qualified # 👨🏿‍💼 E4.0 man office worker: dark skin tone
+1F469 200D 1F4BC ; fully-qualified # 👩‍💼 E4.0 woman office worker
+1F469 1F3FB 200D 1F4BC ; fully-qualified # 👩🏻‍💼 E4.0 woman office worker: light skin tone
+1F469 1F3FC 200D 1F4BC ; fully-qualified # 👩🏼‍💼 E4.0 woman office worker: medium-light skin tone
+1F469 1F3FD 200D 1F4BC ; fully-qualified # 👩🏽‍💼 E4.0 woman office worker: medium skin tone
+1F469 1F3FE 200D 1F4BC ; fully-qualified # 👩🏾‍💼 E4.0 woman office worker: medium-dark skin tone
+1F469 1F3FF 200D 1F4BC ; fully-qualified # 👩🏿‍💼 E4.0 woman office worker: dark skin tone
+1F9D1 200D 1F52C ; fully-qualified # 🧑‍🔬 E12.1 scientist
+1F9D1 1F3FB 200D 1F52C ; fully-qualified # 🧑🏻‍🔬 E12.1 scientist: light skin tone
+1F9D1 1F3FC 200D 1F52C ; fully-qualified # 🧑🏼‍🔬 E12.1 scientist: medium-light skin tone
+1F9D1 1F3FD 200D 1F52C ; fully-qualified # 🧑🏽‍🔬 E12.1 scientist: medium skin tone
+1F9D1 1F3FE 200D 1F52C ; fully-qualified # 🧑🏾‍🔬 E12.1 scientist: medium-dark skin tone
+1F9D1 1F3FF 200D 1F52C ; fully-qualified # 🧑🏿‍🔬 E12.1 scientist: dark skin tone
+1F468 200D 1F52C ; fully-qualified # 👨‍🔬 E4.0 man scientist
+1F468 1F3FB 200D 1F52C ; fully-qualified # 👨🏻‍🔬 E4.0 man scientist: light skin tone
+1F468 1F3FC 200D 1F52C ; fully-qualified # 👨🏼‍🔬 E4.0 man scientist: medium-light skin tone
+1F468 1F3FD 200D 1F52C ; fully-qualified # 👨🏽‍🔬 E4.0 man scientist: medium skin tone
+1F468 1F3FE 200D 1F52C ; fully-qualified # 👨🏾‍🔬 E4.0 man scientist: medium-dark skin tone
+1F468 1F3FF 200D 1F52C ; fully-qualified # 👨🏿‍🔬 E4.0 man scientist: dark skin tone
+1F469 200D 1F52C ; fully-qualified # 👩‍🔬 E4.0 woman scientist
+1F469 1F3FB 200D 1F52C ; fully-qualified # 👩🏻‍🔬 E4.0 woman scientist: light skin tone
+1F469 1F3FC 200D 1F52C ; fully-qualified # 👩🏼‍🔬 E4.0 woman scientist: medium-light skin tone
+1F469 1F3FD 200D 1F52C ; fully-qualified # 👩🏽‍🔬 E4.0 woman scientist: medium skin tone
+1F469 1F3FE 200D 1F52C ; fully-qualified # 👩🏾‍🔬 E4.0 woman scientist: medium-dark skin tone
+1F469 1F3FF 200D 1F52C ; fully-qualified # 👩🏿‍🔬 E4.0 woman scientist: dark skin tone
+1F9D1 200D 1F4BB ; fully-qualified # 🧑‍💻 E12.1 technologist
+1F9D1 1F3FB 200D 1F4BB ; fully-qualified # 🧑🏻‍💻 E12.1 technologist: light skin tone
+1F9D1 1F3FC 200D 1F4BB ; fully-qualified # 🧑🏼‍💻 E12.1 technologist: medium-light skin tone
+1F9D1 1F3FD 200D 1F4BB ; fully-qualified # 🧑🏽‍💻 E12.1 technologist: medium skin tone
+1F9D1 1F3FE 200D 1F4BB ; fully-qualified # 🧑🏾‍💻 E12.1 technologist: medium-dark skin tone
+1F9D1 1F3FF 200D 1F4BB ; fully-qualified # 🧑🏿‍💻 E12.1 technologist: dark skin tone
+1F468 200D 1F4BB ; fully-qualified # 👨‍💻 E4.0 man technologist
+1F468 1F3FB 200D 1F4BB ; fully-qualified # 👨🏻‍💻 E4.0 man technologist: light skin tone
+1F468 1F3FC 200D 1F4BB ; fully-qualified # 👨🏼‍💻 E4.0 man technologist: medium-light skin tone
+1F468 1F3FD 200D 1F4BB ; fully-qualified # 👨🏽‍💻 E4.0 man technologist: medium skin tone
+1F468 1F3FE 200D 1F4BB ; fully-qualified # 👨🏾‍💻 E4.0 man technologist: medium-dark skin tone
+1F468 1F3FF 200D 1F4BB ; fully-qualified # 👨🏿‍💻 E4.0 man technologist: dark skin tone
+1F469 200D 1F4BB ; fully-qualified # 👩‍💻 E4.0 woman technologist
+1F469 1F3FB 200D 1F4BB ; fully-qualified # 👩🏻‍💻 E4.0 woman technologist: light skin tone
+1F469 1F3FC 200D 1F4BB ; fully-qualified # 👩🏼‍💻 E4.0 woman technologist: medium-light skin tone
+1F469 1F3FD 200D 1F4BB ; fully-qualified # 👩🏽‍💻 E4.0 woman technologist: medium skin tone
+1F469 1F3FE 200D 1F4BB ; fully-qualified # 👩🏾‍💻 E4.0 woman technologist: medium-dark skin tone
+1F469 1F3FF 200D 1F4BB ; fully-qualified # 👩🏿‍💻 E4.0 woman technologist: dark skin tone
+1F9D1 200D 1F3A4 ; fully-qualified # 🧑‍🎤 E12.1 singer
+1F9D1 1F3FB 200D 1F3A4 ; fully-qualified # 🧑🏻‍🎤 E12.1 singer: light skin tone
+1F9D1 1F3FC 200D 1F3A4 ; fully-qualified # 🧑🏼‍🎤 E12.1 singer: medium-light skin tone
+1F9D1 1F3FD 200D 1F3A4 ; fully-qualified # 🧑🏽‍🎤 E12.1 singer: medium skin tone
+1F9D1 1F3FE 200D 1F3A4 ; fully-qualified # 🧑🏾‍🎤 E12.1 singer: medium-dark skin tone
+1F9D1 1F3FF 200D 1F3A4 ; fully-qualified # 🧑🏿‍🎤 E12.1 singer: dark skin tone
+1F468 200D 1F3A4 ; fully-qualified # 👨‍🎤 E4.0 man singer
+1F468 1F3FB 200D 1F3A4 ; fully-qualified # 👨🏻‍🎤 E4.0 man singer: light skin tone
+1F468 1F3FC 200D 1F3A4 ; fully-qualified # 👨🏼‍🎤 E4.0 man singer: medium-light skin tone
+1F468 1F3FD 200D 1F3A4 ; fully-qualified # 👨🏽‍🎤 E4.0 man singer: medium skin tone
+1F468 1F3FE 200D 1F3A4 ; fully-qualified # 👨🏾‍🎤 E4.0 man singer: medium-dark skin tone
+1F468 1F3FF 200D 1F3A4 ; fully-qualified # 👨🏿‍🎤 E4.0 man singer: dark skin tone
+1F469 200D 1F3A4 ; fully-qualified # 👩‍🎤 E4.0 woman singer
+1F469 1F3FB 200D 1F3A4 ; fully-qualified # 👩🏻‍🎤 E4.0 woman singer: light skin tone
+1F469 1F3FC 200D 1F3A4 ; fully-qualified # 👩🏼‍🎤 E4.0 woman singer: medium-light skin tone
+1F469 1F3FD 200D 1F3A4 ; fully-qualified # 👩🏽‍🎤 E4.0 woman singer: medium skin tone
+1F469 1F3FE 200D 1F3A4 ; fully-qualified # 👩🏾‍🎤 E4.0 woman singer: medium-dark skin tone
+1F469 1F3FF 200D 1F3A4 ; fully-qualified # 👩🏿‍🎤 E4.0 woman singer: dark skin tone
+1F9D1 200D 1F3A8 ; fully-qualified # 🧑‍🎨 E12.1 artist
+1F9D1 1F3FB 200D 1F3A8 ; fully-qualified # 🧑🏻‍🎨 E12.1 artist: light skin tone
+1F9D1 1F3FC 200D 1F3A8 ; fully-qualified # 🧑🏼‍🎨 E12.1 artist: medium-light skin tone
+1F9D1 1F3FD 200D 1F3A8 ; fully-qualified # 🧑🏽‍🎨 E12.1 artist: medium skin tone
+1F9D1 1F3FE 200D 1F3A8 ; fully-qualified # 🧑🏾‍🎨 E12.1 artist: medium-dark skin tone
+1F9D1 1F3FF 200D 1F3A8 ; fully-qualified # 🧑🏿‍🎨 E12.1 artist: dark skin tone
+1F468 200D 1F3A8 ; fully-qualified # 👨‍🎨 E4.0 man artist
+1F468 1F3FB 200D 1F3A8 ; fully-qualified # 👨🏻‍🎨 E4.0 man artist: light skin tone
+1F468 1F3FC 200D 1F3A8 ; fully-qualified # 👨🏼‍🎨 E4.0 man artist: medium-light skin tone
+1F468 1F3FD 200D 1F3A8 ; fully-qualified # 👨🏽‍🎨 E4.0 man artist: medium skin tone
+1F468 1F3FE 200D 1F3A8 ; fully-qualified # 👨🏾‍🎨 E4.0 man artist: medium-dark skin tone
+1F468 1F3FF 200D 1F3A8 ; fully-qualified # 👨🏿‍🎨 E4.0 man artist: dark skin tone
+1F469 200D 1F3A8 ; fully-qualified # 👩‍🎨 E4.0 woman artist
+1F469 1F3FB 200D 1F3A8 ; fully-qualified # 👩🏻‍🎨 E4.0 woman artist: light skin tone
+1F469 1F3FC 200D 1F3A8 ; fully-qualified # 👩🏼‍🎨 E4.0 woman artist: medium-light skin tone
+1F469 1F3FD 200D 1F3A8 ; fully-qualified # 👩🏽‍🎨 E4.0 woman artist: medium skin tone
+1F469 1F3FE 200D 1F3A8 ; fully-qualified # 👩🏾‍🎨 E4.0 woman artist: medium-dark skin tone
+1F469 1F3FF 200D 1F3A8 ; fully-qualified # 👩🏿‍🎨 E4.0 woman artist: dark skin tone
+1F9D1 200D 2708 FE0F ; fully-qualified # 🧑‍✈️ E12.1 pilot
+1F9D1 200D 2708 ; minimally-qualified # 🧑‍✈ E12.1 pilot
+1F9D1 1F3FB 200D 2708 FE0F ; fully-qualified # 🧑🏻‍✈️ E12.1 pilot: light skin tone
+1F9D1 1F3FB 200D 2708 ; minimally-qualified # 🧑🏻‍✈ E12.1 pilot: light skin tone
+1F9D1 1F3FC 200D 2708 FE0F ; fully-qualified # 🧑🏼‍✈️ E12.1 pilot: medium-light skin tone
+1F9D1 1F3FC 200D 2708 ; minimally-qualified # 🧑🏼‍✈ E12.1 pilot: medium-light skin tone
+1F9D1 1F3FD 200D 2708 FE0F ; fully-qualified # 🧑🏽‍✈️ E12.1 pilot: medium skin tone
+1F9D1 1F3FD 200D 2708 ; minimally-qualified # 🧑🏽‍✈ E12.1 pilot: medium skin tone
+1F9D1 1F3FE 200D 2708 FE0F ; fully-qualified # 🧑🏾‍✈️ E12.1 pilot: medium-dark skin tone
+1F9D1 1F3FE 200D 2708 ; minimally-qualified # 🧑🏾‍✈ E12.1 pilot: medium-dark skin tone
+1F9D1 1F3FF 200D 2708 FE0F ; fully-qualified # 🧑🏿‍✈️ E12.1 pilot: dark skin tone
+1F9D1 1F3FF 200D 2708 ; minimally-qualified # 🧑🏿‍✈ E12.1 pilot: dark skin tone
+1F468 200D 2708 FE0F ; fully-qualified # 👨‍✈️ E4.0 man pilot
+1F468 200D 2708 ; minimally-qualified # 👨‍✈ E4.0 man pilot
+1F468 1F3FB 200D 2708 FE0F ; fully-qualified # 👨🏻‍✈️ E4.0 man pilot: light skin tone
+1F468 1F3FB 200D 2708 ; minimally-qualified # 👨🏻‍✈ E4.0 man pilot: light skin tone
+1F468 1F3FC 200D 2708 FE0F ; fully-qualified # 👨🏼‍✈️ E4.0 man pilot: medium-light skin tone
+1F468 1F3FC 200D 2708 ; minimally-qualified # 👨🏼‍✈ E4.0 man pilot: medium-light skin tone
+1F468 1F3FD 200D 2708 FE0F ; fully-qualified # 👨🏽‍✈️ E4.0 man pilot: medium skin tone
+1F468 1F3FD 200D 2708 ; minimally-qualified # 👨🏽‍✈ E4.0 man pilot: medium skin tone
+1F468 1F3FE 200D 2708 FE0F ; fully-qualified # 👨🏾‍✈️ E4.0 man pilot: medium-dark skin tone
+1F468 1F3FE 200D 2708 ; minimally-qualified # 👨🏾‍✈ E4.0 man pilot: medium-dark skin tone
+1F468 1F3FF 200D 2708 FE0F ; fully-qualified # 👨🏿‍✈️ E4.0 man pilot: dark skin tone
+1F468 1F3FF 200D 2708 ; minimally-qualified # 👨🏿‍✈ E4.0 man pilot: dark skin tone
+1F469 200D 2708 FE0F ; fully-qualified # 👩‍✈️ E4.0 woman pilot
+1F469 200D 2708 ; minimally-qualified # 👩‍✈ E4.0 woman pilot
+1F469 1F3FB 200D 2708 FE0F ; fully-qualified # 👩🏻‍✈️ E4.0 woman pilot: light skin tone
+1F469 1F3FB 200D 2708 ; minimally-qualified # 👩🏻‍✈ E4.0 woman pilot: light skin tone
+1F469 1F3FC 200D 2708 FE0F ; fully-qualified # 👩🏼‍✈️ E4.0 woman pilot: medium-light skin tone
+1F469 1F3FC 200D 2708 ; minimally-qualified # 👩🏼‍✈ E4.0 woman pilot: medium-light skin tone
+1F469 1F3FD 200D 2708 FE0F ; fully-qualified # 👩🏽‍✈️ E4.0 woman pilot: medium skin tone
+1F469 1F3FD 200D 2708 ; minimally-qualified # 👩🏽‍✈ E4.0 woman pilot: medium skin tone
+1F469 1F3FE 200D 2708 FE0F ; fully-qualified # 👩🏾‍✈️ E4.0 woman pilot: medium-dark skin tone
+1F469 1F3FE 200D 2708 ; minimally-qualified # 👩🏾‍✈ E4.0 woman pilot: medium-dark skin tone
+1F469 1F3FF 200D 2708 FE0F ; fully-qualified # 👩🏿‍✈️ E4.0 woman pilot: dark skin tone
+1F469 1F3FF 200D 2708 ; minimally-qualified # 👩🏿‍✈ E4.0 woman pilot: dark skin tone
+1F9D1 200D 1F680 ; fully-qualified # 🧑‍🚀 E12.1 astronaut
+1F9D1 1F3FB 200D 1F680 ; fully-qualified # 🧑🏻‍🚀 E12.1 astronaut: light skin tone
+1F9D1 1F3FC 200D 1F680 ; fully-qualified # 🧑🏼‍🚀 E12.1 astronaut: medium-light skin tone
+1F9D1 1F3FD 200D 1F680 ; fully-qualified # 🧑🏽‍🚀 E12.1 astronaut: medium skin tone
+1F9D1 1F3FE 200D 1F680 ; fully-qualified # 🧑🏾‍🚀 E12.1 astronaut: medium-dark skin tone
+1F9D1 1F3FF 200D 1F680 ; fully-qualified # 🧑🏿‍🚀 E12.1 astronaut: dark skin tone
+1F468 200D 1F680 ; fully-qualified # 👨‍🚀 E4.0 man astronaut
+1F468 1F3FB 200D 1F680 ; fully-qualified # 👨🏻‍🚀 E4.0 man astronaut: light skin tone
+1F468 1F3FC 200D 1F680 ; fully-qualified # 👨🏼‍🚀 E4.0 man astronaut: medium-light skin tone
+1F468 1F3FD 200D 1F680 ; fully-qualified # 👨🏽‍🚀 E4.0 man astronaut: medium skin tone
+1F468 1F3FE 200D 1F680 ; fully-qualified # 👨🏾‍🚀 E4.0 man astronaut: medium-dark skin tone
+1F468 1F3FF 200D 1F680 ; fully-qualified # 👨🏿‍🚀 E4.0 man astronaut: dark skin tone
+1F469 200D 1F680 ; fully-qualified # 👩‍🚀 E4.0 woman astronaut
+1F469 1F3FB 200D 1F680 ; fully-qualified # 👩🏻‍🚀 E4.0 woman astronaut: light skin tone
+1F469 1F3FC 200D 1F680 ; fully-qualified # 👩🏼‍🚀 E4.0 woman astronaut: medium-light skin tone
+1F469 1F3FD 200D 1F680 ; fully-qualified # 👩🏽‍🚀 E4.0 woman astronaut: medium skin tone
+1F469 1F3FE 200D 1F680 ; fully-qualified # 👩🏾‍🚀 E4.0 woman astronaut: medium-dark skin tone
+1F469 1F3FF 200D 1F680 ; fully-qualified # 👩🏿‍🚀 E4.0 woman astronaut: dark skin tone
+1F9D1 200D 1F692 ; fully-qualified # 🧑‍🚒 E12.1 firefighter
+1F9D1 1F3FB 200D 1F692 ; fully-qualified # 🧑🏻‍🚒 E12.1 firefighter: light skin tone
+1F9D1 1F3FC 200D 1F692 ; fully-qualified # 🧑🏼‍🚒 E12.1 firefighter: medium-light skin tone
+1F9D1 1F3FD 200D 1F692 ; fully-qualified # 🧑🏽‍🚒 E12.1 firefighter: medium skin tone
+1F9D1 1F3FE 200D 1F692 ; fully-qualified # 🧑🏾‍🚒 E12.1 firefighter: medium-dark skin tone
+1F9D1 1F3FF 200D 1F692 ; fully-qualified # 🧑🏿‍🚒 E12.1 firefighter: dark skin tone
+1F468 200D 1F692 ; fully-qualified # 👨‍🚒 E4.0 man firefighter
+1F468 1F3FB 200D 1F692 ; fully-qualified # 👨🏻‍🚒 E4.0 man firefighter: light skin tone
+1F468 1F3FC 200D 1F692 ; fully-qualified # 👨🏼‍🚒 E4.0 man firefighter: medium-light skin tone
+1F468 1F3FD 200D 1F692 ; fully-qualified # 👨🏽‍🚒 E4.0 man firefighter: medium skin tone
+1F468 1F3FE 200D 1F692 ; fully-qualified # 👨🏾‍🚒 E4.0 man firefighter: medium-dark skin tone
+1F468 1F3FF 200D 1F692 ; fully-qualified # 👨🏿‍🚒 E4.0 man firefighter: dark skin tone
+1F469 200D 1F692 ; fully-qualified # 👩‍🚒 E4.0 woman firefighter
+1F469 1F3FB 200D 1F692 ; fully-qualified # 👩🏻‍🚒 E4.0 woman firefighter: light skin tone
+1F469 1F3FC 200D 1F692 ; fully-qualified # 👩🏼‍🚒 E4.0 woman firefighter: medium-light skin tone
+1F469 1F3FD 200D 1F692 ; fully-qualified # 👩🏽‍🚒 E4.0 woman firefighter: medium skin tone
+1F469 1F3FE 200D 1F692 ; fully-qualified # 👩🏾‍🚒 E4.0 woman firefighter: medium-dark skin tone
+1F469 1F3FF 200D 1F692 ; fully-qualified # 👩🏿‍🚒 E4.0 woman firefighter: dark skin tone
+1F46E ; fully-qualified # 👮 E0.6 police officer
+1F46E 1F3FB ; fully-qualified # 👮🏻 E1.0 police officer: light skin tone
+1F46E 1F3FC ; fully-qualified # 👮🏼 E1.0 police officer: medium-light skin tone
+1F46E 1F3FD ; fully-qualified # 👮🏽 E1.0 police officer: medium skin tone
+1F46E 1F3FE ; fully-qualified # 👮🏾 E1.0 police officer: medium-dark skin tone
+1F46E 1F3FF ; fully-qualified # 👮🏿 E1.0 police officer: dark skin tone
+1F46E 200D 2642 FE0F ; fully-qualified # 👮‍♂️ E4.0 man police officer
+1F46E 200D 2642 ; minimally-qualified # 👮‍♂ E4.0 man police officer
+1F46E 1F3FB 200D 2642 FE0F ; fully-qualified # 👮🏻‍♂️ E4.0 man police officer: light skin tone
+1F46E 1F3FB 200D 2642 ; minimally-qualified # 👮🏻‍♂ E4.0 man police officer: light skin tone
+1F46E 1F3FC 200D 2642 FE0F ; fully-qualified # 👮🏼‍♂️ E4.0 man police officer: medium-light skin tone
+1F46E 1F3FC 200D 2642 ; minimally-qualified # 👮🏼‍♂ E4.0 man police officer: medium-light skin tone
+1F46E 1F3FD 200D 2642 FE0F ; fully-qualified # 👮🏽‍♂️ E4.0 man police officer: medium skin tone
+1F46E 1F3FD 200D 2642 ; minimally-qualified # 👮🏽‍♂ E4.0 man police officer: medium skin tone
+1F46E 1F3FE 200D 2642 FE0F ; fully-qualified # 👮🏾‍♂️ E4.0 man police officer: medium-dark skin tone
+1F46E 1F3FE 200D 2642 ; minimally-qualified # 👮🏾‍♂ E4.0 man police officer: medium-dark skin tone
+1F46E 1F3FF 200D 2642 FE0F ; fully-qualified # 👮🏿‍♂️ E4.0 man police officer: dark skin tone
+1F46E 1F3FF 200D 2642 ; minimally-qualified # 👮🏿‍♂ E4.0 man police officer: dark skin tone
+1F46E 200D 2640 FE0F ; fully-qualified # 👮‍♀️ E4.0 woman police officer
+1F46E 200D 2640 ; minimally-qualified # 👮‍♀ E4.0 woman police officer
+1F46E 1F3FB 200D 2640 FE0F ; fully-qualified # 👮🏻‍♀️ E4.0 woman police officer: light skin tone
+1F46E 1F3FB 200D 2640 ; minimally-qualified # 👮🏻‍♀ E4.0 woman police officer: light skin tone
+1F46E 1F3FC 200D 2640 FE0F ; fully-qualified # 👮🏼‍♀️ E4.0 woman police officer: medium-light skin tone
+1F46E 1F3FC 200D 2640 ; minimally-qualified # 👮🏼‍♀ E4.0 woman police officer: medium-light skin tone
+1F46E 1F3FD 200D 2640 FE0F ; fully-qualified # 👮🏽‍♀️ E4.0 woman police officer: medium skin tone
+1F46E 1F3FD 200D 2640 ; minimally-qualified # 👮🏽‍♀ E4.0 woman police officer: medium skin tone
+1F46E 1F3FE 200D 2640 FE0F ; fully-qualified # 👮🏾‍♀️ E4.0 woman police officer: medium-dark skin tone
+1F46E 1F3FE 200D 2640 ; minimally-qualified # 👮🏾‍♀ E4.0 woman police officer: medium-dark skin tone
+1F46E 1F3FF 200D 2640 FE0F ; fully-qualified # 👮🏿‍♀️ E4.0 woman police officer: dark skin tone
+1F46E 1F3FF 200D 2640 ; minimally-qualified # 👮🏿‍♀ E4.0 woman police officer: dark skin tone
+1F575 FE0F ; fully-qualified # 🕵️ E0.7 detective
+1F575 ; unqualified # 🕵 E0.7 detective
+1F575 1F3FB ; fully-qualified # 🕵🏻 E2.0 detective: light skin tone
+1F575 1F3FC ; fully-qualified # 🕵🏼 E2.0 detective: medium-light skin tone
+1F575 1F3FD ; fully-qualified # 🕵🏽 E2.0 detective: medium skin tone
+1F575 1F3FE ; fully-qualified # 🕵🏾 E2.0 detective: medium-dark skin tone
+1F575 1F3FF ; fully-qualified # 🕵🏿 E2.0 detective: dark skin tone
+1F575 FE0F 200D 2642 FE0F ; fully-qualified # 🕵️‍♂️ E4.0 man detective
+1F575 200D 2642 FE0F ; unqualified # 🕵‍♂️ E4.0 man detective
+1F575 FE0F 200D 2642 ; unqualified # 🕵️‍♂ E4.0 man detective
+1F575 200D 2642 ; unqualified # 🕵‍♂ E4.0 man detective
+1F575 1F3FB 200D 2642 FE0F ; fully-qualified # 🕵🏻‍♂️ E4.0 man detective: light skin tone
+1F575 1F3FB 200D 2642 ; minimally-qualified # 🕵🏻‍♂ E4.0 man detective: light skin tone
+1F575 1F3FC 200D 2642 FE0F ; fully-qualified # 🕵🏼‍♂️ E4.0 man detective: medium-light skin tone
+1F575 1F3FC 200D 2642 ; minimally-qualified # 🕵🏼‍♂ E4.0 man detective: medium-light skin tone
+1F575 1F3FD 200D 2642 FE0F ; fully-qualified # 🕵🏽‍♂️ E4.0 man detective: medium skin tone
+1F575 1F3FD 200D 2642 ; minimally-qualified # 🕵🏽‍♂ E4.0 man detective: medium skin tone
+1F575 1F3FE 200D 2642 FE0F ; fully-qualified # 🕵🏾‍♂️ E4.0 man detective: medium-dark skin tone
+1F575 1F3FE 200D 2642 ; minimally-qualified # 🕵🏾‍♂ E4.0 man detective: medium-dark skin tone
+1F575 1F3FF 200D 2642 FE0F ; fully-qualified # 🕵🏿‍♂️ E4.0 man detective: dark skin tone
+1F575 1F3FF 200D 2642 ; minimally-qualified # 🕵🏿‍♂ E4.0 man detective: dark skin tone
+1F575 FE0F 200D 2640 FE0F ; fully-qualified # 🕵️‍♀️ E4.0 woman detective
+1F575 200D 2640 FE0F ; unqualified # 🕵‍♀️ E4.0 woman detective
+1F575 FE0F 200D 2640 ; unqualified # 🕵️‍♀ E4.0 woman detective
+1F575 200D 2640 ; unqualified # 🕵‍♀ E4.0 woman detective
+1F575 1F3FB 200D 2640 FE0F ; fully-qualified # 🕵🏻‍♀️ E4.0 woman detective: light skin tone
+1F575 1F3FB 200D 2640 ; minimally-qualified # 🕵🏻‍♀ E4.0 woman detective: light skin tone
+1F575 1F3FC 200D 2640 FE0F ; fully-qualified # 🕵🏼‍♀️ E4.0 woman detective: medium-light skin tone
+1F575 1F3FC 200D 2640 ; minimally-qualified # 🕵🏼‍♀ E4.0 woman detective: medium-light skin tone
+1F575 1F3FD 200D 2640 FE0F ; fully-qualified # 🕵🏽‍♀️ E4.0 woman detective: medium skin tone
+1F575 1F3FD 200D 2640 ; minimally-qualified # 🕵🏽‍♀ E4.0 woman detective: medium skin tone
+1F575 1F3FE 200D 2640 FE0F ; fully-qualified # 🕵🏾‍♀️ E4.0 woman detective: medium-dark skin tone
+1F575 1F3FE 200D 2640 ; minimally-qualified # 🕵🏾‍♀ E4.0 woman detective: medium-dark skin tone
+1F575 1F3FF 200D 2640 FE0F ; fully-qualified # 🕵🏿‍♀️ E4.0 woman detective: dark skin tone
+1F575 1F3FF 200D 2640 ; minimally-qualified # 🕵🏿‍♀ E4.0 woman detective: dark skin tone
+1F482 ; fully-qualified # 💂 E0.6 guard
+1F482 1F3FB ; fully-qualified # 💂🏻 E1.0 guard: light skin tone
+1F482 1F3FC ; fully-qualified # 💂🏼 E1.0 guard: medium-light skin tone
+1F482 1F3FD ; fully-qualified # 💂🏽 E1.0 guard: medium skin tone
+1F482 1F3FE ; fully-qualified # 💂🏾 E1.0 guard: medium-dark skin tone
+1F482 1F3FF ; fully-qualified # 💂🏿 E1.0 guard: dark skin tone
+1F482 200D 2642 FE0F ; fully-qualified # 💂‍♂️ E4.0 man guard
+1F482 200D 2642 ; minimally-qualified # 💂‍♂ E4.0 man guard
+1F482 1F3FB 200D 2642 FE0F ; fully-qualified # 💂🏻‍♂️ E4.0 man guard: light skin tone
+1F482 1F3FB 200D 2642 ; minimally-qualified # 💂🏻‍♂ E4.0 man guard: light skin tone
+1F482 1F3FC 200D 2642 FE0F ; fully-qualified # 💂🏼‍♂️ E4.0 man guard: medium-light skin tone
+1F482 1F3FC 200D 2642 ; minimally-qualified # 💂🏼‍♂ E4.0 man guard: medium-light skin tone
+1F482 1F3FD 200D 2642 FE0F ; fully-qualified # 💂🏽‍♂️ E4.0 man guard: medium skin tone
+1F482 1F3FD 200D 2642 ; minimally-qualified # 💂🏽‍♂ E4.0 man guard: medium skin tone
+1F482 1F3FE 200D 2642 FE0F ; fully-qualified # 💂🏾‍♂️ E4.0 man guard: medium-dark skin tone
+1F482 1F3FE 200D 2642 ; minimally-qualified # 💂🏾‍♂ E4.0 man guard: medium-dark skin tone
+1F482 1F3FF 200D 2642 FE0F ; fully-qualified # 💂🏿‍♂️ E4.0 man guard: dark skin tone
+1F482 1F3FF 200D 2642 ; minimally-qualified # 💂🏿‍♂ E4.0 man guard: dark skin tone
+1F482 200D 2640 FE0F ; fully-qualified # 💂‍♀️ E4.0 woman guard
+1F482 200D 2640 ; minimally-qualified # 💂‍♀ E4.0 woman guard
+1F482 1F3FB 200D 2640 FE0F ; fully-qualified # 💂🏻‍♀️ E4.0 woman guard: light skin tone
+1F482 1F3FB 200D 2640 ; minimally-qualified # 💂🏻‍♀ E4.0 woman guard: light skin tone
+1F482 1F3FC 200D 2640 FE0F ; fully-qualified # 💂🏼‍♀️ E4.0 woman guard: medium-light skin tone
+1F482 1F3FC 200D 2640 ; minimally-qualified # 💂🏼‍♀ E4.0 woman guard: medium-light skin tone
+1F482 1F3FD 200D 2640 FE0F ; fully-qualified # 💂🏽‍♀️ E4.0 woman guard: medium skin tone
+1F482 1F3FD 200D 2640 ; minimally-qualified # 💂🏽‍♀ E4.0 woman guard: medium skin tone
+1F482 1F3FE 200D 2640 FE0F ; fully-qualified # 💂🏾‍♀️ E4.0 woman guard: medium-dark skin tone
+1F482 1F3FE 200D 2640 ; minimally-qualified # 💂🏾‍♀ E4.0 woman guard: medium-dark skin tone
+1F482 1F3FF 200D 2640 FE0F ; fully-qualified # 💂🏿‍♀️ E4.0 woman guard: dark skin tone
+1F482 1F3FF 200D 2640 ; minimally-qualified # 💂🏿‍♀ E4.0 woman guard: dark skin tone
+1F977 ; fully-qualified # 🥷 E13.0 ninja
+1F977 1F3FB ; fully-qualified # 🥷🏻 E13.0 ninja: light skin tone
+1F977 1F3FC ; fully-qualified # 🥷🏼 E13.0 ninja: medium-light skin tone
+1F977 1F3FD ; fully-qualified # 🥷🏽 E13.0 ninja: medium skin tone
+1F977 1F3FE ; fully-qualified # 🥷🏾 E13.0 ninja: medium-dark skin tone
+1F977 1F3FF ; fully-qualified # 🥷🏿 E13.0 ninja: dark skin tone
+1F477 ; fully-qualified # 👷 E0.6 construction worker
+1F477 1F3FB ; fully-qualified # 👷🏻 E1.0 construction worker: light skin tone
+1F477 1F3FC ; fully-qualified # 👷🏼 E1.0 construction worker: medium-light skin tone
+1F477 1F3FD ; fully-qualified # 👷🏽 E1.0 construction worker: medium skin tone
+1F477 1F3FE ; fully-qualified # 👷🏾 E1.0 construction worker: medium-dark skin tone
+1F477 1F3FF ; fully-qualified # 👷🏿 E1.0 construction worker: dark skin tone
+1F477 200D 2642 FE0F ; fully-qualified # 👷‍♂️ E4.0 man construction worker
+1F477 200D 2642 ; minimally-qualified # 👷‍♂ E4.0 man construction worker
+1F477 1F3FB 200D 2642 FE0F ; fully-qualified # 👷🏻‍♂️ E4.0 man construction worker: light skin tone
+1F477 1F3FB 200D 2642 ; minimally-qualified # 👷🏻‍♂ E4.0 man construction worker: light skin tone
+1F477 1F3FC 200D 2642 FE0F ; fully-qualified # 👷🏼‍♂️ E4.0 man construction worker: medium-light skin tone
+1F477 1F3FC 200D 2642 ; minimally-qualified # 👷🏼‍♂ E4.0 man construction worker: medium-light skin tone
+1F477 1F3FD 200D 2642 FE0F ; fully-qualified # 👷🏽‍♂️ E4.0 man construction worker: medium skin tone
+1F477 1F3FD 200D 2642 ; minimally-qualified # 👷🏽‍♂ E4.0 man construction worker: medium skin tone
+1F477 1F3FE 200D 2642 FE0F ; fully-qualified # 👷🏾‍♂️ E4.0 man construction worker: medium-dark skin tone
+1F477 1F3FE 200D 2642 ; minimally-qualified # 👷🏾‍♂ E4.0 man construction worker: medium-dark skin tone
+1F477 1F3FF 200D 2642 FE0F ; fully-qualified # 👷🏿‍♂️ E4.0 man construction worker: dark skin tone
+1F477 1F3FF 200D 2642 ; minimally-qualified # 👷🏿‍♂ E4.0 man construction worker: dark skin tone
+1F477 200D 2640 FE0F ; fully-qualified # 👷‍♀️ E4.0 woman construction worker
+1F477 200D 2640 ; minimally-qualified # 👷‍♀ E4.0 woman construction worker
+1F477 1F3FB 200D 2640 FE0F ; fully-qualified # 👷🏻‍♀️ E4.0 woman construction worker: light skin tone
+1F477 1F3FB 200D 2640 ; minimally-qualified # 👷🏻‍♀ E4.0 woman construction worker: light skin tone
+1F477 1F3FC 200D 2640 FE0F ; fully-qualified # 👷🏼‍♀️ E4.0 woman construction worker: medium-light skin tone
+1F477 1F3FC 200D 2640 ; minimally-qualified # 👷🏼‍♀ E4.0 woman construction worker: medium-light skin tone
+1F477 1F3FD 200D 2640 FE0F ; fully-qualified # 👷🏽‍♀️ E4.0 woman construction worker: medium skin tone
+1F477 1F3FD 200D 2640 ; minimally-qualified # 👷🏽‍♀ E4.0 woman construction worker: medium skin tone
+1F477 1F3FE 200D 2640 FE0F ; fully-qualified # 👷🏾‍♀️ E4.0 woman construction worker: medium-dark skin tone
+1F477 1F3FE 200D 2640 ; minimally-qualified # 👷🏾‍♀ E4.0 woman construction worker: medium-dark skin tone
+1F477 1F3FF 200D 2640 FE0F ; fully-qualified # 👷🏿‍♀️ E4.0 woman construction worker: dark skin tone
+1F477 1F3FF 200D 2640 ; minimally-qualified # 👷🏿‍♀ E4.0 woman construction worker: dark skin tone
+1FAC5 ; fully-qualified # 🫅 E14.0 person with crown
+1FAC5 1F3FB ; fully-qualified # 🫅🏻 E14.0 person with crown: light skin tone
+1FAC5 1F3FC ; fully-qualified # 🫅🏼 E14.0 person with crown: medium-light skin tone
+1FAC5 1F3FD ; fully-qualified # 🫅🏽 E14.0 person with crown: medium skin tone
+1FAC5 1F3FE ; fully-qualified # 🫅🏾 E14.0 person with crown: medium-dark skin tone
+1FAC5 1F3FF ; fully-qualified # 🫅🏿 E14.0 person with crown: dark skin tone
+1F934 ; fully-qualified # 🤴 E3.0 prince
+1F934 1F3FB ; fully-qualified # 🤴🏻 E3.0 prince: light skin tone
+1F934 1F3FC ; fully-qualified # 🤴🏼 E3.0 prince: medium-light skin tone
+1F934 1F3FD ; fully-qualified # 🤴🏽 E3.0 prince: medium skin tone
+1F934 1F3FE ; fully-qualified # 🤴🏾 E3.0 prince: medium-dark skin tone
+1F934 1F3FF ; fully-qualified # 🤴🏿 E3.0 prince: dark skin tone
+1F478 ; fully-qualified # 👸 E0.6 princess
+1F478 1F3FB ; fully-qualified # 👸🏻 E1.0 princess: light skin tone
+1F478 1F3FC ; fully-qualified # 👸🏼 E1.0 princess: medium-light skin tone
+1F478 1F3FD ; fully-qualified # 👸🏽 E1.0 princess: medium skin tone
+1F478 1F3FE ; fully-qualified # 👸🏾 E1.0 princess: medium-dark skin tone
+1F478 1F3FF ; fully-qualified # 👸🏿 E1.0 princess: dark skin tone
+1F473 ; fully-qualified # 👳 E0.6 person wearing turban
+1F473 1F3FB ; fully-qualified # 👳🏻 E1.0 person wearing turban: light skin tone
+1F473 1F3FC ; fully-qualified # 👳🏼 E1.0 person wearing turban: medium-light skin tone
+1F473 1F3FD ; fully-qualified # 👳🏽 E1.0 person wearing turban: medium skin tone
+1F473 1F3FE ; fully-qualified # 👳🏾 E1.0 person wearing turban: medium-dark skin tone
+1F473 1F3FF ; fully-qualified # 👳🏿 E1.0 person wearing turban: dark skin tone
+1F473 200D 2642 FE0F ; fully-qualified # 👳‍♂️ E4.0 man wearing turban
+1F473 200D 2642 ; minimally-qualified # 👳‍♂ E4.0 man wearing turban
+1F473 1F3FB 200D 2642 FE0F ; fully-qualified # 👳🏻‍♂️ E4.0 man wearing turban: light skin tone
+1F473 1F3FB 200D 2642 ; minimally-qualified # 👳🏻‍♂ E4.0 man wearing turban: light skin tone
+1F473 1F3FC 200D 2642 FE0F ; fully-qualified # 👳🏼‍♂️ E4.0 man wearing turban: medium-light skin tone
+1F473 1F3FC 200D 2642 ; minimally-qualified # 👳🏼‍♂ E4.0 man wearing turban: medium-light skin tone
+1F473 1F3FD 200D 2642 FE0F ; fully-qualified # 👳🏽‍♂️ E4.0 man wearing turban: medium skin tone
+1F473 1F3FD 200D 2642 ; minimally-qualified # 👳🏽‍♂ E4.0 man wearing turban: medium skin tone
+1F473 1F3FE 200D 2642 FE0F ; fully-qualified # 👳🏾‍♂️ E4.0 man wearing turban: medium-dark skin tone
+1F473 1F3FE 200D 2642 ; minimally-qualified # 👳🏾‍♂ E4.0 man wearing turban: medium-dark skin tone
+1F473 1F3FF 200D 2642 FE0F ; fully-qualified # 👳🏿‍♂️ E4.0 man wearing turban: dark skin tone
+1F473 1F3FF 200D 2642 ; minimally-qualified # 👳🏿‍♂ E4.0 man wearing turban: dark skin tone
+1F473 200D 2640 FE0F ; fully-qualified # 👳‍♀️ E4.0 woman wearing turban
+1F473 200D 2640 ; minimally-qualified # 👳‍♀ E4.0 woman wearing turban
+1F473 1F3FB 200D 2640 FE0F ; fully-qualified # 👳🏻‍♀️ E4.0 woman wearing turban: light skin tone
+1F473 1F3FB 200D 2640 ; minimally-qualified # 👳🏻‍♀ E4.0 woman wearing turban: light skin tone
+1F473 1F3FC 200D 2640 FE0F ; fully-qualified # 👳🏼‍♀️ E4.0 woman wearing turban: medium-light skin tone
+1F473 1F3FC 200D 2640 ; minimally-qualified # 👳🏼‍♀ E4.0 woman wearing turban: medium-light skin tone
+1F473 1F3FD 200D 2640 FE0F ; fully-qualified # 👳🏽‍♀️ E4.0 woman wearing turban: medium skin tone
+1F473 1F3FD 200D 2640 ; minimally-qualified # 👳🏽‍♀ E4.0 woman wearing turban: medium skin tone
+1F473 1F3FE 200D 2640 FE0F ; fully-qualified # 👳🏾‍♀️ E4.0 woman wearing turban: medium-dark skin tone
+1F473 1F3FE 200D 2640 ; minimally-qualified # 👳🏾‍♀ E4.0 woman wearing turban: medium-dark skin tone
+1F473 1F3FF 200D 2640 FE0F ; fully-qualified # 👳🏿‍♀️ E4.0 woman wearing turban: dark skin tone
+1F473 1F3FF 200D 2640 ; minimally-qualified # 👳🏿‍♀ E4.0 woman wearing turban: dark skin tone
+1F472 ; fully-qualified # 👲 E0.6 person with skullcap
+1F472 1F3FB ; fully-qualified # 👲🏻 E1.0 person with skullcap: light skin tone
+1F472 1F3FC ; fully-qualified # 👲🏼 E1.0 person with skullcap: medium-light skin tone
+1F472 1F3FD ; fully-qualified # 👲🏽 E1.0 person with skullcap: medium skin tone
+1F472 1F3FE ; fully-qualified # 👲🏾 E1.0 person with skullcap: medium-dark skin tone
+1F472 1F3FF ; fully-qualified # 👲🏿 E1.0 person with skullcap: dark skin tone
+1F9D5 ; fully-qualified # 🧕 E5.0 woman with headscarf
+1F9D5 1F3FB ; fully-qualified # 🧕🏻 E5.0 woman with headscarf: light skin tone
+1F9D5 1F3FC ; fully-qualified # 🧕🏼 E5.0 woman with headscarf: medium-light skin tone
+1F9D5 1F3FD ; fully-qualified # 🧕🏽 E5.0 woman with headscarf: medium skin tone
+1F9D5 1F3FE ; fully-qualified # 🧕🏾 E5.0 woman with headscarf: medium-dark skin tone
+1F9D5 1F3FF ; fully-qualified # 🧕🏿 E5.0 woman with headscarf: dark skin tone
+1F935 ; fully-qualified # 🤵 E3.0 person in tuxedo
+1F935 1F3FB ; fully-qualified # 🤵🏻 E3.0 person in tuxedo: light skin tone
+1F935 1F3FC ; fully-qualified # 🤵🏼 E3.0 person in tuxedo: medium-light skin tone
+1F935 1F3FD ; fully-qualified # 🤵🏽 E3.0 person in tuxedo: medium skin tone
+1F935 1F3FE ; fully-qualified # 🤵🏾 E3.0 person in tuxedo: medium-dark skin tone
+1F935 1F3FF ; fully-qualified # 🤵🏿 E3.0 person in tuxedo: dark skin tone
+1F935 200D 2642 FE0F ; fully-qualified # 🤵‍♂️ E13.0 man in tuxedo
+1F935 200D 2642 ; minimally-qualified # 🤵‍♂ E13.0 man in tuxedo
+1F935 1F3FB 200D 2642 FE0F ; fully-qualified # 🤵🏻‍♂️ E13.0 man in tuxedo: light skin tone
+1F935 1F3FB 200D 2642 ; minimally-qualified # 🤵🏻‍♂ E13.0 man in tuxedo: light skin tone
+1F935 1F3FC 200D 2642 FE0F ; fully-qualified # 🤵🏼‍♂️ E13.0 man in tuxedo: medium-light skin tone
+1F935 1F3FC 200D 2642 ; minimally-qualified # 🤵🏼‍♂ E13.0 man in tuxedo: medium-light skin tone
+1F935 1F3FD 200D 2642 FE0F ; fully-qualified # 🤵🏽‍♂️ E13.0 man in tuxedo: medium skin tone
+1F935 1F3FD 200D 2642 ; minimally-qualified # 🤵🏽‍♂ E13.0 man in tuxedo: medium skin tone
+1F935 1F3FE 200D 2642 FE0F ; fully-qualified # 🤵🏾‍♂️ E13.0 man in tuxedo: medium-dark skin tone
+1F935 1F3FE 200D 2642 ; minimally-qualified # 🤵🏾‍♂ E13.0 man in tuxedo: medium-dark skin tone
+1F935 1F3FF 200D 2642 FE0F ; fully-qualified # 🤵🏿‍♂️ E13.0 man in tuxedo: dark skin tone
+1F935 1F3FF 200D 2642 ; minimally-qualified # 🤵🏿‍♂ E13.0 man in tuxedo: dark skin tone
+1F935 200D 2640 FE0F ; fully-qualified # 🤵‍♀️ E13.0 woman in tuxedo
+1F935 200D 2640 ; minimally-qualified # 🤵‍♀ E13.0 woman in tuxedo
+1F935 1F3FB 200D 2640 FE0F ; fully-qualified # 🤵🏻‍♀️ E13.0 woman in tuxedo: light skin tone
+1F935 1F3FB 200D 2640 ; minimally-qualified # 🤵🏻‍♀ E13.0 woman in tuxedo: light skin tone
+1F935 1F3FC 200D 2640 FE0F ; fully-qualified # 🤵🏼‍♀️ E13.0 woman in tuxedo: medium-light skin tone
+1F935 1F3FC 200D 2640 ; minimally-qualified # 🤵🏼‍♀ E13.0 woman in tuxedo: medium-light skin tone
+1F935 1F3FD 200D 2640 FE0F ; fully-qualified # 🤵🏽‍♀️ E13.0 woman in tuxedo: medium skin tone
+1F935 1F3FD 200D 2640 ; minimally-qualified # 🤵🏽‍♀ E13.0 woman in tuxedo: medium skin tone
+1F935 1F3FE 200D 2640 FE0F ; fully-qualified # 🤵🏾‍♀️ E13.0 woman in tuxedo: medium-dark skin tone
+1F935 1F3FE 200D 2640 ; minimally-qualified # 🤵🏾‍♀ E13.0 woman in tuxedo: medium-dark skin tone
+1F935 1F3FF 200D 2640 FE0F ; fully-qualified # 🤵🏿‍♀️ E13.0 woman in tuxedo: dark skin tone
+1F935 1F3FF 200D 2640 ; minimally-qualified # 🤵🏿‍♀ E13.0 woman in tuxedo: dark skin tone
+1F470 ; fully-qualified # 👰 E0.6 person with veil
+1F470 1F3FB ; fully-qualified # 👰🏻 E1.0 person with veil: light skin tone
+1F470 1F3FC ; fully-qualified # 👰🏼 E1.0 person with veil: medium-light skin tone
+1F470 1F3FD ; fully-qualified # 👰🏽 E1.0 person with veil: medium skin tone
+1F470 1F3FE ; fully-qualified # 👰🏾 E1.0 person with veil: medium-dark skin tone
+1F470 1F3FF ; fully-qualified # 👰🏿 E1.0 person with veil: dark skin tone
+1F470 200D 2642 FE0F ; fully-qualified # 👰‍♂️ E13.0 man with veil
+1F470 200D 2642 ; minimally-qualified # 👰‍♂ E13.0 man with veil
+1F470 1F3FB 200D 2642 FE0F ; fully-qualified # 👰🏻‍♂️ E13.0 man with veil: light skin tone
+1F470 1F3FB 200D 2642 ; minimally-qualified # 👰🏻‍♂ E13.0 man with veil: light skin tone
+1F470 1F3FC 200D 2642 FE0F ; fully-qualified # 👰🏼‍♂️ E13.0 man with veil: medium-light skin tone
+1F470 1F3FC 200D 2642 ; minimally-qualified # 👰🏼‍♂ E13.0 man with veil: medium-light skin tone
+1F470 1F3FD 200D 2642 FE0F ; fully-qualified # 👰🏽‍♂️ E13.0 man with veil: medium skin tone
+1F470 1F3FD 200D 2642 ; minimally-qualified # 👰🏽‍♂ E13.0 man with veil: medium skin tone
+1F470 1F3FE 200D 2642 FE0F ; fully-qualified # 👰🏾‍♂️ E13.0 man with veil: medium-dark skin tone
+1F470 1F3FE 200D 2642 ; minimally-qualified # 👰🏾‍♂ E13.0 man with veil: medium-dark skin tone
+1F470 1F3FF 200D 2642 FE0F ; fully-qualified # 👰🏿‍♂️ E13.0 man with veil: dark skin tone
+1F470 1F3FF 200D 2642 ; minimally-qualified # 👰🏿‍♂ E13.0 man with veil: dark skin tone
+1F470 200D 2640 FE0F ; fully-qualified # 👰‍♀️ E13.0 woman with veil
+1F470 200D 2640 ; minimally-qualified # 👰‍♀ E13.0 woman with veil
+1F470 1F3FB 200D 2640 FE0F ; fully-qualified # 👰🏻‍♀️ E13.0 woman with veil: light skin tone
+1F470 1F3FB 200D 2640 ; minimally-qualified # 👰🏻‍♀ E13.0 woman with veil: light skin tone
+1F470 1F3FC 200D 2640 FE0F ; fully-qualified # 👰🏼‍♀️ E13.0 woman with veil: medium-light skin tone
+1F470 1F3FC 200D 2640 ; minimally-qualified # 👰🏼‍♀ E13.0 woman with veil: medium-light skin tone
+1F470 1F3FD 200D 2640 FE0F ; fully-qualified # 👰🏽‍♀️ E13.0 woman with veil: medium skin tone
+1F470 1F3FD 200D 2640 ; minimally-qualified # 👰🏽‍♀ E13.0 woman with veil: medium skin tone
+1F470 1F3FE 200D 2640 FE0F ; fully-qualified # 👰🏾‍♀️ E13.0 woman with veil: medium-dark skin tone
+1F470 1F3FE 200D 2640 ; minimally-qualified # 👰🏾‍♀ E13.0 woman with veil: medium-dark skin tone
+1F470 1F3FF 200D 2640 FE0F ; fully-qualified # 👰🏿‍♀️ E13.0 woman with veil: dark skin tone
+1F470 1F3FF 200D 2640 ; minimally-qualified # 👰🏿‍♀ E13.0 woman with veil: dark skin tone
+1F930 ; fully-qualified # 🤰 E3.0 pregnant woman
+1F930 1F3FB ; fully-qualified # 🤰🏻 E3.0 pregnant woman: light skin tone
+1F930 1F3FC ; fully-qualified # 🤰🏼 E3.0 pregnant woman: medium-light skin tone
+1F930 1F3FD ; fully-qualified # 🤰🏽 E3.0 pregnant woman: medium skin tone
+1F930 1F3FE ; fully-qualified # 🤰🏾 E3.0 pregnant woman: medium-dark skin tone
+1F930 1F3FF ; fully-qualified # 🤰🏿 E3.0 pregnant woman: dark skin tone
+1FAC3 ; fully-qualified # 🫃 E14.0 pregnant man
+1FAC3 1F3FB ; fully-qualified # 🫃🏻 E14.0 pregnant man: light skin tone
+1FAC3 1F3FC ; fully-qualified # 🫃🏼 E14.0 pregnant man: medium-light skin tone
+1FAC3 1F3FD ; fully-qualified # 🫃🏽 E14.0 pregnant man: medium skin tone
+1FAC3 1F3FE ; fully-qualified # 🫃🏾 E14.0 pregnant man: medium-dark skin tone
+1FAC3 1F3FF ; fully-qualified # 🫃🏿 E14.0 pregnant man: dark skin tone
+1FAC4 ; fully-qualified # 🫄 E14.0 pregnant person
+1FAC4 1F3FB ; fully-qualified # 🫄🏻 E14.0 pregnant person: light skin tone
+1FAC4 1F3FC ; fully-qualified # 🫄🏼 E14.0 pregnant person: medium-light skin tone
+1FAC4 1F3FD ; fully-qualified # 🫄🏽 E14.0 pregnant person: medium skin tone
+1FAC4 1F3FE ; fully-qualified # 🫄🏾 E14.0 pregnant person: medium-dark skin tone
+1FAC4 1F3FF ; fully-qualified # 🫄🏿 E14.0 pregnant person: dark skin tone
+1F931 ; fully-qualified # 🤱 E5.0 breast-feeding
+1F931 1F3FB ; fully-qualified # 🤱🏻 E5.0 breast-feeding: light skin tone
+1F931 1F3FC ; fully-qualified # 🤱🏼 E5.0 breast-feeding: medium-light skin tone
+1F931 1F3FD ; fully-qualified # 🤱🏽 E5.0 breast-feeding: medium skin tone
+1F931 1F3FE ; fully-qualified # 🤱🏾 E5.0 breast-feeding: medium-dark skin tone
+1F931 1F3FF ; fully-qualified # 🤱🏿 E5.0 breast-feeding: dark skin tone
+1F469 200D 1F37C ; fully-qualified # 👩‍🍼 E13.0 woman feeding baby
+1F469 1F3FB 200D 1F37C ; fully-qualified # 👩🏻‍🍼 E13.0 woman feeding baby: light skin tone
+1F469 1F3FC 200D 1F37C ; fully-qualified # 👩🏼‍🍼 E13.0 woman feeding baby: medium-light skin tone
+1F469 1F3FD 200D 1F37C ; fully-qualified # 👩🏽‍🍼 E13.0 woman feeding baby: medium skin tone
+1F469 1F3FE 200D 1F37C ; fully-qualified # 👩🏾‍🍼 E13.0 woman feeding baby: medium-dark skin tone
+1F469 1F3FF 200D 1F37C ; fully-qualified # 👩🏿‍🍼 E13.0 woman feeding baby: dark skin tone
+1F468 200D 1F37C ; fully-qualified # 👨‍🍼 E13.0 man feeding baby
+1F468 1F3FB 200D 1F37C ; fully-qualified # 👨🏻‍🍼 E13.0 man feeding baby: light skin tone
+1F468 1F3FC 200D 1F37C ; fully-qualified # 👨🏼‍🍼 E13.0 man feeding baby: medium-light skin tone
+1F468 1F3FD 200D 1F37C ; fully-qualified # 👨🏽‍🍼 E13.0 man feeding baby: medium skin tone
+1F468 1F3FE 200D 1F37C ; fully-qualified # 👨🏾‍🍼 E13.0 man feeding baby: medium-dark skin tone
+1F468 1F3FF 200D 1F37C ; fully-qualified # 👨🏿‍🍼 E13.0 man feeding baby: dark skin tone
+1F9D1 200D 1F37C ; fully-qualified # 🧑‍🍼 E13.0 person feeding baby
+1F9D1 1F3FB 200D 1F37C ; fully-qualified # 🧑🏻‍🍼 E13.0 person feeding baby: light skin tone
+1F9D1 1F3FC 200D 1F37C ; fully-qualified # 🧑🏼‍🍼 E13.0 person feeding baby: medium-light skin tone
+1F9D1 1F3FD 200D 1F37C ; fully-qualified # 🧑🏽‍🍼 E13.0 person feeding baby: medium skin tone
+1F9D1 1F3FE 200D 1F37C ; fully-qualified # 🧑🏾‍🍼 E13.0 person feeding baby: medium-dark skin tone
+1F9D1 1F3FF 200D 1F37C ; fully-qualified # 🧑🏿‍🍼 E13.0 person feeding baby: dark skin tone
+
+# subgroup: person-fantasy
+1F47C ; fully-qualified # 👼 E0.6 baby angel
+1F47C 1F3FB ; fully-qualified # 👼🏻 E1.0 baby angel: light skin tone
+1F47C 1F3FC ; fully-qualified # 👼🏼 E1.0 baby angel: medium-light skin tone
+1F47C 1F3FD ; fully-qualified # 👼🏽 E1.0 baby angel: medium skin tone
+1F47C 1F3FE ; fully-qualified # 👼🏾 E1.0 baby angel: medium-dark skin tone
+1F47C 1F3FF ; fully-qualified # 👼🏿 E1.0 baby angel: dark skin tone
+1F385 ; fully-qualified # 🎅 E0.6 Santa Claus
+1F385 1F3FB ; fully-qualified # 🎅🏻 E1.0 Santa Claus: light skin tone
+1F385 1F3FC ; fully-qualified # 🎅🏼 E1.0 Santa Claus: medium-light skin tone
+1F385 1F3FD ; fully-qualified # 🎅🏽 E1.0 Santa Claus: medium skin tone
+1F385 1F3FE ; fully-qualified # 🎅🏾 E1.0 Santa Claus: medium-dark skin tone
+1F385 1F3FF ; fully-qualified # 🎅🏿 E1.0 Santa Claus: dark skin tone
+1F936 ; fully-qualified # 🤶 E3.0 Mrs. Claus
+1F936 1F3FB ; fully-qualified # 🤶🏻 E3.0 Mrs. Claus: light skin tone
+1F936 1F3FC ; fully-qualified # 🤶🏼 E3.0 Mrs. Claus: medium-light skin tone
+1F936 1F3FD ; fully-qualified # 🤶🏽 E3.0 Mrs. Claus: medium skin tone
+1F936 1F3FE ; fully-qualified # 🤶🏾 E3.0 Mrs. Claus: medium-dark skin tone
+1F936 1F3FF ; fully-qualified # 🤶🏿 E3.0 Mrs. Claus: dark skin tone
+1F9D1 200D 1F384 ; fully-qualified # 🧑‍🎄 E13.0 mx claus
+1F9D1 1F3FB 200D 1F384 ; fully-qualified # 🧑🏻‍🎄 E13.0 mx claus: light skin tone
+1F9D1 1F3FC 200D 1F384 ; fully-qualified # 🧑🏼‍🎄 E13.0 mx claus: medium-light skin tone
+1F9D1 1F3FD 200D 1F384 ; fully-qualified # 🧑🏽‍🎄 E13.0 mx claus: medium skin tone
+1F9D1 1F3FE 200D 1F384 ; fully-qualified # 🧑🏾‍🎄 E13.0 mx claus: medium-dark skin tone
+1F9D1 1F3FF 200D 1F384 ; fully-qualified # 🧑🏿‍🎄 E13.0 mx claus: dark skin tone
+1F9B8 ; fully-qualified # 🦸 E11.0 superhero
+1F9B8 1F3FB ; fully-qualified # 🦸🏻 E11.0 superhero: light skin tone
+1F9B8 1F3FC ; fully-qualified # 🦸🏼 E11.0 superhero: medium-light skin tone
+1F9B8 1F3FD ; fully-qualified # 🦸🏽 E11.0 superhero: medium skin tone
+1F9B8 1F3FE ; fully-qualified # 🦸🏾 E11.0 superhero: medium-dark skin tone
+1F9B8 1F3FF ; fully-qualified # 🦸🏿 E11.0 superhero: dark skin tone
+1F9B8 200D 2642 FE0F ; fully-qualified # 🦸‍♂️ E11.0 man superhero
+1F9B8 200D 2642 ; minimally-qualified # 🦸‍♂ E11.0 man superhero
+1F9B8 1F3FB 200D 2642 FE0F ; fully-qualified # 🦸🏻‍♂️ E11.0 man superhero: light skin tone
+1F9B8 1F3FB 200D 2642 ; minimally-qualified # 🦸🏻‍♂ E11.0 man superhero: light skin tone
+1F9B8 1F3FC 200D 2642 FE0F ; fully-qualified # 🦸🏼‍♂️ E11.0 man superhero: medium-light skin tone
+1F9B8 1F3FC 200D 2642 ; minimally-qualified # 🦸🏼‍♂ E11.0 man superhero: medium-light skin tone
+1F9B8 1F3FD 200D 2642 FE0F ; fully-qualified # 🦸🏽‍♂️ E11.0 man superhero: medium skin tone
+1F9B8 1F3FD 200D 2642 ; minimally-qualified # 🦸🏽‍♂ E11.0 man superhero: medium skin tone
+1F9B8 1F3FE 200D 2642 FE0F ; fully-qualified # 🦸🏾‍♂️ E11.0 man superhero: medium-dark skin tone
+1F9B8 1F3FE 200D 2642 ; minimally-qualified # 🦸🏾‍♂ E11.0 man superhero: medium-dark skin tone
+1F9B8 1F3FF 200D 2642 FE0F ; fully-qualified # 🦸🏿‍♂️ E11.0 man superhero: dark skin tone
+1F9B8 1F3FF 200D 2642 ; minimally-qualified # 🦸🏿‍♂ E11.0 man superhero: dark skin tone
+1F9B8 200D 2640 FE0F ; fully-qualified # 🦸‍♀️ E11.0 woman superhero
+1F9B8 200D 2640 ; minimally-qualified # 🦸‍♀ E11.0 woman superhero
+1F9B8 1F3FB 200D 2640 FE0F ; fully-qualified # 🦸🏻‍♀️ E11.0 woman superhero: light skin tone
+1F9B8 1F3FB 200D 2640 ; minimally-qualified # 🦸🏻‍♀ E11.0 woman superhero: light skin tone
+1F9B8 1F3FC 200D 2640 FE0F ; fully-qualified # 🦸🏼‍♀️ E11.0 woman superhero: medium-light skin tone
+1F9B8 1F3FC 200D 2640 ; minimally-qualified # 🦸🏼‍♀ E11.0 woman superhero: medium-light skin tone
+1F9B8 1F3FD 200D 2640 FE0F ; fully-qualified # 🦸🏽‍♀️ E11.0 woman superhero: medium skin tone
+1F9B8 1F3FD 200D 2640 ; minimally-qualified # 🦸🏽‍♀ E11.0 woman superhero: medium skin tone
+1F9B8 1F3FE 200D 2640 FE0F ; fully-qualified # 🦸🏾‍♀️ E11.0 woman superhero: medium-dark skin tone
+1F9B8 1F3FE 200D 2640 ; minimally-qualified # 🦸🏾‍♀ E11.0 woman superhero: medium-dark skin tone
+1F9B8 1F3FF 200D 2640 FE0F ; fully-qualified # 🦸🏿‍♀️ E11.0 woman superhero: dark skin tone
+1F9B8 1F3FF 200D 2640 ; minimally-qualified # 🦸🏿‍♀ E11.0 woman superhero: dark skin tone
+1F9B9 ; fully-qualified # 🦹 E11.0 supervillain
+1F9B9 1F3FB ; fully-qualified # 🦹🏻 E11.0 supervillain: light skin tone
+1F9B9 1F3FC ; fully-qualified # 🦹🏼 E11.0 supervillain: medium-light skin tone
+1F9B9 1F3FD ; fully-qualified # 🦹🏽 E11.0 supervillain: medium skin tone
+1F9B9 1F3FE ; fully-qualified # 🦹🏾 E11.0 supervillain: medium-dark skin tone
+1F9B9 1F3FF ; fully-qualified # 🦹🏿 E11.0 supervillain: dark skin tone
+1F9B9 200D 2642 FE0F ; fully-qualified # 🦹‍♂️ E11.0 man supervillain
+1F9B9 200D 2642 ; minimally-qualified # 🦹‍♂ E11.0 man supervillain
+1F9B9 1F3FB 200D 2642 FE0F ; fully-qualified # 🦹🏻‍♂️ E11.0 man supervillain: light skin tone
+1F9B9 1F3FB 200D 2642 ; minimally-qualified # 🦹🏻‍♂ E11.0 man supervillain: light skin tone
+1F9B9 1F3FC 200D 2642 FE0F ; fully-qualified # 🦹🏼‍♂️ E11.0 man supervillain: medium-light skin tone
+1F9B9 1F3FC 200D 2642 ; minimally-qualified # 🦹🏼‍♂ E11.0 man supervillain: medium-light skin tone
+1F9B9 1F3FD 200D 2642 FE0F ; fully-qualified # 🦹🏽‍♂️ E11.0 man supervillain: medium skin tone
+1F9B9 1F3FD 200D 2642 ; minimally-qualified # 🦹🏽‍♂ E11.0 man supervillain: medium skin tone
+1F9B9 1F3FE 200D 2642 FE0F ; fully-qualified # 🦹🏾‍♂️ E11.0 man supervillain: medium-dark skin tone
+1F9B9 1F3FE 200D 2642 ; minimally-qualified # 🦹🏾‍♂ E11.0 man supervillain: medium-dark skin tone
+1F9B9 1F3FF 200D 2642 FE0F ; fully-qualified # 🦹🏿‍♂️ E11.0 man supervillain: dark skin tone
+1F9B9 1F3FF 200D 2642 ; minimally-qualified # 🦹🏿‍♂ E11.0 man supervillain: dark skin tone
+1F9B9 200D 2640 FE0F ; fully-qualified # 🦹‍♀️ E11.0 woman supervillain
+1F9B9 200D 2640 ; minimally-qualified # 🦹‍♀ E11.0 woman supervillain
+1F9B9 1F3FB 200D 2640 FE0F ; fully-qualified # 🦹🏻‍♀️ E11.0 woman supervillain: light skin tone
+1F9B9 1F3FB 200D 2640 ; minimally-qualified # 🦹🏻‍♀ E11.0 woman supervillain: light skin tone
+1F9B9 1F3FC 200D 2640 FE0F ; fully-qualified # 🦹🏼‍♀️ E11.0 woman supervillain: medium-light skin tone
+1F9B9 1F3FC 200D 2640 ; minimally-qualified # 🦹🏼‍♀ E11.0 woman supervillain: medium-light skin tone
+1F9B9 1F3FD 200D 2640 FE0F ; fully-qualified # 🦹🏽‍♀️ E11.0 woman supervillain: medium skin tone
+1F9B9 1F3FD 200D 2640 ; minimally-qualified # 🦹🏽‍♀ E11.0 woman supervillain: medium skin tone
+1F9B9 1F3FE 200D 2640 FE0F ; fully-qualified # 🦹🏾‍♀️ E11.0 woman supervillain: medium-dark skin tone
+1F9B9 1F3FE 200D 2640 ; minimally-qualified # 🦹🏾‍♀ E11.0 woman supervillain: medium-dark skin tone
+1F9B9 1F3FF 200D 2640 FE0F ; fully-qualified # 🦹🏿‍♀️ E11.0 woman supervillain: dark skin tone
+1F9B9 1F3FF 200D 2640 ; minimally-qualified # 🦹🏿‍♀ E11.0 woman supervillain: dark skin tone
+1F9D9 ; fully-qualified # 🧙 E5.0 mage
+1F9D9 1F3FB ; fully-qualified # 🧙🏻 E5.0 mage: light skin tone
+1F9D9 1F3FC ; fully-qualified # 🧙🏼 E5.0 mage: medium-light skin tone
+1F9D9 1F3FD ; fully-qualified # 🧙🏽 E5.0 mage: medium skin tone
+1F9D9 1F3FE ; fully-qualified # 🧙🏾 E5.0 mage: medium-dark skin tone
+1F9D9 1F3FF ; fully-qualified # 🧙🏿 E5.0 mage: dark skin tone
+1F9D9 200D 2642 FE0F ; fully-qualified # 🧙‍♂️ E5.0 man mage
+1F9D9 200D 2642 ; minimally-qualified # 🧙‍♂ E5.0 man mage
+1F9D9 1F3FB 200D 2642 FE0F ; fully-qualified # 🧙🏻‍♂️ E5.0 man mage: light skin tone
+1F9D9 1F3FB 200D 2642 ; minimally-qualified # 🧙🏻‍♂ E5.0 man mage: light skin tone
+1F9D9 1F3FC 200D 2642 FE0F ; fully-qualified # 🧙🏼‍♂️ E5.0 man mage: medium-light skin tone
+1F9D9 1F3FC 200D 2642 ; minimally-qualified # 🧙🏼‍♂ E5.0 man mage: medium-light skin tone
+1F9D9 1F3FD 200D 2642 FE0F ; fully-qualified # 🧙🏽‍♂️ E5.0 man mage: medium skin tone
+1F9D9 1F3FD 200D 2642 ; minimally-qualified # 🧙🏽‍♂ E5.0 man mage: medium skin tone
+1F9D9 1F3FE 200D 2642 FE0F ; fully-qualified # 🧙🏾‍♂️ E5.0 man mage: medium-dark skin tone
+1F9D9 1F3FE 200D 2642 ; minimally-qualified # 🧙🏾‍♂ E5.0 man mage: medium-dark skin tone
+1F9D9 1F3FF 200D 2642 FE0F ; fully-qualified # 🧙🏿‍♂️ E5.0 man mage: dark skin tone
+1F9D9 1F3FF 200D 2642 ; minimally-qualified # 🧙🏿‍♂ E5.0 man mage: dark skin tone
+1F9D9 200D 2640 FE0F ; fully-qualified # 🧙‍♀️ E5.0 woman mage
+1F9D9 200D 2640 ; minimally-qualified # 🧙‍♀ E5.0 woman mage
+1F9D9 1F3FB 200D 2640 FE0F ; fully-qualified # 🧙🏻‍♀️ E5.0 woman mage: light skin tone
+1F9D9 1F3FB 200D 2640 ; minimally-qualified # 🧙🏻‍♀ E5.0 woman mage: light skin tone
+1F9D9 1F3FC 200D 2640 FE0F ; fully-qualified # 🧙🏼‍♀️ E5.0 woman mage: medium-light skin tone
+1F9D9 1F3FC 200D 2640 ; minimally-qualified # 🧙🏼‍♀ E5.0 woman mage: medium-light skin tone
+1F9D9 1F3FD 200D 2640 FE0F ; fully-qualified # 🧙🏽‍♀️ E5.0 woman mage: medium skin tone
+1F9D9 1F3FD 200D 2640 ; minimally-qualified # 🧙🏽‍♀ E5.0 woman mage: medium skin tone
+1F9D9 1F3FE 200D 2640 FE0F ; fully-qualified # 🧙🏾‍♀️ E5.0 woman mage: medium-dark skin tone
+1F9D9 1F3FE 200D 2640 ; minimally-qualified # 🧙🏾‍♀ E5.0 woman mage: medium-dark skin tone
+1F9D9 1F3FF 200D 2640 FE0F ; fully-qualified # 🧙🏿‍♀️ E5.0 woman mage: dark skin tone
+1F9D9 1F3FF 200D 2640 ; minimally-qualified # 🧙🏿‍♀ E5.0 woman mage: dark skin tone
+1F9DA ; fully-qualified # 🧚 E5.0 fairy
+1F9DA 1F3FB ; fully-qualified # 🧚🏻 E5.0 fairy: light skin tone
+1F9DA 1F3FC ; fully-qualified # 🧚🏼 E5.0 fairy: medium-light skin tone
+1F9DA 1F3FD ; fully-qualified # 🧚🏽 E5.0 fairy: medium skin tone
+1F9DA 1F3FE ; fully-qualified # 🧚🏾 E5.0 fairy: medium-dark skin tone
+1F9DA 1F3FF ; fully-qualified # 🧚🏿 E5.0 fairy: dark skin tone
+1F9DA 200D 2642 FE0F ; fully-qualified # 🧚‍♂️ E5.0 man fairy
+1F9DA 200D 2642 ; minimally-qualified # 🧚‍♂ E5.0 man fairy
+1F9DA 1F3FB 200D 2642 FE0F ; fully-qualified # 🧚🏻‍♂️ E5.0 man fairy: light skin tone
+1F9DA 1F3FB 200D 2642 ; minimally-qualified # 🧚🏻‍♂ E5.0 man fairy: light skin tone
+1F9DA 1F3FC 200D 2642 FE0F ; fully-qualified # 🧚🏼‍♂️ E5.0 man fairy: medium-light skin tone
+1F9DA 1F3FC 200D 2642 ; minimally-qualified # 🧚🏼‍♂ E5.0 man fairy: medium-light skin tone
+1F9DA 1F3FD 200D 2642 FE0F ; fully-qualified # 🧚🏽‍♂️ E5.0 man fairy: medium skin tone
+1F9DA 1F3FD 200D 2642 ; minimally-qualified # 🧚🏽‍♂ E5.0 man fairy: medium skin tone
+1F9DA 1F3FE 200D 2642 FE0F ; fully-qualified # 🧚🏾‍♂️ E5.0 man fairy: medium-dark skin tone
+1F9DA 1F3FE 200D 2642 ; minimally-qualified # 🧚🏾‍♂ E5.0 man fairy: medium-dark skin tone
+1F9DA 1F3FF 200D 2642 FE0F ; fully-qualified # 🧚🏿‍♂️ E5.0 man fairy: dark skin tone
+1F9DA 1F3FF 200D 2642 ; minimally-qualified # 🧚🏿‍♂ E5.0 man fairy: dark skin tone
+1F9DA 200D 2640 FE0F ; fully-qualified # 🧚‍♀️ E5.0 woman fairy
+1F9DA 200D 2640 ; minimally-qualified # 🧚‍♀ E5.0 woman fairy
+1F9DA 1F3FB 200D 2640 FE0F ; fully-qualified # 🧚🏻‍♀️ E5.0 woman fairy: light skin tone
+1F9DA 1F3FB 200D 2640 ; minimally-qualified # 🧚🏻‍♀ E5.0 woman fairy: light skin tone
+1F9DA 1F3FC 200D 2640 FE0F ; fully-qualified # 🧚🏼‍♀️ E5.0 woman fairy: medium-light skin tone
+1F9DA 1F3FC 200D 2640 ; minimally-qualified # 🧚🏼‍♀ E5.0 woman fairy: medium-light skin tone
+1F9DA 1F3FD 200D 2640 FE0F ; fully-qualified # 🧚🏽‍♀️ E5.0 woman fairy: medium skin tone
+1F9DA 1F3FD 200D 2640 ; minimally-qualified # 🧚🏽‍♀ E5.0 woman fairy: medium skin tone
+1F9DA 1F3FE 200D 2640 FE0F ; fully-qualified # 🧚🏾‍♀️ E5.0 woman fairy: medium-dark skin tone
+1F9DA 1F3FE 200D 2640 ; minimally-qualified # 🧚🏾‍♀ E5.0 woman fairy: medium-dark skin tone
+1F9DA 1F3FF 200D 2640 FE0F ; fully-qualified # 🧚🏿‍♀️ E5.0 woman fairy: dark skin tone
+1F9DA 1F3FF 200D 2640 ; minimally-qualified # 🧚🏿‍♀ E5.0 woman fairy: dark skin tone
+1F9DB ; fully-qualified # 🧛 E5.0 vampire
+1F9DB 1F3FB ; fully-qualified # 🧛🏻 E5.0 vampire: light skin tone
+1F9DB 1F3FC ; fully-qualified # 🧛🏼 E5.0 vampire: medium-light skin tone
+1F9DB 1F3FD ; fully-qualified # 🧛🏽 E5.0 vampire: medium skin tone
+1F9DB 1F3FE ; fully-qualified # 🧛🏾 E5.0 vampire: medium-dark skin tone
+1F9DB 1F3FF ; fully-qualified # 🧛🏿 E5.0 vampire: dark skin tone
+1F9DB 200D 2642 FE0F ; fully-qualified # 🧛‍♂️ E5.0 man vampire
+1F9DB 200D 2642 ; minimally-qualified # 🧛‍♂ E5.0 man vampire
+1F9DB 1F3FB 200D 2642 FE0F ; fully-qualified # 🧛🏻‍♂️ E5.0 man vampire: light skin tone
+1F9DB 1F3FB 200D 2642 ; minimally-qualified # 🧛🏻‍♂ E5.0 man vampire: light skin tone
+1F9DB 1F3FC 200D 2642 FE0F ; fully-qualified # 🧛🏼‍♂️ E5.0 man vampire: medium-light skin tone
+1F9DB 1F3FC 200D 2642 ; minimally-qualified # 🧛🏼‍♂ E5.0 man vampire: medium-light skin tone
+1F9DB 1F3FD 200D 2642 FE0F ; fully-qualified # 🧛🏽‍♂️ E5.0 man vampire: medium skin tone
+1F9DB 1F3FD 200D 2642 ; minimally-qualified # 🧛🏽‍♂ E5.0 man vampire: medium skin tone
+1F9DB 1F3FE 200D 2642 FE0F ; fully-qualified # 🧛🏾‍♂️ E5.0 man vampire: medium-dark skin tone
+1F9DB 1F3FE 200D 2642 ; minimally-qualified # 🧛🏾‍♂ E5.0 man vampire: medium-dark skin tone
+1F9DB 1F3FF 200D 2642 FE0F ; fully-qualified # 🧛🏿‍♂️ E5.0 man vampire: dark skin tone
+1F9DB 1F3FF 200D 2642 ; minimally-qualified # 🧛🏿‍♂ E5.0 man vampire: dark skin tone
+1F9DB 200D 2640 FE0F ; fully-qualified # 🧛‍♀️ E5.0 woman vampire
+1F9DB 200D 2640 ; minimally-qualified # 🧛‍♀ E5.0 woman vampire
+1F9DB 1F3FB 200D 2640 FE0F ; fully-qualified # 🧛🏻‍♀️ E5.0 woman vampire: light skin tone
+1F9DB 1F3FB 200D 2640 ; minimally-qualified # 🧛🏻‍♀ E5.0 woman vampire: light skin tone
+1F9DB 1F3FC 200D 2640 FE0F ; fully-qualified # 🧛🏼‍♀️ E5.0 woman vampire: medium-light skin tone
+1F9DB 1F3FC 200D 2640 ; minimally-qualified # 🧛🏼‍♀ E5.0 woman vampire: medium-light skin tone
+1F9DB 1F3FD 200D 2640 FE0F ; fully-qualified # 🧛🏽‍♀️ E5.0 woman vampire: medium skin tone
+1F9DB 1F3FD 200D 2640 ; minimally-qualified # 🧛🏽‍♀ E5.0 woman vampire: medium skin tone
+1F9DB 1F3FE 200D 2640 FE0F ; fully-qualified # 🧛🏾‍♀️ E5.0 woman vampire: medium-dark skin tone
+1F9DB 1F3FE 200D 2640 ; minimally-qualified # 🧛🏾‍♀ E5.0 woman vampire: medium-dark skin tone
+1F9DB 1F3FF 200D 2640 FE0F ; fully-qualified # 🧛🏿‍♀️ E5.0 woman vampire: dark skin tone
+1F9DB 1F3FF 200D 2640 ; minimally-qualified # 🧛🏿‍♀ E5.0 woman vampire: dark skin tone
+1F9DC ; fully-qualified # 🧜 E5.0 merperson
+1F9DC 1F3FB ; fully-qualified # 🧜🏻 E5.0 merperson: light skin tone
+1F9DC 1F3FC ; fully-qualified # 🧜🏼 E5.0 merperson: medium-light skin tone
+1F9DC 1F3FD ; fully-qualified # 🧜🏽 E5.0 merperson: medium skin tone
+1F9DC 1F3FE ; fully-qualified # 🧜🏾 E5.0 merperson: medium-dark skin tone
+1F9DC 1F3FF ; fully-qualified # 🧜🏿 E5.0 merperson: dark skin tone
+1F9DC 200D 2642 FE0F ; fully-qualified # 🧜‍♂️ E5.0 merman
+1F9DC 200D 2642 ; minimally-qualified # 🧜‍♂ E5.0 merman
+1F9DC 1F3FB 200D 2642 FE0F ; fully-qualified # 🧜🏻‍♂️ E5.0 merman: light skin tone
+1F9DC 1F3FB 200D 2642 ; minimally-qualified # 🧜🏻‍♂ E5.0 merman: light skin tone
+1F9DC 1F3FC 200D 2642 FE0F ; fully-qualified # 🧜🏼‍♂️ E5.0 merman: medium-light skin tone
+1F9DC 1F3FC 200D 2642 ; minimally-qualified # 🧜🏼‍♂ E5.0 merman: medium-light skin tone
+1F9DC 1F3FD 200D 2642 FE0F ; fully-qualified # 🧜🏽‍♂️ E5.0 merman: medium skin tone
+1F9DC 1F3FD 200D 2642 ; minimally-qualified # 🧜🏽‍♂ E5.0 merman: medium skin tone
+1F9DC 1F3FE 200D 2642 FE0F ; fully-qualified # 🧜🏾‍♂️ E5.0 merman: medium-dark skin tone
+1F9DC 1F3FE 200D 2642 ; minimally-qualified # 🧜🏾‍♂ E5.0 merman: medium-dark skin tone
+1F9DC 1F3FF 200D 2642 FE0F ; fully-qualified # 🧜🏿‍♂️ E5.0 merman: dark skin tone
+1F9DC 1F3FF 200D 2642 ; minimally-qualified # 🧜🏿‍♂ E5.0 merman: dark skin tone
+1F9DC 200D 2640 FE0F ; fully-qualified # 🧜‍♀️ E5.0 mermaid
+1F9DC 200D 2640 ; minimally-qualified # 🧜‍♀ E5.0 mermaid
+1F9DC 1F3FB 200D 2640 FE0F ; fully-qualified # 🧜🏻‍♀️ E5.0 mermaid: light skin tone
+1F9DC 1F3FB 200D 2640 ; minimally-qualified # 🧜🏻‍♀ E5.0 mermaid: light skin tone
+1F9DC 1F3FC 200D 2640 FE0F ; fully-qualified # 🧜🏼‍♀️ E5.0 mermaid: medium-light skin tone
+1F9DC 1F3FC 200D 2640 ; minimally-qualified # 🧜🏼‍♀ E5.0 mermaid: medium-light skin tone
+1F9DC 1F3FD 200D 2640 FE0F ; fully-qualified # 🧜🏽‍♀️ E5.0 mermaid: medium skin tone
+1F9DC 1F3FD 200D 2640 ; minimally-qualified # 🧜🏽‍♀ E5.0 mermaid: medium skin tone
+1F9DC 1F3FE 200D 2640 FE0F ; fully-qualified # 🧜🏾‍♀️ E5.0 mermaid: medium-dark skin tone
+1F9DC 1F3FE 200D 2640 ; minimally-qualified # 🧜🏾‍♀ E5.0 mermaid: medium-dark skin tone
+1F9DC 1F3FF 200D 2640 FE0F ; fully-qualified # 🧜🏿‍♀️ E5.0 mermaid: dark skin tone
+1F9DC 1F3FF 200D 2640 ; minimally-qualified # 🧜🏿‍♀ E5.0 mermaid: dark skin tone
+1F9DD ; fully-qualified # 🧝 E5.0 elf
+1F9DD 1F3FB ; fully-qualified # 🧝🏻 E5.0 elf: light skin tone
+1F9DD 1F3FC ; fully-qualified # 🧝🏼 E5.0 elf: medium-light skin tone
+1F9DD 1F3FD ; fully-qualified # 🧝🏽 E5.0 elf: medium skin tone
+1F9DD 1F3FE ; fully-qualified # 🧝🏾 E5.0 elf: medium-dark skin tone
+1F9DD 1F3FF ; fully-qualified # 🧝🏿 E5.0 elf: dark skin tone
+1F9DD 200D 2642 FE0F ; fully-qualified # 🧝‍♂️ E5.0 man elf
+1F9DD 200D 2642 ; minimally-qualified # 🧝‍♂ E5.0 man elf
+1F9DD 1F3FB 200D 2642 FE0F ; fully-qualified # 🧝🏻‍♂️ E5.0 man elf: light skin tone
+1F9DD 1F3FB 200D 2642 ; minimally-qualified # 🧝🏻‍♂ E5.0 man elf: light skin tone
+1F9DD 1F3FC 200D 2642 FE0F ; fully-qualified # 🧝🏼‍♂️ E5.0 man elf: medium-light skin tone
+1F9DD 1F3FC 200D 2642 ; minimally-qualified # 🧝🏼‍♂ E5.0 man elf: medium-light skin tone
+1F9DD 1F3FD 200D 2642 FE0F ; fully-qualified # 🧝🏽‍♂️ E5.0 man elf: medium skin tone
+1F9DD 1F3FD 200D 2642 ; minimally-qualified # 🧝🏽‍♂ E5.0 man elf: medium skin tone
+1F9DD 1F3FE 200D 2642 FE0F ; fully-qualified # 🧝🏾‍♂️ E5.0 man elf: medium-dark skin tone
+1F9DD 1F3FE 200D 2642 ; minimally-qualified # 🧝🏾‍♂ E5.0 man elf: medium-dark skin tone
+1F9DD 1F3FF 200D 2642 FE0F ; fully-qualified # 🧝🏿‍♂️ E5.0 man elf: dark skin tone
+1F9DD 1F3FF 200D 2642 ; minimally-qualified # 🧝🏿‍♂ E5.0 man elf: dark skin tone
+1F9DD 200D 2640 FE0F ; fully-qualified # 🧝‍♀️ E5.0 woman elf
+1F9DD 200D 2640 ; minimally-qualified # 🧝‍♀ E5.0 woman elf
+1F9DD 1F3FB 200D 2640 FE0F ; fully-qualified # 🧝🏻‍♀️ E5.0 woman elf: light skin tone
+1F9DD 1F3FB 200D 2640 ; minimally-qualified # 🧝🏻‍♀ E5.0 woman elf: light skin tone
+1F9DD 1F3FC 200D 2640 FE0F ; fully-qualified # 🧝🏼‍♀️ E5.0 woman elf: medium-light skin tone
+1F9DD 1F3FC 200D 2640 ; minimally-qualified # 🧝🏼‍♀ E5.0 woman elf: medium-light skin tone
+1F9DD 1F3FD 200D 2640 FE0F ; fully-qualified # 🧝🏽‍♀️ E5.0 woman elf: medium skin tone
+1F9DD 1F3FD 200D 2640 ; minimally-qualified # 🧝🏽‍♀ E5.0 woman elf: medium skin tone
+1F9DD 1F3FE 200D 2640 FE0F ; fully-qualified # 🧝🏾‍♀️ E5.0 woman elf: medium-dark skin tone
+1F9DD 1F3FE 200D 2640 ; minimally-qualified # 🧝🏾‍♀ E5.0 woman elf: medium-dark skin tone
+1F9DD 1F3FF 200D 2640 FE0F ; fully-qualified # 🧝🏿‍♀️ E5.0 woman elf: dark skin tone
+1F9DD 1F3FF 200D 2640 ; minimally-qualified # 🧝🏿‍♀ E5.0 woman elf: dark skin tone
+1F9DE ; fully-qualified # 🧞 E5.0 genie
+1F9DE 200D 2642 FE0F ; fully-qualified # 🧞‍♂️ E5.0 man genie
+1F9DE 200D 2642 ; minimally-qualified # 🧞‍♂ E5.0 man genie
+1F9DE 200D 2640 FE0F ; fully-qualified # 🧞‍♀️ E5.0 woman genie
+1F9DE 200D 2640 ; minimally-qualified # 🧞‍♀ E5.0 woman genie
+1F9DF ; fully-qualified # 🧟 E5.0 zombie
+1F9DF 200D 2642 FE0F ; fully-qualified # 🧟‍♂️ E5.0 man zombie
+1F9DF 200D 2642 ; minimally-qualified # 🧟‍♂ E5.0 man zombie
+1F9DF 200D 2640 FE0F ; fully-qualified # 🧟‍♀️ E5.0 woman zombie
+1F9DF 200D 2640 ; minimally-qualified # 🧟‍♀ E5.0 woman zombie
+1F9CC ; fully-qualified # 🧌 E14.0 troll
+
+# subgroup: person-activity
+1F486 ; fully-qualified # 💆 E0.6 person getting massage
+1F486 1F3FB ; fully-qualified # 💆🏻 E1.0 person getting massage: light skin tone
+1F486 1F3FC ; fully-qualified # 💆🏼 E1.0 person getting massage: medium-light skin tone
+1F486 1F3FD ; fully-qualified # 💆🏽 E1.0 person getting massage: medium skin tone
+1F486 1F3FE ; fully-qualified # 💆🏾 E1.0 person getting massage: medium-dark skin tone
+1F486 1F3FF ; fully-qualified # 💆🏿 E1.0 person getting massage: dark skin tone
+1F486 200D 2642 FE0F ; fully-qualified # 💆‍♂️ E4.0 man getting massage
+1F486 200D 2642 ; minimally-qualified # 💆‍♂ E4.0 man getting massage
+1F486 1F3FB 200D 2642 FE0F ; fully-qualified # 💆🏻‍♂️ E4.0 man getting massage: light skin tone
+1F486 1F3FB 200D 2642 ; minimally-qualified # 💆🏻‍♂ E4.0 man getting massage: light skin tone
+1F486 1F3FC 200D 2642 FE0F ; fully-qualified # 💆🏼‍♂️ E4.0 man getting massage: medium-light skin tone
+1F486 1F3FC 200D 2642 ; minimally-qualified # 💆🏼‍♂ E4.0 man getting massage: medium-light skin tone
+1F486 1F3FD 200D 2642 FE0F ; fully-qualified # 💆🏽‍♂️ E4.0 man getting massage: medium skin tone
+1F486 1F3FD 200D 2642 ; minimally-qualified # 💆🏽‍♂ E4.0 man getting massage: medium skin tone
+1F486 1F3FE 200D 2642 FE0F ; fully-qualified # 💆🏾‍♂️ E4.0 man getting massage: medium-dark skin tone
+1F486 1F3FE 200D 2642 ; minimally-qualified # 💆🏾‍♂ E4.0 man getting massage: medium-dark skin tone
+1F486 1F3FF 200D 2642 FE0F ; fully-qualified # 💆🏿‍♂️ E4.0 man getting massage: dark skin tone
+1F486 1F3FF 200D 2642 ; minimally-qualified # 💆🏿‍♂ E4.0 man getting massage: dark skin tone
+1F486 200D 2640 FE0F ; fully-qualified # 💆‍♀️ E4.0 woman getting massage
+1F486 200D 2640 ; minimally-qualified # 💆‍♀ E4.0 woman getting massage
+1F486 1F3FB 200D 2640 FE0F ; fully-qualified # 💆🏻‍♀️ E4.0 woman getting massage: light skin tone
+1F486 1F3FB 200D 2640 ; minimally-qualified # 💆🏻‍♀ E4.0 woman getting massage: light skin tone
+1F486 1F3FC 200D 2640 FE0F ; fully-qualified # 💆🏼‍♀️ E4.0 woman getting massage: medium-light skin tone
+1F486 1F3FC 200D 2640 ; minimally-qualified # 💆🏼‍♀ E4.0 woman getting massage: medium-light skin tone
+1F486 1F3FD 200D 2640 FE0F ; fully-qualified # 💆🏽‍♀️ E4.0 woman getting massage: medium skin tone
+1F486 1F3FD 200D 2640 ; minimally-qualified # 💆🏽‍♀ E4.0 woman getting massage: medium skin tone
+1F486 1F3FE 200D 2640 FE0F ; fully-qualified # 💆🏾‍♀️ E4.0 woman getting massage: medium-dark skin tone
+1F486 1F3FE 200D 2640 ; minimally-qualified # 💆🏾‍♀ E4.0 woman getting massage: medium-dark skin tone
+1F486 1F3FF 200D 2640 FE0F ; fully-qualified # 💆🏿‍♀️ E4.0 woman getting massage: dark skin tone
+1F486 1F3FF 200D 2640 ; minimally-qualified # 💆🏿‍♀ E4.0 woman getting massage: dark skin tone
+1F487 ; fully-qualified # 💇 E0.6 person getting haircut
+1F487 1F3FB ; fully-qualified # 💇🏻 E1.0 person getting haircut: light skin tone
+1F487 1F3FC ; fully-qualified # 💇🏼 E1.0 person getting haircut: medium-light skin tone
+1F487 1F3FD ; fully-qualified # 💇🏽 E1.0 person getting haircut: medium skin tone
+1F487 1F3FE ; fully-qualified # 💇🏾 E1.0 person getting haircut: medium-dark skin tone
+1F487 1F3FF ; fully-qualified # 💇🏿 E1.0 person getting haircut: dark skin tone
+1F487 200D 2642 FE0F ; fully-qualified # 💇‍♂️ E4.0 man getting haircut
+1F487 200D 2642 ; minimally-qualified # 💇‍♂ E4.0 man getting haircut
+1F487 1F3FB 200D 2642 FE0F ; fully-qualified # 💇🏻‍♂️ E4.0 man getting haircut: light skin tone
+1F487 1F3FB 200D 2642 ; minimally-qualified # 💇🏻‍♂ E4.0 man getting haircut: light skin tone
+1F487 1F3FC 200D 2642 FE0F ; fully-qualified # 💇🏼‍♂️ E4.0 man getting haircut: medium-light skin tone
+1F487 1F3FC 200D 2642 ; minimally-qualified # 💇🏼‍♂ E4.0 man getting haircut: medium-light skin tone
+1F487 1F3FD 200D 2642 FE0F ; fully-qualified # 💇🏽‍♂️ E4.0 man getting haircut: medium skin tone
+1F487 1F3FD 200D 2642 ; minimally-qualified # 💇🏽‍♂ E4.0 man getting haircut: medium skin tone
+1F487 1F3FE 200D 2642 FE0F ; fully-qualified # 💇🏾‍♂️ E4.0 man getting haircut: medium-dark skin tone
+1F487 1F3FE 200D 2642 ; minimally-qualified # 💇🏾‍♂ E4.0 man getting haircut: medium-dark skin tone
+1F487 1F3FF 200D 2642 FE0F ; fully-qualified # 💇🏿‍♂️ E4.0 man getting haircut: dark skin tone
+1F487 1F3FF 200D 2642 ; minimally-qualified # 💇🏿‍♂ E4.0 man getting haircut: dark skin tone
+1F487 200D 2640 FE0F ; fully-qualified # 💇‍♀️ E4.0 woman getting haircut
+1F487 200D 2640 ; minimally-qualified # 💇‍♀ E4.0 woman getting haircut
+1F487 1F3FB 200D 2640 FE0F ; fully-qualified # 💇🏻‍♀️ E4.0 woman getting haircut: light skin tone
+1F487 1F3FB 200D 2640 ; minimally-qualified # 💇🏻‍♀ E4.0 woman getting haircut: light skin tone
+1F487 1F3FC 200D 2640 FE0F ; fully-qualified # 💇🏼‍♀️ E4.0 woman getting haircut: medium-light skin tone
+1F487 1F3FC 200D 2640 ; minimally-qualified # 💇🏼‍♀ E4.0 woman getting haircut: medium-light skin tone
+1F487 1F3FD 200D 2640 FE0F ; fully-qualified # 💇🏽‍♀️ E4.0 woman getting haircut: medium skin tone
+1F487 1F3FD 200D 2640 ; minimally-qualified # 💇🏽‍♀ E4.0 woman getting haircut: medium skin tone
+1F487 1F3FE 200D 2640 FE0F ; fully-qualified # 💇🏾‍♀️ E4.0 woman getting haircut: medium-dark skin tone
+1F487 1F3FE 200D 2640 ; minimally-qualified # 💇🏾‍♀ E4.0 woman getting haircut: medium-dark skin tone
+1F487 1F3FF 200D 2640 FE0F ; fully-qualified # 💇🏿‍♀️ E4.0 woman getting haircut: dark skin tone
+1F487 1F3FF 200D 2640 ; minimally-qualified # 💇🏿‍♀ E4.0 woman getting haircut: dark skin tone
+1F6B6 ; fully-qualified # 🚶 E0.6 person walking
+1F6B6 1F3FB ; fully-qualified # 🚶🏻 E1.0 person walking: light skin tone
+1F6B6 1F3FC ; fully-qualified # 🚶🏼 E1.0 person walking: medium-light skin tone
+1F6B6 1F3FD ; fully-qualified # 🚶🏽 E1.0 person walking: medium skin tone
+1F6B6 1F3FE ; fully-qualified # 🚶🏾 E1.0 person walking: medium-dark skin tone
+1F6B6 1F3FF ; fully-qualified # 🚶🏿 E1.0 person walking: dark skin tone
+1F6B6 200D 2642 FE0F ; fully-qualified # 🚶‍♂️ E4.0 man walking
+1F6B6 200D 2642 ; minimally-qualified # 🚶‍♂ E4.0 man walking
+1F6B6 1F3FB 200D 2642 FE0F ; fully-qualified # 🚶🏻‍♂️ E4.0 man walking: light skin tone
+1F6B6 1F3FB 200D 2642 ; minimally-qualified # 🚶🏻‍♂ E4.0 man walking: light skin tone
+1F6B6 1F3FC 200D 2642 FE0F ; fully-qualified # 🚶🏼‍♂️ E4.0 man walking: medium-light skin tone
+1F6B6 1F3FC 200D 2642 ; minimally-qualified # 🚶🏼‍♂ E4.0 man walking: medium-light skin tone
+1F6B6 1F3FD 200D 2642 FE0F ; fully-qualified # 🚶🏽‍♂️ E4.0 man walking: medium skin tone
+1F6B6 1F3FD 200D 2642 ; minimally-qualified # 🚶🏽‍♂ E4.0 man walking: medium skin tone
+1F6B6 1F3FE 200D 2642 FE0F ; fully-qualified # 🚶🏾‍♂️ E4.0 man walking: medium-dark skin tone
+1F6B6 1F3FE 200D 2642 ; minimally-qualified # 🚶🏾‍♂ E4.0 man walking: medium-dark skin tone
+1F6B6 1F3FF 200D 2642 FE0F ; fully-qualified # 🚶🏿‍♂️ E4.0 man walking: dark skin tone
+1F6B6 1F3FF 200D 2642 ; minimally-qualified # 🚶🏿‍♂ E4.0 man walking: dark skin tone
+1F6B6 200D 2640 FE0F ; fully-qualified # 🚶‍♀️ E4.0 woman walking
+1F6B6 200D 2640 ; minimally-qualified # 🚶‍♀ E4.0 woman walking
+1F6B6 1F3FB 200D 2640 FE0F ; fully-qualified # 🚶🏻‍♀️ E4.0 woman walking: light skin tone
+1F6B6 1F3FB 200D 2640 ; minimally-qualified # 🚶🏻‍♀ E4.0 woman walking: light skin tone
+1F6B6 1F3FC 200D 2640 FE0F ; fully-qualified # 🚶🏼‍♀️ E4.0 woman walking: medium-light skin tone
+1F6B6 1F3FC 200D 2640 ; minimally-qualified # 🚶🏼‍♀ E4.0 woman walking: medium-light skin tone
+1F6B6 1F3FD 200D 2640 FE0F ; fully-qualified # 🚶🏽‍♀️ E4.0 woman walking: medium skin tone
+1F6B6 1F3FD 200D 2640 ; minimally-qualified # 🚶🏽‍♀ E4.0 woman walking: medium skin tone
+1F6B6 1F3FE 200D 2640 FE0F ; fully-qualified # 🚶🏾‍♀️ E4.0 woman walking: medium-dark skin tone
+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
+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
+1F9CD 1F3FD ; fully-qualified # 🧍🏽 E12.0 person standing: medium skin tone
+1F9CD 1F3FE ; fully-qualified # 🧍🏾 E12.0 person standing: medium-dark skin tone
+1F9CD 1F3FF ; fully-qualified # 🧍🏿 E12.0 person standing: dark skin tone
+1F9CD 200D 2642 FE0F ; fully-qualified # 🧍‍♂️ E12.0 man standing
+1F9CD 200D 2642 ; minimally-qualified # 🧍‍♂ E12.0 man standing
+1F9CD 1F3FB 200D 2642 FE0F ; fully-qualified # 🧍🏻‍♂️ E12.0 man standing: light skin tone
+1F9CD 1F3FB 200D 2642 ; minimally-qualified # 🧍🏻‍♂ E12.0 man standing: light skin tone
+1F9CD 1F3FC 200D 2642 FE0F ; fully-qualified # 🧍🏼‍♂️ E12.0 man standing: medium-light skin tone
+1F9CD 1F3FC 200D 2642 ; minimally-qualified # 🧍🏼‍♂ E12.0 man standing: medium-light skin tone
+1F9CD 1F3FD 200D 2642 FE0F ; fully-qualified # 🧍🏽‍♂️ E12.0 man standing: medium skin tone
+1F9CD 1F3FD 200D 2642 ; minimally-qualified # 🧍🏽‍♂ E12.0 man standing: medium skin tone
+1F9CD 1F3FE 200D 2642 FE0F ; fully-qualified # 🧍🏾‍♂️ E12.0 man standing: medium-dark skin tone
+1F9CD 1F3FE 200D 2642 ; minimally-qualified # 🧍🏾‍♂ E12.0 man standing: medium-dark skin tone
+1F9CD 1F3FF 200D 2642 FE0F ; fully-qualified # 🧍🏿‍♂️ E12.0 man standing: dark skin tone
+1F9CD 1F3FF 200D 2642 ; minimally-qualified # 🧍🏿‍♂ E12.0 man standing: dark skin tone
+1F9CD 200D 2640 FE0F ; fully-qualified # 🧍‍♀️ E12.0 woman standing
+1F9CD 200D 2640 ; minimally-qualified # 🧍‍♀ E12.0 woman standing
+1F9CD 1F3FB 200D 2640 FE0F ; fully-qualified # 🧍🏻‍♀️ E12.0 woman standing: light skin tone
+1F9CD 1F3FB 200D 2640 ; minimally-qualified # 🧍🏻‍♀ E12.0 woman standing: light skin tone
+1F9CD 1F3FC 200D 2640 FE0F ; fully-qualified # 🧍🏼‍♀️ E12.0 woman standing: medium-light skin tone
+1F9CD 1F3FC 200D 2640 ; minimally-qualified # 🧍🏼‍♀ E12.0 woman standing: medium-light skin tone
+1F9CD 1F3FD 200D 2640 FE0F ; fully-qualified # 🧍🏽‍♀️ E12.0 woman standing: medium skin tone
+1F9CD 1F3FD 200D 2640 ; minimally-qualified # 🧍🏽‍♀ E12.0 woman standing: medium skin tone
+1F9CD 1F3FE 200D 2640 FE0F ; fully-qualified # 🧍🏾‍♀️ E12.0 woman standing: medium-dark skin tone
+1F9CD 1F3FE 200D 2640 ; minimally-qualified # 🧍🏾‍♀ E12.0 woman standing: medium-dark skin tone
+1F9CD 1F3FF 200D 2640 FE0F ; fully-qualified # 🧍🏿‍♀️ E12.0 woman standing: dark skin tone
+1F9CD 1F3FF 200D 2640 ; minimally-qualified # 🧍🏿‍♀ E12.0 woman standing: dark skin tone
+1F9CE ; fully-qualified # 🧎 E12.0 person kneeling
+1F9CE 1F3FB ; fully-qualified # 🧎🏻 E12.0 person kneeling: light skin tone
+1F9CE 1F3FC ; fully-qualified # 🧎🏼 E12.0 person kneeling: medium-light skin tone
+1F9CE 1F3FD ; fully-qualified # 🧎🏽 E12.0 person kneeling: medium skin tone
+1F9CE 1F3FE ; fully-qualified # 🧎🏾 E12.0 person kneeling: medium-dark skin tone
+1F9CE 1F3FF ; fully-qualified # 🧎🏿 E12.0 person kneeling: dark skin tone
+1F9CE 200D 2642 FE0F ; fully-qualified # 🧎‍♂️ E12.0 man kneeling
+1F9CE 200D 2642 ; minimally-qualified # 🧎‍♂ E12.0 man kneeling
+1F9CE 1F3FB 200D 2642 FE0F ; fully-qualified # 🧎🏻‍♂️ E12.0 man kneeling: light skin tone
+1F9CE 1F3FB 200D 2642 ; minimally-qualified # 🧎🏻‍♂ E12.0 man kneeling: light skin tone
+1F9CE 1F3FC 200D 2642 FE0F ; fully-qualified # 🧎🏼‍♂️ E12.0 man kneeling: medium-light skin tone
+1F9CE 1F3FC 200D 2642 ; minimally-qualified # 🧎🏼‍♂ E12.0 man kneeling: medium-light skin tone
+1F9CE 1F3FD 200D 2642 FE0F ; fully-qualified # 🧎🏽‍♂️ E12.0 man kneeling: medium skin tone
+1F9CE 1F3FD 200D 2642 ; minimally-qualified # 🧎🏽‍♂ E12.0 man kneeling: medium skin tone
+1F9CE 1F3FE 200D 2642 FE0F ; fully-qualified # 🧎🏾‍♂️ E12.0 man kneeling: medium-dark skin tone
+1F9CE 1F3FE 200D 2642 ; minimally-qualified # 🧎🏾‍♂ E12.0 man kneeling: medium-dark skin tone
+1F9CE 1F3FF 200D 2642 FE0F ; fully-qualified # 🧎🏿‍♂️ E12.0 man kneeling: dark skin tone
+1F9CE 1F3FF 200D 2642 ; minimally-qualified # 🧎🏿‍♂ E12.0 man kneeling: dark skin tone
+1F9CE 200D 2640 FE0F ; fully-qualified # 🧎‍♀️ E12.0 woman kneeling
+1F9CE 200D 2640 ; minimally-qualified # 🧎‍♀ E12.0 woman kneeling
+1F9CE 1F3FB 200D 2640 FE0F ; fully-qualified # 🧎🏻‍♀️ E12.0 woman kneeling: light skin tone
+1F9CE 1F3FB 200D 2640 ; minimally-qualified # 🧎🏻‍♀ E12.0 woman kneeling: light skin tone
+1F9CE 1F3FC 200D 2640 FE0F ; fully-qualified # 🧎🏼‍♀️ E12.0 woman kneeling: medium-light skin tone
+1F9CE 1F3FC 200D 2640 ; minimally-qualified # 🧎🏼‍♀ E12.0 woman kneeling: medium-light skin tone
+1F9CE 1F3FD 200D 2640 FE0F ; fully-qualified # 🧎🏽‍♀️ E12.0 woman kneeling: medium skin tone
+1F9CE 1F3FD 200D 2640 ; minimally-qualified # 🧎🏽‍♀ E12.0 woman kneeling: medium skin tone
+1F9CE 1F3FE 200D 2640 FE0F ; fully-qualified # 🧎🏾‍♀️ E12.0 woman kneeling: medium-dark skin tone
+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
+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
+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
+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
+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
+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
+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
+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
+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
+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
+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
+1F3C3 1F3FD ; fully-qualified # 🏃🏽 E1.0 person running: medium skin tone
+1F3C3 1F3FE ; fully-qualified # 🏃🏾 E1.0 person running: medium-dark skin tone
+1F3C3 1F3FF ; fully-qualified # 🏃🏿 E1.0 person running: dark skin tone
+1F3C3 200D 2642 FE0F ; fully-qualified # 🏃‍♂️ E4.0 man running
+1F3C3 200D 2642 ; minimally-qualified # 🏃‍♂ E4.0 man running
+1F3C3 1F3FB 200D 2642 FE0F ; fully-qualified # 🏃🏻‍♂️ E4.0 man running: light skin tone
+1F3C3 1F3FB 200D 2642 ; minimally-qualified # 🏃🏻‍♂ E4.0 man running: light skin tone
+1F3C3 1F3FC 200D 2642 FE0F ; fully-qualified # 🏃🏼‍♂️ E4.0 man running: medium-light skin tone
+1F3C3 1F3FC 200D 2642 ; minimally-qualified # 🏃🏼‍♂ E4.0 man running: medium-light skin tone
+1F3C3 1F3FD 200D 2642 FE0F ; fully-qualified # 🏃🏽‍♂️ E4.0 man running: medium skin tone
+1F3C3 1F3FD 200D 2642 ; minimally-qualified # 🏃🏽‍♂ E4.0 man running: medium skin tone
+1F3C3 1F3FE 200D 2642 FE0F ; fully-qualified # 🏃🏾‍♂️ E4.0 man running: medium-dark skin tone
+1F3C3 1F3FE 200D 2642 ; minimally-qualified # 🏃🏾‍♂ E4.0 man running: medium-dark skin tone
+1F3C3 1F3FF 200D 2642 FE0F ; fully-qualified # 🏃🏿‍♂️ E4.0 man running: dark skin tone
+1F3C3 1F3FF 200D 2642 ; minimally-qualified # 🏃🏿‍♂ E4.0 man running: dark skin tone
+1F3C3 200D 2640 FE0F ; fully-qualified # 🏃‍♀️ E4.0 woman running
+1F3C3 200D 2640 ; minimally-qualified # 🏃‍♀ E4.0 woman running
+1F3C3 1F3FB 200D 2640 FE0F ; fully-qualified # 🏃🏻‍♀️ E4.0 woman running: light skin tone
+1F3C3 1F3FB 200D 2640 ; minimally-qualified # 🏃🏻‍♀ E4.0 woman running: light skin tone
+1F3C3 1F3FC 200D 2640 FE0F ; fully-qualified # 🏃🏼‍♀️ E4.0 woman running: medium-light skin tone
+1F3C3 1F3FC 200D 2640 ; minimally-qualified # 🏃🏼‍♀ E4.0 woman running: medium-light skin tone
+1F3C3 1F3FD 200D 2640 FE0F ; fully-qualified # 🏃🏽‍♀️ E4.0 woman running: medium skin tone
+1F3C3 1F3FD 200D 2640 ; minimally-qualified # 🏃🏽‍♀ E4.0 woman running: medium skin tone
+1F3C3 1F3FE 200D 2640 FE0F ; fully-qualified # 🏃🏾‍♀️ E4.0 woman running: medium-dark skin tone
+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
+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
+1F483 1F3FD ; fully-qualified # 💃🏽 E1.0 woman dancing: medium skin tone
+1F483 1F3FE ; fully-qualified # 💃🏾 E1.0 woman dancing: medium-dark skin tone
+1F483 1F3FF ; fully-qualified # 💃🏿 E1.0 woman dancing: dark skin tone
+1F57A ; fully-qualified # 🕺 E3.0 man dancing
+1F57A 1F3FB ; fully-qualified # 🕺🏻 E3.0 man dancing: light skin tone
+1F57A 1F3FC ; fully-qualified # 🕺🏼 E3.0 man dancing: medium-light skin tone
+1F57A 1F3FD ; fully-qualified # 🕺🏽 E3.0 man dancing: medium skin tone
+1F57A 1F3FE ; fully-qualified # 🕺🏾 E3.0 man dancing: medium-dark skin tone
+1F57A 1F3FF ; fully-qualified # 🕺🏿 E3.0 man dancing: dark skin tone
+1F574 FE0F ; fully-qualified # 🕴️ E0.7 person in suit levitating
+1F574 ; unqualified # 🕴 E0.7 person in suit levitating
+1F574 1F3FB ; fully-qualified # 🕴🏻 E4.0 person in suit levitating: light skin tone
+1F574 1F3FC ; fully-qualified # 🕴🏼 E4.0 person in suit levitating: medium-light skin tone
+1F574 1F3FD ; fully-qualified # 🕴🏽 E4.0 person in suit levitating: medium skin tone
+1F574 1F3FE ; fully-qualified # 🕴🏾 E4.0 person in suit levitating: medium-dark skin tone
+1F574 1F3FF ; fully-qualified # 🕴🏿 E4.0 person in suit levitating: dark skin tone
+1F46F ; fully-qualified # 👯 E0.6 people with bunny ears
+1F46F 200D 2642 FE0F ; fully-qualified # 👯‍♂️ E4.0 men with bunny ears
+1F46F 200D 2642 ; minimally-qualified # 👯‍♂ E4.0 men with bunny ears
+1F46F 200D 2640 FE0F ; fully-qualified # 👯‍♀️ E4.0 women with bunny ears
+1F46F 200D 2640 ; minimally-qualified # 👯‍♀ E4.0 women with bunny ears
+1F9D6 ; fully-qualified # 🧖 E5.0 person in steamy room
+1F9D6 1F3FB ; fully-qualified # 🧖🏻 E5.0 person in steamy room: light skin tone
+1F9D6 1F3FC ; fully-qualified # 🧖🏼 E5.0 person in steamy room: medium-light skin tone
+1F9D6 1F3FD ; fully-qualified # 🧖🏽 E5.0 person in steamy room: medium skin tone
+1F9D6 1F3FE ; fully-qualified # 🧖🏾 E5.0 person in steamy room: medium-dark skin tone
+1F9D6 1F3FF ; fully-qualified # 🧖🏿 E5.0 person in steamy room: dark skin tone
+1F9D6 200D 2642 FE0F ; fully-qualified # 🧖‍♂️ E5.0 man in steamy room
+1F9D6 200D 2642 ; minimally-qualified # 🧖‍♂ E5.0 man in steamy room
+1F9D6 1F3FB 200D 2642 FE0F ; fully-qualified # 🧖🏻‍♂️ E5.0 man in steamy room: light skin tone
+1F9D6 1F3FB 200D 2642 ; minimally-qualified # 🧖🏻‍♂ E5.0 man in steamy room: light skin tone
+1F9D6 1F3FC 200D 2642 FE0F ; fully-qualified # 🧖🏼‍♂️ E5.0 man in steamy room: medium-light skin tone
+1F9D6 1F3FC 200D 2642 ; minimally-qualified # 🧖🏼‍♂ E5.0 man in steamy room: medium-light skin tone
+1F9D6 1F3FD 200D 2642 FE0F ; fully-qualified # 🧖🏽‍♂️ E5.0 man in steamy room: medium skin tone
+1F9D6 1F3FD 200D 2642 ; minimally-qualified # 🧖🏽‍♂ E5.0 man in steamy room: medium skin tone
+1F9D6 1F3FE 200D 2642 FE0F ; fully-qualified # 🧖🏾‍♂️ E5.0 man in steamy room: medium-dark skin tone
+1F9D6 1F3FE 200D 2642 ; minimally-qualified # 🧖🏾‍♂ E5.0 man in steamy room: medium-dark skin tone
+1F9D6 1F3FF 200D 2642 FE0F ; fully-qualified # 🧖🏿‍♂️ E5.0 man in steamy room: dark skin tone
+1F9D6 1F3FF 200D 2642 ; minimally-qualified # 🧖🏿‍♂ E5.0 man in steamy room: dark skin tone
+1F9D6 200D 2640 FE0F ; fully-qualified # 🧖‍♀️ E5.0 woman in steamy room
+1F9D6 200D 2640 ; minimally-qualified # 🧖‍♀ E5.0 woman in steamy room
+1F9D6 1F3FB 200D 2640 FE0F ; fully-qualified # 🧖🏻‍♀️ E5.0 woman in steamy room: light skin tone
+1F9D6 1F3FB 200D 2640 ; minimally-qualified # 🧖🏻‍♀ E5.0 woman in steamy room: light skin tone
+1F9D6 1F3FC 200D 2640 FE0F ; fully-qualified # 🧖🏼‍♀️ E5.0 woman in steamy room: medium-light skin tone
+1F9D6 1F3FC 200D 2640 ; minimally-qualified # 🧖🏼‍♀ E5.0 woman in steamy room: medium-light skin tone
+1F9D6 1F3FD 200D 2640 FE0F ; fully-qualified # 🧖🏽‍♀️ E5.0 woman in steamy room: medium skin tone
+1F9D6 1F3FD 200D 2640 ; minimally-qualified # 🧖🏽‍♀ E5.0 woman in steamy room: medium skin tone
+1F9D6 1F3FE 200D 2640 FE0F ; fully-qualified # 🧖🏾‍♀️ E5.0 woman in steamy room: medium-dark skin tone
+1F9D6 1F3FE 200D 2640 ; minimally-qualified # 🧖🏾‍♀ E5.0 woman in steamy room: medium-dark skin tone
+1F9D6 1F3FF 200D 2640 FE0F ; fully-qualified # 🧖🏿‍♀️ E5.0 woman in steamy room: dark skin tone
+1F9D6 1F3FF 200D 2640 ; minimally-qualified # 🧖🏿‍♀ E5.0 woman in steamy room: dark skin tone
+1F9D7 ; fully-qualified # 🧗 E5.0 person climbing
+1F9D7 1F3FB ; fully-qualified # 🧗🏻 E5.0 person climbing: light skin tone
+1F9D7 1F3FC ; fully-qualified # 🧗🏼 E5.0 person climbing: medium-light skin tone
+1F9D7 1F3FD ; fully-qualified # 🧗🏽 E5.0 person climbing: medium skin tone
+1F9D7 1F3FE ; fully-qualified # 🧗🏾 E5.0 person climbing: medium-dark skin tone
+1F9D7 1F3FF ; fully-qualified # 🧗🏿 E5.0 person climbing: dark skin tone
+1F9D7 200D 2642 FE0F ; fully-qualified # 🧗‍♂️ E5.0 man climbing
+1F9D7 200D 2642 ; minimally-qualified # 🧗‍♂ E5.0 man climbing
+1F9D7 1F3FB 200D 2642 FE0F ; fully-qualified # 🧗🏻‍♂️ E5.0 man climbing: light skin tone
+1F9D7 1F3FB 200D 2642 ; minimally-qualified # 🧗🏻‍♂ E5.0 man climbing: light skin tone
+1F9D7 1F3FC 200D 2642 FE0F ; fully-qualified # 🧗🏼‍♂️ E5.0 man climbing: medium-light skin tone
+1F9D7 1F3FC 200D 2642 ; minimally-qualified # 🧗🏼‍♂ E5.0 man climbing: medium-light skin tone
+1F9D7 1F3FD 200D 2642 FE0F ; fully-qualified # 🧗🏽‍♂️ E5.0 man climbing: medium skin tone
+1F9D7 1F3FD 200D 2642 ; minimally-qualified # 🧗🏽‍♂ E5.0 man climbing: medium skin tone
+1F9D7 1F3FE 200D 2642 FE0F ; fully-qualified # 🧗🏾‍♂️ E5.0 man climbing: medium-dark skin tone
+1F9D7 1F3FE 200D 2642 ; minimally-qualified # 🧗🏾‍♂ E5.0 man climbing: medium-dark skin tone
+1F9D7 1F3FF 200D 2642 FE0F ; fully-qualified # 🧗🏿‍♂️ E5.0 man climbing: dark skin tone
+1F9D7 1F3FF 200D 2642 ; minimally-qualified # 🧗🏿‍♂ E5.0 man climbing: dark skin tone
+1F9D7 200D 2640 FE0F ; fully-qualified # 🧗‍♀️ E5.0 woman climbing
+1F9D7 200D 2640 ; minimally-qualified # 🧗‍♀ E5.0 woman climbing
+1F9D7 1F3FB 200D 2640 FE0F ; fully-qualified # 🧗🏻‍♀️ E5.0 woman climbing: light skin tone
+1F9D7 1F3FB 200D 2640 ; minimally-qualified # 🧗🏻‍♀ E5.0 woman climbing: light skin tone
+1F9D7 1F3FC 200D 2640 FE0F ; fully-qualified # 🧗🏼‍♀️ E5.0 woman climbing: medium-light skin tone
+1F9D7 1F3FC 200D 2640 ; minimally-qualified # 🧗🏼‍♀ E5.0 woman climbing: medium-light skin tone
+1F9D7 1F3FD 200D 2640 FE0F ; fully-qualified # 🧗🏽‍♀️ E5.0 woman climbing: medium skin tone
+1F9D7 1F3FD 200D 2640 ; minimally-qualified # 🧗🏽‍♀ E5.0 woman climbing: medium skin tone
+1F9D7 1F3FE 200D 2640 FE0F ; fully-qualified # 🧗🏾‍♀️ E5.0 woman climbing: medium-dark skin tone
+1F9D7 1F3FE 200D 2640 ; minimally-qualified # 🧗🏾‍♀ E5.0 woman climbing: medium-dark skin tone
+1F9D7 1F3FF 200D 2640 FE0F ; fully-qualified # 🧗🏿‍♀️ E5.0 woman climbing: dark skin tone
+1F9D7 1F3FF 200D 2640 ; minimally-qualified # 🧗🏿‍♀ E5.0 woman climbing: dark skin tone
+
+# subgroup: person-sport
+1F93A ; fully-qualified # 🤺 E3.0 person fencing
+1F3C7 ; fully-qualified # 🏇 E1.0 horse racing
+1F3C7 1F3FB ; fully-qualified # 🏇🏻 E1.0 horse racing: light skin tone
+1F3C7 1F3FC ; fully-qualified # 🏇🏼 E1.0 horse racing: medium-light skin tone
+1F3C7 1F3FD ; fully-qualified # 🏇🏽 E1.0 horse racing: medium skin tone
+1F3C7 1F3FE ; fully-qualified # 🏇🏾 E1.0 horse racing: medium-dark skin tone
+1F3C7 1F3FF ; fully-qualified # 🏇🏿 E1.0 horse racing: dark skin tone
+26F7 FE0F ; fully-qualified # ⛷️ E0.7 skier
+26F7 ; unqualified # ⛷ E0.7 skier
+1F3C2 ; fully-qualified # 🏂 E0.6 snowboarder
+1F3C2 1F3FB ; fully-qualified # 🏂🏻 E1.0 snowboarder: light skin tone
+1F3C2 1F3FC ; fully-qualified # 🏂🏼 E1.0 snowboarder: medium-light skin tone
+1F3C2 1F3FD ; fully-qualified # 🏂🏽 E1.0 snowboarder: medium skin tone
+1F3C2 1F3FE ; fully-qualified # 🏂🏾 E1.0 snowboarder: medium-dark skin tone
+1F3C2 1F3FF ; fully-qualified # 🏂🏿 E1.0 snowboarder: dark skin tone
+1F3CC FE0F ; fully-qualified # 🏌️ E0.7 person golfing
+1F3CC ; unqualified # 🏌 E0.7 person golfing
+1F3CC 1F3FB ; fully-qualified # 🏌🏻 E4.0 person golfing: light skin tone
+1F3CC 1F3FC ; fully-qualified # 🏌🏼 E4.0 person golfing: medium-light skin tone
+1F3CC 1F3FD ; fully-qualified # 🏌🏽 E4.0 person golfing: medium skin tone
+1F3CC 1F3FE ; fully-qualified # 🏌🏾 E4.0 person golfing: medium-dark skin tone
+1F3CC 1F3FF ; fully-qualified # 🏌🏿 E4.0 person golfing: dark skin tone
+1F3CC FE0F 200D 2642 FE0F ; fully-qualified # 🏌️‍♂️ E4.0 man golfing
+1F3CC 200D 2642 FE0F ; unqualified # 🏌‍♂️ E4.0 man golfing
+1F3CC FE0F 200D 2642 ; unqualified # 🏌️‍♂ E4.0 man golfing
+1F3CC 200D 2642 ; unqualified # 🏌‍♂ E4.0 man golfing
+1F3CC 1F3FB 200D 2642 FE0F ; fully-qualified # 🏌🏻‍♂️ E4.0 man golfing: light skin tone
+1F3CC 1F3FB 200D 2642 ; minimally-qualified # 🏌🏻‍♂ E4.0 man golfing: light skin tone
+1F3CC 1F3FC 200D 2642 FE0F ; fully-qualified # 🏌🏼‍♂️ E4.0 man golfing: medium-light skin tone
+1F3CC 1F3FC 200D 2642 ; minimally-qualified # 🏌🏼‍♂ E4.0 man golfing: medium-light skin tone
+1F3CC 1F3FD 200D 2642 FE0F ; fully-qualified # 🏌🏽‍♂️ E4.0 man golfing: medium skin tone
+1F3CC 1F3FD 200D 2642 ; minimally-qualified # 🏌🏽‍♂ E4.0 man golfing: medium skin tone
+1F3CC 1F3FE 200D 2642 FE0F ; fully-qualified # 🏌🏾‍♂️ E4.0 man golfing: medium-dark skin tone
+1F3CC 1F3FE 200D 2642 ; minimally-qualified # 🏌🏾‍♂ E4.0 man golfing: medium-dark skin tone
+1F3CC 1F3FF 200D 2642 FE0F ; fully-qualified # 🏌🏿‍♂️ E4.0 man golfing: dark skin tone
+1F3CC 1F3FF 200D 2642 ; minimally-qualified # 🏌🏿‍♂ E4.0 man golfing: dark skin tone
+1F3CC FE0F 200D 2640 FE0F ; fully-qualified # 🏌️‍♀️ E4.0 woman golfing
+1F3CC 200D 2640 FE0F ; unqualified # 🏌‍♀️ E4.0 woman golfing
+1F3CC FE0F 200D 2640 ; unqualified # 🏌️‍♀ E4.0 woman golfing
+1F3CC 200D 2640 ; unqualified # 🏌‍♀ E4.0 woman golfing
+1F3CC 1F3FB 200D 2640 FE0F ; fully-qualified # 🏌🏻‍♀️ E4.0 woman golfing: light skin tone
+1F3CC 1F3FB 200D 2640 ; minimally-qualified # 🏌🏻‍♀ E4.0 woman golfing: light skin tone
+1F3CC 1F3FC 200D 2640 FE0F ; fully-qualified # 🏌🏼‍♀️ E4.0 woman golfing: medium-light skin tone
+1F3CC 1F3FC 200D 2640 ; minimally-qualified # 🏌🏼‍♀ E4.0 woman golfing: medium-light skin tone
+1F3CC 1F3FD 200D 2640 FE0F ; fully-qualified # 🏌🏽‍♀️ E4.0 woman golfing: medium skin tone
+1F3CC 1F3FD 200D 2640 ; minimally-qualified # 🏌🏽‍♀ E4.0 woman golfing: medium skin tone
+1F3CC 1F3FE 200D 2640 FE0F ; fully-qualified # 🏌🏾‍♀️ E4.0 woman golfing: medium-dark skin tone
+1F3CC 1F3FE 200D 2640 ; minimally-qualified # 🏌🏾‍♀ E4.0 woman golfing: medium-dark skin tone
+1F3CC 1F3FF 200D 2640 FE0F ; fully-qualified # 🏌🏿‍♀️ E4.0 woman golfing: dark skin tone
+1F3CC 1F3FF 200D 2640 ; minimally-qualified # 🏌🏿‍♀ E4.0 woman golfing: dark skin tone
+1F3C4 ; fully-qualified # 🏄 E0.6 person surfing
+1F3C4 1F3FB ; fully-qualified # 🏄🏻 E1.0 person surfing: light skin tone
+1F3C4 1F3FC ; fully-qualified # 🏄🏼 E1.0 person surfing: medium-light skin tone
+1F3C4 1F3FD ; fully-qualified # 🏄🏽 E1.0 person surfing: medium skin tone
+1F3C4 1F3FE ; fully-qualified # 🏄🏾 E1.0 person surfing: medium-dark skin tone
+1F3C4 1F3FF ; fully-qualified # 🏄🏿 E1.0 person surfing: dark skin tone
+1F3C4 200D 2642 FE0F ; fully-qualified # 🏄‍♂️ E4.0 man surfing
+1F3C4 200D 2642 ; minimally-qualified # 🏄‍♂ E4.0 man surfing
+1F3C4 1F3FB 200D 2642 FE0F ; fully-qualified # 🏄🏻‍♂️ E4.0 man surfing: light skin tone
+1F3C4 1F3FB 200D 2642 ; minimally-qualified # 🏄🏻‍♂ E4.0 man surfing: light skin tone
+1F3C4 1F3FC 200D 2642 FE0F ; fully-qualified # 🏄🏼‍♂️ E4.0 man surfing: medium-light skin tone
+1F3C4 1F3FC 200D 2642 ; minimally-qualified # 🏄🏼‍♂ E4.0 man surfing: medium-light skin tone
+1F3C4 1F3FD 200D 2642 FE0F ; fully-qualified # 🏄🏽‍♂️ E4.0 man surfing: medium skin tone
+1F3C4 1F3FD 200D 2642 ; minimally-qualified # 🏄🏽‍♂ E4.0 man surfing: medium skin tone
+1F3C4 1F3FE 200D 2642 FE0F ; fully-qualified # 🏄🏾‍♂️ E4.0 man surfing: medium-dark skin tone
+1F3C4 1F3FE 200D 2642 ; minimally-qualified # 🏄🏾‍♂ E4.0 man surfing: medium-dark skin tone
+1F3C4 1F3FF 200D 2642 FE0F ; fully-qualified # 🏄🏿‍♂️ E4.0 man surfing: dark skin tone
+1F3C4 1F3FF 200D 2642 ; minimally-qualified # 🏄🏿‍♂ E4.0 man surfing: dark skin tone
+1F3C4 200D 2640 FE0F ; fully-qualified # 🏄‍♀️ E4.0 woman surfing
+1F3C4 200D 2640 ; minimally-qualified # 🏄‍♀ E4.0 woman surfing
+1F3C4 1F3FB 200D 2640 FE0F ; fully-qualified # 🏄🏻‍♀️ E4.0 woman surfing: light skin tone
+1F3C4 1F3FB 200D 2640 ; minimally-qualified # 🏄🏻‍♀ E4.0 woman surfing: light skin tone
+1F3C4 1F3FC 200D 2640 FE0F ; fully-qualified # 🏄🏼‍♀️ E4.0 woman surfing: medium-light skin tone
+1F3C4 1F3FC 200D 2640 ; minimally-qualified # 🏄🏼‍♀ E4.0 woman surfing: medium-light skin tone
+1F3C4 1F3FD 200D 2640 FE0F ; fully-qualified # 🏄🏽‍♀️ E4.0 woman surfing: medium skin tone
+1F3C4 1F3FD 200D 2640 ; minimally-qualified # 🏄🏽‍♀ E4.0 woman surfing: medium skin tone
+1F3C4 1F3FE 200D 2640 FE0F ; fully-qualified # 🏄🏾‍♀️ E4.0 woman surfing: medium-dark skin tone
+1F3C4 1F3FE 200D 2640 ; minimally-qualified # 🏄🏾‍♀ E4.0 woman surfing: medium-dark skin tone
+1F3C4 1F3FF 200D 2640 FE0F ; fully-qualified # 🏄🏿‍♀️ E4.0 woman surfing: dark skin tone
+1F3C4 1F3FF 200D 2640 ; minimally-qualified # 🏄🏿‍♀ E4.0 woman surfing: dark skin tone
+1F6A3 ; fully-qualified # 🚣 E1.0 person rowing boat
+1F6A3 1F3FB ; fully-qualified # 🚣🏻 E1.0 person rowing boat: light skin tone
+1F6A3 1F3FC ; fully-qualified # 🚣🏼 E1.0 person rowing boat: medium-light skin tone
+1F6A3 1F3FD ; fully-qualified # 🚣🏽 E1.0 person rowing boat: medium skin tone
+1F6A3 1F3FE ; fully-qualified # 🚣🏾 E1.0 person rowing boat: medium-dark skin tone
+1F6A3 1F3FF ; fully-qualified # 🚣🏿 E1.0 person rowing boat: dark skin tone
+1F6A3 200D 2642 FE0F ; fully-qualified # 🚣‍♂️ E4.0 man rowing boat
+1F6A3 200D 2642 ; minimally-qualified # 🚣‍♂ E4.0 man rowing boat
+1F6A3 1F3FB 200D 2642 FE0F ; fully-qualified # 🚣🏻‍♂️ E4.0 man rowing boat: light skin tone
+1F6A3 1F3FB 200D 2642 ; minimally-qualified # 🚣🏻‍♂ E4.0 man rowing boat: light skin tone
+1F6A3 1F3FC 200D 2642 FE0F ; fully-qualified # 🚣🏼‍♂️ E4.0 man rowing boat: medium-light skin tone
+1F6A3 1F3FC 200D 2642 ; minimally-qualified # 🚣🏼‍♂ E4.0 man rowing boat: medium-light skin tone
+1F6A3 1F3FD 200D 2642 FE0F ; fully-qualified # 🚣🏽‍♂️ E4.0 man rowing boat: medium skin tone
+1F6A3 1F3FD 200D 2642 ; minimally-qualified # 🚣🏽‍♂ E4.0 man rowing boat: medium skin tone
+1F6A3 1F3FE 200D 2642 FE0F ; fully-qualified # 🚣🏾‍♂️ E4.0 man rowing boat: medium-dark skin tone
+1F6A3 1F3FE 200D 2642 ; minimally-qualified # 🚣🏾‍♂ E4.0 man rowing boat: medium-dark skin tone
+1F6A3 1F3FF 200D 2642 FE0F ; fully-qualified # 🚣🏿‍♂️ E4.0 man rowing boat: dark skin tone
+1F6A3 1F3FF 200D 2642 ; minimally-qualified # 🚣🏿‍♂ E4.0 man rowing boat: dark skin tone
+1F6A3 200D 2640 FE0F ; fully-qualified # 🚣‍♀️ E4.0 woman rowing boat
+1F6A3 200D 2640 ; minimally-qualified # 🚣‍♀ E4.0 woman rowing boat
+1F6A3 1F3FB 200D 2640 FE0F ; fully-qualified # 🚣🏻‍♀️ E4.0 woman rowing boat: light skin tone
+1F6A3 1F3FB 200D 2640 ; minimally-qualified # 🚣🏻‍♀ E4.0 woman rowing boat: light skin tone
+1F6A3 1F3FC 200D 2640 FE0F ; fully-qualified # 🚣🏼‍♀️ E4.0 woman rowing boat: medium-light skin tone
+1F6A3 1F3FC 200D 2640 ; minimally-qualified # 🚣🏼‍♀ E4.0 woman rowing boat: medium-light skin tone
+1F6A3 1F3FD 200D 2640 FE0F ; fully-qualified # 🚣🏽‍♀️ E4.0 woman rowing boat: medium skin tone
+1F6A3 1F3FD 200D 2640 ; minimally-qualified # 🚣🏽‍♀ E4.0 woman rowing boat: medium skin tone
+1F6A3 1F3FE 200D 2640 FE0F ; fully-qualified # 🚣🏾‍♀️ E4.0 woman rowing boat: medium-dark skin tone
+1F6A3 1F3FE 200D 2640 ; minimally-qualified # 🚣🏾‍♀ E4.0 woman rowing boat: medium-dark skin tone
+1F6A3 1F3FF 200D 2640 FE0F ; fully-qualified # 🚣🏿‍♀️ E4.0 woman rowing boat: dark skin tone
+1F6A3 1F3FF 200D 2640 ; minimally-qualified # 🚣🏿‍♀ E4.0 woman rowing boat: dark skin tone
+1F3CA ; fully-qualified # 🏊 E0.6 person swimming
+1F3CA 1F3FB ; fully-qualified # 🏊🏻 E1.0 person swimming: light skin tone
+1F3CA 1F3FC ; fully-qualified # 🏊🏼 E1.0 person swimming: medium-light skin tone
+1F3CA 1F3FD ; fully-qualified # 🏊🏽 E1.0 person swimming: medium skin tone
+1F3CA 1F3FE ; fully-qualified # 🏊🏾 E1.0 person swimming: medium-dark skin tone
+1F3CA 1F3FF ; fully-qualified # 🏊🏿 E1.0 person swimming: dark skin tone
+1F3CA 200D 2642 FE0F ; fully-qualified # 🏊‍♂️ E4.0 man swimming
+1F3CA 200D 2642 ; minimally-qualified # 🏊‍♂ E4.0 man swimming
+1F3CA 1F3FB 200D 2642 FE0F ; fully-qualified # 🏊🏻‍♂️ E4.0 man swimming: light skin tone
+1F3CA 1F3FB 200D 2642 ; minimally-qualified # 🏊🏻‍♂ E4.0 man swimming: light skin tone
+1F3CA 1F3FC 200D 2642 FE0F ; fully-qualified # 🏊🏼‍♂️ E4.0 man swimming: medium-light skin tone
+1F3CA 1F3FC 200D 2642 ; minimally-qualified # 🏊🏼‍♂ E4.0 man swimming: medium-light skin tone
+1F3CA 1F3FD 200D 2642 FE0F ; fully-qualified # 🏊🏽‍♂️ E4.0 man swimming: medium skin tone
+1F3CA 1F3FD 200D 2642 ; minimally-qualified # 🏊🏽‍♂ E4.0 man swimming: medium skin tone
+1F3CA 1F3FE 200D 2642 FE0F ; fully-qualified # 🏊🏾‍♂️ E4.0 man swimming: medium-dark skin tone
+1F3CA 1F3FE 200D 2642 ; minimally-qualified # 🏊🏾‍♂ E4.0 man swimming: medium-dark skin tone
+1F3CA 1F3FF 200D 2642 FE0F ; fully-qualified # 🏊🏿‍♂️ E4.0 man swimming: dark skin tone
+1F3CA 1F3FF 200D 2642 ; minimally-qualified # 🏊🏿‍♂ E4.0 man swimming: dark skin tone
+1F3CA 200D 2640 FE0F ; fully-qualified # 🏊‍♀️ E4.0 woman swimming
+1F3CA 200D 2640 ; minimally-qualified # 🏊‍♀ E4.0 woman swimming
+1F3CA 1F3FB 200D 2640 FE0F ; fully-qualified # 🏊🏻‍♀️ E4.0 woman swimming: light skin tone
+1F3CA 1F3FB 200D 2640 ; minimally-qualified # 🏊🏻‍♀ E4.0 woman swimming: light skin tone
+1F3CA 1F3FC 200D 2640 FE0F ; fully-qualified # 🏊🏼‍♀️ E4.0 woman swimming: medium-light skin tone
+1F3CA 1F3FC 200D 2640 ; minimally-qualified # 🏊🏼‍♀ E4.0 woman swimming: medium-light skin tone
+1F3CA 1F3FD 200D 2640 FE0F ; fully-qualified # 🏊🏽‍♀️ E4.0 woman swimming: medium skin tone
+1F3CA 1F3FD 200D 2640 ; minimally-qualified # 🏊🏽‍♀ E4.0 woman swimming: medium skin tone
+1F3CA 1F3FE 200D 2640 FE0F ; fully-qualified # 🏊🏾‍♀️ E4.0 woman swimming: medium-dark skin tone
+1F3CA 1F3FE 200D 2640 ; minimally-qualified # 🏊🏾‍♀ E4.0 woman swimming: medium-dark skin tone
+1F3CA 1F3FF 200D 2640 FE0F ; fully-qualified # 🏊🏿‍♀️ E4.0 woman swimming: dark skin tone
+1F3CA 1F3FF 200D 2640 ; minimally-qualified # 🏊🏿‍♀ E4.0 woman swimming: dark skin tone
+26F9 FE0F ; fully-qualified # ⛹️ E0.7 person bouncing ball
+26F9 ; unqualified # ⛹ E0.7 person bouncing ball
+26F9 1F3FB ; fully-qualified # ⛹🏻 E2.0 person bouncing ball: light skin tone
+26F9 1F3FC ; fully-qualified # ⛹🏼 E2.0 person bouncing ball: medium-light skin tone
+26F9 1F3FD ; fully-qualified # ⛹🏽 E2.0 person bouncing ball: medium skin tone
+26F9 1F3FE ; fully-qualified # ⛹🏾 E2.0 person bouncing ball: medium-dark skin tone
+26F9 1F3FF ; fully-qualified # ⛹🏿 E2.0 person bouncing ball: dark skin tone
+26F9 FE0F 200D 2642 FE0F ; fully-qualified # ⛹️‍♂️ E4.0 man bouncing ball
+26F9 200D 2642 FE0F ; unqualified # ⛹‍♂️ E4.0 man bouncing ball
+26F9 FE0F 200D 2642 ; unqualified # ⛹️‍♂ E4.0 man bouncing ball
+26F9 200D 2642 ; unqualified # ⛹‍♂ E4.0 man bouncing ball
+26F9 1F3FB 200D 2642 FE0F ; fully-qualified # ⛹🏻‍♂️ E4.0 man bouncing ball: light skin tone
+26F9 1F3FB 200D 2642 ; minimally-qualified # ⛹🏻‍♂ E4.0 man bouncing ball: light skin tone
+26F9 1F3FC 200D 2642 FE0F ; fully-qualified # ⛹🏼‍♂️ E4.0 man bouncing ball: medium-light skin tone
+26F9 1F3FC 200D 2642 ; minimally-qualified # ⛹🏼‍♂ E4.0 man bouncing ball: medium-light skin tone
+26F9 1F3FD 200D 2642 FE0F ; fully-qualified # ⛹🏽‍♂️ E4.0 man bouncing ball: medium skin tone
+26F9 1F3FD 200D 2642 ; minimally-qualified # ⛹🏽‍♂ E4.0 man bouncing ball: medium skin tone
+26F9 1F3FE 200D 2642 FE0F ; fully-qualified # ⛹🏾‍♂️ E4.0 man bouncing ball: medium-dark skin tone
+26F9 1F3FE 200D 2642 ; minimally-qualified # ⛹🏾‍♂ E4.0 man bouncing ball: medium-dark skin tone
+26F9 1F3FF 200D 2642 FE0F ; fully-qualified # ⛹🏿‍♂️ E4.0 man bouncing ball: dark skin tone
+26F9 1F3FF 200D 2642 ; minimally-qualified # ⛹🏿‍♂ E4.0 man bouncing ball: dark skin tone
+26F9 FE0F 200D 2640 FE0F ; fully-qualified # ⛹️‍♀️ E4.0 woman bouncing ball
+26F9 200D 2640 FE0F ; unqualified # ⛹‍♀️ E4.0 woman bouncing ball
+26F9 FE0F 200D 2640 ; unqualified # ⛹️‍♀ E4.0 woman bouncing ball
+26F9 200D 2640 ; unqualified # ⛹‍♀ E4.0 woman bouncing ball
+26F9 1F3FB 200D 2640 FE0F ; fully-qualified # ⛹🏻‍♀️ E4.0 woman bouncing ball: light skin tone
+26F9 1F3FB 200D 2640 ; minimally-qualified # ⛹🏻‍♀ E4.0 woman bouncing ball: light skin tone
+26F9 1F3FC 200D 2640 FE0F ; fully-qualified # ⛹🏼‍♀️ E4.0 woman bouncing ball: medium-light skin tone
+26F9 1F3FC 200D 2640 ; minimally-qualified # ⛹🏼‍♀ E4.0 woman bouncing ball: medium-light skin tone
+26F9 1F3FD 200D 2640 FE0F ; fully-qualified # ⛹🏽‍♀️ E4.0 woman bouncing ball: medium skin tone
+26F9 1F3FD 200D 2640 ; minimally-qualified # ⛹🏽‍♀ E4.0 woman bouncing ball: medium skin tone
+26F9 1F3FE 200D 2640 FE0F ; fully-qualified # ⛹🏾‍♀️ E4.0 woman bouncing ball: medium-dark skin tone
+26F9 1F3FE 200D 2640 ; minimally-qualified # ⛹🏾‍♀ E4.0 woman bouncing ball: medium-dark skin tone
+26F9 1F3FF 200D 2640 FE0F ; fully-qualified # ⛹🏿‍♀️ E4.0 woman bouncing ball: dark skin tone
+26F9 1F3FF 200D 2640 ; minimally-qualified # ⛹🏿‍♀ E4.0 woman bouncing ball: dark skin tone
+1F3CB FE0F ; fully-qualified # 🏋️ E0.7 person lifting weights
+1F3CB ; unqualified # 🏋 E0.7 person lifting weights
+1F3CB 1F3FB ; fully-qualified # 🏋🏻 E2.0 person lifting weights: light skin tone
+1F3CB 1F3FC ; fully-qualified # 🏋🏼 E2.0 person lifting weights: medium-light skin tone
+1F3CB 1F3FD ; fully-qualified # 🏋🏽 E2.0 person lifting weights: medium skin tone
+1F3CB 1F3FE ; fully-qualified # 🏋🏾 E2.0 person lifting weights: medium-dark skin tone
+1F3CB 1F3FF ; fully-qualified # 🏋🏿 E2.0 person lifting weights: dark skin tone
+1F3CB FE0F 200D 2642 FE0F ; fully-qualified # 🏋️‍♂️ E4.0 man lifting weights
+1F3CB 200D 2642 FE0F ; unqualified # 🏋‍♂️ E4.0 man lifting weights
+1F3CB FE0F 200D 2642 ; unqualified # 🏋️‍♂ E4.0 man lifting weights
+1F3CB 200D 2642 ; unqualified # 🏋‍♂ E4.0 man lifting weights
+1F3CB 1F3FB 200D 2642 FE0F ; fully-qualified # 🏋🏻‍♂️ E4.0 man lifting weights: light skin tone
+1F3CB 1F3FB 200D 2642 ; minimally-qualified # 🏋🏻‍♂ E4.0 man lifting weights: light skin tone
+1F3CB 1F3FC 200D 2642 FE0F ; fully-qualified # 🏋🏼‍♂️ E4.0 man lifting weights: medium-light skin tone
+1F3CB 1F3FC 200D 2642 ; minimally-qualified # 🏋🏼‍♂ E4.0 man lifting weights: medium-light skin tone
+1F3CB 1F3FD 200D 2642 FE0F ; fully-qualified # 🏋🏽‍♂️ E4.0 man lifting weights: medium skin tone
+1F3CB 1F3FD 200D 2642 ; minimally-qualified # 🏋🏽‍♂ E4.0 man lifting weights: medium skin tone
+1F3CB 1F3FE 200D 2642 FE0F ; fully-qualified # 🏋🏾‍♂️ E4.0 man lifting weights: medium-dark skin tone
+1F3CB 1F3FE 200D 2642 ; minimally-qualified # 🏋🏾‍♂ E4.0 man lifting weights: medium-dark skin tone
+1F3CB 1F3FF 200D 2642 FE0F ; fully-qualified # 🏋🏿‍♂️ E4.0 man lifting weights: dark skin tone
+1F3CB 1F3FF 200D 2642 ; minimally-qualified # 🏋🏿‍♂ E4.0 man lifting weights: dark skin tone
+1F3CB FE0F 200D 2640 FE0F ; fully-qualified # 🏋️‍♀️ E4.0 woman lifting weights
+1F3CB 200D 2640 FE0F ; unqualified # 🏋‍♀️ E4.0 woman lifting weights
+1F3CB FE0F 200D 2640 ; unqualified # 🏋️‍♀ E4.0 woman lifting weights
+1F3CB 200D 2640 ; unqualified # 🏋‍♀ E4.0 woman lifting weights
+1F3CB 1F3FB 200D 2640 FE0F ; fully-qualified # 🏋🏻‍♀️ E4.0 woman lifting weights: light skin tone
+1F3CB 1F3FB 200D 2640 ; minimally-qualified # 🏋🏻‍♀ E4.0 woman lifting weights: light skin tone
+1F3CB 1F3FC 200D 2640 FE0F ; fully-qualified # 🏋🏼‍♀️ E4.0 woman lifting weights: medium-light skin tone
+1F3CB 1F3FC 200D 2640 ; minimally-qualified # 🏋🏼‍♀ E4.0 woman lifting weights: medium-light skin tone
+1F3CB 1F3FD 200D 2640 FE0F ; fully-qualified # 🏋🏽‍♀️ E4.0 woman lifting weights: medium skin tone
+1F3CB 1F3FD 200D 2640 ; minimally-qualified # 🏋🏽‍♀ E4.0 woman lifting weights: medium skin tone
+1F3CB 1F3FE 200D 2640 FE0F ; fully-qualified # 🏋🏾‍♀️ E4.0 woman lifting weights: medium-dark skin tone
+1F3CB 1F3FE 200D 2640 ; minimally-qualified # 🏋🏾‍♀ E4.0 woman lifting weights: medium-dark skin tone
+1F3CB 1F3FF 200D 2640 FE0F ; fully-qualified # 🏋🏿‍♀️ E4.0 woman lifting weights: dark skin tone
+1F3CB 1F3FF 200D 2640 ; minimally-qualified # 🏋🏿‍♀ E4.0 woman lifting weights: dark skin tone
+1F6B4 ; fully-qualified # 🚴 E1.0 person biking
+1F6B4 1F3FB ; fully-qualified # 🚴🏻 E1.0 person biking: light skin tone
+1F6B4 1F3FC ; fully-qualified # 🚴🏼 E1.0 person biking: medium-light skin tone
+1F6B4 1F3FD ; fully-qualified # 🚴🏽 E1.0 person biking: medium skin tone
+1F6B4 1F3FE ; fully-qualified # 🚴🏾 E1.0 person biking: medium-dark skin tone
+1F6B4 1F3FF ; fully-qualified # 🚴🏿 E1.0 person biking: dark skin tone
+1F6B4 200D 2642 FE0F ; fully-qualified # 🚴‍♂️ E4.0 man biking
+1F6B4 200D 2642 ; minimally-qualified # 🚴‍♂ E4.0 man biking
+1F6B4 1F3FB 200D 2642 FE0F ; fully-qualified # 🚴🏻‍♂️ E4.0 man biking: light skin tone
+1F6B4 1F3FB 200D 2642 ; minimally-qualified # 🚴🏻‍♂ E4.0 man biking: light skin tone
+1F6B4 1F3FC 200D 2642 FE0F ; fully-qualified # 🚴🏼‍♂️ E4.0 man biking: medium-light skin tone
+1F6B4 1F3FC 200D 2642 ; minimally-qualified # 🚴🏼‍♂ E4.0 man biking: medium-light skin tone
+1F6B4 1F3FD 200D 2642 FE0F ; fully-qualified # 🚴🏽‍♂️ E4.0 man biking: medium skin tone
+1F6B4 1F3FD 200D 2642 ; minimally-qualified # 🚴🏽‍♂ E4.0 man biking: medium skin tone
+1F6B4 1F3FE 200D 2642 FE0F ; fully-qualified # 🚴🏾‍♂️ E4.0 man biking: medium-dark skin tone
+1F6B4 1F3FE 200D 2642 ; minimally-qualified # 🚴🏾‍♂ E4.0 man biking: medium-dark skin tone
+1F6B4 1F3FF 200D 2642 FE0F ; fully-qualified # 🚴🏿‍♂️ E4.0 man biking: dark skin tone
+1F6B4 1F3FF 200D 2642 ; minimally-qualified # 🚴🏿‍♂ E4.0 man biking: dark skin tone
+1F6B4 200D 2640 FE0F ; fully-qualified # 🚴‍♀️ E4.0 woman biking
+1F6B4 200D 2640 ; minimally-qualified # 🚴‍♀ E4.0 woman biking
+1F6B4 1F3FB 200D 2640 FE0F ; fully-qualified # 🚴🏻‍♀️ E4.0 woman biking: light skin tone
+1F6B4 1F3FB 200D 2640 ; minimally-qualified # 🚴🏻‍♀ E4.0 woman biking: light skin tone
+1F6B4 1F3FC 200D 2640 FE0F ; fully-qualified # 🚴🏼‍♀️ E4.0 woman biking: medium-light skin tone
+1F6B4 1F3FC 200D 2640 ; minimally-qualified # 🚴🏼‍♀ E4.0 woman biking: medium-light skin tone
+1F6B4 1F3FD 200D 2640 FE0F ; fully-qualified # 🚴🏽‍♀️ E4.0 woman biking: medium skin tone
+1F6B4 1F3FD 200D 2640 ; minimally-qualified # 🚴🏽‍♀ E4.0 woman biking: medium skin tone
+1F6B4 1F3FE 200D 2640 FE0F ; fully-qualified # 🚴🏾‍♀️ E4.0 woman biking: medium-dark skin tone
+1F6B4 1F3FE 200D 2640 ; minimally-qualified # 🚴🏾‍♀ E4.0 woman biking: medium-dark skin tone
+1F6B4 1F3FF 200D 2640 FE0F ; fully-qualified # 🚴🏿‍♀️ E4.0 woman biking: dark skin tone
+1F6B4 1F3FF 200D 2640 ; minimally-qualified # 🚴🏿‍♀ E4.0 woman biking: dark skin tone
+1F6B5 ; fully-qualified # 🚵 E1.0 person mountain biking
+1F6B5 1F3FB ; fully-qualified # 🚵🏻 E1.0 person mountain biking: light skin tone
+1F6B5 1F3FC ; fully-qualified # 🚵🏼 E1.0 person mountain biking: medium-light skin tone
+1F6B5 1F3FD ; fully-qualified # 🚵🏽 E1.0 person mountain biking: medium skin tone
+1F6B5 1F3FE ; fully-qualified # 🚵🏾 E1.0 person mountain biking: medium-dark skin tone
+1F6B5 1F3FF ; fully-qualified # 🚵🏿 E1.0 person mountain biking: dark skin tone
+1F6B5 200D 2642 FE0F ; fully-qualified # 🚵‍♂️ E4.0 man mountain biking
+1F6B5 200D 2642 ; minimally-qualified # 🚵‍♂ E4.0 man mountain biking
+1F6B5 1F3FB 200D 2642 FE0F ; fully-qualified # 🚵🏻‍♂️ E4.0 man mountain biking: light skin tone
+1F6B5 1F3FB 200D 2642 ; minimally-qualified # 🚵🏻‍♂ E4.0 man mountain biking: light skin tone
+1F6B5 1F3FC 200D 2642 FE0F ; fully-qualified # 🚵🏼‍♂️ E4.0 man mountain biking: medium-light skin tone
+1F6B5 1F3FC 200D 2642 ; minimally-qualified # 🚵🏼‍♂ E4.0 man mountain biking: medium-light skin tone
+1F6B5 1F3FD 200D 2642 FE0F ; fully-qualified # 🚵🏽‍♂️ E4.0 man mountain biking: medium skin tone
+1F6B5 1F3FD 200D 2642 ; minimally-qualified # 🚵🏽‍♂ E4.0 man mountain biking: medium skin tone
+1F6B5 1F3FE 200D 2642 FE0F ; fully-qualified # 🚵🏾‍♂️ E4.0 man mountain biking: medium-dark skin tone
+1F6B5 1F3FE 200D 2642 ; minimally-qualified # 🚵🏾‍♂ E4.0 man mountain biking: medium-dark skin tone
+1F6B5 1F3FF 200D 2642 FE0F ; fully-qualified # 🚵🏿‍♂️ E4.0 man mountain biking: dark skin tone
+1F6B5 1F3FF 200D 2642 ; minimally-qualified # 🚵🏿‍♂ E4.0 man mountain biking: dark skin tone
+1F6B5 200D 2640 FE0F ; fully-qualified # 🚵‍♀️ E4.0 woman mountain biking
+1F6B5 200D 2640 ; minimally-qualified # 🚵‍♀ E4.0 woman mountain biking
+1F6B5 1F3FB 200D 2640 FE0F ; fully-qualified # 🚵🏻‍♀️ E4.0 woman mountain biking: light skin tone
+1F6B5 1F3FB 200D 2640 ; minimally-qualified # 🚵🏻‍♀ E4.0 woman mountain biking: light skin tone
+1F6B5 1F3FC 200D 2640 FE0F ; fully-qualified # 🚵🏼‍♀️ E4.0 woman mountain biking: medium-light skin tone
+1F6B5 1F3FC 200D 2640 ; minimally-qualified # 🚵🏼‍♀ E4.0 woman mountain biking: medium-light skin tone
+1F6B5 1F3FD 200D 2640 FE0F ; fully-qualified # 🚵🏽‍♀️ E4.0 woman mountain biking: medium skin tone
+1F6B5 1F3FD 200D 2640 ; minimally-qualified # 🚵🏽‍♀ E4.0 woman mountain biking: medium skin tone
+1F6B5 1F3FE 200D 2640 FE0F ; fully-qualified # 🚵🏾‍♀️ E4.0 woman mountain biking: medium-dark skin tone
+1F6B5 1F3FE 200D 2640 ; minimally-qualified # 🚵🏾‍♀ E4.0 woman mountain biking: medium-dark skin tone
+1F6B5 1F3FF 200D 2640 FE0F ; fully-qualified # 🚵🏿‍♀️ E4.0 woman mountain biking: dark skin tone
+1F6B5 1F3FF 200D 2640 ; minimally-qualified # 🚵🏿‍♀ E4.0 woman mountain biking: dark skin tone
+1F938 ; fully-qualified # 🤸 E3.0 person cartwheeling
+1F938 1F3FB ; fully-qualified # 🤸🏻 E3.0 person cartwheeling: light skin tone
+1F938 1F3FC ; fully-qualified # 🤸🏼 E3.0 person cartwheeling: medium-light skin tone
+1F938 1F3FD ; fully-qualified # 🤸🏽 E3.0 person cartwheeling: medium skin tone
+1F938 1F3FE ; fully-qualified # 🤸🏾 E3.0 person cartwheeling: medium-dark skin tone
+1F938 1F3FF ; fully-qualified # 🤸🏿 E3.0 person cartwheeling: dark skin tone
+1F938 200D 2642 FE0F ; fully-qualified # 🤸‍♂️ E4.0 man cartwheeling
+1F938 200D 2642 ; minimally-qualified # 🤸‍♂ E4.0 man cartwheeling
+1F938 1F3FB 200D 2642 FE0F ; fully-qualified # 🤸🏻‍♂️ E4.0 man cartwheeling: light skin tone
+1F938 1F3FB 200D 2642 ; minimally-qualified # 🤸🏻‍♂ E4.0 man cartwheeling: light skin tone
+1F938 1F3FC 200D 2642 FE0F ; fully-qualified # 🤸🏼‍♂️ E4.0 man cartwheeling: medium-light skin tone
+1F938 1F3FC 200D 2642 ; minimally-qualified # 🤸🏼‍♂ E4.0 man cartwheeling: medium-light skin tone
+1F938 1F3FD 200D 2642 FE0F ; fully-qualified # 🤸🏽‍♂️ E4.0 man cartwheeling: medium skin tone
+1F938 1F3FD 200D 2642 ; minimally-qualified # 🤸🏽‍♂ E4.0 man cartwheeling: medium skin tone
+1F938 1F3FE 200D 2642 FE0F ; fully-qualified # 🤸🏾‍♂️ E4.0 man cartwheeling: medium-dark skin tone
+1F938 1F3FE 200D 2642 ; minimally-qualified # 🤸🏾‍♂ E4.0 man cartwheeling: medium-dark skin tone
+1F938 1F3FF 200D 2642 FE0F ; fully-qualified # 🤸🏿‍♂️ E4.0 man cartwheeling: dark skin tone
+1F938 1F3FF 200D 2642 ; minimally-qualified # 🤸🏿‍♂ E4.0 man cartwheeling: dark skin tone
+1F938 200D 2640 FE0F ; fully-qualified # 🤸‍♀️ E4.0 woman cartwheeling
+1F938 200D 2640 ; minimally-qualified # 🤸‍♀ E4.0 woman cartwheeling
+1F938 1F3FB 200D 2640 FE0F ; fully-qualified # 🤸🏻‍♀️ E4.0 woman cartwheeling: light skin tone
+1F938 1F3FB 200D 2640 ; minimally-qualified # 🤸🏻‍♀ E4.0 woman cartwheeling: light skin tone
+1F938 1F3FC 200D 2640 FE0F ; fully-qualified # 🤸🏼‍♀️ E4.0 woman cartwheeling: medium-light skin tone
+1F938 1F3FC 200D 2640 ; minimally-qualified # 🤸🏼‍♀ E4.0 woman cartwheeling: medium-light skin tone
+1F938 1F3FD 200D 2640 FE0F ; fully-qualified # 🤸🏽‍♀️ E4.0 woman cartwheeling: medium skin tone
+1F938 1F3FD 200D 2640 ; minimally-qualified # 🤸🏽‍♀ E4.0 woman cartwheeling: medium skin tone
+1F938 1F3FE 200D 2640 FE0F ; fully-qualified # 🤸🏾‍♀️ E4.0 woman cartwheeling: medium-dark skin tone
+1F938 1F3FE 200D 2640 ; minimally-qualified # 🤸🏾‍♀ E4.0 woman cartwheeling: medium-dark skin tone
+1F938 1F3FF 200D 2640 FE0F ; fully-qualified # 🤸🏿‍♀️ E4.0 woman cartwheeling: dark skin tone
+1F938 1F3FF 200D 2640 ; minimally-qualified # 🤸🏿‍♀ E4.0 woman cartwheeling: dark skin tone
+1F93C ; fully-qualified # 🤼 E3.0 people wrestling
+1F93C 200D 2642 FE0F ; fully-qualified # 🤼‍♂️ E4.0 men wrestling
+1F93C 200D 2642 ; minimally-qualified # 🤼‍♂ E4.0 men wrestling
+1F93C 200D 2640 FE0F ; fully-qualified # 🤼‍♀️ E4.0 women wrestling
+1F93C 200D 2640 ; minimally-qualified # 🤼‍♀ E4.0 women wrestling
+1F93D ; fully-qualified # 🤽 E3.0 person playing water polo
+1F93D 1F3FB ; fully-qualified # 🤽🏻 E3.0 person playing water polo: light skin tone
+1F93D 1F3FC ; fully-qualified # 🤽🏼 E3.0 person playing water polo: medium-light skin tone
+1F93D 1F3FD ; fully-qualified # 🤽🏽 E3.0 person playing water polo: medium skin tone
+1F93D 1F3FE ; fully-qualified # 🤽🏾 E3.0 person playing water polo: medium-dark skin tone
+1F93D 1F3FF ; fully-qualified # 🤽🏿 E3.0 person playing water polo: dark skin tone
+1F93D 200D 2642 FE0F ; fully-qualified # 🤽‍♂️ E4.0 man playing water polo
+1F93D 200D 2642 ; minimally-qualified # 🤽‍♂ E4.0 man playing water polo
+1F93D 1F3FB 200D 2642 FE0F ; fully-qualified # 🤽🏻‍♂️ E4.0 man playing water polo: light skin tone
+1F93D 1F3FB 200D 2642 ; minimally-qualified # 🤽🏻‍♂ E4.0 man playing water polo: light skin tone
+1F93D 1F3FC 200D 2642 FE0F ; fully-qualified # 🤽🏼‍♂️ E4.0 man playing water polo: medium-light skin tone
+1F93D 1F3FC 200D 2642 ; minimally-qualified # 🤽🏼‍♂ E4.0 man playing water polo: medium-light skin tone
+1F93D 1F3FD 200D 2642 FE0F ; fully-qualified # 🤽🏽‍♂️ E4.0 man playing water polo: medium skin tone
+1F93D 1F3FD 200D 2642 ; minimally-qualified # 🤽🏽‍♂ E4.0 man playing water polo: medium skin tone
+1F93D 1F3FE 200D 2642 FE0F ; fully-qualified # 🤽🏾‍♂️ E4.0 man playing water polo: medium-dark skin tone
+1F93D 1F3FE 200D 2642 ; minimally-qualified # 🤽🏾‍♂ E4.0 man playing water polo: medium-dark skin tone
+1F93D 1F3FF 200D 2642 FE0F ; fully-qualified # 🤽🏿‍♂️ E4.0 man playing water polo: dark skin tone
+1F93D 1F3FF 200D 2642 ; minimally-qualified # 🤽🏿‍♂ E4.0 man playing water polo: dark skin tone
+1F93D 200D 2640 FE0F ; fully-qualified # 🤽‍♀️ E4.0 woman playing water polo
+1F93D 200D 2640 ; minimally-qualified # 🤽‍♀ E4.0 woman playing water polo
+1F93D 1F3FB 200D 2640 FE0F ; fully-qualified # 🤽🏻‍♀️ E4.0 woman playing water polo: light skin tone
+1F93D 1F3FB 200D 2640 ; minimally-qualified # 🤽🏻‍♀ E4.0 woman playing water polo: light skin tone
+1F93D 1F3FC 200D 2640 FE0F ; fully-qualified # 🤽🏼‍♀️ E4.0 woman playing water polo: medium-light skin tone
+1F93D 1F3FC 200D 2640 ; minimally-qualified # 🤽🏼‍♀ E4.0 woman playing water polo: medium-light skin tone
+1F93D 1F3FD 200D 2640 FE0F ; fully-qualified # 🤽🏽‍♀️ E4.0 woman playing water polo: medium skin tone
+1F93D 1F3FD 200D 2640 ; minimally-qualified # 🤽🏽‍♀ E4.0 woman playing water polo: medium skin tone
+1F93D 1F3FE 200D 2640 FE0F ; fully-qualified # 🤽🏾‍♀️ E4.0 woman playing water polo: medium-dark skin tone
+1F93D 1F3FE 200D 2640 ; minimally-qualified # 🤽🏾‍♀ E4.0 woman playing water polo: medium-dark skin tone
+1F93D 1F3FF 200D 2640 FE0F ; fully-qualified # 🤽🏿‍♀️ E4.0 woman playing water polo: dark skin tone
+1F93D 1F3FF 200D 2640 ; minimally-qualified # 🤽🏿‍♀ E4.0 woman playing water polo: dark skin tone
+1F93E ; fully-qualified # 🤾 E3.0 person playing handball
+1F93E 1F3FB ; fully-qualified # 🤾🏻 E3.0 person playing handball: light skin tone
+1F93E 1F3FC ; fully-qualified # 🤾🏼 E3.0 person playing handball: medium-light skin tone
+1F93E 1F3FD ; fully-qualified # 🤾🏽 E3.0 person playing handball: medium skin tone
+1F93E 1F3FE ; fully-qualified # 🤾🏾 E3.0 person playing handball: medium-dark skin tone
+1F93E 1F3FF ; fully-qualified # 🤾🏿 E3.0 person playing handball: dark skin tone
+1F93E 200D 2642 FE0F ; fully-qualified # 🤾‍♂️ E4.0 man playing handball
+1F93E 200D 2642 ; minimally-qualified # 🤾‍♂ E4.0 man playing handball
+1F93E 1F3FB 200D 2642 FE0F ; fully-qualified # 🤾🏻‍♂️ E4.0 man playing handball: light skin tone
+1F93E 1F3FB 200D 2642 ; minimally-qualified # 🤾🏻‍♂ E4.0 man playing handball: light skin tone
+1F93E 1F3FC 200D 2642 FE0F ; fully-qualified # 🤾🏼‍♂️ E4.0 man playing handball: medium-light skin tone
+1F93E 1F3FC 200D 2642 ; minimally-qualified # 🤾🏼‍♂ E4.0 man playing handball: medium-light skin tone
+1F93E 1F3FD 200D 2642 FE0F ; fully-qualified # 🤾🏽‍♂️ E4.0 man playing handball: medium skin tone
+1F93E 1F3FD 200D 2642 ; minimally-qualified # 🤾🏽‍♂ E4.0 man playing handball: medium skin tone
+1F93E 1F3FE 200D 2642 FE0F ; fully-qualified # 🤾🏾‍♂️ E4.0 man playing handball: medium-dark skin tone
+1F93E 1F3FE 200D 2642 ; minimally-qualified # 🤾🏾‍♂ E4.0 man playing handball: medium-dark skin tone
+1F93E 1F3FF 200D 2642 FE0F ; fully-qualified # 🤾🏿‍♂️ E4.0 man playing handball: dark skin tone
+1F93E 1F3FF 200D 2642 ; minimally-qualified # 🤾🏿‍♂ E4.0 man playing handball: dark skin tone
+1F93E 200D 2640 FE0F ; fully-qualified # 🤾‍♀️ E4.0 woman playing handball
+1F93E 200D 2640 ; minimally-qualified # 🤾‍♀ E4.0 woman playing handball
+1F93E 1F3FB 200D 2640 FE0F ; fully-qualified # 🤾🏻‍♀️ E4.0 woman playing handball: light skin tone
+1F93E 1F3FB 200D 2640 ; minimally-qualified # 🤾🏻‍♀ E4.0 woman playing handball: light skin tone
+1F93E 1F3FC 200D 2640 FE0F ; fully-qualified # 🤾🏼‍♀️ E4.0 woman playing handball: medium-light skin tone
+1F93E 1F3FC 200D 2640 ; minimally-qualified # 🤾🏼‍♀ E4.0 woman playing handball: medium-light skin tone
+1F93E 1F3FD 200D 2640 FE0F ; fully-qualified # 🤾🏽‍♀️ E4.0 woman playing handball: medium skin tone
+1F93E 1F3FD 200D 2640 ; minimally-qualified # 🤾🏽‍♀ E4.0 woman playing handball: medium skin tone
+1F93E 1F3FE 200D 2640 FE0F ; fully-qualified # 🤾🏾‍♀️ E4.0 woman playing handball: medium-dark skin tone
+1F93E 1F3FE 200D 2640 ; minimally-qualified # 🤾🏾‍♀ E4.0 woman playing handball: medium-dark skin tone
+1F93E 1F3FF 200D 2640 FE0F ; fully-qualified # 🤾🏿‍♀️ E4.0 woman playing handball: dark skin tone
+1F93E 1F3FF 200D 2640 ; minimally-qualified # 🤾🏿‍♀ E4.0 woman playing handball: dark skin tone
+1F939 ; fully-qualified # 🤹 E3.0 person juggling
+1F939 1F3FB ; fully-qualified # 🤹🏻 E3.0 person juggling: light skin tone
+1F939 1F3FC ; fully-qualified # 🤹🏼 E3.0 person juggling: medium-light skin tone
+1F939 1F3FD ; fully-qualified # 🤹🏽 E3.0 person juggling: medium skin tone
+1F939 1F3FE ; fully-qualified # 🤹🏾 E3.0 person juggling: medium-dark skin tone
+1F939 1F3FF ; fully-qualified # 🤹🏿 E3.0 person juggling: dark skin tone
+1F939 200D 2642 FE0F ; fully-qualified # 🤹‍♂️ E4.0 man juggling
+1F939 200D 2642 ; minimally-qualified # 🤹‍♂ E4.0 man juggling
+1F939 1F3FB 200D 2642 FE0F ; fully-qualified # 🤹🏻‍♂️ E4.0 man juggling: light skin tone
+1F939 1F3FB 200D 2642 ; minimally-qualified # 🤹🏻‍♂ E4.0 man juggling: light skin tone
+1F939 1F3FC 200D 2642 FE0F ; fully-qualified # 🤹🏼‍♂️ E4.0 man juggling: medium-light skin tone
+1F939 1F3FC 200D 2642 ; minimally-qualified # 🤹🏼‍♂ E4.0 man juggling: medium-light skin tone
+1F939 1F3FD 200D 2642 FE0F ; fully-qualified # 🤹🏽‍♂️ E4.0 man juggling: medium skin tone
+1F939 1F3FD 200D 2642 ; minimally-qualified # 🤹🏽‍♂ E4.0 man juggling: medium skin tone
+1F939 1F3FE 200D 2642 FE0F ; fully-qualified # 🤹🏾‍♂️ E4.0 man juggling: medium-dark skin tone
+1F939 1F3FE 200D 2642 ; minimally-qualified # 🤹🏾‍♂ E4.0 man juggling: medium-dark skin tone
+1F939 1F3FF 200D 2642 FE0F ; fully-qualified # 🤹🏿‍♂️ E4.0 man juggling: dark skin tone
+1F939 1F3FF 200D 2642 ; minimally-qualified # 🤹🏿‍♂ E4.0 man juggling: dark skin tone
+1F939 200D 2640 FE0F ; fully-qualified # 🤹‍♀️ E4.0 woman juggling
+1F939 200D 2640 ; minimally-qualified # 🤹‍♀ E4.0 woman juggling
+1F939 1F3FB 200D 2640 FE0F ; fully-qualified # 🤹🏻‍♀️ E4.0 woman juggling: light skin tone
+1F939 1F3FB 200D 2640 ; minimally-qualified # 🤹🏻‍♀ E4.0 woman juggling: light skin tone
+1F939 1F3FC 200D 2640 FE0F ; fully-qualified # 🤹🏼‍♀️ E4.0 woman juggling: medium-light skin tone
+1F939 1F3FC 200D 2640 ; minimally-qualified # 🤹🏼‍♀ E4.0 woman juggling: medium-light skin tone
+1F939 1F3FD 200D 2640 FE0F ; fully-qualified # 🤹🏽‍♀️ E4.0 woman juggling: medium skin tone
+1F939 1F3FD 200D 2640 ; minimally-qualified # 🤹🏽‍♀ E4.0 woman juggling: medium skin tone
+1F939 1F3FE 200D 2640 FE0F ; fully-qualified # 🤹🏾‍♀️ E4.0 woman juggling: medium-dark skin tone
+1F939 1F3FE 200D 2640 ; minimally-qualified # 🤹🏾‍♀ E4.0 woman juggling: medium-dark skin tone
+1F939 1F3FF 200D 2640 FE0F ; fully-qualified # 🤹🏿‍♀️ E4.0 woman juggling: dark skin tone
+1F939 1F3FF 200D 2640 ; minimally-qualified # 🤹🏿‍♀ E4.0 woman juggling: dark skin tone
+
+# subgroup: person-resting
+1F9D8 ; fully-qualified # 🧘 E5.0 person in lotus position
+1F9D8 1F3FB ; fully-qualified # 🧘🏻 E5.0 person in lotus position: light skin tone
+1F9D8 1F3FC ; fully-qualified # 🧘🏼 E5.0 person in lotus position: medium-light skin tone
+1F9D8 1F3FD ; fully-qualified # 🧘🏽 E5.0 person in lotus position: medium skin tone
+1F9D8 1F3FE ; fully-qualified # 🧘🏾 E5.0 person in lotus position: medium-dark skin tone
+1F9D8 1F3FF ; fully-qualified # 🧘🏿 E5.0 person in lotus position: dark skin tone
+1F9D8 200D 2642 FE0F ; fully-qualified # 🧘‍♂️ E5.0 man in lotus position
+1F9D8 200D 2642 ; minimally-qualified # 🧘‍♂ E5.0 man in lotus position
+1F9D8 1F3FB 200D 2642 FE0F ; fully-qualified # 🧘🏻‍♂️ E5.0 man in lotus position: light skin tone
+1F9D8 1F3FB 200D 2642 ; minimally-qualified # 🧘🏻‍♂ E5.0 man in lotus position: light skin tone
+1F9D8 1F3FC 200D 2642 FE0F ; fully-qualified # 🧘🏼‍♂️ E5.0 man in lotus position: medium-light skin tone
+1F9D8 1F3FC 200D 2642 ; minimally-qualified # 🧘🏼‍♂ E5.0 man in lotus position: medium-light skin tone
+1F9D8 1F3FD 200D 2642 FE0F ; fully-qualified # 🧘🏽‍♂️ E5.0 man in lotus position: medium skin tone
+1F9D8 1F3FD 200D 2642 ; minimally-qualified # 🧘🏽‍♂ E5.0 man in lotus position: medium skin tone
+1F9D8 1F3FE 200D 2642 FE0F ; fully-qualified # 🧘🏾‍♂️ E5.0 man in lotus position: medium-dark skin tone
+1F9D8 1F3FE 200D 2642 ; minimally-qualified # 🧘🏾‍♂ E5.0 man in lotus position: medium-dark skin tone
+1F9D8 1F3FF 200D 2642 FE0F ; fully-qualified # 🧘🏿‍♂️ E5.0 man in lotus position: dark skin tone
+1F9D8 1F3FF 200D 2642 ; minimally-qualified # 🧘🏿‍♂ E5.0 man in lotus position: dark skin tone
+1F9D8 200D 2640 FE0F ; fully-qualified # 🧘‍♀️ E5.0 woman in lotus position
+1F9D8 200D 2640 ; minimally-qualified # 🧘‍♀ E5.0 woman in lotus position
+1F9D8 1F3FB 200D 2640 FE0F ; fully-qualified # 🧘🏻‍♀️ E5.0 woman in lotus position: light skin tone
+1F9D8 1F3FB 200D 2640 ; minimally-qualified # 🧘🏻‍♀ E5.0 woman in lotus position: light skin tone
+1F9D8 1F3FC 200D 2640 FE0F ; fully-qualified # 🧘🏼‍♀️ E5.0 woman in lotus position: medium-light skin tone
+1F9D8 1F3FC 200D 2640 ; minimally-qualified # 🧘🏼‍♀ E5.0 woman in lotus position: medium-light skin tone
+1F9D8 1F3FD 200D 2640 FE0F ; fully-qualified # 🧘🏽‍♀️ E5.0 woman in lotus position: medium skin tone
+1F9D8 1F3FD 200D 2640 ; minimally-qualified # 🧘🏽‍♀ E5.0 woman in lotus position: medium skin tone
+1F9D8 1F3FE 200D 2640 FE0F ; fully-qualified # 🧘🏾‍♀️ E5.0 woman in lotus position: medium-dark skin tone
+1F9D8 1F3FE 200D 2640 ; minimally-qualified # 🧘🏾‍♀ E5.0 woman in lotus position: medium-dark skin tone
+1F9D8 1F3FF 200D 2640 FE0F ; fully-qualified # 🧘🏿‍♀️ E5.0 woman in lotus position: dark skin tone
+1F9D8 1F3FF 200D 2640 ; minimally-qualified # 🧘🏿‍♀ E5.0 woman in lotus position: dark skin tone
+1F6C0 ; fully-qualified # 🛀 E0.6 person taking bath
+1F6C0 1F3FB ; fully-qualified # 🛀🏻 E1.0 person taking bath: light skin tone
+1F6C0 1F3FC ; fully-qualified # 🛀🏼 E1.0 person taking bath: medium-light skin tone
+1F6C0 1F3FD ; fully-qualified # 🛀🏽 E1.0 person taking bath: medium skin tone
+1F6C0 1F3FE ; fully-qualified # 🛀🏾 E1.0 person taking bath: medium-dark skin tone
+1F6C0 1F3FF ; fully-qualified # 🛀🏿 E1.0 person taking bath: dark skin tone
+1F6CC ; fully-qualified # 🛌 E1.0 person in bed
+1F6CC 1F3FB ; fully-qualified # 🛌🏻 E4.0 person in bed: light skin tone
+1F6CC 1F3FC ; fully-qualified # 🛌🏼 E4.0 person in bed: medium-light skin tone
+1F6CC 1F3FD ; fully-qualified # 🛌🏽 E4.0 person in bed: medium skin tone
+1F6CC 1F3FE ; fully-qualified # 🛌🏾 E4.0 person in bed: medium-dark skin tone
+1F6CC 1F3FF ; fully-qualified # 🛌🏿 E4.0 person in bed: dark skin tone
+
+# subgroup: family
+1F9D1 200D 1F91D 200D 1F9D1 ; fully-qualified # 🧑‍🤝‍🧑 E12.0 people holding hands
+1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏻‍🤝‍🧑🏻 E12.0 people holding hands: light skin tone
+1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏻‍🤝‍🧑🏼 E12.1 people holding hands: light skin tone, medium-light skin tone
+1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏻‍🤝‍🧑🏽 E12.1 people holding hands: light skin tone, medium skin tone
+1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏻‍🤝‍🧑🏾 E12.1 people holding hands: light skin tone, medium-dark skin tone
+1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏻‍🤝‍🧑🏿 E12.1 people holding hands: light skin tone, dark skin tone
+1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏼‍🤝‍🧑🏻 E12.0 people holding hands: medium-light skin tone, light skin tone
+1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏼‍🤝‍🧑🏼 E12.0 people holding hands: medium-light skin tone
+1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏼‍🤝‍🧑🏽 E12.1 people holding hands: medium-light skin tone, medium skin tone
+1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏼‍🤝‍🧑🏾 E12.1 people holding hands: medium-light skin tone, medium-dark skin tone
+1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏼‍🤝‍🧑🏿 E12.1 people holding hands: medium-light skin tone, dark skin tone
+1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏽‍🤝‍🧑🏻 E12.0 people holding hands: medium skin tone, light skin tone
+1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏽‍🤝‍🧑🏼 E12.0 people holding hands: medium skin tone, medium-light skin tone
+1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏽‍🤝‍🧑🏽 E12.0 people holding hands: medium skin tone
+1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏽‍🤝‍🧑🏾 E12.1 people holding hands: medium skin tone, medium-dark skin tone
+1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏽‍🤝‍🧑🏿 E12.1 people holding hands: medium skin tone, dark skin tone
+1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏾‍🤝‍🧑🏻 E12.0 people holding hands: medium-dark skin tone, light skin tone
+1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏾‍🤝‍🧑🏼 E12.0 people holding hands: medium-dark skin tone, medium-light skin tone
+1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏾‍🤝‍🧑🏽 E12.0 people holding hands: medium-dark skin tone, medium skin tone
+1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏾‍🤝‍🧑🏾 E12.0 people holding hands: medium-dark skin tone
+1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏾‍🤝‍🧑🏿 E12.1 people holding hands: medium-dark skin tone, dark skin tone
+1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏿‍🤝‍🧑🏻 E12.0 people holding hands: dark skin tone, light skin tone
+1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏿‍🤝‍🧑🏼 E12.0 people holding hands: dark skin tone, medium-light skin tone
+1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏿‍🤝‍🧑🏽 E12.0 people holding hands: dark skin tone, medium skin tone
+1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏿‍🤝‍🧑🏾 E12.0 people holding hands: dark skin tone, medium-dark skin tone
+1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏿‍🤝‍🧑🏿 E12.0 people holding hands: dark skin tone
+1F46D ; fully-qualified # 👭 E1.0 women holding hands
+1F46D 1F3FB ; fully-qualified # 👭🏻 E12.0 women holding hands: light skin tone
+1F469 1F3FB 200D 1F91D 200D 1F469 1F3FC ; fully-qualified # 👩🏻‍🤝‍👩🏼 E12.1 women holding hands: light skin tone, medium-light skin tone
+1F469 1F3FB 200D 1F91D 200D 1F469 1F3FD ; fully-qualified # 👩🏻‍🤝‍👩🏽 E12.1 women holding hands: light skin tone, medium skin tone
+1F469 1F3FB 200D 1F91D 200D 1F469 1F3FE ; fully-qualified # 👩🏻‍🤝‍👩🏾 E12.1 women holding hands: light skin tone, medium-dark skin tone
+1F469 1F3FB 200D 1F91D 200D 1F469 1F3FF ; fully-qualified # 👩🏻‍🤝‍👩🏿 E12.1 women holding hands: light skin tone, dark skin tone
+1F469 1F3FC 200D 1F91D 200D 1F469 1F3FB ; fully-qualified # 👩🏼‍🤝‍👩🏻 E12.0 women holding hands: medium-light skin tone, light skin tone
+1F46D 1F3FC ; fully-qualified # 👭🏼 E12.0 women holding hands: medium-light skin tone
+1F469 1F3FC 200D 1F91D 200D 1F469 1F3FD ; fully-qualified # 👩🏼‍🤝‍👩🏽 E12.1 women holding hands: medium-light skin tone, medium skin tone
+1F469 1F3FC 200D 1F91D 200D 1F469 1F3FE ; fully-qualified # 👩🏼‍🤝‍👩🏾 E12.1 women holding hands: medium-light skin tone, medium-dark skin tone
+1F469 1F3FC 200D 1F91D 200D 1F469 1F3FF ; fully-qualified # 👩🏼‍🤝‍👩🏿 E12.1 women holding hands: medium-light skin tone, dark skin tone
+1F469 1F3FD 200D 1F91D 200D 1F469 1F3FB ; fully-qualified # 👩🏽‍🤝‍👩🏻 E12.0 women holding hands: medium skin tone, light skin tone
+1F469 1F3FD 200D 1F91D 200D 1F469 1F3FC ; fully-qualified # 👩🏽‍🤝‍👩🏼 E12.0 women holding hands: medium skin tone, medium-light skin tone
+1F46D 1F3FD ; fully-qualified # 👭🏽 E12.0 women holding hands: medium skin tone
+1F469 1F3FD 200D 1F91D 200D 1F469 1F3FE ; fully-qualified # 👩🏽‍🤝‍👩🏾 E12.1 women holding hands: medium skin tone, medium-dark skin tone
+1F469 1F3FD 200D 1F91D 200D 1F469 1F3FF ; fully-qualified # 👩🏽‍🤝‍👩🏿 E12.1 women holding hands: medium skin tone, dark skin tone
+1F469 1F3FE 200D 1F91D 200D 1F469 1F3FB ; fully-qualified # 👩🏾‍🤝‍👩🏻 E12.0 women holding hands: medium-dark skin tone, light skin tone
+1F469 1F3FE 200D 1F91D 200D 1F469 1F3FC ; fully-qualified # 👩🏾‍🤝‍👩🏼 E12.0 women holding hands: medium-dark skin tone, medium-light skin tone
+1F469 1F3FE 200D 1F91D 200D 1F469 1F3FD ; fully-qualified # 👩🏾‍🤝‍👩🏽 E12.0 women holding hands: medium-dark skin tone, medium skin tone
+1F46D 1F3FE ; fully-qualified # 👭🏾 E12.0 women holding hands: medium-dark skin tone
+1F469 1F3FE 200D 1F91D 200D 1F469 1F3FF ; fully-qualified # 👩🏾‍🤝‍👩🏿 E12.1 women holding hands: medium-dark skin tone, dark skin tone
+1F469 1F3FF 200D 1F91D 200D 1F469 1F3FB ; fully-qualified # 👩🏿‍🤝‍👩🏻 E12.0 women holding hands: dark skin tone, light skin tone
+1F469 1F3FF 200D 1F91D 200D 1F469 1F3FC ; fully-qualified # 👩🏿‍🤝‍👩🏼 E12.0 women holding hands: dark skin tone, medium-light skin tone
+1F469 1F3FF 200D 1F91D 200D 1F469 1F3FD ; fully-qualified # 👩🏿‍🤝‍👩🏽 E12.0 women holding hands: dark skin tone, medium skin tone
+1F469 1F3FF 200D 1F91D 200D 1F469 1F3FE ; fully-qualified # 👩🏿‍🤝‍👩🏾 E12.0 women holding hands: dark skin tone, medium-dark skin tone
+1F46D 1F3FF ; fully-qualified # 👭🏿 E12.0 women holding hands: dark skin tone
+1F46B ; fully-qualified # 👫 E0.6 woman and man holding hands
+1F46B 1F3FB ; fully-qualified # 👫🏻 E12.0 woman and man holding hands: light skin tone
+1F469 1F3FB 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👩🏻‍🤝‍👨🏼 E12.0 woman and man holding hands: light skin tone, medium-light skin tone
+1F469 1F3FB 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👩🏻‍🤝‍👨🏽 E12.0 woman and man holding hands: light skin tone, medium skin tone
+1F469 1F3FB 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👩🏻‍🤝‍👨🏾 E12.0 woman and man holding hands: light skin tone, medium-dark skin tone
+1F469 1F3FB 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👩🏻‍🤝‍👨🏿 E12.0 woman and man holding hands: light skin tone, dark skin tone
+1F469 1F3FC 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👩🏼‍🤝‍👨🏻 E12.0 woman and man holding hands: medium-light skin tone, light skin tone
+1F46B 1F3FC ; fully-qualified # 👫🏼 E12.0 woman and man holding hands: medium-light skin tone
+1F469 1F3FC 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👩🏼‍🤝‍👨🏽 E12.0 woman and man holding hands: medium-light skin tone, medium skin tone
+1F469 1F3FC 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👩🏼‍🤝‍👨🏾 E12.0 woman and man holding hands: medium-light skin tone, medium-dark skin tone
+1F469 1F3FC 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👩🏼‍🤝‍👨🏿 E12.0 woman and man holding hands: medium-light skin tone, dark skin tone
+1F469 1F3FD 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👩🏽‍🤝‍👨🏻 E12.0 woman and man holding hands: medium skin tone, light skin tone
+1F469 1F3FD 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👩🏽‍🤝‍👨🏼 E12.0 woman and man holding hands: medium skin tone, medium-light skin tone
+1F46B 1F3FD ; fully-qualified # 👫🏽 E12.0 woman and man holding hands: medium skin tone
+1F469 1F3FD 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👩🏽‍🤝‍👨🏾 E12.0 woman and man holding hands: medium skin tone, medium-dark skin tone
+1F469 1F3FD 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👩🏽‍🤝‍👨🏿 E12.0 woman and man holding hands: medium skin tone, dark skin tone
+1F469 1F3FE 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👩🏾‍🤝‍👨🏻 E12.0 woman and man holding hands: medium-dark skin tone, light skin tone
+1F469 1F3FE 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👩🏾‍🤝‍👨🏼 E12.0 woman and man holding hands: medium-dark skin tone, medium-light skin tone
+1F469 1F3FE 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👩🏾‍🤝‍👨🏽 E12.0 woman and man holding hands: medium-dark skin tone, medium skin tone
+1F46B 1F3FE ; fully-qualified # 👫🏾 E12.0 woman and man holding hands: medium-dark skin tone
+1F469 1F3FE 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👩🏾‍🤝‍👨🏿 E12.0 woman and man holding hands: medium-dark skin tone, dark skin tone
+1F469 1F3FF 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👩🏿‍🤝‍👨🏻 E12.0 woman and man holding hands: dark skin tone, light skin tone
+1F469 1F3FF 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👩🏿‍🤝‍👨🏼 E12.0 woman and man holding hands: dark skin tone, medium-light skin tone
+1F469 1F3FF 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👩🏿‍🤝‍👨🏽 E12.0 woman and man holding hands: dark skin tone, medium skin tone
+1F469 1F3FF 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👩🏿‍🤝‍👨🏾 E12.0 woman and man holding hands: dark skin tone, medium-dark skin tone
+1F46B 1F3FF ; fully-qualified # 👫🏿 E12.0 woman and man holding hands: dark skin tone
+1F46C ; fully-qualified # 👬 E1.0 men holding hands
+1F46C 1F3FB ; fully-qualified # 👬🏻 E12.0 men holding hands: light skin tone
+1F468 1F3FB 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👨🏻‍🤝‍👨🏼 E12.1 men holding hands: light skin tone, medium-light skin tone
+1F468 1F3FB 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👨🏻‍🤝‍👨🏽 E12.1 men holding hands: light skin tone, medium skin tone
+1F468 1F3FB 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👨🏻‍🤝‍👨🏾 E12.1 men holding hands: light skin tone, medium-dark skin tone
+1F468 1F3FB 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👨🏻‍🤝‍👨🏿 E12.1 men holding hands: light skin tone, dark skin tone
+1F468 1F3FC 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👨🏼‍🤝‍👨🏻 E12.0 men holding hands: medium-light skin tone, light skin tone
+1F46C 1F3FC ; fully-qualified # 👬🏼 E12.0 men holding hands: medium-light skin tone
+1F468 1F3FC 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👨🏼‍🤝‍👨🏽 E12.1 men holding hands: medium-light skin tone, medium skin tone
+1F468 1F3FC 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👨🏼‍🤝‍👨🏾 E12.1 men holding hands: medium-light skin tone, medium-dark skin tone
+1F468 1F3FC 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👨🏼‍🤝‍👨🏿 E12.1 men holding hands: medium-light skin tone, dark skin tone
+1F468 1F3FD 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👨🏽‍🤝‍👨🏻 E12.0 men holding hands: medium skin tone, light skin tone
+1F468 1F3FD 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👨🏽‍🤝‍👨🏼 E12.0 men holding hands: medium skin tone, medium-light skin tone
+1F46C 1F3FD ; fully-qualified # 👬🏽 E12.0 men holding hands: medium skin tone
+1F468 1F3FD 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👨🏽‍🤝‍👨🏾 E12.1 men holding hands: medium skin tone, medium-dark skin tone
+1F468 1F3FD 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👨🏽‍🤝‍👨🏿 E12.1 men holding hands: medium skin tone, dark skin tone
+1F468 1F3FE 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👨🏾‍🤝‍👨🏻 E12.0 men holding hands: medium-dark skin tone, light skin tone
+1F468 1F3FE 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👨🏾‍🤝‍👨🏼 E12.0 men holding hands: medium-dark skin tone, medium-light skin tone
+1F468 1F3FE 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👨🏾‍🤝‍👨🏽 E12.0 men holding hands: medium-dark skin tone, medium skin tone
+1F46C 1F3FE ; fully-qualified # 👬🏾 E12.0 men holding hands: medium-dark skin tone
+1F468 1F3FE 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👨🏾‍🤝‍👨🏿 E12.1 men holding hands: medium-dark skin tone, dark skin tone
+1F468 1F3FF 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👨🏿‍🤝‍👨🏻 E12.0 men holding hands: dark skin tone, light skin tone
+1F468 1F3FF 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👨🏿‍🤝‍👨🏼 E12.0 men holding hands: dark skin tone, medium-light skin tone
+1F468 1F3FF 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👨🏿‍🤝‍👨🏽 E12.0 men holding hands: dark skin tone, medium skin tone
+1F468 1F3FF 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👨🏿‍🤝‍👨🏾 E12.0 men holding hands: dark skin tone, medium-dark skin tone
+1F46C 1F3FF ; fully-qualified # 👬🏿 E12.0 men holding hands: dark skin tone
+1F48F ; fully-qualified # 💏 E0.6 kiss
+1F48F 1F3FB ; fully-qualified # 💏🏻 E13.1 kiss: light skin tone
+1F48F 1F3FC ; fully-qualified # 💏🏼 E13.1 kiss: medium-light skin tone
+1F48F 1F3FD ; fully-qualified # 💏🏽 E13.1 kiss: medium skin tone
+1F48F 1F3FE ; fully-qualified # 💏🏾 E13.1 kiss: medium-dark skin tone
+1F48F 1F3FF ; fully-qualified # 💏🏿 E13.1 kiss: dark skin tone
+1F9D1 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏻‍❤️‍💋‍🧑🏼 E13.1 kiss: person, person, light skin tone, medium-light skin tone
+1F9D1 1F3FB 200D 2764 200D 1F48B 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏻‍❤‍💋‍🧑🏼 E13.1 kiss: person, person, light skin tone, medium-light skin tone
+1F9D1 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏻‍❤️‍💋‍🧑🏽 E13.1 kiss: person, person, light skin tone, medium skin tone
+1F9D1 1F3FB 200D 2764 200D 1F48B 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏻‍❤‍💋‍🧑🏽 E13.1 kiss: person, person, light skin tone, medium skin tone
+1F9D1 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏻‍❤️‍💋‍🧑🏾 E13.1 kiss: person, person, light skin tone, medium-dark skin tone
+1F9D1 1F3FB 200D 2764 200D 1F48B 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏻‍❤‍💋‍🧑🏾 E13.1 kiss: person, person, light skin tone, medium-dark skin tone
+1F9D1 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏻‍❤️‍💋‍🧑🏿 E13.1 kiss: person, person, light skin tone, dark skin tone
+1F9D1 1F3FB 200D 2764 200D 1F48B 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏻‍❤‍💋‍🧑🏿 E13.1 kiss: person, person, light skin tone, dark skin tone
+1F9D1 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏼‍❤️‍💋‍🧑🏻 E13.1 kiss: person, person, medium-light skin tone, light skin tone
+1F9D1 1F3FC 200D 2764 200D 1F48B 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏼‍❤‍💋‍🧑🏻 E13.1 kiss: person, person, medium-light skin tone, light skin tone
+1F9D1 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏼‍❤️‍💋‍🧑🏽 E13.1 kiss: person, person, medium-light skin tone, medium skin tone
+1F9D1 1F3FC 200D 2764 200D 1F48B 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏼‍❤‍💋‍🧑🏽 E13.1 kiss: person, person, medium-light skin tone, medium skin tone
+1F9D1 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏼‍❤️‍💋‍🧑🏾 E13.1 kiss: person, person, medium-light skin tone, medium-dark skin tone
+1F9D1 1F3FC 200D 2764 200D 1F48B 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏼‍❤‍💋‍🧑🏾 E13.1 kiss: person, person, medium-light skin tone, medium-dark skin tone
+1F9D1 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏼‍❤️‍💋‍🧑🏿 E13.1 kiss: person, person, medium-light skin tone, dark skin tone
+1F9D1 1F3FC 200D 2764 200D 1F48B 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏼‍❤‍💋‍🧑🏿 E13.1 kiss: person, person, medium-light skin tone, dark skin tone
+1F9D1 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏽‍❤️‍💋‍🧑🏻 E13.1 kiss: person, person, medium skin tone, light skin tone
+1F9D1 1F3FD 200D 2764 200D 1F48B 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏽‍❤‍💋‍🧑🏻 E13.1 kiss: person, person, medium skin tone, light skin tone
+1F9D1 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏽‍❤️‍💋‍🧑🏼 E13.1 kiss: person, person, medium skin tone, medium-light skin tone
+1F9D1 1F3FD 200D 2764 200D 1F48B 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏽‍❤‍💋‍🧑🏼 E13.1 kiss: person, person, medium skin tone, medium-light skin tone
+1F9D1 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏽‍❤️‍💋‍🧑🏾 E13.1 kiss: person, person, medium skin tone, medium-dark skin tone
+1F9D1 1F3FD 200D 2764 200D 1F48B 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏽‍❤‍💋‍🧑🏾 E13.1 kiss: person, person, medium skin tone, medium-dark skin tone
+1F9D1 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏽‍❤️‍💋‍🧑🏿 E13.1 kiss: person, person, medium skin tone, dark skin tone
+1F9D1 1F3FD 200D 2764 200D 1F48B 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏽‍❤‍💋‍🧑🏿 E13.1 kiss: person, person, medium skin tone, dark skin tone
+1F9D1 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏾‍❤️‍💋‍🧑🏻 E13.1 kiss: person, person, medium-dark skin tone, light skin tone
+1F9D1 1F3FE 200D 2764 200D 1F48B 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏾‍❤‍💋‍🧑🏻 E13.1 kiss: person, person, medium-dark skin tone, light skin tone
+1F9D1 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏾‍❤️‍💋‍🧑🏼 E13.1 kiss: person, person, medium-dark skin tone, medium-light skin tone
+1F9D1 1F3FE 200D 2764 200D 1F48B 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏾‍❤‍💋‍🧑🏼 E13.1 kiss: person, person, medium-dark skin tone, medium-light skin tone
+1F9D1 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏾‍❤️‍💋‍🧑🏽 E13.1 kiss: person, person, medium-dark skin tone, medium skin tone
+1F9D1 1F3FE 200D 2764 200D 1F48B 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏾‍❤‍💋‍🧑🏽 E13.1 kiss: person, person, medium-dark skin tone, medium skin tone
+1F9D1 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏾‍❤️‍💋‍🧑🏿 E13.1 kiss: person, person, medium-dark skin tone, dark skin tone
+1F9D1 1F3FE 200D 2764 200D 1F48B 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏾‍❤‍💋‍🧑🏿 E13.1 kiss: person, person, medium-dark skin tone, dark skin tone
+1F9D1 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏿‍❤️‍💋‍🧑🏻 E13.1 kiss: person, person, dark skin tone, light skin tone
+1F9D1 1F3FF 200D 2764 200D 1F48B 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏿‍❤‍💋‍🧑🏻 E13.1 kiss: person, person, dark skin tone, light skin tone
+1F9D1 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏿‍❤️‍💋‍🧑🏼 E13.1 kiss: person, person, dark skin tone, medium-light skin tone
+1F9D1 1F3FF 200D 2764 200D 1F48B 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏿‍❤‍💋‍🧑🏼 E13.1 kiss: person, person, dark skin tone, medium-light skin tone
+1F9D1 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏿‍❤️‍💋‍🧑🏽 E13.1 kiss: person, person, dark skin tone, medium skin tone
+1F9D1 1F3FF 200D 2764 200D 1F48B 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏿‍❤‍💋‍🧑🏽 E13.1 kiss: person, person, dark skin tone, medium skin tone
+1F9D1 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏿‍❤️‍💋‍🧑🏾 E13.1 kiss: person, person, dark skin tone, medium-dark skin tone
+1F9D1 1F3FF 200D 2764 200D 1F48B 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏿‍❤‍💋‍🧑🏾 E13.1 kiss: person, person, dark skin tone, medium-dark skin tone
+1F469 200D 2764 FE0F 200D 1F48B 200D 1F468 ; fully-qualified # 👩‍❤️‍💋‍👨 E2.0 kiss: woman, man
+1F469 200D 2764 200D 1F48B 200D 1F468 ; minimally-qualified # 👩‍❤‍💋‍👨 E2.0 kiss: woman, man
+1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👩🏻‍❤️‍💋‍👨🏻 E13.1 kiss: woman, man, light skin tone
+1F469 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👩🏻‍❤‍💋‍👨🏻 E13.1 kiss: woman, man, light skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👩🏻‍❤️‍💋‍👨🏼 E13.1 kiss: woman, man, light skin tone, medium-light skin tone
+1F469 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👩🏻‍❤‍💋‍👨🏼 E13.1 kiss: woman, man, light skin tone, medium-light skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👩🏻‍❤️‍💋‍👨🏽 E13.1 kiss: woman, man, light skin tone, medium skin tone
+1F469 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👩🏻‍❤‍💋‍👨🏽 E13.1 kiss: woman, man, light skin tone, medium skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👩🏻‍❤️‍💋‍👨🏾 E13.1 kiss: woman, man, light skin tone, medium-dark skin tone
+1F469 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👩🏻‍❤‍💋‍👨🏾 E13.1 kiss: woman, man, light skin tone, medium-dark skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👩🏻‍❤️‍💋‍👨🏿 E13.1 kiss: woman, man, light skin tone, dark skin tone
+1F469 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👩🏻‍❤‍💋‍👨🏿 E13.1 kiss: woman, man, light skin tone, dark skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👩🏼‍❤️‍💋‍👨🏻 E13.1 kiss: woman, man, medium-light skin tone, light skin tone
+1F469 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👩🏼‍❤‍💋‍👨🏻 E13.1 kiss: woman, man, medium-light skin tone, light skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👩🏼‍❤️‍💋‍👨🏼 E13.1 kiss: woman, man, medium-light skin tone
+1F469 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👩🏼‍❤‍💋‍👨🏼 E13.1 kiss: woman, man, medium-light skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👩🏼‍❤️‍💋‍👨🏽 E13.1 kiss: woman, man, medium-light skin tone, medium skin tone
+1F469 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👩🏼‍❤‍💋‍👨🏽 E13.1 kiss: woman, man, medium-light skin tone, medium skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👩🏼‍❤️‍💋‍👨🏾 E13.1 kiss: woman, man, medium-light skin tone, medium-dark skin tone
+1F469 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👩🏼‍❤‍💋‍👨🏾 E13.1 kiss: woman, man, medium-light skin tone, medium-dark skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👩🏼‍❤️‍💋‍👨🏿 E13.1 kiss: woman, man, medium-light skin tone, dark skin tone
+1F469 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👩🏼‍❤‍💋‍👨🏿 E13.1 kiss: woman, man, medium-light skin tone, dark skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👩🏽‍❤️‍💋‍👨🏻 E13.1 kiss: woman, man, medium skin tone, light skin tone
+1F469 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👩🏽‍❤‍💋‍👨🏻 E13.1 kiss: woman, man, medium skin tone, light skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👩🏽‍❤️‍💋‍👨🏼 E13.1 kiss: woman, man, medium skin tone, medium-light skin tone
+1F469 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👩🏽‍❤‍💋‍👨🏼 E13.1 kiss: woman, man, medium skin tone, medium-light skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👩🏽‍❤️‍💋‍👨🏽 E13.1 kiss: woman, man, medium skin tone
+1F469 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👩🏽‍❤‍💋‍👨🏽 E13.1 kiss: woman, man, medium skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👩🏽‍❤️‍💋‍👨🏾 E13.1 kiss: woman, man, medium skin tone, medium-dark skin tone
+1F469 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👩🏽‍❤‍💋‍👨🏾 E13.1 kiss: woman, man, medium skin tone, medium-dark skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👩🏽‍❤️‍💋‍👨🏿 E13.1 kiss: woman, man, medium skin tone, dark skin tone
+1F469 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👩🏽‍❤‍💋‍👨🏿 E13.1 kiss: woman, man, medium skin tone, dark skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👩🏾‍❤️‍💋‍👨🏻 E13.1 kiss: woman, man, medium-dark skin tone, light skin tone
+1F469 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👩🏾‍❤‍💋‍👨🏻 E13.1 kiss: woman, man, medium-dark skin tone, light skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👩🏾‍❤️‍💋‍👨🏼 E13.1 kiss: woman, man, medium-dark skin tone, medium-light skin tone
+1F469 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👩🏾‍❤‍💋‍👨🏼 E13.1 kiss: woman, man, medium-dark skin tone, medium-light skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👩🏾‍❤️‍💋‍👨🏽 E13.1 kiss: woman, man, medium-dark skin tone, medium skin tone
+1F469 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👩🏾‍❤‍💋‍👨🏽 E13.1 kiss: woman, man, medium-dark skin tone, medium skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👩🏾‍❤️‍💋‍👨🏾 E13.1 kiss: woman, man, medium-dark skin tone
+1F469 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👩🏾‍❤‍💋‍👨🏾 E13.1 kiss: woman, man, medium-dark skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👩🏾‍❤️‍💋‍👨🏿 E13.1 kiss: woman, man, medium-dark skin tone, dark skin tone
+1F469 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👩🏾‍❤‍💋‍👨🏿 E13.1 kiss: woman, man, medium-dark skin tone, dark skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👩🏿‍❤️‍💋‍👨🏻 E13.1 kiss: woman, man, dark skin tone, light skin tone
+1F469 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👩🏿‍❤‍💋‍👨🏻 E13.1 kiss: woman, man, dark skin tone, light skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👩🏿‍❤️‍💋‍👨🏼 E13.1 kiss: woman, man, dark skin tone, medium-light skin tone
+1F469 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👩🏿‍❤‍💋‍👨🏼 E13.1 kiss: woman, man, dark skin tone, medium-light skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👩🏿‍❤️‍💋‍👨🏽 E13.1 kiss: woman, man, dark skin tone, medium skin tone
+1F469 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👩🏿‍❤‍💋‍👨🏽 E13.1 kiss: woman, man, dark skin tone, medium skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👩🏿‍❤️‍💋‍👨🏾 E13.1 kiss: woman, man, dark skin tone, medium-dark skin tone
+1F469 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👩🏿‍❤‍💋‍👨🏾 E13.1 kiss: woman, man, dark skin tone, medium-dark skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👩🏿‍❤️‍💋‍👨🏿 E13.1 kiss: woman, man, dark skin tone
+1F469 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👩🏿‍❤‍💋‍👨🏿 E13.1 kiss: woman, man, dark skin tone
+1F468 200D 2764 FE0F 200D 1F48B 200D 1F468 ; fully-qualified # 👨‍❤️‍💋‍👨 E2.0 kiss: man, man
+1F468 200D 2764 200D 1F48B 200D 1F468 ; minimally-qualified # 👨‍❤‍💋‍👨 E2.0 kiss: man, man
+1F468 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👨🏻‍❤️‍💋‍👨🏻 E13.1 kiss: man, man, light skin tone
+1F468 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👨🏻‍❤‍💋‍👨🏻 E13.1 kiss: man, man, light skin tone
+1F468 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👨🏻‍❤️‍💋‍👨🏼 E13.1 kiss: man, man, light skin tone, medium-light skin tone
+1F468 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👨🏻‍❤‍💋‍👨🏼 E13.1 kiss: man, man, light skin tone, medium-light skin tone
+1F468 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👨🏻‍❤️‍💋‍👨🏽 E13.1 kiss: man, man, light skin tone, medium skin tone
+1F468 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👨🏻‍❤‍💋‍👨🏽 E13.1 kiss: man, man, light skin tone, medium skin tone
+1F468 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👨🏻‍❤️‍💋‍👨🏾 E13.1 kiss: man, man, light skin tone, medium-dark skin tone
+1F468 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👨🏻‍❤‍💋‍👨🏾 E13.1 kiss: man, man, light skin tone, medium-dark skin tone
+1F468 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👨🏻‍❤️‍💋‍👨🏿 E13.1 kiss: man, man, light skin tone, dark skin tone
+1F468 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👨🏻‍❤‍💋‍👨🏿 E13.1 kiss: man, man, light skin tone, dark skin tone
+1F468 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👨🏼‍❤️‍💋‍👨🏻 E13.1 kiss: man, man, medium-light skin tone, light skin tone
+1F468 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👨🏼‍❤‍💋‍👨🏻 E13.1 kiss: man, man, medium-light skin tone, light skin tone
+1F468 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👨🏼‍❤️‍💋‍👨🏼 E13.1 kiss: man, man, medium-light skin tone
+1F468 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👨🏼‍❤‍💋‍👨🏼 E13.1 kiss: man, man, medium-light skin tone
+1F468 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👨🏼‍❤️‍💋‍👨🏽 E13.1 kiss: man, man, medium-light skin tone, medium skin tone
+1F468 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👨🏼‍❤‍💋‍👨🏽 E13.1 kiss: man, man, medium-light skin tone, medium skin tone
+1F468 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👨🏼‍❤️‍💋‍👨🏾 E13.1 kiss: man, man, medium-light skin tone, medium-dark skin tone
+1F468 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👨🏼‍❤‍💋‍👨🏾 E13.1 kiss: man, man, medium-light skin tone, medium-dark skin tone
+1F468 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👨🏼‍❤️‍💋‍👨🏿 E13.1 kiss: man, man, medium-light skin tone, dark skin tone
+1F468 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👨🏼‍❤‍💋‍👨🏿 E13.1 kiss: man, man, medium-light skin tone, dark skin tone
+1F468 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👨🏽‍❤️‍💋‍👨🏻 E13.1 kiss: man, man, medium skin tone, light skin tone
+1F468 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👨🏽‍❤‍💋‍👨🏻 E13.1 kiss: man, man, medium skin tone, light skin tone
+1F468 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👨🏽‍❤️‍💋‍👨🏼 E13.1 kiss: man, man, medium skin tone, medium-light skin tone
+1F468 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👨🏽‍❤‍💋‍👨🏼 E13.1 kiss: man, man, medium skin tone, medium-light skin tone
+1F468 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👨🏽‍❤️‍💋‍👨🏽 E13.1 kiss: man, man, medium skin tone
+1F468 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👨🏽‍❤‍💋‍👨🏽 E13.1 kiss: man, man, medium skin tone
+1F468 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👨🏽‍❤️‍💋‍👨🏾 E13.1 kiss: man, man, medium skin tone, medium-dark skin tone
+1F468 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👨🏽‍❤‍💋‍👨🏾 E13.1 kiss: man, man, medium skin tone, medium-dark skin tone
+1F468 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👨🏽‍❤️‍💋‍👨🏿 E13.1 kiss: man, man, medium skin tone, dark skin tone
+1F468 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👨🏽‍❤‍💋‍👨🏿 E13.1 kiss: man, man, medium skin tone, dark skin tone
+1F468 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👨🏾‍❤️‍💋‍👨🏻 E13.1 kiss: man, man, medium-dark skin tone, light skin tone
+1F468 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👨🏾‍❤‍💋‍👨🏻 E13.1 kiss: man, man, medium-dark skin tone, light skin tone
+1F468 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👨🏾‍❤️‍💋‍👨🏼 E13.1 kiss: man, man, medium-dark skin tone, medium-light skin tone
+1F468 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👨🏾‍❤‍💋‍👨🏼 E13.1 kiss: man, man, medium-dark skin tone, medium-light skin tone
+1F468 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👨🏾‍❤️‍💋‍👨🏽 E13.1 kiss: man, man, medium-dark skin tone, medium skin tone
+1F468 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👨🏾‍❤‍💋‍👨🏽 E13.1 kiss: man, man, medium-dark skin tone, medium skin tone
+1F468 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👨🏾‍❤️‍💋‍👨🏾 E13.1 kiss: man, man, medium-dark skin tone
+1F468 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👨🏾‍❤‍💋‍👨🏾 E13.1 kiss: man, man, medium-dark skin tone
+1F468 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👨🏾‍❤️‍💋‍👨🏿 E13.1 kiss: man, man, medium-dark skin tone, dark skin tone
+1F468 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👨🏾‍❤‍💋‍👨🏿 E13.1 kiss: man, man, medium-dark skin tone, dark skin tone
+1F468 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👨🏿‍❤️‍💋‍👨🏻 E13.1 kiss: man, man, dark skin tone, light skin tone
+1F468 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👨🏿‍❤‍💋‍👨🏻 E13.1 kiss: man, man, dark skin tone, light skin tone
+1F468 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👨🏿‍❤️‍💋‍👨🏼 E13.1 kiss: man, man, dark skin tone, medium-light skin tone
+1F468 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👨🏿‍❤‍💋‍👨🏼 E13.1 kiss: man, man, dark skin tone, medium-light skin tone
+1F468 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👨🏿‍❤️‍💋‍👨🏽 E13.1 kiss: man, man, dark skin tone, medium skin tone
+1F468 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👨🏿‍❤‍💋‍👨🏽 E13.1 kiss: man, man, dark skin tone, medium skin tone
+1F468 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👨🏿‍❤️‍💋‍👨🏾 E13.1 kiss: man, man, dark skin tone, medium-dark skin tone
+1F468 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👨🏿‍❤‍💋‍👨🏾 E13.1 kiss: man, man, dark skin tone, medium-dark skin tone
+1F468 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👨🏿‍❤️‍💋‍👨🏿 E13.1 kiss: man, man, dark skin tone
+1F468 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👨🏿‍❤‍💋‍👨🏿 E13.1 kiss: man, man, dark skin tone
+1F469 200D 2764 FE0F 200D 1F48B 200D 1F469 ; fully-qualified # 👩‍❤️‍💋‍👩 E2.0 kiss: woman, woman
+1F469 200D 2764 200D 1F48B 200D 1F469 ; minimally-qualified # 👩‍❤‍💋‍👩 E2.0 kiss: woman, woman
+1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FB ; fully-qualified # 👩🏻‍❤️‍💋‍👩🏻 E13.1 kiss: woman, woman, light skin tone
+1F469 1F3FB 200D 2764 200D 1F48B 200D 1F469 1F3FB ; minimally-qualified # 👩🏻‍❤‍💋‍👩🏻 E13.1 kiss: woman, woman, light skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FC ; fully-qualified # 👩🏻‍❤️‍💋‍👩🏼 E13.1 kiss: woman, woman, light skin tone, medium-light skin tone
+1F469 1F3FB 200D 2764 200D 1F48B 200D 1F469 1F3FC ; minimally-qualified # 👩🏻‍❤‍💋‍👩🏼 E13.1 kiss: woman, woman, light skin tone, medium-light skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FD ; fully-qualified # 👩🏻‍❤️‍💋‍👩🏽 E13.1 kiss: woman, woman, light skin tone, medium skin tone
+1F469 1F3FB 200D 2764 200D 1F48B 200D 1F469 1F3FD ; minimally-qualified # 👩🏻‍❤‍💋‍👩🏽 E13.1 kiss: woman, woman, light skin tone, medium skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FE ; fully-qualified # 👩🏻‍❤️‍💋‍👩🏾 E13.1 kiss: woman, woman, light skin tone, medium-dark skin tone
+1F469 1F3FB 200D 2764 200D 1F48B 200D 1F469 1F3FE ; minimally-qualified # 👩🏻‍❤‍💋‍👩🏾 E13.1 kiss: woman, woman, light skin tone, medium-dark skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FF ; fully-qualified # 👩🏻‍❤️‍💋‍👩🏿 E13.1 kiss: woman, woman, light skin tone, dark skin tone
+1F469 1F3FB 200D 2764 200D 1F48B 200D 1F469 1F3FF ; minimally-qualified # 👩🏻‍❤‍💋‍👩🏿 E13.1 kiss: woman, woman, light skin tone, dark skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FB ; fully-qualified # 👩🏼‍❤️‍💋‍👩🏻 E13.1 kiss: woman, woman, medium-light skin tone, light skin tone
+1F469 1F3FC 200D 2764 200D 1F48B 200D 1F469 1F3FB ; minimally-qualified # 👩🏼‍❤‍💋‍👩🏻 E13.1 kiss: woman, woman, medium-light skin tone, light skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FC ; fully-qualified # 👩🏼‍❤️‍💋‍👩🏼 E13.1 kiss: woman, woman, medium-light skin tone
+1F469 1F3FC 200D 2764 200D 1F48B 200D 1F469 1F3FC ; minimally-qualified # 👩🏼‍❤‍💋‍👩🏼 E13.1 kiss: woman, woman, medium-light skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FD ; fully-qualified # 👩🏼‍❤️‍💋‍👩🏽 E13.1 kiss: woman, woman, medium-light skin tone, medium skin tone
+1F469 1F3FC 200D 2764 200D 1F48B 200D 1F469 1F3FD ; minimally-qualified # 👩🏼‍❤‍💋‍👩🏽 E13.1 kiss: woman, woman, medium-light skin tone, medium skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FE ; fully-qualified # 👩🏼‍❤️‍💋‍👩🏾 E13.1 kiss: woman, woman, medium-light skin tone, medium-dark skin tone
+1F469 1F3FC 200D 2764 200D 1F48B 200D 1F469 1F3FE ; minimally-qualified # 👩🏼‍❤‍💋‍👩🏾 E13.1 kiss: woman, woman, medium-light skin tone, medium-dark skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FF ; fully-qualified # 👩🏼‍❤️‍💋‍👩🏿 E13.1 kiss: woman, woman, medium-light skin tone, dark skin tone
+1F469 1F3FC 200D 2764 200D 1F48B 200D 1F469 1F3FF ; minimally-qualified # 👩🏼‍❤‍💋‍👩🏿 E13.1 kiss: woman, woman, medium-light skin tone, dark skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FB ; fully-qualified # 👩🏽‍❤️‍💋‍👩🏻 E13.1 kiss: woman, woman, medium skin tone, light skin tone
+1F469 1F3FD 200D 2764 200D 1F48B 200D 1F469 1F3FB ; minimally-qualified # 👩🏽‍❤‍💋‍👩🏻 E13.1 kiss: woman, woman, medium skin tone, light skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FC ; fully-qualified # 👩🏽‍❤️‍💋‍👩🏼 E13.1 kiss: woman, woman, medium skin tone, medium-light skin tone
+1F469 1F3FD 200D 2764 200D 1F48B 200D 1F469 1F3FC ; minimally-qualified # 👩🏽‍❤‍💋‍👩🏼 E13.1 kiss: woman, woman, medium skin tone, medium-light skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FD ; fully-qualified # 👩🏽‍❤️‍💋‍👩🏽 E13.1 kiss: woman, woman, medium skin tone
+1F469 1F3FD 200D 2764 200D 1F48B 200D 1F469 1F3FD ; minimally-qualified # 👩🏽‍❤‍💋‍👩🏽 E13.1 kiss: woman, woman, medium skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FE ; fully-qualified # 👩🏽‍❤️‍💋‍👩🏾 E13.1 kiss: woman, woman, medium skin tone, medium-dark skin tone
+1F469 1F3FD 200D 2764 200D 1F48B 200D 1F469 1F3FE ; minimally-qualified # 👩🏽‍❤‍💋‍👩🏾 E13.1 kiss: woman, woman, medium skin tone, medium-dark skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FF ; fully-qualified # 👩🏽‍❤️‍💋‍👩🏿 E13.1 kiss: woman, woman, medium skin tone, dark skin tone
+1F469 1F3FD 200D 2764 200D 1F48B 200D 1F469 1F3FF ; minimally-qualified # 👩🏽‍❤‍💋‍👩🏿 E13.1 kiss: woman, woman, medium skin tone, dark skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FB ; fully-qualified # 👩🏾‍❤️‍💋‍👩🏻 E13.1 kiss: woman, woman, medium-dark skin tone, light skin tone
+1F469 1F3FE 200D 2764 200D 1F48B 200D 1F469 1F3FB ; minimally-qualified # 👩🏾‍❤‍💋‍👩🏻 E13.1 kiss: woman, woman, medium-dark skin tone, light skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FC ; fully-qualified # 👩🏾‍❤️‍💋‍👩🏼 E13.1 kiss: woman, woman, medium-dark skin tone, medium-light skin tone
+1F469 1F3FE 200D 2764 200D 1F48B 200D 1F469 1F3FC ; minimally-qualified # 👩🏾‍❤‍💋‍👩🏼 E13.1 kiss: woman, woman, medium-dark skin tone, medium-light skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FD ; fully-qualified # 👩🏾‍❤️‍💋‍👩🏽 E13.1 kiss: woman, woman, medium-dark skin tone, medium skin tone
+1F469 1F3FE 200D 2764 200D 1F48B 200D 1F469 1F3FD ; minimally-qualified # 👩🏾‍❤‍💋‍👩🏽 E13.1 kiss: woman, woman, medium-dark skin tone, medium skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FE ; fully-qualified # 👩🏾‍❤️‍💋‍👩🏾 E13.1 kiss: woman, woman, medium-dark skin tone
+1F469 1F3FE 200D 2764 200D 1F48B 200D 1F469 1F3FE ; minimally-qualified # 👩🏾‍❤‍💋‍👩🏾 E13.1 kiss: woman, woman, medium-dark skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FF ; fully-qualified # 👩🏾‍❤️‍💋‍👩🏿 E13.1 kiss: woman, woman, medium-dark skin tone, dark skin tone
+1F469 1F3FE 200D 2764 200D 1F48B 200D 1F469 1F3FF ; minimally-qualified # 👩🏾‍❤‍💋‍👩🏿 E13.1 kiss: woman, woman, medium-dark skin tone, dark skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FB ; fully-qualified # 👩🏿‍❤️‍💋‍👩🏻 E13.1 kiss: woman, woman, dark skin tone, light skin tone
+1F469 1F3FF 200D 2764 200D 1F48B 200D 1F469 1F3FB ; minimally-qualified # 👩🏿‍❤‍💋‍👩🏻 E13.1 kiss: woman, woman, dark skin tone, light skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FC ; fully-qualified # 👩🏿‍❤️‍💋‍👩🏼 E13.1 kiss: woman, woman, dark skin tone, medium-light skin tone
+1F469 1F3FF 200D 2764 200D 1F48B 200D 1F469 1F3FC ; minimally-qualified # 👩🏿‍❤‍💋‍👩🏼 E13.1 kiss: woman, woman, dark skin tone, medium-light skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FD ; fully-qualified # 👩🏿‍❤️‍💋‍👩🏽 E13.1 kiss: woman, woman, dark skin tone, medium skin tone
+1F469 1F3FF 200D 2764 200D 1F48B 200D 1F469 1F3FD ; minimally-qualified # 👩🏿‍❤‍💋‍👩🏽 E13.1 kiss: woman, woman, dark skin tone, medium skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FE ; fully-qualified # 👩🏿‍❤️‍💋‍👩🏾 E13.1 kiss: woman, woman, dark skin tone, medium-dark skin tone
+1F469 1F3FF 200D 2764 200D 1F48B 200D 1F469 1F3FE ; minimally-qualified # 👩🏿‍❤‍💋‍👩🏾 E13.1 kiss: woman, woman, dark skin tone, medium-dark skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FF ; fully-qualified # 👩🏿‍❤️‍💋‍👩🏿 E13.1 kiss: woman, woman, dark skin tone
+1F469 1F3FF 200D 2764 200D 1F48B 200D 1F469 1F3FF ; minimally-qualified # 👩🏿‍❤‍💋‍👩🏿 E13.1 kiss: woman, woman, dark skin tone
+1F491 ; fully-qualified # 💑 E0.6 couple with heart
+1F491 1F3FB ; fully-qualified # 💑🏻 E13.1 couple with heart: light skin tone
+1F491 1F3FC ; fully-qualified # 💑🏼 E13.1 couple with heart: medium-light skin tone
+1F491 1F3FD ; fully-qualified # 💑🏽 E13.1 couple with heart: medium skin tone
+1F491 1F3FE ; fully-qualified # 💑🏾 E13.1 couple with heart: medium-dark skin tone
+1F491 1F3FF ; fully-qualified # 💑🏿 E13.1 couple with heart: dark skin tone
+1F9D1 1F3FB 200D 2764 FE0F 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏻‍❤️‍🧑🏼 E13.1 couple with heart: person, person, light skin tone, medium-light skin tone
+1F9D1 1F3FB 200D 2764 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏻‍❤‍🧑🏼 E13.1 couple with heart: person, person, light skin tone, medium-light skin tone
+1F9D1 1F3FB 200D 2764 FE0F 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏻‍❤️‍🧑🏽 E13.1 couple with heart: person, person, light skin tone, medium skin tone
+1F9D1 1F3FB 200D 2764 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏻‍❤‍🧑🏽 E13.1 couple with heart: person, person, light skin tone, medium skin tone
+1F9D1 1F3FB 200D 2764 FE0F 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏻‍❤️‍🧑🏾 E13.1 couple with heart: person, person, light skin tone, medium-dark skin tone
+1F9D1 1F3FB 200D 2764 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏻‍❤‍🧑🏾 E13.1 couple with heart: person, person, light skin tone, medium-dark skin tone
+1F9D1 1F3FB 200D 2764 FE0F 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏻‍❤️‍🧑🏿 E13.1 couple with heart: person, person, light skin tone, dark skin tone
+1F9D1 1F3FB 200D 2764 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏻‍❤‍🧑🏿 E13.1 couple with heart: person, person, light skin tone, dark skin tone
+1F9D1 1F3FC 200D 2764 FE0F 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏼‍❤️‍🧑🏻 E13.1 couple with heart: person, person, medium-light skin tone, light skin tone
+1F9D1 1F3FC 200D 2764 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏼‍❤‍🧑🏻 E13.1 couple with heart: person, person, medium-light skin tone, light skin tone
+1F9D1 1F3FC 200D 2764 FE0F 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏼‍❤️‍🧑🏽 E13.1 couple with heart: person, person, medium-light skin tone, medium skin tone
+1F9D1 1F3FC 200D 2764 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏼‍❤‍🧑🏽 E13.1 couple with heart: person, person, medium-light skin tone, medium skin tone
+1F9D1 1F3FC 200D 2764 FE0F 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏼‍❤️‍🧑🏾 E13.1 couple with heart: person, person, medium-light skin tone, medium-dark skin tone
+1F9D1 1F3FC 200D 2764 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏼‍❤‍🧑🏾 E13.1 couple with heart: person, person, medium-light skin tone, medium-dark skin tone
+1F9D1 1F3FC 200D 2764 FE0F 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏼‍❤️‍🧑🏿 E13.1 couple with heart: person, person, medium-light skin tone, dark skin tone
+1F9D1 1F3FC 200D 2764 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏼‍❤‍🧑🏿 E13.1 couple with heart: person, person, medium-light skin tone, dark skin tone
+1F9D1 1F3FD 200D 2764 FE0F 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏽‍❤️‍🧑🏻 E13.1 couple with heart: person, person, medium skin tone, light skin tone
+1F9D1 1F3FD 200D 2764 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏽‍❤‍🧑🏻 E13.1 couple with heart: person, person, medium skin tone, light skin tone
+1F9D1 1F3FD 200D 2764 FE0F 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏽‍❤️‍🧑🏼 E13.1 couple with heart: person, person, medium skin tone, medium-light skin tone
+1F9D1 1F3FD 200D 2764 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏽‍❤‍🧑🏼 E13.1 couple with heart: person, person, medium skin tone, medium-light skin tone
+1F9D1 1F3FD 200D 2764 FE0F 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏽‍❤️‍🧑🏾 E13.1 couple with heart: person, person, medium skin tone, medium-dark skin tone
+1F9D1 1F3FD 200D 2764 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏽‍❤‍🧑🏾 E13.1 couple with heart: person, person, medium skin tone, medium-dark skin tone
+1F9D1 1F3FD 200D 2764 FE0F 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏽‍❤️‍🧑🏿 E13.1 couple with heart: person, person, medium skin tone, dark skin tone
+1F9D1 1F3FD 200D 2764 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏽‍❤‍🧑🏿 E13.1 couple with heart: person, person, medium skin tone, dark skin tone
+1F9D1 1F3FE 200D 2764 FE0F 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏾‍❤️‍🧑🏻 E13.1 couple with heart: person, person, medium-dark skin tone, light skin tone
+1F9D1 1F3FE 200D 2764 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏾‍❤‍🧑🏻 E13.1 couple with heart: person, person, medium-dark skin tone, light skin tone
+1F9D1 1F3FE 200D 2764 FE0F 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏾‍❤️‍🧑🏼 E13.1 couple with heart: person, person, medium-dark skin tone, medium-light skin tone
+1F9D1 1F3FE 200D 2764 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏾‍❤‍🧑🏼 E13.1 couple with heart: person, person, medium-dark skin tone, medium-light skin tone
+1F9D1 1F3FE 200D 2764 FE0F 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏾‍❤️‍🧑🏽 E13.1 couple with heart: person, person, medium-dark skin tone, medium skin tone
+1F9D1 1F3FE 200D 2764 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏾‍❤‍🧑🏽 E13.1 couple with heart: person, person, medium-dark skin tone, medium skin tone
+1F9D1 1F3FE 200D 2764 FE0F 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏾‍❤️‍🧑🏿 E13.1 couple with heart: person, person, medium-dark skin tone, dark skin tone
+1F9D1 1F3FE 200D 2764 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏾‍❤‍🧑🏿 E13.1 couple with heart: person, person, medium-dark skin tone, dark skin tone
+1F9D1 1F3FF 200D 2764 FE0F 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏿‍❤️‍🧑🏻 E13.1 couple with heart: person, person, dark skin tone, light skin tone
+1F9D1 1F3FF 200D 2764 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏿‍❤‍🧑🏻 E13.1 couple with heart: person, person, dark skin tone, light skin tone
+1F9D1 1F3FF 200D 2764 FE0F 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏿‍❤️‍🧑🏼 E13.1 couple with heart: person, person, dark skin tone, medium-light skin tone
+1F9D1 1F3FF 200D 2764 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏿‍❤‍🧑🏼 E13.1 couple with heart: person, person, dark skin tone, medium-light skin tone
+1F9D1 1F3FF 200D 2764 FE0F 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏿‍❤️‍🧑🏽 E13.1 couple with heart: person, person, dark skin tone, medium skin tone
+1F9D1 1F3FF 200D 2764 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏿‍❤‍🧑🏽 E13.1 couple with heart: person, person, dark skin tone, medium skin tone
+1F9D1 1F3FF 200D 2764 FE0F 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏿‍❤️‍🧑🏾 E13.1 couple with heart: person, person, dark skin tone, medium-dark skin tone
+1F9D1 1F3FF 200D 2764 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏿‍❤‍🧑🏾 E13.1 couple with heart: person, person, dark skin tone, medium-dark skin tone
+1F469 200D 2764 FE0F 200D 1F468 ; fully-qualified # 👩‍❤️‍👨 E2.0 couple with heart: woman, man
+1F469 200D 2764 200D 1F468 ; minimally-qualified # 👩‍❤‍👨 E2.0 couple with heart: woman, man
+1F469 1F3FB 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👩🏻‍❤️‍👨🏻 E13.1 couple with heart: woman, man, light skin tone
+1F469 1F3FB 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👩🏻‍❤‍👨🏻 E13.1 couple with heart: woman, man, light skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👩🏻‍❤️‍👨🏼 E13.1 couple with heart: woman, man, light skin tone, medium-light skin tone
+1F469 1F3FB 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👩🏻‍❤‍👨🏼 E13.1 couple with heart: woman, man, light skin tone, medium-light skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👩🏻‍❤️‍👨🏽 E13.1 couple with heart: woman, man, light skin tone, medium skin tone
+1F469 1F3FB 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👩🏻‍❤‍👨🏽 E13.1 couple with heart: woman, man, light skin tone, medium skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👩🏻‍❤️‍👨🏾 E13.1 couple with heart: woman, man, light skin tone, medium-dark skin tone
+1F469 1F3FB 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👩🏻‍❤‍👨🏾 E13.1 couple with heart: woman, man, light skin tone, medium-dark skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👩🏻‍❤️‍👨🏿 E13.1 couple with heart: woman, man, light skin tone, dark skin tone
+1F469 1F3FB 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👩🏻‍❤‍👨🏿 E13.1 couple with heart: woman, man, light skin tone, dark skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👩🏼‍❤️‍👨🏻 E13.1 couple with heart: woman, man, medium-light skin tone, light skin tone
+1F469 1F3FC 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👩🏼‍❤‍👨🏻 E13.1 couple with heart: woman, man, medium-light skin tone, light skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👩🏼‍❤️‍👨🏼 E13.1 couple with heart: woman, man, medium-light skin tone
+1F469 1F3FC 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👩🏼‍❤‍👨🏼 E13.1 couple with heart: woman, man, medium-light skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👩🏼‍❤️‍👨🏽 E13.1 couple with heart: woman, man, medium-light skin tone, medium skin tone
+1F469 1F3FC 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👩🏼‍❤‍👨🏽 E13.1 couple with heart: woman, man, medium-light skin tone, medium skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👩🏼‍❤️‍👨🏾 E13.1 couple with heart: woman, man, medium-light skin tone, medium-dark skin tone
+1F469 1F3FC 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👩🏼‍❤‍👨🏾 E13.1 couple with heart: woman, man, medium-light skin tone, medium-dark skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👩🏼‍❤️‍👨🏿 E13.1 couple with heart: woman, man, medium-light skin tone, dark skin tone
+1F469 1F3FC 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👩🏼‍❤‍👨🏿 E13.1 couple with heart: woman, man, medium-light skin tone, dark skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👩🏽‍❤️‍👨🏻 E13.1 couple with heart: woman, man, medium skin tone, light skin tone
+1F469 1F3FD 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👩🏽‍❤‍👨🏻 E13.1 couple with heart: woman, man, medium skin tone, light skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👩🏽‍❤️‍👨🏼 E13.1 couple with heart: woman, man, medium skin tone, medium-light skin tone
+1F469 1F3FD 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👩🏽‍❤‍👨🏼 E13.1 couple with heart: woman, man, medium skin tone, medium-light skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👩🏽‍❤️‍👨🏽 E13.1 couple with heart: woman, man, medium skin tone
+1F469 1F3FD 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👩🏽‍❤‍👨🏽 E13.1 couple with heart: woman, man, medium skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👩🏽‍❤️‍👨🏾 E13.1 couple with heart: woman, man, medium skin tone, medium-dark skin tone
+1F469 1F3FD 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👩🏽‍❤‍👨🏾 E13.1 couple with heart: woman, man, medium skin tone, medium-dark skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👩🏽‍❤️‍👨🏿 E13.1 couple with heart: woman, man, medium skin tone, dark skin tone
+1F469 1F3FD 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👩🏽‍❤‍👨🏿 E13.1 couple with heart: woman, man, medium skin tone, dark skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👩🏾‍❤️‍👨🏻 E13.1 couple with heart: woman, man, medium-dark skin tone, light skin tone
+1F469 1F3FE 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👩🏾‍❤‍👨🏻 E13.1 couple with heart: woman, man, medium-dark skin tone, light skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👩🏾‍❤️‍👨🏼 E13.1 couple with heart: woman, man, medium-dark skin tone, medium-light skin tone
+1F469 1F3FE 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👩🏾‍❤‍👨🏼 E13.1 couple with heart: woman, man, medium-dark skin tone, medium-light skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👩🏾‍❤️‍👨🏽 E13.1 couple with heart: woman, man, medium-dark skin tone, medium skin tone
+1F469 1F3FE 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👩🏾‍❤‍👨🏽 E13.1 couple with heart: woman, man, medium-dark skin tone, medium skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👩🏾‍❤️‍👨🏾 E13.1 couple with heart: woman, man, medium-dark skin tone
+1F469 1F3FE 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👩🏾‍❤‍👨🏾 E13.1 couple with heart: woman, man, medium-dark skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👩🏾‍❤️‍👨🏿 E13.1 couple with heart: woman, man, medium-dark skin tone, dark skin tone
+1F469 1F3FE 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👩🏾‍❤‍👨🏿 E13.1 couple with heart: woman, man, medium-dark skin tone, dark skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👩🏿‍❤️‍👨🏻 E13.1 couple with heart: woman, man, dark skin tone, light skin tone
+1F469 1F3FF 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👩🏿‍❤‍👨🏻 E13.1 couple with heart: woman, man, dark skin tone, light skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👩🏿‍❤️‍👨🏼 E13.1 couple with heart: woman, man, dark skin tone, medium-light skin tone
+1F469 1F3FF 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👩🏿‍❤‍👨🏼 E13.1 couple with heart: woman, man, dark skin tone, medium-light skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👩🏿‍❤️‍👨🏽 E13.1 couple with heart: woman, man, dark skin tone, medium skin tone
+1F469 1F3FF 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👩🏿‍❤‍👨🏽 E13.1 couple with heart: woman, man, dark skin tone, medium skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👩🏿‍❤️‍👨🏾 E13.1 couple with heart: woman, man, dark skin tone, medium-dark skin tone
+1F469 1F3FF 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👩🏿‍❤‍👨🏾 E13.1 couple with heart: woman, man, dark skin tone, medium-dark skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👩🏿‍❤️‍👨🏿 E13.1 couple with heart: woman, man, dark skin tone
+1F469 1F3FF 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👩🏿‍❤‍👨🏿 E13.1 couple with heart: woman, man, dark skin tone
+1F468 200D 2764 FE0F 200D 1F468 ; fully-qualified # 👨‍❤️‍👨 E2.0 couple with heart: man, man
+1F468 200D 2764 200D 1F468 ; minimally-qualified # 👨‍❤‍👨 E2.0 couple with heart: man, man
+1F468 1F3FB 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👨🏻‍❤️‍👨🏻 E13.1 couple with heart: man, man, light skin tone
+1F468 1F3FB 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👨🏻‍❤‍👨🏻 E13.1 couple with heart: man, man, light skin tone
+1F468 1F3FB 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👨🏻‍❤️‍👨🏼 E13.1 couple with heart: man, man, light skin tone, medium-light skin tone
+1F468 1F3FB 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👨🏻‍❤‍👨🏼 E13.1 couple with heart: man, man, light skin tone, medium-light skin tone
+1F468 1F3FB 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👨🏻‍❤️‍👨🏽 E13.1 couple with heart: man, man, light skin tone, medium skin tone
+1F468 1F3FB 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👨🏻‍❤‍👨🏽 E13.1 couple with heart: man, man, light skin tone, medium skin tone
+1F468 1F3FB 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👨🏻‍❤️‍👨🏾 E13.1 couple with heart: man, man, light skin tone, medium-dark skin tone
+1F468 1F3FB 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👨🏻‍❤‍👨🏾 E13.1 couple with heart: man, man, light skin tone, medium-dark skin tone
+1F468 1F3FB 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👨🏻‍❤️‍👨🏿 E13.1 couple with heart: man, man, light skin tone, dark skin tone
+1F468 1F3FB 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👨🏻‍❤‍👨🏿 E13.1 couple with heart: man, man, light skin tone, dark skin tone
+1F468 1F3FC 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👨🏼‍❤️‍👨🏻 E13.1 couple with heart: man, man, medium-light skin tone, light skin tone
+1F468 1F3FC 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👨🏼‍❤‍👨🏻 E13.1 couple with heart: man, man, medium-light skin tone, light skin tone
+1F468 1F3FC 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👨🏼‍❤️‍👨🏼 E13.1 couple with heart: man, man, medium-light skin tone
+1F468 1F3FC 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👨🏼‍❤‍👨🏼 E13.1 couple with heart: man, man, medium-light skin tone
+1F468 1F3FC 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👨🏼‍❤️‍👨🏽 E13.1 couple with heart: man, man, medium-light skin tone, medium skin tone
+1F468 1F3FC 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👨🏼‍❤‍👨🏽 E13.1 couple with heart: man, man, medium-light skin tone, medium skin tone
+1F468 1F3FC 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👨🏼‍❤️‍👨🏾 E13.1 couple with heart: man, man, medium-light skin tone, medium-dark skin tone
+1F468 1F3FC 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👨🏼‍❤‍👨🏾 E13.1 couple with heart: man, man, medium-light skin tone, medium-dark skin tone
+1F468 1F3FC 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👨🏼‍❤️‍👨🏿 E13.1 couple with heart: man, man, medium-light skin tone, dark skin tone
+1F468 1F3FC 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👨🏼‍❤‍👨🏿 E13.1 couple with heart: man, man, medium-light skin tone, dark skin tone
+1F468 1F3FD 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👨🏽‍❤️‍👨🏻 E13.1 couple with heart: man, man, medium skin tone, light skin tone
+1F468 1F3FD 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👨🏽‍❤‍👨🏻 E13.1 couple with heart: man, man, medium skin tone, light skin tone
+1F468 1F3FD 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👨🏽‍❤️‍👨🏼 E13.1 couple with heart: man, man, medium skin tone, medium-light skin tone
+1F468 1F3FD 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👨🏽‍❤‍👨🏼 E13.1 couple with heart: man, man, medium skin tone, medium-light skin tone
+1F468 1F3FD 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👨🏽‍❤️‍👨🏽 E13.1 couple with heart: man, man, medium skin tone
+1F468 1F3FD 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👨🏽‍❤‍👨🏽 E13.1 couple with heart: man, man, medium skin tone
+1F468 1F3FD 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👨🏽‍❤️‍👨🏾 E13.1 couple with heart: man, man, medium skin tone, medium-dark skin tone
+1F468 1F3FD 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👨🏽‍❤‍👨🏾 E13.1 couple with heart: man, man, medium skin tone, medium-dark skin tone
+1F468 1F3FD 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👨🏽‍❤️‍👨🏿 E13.1 couple with heart: man, man, medium skin tone, dark skin tone
+1F468 1F3FD 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👨🏽‍❤‍👨🏿 E13.1 couple with heart: man, man, medium skin tone, dark skin tone
+1F468 1F3FE 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👨🏾‍❤️‍👨🏻 E13.1 couple with heart: man, man, medium-dark skin tone, light skin tone
+1F468 1F3FE 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👨🏾‍❤‍👨🏻 E13.1 couple with heart: man, man, medium-dark skin tone, light skin tone
+1F468 1F3FE 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👨🏾‍❤️‍👨🏼 E13.1 couple with heart: man, man, medium-dark skin tone, medium-light skin tone
+1F468 1F3FE 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👨🏾‍❤‍👨🏼 E13.1 couple with heart: man, man, medium-dark skin tone, medium-light skin tone
+1F468 1F3FE 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👨🏾‍❤️‍👨🏽 E13.1 couple with heart: man, man, medium-dark skin tone, medium skin tone
+1F468 1F3FE 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👨🏾‍❤‍👨🏽 E13.1 couple with heart: man, man, medium-dark skin tone, medium skin tone
+1F468 1F3FE 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👨🏾‍❤️‍👨🏾 E13.1 couple with heart: man, man, medium-dark skin tone
+1F468 1F3FE 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👨🏾‍❤‍👨🏾 E13.1 couple with heart: man, man, medium-dark skin tone
+1F468 1F3FE 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👨🏾‍❤️‍👨🏿 E13.1 couple with heart: man, man, medium-dark skin tone, dark skin tone
+1F468 1F3FE 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👨🏾‍❤‍👨🏿 E13.1 couple with heart: man, man, medium-dark skin tone, dark skin tone
+1F468 1F3FF 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👨🏿‍❤️‍👨🏻 E13.1 couple with heart: man, man, dark skin tone, light skin tone
+1F468 1F3FF 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👨🏿‍❤‍👨🏻 E13.1 couple with heart: man, man, dark skin tone, light skin tone
+1F468 1F3FF 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👨🏿‍❤️‍👨🏼 E13.1 couple with heart: man, man, dark skin tone, medium-light skin tone
+1F468 1F3FF 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👨🏿‍❤‍👨🏼 E13.1 couple with heart: man, man, dark skin tone, medium-light skin tone
+1F468 1F3FF 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👨🏿‍❤️‍👨🏽 E13.1 couple with heart: man, man, dark skin tone, medium skin tone
+1F468 1F3FF 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👨🏿‍❤‍👨🏽 E13.1 couple with heart: man, man, dark skin tone, medium skin tone
+1F468 1F3FF 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👨🏿‍❤️‍👨🏾 E13.1 couple with heart: man, man, dark skin tone, medium-dark skin tone
+1F468 1F3FF 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👨🏿‍❤‍👨🏾 E13.1 couple with heart: man, man, dark skin tone, medium-dark skin tone
+1F468 1F3FF 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👨🏿‍❤️‍👨🏿 E13.1 couple with heart: man, man, dark skin tone
+1F468 1F3FF 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👨🏿‍❤‍👨🏿 E13.1 couple with heart: man, man, dark skin tone
+1F469 200D 2764 FE0F 200D 1F469 ; fully-qualified # 👩‍❤️‍👩 E2.0 couple with heart: woman, woman
+1F469 200D 2764 200D 1F469 ; minimally-qualified # 👩‍❤‍👩 E2.0 couple with heart: woman, woman
+1F469 1F3FB 200D 2764 FE0F 200D 1F469 1F3FB ; fully-qualified # 👩🏻‍❤️‍👩🏻 E13.1 couple with heart: woman, woman, light skin tone
+1F469 1F3FB 200D 2764 200D 1F469 1F3FB ; minimally-qualified # 👩🏻‍❤‍👩🏻 E13.1 couple with heart: woman, woman, light skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F469 1F3FC ; fully-qualified # 👩🏻‍❤️‍👩🏼 E13.1 couple with heart: woman, woman, light skin tone, medium-light skin tone
+1F469 1F3FB 200D 2764 200D 1F469 1F3FC ; minimally-qualified # 👩🏻‍❤‍👩🏼 E13.1 couple with heart: woman, woman, light skin tone, medium-light skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F469 1F3FD ; fully-qualified # 👩🏻‍❤️‍👩🏽 E13.1 couple with heart: woman, woman, light skin tone, medium skin tone
+1F469 1F3FB 200D 2764 200D 1F469 1F3FD ; minimally-qualified # 👩🏻‍❤‍👩🏽 E13.1 couple with heart: woman, woman, light skin tone, medium skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F469 1F3FE ; fully-qualified # 👩🏻‍❤️‍👩🏾 E13.1 couple with heart: woman, woman, light skin tone, medium-dark skin tone
+1F469 1F3FB 200D 2764 200D 1F469 1F3FE ; minimally-qualified # 👩🏻‍❤‍👩🏾 E13.1 couple with heart: woman, woman, light skin tone, medium-dark skin tone
+1F469 1F3FB 200D 2764 FE0F 200D 1F469 1F3FF ; fully-qualified # 👩🏻‍❤️‍👩🏿 E13.1 couple with heart: woman, woman, light skin tone, dark skin tone
+1F469 1F3FB 200D 2764 200D 1F469 1F3FF ; minimally-qualified # 👩🏻‍❤‍👩🏿 E13.1 couple with heart: woman, woman, light skin tone, dark skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F469 1F3FB ; fully-qualified # 👩🏼‍❤️‍👩🏻 E13.1 couple with heart: woman, woman, medium-light skin tone, light skin tone
+1F469 1F3FC 200D 2764 200D 1F469 1F3FB ; minimally-qualified # 👩🏼‍❤‍👩🏻 E13.1 couple with heart: woman, woman, medium-light skin tone, light skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F469 1F3FC ; fully-qualified # 👩🏼‍❤️‍👩🏼 E13.1 couple with heart: woman, woman, medium-light skin tone
+1F469 1F3FC 200D 2764 200D 1F469 1F3FC ; minimally-qualified # 👩🏼‍❤‍👩🏼 E13.1 couple with heart: woman, woman, medium-light skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F469 1F3FD ; fully-qualified # 👩🏼‍❤️‍👩🏽 E13.1 couple with heart: woman, woman, medium-light skin tone, medium skin tone
+1F469 1F3FC 200D 2764 200D 1F469 1F3FD ; minimally-qualified # 👩🏼‍❤‍👩🏽 E13.1 couple with heart: woman, woman, medium-light skin tone, medium skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F469 1F3FE ; fully-qualified # 👩🏼‍❤️‍👩🏾 E13.1 couple with heart: woman, woman, medium-light skin tone, medium-dark skin tone
+1F469 1F3FC 200D 2764 200D 1F469 1F3FE ; minimally-qualified # 👩🏼‍❤‍👩🏾 E13.1 couple with heart: woman, woman, medium-light skin tone, medium-dark skin tone
+1F469 1F3FC 200D 2764 FE0F 200D 1F469 1F3FF ; fully-qualified # 👩🏼‍❤️‍👩🏿 E13.1 couple with heart: woman, woman, medium-light skin tone, dark skin tone
+1F469 1F3FC 200D 2764 200D 1F469 1F3FF ; minimally-qualified # 👩🏼‍❤‍👩🏿 E13.1 couple with heart: woman, woman, medium-light skin tone, dark skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F469 1F3FB ; fully-qualified # 👩🏽‍❤️‍👩🏻 E13.1 couple with heart: woman, woman, medium skin tone, light skin tone
+1F469 1F3FD 200D 2764 200D 1F469 1F3FB ; minimally-qualified # 👩🏽‍❤‍👩🏻 E13.1 couple with heart: woman, woman, medium skin tone, light skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F469 1F3FC ; fully-qualified # 👩🏽‍❤️‍👩🏼 E13.1 couple with heart: woman, woman, medium skin tone, medium-light skin tone
+1F469 1F3FD 200D 2764 200D 1F469 1F3FC ; minimally-qualified # 👩🏽‍❤‍👩🏼 E13.1 couple with heart: woman, woman, medium skin tone, medium-light skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F469 1F3FD ; fully-qualified # 👩🏽‍❤️‍👩🏽 E13.1 couple with heart: woman, woman, medium skin tone
+1F469 1F3FD 200D 2764 200D 1F469 1F3FD ; minimally-qualified # 👩🏽‍❤‍👩🏽 E13.1 couple with heart: woman, woman, medium skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F469 1F3FE ; fully-qualified # 👩🏽‍❤️‍👩🏾 E13.1 couple with heart: woman, woman, medium skin tone, medium-dark skin tone
+1F469 1F3FD 200D 2764 200D 1F469 1F3FE ; minimally-qualified # 👩🏽‍❤‍👩🏾 E13.1 couple with heart: woman, woman, medium skin tone, medium-dark skin tone
+1F469 1F3FD 200D 2764 FE0F 200D 1F469 1F3FF ; fully-qualified # 👩🏽‍❤️‍👩🏿 E13.1 couple with heart: woman, woman, medium skin tone, dark skin tone
+1F469 1F3FD 200D 2764 200D 1F469 1F3FF ; minimally-qualified # 👩🏽‍❤‍👩🏿 E13.1 couple with heart: woman, woman, medium skin tone, dark skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F469 1F3FB ; fully-qualified # 👩🏾‍❤️‍👩🏻 E13.1 couple with heart: woman, woman, medium-dark skin tone, light skin tone
+1F469 1F3FE 200D 2764 200D 1F469 1F3FB ; minimally-qualified # 👩🏾‍❤‍👩🏻 E13.1 couple with heart: woman, woman, medium-dark skin tone, light skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F469 1F3FC ; fully-qualified # 👩🏾‍❤️‍👩🏼 E13.1 couple with heart: woman, woman, medium-dark skin tone, medium-light skin tone
+1F469 1F3FE 200D 2764 200D 1F469 1F3FC ; minimally-qualified # 👩🏾‍❤‍👩🏼 E13.1 couple with heart: woman, woman, medium-dark skin tone, medium-light skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F469 1F3FD ; fully-qualified # 👩🏾‍❤️‍👩🏽 E13.1 couple with heart: woman, woman, medium-dark skin tone, medium skin tone
+1F469 1F3FE 200D 2764 200D 1F469 1F3FD ; minimally-qualified # 👩🏾‍❤‍👩🏽 E13.1 couple with heart: woman, woman, medium-dark skin tone, medium skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F469 1F3FE ; fully-qualified # 👩🏾‍❤️‍👩🏾 E13.1 couple with heart: woman, woman, medium-dark skin tone
+1F469 1F3FE 200D 2764 200D 1F469 1F3FE ; minimally-qualified # 👩🏾‍❤‍👩🏾 E13.1 couple with heart: woman, woman, medium-dark skin tone
+1F469 1F3FE 200D 2764 FE0F 200D 1F469 1F3FF ; fully-qualified # 👩🏾‍❤️‍👩🏿 E13.1 couple with heart: woman, woman, medium-dark skin tone, dark skin tone
+1F469 1F3FE 200D 2764 200D 1F469 1F3FF ; minimally-qualified # 👩🏾‍❤‍👩🏿 E13.1 couple with heart: woman, woman, medium-dark skin tone, dark skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F469 1F3FB ; fully-qualified # 👩🏿‍❤️‍👩🏻 E13.1 couple with heart: woman, woman, dark skin tone, light skin tone
+1F469 1F3FF 200D 2764 200D 1F469 1F3FB ; minimally-qualified # 👩🏿‍❤‍👩🏻 E13.1 couple with heart: woman, woman, dark skin tone, light skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F469 1F3FC ; fully-qualified # 👩🏿‍❤️‍👩🏼 E13.1 couple with heart: woman, woman, dark skin tone, medium-light skin tone
+1F469 1F3FF 200D 2764 200D 1F469 1F3FC ; minimally-qualified # 👩🏿‍❤‍👩🏼 E13.1 couple with heart: woman, woman, dark skin tone, medium-light skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F469 1F3FD ; fully-qualified # 👩🏿‍❤️‍👩🏽 E13.1 couple with heart: woman, woman, dark skin tone, medium skin tone
+1F469 1F3FF 200D 2764 200D 1F469 1F3FD ; minimally-qualified # 👩🏿‍❤‍👩🏽 E13.1 couple with heart: woman, woman, dark skin tone, medium skin tone
+1F469 1F3FF 200D 2764 FE0F 200D 1F469 1F3FE ; fully-qualified # 👩🏿‍❤️‍👩🏾 E13.1 couple with heart: woman, woman, dark skin tone, medium-dark skin tone
+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
+1F468 200D 1F469 200D 1F466 200D 1F466 ; fully-qualified # 👨‍👩‍👦‍👦 E2.0 family: man, woman, boy, boy
+1F468 200D 1F469 200D 1F467 200D 1F467 ; fully-qualified # 👨‍👩‍👧‍👧 E2.0 family: man, woman, girl, girl
+1F468 200D 1F468 200D 1F466 ; fully-qualified # 👨‍👨‍👦 E2.0 family: man, man, boy
+1F468 200D 1F468 200D 1F467 ; fully-qualified # 👨‍👨‍👧 E2.0 family: man, man, girl
+1F468 200D 1F468 200D 1F467 200D 1F466 ; fully-qualified # 👨‍👨‍👧‍👦 E2.0 family: man, man, girl, boy
+1F468 200D 1F468 200D 1F466 200D 1F466 ; fully-qualified # 👨‍👨‍👦‍👦 E2.0 family: man, man, boy, boy
+1F468 200D 1F468 200D 1F467 200D 1F467 ; fully-qualified # 👨‍👨‍👧‍👧 E2.0 family: man, man, girl, girl
+1F469 200D 1F469 200D 1F466 ; fully-qualified # 👩‍👩‍👦 E2.0 family: woman, woman, boy
+1F469 200D 1F469 200D 1F467 ; fully-qualified # 👩‍👩‍👧 E2.0 family: woman, woman, girl
+1F469 200D 1F469 200D 1F467 200D 1F466 ; fully-qualified # 👩‍👩‍👧‍👦 E2.0 family: woman, woman, girl, boy
+1F469 200D 1F469 200D 1F466 200D 1F466 ; fully-qualified # 👩‍👩‍👦‍👦 E2.0 family: woman, woman, boy, boy
+1F469 200D 1F469 200D 1F467 200D 1F467 ; fully-qualified # 👩‍👩‍👧‍👧 E2.0 family: woman, woman, girl, girl
+1F468 200D 1F466 ; fully-qualified # 👨‍👦 E4.0 family: man, boy
+1F468 200D 1F466 200D 1F466 ; fully-qualified # 👨‍👦‍👦 E4.0 family: man, boy, boy
+1F468 200D 1F467 ; fully-qualified # 👨‍👧 E4.0 family: man, girl
+1F468 200D 1F467 200D 1F466 ; fully-qualified # 👨‍👧‍👦 E4.0 family: man, girl, boy
+1F468 200D 1F467 200D 1F467 ; fully-qualified # 👨‍👧‍👧 E4.0 family: man, girl, girl
+1F469 200D 1F466 ; fully-qualified # 👩‍👦 E4.0 family: woman, boy
+1F469 200D 1F466 200D 1F466 ; fully-qualified # 👩‍👦‍👦 E4.0 family: woman, boy, boy
+1F469 200D 1F467 ; fully-qualified # 👩‍👧 E4.0 family: woman, girl
+1F469 200D 1F467 200D 1F466 ; fully-qualified # 👩‍👧‍👦 E4.0 family: woman, girl, boy
+1F469 200D 1F467 200D 1F467 ; fully-qualified # 👩‍👧‍👧 E4.0 family: woman, girl, girl
+
+# subgroup: person-symbol
+1F5E3 FE0F ; fully-qualified # 🗣️ E0.7 speaking head
+1F5E3 ; unqualified # 🗣 E0.7 speaking head
+1F464 ; fully-qualified # 👤 E0.6 bust in silhouette
+1F465 ; fully-qualified # 👥 E1.0 busts in silhouette
+1FAC2 ; fully-qualified # 🫂 E13.0 people hugging
+1F463 ; fully-qualified # 👣 E0.6 footprints
+
+# People & Body subtotal: 2986
+# People & Body subtotal: 506 w/o modifiers
+
+# group: Component
+
+# subgroup: skin-tone
+1F3FB ; component # 🏻 E1.0 light skin tone
+1F3FC ; component # 🏼 E1.0 medium-light skin tone
+1F3FD ; component # 🏽 E1.0 medium skin tone
+1F3FE ; component # 🏾 E1.0 medium-dark skin tone
+1F3FF ; component # 🏿 E1.0 dark skin tone
+
+# subgroup: hair-style
+1F9B0 ; component # 🦰 E11.0 red hair
+1F9B1 ; component # 🦱 E11.0 curly hair
+1F9B3 ; component # 🦳 E11.0 white hair
+1F9B2 ; component # 🦲 E11.0 bald
+
+# Component subtotal: 9
+# Component subtotal: 4 w/o modifiers
+
+# group: Animals & Nature
+
+# subgroup: animal-mammal
+1F435 ; fully-qualified # 🐵 E0.6 monkey face
+1F412 ; fully-qualified # 🐒 E0.6 monkey
+1F98D ; fully-qualified # 🦍 E3.0 gorilla
+1F9A7 ; fully-qualified # 🦧 E12.0 orangutan
+1F436 ; fully-qualified # 🐶 E0.6 dog face
+1F415 ; fully-qualified # 🐕 E0.7 dog
+1F9AE ; fully-qualified # 🦮 E12.0 guide dog
+1F415 200D 1F9BA ; fully-qualified # 🐕‍🦺 E12.0 service dog
+1F429 ; fully-qualified # 🐩 E0.6 poodle
+1F43A ; fully-qualified # 🐺 E0.6 wolf
+1F98A ; fully-qualified # 🦊 E3.0 fox
+1F99D ; fully-qualified # 🦝 E11.0 raccoon
+1F431 ; fully-qualified # 🐱 E0.6 cat face
+1F408 ; fully-qualified # 🐈 E0.7 cat
+1F408 200D 2B1B ; fully-qualified # 🐈‍⬛ E13.0 black cat
+1F981 ; fully-qualified # 🦁 E1.0 lion
+1F42F ; fully-qualified # 🐯 E0.6 tiger face
+1F405 ; fully-qualified # 🐅 E1.0 tiger
+1F406 ; fully-qualified # 🐆 E1.0 leopard
+1F434 ; fully-qualified # 🐴 E0.6 horse face
+1F40E ; fully-qualified # 🐎 E0.6 horse
+1F984 ; fully-qualified # 🦄 E1.0 unicorn
+1F993 ; fully-qualified # 🦓 E5.0 zebra
+1F98C ; fully-qualified # 🦌 E3.0 deer
+1F9AC ; fully-qualified # 🦬 E13.0 bison
+1F42E ; fully-qualified # 🐮 E0.6 cow face
+1F402 ; fully-qualified # 🐂 E1.0 ox
+1F403 ; fully-qualified # 🐃 E1.0 water buffalo
+1F404 ; fully-qualified # 🐄 E1.0 cow
+1F437 ; fully-qualified # 🐷 E0.6 pig face
+1F416 ; fully-qualified # 🐖 E1.0 pig
+1F417 ; fully-qualified # 🐗 E0.6 boar
+1F43D ; fully-qualified # 🐽 E0.6 pig nose
+1F40F ; fully-qualified # 🐏 E1.0 ram
+1F411 ; fully-qualified # 🐑 E0.6 ewe
+1F410 ; fully-qualified # 🐐 E1.0 goat
+1F42A ; fully-qualified # 🐪 E1.0 camel
+1F42B ; fully-qualified # 🐫 E0.6 two-hump camel
+1F999 ; fully-qualified # 🦙 E11.0 llama
+1F992 ; fully-qualified # 🦒 E5.0 giraffe
+1F418 ; fully-qualified # 🐘 E0.6 elephant
+1F9A3 ; fully-qualified # 🦣 E13.0 mammoth
+1F98F ; fully-qualified # 🦏 E3.0 rhinoceros
+1F99B ; fully-qualified # 🦛 E11.0 hippopotamus
+1F42D ; fully-qualified # 🐭 E0.6 mouse face
+1F401 ; fully-qualified # 🐁 E1.0 mouse
+1F400 ; fully-qualified # 🐀 E1.0 rat
+1F439 ; fully-qualified # 🐹 E0.6 hamster
+1F430 ; fully-qualified # 🐰 E0.6 rabbit face
+1F407 ; fully-qualified # 🐇 E1.0 rabbit
+1F43F FE0F ; fully-qualified # 🐿️ E0.7 chipmunk
+1F43F ; unqualified # 🐿 E0.7 chipmunk
+1F9AB ; fully-qualified # 🦫 E13.0 beaver
+1F994 ; fully-qualified # 🦔 E5.0 hedgehog
+1F987 ; fully-qualified # 🦇 E3.0 bat
+1F43B ; fully-qualified # 🐻 E0.6 bear
+1F43B 200D 2744 FE0F ; fully-qualified # 🐻‍❄️ E13.0 polar bear
+1F43B 200D 2744 ; minimally-qualified # 🐻‍❄ E13.0 polar bear
+1F428 ; fully-qualified # 🐨 E0.6 koala
+1F43C ; fully-qualified # 🐼 E0.6 panda
+1F9A5 ; fully-qualified # 🦥 E12.0 sloth
+1F9A6 ; fully-qualified # 🦦 E12.0 otter
+1F9A8 ; fully-qualified # 🦨 E12.0 skunk
+1F998 ; fully-qualified # 🦘 E11.0 kangaroo
+1F9A1 ; fully-qualified # 🦡 E11.0 badger
+1F43E ; fully-qualified # 🐾 E0.6 paw prints
+
+# subgroup: animal-bird
+1F983 ; fully-qualified # 🦃 E1.0 turkey
+1F414 ; fully-qualified # 🐔 E0.6 chicken
+1F413 ; fully-qualified # 🐓 E1.0 rooster
+1F423 ; fully-qualified # 🐣 E0.6 hatching chick
+1F424 ; fully-qualified # 🐤 E0.6 baby chick
+1F425 ; fully-qualified # 🐥 E0.6 front-facing baby chick
+1F426 ; fully-qualified # 🐦 E0.6 bird
+1F427 ; fully-qualified # 🐧 E0.6 penguin
+1F54A FE0F ; fully-qualified # 🕊️ E0.7 dove
+1F54A ; unqualified # 🕊 E0.7 dove
+1F985 ; fully-qualified # 🦅 E3.0 eagle
+1F986 ; fully-qualified # 🦆 E3.0 duck
+1F9A2 ; fully-qualified # 🦢 E11.0 swan
+1F989 ; fully-qualified # 🦉 E3.0 owl
+1F9A4 ; fully-qualified # 🦤 E13.0 dodo
+1FAB6 ; fully-qualified # 🪶 E13.0 feather
+1F9A9 ; fully-qualified # 🦩 E12.0 flamingo
+1F99A ; fully-qualified # 🦚 E11.0 peacock
+1F99C ; fully-qualified # 🦜 E11.0 parrot
+
+# subgroup: animal-amphibian
+1F438 ; fully-qualified # 🐸 E0.6 frog
+
+# subgroup: animal-reptile
+1F40A ; fully-qualified # 🐊 E1.0 crocodile
+1F422 ; fully-qualified # 🐢 E0.6 turtle
+1F98E ; fully-qualified # 🦎 E3.0 lizard
+1F40D ; fully-qualified # 🐍 E0.6 snake
+1F432 ; fully-qualified # 🐲 E0.6 dragon face
+1F409 ; fully-qualified # 🐉 E1.0 dragon
+1F995 ; fully-qualified # 🦕 E5.0 sauropod
+1F996 ; fully-qualified # 🦖 E5.0 T-Rex
+
+# subgroup: animal-marine
+1F433 ; fully-qualified # 🐳 E0.6 spouting whale
+1F40B ; fully-qualified # 🐋 E1.0 whale
+1F42C ; fully-qualified # 🐬 E0.6 dolphin
+1F9AD ; fully-qualified # 🦭 E13.0 seal
+1F41F ; fully-qualified # 🐟 E0.6 fish
+1F420 ; fully-qualified # 🐠 E0.6 tropical fish
+1F421 ; fully-qualified # 🐡 E0.6 blowfish
+1F988 ; fully-qualified # 🦈 E3.0 shark
+1F419 ; fully-qualified # 🐙 E0.6 octopus
+1F41A ; fully-qualified # 🐚 E0.6 spiral shell
+1FAB8 ; fully-qualified # 🪸 E14.0 coral
+
+# subgroup: animal-bug
+1F40C ; fully-qualified # 🐌 E0.6 snail
+1F98B ; fully-qualified # 🦋 E3.0 butterfly
+1F41B ; fully-qualified # 🐛 E0.6 bug
+1F41C ; fully-qualified # 🐜 E0.6 ant
+1F41D ; fully-qualified # 🐝 E0.6 honeybee
+1FAB2 ; fully-qualified # 🪲 E13.0 beetle
+1F41E ; fully-qualified # 🐞 E0.6 lady beetle
+1F997 ; fully-qualified # 🦗 E5.0 cricket
+1FAB3 ; fully-qualified # 🪳 E13.0 cockroach
+1F577 FE0F ; fully-qualified # 🕷️ E0.7 spider
+1F577 ; unqualified # 🕷 E0.7 spider
+1F578 FE0F ; fully-qualified # 🕸️ E0.7 spider web
+1F578 ; unqualified # 🕸 E0.7 spider web
+1F982 ; fully-qualified # 🦂 E1.0 scorpion
+1F99F ; fully-qualified # 🦟 E11.0 mosquito
+1FAB0 ; fully-qualified # 🪰 E13.0 fly
+1FAB1 ; fully-qualified # 🪱 E13.0 worm
+1F9A0 ; fully-qualified # 🦠 E11.0 microbe
+
+# subgroup: plant-flower
+1F490 ; fully-qualified # 💐 E0.6 bouquet
+1F338 ; fully-qualified # 🌸 E0.6 cherry blossom
+1F4AE ; fully-qualified # 💮 E0.6 white flower
+1FAB7 ; fully-qualified # 🪷 E14.0 lotus
+1F3F5 FE0F ; fully-qualified # 🏵️ E0.7 rosette
+1F3F5 ; unqualified # 🏵 E0.7 rosette
+1F339 ; fully-qualified # 🌹 E0.6 rose
+1F940 ; fully-qualified # 🥀 E3.0 wilted flower
+1F33A ; fully-qualified # 🌺 E0.6 hibiscus
+1F33B ; fully-qualified # 🌻 E0.6 sunflower
+1F33C ; fully-qualified # 🌼 E0.6 blossom
+1F337 ; fully-qualified # 🌷 E0.6 tulip
+
+# subgroup: plant-other
+1F331 ; fully-qualified # 🌱 E0.6 seedling
+1FAB4 ; fully-qualified # 🪴 E13.0 potted plant
+1F332 ; fully-qualified # 🌲 E1.0 evergreen tree
+1F333 ; fully-qualified # 🌳 E1.0 deciduous tree
+1F334 ; fully-qualified # 🌴 E0.6 palm tree
+1F335 ; fully-qualified # 🌵 E0.6 cactus
+1F33E ; fully-qualified # 🌾 E0.6 sheaf of rice
+1F33F ; fully-qualified # 🌿 E0.6 herb
+2618 FE0F ; fully-qualified # ☘️ E1.0 shamrock
+2618 ; unqualified # ☘ E1.0 shamrock
+1F340 ; fully-qualified # 🍀 E0.6 four leaf clover
+1F341 ; fully-qualified # 🍁 E0.6 maple leaf
+1F342 ; fully-qualified # 🍂 E0.6 fallen leaf
+1F343 ; fully-qualified # 🍃 E0.6 leaf fluttering in wind
+1FAB9 ; fully-qualified # 🪹 E14.0 empty nest
+1FABA ; fully-qualified # 🪺 E14.0 nest with eggs
+
+# Animals & Nature subtotal: 151
+# Animals & Nature subtotal: 151 w/o modifiers
+
+# group: Food & Drink
+
+# subgroup: food-fruit
+1F347 ; fully-qualified # 🍇 E0.6 grapes
+1F348 ; fully-qualified # 🍈 E0.6 melon
+1F349 ; fully-qualified # 🍉 E0.6 watermelon
+1F34A ; fully-qualified # 🍊 E0.6 tangerine
+1F34B ; fully-qualified # 🍋 E1.0 lemon
+1F34C ; fully-qualified # 🍌 E0.6 banana
+1F34D ; fully-qualified # 🍍 E0.6 pineapple
+1F96D ; fully-qualified # 🥭 E11.0 mango
+1F34E ; fully-qualified # 🍎 E0.6 red apple
+1F34F ; fully-qualified # 🍏 E0.6 green apple
+1F350 ; fully-qualified # 🍐 E1.0 pear
+1F351 ; fully-qualified # 🍑 E0.6 peach
+1F352 ; fully-qualified # 🍒 E0.6 cherries
+1F353 ; fully-qualified # 🍓 E0.6 strawberry
+1FAD0 ; fully-qualified # 🫐 E13.0 blueberries
+1F95D ; fully-qualified # 🥝 E3.0 kiwi fruit
+1F345 ; fully-qualified # 🍅 E0.6 tomato
+1FAD2 ; fully-qualified # 🫒 E13.0 olive
+1F965 ; fully-qualified # 🥥 E5.0 coconut
+
+# subgroup: food-vegetable
+1F951 ; fully-qualified # 🥑 E3.0 avocado
+1F346 ; fully-qualified # 🍆 E0.6 eggplant
+1F954 ; fully-qualified # 🥔 E3.0 potato
+1F955 ; fully-qualified # 🥕 E3.0 carrot
+1F33D ; fully-qualified # 🌽 E0.6 ear of corn
+1F336 FE0F ; fully-qualified # 🌶️ E0.7 hot pepper
+1F336 ; unqualified # 🌶 E0.7 hot pepper
+1FAD1 ; fully-qualified # 🫑 E13.0 bell pepper
+1F952 ; fully-qualified # 🥒 E3.0 cucumber
+1F96C ; fully-qualified # 🥬 E11.0 leafy green
+1F966 ; fully-qualified # 🥦 E5.0 broccoli
+1F9C4 ; fully-qualified # 🧄 E12.0 garlic
+1F9C5 ; fully-qualified # 🧅 E12.0 onion
+1F344 ; fully-qualified # 🍄 E0.6 mushroom
+1F95C ; fully-qualified # 🥜 E3.0 peanuts
+1FAD8 ; fully-qualified # 🫘 E14.0 beans
+1F330 ; fully-qualified # 🌰 E0.6 chestnut
+
+# subgroup: food-prepared
+1F35E ; fully-qualified # 🍞 E0.6 bread
+1F950 ; fully-qualified # 🥐 E3.0 croissant
+1F956 ; fully-qualified # 🥖 E3.0 baguette bread
+1FAD3 ; fully-qualified # 🫓 E13.0 flatbread
+1F968 ; fully-qualified # 🥨 E5.0 pretzel
+1F96F ; fully-qualified # 🥯 E11.0 bagel
+1F95E ; fully-qualified # 🥞 E3.0 pancakes
+1F9C7 ; fully-qualified # 🧇 E12.0 waffle
+1F9C0 ; fully-qualified # 🧀 E1.0 cheese wedge
+1F356 ; fully-qualified # 🍖 E0.6 meat on bone
+1F357 ; fully-qualified # 🍗 E0.6 poultry leg
+1F969 ; fully-qualified # 🥩 E5.0 cut of meat
+1F953 ; fully-qualified # 🥓 E3.0 bacon
+1F354 ; fully-qualified # 🍔 E0.6 hamburger
+1F35F ; fully-qualified # 🍟 E0.6 french fries
+1F355 ; fully-qualified # 🍕 E0.6 pizza
+1F32D ; fully-qualified # 🌭 E1.0 hot dog
+1F96A ; fully-qualified # 🥪 E5.0 sandwich
+1F32E ; fully-qualified # 🌮 E1.0 taco
+1F32F ; fully-qualified # 🌯 E1.0 burrito
+1FAD4 ; fully-qualified # 🫔 E13.0 tamale
+1F959 ; fully-qualified # 🥙 E3.0 stuffed flatbread
+1F9C6 ; fully-qualified # 🧆 E12.0 falafel
+1F95A ; fully-qualified # 🥚 E3.0 egg
+1F373 ; fully-qualified # 🍳 E0.6 cooking
+1F958 ; fully-qualified # 🥘 E3.0 shallow pan of food
+1F372 ; fully-qualified # 🍲 E0.6 pot of food
+1FAD5 ; fully-qualified # 🫕 E13.0 fondue
+1F963 ; fully-qualified # 🥣 E5.0 bowl with spoon
+1F957 ; fully-qualified # 🥗 E3.0 green salad
+1F37F ; fully-qualified # 🍿 E1.0 popcorn
+1F9C8 ; fully-qualified # 🧈 E12.0 butter
+1F9C2 ; fully-qualified # 🧂 E11.0 salt
+1F96B ; fully-qualified # 🥫 E5.0 canned food
+
+# subgroup: food-asian
+1F371 ; fully-qualified # 🍱 E0.6 bento box
+1F358 ; fully-qualified # 🍘 E0.6 rice cracker
+1F359 ; fully-qualified # 🍙 E0.6 rice ball
+1F35A ; fully-qualified # 🍚 E0.6 cooked rice
+1F35B ; fully-qualified # 🍛 E0.6 curry rice
+1F35C ; fully-qualified # 🍜 E0.6 steaming bowl
+1F35D ; fully-qualified # 🍝 E0.6 spaghetti
+1F360 ; fully-qualified # 🍠 E0.6 roasted sweet potato
+1F362 ; fully-qualified # 🍢 E0.6 oden
+1F363 ; fully-qualified # 🍣 E0.6 sushi
+1F364 ; fully-qualified # 🍤 E0.6 fried shrimp
+1F365 ; fully-qualified # 🍥 E0.6 fish cake with swirl
+1F96E ; fully-qualified # 🥮 E11.0 moon cake
+1F361 ; fully-qualified # 🍡 E0.6 dango
+1F95F ; fully-qualified # 🥟 E5.0 dumpling
+1F960 ; fully-qualified # 🥠 E5.0 fortune cookie
+1F961 ; fully-qualified # 🥡 E5.0 takeout box
+
+# subgroup: food-marine
+1F980 ; fully-qualified # 🦀 E1.0 crab
+1F99E ; fully-qualified # 🦞 E11.0 lobster
+1F990 ; fully-qualified # 🦐 E3.0 shrimp
+1F991 ; fully-qualified # 🦑 E3.0 squid
+1F9AA ; fully-qualified # 🦪 E12.0 oyster
+
+# subgroup: food-sweet
+1F366 ; fully-qualified # 🍦 E0.6 soft ice cream
+1F367 ; fully-qualified # 🍧 E0.6 shaved ice
+1F368 ; fully-qualified # 🍨 E0.6 ice cream
+1F369 ; fully-qualified # 🍩 E0.6 doughnut
+1F36A ; fully-qualified # 🍪 E0.6 cookie
+1F382 ; fully-qualified # 🎂 E0.6 birthday cake
+1F370 ; fully-qualified # 🍰 E0.6 shortcake
+1F9C1 ; fully-qualified # 🧁 E11.0 cupcake
+1F967 ; fully-qualified # 🥧 E5.0 pie
+1F36B ; fully-qualified # 🍫 E0.6 chocolate bar
+1F36C ; fully-qualified # 🍬 E0.6 candy
+1F36D ; fully-qualified # 🍭 E0.6 lollipop
+1F36E ; fully-qualified # 🍮 E0.6 custard
+1F36F ; fully-qualified # 🍯 E0.6 honey pot
+
+# subgroup: drink
+1F37C ; fully-qualified # 🍼 E1.0 baby bottle
+1F95B ; fully-qualified # 🥛 E3.0 glass of milk
+2615 ; fully-qualified # ☕ E0.6 hot beverage
+1FAD6 ; fully-qualified # 🫖 E13.0 teapot
+1F375 ; fully-qualified # 🍵 E0.6 teacup without handle
+1F376 ; fully-qualified # 🍶 E0.6 sake
+1F37E ; fully-qualified # 🍾 E1.0 bottle with popping cork
+1F377 ; fully-qualified # 🍷 E0.6 wine glass
+1F378 ; fully-qualified # 🍸 E0.6 cocktail glass
+1F379 ; fully-qualified # 🍹 E0.6 tropical drink
+1F37A ; fully-qualified # 🍺 E0.6 beer mug
+1F37B ; fully-qualified # 🍻 E0.6 clinking beer mugs
+1F942 ; fully-qualified # 🥂 E3.0 clinking glasses
+1F943 ; fully-qualified # 🥃 E3.0 tumbler glass
+1FAD7 ; fully-qualified # 🫗 E14.0 pouring liquid
+1F964 ; fully-qualified # 🥤 E5.0 cup with straw
+1F9CB ; fully-qualified # 🧋 E13.0 bubble tea
+1F9C3 ; fully-qualified # 🧃 E12.0 beverage box
+1F9C9 ; fully-qualified # 🧉 E12.0 mate
+1F9CA ; fully-qualified # 🧊 E12.0 ice
+
+# subgroup: dishware
+1F962 ; fully-qualified # 🥢 E5.0 chopsticks
+1F37D FE0F ; fully-qualified # 🍽️ E0.7 fork and knife with plate
+1F37D ; unqualified # 🍽 E0.7 fork and knife with plate
+1F374 ; fully-qualified # 🍴 E0.6 fork and knife
+1F944 ; fully-qualified # 🥄 E3.0 spoon
+1F52A ; fully-qualified # 🔪 E0.6 kitchen knife
+1FAD9 ; fully-qualified # 🫙 E14.0 jar
+1F3FA ; fully-qualified # 🏺 E1.0 amphora
+
+# Food & Drink subtotal: 134
+# Food & Drink subtotal: 134 w/o modifiers
+
+# group: Travel & Places
+
+# subgroup: place-map
+1F30D ; fully-qualified # 🌍 E0.7 globe showing Europe-Africa
+1F30E ; fully-qualified # 🌎 E0.7 globe showing Americas
+1F30F ; fully-qualified # 🌏 E0.6 globe showing Asia-Australia
+1F310 ; fully-qualified # 🌐 E1.0 globe with meridians
+1F5FA FE0F ; fully-qualified # 🗺️ E0.7 world map
+1F5FA ; unqualified # 🗺 E0.7 world map
+1F5FE ; fully-qualified # 🗾 E0.6 map of Japan
+1F9ED ; fully-qualified # 🧭 E11.0 compass
+
+# subgroup: place-geographic
+1F3D4 FE0F ; fully-qualified # 🏔️ E0.7 snow-capped mountain
+1F3D4 ; unqualified # 🏔 E0.7 snow-capped mountain
+26F0 FE0F ; fully-qualified # ⛰️ E0.7 mountain
+26F0 ; unqualified # ⛰ E0.7 mountain
+1F30B ; fully-qualified # 🌋 E0.6 volcano
+1F5FB ; fully-qualified # 🗻 E0.6 mount fuji
+1F3D5 FE0F ; fully-qualified # 🏕️ E0.7 camping
+1F3D5 ; unqualified # 🏕 E0.7 camping
+1F3D6 FE0F ; fully-qualified # 🏖️ E0.7 beach with umbrella
+1F3D6 ; unqualified # 🏖 E0.7 beach with umbrella
+1F3DC FE0F ; fully-qualified # 🏜️ E0.7 desert
+1F3DC ; unqualified # 🏜 E0.7 desert
+1F3DD FE0F ; fully-qualified # 🏝️ E0.7 desert island
+1F3DD ; unqualified # 🏝 E0.7 desert island
+1F3DE FE0F ; fully-qualified # 🏞️ E0.7 national park
+1F3DE ; unqualified # 🏞 E0.7 national park
+
+# subgroup: place-building
+1F3DF FE0F ; fully-qualified # 🏟️ E0.7 stadium
+1F3DF ; unqualified # 🏟 E0.7 stadium
+1F3DB FE0F ; fully-qualified # 🏛️ E0.7 classical building
+1F3DB ; unqualified # 🏛 E0.7 classical building
+1F3D7 FE0F ; fully-qualified # 🏗️ E0.7 building construction
+1F3D7 ; unqualified # 🏗 E0.7 building construction
+1F9F1 ; fully-qualified # 🧱 E11.0 brick
+1FAA8 ; fully-qualified # 🪨 E13.0 rock
+1FAB5 ; fully-qualified # 🪵 E13.0 wood
+1F6D6 ; fully-qualified # 🛖 E13.0 hut
+1F3D8 FE0F ; fully-qualified # 🏘️ E0.7 houses
+1F3D8 ; unqualified # 🏘 E0.7 houses
+1F3DA FE0F ; fully-qualified # 🏚️ E0.7 derelict house
+1F3DA ; unqualified # 🏚 E0.7 derelict house
+1F3E0 ; fully-qualified # 🏠 E0.6 house
+1F3E1 ; fully-qualified # 🏡 E0.6 house with garden
+1F3E2 ; fully-qualified # 🏢 E0.6 office building
+1F3E3 ; fully-qualified # 🏣 E0.6 Japanese post office
+1F3E4 ; fully-qualified # 🏤 E1.0 post office
+1F3E5 ; fully-qualified # 🏥 E0.6 hospital
+1F3E6 ; fully-qualified # 🏦 E0.6 bank
+1F3E8 ; fully-qualified # 🏨 E0.6 hotel
+1F3E9 ; fully-qualified # 🏩 E0.6 love hotel
+1F3EA ; fully-qualified # 🏪 E0.6 convenience store
+1F3EB ; fully-qualified # 🏫 E0.6 school
+1F3EC ; fully-qualified # 🏬 E0.6 department store
+1F3ED ; fully-qualified # 🏭 E0.6 factory
+1F3EF ; fully-qualified # 🏯 E0.6 Japanese castle
+1F3F0 ; fully-qualified # 🏰 E0.6 castle
+1F492 ; fully-qualified # 💒 E0.6 wedding
+1F5FC ; fully-qualified # 🗼 E0.6 Tokyo tower
+1F5FD ; fully-qualified # 🗽 E0.6 Statue of Liberty
+
+# subgroup: place-religious
+26EA ; fully-qualified # ⛪ E0.6 church
+1F54C ; fully-qualified # 🕌 E1.0 mosque
+1F6D5 ; fully-qualified # 🛕 E12.0 hindu temple
+1F54D ; fully-qualified # 🕍 E1.0 synagogue
+26E9 FE0F ; fully-qualified # ⛩️ E0.7 shinto shrine
+26E9 ; unqualified # ⛩ E0.7 shinto shrine
+1F54B ; fully-qualified # 🕋 E1.0 kaaba
+
+# subgroup: place-other
+26F2 ; fully-qualified # ⛲ E0.6 fountain
+26FA ; fully-qualified # ⛺ E0.6 tent
+1F301 ; fully-qualified # 🌁 E0.6 foggy
+1F303 ; fully-qualified # 🌃 E0.6 night with stars
+1F3D9 FE0F ; fully-qualified # 🏙️ E0.7 cityscape
+1F3D9 ; unqualified # 🏙 E0.7 cityscape
+1F304 ; fully-qualified # 🌄 E0.6 sunrise over mountains
+1F305 ; fully-qualified # 🌅 E0.6 sunrise
+1F306 ; fully-qualified # 🌆 E0.6 cityscape at dusk
+1F307 ; fully-qualified # 🌇 E0.6 sunset
+1F309 ; fully-qualified # 🌉 E0.6 bridge at night
+2668 FE0F ; fully-qualified # ♨️ E0.6 hot springs
+2668 ; unqualified # ♨ E0.6 hot springs
+1F3A0 ; fully-qualified # 🎠 E0.6 carousel horse
+1F6DD ; fully-qualified # 🛝 E14.0 playground slide
+1F3A1 ; fully-qualified # 🎡 E0.6 ferris wheel
+1F3A2 ; fully-qualified # 🎢 E0.6 roller coaster
+1F488 ; fully-qualified # 💈 E0.6 barber pole
+1F3AA ; fully-qualified # 🎪 E0.6 circus tent
+
+# subgroup: transport-ground
+1F682 ; fully-qualified # 🚂 E1.0 locomotive
+1F683 ; fully-qualified # 🚃 E0.6 railway car
+1F684 ; fully-qualified # 🚄 E0.6 high-speed train
+1F685 ; fully-qualified # 🚅 E0.6 bullet train
+1F686 ; fully-qualified # 🚆 E1.0 train
+1F687 ; fully-qualified # 🚇 E0.6 metro
+1F688 ; fully-qualified # 🚈 E1.0 light rail
+1F689 ; fully-qualified # 🚉 E0.6 station
+1F68A ; fully-qualified # 🚊 E1.0 tram
+1F69D ; fully-qualified # 🚝 E1.0 monorail
+1F69E ; fully-qualified # 🚞 E1.0 mountain railway
+1F68B ; fully-qualified # 🚋 E1.0 tram car
+1F68C ; fully-qualified # 🚌 E0.6 bus
+1F68D ; fully-qualified # 🚍 E0.7 oncoming bus
+1F68E ; fully-qualified # 🚎 E1.0 trolleybus
+1F690 ; fully-qualified # 🚐 E1.0 minibus
+1F691 ; fully-qualified # 🚑 E0.6 ambulance
+1F692 ; fully-qualified # 🚒 E0.6 fire engine
+1F693 ; fully-qualified # 🚓 E0.6 police car
+1F694 ; fully-qualified # 🚔 E0.7 oncoming police car
+1F695 ; fully-qualified # 🚕 E0.6 taxi
+1F696 ; fully-qualified # 🚖 E1.0 oncoming taxi
+1F697 ; fully-qualified # 🚗 E0.6 automobile
+1F698 ; fully-qualified # 🚘 E0.7 oncoming automobile
+1F699 ; fully-qualified # 🚙 E0.6 sport utility vehicle
+1F6FB ; fully-qualified # 🛻 E13.0 pickup truck
+1F69A ; fully-qualified # 🚚 E0.6 delivery truck
+1F69B ; fully-qualified # 🚛 E1.0 articulated lorry
+1F69C ; fully-qualified # 🚜 E1.0 tractor
+1F3CE FE0F ; fully-qualified # 🏎️ E0.7 racing car
+1F3CE ; unqualified # 🏎 E0.7 racing car
+1F3CD FE0F ; fully-qualified # 🏍️ E0.7 motorcycle
+1F3CD ; unqualified # 🏍 E0.7 motorcycle
+1F6F5 ; fully-qualified # 🛵 E3.0 motor scooter
+1F9BD ; fully-qualified # 🦽 E12.0 manual wheelchair
+1F9BC ; fully-qualified # 🦼 E12.0 motorized wheelchair
+1F6FA ; fully-qualified # 🛺 E12.0 auto rickshaw
+1F6B2 ; fully-qualified # 🚲 E0.6 bicycle
+1F6F4 ; fully-qualified # 🛴 E3.0 kick scooter
+1F6F9 ; fully-qualified # 🛹 E11.0 skateboard
+1F6FC ; fully-qualified # 🛼 E13.0 roller skate
+1F68F ; fully-qualified # 🚏 E0.6 bus stop
+1F6E3 FE0F ; fully-qualified # 🛣️ E0.7 motorway
+1F6E3 ; unqualified # 🛣 E0.7 motorway
+1F6E4 FE0F ; fully-qualified # 🛤️ E0.7 railway track
+1F6E4 ; unqualified # 🛤 E0.7 railway track
+1F6E2 FE0F ; fully-qualified # 🛢️ E0.7 oil drum
+1F6E2 ; unqualified # 🛢 E0.7 oil drum
+26FD ; fully-qualified # ⛽ E0.6 fuel pump
+1F6DE ; fully-qualified # 🛞 E14.0 wheel
+1F6A8 ; fully-qualified # 🚨 E0.6 police car light
+1F6A5 ; fully-qualified # 🚥 E0.6 horizontal traffic light
+1F6A6 ; fully-qualified # 🚦 E1.0 vertical traffic light
+1F6D1 ; fully-qualified # 🛑 E3.0 stop sign
+1F6A7 ; fully-qualified # 🚧 E0.6 construction
+
+# subgroup: transport-water
+2693 ; fully-qualified # ⚓ E0.6 anchor
+1F6DF ; fully-qualified # 🛟 E14.0 ring buoy
+26F5 ; fully-qualified # ⛵ E0.6 sailboat
+1F6F6 ; fully-qualified # 🛶 E3.0 canoe
+1F6A4 ; fully-qualified # 🚤 E0.6 speedboat
+1F6F3 FE0F ; fully-qualified # 🛳️ E0.7 passenger ship
+1F6F3 ; unqualified # 🛳 E0.7 passenger ship
+26F4 FE0F ; fully-qualified # ⛴️ E0.7 ferry
+26F4 ; unqualified # ⛴ E0.7 ferry
+1F6E5 FE0F ; fully-qualified # 🛥️ E0.7 motor boat
+1F6E5 ; unqualified # 🛥 E0.7 motor boat
+1F6A2 ; fully-qualified # 🚢 E0.6 ship
+
+# subgroup: transport-air
+2708 FE0F ; fully-qualified # ✈️ E0.6 airplane
+2708 ; unqualified # ✈ E0.6 airplane
+1F6E9 FE0F ; fully-qualified # 🛩️ E0.7 small airplane
+1F6E9 ; unqualified # 🛩 E0.7 small airplane
+1F6EB ; fully-qualified # 🛫 E1.0 airplane departure
+1F6EC ; fully-qualified # 🛬 E1.0 airplane arrival
+1FA82 ; fully-qualified # 🪂 E12.0 parachute
+1F4BA ; fully-qualified # 💺 E0.6 seat
+1F681 ; fully-qualified # 🚁 E1.0 helicopter
+1F69F ; fully-qualified # 🚟 E1.0 suspension railway
+1F6A0 ; fully-qualified # 🚠 E1.0 mountain cableway
+1F6A1 ; fully-qualified # 🚡 E1.0 aerial tramway
+1F6F0 FE0F ; fully-qualified # 🛰️ E0.7 satellite
+1F6F0 ; unqualified # 🛰 E0.7 satellite
+1F680 ; fully-qualified # 🚀 E0.6 rocket
+1F6F8 ; fully-qualified # 🛸 E5.0 flying saucer
+
+# subgroup: hotel
+1F6CE FE0F ; fully-qualified # 🛎️ E0.7 bellhop bell
+1F6CE ; unqualified # 🛎 E0.7 bellhop bell
+1F9F3 ; fully-qualified # 🧳 E11.0 luggage
+
+# subgroup: time
+231B ; fully-qualified # ⌛ E0.6 hourglass done
+23F3 ; fully-qualified # ⏳ E0.6 hourglass not done
+231A ; fully-qualified # ⌚ E0.6 watch
+23F0 ; fully-qualified # ⏰ E0.6 alarm clock
+23F1 FE0F ; fully-qualified # ⏱️ E1.0 stopwatch
+23F1 ; unqualified # ⏱ E1.0 stopwatch
+23F2 FE0F ; fully-qualified # ⏲️ E1.0 timer clock
+23F2 ; unqualified # ⏲ E1.0 timer clock
+1F570 FE0F ; fully-qualified # 🕰️ E0.7 mantelpiece clock
+1F570 ; unqualified # 🕰 E0.7 mantelpiece clock
+1F55B ; fully-qualified # 🕛 E0.6 twelve o’clock
+1F567 ; fully-qualified # 🕧 E0.7 twelve-thirty
+1F550 ; fully-qualified # 🕐 E0.6 one o’clock
+1F55C ; fully-qualified # 🕜 E0.7 one-thirty
+1F551 ; fully-qualified # 🕑 E0.6 two o’clock
+1F55D ; fully-qualified # 🕝 E0.7 two-thirty
+1F552 ; fully-qualified # 🕒 E0.6 three o’clock
+1F55E ; fully-qualified # 🕞 E0.7 three-thirty
+1F553 ; fully-qualified # 🕓 E0.6 four o’clock
+1F55F ; fully-qualified # 🕟 E0.7 four-thirty
+1F554 ; fully-qualified # 🕔 E0.6 five o’clock
+1F560 ; fully-qualified # 🕠 E0.7 five-thirty
+1F555 ; fully-qualified # 🕕 E0.6 six o’clock
+1F561 ; fully-qualified # 🕡 E0.7 six-thirty
+1F556 ; fully-qualified # 🕖 E0.6 seven o’clock
+1F562 ; fully-qualified # 🕢 E0.7 seven-thirty
+1F557 ; fully-qualified # 🕗 E0.6 eight o’clock
+1F563 ; fully-qualified # 🕣 E0.7 eight-thirty
+1F558 ; fully-qualified # 🕘 E0.6 nine o’clock
+1F564 ; fully-qualified # 🕤 E0.7 nine-thirty
+1F559 ; fully-qualified # 🕙 E0.6 ten o’clock
+1F565 ; fully-qualified # 🕥 E0.7 ten-thirty
+1F55A ; fully-qualified # 🕚 E0.6 eleven o’clock
+1F566 ; fully-qualified # 🕦 E0.7 eleven-thirty
+
+# subgroup: sky & weather
+1F311 ; fully-qualified # 🌑 E0.6 new moon
+1F312 ; fully-qualified # 🌒 E1.0 waxing crescent moon
+1F313 ; fully-qualified # 🌓 E0.6 first quarter moon
+1F314 ; fully-qualified # 🌔 E0.6 waxing gibbous moon
+1F315 ; fully-qualified # 🌕 E0.6 full moon
+1F316 ; fully-qualified # 🌖 E1.0 waning gibbous moon
+1F317 ; fully-qualified # 🌗 E1.0 last quarter moon
+1F318 ; fully-qualified # 🌘 E1.0 waning crescent moon
+1F319 ; fully-qualified # 🌙 E0.6 crescent moon
+1F31A ; fully-qualified # 🌚 E1.0 new moon face
+1F31B ; fully-qualified # 🌛 E0.6 first quarter moon face
+1F31C ; fully-qualified # 🌜 E0.7 last quarter moon face
+1F321 FE0F ; fully-qualified # 🌡️ E0.7 thermometer
+1F321 ; unqualified # 🌡 E0.7 thermometer
+2600 FE0F ; fully-qualified # ☀️ E0.6 sun
+2600 ; unqualified # ☀ E0.6 sun
+1F31D ; fully-qualified # 🌝 E1.0 full moon face
+1F31E ; fully-qualified # 🌞 E1.0 sun with face
+1FA90 ; fully-qualified # 🪐 E12.0 ringed planet
+2B50 ; fully-qualified # ⭐ E0.6 star
+1F31F ; fully-qualified # 🌟 E0.6 glowing star
+1F320 ; fully-qualified # 🌠 E0.6 shooting star
+1F30C ; fully-qualified # 🌌 E0.6 milky way
+2601 FE0F ; fully-qualified # ☁️ E0.6 cloud
+2601 ; unqualified # ☁ E0.6 cloud
+26C5 ; fully-qualified # ⛅ E0.6 sun behind cloud
+26C8 FE0F ; fully-qualified # ⛈️ E0.7 cloud with lightning and rain
+26C8 ; unqualified # ⛈ E0.7 cloud with lightning and rain
+1F324 FE0F ; fully-qualified # 🌤️ E0.7 sun behind small cloud
+1F324 ; unqualified # 🌤 E0.7 sun behind small cloud
+1F325 FE0F ; fully-qualified # 🌥️ E0.7 sun behind large cloud
+1F325 ; unqualified # 🌥 E0.7 sun behind large cloud
+1F326 FE0F ; fully-qualified # 🌦️ E0.7 sun behind rain cloud
+1F326 ; unqualified # 🌦 E0.7 sun behind rain cloud
+1F327 FE0F ; fully-qualified # 🌧️ E0.7 cloud with rain
+1F327 ; unqualified # 🌧 E0.7 cloud with rain
+1F328 FE0F ; fully-qualified # 🌨️ E0.7 cloud with snow
+1F328 ; unqualified # 🌨 E0.7 cloud with snow
+1F329 FE0F ; fully-qualified # 🌩️ E0.7 cloud with lightning
+1F329 ; unqualified # 🌩 E0.7 cloud with lightning
+1F32A FE0F ; fully-qualified # 🌪️ E0.7 tornado
+1F32A ; unqualified # 🌪 E0.7 tornado
+1F32B FE0F ; fully-qualified # 🌫️ E0.7 fog
+1F32B ; unqualified # 🌫 E0.7 fog
+1F32C FE0F ; fully-qualified # 🌬️ E0.7 wind face
+1F32C ; unqualified # 🌬 E0.7 wind face
+1F300 ; fully-qualified # 🌀 E0.6 cyclone
+1F308 ; fully-qualified # 🌈 E0.6 rainbow
+1F302 ; fully-qualified # 🌂 E0.6 closed umbrella
+2602 FE0F ; fully-qualified # ☂️ E0.7 umbrella
+2602 ; unqualified # ☂ E0.7 umbrella
+2614 ; fully-qualified # ☔ E0.6 umbrella with rain drops
+26F1 FE0F ; fully-qualified # ⛱️ E0.7 umbrella on ground
+26F1 ; unqualified # ⛱ E0.7 umbrella on ground
+26A1 ; fully-qualified # ⚡ E0.6 high voltage
+2744 FE0F ; fully-qualified # ❄️ E0.6 snowflake
+2744 ; unqualified # ❄ E0.6 snowflake
+2603 FE0F ; fully-qualified # ☃️ E0.7 snowman
+2603 ; unqualified # ☃ E0.7 snowman
+26C4 ; fully-qualified # ⛄ E0.6 snowman without snow
+2604 FE0F ; fully-qualified # ☄️ E1.0 comet
+2604 ; unqualified # ☄ E1.0 comet
+1F525 ; fully-qualified # 🔥 E0.6 fire
+1F4A7 ; fully-qualified # 💧 E0.6 droplet
+1F30A ; fully-qualified # 🌊 E0.6 water wave
+
+# Travel & Places subtotal: 267
+# Travel & Places subtotal: 267 w/o modifiers
+
+# group: Activities
+
+# subgroup: event
+1F383 ; fully-qualified # 🎃 E0.6 jack-o-lantern
+1F384 ; fully-qualified # 🎄 E0.6 Christmas tree
+1F386 ; fully-qualified # 🎆 E0.6 fireworks
+1F387 ; fully-qualified # 🎇 E0.6 sparkler
+1F9E8 ; fully-qualified # 🧨 E11.0 firecracker
+2728 ; fully-qualified # ✨ E0.6 sparkles
+1F388 ; fully-qualified # 🎈 E0.6 balloon
+1F389 ; fully-qualified # 🎉 E0.6 party popper
+1F38A ; fully-qualified # 🎊 E0.6 confetti ball
+1F38B ; fully-qualified # 🎋 E0.6 tanabata tree
+1F38D ; fully-qualified # 🎍 E0.6 pine decoration
+1F38E ; fully-qualified # 🎎 E0.6 Japanese dolls
+1F38F ; fully-qualified # 🎏 E0.6 carp streamer
+1F390 ; fully-qualified # 🎐 E0.6 wind chime
+1F391 ; fully-qualified # 🎑 E0.6 moon viewing ceremony
+1F9E7 ; fully-qualified # 🧧 E11.0 red envelope
+1F380 ; fully-qualified # 🎀 E0.6 ribbon
+1F381 ; fully-qualified # 🎁 E0.6 wrapped gift
+1F397 FE0F ; fully-qualified # 🎗️ E0.7 reminder ribbon
+1F397 ; unqualified # 🎗 E0.7 reminder ribbon
+1F39F FE0F ; fully-qualified # 🎟️ E0.7 admission tickets
+1F39F ; unqualified # 🎟 E0.7 admission tickets
+1F3AB ; fully-qualified # 🎫 E0.6 ticket
+
+# subgroup: award-medal
+1F396 FE0F ; fully-qualified # 🎖️ E0.7 military medal
+1F396 ; unqualified # 🎖 E0.7 military medal
+1F3C6 ; fully-qualified # 🏆 E0.6 trophy
+1F3C5 ; fully-qualified # 🏅 E1.0 sports medal
+1F947 ; fully-qualified # 🥇 E3.0 1st place medal
+1F948 ; fully-qualified # 🥈 E3.0 2nd place medal
+1F949 ; fully-qualified # 🥉 E3.0 3rd place medal
+
+# subgroup: sport
+26BD ; fully-qualified # ⚽ E0.6 soccer ball
+26BE ; fully-qualified # ⚾ E0.6 baseball
+1F94E ; fully-qualified # 🥎 E11.0 softball
+1F3C0 ; fully-qualified # 🏀 E0.6 basketball
+1F3D0 ; fully-qualified # 🏐 E1.0 volleyball
+1F3C8 ; fully-qualified # 🏈 E0.6 american football
+1F3C9 ; fully-qualified # 🏉 E1.0 rugby football
+1F3BE ; fully-qualified # 🎾 E0.6 tennis
+1F94F ; fully-qualified # 🥏 E11.0 flying disc
+1F3B3 ; fully-qualified # 🎳 E0.6 bowling
+1F3CF ; fully-qualified # 🏏 E1.0 cricket game
+1F3D1 ; fully-qualified # 🏑 E1.0 field hockey
+1F3D2 ; fully-qualified # 🏒 E1.0 ice hockey
+1F94D ; fully-qualified # 🥍 E11.0 lacrosse
+1F3D3 ; fully-qualified # 🏓 E1.0 ping pong
+1F3F8 ; fully-qualified # 🏸 E1.0 badminton
+1F94A ; fully-qualified # 🥊 E3.0 boxing glove
+1F94B ; fully-qualified # 🥋 E3.0 martial arts uniform
+1F945 ; fully-qualified # 🥅 E3.0 goal net
+26F3 ; fully-qualified # ⛳ E0.6 flag in hole
+26F8 FE0F ; fully-qualified # ⛸️ E0.7 ice skate
+26F8 ; unqualified # ⛸ E0.7 ice skate
+1F3A3 ; fully-qualified # 🎣 E0.6 fishing pole
+1F93F ; fully-qualified # 🤿 E12.0 diving mask
+1F3BD ; fully-qualified # 🎽 E0.6 running shirt
+1F3BF ; fully-qualified # 🎿 E0.6 skis
+1F6F7 ; fully-qualified # 🛷 E5.0 sled
+1F94C ; fully-qualified # 🥌 E5.0 curling stone
+
+# subgroup: game
+1F3AF ; fully-qualified # 🎯 E0.6 bullseye
+1FA80 ; fully-qualified # 🪀 E12.0 yo-yo
+1FA81 ; fully-qualified # 🪁 E12.0 kite
+1F3B1 ; fully-qualified # 🎱 E0.6 pool 8 ball
+1F52E ; fully-qualified # 🔮 E0.6 crystal ball
+1FA84 ; fully-qualified # 🪄 E13.0 magic wand
+1F9FF ; fully-qualified # 🧿 E11.0 nazar amulet
+1FAAC ; fully-qualified # 🪬 E14.0 hamsa
+1F3AE ; fully-qualified # 🎮 E0.6 video game
+1F579 FE0F ; fully-qualified # 🕹️ E0.7 joystick
+1F579 ; unqualified # 🕹 E0.7 joystick
+1F3B0 ; fully-qualified # 🎰 E0.6 slot machine
+1F3B2 ; fully-qualified # 🎲 E0.6 game die
+1F9E9 ; fully-qualified # 🧩 E11.0 puzzle piece
+1F9F8 ; fully-qualified # 🧸 E11.0 teddy bear
+1FA85 ; fully-qualified # 🪅 E13.0 piñata
+1FAA9 ; fully-qualified # 🪩 E14.0 mirror ball
+1FA86 ; fully-qualified # 🪆 E13.0 nesting dolls
+2660 FE0F ; fully-qualified # ♠️ E0.6 spade suit
+2660 ; unqualified # ♠ E0.6 spade suit
+2665 FE0F ; fully-qualified # ♥️ E0.6 heart suit
+2665 ; unqualified # ♥ E0.6 heart suit
+2666 FE0F ; fully-qualified # ♦️ E0.6 diamond suit
+2666 ; unqualified # ♦ E0.6 diamond suit
+2663 FE0F ; fully-qualified # ♣️ E0.6 club suit
+2663 ; unqualified # ♣ E0.6 club suit
+265F FE0F ; fully-qualified # ♟️ E11.0 chess pawn
+265F ; unqualified # ♟ E11.0 chess pawn
+1F0CF ; fully-qualified # 🃏 E0.6 joker
+1F004 ; fully-qualified # 🀄 E0.6 mahjong red dragon
+1F3B4 ; fully-qualified # 🎴 E0.6 flower playing cards
+
+# subgroup: arts & crafts
+1F3AD ; fully-qualified # 🎭 E0.6 performing arts
+1F5BC FE0F ; fully-qualified # 🖼️ E0.7 framed picture
+1F5BC ; unqualified # 🖼 E0.7 framed picture
+1F3A8 ; fully-qualified # 🎨 E0.6 artist palette
+1F9F5 ; fully-qualified # 🧵 E11.0 thread
+1FAA1 ; fully-qualified # 🪡 E13.0 sewing needle
+1F9F6 ; fully-qualified # 🧶 E11.0 yarn
+1FAA2 ; fully-qualified # 🪢 E13.0 knot
+
+# Activities subtotal: 97
+# Activities subtotal: 97 w/o modifiers
+
+# group: Objects
+
+# subgroup: clothing
+1F453 ; fully-qualified # 👓 E0.6 glasses
+1F576 FE0F ; fully-qualified # 🕶️ E0.7 sunglasses
+1F576 ; unqualified # 🕶 E0.7 sunglasses
+1F97D ; fully-qualified # 🥽 E11.0 goggles
+1F97C ; fully-qualified # 🥼 E11.0 lab coat
+1F9BA ; fully-qualified # 🦺 E12.0 safety vest
+1F454 ; fully-qualified # 👔 E0.6 necktie
+1F455 ; fully-qualified # 👕 E0.6 t-shirt
+1F456 ; fully-qualified # 👖 E0.6 jeans
+1F9E3 ; fully-qualified # 🧣 E5.0 scarf
+1F9E4 ; fully-qualified # 🧤 E5.0 gloves
+1F9E5 ; fully-qualified # 🧥 E5.0 coat
+1F9E6 ; fully-qualified # 🧦 E5.0 socks
+1F457 ; fully-qualified # 👗 E0.6 dress
+1F458 ; fully-qualified # 👘 E0.6 kimono
+1F97B ; fully-qualified # 🥻 E12.0 sari
+1FA71 ; fully-qualified # 🩱 E12.0 one-piece swimsuit
+1FA72 ; fully-qualified # 🩲 E12.0 briefs
+1FA73 ; fully-qualified # 🩳 E12.0 shorts
+1F459 ; fully-qualified # 👙 E0.6 bikini
+1F45A ; fully-qualified # 👚 E0.6 woman’s clothes
+1F45B ; fully-qualified # 👛 E0.6 purse
+1F45C ; fully-qualified # 👜 E0.6 handbag
+1F45D ; fully-qualified # 👝 E0.6 clutch bag
+1F6CD FE0F ; fully-qualified # 🛍️ E0.7 shopping bags
+1F6CD ; unqualified # 🛍 E0.7 shopping bags
+1F392 ; fully-qualified # 🎒 E0.6 backpack
+1FA74 ; fully-qualified # 🩴 E13.0 thong sandal
+1F45E ; fully-qualified # 👞 E0.6 man’s shoe
+1F45F ; fully-qualified # 👟 E0.6 running shoe
+1F97E ; fully-qualified # 🥾 E11.0 hiking boot
+1F97F ; fully-qualified # 🥿 E11.0 flat shoe
+1F460 ; fully-qualified # 👠 E0.6 high-heeled shoe
+1F461 ; fully-qualified # 👡 E0.6 woman’s sandal
+1FA70 ; fully-qualified # 🩰 E12.0 ballet shoes
+1F462 ; fully-qualified # 👢 E0.6 woman’s boot
+1F451 ; fully-qualified # 👑 E0.6 crown
+1F452 ; fully-qualified # 👒 E0.6 woman’s hat
+1F3A9 ; fully-qualified # 🎩 E0.6 top hat
+1F393 ; fully-qualified # 🎓 E0.6 graduation cap
+1F9E2 ; fully-qualified # 🧢 E5.0 billed cap
+1FA96 ; fully-qualified # 🪖 E13.0 military helmet
+26D1 FE0F ; fully-qualified # ⛑️ E0.7 rescue worker’s helmet
+26D1 ; unqualified # ⛑ E0.7 rescue worker’s helmet
+1F4FF ; fully-qualified # 📿 E1.0 prayer beads
+1F484 ; fully-qualified # 💄 E0.6 lipstick
+1F48D ; fully-qualified # 💍 E0.6 ring
+1F48E ; fully-qualified # 💎 E0.6 gem stone
+
+# subgroup: sound
+1F507 ; fully-qualified # 🔇 E1.0 muted speaker
+1F508 ; fully-qualified # 🔈 E0.7 speaker low volume
+1F509 ; fully-qualified # 🔉 E1.0 speaker medium volume
+1F50A ; fully-qualified # 🔊 E0.6 speaker high volume
+1F4E2 ; fully-qualified # 📢 E0.6 loudspeaker
+1F4E3 ; fully-qualified # 📣 E0.6 megaphone
+1F4EF ; fully-qualified # 📯 E1.0 postal horn
+1F514 ; fully-qualified # 🔔 E0.6 bell
+1F515 ; fully-qualified # 🔕 E1.0 bell with slash
+
+# subgroup: music
+1F3BC ; fully-qualified # 🎼 E0.6 musical score
+1F3B5 ; fully-qualified # 🎵 E0.6 musical note
+1F3B6 ; fully-qualified # 🎶 E0.6 musical notes
+1F399 FE0F ; fully-qualified # 🎙️ E0.7 studio microphone
+1F399 ; unqualified # 🎙 E0.7 studio microphone
+1F39A FE0F ; fully-qualified # 🎚️ E0.7 level slider
+1F39A ; unqualified # 🎚 E0.7 level slider
+1F39B FE0F ; fully-qualified # 🎛️ E0.7 control knobs
+1F39B ; unqualified # 🎛 E0.7 control knobs
+1F3A4 ; fully-qualified # 🎤 E0.6 microphone
+1F3A7 ; fully-qualified # 🎧 E0.6 headphone
+1F4FB ; fully-qualified # 📻 E0.6 radio
+
+# subgroup: musical-instrument
+1F3B7 ; fully-qualified # 🎷 E0.6 saxophone
+1FA97 ; fully-qualified # 🪗 E13.0 accordion
+1F3B8 ; fully-qualified # 🎸 E0.6 guitar
+1F3B9 ; fully-qualified # 🎹 E0.6 musical keyboard
+1F3BA ; fully-qualified # 🎺 E0.6 trumpet
+1F3BB ; fully-qualified # 🎻 E0.6 violin
+1FA95 ; fully-qualified # 🪕 E12.0 banjo
+1F941 ; fully-qualified # 🥁 E3.0 drum
+1FA98 ; fully-qualified # 🪘 E13.0 long drum
+
+# subgroup: phone
+1F4F1 ; fully-qualified # 📱 E0.6 mobile phone
+1F4F2 ; fully-qualified # 📲 E0.6 mobile phone with arrow
+260E FE0F ; fully-qualified # ☎️ E0.6 telephone
+260E ; unqualified # ☎ E0.6 telephone
+1F4DE ; fully-qualified # 📞 E0.6 telephone receiver
+1F4DF ; fully-qualified # 📟 E0.6 pager
+1F4E0 ; fully-qualified # 📠 E0.6 fax machine
+
+# subgroup: computer
+1F50B ; fully-qualified # 🔋 E0.6 battery
+1FAAB ; fully-qualified # 🪫 E14.0 low battery
+1F50C ; fully-qualified # 🔌 E0.6 electric plug
+1F4BB ; fully-qualified # 💻 E0.6 laptop
+1F5A5 FE0F ; fully-qualified # 🖥️ E0.7 desktop computer
+1F5A5 ; unqualified # 🖥 E0.7 desktop computer
+1F5A8 FE0F ; fully-qualified # 🖨️ E0.7 printer
+1F5A8 ; unqualified # 🖨 E0.7 printer
+2328 FE0F ; fully-qualified # ⌨️ E1.0 keyboard
+2328 ; unqualified # ⌨ E1.0 keyboard
+1F5B1 FE0F ; fully-qualified # 🖱️ E0.7 computer mouse
+1F5B1 ; unqualified # 🖱 E0.7 computer mouse
+1F5B2 FE0F ; fully-qualified # 🖲️ E0.7 trackball
+1F5B2 ; unqualified # 🖲 E0.7 trackball
+1F4BD ; fully-qualified # 💽 E0.6 computer disk
+1F4BE ; fully-qualified # 💾 E0.6 floppy disk
+1F4BF ; fully-qualified # 💿 E0.6 optical disk
+1F4C0 ; fully-qualified # 📀 E0.6 dvd
+1F9EE ; fully-qualified # 🧮 E11.0 abacus
+
+# subgroup: light & video
+1F3A5 ; fully-qualified # 🎥 E0.6 movie camera
+1F39E FE0F ; fully-qualified # 🎞️ E0.7 film frames
+1F39E ; unqualified # 🎞 E0.7 film frames
+1F4FD FE0F ; fully-qualified # 📽️ E0.7 film projector
+1F4FD ; unqualified # 📽 E0.7 film projector
+1F3AC ; fully-qualified # 🎬 E0.6 clapper board
+1F4FA ; fully-qualified # 📺 E0.6 television
+1F4F7 ; fully-qualified # 📷 E0.6 camera
+1F4F8 ; fully-qualified # 📸 E1.0 camera with flash
+1F4F9 ; fully-qualified # 📹 E0.6 video camera
+1F4FC ; fully-qualified # 📼 E0.6 videocassette
+1F50D ; fully-qualified # 🔍 E0.6 magnifying glass tilted left
+1F50E ; fully-qualified # 🔎 E0.6 magnifying glass tilted right
+1F56F FE0F ; fully-qualified # 🕯️ E0.7 candle
+1F56F ; unqualified # 🕯 E0.7 candle
+1F4A1 ; fully-qualified # 💡 E0.6 light bulb
+1F526 ; fully-qualified # 🔦 E0.6 flashlight
+1F3EE ; fully-qualified # 🏮 E0.6 red paper lantern
+1FA94 ; fully-qualified # 🪔 E12.0 diya lamp
+
+# subgroup: book-paper
+1F4D4 ; fully-qualified # 📔 E0.6 notebook with decorative cover
+1F4D5 ; fully-qualified # 📕 E0.6 closed book
+1F4D6 ; fully-qualified # 📖 E0.6 open book
+1F4D7 ; fully-qualified # 📗 E0.6 green book
+1F4D8 ; fully-qualified # 📘 E0.6 blue book
+1F4D9 ; fully-qualified # 📙 E0.6 orange book
+1F4DA ; fully-qualified # 📚 E0.6 books
+1F4D3 ; fully-qualified # 📓 E0.6 notebook
+1F4D2 ; fully-qualified # 📒 E0.6 ledger
+1F4C3 ; fully-qualified # 📃 E0.6 page with curl
+1F4DC ; fully-qualified # 📜 E0.6 scroll
+1F4C4 ; fully-qualified # 📄 E0.6 page facing up
+1F4F0 ; fully-qualified # 📰 E0.6 newspaper
+1F5DE FE0F ; fully-qualified # 🗞️ E0.7 rolled-up newspaper
+1F5DE ; unqualified # 🗞 E0.7 rolled-up newspaper
+1F4D1 ; fully-qualified # 📑 E0.6 bookmark tabs
+1F516 ; fully-qualified # 🔖 E0.6 bookmark
+1F3F7 FE0F ; fully-qualified # 🏷️ E0.7 label
+1F3F7 ; unqualified # 🏷 E0.7 label
+
+# subgroup: money
+1F4B0 ; fully-qualified # 💰 E0.6 money bag
+1FA99 ; fully-qualified # 🪙 E13.0 coin
+1F4B4 ; fully-qualified # 💴 E0.6 yen banknote
+1F4B5 ; fully-qualified # 💵 E0.6 dollar banknote
+1F4B6 ; fully-qualified # 💶 E1.0 euro banknote
+1F4B7 ; fully-qualified # 💷 E1.0 pound banknote
+1F4B8 ; fully-qualified # 💸 E0.6 money with wings
+1F4B3 ; fully-qualified # 💳 E0.6 credit card
+1F9FE ; fully-qualified # 🧾 E11.0 receipt
+1F4B9 ; fully-qualified # 💹 E0.6 chart increasing with yen
+
+# subgroup: mail
+2709 FE0F ; fully-qualified # ✉️ E0.6 envelope
+2709 ; unqualified # ✉ E0.6 envelope
+1F4E7 ; fully-qualified # 📧 E0.6 e-mail
+1F4E8 ; fully-qualified # 📨 E0.6 incoming envelope
+1F4E9 ; fully-qualified # 📩 E0.6 envelope with arrow
+1F4E4 ; fully-qualified # 📤 E0.6 outbox tray
+1F4E5 ; fully-qualified # 📥 E0.6 inbox tray
+1F4E6 ; fully-qualified # 📦 E0.6 package
+1F4EB ; fully-qualified # 📫 E0.6 closed mailbox with raised flag
+1F4EA ; fully-qualified # 📪 E0.6 closed mailbox with lowered flag
+1F4EC ; fully-qualified # 📬 E0.7 open mailbox with raised flag
+1F4ED ; fully-qualified # 📭 E0.7 open mailbox with lowered flag
+1F4EE ; fully-qualified # 📮 E0.6 postbox
+1F5F3 FE0F ; fully-qualified # 🗳️ E0.7 ballot box with ballot
+1F5F3 ; unqualified # 🗳 E0.7 ballot box with ballot
+
+# subgroup: writing
+270F FE0F ; fully-qualified # ✏️ E0.6 pencil
+270F ; unqualified # ✏ E0.6 pencil
+2712 FE0F ; fully-qualified # ✒️ E0.6 black nib
+2712 ; unqualified # ✒ E0.6 black nib
+1F58B FE0F ; fully-qualified # 🖋️ E0.7 fountain pen
+1F58B ; unqualified # 🖋 E0.7 fountain pen
+1F58A FE0F ; fully-qualified # 🖊️ E0.7 pen
+1F58A ; unqualified # 🖊 E0.7 pen
+1F58C FE0F ; fully-qualified # 🖌️ E0.7 paintbrush
+1F58C ; unqualified # 🖌 E0.7 paintbrush
+1F58D FE0F ; fully-qualified # 🖍️ E0.7 crayon
+1F58D ; unqualified # 🖍 E0.7 crayon
+1F4DD ; fully-qualified # 📝 E0.6 memo
+
+# subgroup: office
+1F4BC ; fully-qualified # 💼 E0.6 briefcase
+1F4C1 ; fully-qualified # 📁 E0.6 file folder
+1F4C2 ; fully-qualified # 📂 E0.6 open file folder
+1F5C2 FE0F ; fully-qualified # 🗂️ E0.7 card index dividers
+1F5C2 ; unqualified # 🗂 E0.7 card index dividers
+1F4C5 ; fully-qualified # 📅 E0.6 calendar
+1F4C6 ; fully-qualified # 📆 E0.6 tear-off calendar
+1F5D2 FE0F ; fully-qualified # 🗒️ E0.7 spiral notepad
+1F5D2 ; unqualified # 🗒 E0.7 spiral notepad
+1F5D3 FE0F ; fully-qualified # 🗓️ E0.7 spiral calendar
+1F5D3 ; unqualified # 🗓 E0.7 spiral calendar
+1F4C7 ; fully-qualified # 📇 E0.6 card index
+1F4C8 ; fully-qualified # 📈 E0.6 chart increasing
+1F4C9 ; fully-qualified # 📉 E0.6 chart decreasing
+1F4CA ; fully-qualified # 📊 E0.6 bar chart
+1F4CB ; fully-qualified # 📋 E0.6 clipboard
+1F4CC ; fully-qualified # 📌 E0.6 pushpin
+1F4CD ; fully-qualified # 📍 E0.6 round pushpin
+1F4CE ; fully-qualified # 📎 E0.6 paperclip
+1F587 FE0F ; fully-qualified # 🖇️ E0.7 linked paperclips
+1F587 ; unqualified # 🖇 E0.7 linked paperclips
+1F4CF ; fully-qualified # 📏 E0.6 straight ruler
+1F4D0 ; fully-qualified # 📐 E0.6 triangular ruler
+2702 FE0F ; fully-qualified # ✂️ E0.6 scissors
+2702 ; unqualified # ✂ E0.6 scissors
+1F5C3 FE0F ; fully-qualified # 🗃️ E0.7 card file box
+1F5C3 ; unqualified # 🗃 E0.7 card file box
+1F5C4 FE0F ; fully-qualified # 🗄️ E0.7 file cabinet
+1F5C4 ; unqualified # 🗄 E0.7 file cabinet
+1F5D1 FE0F ; fully-qualified # 🗑️ E0.7 wastebasket
+1F5D1 ; unqualified # 🗑 E0.7 wastebasket
+
+# subgroup: lock
+1F512 ; fully-qualified # 🔒 E0.6 locked
+1F513 ; fully-qualified # 🔓 E0.6 unlocked
+1F50F ; fully-qualified # 🔏 E0.6 locked with pen
+1F510 ; fully-qualified # 🔐 E0.6 locked with key
+1F511 ; fully-qualified # 🔑 E0.6 key
+1F5DD FE0F ; fully-qualified # 🗝️ E0.7 old key
+1F5DD ; unqualified # 🗝 E0.7 old key
+
+# subgroup: tool
+1F528 ; fully-qualified # 🔨 E0.6 hammer
+1FA93 ; fully-qualified # 🪓 E12.0 axe
+26CF FE0F ; fully-qualified # ⛏️ E0.7 pick
+26CF ; unqualified # ⛏ E0.7 pick
+2692 FE0F ; fully-qualified # ⚒️ E1.0 hammer and pick
+2692 ; unqualified # ⚒ E1.0 hammer and pick
+1F6E0 FE0F ; fully-qualified # 🛠️ E0.7 hammer and wrench
+1F6E0 ; unqualified # 🛠 E0.7 hammer and wrench
+1F5E1 FE0F ; fully-qualified # 🗡️ E0.7 dagger
+1F5E1 ; unqualified # 🗡 E0.7 dagger
+2694 FE0F ; fully-qualified # ⚔️ E1.0 crossed swords
+2694 ; unqualified # ⚔ E1.0 crossed swords
+1F52B ; fully-qualified # 🔫 E0.6 water pistol
+1FA83 ; fully-qualified # 🪃 E13.0 boomerang
+1F3F9 ; fully-qualified # 🏹 E1.0 bow and arrow
+1F6E1 FE0F ; fully-qualified # 🛡️ E0.7 shield
+1F6E1 ; unqualified # 🛡 E0.7 shield
+1FA9A ; fully-qualified # 🪚 E13.0 carpentry saw
+1F527 ; fully-qualified # 🔧 E0.6 wrench
+1FA9B ; fully-qualified # 🪛 E13.0 screwdriver
+1F529 ; fully-qualified # 🔩 E0.6 nut and bolt
+2699 FE0F ; fully-qualified # ⚙️ E1.0 gear
+2699 ; unqualified # ⚙ E1.0 gear
+1F5DC FE0F ; fully-qualified # 🗜️ E0.7 clamp
+1F5DC ; unqualified # 🗜 E0.7 clamp
+2696 FE0F ; fully-qualified # ⚖️ E1.0 balance scale
+2696 ; unqualified # ⚖ E1.0 balance scale
+1F9AF ; fully-qualified # 🦯 E12.0 white cane
+1F517 ; fully-qualified # 🔗 E0.6 link
+26D3 FE0F ; fully-qualified # ⛓️ E0.7 chains
+26D3 ; unqualified # ⛓ E0.7 chains
+1FA9D ; fully-qualified # 🪝 E13.0 hook
+1F9F0 ; fully-qualified # 🧰 E11.0 toolbox
+1F9F2 ; fully-qualified # 🧲 E11.0 magnet
+1FA9C ; fully-qualified # 🪜 E13.0 ladder
+
+# subgroup: science
+2697 FE0F ; fully-qualified # ⚗️ E1.0 alembic
+2697 ; unqualified # ⚗ E1.0 alembic
+1F9EA ; fully-qualified # 🧪 E11.0 test tube
+1F9EB ; fully-qualified # 🧫 E11.0 petri dish
+1F9EC ; fully-qualified # 🧬 E11.0 dna
+1F52C ; fully-qualified # 🔬 E1.0 microscope
+1F52D ; fully-qualified # 🔭 E1.0 telescope
+1F4E1 ; fully-qualified # 📡 E0.6 satellite antenna
+
+# subgroup: medical
+1F489 ; fully-qualified # 💉 E0.6 syringe
+1FA78 ; fully-qualified # 🩸 E12.0 drop of blood
+1F48A ; fully-qualified # 💊 E0.6 pill
+1FA79 ; fully-qualified # 🩹 E12.0 adhesive bandage
+1FA7C ; fully-qualified # 🩼 E14.0 crutch
+1FA7A ; fully-qualified # 🩺 E12.0 stethoscope
+1FA7B ; fully-qualified # 🩻 E14.0 x-ray
+
+# subgroup: household
+1F6AA ; fully-qualified # 🚪 E0.6 door
+1F6D7 ; fully-qualified # 🛗 E13.0 elevator
+1FA9E ; fully-qualified # 🪞 E13.0 mirror
+1FA9F ; fully-qualified # 🪟 E13.0 window
+1F6CF FE0F ; fully-qualified # 🛏️ E0.7 bed
+1F6CF ; unqualified # 🛏 E0.7 bed
+1F6CB FE0F ; fully-qualified # 🛋️ E0.7 couch and lamp
+1F6CB ; unqualified # 🛋 E0.7 couch and lamp
+1FA91 ; fully-qualified # 🪑 E12.0 chair
+1F6BD ; fully-qualified # 🚽 E0.6 toilet
+1FAA0 ; fully-qualified # 🪠 E13.0 plunger
+1F6BF ; fully-qualified # 🚿 E1.0 shower
+1F6C1 ; fully-qualified # 🛁 E1.0 bathtub
+1FAA4 ; fully-qualified # 🪤 E13.0 mouse trap
+1FA92 ; fully-qualified # 🪒 E12.0 razor
+1F9F4 ; fully-qualified # 🧴 E11.0 lotion bottle
+1F9F7 ; fully-qualified # 🧷 E11.0 safety pin
+1F9F9 ; fully-qualified # 🧹 E11.0 broom
+1F9FA ; fully-qualified # 🧺 E11.0 basket
+1F9FB ; fully-qualified # 🧻 E11.0 roll of paper
+1FAA3 ; fully-qualified # 🪣 E13.0 bucket
+1F9FC ; fully-qualified # 🧼 E11.0 soap
+1FAE7 ; fully-qualified # 🫧 E14.0 bubbles
+1FAA5 ; fully-qualified # 🪥 E13.0 toothbrush
+1F9FD ; fully-qualified # 🧽 E11.0 sponge
+1F9EF ; fully-qualified # 🧯 E11.0 fire extinguisher
+1F6D2 ; fully-qualified # 🛒 E3.0 shopping cart
+
+# subgroup: other-object
+1F6AC ; fully-qualified # 🚬 E0.6 cigarette
+26B0 FE0F ; fully-qualified # ⚰️ E1.0 coffin
+26B0 ; unqualified # ⚰ E1.0 coffin
+1FAA6 ; fully-qualified # 🪦 E13.0 headstone
+26B1 FE0F ; fully-qualified # ⚱️ E1.0 funeral urn
+26B1 ; unqualified # ⚱ E1.0 funeral urn
+1F5FF ; fully-qualified # 🗿 E0.6 moai
+1FAA7 ; fully-qualified # 🪧 E13.0 placard
+1FAAA ; fully-qualified # 🪪 E14.0 identification card
+
+# Objects subtotal: 304
+# Objects subtotal: 304 w/o modifiers
+
+# group: Symbols
+
+# subgroup: transport-sign
+1F3E7 ; fully-qualified # 🏧 E0.6 ATM sign
+1F6AE ; fully-qualified # 🚮 E1.0 litter in bin sign
+1F6B0 ; fully-qualified # 🚰 E1.0 potable water
+267F ; fully-qualified # ♿ E0.6 wheelchair symbol
+1F6B9 ; fully-qualified # 🚹 E0.6 men’s room
+1F6BA ; fully-qualified # 🚺 E0.6 women’s room
+1F6BB ; fully-qualified # 🚻 E0.6 restroom
+1F6BC ; fully-qualified # 🚼 E0.6 baby symbol
+1F6BE ; fully-qualified # 🚾 E0.6 water closet
+1F6C2 ; fully-qualified # 🛂 E1.0 passport control
+1F6C3 ; fully-qualified # 🛃 E1.0 customs
+1F6C4 ; fully-qualified # 🛄 E1.0 baggage claim
+1F6C5 ; fully-qualified # 🛅 E1.0 left luggage
+
+# subgroup: warning
+26A0 FE0F ; fully-qualified # ⚠️ E0.6 warning
+26A0 ; unqualified # ⚠ E0.6 warning
+1F6B8 ; fully-qualified # 🚸 E1.0 children crossing
+26D4 ; fully-qualified # ⛔ E0.6 no entry
+1F6AB ; fully-qualified # 🚫 E0.6 prohibited
+1F6B3 ; fully-qualified # 🚳 E1.0 no bicycles
+1F6AD ; fully-qualified # 🚭 E0.6 no smoking
+1F6AF ; fully-qualified # 🚯 E1.0 no littering
+1F6B1 ; fully-qualified # 🚱 E1.0 non-potable water
+1F6B7 ; fully-qualified # 🚷 E1.0 no pedestrians
+1F4F5 ; fully-qualified # 📵 E1.0 no mobile phones
+1F51E ; fully-qualified # 🔞 E0.6 no one under eighteen
+2622 FE0F ; fully-qualified # ☢️ E1.0 radioactive
+2622 ; unqualified # ☢ E1.0 radioactive
+2623 FE0F ; fully-qualified # ☣️ E1.0 biohazard
+2623 ; unqualified # ☣ E1.0 biohazard
+
+# subgroup: arrow
+2B06 FE0F ; fully-qualified # ⬆️ E0.6 up arrow
+2B06 ; unqualified # ⬆ E0.6 up arrow
+2197 FE0F ; fully-qualified # ↗️ E0.6 up-right arrow
+2197 ; unqualified # ↗ E0.6 up-right arrow
+27A1 FE0F ; fully-qualified # ➡️ E0.6 right arrow
+27A1 ; unqualified # ➡ E0.6 right arrow
+2198 FE0F ; fully-qualified # ↘️ E0.6 down-right arrow
+2198 ; unqualified # ↘ E0.6 down-right arrow
+2B07 FE0F ; fully-qualified # ⬇️ E0.6 down arrow
+2B07 ; unqualified # ⬇ E0.6 down arrow
+2199 FE0F ; fully-qualified # ↙️ E0.6 down-left arrow
+2199 ; unqualified # ↙ E0.6 down-left arrow
+2B05 FE0F ; fully-qualified # ⬅️ E0.6 left arrow
+2B05 ; unqualified # ⬅ E0.6 left arrow
+2196 FE0F ; fully-qualified # ↖️ E0.6 up-left arrow
+2196 ; unqualified # ↖ E0.6 up-left arrow
+2195 FE0F ; fully-qualified # ↕️ E0.6 up-down arrow
+2195 ; unqualified # ↕ E0.6 up-down arrow
+2194 FE0F ; fully-qualified # ↔️ E0.6 left-right arrow
+2194 ; unqualified # ↔ E0.6 left-right arrow
+21A9 FE0F ; fully-qualified # ↩️ E0.6 right arrow curving left
+21A9 ; unqualified # ↩ E0.6 right arrow curving left
+21AA FE0F ; fully-qualified # ↪️ E0.6 left arrow curving right
+21AA ; unqualified # ↪ E0.6 left arrow curving right
+2934 FE0F ; fully-qualified # ⤴️ E0.6 right arrow curving up
+2934 ; unqualified # ⤴ E0.6 right arrow curving up
+2935 FE0F ; fully-qualified # ⤵️ E0.6 right arrow curving down
+2935 ; unqualified # ⤵ E0.6 right arrow curving down
+1F503 ; fully-qualified # 🔃 E0.6 clockwise vertical arrows
+1F504 ; fully-qualified # 🔄 E1.0 counterclockwise arrows button
+1F519 ; fully-qualified # 🔙 E0.6 BACK arrow
+1F51A ; fully-qualified # 🔚 E0.6 END arrow
+1F51B ; fully-qualified # 🔛 E0.6 ON! arrow
+1F51C ; fully-qualified # 🔜 E0.6 SOON arrow
+1F51D ; fully-qualified # 🔝 E0.6 TOP arrow
+
+# subgroup: religion
+1F6D0 ; fully-qualified # 🛐 E1.0 place of worship
+269B FE0F ; fully-qualified # ⚛️ E1.0 atom symbol
+269B ; unqualified # ⚛ E1.0 atom symbol
+1F549 FE0F ; fully-qualified # 🕉️ E0.7 om
+1F549 ; unqualified # 🕉 E0.7 om
+2721 FE0F ; fully-qualified # ✡️ E0.7 star of David
+2721 ; unqualified # ✡ E0.7 star of David
+2638 FE0F ; fully-qualified # ☸️ E0.7 wheel of dharma
+2638 ; unqualified # ☸ E0.7 wheel of dharma
+262F FE0F ; fully-qualified # ☯️ E0.7 yin yang
+262F ; unqualified # ☯ E0.7 yin yang
+271D FE0F ; fully-qualified # ✝️ E0.7 latin cross
+271D ; unqualified # ✝ E0.7 latin cross
+2626 FE0F ; fully-qualified # ☦️ E1.0 orthodox cross
+2626 ; unqualified # ☦ E1.0 orthodox cross
+262A FE0F ; fully-qualified # ☪️ E0.7 star and crescent
+262A ; unqualified # ☪ E0.7 star and crescent
+262E FE0F ; fully-qualified # ☮️ E1.0 peace symbol
+262E ; unqualified # ☮ E1.0 peace symbol
+1F54E ; fully-qualified # 🕎 E1.0 menorah
+1F52F ; fully-qualified # 🔯 E0.6 dotted six-pointed star
+
+# subgroup: zodiac
+2648 ; fully-qualified # ♈ E0.6 Aries
+2649 ; fully-qualified # ♉ E0.6 Taurus
+264A ; fully-qualified # ♊ E0.6 Gemini
+264B ; fully-qualified # ♋ E0.6 Cancer
+264C ; fully-qualified # ♌ E0.6 Leo
+264D ; fully-qualified # ♍ E0.6 Virgo
+264E ; fully-qualified # ♎ E0.6 Libra
+264F ; fully-qualified # ♏ E0.6 Scorpio
+2650 ; fully-qualified # ♐ E0.6 Sagittarius
+2651 ; fully-qualified # ♑ E0.6 Capricorn
+2652 ; fully-qualified # ♒ E0.6 Aquarius
+2653 ; fully-qualified # ♓ E0.6 Pisces
+26CE ; fully-qualified # ⛎ E0.6 Ophiuchus
+
+# subgroup: av-symbol
+1F500 ; fully-qualified # 🔀 E1.0 shuffle tracks button
+1F501 ; fully-qualified # 🔁 E1.0 repeat button
+1F502 ; fully-qualified # 🔂 E1.0 repeat single button
+25B6 FE0F ; fully-qualified # ▶️ E0.6 play button
+25B6 ; unqualified # ▶ E0.6 play button
+23E9 ; fully-qualified # ⏩ E0.6 fast-forward button
+23ED FE0F ; fully-qualified # ⏭️ E0.7 next track button
+23ED ; unqualified # ⏭ E0.7 next track button
+23EF FE0F ; fully-qualified # ⏯️ E1.0 play or pause button
+23EF ; unqualified # ⏯ E1.0 play or pause button
+25C0 FE0F ; fully-qualified # ◀️ E0.6 reverse button
+25C0 ; unqualified # ◀ E0.6 reverse button
+23EA ; fully-qualified # ⏪ E0.6 fast reverse button
+23EE FE0F ; fully-qualified # ⏮️ E0.7 last track button
+23EE ; unqualified # ⏮ E0.7 last track button
+1F53C ; fully-qualified # 🔼 E0.6 upwards button
+23EB ; fully-qualified # ⏫ E0.6 fast up button
+1F53D ; fully-qualified # 🔽 E0.6 downwards button
+23EC ; fully-qualified # ⏬ E0.6 fast down button
+23F8 FE0F ; fully-qualified # ⏸️ E0.7 pause button
+23F8 ; unqualified # ⏸ E0.7 pause button
+23F9 FE0F ; fully-qualified # ⏹️ E0.7 stop button
+23F9 ; unqualified # ⏹ E0.7 stop button
+23FA FE0F ; fully-qualified # ⏺️ E0.7 record button
+23FA ; unqualified # ⏺ E0.7 record button
+23CF FE0F ; fully-qualified # ⏏️ E1.0 eject button
+23CF ; unqualified # ⏏ E1.0 eject button
+1F3A6 ; fully-qualified # 🎦 E0.6 cinema
+1F505 ; fully-qualified # 🔅 E1.0 dim button
+1F506 ; fully-qualified # 🔆 E1.0 bright button
+1F4F6 ; fully-qualified # 📶 E0.6 antenna bars
+1F4F3 ; fully-qualified # 📳 E0.6 vibration mode
+1F4F4 ; fully-qualified # 📴 E0.6 mobile phone off
+
+# subgroup: gender
+2640 FE0F ; fully-qualified # ♀️ E4.0 female sign
+2640 ; unqualified # ♀ E4.0 female sign
+2642 FE0F ; fully-qualified # ♂️ E4.0 male sign
+2642 ; unqualified # ♂ E4.0 male sign
+26A7 FE0F ; fully-qualified # ⚧️ E13.0 transgender symbol
+26A7 ; unqualified # ⚧ E13.0 transgender symbol
+
+# subgroup: math
+2716 FE0F ; fully-qualified # ✖️ E0.6 multiply
+2716 ; unqualified # ✖ E0.6 multiply
+2795 ; fully-qualified # ➕ E0.6 plus
+2796 ; fully-qualified # ➖ E0.6 minus
+2797 ; fully-qualified # ➗ E0.6 divide
+1F7F0 ; fully-qualified # 🟰 E14.0 heavy equals sign
+267E FE0F ; fully-qualified # ♾️ E11.0 infinity
+267E ; unqualified # ♾ E11.0 infinity
+
+# subgroup: punctuation
+203C FE0F ; fully-qualified # ‼️ E0.6 double exclamation mark
+203C ; unqualified # ‼ E0.6 double exclamation mark
+2049 FE0F ; fully-qualified # ⁉️ E0.6 exclamation question mark
+2049 ; unqualified # ⁉ E0.6 exclamation question mark
+2753 ; fully-qualified # ❓ E0.6 red question mark
+2754 ; fully-qualified # ❔ E0.6 white question mark
+2755 ; fully-qualified # ❕ E0.6 white exclamation mark
+2757 ; fully-qualified # ❗ E0.6 red exclamation mark
+3030 FE0F ; fully-qualified # 〰️ E0.6 wavy dash
+3030 ; unqualified # 〰 E0.6 wavy dash
+
+# subgroup: currency
+1F4B1 ; fully-qualified # 💱 E0.6 currency exchange
+1F4B2 ; fully-qualified # 💲 E0.6 heavy dollar sign
+
+# subgroup: other-symbol
+2695 FE0F ; fully-qualified # ⚕️ E4.0 medical symbol
+2695 ; unqualified # ⚕ E4.0 medical symbol
+267B FE0F ; fully-qualified # ♻️ E0.6 recycling symbol
+267B ; unqualified # ♻ E0.6 recycling symbol
+269C FE0F ; fully-qualified # ⚜️ E1.0 fleur-de-lis
+269C ; unqualified # ⚜ E1.0 fleur-de-lis
+1F531 ; fully-qualified # 🔱 E0.6 trident emblem
+1F4DB ; fully-qualified # 📛 E0.6 name badge
+1F530 ; fully-qualified # 🔰 E0.6 Japanese symbol for beginner
+2B55 ; fully-qualified # ⭕ E0.6 hollow red circle
+2705 ; fully-qualified # ✅ E0.6 check mark button
+2611 FE0F ; fully-qualified # ☑️ E0.6 check box with check
+2611 ; unqualified # ☑ E0.6 check box with check
+2714 FE0F ; fully-qualified # ✔️ E0.6 check mark
+2714 ; unqualified # ✔ E0.6 check mark
+274C ; fully-qualified # ❌ E0.6 cross mark
+274E ; fully-qualified # ❎ E0.6 cross mark button
+27B0 ; fully-qualified # ➰ E0.6 curly loop
+27BF ; fully-qualified # ➿ E1.0 double curly loop
+303D FE0F ; fully-qualified # 〽️ E0.6 part alternation mark
+303D ; unqualified # 〽 E0.6 part alternation mark
+2733 FE0F ; fully-qualified # ✳️ E0.6 eight-spoked asterisk
+2733 ; unqualified # ✳ E0.6 eight-spoked asterisk
+2734 FE0F ; fully-qualified # ✴️ E0.6 eight-pointed star
+2734 ; unqualified # ✴ E0.6 eight-pointed star
+2747 FE0F ; fully-qualified # ❇️ E0.6 sparkle
+2747 ; unqualified # ❇ E0.6 sparkle
+00A9 FE0F ; fully-qualified # ©️ E0.6 copyright
+00A9 ; unqualified # © E0.6 copyright
+00AE FE0F ; fully-qualified # ®️ E0.6 registered
+00AE ; unqualified # ® E0.6 registered
+2122 FE0F ; fully-qualified # ™️ E0.6 trade mark
+2122 ; unqualified # ™ E0.6 trade mark
+
+# subgroup: keycap
+0023 FE0F 20E3 ; fully-qualified # #️⃣ E0.6 keycap: #
+0023 20E3 ; unqualified # #⃣ E0.6 keycap: #
+002A FE0F 20E3 ; fully-qualified # *️⃣ E2.0 keycap: *
+002A 20E3 ; unqualified # *⃣ E2.0 keycap: *
+0030 FE0F 20E3 ; fully-qualified # 0️⃣ E0.6 keycap: 0
+0030 20E3 ; unqualified # 0⃣ E0.6 keycap: 0
+0031 FE0F 20E3 ; fully-qualified # 1️⃣ E0.6 keycap: 1
+0031 20E3 ; unqualified # 1⃣ E0.6 keycap: 1
+0032 FE0F 20E3 ; fully-qualified # 2️⃣ E0.6 keycap: 2
+0032 20E3 ; unqualified # 2⃣ E0.6 keycap: 2
+0033 FE0F 20E3 ; fully-qualified # 3️⃣ E0.6 keycap: 3
+0033 20E3 ; unqualified # 3⃣ E0.6 keycap: 3
+0034 FE0F 20E3 ; fully-qualified # 4️⃣ E0.6 keycap: 4
+0034 20E3 ; unqualified # 4⃣ E0.6 keycap: 4
+0035 FE0F 20E3 ; fully-qualified # 5️⃣ E0.6 keycap: 5
+0035 20E3 ; unqualified # 5⃣ E0.6 keycap: 5
+0036 FE0F 20E3 ; fully-qualified # 6️⃣ E0.6 keycap: 6
+0036 20E3 ; unqualified # 6⃣ E0.6 keycap: 6
+0037 FE0F 20E3 ; fully-qualified # 7️⃣ E0.6 keycap: 7
+0037 20E3 ; unqualified # 7⃣ E0.6 keycap: 7
+0038 FE0F 20E3 ; fully-qualified # 8️⃣ E0.6 keycap: 8
+0038 20E3 ; unqualified # 8⃣ E0.6 keycap: 8
+0039 FE0F 20E3 ; fully-qualified # 9️⃣ E0.6 keycap: 9
+0039 20E3 ; unqualified # 9⃣ E0.6 keycap: 9
+1F51F ; fully-qualified # 🔟 E0.6 keycap: 10
+
+# subgroup: alphanum
+1F520 ; fully-qualified # 🔠 E0.6 input latin uppercase
+1F521 ; fully-qualified # 🔡 E0.6 input latin lowercase
+1F522 ; fully-qualified # 🔢 E0.6 input numbers
+1F523 ; fully-qualified # 🔣 E0.6 input symbols
+1F524 ; fully-qualified # 🔤 E0.6 input latin letters
+1F170 FE0F ; fully-qualified # 🅰️ E0.6 A button (blood type)
+1F170 ; unqualified # 🅰 E0.6 A button (blood type)
+1F18E ; fully-qualified # 🆎 E0.6 AB button (blood type)
+1F171 FE0F ; fully-qualified # 🅱️ E0.6 B button (blood type)
+1F171 ; unqualified # 🅱 E0.6 B button (blood type)
+1F191 ; fully-qualified # 🆑 E0.6 CL button
+1F192 ; fully-qualified # 🆒 E0.6 COOL button
+1F193 ; fully-qualified # 🆓 E0.6 FREE button
+2139 FE0F ; fully-qualified # ℹ️ E0.6 information
+2139 ; unqualified # ℹ E0.6 information
+1F194 ; fully-qualified # 🆔 E0.6 ID button
+24C2 FE0F ; fully-qualified # Ⓜ️ E0.6 circled M
+24C2 ; unqualified # Ⓜ E0.6 circled M
+1F195 ; fully-qualified # 🆕 E0.6 NEW button
+1F196 ; fully-qualified # 🆖 E0.6 NG button
+1F17E FE0F ; fully-qualified # 🅾️ E0.6 O button (blood type)
+1F17E ; unqualified # 🅾 E0.6 O button (blood type)
+1F197 ; fully-qualified # 🆗 E0.6 OK button
+1F17F FE0F ; fully-qualified # 🅿️ E0.6 P button
+1F17F ; unqualified # 🅿 E0.6 P button
+1F198 ; fully-qualified # 🆘 E0.6 SOS button
+1F199 ; fully-qualified # 🆙 E0.6 UP! button
+1F19A ; fully-qualified # 🆚 E0.6 VS button
+1F201 ; fully-qualified # 🈁 E0.6 Japanese “here” button
+1F202 FE0F ; fully-qualified # 🈂️ E0.6 Japanese “service charge” button
+1F202 ; unqualified # 🈂 E0.6 Japanese “service charge” button
+1F237 FE0F ; fully-qualified # 🈷️ E0.6 Japanese “monthly amount” button
+1F237 ; unqualified # 🈷 E0.6 Japanese “monthly amount” button
+1F236 ; fully-qualified # 🈶 E0.6 Japanese “not free of charge” button
+1F22F ; fully-qualified # 🈯 E0.6 Japanese “reserved” button
+1F250 ; fully-qualified # 🉐 E0.6 Japanese “bargain” button
+1F239 ; fully-qualified # 🈹 E0.6 Japanese “discount” button
+1F21A ; fully-qualified # 🈚 E0.6 Japanese “free of charge” button
+1F232 ; fully-qualified # 🈲 E0.6 Japanese “prohibited” button
+1F251 ; fully-qualified # 🉑 E0.6 Japanese “acceptable” button
+1F238 ; fully-qualified # 🈸 E0.6 Japanese “application” button
+1F234 ; fully-qualified # 🈴 E0.6 Japanese “passing grade” button
+1F233 ; fully-qualified # 🈳 E0.6 Japanese “vacancy” button
+3297 FE0F ; fully-qualified # ㊗️ E0.6 Japanese “congratulations” button
+3297 ; unqualified # ㊗ E0.6 Japanese “congratulations” button
+3299 FE0F ; fully-qualified # ㊙️ E0.6 Japanese “secret” button
+3299 ; unqualified # ㊙ E0.6 Japanese “secret” button
+1F23A ; fully-qualified # 🈺 E0.6 Japanese “open for business” button
+1F235 ; fully-qualified # 🈵 E0.6 Japanese “no vacancy” button
+
+# subgroup: geometric
+1F534 ; fully-qualified # 🔴 E0.6 red circle
+1F7E0 ; fully-qualified # 🟠 E12.0 orange circle
+1F7E1 ; fully-qualified # 🟡 E12.0 yellow circle
+1F7E2 ; fully-qualified # 🟢 E12.0 green circle
+1F535 ; fully-qualified # 🔵 E0.6 blue circle
+1F7E3 ; fully-qualified # 🟣 E12.0 purple circle
+1F7E4 ; fully-qualified # 🟤 E12.0 brown circle
+26AB ; fully-qualified # ⚫ E0.6 black circle
+26AA ; fully-qualified # ⚪ E0.6 white circle
+1F7E5 ; fully-qualified # 🟥 E12.0 red square
+1F7E7 ; fully-qualified # 🟧 E12.0 orange square
+1F7E8 ; fully-qualified # 🟨 E12.0 yellow square
+1F7E9 ; fully-qualified # 🟩 E12.0 green square
+1F7E6 ; fully-qualified # 🟦 E12.0 blue square
+1F7EA ; fully-qualified # 🟪 E12.0 purple square
+1F7EB ; fully-qualified # 🟫 E12.0 brown square
+2B1B ; fully-qualified # ⬛ E0.6 black large square
+2B1C ; fully-qualified # ⬜ E0.6 white large square
+25FC FE0F ; fully-qualified # ◼️ E0.6 black medium square
+25FC ; unqualified # ◼ E0.6 black medium square
+25FB FE0F ; fully-qualified # ◻️ E0.6 white medium square
+25FB ; unqualified # ◻ E0.6 white medium square
+25FE ; fully-qualified # ◾ E0.6 black medium-small square
+25FD ; fully-qualified # ◽ E0.6 white medium-small square
+25AA FE0F ; fully-qualified # ▪️ E0.6 black small square
+25AA ; unqualified # ▪ E0.6 black small square
+25AB FE0F ; fully-qualified # ▫️ E0.6 white small square
+25AB ; unqualified # ▫ E0.6 white small square
+1F536 ; fully-qualified # 🔶 E0.6 large orange diamond
+1F537 ; fully-qualified # 🔷 E0.6 large blue diamond
+1F538 ; fully-qualified # 🔸 E0.6 small orange diamond
+1F539 ; fully-qualified # 🔹 E0.6 small blue diamond
+1F53A ; fully-qualified # 🔺 E0.6 red triangle pointed up
+1F53B ; fully-qualified # 🔻 E0.6 red triangle pointed down
+1F4A0 ; fully-qualified # 💠 E0.6 diamond with a dot
+1F518 ; fully-qualified # 🔘 E0.6 radio button
+1F533 ; fully-qualified # 🔳 E0.6 white square button
+1F532 ; fully-qualified # 🔲 E0.6 black square button
+
+# Symbols subtotal: 302
+# Symbols subtotal: 302 w/o modifiers
+
+# group: Flags
+
+# subgroup: flag
+1F3C1 ; fully-qualified # 🏁 E0.6 chequered flag
+1F6A9 ; fully-qualified # 🚩 E0.6 triangular flag
+1F38C ; fully-qualified # 🎌 E0.6 crossed flags
+1F3F4 ; fully-qualified # 🏴 E1.0 black flag
+1F3F3 FE0F ; fully-qualified # 🏳️ E0.7 white flag
+1F3F3 ; unqualified # 🏳 E0.7 white flag
+1F3F3 FE0F 200D 1F308 ; fully-qualified # 🏳️‍🌈 E4.0 rainbow flag
+1F3F3 200D 1F308 ; unqualified # 🏳‍🌈 E4.0 rainbow flag
+1F3F3 FE0F 200D 26A7 FE0F ; fully-qualified # 🏳️‍⚧️ E13.0 transgender flag
+1F3F3 200D 26A7 FE0F ; unqualified # 🏳‍⚧️ E13.0 transgender flag
+1F3F3 FE0F 200D 26A7 ; unqualified # 🏳️‍⚧ E13.0 transgender flag
+1F3F3 200D 26A7 ; unqualified # 🏳‍⚧ E13.0 transgender flag
+1F3F4 200D 2620 FE0F ; fully-qualified # 🏴‍☠️ E11.0 pirate flag
+1F3F4 200D 2620 ; minimally-qualified # 🏴‍☠ E11.0 pirate flag
+
+# subgroup: country-flag
+1F1E6 1F1E8 ; fully-qualified # 🇦🇨 E2.0 flag: Ascension Island
+1F1E6 1F1E9 ; fully-qualified # 🇦🇩 E2.0 flag: Andorra
+1F1E6 1F1EA ; fully-qualified # 🇦🇪 E2.0 flag: United Arab Emirates
+1F1E6 1F1EB ; fully-qualified # 🇦🇫 E2.0 flag: Afghanistan
+1F1E6 1F1EC ; fully-qualified # 🇦🇬 E2.0 flag: Antigua & Barbuda
+1F1E6 1F1EE ; fully-qualified # 🇦🇮 E2.0 flag: Anguilla
+1F1E6 1F1F1 ; fully-qualified # 🇦🇱 E2.0 flag: Albania
+1F1E6 1F1F2 ; fully-qualified # 🇦🇲 E2.0 flag: Armenia
+1F1E6 1F1F4 ; fully-qualified # 🇦🇴 E2.0 flag: Angola
+1F1E6 1F1F6 ; fully-qualified # 🇦🇶 E2.0 flag: Antarctica
+1F1E6 1F1F7 ; fully-qualified # 🇦🇷 E2.0 flag: Argentina
+1F1E6 1F1F8 ; fully-qualified # 🇦🇸 E2.0 flag: American Samoa
+1F1E6 1F1F9 ; fully-qualified # 🇦🇹 E2.0 flag: Austria
+1F1E6 1F1FA ; fully-qualified # 🇦🇺 E2.0 flag: Australia
+1F1E6 1F1FC ; fully-qualified # 🇦🇼 E2.0 flag: Aruba
+1F1E6 1F1FD ; fully-qualified # 🇦🇽 E2.0 flag: Åland Islands
+1F1E6 1F1FF ; fully-qualified # 🇦🇿 E2.0 flag: Azerbaijan
+1F1E7 1F1E6 ; fully-qualified # 🇧🇦 E2.0 flag: Bosnia & Herzegovina
+1F1E7 1F1E7 ; fully-qualified # 🇧🇧 E2.0 flag: Barbados
+1F1E7 1F1E9 ; fully-qualified # 🇧🇩 E2.0 flag: Bangladesh
+1F1E7 1F1EA ; fully-qualified # 🇧🇪 E2.0 flag: Belgium
+1F1E7 1F1EB ; fully-qualified # 🇧🇫 E2.0 flag: Burkina Faso
+1F1E7 1F1EC ; fully-qualified # 🇧🇬 E2.0 flag: Bulgaria
+1F1E7 1F1ED ; fully-qualified # 🇧🇭 E2.0 flag: Bahrain
+1F1E7 1F1EE ; fully-qualified # 🇧🇮 E2.0 flag: Burundi
+1F1E7 1F1EF ; fully-qualified # 🇧🇯 E2.0 flag: Benin
+1F1E7 1F1F1 ; fully-qualified # 🇧🇱 E2.0 flag: St. Barthélemy
+1F1E7 1F1F2 ; fully-qualified # 🇧🇲 E2.0 flag: Bermuda
+1F1E7 1F1F3 ; fully-qualified # 🇧🇳 E2.0 flag: Brunei
+1F1E7 1F1F4 ; fully-qualified # 🇧🇴 E2.0 flag: Bolivia
+1F1E7 1F1F6 ; fully-qualified # 🇧🇶 E2.0 flag: Caribbean Netherlands
+1F1E7 1F1F7 ; fully-qualified # 🇧🇷 E2.0 flag: Brazil
+1F1E7 1F1F8 ; fully-qualified # 🇧🇸 E2.0 flag: Bahamas
+1F1E7 1F1F9 ; fully-qualified # 🇧🇹 E2.0 flag: Bhutan
+1F1E7 1F1FB ; fully-qualified # 🇧🇻 E2.0 flag: Bouvet Island
+1F1E7 1F1FC ; fully-qualified # 🇧🇼 E2.0 flag: Botswana
+1F1E7 1F1FE ; fully-qualified # 🇧🇾 E2.0 flag: Belarus
+1F1E7 1F1FF ; fully-qualified # 🇧🇿 E2.0 flag: Belize
+1F1E8 1F1E6 ; fully-qualified # 🇨🇦 E2.0 flag: Canada
+1F1E8 1F1E8 ; fully-qualified # 🇨🇨 E2.0 flag: Cocos (Keeling) Islands
+1F1E8 1F1E9 ; fully-qualified # 🇨🇩 E2.0 flag: Congo - Kinshasa
+1F1E8 1F1EB ; fully-qualified # 🇨🇫 E2.0 flag: Central African Republic
+1F1E8 1F1EC ; fully-qualified # 🇨🇬 E2.0 flag: Congo - Brazzaville
+1F1E8 1F1ED ; fully-qualified # 🇨🇭 E2.0 flag: Switzerland
+1F1E8 1F1EE ; fully-qualified # 🇨🇮 E2.0 flag: Côte d’Ivoire
+1F1E8 1F1F0 ; fully-qualified # 🇨🇰 E2.0 flag: Cook Islands
+1F1E8 1F1F1 ; fully-qualified # 🇨🇱 E2.0 flag: Chile
+1F1E8 1F1F2 ; fully-qualified # 🇨🇲 E2.0 flag: Cameroon
+1F1E8 1F1F3 ; fully-qualified # 🇨🇳 E0.6 flag: China
+1F1E8 1F1F4 ; fully-qualified # 🇨🇴 E2.0 flag: Colombia
+1F1E8 1F1F5 ; fully-qualified # 🇨🇵 E2.0 flag: Clipperton Island
+1F1E8 1F1F7 ; fully-qualified # 🇨🇷 E2.0 flag: Costa Rica
+1F1E8 1F1FA ; fully-qualified # 🇨🇺 E2.0 flag: Cuba
+1F1E8 1F1FB ; fully-qualified # 🇨🇻 E2.0 flag: Cape Verde
+1F1E8 1F1FC ; fully-qualified # 🇨🇼 E2.0 flag: Curaçao
+1F1E8 1F1FD ; fully-qualified # 🇨🇽 E2.0 flag: Christmas Island
+1F1E8 1F1FE ; fully-qualified # 🇨🇾 E2.0 flag: Cyprus
+1F1E8 1F1FF ; fully-qualified # 🇨🇿 E2.0 flag: Czechia
+1F1E9 1F1EA ; fully-qualified # 🇩🇪 E0.6 flag: Germany
+1F1E9 1F1EC ; fully-qualified # 🇩🇬 E2.0 flag: Diego Garcia
+1F1E9 1F1EF ; fully-qualified # 🇩🇯 E2.0 flag: Djibouti
+1F1E9 1F1F0 ; fully-qualified # 🇩🇰 E2.0 flag: Denmark
+1F1E9 1F1F2 ; fully-qualified # 🇩🇲 E2.0 flag: Dominica
+1F1E9 1F1F4 ; fully-qualified # 🇩🇴 E2.0 flag: Dominican Republic
+1F1E9 1F1FF ; fully-qualified # 🇩🇿 E2.0 flag: Algeria
+1F1EA 1F1E6 ; fully-qualified # 🇪🇦 E2.0 flag: Ceuta & Melilla
+1F1EA 1F1E8 ; fully-qualified # 🇪🇨 E2.0 flag: Ecuador
+1F1EA 1F1EA ; fully-qualified # 🇪🇪 E2.0 flag: Estonia
+1F1EA 1F1EC ; fully-qualified # 🇪🇬 E2.0 flag: Egypt
+1F1EA 1F1ED ; fully-qualified # 🇪🇭 E2.0 flag: Western Sahara
+1F1EA 1F1F7 ; fully-qualified # 🇪🇷 E2.0 flag: Eritrea
+1F1EA 1F1F8 ; fully-qualified # 🇪🇸 E0.6 flag: Spain
+1F1EA 1F1F9 ; fully-qualified # 🇪🇹 E2.0 flag: Ethiopia
+1F1EA 1F1FA ; fully-qualified # 🇪🇺 E2.0 flag: European Union
+1F1EB 1F1EE ; fully-qualified # 🇫🇮 E2.0 flag: Finland
+1F1EB 1F1EF ; fully-qualified # 🇫🇯 E2.0 flag: Fiji
+1F1EB 1F1F0 ; fully-qualified # 🇫🇰 E2.0 flag: Falkland Islands
+1F1EB 1F1F2 ; fully-qualified # 🇫🇲 E2.0 flag: Micronesia
+1F1EB 1F1F4 ; fully-qualified # 🇫🇴 E2.0 flag: Faroe Islands
+1F1EB 1F1F7 ; fully-qualified # 🇫🇷 E0.6 flag: France
+1F1EC 1F1E6 ; fully-qualified # 🇬🇦 E2.0 flag: Gabon
+1F1EC 1F1E7 ; fully-qualified # 🇬🇧 E0.6 flag: United Kingdom
+1F1EC 1F1E9 ; fully-qualified # 🇬🇩 E2.0 flag: Grenada
+1F1EC 1F1EA ; fully-qualified # 🇬🇪 E2.0 flag: Georgia
+1F1EC 1F1EB ; fully-qualified # 🇬🇫 E2.0 flag: French Guiana
+1F1EC 1F1EC ; fully-qualified # 🇬🇬 E2.0 flag: Guernsey
+1F1EC 1F1ED ; fully-qualified # 🇬🇭 E2.0 flag: Ghana
+1F1EC 1F1EE ; fully-qualified # 🇬🇮 E2.0 flag: Gibraltar
+1F1EC 1F1F1 ; fully-qualified # 🇬🇱 E2.0 flag: Greenland
+1F1EC 1F1F2 ; fully-qualified # 🇬🇲 E2.0 flag: Gambia
+1F1EC 1F1F3 ; fully-qualified # 🇬🇳 E2.0 flag: Guinea
+1F1EC 1F1F5 ; fully-qualified # 🇬🇵 E2.0 flag: Guadeloupe
+1F1EC 1F1F6 ; fully-qualified # 🇬🇶 E2.0 flag: Equatorial Guinea
+1F1EC 1F1F7 ; fully-qualified # 🇬🇷 E2.0 flag: Greece
+1F1EC 1F1F8 ; fully-qualified # 🇬🇸 E2.0 flag: South Georgia & South Sandwich Islands
+1F1EC 1F1F9 ; fully-qualified # 🇬🇹 E2.0 flag: Guatemala
+1F1EC 1F1FA ; fully-qualified # 🇬🇺 E2.0 flag: Guam
+1F1EC 1F1FC ; fully-qualified # 🇬🇼 E2.0 flag: Guinea-Bissau
+1F1EC 1F1FE ; fully-qualified # 🇬🇾 E2.0 flag: Guyana
+1F1ED 1F1F0 ; fully-qualified # 🇭🇰 E2.0 flag: Hong Kong SAR China
+1F1ED 1F1F2 ; fully-qualified # 🇭🇲 E2.0 flag: Heard & McDonald Islands
+1F1ED 1F1F3 ; fully-qualified # 🇭🇳 E2.0 flag: Honduras
+1F1ED 1F1F7 ; fully-qualified # 🇭🇷 E2.0 flag: Croatia
+1F1ED 1F1F9 ; fully-qualified # 🇭🇹 E2.0 flag: Haiti
+1F1ED 1F1FA ; fully-qualified # 🇭🇺 E2.0 flag: Hungary
+1F1EE 1F1E8 ; fully-qualified # 🇮🇨 E2.0 flag: Canary Islands
+1F1EE 1F1E9 ; fully-qualified # 🇮🇩 E2.0 flag: Indonesia
+1F1EE 1F1EA ; fully-qualified # 🇮🇪 E2.0 flag: Ireland
+1F1EE 1F1F1 ; fully-qualified # 🇮🇱 E2.0 flag: Israel
+1F1EE 1F1F2 ; fully-qualified # 🇮🇲 E2.0 flag: Isle of Man
+1F1EE 1F1F3 ; fully-qualified # 🇮🇳 E2.0 flag: India
+1F1EE 1F1F4 ; fully-qualified # 🇮🇴 E2.0 flag: British Indian Ocean Territory
+1F1EE 1F1F6 ; fully-qualified # 🇮🇶 E2.0 flag: Iraq
+1F1EE 1F1F7 ; fully-qualified # 🇮🇷 E2.0 flag: Iran
+1F1EE 1F1F8 ; fully-qualified # 🇮🇸 E2.0 flag: Iceland
+1F1EE 1F1F9 ; fully-qualified # 🇮🇹 E0.6 flag: Italy
+1F1EF 1F1EA ; fully-qualified # 🇯🇪 E2.0 flag: Jersey
+1F1EF 1F1F2 ; fully-qualified # 🇯🇲 E2.0 flag: Jamaica
+1F1EF 1F1F4 ; fully-qualified # 🇯🇴 E2.0 flag: Jordan
+1F1EF 1F1F5 ; fully-qualified # 🇯🇵 E0.6 flag: Japan
+1F1F0 1F1EA ; fully-qualified # 🇰🇪 E2.0 flag: Kenya
+1F1F0 1F1EC ; fully-qualified # 🇰🇬 E2.0 flag: Kyrgyzstan
+1F1F0 1F1ED ; fully-qualified # 🇰🇭 E2.0 flag: Cambodia
+1F1F0 1F1EE ; fully-qualified # 🇰🇮 E2.0 flag: Kiribati
+1F1F0 1F1F2 ; fully-qualified # 🇰🇲 E2.0 flag: Comoros
+1F1F0 1F1F3 ; fully-qualified # 🇰🇳 E2.0 flag: St. Kitts & Nevis
+1F1F0 1F1F5 ; fully-qualified # 🇰🇵 E2.0 flag: North Korea
+1F1F0 1F1F7 ; fully-qualified # 🇰🇷 E0.6 flag: South Korea
+1F1F0 1F1FC ; fully-qualified # 🇰🇼 E2.0 flag: Kuwait
+1F1F0 1F1FE ; fully-qualified # 🇰🇾 E2.0 flag: Cayman Islands
+1F1F0 1F1FF ; fully-qualified # 🇰🇿 E2.0 flag: Kazakhstan
+1F1F1 1F1E6 ; fully-qualified # 🇱🇦 E2.0 flag: Laos
+1F1F1 1F1E7 ; fully-qualified # 🇱🇧 E2.0 flag: Lebanon
+1F1F1 1F1E8 ; fully-qualified # 🇱🇨 E2.0 flag: St. Lucia
+1F1F1 1F1EE ; fully-qualified # 🇱🇮 E2.0 flag: Liechtenstein
+1F1F1 1F1F0 ; fully-qualified # 🇱🇰 E2.0 flag: Sri Lanka
+1F1F1 1F1F7 ; fully-qualified # 🇱🇷 E2.0 flag: Liberia
+1F1F1 1F1F8 ; fully-qualified # 🇱🇸 E2.0 flag: Lesotho
+1F1F1 1F1F9 ; fully-qualified # 🇱🇹 E2.0 flag: Lithuania
+1F1F1 1F1FA ; fully-qualified # 🇱🇺 E2.0 flag: Luxembourg
+1F1F1 1F1FB ; fully-qualified # 🇱🇻 E2.0 flag: Latvia
+1F1F1 1F1FE ; fully-qualified # 🇱🇾 E2.0 flag: Libya
+1F1F2 1F1E6 ; fully-qualified # 🇲🇦 E2.0 flag: Morocco
+1F1F2 1F1E8 ; fully-qualified # 🇲🇨 E2.0 flag: Monaco
+1F1F2 1F1E9 ; fully-qualified # 🇲🇩 E2.0 flag: Moldova
+1F1F2 1F1EA ; fully-qualified # 🇲🇪 E2.0 flag: Montenegro
+1F1F2 1F1EB ; fully-qualified # 🇲🇫 E2.0 flag: St. Martin
+1F1F2 1F1EC ; fully-qualified # 🇲🇬 E2.0 flag: Madagascar
+1F1F2 1F1ED ; fully-qualified # 🇲🇭 E2.0 flag: Marshall Islands
+1F1F2 1F1F0 ; fully-qualified # 🇲🇰 E2.0 flag: North Macedonia
+1F1F2 1F1F1 ; fully-qualified # 🇲🇱 E2.0 flag: Mali
+1F1F2 1F1F2 ; fully-qualified # 🇲🇲 E2.0 flag: Myanmar (Burma)
+1F1F2 1F1F3 ; fully-qualified # 🇲🇳 E2.0 flag: Mongolia
+1F1F2 1F1F4 ; fully-qualified # 🇲🇴 E2.0 flag: Macao SAR China
+1F1F2 1F1F5 ; fully-qualified # 🇲🇵 E2.0 flag: Northern Mariana Islands
+1F1F2 1F1F6 ; fully-qualified # 🇲🇶 E2.0 flag: Martinique
+1F1F2 1F1F7 ; fully-qualified # 🇲🇷 E2.0 flag: Mauritania
+1F1F2 1F1F8 ; fully-qualified # 🇲🇸 E2.0 flag: Montserrat
+1F1F2 1F1F9 ; fully-qualified # 🇲🇹 E2.0 flag: Malta
+1F1F2 1F1FA ; fully-qualified # 🇲🇺 E2.0 flag: Mauritius
+1F1F2 1F1FB ; fully-qualified # 🇲🇻 E2.0 flag: Maldives
+1F1F2 1F1FC ; fully-qualified # 🇲🇼 E2.0 flag: Malawi
+1F1F2 1F1FD ; fully-qualified # 🇲🇽 E2.0 flag: Mexico
+1F1F2 1F1FE ; fully-qualified # 🇲🇾 E2.0 flag: Malaysia
+1F1F2 1F1FF ; fully-qualified # 🇲🇿 E2.0 flag: Mozambique
+1F1F3 1F1E6 ; fully-qualified # 🇳🇦 E2.0 flag: Namibia
+1F1F3 1F1E8 ; fully-qualified # 🇳🇨 E2.0 flag: New Caledonia
+1F1F3 1F1EA ; fully-qualified # 🇳🇪 E2.0 flag: Niger
+1F1F3 1F1EB ; fully-qualified # 🇳🇫 E2.0 flag: Norfolk Island
+1F1F3 1F1EC ; fully-qualified # 🇳🇬 E2.0 flag: Nigeria
+1F1F3 1F1EE ; fully-qualified # 🇳🇮 E2.0 flag: Nicaragua
+1F1F3 1F1F1 ; fully-qualified # 🇳🇱 E2.0 flag: Netherlands
+1F1F3 1F1F4 ; fully-qualified # 🇳🇴 E2.0 flag: Norway
+1F1F3 1F1F5 ; fully-qualified # 🇳🇵 E2.0 flag: Nepal
+1F1F3 1F1F7 ; fully-qualified # 🇳🇷 E2.0 flag: Nauru
+1F1F3 1F1FA ; fully-qualified # 🇳🇺 E2.0 flag: Niue
+1F1F3 1F1FF ; fully-qualified # 🇳🇿 E2.0 flag: New Zealand
+1F1F4 1F1F2 ; fully-qualified # 🇴🇲 E2.0 flag: Oman
+1F1F5 1F1E6 ; fully-qualified # 🇵🇦 E2.0 flag: Panama
+1F1F5 1F1EA ; fully-qualified # 🇵🇪 E2.0 flag: Peru
+1F1F5 1F1EB ; fully-qualified # 🇵🇫 E2.0 flag: French Polynesia
+1F1F5 1F1EC ; fully-qualified # 🇵🇬 E2.0 flag: Papua New Guinea
+1F1F5 1F1ED ; fully-qualified # 🇵🇭 E2.0 flag: Philippines
+1F1F5 1F1F0 ; fully-qualified # 🇵🇰 E2.0 flag: Pakistan
+1F1F5 1F1F1 ; fully-qualified # 🇵🇱 E2.0 flag: Poland
+1F1F5 1F1F2 ; fully-qualified # 🇵🇲 E2.0 flag: St. Pierre & Miquelon
+1F1F5 1F1F3 ; fully-qualified # 🇵🇳 E2.0 flag: Pitcairn Islands
+1F1F5 1F1F7 ; fully-qualified # 🇵🇷 E2.0 flag: Puerto Rico
+1F1F5 1F1F8 ; fully-qualified # 🇵🇸 E2.0 flag: Palestinian Territories
+1F1F5 1F1F9 ; fully-qualified # 🇵🇹 E2.0 flag: Portugal
+1F1F5 1F1FC ; fully-qualified # 🇵🇼 E2.0 flag: Palau
+1F1F5 1F1FE ; fully-qualified # 🇵🇾 E2.0 flag: Paraguay
+1F1F6 1F1E6 ; fully-qualified # 🇶🇦 E2.0 flag: Qatar
+1F1F7 1F1EA ; fully-qualified # 🇷🇪 E2.0 flag: Réunion
+1F1F7 1F1F4 ; fully-qualified # 🇷🇴 E2.0 flag: Romania
+1F1F7 1F1F8 ; fully-qualified # 🇷🇸 E2.0 flag: Serbia
+1F1F7 1F1FA ; fully-qualified # 🇷🇺 E0.6 flag: Russia
+1F1F7 1F1FC ; fully-qualified # 🇷🇼 E2.0 flag: Rwanda
+1F1F8 1F1E6 ; fully-qualified # 🇸🇦 E2.0 flag: Saudi Arabia
+1F1F8 1F1E7 ; fully-qualified # 🇸🇧 E2.0 flag: Solomon Islands
+1F1F8 1F1E8 ; fully-qualified # 🇸🇨 E2.0 flag: Seychelles
+1F1F8 1F1E9 ; fully-qualified # 🇸🇩 E2.0 flag: Sudan
+1F1F8 1F1EA ; fully-qualified # 🇸🇪 E2.0 flag: Sweden
+1F1F8 1F1EC ; fully-qualified # 🇸🇬 E2.0 flag: Singapore
+1F1F8 1F1ED ; fully-qualified # 🇸🇭 E2.0 flag: St. Helena
+1F1F8 1F1EE ; fully-qualified # 🇸🇮 E2.0 flag: Slovenia
+1F1F8 1F1EF ; fully-qualified # 🇸🇯 E2.0 flag: Svalbard & Jan Mayen
+1F1F8 1F1F0 ; fully-qualified # 🇸🇰 E2.0 flag: Slovakia
+1F1F8 1F1F1 ; fully-qualified # 🇸🇱 E2.0 flag: Sierra Leone
+1F1F8 1F1F2 ; fully-qualified # 🇸🇲 E2.0 flag: San Marino
+1F1F8 1F1F3 ; fully-qualified # 🇸🇳 E2.0 flag: Senegal
+1F1F8 1F1F4 ; fully-qualified # 🇸🇴 E2.0 flag: Somalia
+1F1F8 1F1F7 ; fully-qualified # 🇸🇷 E2.0 flag: Suriname
+1F1F8 1F1F8 ; fully-qualified # 🇸🇸 E2.0 flag: South Sudan
+1F1F8 1F1F9 ; fully-qualified # 🇸🇹 E2.0 flag: São Tomé & Príncipe
+1F1F8 1F1FB ; fully-qualified # 🇸🇻 E2.0 flag: El Salvador
+1F1F8 1F1FD ; fully-qualified # 🇸🇽 E2.0 flag: Sint Maarten
+1F1F8 1F1FE ; fully-qualified # 🇸🇾 E2.0 flag: Syria
+1F1F8 1F1FF ; fully-qualified # 🇸🇿 E2.0 flag: Eswatini
+1F1F9 1F1E6 ; fully-qualified # 🇹🇦 E2.0 flag: Tristan da Cunha
+1F1F9 1F1E8 ; fully-qualified # 🇹🇨 E2.0 flag: Turks & Caicos Islands
+1F1F9 1F1E9 ; fully-qualified # 🇹🇩 E2.0 flag: Chad
+1F1F9 1F1EB ; fully-qualified # 🇹🇫 E2.0 flag: French Southern Territories
+1F1F9 1F1EC ; fully-qualified # 🇹🇬 E2.0 flag: Togo
+1F1F9 1F1ED ; fully-qualified # 🇹🇭 E2.0 flag: Thailand
+1F1F9 1F1EF ; fully-qualified # 🇹🇯 E2.0 flag: Tajikistan
+1F1F9 1F1F0 ; fully-qualified # 🇹🇰 E2.0 flag: Tokelau
+1F1F9 1F1F1 ; fully-qualified # 🇹🇱 E2.0 flag: Timor-Leste
+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 1F1F9 ; fully-qualified # 🇹🇹 E2.0 flag: Trinidad & Tobago
+1F1F9 1F1FB ; fully-qualified # 🇹🇻 E2.0 flag: Tuvalu
+1F1F9 1F1FC ; fully-qualified # 🇹🇼 E2.0 flag: Taiwan
+1F1F9 1F1FF ; fully-qualified # 🇹🇿 E2.0 flag: Tanzania
+1F1FA 1F1E6 ; fully-qualified # 🇺🇦 E2.0 flag: Ukraine
+1F1FA 1F1EC ; fully-qualified # 🇺🇬 E2.0 flag: Uganda
+1F1FA 1F1F2 ; fully-qualified # 🇺🇲 E2.0 flag: U.S. Outlying Islands
+1F1FA 1F1F3 ; fully-qualified # 🇺🇳 E4.0 flag: United Nations
+1F1FA 1F1F8 ; fully-qualified # 🇺🇸 E0.6 flag: United States
+1F1FA 1F1FE ; fully-qualified # 🇺🇾 E2.0 flag: Uruguay
+1F1FA 1F1FF ; fully-qualified # 🇺🇿 E2.0 flag: Uzbekistan
+1F1FB 1F1E6 ; fully-qualified # 🇻🇦 E2.0 flag: Vatican City
+1F1FB 1F1E8 ; fully-qualified # 🇻🇨 E2.0 flag: St. Vincent & Grenadines
+1F1FB 1F1EA ; fully-qualified # 🇻🇪 E2.0 flag: Venezuela
+1F1FB 1F1EC ; fully-qualified # 🇻🇬 E2.0 flag: British Virgin Islands
+1F1FB 1F1EE ; fully-qualified # 🇻🇮 E2.0 flag: U.S. Virgin Islands
+1F1FB 1F1F3 ; fully-qualified # 🇻🇳 E2.0 flag: Vietnam
+1F1FB 1F1FA ; fully-qualified # 🇻🇺 E2.0 flag: Vanuatu
+1F1FC 1F1EB ; fully-qualified # 🇼🇫 E2.0 flag: Wallis & Futuna
+1F1FC 1F1F8 ; fully-qualified # 🇼🇸 E2.0 flag: Samoa
+1F1FD 1F1F0 ; fully-qualified # 🇽🇰 E2.0 flag: Kosovo
+1F1FE 1F1EA ; fully-qualified # 🇾🇪 E2.0 flag: Yemen
+1F1FE 1F1F9 ; fully-qualified # 🇾🇹 E2.0 flag: Mayotte
+1F1FF 1F1E6 ; fully-qualified # 🇿🇦 E2.0 flag: South Africa
+1F1FF 1F1F2 ; fully-qualified # 🇿🇲 E2.0 flag: Zambia
+1F1FF 1F1FC ; fully-qualified # 🇿🇼 E2.0 flag: Zimbabwe
+
+# subgroup: subdivision-flag
+1F3F4 E0067 E0062 E0065 E006E E0067 E007F ; fully-qualified # 🏴󠁧󠁢󠁥󠁮󠁧󠁿 E5.0 flag: England
+1F3F4 E0067 E0062 E0073 E0063 E0074 E007F ; fully-qualified # 🏴󠁧󠁢󠁳󠁣󠁴󠁿 E5.0 flag: Scotland
+1F3F4 E0067 E0062 E0077 E006C E0073 E007F ; fully-qualified # 🏴󠁧󠁢󠁷󠁬󠁳󠁿 E5.0 flag: Wales
+
+# Flags subtotal: 275
+# Flags subtotal: 275 w/o modifiers
+
+# Status Counts
+# fully-qualified : 3624
+# minimally-qualified : 817
+# unqualified : 252
+# component : 9
+
+#EOF
diff --git a/admin/unidata/emoji-zwj.awk b/admin/unidata/emoji-zwj.awk
index d4e2944ca34..e704cb45263 100644
--- a/admin/unidata/emoji-zwj.awk
+++ b/admin/unidata/emoji-zwj.awk
@@ -114,7 +114,7 @@ END {
print " (nconc (char-table-range composition-function-table (car elt))"
print " (list (vector (cdr elt)"
print " 0"
- print " 'compose-gstring-for-graphic)))))"
+ print " #'compose-gstring-for-graphic)))))"
print ";; The following two blocks are derived by hand from emoji-sequences.txt"
print ";; FIXME: add support for Emoji_Keycap_Sequence once we learn how to respect FE0F/VS-16"
@@ -126,7 +126,7 @@ END {
print " (nconc (char-table-range composition-function-table '(#x1F1E6 . #x1F1FF))"
print " (list (vector \"[\\U0001F1E6-\\U0001F1FF][\\U0001F1E6-\\U0001F1FF]\""
print " 0"
- print " 'compose-gstring-for-graphic))))"
+ print " #'compose-gstring-for-graphic))))"
print ";; UK Flags"
print "(set-char-table-range composition-function-table"
@@ -134,7 +134,7 @@ END {
print " (nconc (char-table-range composition-function-table #x1F3F4)"
print " (list (vector \"\\U0001F3F4\\U000E0067\\U000E0062\\\\(?:\\U000E0065\\U000E006E\\U000E0067\\\\|\\U000E0073\\U000E0063\\U000E0074\\\\|\\U000E0077\\U000E006C\\U000E0073\\\\)\\U000E007F\""
print " 0"
- print " 'compose-gstring-for-graphic))))"
+ print " #'compose-gstring-for-graphic))))"
printf "\n(provide 'emoji-zwj)"
}
diff --git a/admin/update_autogen b/admin/update_autogen
index 11c4313ae37..99297a9c0dc 100755
--- a/admin/update_autogen
+++ b/admin/update_autogen
@@ -44,7 +44,7 @@ PD=${0%/*}
[ "$PD" = "$0" ] && PD=. # if PATH includes PWD
## This should be the admin directory.
-cd $PD
+cd $PD || exit
cd ../
[ -d admin ] || die "Could not locate admin directory"
@@ -53,7 +53,7 @@ cd ../
usage ()
{
cat 1>&2 <<EOF
-Usage: ${PN} [-f] [-c] [-q] [-A dir] [-I] [-L] [-C] [-- make-flags]
+Usage: ${PN} [-f] [-c] [-q] [-A dir] [-L] [-C] [-- make-flags]
Update some auto-generated files in the Emacs tree.
By default, only does the versioned loaddefs-like files in lisp/.
This requires a build. Passes any non-option args to make (eg -- -j2).
@@ -63,8 +63,6 @@ Options:
commit them (caution).
-q: be quiet; only give error messages, not status messages.
-A: only update autotools files, copying into specified dir.
--H: also update ChangeLog.${changelog_n}
--I: also update info/dir.
-L: also update ldefs-boot.el.
-C: start from a clean state. Slower, but more correct.
EOF
@@ -81,14 +79,10 @@ clean=
autogendir= # was "autogen"
ldefs_flag=1
lboot_flag=
-info_flag=
-changelog_flag=
## Parameters.
ldefs_in=lisp/loaddefs.el
ldefs_out=lisp/ldefs-boot.el
-changelog_n=$(sed -n 's/CHANGELOG_HISTORY_INDEX_MAX *= *//p' Makefile.in)
-changelog_files="ChangeLog.$changelog_n"
sources="configure.ac lib/Makefile.am"
## Files to copy into autogendir.
## Everything:
@@ -108,10 +102,10 @@ done
tempfile=/tmp/$PN.$$
-trap "rm -f $tempfile 2> /dev/null" EXIT
+trap 'rm -f $tempfile 2> /dev/null' EXIT
-while getopts ":hcfqA:HCIL" option ; do
+while getopts ":hcfqA:CL" option ; do
case $option in
(h) usage ;;
@@ -127,10 +121,6 @@ while getopts ":hcfqA:HCIL" option ; do
(C) clean=1 ;;
- (H) changelog_flag=1 ;;
-
- (I) info_flag=1 ;;
-
(L) lboot_flag=1 ;;
(\?) die "Bad option -$OPTARG" ;;
@@ -172,7 +162,7 @@ status ()
echo "Checking input file status..."
## The lisp portion could be more permissive, eg only care about .el files.
-modified=$(status ${autogendir:+$sources} ${ldefs_flag:+lisp} ${info_flag:+doc}) || die
+modified=$(status ${autogendir:+$sources} ${ldefs_flag:+lisp}) || die
[ "$modified" ] && {
echo "Locally modified: $modified"
@@ -235,65 +225,8 @@ commit ()
} # function commit
-## No longer used since info/dir is now generated at install time if needed,
-## and is not in the repository any more.
-info_dir ()
-{
- local basefile=build-aux/dir_top outfile=info/dir
-
- echo "Regenerating info/dir..."
-
- ## Header contains non-printing characters, so this is more
- ## reliable than using echo.
- rm -f $outfile
- cp $basefile $outfile
-
- local topic file dircat dirent
-
- ## FIXME inefficient looping.
- for topic in "Texinfo documentation system" "Emacs" "GNU Emacs Lisp" \
- "Emacs editing modes" "Emacs network features" "Emacs misc features" \
- "Emacs lisp libraries"; do
-
- cat - <<EOF >> $outfile
-
-$topic
-EOF
- ## Bit faster than doc/*/*.texi.
- for file in doc/emacs/emacs.texi doc/lispintro/*.texi \
- doc/lispref/elisp.texi doc/misc/*.texi; do
-
- ## FIXME do not ignore w32 if OS is w32.
- case $file in
- *-xtra.texi|*efaq-w32.texi) continue ;;
- esac
-
- dircat=$(sed -n -e 's/@value{emacsname}/Emacs/' -e 's/^@dircategory //p' $file)
-
- ## TODO warn about unknown topics (check-info in top-level
- ## Makefile does this).
- [ "$dircat" = "$topic" ] || continue
-
- sed -n -e 's/@value{emacsname}/Emacs/' \
- -e 's/@acronym{\([A-Z]*\)}/\1/' \
- -e '/^@direntry/,/^@end direntry/ s/^\([^@]\)/\1/p' \
- $file >> $outfile
-
- done
- done
-
- local modified
-
- modified=$(status $outfile) || die
-
- commit "info/dir" $modified || die "commit error"
-} # function info_dir
-
-
[ "$autogendir" ] && {
- oldpwd=$PWD
-
cp $genfiles $autogendir/
cd $autogendir || die "cd error for $autogendir"
@@ -308,9 +241,6 @@ EOF
} # $autogendir
-[ "$info_flag" ] && info_dir
-
-
[ "$ldefs_flag" ] || exit 0
@@ -385,14 +315,6 @@ modified=$(status $genfiles $ldefs_out $grammar_out) || die
commit "loaddefs" $modified || die "commit error"
-## Less important than the other stuff, so do it last.
-[ ! "$changelog_flag" ] || {
- make change-history-nocommit || die "make change-history error"
- modified=$(status $changelog_files) || die
- commit "ChangeLog" $modified || die "commit error"
-}
-
-
exit 0
### update_autogen ends here
diff --git a/build-aux/config.guess b/build-aux/config.guess
index e81d3ae7c21..1105a749838 100755
--- a/build-aux/config.guess
+++ b/build-aux/config.guess
@@ -4,7 +4,7 @@
# shellcheck disable=SC2006,SC2268 # see below for rationale
-timestamp='2021-06-03'
+timestamp='2021-11-30'
# 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
@@ -437,7 +437,7 @@ case $UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION in
# This test works for both compilers.
if test "$CC_FOR_BUILD" != no_compiler_found; then
if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \
- (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \
+ (CCOPTS="" $CC_FOR_BUILD -m64 -E - 2>/dev/null) | \
grep IS_64BIT_ARCH >/dev/null
then
SUN_ARCH=x86_64
@@ -1522,6 +1522,9 @@ EOF
i*86:rdos:*:*)
GUESS=$UNAME_MACHINE-pc-rdos
;;
+ i*86:Fiwix:*:*)
+ GUESS=$UNAME_MACHINE-pc-fiwix
+ ;;
*:AROS:*:*)
GUESS=$UNAME_MACHINE-unknown-aros
;;
diff --git a/build-aux/config.sub b/build-aux/config.sub
index d74fb6deac9..38f3d037a78 100755
--- a/build-aux/config.sub
+++ b/build-aux/config.sub
@@ -4,7 +4,7 @@
# shellcheck disable=SC2006,SC2268 # see below for rationale
-timestamp='2021-08-14'
+timestamp='2021-10-27'
# 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
@@ -1304,7 +1304,7 @@ esac
if test x$basic_os != x
then
-# First recognize some ad-hoc caes, or perhaps split kernel-os, or else just
+# First recognize some ad-hoc cases, or perhaps split kernel-os, or else just
# set os.
case $basic_os in
gnu/linux*)
@@ -1748,7 +1748,8 @@ case $os in
| skyos* | haiku* | rdos* | toppers* | drops* | es* \
| onefs* | tirtos* | phoenix* | fuchsia* | redox* | bme* \
| midnightbsd* | amdhsa* | unleashed* | emscripten* | wasi* \
- | nsk* | powerunix* | genode* | zvmoe* | qnx* | emx* | zephyr*)
+ | nsk* | powerunix* | genode* | zvmoe* | qnx* | emx* | zephyr* \
+ | fiwix* )
;;
# This one is extra strict with allowed versions
sco3.2v2 | sco3.2v[4-9]* | sco5v6*)
diff --git a/configure.ac b/configure.ac
index 766811b8a8e..d1a433a5022 100644
--- a/configure.ac
+++ b/configure.ac
@@ -23,7 +23,7 @@ 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, 28.0.90, bug-gnu-emacs@gnu.org, , https://www.gnu.org/software/emacs/)
+AC_INIT(GNU Emacs, 29.0.50, bug-gnu-emacs@gnu.org, , https://www.gnu.org/software/emacs/)
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.
@@ -447,6 +447,8 @@ OPTION_DEFAULT_ON([tiff],[don't compile with TIFF image support])
OPTION_DEFAULT_ON([gif],[don't compile with GIF image support])
OPTION_DEFAULT_ON([png],[don't compile with PNG image support])
OPTION_DEFAULT_ON([rsvg],[don't compile with SVG image support])
+OPTION_DEFAULT_ON([webp],[don't compile with WebP image support])
+OPTION_DEFAULT_ON([sqlite3],[don't compile with sqlite3 support])
OPTION_DEFAULT_ON([lcms2],[don't compile with Little CMS support])
OPTION_DEFAULT_ON([libsystemd],[don't compile with libsystemd support])
OPTION_DEFAULT_ON([cairo],[don't compile with Cairo drawing])
@@ -468,6 +470,7 @@ AC_ARG_WITH([ns],[AS_HELP_STRING([--with-ns],
[use Nextstep (macOS Cocoa or GNUstep) windowing system.
On by default on macOS.])],[],[with_ns=maybe])
OPTION_DEFAULT_OFF([w32], [use native MS Windows GUI in a Cygwin build])
+OPTION_DEFAULT_OFF([pgtk], [use pure GTK build without reliance on X libs (Wayland support) (requires cairo) - Experimental])
OPTION_DEFAULT_ON([gpm],[don't use -lgpm for mouse support on a GNU/Linux console])
OPTION_DEFAULT_ON([dbus],[don't compile with D-Bus support])
@@ -486,6 +489,7 @@ OPTION_DEFAULT_ON([modules],[don't compile with dynamic modules support])
OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support])
OPTION_DEFAULT_OFF([native-compilation],[compile with Emacs Lisp native compiler support])
OPTION_DEFAULT_OFF([cygwin32-native-compilation],[use native compilation on 32-bit Cygwin])
+OPTION_DEFAULT_OFF([xinput2],[use version 2 of the X Input Extension for input])
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)])],
@@ -509,6 +513,12 @@ otherwise for the first of 'inotify', 'kqueue' or 'gfile' that is usable.])
OPTION_DEFAULT_OFF([xwidgets],
[enable use of xwidgets in Emacs buffers (requires gtk3 or macOS Cocoa)])
+OPTION_DEFAULT_OFF([be-app],
+ [enable use of Haiku's Application Kit as a window system])
+
+OPTION_DEFAULT_OFF([be-cairo],
+ [enable use of cairo under Haiku's Application Kit])
+
## Makefile.in needs the cache file name.
AC_SUBST(cache_file)
@@ -785,6 +795,10 @@ case "${canonical}" in
LDFLAGS="-N2M $LDFLAGS"
;;
+ *-haiku )
+ opsys=haiku
+ ;;
+
## Intel 386 machines where we don't care about the manufacturer.
i[3456]86-*-* )
case "${canonical}" in
@@ -906,7 +920,9 @@ if test "$ac_test_CFLAGS" != set; then
if test $emacs_cv_prog_cc_g3 != yes; then
CFLAGS=$emacs_save_CFLAGS
fi
- if test $opsys = mingw32; then
+ # Haiku also needs -gdwarf-2 because its GDB is too old
+ # to understand newer formats.
+ if test $opsys = mingw32 || test $opsys = haiku; then
CFLAGS="$CFLAGS -gdwarf-2"
fi
fi
@@ -1182,8 +1198,8 @@ fi)
dnl Automake replacements.
AC_DEFUN([AM_CONDITIONAL],
- [$2 && $1=1 || $1=
- AC_SUBST([$1])])
+ [$2 && $1_CONDITION=1 || $1_CONDITION=
+ AC_SUBST([$1_CONDITION])])
dnl Prefer silent make output. For verbose output, use
dnl 'configure --disable-silent-rules' or 'make V=1' .
@@ -1573,6 +1589,8 @@ case "$opsys" in
## Motif needs -lgen.
unixware) LIBS_SYSTEM="-lsocket -lnsl -lelf -lgen" ;;
+
+ haiku) LIBS_SYSTEM="-lnetwork" ;;
esac
AC_SUBST(LIBS_SYSTEM)
@@ -1823,8 +1841,14 @@ AC_SUBST(AUTO_DEPEND)
## window-system-specific substs.
window_system=none
+
+if test "${with_pgtk}" = "yes"; then
+ window_system=pgtk
+fi
+
+
AC_PATH_X
-if test "$no_x" != yes; then
+if test "$no_x" != yes && test "${with_pgtk}" != "yes"; then
window_system=x11
fi
@@ -2078,6 +2102,22 @@ if test "${HAVE_NS}" = yes; then
fi
fi
+HAVE_BE_APP=no
+if test "${opsys}" = "haiku" && test "${with_be_app}" = "yes"; then
+ dnl Only GCC is supported. Clang might work, but it's
+ dnl not reliable, so don't check for it here.
+ AC_PROG_CXX([gcc g++])
+ CXXFLAGS="$CXXFLAGS $emacs_g3_CFLAGS"
+ AC_LANG_PUSH([C++])
+ AC_CHECK_HEADER([app/Application.h], [HAVE_BE_APP=yes],
+ [AC_MSG_ERROR([The Application Kit headers required for building
+with the Application Kit were not found or cannot be compiled. Either fix this, or
+re-configure with the option '--without-be-app'.])])
+ AC_LANG_POP([C++])
+fi
+
+AC_SUBST(HAVE_BE_APP)
+
HAVE_W32=no
W32_OBJ=
W32_LIBS=
@@ -2199,6 +2239,39 @@ if test "${HAVE_W32}" = "yes"; then
with_xft=no
fi
+HAIKU_OBJ=
+HAIKU_CXX_OBJ=
+HAIKU_LIBS=
+HAIKU_CFLAGS=
+
+if test "$opsys" = "haiku"; then
+ HAIKU_OBJ="$HAIKU_OBJ haiku.o"
+fi
+
+if test "${HAVE_BE_APP}" = "yes"; then
+ AC_DEFINE([HAVE_HAIKU], 1,
+ [Define if Emacs will be built with Haiku windowing support])
+fi
+
+if test "${HAVE_BE_APP}" = "yes"; then
+ window_system=haiku
+ with_xft=no
+ HAIKU_OBJ="$HAIKU_OBJ haikufns.o haikuterm.o haikumenu.o haikufont.o haikuselect.o haiku_io.o"
+ HAIKU_CXX_OBJ="haiku_support.o haiku_font_support.o haiku_draw_support.o haiku_select.o"
+ HAIKU_LIBS="-lbe -lgame -ltranslation -ltracker" # -lgame is needed for set_mouse_position.
+
+ if test "${with_native_image_api}" = yes; then
+ AC_DEFINE(HAVE_NATIVE_IMAGE_API, 1, [Define to use native OS APIs for images.])
+ NATIVE_IMAGE_API="yes (haiku)"
+ HAIKU_OBJ="$HAIKU_OBJ haikuimage.o"
+ fi
+fi
+
+AC_SUBST(HAIKU_LIBS)
+AC_SUBST(HAIKU_OBJ)
+AC_SUBST(HAIKU_CXX_OBJ)
+AC_SUBST(HAIKU_CFLAGS)
+
## $window_system is now set to the window system we will
## ultimately use.
@@ -2238,6 +2311,16 @@ dnl use the toolkit if we have gtk, or X11R5 or newer.
w32 )
term_header=w32term.h
;;
+ pgtk )
+ term_header=pgtkterm.h
+ with_gtk3=yes
+ USE_X_TOOLKIT=none
+ HAVE_PGTK=yes
+ AC_DEFINE([HAVE_PGTK], 1, [Define to 1 if you have pure Gtk+-3.])
+ ;;
+ haiku )
+ term_header=haikuterm.h
+ ;;
esac
if test "$window_system" = none && test "X$with_x" != "Xno"; then
@@ -2569,7 +2652,9 @@ fi
### Use -lrsvg-2 if available, unless '--with-rsvg=no' is specified.
HAVE_RSVG=no
-if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${opsys}" = "mingw32"; then
+if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" \
+ || test "${opsys}" = "mingw32" || test "${HAVE_BE_APP}" = "yes" \
+ || test "${window_system}" = "pgtk"; then
if test "${with_rsvg}" != "no"; then
RSVG_REQUIRED=2.14.0
RSVG_MODULE="librsvg-2.0 >= $RSVG_REQUIRED"
@@ -2589,8 +2674,53 @@ if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${opsys}" =
fi
fi
+### Use -lwebp if available, unless '--with-webp=no'
+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
+ WEBP_REQUIRED=0.6.0
+ WEBP_MODULE="libwebp >= $WEBP_REQUIRED"
+
+ EMACS_CHECK_MODULES([WEBP], [$WEBP_MODULE])
+ AC_SUBST(WEBP_CFLAGS)
+ AC_SUBST(WEBP_LIBS)
+ 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=
+ fi
+ fi
+fi
+
+### Use -lsqlite3 if available, unless '--with-sqlite3=no'
+HAVE_SQLITE3=no
+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=
+ 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
+
HAVE_IMAGEMAGICK=no
-if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${HAVE_W32}" = "yes"; then
+if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${HAVE_W32}" = "yes" || \
+ test "${HAVE_BE_APP}" = "yes" || test "${window_system}" = "pgtk"; then
if test "${with_imagemagick}" != "no"; then
if test -n "$BREW"; then
# Homebrew doesn't link ImageMagick 6 by default, so make sure
@@ -2673,6 +2803,9 @@ if test "${opsys}" != "mingw32"; then
AC_DEFINE([GLIB_DISABLE_DEPRECATION_WARNINGS], [1],
[Define to 1 to disable Glib deprecation warnings.])
fi
+ if test "$window_system" = pgtk; then
+ GLIB_GSETTINGS
+ fi
else
check_gtk2=yes
gtk3_pkg_errors="$GTK_PKG_ERRORS "
@@ -2814,6 +2947,15 @@ AC_SUBST(XWIDGETS_OBJ)
CFLAGS=$OLD_CFLAGS
LIBS=$OLD_LIBS
+PGTK_OBJ=
+PGTK_LIBS=
+if test "$window_system" = "pgtk"; then
+ PGTK_OBJ="pgtkfns.o pgtkterm.o pgtkselect.o pgtkmenu.o pgtkim.o xsettings.o"
+ PGTK_LIBS="$GTK_LIBS"
+fi
+AC_SUBST(PGTK_OBJ)
+AC_SUBST(PGTK_LIBS)
+
dnl D-Bus has been tested under GNU/Linux only. Must be adapted for
dnl other platforms.
HAVE_DBUS=no
@@ -2843,7 +2985,7 @@ AC_SUBST(DBUS_OBJ)
dnl GSettings has been tested under GNU/Linux only.
HAVE_GSETTINGS=no
-if test "${HAVE_X11}" = "yes" && test "${with_gsettings}" = "yes"; then
+if test "${HAVE_X11}" = "yes" -o "${window_system}" = "pgtk" && test "${with_gsettings}" = "yes"; then
EMACS_CHECK_MODULES([GSETTINGS], [gio-2.0 >= 2.26])
if test "$HAVE_GSETTINGS" = "yes"; then
old_CFLAGS=$CFLAGS
@@ -2877,7 +3019,7 @@ fi
dnl GConf has been tested under GNU/Linux only.
dnl The version is really arbitrary, it is about the same age as Gtk+ 2.6.
HAVE_GCONF=no
-if test "${HAVE_X11}" = "yes" && test "${with_gconf}" != "no"; then
+if test "${HAVE_X11}" = "yes" -o "${window_system}" = "pgtk" && test "${with_gconf}" != "no"; then
EMACS_CHECK_MODULES([GCONF], [gconf-2.0 >= 2.13])
if test "$HAVE_GCONF" = yes; then
AC_DEFINE(HAVE_GCONF, 1, [Define to 1 if using GConf.])
@@ -3240,6 +3382,9 @@ if test "${with_toolkit_scroll_bars}" != "no"; then
elif test "${HAVE_W32}" = "yes"; then
AC_DEFINE(USE_TOOLKIT_SCROLL_BARS)
USE_TOOLKIT_SCROLL_BARS=yes
+ elif test "${HAVE_BE_APP}" = "yes"; then
+ AC_DEFINE(USE_TOOLKIT_SCROLL_BARS)
+ USE_TOOLKIT_SCROLL_BARS=yes
fi
fi
@@ -3330,6 +3475,39 @@ if test "${HAVE_X11}" = "yes"; then
fi
fi
+if test "$window_system" = "pgtk"; then
+ CAIRO_REQUIRED=1.12.0
+ CAIRO_MODULE="cairo >= $CAIRO_REQUIRED"
+ EMACS_CHECK_MODULES(CAIRO, $CAIRO_MODULE)
+ if test $HAVE_CAIRO = yes; then
+ AC_DEFINE(USE_CAIRO, 1, [Define to 1 if using cairo.])
+ else
+ AC_MSG_ERROR([cairo required but not found.])
+ fi
+
+ CFLAGS="$CFLAGS $CAIRO_CFLAGS"
+ LIBS="$LIBS $CAIRO_LIBS"
+ AC_SUBST(CAIRO_CFLAGS)
+ AC_SUBST(CAIRO_LIBS)
+fi
+
+if test "${HAVE_BE_APP}" = "yes"; then
+ if test "${with_be_cairo}" != "no"; then
+ CAIRO_REQUIRED=1.8.0
+ CAIRO_MODULE="cairo >= $CAIRO_REQUIRED"
+ EMACS_CHECK_MODULES(CAIRO, $CAIRO_MODULE)
+ if test $HAVE_CAIRO = yes; then
+ AC_DEFINE(USE_BE_CAIRO, 1, [Define to 1 if using cairo on Haiku.])
+ CFLAGS="$CFLAGS $CAIRO_CFLAGS"
+ LIBS="$LIBS $CAIRO_LIBS"
+ AC_SUBST(CAIRO_CFLAGS)
+ AC_SUBST(CAIRO_LIBS)
+ else
+ AC_MSG_WARN([cairo requested but not found.])
+ fi
+ fi
+fi
+
### Start of font-backend (under any platform) section.
# (nothing here yet -- this is a placeholder)
### End of font-backend (under any platform) section.
@@ -3449,10 +3627,34 @@ if test "${HAVE_X11}" = "yes"; then
fi
fi
else # "${HAVE_X11}" != "yes"
- HAVE_XFT=no
- HAVE_FREETYPE=no
- HAVE_LIBOTF=no
- HAVE_M17N_FLT=no
+ if test $window_system = pgtk; then
+ EMACS_CHECK_MODULES([FONTCONFIG], [fontconfig >= 2.2.0])
+ EMACS_CHECK_MODULES([FREETYPE], [freetype2])
+ if test "$HAVE_FONTCONFIG" != yes -o "$HAVE_FREETYPE" != yes; then
+ AC_MSG_ERROR(fontconfig and freetype is required.)
+ fi
+ HAVE_LIBOTF=no
+ AC_DEFINE(HAVE_FREETYPE, 1,
+ [Define to 1 if using the freetype and fontconfig libraries.])
+ if test "${with_libotf}" != "no"; then
+ EMACS_CHECK_MODULES([LIBOTF], [libotf])
+ if test "$HAVE_LIBOTF" = "yes"; then
+ AC_DEFINE(HAVE_LIBOTF, 1, [Define to 1 if using libotf.])
+ AC_CHECK_LIB(otf, OTF_get_variation_glyphs,
+ HAVE_OTF_GET_VARIATION_GLYPHS=yes,
+ HAVE_OTF_GET_VARIATION_GLYPHS=no)
+ if test "${HAVE_OTF_GET_VARIATION_GLYPHS}" = "yes"; then
+ AC_DEFINE(HAVE_OTF_GET_VARIATION_GLYPHS, 1,
+ [Define to 1 if libotf has OTF_get_variation_glyphs.])
+ fi
+ fi
+ fi
+ else
+ HAVE_XFT=no
+ HAVE_FREETYPE=no
+ HAVE_LIBOTF=no
+ HAVE_M17N_FLT=no
+ fi
fi # "${HAVE_X11}" != "yes"
HAVE_HARFBUZZ=no
@@ -3464,6 +3666,7 @@ else
harfbuzz_required_ver=0.9.42
fi
if test "${HAVE_X11}" = "yes" && test "${HAVE_FREETYPE}" = "yes" \
+ || test "$window_system" = "pgtk" \
|| test "${HAVE_W32}" = "yes"; then
if test "${with_harfbuzz}" != "no"; then
EMACS_CHECK_MODULES([HARFBUZZ], [harfbuzz >= $harfbuzz_required_ver])
@@ -3478,6 +3681,58 @@ if test "${HAVE_X11}" = "yes" && test "${HAVE_FREETYPE}" = "yes" \
fi
fi
+### Start of font-backend (under Haiku) selectionn.
+if test "${HAVE_BE_APP}" = "yes"; then
+ if test $HAVE_CAIRO = "yes"; then
+ EMACS_CHECK_MODULES([FREETYPE], [freetype2 >= 2.5.0])
+ test "$HAVE_FREETYPE" = "no" && AC_MSG_ERROR(cairo on Haiku requires libfreetype)
+ EMACS_CHECK_MODULES([FONTCONFIG], [fontconfig >= 2.2.0])
+ test "$HAVE_FONTCONFIG" = "no" && AC_MSG_ERROR(cairo on Haiku requires libfontconfig)
+ fi
+
+ HAVE_LIBOTF=no
+
+ if test "${HAVE_FREETYPE}" = "yes"; then
+ AC_DEFINE(HAVE_FREETYPE, 1,
+ [Define to 1 if using the freetype and fontconfig libraries.])
+ OLD_CFLAGS=$CFLAGS
+ OLD_LIBS=$LIBS
+ CFLAGS="$CFLAGS $FREETYPE_CFLAGS"
+ LIBS="$FREETYPE_LIBS $LIBS"
+ AC_CHECK_FUNCS(FT_Face_GetCharVariantIndex)
+ CFLAGS=$OLD_CFLAGS
+ LIBS=$OLD_LIBS
+ if test "${with_libotf}" != "no"; then
+ EMACS_CHECK_MODULES([LIBOTF], [libotf])
+ if test "$HAVE_LIBOTF" = "yes"; then
+ AC_DEFINE(HAVE_LIBOTF, 1, [Define to 1 if using libotf.])
+ AC_CHECK_LIB(otf, OTF_get_variation_glyphs,
+ HAVE_OTF_GET_VARIATION_GLYPHS=yes,
+ HAVE_OTF_GET_VARIATION_GLYPHS=no)
+ if test "${HAVE_OTF_GET_VARIATION_GLYPHS}" = "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
+ AC_DEFINE(HAVE_OTF_KANNADA_BUG, 1,
+[Define to 1 if libotf is affected by https://debbugs.gnu.org/28110.])
+ fi
+ fi
+ fi
+ dnl FIXME should there be an error if HAVE_FREETYPE != yes?
+ dnl Does the new font backend require it, or can it work without it?
+ fi
+fi
+
+if test "${HAVE_BE_APP}" = "yes" && test "${HAVE_FREETYPE}" = "yes"; then
+ if test "${with_harfbuzz}" != "no"; then
+ EMACS_CHECK_MODULES([HARFBUZZ], [harfbuzz >= $harfbuzz_required_ver])
+ if test "$HAVE_HARFBUZZ" = "yes"; then
+ AC_DEFINE(HAVE_HARFBUZZ, 1, [Define to 1 if using HarfBuzz.])
+ fi
+ fi
+fi
+
### End of font-backend section.
AC_SUBST(FREETYPE_CFLAGS)
@@ -3599,7 +3854,8 @@ AC_SUBST(LIBXPM)
HAVE_JPEG=no
LIBJPEG=
if test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \
- || test "${HAVE_NS}" = "yes"; then
+ || test "${HAVE_NS}" = "yes" || test "${HAVE_BE_APP}" = "yes" \
+ || test "$window_system" = "pgtk"; then
if test "${with_jpeg}" != "no"; then
AC_CACHE_CHECK([for jpeglib 6b or later],
[emacs_cv_jpeglib],
@@ -3739,10 +3995,12 @@ 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])
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%%.*}"
AC_SUBST(emacs_major_version)
@@ -3915,7 +4173,8 @@ if test "${with_png}" != no; then
if test "$opsys" = mingw32; then
AC_CHECK_HEADER([png.h], [HAVE_PNG=yes])
elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \
- || test "${HAVE_NS}" = "yes"; then
+ || test "${HAVE_NS}" = "yes" || test "${HAVE_BE_APP}" = "yes" \
+ || test "$window_system" = "pgtk"; then
EMACS_CHECK_MODULES([PNG], [libpng >= 1.0.0])
if test $HAVE_PNG = yes; then
LIBPNG=$PNG_LIBS
@@ -3990,7 +4249,8 @@ if test "${opsys}" = "mingw32"; then
AC_DEFINE(HAVE_TIFF, 1, [Define to 1 if you have the tiff library (-ltiff).])
fi
elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \
- || test "${HAVE_NS}" = "yes"; then
+ || test "${HAVE_NS}" = "yes" || test "${HAVE_BE_APP}" = "yes" \
+ || test "$window_system" = "pgtk"; then
if test "${with_tiff}" != "no"; then
AC_CHECK_HEADER(tiffio.h,
[tifflibs="-lz -lm"
@@ -4019,7 +4279,8 @@ if test "${opsys}" = "mingw32"; then
AC_DEFINE(HAVE_GIF, 1, [Define to 1 if you have a gif (or ungif) library.])
fi
elif test "${HAVE_X11}" = "yes" && test "${with_gif}" != "no" \
- || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes"; then
+ || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes" \
+ || test "${HAVE_BE_APP}" = "yes" || test "$window_system" = "pgtk"; then
AC_CHECK_HEADER(gif_lib.h,
# EGifPutExtensionLast only exists from version libungif-4.1.0b1.
# Earlier versions can crash Emacs, but version 5.0 removes EGifPutExtensionLast.
@@ -4212,6 +4473,26 @@ fi
AC_SUBST(XFIXES_CFLAGS)
AC_SUBST(XFIXES_LIBS)
+## Use XInput 2.0 if available
+HAVE_XINPUT2=no
+if test "${HAVE_X11}" = "yes" && test "${with_xinput2}" != "no"; then
+ EMACS_CHECK_MODULES([XINPUT], [xi])
+ if test $HAVE_XINPUT = yes; then
+ # Now check for XInput2.h
+ AC_CHECK_HEADER(X11/extensions/XInput2.h,
+ [AC_CHECK_LIB(Xi, XIGrabButton, HAVE_XINPUT2=yes)])
+ fi
+ if test $HAVE_XINPUT2 = yes; then
+ AC_DEFINE(HAVE_XINPUT2, 1, [Define to 1 if the X Input Extension version 2.0 or later is present.])
+ if test "$USE_GTK_TOOLKIT" = "GTK2"; then
+ AC_MSG_WARN([You are building Emacs with GTK+ 2 and the X Input Extension version 2.
+This might lead to problems if your version of GTK+ is not built with support for XInput 2.])
+ fi
+ fi
+fi
+AC_SUBST(XINPUT_CFLAGS)
+AC_SUBST(XINPUT_LIBS)
+
### Use Xdbe (-lXdbe) if available
HAVE_XDBE=no
if test "${HAVE_X11}" = "yes"; then
@@ -4436,6 +4717,13 @@ case $with_unexec,$canonical in
[AC_MSG_ERROR([Non-ELF systems are not supported on this platform.])]);;
esac
+if test "$with_unexec" = yes && test "$opsys" = "haiku"; then
+ dnl A serious attempt was actually made to port unexec to Haiku.
+ dnl Something in libstdc++ seems to prevent it from working.
+ AC_MSG_ERROR([Haiku is not supported by the legacy unexec dumper.
+Please use the portable dumper instead.])
+fi
+
# Dump loading
AC_CHECK_FUNCS([posix_madvise])
@@ -4789,7 +5077,7 @@ CFLAGS="$OLDCFLAGS"
LIBS="$OLDLIBS"])
if test "${emacs_cv_links_glib}" = "yes"; then
AC_DEFINE(HAVE_GLIB, 1, [Define to 1 if GLib is linked in.])
- if test "$HAVE_NS" = no;then
+ if test "$HAVE_NS" = no ; then
XGSELOBJ=xgselect.o
fi
fi
@@ -5044,7 +5332,7 @@ dnl It would have Emacs fork off a separate process
dnl to read the input and send it to the true Emacs process
dnl through a pipe.
case $opsys in
- darwin | gnu-linux | gnu-kfreebsd )
+ darwin | gnu-linux | gnu-kfreebsd)
AC_DEFINE(INTERRUPT_INPUT, 1, [Define to read input using SIGIO.])
;;
esac
@@ -5140,6 +5428,14 @@ case $opsys in
AC_DEFINE(PTY_OPEN, [fd = open (pty_name, O_RDWR | O_NONBLOCK)])
AC_DEFINE(PTY_TTY_NAME_SPRINTF, [{ char *ptsname (int), *ptyname; int grantpt_result; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); grantpt_result = grantpt (fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (grantpt_result == -1) fatal("could not grant slave pty"); if (unlockpt(fd) == -1) fatal("could not unlock slave pty"); if (!(ptyname = ptsname(fd))) fatal ("could not enable slave pty"); snprintf (pty_name, PTY_NAME_SIZE, "%s", ptyname); }])
;;
+
+ haiku*)
+ AC_DEFINE(FIRST_PTY_LETTER, ['s'])
+ AC_DEFINE(PTY_NAME_SPRINTF, [])
+ dnl on Haiku pty names aren't distinctive, thus the use of posix_openpt
+ AC_DEFINE(PTY_OPEN, [fd = posix_openpt (O_RDWR | O_NONBLOCK)])
+ AC_DEFINE(PTY_TTY_NAME_SPRINTF, [{ char *ptyname; int grantpt_result; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); grantpt_result = grantpt (fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (grantpt_result == -1) fatal("could not grant slave pty"); if (unlockpt(fd) == -1) fatal("could not unlock slave pty"); if (!(ptyname = ptsname(fd))) fatal ("could not enable slave pty"); snprintf (pty_name, PTY_NAME_SIZE, "%s", ptyname); }])
+ ;;
esac
@@ -5224,6 +5520,7 @@ case $opsys in
#if defined __i386__ || defined __sparc__ || defined __mc68000__ \
|| defined __alpha__ || defined __mips__ || defined __s390__ \
|| defined __arm__ || defined __powerpc__ || defined __amd64__ \
+ || defined __x86_64__ \
|| defined __ia64__ || defined __sh__
/* ok */
#else
@@ -5361,8 +5658,25 @@ case $opsys in
AC_DEFINE(USG, [])
AC_DEFINE(USG5_4, [])
;;
+
+ haiku)
+ AC_DEFINE(HAIKU, [], [Define if the system is Haiku.])
+ ;;
esac
+AC_SYS_POSIX_TERMIOS
+if test $ac_cv_sys_posix_termios = yes; then
+ AC_CHECK_SIZEOF([speed_t], [], [#include <termios.h>])
+ dnl on Haiku, and possibly other platforms, speed_t is defined to
+ dnl unsigned char, even when speeds greater than 200 baud are
+ dnl defined.
+
+ if test ${ac_cv_sizeof_speed_t} -lt 2; then
+ AC_DEFINE([HAVE_TINY_SPEED_T], [1],
+ [Define to 1 if speed_t has some sort of nonsensically tiny size.])
+ fi
+fi
+
AC_CACHE_CHECK([for usable FIONREAD], [emacs_cv_usable_FIONREAD],
[case $opsys in
aix4-2 | nacl)
@@ -5405,6 +5719,22 @@ if test $emacs_cv_usable_FIONREAD = yes; then
AC_DEFINE([USABLE_SIGIO], [1], [Define to 1 if SIGIO is usable.])
fi
fi
+
+ if test $emacs_broken_SIGIO = no && test $emacs_cv_usable_SIGIO = no; then
+ AC_CACHE_CHECK([for usable SIGPOLL], [emacs_cv_usable_SIGPOLL],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[#include <fcntl.h>
+ #include <signal.h>
+ ]],
+ [[int foo = SIGPOLL | F_SETFL;]])],
+ [emacs_cv_usable_SIGPOLL=yes],
+ [emacs_cv_usable_SIGPOLL=no])],
+ [emacs_cv_usable_SIGPOLL=yes],
+ [emacs_cv_usable_SIGPOLL=no])
+ if test $emacs_cv_usable_SIGPOLL = yes; then
+ AC_DEFINE([USABLE_SIGPOLL], [1], [Define to 1 if SIGPOLL is usable but SIGIO is not.])
+ fi
+ fi
fi
case $opsys in
@@ -5455,6 +5785,7 @@ AC_SUBST(prefix)
AC_SUBST(exec_prefix)
AC_SUBST(bindir)
AC_SUBST(datadir)
+AC_SUBST(gsettingsschemadir)
AC_SUBST(sharedstatedir)
AC_SUBST(libexecdir)
AC_SUBST(mandir)
@@ -5517,6 +5848,17 @@ if test "${HAVE_X_WINDOWS}" = "yes" ; then
FONT_OBJ="$FONT_OBJ ftfont.o"
fi
fi
+
+if test "${window_system}" = "pgtk"; then
+ FONT_OBJ="ftfont.o ftcrfont.o"
+fi
+
+if test "${HAVE_BE_APP}" = "yes" ; then
+ if test "${HAVE_CAIRO}" = "yes"; then
+ FONT_OBJ="$FONT_OBJ ftfont.o ftcrfont.o"
+ fi
+fi
+
if test "${HAVE_HARFBUZZ}" = "yes" ; then
FONT_OBJ="$FONT_OBJ hbfont.o"
fi
@@ -5699,6 +6041,7 @@ CFLAGS=$pre_PKG_CONFIG_CFLAGS
LIBS="$LIB_PTHREAD $pre_PKG_CONFIG_LIBS"
gl_ASSERT_NO_GNULIB_POSIXCHECK
gl_ASSERT_NO_GNULIB_TESTS
+gl_EEMALLOC
gl_INIT
CFLAGS=$SAVE_CFLAGS
LIBS=$SAVE_LIBS
@@ -5904,11 +6247,11 @@ Configured for '${canonical}'.
#### Please respect alphabetical ordering when making additions.
optsep=
emacs_config_features=
-for opt in ACL CAIRO DBUS FREETYPE GCONF GIF GLIB GMP GNUTLS GPM GSETTINGS \
+for opt in ACL BE_APP CAIRO DBUS FREETYPE GCONF GIF GLIB GMP GNUTLS GPM GSETTINGS \
HARFBUZZ IMAGEMAGICK JPEG JSON LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 \
- M17N_FLT MODULES NATIVE_COMP NOTIFY NS OLDXMENU PDUMPER PNG RSVG SECCOMP \
- SOUND THREADS TIFF \
- TOOLKIT_SCROLL_BARS UNEXEC X11 XAW3D XDBE XFT XIM XPM XWIDGETS X_TOOLKIT \
+ M17N_FLT MODULES NATIVE_COMP NOTIFY NS OLDXMENU PDUMPER PGTK PNG RSVG SECCOMP \
+ SOUND SQLITE3 THREADS TIFF TOOLKIT_SCROLL_BARS \
+ UNEXEC WEBP X11 XAW3D XDBE XFT XIM XINPUT2 XPM XWIDGETS X_TOOLKIT \
ZLIB; do
case $opt in
@@ -5953,6 +6296,8 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D
Does Emacs use a gif library? ${HAVE_GIF} $LIBGIF
Does Emacs use a png library? ${HAVE_PNG} $LIBPNG
Does Emacs use -lrsvg-2? ${HAVE_RSVG}
+ Does Emacs use -lwebp? ${HAVE_WEBP}
+ Does Emacs use -lsqlite3? ${HAVE_SQLITE3}
Does Emacs use cairo? ${HAVE_CAIRO}
Does Emacs use -llcms2? ${HAVE_LCMS2}
Does Emacs use imagemagick? ${HAVE_IMAGEMAGICK}
@@ -5984,6 +6329,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D
Does Emacs support legacy unexec dumping? ${with_unexec}
Which dumping strategy does Emacs use? ${with_dumping}
Does Emacs have native lisp compiler? ${HAVE_NATIVE_COMP}
+ Does Emacs use version 2 of the the X Input Extension? ${HAVE_XINPUT2}
"])
if test -n "${EMACSDATA}"; then
@@ -6060,6 +6406,13 @@ if test -f "$srcdir/$opt_makefile.in"; then
dnl ", [], [opt_makefile='$opt_makefile']" and it should work.
AC_CONFIG_FILES([test/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])
+fi
dnl The admin/ directory used to be excluded from tarfiles.
diff --git a/doc/emacs/Makefile.in b/doc/emacs/Makefile.in
index 69d39efa8b9..dde3ae83c16 100644
--- a/doc/emacs/Makefile.in
+++ b/doc/emacs/Makefile.in
@@ -140,6 +140,7 @@ EMACSSOURCES= \
${srcdir}/xresources.texi \
${srcdir}/anti.texi \
${srcdir}/macos.texi \
+ $(srcdir)/haiku.texi \
${srcdir}/msdos.texi \
${srcdir}/gnu.texi \
${srcdir}/glossary.texi \
diff --git a/doc/emacs/abbrevs.texi b/doc/emacs/abbrevs.texi
index c83da8aaec6..972416ff1cd 100644
--- a/doc/emacs/abbrevs.texi
+++ b/doc/emacs/abbrevs.texi
@@ -274,7 +274,7 @@ Edit a list of abbrevs; you can add, alter or remove definitions.
@example
@var{various other tables@dots{}}
(lisp-mode-abbrev-table)
-"dk" 0 "define-key"
+"ks" 0 "keymap-set"
(global-abbrev-table)
"dfn" 0 "definition"
@end example
diff --git a/doc/emacs/cmdargs.texi b/doc/emacs/cmdargs.texi
index 687a5caf712..b1e471f6d63 100644
--- a/doc/emacs/cmdargs.texi
+++ b/doc/emacs/cmdargs.texi
@@ -185,6 +185,11 @@ successfully.
@item --version
@opindex --version
Print Emacs version, then exit successfully.
+
+@item --fingerprint
+@opindex --fingerprint
+Print the Emacs ``fingerprint'', which is used to uniquely identify
+the compiled version of Emacs.
@end table
@node Initial Options
@@ -751,6 +756,10 @@ On MS-Windows, if you set this variable, Emacs will load and initialize
the network library at startup, instead of waiting until the first
time it is required.
+@item WAYLAND_DISPLAY
+Pgtk Emacs (built with @option{--with-pgtk}) can run on Wayland natively.
+@env{WAYLAND_DISPLAY} specifies the connection to the compositor.
+
@item emacs_dir
On MS-Windows, @env{emacs_dir} is a special environment variable, which
indicates the full path of the directory in which Emacs is installed.
diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi
index a3d8a779b8b..c4c43f2713a 100644
--- a/doc/emacs/custom.texi
+++ b/doc/emacs/custom.texi
@@ -195,7 +195,7 @@ the customization buffer:
The first line shows that the variable is named
@code{kill-ring-max}, formatted as @samp{Kill Ring Max} for easier
-viewing. Its value is @samp{60}. The button labeled @samp{[Hide]},
+viewing. Its value is @samp{120}. The button labeled @samp{[Hide]},
if activated, hides the variable's value and state; this is useful to
avoid cluttering up the customization buffer with very long values
(for this reason, variables that have very long values may start out
@@ -1474,9 +1474,10 @@ as Dired buffers (@pxref{Dired}).
Most of the variables reflect the situation on the local machine.
Often, they must use a different value when you operate in buffers
-with a remote default directory. Think about the shell to be applied
-when calling @code{shell} -- it might be @file{/bin/bash} on your
-local machine, and @file{/bin/ksh} on a remote machine.
+with a remote default directory. Think about the behavior when
+calling @code{shell} -- on your local machine, you might use
+@file{/bin/bash} and rely on termcap, but on a remote machine, it may
+be @file{/bin/ksh} and terminfo.
This can be accomplished with @dfn{connection-local variables}.
Directory and file local variables override connection-local
@@ -1492,6 +1493,10 @@ variables/value pairs in a @dfn{profile}, using the
criteria, identifying a remote machine:
@example
+(connection-local-set-profile-variables 'remote-terminfo
+ '((system-uses-terminfo . t)
+ (comint-terminfo-terminal . "dumb-emacs-ansi")))
+
(connection-local-set-profile-variables 'remote-ksh
'((shell-file-name . "/bin/ksh")
(shell-command-switch . "-c")))
@@ -1501,11 +1506,13 @@ criteria, identifying a remote machine:
(shell-command-switch . "-c")))
(connection-local-set-profiles
- '(:application tramp :machine "remotemachine") 'remote-ksh)
+ '(:application tramp :machine "remotemachine")
+ 'remote-terminfo 'remote-ksh)
@end example
- This code declares two different profiles, @code{remote-ksh} and
-@code{remote-bash}. The profile @code{remote-ksh} is applied to all
+ This code declares three different profiles, @code{remote-terminfo},
+@code{remote-ksh}, and @code{remote-bash}. The profiles
+@code{remote-terminfo} and @code{remote-ksh} are applied to all
buffers which have a remote default directory matching the regexp
@code{"remotemachine"} as host name. Such a criteria can also
discriminate for the properties @code{:protocol} (this is the Tramp
@@ -1577,7 +1584,7 @@ which overrides the global definitions of some keys.
self-inserting because the global keymap binds it to the command
@code{self-insert-command}. The standard Emacs editing characters
such as @kbd{C-a} also get their standard meanings from the global
-keymap. Commands to rebind keys, such as @kbd{M-x global-set-key},
+keymap. Commands to rebind keys, such as @kbd{M-x keymap-global-set},
work by storing the new binding in the proper place in the global map
(@pxref{Rebinding}). To view the current key bindings, use the
@kbd{C-h b} command.
@@ -1727,8 +1734,8 @@ them, it may be convenient to disable completion on those keys by
putting this in your init file:
@lisp
-(define-key minibuffer-local-completion-map " " 'self-insert-command)
-(define-key minibuffer-local-completion-map "?" 'self-insert-command)
+(keymap-set minibuffer-local-completion-map "SPC" 'self-insert-command)
+(keymap-set minibuffer-local-completion-map "?" 'self-insert-command)
@end lisp
@node Rebinding
@@ -1747,19 +1754,19 @@ local keymap, which affects all buffers using the same major mode.
Emacs session. @xref{Init Rebinding}, for a description of how to
make key rebindings affect future Emacs sessions.
-@findex global-set-key
-@findex local-set-key
-@findex global-unset-key
-@findex local-unset-key
+@findex keymap-global-set
+@findex keymap-local-set
+@findex keymap-global-unset
+@findex keymap-local-unset
@table @kbd
-@item M-x global-set-key @key{RET} @var{key} @var{cmd} @key{RET}
+@item M-x keymap-global-set @key{RET} @var{key} @var{cmd} @key{RET}
Define @var{key} globally to run @var{cmd}.
-@item M-x local-set-key @key{RET} @var{key} @var{cmd} @key{RET}
+@item M-x keymap-local-set @key{RET} @var{key} @var{cmd} @key{RET}
Define @var{key} locally (in the major mode now in effect) to run
@var{cmd}.
-@item M-x global-unset-key @key{RET} @var{key}
+@item M-x keymap-global-unset @key{RET} @var{key}
Make @var{key} undefined in the global map.
-@item M-x local-unset-key @key{RET} @var{key}
+@item M-x keymap-local-unset @key{RET} @var{key}
Make @var{key} undefined locally (in the major mode now in effect).
@end table
@@ -1768,11 +1775,11 @@ command (@pxref{Interactive Shell}), replacing the normal global
definition of @kbd{C-z}:
@example
-M-x global-set-key @key{RET} C-z shell @key{RET}
+M-x keymap-global-set @key{RET} C-z shell @key{RET}
@end example
@noindent
-The @code{global-set-key} command reads the command name after the
+The @code{keymap-global-set} command reads the command name after the
key. After you press the key, a message like this appears so that you
can confirm that you are binding the key you want:
@@ -1793,7 +1800,7 @@ reads another character; if that is @kbd{4}, another prefix character,
it reads one more character, and so on. For example,
@example
-M-x global-set-key @key{RET} C-x 4 $ spell-other-window @key{RET}
+M-x keymap-global-set @key{RET} C-x 4 $ spell-other-window @key{RET}
@end example
@noindent
@@ -1801,8 +1808,8 @@ redefines @kbd{C-x 4 $} to run the (fictitious) command
@code{spell-other-window}.
You can remove the global definition of a key with
-@code{global-unset-key}. This makes the key @dfn{undefined}; if you
-type it, Emacs will just beep. Similarly, @code{local-unset-key} makes
+@code{keymap-global-unset}. This makes the key @dfn{undefined}; if you
+type it, Emacs will just beep. Similarly, @code{keymap-local-unset} makes
a key undefined in the current major mode keymap, which makes the global
definition (or lack of one) come back into effect in that major mode.
@@ -1835,11 +1842,11 @@ you can specify them in your initialization file by writing Lisp code.
simplest is to use the @code{kbd} function, which converts a textual
representation of a key sequence---similar to how we have written key
sequences in this manual---into a form that can be passed as an
-argument to @code{global-set-key}. For example, here's how to bind
+argument to @code{keymap-global-set}. For example, here's how to bind
@kbd{C-z} to the @code{shell} command (@pxref{Interactive Shell}):
@example
-(global-set-key (kbd "C-z") 'shell)
+(keymap-global-set "C-z" 'shell)
@end example
@noindent
@@ -1852,69 +1859,24 @@ causes an error; it certainly isn't what you want.
and mouse events:
@example
-(global-set-key (kbd "C-c y") 'clipboard-yank)
-(global-set-key (kbd "C-M-q") 'query-replace)
-(global-set-key (kbd "<f5>") 'flyspell-mode)
-(global-set-key (kbd "C-<f5>") 'display-line-numbers-mode)
-(global-set-key (kbd "C-<right>") 'forward-sentence)
-(global-set-key (kbd "<mouse-2>") 'mouse-save-then-kill)
-@end example
-
- Instead of using @code{kbd}, you can use a Lisp string or vector to
-specify the key sequence. Using a string is simpler, but only works
-for @acronym{ASCII} characters and Meta-modified @acronym{ASCII}
-characters. For example, here's how to bind @kbd{C-x M-l} to
-@code{make-symbolic-link} (@pxref{Copying and Naming}):
-
-@example
-(global-set-key "\C-x\M-l" 'make-symbolic-link)
-@end example
-
- To bind a key sequence including @key{TAB}, @key{RET}, @key{ESC}, or
-@key{DEL}, the string should contain the Emacs Lisp escape sequence
-@samp{\t}, @samp{\r}, @samp{\e}, or @samp{\d} respectively. Here is
-an example which binds @kbd{C-x @key{TAB}} to @code{indent-rigidly}
-(@pxref{Indentation}):
-
-@example
-(global-set-key "\C-x\t" 'indent-rigidly)
-@end example
-
- When the key sequence includes function keys or mouse button events,
-or non-@acronym{ASCII} characters such as @code{C-=} or @code{H-a},
-you can use a vector to specify the key sequence. Each element in the
-vector stands for an input event; the elements are separated by spaces
-and surrounded by a pair of square brackets. If a vector element is a
-character, write it as a Lisp character constant: @samp{?} followed by
-the character as it would appear in a string. Function keys are
-represented by symbols (@pxref{Function Keys}); simply write the
-symbol's name, with no other delimiters or punctuation. Here are some
-examples:
-
-@example
-(global-set-key [?\C-=] 'make-symbolic-link)
-(global-set-key [?\M-\C-=] 'make-symbolic-link)
-(global-set-key [?\H-a] 'make-symbolic-link)
-(global-set-key [f7] 'make-symbolic-link)
-(global-set-key [C-mouse-1] 'make-symbolic-link)
-@end example
-
-@noindent
-You can use a vector for the simple cases too:
-
-@example
-(global-set-key [?\C-z ?\M-l] 'make-symbolic-link)
+(keymap-global-set "C-c y" 'clipboard-yank)
+(keymap-global-set "C-M-q" 'query-replace)
+(keymap-global-set "<f5>" 'flyspell-mode)
+(keymap-global-set "C-<f5>" 'display-line-numbers-mode)
+(keymap-global-set "C-<right>" 'forward-sentence)
+(keymap-global-set "<mouse-2>" 'mouse-save-then-kill)
@end example
Language and coding systems may cause problems with key bindings for
non-@acronym{ASCII} characters. @xref{Init Non-ASCII}.
-@findex define-key
+@findex keymap-set
+@findex keymap-unset
As described in @ref{Local Keymaps}, major modes and minor modes can
define local keymaps. These keymaps are constructed when the mode is
-loaded for the first time in a session. The function @code{define-key}
-can be used to make changes in a specific keymap. This function can
-also unset keys, when passed @code{nil} as the binding.
+loaded for the first time in a session. The function @code{keymap-set}
+can be used to make changes in a specific keymap. To remove a key
+binding, use @code{keymap-unset}.
Since a mode's keymaps are not constructed until it has been loaded,
you must delay running code which modifies them, e.g., by putting it
@@ -1926,11 +1888,11 @@ the one for @kbd{C-c C-x x} in Texinfo mode:
@example
(add-hook 'texinfo-mode-hook
(lambda ()
- (define-key texinfo-mode-map "\C-cp"
+ (keymap-set texinfo-mode-map "C-c p"
'backward-paragraph)
- (define-key texinfo-mode-map "\C-cn"
+ (keymap-set texinfo-mode-map "C-c n"
'forward-paragraph)))
- (define-key texinfo-mode-map "\C-c\C-xx" nil)
+ (keymap-set texinfo-mode-map "C-c C-x x" nil)
@end example
@node Modifier Keys
@@ -1952,7 +1914,7 @@ between those keystrokes. However, you can bind shifted @key{Control}
alphabetical keystrokes in GUI frames:
@lisp
-(global-set-key (kbd "C-S-n") #'previous-line)
+(keymap-global-set "C-S-n" #'previous-line)
@end lisp
For all other modifiers, you can make the modified alphabetical
@@ -2106,7 +2068,7 @@ button, @code{mouse-2} for the next, and so on. Here is how you can
redefine the second mouse button to split the current window:
@example
-(global-set-key [mouse-2] 'split-window-below)
+(keymap-global-set "<mouse-2>" 'split-window-below)
@end example
The symbols for drag events are similar, but have the prefix
@@ -2189,7 +2151,7 @@ Thus, here is how to define the command for clicking the first button in
a mode line to run @code{scroll-up-command}:
@example
-(global-set-key [mode-line mouse-1] 'scroll-up-command)
+(keymap-global-set "<mode-line> <mouse-1>" 'scroll-up-command)
@end example
Here is the complete list of these dummy prefix keys and their
@@ -2580,13 +2542,13 @@ Rebind the key @kbd{C-x l} to run the function @code{make-symbolic-link}
(@pxref{Init Rebinding}).
@example
-(global-set-key "\C-xl" 'make-symbolic-link)
+(keymap-global-set "C-x l" 'make-symbolic-link)
@end example
or
@example
-(define-key global-map "\C-xl" 'make-symbolic-link)
+(keymap-set global-map "C-x l" 'make-symbolic-link)
@end example
Note once again the single-quote used to refer to the symbol
@@ -2596,24 +2558,23 @@ Note once again the single-quote used to refer to the symbol
Do the same thing for Lisp mode only.
@example
-(define-key lisp-mode-map "\C-xl" 'make-symbolic-link)
+(keymap-set lisp-mode-map "C-x l" 'make-symbolic-link)
@end example
@item
Redefine all keys which now run @code{next-line} in Fundamental mode
so that they run @code{forward-line} instead.
-@findex substitute-key-definition
+@findex keymap-substitute
@example
-(substitute-key-definition 'next-line 'forward-line
- global-map)
+(keymap-substitute global-map 'next-line 'forward-line)
@end example
@item
Make @kbd{C-x C-v} undefined.
@example
-(global-unset-key "\C-x\C-v")
+(keymap-global-unset "C-x C-v")
@end example
One reason to undefine a key is so that you can make it a prefix.
@@ -2789,18 +2750,6 @@ strings incorrectly. You should then avoid adding Emacs Lisp code
that modifies the coding system in other ways, such as calls to
@code{set-language-environment}.
- To bind non-@acronym{ASCII} keys, you must use a vector (@pxref{Init
-Rebinding}). The string syntax cannot be used, since the
-non-@acronym{ASCII} characters will be interpreted as meta keys. For
-instance:
-
-@example
-(global-set-key [?@var{char}] 'some-function)
-@end example
-
-@noindent
-Type @kbd{C-q}, followed by the key you want to bind, to insert @var{char}.
-
@node Early Init File
@subsection The Early Init File
@cindex early init file
diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi
index 9cdd4b805e6..48cf5630eea 100644
--- a/doc/emacs/dired.texi
+++ b/doc/emacs/dired.texi
@@ -742,6 +742,15 @@ never creates such missing directories; the value @code{always},
means Dired automatically creates them; the value @code{ask}
means Dired asks you for confirmation before creating them.
+@vindex dired-create-destination-dirs-on-trailing-dirsep
+If the option @code{dired-create-destination-dirs-on-trailing-dirsep}
+is non-@code{nil} in addition to @code{dired-create-destination-dirs},
+a trailing directory separator at the destination directory is treated
+specially. In that case, when copying to @samp{test/} and no
+directory @samp{test} exists already, it will be created and the
+specified source files or directories are copied into the newly
+created directory.
+
@vindex dired-copy-preserve-time
If @code{dired-copy-preserve-time} is non-@code{nil}, then copying
with this command preserves the modification time of the old file in
@@ -784,6 +793,14 @@ which to move the files (this is like the shell command @command{mv}).
The option @code{dired-create-destination-dirs} controls whether Dired
should create non-existent directories in @var{new}.
+The option @code{dired-create-destination-dirs-on-trailing-dirsep},
+when set in addition to @code{dired-create-destination-dirs}, controls
+wether a trailing directory separator at the destination is treated
+specially. In that case, when renaming a directory @samp{old} to
+@samp{new/} and no directory @samp{new} exists already, it will be
+created and @samp{old} is moved into the newly created directory.
+Otherwise, @samp{old} is renamed to @samp{new}.
+
Dired automatically changes the visited file name of buffers associated
with renamed files so that they refer to the new names.
@@ -1509,14 +1526,12 @@ image-dired}. This prompts for a directory; specify one that has
image files. This creates thumbnails for all the images in that
directory, and displays them all in the thumbnail buffer. The
thumbnails are generated in the background and are loaded as they
-become available. This command asks for confirmation if the number of
-image files exceeds @code{image-dired-show-all-from-dir-max-files}.
+become available.
With point in the thumbnail buffer, you can type @key{RET}
-(@code{image-dired-display-thumbnail-original-image}) to display a
-sized version of it in another window. This sizes the image to fit
-the window. Use the arrow keys to move around in the buffer. For
-easy browsing, use @key{SPC}
+(@code{image-dired-display-thumbnail-original-image}) to display the
+image in another window. Use the arrow keys to move around in the
+thumbnail buffer. For easy browsing, use @key{SPC}
(@code{image-dired-display-next-thumbnail-original}) to advance and
display the next image. Typing @key{DEL}
(@code{image-dired-display-previous-thumbnail-original}) backs up to
@@ -1569,6 +1584,14 @@ rotation is lossless, and uses an external utility called
@node Misc Dired Features
@section Other Dired Features
+@vindex dired-free-space
+ By default, Dired will display the available space on the disk in
+the first line. This is the @code{first} value of the
+@code{dired-free-space} variable. If you set this to
+@code{separate} instead, Dired will display this on a separate line
+(including the space the files in the current directory takes). If
+you set this to @code{nil}, the free space isn't displayed at all.
+
@kindex + @r{(Dired)}
@findex dired-create-directory
The command @kbd{+} (@code{dired-create-directory}) reads a
diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi
index 7ea754612ee..15cad88d596 100644
--- a/doc/emacs/display.texi
+++ b/doc/emacs/display.texi
@@ -642,24 +642,41 @@ apply them to specific text when you want the effects they produce.
@item default
This face is used for ordinary text that doesn't specify any face.
Its background color is used as the frame's background color.
+
@item bold
This face uses a bold variant of the default font.
+
@item italic
This face uses an italic variant of the default font.
+
@item bold-italic
This face uses a bold italic variant of the default font.
+
@item underline
This face underlines text.
+
@item fixed-pitch
This face forces use of a fixed-width font. It's reasonable to
customize this face to use a different fixed-width font, if you like,
but you should not make it a variable-width font.
+
@item fixed-pitch-serif
This face is like @code{fixed-pitch}, except the font has serifs and
looks more like traditional typewriting.
+
@cindex @code{variable-pitch} face
@item variable-pitch
-This face forces use of a variable-width font.
+This face forces use of a variable-width (i.e., proportional) font.
+The font size picked for this face matches the font picked for the
+default (usually fixed-width) font.
+
+@item variable-pitch-text
+This is like the @code{variable-pitch} face (from which it inherits),
+but is slightly larger. A proportional font of the same height as a
+monospace font usually appears visually smaller, and can therefore be
+harder to read. When displaying longer texts, this face can be a good
+choice over the (slightly smaller) @code{variable-pitch} face.
+
@cindex @code{shadow} face
@item shadow
This face is used for making the text less noticeable than the surrounding
@@ -716,46 +733,62 @@ frame:
@table @code
@item mode-line
@cindex @code{mode-line} face
-@cindex faces for mode lines
-This face is used for the mode line of the currently selected window,
+This is the base face used for the mode lines, as well as header lines
and for menu bars when toolkit menus are not used. By default, it's
drawn with shadows for a raised effect on graphical displays, and
drawn as the inverse of the default face on non-windowed terminals.
+
+The @code{mode-line-active} and @code{mode-line-inactive} faces (which
+are the ones used on the mode lines) inherit from this face.
+
+@item mode-line-active
+@cindex faces for mode lines
+Like @code{mode-line}, but used for the mode line of the currently
+selected window. This face inherits from @code{mode-line}, so changes
+in that face affect mode lines in all windows.
+
@item mode-line-inactive
@cindex @code{mode-line-inactive} face
Like @code{mode-line}, but used for mode lines of the windows other
than the selected one (if @code{mode-line-in-non-selected-windows} is
non-@code{nil}). This face inherits from @code{mode-line}, so changes
in that face affect mode lines in all windows.
+
@item mode-line-highlight
@cindex @code{mode-line-highlight} face
Like @code{highlight}, but used for mouse-sensitive portions of text
on mode lines. Such portions of text typically pop up tooltips
(@pxref{Tooltips}) when the mouse pointer hovers above them.
+
@item mode-line-buffer-id
@cindex @code{mode-line-buffer-id} face
This face is used for buffer identification parts in the mode line.
+
@item header-line
@cindex @code{header-line} face
Similar to @code{mode-line} for a window's header line, which appears
at the top of a window just as the mode line appears at the bottom.
Most windows do not have a header line---only some special modes, such
Info mode, create one.
+
@item header-line-highlight
@cindex @code{header-line-highlight} face
Similar to @code{highlight} and @code{mode-line-highlight}, but used
for mouse-sensitive portions of text on header lines. This is a
separate face because the @code{header-line} face might be customized
in a way that does not interact well with @code{highlight}.
+
@item tab-line
@cindex @code{tab-line} face
Similar to @code{mode-line} for a window's tab line, which appears
at the top of a window with tabs representing window buffers.
@xref{Tab Line}.
+
@item vertical-border
@cindex @code{vertical-border} face
This face is used for the vertical divider between windows on text
terminals.
+
@item minibuffer-prompt
@cindex @code{minibuffer-prompt} face
@vindex minibuffer-prompt-properties
@@ -765,19 +798,23 @@ By default, Emacs automatically adds this face to the value of
properties (@pxref{Text Properties,,, elisp, the Emacs Lisp Reference
Manual}) used to display the prompt text. (This variable takes effect
when you enter the minibuffer.)
+
@item fringe
@cindex @code{fringe} face
The face for the fringes to the left and right of windows on graphic
displays. (The fringes are the narrow portions of the Emacs frame
between the text area and the window's right and left borders.)
@xref{Fringes}.
+
@item cursor
The @code{:background} attribute of this face specifies the color of
the text cursor. @xref{Cursor Display}.
+
@item tooltip
This face is used for tooltip text. By default, if Emacs is built
with GTK+ support, tooltips are drawn via GTK+ and this face has no
effect. @xref{Tooltips}.
+
@item mouse
This face determines the color of the mouse pointer.
@end table
@@ -1653,6 +1690,12 @@ characters more prominent on display. @xref{Glyphless Chars,,
Glyphless Character Display, elisp, The Emacs Lisp Reference Manual},
for details.
+@findex glyphless-display-mode
+ The @code{glyphless-display-mode} minor mode can be used to toggle
+the display of glyphless characters in the current buffer. The
+glyphless characters will be displayed as boxes with acronyms of their
+names inside.
+
@cindex curly quotes, and terminal capabilities
@cindex curved quotes, and terminal capabilities
@cindex @code{homoglyph} face
diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi
index 83847fb8f12..dff42c7b42c 100644
--- a/doc/emacs/emacs.texi
+++ b/doc/emacs/emacs.texi
@@ -221,6 +221,7 @@ Appendices
* X Resources:: X resources for customizing Emacs.
* Antinews:: Information about Emacs version 27.
* Mac OS / GNUstep:: Using Emacs under macOS and GNUstep.
+* Haiku:: Using Emacs on Haiku.
* Microsoft Windows:: Using Emacs on Microsoft Windows and MS-DOS.
* Manifesto:: What's GNU? Gnu's Not Unix!
@@ -344,14 +345,14 @@ Cut and Paste Operations on Graphical Displays
Registers
-* Position Registers:: Saving positions in registers.
-* Text Registers:: Saving text in registers.
-* Rectangle Registers:: Saving rectangles in registers.
-* Configuration Registers:: Saving window configurations in registers.
-* Number Registers:: Numbers in registers.
-* File Registers:: File names in registers.
-* Keyboard Macro Registers:: Keyboard macros in registers.
-* Bookmarks:: Bookmarks are like registers, but persistent.
+* Position Registers:: Saving positions in registers.
+* Text Registers:: Saving text in registers.
+* Rectangle Registers:: Saving rectangles in registers.
+* Configuration Registers:: Saving window configurations in registers.
+* Number Registers:: Numbers in registers.
+* File and Buffer Registers:: File and buffer names in registers.
+* Keyboard Macro Registers:: Keyboard macros in registers.
+* Bookmarks:: Bookmarks are like registers, but persistent.
Controlling the Display
@@ -1249,6 +1250,11 @@ Emacs and macOS / GNUstep
* Mac / GNUstep Events:: How window system events are handled.
* GNUstep Support:: Details on status of GNUstep support.
+Emacs and Haiku
+
+* Haiku Basics:: Basic Emacs usage and installation under Haiku.
+* Haiku Fonts:: The various options for displaying fonts on Haiku.
+
Emacs and Microsoft Windows/MS-DOS
* Windows Startup:: How to start Emacs on Windows.
@@ -1618,6 +1624,7 @@ Lisp programming.
@include anti.texi
@include macos.texi
+@include haiku.texi
@c Includes msdos-xtra.
@include msdos.texi
@include gnu.texi
diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi
index 65a57ccd31b..b7016b00575 100644
--- a/doc/emacs/files.texi
+++ b/doc/emacs/files.texi
@@ -1476,8 +1476,8 @@ characters that don't match. Then the command exits.
If point in the two windows is followed by non-matching text when
the command starts, @kbd{M-x compare-windows} tries heuristically to
advance up to matching text in the two windows, and then exits. So if
-you use @kbd{M-x compare-windows} repeatedly, each time it either
-skips one matching range or finds the start of another.
+you use @kbd{M-x compare-windows} repeatedly (@pxref{Repeating}), each
+time it either skips one matching range or finds the start of another.
@vindex compare-ignore-case
@vindex compare-ignore-whitespace
@@ -2205,11 +2205,11 @@ window, so this is only necessary if you customize the default
behavior by using the options @code{image-auto-resize} and
@code{image-auto-resize-on-window-resize}.
-@findex image-transform-fit-both
+@findex image-transform-fit-to-window
@findex image-transform-set-scale
@findex image-transform-reset
To resize the image manually you can use the command
-@code{image-transform-fit-both} bound to @kbd{s b}
+@code{image-transform-fit-to-window} bound to @kbd{s w}
that fits the image to both the window height and width.
To scale the image specifying a scale factor, use the command
@code{image-transform-set-scale} bound to @kbd{s s}.
diff --git a/doc/emacs/haiku.texi b/doc/emacs/haiku.texi
new file mode 100644
index 00000000000..d2b7eb8408f
--- /dev/null
+++ b/doc/emacs/haiku.texi
@@ -0,0 +1,124 @@
+@c This is part of the Emacs manual.
+@c Copyright (C) 2021 Free Software Foundation, Inc.
+@c See file emacs.texi for copying conditions.
+@node Haiku
+@appendix Emacs and Haiku
+@cindex Haiku
+
+ 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.
+
+@menu
+* Haiku Basics:: Basic Emacs usage and installation under Haiku.
+* Haiku Fonts:: The various options for displaying fonts on Haiku.
+@end menu
+
+@node Haiku Basics
+@section Installation and usage peculiarities under Haiku
+@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.
+
+@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.
+
+@cindex modifier key customization (Haiku)
+@table @code
+@vindex haiku-meta-keysym
+@item haiku-meta-keysym
+The system modifier key that will be treated as the Meta key by Emacs.
+It defaults to @code{command}.
+
+@vindex haiku-control-keysym
+@item haiku-control-keysym
+The system modifier key that will be treated as the Control key by
+Emacs. It defaults to @code{control}.
+
+@vindex haiku-super-keysym
+@item haiku-super-keysym
+The system modifier key that will be treated as the Super key by
+Emacs. It defaults to @code{option}.
+
+@vindex haiku-shift-keysym
+@item haiku-shift-keysym
+The system modifier key that will be treated as the Shift key by
+Emacs. It defaults to @code{shift}.
+@end table
+
+The value of each variable can be one of the symbols @code{command},
+@code{control}, @code{option}, @code{shift}, or @code{nil}.
+@code{nil} or any other value will cause the default value to be used
+instead.
+
+@cindex tooltips (haiku)
+@cindex haiku tooltips
+@vindex haiku-use-system-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{haiku-use-system-tooltips} to
+the nil value, and Emacs will use its own implementation of tooltips.
+
+ Both system tooltips and Emacs's own tooltips cannot display above
+the menu bar, so help text in the menu bar will display in the echo
+area instead.
+
+@subsection What to do when Emacs crashes
+@cindex crashes, Haiku
+@cindex haiku debugger
+@vindex haiku-debug-on-fatal-error
+ If the variable @code{haiku-debug-on-fatal-error} is non-nil, Emacs
+will launch the system debugger when a fatal signal is received. It
+defaults to @code{t}. If GDB cannot be used on your system, please
+attach the report generated by the system debugger when reporting a
+bug.
+
+@node Haiku Fonts
+@section Font and font backend selection on 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.
+
+ 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.
diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi
index 7d6c3085cb6..20a9d8be13b 100644
--- a/doc/emacs/help.texi
+++ b/doc/emacs/help.texi
@@ -461,15 +461,18 @@ Move point back to the previous hyperlink (@code{backward-button}).
@item mouse-1
@itemx mouse-2
Follow a hyperlink that you click on.
+@item n
+@itemx p
+Move forward and back between pages in the Help buffer.
@item C-c C-c
Show all documentation about the symbol at point
(@code{help-follow-symbol}).
@item C-c C-f
@itemx r
-Go forward to the next help topic (@code{help-go-forward}).
+Go forward in history of help commands (@code{help-go-forward}).
@item C-c C-b
@itemx l
-Go back to the previous help topic (@code{help-go-back}).
+Go back in history of help commands (@code{help-go-back}).
@item s
View the source of the current help topic (if any)
(@code{help-view-source}).
@@ -498,6 +501,30 @@ C-b} or @kbd{l} (@code{help-go-back}). While retracing your steps,
you can go forward by using @kbd{C-c C-f} or @kbd{r}
(@code{help-go-forward}).
+@kindex TAB @r{(Help mode)}
+@findex forward-button
+@kindex S-TAB @r{(Help mode)}
+@findex backward-button
+ To move between hyperlinks in a help buffer, use @key{TAB}
+(@code{forward-button}) to move forward to the next hyperlink and
+@kbd{S-@key{TAB}} (@code{backward-button}) to move back to the
+previous hyperlink. These commands act cyclically; for instance,
+typing @key{TAB} at the last hyperlink moves back to the first
+hyperlink.
+
+@kindex n @r{(Help mode)}
+@kindex p @r{(Help mode)}
+@findex help-goto-next-page
+@findex help-goto-previous-page
+ Help buffers produced by some Help commands (like @kbd{C-h b}, which
+shows a long list of key bindings) are divided into pages by the
+@samp{^L} character. In such buffers, the @kbd{n}
+(@code{help-goto-next-page}) command will take you to the next start
+of page, and the @kbd{p} (@code{help-goto-previous-page}) command will
+take you to the previous start of page. This way you can quickly
+navigate between the different kinds of documentation in a help
+buffer.
+
@cindex URL, viewing in help
@cindex help, viewing web pages
@cindex viewing web pages in help
@@ -507,16 +534,6 @@ code definitions, and URLs (web pages). The first two are opened in
Emacs, and the third using a web browser via the @code{browse-url}
command (@pxref{Browse-URL}).
-@kindex TAB @r{(Help mode)}
-@findex forward-button
-@kindex S-TAB @r{(Help mode)}
-@findex backward-button
- In a help buffer, @key{TAB} (@code{forward-button}) moves point
-forward to the next hyperlink, while @kbd{S-@key{TAB}}
-(@code{backward-button}) moves point back to the previous hyperlink.
-These commands act cyclically; for instance, typing @key{TAB} at the
-last hyperlink moves back to the first hyperlink.
-
To view all documentation about any symbol in the text, move point
to the symbol and type @kbd{C-c C-c} (@code{help-follow-symbol}).
This shows the documentation for all the meanings of the symbol---as a
diff --git a/doc/emacs/killing.texi b/doc/emacs/killing.texi
index 6e4fd77e8b9..375ac970d78 100644
--- a/doc/emacs/killing.texi
+++ b/doc/emacs/killing.texi
@@ -353,7 +353,7 @@ other ways to move text around.)
@vindex kill-ring-max
The maximum number of entries in the kill ring is controlled by the
-variable @code{kill-ring-max}. The default is 60. If you make a new
+variable @code{kill-ring-max}. The default is 120. If you make a new
kill when this limit has been reached, Emacs makes room by deleting
the oldest entry in the kill ring.
@@ -562,6 +562,14 @@ new yank to the clipboard.
To prevent kill and yank commands from accessing the clipboard,
change the variable @code{select-enable-clipboard} to @code{nil}.
+@findex yank-media
+ Programs can put other things than plain text on the clipboard. For
+instance, a web browser will usually let you choose ``Copy Image'' on
+images, and this image will be put on the clipboard. On capable
+platforms, Emacs can yank these objects with the @code{yank-media}
+command---but only in modes that have support for it (@pxref{Yanking
+Media,,, elisp, The Emacs Lisp Reference Manual}).
+
@cindex clipboard manager
@vindex x-select-enable-clipboard-manager
Many X desktop environments support a feature called the
diff --git a/doc/emacs/kmacro.texi b/doc/emacs/kmacro.texi
index 78964bb903f..e0533f049ea 100644
--- a/doc/emacs/kmacro.texi
+++ b/doc/emacs/kmacro.texi
@@ -439,7 +439,7 @@ name to execute the last keyboard macro, in its current form. (If you
later add to the definition of this macro, that does not alter the
name's definition as a macro.) The macro name is a Lisp symbol, and
defining it in this way makes it a valid command name for calling with
-@kbd{M-x} or for binding a key to with @code{global-set-key}
+@kbd{M-x} or for binding a key to with @code{keymap-global-set}
(@pxref{Keymaps}). If you specify a name that has a prior definition
other than a keyboard macro, an error message is shown and nothing is
changed.
diff --git a/doc/emacs/m-x.texi b/doc/emacs/m-x.texi
index d35a8351541..7b9b40388c2 100644
--- a/doc/emacs/m-x.texi
+++ b/doc/emacs/m-x.texi
@@ -45,10 +45,11 @@ from running the command by name.
@cindex obsolete command
When @kbd{M-x} completes on commands, it ignores the commands that
-are declared @dfn{obsolete}; for these, you will have to type their
-full name. (Obsolete commands are those for which newer, better
-alternatives exist, and which are slated for removal in some future
-Emacs release.)
+were declared @dfn{obsolete} in any previous major version of Emacs;
+for these, you will have to type their full name. Commands that were
+marked obsolete in the current version of Emacs are listed. (Obsolete
+commands are those for which newer, better alternatives exist, and
+which are slated for removal in some future Emacs release.)
@vindex read-extended-command-predicate
In addition, @kbd{M-x} completion can exclude commands that are not
diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi
index 05e5a5d5ec3..ebd72fa2a00 100644
--- a/doc/emacs/maintaining.texi
+++ b/doc/emacs/maintaining.texi
@@ -2139,7 +2139,10 @@ Find definition of identifier, and display it in a new frame
Find definition of identifier at mouse click.
@item M-,
Go back to where you previously invoked @kbd{M-.} and friends
-(@code{xref-pop-marker-stack}).
+(@code{xref-go-back}).
+@item C-M-,
+Go forward to where you previously invoked @kbd{M-,}
+(@code{xref-go-forward}).
@item M-x xref-etags-mode
Switch @code{xref} to use the @code{etags} backend.
@end table
@@ -2204,15 +2207,17 @@ selects the window showing the first candidate. The default value is
buffer, but doesn't select any of them.
@kindex M-,
-@findex xref-pop-marker-stack
-@vindex xref-marker-ring-length
+@findex xref-go-back
To go back to places @emph{from where} you've displayed the definition,
-use @kbd{M-,} (@code{xref-pop-marker-stack}). It jumps back to the
+use @kbd{M-,} (@code{xref-go-back}). It jumps back to the
point of the last invocation of @kbd{M-.}. Thus you can find and
examine the definition of something with @kbd{M-.} and then return to
-where you were with @kbd{M-,}. @kbd{M-,} allows you to retrace your
-steps to a depth determined by the variable
-@code{xref-marker-ring-length}, which defaults to 16.
+where you were with @kbd{M-,}.
+
+@kindex C-M-,
+@findex xref-go-forward
+ Go forward to a place from where you previously went back using @kbd{M-,}.
+This is useful if you find that you went back too far.
@findex xref-etags-mode
Some major modes install @code{xref} support facilities that might
diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi
index 5123a716dcb..1f2c852fac1 100644
--- a/doc/emacs/misc.texi
+++ b/doc/emacs/misc.texi
@@ -1497,14 +1497,20 @@ directory stack if they are not already on it
underlying shell, of course.
@vindex comint-terminfo-terminal
+@vindex system-uses-terminfo
@vindex TERM@r{, environment variable, in sub-shell}
Comint mode sets the @env{TERM} environment variable to a safe default
value, but this value disables some useful features. For example,
color is disabled in applications that use @env{TERM} to determine if
color is supported. Therefore, Emacs provides an option
-@code{comint-terminfo-terminal}, which you can set to a terminal that
-is present in your system's terminfo database, in order to take
-advantage of advanced features of that terminal.
+@code{comint-terminfo-terminal} to let you choose a terminal with more
+advanced features, as defined in your system's terminfo database.
+Emacs will use this option as the value for @env{TERM} so long as
+@code{system-uses-terminfo} is non-nil.
+
+Both @code{comint-terminfo-terminal} and @code{system-uses-terminfo}
+can be declared as connection-local variables to adjust these options
+to match what a remote system expects (@pxref{Connection Variables}).
@node Terminal emulator
@subsection Emacs Terminal Emulator
@@ -1697,6 +1703,11 @@ options. @xref{Initial Options}. When Emacs is started this way, it
calls @code{server-start} after initialization and does not open an
initial frame. It then waits for edit requests from clients.
+@item
+Run the command @code{emacsclient} with the @samp{--alternate-editor=""}
+command-line option. This starts an Emacs daemon only if no Emacs daemon
+is already running.
+
@cindex systemd unit file
@item
If your operating system uses @command{systemd} to manage startup,
@@ -1763,6 +1774,32 @@ you can give each daemon its own server name like this:
emacs --daemon=foo
@end example
+@findex 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.
+
+@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
+stopped.
+@end itemize
+
@findex server-eval-at
If you have defined a server by a unique server name, it is possible
to connect to the server from another Emacs instance and evaluate Lisp
@@ -1986,6 +2023,11 @@ the new frame displays the @file{*scratch*} buffer by default. You
can customize this behavior with the variable @code{initial-buffer-choice}
(@pxref{Entering Emacs}).
+@item -r
+@itemx --reuse-frame
+Create a new graphical client frame if none exists, otherwise use an
+existing Emacs frame.
+
@item -F @var{alist}
@itemx --frame-parameters=@var{alist}
Set the parameters for a newly-created graphical frame
@@ -2942,6 +2984,41 @@ one-key commands for scrolling the widget, changing its size, and
reloading it. Type @w{@kbd{C-h b}} in that buffer to see the key
bindings.
+@findex xwidget-webkit-edit-mode
+@cindex xwidget-webkit-edit-mode
+ By default, typing a self-inserting character inside an xwidget
+webkit buffer will do nothing, or trigger some special action. To
+make those characters and other common editing keys insert themselves
+when pressed, you can enable @code{xwidget-webkit-edit-mode}, which
+redefines them to be passed through to the WebKit xwidget.
+
+You can also enable @code{xwidget-webkit-edit-mode} by typing @kbd{e}
+inside the xwidget webkit buffer.
+
+@findex xwidget-webkit-isearch-mode
+@cindex searching in webkit buffers
+ @code{xwidget-webkit-isearch-mode} is a minor mode that behaves
+similarly to incremental search (@pxref{Incremental Search}), but
+operates on the contents of a WebKit widget instead of the current
+buffer. It is bound to @kbd{C-s} and @kbd{C-r} inside xwidget-webkit
+buffers. When it is invoked by @kbd{C-r}, the initial search will be
+performed in reverse direction.
+
+Typing any self-inserting character will cause the character to be
+inserted into the current search query. Typing @kbd{C-s} will cause
+the WebKit widget to display the next search result, while typing
+@kbd{C-r} will cause it to display the previous one.
+
+To leave incremental search, you can type @kbd{C-g}.
+
+@findex xwidget-webkit-browse-history
+@cindex history of webkit buffers
+ The command @code{xwidget-webkit-browse-history} displays a buffer
+containing a list of pages previously loaded by the current WebKit
+buffer, and lets you navigate to those pages by hitting @kbd{RET}.
+
+It is bound to @kbd{H}.
+
@node Browse-URL
@subsection Following URLs
@cindex World Wide Web
diff --git a/doc/emacs/msdos-xtra.texi b/doc/emacs/msdos-xtra.texi
index fce6ae46f81..114700f08d3 100644
--- a/doc/emacs/msdos-xtra.texi
+++ b/doc/emacs/msdos-xtra.texi
@@ -105,7 +105,7 @@ following line into your @file{_emacs} file:
@smallexample
;; @r{Make the @key{ENTER} key from the numeric keypad act as @kbd{C-j}.}
-(define-key function-key-map [kp-enter] [?\C-j])
+(keymap-set function-key-map "<kp-enter>" "C-j")
@end smallexample
@node MS-DOS Mouse
diff --git a/doc/emacs/msdos.texi b/doc/emacs/msdos.texi
index 0f8f429b3f8..20eaa0bcb6f 100644
--- a/doc/emacs/msdos.texi
+++ b/doc/emacs/msdos.texi
@@ -1181,6 +1181,14 @@ The default is @code{t}, which fits well with the Windows default
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.
+
@ifnottex
@include msdos-xtra.texi
@end ifnottex
diff --git a/doc/emacs/mule.texi b/doc/emacs/mule.texi
index 81aabfb57d5..121d6967309 100644
--- a/doc/emacs/mule.texi
+++ b/doc/emacs/mule.texi
@@ -473,6 +473,10 @@ First, letters are mapped into symbols for particular sounds or tone
marks; then, sequences of these that make up a whole syllable are
mapped into one syllable sign.
+@kindex C-f@r{, when using input methods}
+@kindex C-b@r{, when using input methods}
+@kindex C-n@r{, when using input methods}
+@kindex C-p@r{, when using input methods}
Chinese and Japanese require more complex methods. In Chinese input
methods, first you enter the phonetic spelling of a Chinese word (in
input method @code{chinese-py}, among others), or a sequence of
@@ -498,6 +502,7 @@ alternatives in the row are also numbered; the number appears before
the alternative. Typing a number selects the associated alternative
of the current row and uses it as input.
+@kindex TAB@r{, when using Chinese input methods}
@key{TAB} in these Chinese input methods displays a buffer showing
all the possible characters at once; then clicking @kbd{mouse-2} on
one of them selects that alternative. The keys @kbd{C-f}, @kbd{C-b},
@@ -571,11 +576,37 @@ modes that make buffer text or parts of it read-only, such as
@code{read-only-mode} and @code{image-mode}, even when an input method
is active.
+@kindex C-x 8 @key{RET}
+@cindex insert character by name or code-point
Another facility for typing characters not on your keyboard is by
using @kbd{C-x 8 @key{RET}} (@code{insert-char}) to insert a single
character based on its Unicode name or code-point; see @ref{Inserting
Text}.
+@cindex emoji input
+@cindex inserting Emoji
+@kindex C-x 8 e
+@findex emoji-insert
+@findex emoji-list
+@findex emoji-search
+ There are specialized commands for inserting Emoji, and these can be
+found on the @kbd{C-x 8 e} keymap. @kbd{C-x 8 e e}
+(@code{emoji-insert}) will let you navigate through different Emoji
+categories and then choose one. @kbd{C-x 8 e l} (@code{emoji-list})
+will pop up a new buffer and list all the Emoji; clicking (or using
+@kbd{RET}) on an emoji character will insert it in the current buffer.
+Finally, @kbd{C-x 8 e s} (@code{emoji-search}) will allow you to
+search for Emoji based on their names.
+
+@findex emoji-describe
+ @code{describe-char} displays a lot of information about the
+character/glyphs under point (including emojis). It's sometimes
+useful to get a quick description of the name, and you can use the
+@kbd{C-x 8 e d} (@code{emoji-describe}) command to do that. It's
+meant primarily to help distinguish between different Emoji
+variants (which can look very similar), but it will also tell you
+the names of non-Emoji characters.
+
@node Select Input Method
@section Selecting an Input Method
@@ -1961,3 +1992,16 @@ or right of the current screen position, moving to the next or
previous screen line as appropriate. Note that this might potentially
move point many buffer positions away, depending on the surrounding
bidirectional context.
+
+@cindex bidi formatting control characters
+ Bidirectional text sometimes uses special formatting characters to
+affect the reordering of text for display. The @sc{lrm} and @sc{rlm}
+characters, mentioned above, are two such characters, but there are
+more of them. They are by default displayed as thin space glyphs on
+GUI frames, and as simple spaces on text-mode frames. If you want to
+be aware of these special control characters, so that their effect on
+display does not come as a surprise, you can turn on the
+@code{glyphless-display-mode} (@pxref{Text Display}). This minor mode
+will cause these formatting characters to be displayed as acronyms
+inside a small box, so that they stand out on display, and make their
+effect easier to understand.
diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi
index 51a48df2e27..85ed65a4954 100644
--- a/doc/emacs/programs.texi
+++ b/doc/emacs/programs.texi
@@ -868,6 +868,15 @@ highlighting also when point is in whitespace at the beginning of a
line and there is a paren at the first or last non-whitespace position
on the line, or when point is at the end of a line and there is a
paren at the last non-whitespace position on the line.
+
+@item
+@vindex show-paren-context-when-offscreen
+@code{show-paren-context-when-offscreen}, when non-@code{nil}, shows
+some context in the echo area when point is in a closing delimiter and
+the opening delimiter is offscreen. The context is usually the line
+that contains the opening delimiter, except if the opening delimiter
+is on its own line, in which case the context includes the previous
+nonblank line.
@end itemize
@cindex Electric Pair mode
@@ -1818,7 +1827,7 @@ sure the keymap is loaded before we try to change it.
@example
(defun my-bind-clb ()
- (define-key c-mode-base-map "\C-m"
+ (keymap-set c-mode-base-map "RET"
'c-context-line-break))
(add-hook 'c-initialization-hook 'my-bind-clb)
@end example
diff --git a/doc/emacs/regs.texi b/doc/emacs/regs.texi
index 59fa0ff0a1c..df1eec04c00 100644
--- a/doc/emacs/regs.texi
+++ b/doc/emacs/regs.texi
@@ -47,14 +47,14 @@ are similar in spirit to registers, so they are also documented in
this chapter.
@menu
-* Position Registers:: Saving positions in registers.
-* Text Registers:: Saving text in registers.
-* Rectangle Registers:: Saving rectangles in registers.
-* Configuration Registers:: Saving window configurations in registers.
-* Number Registers:: Numbers in registers.
-* File Registers:: File names in registers.
-* Keyboard Macro Registers:: Keyboard macros in registers.
-* Bookmarks:: Bookmarks are like registers, but persistent.
+* Position Registers:: Saving positions in registers.
+* Text Registers:: Saving text in registers.
+* Rectangle Registers:: Saving rectangles in registers.
+* Configuration Registers:: Saving window configurations in registers.
+* Number Registers:: Numbers in registers.
+* File and Buffer Registers:: File and buffer names in registers.
+* Keyboard Macro Registers:: Keyboard macros in registers.
+* Bookmarks:: Bookmarks are like registers, but persistent.
@end menu
@node Position Registers
@@ -238,9 +238,10 @@ register contents into the buffer. @kbd{C-x r +} with no numeric
argument increments the register value by 1; @kbd{C-x r n} with no
numeric argument stores zero in the register.
-@node File Registers
-@section Keeping File Names in Registers
+@node File and Buffer Registers
+@section Keeping File and Buffer Names in Registers
@cindex saving file name in a register
+@cindex saving buffer name in a register
If you visit certain file names frequently, you can visit them more
conveniently if you put their names in registers. Here's the Lisp code
@@ -265,6 +266,15 @@ puts the file name shown in register @samp{z}.
@var{r}}. (This is the same command used to jump to a position or
restore a frame configuration.)
+ Similarly, if there's certain buffers you visit frequently, you
+can put their names in registers. For instance, if you visit the
+@samp{*Messages*} buffer often, you can use the following snippet to
+put that buffer into the @samp{m} register:
+
+@smallexample
+(set-register ?m '(buffer . "*Messages*"))
+@end smallexample
+
@node Keyboard Macro Registers
@section Keyboard Macro Registers
@cindex saving keyboard macro in a register
diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi
index d711636ecfc..ead0f699bb3 100644
--- a/doc/emacs/text.texi
+++ b/doc/emacs/text.texi
@@ -996,6 +996,13 @@ specific file (@pxref{File Variables}).
major mode's special commands. (The variable
@code{outline-minor-mode-prefix} controls the prefix used.)
+@vindex outline-minor-mode-use-buttons
+ If @code{outline-minor-mode-use-buttons} is non-@code{nil}, Outline
+minor mode will use buttons (at the start of the header lines) in
+addition to ellipsis to show that a section is hidden. Using
+@kbd{RET} (or clicking on the button with a mouse) will toggle
+displaying the section.
+
@vindex outline-minor-mode-cycle
If the @code{outline-minor-mode-cycle} user option is
non-@code{nil}, the @kbd{TAB} and @kbd{S-@key{TAB}} keys are enabled on the
diff --git a/doc/emacs/xresources.texi b/doc/emacs/xresources.texi
index 00fa6c0aa31..a7bd006df4d 100644
--- a/doc/emacs/xresources.texi
+++ b/doc/emacs/xresources.texi
@@ -395,6 +395,8 @@ Background color.
Foreground color for a selected item.
@item foreground
Foreground color.
+@item disabledForeground
+Foreground color for a disabled menu item.
@ifnottex
@item horizontalSpacing
Horizontal spacing in pixels between items. Default is 3.
@@ -406,6 +408,12 @@ the associated text. Default is 10.
@item shadowThickness
Thickness of shadow lines for 3D buttons, arrows, and other graphical
elements. Default is 1.
+@item borderThickness
+Thickness of the external borders of the menu bars and pop-up menus.
+Default is 1.
+@item cursor
+Name of the cursor to use in the menu bars and pop-up menus. Default
+is @code{"right_ptr"}.
@end ifnottex
@item margin
Margin of the menu bar, in characters. Default is 1.
diff --git a/doc/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi
index bd5decff669..43f1c2ddd54 100644
--- a/doc/lispintro/emacs-lisp-intro.texi
+++ b/doc/lispintro/emacs-lisp-intro.texi
@@ -4896,8 +4896,6 @@ result of this, point is placed at the beginning of the buffer and mark
is set at the end of the buffer. The whole buffer is, therefore, the
region.
-@c FIXME: the definition of append-to-buffer has been changed (in
-@c 2010-03-30).
@node append-to-buffer
@section The Definition of @code{append-to-buffer}
@findex append-to-buffer
@@ -4932,8 +4930,9 @@ buffer to which the text will go, the window it comes from and goes
to, and the region that will be copied.
@need 1250
-Here is the complete text of the function:
+Here is a possible implementation of the function:
+@c GNU Emacs 22
@smallexample
@group
(defun append-to-buffer (buffer start end)
@@ -5000,7 +4999,9 @@ name. (The function can handle either.)
Since the @code{append-to-buffer} function will be used interactively,
the function must have an @code{interactive} expression. (For a
review of @code{interactive}, see @ref{Interactive, , Making a
-Function Interactive}.) The expression reads as follows:
+Function Interactive}.)
+
+The expression reads as follows:
@smallexample
@group
@@ -5029,7 +5030,7 @@ for true.
The first argument to @code{other-buffer}, the exception, is yet
another function, @code{current-buffer}. That is not going to be
-returned. The second argument is the symbol for true, @code{t}. that
+returned. The second argument is the symbol for true, @code{t}. That
tells @code{other-buffer} that it may show visible buffers (except in
this case, it will not show the current buffer, which makes sense).
@@ -5065,33 +5066,6 @@ point and mark. That argument worked fine.)
@node append-to-buffer body
@subsection The Body of @code{append-to-buffer}
-@ignore
-in GNU Emacs 22 in /usr/local/src/emacs/lisp/simple.el
-
-(defun append-to-buffer (buffer start end)
- "Append to specified buffer the text of the region.
-It is inserted into that buffer before its point.
-
-When calling from a program, give three arguments:
-BUFFER (or buffer name), START and END.
-START and END specify the portion of the current buffer to be copied."
- (interactive
- (list (read-buffer "Append to buffer: " (other-buffer (current-buffer) t))
- (region-beginning) (region-end)))
- (let ((oldbuf (current-buffer)))
- (save-excursion
- (let* ((append-to (get-buffer-create buffer))
- (windows (get-buffer-window-list append-to t t))
- point)
- (set-buffer append-to)
- (setq point (point))
- (barf-if-buffer-read-only)
- (insert-buffer-substring oldbuf start end)
- (dolist (window windows)
- (when (= (window-point window) point)
- (set-window-point window (point))))))))
-@end ignore
-
The body of the @code{append-to-buffer} function begins with @code{let}.
As we have seen before (@pxref{let, , @code{let}}), the purpose of a
@@ -5110,7 +5084,7 @@ whole by showing a template for @code{append-to-buffer} with the
"@var{documentation}@dots{}"
(interactive @dots{})
(let ((@var{variable} @var{value}))
- @var{body}@dots{})
+ @var{body}@dots{}))
@end group
@end smallexample
@@ -5230,19 +5204,39 @@ of filling in the slots of a template:
@need 1200
@noindent
+@anchor{let* introduced}
+@findex let*
In this function, the body of the @code{save-excursion} contains only
one expression, the @code{let*} expression. You know about a
-@code{let} function. The @code{let*} function is different. It has a
-@samp{*} in its name. It enables Emacs to set each variable in its
-varlist in sequence, one after another.
+@code{let} function. The @code{let*} function is different. It
+enables Emacs to set each variable in its varlist in sequence, one
+after another; such that variables in the latter part of the varlist
+can make use of the values to which Emacs set variables earlier in the
+varlist.
-Its critical feature is that variables later in the varlist can make
-use of the values to which Emacs set variables earlier in the varlist.
-@xref{fwd-para let, , The @code{let*} expression}.
+Looking at the @code{let*} expression in @code{append-to-buffer}:
-We will skip functions like @code{let*} and focus on two: the
-@code{set-buffer} function and the @code{insert-buffer-substring}
-function.
+@smallexample
+@group
+(let* ((append-to (get-buffer-create buffer))
+ (windows (get-buffer-window-list append-to t t))
+ point)
+ BODY...)
+@end group
+@end smallexample
+
+@noindent
+we see that @code{append-to} is bound to the value returned by the
+@w{@code{(get-buffer-create buffer)}}. On the next line,
+@code{append-to} is used as an argument to
+@code{get-buffer-window-list}; this would not be possible with the
+@code{let} expression. Note that @code{point} is automatically bound
+to @code{nil}, the same way as it would be done in the @code{let}
+statement.
+
+Now let's focus on the functions @code{set-buffer} and
+@code{insert-buffer-substring} in the body of the @code{let*}
+expression.
@need 1250
In the old days, the @code{set-buffer} expression was simply
@@ -5260,27 +5254,8 @@ but now it is
@end smallexample
@noindent
-@code{append-to} is bound to @code{(get-buffer-create buffer)} earlier
-on in the @code{let*} expression. That extra binding would not be
-necessary except for that @code{append-to} is used later in the
-varlist as an argument to @code{get-buffer-window-list}.
-
-@ignore
-in GNU Emacs 22
-
- (let ((oldbuf (current-buffer)))
- (save-excursion
- (let* ((append-to (get-buffer-create buffer))
- (windows (get-buffer-window-list append-to t t))
- point)
- (set-buffer append-to)
- (setq point (point))
- (barf-if-buffer-read-only)
- (insert-buffer-substring oldbuf start end)
- (dolist (window windows)
- (when (= (window-point window) point)
- (set-window-point window (point))))))))
-@end ignore
+This is because @code{append-to} was bound to @code{(get-buffer-create
+buffer)} earlier on in the @code{let*} expression.
The @code{append-to-buffer} function definition inserts text from the
buffer in which you are currently to a named buffer. It happens that
@@ -5377,6 +5352,12 @@ an argument and insert the region into the current buffer.
@item mark-whole-buffer
Mark the whole buffer as a region. Normally bound to @kbd{C-x h}.
+@item let*
+Declare a list of variables and give them an initial value; then
+evaluate the rest of the expressions in the body of @code{let*}. The
+values of the variables can be used to bind ensuing variables in the
+list.
+
@item set-buffer
Switch the attention of Emacs to another buffer, but do not change the
window being displayed. Used when the program rather than a human is
@@ -8772,7 +8753,7 @@ keeps the kill ring from growing too long. It looks like this:
The code checks whether the length of the kill ring is greater than
the maximum permitted length. This is the value of
-@code{kill-ring-max} (which is 60, by default). If the length of the
+@code{kill-ring-max} (which is 120, by default). If the length of the
kill ring is too long, then this code sets the last element of the
kill ring to @code{nil}. It does this by using two functions,
@code{nthcdr} and @code{setcdr}.
@@ -12879,25 +12860,12 @@ familiar part of this function.
@node fwd-para let
@unnumberedsubsec The @code{let*} expression
-The next line of the @code{forward-paragraph} function begins a
-@code{let*} expression. This is different from @code{let}. The
-symbol is @code{let*} not @code{let}.
-
@findex let*
-The @code{let*} special form is like @code{let} except that Emacs sets
-each variable in sequence, one after another, and variables in the
-latter part of the varlist can make use of the values to which Emacs
-set variables in the earlier part of the varlist.
-
-@ignore
-( refappend save-excursion, , code save-excursion in code append-to-buffer .)
-@end ignore
-
-(@ref{append save-excursion, , @code{save-excursion} in @code{append-to-buffer}}.)
-
-In the @code{let*} expression in this function, Emacs binds a total of
-seven variables: @code{opoint}, @code{fill-prefix-regexp},
-@code{parstart}, @code{parsep}, @code{sp-parstart}, @code{start}, and
+The next line of the @code{forward-paragraph} function begins a
+@code{let*} expression (@pxref{let* introduced,,@code{let*}
+introduced}), in which Emacs binds a total of seven variables:
+@code{opoint}, @code{fill-prefix-regexp}, @code{parstart},
+@code{parsep}, @code{sp-parstart}, @code{start}, and
@code{found-start}.
The variable @code{parsep} appears twice, first, to remove instances
diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi
index 35ef61700c2..0a324a642fe 100644
--- a/doc/lispref/commands.texi
+++ b/doc/lispref/commands.texi
@@ -451,11 +451,11 @@ reads and discards the following up-event. You can get access to that
up-event with the @samp{U} code character.
This kind of input is used by commands such as @code{describe-key} and
-@code{global-set-key}.
+@code{keymap-global-set}.
@item K
A key sequence on a form that can be used as input to functions like
-@code{define-key}. This works like @samp{k}, except that it
+@code{keymap-set}. This works like @samp{k}, except that it
suppresses, for the last input event in the key sequence, the
conversions that are normally used (when necessary) to convert an
undefined key into a defined one (@pxref{Key Sequence Input}), so this
@@ -1175,7 +1175,9 @@ intended by Lisp code to be used as an event.
* Button-Down Events:: A button was pushed and not yet released.
* Repeat Events:: Double and triple click (or drag, or down).
* Motion Events:: Just moving the mouse, not pushing a button.
+* Touchscreen Events:: Tapping and moving fingers on a touchscreen.
* Focus Events:: Moving the mouse between frames.
+* Xwidget Events:: Events generated by xwidgets.
* Misc Events:: Other events the system can generate.
* Event Examples:: Examples of the lists for mouse events.
* Classifying Events:: Finding the modifier keys in an event symbol.
@@ -1314,12 +1316,9 @@ actually treated as the meta key, not this.)
It is best to avoid mentioning specific bit numbers in your program.
To test the modifier bits of a character, use the function
@code{event-modifiers} (@pxref{Classifying Events}). When making key
-bindings, you can use the read syntax for characters with modifier bits
-(@samp{\C-}, @samp{\M-}, and so on). For making key bindings with
-@code{define-key}, you can use lists such as @code{(control hyper ?x)} to
-specify the characters (@pxref{Changing Key Bindings}). The function
-@code{event-convert-list} converts such a list into an event type
-(@pxref{Classifying Events}).
+bindings with @code{keymap-set}, you specify these events using
+strings like @samp{C-H-x} instead (for ``control hyper x'')
+(@pxref{Changing Key Bindings}).
@node Function Keys
@subsection Function Keys
@@ -1837,6 +1836,59 @@ small movements. Otherwise, motion events are not generated as long
as the mouse cursor remains pointing to the same glyph in the text.
@end defvar
+@node Touchscreen Events
+@subsection Touchscreen Events
+@cindex touchscreen events
+@cindex support for touchscreens
+
+Some window systems provide support for input devices that react to
+the user's touching the screen and moving fingers while touching the
+screen. These input devices are known as touchscreens, and Emacs
+reports the events they generate as @dfn{touchscreen events}.
+
+Most individual events generated by a touchscreen only have meaning as
+part of a larger sequence of other events: for instance, the simple
+operation of tapping the touchscreen involves the user placing and
+raising a finger on the touchscreen, and swiping the display to
+scroll it involves placing a finger, moving it many times upwards or
+downwards, and then raising the finger.
+
+@cindex touch point, in touchscreen events
+While a simplistic model consisting of one finger is adequate for taps
+and scrolling, more complicated gestures require support for keeping
+track of multiple fingers, where the position of each finger is
+represented by a @dfn{touch point}. For example, a ``pinch to zoom''
+gesture might consist of the user placing two fingers and moving them
+individually in opposite directions, where the distance between the
+positions of their individual points determine the amount by which to
+zoom the display, and the center of an imaginary line between those
+positions determines where to pan the display after zooming.
+
+The low-level touchscreen events described below can be used to
+implement all the touch sequences described above. In those events,
+each point is represented by a cons of an arbitrary number identifying
+the point and a mouse position list (@pxref{Click Events}) specifying
+the position of the finger when the event occurred.
+
+@table @code
+@cindex @code{touchscreen-begin} event
+@item (touchscreen-begin @var{point})
+This event is sent when @var{point} is created by the user pressing a
+finger against the touchscreen.
+
+@cindex @code{touchscreen-update} event
+@item (touchscreen-update @var{points})
+This event is sent when a point on the touchscreen has changed
+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})
+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.
+@end table
+
@node Focus Events
@subsection Focus Events
@cindex focus event
@@ -1873,6 +1925,100 @@ sequence---that is, after a prefix key---then Emacs reorders the events
so that the focus event comes either before or after the multi-event key
sequence, and not within it.
+@node Xwidget Events
+@subsection Xwidget events
+
+Xwidgets (@pxref{Xwidgets}) can send events to update Lisp programs on
+their status. These events are dubbed @code{xwidget-events}, and
+contain various data describing the nature of the change.
+
+@table @code
+@cindex @code{xwidget-event} event
+@item (xwidget-event @var{kind} @var{xwidget} @var{arg})
+This event is sent whenever some kind of update occurs in
+@var{xwidget}. There are several types of updates, identified by
+their @var{kind}.
+
+@cindex xwidget callbacks
+It is a special event (@pxref{Special Events}), which should be
+handled by adding a callback to an xwidget that is called whenever an
+xwidget event for @var{xwidget} is received.
+
+You can add a callback by setting the @code{callback} of an xwidget's
+property list, which should be a function that accepts @var{xwidget}
+and @var{kind} as arguments.
+
+@table @code
+@cindex @code{load-changed} xwidget event
+@item load-changed
+This xwidget event indicates that the @var{xwidget} has reached a
+particular point of the page-loading process. When these events are
+sent, @var{arg} will contain a string that futher describes the status
+of the widget:
+
+@table @samp
+@cindex @samp{load-started} in xwidgets
+@item load-started
+This means the widget has begun a page-loading operation.
+
+@cindex @samp{load-finished} in xwidgets
+@item load-finished
+This means the @var{xwidget} has finished processing whatever
+page-loading operation that it was previously performing.
+
+@cindex @samp{load-redirected} in xwidgets
+@item load-redirected
+This means the @var{xwidget} has encountered and followed a redirect
+during the page-loading operation.
+
+@cindex @samp{load-committed} in xwidgets
+@item load-committed
+This means the @var{xwidget} has committed to a given URL during the
+page-loading operation, i.e.@: the URL is the final URL that will be
+rendered by @var{xwidget} during the current page-loading operation.
+@end table
+
+@cindex @code{download-callback} xwidget events
+@item download-callback
+This event indicates that a download of some kind has been completed.
+@end table
+
+In the above events, there can be arguments after @var{arg}, which
+itself indicates the URL from which the download file was retrieved:
+the first argument after @var{arg} indicates the MIME type of the
+download, as a string, while the second argument contains the full
+file name of the downloaded file.
+
+@table @code
+@cindex @code{download-started} xwidget events
+@item download-started
+This event indicates that a download has been started. In these
+events, @var{arg} contains the URL of the file that is currently being
+downloaded.
+
+@cindex @code{javascript-callback} xwidget events
+@item javascript-callback
+This event contains JavaScript callback data. These events are used
+internally by @code{xwidget-webkit-execute-script}.
+@end table
+
+@cindex @code{xwidget-display-event} event
+@item (xwidget-display-event @var{xwidget} @var{source})
+This event is sent whenever an xwidget requests that another xwidget
+be displayed. @var{xwidget} is the xwidget that should be displayed,
+and @var{source} is the xwidget that asked to display @var{xwidget}.
+
+It is also a special event which should be handled through callbacks.
+You can add such a callback by setting the @code{display-callback} of
+@var{source}'s property list, which should be a function that accepts
+@var{xwidget} and @var{source} as arguments.
+
+@var{xwidget}'s buffer will be set to a temporary buffer. When
+displaying the widget, care should be taken to replace the buffer with
+the buffer in which the xwidget will be displayed, using
+@code{set-xwidget-buffer} (@pxref{Xwidgets}).
+@end table
+
@node Misc Events
@subsection Miscellaneous System Events
@@ -1900,15 +2046,37 @@ This kind of event indicates that the user deiconified @var{frame} using
the window manager. Its standard definition is @code{ignore}; since the
frame has already been made visible, Emacs has no work to do.
+@cindex @code{touch-end} event
+@item (touch-end (@var{position}))
+This kind of event indicates that the user's finger moved off the
+mouse wheel or the touchpad. The @var{position} element is a mouse
+position list (@pxref{Click Events}), specifying the position of the
+mouse cursor when the finger moved off the mouse wheel.
+
@cindex @code{wheel-up} event
@cindex @code{wheel-down} event
-@item (wheel-up @var{position})
-@itemx (wheel-down @var{position})
+@item (wheel-up @var{position} @var{clicks} @var{lines} @var{pixel-delta})
+@itemx (wheel-down @var{position} @var{clicks} @var{lines} @var{pixel-delta})
These kinds of event are generated by moving a mouse wheel. The
@var{position} element is a mouse position list (@pxref{Click
Events}), specifying the position of the mouse cursor when the event
occurred.
+@var{clicks}, if present, is the number of times that the wheel was
+moved in quick succession. @xref{Repeat Events}. @var{lines}, if
+present and not @code{nil}, is the number of screen lines that should
+be scrolled. @var{pixel-delta}, if present, is a cons cell of the
+form @w{@code{(@var{x} . @var{y})}}, where @var{x} and @var{y} are the
+numbers of pixels by which to scroll in each axis, a.k.a.@:
+@dfn{pixelwise deltas}.
+
+@cindex pixel-resolution wheel events
+You can use these @var{x} and @var{y} pixelwise deltas to determine
+how much the mouse wheel has actually moved at pixel resolution. For
+example, the pixelwise deltas could be used to scroll the display at
+pixel resolution, exactly according to the user's turning the mouse
+wheel.
+
@vindex mouse-wheel-up-event
@vindex mouse-wheel-down-event
This kind of event is generated only on some kinds of systems. On some
@@ -1968,7 +2136,7 @@ example:
(interactive)
(message "Caught signal %S" last-input-event))
-(define-key special-event-map [sigusr1] 'sigusr-handler)
+(keymap-set special-event-map "<sigusr1>" 'sigusr-handler)
@end smallexample
To test the signal handler, you can make Emacs send a signal to itself:
@@ -2069,7 +2237,7 @@ bind it to the @code{signal usr1} event sequence:
(defun usr1-handler ()
(interactive)
(message "Got USR1 signal"))
-(global-set-key [signal usr1] 'usr1-handler)
+(keymap-global-set "<signal> <usr1>" 'usr1-handler)
@end smallexample
@node Classifying Events
@@ -2174,21 +2342,6 @@ This function returns non-@code{nil} if @var{object} is a mouse movement
event. @xref{Motion Events}.
@end defun
-@defun event-convert-list list
-This function converts a list of modifier names and a basic event type
-to an event type which specifies all of them. The basic event type
-must be the last element of the list. For example,
-
-@example
-(event-convert-list '(control ?a))
- @result{} 1
-(event-convert-list '(control meta ?a))
- @result{} -134217727
-(event-convert-list '(control super f1))
- @result{} C-s-f1
-@end example
-@end defun
-
@node Accessing Mouse
@subsection Accessing Mouse Events
@cindex mouse events, data in
@@ -2408,25 +2561,14 @@ characters in a string is a complex matter, for reasons of historical
compatibility, and it is not always possible.
We recommend that new programs avoid dealing with these complexities
-by not storing keyboard events in strings. Here is how to do that:
-
-@itemize @bullet
-@item
-Use vectors instead of strings for key sequences, when you plan to use
-them for anything other than as arguments to @code{lookup-key} and
-@code{define-key}. For example, you can use
-@code{read-key-sequence-vector} instead of @code{read-key-sequence}, and
-@code{this-command-keys-vector} instead of @code{this-command-keys}.
+by not storing keyboard events in strings containing control
+characters or the like, but instead store them in the common Emacs
+format as understood by @code{key-valid-p}.
-@item
-Use vectors to write key sequence constants containing meta characters,
-even when passing them directly to @code{define-key}.
-
-@item
-When you have to look at the contents of a key sequence that might be a
-string, use @code{listify-key-sequence} (@pxref{Event Input Misc})
-first, to convert it to a list.
-@end itemize
+ If you read a key sequence with @code{read-key-sequence-vector} (or
+@code{read-key-sequence}), or access a key sequence with
+@code{this-command-keys-vector} (or @code{this-command-keys}), you can
+transform this to the recommended format by using @code{key-description}.
The complexities stem from the modifier bits that keyboard input
characters can include. Aside from the Meta modifier, none of these
@@ -2618,10 +2760,14 @@ returns the key sequence as a vector, never as a string.
@cindex upper case key sequence
@cindex downcasing in @code{lookup-key}
@cindex shift-translation
+@vindex translate-upper-case-key-bindings
If an input character is upper-case (or has the shift modifier) and
has no key binding, but its lower-case equivalent has one, then
-@code{read-key-sequence} converts the character to lower case. Note
-that @code{lookup-key} does not perform case conversion in this way.
+@code{read-key-sequence} converts the character to lower case. (This
+behaviour can be disabled by setting the
+@code{translate-upper-case-key-bindings} user option to @code{nil}.)
+Note that @code{lookup-key} does not perform case conversion in this
+way.
@vindex this-command-keys-shift-translated
When reading input results in such a @dfn{shift-translation}, Emacs
@@ -2934,7 +3080,7 @@ supplied to input methods (@pxref{Input Methods}). Use
if you want to translate characters after input methods operate.
@end defvar
-@defun keyboard-translate from to
+@defun key-translate from to
This function modifies @code{keyboard-translate-table} to translate
character code @var{from} into character code @var{to}. It creates
the keyboard translate table if necessary.
@@ -2945,12 +3091,12 @@ make @kbd{C-x}, @kbd{C-c} and @kbd{C-v} perform the cut, copy and paste
operations:
@example
-(keyboard-translate ?\C-x 'control-x)
-(keyboard-translate ?\C-c 'control-c)
-(keyboard-translate ?\C-v 'control-v)
-(global-set-key [control-x] 'kill-region)
-(global-set-key [control-c] 'kill-ring-save)
-(global-set-key [control-v] 'yank)
+(key-translate "C-x" "<control-x>")
+(key-translate "C-c" "<control-c>")
+(key-translate "C-v" "<control-v>")
+(keymap-global-set "<control-x>" 'kill-region)
+(keymap-global-set "<control-c>" 'kill-ring-save)
+(keymap-global-set "<control-v>" 'yank)
@end example
@noindent
diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 30676f0fb11..06da1025186 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -1283,6 +1283,15 @@ bindings that can then be used inside @var{body}. The variable
bindings are produced by destructuring binding of elements of
@var{pattern} to the values of the corresponding elements of the
evaluated @var{exp}.
+
+Here's a trivial example:
+
+@example
+(pcase-let ((`(,major ,minor)
+ (split-string "image/png" "/")))
+ minor)
+ @result{} "png"
+@end example
@end defmac
@defmac pcase-let* bindings body@dots{}
diff --git a/doc/lispref/customize.texi b/doc/lispref/customize.texi
index b93b8bc015a..00287a7212a 100644
--- a/doc/lispref/customize.texi
+++ b/doc/lispref/customize.texi
@@ -737,7 +737,7 @@ If omitted, @var{key-type} and @var{value-type} default to
The user can add any key matching the specified key type, but you can
give some keys a preferential treatment by specifying them with the
-@code{:options} (see @ref{Variable Definitions}). The specified keys
+@code{:options} (@pxref{Variable Definitions}). The specified keys
will always be shown in the customize buffer (together with a suitable
value), with a checkbox to include or exclude or disable the key/value
pair from the alist. The user will not be able to edit the keys
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index b1fb9f8b956..98a15404f91 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -561,6 +561,26 @@ You can rewrite the previous example with this macro as follows:
@end example
@end defmac
+@defmac with-delayed-message (timeout message) body@dots{}
+Sometimes it's unclear whether an operation will take a long time to
+execute or not, or it can be inconvenient to implement a progress
+reporter. This macro can be used in those situations.
+
+@lisp
+(with-delayed-message (2 (format "Gathering data for %s" entry))
+ (setq data (gather-data entry)))
+@end lisp
+
+In this example, if the body takes more than two seconds to execute,
+the message will be displayed. If it takes a shorter time than that,
+the message won't be displayed. In either case, the body is evaluated
+as normally, and the return value of the final element in the body is
+the return value of the macro.
+
+The @var{message} element is evaluated before @var{body}, and is
+always evaluated, whether the message is displayed or not.
+@end defmac
+
@node Logging Messages
@subsection Logging Messages in @file{*Messages*}
@cindex logging echo-area messages
@@ -1334,6 +1354,11 @@ are not resized. By default, this mode uses @code{fit-window-to-buffer}
(@pxref{Resizing Windows}) for resizing. You can specify a different
function by customizing the options @code{temp-buffer-max-height} and
@code{temp-buffer-max-width} below.
+
+The effect of this option can be overridden by providing a suitable
+@code{window-height}, @code{window-width} or @code{window-size} action
+alist entry for @code{display-buffer} (@pxref{Buffer Display Action
+Alists}).
@end defopt
@defopt temp-buffer-max-height
@@ -1983,7 +2008,8 @@ The return value is an approximation: it only considers the values
returned by @code{char-width} for the constituent characters, always
takes a tab character as taking @code{tab-width} columns, ignores
display properties and fonts, etc. For these reasons, we recommend
-using @code{window-text-pixel-size}, described below, instead.
+using @code{window-text-pixel-size} or @code{string-pixel-width},
+described below, instead.
@end defun
@defun truncate-string-to-width string width &optional start-column padding ellipsis ellipsis-text-property
@@ -2060,7 +2086,7 @@ displayed in a given window. This function is used by
(@pxref{Resizing Windows}) to make a window exactly as large as the text
it contains.
-@defun window-text-pixel-size &optional window from to x-limit y-limit mode-lines
+@defun window-text-pixel-size &optional window from to x-limit y-limit mode-lines ignore-line-at-end
This function returns the size of the text of @var{window}'s buffer in
pixels. @var{window} must be a live window and defaults to the
selected one. The return value is a cons of the maximum pixel-width
@@ -2110,6 +2136,12 @@ line, if present, in the return value. If it is @code{t}, include the
height of all of these lines, if present, in the return value.
@end defun
+The optional argument @var{ignore-line-at-end} controls whether or
+not to count the height of text in @var{to}'s screen line as part of
+the returned pixel-height. This is useful if your Lisp program is
+only interested in the dimensions of text up to and excluding the
+visual beginning of @var{to}'s screen line.
+
@code{window-text-pixel-size} treats the text displayed in a window as a
whole and does not care about the size of individual lines. The
following function does.
@@ -2175,12 +2207,59 @@ though when this function is run from an idle timer with a delay of zero
seconds.
@end defun
+@defun buffer-text-pixel-size &optional buffer-or-name window from to x-limit y-limit
+This is much like @code{window-text-pixel-size}, but can be used when
+the buffer isn't shown in a window. (@code{window-text-pixel-size} is
+faster when it is, so this function shouldn't be used in that case.)
+
+@var{buffer-or-name} must specify a live buffer or the name of a live
+buffer and defaults to the current buffer. @var{window} must be a
+live window and defaults to the selected one; the function will
+compute the text dimensions as if @var{buffer} is displayed in
+@var{window}. The return value is a cons of the maximum pixel-width
+of any text line and the pixel-height of all the text lines of the
+buffer specified by @var{buffer-or-name}.
+
+The optional arguments @var{x-limit} and @var{y-limit} have the same
+meaning as with @code{window-text-pixel-size}.
+@end defun
+
+@defun string-pixel-width string
+This is a convenience function that uses @code{window-text-pixel-size}
+to compute the width of @var{string} (in pixels).
+@end defun
+
@defun line-pixel-height
This function returns the height in pixels of the line at point in the
selected window. The value includes the line spacing of the line
(@pxref{Line Height}).
@end defun
+@cindex grapheme cluster
+@defun string-glyph-split string
+When character compositions are in effect, sequence of characters can
+be composed for display to form @dfn{grapheme clusters}, for example
+to display accented characters, or ligatures, or Emoji, or when
+complex text shaping requires that for some scripts. When that
+happens, characters no longer map in a simple way to display columns,
+and display layout decisions with such strings, such as truncating too
+wide strings, can be a complex job. This function helps in performing
+suvh jobs: it splits up its argument @var{string} into a list of
+substrings, where each substring produces a single grapheme cluster
+that should be displayed as a unit. Lisp programs can then use this
+list to construct visually-valid substrings of @var{string} which will
+look correctly on display, or compute the width of any substring of
+@var{string} by adding the width of its constituents in the returned
+list, etc.
+
+For instance, if you want to display a string without the first glyph,
+you can say:
+
+@example
+(apply #'insert (cdr (string-glyph-split string))))
+@end example
+@end defun
+
When a buffer is displayed with line numbers (@pxref{Display Custom,,,
emacs, The GNU Emacs Manual}), it is sometimes useful to know the
width taken for displaying the line numbers. The following function
@@ -2372,8 +2451,10 @@ value @code{unspecified}. This special value means that the face
doesn't specify that attribute directly. An @code{unspecified}
attribute tells Emacs to refer instead to a parent face (see the
description @code{:inherit} attribute below); or, failing that, to an
-underlying face (@pxref{Displaying Faces}). The @code{default} face
-must specify all attributes.
+underlying face (@pxref{Displaying Faces}). (However,
+@code{unspecified} is not a valid value in @code{defface}.)
+
+ The @code{default} face must specify all attributes.
Some of these attributes are meaningful only on certain kinds of
displays. If your display cannot handle a certain attribute, the
@@ -2709,8 +2790,9 @@ apply to. Here are the possible values of @var{characteristic}:
@item type
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), or @code{tty} (a
-non-graphics-capable display). @xref{Window Systems, window-system}.
+console), @code{w32} (for MS Windows 9X/NT/2K/XP), @code{haiku} (for
+Haiku), @code{pgtk} (for GTK), 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},
@@ -4798,9 +4880,7 @@ window on a minibuffer-less frame.
The @code{display} text property (or overlay property) is used to
insert images into text, and to control other aspects of how text
-displays. The value of the @code{display} property should be a
-display specification, or a list or vector containing several display
-specifications. Display specifications in the same @code{display}
+displays. Display specifications in the same @code{display}
property value generally apply in parallel to the text they cover.
If several sources (overlays and/or a text property) specify values
@@ -4808,6 +4888,50 @@ for the @code{display} property, only one of the values takes effect,
following the rules of @code{get-char-property}. @xref{Examining
Properties}.
+ The value of the @code{display} property should be a display
+specification, or a list or vector containing several display
+specifications.
+
+@defun get-display-property position prop &optional object properties
+This convenience function can be used to get a specific display
+property, no matter whether the @code{display} property is a vector, a
+list or a simple property. This is like @code{get-text-property}
+(@pxref{Examining Properties}), but works on the @code{display}
+property only.
+
+@var{position} is the position in the buffer or string to examine, and
+@var{prop} is the @code{display} property to return. The optional
+@var{object} argument should be either a string or a buffer, and
+defaults to the current buffer. If the optional @var{properties}
+argument is non-@code{nil}, it should be a @code{display} property,
+and in that case, @var{position} and @var{object} are ignored. (This
+can be useful if you've already gotten the @code{display} property
+with @code{get-char-property}, for instance (@pxref{Examining
+Properties}).
+@end defun
+
+@defun add-display-text-property start end prop value &optional object
+Add @code{display} property @var{prop} of @var{value} to the text from
+@var{start} to @var{end}.
+
+If any text in the region has a non-@code{nil} @code{display}
+property, those properties are retained. For instance:
+
+@lisp
+(add-display-text-property 4 8 'height 2.0)
+(add-display-text-property 2 12 'raise 0.5)
+@end lisp
+
+After doing this, the region from 2 to 4 will have the @code{raise}
+@code{display} property, the region from 4 to 8 will have both the
+@code{raise} and @code{height} @code{display} properties, and finally
+the region from 8 to 12 will only have the @code{raise} @code{display}
+property.
+
+If @var{object} is non-@code{nil}, it should be a string or a buffer.
+If @code{nil}, this defaults to the current buffer.
+@end defun
+
@cindex display property, unsafe evaluation
@cindex security, and display specifications
Some of the display specifications allow inclusion of Lisp forms,
@@ -5083,6 +5207,24 @@ text that has the specification. It displays all of these spaces
be an integer or float. Characters other than spaces are not affected
at all; in particular, this has no effect on tab characters.
+@item (min-width (@var{width}))
+This display specification ensures the text that has it takes at least
+@var{width} space on display, by adding a stretch of white space to
+the end of the text if the text is shorter than @var{width}. The text
+is partitioned using the identity of the parameter, which is why the
+parameter is a list with one element. For instance:
+
+@lisp
+(insert (propertize "foo" '(display (min-width (6.0)))))
+@end lisp
+
+This will add padding after @samp{foo} bringing the total width up to
+the width of six normal characters. Note that the affected characters
+are identified by the @code{(6.0)} list in the display property,
+compared with @code{eq}. The element @var{width} can be either an
+integer or a float specifying the required minimum width of the text
+(@pxref{Pixel Specification}).
+
@item (height @var{height})
This display specification makes the text taller or shorter.
Here are the possibilities for @var{height}:
@@ -5283,13 +5425,13 @@ to modify the set of known names for these dynamic libraries.
Supported image formats (and the required support libraries) include
PBM and XBM (which do not depend on support libraries and are always
available), XPM (@code{libXpm}), GIF (@code{libgif} or
-@code{libungif}), JPEG (@code{libjpeg}), TIFF
-(@code{libtiff}), PNG (@code{libpng}), and SVG (@code{librsvg}).
+@code{libungif}), JPEG (@code{libjpeg}), TIFF (@code{libtiff}), PNG
+(@code{libpng}), SVG (@code{librsvg}), and WebP (@code{libwebp}).
Each of these image formats is associated with an @dfn{image type
symbol}. The symbols for the above formats are, respectively,
-@code{pbm}, @code{xbm}, @code{xpm}, @code{gif},
-@code{jpeg}, @code{tiff}, @code{png}, and @code{svg}.
+@code{pbm}, @code{xbm}, @code{xpm}, @code{gif}, @code{jpeg},
+@code{tiff}, @code{png}, @code{svg}, and @code{webp}.
Furthermore, if you build Emacs with ImageMagick
(@code{libMagickWand}) support, Emacs can display any image format
@@ -6293,6 +6435,9 @@ Image type @code{png}.
@item TIFF
Image type @code{tiff}.
Supports the @code{:index} property. @xref{Multi-Frame Images}.
+
+@item WebP
+Image type @code{webp}.
@end table
@node Defining Images
@@ -6444,7 +6589,7 @@ will compute a scaling factor based on the font pixel size.
property yourself, but it is easier to use the functions in this
section.
-@defun insert-image image &optional string area slice
+@defun insert-image image &optional string area slice inhibit-isearch
This function inserts @var{image} in the current buffer at point. The
value @var{image} should be an image descriptor; it could be a value
returned by @code{create-image}, or the value of a symbol defined with
@@ -6469,7 +6614,9 @@ image.
Internally, this function inserts @var{string} in the buffer, and gives
it a @code{display} property which specifies @var{image}. @xref{Display
-Property}.
+Property}. By default, doing interactive searches in the buffer will
+consider @var{string} when searching. If @var{inhibit-isearch} is
+non-@code{nil}, this is inhibited.
@end defun
@cindex slice, image
@@ -6545,6 +6692,11 @@ cache, it can always be displayed, even if the value of
@code{max-image-size} is subsequently changed (@pxref{Image Cache}).
@end defvar
+@defun image-at-point-p
+This function returns @code{t} if point is on an image, and @code{nil}
+otherwise.
+@end defun
+
Images inserted with the insertion functions above also get a local
keymap installed in the text properties (or overlays) that span the
displayed image. This keymap defines the following commands:
@@ -6716,7 +6868,10 @@ xwidget object, and then use that object as the display specifier
in a @code{display} text or overlay property (@pxref{Display
Property}).
-@defun make-xwidget type title width height arguments &optional buffer
+ Embedded widgets can send events notifying Lisp code about changes
+occurring within them. (@pxref{Xwidget Events}).
+
+@defun make-xwidget type title width height arguments &optional buffer related
This creates and returns an xwidget object. If
@var{buffer} is omitted or @code{nil}, it defaults to the current
buffer. If @var{buffer} names a buffer that doesn't exist, it will be
@@ -6729,7 +6884,17 @@ The WebKit component.
@end table
The @var{width} and @var{height} arguments specify the widget size in
-pixels, and @var{title}, a string, specifies its title.
+pixels, and @var{title}, a string, specifies its title. @var{related}
+is used internally by the WebKit widget, and specifies another WebKit
+widget that the newly created widget should share settings and
+subprocesses with.
+
+The xwidget that is returned will be killed alongside its buffer
+(@pxref{Killing Buffers}). You can also kill it using
+@code{kill-xwidget}. Once it is killed, the xwidget may continue to
+exist as a Lisp object and act as a @code{display} property until all
+references to it are gone, but most actions that can be performed on
+live xwidgets will no longer be available.
@end defun
@defun xwidgetp object
@@ -6737,6 +6902,17 @@ This function returns @code{t} if @var{object} is an xwidget,
@code{nil} otherwise.
@end defun
+@defun xwidget-live-p object
+This function returns @code{t} if @var{object} is an xwidget that
+hasn't been killed, and @code{nil} otherwise.
+@end defun
+
+@defun kill-xwidget xwidget
+This function kills @var{xwidget}, by removing it from its buffer and
+releasing window system resources it holds.
+@end defun
+
+@cindex xwidget property list
@defun xwidget-plist xwidget
This function returns the property list of @var{xwidget}.
@end defun
@@ -6747,7 +6923,12 @@ property list given by @var{plist}.
@end defun
@defun xwidget-buffer xwidget
-This function returns the buffer of @var{xwidget}.
+This function returns the buffer of @var{xwidget}. If @var{xwidget}
+has been killed, it returns @code{nil}.
+@end defun
+
+@defun set-xwidget-buffer xwidget buffer
+This function sets the buffer of @var{xwidget} to @var{buffer}.
@end defun
@defun get-buffer-xwidgets buffer
@@ -6810,6 +6991,130 @@ This function returns the current setting of @var{xwidget}s
query-on-exit flag, either @code{t} or @code{nil}.
@end defun
+@defun xwidget-perform-lispy-event xwidget event frame
+Send an input event @var{event} to @var{xwidget}. The precise action
+performed is platform-specific. @xref{Input Events}.
+
+You can optionally pass the frame on which the event was generated via
+@var{frame}. On X11, modifier keys in key events will not be
+considered if @var{frame} is @code{nil}, and the selected frame is not
+an X-Windows frame.
+
+On GTK, only keyboard and function key events are supported. Mouse,
+motion, and click events are dispatched to the xwidget without going
+through Lisp code, and as such shouldn't require this function to be
+called.
+@end defun
+
+@defun xwidget-webkit-search query xwidget &optional case-insensitive backwards wrap-around
+Start an incremental search on the WebKit widget @var{xwidget} with
+the string @var{query} as the query. @var{case-insensitive} denotes
+whether or not the search is case-insensitive, @var{backwards}
+determines if the search is performed backwards towards the start of
+the document, and @var{wrap-around} determines whether or not the
+search terminates at the end of the document.
+
+If the function is called while a search query is already present,
+then the query specified here will replace the existing query.
+
+To stop a search query, use @code{xwidget-webkit-finish-search}.
+@end defun
+
+@defun xwidget-webkit-next-result xwidget
+Display the next search result in @var{xwidget}. This function will
+signal an error if a search query has not been already started in
+@var{xwidget} through @code{xwidget-webkit-search}.
+
+If @code{wrap-around} was non-nil when @code{xwidget-webkit-search}
+was called, then the search will restart from the beginning of the
+document when its end is reached.
+@end defun
+
+@defun xwidget-webkit-previous-result xwidget
+Display the previous search result in @var{xwidget}. This function
+signals an error if a search query has not been already started in
+@var{xwidget} through @code{xwidget-webkit-search}.
+
+If @code{wrap-around} was non-nil when @code{xwidget-webkit-search}
+was called, then the search will restart from the end of the
+document when its beginning is reached.
+@end defun
+
+@defun xwidget-webkit-finish-search xwidget
+Finish a search operation started with @code{xwidget-webkit-search} in
+@var{xwidget}. If there is no query currently ongoing, this function
+signals an error.
+@end defun
+
+@defun xwidget-webkit-load-html xwidget text &optional base-uri
+Load @var{text}, a string, into @var{xwidget}, which should be a
+WebKit xwidget. Any HTML markup in @var{text} will be processed
+by @var{xwidget} while rendering the text.
+
+Optional argument @var{base-uri}, which should be a string, specifies
+the absolute location of the web resources referenced by @var{text},
+to be used for resolving relative links in @var{text}.
+@end defun
+
+@defun xwidget-webkit-goto-history xwidget rel-pos
+Make @var{xwidget}, a WebKit widget, load the @var{rel-pos}th element
+in its navigation history.
+
+If @var{rel-pos} is zero, the current page will be reloaded instead.
+@end defun
+
+@defun xwidget-webkit-back-forward-list xwidget &optional limit
+Return the navigation history of @var{xwidget}, up to @var{limit}
+items in each direction. If not specified, @var{limit} defaults to
+50.
+
+The returned value is a list of the form @w{@code{(@var{back}
+@var{here} @var{forward})}}, where @var{here} is the current
+navigation item, while @var{back} is a list of items containing the
+items recorded by WebKit before the current navigation item, and
+@var{forward} is a list of items recorded after the current navigation
+item. @var{back}, @var{here} and @var{forward} can all be @code{nil}.
+
+When @var{here} is @code{nil}, it means that no items have been
+recorded yet; if @var{back} or @var{forward} are @code{nil}, it means
+that there is no history recorded before or after the current item
+respectively.
+
+Navigation items are themselves lists of the form @w{@code{(@var{idx}
+@var{title} @var{uri})}}. In these lists, @var{idx} is an index that
+can be passed to @code{xwidget-webkit-goto-history}, @var{title} is
+the human-readable title of the item, and @var{uri} is the URI of the
+item. The user should normally have no reason to load @var{uri}
+manually to reach a specific history item. Instead, @var{idx} should
+be passed as an index to @code{xwidget-webkit-goto-history}.
+@end defun
+
+@defun xwidget-webkit-estimated-load-progress xwidget
+Return an estimate of how much data is remaining to be transferred
+before the page displayed by the WebKit widget @var{xwidget} is fully
+loaded.
+
+The value returned is a float ranging between 0.0 and 1.0.
+@end defun
+
+@defun xwidget-webkit-set-cookie-storage-file xwidget file
+Make the WebKit widget @var{xwidget} store cookies in @var{file}.
+
+@var{file} must be an absolute file name. The new setting will also
+affect any xwidget that was created with @var{xwidget} as the
+@code{related} argument to @code{make-xwidget}, and widgets related to
+those as well.
+
+If this function is not called at least once on @var{xwidget} or a
+related widget, @var{xwidget} will not store cookies on disk at all.
+@end defun
+
+@defun xwidget-webkit-stop-loading xwidget
+Terminate any data transfer still in progress in the WebKit widget
+@var{xwidget} as part of a page-loading operation. If a page is not
+being loaded, this function does nothing.
+@end defun
+
@node Buttons
@section Buttons
@cindex buttons in buffers
@@ -7003,7 +7308,7 @@ This inserts a button with the label @var{label} at point, using text
properties.
@end defun
-@defun button-buttonize string callback &optional data
+@defun buttonize string callback &optional data
Sometimes it's more convenient to make a string into a button without
inserting it into a buffer immediately, for instance when creating
data structures that may then, later, be inserted into a buffer. This
@@ -7478,16 +7783,14 @@ The string is formatted #RRGGBB (hash followed by six hex digits)."
(kill-buffer nil))
(setq colorcomp-mode-map
- (let ((m (make-sparse-keymap)))
- (suppress-keymap m)
- (define-key m "i" 'colorcomp-R-less)
- (define-key m "o" 'colorcomp-R-more)
- (define-key m "k" 'colorcomp-G-less)
- (define-key m "l" 'colorcomp-G-more)
- (define-key m "," 'colorcomp-B-less)
- (define-key m "." 'colorcomp-B-more)
- (define-key m " " 'colorcomp-copy-as-kill-and-exit)
- m))
+ (define-keymap :suppress t
+ "i" 'colorcomp-R-less
+ "o" 'colorcomp-R-more
+ "k" 'colorcomp-G-less
+ "l" 'colorcomp-G-more
+ "," 'colorcomp-B-less
+ "." 'colorcomp-B-more
+ "SPC" 'colorcomp-copy-as-kill-and-exit))
@end smallexample
Note that we never modify the data in each node, which is fixed when the
@@ -7896,7 +8199,14 @@ there is no available font (on a graphical display), and characters
which cannot be encoded by the terminal's coding system (on a text
terminal).
+@vindex glyphless-display-mode
+The @code{glyphless-display-mode} minor mode can be used to toggle
+displaying glyphless characters in a convenient manner in the current
+buffer. If this mode is enabled, all the glyphless characters are
+displayed as boxes that display acronyms of their character names.
+
@defvar glyphless-char-display
+For more fine-grained (and global) control, this variable can be used.
The value of this variable is a char-table which defines glyphless
characters and how they are displayed. Each entry must be one of the
following display methods:
@@ -7976,6 +8286,16 @@ Characters of Unicode General Category [Cf], such as U+200E
@sc{left-to-right mark}, but excluding characters that have graphic
images, such as U+00AD @sc{soft hyphen}.
+@item bidi-control
+This is a subset of @code{format-control}, but only includes
+characters that are related to bidirectional formatting control, like
+U+2069 @sc{pop directional isolate} and U+202A @sc{left-to-right
+embedding}. @xref{Bidirectional Display}.
+
+Characters of Unicode General Category [Cf], such as U+200E
+@sc{left-to-right mark}, but excluding characters that have graphic
+images, such as U+00AD @sc{soft hyphen}.
+
@item variation-selectors
Unicode VS-1 through VS-16 (U+FE00 through U+FE0F), which are used to
select between different glyphs for the same codepoints (typically
@@ -8053,6 +8373,8 @@ Emacs is displaying the frame using the Nextstep interface (used on
GNUstep and macOS).
@item pc
Emacs is displaying the frame using MS-DOS direct screen writes.
+@item haiku
+Emacs is displaying the frame using the Application Kit on Haiku.
@item nil
Emacs is displaying the frame on a character-based terminal.
@end table
@@ -8099,6 +8421,7 @@ area. On text-mode (a.k.a.@: ``TTY'') frames, tooltips are always
displayed in the echo area.
@end defun
+@cindex system tooltips
@vindex x-gtk-use-system-tooltips
When Emacs is built with GTK+ support, it by default displays tooltips
using GTK+ functions, and the appearance of the tooltips is then
diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index 7d67cc3af11..0db77255a65 100644
--- a/doc/lispref/edebug.texi
+++ b/doc/lispref/edebug.texi
@@ -1267,7 +1267,7 @@ balanced parentheses, recursive processing of forms, and recursion via
indirect specifications.
Here's a table of the possible elements of a specification list, with
-their meanings (see @ref{Specification Examples}, for the referenced
+their meanings (@pxref{Specification Examples}, for the referenced
examples):
@table @code
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index 6057691239f..2186203eb6d 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -365,6 +365,7 @@ Editing Types
* Keymap Type:: What function a keystroke invokes.
* Overlay Type:: How an overlay is represented.
* Font Type:: Fonts for displaying text.
+* Xwidget Type:: Embeddable widgets.
Numbers
@@ -525,6 +526,7 @@ Variables
* Variables with Restricted Values:: Non-constant variables whose value can
@emph{not} be an arbitrary Lisp object.
* Generalized Variables:: Extending the concept of variables.
+* Multisession Variables:: Variables that survive restarting Emacs.
Scoping Rules for Variable Bindings
@@ -546,6 +548,10 @@ Generalized Variables
* Setting Generalized Variables:: The @code{setf} macro.
* Adding Generalized Variables:: Defining new @code{setf} forms.
+Multisession Variables
+
+* Multisession Variables:: Variables that survive restarting Emacs.
+
Functions
* What Is a Function:: Lisp functions vs. primitives; terminology.
@@ -839,6 +845,7 @@ Keymaps
* Key Lookup:: Finding a key's binding in one keymap.
* Functions for Key Lookup:: How to request key lookup.
* Changing Key Bindings:: Redefining a key in a keymap.
+* Low-Level Key Binding:: Legacy key syntax description.
* Remapping Commands:: A keymap can translate one command to another.
* Translation Keymaps:: Keymaps for translating sequences of events.
* Key Binding Commands:: Interactive interfaces for redefining keys.
@@ -1123,6 +1130,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.
+* 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.
* Text Terminal Colors:: Defining colors for text terminals.
@@ -1221,6 +1229,7 @@ Text
* Base 64:: Conversion to or from base 64 encoding.
* Checksum/Hash:: Computing cryptographic hashes.
* GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS.
+* Database:: Interacting with an SQL database.
* Parsing HTML/XML:: Parsing HTML and XML.
* Atomic Changes:: Installing several buffer changes atomically.
* Change Hooks:: Supplying functions to be run when text is changed.
diff --git a/doc/lispref/errors.texi b/doc/lispref/errors.texi
index f848218e267..9dd052c5235 100644
--- a/doc/lispref/errors.texi
+++ b/doc/lispref/errors.texi
@@ -98,6 +98,10 @@ Lisp reader, not to file I/O@. @xref{Input Functions}.
@item file-already-exists
This is a subcategory of @code{file-error}. @xref{Writing to Files}.
+@item permission-denied
+This is a subcategory of @code{file-error}, which occurs when the OS
+doesn't allow Emacs to access a file or a directory for some reason.
+
@item file-date-error
This is a subcategory of @code{file-error}. It occurs when
@code{copy-file} tries and fails to set the last-modification time of
diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index 1e05153f3c0..4b114ba111d 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -1314,6 +1314,20 @@ on the 19th, @file{aug-20} was written on the 20th, and the file
@end example
@end defun
+@defun file-has-changed-p filename tag
+This function returns non-@code{nil} if the time stamp of
+@var{filename} has changed since the last call. When called for the
+first time for some @var{filename}, it records the last modification
+time and size of the file, and returns non-@code{nil} when
+@var{filename} exists. Thereafter, when called for the same
+@var{filename}, it compares the current time stamp and size with the
+recorded ones, and returns non-@code{nil} only if either the time
+stamp or the size (or both) are different. This is useful when a Lisp
+program wants to re-read a file whenever it changes. With an optional
+argument @var{tag}, which must be a symbol, the size and modification
+time comparisons are limited to calls with the same tag.
+@end defun
+
@defun file-attributes filename &optional id-format
@anchor{Definition of file-attributes}
This function returns a list of attributes of file @var{filename}. If
@@ -2083,6 +2097,9 @@ directory. Therefore, Emacs considers a file name as having two main
parts: the @dfn{directory name} part, and the @dfn{nondirectory} part
(or @dfn{file name within the directory}). Either part may be empty.
Concatenating these two parts reproduces the original file name.
+@footnote{Emacs follows the GNU convention to use the term @emph{file name}
+instead of the term @emph{pathname}. We use the term @emph{path} only for
+search paths, which are lists of directory names.}
On most systems, the directory part is everything up to and including
the last slash (backslash is also allowed in input on MS-DOS or
@@ -2227,6 +2244,19 @@ and @code{file-name-nondirectory}. For example,
@end example
@end defun
+@defun file-name-split filename
+This function splits a file name into its components, and can be
+thought of as the inverse of @code{string-join} with the appropriate
+directory separator. For example,
+
+@example
+(file-name-split "/tmp/foo.txt")
+ @result{} ("" "tmp" "foo.txt")
+(string-join (file-name-split "/tmp/foo.txt") "/")
+ @result{} "/tmp/foo.txt"
+@end example
+@end defun
+
@node Relative File Names
@subsection Absolute and Relative File Names
@cindex absolute file name
@@ -3278,8 +3308,8 @@ first, before handlers for jobs such as remote file access.
@ifnottex
@noindent
-@code{access-file}, @code{add-name-to-file},
-@code{byte-compiler-base-file-name},@*
+@code{abbreviate-file-name}, @code{access-file},
+@code{add-name-to-file}, @code{byte-compiler-base-file-name},@*
@code{copy-directory}, @code{copy-file},
@code{delete-directory}, @code{delete-file},
@code{diff-latest-backup-file},
@@ -3338,7 +3368,8 @@ first, before handlers for jobs such as remote file access.
@iftex
@noindent
@flushleft
-@code{access-file}, @code{add-name-to-file},
+@code{abbreviate-file-name}, @code{access-file},
+@code{add-name-to-file},
@code{byte-com@discretionary{}{}{}piler-base-file-name},
@code{copy-directory}, @code{copy-file},
@code{delete-directory}, @code{delete-file},
diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi
index 3aab9408422..3708ef94619 100644
--- a/doc/lispref/frames.texi
+++ b/doc/lispref/frames.texi
@@ -105,6 +105,7 @@ window of another Emacs frame. @xref{Child 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.
+* 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.
* Text Terminal Colors:: Defining colors for text terminals.
@@ -170,7 +171,9 @@ usually not run for the initial frame, since Emacs reads the initial
file only after creating that frame. However, if the initial frame is
specified to use a separate minibuffer frame (@pxref{Minibuffers and
Frames}), the functions will be run for both, the minibuffer-less and
-the minibuffer frame.
+the minibuffer frame. Alternatively, you can add functions to these
+hooks in your ``early init file'' (@pxref{Init File}), in which case
+they will be in effect for the initial frame as well.
@defvar frame-inherited-parameters
This variable specifies the list of frame parameters that a newly
@@ -213,7 +216,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}, or @code{pc}). @xref{Frames}.
+@code{t}, @code{w32}, @code{ns}, @code{pc}, @code{haiku}, or @code{pgtk}).
+@xref{Frames}.
@item
A list of terminal parameters. @xref{Terminal Parameters}.
@@ -679,7 +683,7 @@ indicate that position for the various builds:
@itemize @w{}
@item (1) non-toolkit and terminal frames
-@item (2) Lucid, Motif and MS-Windows frames
+@item (2) Lucid, Motif, MS-Windows, and Haiku frames
@item (3) GTK+ and NS frames
@end itemize
@@ -1728,7 +1732,9 @@ fit will be clipped by the window manager.
@item fullscreen
This parameter specifies whether to maximize the frame's width, height
or both. Its value can be @code{fullwidth}, @code{fullheight},
-@code{fullboth}, or @code{maximized}. A @dfn{fullwidth} frame is as
+@code{fullboth}, or @code{maximized}.@footnote{On Haiku, setting
+@code{fullscreen} to @code{fullwidth} or @code{fullheight} has no
+effect.} A @dfn{fullwidth} frame is as
wide as possible, a @dfn{fullheight} frame is as tall as possible, and
a @dfn{fullboth} frame is both as wide and as tall as possible. A
@dfn{maximized} frame is like a ``fullboth'' frame, except that it usually
@@ -2190,7 +2196,10 @@ either via @code{focus-follows-mouse} (@pxref{Input Focus}) or
@code{mouse-autoselect-window} (@pxref{Mouse Window Auto-selection}).
This may have the unwanted side-effect that a user cannot scroll a
non-selected frame with the mouse. Some window managers may not honor
-this parameter.
+this parameter. On Haiku, it also has the side-effect that the window
+will not be able to receive any keyboard input from the user, not even
+if the user switches to the frame using the key combination
+@kbd{Alt-@key{TAB}}.
@vindex undecorated@r{, a frame parameter}
@item undecorated
@@ -2351,7 +2360,10 @@ driver for OTF and TTF fonts with text shaping by the Uniscribe
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
-other systems, there is only one available font backend, so it does
+Haiku, there can be several font drivers (@pxref{Haiku Fonts,,, emacs,
+The GNU Emacs Manual}).
+
+On other systems, there is only one available font backend, so it does
not make sense to modify this frame parameter.
@vindex background-mode@r{, a frame parameter}
@@ -3140,8 +3152,10 @@ raises @var{frame} above all other child frames of its parent.
@deffn Command lower-frame &optional frame
This function lowers frame @var{frame} (default, the selected frame)
below all other frames belonging to the same or a higher z-group as
-@var{frame}. If @var{frame} is a child frame (@pxref{Child Frames}),
-this lowers @var{frame} below all other child frames of its parent.
+@var{frame}.@footnote{Lowering frames is not supported on Haiku, due
+to limitations imposed by the system.} If @var{frame} is a child
+frame (@pxref{Child Frames}), this lowers @var{frame} below all other
+child frames of its parent.
@end deffn
@defun frame-restack frame1 frame2 &optional above
@@ -3151,7 +3165,8 @@ that if both frames are visible and their display areas overlap,
third argument @var{above} is non-@code{nil}, this function restacks
@var{frame1} above @var{frame2}. This means that if both frames are
visible and their display areas overlap, @var{frame1} will (partially)
-obscure @var{frame2}.
+obscure @var{frame2}.@footnote{Restacking frames is not supported on
+Haiku, due to limitations imposed by the system.}
Technically, this function may be thought of as an atomic action
performed in two steps: The first step removes @var{frame1}'s
@@ -3246,12 +3261,16 @@ parent frame's window-system window.
@cindex reparent frame
@cindex nest frame
- The @code{parent-frame} parameter can be changed at any time. Setting
-it to another frame @dfn{reparents} the child frame. Setting it to
-another child frame makes the frame a @dfn{nested} child frame. Setting
-it to @code{nil} restores the frame's status as a top-level frame---a
-frame whose window-system window is a child of its display's root
-window.
+ The @code{parent-frame} parameter can be changed at any time.
+Setting it to another frame @dfn{reparents} the child frame. Setting
+it to another child frame makes the frame a @dfn{nested} child frame.
+Setting it to @code{nil} restores the frame's status as a top-level
+frame---a frame whose window-system window is a child of its display's
+root window.@footnote{On Haiku, child frames are only visible when a
+parent frame is active, owing to a limitation of the Haiku windowing
+system. Owing to the same limitation, child frames are only
+guaranteed to appear above their top-level parent; that is to say, the
+top-most frame in the hierarchy, which does not have a parent frame.}
Since child frames can be arbitrarily nested, a frame can be both a
child and a parent frame. Also, the relative roles of child and parent
@@ -3925,6 +3944,47 @@ For backward compatibility, there are obsolete aliases
names of @code{gui-get-selection} and @code{gui-set-selection} before
Emacs 25.1.
+@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.
+
+@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:
+
+@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.
+@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.
+
@node Drag and Drop
@section Drag and Drop
@cindex drag and drop
diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi
index c8f3b12080a..46a1e57ea58 100644
--- a/doc/lispref/functions.texi
+++ b/doc/lispref/functions.texi
@@ -969,14 +969,14 @@ side-effects only---the values it returns are ignored, not collected
into a list. @code{mapc} always returns @var{sequence}.
@end defun
-@defun mapconcat function sequence separator
+@defun mapconcat function sequence &optional separator
@code{mapconcat} applies @var{function} to each element of
@var{sequence}; the results, which must be sequences of characters
(strings, vectors, or lists), are concatenated into a single string
return value. Between each pair of result sequences, @code{mapconcat}
inserts the characters from @var{separator}, which also must be a
-string, or a vector or list of characters. @xref{Sequences Arrays
-Vectors}.
+string, or a vector or list of characters; a @code{nil} value is
+treated as the empty string. @xref{Sequences Arrays Vectors}.
The argument @var{function} must be a function that can take one
argument and returns a sequence of characters: a string, a vector, or
@@ -994,8 +994,7 @@ string.
@group
(mapconcat (lambda (x) (format "%c" (1+ x)))
- "HAL-8000"
- "")
+ "HAL-8000")
@result{} "IBM.9111"
@end group
@end example
diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi
index a48571838cc..e7b6406fd8c 100644
--- a/doc/lispref/help.texi
+++ b/doc/lispref/help.texi
@@ -333,6 +333,13 @@ stands for no text itself. It is used only for a side effect: it
specifies @var{mapvar}'s value as the keymap for any following
@samp{\[@var{command}]} sequences in this documentation string.
+@item \`@var{KEYSEQ}'
+stands for a key sequence @var{KEYSEQ}, 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 @code{read-key-sequence}. It must be a valid key
+sequence according to @code{key-valid-p}.
+
@item `
(grave accent) stands for a left quote.
This generates a left single quotation mark, an apostrophe, or a grave
@@ -644,7 +651,7 @@ follows:
@smallexample
@group
-(define-key global-map (string help-char) 'help-command)
+(keymap-set global-map (key-description (string help-char)) 'help-command)
(fset 'help-command help-map)
@end group
@end smallexample
diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi
index d3edd633171..7718712b9b8 100644
--- a/doc/lispref/internals.texi
+++ b/doc/lispref/internals.texi
@@ -218,6 +218,14 @@ the Emacs executable that dumped them.
If you want to use this function in an Emacs that was already dumped,
you must run Emacs with the @samp{-batch} option.
+
+@vindex after-pdump-load-hook
+If you're including @samp{.el} files in the dumped Emacs and that
+@samp{.el} file has code that is normally run at load time, that code
+won't be run when Emacs starts after dumping. To help work around
+that problem, you can put functions on the
+@code{after-pdump-load-hook} hook. This hook is run when starting
+Emacs.
@end defun
@defun dump-emacs to-file from-file
diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi
index 4097c86f074..edf1d6e83fd 100644
--- a/doc/lispref/keymaps.texi
+++ b/doc/lispref/keymaps.texi
@@ -30,6 +30,7 @@ is found. The whole process is called @dfn{key lookup}.
* Key Lookup:: Finding a key's binding in one keymap.
* Functions for Key Lookup:: How to request key lookup.
* Changing Key Bindings:: Redefining a key in a keymap.
+* Low-Level Key Binding:: Legacy key syntax description.
* Remapping Commands:: A keymap can translate one command to another.
* Translation Keymaps:: Keymaps for translating sequences of events.
* Key Binding Commands:: Interactive interfaces for redefining keys.
@@ -94,8 +95,15 @@ Manual}.
(kbd "<f1> SPC") @result{} [f1 32]
(kbd "C-M-<down>") @result{} [C-M-down]
@end example
+
+@findex key-valid-p
+The @code{kbd} function is very permissive, and will try to return
+something sensible even if the syntax used isn't completely
+conforming. To check whether the syntax is actually valid, use the
+@code{key-valid-p} function.
@end defun
+
@node Keymap Basics
@section Keymap Basics
@cindex key binding
@@ -359,7 +367,7 @@ I.e., something like:
@group
(let ((map (make-sparse-keymap)))
(set-keymap-parent map <theirmap>)
- (define-key map ...)
+ (keymap-set map ...)
...)
@end group
@end example
@@ -412,10 +420,10 @@ The effect is that this keymap inherits all the bindings of
but can add to them or override them with @var{elements}.
If you change the bindings in @var{parent-keymap} using
-@code{define-key} or other key-binding functions, these changed
+@code{keymap-set} or other key-binding functions, these changed
bindings are visible in the inheriting keymap, unless shadowed by the
bindings made by @var{elements}. The converse is not true: if you use
-@code{define-key} to change bindings in the inheriting keymap, these
+@code{keymap-set} to change bindings in the inheriting keymap, these
changes are recorded in @var{elements}, but have no effect on
@var{parent-keymap}.
@@ -610,16 +618,16 @@ active keymap.
@result{} nil
@end group
@group
-(local-set-key "\C-p" ctl-x-map)
+(keymap-local-set "C-p" ctl-x-map)
@result{} nil
@end group
@group
-(key-binding "\C-p\C-f")
+(keymap-binding "C-p C-f")
@result{} find-file
@end group
@group
-(key-binding "\C-p6")
+(keymap-binding "C-p 6")
@result{} nil
@end group
@end example
@@ -682,7 +690,7 @@ use, in place of the buffer's default local keymap.
@cindex major mode keymap
The local keymap is normally set by the buffer's major mode, and
every buffer with the same major mode shares the same local keymap.
-Hence, if you call @code{local-set-key} (@pxref{Key Binding Commands})
+Hence, if you call @code{keymap-local-set} (@pxref{Key Binding Commands})
to change the local keymap in one buffer, that also affects the local
keymaps in other buffers with the same major mode.
@@ -716,39 +724,7 @@ Normally it ignores @code{overriding-local-map} and
then it pays attention to them. @var{position} can optionally be either
an event position as returned by @code{event-start} or a buffer
position, and may change the keymaps as described for
-@code{key-binding}.
-@end defun
-
-@defun key-binding key &optional accept-defaults no-remap position
-This function returns the binding for @var{key} according to the
-current active keymaps. The result is @code{nil} if @var{key} is
-undefined in the keymaps.
-
-The argument @var{accept-defaults} controls checking for default
-bindings, as in @code{lookup-key} (@pxref{Functions for Key Lookup}).
-
-When commands are remapped (@pxref{Remapping Commands}),
-@code{key-binding} normally processes command remappings so as to
-return the remapped command that will actually be executed. However,
-if @var{no-remap} is non-@code{nil}, @code{key-binding} ignores
-remappings and returns the binding directly specified for @var{key}.
-
-If @var{key} starts with a mouse event (perhaps following a prefix
-event), the maps to be consulted are determined based on the event's
-position. Otherwise, they are determined based on the value of point.
-However, you can override either of them by specifying @var{position}.
-If @var{position} is non-@code{nil}, it should be either a buffer
-position or an event position like the value of @code{event-start}.
-Then the maps consulted are determined based on @var{position}.
-
-Emacs signals an error if @var{key} is not a string or a vector.
-
-@example
-@group
-(key-binding "\C-x\C-f")
- @result{} find-file
-@end group
-@end example
+@code{keymap-binding}.
@end defun
@node Searching Keymaps
@@ -821,7 +797,7 @@ out with.
This function returns the current global keymap. This is the same as
the value of @code{global-map} unless you change one or the other.
The return value is a reference, not a copy; if you use
-@code{define-key} or other functions on it you will alter global
+@code{keymap-set} or other functions on it you will alter global
bindings.
@example
@@ -857,7 +833,7 @@ keymap.
@end defun
@code{current-local-map} returns a reference to the local keymap, not
-a copy of it; if you use @code{define-key} or other functions on it
+a copy of it; if you use @code{keymap-set} or other functions on it
you will alter local bindings.
@defun current-minor-mode-maps
@@ -1025,7 +1001,7 @@ keymap.
Let's use the term @dfn{keymap entry} to describe the value found by
looking up an event type in a keymap. (This doesn't include the item
string and other extra elements in a keymap element for a menu item, because
-@code{lookup-key} and other key lookup functions don't include them in
+@code{keymap-lookup} and other key lookup functions don't include them in
the returned value.) While any Lisp object may be stored in a keymap
as a keymap entry, not all make sense for key lookup. Here is a table
of the meaningful types of keymap entries:
@@ -1176,7 +1152,7 @@ Used in keymaps to undefine keys. It calls @code{ding}, but does
not cause an error.
@end deffn
-@defun local-key-binding key &optional accept-defaults
+@defun keymap-local-binding key &optional accept-defaults
This function returns the binding for @var{key} in the current
local keymap, or @code{nil} if it is undefined there.
@@ -1184,7 +1160,7 @@ The argument @var{accept-defaults} controls checking for default bindings,
as in @code{lookup-key} (above).
@end defun
-@defun global-key-binding key &optional accept-defaults
+@defun keymap-global-binding key &optional accept-defaults
This function returns the binding for command @var{key} in the
current global keymap, or @code{nil} if it is undefined there.
@@ -1267,51 +1243,63 @@ change a binding in the global keymap, the change is effective in all
buffers (though it has no direct effect in buffers that shadow the
global binding with a local one). If you change the current buffer's
local map, that usually affects all buffers using the same major mode.
-The @code{global-set-key} and @code{local-set-key} functions are
+The @code{keymap-global-set} and @code{keymap-local-set} functions are
convenient interfaces for these operations (@pxref{Key Binding
-Commands}). You can also use @code{define-key}, a more general
+Commands}). You can also use @code{keymap-set}, a more general
function; then you must explicitly specify the map to change.
When choosing the key sequences for Lisp programs to rebind, please
follow the Emacs conventions for use of various keys (@pxref{Key
Binding Conventions}).
-@cindex meta character key constants
-@cindex control character key constants
- In writing the key sequence to rebind, it is good to use the special
-escape sequences for control and meta characters (@pxref{String Type}).
-The syntax @samp{\C-} means that the following character is a control
-character and @samp{\M-} means that the following character is a meta
-character. Thus, the string @code{"\M-x"} is read as containing a
-single @kbd{M-x}, @code{"\C-f"} is read as containing a single
-@kbd{C-f}, and @code{"\M-\C-x"} and @code{"\C-\M-x"} are both read as
-containing a single @kbd{C-M-x}. You can also use this escape syntax in
-vectors, as well as others that aren't allowed in strings; one example
-is @samp{[?\C-\H-x home]}. @xref{Character Type}.
-
- The key definition and lookup functions accept an alternate syntax for
-event types in a key sequence that is a vector: you can use a list
-containing modifier names plus one base event (a character or function
-key name). For example, @code{(control ?a)} is equivalent to
-@code{?\C-a} and @code{(hyper control left)} is equivalent to
-@code{C-H-left}. One advantage of such lists is that the precise
-numeric codes for the modifier bits don't appear in compiled files.
-
The functions below signal an error if @var{keymap} is not a keymap,
-or if @var{key} is not a string or vector representing a key sequence.
-You can use event types (symbols) as shorthand for events that are
-lists. The @code{kbd} function (@pxref{Key Sequences}) is a
-convenient way to specify the key sequence.
+or if @var{key} is not a valid key.
+
+@var{key} is a string representing a single key or a series of key
+strokes. Key strokes are separated by a single space character.
+
+Each key stroke is either a single character, or the name of an
+event, surrounded by angle brackets. In addition, any key stroke
+may be preceded by one or more modifier keys. Finally, a limited
+number of characters have a special shorthand syntax. Here's some
+example key sequences:
+
+@table @kbd
+@item f
+The key @kbd{f}.
+
+@item S o m
+A three key sequence of the keys @kbd{S}, @kbd{o} and @kbd{m}.
+
+@item C-c o
+A two key sequence of the keys @kbd{c} with the control modifier and
+then the key @kbd{o}
+
+@item H-<left>
+The key named @kbd{left} with the hyper modifier.
+
+@item M-RET
+The @kbd{return} key with a meta modifier.
+
+@item C-M-<space>
+The @kbd{space} key with both the control and meta modifiers.
+@end table
+
+The only keys that have a special shorthand syntax are @kbd{NUL},
+@kbd{RET}, @kbd{TAB}, @kbd{LFD}, @kbd{ESC}, @kbd{SPC} and @kbd{DEL}.
-@defun define-key keymap key binding
+The modifiers have to be specified in alphabetical order:
+@samp{A-C-H-M-S-s}, which is @samp{Alt-Control-Hyper-Meta-Shift-super}.
+
+@defun keymap-set keymap key binding
This function sets the binding for @var{key} in @var{keymap}. (If
@var{key} is more than one event long, the change is actually made
in another keymap reached from @var{keymap}.) The argument
@var{binding} can be any Lisp object, but only certain types are
meaningful. (For a list of meaningful types, see @ref{Key Lookup}.)
-The value returned by @code{define-key} is @var{binding}.
+The value returned by @code{keymap-set} is @var{binding}.
-If @var{key} is @code{[t]}, this sets the default binding in
+If @var{key} is @kbd{<t>}, this sets the default binding in
@var{keymap}. When an event has no binding of its own, the Emacs
command loop uses the keymap's default binding, if there is one.
@@ -1319,7 +1307,7 @@ command loop uses the keymap's default binding, if there is one.
@cindex key sequence error
Every prefix of @var{key} must be a prefix key (i.e., bound to a keymap)
or undefined; otherwise an error is signaled. If some prefix of
-@var{key} is undefined, then @code{define-key} defines it as a prefix
+@var{key} is undefined, then @code{keymap-set} defines it as a prefix
key so that the rest of @var{key} can be defined as specified.
If there was previously no binding for @var{key} in @var{keymap}, the
@@ -1337,7 +1325,7 @@ bindings in it:
@result{} (keymap)
@end group
@group
-(define-key map "\C-f" 'forward-char)
+(keymap-set map "C-f" 'forward-char)
@result{} forward-char
@end group
@group
@@ -1347,7 +1335,7 @@ map
@group
;; @r{Build sparse submap for @kbd{C-x} and bind @kbd{f} in that.}
-(define-key map (kbd "C-x f") 'forward-word)
+(keymap-set map "C-x f" 'forward-word)
@result{} forward-word
@end group
@group
@@ -1360,14 +1348,14 @@ map
@group
;; @r{Bind @kbd{C-p} to the @code{ctl-x-map}.}
-(define-key map (kbd "C-p") ctl-x-map)
+(keymap-set map "C-p" ctl-x-map)
;; @code{ctl-x-map}
@result{} [nil @dots{} find-file @dots{} backward-kill-sentence]
@end group
@group
;; @r{Bind @kbd{C-f} to @code{foo} in the @code{ctl-x-map}.}
-(define-key map (kbd "C-p C-f") 'foo)
+(keymap-set map "C-p C-f" 'foo)
@result{} 'foo
@end group
@group
@@ -1386,6 +1374,99 @@ changing an entry in @code{ctl-x-map}, and this has the effect of
changing the bindings of both @kbd{C-p C-f} and @kbd{C-x C-f} in the
default global map.
+@defun define-keymap &key options... &rest pairs...
+@code{keymap-set} is the general work horse for defining a key in a
+keymap. When writing modes, however, you frequently have to bind a
+large number of keys at once, and using @code{keymap-set} on them all
+can be tedious and error-prone. Instead you can use
+@code{define-keymap}, which creates a keymaps and binds a number of
+keys. Here's a very basic example:
+
+@lisp
+(define-keymap
+ "n" #'forward-line
+ "f" #'previous-line
+ "C-c C-c" #'quit-window)
+@end lisp
+
+This function creates a new sparse keymap, defines the two keystrokes
+in @var{pairs}, and returns the new keymap.
+
+@var{pairs} is a list of alternating key bindings and key definitions,
+as accepted by @code{keymap-set}. In addition the key can be the
+special symbol @code{:menu}, in which case the definition should be a
+menu definition as accepted by @code{easy-menu-define} (@pxref{Easy
+Menu}). Here's a brief example:
+
+@lisp
+(define-keymap :full t
+ "g" #'eww-reload
+ :menu '("Eww"
+ ["Exit" quit-window t]
+ ["Reload" eww-reload t]))
+@end lisp
+
+A number of keywords can be used before the key/definition pairs to
+changes features of the new keymap. If the keyword is missing, the
+default value for the feature is @code{nil}. Here's a list of the
+available keywords:
+
+@table @code
+@item :full
+If non-@code{nil}, create a chartable keymap (as from
+@code{make-keymap}) instead of a sparse keymap (as from
+@code{make-sparse-keymap} (@pxref{Creating Keymaps}). A sparse keymap
+is the default.
+
+@item :parent
+If non-@code{nil}, this should be a keymap to use as the parent
+(@pxref{Inheritance and Keymaps}).
+
+@item :keymap
+If non-@code{nil}, this should be a keymap. Instead of creating a new
+keymap, this keymap is modified instead.
+
+@item :suppress
+If non-@code{nil}, the keymap will be suppressed with
+@code{suppress-keymap} (@pxref{Changing Key Bindings}). If
+@code{nodigits}, treat digits like other chars.
+
+@item :name
+If non-@code{nil}, this should be a string to use as the menu for the
+keymap if you use it as a menu with @code{x-popup-menu} (@pxref{Pop-Up
+Menus}).
+
+@item :prefix
+If non-@code{nil}, this should be a symbol to be used as a prefix
+command (@pxref{Prefix Keys}). If this is the case, this symbol is
+returned by @code{define-keymap} instead of the map itself.
+@end table
+
+@end defun
+
+@defmac defvar-keymap name &key options... &rest pairs...
+By far, the most common thing to do with a keymap is to bind it to a
+variable. This is what virtually all modes do---a mode called
+@code{foo} almost always has a variable called @code{foo-mode-map}.
+
+This macro defines @var{name} as a variable, and passes @var{options}
+and @var{pars} to @code{define-keymap}, and uses the result as the
+default value for the variable.
+
+@var{options} is like the keywords in @code{define-keymap}, but adds a
+@code{:doc} keyword that says what the doc string for the @var{name}
+variable should be.
+
+Here's an example:
+
+@lisp
+(defvar-keymap eww-textarea-map
+ :parent text-mode-map
+ "RET" #'forward-line
+ "TAB" #'shr-next-link)
+@end lisp
+@end defmac
+
The function @code{substitute-key-definition} scans a keymap for
keys that have a certain binding and rebinds them with a different
binding. Another feature which is cleaner and can often produce the
@@ -1485,13 +1566,181 @@ Modes}); then its keymap will automatically inherit from
(defvar special-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
- (define-key map "q" 'quit-window)
+ (keymap-set map "q" 'quit-window)
@dots{}
map))
@end group
@end smallexample
@end defun
+@node Low-Level Key Binding
+@section Low-Level Key Binding
+@cindex low-level key bindings
+
+ Historically, Emacs has supported a number of different syntaxes for
+defining keys. The documented way to bind a key today is to use the
+syntax supported by @code{key-valid-p}, which is what all the
+functions like @code{keymap-set} and @code{keymap-lookup} supports.
+This section documents the old-style syntax and interface functions;
+they should not be used in new code.
+
+@cindex meta character key constants
+@cindex control character key constants
+ @code{define-key} (and other low-level functions that are used to
+rebind keys) understand a number of different syntaxes for the keys.
+
+@table @asis
+@item A vector containing lists of keys.
+You can use a list containing modifier names plus one base event (a
+character or function key name). For example, @code{[(control ?a)
+(meta b)]} is equivalent to @kbd{C-a M-b} and @code{[(hyper control
+left)]} is equivalent to @kbd{C-H-left}.
+
+@item A string of characters with modifiers
+Internally, key sequences are often represented as strings using the
+special escape sequences for shift, control and meta modifiers
+(@pxref{String Type}), but this representation can also be used by
+users when rebinding keys. A string like @code{"\M-x"} is read as
+containing a single @kbd{M-x}, @code{"\C-f"} is read as containing a
+single @kbd{C-f}, and @code{"\M-\C-x"} and @code{"\C-\M-x"} are both
+read as containing a single @kbd{C-M-x}.
+
+@item A vector of characters and key symbols
+This is the other internal representation of key sequences. It
+supports a fuller range of modifiers than the string representation,
+and also support function keys. An example is @w{@samp{[?\C-\H-x
+home]}}, which represents the @w{@kbd{C-H-x @key{home}}} key sequence.
+@xref{Character Type}.
+@end table
+
+@defun define-key keymap key binding &optional remove
+This function is like @code{keymap-set} (@pxref{Changing Key
+Bindings}, but understands only the legacy key syntaxes.
+
+In addition, this function also has a @var{remove} argument. If it is
+non-@code{nil}, the definition will be removed. This is almost the
+same as setting the definition to @code{nil}, but makes a difference
+if the @var{keymap} has a parent, and @var{key} is shadowing the same
+binding in the parent. With @var{remove}, subsequent lookups will
+return the binding in the parent, and with a nil @var{def}, the
+lookups will return @code{nil}.
+@end defun
+
+Here are other legacy key definition functions and commands, with the
+equivalent modern function to use instead in new code.
+
+@deffn Command global-set-key key binding
+This function sets the binding of @var{key} in the current global map
+to @var{binding}. Use @code{keymap-global-set} instead.
+@end deffn
+
+@deffn Command global-unset-key key
+This function removes the binding of @var{key} from the current
+global map. Use @code{keymap-global-unset} instead.
+@end deffn
+
+@deffn Command local-set-key key binding
+This function sets the binding of @var{key} in the current local
+keymap to @var{binding}. Use @code{keymap-local-set} instead.
+@end deffn
+
+@deffn Command local-unset-key key
+This function removes the binding of @var{key} from the current
+local map. Use @code{keymap-local-unset} instead.
+@end deffn
+
+@defun substitute-key-definition olddef newdef keymap &optional oldmap
+This function replaces @var{olddef} with @var{newdef} for any keys in
+@var{keymap} that were bound to @var{olddef}. In other words,
+@var{olddef} is replaced with @var{newdef} wherever it appears. The
+function returns @code{nil}. Use @code{keymap-substitute} instead.
+@end defun
+
+@defun define-key-after map key binding &optional after
+Define a binding in @var{map} for @var{key}, with value @var{binding},
+just like @code{define-key}, but position the binding in @var{map} after
+the binding for the event @var{after}. The argument @var{key} should be
+of length one---a vector or string with just one element. But
+@var{after} should be a single event type---a symbol or a character, not
+a sequence. The new binding goes after the binding for @var{after}. If
+@var{after} is @code{t} or is omitted, then the new binding goes last, at
+the end of the keymap. However, new bindings are added before any
+inherited keymap. Use @code{keymap-set-after} instead of this function.
+@end defun
+
+@defun keyboard-translate from to
+This function modifies @code{keyboard-translate-table} to translate
+character code @var{from} into character code @var{to}. It creates
+the keyboard translate table if necessary. Use @code{key-translate}
+instead.
+@end defun
+
+@defun key-binding key &optional accept-defaults no-remap position
+This function returns the binding for @var{key} according to the
+current active keymaps. The result is @code{nil} if @var{key} is
+undefined in the keymaps. The argument @var{accept-defaults} controls
+checking for default bindings, as in @code{lookup-key}
+(@pxref{Functions for Key Lookup}). If @var{no-remap} is
+non-@code{nil}, @code{key-binding} ignores command remappings
+(@pxref{Remapping Commands}) and returns the binding directly
+specified for @var{key}. The optional argument @var{position} should
+be either a buffer position or an event position like the value of
+@code{event-start}; it tells the function to consult the maps
+determined based on that @var{position}.
+
+Emacs signals an error if @var{key} is not a string or a vector.
+
+Use @code{keymap-lookup} instead of this function.
+@end defun
+
+@defun lookup-key keymap key &optional accept-defaults
+This function returns the definition of @var{key} in @var{keymap}. If
+the string or vector @var{key} is not a valid key sequence according
+to the prefix keys specified in @var{keymap}, it must be too long and
+have extra events at the end that do not fit into a single key
+sequence. Then the value is a number, the number of events at the
+front of @var{key} that compose a complete key.
+
+If @var{accept-defaults} is non-@code{nil}, then @code{lookup-key}
+considers default bindings as well as bindings for the specific events
+in @var{key}. Otherwise, @code{lookup-key} reports only bindings for
+the specific sequence @var{key}, ignoring default bindings except when
+you explicitly ask about them.
+
+Use @code{keymap-lookup} instead of this function.
+@end defun
+
+@defun local-key-binding key &optional accept-defaults
+This function returns the binding for @var{key} in the current
+local keymap, or @code{nil} if it is undefined there.
+
+The argument @var{accept-defaults} controls checking for default bindings,
+as in @code{lookup-key} (above).
+@end defun
+
+@defun global-key-binding key &optional accept-defaults
+This function returns the binding for command @var{key} in the
+current global keymap, or @code{nil} if it is undefined there.
+
+The argument @var{accept-defaults} controls checking for default bindings,
+as in @code{lookup-key} (above).
+@end defun
+
+@defun event-convert-list list
+This function converts a list of modifier names and a basic event type
+to an event type which specifies all of them. The basic event type
+must be the last element of the list. For example,
+
+@example
+(event-convert-list '(control ?a))
+ @result{} 1
+(event-convert-list '(control meta ?a))
+ @result{} -134217727
+(event-convert-list '(control super f1))
+ @result{} C-s-f1
+@end example
+@end defun
+
@node Remapping Commands
@section Remapping Commands
@cindex remapping commands
@@ -1510,7 +1759,7 @@ definition for a key binding).
the following remapping:
@smallexample
-(define-key my-mode-map [remap kill-line] 'my-kill-line)
+(keymap-set my-mode-map "<remap> <kill-line>" 'my-kill-line)
@end smallexample
@noindent
@@ -1525,8 +1774,8 @@ In addition, remapping only works through a single level; in the
following example,
@smallexample
-(define-key my-mode-map [remap kill-line] 'my-kill-line)
-(define-key my-mode-map [remap my-kill-line] 'my-other-kill-line)
+(keymap-set my-mode-map "<remap> <kill-line>" 'my-kill-line)
+(keymap-set my-mode-map "<remap> <my-kill-line>" 'my-other-kill-line)
@end smallexample
@noindent
@@ -1538,7 +1787,7 @@ remapped to @code{my-kill-line}; if an ordinary binding specifies
To undo the remapping of a command, remap it to @code{nil}; e.g.,
@smallexample
-(define-key my-mode-map [remap kill-line] nil)
+(keymap-set my-mode-map "<remap> <kill-line>" nil)
@end smallexample
@defun command-remapping command &optional position keymaps
@@ -1670,7 +1919,7 @@ to turn the character that follows into a Hyper character:
symbol
(cons symbol (cdr e)))))
-(define-key local-function-key-map "\C-ch" 'hyperify)
+(keymap-set local-function-key-map "C-c h" 'hyperify)
@end group
@end example
@@ -1700,34 +1949,20 @@ problematic suffixes/prefixes are @kbd{@key{ESC}}, @kbd{M-O} (which is really
@section Commands for Binding Keys
This section describes some convenient interactive interfaces for
-changing key bindings. They work by calling @code{define-key}.
+changing key bindings. They work by calling @code{keymap-set}.
- People often use @code{global-set-key} in their init files
+ People often use @code{keymap-global-set} in their init files
(@pxref{Init File}) for simple customization. For example,
@smallexample
-(global-set-key (kbd "C-x C-\\") 'next-line)
-@end smallexample
-
-@noindent
-or
-
-@smallexample
-(global-set-key [?\C-x ?\C-\\] 'next-line)
-@end smallexample
-
-@noindent
-or
-
-@smallexample
-(global-set-key [(control ?x) (control ?\\)] 'next-line)
+(keymap-global-set "C-x C-\\" 'next-line)
@end smallexample
@noindent
redefines @kbd{C-x C-\} to move down a line.
@smallexample
-(global-set-key [M-mouse-1] 'mouse-set-point)
+(keymap-global-set "M-<mouse-1>" 'mouse-set-point)
@end smallexample
@noindent
@@ -1741,14 +1976,7 @@ they usually will be in a Lisp file (@pxref{Loading Non-ASCII}), you
must type the keys as multibyte too. For instance, if you use this:
@smallexample
-(global-set-key "ö" 'my-function) ; bind o-umlaut
-@end smallexample
-
-@noindent
-or
-
-@smallexample
-(global-set-key ?ö 'my-function) ; bind o-umlaut
+(keymap-global-set "ö" 'my-function) ; bind o-umlaut
@end smallexample
@noindent
@@ -1759,20 +1987,20 @@ binding, you need to teach Emacs how to decode the keyboard by using an
appropriate input method (@pxref{Input Methods, , Input Methods, emacs, The GNU
Emacs Manual}).
-@deffn Command global-set-key key binding
+@deffn Command keymap-global-set key binding
This function sets the binding of @var{key} in the current global map
to @var{binding}.
@smallexample
@group
-(global-set-key @var{key} @var{binding})
+(keymap-global-set @var{key} @var{binding})
@equiv{}
-(define-key (current-global-map) @var{key} @var{binding})
+(keymap-set (current-global-map) @var{key} @var{binding})
@end group
@end smallexample
@end deffn
-@deffn Command global-unset-key key
+@deffn Command keymap-global-unset key
@cindex unbinding keys
This function removes the binding of @var{key} from the current
global map.
@@ -1783,50 +2011,32 @@ that uses @var{key} as a prefix---which would not be allowed if
@smallexample
@group
-(global-unset-key "\C-l")
+(keymap-global-unset "C-l")
@result{} nil
@end group
@group
-(global-set-key "\C-l\C-l" 'redraw-display)
+(keymap-global-set "C-l C-l" 'redraw-display)
@result{} nil
@end group
@end smallexample
-
-This function is equivalent to using @code{define-key} as follows:
-
-@smallexample
-@group
-(global-unset-key @var{key})
-@equiv{}
-(define-key (current-global-map) @var{key} nil)
-@end group
-@end smallexample
@end deffn
-@deffn Command local-set-key key binding
+@deffn Command keymap-local-set key binding
This function sets the binding of @var{key} in the current local
keymap to @var{binding}.
@smallexample
@group
-(local-set-key @var{key} @var{binding})
+(keymap-local-set @var{key} @var{binding})
@equiv{}
-(define-key (current-local-map) @var{key} @var{binding})
+(keymap-set (current-local-map) @var{key} @var{binding})
@end group
@end smallexample
@end deffn
-@deffn Command local-unset-key key
+@deffn Command keymap-local-unset key
This function removes the binding of @var{key} from the current
local map.
-
-@smallexample
-@group
-(local-unset-key @var{key})
-@equiv{}
-(define-key (current-local-map) @var{key} nil)
-@end group
-@end smallexample
@end deffn
@node Scanning Keymaps
@@ -2227,6 +2437,12 @@ This property specifies that @var{string} is the string to display
as the keyboard equivalent for this menu item. You can use
the @samp{\\[...]} documentation construct in @var{string}.
+This property can also be a function (which will be called with no
+arguments). This function should return a string. This function will
+be called every time the menu is computed, so using a function that
+takes a lot of time to compute is not a good idea, and it should
+expect to be called from any context.
+
@item :filter @var{filter-fn}
This property provides a way to compute the menu item dynamically.
The property value @var{filter-fn} should be a function of one argument;
@@ -2675,9 +2891,9 @@ using an indirection through @code{tool-bar-map}.
By default, the global map binds @code{[tool-bar]} as follows:
@example
-(global-set-key [tool-bar]
- `(menu-item ,(purecopy "tool bar") ignore
- :filter tool-bar-make-keymap))
+(keymap-global-set "<tool-bar>"
+ `(menu-item ,(purecopy "tool bar") ignore
+ :filter tool-bar-make-keymap))
@end example
@noindent
diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi
index 4d683da1ad3..ee119445e56 100644
--- a/doc/lispref/loading.texi
+++ b/doc/lispref/loading.texi
@@ -552,7 +552,7 @@ An autoloaded keymap loads automatically during key lookup when a prefix
key's binding is the symbol @var{function}. Autoloading does not occur
for other kinds of access to the keymap. In particular, it does not
happen when a Lisp program gets the keymap from the value of a variable
-and calls @code{define-key}; not even if the variable name is the same
+and calls @code{keymap-set}; not even if the variable name is the same
symbol @var{function}.
@cindex function cell in autoload
@@ -1156,7 +1156,7 @@ You don't need to give a directory or extension in the file name
@var{library}. Normally, you just give a bare file name, like this:
@example
-(with-eval-after-load "js" (define-key js-mode-map "\C-c\C-c" 'js-eval))
+(with-eval-after-load "js" (keymap-set js-mode-map "C-c C-c" 'js-eval))
@end example
To restrict which files can trigger the evaluation, include a
diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi
index 5df3a74e780..69c022e5253 100644
--- a/doc/lispref/modes.texi
+++ b/doc/lispref/modes.texi
@@ -269,6 +269,18 @@ normal-mode}), but tries to force it not to choose any modes in
@var{avoided-modes}, if that argument is non-@code{nil}.
@end defun
+@defun clean-mode
+Changing the major mode clears out most local variables, but it
+doesn't remove all artefacts in the buffer (like text properties and
+overlays). It's rare to change a buffer from one major mode to
+another (except from @code{fundamental-mode} to everything else), so
+this is usually not a concern. It can sometimes be convenient (mostly
+when debugging a problem in a buffer) to do a ``full reset'' of the
+buffer, and that's what the @code{clean-mode} major mode offers. It
+will kill all local variables (even the permanently local ones), and
+also removes all overlays and text properties.
+@end defun
+
The easiest way to write a major mode is to use the macro
@code{define-derived-mode}, which sets up the new mode as a variant of
an existing major mode. @xref{Derived Modes}. We recommend using
@@ -904,10 +916,8 @@ which in turn may have been changed in a mode hook.
Here is a hypothetical example:
@example
-(defvar hypertext-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [down-mouse-3] 'do-hyper-link)
- map))
+(defvar-keymap hypertext-mode-map
+ "<down-mouse-3>" #'do-hyper-link)
(define-derived-mode hypertext-mode
text-mode "Hypertext"
@@ -1138,10 +1148,11 @@ re-sorting entries. Comparison is done with @code{equal}.
@item
@var{contents} is a vector with the same number of elements as
@code{tabulated-list-format}. Each vector element is either a string,
-which is inserted into the buffer as-is, or a list @code{(@var{label}
-. @var{properties})}, which means to insert a text button by calling
-@code{insert-text-button} with @var{label} and @var{properties} as
-arguments (@pxref{Making Buttons}).
+which is inserted into the buffer as-is; an image descriptor, which is
+used to insert an image (@pxref{Image Descriptors}); or a list
+@w{@code{(@var{label} . @var{properties})}}, which means to insert a
+text button by calling @code{insert-text-button} with @var{label} and
+@var{properties} as arguments (@pxref{Making Buttons}).
There should be no newlines in any of these strings.
@end itemize
@@ -1331,11 +1342,9 @@ the conventions listed above:
;; @r{Create the keymap for this mode.}
@group
-(defvar text-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\e\t" 'ispell-complete-word)
- @dots{}
- map)
+(defvar-keymap text-mode-map
+ "C-M-i" #'ispell-complete-word
+ @dots{})
"Keymap for `text-mode'.
Many other modes, such as `mail-mode', `outline-mode' and
`indented-text-mode', inherit all the commands defined in this map.")
@@ -1408,13 +1417,11 @@ common. The following code sets up the common commands:
@smallexample
@group
-(defvar lisp-mode-shared-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map prog-mode-map)
- (define-key map "\e\C-q" 'indent-sexp)
- (define-key map "\177" 'backward-delete-char-untabify)
- map)
- "Keymap for commands shared by all sorts of Lisp modes.")
+(defvar-keymap lisp-mode-shared-map
+ :parent prog-mode-map
+ :doc "Keymap for commands shared by all sorts of Lisp modes."
+ "C-M-q" #'indent-sexp
+ "DEL" #'backward-delete-char-untabify)
@end group
@end smallexample
@@ -1423,16 +1430,12 @@ And here is the code to set up the keymap for Lisp mode:
@smallexample
@group
-(defvar lisp-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap "Lisp")))
- (set-keymap-parent map lisp-mode-shared-map)
- (define-key map "\e\C-x" 'lisp-eval-defun)
- (define-key map "\C-c\C-z" 'run-lisp)
- @dots{}
- map)
- "Keymap for ordinary Lisp mode.
-All commands in `lisp-mode-shared-map' are inherited by this map.")
+(defvar-keymap lisp-mode-map
+ :doc "Keymap for ordinary Lisp mode.
+All commands in `lisp-mode-shared-map' are inherited by this map."
+ :parent lisp-mode-shared-map
+ "C-M-x" #'lisp-eval-defun
+ "C-c C-z" #'run-lisp)
@end group
@end smallexample
diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi
index 0551bb5673f..bbd3973f61b 100644
--- a/doc/lispref/objects.texi
+++ b/doc/lispref/objects.texi
@@ -1535,6 +1535,7 @@ editing.
* Keymap Type:: What function a keystroke invokes.
* Overlay Type:: How an overlay is represented.
* Font Type:: Fonts for displaying text.
+* Xwidget Type:: Embeddable widgets.
@end menu
@node Buffer Type
@@ -1860,6 +1861,20 @@ syntax looks like @samp{#<font-object>}, @samp{#<font-spec>}, and
@samp{#<font-entity>} respectively. @xref{Low-Level Font}, for a
description of these Lisp objects.
+@node Xwidget Type
+@subsection Xwidget Type
+@cindex xwidget type
+@cindex xwidget-view type
+
+ An @dfn{xwidget} is a special display element, such as a web
+browser, that can be embedded inside a buffer. Each window that
+displays an xwidget will also have an @dfn{xwidget view}, which on
+X-Windows corresponds to a single X window used to display the widget.
+
+Neither of these objects are readable; their print syntaxes look like
+@samp{#<xwidget>} and @samp{#<xwidget-view>}, respectively.
+@xref{Xwidgets}, for a more detailed description of xwidgets.
+
@node Circular Objects
@section Read Syntax for Circular Objects
@cindex circular structure, read syntax
diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi
index db986178dd8..de76ab4884a 100644
--- a/doc/lispref/os.texi
+++ b/doc/lispref/os.texi
@@ -947,6 +947,9 @@ actually Linux is just the kernel, not the whole system.)
@item gnu/kfreebsd
A GNU (glibc-based) system with a FreeBSD kernel.
+@item haiku
+The Haiku operating system, a derivative of the Be Operating System.
+
@item hpux
Hewlett-Packard HPUX operating system.
@@ -1349,7 +1352,7 @@ may change as higher-resolution clocks become available.
@cindex time value
Function arguments, e.g., the @var{time} argument to
-@code{current-time-string}, accept a more-general @dfn{time value}
+@code{format-time-string}, accept a more-general @dfn{time value}
format, which can be a Lisp timestamp, @code{nil} for the current
time, a single floating-point number for seconds, or a list
@code{(@var{high} @var{low} @var{micro})} or @code{(@var{high}
@@ -1504,10 +1507,7 @@ The optional @var{form} argument specifies the timestamp form to be
returned. If @var{form} is the symbol @code{integer}, this function
returns an integer count of seconds. If @var{form} is a positive
integer, it specifies a clock frequency and this function returns an
-integer-pair timestamp @code{(@var{ticks}
-. @var{form})}.@footnote{Currently a positive integer @var{form}
-should be at least 65536 if the returned value is intended to be given
-to standard functions expecting Lisp timestamps.} If @var{form} is
+integer-pair timestamp @code{(@var{ticks} . @var{form})}. If @var{form} is
@code{t}, this function treats it as a positive integer suitable for
representing the timestamp; for example, it is treated as 1000000000
if @var{time} is nil and the platform timestamp has nanosecond
@@ -1721,7 +1721,8 @@ This function parses the time-string @var{string} and returns the
corresponding Lisp timestamp. The argument @var{string} should represent
a date-time, and should be in one of the forms recognized by
@code{parse-time-string} (see below). This function assumes Universal
-Time if @var{string} lacks explicit time zone information.
+Time if @var{string} lacks explicit time zone information,
+and assumes earliest values if @var{string} lacks month, day, or time.
The operating system limits the range of time and zone values.
@end defun
@@ -2180,7 +2181,13 @@ In most cases, @var{repeat} has no effect on when @emph{first} call
takes place---@var{time} alone specifies that. There is one exception:
if @var{time} is @code{t}, then the timer runs whenever the time is a
multiple of @var{repeat} seconds after the epoch. This is useful for
-functions like @code{display-time}.
+functions like @code{display-time}. For instance, the following will
+make @var{function} run at every ``whole'' minute (e.g.,
+@samp{11:03:00}, @samp{11:04:00}, etc):
+
+@example
+(run-at-time t 60 @var{function})
+@end example
If Emacs didn't get any CPU time when the timer would have run (for
example if the system was busy running another process or if the
@@ -3231,6 +3238,14 @@ Removes an existing file watch specified by its @var{descriptor}.
@code{file-notify-add-watch}.
@end defun
+@deffn Command file-notify-rm-all-watches
+Removes all existing file notification watches from Emacs.
+
+Use this command with caution, because it could have unexpected side
+effects on packages relying on file watches. It is intended mainly
+for debugging purposes, or when Emacs has been stalled.
+@end deffn
+
@defun file-notify-valid-p descriptor
Checks a watch specified by its @var{descriptor} for validity.
@var{descriptor} should be an object returned by
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index 8a9cb2a8f88..ac5d4d16277 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -966,6 +966,15 @@ use the function @code{process-tty-name} (@pxref{Process
Information}).
@end defvar
+@defvar process-error-pause-time
+If a process sentinel/filter function has an error, Emacs will (by
+default) pause Emacs for @code{process-error-pause-time} seconds after
+displaying this error, so that users will see the error in question.
+However, this can lead to situations where Emacs becomes unresponsive
+(if there's a lot of these errors happening), so this can be disabled
+by setting @code{process-error-pause-time} to 0.
+@end defvar
+
@node Deleting Processes
@section Deleting Processes
@cindex deleting processes
diff --git a/doc/lispref/searching.texi b/doc/lispref/searching.texi
index ce79765b733..296ce20169c 100644
--- a/doc/lispref/searching.texi
+++ b/doc/lispref/searching.texi
@@ -2045,7 +2045,7 @@ feature for matching regular expressions from end to beginning. It's
not worth the trouble of implementing that.
@end deffn
-@defun string-match regexp string &optional start
+@defun string-match regexp string &optional start inhibit-modify
This function returns the index of the start of the first match for
the regular expression @var{regexp} in @var{string}, or @code{nil} if
there is no match. If @var{start} is non-@code{nil}, the search starts
@@ -2070,8 +2070,10 @@ For example,
The index of the first character of the
string is 0, the index of the second character is 1, and so on.
-If this function finds a match, the index of the first character beyond
-the match is available as @code{(match-end 0)}. @xref{Match Data}.
+By default, if this function finds a match, the index of the first
+character beyond the match is available as @code{(match-end 0)}.
+@xref{Match Data}. If @var{inhibit-modify} is non-@code{nil}, the
+match data isn't modified.
@example
@group
@@ -2092,16 +2094,18 @@ This predicate function does what @code{string-match} does, but it
avoids modifying the match data.
@end defun
-@defun looking-at regexp
+@defun looking-at regexp &optional inhibit-modify
This function determines whether the text in the current buffer directly
following point matches the regular expression @var{regexp}. ``Directly
following'' means precisely that: the search is ``anchored'' and it can
succeed only starting with the first character following point. The
result is @code{t} if so, @code{nil} otherwise.
-This function does not move point, but it does update the match data.
-@xref{Match Data}. If you need to test for a match without modifying
-the match data, use @code{looking-at-p}, described below.
+This function does not move point, but it does update the match data
+(if @var{inhibit-modify} is @code{nil} or missing, which is the
+default). @xref{Match Data}. As a convenience, instead of using the
+@var{inhibit-modify} argument, you can use @code{looking-at-p},
+described below.
In this example, point is located directly before the @samp{T}. If it
were anywhere else, the result would be @code{nil}.
@@ -2208,13 +2212,13 @@ backtracking specified by the POSIX standard for regular expression
matching.
@end deffn
-@defun posix-looking-at regexp
+@defun posix-looking-at regexp &optional inhibit-modify
This is like @code{looking-at} except that it performs the full
backtracking specified by the POSIX standard for regular expression
matching.
@end defun
-@defun posix-string-match regexp string &optional start
+@defun posix-string-match regexp string &optional start inhibit-modify
This is like @code{string-match} except that it performs the full
backtracking specified by the POSIX standard for regular expression
matching.
diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi
index 7212677d832..0914f204113 100644
--- a/doc/lispref/strings.texi
+++ b/doc/lispref/strings.texi
@@ -430,8 +430,8 @@ middle of a character representation.
This function measures the string length in characters or bytes, and
thus is generally inappropriate if you need to shorten strings for
display purposes; use @code{truncate-string-to-width} or
-@code{window-text-pixel-size} instead (@pxref{Size of Displayed
-Text}).
+@code{window-text-pixel-size} or @code{string-glyph-split} instead
+(@pxref{Size of Displayed Text}).
@end defun
@defun string-lines string &optional omit-nulls
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index f66cdfdbd19..5ab5e5715f0 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -60,6 +60,7 @@ the character after point.
* Base 64:: Conversion to or from base 64 encoding.
* Checksum/Hash:: Computing cryptographic hashes.
* GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS.
+* Database:: Interacting with an SQL database.
* Parsing HTML/XML:: Parsing HTML and XML.
* Parsing JSON:: Parsing and generating JSON values.
* JSONRPC:: JSON Remote Procedure Call protocol
@@ -599,6 +600,19 @@ This command indents to the left margin if that is not zero.
The value returned is @code{nil}.
@end deffn
+@deffn Command ensure-empty-lines &optional number-of-empty-lines
+This command can be used to ensure that you have a specific number of
+empty lines before point. (An ``empty line'' is here defined as a
+line with no characters on it---a line with space characters isn't an
+empty line.) It defaults to ensuring that there's a single empty line
+before point.
+
+If point isn't at the beginning of a line, a newline character is
+inserted first. If there's more empty lines before point than
+specified, the number of empty lines is reduced. Otherwise it's
+increased to the specified number.
+@end deffn
+
@defvar overwrite-mode
This variable controls whether overwrite mode is in effect. The value
should be @code{overwrite-mode-textual}, @code{overwrite-mode-binary},
@@ -1329,7 +1343,7 @@ that @kbd{C-y} should yank.
@defopt kill-ring-max
The value of this variable is the maximum length to which the kill
ring can grow, before elements are thrown away at the end. The default
-value for @code{kill-ring-max} is 60.
+value for @code{kill-ring-max} is 120.
@end defopt
@node Undo
@@ -1493,6 +1507,11 @@ continuing to undo.
This function does not bind @code{undo-in-progress}.
@end defun
+@defmac with-undo-amalgamate body@dots{}
+This macro removes all the undo boundaries inserted during the
+execution of @var{body} so that it can be undone as a single step.
+@end defmac
+
Some commands leave the region active after execution in such a way that
it interferes with selective undo of that command. To make @code{undo}
ignore the active region when invoked immediately after such a command,
@@ -1633,6 +1652,47 @@ The variable @code{paragraph-separate} controls how to distinguish
paragraphs. @xref{Standard Regexps}.
@end deffn
+@defun pixel-fill-region start end pixel-width
+Most Emacs buffers use monospaced text, so all the filling functions
+(like @code{fill-region}) work based on the number of characters and
+@code{char-width}. However, Emacs can render other types of things,
+like text that contains images and using proportional fonts, and the
+@code{pixel-fill-region} exists to handle that. It fills the region
+of text between @var{start} and @var{end} at pixel granularity, so
+text using variable-pitch fonts or several different fonts looks
+filled regardless of different character sizes. The argument
+@var{pixel-width} specifies the maximum pixel width a line is allowed
+to have after filling; it is the pixel-resolution equivalent of the
+@code{fill-column} in @code{fill-region}. For instance, this Lisp
+snippet will insert text using a proportional font, and then fill this
+to be no wider than 300 pixels:
+
+@lisp
+(insert (propertize
+ "This is a sentence that's ends here."
+ 'face 'variable-pitch))
+(pixel-fill-region (point) (point-max) 300)
+@end lisp
+
+If @var{start} isn't at the start of a line, the horizontal position
+of @var{start}, converted to pixel units, will be used as the
+indentation prefix on subsequent lines.
+
+@findex pixel-fill-width
+The @code{pixel-fill-width} helper function can be used to compute the
+pixel width to use. If given no arguments, it'll return a value
+slightly less than the width of the current window. The first
+optional value, @var{columns}, specifies the number of columns using
+the standard, monospaced fonts, e.g. @code{fill-column}. The second
+optional value is the window to use. You'd typically use it like
+this:
+
+@lisp
+(pixel-fill-region
+ start end (pixel-fill-width fill-column))
+@end lisp
+@end defun
+
@deffn Command fill-individual-paragraphs start end &optional justify citation-regexp
This command fills each paragraph in the region according to its
individual fill prefix. Thus, if the lines of a paragraph were indented
@@ -3602,6 +3662,11 @@ edited even in read-only buffers. @xref{Read Only Buffers}.
A non-@code{nil} @code{invisible} property can make a character invisible
on the screen. @xref{Invisible Text}, for details.
+@kindex inhibit-isearch @r{(text property)}
+@item inhibit-isearch
+A non-@code{nil} @code{inhibit-isearch} property will make isearch
+skip the text.
+
@item intangible
@kindex intangible @r{(text property)}
If a group of consecutive characters have equal and non-@code{nil}
@@ -3627,9 +3692,20 @@ property is obsolete; use the @code{cursor-intangible} property instead.
@item cursor-intangible
@kindex cursor-intangible @r{(text property)}
@findex cursor-intangible-mode
+@cindex rear-nonsticky, and cursor-intangible property
When the minor mode @code{cursor-intangible-mode} is turned on, point
is moved away from any position that has a non-@code{nil}
@code{cursor-intangible} property, just before redisplay happens.
+Note that ``stickiness'' of the property (@pxref{Sticky Properties})
+is taken into account when computing allowed cursor positions, so (for
+instance) to insert a stretch of five @samp{x} characters into which
+the cursor can't enter, you should do something like:
+
+@lisp
+(insert
+ (propertize "xxxx" 'cursor-intangible t)
+ (propertize "x" 'cursor-intangible t 'rear-nonsticky t))
+@end lisp
@vindex cursor-sensor-inhibit
When the variable @code{cursor-sensor-inhibit} is non-@code{nil}, the
@@ -3936,6 +4012,8 @@ of the kill ring. To insert with inheritance, use the special
primitives described in this section. Self-inserting characters
inherit properties because they work using these primitives.
+@cindex front-sticky text property
+@cindex rear-nonsticky text property
When you do insertion with inheritance, @emph{which} properties are
inherited, and from where, depends on which properties are @dfn{sticky}.
Insertion after a character inherits those of its properties that are
@@ -4168,7 +4246,7 @@ position. The action code is always @code{t}.
For example, here is how Info mode handles @key{mouse-1}:
@smallexample
-(define-key Info-mode-map [follow-link] 'mouse-face)
+(keymap-set Info-mode-map "<follow-link>" 'mouse-face)
@end smallexample
@item a function
@@ -4181,9 +4259,9 @@ For example, here is how pcvs enables @kbd{mouse-1} to follow links on
file names only:
@smallexample
-(define-key map [follow-link]
- (lambda (pos)
- (eq (get-char-property pos 'face) 'cvs-filename-face)))
+(keymap-set map "<follow-link>"
+ (lambda (pos)
+ (eq (get-char-property pos 'face) 'cvs-filename-face)))
@end smallexample
@item anything else
@@ -5058,6 +5136,177 @@ On success, it returns a list of a binary string (the output) and the
IV used.
@end defun
+@node Database
+@section Database
+@cindex database access, SQLite
+
+ Emacs can be compiled with built-in support for accessing SQLite
+databases. This section describes the facilities available for
+accessing SQLite databases from Lisp programs.
+
+@defun sqlite-available-p
+The function returns non-@code{nil} if built-in SQLite support is
+available in this Emacs session.
+@end defun
+
+When SQLite support is available, the following functions can be used.
+
+@cindex database object
+@defun sqlite-open &optional file
+This function opens @var{file} as an SQLite database file. If
+@var{file} doesn't exist, a new database will be created and stored in
+that file. If @var{file} is omitted or @code{nil}, a new in-memory
+database is created instead.
+
+The return value is a @dfn{database object} that can be used as the
+argument to most of the subsequent functions described below.
+@end defun
+
+@defun sqlitep object
+This predicate returns non-@code{nil} if @var{object} is an SQLite
+database object. The database object returned by the
+@code{sqlite-open} function satisfies this predicate.
+@end defun
+
+@defun sqlite-close db
+Close the database @var{db}. It's usually not necessary to call this
+function explicitly---the database will automatically be closed if
+Emacs shuts down or the database object is garbage collected.
+@end defun
+
+@defun sqlite-execute db statement &optional values
+Execute the @acronym{SQL} @var{statement}. For instance:
+
+@lisp
+(sqlite-execute db "insert into foo values ('bar', 2)")
+@end lisp
+
+If the optional @var{values} parameter is present, it should be either
+a list or a vector of values to bind while executing the statement.
+For instance:
+
+@lisp
+(sqlite-execute db "insert into foo values (?, ?)" '("bar" 2))
+@end lisp
+
+This has exactly the same effect as the previous example, but is more
+efficient and safer (because it doesn't involve any string parsing or
+interpolation).
+
+@code{sqlite-execute} returns the number of affected rows. For
+instance, an @samp{insert} statement will return @samp{1}, whereas an
+@samp{update} statement may return zero or a higher number.
+@end defun
+
+@defun sqlite-select db query &optional values result-type
+Select some data from @var{db} and return them. For instance:
+
+@lisp
+(sqlite-select db "select * from foo where key = 2")
+ @result{} (("bar" 2))
+@end lisp
+
+As with the @code{sqlite-execute}, you can optionally pass in a list
+or a vector of values that will be bound before executing the select:
+
+@lisp
+(sqlite-select db "select * from foo where key = ?" [2])
+ @result{} (("bar" 2))
+@end lisp
+
+This is usually more efficient and safer than the method used by the
+previous example.
+
+By default, this function returns a list of matching rows, where each
+row is a list of column values. If @var{return-type} is @code{full},
+the names of the columns (as a list of strings) will be returned as
+the first element in the return value.
+
+@cindex statement object
+If @var{return-type} is @code{set}, this function will return a
+@dfn{statement object} instead. This object can be examined by using
+the @code{sqlite-next}, @code{sqlite-columns} and @code{sqlite-more-p}
+functions. If the result set is small, it's often more convenient to
+just return the data directly, but if the result set is large (or if
+you won't be using all the data from the set), using the @code{set}
+method will allocate a lot less memory, and is therefore more
+memory-efficient.
+@end defun
+
+@defun sqlite-next statement
+This function returns the next row in the result set @var{statement},
+typically an object returned by @code{sqlite-select}.
+
+@lisp
+(sqlite-next stmt)
+ @result{} ("bar" 2)
+@end lisp
+@end defun
+
+@defun sqlite-columns statement
+This function returns the column names of the result set
+@var{statement}, typically an object returned by @code{sqlite-select}.
+
+@lisp
+(sqlite-columns stmt)
+ @result{} ("name" "issue")
+@end lisp
+@end defun
+
+@defun sqlite-more-p statement
+This predicate says whether there is more data to be fetched from the
+result set @var{statement}, typically an object returned by
+@code{sqlite-select}.
+@end defun
+
+@defun sqlite-finalize statement
+If @var{statement} is not going to be used any more, calling this
+function will free the resources used by @var{statement}. This is
+usually not necessary---when the @var{statement} object is
+garbage-collected, Emacs will automatically free its resources.
+@end defun
+
+@defun sqlite-transaction db
+Start a transaction in @var{db}. When in a transaction, other readers
+of the database won't access the results until the transaction has
+been committed by @code{sqlite-commit}.
+@end defun
+
+@defun sqlite-commit db
+End a transaction in @var{db} and write the data out to its file.
+@end defun
+
+@defun sqlite-rollback db
+End a transaction in @var{db} and discard any changes that have been
+made by the transaction.
+@end defun
+
+@defmac with-sqlite-transaction db body@dots{}
+Like @code{progn} (@pxref{Sequencing}), but executes @var{body} with a
+transaction held, and commits the transaction at the end.
+@end defmac
+
+@defun sqlite-pragma db pragma
+Execute @var{pragma} in @var{db}. A @dfn{pragma} is usually a command
+that affects the database overall, instead of any particular table.
+For instance, to make SQLite automatically garbage collect data that's
+no longer needed, you can say:
+
+@lisp
+(sqlite-pragma db "auto_vacuum = FULL")
+@end lisp
+
+This function returns non-@code{nil} on success and @code{nil} if the
+pragma failed. Many pragmas can only be issued when the database is
+brand new and empty.
+@end defun
+
+@defun sqlite-load-extension db module
+Load the named extension @var{module} into the database @var{db}.
+Extensions are usually shared-library files; on GNU and Unix systems,
+they have the @file{.so} file-name extension.
+@end defun
+
@node Parsing HTML/XML
@section Parsing HTML and XML
@cindex parsing html
diff --git a/doc/lispref/tips.texi b/doc/lispref/tips.texi
index fa764f18b5c..cbfcbd8d14f 100644
--- a/doc/lispref/tips.texi
+++ b/doc/lispref/tips.texi
@@ -252,6 +252,13 @@ themselves; Lisp programmers find this disconcerting.
Please put a copyright notice and copying permission notice on the
file if you distribute copies. @xref{Library Headers}.
+@item
+For variables holding (or functions returning) a file or directory name,
+avoid using @code{path} in its name, preferring @code{file},
+@code{file-name}, or @code{directory} instead, since Emacs follows the
+GNU convention to use the term @emph{path} only for search paths,
+which are lists of directory names.
+
@end itemize
@node Key Binding Conventions
diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi
index a1d1919b4bf..98a9487aea9 100644
--- a/doc/lispref/variables.texi
+++ b/doc/lispref/variables.texi
@@ -44,6 +44,7 @@ representing the variable.
* Variables with Restricted Values:: Non-constant variables whose value can
@emph{not} be an arbitrary Lisp object.
* Generalized Variables:: Extending the concept of variables.
+* Multisession Variables:: Variables that survive restarting Emacs.
@end menu
@node Global Variables
@@ -363,7 +364,7 @@ where you are in Emacs.
@cindex evaluation error
@cindex infinite recursion
This variable defines the limit on the total number of local variable
-bindings and @code{unwind-protect} cleanups (see @ref{Cleanups,,
+bindings and @code{unwind-protect} cleanups (@pxref{Cleanups,,
Cleaning Up from Nonlocal Exits}) that are allowed before Emacs
signals an error (with data @code{"Variable binding depth exceeds
max-specpdl-size"}).
@@ -686,7 +687,7 @@ entire computation of the value into the @code{defvar}, like this:
@example
(defvar my-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-a" 'my-command)
+ (keymap-set map "C-c C-a" 'my-command)
@dots{}
map)
@var{docstring})
@@ -702,25 +703,6 @@ important if the user has run hooks to alter part of the contents
(such as, to rebind keys). Third, evaluating the @code{defvar} form
with @kbd{C-M-x} will reinitialize the map completely.
- Putting so much code in the @code{defvar} form has one disadvantage:
-it puts the documentation string far away from the line which names the
-variable. Here's a safe way to avoid that:
-
-@example
-(defvar my-mode-map nil
- @var{docstring})
-(unless my-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-a" 'my-command)
- @dots{}
- (setq my-mode-map map)))
-@end example
-
-@noindent
-This has all the same advantages as putting the initialization inside
-the @code{defvar}, except that you must type @kbd{C-M-x} twice, once on
-each form, if you do want to reinitialize the variable.
-
@node Accessing Variables
@section Accessing Variable Values
@@ -1695,12 +1677,14 @@ buffer-local variables interactively.
@end deffn
@cindex local variables, killed by major mode
-@defun kill-all-local-variables
+@defun kill-all-local-variables &optional kill-permanent
This function eliminates all the buffer-local variable bindings of the
-current buffer except for variables marked as permanent and local
-hook functions that have a non-@code{nil} @code{permanent-local-hook}
-property (@pxref{Setting Hooks}). As a result, the buffer will see
-the default values of most variables.
+current buffer. As a result, the buffer will see the default values
+of most variables. By default, for variables marked as permanent and
+local hook functions that have a non-@code{nil}
+@code{permanent-local-hook} property (@pxref{Setting Hooks}) won't be
+killed, but if the optional @var{kill-permanent} argument is
+non-@code{nil}, even these variables will be killed.
This function also resets certain other information pertaining to the
buffer: it sets the local keymap to @code{nil}, the syntax table to the
@@ -2769,3 +2753,157 @@ form that has not already had an appropriate expansion defined. In
Common Lisp, this is not an error since the function @code{(setf
@var{func})} might be defined later.
@end quotation
+
+@node Multisession Variables
+@section Multisession Variables
+
+@cindex multisession variable
+ When you set a variable to a value and then close Emacs and restart
+it, that value won't be automatically restored. Users usually set
+normal variables in their startup files, or use Customize
+(@pxref{Customization}) to set user options permanently, and various
+packages have various files wher they store the data (e.g., Gnus
+stores this in @file{.newsrc.eld} and the URL library stores cookies
+in @file{~/.emacs.d/url/cookies}).
+
+For things in between these two extremes (i.e., configuration which
+goes in the startup file, and massive application state that goes into
+separate files), Emacs provides a facility to replicate data between
+sessions called @dfn{multisession variables}. (This facility may not
+be available on all systems.) To give you an idea of how these are
+meant to be used, here's a small example:
+
+@lisp
+@group
+(define-multisession-variable foo-var 0)
+(defun my-adder (num)
+ (interactive "nAdd number: ")
+ (setf (multisession-value foo)
+ (+ (multisession-value foo) num))
+ (message "The new number is: %s" (multisession-value foo)))
+@end group
+@end lisp
+
+@noindent
+This defines the variable @code{foo-var} and binds it to a special
+multisession object which is initialized with the value @samp{0} (if
+the variable doesn't already exist from a previous session). The
+@code{my-adder} command queries the user for a number, adds this to
+the old (possibly saved value), and then saves the new value.
+
+This facility isn't meant to be used for huge data structures, but
+should be performant for most values.
+
+@defmac define-multisession-variable name initial-value &optional doc &rest args
+This macro defines @var{name} as a multisession variable, and gives it
+the @var{initial-value} if this variable hasn't been assigned a value
+earlier. @var{doc} is the doc string, and several keyword arguments can
+be used in @var{args}:
+
+@table @code
+@item :package @var{package-symbol}
+This keyword says that a multisession variable belongs to the package
+specified by @var{package-symbol}. The combination of
+@var{package-symbol} and @var{name} has to be unique. If
+@var{package-symbol} isn't given, this will default to the first
+``segment'' of the @var{name} symbol's name, which is the part of its
+name up to and excluding the first @samp{-}. For instance, if
+@var{name} is @code{foo-var} and @var{package-symbol} isn't given,
+@var{package-symbol} will default to @code{foo}.
+
+@cindex synchronized multisession variables
+@item :synchronized @var{bool}
+Multisession variables can be @dfn{synchronized} if @var{bool} is
+non-@code{nil}. This means that if there're two concurrent Emacs
+instances running, and the other Emacs changes the multisession
+variable @code{foo-var}, the current Emacs instance will retrieve that
+modified data when accessing the value. If @var{synchronized} is
+@code{nil} or missing, this won't happen, and the values in all
+Emacs sessions using the variable will be independent of each other.
+
+@item :storage @var{storage}
+Use the specified @var{storage} method. This can be either
+@code{sqlite} (in Emacs compiled with SQLite support) or @code{files}.
+If not given, this defaults to the value of the
+@code{multisession-storage} variable, described below.
+@end table
+@end defmac
+
+@defun multisession-value variable
+This function returns the current value of @var{variable}. If this
+variable hasn't been accessed before in this Emacs session, or if it's
+changed externally, it will be read in from external storage. If not,
+the current value in this session is returned as is. It is an error
+to call this function for a @var{variable} that is not a multisession
+variable.
+
+Values retrieved via @code{multisession-value} may or may not be
+@code{eq} to each other, but they will always be @code{equal}.
+
+This is a generalized variable (@pxref{Generalized Variables}), so the
+way to update such a variable is to say, for instance:
+
+@lisp
+(setf (multisession-value foo-bar) 'zot)
+@end lisp
+
+Only Emacs Lisp values that have a readable print syntax
+(@pxref{Printed Representation}) can be saved this way.
+
+If the multisession variable is synchronized, setting it may update
+the value first. For instance:
+
+@lisp
+(cl-incf (multisession-value foo-bar))
+@end lisp
+
+This first checks whether the value has changed in a different
+Emacs instance, retrieves that value, and then adds 1 to that value and
+stores it. But note that this is done without locking, so if many
+instances are updating the value at the same time, it's unpredictable
+which instance ``wins''.
+@end defun
+
+@defun multisession-delete object
+This function deletes @var{object} and its value from its persistent
+storage.
+@end defun
+
+@c FIXME: this lacks the documentation of the form of the arguments.
+@defun make-multisession
+You can also make persistent values that aren't tied to a specific
+variable, but are tied to an explicit package and key.
+
+@example
+(setq foo (make-multisession :package "mail"
+ :key "friends"))
+(setf (multisession-value foo) 'everybody)
+@end example
+
+This supports the same keywords as
+@code{define-multisession-variable}, but also supports a
+@code{:initial-value} keyword, which specifies the default value.
+@end defun
+
+@defopt multisession-storage
+This variable controls how the multisession variables are stored. It
+value defaults to @code{files}, which means that the values are stored
+in a one-file-per-variable structure inside the directory specified by
+@code{multisession-directory}. If this value is @code{sqlite}
+instead, the values are stored in an SQLite database; this is only
+available if Emacs was built with SQLite support.
+@end defopt
+
+@defopt multisession-directory
+The multisession variables are stored under this directory, which
+defaults to @file{multisession/} subdirectory of the
+@code{user-emacs-directory}, which is typically
+@file{~/.emacs.d/multisession/}.
+@end defopt
+
+@findex multisession-edit-mode
+@deffn Command list-multisession-values
+This command pops up a buffer listing all the multisession variables,
+and enters a special mode @code{multisession-edit-mode} which allows
+you to delete them and edit their values.
+@end deffn
diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi
index d988a0ff118..c3894bc3954 100644
--- a/doc/lispref/windows.texi
+++ b/doc/lispref/windows.texi
@@ -3038,6 +3038,11 @@ desired total height with respect to the total height of its frame's
root window.
@item
+A cons cell whose @sc{car} is @code{body-lines} and whose @sc{cdr} is an
+integer that specifies the height of the chosen window's body in frame
+lines.
+
+@item
If the value specifies a function, that function is called with one
argument---the chosen window. The function is supposed to adjust the
height of the window; its return value is ignored. Suitable functions
@@ -3071,16 +3076,47 @@ desired total width with respect to the total width of the frame's
root window.
@item
+A cons cell whose @sc{car} is @code{body-columns} and whose @sc{cdr} is
+an integer that specifies the width of the chosen window's body in frame
+columns.
+
+@item
If the value specifies a function, that function is called with one
argument---the chosen window. The function is supposed to adjust the
width of the window; its return value is ignored.
@end itemize
-By convention, the width of the chosen window is adjusted only if the
-window is part of a horizontal combination (@pxref{Windows and
-Frames}) to avoid changing the width of other, unrelated windows.
-Also, this entry should be processed under only certain conditions
-which are specified right below this list.
+@vindex window-size@r{, a buffer display action alist entry}
+@item window-size
+This entry is a combination of the two preceding ones and can be used to
+adjust the chosen window's height @emph{and} width. Since windows can
+be resized in one direction only without affecting other windows,
+@code{window-size} is effective only to set up the size of a window
+appearing alone on a frame. The value can be one of the following:
+
+@itemize @bullet
+@item
+@code{nil} means to leave the size of the chosen window alone.
+
+@item
+A cons cell of two integers specifies the desired total width and height
+of the chosen window in lines and columns. It's effect is to adjust the
+size of the frame accordingly.
+
+@item
+A cons cell whose @sc{car} equals @code{body-chars} and whose @sc{cdr}
+is a cons cell of two integers---the desired body width and height of
+the chosen window in frame columns and lines. It's effect is to adjust
+the size of the frame accordingly.
+
+@item
+If the value specifies a function, that function is called with one
+argument---the chosen window. The function is supposed to adjust the
+size of the window's frame; its return value is ignored.
+@end itemize
+
+This entry should be processed under only certain conditions which are
+specified right below this list.
@vindex dedicated@r{, a buffer display action alist entry}
@item dedicated
@@ -3181,6 +3217,14 @@ the window was created earlier by @code{display-buffer} to show the
buffer and never was used to show another buffer until it was reused
by the current invocation of @code{display-buffer}.
+If no @code{window-height}, @code{window-width} or @code{window-size}
+entry was specified, the window may still be resized automatically when
+the buffer is temporary and @code{temp-buffer-resize-mode} has been
+enabled, @ref{Temporary Displays}. In that case, the @sc{cdr} of a
+@code{window-height}, @code{window-width} or @code{window-size} entry
+can be used to inhibit or override the default behavior of
+@code{temp-buffer-resize-mode} for specific buffers or invocations of
+@code{display-buffer}.
@node Choosing Window Options
@subsection Additional Options for Displaying Buffers
diff --git a/doc/man/emacsclient.1 b/doc/man/emacsclient.1
index ba64efa282c..e5d1bbe09ae 100644
--- a/doc/man/emacsclient.1
+++ b/doc/man/emacsclient.1
@@ -1,5 +1,5 @@
.\" See section COPYING for conditions for redistribution.
-.TH EMACSCLIENT 1 "2020-10-18" "GNU Emacs" "GNU"
+.TH EMACSCLIENT 1 "2021-11-05" "GNU Emacs" "GNU"
.\" NAME should be all caps, SECTION should be 1-8, maybe w/ subsection
.\" other params are allowed: see man(7), man(1)
.SH NAME
@@ -69,6 +69,9 @@ start Emacs in daemon mode, and try to connect to it.
.B -c, \-\-create-frame
Create a new frame instead of trying to use the current Emacs frame.
.TP
+.B -r \-\-reuse-frame
+Reuse an existing frame if one exists, otherwise create a new frame.
+.TP
.B \-F, \-\-frame-parameters=ALIST
Set the parameters of a newly-created frame.
.TP
diff --git a/doc/misc/cc-mode.texi b/doc/misc/cc-mode.texi
index 98ded68e713..a388846fbfe 100644
--- a/doc/misc/cc-mode.texi
+++ b/doc/misc/cc-mode.texi
@@ -283,6 +283,7 @@ Font Locking
* Font Locking Preliminaries::
* Faces::
* Doc Comments::
+* Wrong Comment Style::
* Misc Font Locking::
* AWK Mode Font Locking::
diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi
index 0ec02495d5e..55b112cb24a 100644
--- a/doc/misc/cl.texi
+++ b/doc/misc/cl.texi
@@ -1245,6 +1245,12 @@ blocks for other macros like @code{cl-incf}, and @code{cl-pushnew}.
The @code{cl-letf} and @code{cl-letf*} macros are used in the processing
of symbol macros; @pxref{Macro Bindings}.
+@defmac with-memoization @var{place} @var{code}@dots{}
+This macro provides a simple way to do memoization. @var{code} is
+evaluated and then stashed in @var{place}. If @var{place}'s value is
+non-@code{nil}, return that value instead of evaluating @var{code}.
+@end defmac
+
@node Variable Bindings
@section Variable Bindings
@@ -5028,7 +5034,7 @@ The above @code{incf} example could be written using
@ignore
(defmacro concatf (place &rest args)
(gv-letplace (getter setter) place
- (macroexp-let2 nil v (mapconcat 'identity args "")
+ (macroexp-let2 nil v (mapconcat 'identity args)
(funcall setter `(concat ,getter ,v)))))
@end ignore
@end defmac
diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi
index 24bee6ad04f..28f0cb972d0 100644
--- a/doc/misc/efaq.texi
+++ b/doc/misc/efaq.texi
@@ -151,7 +151,7 @@ and @key{Meta}
@item
@key{DEL}: @key{Delete}, usually @strong{not} the same as
-@key{Backspace}; same as @kbd{C-?} (see @ref{Backspace invokes help}, if
+@key{Backspace}; same as @kbd{C-?} (@pxref{Backspace invokes help}, if
deleting invokes Emacs help)
@item
@@ -793,7 +793,7 @@ informational files about Emacs and relevant aspects of the GNU project
are available for you to read.
The following files (and others) are available in the @file{etc}
-directory of the Emacs distribution (see @ref{File-name conventions}, if
+directory of the Emacs distribution (@pxref{File-name conventions}, if
you're not sure where that is). Many of these files are available via
the Emacs @samp{Help} menu, or by typing @kbd{C-h ?} (@kbd{M-x
help-for-help}).
diff --git a/doc/misc/eieio.texi b/doc/misc/eieio.texi
index 63b42827311..c8d488d6edb 100644
--- a/doc/misc/eieio.texi
+++ b/doc/misc/eieio.texi
@@ -700,18 +700,18 @@ slot values, and use the previously mentioned set/ref routines.
@defun slot-value object slot
@anchor{slot-value}
This function retrieves the value of @var{slot} from @var{object}.
+It can also be used on objects defined by @code{cl-defstruct}.
This is a generalized variable that can be used with @code{setf} to
-modify the value stored in @var{slot}. @xref{Generalized
-Variables,,,elisp,GNU Emacs Lisp Reference Manual}.
+modify the value stored in @var{slot}.
+@xref{Generalized Variables,,,elisp,GNU Emacs Lisp Reference Manual}.
@end defun
@defun set-slot-value object slot value
@anchor{set-slot-value}
This function sets the value of @var{slot} from @var{object}.
-This is not a CLOS function, but is the obsolete setter for
-@code{slot-value} used by the @code{setf} macro. It is therefore
+This is not a CLOS function. It is therefore
recommended to use @w{@code{(setf (slot-value @var{object} @var{slot})
@var{value})}} instead.
@end defun
@@ -856,11 +856,12 @@ You can also create a generic method with @code{cl-defmethod}
(@pxref{Methods}). When a method is created and there is no generic
method in place with that name, then a new generic will be created,
and the new method will use it.
-@end defmac
-In CLOS, a generic call also be used to provide an argument list and
-dispatch precedence for all the arguments. In @eieio{}, dispatching
-only occurs for the first argument, so the @var{arglist} is not used.
+In CLOS, a generic method can also be used to provide an argument list
+and dispatch precedence for all the arguments. In @eieio{},
+dispatching only occurs for the first argument, so the @var{arglist}
+is not used.
+@end defmac
@node Methods
@section Methods
diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi
index 7cd3e5f5828..96a4ad556f6 100644
--- a/doc/misc/emacs-mime.texi
+++ b/doc/misc/emacs-mime.texi
@@ -454,7 +454,8 @@ setting this option to non-@code{nil}. The default value is @code{t}.
@item mm-external-terminal-program
@vindex mm-external-terminal-program
-The program used to start an external terminal.
+This should be a list of strings; typically something like
+@samp{("xterm" "-e")} or @samp{("gnome-terminal" "--")}.
@item mm-enable-external
@vindex mm-enable-external
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index 73e24a4b364..e7286d2ebe3 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -2,13 +2,15 @@
@c %**start of header
@setfilename ../../info/erc.info
@settitle ERC Manual
+@set ERCVER 5.4.1
+@set ERCDIST as distributed with Emacs @value{EMACSVER}
@include docstyle.texi
@syncodeindex fn cp
@include emacsver.texi
@c %**end of header
@copying
-This manual is for ERC as distributed with Emacs @value{EMACSVER}.
+This manual is for ERC @value{ERCVER} @value{ERCDIST}.
Copyright @copyright{} 2005--2021 Free Software Foundation, Inc.
@@ -88,7 +90,28 @@ Advanced Usage
ERC is a powerful, modular, and extensible IRC client for Emacs.
It is distributed with Emacs since version 22.1.
-It comes with the following capabilities enabled by default.
+IRC is short for Internet Relay Chat. When using IRC, you can
+communicate with other users on the same IRC network. There are many
+different networks---if you search for ``IRC networks'' in your
+favorite search engine, you will find up-to-date lists of IRC networks
+catering to various interests and topics.
+
+To use IRC, you need an IRC client such as ERC. Using the client, you
+connect to an IRC server. Once you've done that, you will have access
+to all available channels on that server's network. A channel is
+basically a chat room, and what you type in a channel will be shown to
+all other users in that channel. You can be in several channels at
+the same time---ERC will show each channel in its own buffer.
+
+IRC channel names always begin with a @samp{#} character. For
+example, the Emacs channel on Libera.Chat is @samp{#emacs}, and the
+ERC channel is @samp{#erc}. Do not confuse them with the hashtags
+used on many social media platforms.
+
+You can also send private messages to other IRC users on the same
+network, even if they are not in the same channels as you.
+
+ERC comes with the following capabilities enabled by default.
@itemize @bullet
@item Flood control
@@ -112,7 +135,11 @@ It comes with the following capabilities enabled by default.
@cindex settings
The command @kbd{M-x erc} will start ERC and prompt for the server to
-connect to.
+connect to. If you're unsure of which server or network to connect
+to, we suggest starting with ``irc.libera.chat''. There you will find
+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.
diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi
index 5153829e2da..71c423ad9c6 100644
--- a/doc/misc/ert.texi
+++ b/doc/misc/ert.texi
@@ -109,6 +109,7 @@ Appendix
@end menu
@end ifnottex
+
@node Introduction
@chapter Introduction
@cindex introduction to ERT
@@ -123,7 +124,7 @@ commands to run them to verify whether the definitions that are
currently loaded in Emacs pass the tests.
Some Lisp files have comments like the following (adapted from the
-package @code{pp.el}):
+package @file{pp.el}):
@lisp
;; (pp-to-string '(quote quote)) ; expected: "'quote"
@@ -358,6 +359,7 @@ Prompt for a test and then show its documentation.
@end table
+
@node Running Tests in Batch Mode
@section Running Tests in Batch Mode
@cindex running tests in batch mode
@@ -375,7 +377,7 @@ emacs -batch -l ert -l my-tests.el -f ert-run-tests-batch-and-exit
@end example
This command will start up Emacs in batch mode, load ERT, load
-@code{my-tests.el}, and run all tests defined in it. It will exit
+@file{my-tests.el}, and run all tests defined in it. It will exit
with a zero exit status if all tests passed, or nonzero if any tests
failed or if anything else went wrong. It will also print progress
messages and error diagnostics to standard output.
@@ -390,12 +392,37 @@ summary as shown below:
emacs -batch -l ert -f ert-summarize-tests-batch-and-exit output.log
@end example
+@vindex ert-batch-print-level
+@vindex ert-batch-print-length
+ERT attempts to limit the output size for failed tests by choosing
+conservative values for @code{print-level} and @code{print-length}
+when printing Lisp values. This can in some cases make it difficult
+to see which portions of those values are incorrect. Use
+@code{ert-batch-print-level} and @code{ert-batch-print-length}
+to customize that:
+
+@example
+emacs -batch -l ert -l my-tests.el \
+ --eval "(let ((ert-batch-print-level 10) \
+ (ert-batch-print-length 120)) \
+ (ert-run-tests-batch-and-exit))"
+@end example
+
+@vindex ert-batch-backtrace-line-length
+Even modest settings for @code{print-level} and @code{print-length} can
+produce extremely long lines in backtraces, however, with attendant
+pauses in execution progress. Set
+@code{ert-batch-backtrace-line-length} to t to use the value of
+@code{backtrace-line-length}, @code{nil} to stop any limitations on backtrace
+line lengths (that is, to get full backtraces), or a positive integer to
+limit backtrace line length to that number.
+
@vindex ert-quiet
By default, ERT in batch mode is quite verbose, printing a line with
result after each test. This gives you progress information: how many
tests have been executed and how many there are. However, in some
cases this much output may be undesirable. In this case, set
-@code{ert-quiet} variable to a non-nil value:
+@code{ert-quiet} variable to a non-@code{nil} value:
@example
emacs -batch -l ert -l my-tests.el \
@@ -414,10 +441,21 @@ emacs -batch -l ert -l my-tests.el \
-eval '(ert-run-tests-batch-and-exit "to-match")'
@end example
+@vindex EMACS_TEST_VERBOSE@r{, environment variable}
By default, ERT test failure summaries are quite brief in batch
mode---only the names of the failed tests are listed. If the
-EMACS_TEST_VERBOSE environment variable is set, the failure summaries
-will also include the data from the failing test.
+@env{EMACS_TEST_VERBOSE} environment variable is set, the failure
+summaries will also include the data from the failing test.
+
+@vindex EMACS_TEST_JUNIT_REPORT@r{, environment variable}
+ERT can produce JUnit test reports in batch mode. If the environment
+variable @env{EMACS_TEST_JUNIT_REPORT} is set, ERT will produce for
+every test package @file{my-tests.el} a corresponding JUnit test
+report @file{my-tests.xml}. The function
+@code{ert-summarize-tests-batch-and-exit} collects all these package
+test reports into a new JUnit test report, with the respective name of
+that environment variable.
+
@node Test Selectors
@section Test Selectors
@@ -486,8 +524,10 @@ to find where a test was defined if the test was loaded from a file.
* Expected Failures:: Tests for known bugs.
* Tests and Their Environment:: Don't depend on customizations; no side effects.
* Useful Techniques:: Some examples.
+* erts files:: Files containing many buffer tests.
@end menu
+
@node The @code{should} Macro
@section The @code{should} Macro
@@ -768,6 +808,121 @@ for testing. Usually, this makes the interfaces easier to use as
well.
+@node erts files
+@section erts files
+
+@findex ert-test-erts-file
+Many relevant Emacs tests depend on comparing the contents of a buffer
+before and after executing a particular function. These tests can be
+written the normal way---making a temporary buffer, inserting the
+``before'' text, running the function, and then comparing with the
+expected ``after'' text. However, this often leads to test code
+that's pretty difficult to read and write, especially when the text in
+question is multi-line.
+
+So ert provides a function called @code{ert-test-erts-file} that takes
+two parameters: The name of a specially-formatted @dfn{erts} file, and
+(optionally) a function that performs the transform.
+
+@findex erts-mode
+These erts files can be edited with the @code{erts-mode} major mode.
+
+An erts file is divided into sections by the (@samp{=-=}) separator.
+
+Here's an example file containing two tests:
+
+@example
+Name: flet
+
+=-=
+(cl-flet ((bla (x)
+(* x x)))
+(bla 42))
+=-=
+(cl-flet ((bla (x)
+ (* x x)))
+ (bla 42))
+=-=-=
+
+Name: defun
+
+=-=
+(defun x ()
+ (print (quote ( thingy great
+ stuff))))
+=-=-=
+@end example
+
+A test starts with a line containing just @samp{=-=} and ends with a
+line containing just @samp{=-=-=}. The test may be preceded by
+freeform text (for instance, comments), and also name/value pairs (see
+below for a list of them).
+
+If there is a line with @samp{=-=} inside the test, that designates
+the start of the ``after'' text. Otherwise, the ``before'' and
+``after'' texts are assumed to be identical, which you typically see
+when writing indentation tests.
+
+@code{ert-test-erts-file} puts the ``before'' section into a temporary
+buffer, calls the transform function, and then compares with the
+``after'' section.
+
+Here's an example usage:
+
+@lisp
+(ert-test-erts-file "elisp.erts"
+ (lambda ()
+ (emacs-lisp-mode)
+ (indent-region (point-min) (point-max))))
+@end lisp
+
+A list of the name/value specifications that can appear before a test
+follows. The general syntax is @samp{Name: Value}, but continuation
+lines can be used (along the same lines as in mail---subsequent lines
+that start with a space are part of the value).
+
+@example
+Name: foo
+Code: (indent-region
+ (point-min) (point-max))
+@end example
+
+@table @samp
+@item Name
+All tests should have a name. This name will appear in ERT output if
+the test fails, and helps to identify the failing test.
+
+@item Code
+This is the code that will be run to do the transform. This can also
+be passed in via the @code{ert-test-erts-file} call, but @samp{Code}
+overrides that. It's used not only in the following test, but in all
+subsequent tests in the file (until overridden by another @samp{Code}
+specification).
+
+@item No-Before-Newline
+@itemx No-After-Newline
+These specifications say whether the ``before'' or ``after'' portions
+have a newline at the end. (This would otherwise be impossible to
+specify.)
+
+@item Point-Char
+Sometimes it's useful to be able to put point at a specific place
+before executing the transform function. @samp{Point-Char: |} will
+make @code{ert-test-erts-file} place point where @samp{|} is in the
+``before'' form (and remove that character), and will check that it's
+where the @samp{|} character is in the ``after'' form (and issue a
+test failure if that isn't the case). (This is used in all subsequent
+tests, unless overridden by a new @samp{Point-Char} spec.)
+
+@item Skip
+If this is present and value is a form that evaluates to a
+non-@code{nil} value, the test will be skipped.
+@end table
+
+If you need to use the literal line single line @samp{=-=} in a test
+section, you can quote it with a @samp{\} character.
+
+
@node How to Debug Tests
@chapter How to Debug Tests
@@ -969,6 +1124,7 @@ For information on mocks, stubs, fixtures, or test suites, see below.
* Fixtures and Test Suites:: How ERT differs from tools for other languages.
@end menu
+
@node Mocks and Stubs
@section Other Tools for Emacs Lisp
@cindex mocks and stubs
@@ -1043,11 +1199,13 @@ e.g., to run quick tests during interactive development and slow tests less
often. This can be achieved with the @code{:tag} argument to
@code{ert-deftest} and @code{tag} test selectors.
+
@node Index
@unnumbered Index
@printindex cp
+
@node GNU Free Documentation License
@appendix GNU Free Documentation License
@include doclicense.texi
diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi
index c01ceb5fb93..a87dd4308c5 100644
--- a/doc/misc/eshell.texi
+++ b/doc/misc/eshell.texi
@@ -271,8 +271,30 @@ Some of the built-in commands have different behavior from their
external counterparts, and some have no external counterpart. Most of
these will print a usage message when given the @code{--help} option.
+In some cases, a built-in command's behavior can be configured via
+user settings, some of which are mentioned below. For example,
+certain commands have two user settings to allow them to overwrite
+files without warning and to ensure that they always prompt before
+overwriting files. If both settings are non-@code{nil}, the commands
+always prompt. If both settings are @code{nil} (the default), the
+commands signal an error.
+
+Several commands observe the value of
+@code{eshell-default-target-is-dot}. If non-@code{nil}, then the
+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}.
+
@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 addpath
@cmindex addpath
Adds a given path or set of paths to the PATH environment variable, or,
@@ -282,26 +304,137 @@ with no arguments, prints the current paths in this variable.
@cmindex alias
Define an alias (@pxref{Aliases}). This adds it to the aliases file.
+@item basename
+@cmindex basename
+Return a file name 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 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:
+
+@itemize @minus{}
+@item
+When it receives no argument at all, it changes to the home directory.
+
+@item
+Giving the command @kbd{cd -} changes back to the previous working
+directory (this is the same as @kbd{cd $-}).
+
+@item
+The command @kbd{cd =} shows the directory stack. Each line is
+numbered.
+
+@item
+With @kbd{cd =foo}, Eshell searches the directory stack for a directory
+matching the regular expression @samp{foo}, and changes to that
+directory.
+
+@item
+With @kbd{cd -42}, you can access the directory stack slots by number.
+
+@item
+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
-Scrolls the contents of the eshell window out of sight, leaving a blank window.
-If provided with an optional non-nil argument, the scrollback contents are
-cleared instead.
+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.
+
+@item clear-scrollback
+@cmindex 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 cp
+Copy a file to a new location or copy multiple files to the same
+directory.
+
+If @code{eshell-cp-overwrite-files} is non-@code{nil}, then
+@command{cp} will overwrite files without warning. If
+@code{eshell-cp-interactive-query} is non-@code{nil}, then
+@command{cp} will ask before overwriting anything.
@item date
@cmindex date
-Similar to, but slightly different from, the GNU Coreutils
+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.
@item define
@cmindex define
-Define a varalias.
+Define a variable alias.
@xref{Variable Aliases, , , elisp, The Emacs Lisp Reference Manual}.
@item diff
@cmindex diff
-Use Emacs's internal @code{diff} (not to be confused with
-@code{ediff}). @xref{Comparing Files, , , emacs, The GNU Emacs Manual}.
+Compare files using Emacs's internal @code{diff} (not to be confused
+with @code{ediff}). @xref{Comparing Files, , , emacs, The GNU Emacs
+Manual}.
+
+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 $*'}.
+
+@item dirname
+@cmindex dirname
+Return the directory component of a file name.
+
+@item dirs
+@cmindex 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 echo
+@cmindex echo
+Echoes its input. If @code{eshell-plain-echo-behavior} is
+non-@code{nil}, @command{echo} will try to behave more like a plain
+shell's @command{echo}.
+
+@item env
+@cmindex env
+Prints the current environment variables. Unlike in Bash, this
+command does not yet support running commands with a modified
+environment.
+
+@item exit
+@cmindex 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
+Set environment variables using input like Bash's @command{export}, as
+in @samp{export @var{var1}=@var{val1} @var{var2}=@var{val2} @dots{}}.
+
+@item expr
+@cmindex expr
+An implementation of @command{expr} using the Calc package.
+@xref{Top,,, calc, The GNU Emacs Calculator}.
+
+This command can be loaded as part of the eshell-xtra module, which is
+disabled by default.
@item grep
@cmindex grep
@@ -313,13 +446,36 @@ Use Emacs's internal @code{diff} (not to be confused with
@cmindex fgrep
@itemx glimpse
@cmindex glimpse
-The @command{grep} commands are compatible with GNU @command{grep}, but
-use Emacs's internal @code{grep} instead.
+The @command{grep} commands are compatible with GNU @command{grep},
+but use Emacs's internal @code{grep} instead.
+@xref{Grep Searching, , , emacs, The GNU Emacs Manual}.
+
+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.
+
+@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 info
@cmindex info
-Same as the external @command{info} command, but uses Emacs's internal
-Info reader.
+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 intersection
+@cmindex intersection
+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.
+
+This command can be loaded as part of the eshell-xtra module, which is
+disabled by default.
@item jobs
@cmindex jobs
@@ -337,46 +493,152 @@ 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 ln
+@cmindex ln
+Create links to files.
+
+If @code{eshell-ln-overwrite-files} is non-@code{nil}, @command{ln}
+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
@cmindex locate
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}.
+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 $*'}.
+
+@item ls
+@cmindex ls
+Lists the contents of directories.
+
+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}}}.
+
+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}).
+
+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.
+
+The user option @code{eshell-ls-default-blocksize} determines the
+default blocksize used when displaying file sizes with the option
+@option{-s}.
+
@item make
@cmindex make
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
+Display Man pages using the Emacs @code{man} command.
+@xref{Man Page, , , emacs, The GNU Emacs Manual}.
+
+@item mismatch
+@cmindex mismatch
+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.
+
+This command can be loaded as part of the eshell-xtra module, which is
+disabled by default.
+
+@item mkdir
+@cmindex mkdir
+Make new directories.
+
+@item mv
+@cmindex mv
+Move or rename files.
+
+If @code{eshell-mv-overwrite-files} is non-@code{nil}, @command{mv}
+will overwrite files without warning. If
+@code{eshell-mv-interactive-query} is non-@code{nil}, @command{mv}
+will prompt before overwriting anything.
+
@item occur
@cmindex occur
Alias to Emacs's @code{occur}.
@xref{Other Repeating Search, , , emacs, The GNU Emacs Manual}.
+@item popd
+@cmindex popd
+Pop a directory from the directory stack and switch to a another place
+in the stack.
+
@item printnl
@cmindex printnl
Print the arguments separated by newlines.
-@item cd
-@cmindex cd
-This command changes the current working directory. Usually, it is
-invoked as @samp{cd foo} where @file{foo} is the new working directory.
-But @command{cd} knows about a few special arguments:
-
-When it receives no argument at all, it changes to the home directory.
-
-Giving the command @samp{cd -} changes back to the previous working
-directory (this is the same as @samp{cd $-}).
-
-The command @samp{cd =} shows the directory stack. Each line is
-numbered.
-
-With @samp{cd =foo}, Eshell searches the directory stack for a directory
-matching the regular expression @samp{foo} and changes to that
-directory.
-
-With @samp{cd -42}, you can access the directory stack by number.
+@item pushd
+@cmindex pushd
+Push the current directory onto the directory stack, then change to
+another directory.
+
+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 pwd
+@cmindex pwd
+Prints the current working directory.
+
+@item rm
+@cmindex rm
+Removes files, buffers, processes, or Emacs Lisp symbols, depending on
+the argument.
+
+If @code{eshell-rm-interactive-query} is non-@code{nil}, @command{rm}
+will prompt before removing anything. If
+@code{eshell-rm-removes-directories} is non-@code{nil}, then
+@command{rm} can also remove directories. Otherwise, @command{rmdir}
+is required.
+
+@item rmdir
+@cmindex rmdir
+Removes directories if they are empty.
+
+@item set-difference
+@cmindex set-difference
+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.
+
+This command can be loaded as part of the eshell-xtra module, which is
+disabled by default.
+
+@item set-exclusive-or
+@cmindex set-exclusive-or
+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.
+
+This command can be loaded as part of the eshell-xtra module, which is
+disabled by default.
+
+@item setq
+@cmindex setq
+Set variable values, using the function @code{setq} like a command.
+@xref{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 su
@cmindex su
@@ -386,6 +648,50 @@ Uses TRAMP's @command{su} or @command{sudo} method @pxref{Inline methods, , , tr
to run a command via @command{su} or @command{sudo}. These commands
are in the eshell-tramp module, which is disabled by default.
+
+@item substitute
+@cmindex substitute
+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.
+
+This command can be loaded as part of the eshell-xtra module, which is
+disabled by default.
+
+@item time
+@cmindex time
+Show the time elapsed during a command's execution.
+
+@item umask
+@cmindex umask
+Set or view the default file permissions for newly created files and
+directories.
+
+@item union
+@cmindex union
+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.
+
+This command can be loaded as part of the eshell-xtra module, which is
+disabled by default.
+
+@item unset
+@cmindex unset
+Unset an environment variable.
+
+@item wait
+@cmindex wait
+Wait until a process has successfully completed.
+
+@item which
+@cmindex which
+Identify a command and its location.
+
+@item whoami
+@cmindex whoami
+Print the current user. This Eshell version of @command{whoami}
+supports Tramp.
@end table
@subsection Built-in variables
diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi
index ca752ec11b1..e41aa8d886d 100644
--- a/doc/misc/eww.texi
+++ b/doc/misc/eww.texi
@@ -305,6 +305,7 @@ state the directionality.
@vindex shr-max-image-proportion
@vindex shr-blocked-images
+@vindex shr-allowed-images
@cindex Image Display
Loading random images from the web can be problematic due to their
size or content. By customizing @code{shr-max-image-proportion} you
@@ -312,7 +313,9 @@ can set the maximal image proportion in relation to the window they
are displayed in. E.g., 0.7 means an image is allowed to take up 70%
of the width and height. If Emacs supports image scaling (ImageMagick
support required) then larger images are scaled down. You can block
-specific images completely by customizing @code{shr-blocked-images}.
+specific images completely by customizing @code{shr-blocked-images},
+or, if you want to only allow some specific images, customize
+@code{shr-allowed-images}.
@vindex shr-inhibit-images
You can control image display by customizing
@@ -380,6 +383,32 @@ thus allowing for the use of the usual substitutions, such as
@code{\[eww-reload]} for the current key binding of the
@code{eww-reload} command.
+@vindex eww-auto-rename-buffer
+ If the @code{eww-auto-rename-buffer} user option is non-@code{nil},
+EWW buffers will be renamed after rendering a document. If this is
+@code{title}, rename based on the title of the document. If this is
+@code{url}, rename based on the @acronym{URL} of the document. This
+can also be a user-defined function, which is called with no
+parameters in the EWW buffer, and should return a string.
+
+@cindex utm
+@vindex eww-url-transformers
+ EWW runs the URLs through @code{eww-url-transformers} before using
+them. This user option is a list of functions, where each function is
+called with the URL as the parameter, and should return the (possibly)
+transformed URL. By default, this variable contains
+@code{eww-remove-tracking}, which removes the common @samp{utm_}
+trackers from links.
+
+@cindex video
+@vindex shr-use-xwidgets-for-media
+ If Emacs has been built with xwidget support, EWW can use that to
+display @samp{<video>} elements. However, this support is still
+experimental, and on some systems doesn't work (and even worse) may
+crash your Emacs, so this feature is off by default. If you wish to
+switch it on, set @code{shr-use-xwidgets-for-media} to a
+non-@code{nil} value.
+
@node Command Line
@chapter Command Line Usage
diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi
index f741ee5d723..ca464aff665 100644
--- a/doc/misc/flymake.texi
+++ b/doc/misc/flymake.texi
@@ -1,4 +1,4 @@
-\input texinfo @c -*-texinfo; coding: utf-8 -*-
+\input texinfo @c -*- mode: texinfo; coding: utf-8 -*-
@comment %**start of header
@setfilename ../../info/flymake.info
@set VERSION 1.2
@@ -1145,7 +1145,7 @@ file are parsed.
For @file{file.h}, the include directives to look for are
@code{#include "file.h"}, @code{#include "../file.h"}, etc. Each
include is checked against a list of include directories
-(see @ref{Getting the include directories}) to be sure it points to the
+(@pxref{Getting the include directories}) to be sure it points to the
correct @file{file.h}.
First matching master file found stops the search. The master file is then
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 6c892bc80a9..74b5fb442e3 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -1004,7 +1004,7 @@ The fundamental building blocks of Gnus are @dfn{servers},
@dfn{groups}, and @dfn{articles}. Servers can be local or remote.
Each server maintains a list of groups, and those groups contain
articles. Because Gnus presents a unified interface to a wide variety
-of servers, the vocabulary doesn't always quite line up (see @ref{FAQ
+of servers, the vocabulary doesn't always quite line up (@pxref{FAQ
- Glossary}, for a more complete glossary). Thus a local maildir is
referred to as a ``server'' (@pxref{Finding the News}) the same as a
Usenet or IMAP server is; ``groups'' (@pxref{Group Buffer}) might mean
@@ -9843,6 +9843,13 @@ Gravatarify the @code{From} header (@code{gnus-treat-from-gravatar}).
Gravatarify all mail headers (i.e., @code{Cc}, @code{To})
(@code{gnus-treat-from-gravatar}).
+@item W D e
+@kindex W D e @r{(Summary)}
+@findex gnus-article-emojize-symbols
+Some symbols have both a non-emoji presentation and an emoji
+presentation. This command will make Gnus choose the emoji presentation
+(@code{gnus-article-emojize-symbols}).
+
@item W D D
@kindex W D D @r{(Summary)}
@findex gnus-article-remove-images
@@ -12185,6 +12192,7 @@ controlling variable is a predicate list, as described above.
@vindex gnus-treat-capitalize-sentences
@vindex gnus-treat-overstrike
@vindex gnus-treat-strip-cr
+@vindex gnus-treat-emojize-symbols
@vindex gnus-treat-strip-headers-in-body
@vindex gnus-treat-strip-leading-blank-lines
@vindex gnus-treat-strip-multiple-blank-lines
@@ -12237,6 +12245,7 @@ possible but those listed are probably sufficient for most people.
@item gnus-treat-capitalize-sentences (t, integer)
@item gnus-treat-overstrike (t, integer)
@item gnus-treat-strip-cr (t, integer)
+@item gnus-treat-emojize-symbols (t, integer)
@item gnus-treat-strip-headers-in-body (t, integer)
@item gnus-treat-strip-leading-blank-lines (t, first, integer)
@item gnus-treat-strip-multiple-blank-lines (t, integer)
@@ -15438,10 +15447,6 @@ If non-@code{nil}, ask for confirmation before deleting old incoming
files. This variable only applies when
@code{mail-source-delete-incoming} is a positive number.
-@item mail-source-ignore-errors
-@vindex mail-source-ignore-errors
-If non-@code{nil}, ignore errors when reading mail from a mail source.
-
@item mail-source-directory
@vindex mail-source-directory
Directory where incoming mail source files (if any) will be stored. The
@@ -18043,7 +18048,7 @@ find all messages that have been received recently from certain groups:
(list
(cons 'query
(format-time-string "SENTSINCE %d-%b-%Y"
- (time-subtract (current-time)
+ (time-subtract nil
(days-to-time (car args)))))
(cons 'criteria "")))
(group-spec (cadr args)))
@@ -28881,7 +28886,7 @@ gnus-agent-cache nil)} reverts to the old behavior.
@item
Dired integration
-@code{gnus-dired-minor-mode} (see @ref{Other modes}) installs key
+@code{gnus-dired-minor-mode} (@pxref{Other modes}) installs key
bindings in dired buffers to send a file as an attachment, open a file
using the appropriate mailcap entry, and print a file using the mailcap
entry.
diff --git a/doc/misc/htmlfontify.texi b/doc/misc/htmlfontify.texi
index 1674565cdac..b2216924e2d 100644
--- a/doc/misc/htmlfontify.texi
+++ b/doc/misc/htmlfontify.texi
@@ -633,7 +633,7 @@ Convert an Emacs :foreground property to a CSS color property.
(hfy-flatten-style @var{style})
@end lisp
-Take @var{style} (see @ref{hfy-face-to-style-i}, @ref{hfy-face-to-style})
+Take @var{style} (@pxref{hfy-face-to-style-i}, @pxref{hfy-face-to-style})
and merge any multiple attributes appropriately. Currently only font-size is
merged down to a single occurrence---others may need special handling, but I
haven't encountered them yet. Returns a @ref{hfy-style-assoc}.
@@ -841,7 +841,7 @@ See @ref{hfy-display-class} for details of valid values for @var{class}.
@end lisp
Find face in effect at point P@. If overlays are to be considered
-(see @ref{hfy-optimizations}) then this may return a @code{defface} style
+(@pxref{hfy-optimizations}) then this may return a @code{defface} style
list of face properties instead of a face symbol.
@item hfy-bgcol
diff --git a/doc/misc/mairix-el.texi b/doc/misc/mairix-el.texi
index d0ec552145e..e57b5ed5422 100644
--- a/doc/misc/mairix-el.texi
+++ b/doc/misc/mairix-el.texi
@@ -60,6 +60,8 @@ database.
* Using:: List of interactive functions
* Extending:: Support your favorite mail reader!
* GNU Free Documentation License:: The license for this documentation.
+* Function Index: Function Index.
+* Variable Index: Variable Index.
@end menu
@node About
@@ -339,4 +341,14 @@ And that's it!
@appendix GNU Free Documentation License
@include doclicense.texi
+@node Function Index
+@unnumbered Function Index
+
+@printindex fn
+
+@node Variable Index
+@unnumbered Variable Index
+
+@printindex vr
+
@bye
diff --git a/doc/misc/mh-e.texi b/doc/misc/mh-e.texi
index bc788ebae09..d96c243f52b 100644
--- a/doc/misc/mh-e.texi
+++ b/doc/misc/mh-e.texi
@@ -1018,16 +1018,16 @@ Send multimedia messages (@pxref{Adding Attachments}).
Read HTML messages (@pxref{HTML}).
@c -------------------------
@item
-Use aliases and identities (see @ref{Aliases}, @pxref{Identities}).
+Use aliases and identities (@pxref{Aliases}, @pxref{Identities}).
@c -------------------------
@item
-Create different views of your mail (see @ref{Threading}, @pxref{Limits}).
+Create different views of your mail (@pxref{Threading}, @pxref{Limits}).
@c -------------------------
@item
Deal with junk mail (@pxref{Junk}).
@c -------------------------
@item
-Handle signed and encrypted messages (see @ref{Reading PGP},
+Handle signed and encrypted messages (@pxref{Reading PGP},
@pxref{Sending PGP}).
@c -------------------------
@item
@@ -1038,7 +1038,7 @@ Process mail that was sent with @command{shar} or @command{uuencode}
Use sequences conveniently (@pxref{Sequences}).
@c -------------------------
@item
-Use the speedbar, tool bar, and menu bar (see @ref{Speedbar}, see @ref{Tool
+Use the speedbar, tool bar, and menu bar (@pxref{Speedbar}, @pxref{Tool
Bar}, @pxref{Menu Bar}).
@c -------------------------
@item
diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org
index 9674a12e695..f67a1795673 100644
--- a/doc/misc/modus-themes.org
+++ b/doc/misc/modus-themes.org
@@ -5,9 +5,9 @@
#+options: ':t toc:nil author:t email:t num:t
#+startup: content
-#+macro: stable-version 1.6.0
-#+macro: release-date 2021-09-29
-#+macro: development-version 1.7.0-dev
+#+macro: stable-version 1.7.0
+#+macro: release-date 2021-11-18
+#+macro: development-version 1.8.0-dev
#+macro: file @@texinfo:@file{@@$1@@texinfo:}@@
#+macro: space @@texinfo:@: @@
#+macro: kbd @@texinfo:@kbd{@@$1@@texinfo:}@@
@@ -95,7 +95,7 @@ Emacs.
:end:
#+cindex: Screenshots
-Check the web page with [[https://protesilaos.com/modus-themes-pictures/][the screen shots]]. There are lots of scenarios
+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.
@@ -108,7 +108,7 @@ options.
:end:
#+cindex: Changelog
-Please refer to the [[https://protesilaos.com/modus-themes-changelog][web page with the change log]]. It is comprehensive
+Please refer to the [[https://protesilaos.com/emacs/modus-themes-changelog][web page with the change log]]. It is comprehensive
and covers everything that goes into every tagged release of the themes.
* Installation
@@ -268,7 +268,7 @@ could look like:
(define-key global-map (kbd "<f5>") #'modus-themes-toggle)
#+end_src
-[[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration for use-package]].
+[[#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
@@ -283,11 +283,12 @@ With those granted, bear in mind a couple of technical points on
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]]).
-** Sample configuration for use-package
+** Sample configuration with and without use-package
:properties:
:custom_id: h:e979734c-a9e1-4373-9365-0f2cd36107b8
:end:
#+cindex: use-package configuration
+#+cindex: sample configuration
It is common for Emacs users to rely on ~use-package~ for declaring
package configurations in their setup. We use this as an example:
@@ -309,6 +310,25 @@ package configurations in their setup. We use this as an example:
:bind ("<f5>" . modus-themes-toggle))
#+end_src
+The same without ~use-package~:
+
+#+begin_src emacs-lisp
+(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)
+
+;; Load the theme of your choice:
+(modus-themes-load-operandi) ;; OR (modus-themes-load-vivendi)
+
+(define-key global-map (kbd "<f5>") #'modus-themes-toggle)
+#+end_src
+
[[#h:e68560b3-7fb0-42bc-a151-e015948f8a35][Differences between loading and enabling]].
Note: make sure not to customize the variable ~custom-theme-load-path~
@@ -325,7 +345,7 @@ 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 re-loads) the theme. Whereas the
+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.
@@ -352,7 +372,7 @@ session, are better off using something like this:
(enable-theme 'modus-operandi) ;; OR (enable-theme 'modus-vivendi)
#+end_src
-[[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration for use-package]].
+[[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration with and without use-package]].
With the above granted, other sections of the manual discuss how to
configure custom faces, where ~load-theme~ is expected, though
@@ -372,7 +392,8 @@ without any further tweaks. By default, all customization options are
set to nil, unless otherwise noted in this manual.
Remember that all customization options must be evaluated before loading
-a theme ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]).
+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.
@@ -380,8 +401,9 @@ this manual.
#+begin_src emacs-lisp
(setq modus-themes-italic-constructs t
modus-themes-bold-constructs nil
- modus-themes-no-mixed-fonts nil
+ modus-themes-mixed-fonts nil
modus-themes-subtle-line-numbers nil
+ modus-themes-intense-markup t
modus-themes-success-deuteranopia t
modus-themes-tabs-accented t
modus-themes-inhibit-reload t ; only applies to `customize-set-variable' and related
@@ -391,7 +413,7 @@ this manual.
;; 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'
+ ;; `intense' OR `faint'.
modus-themes-lang-checkers nil
;; Options for `modus-themes-mode-line' are either nil, or a list
@@ -399,6 +421,10 @@ this manual.
;; `accented', `padded'.
modus-themes-mode-line '(padded accented borderless)
+ ;; This one only works when `modus-themes-mode-line' (above) has
+ ;; the `padded' property. It takes a positive integer.
+ modus-themes-mode-line-padding 3
+
;; 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'
@@ -450,7 +476,7 @@ this manual.
modus-themes-headings ; this is an alist: read the manual or its doc string
'((1 . (overline background))
(2 . (rainbow overline))
- (t . (no-bold)))
+ (t . (semibold)))
modus-themes-variable-pitch-ui nil
modus-themes-variable-pitch-headings t
@@ -470,7 +496,10 @@ this manual.
:end:
#+vindex: modus-themes-inhibit-reload
-Symbol: ~modus-themes-inhibit-reload~
+Brief: Toggle reloading of the active theme when an option is changed
+through the Customize UI.
+
+Symbol: ~modus-themes-inhibit-reload~ (=boolean= type)
Possible values:
@@ -483,6 +512,9 @@ currently active Modus theme.
Enable this behaviour by setting this variable to ~nil~.
+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]]).
+
** Option for color-coding success state
:properties:
:alt_title: Success' color-code
@@ -491,25 +523,27 @@ Enable this behaviour by setting this variable to ~nil~.
:end:
#+vindex: modus-themes-success-deuteranopia
-Symbol: ~modus-themes-success-deuteranopia~
+Brief: Toggle the use of blue instead of green in places which
+color-code green as "success" and red as "failure".
+
+Symbol: ~modus-themes-success-deuteranopia~ (=boolean= type)
Possible values:
1. ~nil~ (default)
2. ~t~
-The default is to colorise all faces that denote "success", "done", or
-similar with a variant of green.
+The default is to colorise a passing state in a green hue. This affects
+all faces that denote "success", "done", marking a selection as opposed
+to marking for deletion, the current search match in contrast to lazily
+highlighted ones, and the like.
With a non-nil value (~t~), use variants of blue instead of green. This
is meant to empower users with red-green color deficiency.
-The present customization option should apply to all contexts where
-there can be a color-coded distinction between success and failure,
-to-do and done, and so on.
-
-Diffs, which have a red/green dichotomy by default, can also be
-configured to conform with deuteranopia.
+Diffs, which rely on a red/green dichotomy by default, can also be
+configured to meet the needs of users with deuteranopia via the option
+~modus-themes-diffs~.
[[#h:ea7ac54f-5827-49bd-b09f-62424b3b6427][Option for diff buffer looks]].
@@ -521,7 +555,9 @@ configured to conform with deuteranopia.
:end:
#+vindex: modus-themes-bold-constructs
-Symbol: ~modus-themes-bold-constructs~
+Brief: Use bold for code syntax highlighting and related.
+
+Symbol: ~modus-themes-bold-constructs~ (=boolean= type)
Possible values:
@@ -549,7 +585,9 @@ Advanced users may also want to configure the exact attributes of the
:end:
#+vindex: modus-themes-italic-constructs
-Symbol: ~modus-themes-italic-constructs~
+Brief: Use italics for code syntax highlighting and related.
+
+Symbol: ~modus-themes-italic-constructs~ (=boolean= type)
Possible values:
@@ -575,7 +613,9 @@ Advanced users may also want to configure the exact attributes of the
:end:
#+vindex: modus-themes-syntax
-Symbol: ~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:
@@ -629,36 +669,41 @@ weight or italic text: ~modus-themes-bold-constructs~ and
[[#h:977c900d-0d6d-4dbb-82d9-c2aae69543d6][Option for more italic constructs]].
-** Option for no font mixing
+** Option for font mixing
:properties:
-:alt_title: No mixed fonts
+:alt_title: Mixed fonts
:description: Toggle mixing of font families
:custom_id: h:115e6c23-ee35-4a16-8cef-e2fcbb08e28b
:end:
-#+vindex: modus-themes-no-mixed-fonts
+#+vindex: modus-themes-mixed-fonts
-Symbol: ~modus-themes-no-mixed-fonts~
+Brief: Toggle the use of monospaced fonts for spacing-sensitive
+constructs (affects font families).
+
+Symbol: ~modus-themes-mixed-fonts~ (=boolean= type)
Possible values:
1. ~nil~ (default)
2. ~t~
-By default, the themes configure some spacing-sensitive faces like Org
+When set to non-nil (~t~), configure some spacing-sensitive faces like Org
tables and code blocks to always inherit from the ~fixed-pitch~ face.
-This is to ensure that those constructs 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. To disable this behaviour, set the
-option to ~t~.
+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.
-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~.
+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
:properties:
:alt_title: Link styles
@@ -667,7 +712,9 @@ are ~org-variable-pitch~ and ~mixed-pitch~.
:end:
#+vindex: modus-themes-links
-Symbol: ~modus-themes-links~
+Brief: Control the style of links to web pages, files, buffers...
+
+Symbol: ~modus-themes-links~ (=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:
@@ -738,7 +785,10 @@ their documentation strings.
:end:
#+vindex: modus-themes-prompts
-Symbol: ~modus-themes-prompts~
+Brief: Control the style of command prompts (e.g. minibuffer, shell, IRC
+clients).
+
+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:
@@ -794,7 +844,9 @@ In user configuration files the form may look like this:
:end:
#+vindex: modus-themes-mode-line
-Symbol: ~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:
@@ -836,7 +888,10 @@ This is done by applying box effects and combining them with an
underline and overline. To ensure that the underline is placed at the
bottom, set ~x-underline-at-descent-line~ to non-nil. The ~padded~ property
has no effect when the ~moody~ property is also used, because Moody
-already applies its own padding.
+already applies its own padding. The exact value of the padding is
+controlled by the variable ~modus-themes-mode-line-padding~.
+
+[[#h:a12b4d3c-e66b-42ed-99ab-4ea039b69e2e][Option for mode line padding]].
Combinations of any of those properties are expressed as a list,
like in these examples:
@@ -877,6 +932,28 @@ Furthermore, because Moody expects an underline and overline instead of
a box style, it is 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 mode line padding
+:properties:
+:custom_id: h:a12b4d3c-e66b-42ed-99ab-4ea039b69e2e
+:end:
+#+vindex: modus-themes-mode-line-padding
+
+Brief: Set the padding of the mode lines.
+
+Symbol: ~modus-themes-mode-line-padding~ (=natnum= type)
+
+Controls the exact width of the mode line's padding. Possible values
+are positive integers. The default value is =6=.
+
+This customization option applies only when ~modus-themes-mode-line~ is
+configured with the ~padded~ property.
+
+[[#h:27943af6-d950-42d0-bc23-106e43f50a24][Option for mode line presentation]].
+
** Option for accented background in tab interfaces
:properties:
:alt_title: Tab style
@@ -885,7 +962,9 @@ non-nil value.
:end:
#+vindex: modus-themes-tabs-accented
-Symbol: ~modus-themes-tabs-accented~
+Brief: Toggle accent colors for tabbed interfaces.
+
+Symbol: ~modus-themes-tabs-accented~ (=boolean= type)
Possible values:
@@ -906,7 +985,9 @@ Centaur tabs package.
:end:
#+vindex: modus-themes-completions
-Symbol: ~modus-themes-completions~
+Brief: Set the overall style of completion framework interfaces.
+
+Symbol: ~modus-themes-completions~ (=choice= type)
Possible values:
@@ -951,7 +1032,10 @@ possibilities.
:end:
#+vindex: modus-themes-mail-citations
-Symbol: ~modus-themes-mail-citations~
+Brief: Set the overall style of citations/quotes when composing
+emails.
+
+Symbol: ~modus-themes-mail-citations~ (=choice= type)
Possible values:
@@ -980,7 +1064,9 @@ not touch.
:end:
#+vindex: modus-themes-fringes
-Symbol: ~modus-themes-fringes~
+Brief: Control the overall coloration of the fringes.
+
+Symbol: ~modus-themes-fringes~ (=choice= type)
Possible values:
@@ -1004,7 +1090,10 @@ names imply.
:end:
#+vindex: modus-themes-lang-checkers
-Symbol: ~modus-themes-lang-checkers~
+Brief: Control the style of in-buffer warnings and errors produced by
+spell checkers, code linters, and the like.
+
+Symbol: ~modus-themes-lang-checkers~ (=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:
@@ -1012,7 +1101,9 @@ an empty list). The list can include any of the following symbols:
+ ~straight-underline~
+ ~text-also~
+ ~background~
-+ ~intense~
++ Overall coloration:
+ - ~intense~
+ - ~faint~
The default (a ~nil~ value or an empty list) applies a color-coded
underline to the affected text, while it leaves the original foreground
@@ -1028,15 +1119,15 @@ affected text.
The property ~background~ adds a color-coded background.
The property ~intense~ amplifies the applicable colors if ~background~
-and/or ~text-only~ are set. If ~intense~ is set on its own, then it implies
-~text-only~.
+and/or ~text-also~ are set. If ~intense~ is set on its own, then it implies
+~text-also~.
-To disable fringe indicators for Flymake or Flycheck, refer to variables
-~flymake-fringe-indicator-position~ and ~flycheck-indication-mode~,
-respectively.
+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:
+Combinations of any of those properties can be expressed in a list, as
+in those examples:
#+begin_src emacs-lisp
(background)
@@ -1056,6 +1147,10 @@ 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.
+
** Option for line highlighting
:properties:
:alt_title: Line highlighting
@@ -1064,7 +1159,9 @@ style, is controlled by the built-in variables ~underline-minimum-offset~,
:end:
#+vindex: modus-themes-hl-line
-Symbol: ~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)
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:
@@ -1116,7 +1213,9 @@ This style affects several packages that enable ~hl-line-mode~, such as
:end:
#+vindex: modus-themes-subtle-line-numbers
-Symbol: ~modus-themes-subtle-line-numbers~
+Brief: Toggle subtle line numbers.
+
+Symbol: ~modus-themes-subtle-line-numbers~ (=boolean= type)
Possible value:
@@ -1137,6 +1236,30 @@ Instead they retain the primary background of the theme, blending with
the rest of the buffer. Foreground values for all relevant faces are
updated to accommodate this aesthetic.
+** Option for intense markup in Org and others
+:properties:
+:alt_title: Intense markup
+:description: Toggle intense style for markup in Org and others
+:custom_id: h:9d9a4e64-99ac-4018-8f66-3051b9c43fd7
+:end:
+#+vindex: modus-themes-intense-markup
+
+Brief: Toggle intense style for inline code and related markup.
+
+Symbol: ~modus-themes-intense-markup~ (=boolean= type)
+
+Possible value:
+
+1. ~nil~ (default)
+2. ~t~
+
+The default style for certain markup types like inline code and verbatim
+constructs in Org and related major modes is a subtle foreground color
+combined with a subtle background.
+
+With a non-nil value (~t~), these constructs will use a more prominent
+background and foreground color combination instead.
+
** Option for parenthesis matching
:properties:
:alt_title: Matching parentheses
@@ -1145,7 +1268,10 @@ updated to accommodate this aesthetic.
:end:
#+vindex: modus-themes-paren-match
-Symbol: ~modus-themes-paren-match~
+Brief: Control the style of matching delimiters produced by
+~show-paren-mode~.
+
+Symbol: ~modus-themes-paren-match~ (=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:
@@ -1192,7 +1318,9 @@ This customization variable affects the built-in ~show-paren-mode~ and the
:end:
#+vindex: modus-themes-region
-Symbol: ~modus-themes-region~
+Brief: Control the style of the region.
+
+Symbol: ~modus-themes-region~ (=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:
@@ -1238,7 +1366,9 @@ In user configuration files the form may look like this:
:end:
#+vindex: modus-themes-diffs
-Symbol: ~modus-themes-diffs~
+Bried: Set the overall style of diffs.
+
+Symbol: ~modus-themes-diffs~ (=choice= type)
Possible values:
@@ -1284,7 +1414,9 @@ interest of backward compatibility.
:end:
#+vindex: modus-themes-org-blocks
-Symbol: ~modus-themes-org-blocks~
+Brief: Set the overall style of Org code blocks, quotes, and the like.
+
+Symbol: ~modus-themes-org-blocks~ (=choice= type)
Possible values:
@@ -1325,7 +1457,10 @@ and ~rainbow~. Those will continue to work as they are aliases for
:end:
#+vindex: modus-themes-org-agenda
-Symbol: ~modus-themes-org-agenda~
+Brief: Control the style of the Org agenda. Multiple parameters are
+available, each with its own options.
+
+Symbol: ~modus-themes-org-agenda~ (=alist= type, multiple styles)
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
@@ -1335,7 +1470,7 @@ all possible combinations:
(setq modus-themes-org-agenda
'((header-block . (variable-pitch scale-title))
(header-date . (grayscale workaholic bold-today))
- (event . (accented scale-small))
+ (event . (accented italic varied))
(scheduled . uniform)
(habit . traffic-light)))
#+end_src
@@ -1394,28 +1529,41 @@ For example:
(header-date . (grayscale workaholic bold-today scale-heading))
#+end_src
-An ~event~ key covers events from the diary and other entries that derive
-from a symbolic expression or sexp (e.g. phases of the moon, holidays).
-This key accepts a list of values. By default (a nil value or an empty
-list) those have a gray foreground, while sexp events are additionally
-presented using slanted text (italics). The properties that can form a
-list of possible values are:
-
-- ~scale-small~ reduces the height of the entries to the value of the user
- option ~modus-themes-scale-small~ (0.9 the height of the main font size
- by default).
-- ~accented~ applies an accent value to the event's foreground, replacing
- the original gray.
+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:
+
+- ~scale-small~ reduces the height of the entries to the value of
+ the user option ~modus-themes-scale-small~ (0.9 the height of
+ the main font size by default). This work best when the
+ relevant entries have no tags associated with them and when the
+ user is interested in reducing their presence in the agenda
+ view.
+- ~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:
#+begin_src emacs-lisp
(event . nil)
-(event . (scale-small))
-(event . (scale-small accented))
-(event . (scale-small accented italic))
+(event . (italic))
+(event . (accented italic))
+(event . (accented italic varied))
#+end_src
A ~scheduled~ key applies to tasks with a scheduled date. By default (a
@@ -1498,7 +1646,10 @@ Putting it all together, the alist can look like this:
:end:
#+vindex: modus-themes-headings
-Symbol: ~modus-themes-headings~
+Brief: Control the style of headings. This can be particularised for
+each level of heading (e.g. Org has eight levels).
+
+Symbol: ~modus-themes-headings~ (=alist= type, multiple properties)
This is an alist that accepts a =(key . list-of-values)= combination. The
key is either a number, representing the heading's level or ~t~, which
@@ -1518,8 +1669,21 @@ Properties:
+ ~rainbow~
+ ~overline~
+ ~background~
-+ ~no-bold~
+ ~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~
By default (a ~nil~ value for this variable), all headings have a bold
typographic weight and use a desaturated text color.
@@ -1531,20 +1695,27 @@ An ~overline~ property draws a line above the area of the heading.
A ~background~ property adds a subtle tinted color to the background of
the heading.
-A ~no-bold~ property removes the bold weight from the heading's text.
-
A ~monochrome~ property makes all headings the same base color, which is
that of the default for the active theme (black/white). When ~background~
is also set, ~monochrome~ changes its color to gray. If both ~monochrome~
and ~rainbow~ are set, the former takes precedence.
+The symbol of a weight attribute adjusts the font of the heading
+accordingly, such as ~light~, ~semibold~, etc. Valid symbols are defined in
+the internal variable ~modus-themes--heading-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.
+
+[[#h:2793a224-2109-4f61-a106-721c57c01375][Configure bold and italic faces]].
+
Combinations of any of those properties are expressed as a list, like in
these examples:
#+begin_src emacs-lisp
-(no-bold)
+(semibold)
(rainbow background)
-(overline monochrome no-bold)
+(overline monochrome semibold)
#+end_src
The order in which the properties are set is not significant.
@@ -1555,7 +1726,7 @@ In user configuration files the form may look like this:
(setq modus-themes-headings
'((1 . (background overline rainbow))
(2 . (background overline))
- (t . (overline no-bold))))
+ (t . (overline semibold))))
#+end_src
When defining the styles per heading level, it is possible to pass a
@@ -1570,7 +1741,7 @@ original aesthetic for that level. For example:
(setq modus-themes-headings
'((1 . (background overline))
- (2 . (rainbow no-bold))
+ (2 . (rainbow semibold))
(t . t))) ; default style for all other levels
#+end_src
@@ -1591,7 +1762,9 @@ others, such as ~org-fontify-done-headline~.
:end:
#+vindex: modus-themes-scale-headings
-Symbol: ~modus-themes-scale-headings~
+Brief: Toggle the scaling of headings.
+
+Symbol: ~modus-themes-scale-headings~ (=boolean= type)
Possible values:
@@ -1610,6 +1783,17 @@ main text. This is noticeable in modes like Org, Markdown, and Info.
:custom_id: h:6868baa1-beba-45ed-baa5-5fd68322ccb3
:end:
+Brief: Specify the height for individual heading scales.
+
+Symbols (all are =number= type):
+
++ ~modus-themes-scale-1~
++ ~modus-themes-scale-2~
++ ~modus-themes-scale-3~
++ ~modus-themes-scale-4~
++ ~modus-themes-scale-title~
++ ~modus-themes-scale-small~
+
In addition to the toggle for enabling scaled headings, users can also
specify a number of their own.
@@ -1681,7 +1865,10 @@ size of the heading, but not of keywords that were added to it, like
:end:
#+vindex: modus-themes-variable-pitch-ui
-Symbol: ~modus-themes-variable-pitch-ui~
+Brief: Toggle the use of proportionately spaced (~variable-pitch~) fonts
+in the User Interface.
+
+Symbol: ~modus-themes-variable-pitch-ui~ (=boolean= type)
Possible values:
@@ -1708,7 +1895,10 @@ is done by assigning the ~variable-pitch~ face to the relevant items.
:end:
#+vindex: modus-themes-variable-pitch-headings
-Symbol: ~modus-themes-variable-pitch-headings~
+Brief: Toggle the use of proportionately spaced (~variable-pitch~) fonts
+in headings.
+
+Symbol: ~modus-themes-variable-pitch-headings~ (=boolean= type)
Possible values:
@@ -2460,17 +2650,16 @@ inspiration from the ~modus-themes-toggle~ we already provide:
:end:
#+cindex: Font configurations
-The themes are designed to cope well with mixed font configurations.
-
-[[#h:115e6c23-ee35-4a16-8cef-e2fcbb08e28b][Option for no font mixing]].
+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~.
-This mostly concerns ~org-mode~ and ~markdown-mode~, though expect to find
-it elsewhere like in ~Info-mode~.
+[[#h:115e6c23-ee35-4a16-8cef-e2fcbb08e28b][Option for font mixing]].
In practice it means that the user can safely opt for a more
prose-friendly proportionately spaced typeface as their default, while
-letting spacing-sensitive elements like tables and inline code always
-use a monospaced font, by inheriting from the ~fixed-pitch~ face.
+spacing-sensitive elements like tables and inline code always use a
+monospaced font, by inheriting from the ~fixed-pitch~ face.
Users can try the built-in {{{kbd(M-x variable-pitch-mode)}}} to see the
effect in action.
@@ -2491,7 +2680,14 @@ reading the doc string of ~set-face-attribute~):
(set-face-attribute 'variable-pitch nil :family "DejaVu Serif" :height 1.0)
;; Monospaced typeface
-(set-face-attribute 'fixed-pitch nil :family "DejaVu Sans Mono" :height 1.0)
+(set-face-attribute 'fixed-pitch nil :family "DejaVu Sans Mono" :height 1.5)
+#+end_src
+
+Or employ the ~face-attribute~ function to read an existing value, such as
+if you want to make ~fixed-pitch~ use the font family of the ~default~ face:
+
+#+begin_src emacs-lisp
+(set-face-attribute 'fixed-pitch nil :family (face-attribute 'default :family))
#+end_src
The next section shows how to make those work in a more elaborate setup
@@ -2504,12 +2700,13 @@ specify an absolute value, which is the point size × 10. So if you want
to use a font at point size =11=, you set the height to =110=.[fn:: ~:height~
values do not need to be rounded to multiples of ten: the likes of =115=
are perfectly valid—some typefaces will change to account for those
-finer increments.] Whereas every other face must have a value that is
-relative to the default, represented as a floating point (if you use an
-integer, then that means an absolute height). This is of paramount
-importance: it ensures that all fonts can scale gracefully when using
-something like the ~text-scale-adjust~ command which only operates on the
-base font size (i.e. the ~default~ face's absolute height).
+finer increments.] Whereas every other face must either not specify a
+height or have a value that is relative to the default, represented as a
+floating point. If you use an integer, then that means an absolute
+height. This is of paramount importance: it ensures that all fonts can
+scale gracefully when using something like the ~text-scale-adjust~ command
+which only operates on the base font size (i.e. the ~default~ face's
+absolute height).
[[#h:e6c5451f-6763-4be7-8fdb-b4706a422a4c][Note for EWW and Elfeed fonts]].
@@ -2545,7 +2742,7 @@ it means for a construct to be bold/italic, by tweaking the ~bold~ and
To achieve those effects, one must first be sure that the fonts they use
have support for those features. It then is a matter of following the
-instructions for all face tweaks.
+instructions for all typeface tweaks.
[[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]].
@@ -2573,19 +2770,20 @@ To reset the font family, one can use this:
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 hook it up to the
-~modus-themes-after-load-theme-hook~. This is necessary because the
-themes set the default styles of faces (otherwise changing themes would
-not be possible).
+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).
[[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]].
This is a minimal setup to preserve font configurations across theme
-load phases. For a more permanent setup, it is better to employ the
+load phases. For a more permanent setup, it is better to rely on the
~custom-set-faces~ function: ~set-face-attribute~ works just fine, though it
-is more convenient for quick previews or for smaller scale operations
-(~custom-set-faces~ follows the format used in the source code of the
-themes).
+probably is better suited for quick previews or for smaller scale
+operations (~custom-set-faces~ follows the format used in the source code
+of the themes, which can make it easier to redefine faces in bulk).
#+begin_src emacs-lisp
;; our generic function
@@ -2605,6 +2803,8 @@ themes).
(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]].
+
** Custom Org user faces
:properties:
:custom_id: h:89f0678d-c5c3-4a57-a526-668b2bb2d7ad
@@ -2897,6 +3097,101 @@ With those in place, PDFs have a distinct backdrop for their page, while
they automatically switch to their dark mode when ~modus-themes-toggle~ is
called from inside a buffer whose major-mode is ~pdf-view-mode~.
+** 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 re-use 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 re-use 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:
+
+#+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
+
** A theme-agnostic hook for theme loading
:properties:
:custom_id: h:86f6906b-f090-46cc-9816-1fe8aeb38776
@@ -3121,6 +3416,7 @@ have lots of extensions, so the "full support" may not be 100% true…
+ ido-mode
+ iedit
+ iflipb
++ image-dired
+ imenu-list
+ indium
+ info
@@ -3162,6 +3458,7 @@ have lots of extensions, so the "full support" may not be 100% true…
+ mu4e
+ mu4e-conversation
+ multiple-cursors
++ nano-modeline
+ neotree
+ no-emoji
+ notmuch
@@ -3263,6 +3560,7 @@ have lots of extensions, so the "full support" may not be 100% true…
+ vc-annotate (the output of {{{kbd(C-x v g)}}})
+ vdiff
+ vertico
++ vertico-quick
+ vimish-fold
+ visible-mark
+ visual-regexp
@@ -3314,7 +3612,6 @@ supported by the themes.
+ tide
+ vertico-indexed
+ vertico-mouse
-+ vertico-quick
* Notes on individual packages
:properties:
@@ -4219,7 +4516,7 @@ The source code of the themes is [[https://gitlab.com/protesilaos/modus-themes/]
being. A [[https://github.com/protesilaos/modus-themes/][mirror on Github]] is also on offer.
An HTML version of this manual is provided as an extension of the
-[[https://protesilaos.com/modus-themes/][author's personal website]] (does not rely on any non-free code).
+[[https://protesilaos.com/emacs/modus-themes/][author's personal website]] (does not rely on any non-free code).
** Issues you can help with
:properties:
@@ -4323,11 +4620,11 @@ The Modus themes are a collective effort. Every bit of work matters.
+ Author/maintainer :: Protesilaos Stavrou.
+ Contributions to code or documentation :: Anders Johansson, Basil
- L.{{{space()}}} Contovounesios, Carlo Zancanaro, Eli Zaretskii, Fritz Grabo,
- Kévin Le Gouguec, Kostadin Ninev, Madhavan Krishnan, Markus Beppler,
- Matthew Stevenson, Mauro Aranda, Nicolas De Jaeghere, Philip
- Kaludercic, Rudolf Adamkovič, Stephen Gildea, Shreyas Ragavan, Stefan
- Kangas, Vincent Murphy, Xinglu Chen.
+ L.{{{space()}}} Contovounesios, Carlo Zancanaro, Christian Tietze, Daniel
+ Mendler, Eli Zaretskii, Fritz Grabo, Kévin Le Gouguec, Kostadin Ninev,
+ Madhavan Krishnan, Markus Beppler, Matthew Stevenson, Mauro Aranda,
+ Nicolas De Jaeghere, Philip Kaludercic, Rudolf Adamkovič, Stephen
+ Gildea, Shreyas Ragavan, Stefan Kangas, Vincent Murphy, Xinglu Chen.
+ Ideas and user feedback :: Aaron Jensen, Adam Porter, Adam Spiers,
Adrian Manea, Alex Griffin, Alex Peitsinis, Alexey Shmalko, Alok
@@ -4336,19 +4633,20 @@ The Modus themes are a collective effort. Every bit of work matters.
Dimech, Damien Cassou, Daniel Mendler, Dario Gjorgjevski, David
Edmondson, Davor Rotim, Divan Santana, Eliraz Kedmi, Emanuele Michele
Alberto Monterosso, Farasha Euker, Feng Shu, Gautier Ponsinet, Gerry
- Agbobada, Gianluca Recchia, Gustavo Barros, Hörmetjan Yiltiz, Ilja
- Kocken, Iris Garcia, Jeremy Friesen, Jerry Zhang, John Haman, Joshua
- O'Connor, Kevin Fleming, Kévin Le Gouguec, Kostadin Ninev, Len Trigg,
- Manuel Uberti, Mark Burton, Markus Beppler, Mauro Aranda, Michael
- Goldenberg, Morgan Smith, Murilo Pereira, Nicky van Foreest, Nicolas
- De Jaeghere, Paul Poloskov, Pengji Zhang, Pete Kazmier, Peter Wu,
- Philip Kaludercic, Pierre Téchoueyres, Roman Rudakov, Ryan Phillips,
- Rudolf Adamkovič, Sam Kleinman, Shreyas Ragavan, Simon Pugnet, Tassilo
- Horn, Thibaut Verron, Thomas Heartman, Trey Merkley, Togan Muftuoglu,
- Toon Claes, Uri Sharf, Utkarsh Singh, Vincent Foley. As well as
- users: Ben, CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, Fredrik,
- Moesasji, Nick, TheBlob42, Trey, bepolymathe, doolio, fleimgruber,
- iSeeU, jixiuf, okamsn, pRot0ta1p.
+ Agbobada, Gianluca Recchia, Guilherme Semente, Gustavo Barros,
+ Hörmetjan Yiltiz, Ilja Kocken, Iris Garcia, Jeremy Friesen, Jerry
+ Zhang, Johannes Grødem, John Haman, Joshua O'Connor, Kevin Fleming,
+ Kévin Le Gouguec, Kostadin Ninev, Len Trigg, Manuel Uberti, Mark
+ Burton, Markus Beppler, Mauro Aranda, Michael Goldenberg, Morgan
+ Smith, Murilo Pereira, Nicky van Foreest, Nicolas De Jaeghere, Paul
+ Poloskov, Pengji Zhang, Pete Kazmier, Peter Wu, Philip Kaludercic,
+ Pierre Téchoueyres, Roman Rudakov, Ryan Phillips, Rudolf Adamkovič,
+ Sam Kleinman, Shreyas Ragavan, Simon Pugnet, Tassilo Horn, Thibaut
+ Verron, Thomas Heartman, Trey Merkley, Togan Muftuoglu, Toon Claes,
+ Uri Sharf, Utkarsh Singh, Vincent Foley. As well as users: Ben,
+ CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, Fredrik, Moesasji,
+ Nick, TheBlob42, Trey, bepolymathe, doolio, fleimgruber, iSeeU,
+ jixiuf, okamsn, pRot0ta1p.
+ Packaging :: Basil L.{{{space()}}} Contovounesios, Eli Zaretskii, Glenn
Morris, Mauro Aranda, Richard Stallman, Stefan Kangas (core Emacs),
@@ -4358,9 +4656,10 @@ The Modus themes are a collective effort. Every bit of work matters.
+ Inspiration for certain features :: Bozhidar Batsov (zenburn-theme),
Fabrice Niessen (leuven-theme).
-Special thanks, in no particular order, to Manuel Uberti, Gustavo
-Barros, and Omar Antolín Camarena for their long time contributions and
-insightful commentary.
+Special thanks (from A-Z) to Gustavo Barros, Manuel Uberti, Nicolas De
+Jaeghere, and Omar Antolín Camarena for their long time contributions
+and insightful commentary on key aspects of the themes' design and/or
+aspects of their functionality.
* Meta
:properties:
@@ -4388,9 +4687,9 @@ of this sort):
And here are the canonical sources of this project's documentation:
-+ Manual :: <https://protesilaos.com/modus-themes>
-+ Change Log :: <https://protesilaos.com/modus-themes-changelog>
-+ Screenshots :: <https://protesilaos.com/modus-themes-pictures>
++ Manual :: <https://protesilaos.com/emacs/modus-themes>
++ Change Log :: <https://protesilaos.com/emacs/modus-themes-changelog>
++ Screenshots :: <https://protesilaos.com/emacs/modus-themes-pictures>
* GNU Free Documentation License
:properties:
diff --git a/doc/misc/pcl-cvs.texi b/doc/misc/pcl-cvs.texi
index 4ba067fd81f..833326c089b 100644
--- a/doc/misc/pcl-cvs.texi
+++ b/doc/misc/pcl-cvs.texi
@@ -524,8 +524,8 @@ you can use in PCL-CVS@. They are grouped together by type.
Most commands in PCL-CVS require that you have a @file{*cvs*}
buffer. The commands that you use to get one are listed below.
For each, a @samp{cvs} process will be run, the output will be parsed by
-PCL-CVS, and the result will be printed in the @file{*cvs*} buffer (see
-@ref{Buffer contents}, for a description of the buffer's contents).
+PCL-CVS, and the result will be printed in the @file{*cvs*} buffer
+(@pxref{Buffer contents}, for a description of the buffer's contents).
@table @kbd
@item M-x cvs-update
diff --git a/doc/misc/rcirc.texi b/doc/misc/rcirc.texi
index 603bf42e0cc..f03f614275c 100644
--- a/doc/misc/rcirc.texi
+++ b/doc/misc/rcirc.texi
@@ -609,12 +609,6 @@ Use this symbol if you need to identify yourself in the Bitlbee channel
as follows: @code{identify secret}. The necessary arguments are the
nickname you want to use this for, and the password to use.
-@item sasl
-@cindex sasl authentication
-Use this symbol if you want to use @acronym{SASL} authentication. The
-necessary arguments are the nickname you want to use this for, and the
-password to use.
-
@cindex gateway to other IM services
@cindex instant messaging, other services
@cindex Jabber
@@ -633,6 +627,19 @@ the other instant messaging services, and Bitlbee will log you in. All
@code{rcirc} needs to know, is the login to your Bitlbee account. Don't
confuse the Bitlbee account with all the other accounts.
+@item sasl
+@cindex sasl authentication
+Use this symbol if you want to use @acronym{SASL} authentication. The
+necessary arguments are the nickname you want to use this for, and the
+password to use.
+
+@item certfp
+@cindex certfp authentication
+Use this symbol if you want to use CertFP authentication. The
+necessary arguments are the path to the client certificate key and
+password. The CertFP authentication requires a @acronym{TLS}
+connection.
+
@end table
@end table
diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex
index e48383defc4..6e194298948 100644
--- a/doc/misc/texinfo.tex
+++ b/doc/misc/texinfo.tex
@@ -3,7 +3,7 @@
% Load plain if necessary, i.e., if running under initex.
\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi
%
-\def\texinfoversion{2021-04-25.21}
+\def\texinfoversion{2021-11-01.16}
%
% Copyright 1985, 1986, 1988, 1990-2021 Free Software Foundation, Inc.
%
@@ -3614,6 +3614,9 @@ $$%
\def\quotedblbase{{\ecfont \char"12}}
\def\quotesinglbase{{\ecfont \char"0D}}
%
+\def\L{{\ecfont \char"8A}} % L with stroke
+\def\l{{\ecfont \char"AA}} % l with stroke
+%
% This positioning is not perfect (see the ogonek LaTeX package), but
% we have the precomposed glyphs for the most common cases. We put the
% tests to use those glyphs in the single \ogonek macro so we have fewer
@@ -7592,6 +7595,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
%
\def\printdefunline#1#2{%
\begingroup
+ \plainfrenchspacing
% call \deffnheader:
#1#2 \endheader
% common ending:
@@ -9402,7 +9406,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\fi\fi
%
\ifimagevmode
- \nobreak\medskip
+ \medskip
% Usually we'll have text after the image which will insert
% \parskip glue, so insert it here too to equalize the space
% above and below.
@@ -11599,11 +11603,9 @@ directory should work if nowhere else does.}
@setregularquotes
@c Local variables:
-@c eval: (add-hook 'before-save-hook 'time-stamp)
+@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 time-stamp-start: "def\\\\texinfoversion{"
-@c time-stamp-format: "%:y-%02m-%02d.%02H"
-@c time-stamp-end: "}"
@c End:
@c vim:sw=2:
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 27ad912523b..86f4d1c38eb 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -2238,8 +2238,7 @@ preserves the path value, which can be used to update
shell supports the login argument @samp{-l}.
@end defopt
-Starting with @w{Emacs 26}, @code{tramp-remote-path} can be set per
-host via connection-local
+@code{tramp-remote-path} can also be set per host via connection-local
@ifinfo
variables, @xref{Connection Variables, , , emacs}.
@end ifinfo
@@ -3389,9 +3388,9 @@ returns the exit code for it. When the user option
indication that the process has been interrupted, and returns a
corresponding string.
-This remote process handling does not apply to @acronym{GVFS} (see
-@ref{GVFS-based methods}) because the remote file system is mounted on
-the local host and @value{tramp} accesses it by changing the
+This remote process handling does not apply to @acronym{GVFS}
+(@pxref{GVFS-based methods}) because the remote file system is mounted
+on the local host and @value{tramp} accesses it by changing the
@code{default-directory}.
@value{tramp} starts a remote process when a command is executed in a
@@ -3411,7 +3410,7 @@ might also add their name to this environment variable, like
For @value{tramp} to find the command on the remote, it must be
accessible through the default search path as setup by @value{tramp}
upon first connection. Alternatively, use an absolute path or extend
-@code{tramp-remote-path} (see @ref{Remote programs}):
+@code{tramp-remote-path} (@pxref{Remote programs}):
@lisp
@group
@@ -3533,9 +3532,8 @@ ensures the correct name of the remote shell program.
When @code{explicit-shell-file-name} is equal to @code{nil}, calling
@code{shell} interactively will prompt for a shell name.
-Starting with @w{Emacs 26}, you could use connection-local variables
-for setting different values of @code{explicit-shell-file-name} for
-different remote hosts.
+You could use connection-local variables for setting different values
+of @code{explicit-shell-file-name} for different remote hosts.
@ifinfo
@xref{Connection Variables, , , emacs}.
@end ifinfo
@@ -4061,6 +4059,11 @@ CPIO archives
@cindex @file{cpio} file archive suffix
@cindex file archive suffix @file{cpio}
+@item @samp{.crate} ---
+Cargo (Rust) packages
+@cindex @file{crate} file archive suffix
+@cindex file archive suffix @file{crate}
+
@item @samp{.deb} ---
Debian packages
@cindex @file{deb} file archive suffix
@@ -4347,8 +4350,8 @@ Where is the latest @value{tramp}?
@item
Which systems does it work on?
-The package works successfully on @w{Emacs 25}, @w{Emacs 26}, @w{Emacs
-27}, and @w{Emacs 28}.
+The package works successfully on @w{Emacs 26}, @w{Emacs 27}, @w{Emacs
+28}, and @w{Emacs 29}.
While Unix and Unix-like systems are the primary remote targets,
@value{tramp} has equal success connecting to other platforms, such as
@@ -5225,6 +5228,28 @@ time being you can suppress this error by the following code in your
@item
+I get an error @samp{Remote file error: Not a valid Tramp file name
+function `tramp-FOO-file-name-p'}
+
+@value{tramp} has changed the signature of an internal function.
+External packages implementing an own @value{tramp} backend must
+follow this change. Please report this problem to the author of that
+package.
+
+For the running session, @value{tramp} disables the external package,
+and you can continue to work. If you don't want to see this error
+while activating @value{tramp}, you can suppress it by the same code
+as above in your @file{~/.emacs}:
+
+@lisp
+@group
+(setq debug-ignored-errors
+ (cons 'remote-file-error debug-ignored-errors))
+@end group
+@end lisp
+
+
+@item
How to disable other packages from calling @value{tramp}?
There are packages that call @value{tramp} without the user ever
diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi
index e9fbacc7920..89c478035c0 100644
--- a/doc/misc/trampver.texi
+++ b/doc/misc/trampver.texi
@@ -8,10 +8,10 @@
@c In the Tramp GIT, the version numbers are auto-frobbed from
@c tramp.el, and the bug report address is auto-frobbed from
@c configure.ac.
-@set trampver 2.5.2.28.1
+@set trampver 2.6.0-pre
@set trampurl https://www.gnu.org/software/tramp/
@set tramp-bug-report-address tramp-devel@@gnu.org
-@set emacsver 25.1
+@set emacsver 26.1
@c Other flags from configuration.
@set instprefix /usr/local
diff --git a/doc/misc/vhdl-mode.texi b/doc/misc/vhdl-mode.texi
index fef98a74636..7022582db51 100644
--- a/doc/misc/vhdl-mode.texi
+++ b/doc/misc/vhdl-mode.texi
@@ -243,7 +243,7 @@ components. Also notice that the first component,
@vindex vhdl-offsets-alist
@vindex offsets-alist @r{(vhdl-)}
Indentation for the current line is calculated using the syntactic
-component list derived in step 1 above (see @ref{Syntactic
+component list derived in step 1 above (@pxref{Syntactic
Analysis}). Each component contributes to the final total indentation
of the line in two ways.
@@ -668,7 +668,7 @@ not handled by the mode directly.
@cindex custom indentation functions
One of the most common ways to customize VHDL Mode is by writing
@dfn{custom indentation functions} and associating them with specific
-syntactic symbols (see @ref{Syntactic Symbols}). VHDL Mode itself
+syntactic symbols (@pxref{Syntactic Symbols}). VHDL Mode itself
uses custom indentation functions to provide more sophisticated
indentation, for example when lining up selected signal assignments:
@example
@@ -732,7 +732,7 @@ operator on the first line of the statement. Here is the lisp code
@end example
@noindent
Custom indent functions take a single argument, which is a syntactic
-component cons cell (see @ref{Syntactic Analysis}). The
+component cons cell (@pxref{Syntactic Analysis}). The
function returns an integer offset value that will be added to the
running total indentation for the line. Note that what actually gets
returned is the difference between the column that the signal assignment
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index f533c58aa41..31ea3de620d 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -12,6 +12,14 @@ extensible IRC (Internet Relay Chat) client distributed with
GNU Emacs since Emacs version 22.1.
+* Changes in ERC 5.4.1
+
+** No user-visible changes since ERC 5.4, but a few tweaks in some ERC
+file headers and the ERC manual in order to successfully build ERC for
+GNU ELPA. (See below for the news item of ERC now being distributed
+on GNU ELPA in addition to its continued inclusion in GNU Emacs core.)
+
+
* Changes in ERC 5.4
** Starting with Emacs 28.1 and ERC 5.4, ERC NEWS are added here again.
diff --git a/etc/MACHINES b/etc/MACHINES
index d8d0b86fb4d..d883f1abd60 100644
--- a/etc/MACHINES
+++ b/etc/MACHINES
@@ -103,6 +103,34 @@ the list at the end of this file.
./configure CC='gcc -m64' # GCC
./configure CC='cc -m64' # Oracle Developer Studio
+** Haiku
+
+ On 32-bit Haiku it is required that the newer GCC 8 be used, instead
+ of the legacy GCC 2 used by default. This can be achieved by
+ invoking configure inside a shell launched by the 'setarch' program
+ invoked as 'setarch x86'.
+
+ When building with packages discovered through pkg-config, such as
+ libpng, on a GCC 2/GCC 8 hybrid system, simply evaluating 'setarch
+ x86' is insufficient to ensure that all required libraries are found
+ at their correct locations. To avoid this problem, set the
+ environment variable 'PKG_CONFIG_PATH' to the GCC 8 pkg-config
+ directory at '/system/develop/lib/x86/pkgconfig/' before configuring
+ Emacs.
+
+ If GCC complains about not being able to resolve symbols such as
+ "BHandler::LockLooper", you are almost certainly experiencing this
+ problem.
+
+ Haiku running on non-x86 systems has not been tested. It is
+ anticipated that Haiku running on big-endian systems will experience
+ problems when Emacs is built with Haiku windowing support, but there
+ doesn't seem to be any reliable way to get Haiku running on a
+ big-endian system at present.
+
+ The earliest release of Haiku that will successfully compile Emacs
+ is R1/Beta2. For windowing support, R1/Beta3 or later is required.
+
* Obsolete platforms
diff --git a/etc/NEWS b/etc/NEWS
index e7d72159023..24f3da8f96f 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1,15 +1,15 @@
GNU Emacs NEWS -- history of user-visible changes.
-Copyright (C) 2019-2021 Free Software Foundation, Inc.
+Copyright (C) 2021 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 28.
+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.27, NEWS.26, ..., NEWS.18, and NEWS.1-17 for changes
+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'
@@ -22,4561 +22,1187 @@ When you add a new item, use the appropriate mark if you are sure it
applies, and please also update docstrings as needed.
-* Installation Changes in Emacs 28.1
-
-** Emacs now optionally supports native compilation of Lisp files.
-To enable this, configure Emacs with the '--with-native-compilation' option.
-This requires the libgccjit library to be installed and functional,
-and also requires GCC and Binutils to be available when Lisp code is
-natively compiled. See the Info node "(elisp) Native Compilation" for
-more details.
-
-If you build Emacs with native compilation, but without zlib, be sure
-to configure with the '--without-compress-install' option, so that the
-installed *.el files are not compressed; otherwise, you will not be
-able to use JIT native compilation of the installed *.el files.
-
-Note that JIT native compilation is done in a fresh session of Emacs
-that is run in a subprocess, so it can legitimately report some
-warnings and errors that aren't uncovered by byte-compilation. We
-recommend examining any such warnings before you decide they are
-false.
-
-** The Cairo graphics library is now used by default if present.
-'--with-cairo' is now the default, if the appropriate development files
-are found by 'configure'. Note that building with Cairo means using
-Pango instead of libXFT for font support. Since Pango 1.44 has
-removed support for bitmapped fonts, this may require you to adjust
-your font settings.
-
-Note also that 'FontBackend' settings in ".Xdefaults" or
-".Xresources", or 'font-backend' frame parameter settings in your init
-files, may need to be adjusted, as 'xft' is no longer a valid backend
-when using Cairo. Use 'ftcrhb' if your Emacs was built with HarfBuzz
-text shaping support, and 'ftcr' otherwise. You can determine this by
-checking 'system-configuration-features'. The 'ftcr' backend will
-still be available when HarfBuzz is supported, but will not be used by
-default. We strongly recommend building with HarfBuzz support. 'x' is
-still a valid backend.
-
----
-** 'configure' now warns about building with libXft support.
-libXft is unmaintained, and causes a number of problems with modern
-fonts including but not limited to crashes; support for it may be
-removed in a future version of Emacs. Please consider using
-Cairo + HarfBuzz instead.
-
----
-** 'configure' now warns about not using HarfBuzz if using Cairo.
-We want to encourage people to use the most modern font features
-available, and this is the Cairo graphics library + HarfBuzz for font
-shaping, so 'configure' now recommends that combination.
-
----
-** Building without double buffering support.
-'configure --with-xdbe=no' can now be used to disable double buffering
-at build time.
-
----
-** Support for building with Motif has been removed.
-
----
-** The configure option '--without-makeinfo' has been removed.
-This was only ever relevant when building from a repository checkout.
-This now requires makeinfo, which is part of the texinfo package.
-
----
-** New configure option '--disable-year2038'.
-This causes Emacs to use only 32-bit time_t on platforms that have
-both 32- and 64-bit time_t. This may help when linking Emacs with a
-library with an ABI requiring traditional 32-bit time_t. This option
-currently affects only 32-bit ARM and x86 running GNU/Linux with glibc
-2.34 and later. Emacs now defaults to 64-bit time_t on these
-platforms.
-
----
-** Support for building with '-fcheck-pointer-bounds' has been removed.
-GCC has withdrawn the '-fcheck-pointer-bounds' option and support for
-its implementation has been removed from the Linux kernel.
-
----
-** The ftx font backend driver has been removed.
-It was declared obsolete in Emacs 27.1.
-
----
-** Emacs no longer supports old OpenBSD systems.
-OpenBSD 5.3 and older releases are no longer supported, as they lack
-proper pty support that Emacs needs.
-
-
-* Startup Changes in Emacs 28.1
-
----
-** In GTK builds, Emacs now supports startup notification.
-This means that Emacs won't steal keyboard focus upon startup
-(when started via the Desktop) if the user is typing into another
-application.
-
----
-** Errors in 'kill-emacs-hook' no longer prevent Emacs from shutting down.
-If a function in that hook signals an error in an interactive Emacs,
-the user will be prompted on whether to continue. If the user doesn't
-answer within five seconds, Emacs will continue shutting down anyway.
-
-** Emacs now supports loading a Secure Computing filter.
-This is supported only on capable GNU/Linux systems. To activate,
-invoke Emacs with the '--seccomp=FILE' command-line option. FILE must
-name a binary file containing an array of 'struct sock_filter'
-structures. Emacs will then install that list of Secure Computing
-filters into its own process early during the startup process. You
-can use this functionality to put an Emacs process in a sandbox to
-avoid security issues when executing untrusted code. See the manual
-page for 'seccomp' system call, for details about Secure Computing
-filters.
-
-** Emacs can support 24-bit color TTY without terminfo database.
-If your text-mode terminal supports 24-bit true color, but your system
-lacks the terminfo database, you can instruct Emacs to support 24-bit
-true color by setting 'COLORTERM=truecolor' in the environment. This is
-useful on systems such as FreeBSD which ships only with "etc/termcap".
-
----
-** File names given on the command line are now be pushed onto history.
-The file names will be pushed onto 'file-name-history', like the names
-of files visited via 'C-x C-f' and other commands.
-
-
-* Changes in Emacs 28.1
-
----
-** Emacs now supports Unicode Standard version 14.0.
+* Installation Changes in Emacs 29.1
+++
-** Improved support for Emoji.
-On capable systems, Emacs now correctly displays Emoji and Emoji
-sequences by default, provided that a suitable font is available to
-Emacs. With a few exceptions, all of the Emoji sequences specified by
-Unicode 14.0 are automatically composed and displayed as a single
-colorful glyph. This is achieved by changes in the Emacs font
-configuration, and by additional character-composition rules for the
-Emoji codepoints that follow from the Unicode-defined sequences.
-
-If your system lacks a suitable font, we recommend to install "Noto
-Color Emoji"; Emacs will use it automatically if it's installed. If
-you prefer to use another font for Emoji, customize your fontset like
-this:
-
- (set-fontset-font t 'emoji
- '("My New Emoji Font" . "iso10646-1") nil 'prepend)
-
-The Emoji characters are now assigned to a special script, 'emoji', so
-as to make it easier to customize fontsets for Emoji display, as in
-the above example. (Previously, the Emoji characters were assigned to
-the 'symbol' script, together with other symbol and punctuation
-characters.)
+** 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.
-+++
-** 'glyphless-char-display-control' now applies to Variation Selectors.
-VS-1 through VS-16 are now displayed as 'thin-space' by default when
-not composed with previous characters (typically, as part of Emoji
-sequences).
-
-+++
-** New command 'execute-extended-command-for-buffer'.
-This new command, bound to 'M-S-x', works like
-'execute-extended-command', but limits the set of commands to the
-commands that have been determined to be particularly useful with the
-current mode.
-
-+++
-** New user option 'read-extended-command-predicate'.
-This user option controls how 'M-x' performs completion of commands when
-you type 'TAB'. By default, any command that matches what you have
-typed is considered a completion candidate, but you can customize this
-option to exclude commands that are not applicable to the current
-buffer's major and minor modes, and respect the command's completion
-predicate (if any).
+** 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.
+++
-** Completion on 'M-x' shows key bindings for commands.
-When 'suggest-key-bindings' is non-nil (as it is by default), the
-completion list popped up by 'M-x' shows the key bindings for all the
-commands shown in the list of candidate completions that have a key
-binding.
-
-+++
-** New user option 'completions-detailed'.
-When non-nil, some commands like 'describe-symbol' show more detailed
-completions with more information in completion prefix and suffix.
-The default is nil.
-
----
-** 'C-s' in 'M-x' now once again searches over completions.
-In Emacs 23, typing 'M-x' ('read-extended-command') and then 'C-s' (to
-do an interactive search) would search over possible completions.
-This was lost in Emacs 24, but is now back again.
-
-+++
-** User option 'completions-format' supports a new value 'one-column'.
-
-+++
-** New system for displaying documentation for groups of functions.
-This can either be used by saying 'M-x shortdoc-display-group' and
-choosing a group, or clicking a button in the "*Help*" buffers when
-looking at the doc string of a function that belongs to one of these
-groups.
-
-+++
-** New minor mode 'context-menu-mode' for context menus popped by 'mouse-3'.
-When this mode is enabled, clicking 'down-mouse-3' (usually, the
-right mouse button) anywhere in the buffer pops up a menu whose
-contents depends on surrounding context near the mouse click.
-You can change the order of the default sub-menus in the context menu
-by customizing the user option 'context-menu-functions'. You can also
-invoke the context menu by pressing 'S-<F10>' or, on macOS, by
-clicking 'C-down-mouse-1'.
-
-+++
-** A new keymap for buffer actions has been added.
-The 'C-x x' keymap now holds keystrokes for various buffer-oriented
-commands. The new keystrokes are 'C-x x g' ('revert-buffer-quick'),
-'C-x x r' ('rename-buffer'), 'C-x x u' ('rename-uniquely'), 'C-x x n'
-('clone-buffer'), 'C-x x i' ('insert-buffer'), 'C-x x t'
-('toggle-truncate-lines') and 'C-x x f' ('font-lock-update').
-
-+++
-** Modifiers now go outside angle brackets in pretty-printed key bindings.
-For example, 'RET' with Control and Meta modifiers is now shown as
-'C-M-<return>' instead of '<C-M-return>'. Either variant can be used
-as input; functions such as 'kbd' and 'read-kbd-macro' accept both
-styles as equivalent (they have done so for a long time).
+*** Cairo drawing support has been enabled for Haiku builds.
+To enable Cairo support, ensure that the Cairo and FreeType
+development files are present on your system, and configure Emacs with
+'--with-be-cairo'.
---
-** 'eval-expression' no longer signals an error on incomplete expressions.
-Previously, typing 'M-: ( RET' would result in Emacs saying "End of
-file during parsing" and dropping out of the minibuffer. The user
-would have to type 'M-: M-p' to edit and redo the expression. Now
-Emacs will echo the message and allow the user to continue editing.
+*** Double buffering is now enabled on the Haiku operating system.
+Unlike X, there is no compile-time option to enable or disable
+double-buffering. If you wish to disable double-buffering, change the
+frame parameter 'inhibit-double-buffering' instead.
-+++
-** 'eval-last-sexp' now handles 'defvar'/'defcustom'/'defface' specially.
-This command would previously not redefine values defined by these
-forms, but this command has now been changed to work more like
-'eval-defun', and reset the values as specified.
+** 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.
----
-** New user option 'use-short-answers'.
-When non-nil, the function 'y-or-n-p' is used instead of
-'yes-or-no-p'. This eliminates the need to define an alias that maps
-one to another in the init file. The same user option also controls
-whether the function 'read-answer' accepts short answers.
+** Emacs now supports use of XInput 2 for input events.
+If your X server has support and you have the XInput 2 development headers
+installed, you can configure Emacs with the option '--with-xinput2' to enable
+this support.
-+++
-** New user option 'kill-buffer-delete-auto-save-files'.
-If non-nil, killing a buffer that has an auto-save file will prompt
-the user for whether that auto-save file should be deleted. (Note
-that 'delete-auto-save-files', if non-nil, was previously documented
-to result in deletion of auto-save files when killing a buffer without
-unsaved changes, but this has apparently not worked for several
-decades, so the documented semantics of this variable has been changed
-to match the behavior.)
+The named feature 'xinput2' can be used to test for the presence of
+XInput 2 support from Lisp programs.
-+++
-** New user option 'next-error-message-highlight'.
-In addition to a fringe arrow, 'next-error' error may now optionally
-highlight the current error message in the 'next-error' buffer.
-This user option can be also customized to keep highlighting on all
-visited errors, so you can have an overview what errors were already visited.
+** Emacs now supports being built with pure GTK.
+To use this option, make sure the GTK 3 and Cairo development files
+are installed, and configure Emacs with the option '--with-pgtk'.
+Unlike the default X and GTK build, the resulting Emacs binary will
+work on any underlying window system supported by GDK, such as
+Wayland and Broadway.
----
-** New choice 'next-error-quit-window' for 'next-error-found-function'.
-When 'next-error-found-function' is customized to 'next-error-quit-window',
-then typing the numeric prefix argument 0 before the command 'next-error'
-will quit the source window after visiting the next occurrence.
-
-+++
-** New user option 'file-preserve-symlinks-on-save'.
-This controls what Emacs does when saving buffers that visit files via
-symbolic links, and 'file-precious-flag' is non-nil.
-
-+++
-** New user option 'copy-directory-create-symlink'.
-If non-nil, will make 'copy-directory' (when used on a symbolic
-link) copy the link instead of following the link. The default is
-nil, so the default behavior is unchanged.
-
-+++
-** New user option 'ignored-local-variable-values'.
-This is the opposite of 'safe-local-variable-values' -- it's an alist
-of variable-value pairs that are to be ignored when reading a
-local-variables section of a file.
-
----
-** Specific warnings can now be disabled from the warning buffer.
-When a warning is displayed to the user, the resulting buffer now has
-buttons which allow making permanent changes to the treatment of that
-warning. Automatic showing of the warning can be disabled (although
-it is still logged to the "*Messages*" buffer), or the warning can be
-disabled entirely.
-
-+++
-** ".dir-locals.el" now supports setting 'auto-mode-alist'.
-The new 'auto-mode-alist' specification in ".dir-locals.el" files can
-now be used to override the global 'auto-mode-alist' in the current
-directory tree.
-
----
-** User option 'uniquify-buffer-name-style' can now be a function.
-This user option can be one of the predefined styles or a function to
-personalize the uniquified buffer name.
-
----
-** 'remove-hook' is now an interactive command.
-
----
-** 'expand-file-name' now checks for null bytes in filenames.
-The function will now check for null bytes in both NAME and
-DEFAULT-DIRECTORY arguments, as well as in the 'default-directory'
-buffer-local variable, when its value is used. If null bytes are
-found, 'expand-file-name' will signal an error.
-This means that practically all file-related operations will now check
-file names for null bytes, thus avoiding subtle bugs with silently
-using only the part of file name up to the first null byte.
-
----
-** Frames
-
-+++
-*** The key prefix 'C-x 5 5' displays next command buffer in a new frame.
-It's bound to the command 'other-frame-prefix' that requests the buffer
-of the next command to be displayed in a new frame.
-
-+++
-*** New command 'clone-frame' (bound to 'C-x 5 c').
-This is like 'C-x 5 2', but uses the window configuration and frame
-parameters of the current frame instead of 'default-frame-alist'.
-When called interactively with a prefix arg, the window configuration
-is not cloned.
-
----
-*** Default values of 'frame-title-format' and 'icon-title-format' have changed.
-These variables are used to display the title bar of visible frames
-and the title bar of an iconified frame. They now show the name of
-the current buffer and the text "GNU Emacs" instead of the value of
-'invocation-name'. To get the old behavior back, add the following to
-your init file:
-
- (setq frame-title-format '(multiple-frames "%b"
- ("" invocation-name "@" system-name)))
-
-+++
-*** New frame parameter 'drag-with-tab-line'.
-This parameter, similar to 'drag-with-header-line', allows moving frames
-by dragging the tab lines of their topmost windows with the mouse.
-
-+++
-*** New optional behavior of 'delete-other-frames'.
-When invoked with a prefix argument, 'delete-other-frames' now
-iconifies frames, rather than deleting them.
-
----
-*** Commands 'set-frame-width' and 'set-frame-height' now prompt for values.
-These commands now prompt for the value via the minibuffer, instead of
-requiring the user to specify the value via the prefix argument.
-
-** Windows
-
-+++
-*** The key prefix 'C-x 4 1' displays next command buffer in the same window.
-It's bound to the command 'same-window-prefix' that requests the buffer
-of the next command to be displayed in the same window.
-
-+++
-*** The key prefix 'C-x 4 4' displays next command buffer in a new window.
-It's bound to the command 'other-window-prefix' that requests the buffer
-of the next command to be displayed in a new window.
-
-+++
-*** New command 'recenter-other-window', bound to 'S-M-C-l'.
-Like 'recenter-top-bottom', but acting on the other window.
-
-+++
-*** New user option 'delete-window-choose-selected'.
-This allows specifying how Emacs chooses which window will be the
-frame's selected window after the currently selected window is
-deleted.
-
-+++
-*** New argument NO-OTHER for some window functions.
-'get-lru-window', 'get-mru-window' and 'get-largest-window' now accept a
-new optional argument NO-OTHER which, if non-nil, avoids returning a
-window whose 'no-other-window' parameter is non-nil.
-
-+++
-*** New 'display-buffer' function 'display-buffer-use-least-recent-window'.
-This is like 'display-buffer-use-some-window', but won't reuse the
-current window, and when called repeatedly will try not to reuse a
-previously selected window.
-
-+++
-*** New function 'window-bump-use-time'.
-This updates the use time of a window.
-
-** Minibuffer
-
-+++
-*** Minibuffer scrolling is now conservative by default.
-This is controlled by the new variable 'scroll-minibuffer-conservatively'.
-It is t by default; setting it to nil will cause scrolling in the
-minibuffer obey the value of 'scroll-conservatively'.
-
-+++
-*** Improved handling of minibuffers on switching frames.
-By default, when you switch to another frame, an active minibuffer now
-moves to the newly selected frame. Nevertheless, the effect of what
-you type in the minibuffer happens in the frame where the minibuffer
-was first activated. An alternative behavior is available by
-customizing 'minibuffer-follows-selected-frame' to nil. Here, the
-minibuffer stays in the frame where you first opened it, and you must
-switch back to this frame to continue or abort its command. The old
-behavior, which mixed these two, can be approximated by customizing
-'minibuffer-follows-selected-frame' to a value which is neither nil
-nor t.
-
-+++
-*** New user option 'read-minibuffer-restore-windows'.
-When customized to nil, it uses 'minibuffer-restore-windows' in
-'minibuffer-exit-hook' to remove only the window showing the
-"*Completions*" buffer, but keeps all other windows created
-while the minibuffer was active.
-
----
-*** New variable 'redisplay-adhoc-scroll-in-resize-mini-windows'.
-Customizing it to nil will disable the ad-hoc auto-scrolling of
-minibuffer text shown in mini-windows when resizing those windows.
-The default heuristics of that scrolling can be counter productive in
-some corner cases, though the cure might be worse than the disease.
-This said, the effect should be negligible in the vast majority of
-cases anyway.
-
-** Mode Line
-
-+++
-*** New user option 'mode-line-compact'.
-If non-nil, repeating spaces are compressed into a single space. If
-'long', this is only done when the mode line is longer than the
-current window width (in columns).
-
-+++
-*** New user options to control format of line/column numbers in the mode line.
-'mode-line-position-line-format' is the line number format (when
-'line-number-mode' is on), 'mode-line-position-column-format' is
-the column number format (when 'column-number-mode' is on), and
-'mode-line-position-column-line-format' is the combined format (when
-both modes are on).
-
-** Tab Bars and Tab Lines
-
-+++
-*** The prefix key 'C-x t t' can be used to display a buffer in a new tab.
-Typing 'C-x t t' before a command will cause the buffer shown by that
-command to be displayed in a new tab. 'C-x t t' is bound to the
-command 'other-tab-prefix'.
-
-+++
-*** New command 'C-x t C-r' to open file read-only in the other tab.
-
-+++
-*** The tab bar now supports more mouse commands.
-Clicking 'mouse-2' closes the tab, 'mouse-3' displays the context menu
-with items that operate on the clicked tab. Dragging the tab with
-'mouse-1' moves it to another position on the tab bar. Mouse wheel
-scrolling switches to the previous/next tab, and holding the Shift key
-during scrolling moves the tab to the left/right.
-
-+++
-*** Frame-specific appearance of the tab bar when 'tab-bar-show' is a number.
-When 'tab-bar-show' is a number, the tab bar on different frames can
-be shown or hidden independently, as determined by the number of tabs
-on each frame compared to the numerical value of 'tab-bar-show'.
-
-+++
-*** New command 'toggle-frame-tab-bar'.
-It can be used to enable/disable the tab bar on the currently selected
-frame regardless of the values of 'tab-bar-mode' and 'tab-bar-show'.
-This allows enabling/disabling the tab bar independently on different
-frames.
+
+* Startup Changes in Emacs 29.1
+++
-*** New user option 'tab-bar-format' defines a list of tab bar items.
-When it contains 'tab-bar-format-global' (possibly appended after
-'tab-bar-format-align-right'), then after enabling 'display-time-mode'
-(or any other mode that uses 'global-mode-string') it displays time
-aligned to the right on the tab bar instead of on the mode line.
-When 'tab-bar-format-tabs' is replaced with 'tab-bar-format-tabs-groups',
-the tab bar displays tab groups.
+** Emacs now has a '--fingerprint' option.
+This will output a string identifying the current Emacs build.
+++
-*** New optional key binding for 'tab-last'.
-If you customize the user option 'tab-bar-select-tab-modifiers' to
-allow selecting tabs using their index numbers, the '<MODIFIER>-9' key
-is bound to 'tab-last', and switches to the last tab. Here <MODIFIER>
-is any of the modifiers in the list that is the value of
-'tab-bar-select-tab-modifiers'. You can also use positive indices,
-which count from the last tab: 1 is the last tab, 2 the one before
-that, etc.
-
----
-*** New command 'tab-duplicate' bound to 'C-x t n'.
-
----
-*** 'C-x t N' creates a new tab at the specified absolute position.
-The position is provided as prefix arg, and specifies an index that
-starts at 1. Negative values count from the end of the tab bar.
+** New hook 'after-pdump-load-hook'.
+This is run at the end of the Emacs startup process, and it meant to
+be used to reinitialize structures that would normally be done at load
+time.
----
-*** 'C-x t M' moves the current tab to the specified absolute position.
-The position is provided as prefix arg, whose interpretation is as in
-'C-x t N'.
-
----
-*** 'C-x t G' assigns a tab to a named group of tabs.
-'tab-close-group' closes all tabs that belong to the selected group.
-The user option 'tab-bar-new-tab-group' defines the default group of
-new tabs. After customizing 'tab-bar-tab-post-change-group-functions'
-to 'tab-bar-move-tab-to-group', changing the group of a tab will also
-move it closer to other tabs in the same group.
+
+* Incompatible changes in Emacs 29.1
---
-*** New user option 'tab-bar-tab-name-format-function'.
+** '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.
---
-*** New user option 'tab-line-tab-name-format-function'.
+** The mode line now uses a proportional font by default.
+To get the old monospaced mode line back, customize the
+'mode-line-active' and 'mode-line-inactive' faces not to inherit from
+the 'variable-pitch' face, or add this to your "~/.emacs":
----
-*** The tabs in the tab line can now be scrolled using horizontal scroll.
-If your mouse or trackpad supports it, you can now scroll tabs when
-the mouse pointer is in the tab line by scrolling left or right.
+ (set-face-attribute 'mode-line-active nil :inherit 'mode-line)
+ (set-face-attribute 'mode-line-inactive nil :inherit 'mode-line)
----
-*** New tab-line faces and user options.
-The face 'tab-line-tab-special' is used for tabs whose buffers are
-special, i.e. buffers that don't visit a file. The face
-'tab-line-tab-modified' is used to display modified, file-backed
-buffers. The face 'tab-line-tab-inactive-alternate' is used to
-display inactive tabs with an alternating background color, making
-them easier to distinguish, especially if the face 'tab-line-tab' is
-configured to not display with a box; this alternate face is only
-applied when the user option 'tab-line-tab-face-functions' is so
-configured. That option may also be used to customize tab-line faces
-in other ways.
-
-** Mouse wheel
+
+* Changes in Emacs 29.1
----
-*** Mouse wheel scrolling now defaults to one line at a time.
+** 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.
---
-*** Mouse wheel scrolling now works on more parts of frame's display.
-When using 'mouse-wheel-mode', the mouse wheel will now scroll also when
-the mouse cursor is on the scroll bars, fringes, margins, header line,
-and mode line. ('mouse-wheel-mode' is enabled by default on most graphical
-displays.)
+** '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.
+++
-*** Mouse wheel scrolling with Shift modifier now scrolls horizontally.
-This works in text buffers and over images. Typing a numeric prefix arg
-(e.g. 'M-5') before starting horizontal scrolling changes its step value.
-The value is saved in the user option 'mouse-wheel-scroll-amount-horizontal'.
-
-** Customize
-
----
-*** Customize buffers can now be reverted with 'C-x x g'.
-
----
-*** Most customize commands now hide obsolete user options.
-Obsolete user options are no longer shown in the listings produced by
-the commands 'customize', 'customize-group', 'customize-apropos' and
-'customize-changed'.
-
-To customize obsolete user options, use 'customize-option' or
-'customize-saved'.
-
----
-*** New SVG icons for checkboxes and arrows.
-They will be used automatically instead of the old icons. If Emacs is
-built without SVG support, the old icons will be used instead.
-
-** Help
-
----
-*** The order of things displayed in the "*Help*" buffer has been changed.
-The indented "administrative" block (containing the "probably
-introduced" and "other relevant functions" (and similar things) has
-been moved to after the doc string.
+** New user option 'process-error-pause-time'.
+This determines how long to pause Emacs after a process
+filter/sentinel error has been handled.
+++
-*** New command 'describe-command' shows help for a command.
-This can be used instead of 'describe-function' for interactive
-commands and is globally bound to 'C-h x'.
+** New 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 command 'describe-keymap' describes keybindings in a keymap.
-
----
-*** New command 'apropos-function'.
-This works like 'C-u M-x apropos-command' but is more discoverable.
-
----
-*** New keybinding 'C-h R' prompts for an Info manual and displays it.
-
----
-*** Keybindings in 'help-mode' use the new 'help-key-binding' face.
-This face is added by 'substitute-command-keys' to any "\[command]"
-substitution. The return value of that function should consequently
-be assumed to be a propertized string. To prevent the function from
-adding the 'help-key-binding' face, call 'substitute-command-keys'
-with the new optional argument NO-FACE non-nil.
-
-Note that the new face will also be used in tooltips. When using the
-GTK toolkit, this is only true if 'x-gtk-use-system-tooltips' is t.
+** New 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 user option 'help-enable-symbol-autoload'.
-If non-nil, displaying help for an autoloaded function whose
-'autoload' form provides no documentation string will try to load the
-file it's from. This will give more extensive help for such
-functions.
-
----
-*** The 'help-for-help' ('C-h C-h') screen has been redesigned.
+** New function 'buffer-text-pixel-size'.
+This is similar to 'window-text-pixel-size', but can be used when the
+buffer isn't displayed.
+++
-*** New convenience commands with short keys in the Help buffer.
-New command 'help-view-source' ('s') will view the source file (if
-any) of the current help topic. New command 'help-goto-info' ('i')
-will look up the current symbol (if any) in Info. New command
-'help-customize' ('c') will customize the user option or the face
-(if any) whose doc string is being shown in the Help buffer.
+** New X resource: "borderThickness".
+This controls the thickness of the external borders of the menu bars
+and pop-up menus.
---
-*** New user option 'describe-bindings-outline'.
-It enables outlines in the output buffer of 'describe-bindings' that
-can provide a better overview in a long list of available bindings.
+** New 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.
-+++
-*** New commands to describe buttons and widgets.
-'widget-describe' (on a widget) will pop up a help buffer and give a
-description of the properties. Likewise 'button-describe' does the
-same for a button.
+** Terminal Emacs
---
-*** Improved "find definition" feature of "*Help*" buffers.
-Now clicking on the link to find the definition of functions generated
-by 'cl-defstruct', or variables generated by 'define-derived-mode',
-for example, will go to the exact place where they are defined.
+*** 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".
----
-*** New commands 'apropos-next-symbol' and 'apropos-previous-symbol'.
-These new navigation commands are bound to 'n' and 'p' in
-'apropos-mode'.
-
----
-*** The command 'view-lossage' can now be invoked from the menu bar.
-The menu bar "Help" menu now has a "Show Recent Inputs" item under the
-"Describe" sub-menu.
+** ERT
+++
-*** New command 'lossage-size'.
-It allows users to change the maximum number of keystrokes and
-commands recorded for the purpose of 'view-lossage'.
-
----
-*** Closing the "*Help*" buffer from the toolbar now buries the buffer.
-In previous Emacs versions, the "*Help*" buffer was killed instead when
-clicking the "X" icon in the tool bar.
+*** 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.
---
-*** 'g' ('revert-buffer') in 'help-mode' no longer requires confirmation.
-
-** File Locks
+*** 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.
+++
-*** New user option 'lock-file-name-transforms'.
-This option allows controlling where lock files are written. It uses
-the same syntax as 'auto-save-file-name-transforms'.
+*** 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.
-+++
-*** New user option 'remote-file-name-inhibit-locks'.
-When non-nil, this option suppresses lock files for remote files.
-Default is nil.
+** Emoji
+++
-*** New minor mode 'lock-file-mode'.
-This command, called interactively, toggles the local value of
-'create-lockfiles' in the current buffer.
-
-** Emacs Server
+*** Emacs now has several new methods for inserting Emojis.
+The Emoji commands are under the new 'C-x 8 e' prefix.
+++
-*** New user option 'server-client-instructions'.
-When emacsclient connects, Emacs will (by default) output a message
-about how to exit the client frame. If 'server-client-instructions'
-is set to nil, this message is inhibited.
+*** New command '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 'server-edit-abort'.
-This command (not bound to any key by default) can be used to abort
-an edit instead of marking it as "Done" (which the 'C-x #' command
-does). The 'emacsclient' program exits with an abnormal status as
-result of this command.
+*** New command 'emoji-search' (bound to 'C-x 8 e s').
+This command lets you search for Emojis based on names.
+++
-*** New desktop integration for connecting to the server.
-If your operating system’s desktop environment is
-freedesktop.org-compatible (which is true of most GNU/Linux and other
-recent Unix-like desktops), you may use the new "Emacs (Client)"
-desktop menu entry to open files in an existing Emacs instance rather
-than starting a new one. The daemon starts if it is not already
-running.
-
-** Miscellaneous
-
-+++
-*** New command 'font-lock-update', bound to 'C-x x f'.
-This command updates the syntax highlighting in this buffer.
-
-+++
-*** New command 'memory-report'.
-This command opens a new buffer called "*Memory Report*" and gives a
-summary of where Emacs is using memory currently.
-
-+++
-*** New command 'submit-emacs-patch'.
-This works like 'report-emacs-bug', but is more geared towards sending
-patches to the Emacs issue tracker.
+*** New command 'emoji-list' (bound to 'C-x 8 e l').
+This command lists all Emojis (categorized by themes) in a special
+buffer and lets you choose one of them.
---
-*** New face 'apropos-button'.
-Applies to buttons that indicate a face.
+*** New command 'emoji-recent' (bound to 'C-x 8 e r').
+This command lets you choose among the Emojis you have recently
+inserted.
+++
-*** New face 'font-lock-doc-markup-face'.
-Intended for documentation mark-up syntax and tags inside text that
-uses 'font-lock-doc-face', which it should appropriately stand out
-against and harmonize with. It would typically be used in structured
-documentation comments in program source code by language-specific
-modes, for mark-up conventions like Haddock, Javadoc or Doxygen. By
-default this face inherits from 'font-lock-constant-face'.
+*** New command 'emoji-describe' (bound to 'C-x 8 e d').
+This command will tell you the name of the Emoji at point. (This
+command also works for non-Emoji characters.)
-+++
-*** New face box style 'flat-button'.
-This is a plain 2D button, but uses the background color instead of
-the foreground color.
+** Help
---
-*** New faces 'shortdoc-heading' and 'shortdoc-section'.
-Applied to shortdoc headings and sections.
+*** 'C-h b' uses outlining by default.
+Set 'describe-bindings-outline' to nil to get the old behavior.
---
-*** New face 'separator-line'.
-This is used by 'make-separator-line' (see below).
-
-+++
-*** 'redisplay-skip-fontification-on-input' helps Emacs keep up with fast input.
-This is another attempt to solve the problem of handling high key repeat rate
-and other "slow scrolling" situations. It is hoped it behaves better
-than 'fast-but-imprecise-scrolling' and 'jit-lock-defer-time'.
-It is not enabled by default.
-
----
-*** Obsolete aliases are no longer hidden from command completion.
-Completion of command names now considers obsolete aliases as
-candidates, if they were marked obsolete in the current major version
-of Emacs. Invoking a command via an obsolete alias now mentions the
-obsolescence fact and shows the new name of the command.
-
-+++
-*** Support for '(box . SIZE)' 'cursor-type'.
-By default, 'box' cursor always has a filled box shape. But if you
-specify 'cursor-type' to be '(box . SIZE)', the cursor becomes a hollow
-box if the point is on an image larger than SIZE pixels in any
-dimension.
+*** Jumping to function/variable source now saves mark before moving point.
+Jumping to source from "*Help*" buffer moves the point when the source
+buffer is already open. Now, the old point is pushed to mark ring.
+++
-*** The user can now customize how "default" values are prompted for.
-The new utility function 'format-prompt' has been added which uses the
-new 'minibuffer-default-prompt-format' user option to format "default"
-prompts. This means that prompts that look like "Enter a number
-(default 10)" can be customized to look like, for instance, "Enter a
-number [10]", or not have the default displayed at all, like "Enter a
-number". (This only affects callers that were altered to use
-'format-prompt'.)
+*** New key bindings in "*Help*" buffers: 'n' and 'p'.
+These will take you (respectively) to the next and previous "page".
---
-*** New help window when Emacs prompts before opening a large file.
-Commands like 'find-file' or 'visit-tags-table' ask to visit a file
-normally or literally when the file is larger than a certain size (by
-default, 9.5 MiB). Press '?' or 'C-h' in that prompt to read more
-about the different options to visit a file, how you can disable the
-prompt, and how you can tweak the file size threshold.
+*** 'describe-char' now also outputs the name of emoji combinations.
-+++
-*** Emacs now defaults to UTF-8 instead of ISO-8859-1.
-This is only for the default, where the user has set no 'LANG' (or
-similar) variable or environment. This change should lead to no
-user-visible changes for normal usage.
-
----
-*** 'global-display-fill-column-indicator-mode' skips some buffers.
-By default, turning on 'global-display-fill-column-indicator-mode'
-doesn't turn on 'display-fill-column-indicator-mode' in special-mode
-buffers. This can be controlled by customizing the user option
-'global-display-fill-column-indicator-modes'.
+** Outline Minor Mode
+++
-*** 'nobreak-char-display' now also affects all non-ASCII space characters.
-Previously, this was limited only to 'NO-BREAK SPACE' and hyphen
-characters. Now it also covers the rest of the non-ASCII Unicode
-space characters. Also, unlike in previous versions of Emacs, the
-non-ASCII characters are displayed as themselves when
-'nobreak-char-display' is t, i.e. they are not replaced on display
-with the ASCII space and hyphen characters.
+*** New 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. Default nil.
---
-*** New backward compatibility variable 'nobreak-char-ascii-display'.
-This variable is nil by default, and non-ASCII space and hyphen
-characters are displayed as themselves, even if 'nobreak-char-display'
-is non-nil. If 'nobreak-char-ascii-display' is set to a non-nil
-value, the non-ASCII space and hyphen characters are instead displayed
-as their ASCII counterparts: spaces and ASCII hyphen (a.k.a. "dash")
-characters. This provides backward compatibility feature for the
-change described above, where the non-ASCII characters are no longer
-replaced with their ASCII counterparts when 'nobreak-char-display' is
-t. You may need this on text-mode terminals that produce messed up
-display when non-ASCII spaces and hyphens are written to the display.
-(This variable is only effective when 'nobreak-char-display' is t.)
+*** New user option 'outline-minor-mode-buttons'.
+This is a list of pairs of open/close strings used to display buttons.
+++
-*** Improved support for terminal emulators that encode the Meta flag.
-Some terminal emulators set the 8th bit of Meta characters, and then
-encode the resulting character code as if it were non-ASCII character
-above codepoint 127. Previously, the only way of using these in Emacs
-was to set up the terminal emulator to use the 'ESC' characters to send
-Meta characters to Emacs, e.g., send "ESC x" when the user types
-'M-x'. You can now avoid the need for this setup of such terminal
-emulators by using the new input-meta-mode with the special value
-'encoded' with these terminal emulators.
-
----
-*** 'auto-composition-mode' can now be selectively disabled on some TTYs.
-Some text-mode terminals produce display glitches trying to compose
-characters. The 'auto-composition-mode' can now have a string value
-that names a terminal type; if the value returned by the 'tty-type'
-function compares equal with that string, automatic composition will
-be disabled in windows shown on that terminal. The Linux terminal
-sets this up by default.
-
----
-*** Support for the 'strike-through' face attribute on TTY frames.
-If your terminal's termcap or terminfo database entry has the 'smxx'
-capability defined, Emacs will now emit the prescribed escape
-sequences necessary to render faces with the 'strike-through'
-attribute on TTY frames.
-
----
-*** TTY menu navigation is now supported in 'xterm-mouse-mode'.
-TTY menus support mouse navigation and selection when 'xterm-mouse-mode'
-is active. When run on a terminal, clicking on the menu bar with the
-mouse now pops up a TTY menu by default instead of running the command
-'tmm-menubar'. To restore the old behavior, set the user option
-'tty-menu-open-use-tmm' to non-nil.
+** Support for the WebP image format.
+This support is built by default when the libwebp library is
+available. To disable it, use the '--without-webp' configure flag.
+Image specifiers can now use ':type webp'.
----
-*** 'M-x report-emacs-bug' will no longer include "Recent messages" section.
-These were taken from the "*Messages*" buffer, and may inadvertently
-leak information from the reporting user.
-
----
-*** 'C-u M-x dig' will now prompt for a query type to use.
-
----
-*** Rudimentary support for the 'st' terminal emulator.
-Emacs now supports 256 color display on the 'st' terminal emulator.
+** Windows
+++
-*** Update IRC-related references to point to Libera.Chat.
-The Free Software Foundation and the GNU Project have moved their
-official IRC channels from the Freenode network to Libera.Chat. For the
-original announcement and the follow-up update, including more details,
-see:
-
-https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00005.html
-https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00007.html
+*** 'display-buffer' now can set up the body size of the chosen window.
+For example, a 'display-buffer-alist' entry of
-Given the relocation of GNU and FSF's official IRC channels, as well
-as #emacs and various other Emacs-themed channels (see the link below)
-to Libera.Chat, IRC-related references in the Emacs repository have
-now been updated to point to Libera.Chat.
+ '(window-width . (body-columns . 40))'
-https://lists.gnu.org/archive/html/info-gnu-emacs/2021-06/msg00000.html
-
-
-* Incompatible Editing Changes in Emacs 28.1
-
----
-** 'toggle-truncate-lines' now disables 'visual-line-mode'.
-This is for symmetry with 'visual-line-mode', which disables
-'truncate-lines'.
-
----
-** 'electric-indent-mode' now also indents inside strings and comments.
-(This only happens when indentation function also supports this.)
-
-To recover the previous behavior you can use:
-
- (add-hook 'electric-indent-functions
- (lambda (_) (if (nth 8 (syntax-ppss)) 'no-indent)))
-
----
-** The 'M-o' ('facemenu-keymap') global binding has been removed.
-To restore the old binding, say something like:
+will make the body of the chosen window 40 columns wide. For the
+height use 'window-height' in combination with 'body-lines'.
- (require 'facemenu)
- (define-key global-map "\M-o" 'facemenu-keymap)
- (define-key facemenu-keymap "\es" 'center-line)
- (define-key facemenu-keymap "\eS" 'center-paragraph)
-
-The last two lines are not strictly necessary if you don't care about
-having those two commands on the 'M-o' keymap; see the next section.
-
----
-** The 'M-o M-s' and 'M-o M-S' global bindings have been removed.
-Use 'M-x center-line' and 'M-x center-paragraph' instead. See the
-previous section for how to get back the old bindings. Alternatively,
-if you only want these two commands to have the global bindings they
-had before, you can add the following to your init file:
-
- (define-key global-map "\M-o\M-s" 'center-line)
- (define-key global-map "\M-o\M-S" 'center-paragraph)
-
----
-** The 'M-o M-o' global binding has been removed.
-Use 'M-x font-lock-fontify-block' instead, or the new 'C-x x f'
-command, which updates the syntax highlighting in the current buffer.
-
----
-** The escape sequence '\e[29~' in Xterm is now mapped to 'menu'.
-Xterm sends this sequence for both 'F16' and 'Menu' keys
-It used to be mapped to 'print' but we couldn't find a terminal
-that uses this sequence for any kind of 'Print' key.
-This makes the Menu key (see https://en.wikipedia.org/wiki/Menu_key)
-work for 'context-menu-mode' in Xterm.
-
----
-** New user option 'xterm-store-paste-on-kill-ring'.
-If non-nil (the default), Emacs pushes pasted text onto the kill ring
-(if using an xterm-like terminal that supports bracketed paste).
-Setting this to nil inhibits that.
-
----
-** 'vc-print-branch-log' shows the change log from its root directory.
-It previously used to use the default directory.
-
----
-** 'project-shell' and 'shell' now use 'pop-to-buffer-same-window'.
-This is to keep the same behavior as Eshell.
+** Tab Bars and Tab Lines
---
-** In 'nroff-mode', 'center-line' is no longer bound to a key.
-The original key binding was 'M-s', which interfered with I-search,
-since the latter uses 'M-s' as a prefix key of the search prefix map.
+*** 'C-x t RET' creates a new tab when the provided tab name doesn't exist.
----
-** In 'f90-mode', the backslash character ('\') no longer escapes.
-For about a decade, the backslash character has no longer had a
-special escape syntax in Fortran F90. To get the old behavior back,
-say something like:
+** 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.
- (modify-syntax-entry ?\\ "\\" f90-mode-syntax-table)
+** Emacs server and client changes
+++
-** Setting 'fill-column' to nil is obsolete.
-This undocumented use of 'fill-column' is now obsolete. To disable
-auto filling, turn off 'auto-fill-mode' instead.
-
-For instance, you could add something like the following to your init
-file:
-
- (add-hook 'foo-mode-hook (lambda () (auto-fill-mode -1))
-
-
-* Editing Changes in Emacs 28.1
-
-** Input methods
+*** New command-line option '-r' for emacsclient.
+With this command-line option, Emacs reuses an existing graphical client
+frame if one exists; otherwise it creates a new frame.
+++
-*** Emacs now supports "transient" input methods.
-A transient input method is enabled for inserting a single character,
-and is then automatically disabled. 'C-x \' temporarily enables the
-selected transient input method. Use 'C-u C-x \' to select a
-transient input method (which can be different from the input method
-enabled by 'C-\'). For example, 'C-u C-x \ compose RET' selects the
-'compose' input method; then typing 'C-x \ 1 2' will insert the
-character '½', and disable the 'compose' input method afterwards.
-You can use 'C-x \' in incremental search to insert a single character
-to the search string.
+*** '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 given by the argument, which can be
+'empty', 'delete-frame' or 'kill-terminal'.
----
-*** New input method 'compose' based on X Multi_key sequences.
+* Editing Changes in Emacs 29.1
---
-*** New input method 'iso-transl' with the same keys as 'C-x 8'.
-After selecting it as a transient input method with 'C-u C-x \
-iso-transl RET', it supports the same key sequences as 'C-x 8',
-so e.g. like 'C-x 8 [' inserts a left single quotation mark,
-'C-x \ [' does the same.
-
----
-*** New user option 'read-char-by-name-sort'.
-It defines the sorting order of characters for completion of 'C-x 8 RET TAB'
-and can be customized to sort them by codepoints instead of character names.
-Additionally, you can group characters by Unicode blocks after customizing
-'completions-group' and 'completions-group-sort'.
-
----
-*** Improved language transliteration in Malayalam input methods.
-Added a new Mozhi scheme. The inapplicable ITRANS scheme is now
-deprecated. Errors in the Inscript method were corrected.
-
----
-*** New input method 'cham'.
-There's also a Cham greeting in "etc/HELLO".
-
----
-*** New input methods for Lakota language orthographies.
-Two orthographies are represented here, the Suggested Lakota
-Orthography and what is known as the White Hat Orthography. Input
-methods 'lakota-slo-prefix', 'lakota-slo-postfix', and
-'lakota-white-hat-postfix' have been added. There is also a Lakota
-greeting in "etc/HELLO".
-
-+++
-** Standalone 'M-y' allows interactive selection from previous kills.
-'M-y' can now be typed after a command that is not a yank command.
-When invoked like that, it prompts in the minibuffer for one of the
-previous kills, offering completion and minibuffer-history navigation
-through previous kills recorded in the kill ring. A similar feature
-in Isearch can be invoked if you bind 'C-s M-y' to the command
-'isearch-yank-pop'. When the user option 'yank-from-kill-ring-rotate'
-is nil the kill ring is not rotated after 'yank-from-kill-ring'.
-
-+++
-** New user option 'word-wrap-by-category'.
-When word-wrap is enabled, and this option is non-nil, that allows
-Emacs to break lines after more characters than just whitespace
-characters. In particular, this significantly improves word-wrapping
-for CJK text mixed with Latin text.
-
-+++
-** New command 'undo-redo'.
-It undoes previous undo commands, but doesn't record itself as an
-undoable command. It is bound to 'C-?' and 'C-M-_', the first binding
-works well in graphical mode, and the second one is easy to hit on tty.
+** Indentation of 'cl-flet' and 'cl-labels' has changed.
+These forms now indent like this:
-For full conventional undo/redo behavior, you can also customize the
-user option 'undo-no-redo' to t.
+ (cl-flet ((bla (x)
+ (* x x)))
+ (bla 42))
-+++
-** New commands 'copy-matching-lines' and 'kill-matching-lines'.
-These commands are similar to the command 'flush-lines',
-but add the matching lines to the kill ring as a single string,
-including the newlines that separate the lines.
+This change also affects 'cl-macrolet', 'cl-flet*' and
+'cl-symbol-macrolet'.
+++
-** New user option 'kill-transform-function'.
-This can be used to transform (and suppress) strings from entering the
-kill ring.
+** New user option 'translate-upper-case-key-bindings'.
+This can be set to nil to inhibit translating upper case keys to lower
+case keys.
+++
-** 'save-interprogram-paste-before-kill' can now be a number.
-In that case, it's interpreted as a limit on the size of the clipboard
-data that will be saved to the 'kill-ring' prior to killing text: if
-the size of the clipboard data is greater than or equal to the limit,
-it will not be saved.
-
-+++
-** New user option 'tab-first-completion'.
-If 'tab-always-indent' is 'complete', this new user option can be used to
-further tweak whether to complete or indent.
+** New command 'ensure-empty-lines'.
+This command increases (or decreases) the number of empty lines before
+point.
---
-** 'indent-tabs-mode' is now a global minor mode instead of just a variable.
-
-+++
-** New choice 'permanent' for 'shift-select-mode'.
-When the mark was activated by shifted motion keys, non-shifted motion
-keys don't deactivate the mark after customizing 'shift-select-mode'
-to 'permanent'. Similarly, the active mark will not be deactivated by
-typing shifted motion keys.
-
-+++
-** The "Edit => Clear" menu item now obeys a rectangular region.
-
-+++
-** New command 'revert-buffer-with-fine-grain'.
-Revert a buffer trying to be as non-destructive as possible,
-preserving markers, properties and overlays. The new variable
-'revert-buffer-with-fine-grain-max-seconds' specifies the maximum
-number of seconds that 'revert-buffer-with-fine-grain' should spend
-trying to be non-destructive, with a default value of 2 seconds.
-
-+++
-** New command 'revert-buffer-quick'.
-This is bound to 'C-x x g' and is like 'revert-buffer', but prompts
-less.
-
-+++
-** New user option 'revert-buffer-quick-short-answers'.
-This controls how the new 'revert-buffer-quick' ('C-x x g') command
-prompts. A non-nil value will make it use 'y-or-n-p' rather than
-'yes-or-no-p'. Defaults to nil.
+*** Improved mouse behavior with auto-scrolling modes.
+When clicking inside the 'scroll-margin' or 'hscroll-margin' region
+the point is now moved only when releasing the mouse button. This no
+longer results in a bogus selection, unless the mouse has been
+effectively dragged.
+++
-** New user option 'query-about-changed-file'.
-If non-nil (the default), Emacs prompts as before when re-visiting a
-file that has changed externally after it was visited the first time.
-If nil, Emacs does not prompt, but instead shows the buffer with its
-contents before the change, and provides instructions how to revert
-the buffer.
+** 'kill-ring-max' now defaults to 120.
---
-** New value 'save-some-buffers-root' of 'save-some-buffers-default-predicate'.
-When using this predicate, only buffers under the current project root
-will be considered when saving buffers with 'save-some-buffers'.
+** New user option '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 'save-place-abbreviate-file-names'.
-This can simplify sharing the 'save-place-file' file across
-different hosts.
-
----
-** New user options 'copy-region-blink-delay' and 'delete-pair-blink-delay'.
-'copy-region-blink-delay' specifies a delay to indicate the region
-copied by 'kill-ring-save'. 'delete-pair-blink-delay' specifies
-a delay to show the paired character to delete.
-
----
-** 'zap-up-to-char' now uses 'read-char-from-minibuffer'.
-This allows navigating through the history of characters that have
-been input. This is mostly useful for characters that have complex
-input methods where inputting the character again may involve many
-keystrokes.
+** show-paren-mode
+++
-** Input history for 'goto-line' can now be made local to every buffer.
-In any event, line numbers used with 'goto-line' are kept in their own
-history list. This should help make faster the process of finding
-line numbers that were previously jumped to. By default, all buffers
-share a single history list. To make every buffer have its own
-history list, customize the user option 'goto-line-history-local'.
+*** New 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. Default nil.
-+++
-** New command 'goto-line-relative' for use in a narrowed buffer.
-It moves point to the line relative to the accessible portion of the
-narrowed buffer. 'M-g M-g' in Info is rebound to this command.
-When 'widen-automatically' is non-nil, 'goto-line' widens the narrowed
-buffer to be able to move point to the inaccessible portion.
-'goto-line-relative' is bound to 'C-x n g'.
+** Comint
+++
-** 'goto-char' prompts for the character position.
-When called interactively, 'goto-char' now offers the position at
-point as the default.
+*** 'comint-term-environment' is now aware of connection-local variables.
+The user option 'comint-terminfo-terminal' and variable
+'system-uses-terminfo' can now be set as connection-local variables to
+change the terminal used on a remote host.
-** Auto-saving via 'auto-save-visited-mode' can now be inhibited.
-Set the variable 'auto-save-visited-mode' buffer-locally to nil to
-achieve that.
-
-+++
-** New command 'kdb-macro-redisplay' to force redisplay in keyboard macros.
-This command is bound to 'C-x C-k d'.
+** Mwheel
---
-** 'blink-cursor-mode' is now enabled by default regardless of the UI.
-It used to be enabled when Emacs is started in GUI mode but not when started
-in text mode. The cursor still only actually blinks in GUI frames.
-
-** 'show-paren-mode' is now enabled by default.
-To go back to the previous behavior, customize the user option of the
-same name to nil.
-
-+++
-** New minor mode 'show-paren-local-mode'.
-It serves as a local counterpart for 'show-paren-mode', allowing you
-to toggle it separately in different buffers. To use it only in
-programming modes, for example, add the following to your init file:
-
- (add-hook 'prog-mode-hook #'show-paren-local-mode)
+*** New user options for alternate wheel events.
+The options 'mouse-wheel-down-alternate-event', 'mouse-wheel-up-alternate-event',
+'mouse-wheel-left-alternate-event', and 'mouse-wheel-right-alternate-event' have
+been added to better support systems where two kinds of wheel events can be
+received.
-* Changes in Specialized Modes and Packages in Emacs 28.1
+* Changes in Specialized Modes and Packages in Emacs 29.1
** Isearch and Replace
-+++
-*** Interactive regular expression search now uses faces for sub-groups.
-E.g., 'C-M-s foo-\([0-9]+\)' will now use the 'isearch-group-1' face
-on the part of the regexp that matches the sub-expression "[0-9]+".
-By default, there are two faces for sub-group highlighting, but you
-can define more faces whose names are of the form 'isearch-group-N',
-where N are successive numbers above 2.
-
-This is controlled by the 'search-highlight-submatches' user option.
-This feature is available only on terminals that have enough colors to
-distinguish between sub-expression highlighting.
+*** New user option 'char-fold-override' omits the default character-folding.
-+++
-*** Interactive regular expression replace now uses faces for sub-groups.
-Like 'search-highlight-submatches', this is controlled by the new user option
-'query-replace-highlight-submatches'.
+** New minor mode 'glyphless-display-mode'.
+This allows an easy way to toggle seeing all glyphless characters in
+the current buffer.
-+++
-*** New key 'M-s M-.' starts isearch looking for the thing at point.
-This key is bound to the new command 'isearch-forward-thing-at-point'.
-The new user option 'isearch-forward-thing-at-point' defines
-a list of symbols to try to get the "thing" at point. By default,
-the first element of the list is 'region' that tries to yank
-the currently active region to the search string.
+** Registers
+++
-*** New user option 'isearch-wrap-pause' defines how to wrap the search.
-There are choices to disable wrapping completely and to wrap immediately.
-When wrapping immediately, it consistently handles the numeric arguments
-of 'C-s' ('isearch-repeat-forward') and 'C-r' ('isearch-repeat-backward'),
-continuing with the remaining count after wrapping.
+*** Buffer names can now be stored in registers.
+For instance, to enable jumping to the "*Messages*" buffer with
+'C-x r j m':
-+++
-*** New user option 'isearch-repeat-on-direction-change'.
-When this option is set, direction changes in Isearch move to another
-search match, if there is one, instead of moving point to the other
-end of the current match.
+ (set-register ?m '(buffer . "*Messages*"))
-+++
-*** New user option 'isearch-allow-motion'.
-When 'isearch-allow-motion' is set, the commands 'beginning-of-buffer',
-'end-of-buffer', 'scroll-up-command' and 'scroll-down-command', when
-invoked during I-search, move respectively to the first occurrence of
-the current search string in the buffer, the last one, the first one
-after the current window, and the last one before the current window.
-Additionally, users can change the meaning of other motion commands
-during I-search by using their 'isearch-motion' property. The user
-option 'isearch-motion-changes-direction' controls whether the
-direction of the search changes after a motion command.
+** pixel-fill
+++
-*** New user option 'lazy-highlight-no-delay-length'.
-Lazy highlighting of matches in Isearch now starts immediately if the
-search string is at least this long. 'lazy-highlight-initial-delay'
-still applies for shorter search strings, which avoids flicker in the
-search buffer due to too many matches being highlighted.
+*** This is a new package that deals with filling variable-pitch text.
+++
-*** The default 'search-whitespace-regexp' value has changed.
-This used to be "\\s-+", which meant that it was mode-dependent whether
-newlines were included in the whitespace set. This has now been
-changed to only match spaces and tab characters.
-
-** Dired
-
-+++
-*** New user option 'dired-kill-when-opening-new-dired-buffer'.
-If non-nil, Dired will kill the current buffer when selecting a new
-directory to display.
-
-+++
-*** Behavior change on 'dired-do-chmod'.
-As a security precaution, Dired's M command no longer follows symbolic
-links. Instead, it changes the symbolic link's own mode; this always
-fails on platforms where such modes are immutable.
-
----
-*** Behavior change on 'dired-clean-confirm-killing-deleted-buffers'.
-Previously, if 'dired-clean-up-buffers-too' was non-nil, and
-'dired-clean-confirm-killing-deleted-buffers' was nil, the buffers
-wouldn't be killed. This combination will now kill the buffers.
-
-+++
-*** New user option 'dired-switches-in-mode-line'.
-This user option controls how 'ls' switches are displayed in the mode
-line, and allows truncating them (to preserve space on the mode line)
-or showing them literally, either instead of, or in addition to,
-displaying "by name" or "by date" sort order.
-
-+++
-*** New user option 'dired-compress-directory-default-suffix'.
-This user option controls the default suffix for compressing a
-directory. If it's nil, ".tar.gz" will be used. Refer to
-'dired-compress-files-alist' for a list of supported suffixes.
-
-+++
-*** New user option 'dired-compress-file-default-suffix'.
-This user option controls the default suffix for compressing files.
-If it's nil, ".gz" will be used. Refer to 'dired-compress-file-alist'
-for a list of supported suffixes.
-
----
-*** Broken and circular links are shown with the 'dired-broken-symlink' face.
-
----
-*** '=' ('dired-diff') will now put all backup files into the 'M-n' history.
-When using '=' on a file with backup files, the default file to use
-for diffing is the newest backup file. You can now use 'M-n' to quickly
-select a different backup file instead.
-
-+++
-*** New user option 'dired-maybe-use-globstar'.
-If set, enables globstar (recursive globbing) in shells that support
-this feature, but have it turned off by default. This allows producing
-directory listings with files matching a wildcard in all the
-subdirectories of a given directory. The new variable
-'dired-enable-globstar-in-shell' lists which shells can have globstar
-enabled, and how to enable it.
-
-+++
-*** New user option 'dired-copy-dereference'.
-If set to non-nil, Dired will dereference symbolic links when copying.
-This can be switched off on a per-usage basis by providing
-'dired-do-copy' with a 'C-u' prefix.
-
----
-*** New user option 'dired-do-revert-buffer'.
-Non-nil reverts the destination Dired buffer after performing one
-of these operations: 'dired-do-copy', 'dired-do-rename',
-'dired-do-symlink', 'dired-do-hardlink'.
-
----
-*** New user option 'dired-mark-region'.
-This option affects all Dired commands that mark files. When non-nil
-and the region is active in Transient Mark mode, then Dired commands
-operate only on files in the active region. The values 'file' and
-'line' of this user option define the details of marking the file at
-the end of the region.
-
-+++
-*** State changing VC operations are supported in Dired.
-These operations are supported on files and directories via the new
-command 'dired-vc-next-action'.
-
-+++
-*** 'dired-jump' and 'dired-jump-other-window' moved from 'dired-x' to 'dired'.
-The 'dired-jump' and 'dired-jump-other-window' commands have been
-moved from the 'dired-x' package to 'dired'. The user option
-'dired-bind-jump' no longer has any effect and is now obsolete.
-The commands are now bound to 'C-x C-j' and 'C-x 4 C-j' by default.
-
-To get the old behavior of 'dired-bind-jump' back and unbind the above
-keys, add the following to your init file:
-
- (global-set-key "\C-x\C-j" nil)
- (global-set-key "\C-x4\C-j" nil)
-
----
-*** 'dired-query' now uses 'read-char-from-minibuffer'.
-Using it instead of 'read-char-choice' allows using 'C-x o'
-to switch to the help window displayed after typing 'C-h'.
-
-+++
-** Emacs 28.1 comes with Org v9.5.
-See the file ORG-NEWS for user-visible changes in Org.
-
-** Outline
-
-+++
-*** New commands to cycle heading visibility.
-Typing 'TAB' on a heading line cycles the current section between
-"hide all", "subheadings", and "show all" states. Typing 'S-TAB'
-anywhere in the buffer cycles the whole buffer between "only top-level
-headings", "all headings and subheadings", and "show all" states.
-
-+++
-*** New user option 'outline-minor-mode-cycle'.
-This user option customizes 'outline-minor-mode', with the difference
-that 'TAB' and 'S-TAB' on heading lines cycle heading visibility.
-Typing 'TAB' on a heading line cycles the current section between
-"hide all", "subheadings", and "show all" states. Typing 'S-TAB' on a
-heading line cycles the whole buffer between "only top-level
-headings", "all headings and subheadings", and "show all" states.
-
----
-*** New user option 'outline-minor-mode-highlight'.
-This user option customizes 'outline-minor-mode'. It puts
-highlighting on heading lines using standard outline faces. This
-works well only when there are no conflicts with faces used by the
-major mode.
-
-** Ispell
-
-+++
-*** 'ispell-comments-and-strings' now accepts START and END arguments.
-These arguments default to the active region when used interactively.
-
-+++
-*** New command 'ispell-comment-or-string-at-point'.
-
----
-*** New user option 'ispell-help-timeout'.
-This controls how long the ispell help (on the '?' key) is displayed.
-
-** Flyspell mode
-
-+++
-*** Corrections and actions menu can be optionally bound to 'mouse-3'.
-When Flyspell mode highlights a word as misspelled, you can click on
-it to display a menu of possible corrections and actions. You can now
-easily bind this menu to 'down-mouse-3' (usually the right mouse button)
-instead of 'mouse-2' (the default) by enabling 'context-menu-mode'.
-
----
-*** The current dictionary is now displayed in the minor mode lighter.
-Clicking the dictionary name changes the current dictionary.
-
-** Package
-
-*** The new NonGNU ELPA archive is enabled by default alongside GNU ELPA.
-Thus, packages on NonGNU ELPA will appear by default in the list shown
-by 'list-packages'.
-
----
-*** '/ s' ('package-menu-filter-by-status') changed parameter handling.
-The command was documented to take a comma-separated list of statuses
-to filter by, but instead it used the parameter as a regexp. The
-command has been changed so that it now works as documented, and
-checks statuses not as a regexp, but instead an exact match from the
-comma-separated list.
-
-+++
-*** New command 'package-browse-url' and keystroke 'w'.
-
-+++
-*** New commands to filter the package list.
-The filter commands are bound to the following keys:
-
-key binding
---- -------
-/ a package-menu-filter-by-archive
-/ d package-menu-filter-by-description
-/ k package-menu-filter-by-keyword
-/ N package-menu-filter-by-name-or-description
-/ n package-menu-filter-by-name
-/ s package-menu-filter-by-status
-/ v package-menu-filter-by-version
-/ m package-menu-filter-marked
-/ u package-menu-filter-upgradable
-/ / package-menu-filter-clear
-
-*** Option to automatically native-compile packages upon installation.
-Customize the user option 'package-native-compile' to enable automatic
-native compilation of packages when they are installed. That option
-is nil by default; if set non-nil, and if your Emacs was built with
-native-compilation support, each package will be natively compiled
-when it is installed, by invoking an asynchronous Emacs subprocess to
-run the native-compilation of the package files. (Be sure to leave
-Emacs running until these asynchronous subprocesses exit, or else the
-native-compilation will be aborted when you exit Emacs.)
-
----
-*** Column widths in 'list-packages' display can now be customized.
-See the new user options 'package-name-column-width',
-'package-version-column-width', 'package-status-column-width', and
-'package-archive-column-width'.
+*** New function 'pixel-fill-region'.
+This fills the region to be no wider than a specified pixel width.
** Info
---
-*** New user option 'Info-warn-on-index-alternatives-wrap'.
-This option affects what happens when using the ',' command after
-looking up an entry with 'i' in info buffers. If non-nil (the
-default), the ',' command will now display a warning when proceeding
-beyond the final index match, and tapping ',' once more will then take
-you to the first match.
+*** 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.
-** Abbrev mode
-
-+++
-*** Emacs can now suggest to use an abbrev based on text you type.
-A new user option, 'abbrev-suggest', enables the new abbrev suggestion
-feature. When enabled, if a user manually types a piece of text that
-could have saved enough typing by using an abbrev, a hint will be
-displayed in the echo area, mentioning the abbrev that could have been
-used instead.
-
-** Bookmarks
-
----
-*** Bookmarks can now be targets for new tabs.
-When the bookmark.el library is loaded, a customize choice is added
-to 'tab-bar-new-tab-choice' for new tabs to show the bookmark list.
-
----
-*** New user option 'bookmark-set-fringe-mark'.
-If non-nil, setting a bookmark will set a fringe mark on the current
-line, and jumping to a bookmark will also set this mark.
+** vc
---
-*** New user option 'bookmark-menu-confirm-deletion'.
-In Bookmark Menu mode, Emacs by default does not prompt for
-confirmation when you type 'x' to execute the deletion of bookmarks
-that have been marked for deletion. However, if this new option is
-non-nil then Emacs will require confirmation with 'yes-or-no-p' before
-deleting.
-
----
-*** The 'list-bookmarks' menu is now based on 'tabulated-list-mode'.
-The interactive bookmark list will now benefit from features in
-'tabulated-list-mode' like sorting columns or changing column width.
-
-Support for the optional "inline" header line, allowing for a
-header without using 'header-line-format', has been dropped.
-The variables 'bookmark-bmenu-use-header-line' and
-'bookmark-bmenu-inline-header-height' are now obsolete.
-
-** Recentf
-
----
-*** The recentf files are no longer backed up.
-
----
-*** 'recentf-auto-cleanup' now repeats daily when set to a time string.
-When 'recentf-auto-cleanup' is set to a time string, it now repeats
-every day, rather than only running once after the mode is turned on.
-
-** Calc
-
----
-*** The behavior when doing forward-delete has been changed.
-Previously, using the 'C-d' command would delete the final number in
-the input field, no matter where point was. This has been changed to
-work more traditionally, with 'C-d' deleting the next character.
-Likewise, point isn't moved to the end of the string before inserting
-digits.
-
-+++
-*** Setting the word size to zero disables word clipping.
-The word size normally clips the results of certain bit-oriented
-operations such as shifts and bitwise XOR. A word size of zero, set
-by 'b w', makes the operation have effect on the whole argument values
-and the result is not truncated in any way.
-
----
-*** The '/' operator now has higher precedence in (La)TeX input mode.
-It no longer has lower precedence than '+' and '-'.
-
----
-*** New user option 'calc-make-windows-dedicated'.
-When this user option is non-nil, Calc will mark its windows as
-dedicated.
-
-** Calendar
-
-+++
-*** New user option 'calendar-time-zone-style'.
-If 'numeric', calendar functions (eg 'calendar-sunrise-sunset') that display
-time zones will use a form like "+0100" instead of "CET".
-
-** Imenu
-
-+++
-*** New user option 'imenu-max-index-time'.
-If creating the imenu index takes longer than specified by this
-option (default 5 seconds), imenu indexing is stopped.
-
-** ido
-
----
-*** Switching on 'ido-mode' now also overrides 'ffap-file-finder'.
-
----
-*** Killing virtual ido buffers interactively will make them go away.
-Previously, killing a virtual ido buffer with 'ido-kill-buffer' didn't
-do anything. This has now been changed, and killing virtual buffers
-with that command will remove the buffer from recentf.
-
-** So Long
-
----
-*** New 'so-long-predicate' function 'so-long-statistics-excessive-p'.
-It efficiently detects the presence of a long line anywhere in the
-buffer using 'buffer-line-statistics' (see above). This is now the
-default predicate (replacing 'so-long-detected-long-line-p').
-
----
-*** Default values 'so-long-threshold' and 'so-long-max-lines' increased.
-The values of these user options have been raised to 10000 bytes and 500
-lines respectively, to reduce the likelihood of false-positives when
-'global-so-long-mode' is enabled. The latter value is now only used
-by the old predicate, as the new predicate knows the longest line in
-the entire buffer.
-
----
-*** 'so-long-target-modes' now includes 'fundamental-mode' by default.
-This means that 'global-so-long-mode' will also process files which were
-not recognised. (This only has an effect if 'set-auto-mode' chooses
-'fundamental-mode'; buffers which are simply in 'fundamental-mode' by
-default are unaffected.)
-
----
-*** New user options to preserve modes and variables.
-The new options 'so-long-mode-preserved-minor-modes' and
-'so-long-mode-preserved-variables' allow specified mode and variable
-states to be maintained if 'so-long-mode' replaces the original major
-mode. By default, these new options support 'view-mode'.
-
-** Grep
-
-+++
-*** New user option 'grep-match-regexp' matches grep markers to highlight.
-Grep emits SGR ANSI escape sequences to color its output. The new
-user option 'grep-match-regexp' holds the regular expression to match
-the appropriate markers in order to provide highlighting in the source
-buffer. The user option can be customized to accommodate other
-grep-like tools.
-
----
-*** The 'lgrep' command now ignores directories.
-On systems where the grep command supports it, directories will be
-skipped.
-
-*** Commands that use 'grep-find' now follow symlinks for command-line args.
-This is because the default value of 'grep-find-template' now includes
-the 'find' option '-H'. Commands that use that variable, including
-indirectly via a call to 'xref-matches-in-directory', might be
-affected. In particular, there should be no need anymore to ensure
-any directory names on the 'find' command lines end in a slash.
-This change is for better compatibility with old versions of non-GNU
-'find', such as the one used on macOS.
-
----
-*** New utility function 'grep-file-at-point'.
-This returns the name of the file at point (if any) in 'grep-mode'
-buffers.
-
-** Shell
-
----
-*** New command in 'shell-mode': 'narrow-to-prompt'.
-This is bound to 'C-x n d' in 'shell-mode' buffers, and narrows to the
-command line under point (and any following output).
-
----
-*** New user option 'shell-has-auto-cd'.
-If non-nil, 'shell-mode' handles implicit "cd" commands, changing the
-directory if the command is a directory. Useful for shells like "zsh"
-that has this feature.
-
-** term-mode
-
----
-*** New user option 'term-scroll-snap-to-bottom'.
-By default, 'term' and 'ansi-term' will now recenter the buffer so
-that the prompt is on the final line in the window. Setting this new
-user option to nil inhibits this behavior.
-
----
-*** New user option 'term-set-terminal-size'
-If non-nil, the 'LINES' and 'COLUMNS' environment variables will be set
-based on the current window size. In previous versions of Emacs, this
-was always done (and that could lead to odd displays when resizing the
-window after starting). This variable defaults to nil.
-
----
-*** 'term-mode' now supports "bright" color codes.
-"Bright" ANSI color codes are now displayed using the color values
-defined in 'term-color-bright-*'. In addition, bold text with regular
-ANSI colors can be displayed as "bright" if 'ansi-color-bold-is-bright'
-is non-nil.
-
-** Eshell
-
----
-*** 'eshell-hist-ignoredups' can now also be used to mimic "erasedups" in bash.
-
----
-*** Environment variable 'INSIDE_EMACS' is now copied to subprocesses.
-Its value contains the result of evaluating '(format "%s,eshell"
-emacs-version)'. Other package names, like "tramp", could also be included.
-
----
-*** Eshell no longer re-initializes its keymap every call.
-This allows users to use (define-key eshell-mode-map ...) as usual.
-Some modules have their own minor mode now to account for these
-changes.
-
-*** Support for bookmark.el.
-The command 'bookmark-set' (bound to 'C-x r m') is now supported, and
-will create a bookmark that opens the current directory in Eshell.
-
-** Archive mode
-
----
-*** Archive Mode can now parse ".squashfs" files.
-
-*** Can now modify members of 'ar' archives.
-
-*** Display of summaries is unified between backends.
+*** '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'.
-*** New user option and command to control displayed columns.
-New user option 'archive-hidden-columns' and new command
-'archive-hideshow-column' let you control which columns are displayed
-and which are kept hidden.
-
----
-*** New command bound to 'C': 'archive-copy-file'.
-This command extracts the file at point and writes its data to a
-file.
-
-** browse-url
-
-*** Added support for custom URL handlers.
-There is a new variable 'browse-url-default-handlers' and a user
-option 'browse-url-handlers' being alists with '(REGEXP-OR-PREDICATE
-. FUNCTION)' entries allowing to define different browsing FUNCTIONs
-depending on the URL to be browsed. The variable is for default
-handlers provided by Emacs itself or external packages, the user
-option is for the user (and allows for overriding the default
-handlers).
-
-Formerly, one could do the same by setting
-'browse-url-browser-function' to such an alist. This usage is still
-supported but deprecated.
-
-*** Categorization of browsing commands into internal vs. external.
-All standard browsing commands such as 'browse-url-firefox',
-'browse-url-mail', or 'eww' have been categorized into internal (URL
-is browsed in Emacs) or external (an external application is spawned
-with the URL). This is done by adding a 'browse-url-browser-kind'
-symbol property to the browsing commands. With a new command
-'browse-url-with-browser-kind', an URL can explicitly be browsed with
-either an internal or external browser.
-
----
-*** Support for browsing of remote files.
-If a remote file is specified, a local temporary copy of that file is
-passed to the browser.
-
----
-*** Support for the conkeror browser is now obsolete.
+** Message
---
-*** Support for the Mosaic browser has been removed.
-This support has been obsolete since 25.1.
-
-** Completion List Mode
-
-*** Improved navigation in the "*Completions*" buffer.
-New key bindings have been added to 'completion-list-mode': 'n' and
-'p' now navigate completions, and 'M-g M-c' switches to the
-minibuffer and back to the completion list buffer.
-
-+++
-** profiler.el
-The results displayed by 'profiler-report' now have the usage figures
-at the left hand side followed by the function name. This is intended
-to make better use of the horizontal space, in particular eliminating
-the truncation of function names. There is no way to get the former
-layout back.
-
-** Icomplete
+*** 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.
---
-*** New user option 'icomplete-matches-format'.
-This allows controlling the current/total number of matches for the
-prompt prefix.
-
-+++
-*** New minor modes 'icomplete-vertical-mode' and 'fido-vertical-mode'.
-These modes modify Icomplete ('M-x icomplete-mode') and Fido ('M-x
-fido-mode'), to display completion candidates vertically instead of
-horizontally. In Icomplete, completions are rotated and selection
-kept at the top. In Fido, completions scroll like a typical dropdown
-widget. Both these new minor modes will turn on their non-vertical
-counterparts first, if they are not on already.
+*** Message Mode now supports image yanking.
----
-*** Default value of 'icomplete-compute-delay' has been changed to 0.15 s.
+** HTML Mode
---
-*** Default value of 'icomplete-max-delay-chars' has been changed to 2.
+*** HTML Mode now supports "text/html" and "image/*" yanking.
----
-*** Reduced blinking while completing the next completions set.
-Icomplete doesn't hide the hint with the previously computed
-completions anymore when compute delay is in effect, or the previous
-computation has been aborted by input. Instead it shows the previous
-completions until the new ones are ready.
+** Texinfo Mode
---
-*** Change in meaning of 'icomplete-show-matches-on-no-input'.
-Previously, choosing a different completion with commands like 'C-.'
-and then hitting 'RET' would choose the default completion. Doing this
-will now choose the completion under point instead. Also when this option
-is nil, completions are not shown when the minibuffer reads a file name
-with initial input as the default directory.
+*** 'texinfo-mode' now has a specialised 'narrow-to-defun' definition.
+It narrows to the current node.
-** Windmove
+** eww/shr
+++
-*** New user options to customize windmove keybindings.
-These options include 'windmove-default-keybindings',
-'windmove-display-default-keybindings',
-'windmove-delete-default-keybindings',
-'windmove-swap-states-default-keybindings'.
-Also new mode 'windmove-mode' enables the customized keybindings.
-
-** Occur mode
-
----
-*** New bindings in occur-mode.
-The command 'next-error-no-select' is now bound to 'n' and
-'previous-error-no-select' is bound to 'p'.
-
----
-*** New command 'recenter-current-error'.
-It is bound to 'l' in Occur or compilation buffers, and recenters the
-current displayed occurrence/error.
-
----
-*** Matches in target buffers are now highlighted as in 'compilation-mode'.
-The method of highlighting is specified by the user options
-'next-error-highlight' and 'next-error-highlight-no-select'.
-
----
-*** A fringe arrow in the "*Occur*" buffer indicates the selected match.
-
----
-*** Occur mode may use a different type for 'occur-target' property values.
-The value was previously always a marker set to the start of the first
-match on the line but can now also be a list of '(BEGIN . END)' pairs
-of markers delimiting each match on the line.
-This is a fully compatible change to the internal occur-mode
-implementation, and code creating their own occur-mode buffers will
-work as before.
-
-** Emacs Lisp mode
-
----
-*** The mode-line now indicates whether we're using lexical or dynamic scoping.
+*** New user option 'shr-allowed-images'.
+This complements 'shr-blocked-images', but allows specifying just the
+allowed images.
+++
-*** A space between an open paren and a symbol changes the indentation rule.
-The presence of a space between an open paren and a symbol now is
-taken as a statement by the programmer that this should be indented
-as a data list rather than as a piece of code.
-
-** Lisp Mode
-
-*** New minor mode 'cl-font-lock-built-in-mode' for 'lisp-mode'.
-The mode provides refined highlighting of built-in functions, types,
-and variables.
-
----
-*** Lisp mode now uses 'common-lisp-indent-function'.
-To revert to the previous behavior,
-'(setq lisp-indent-function 'lisp-indent-function)' from 'lisp-mode-hook'.
-
-** Change Logs and VC
+*** 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, and is known to crash Emacs on some systems, and just
+doesn't work on other systems. Also see etc/PROBLEMS.
+++
-*** 'vc-revert-show-diff' now has a third possible value: 'kill'.
-If this user option is 'kill', then the diff buffer will be killed
-after the 'vc-revert' action instead of buried.
-
----
-*** More VC commands can be used from non-file buffers.
-The relevant commands are those that don't change the VC state.
-The non-file buffers which can use VC commands are those that have
-their 'default-directory' under VC.
-
----
-*** New face 'log-view-commit-body'.
-This is used when expanding commit messages from 'vc-print-root-log'
-and similar commands.
-
----
-*** New faces for 'vc-dir' buffers.
-Those are: 'vc-dir-header', 'vc-dir-header-value', 'vc-dir-directory',
-'vc-dir-file', 'vc-dir-mark-indicator', 'vc-dir-status-warning',
-'vc-dir-status-edited', 'vc-dir-status-up-to-date',
-'vc-dir-status-ignored'.
-
----
-*** The responsible VC backend is now the most specific one.
-'vc-responsible-backend' loops over the backends in
-'vc-handled-backends' to determine which backend is responsible for a
-specific (unregistered) file. Previously, the first matching backend
-was chosen, but now the one with the most specific path is chosen (in
-case there's a directory handled by one backend inside another).
-
----
-*** New command 'vc-dir-root' uses the root directory without asking.
-
----
-*** New commands 'vc-dir-mark-registered-files' (bound to '* r') and
-'vc-dir-mark-unregistered-files'.
-
----
-*** Support for bookmark.el.
-Bookmark locations can refer to VC directory buffers.
-
----
-*** New user option 'vc-hg-create-bookmark'.
-It controls whether a bookmark or branch will be created when you
-invoke 'C-u C-x v s' ('vc-create-tag').
-
----
-*** 'vc-hg' now uses 'hg summary' to populate extra 'vc-dir' headers.
-
----
-*** New user option 'vc-git-revision-complete-only-branches'.
-If non-nil, only branches and remotes are considered when doing
-completion over Git branch names. The default is nil, which causes
-tags to be considered as well.
-
----
-*** New user option 'vc-git-log-switches'.
-String or list of strings specifying switches for Git log under VC.
-
----
-*** Command 'vc-switch-backend' is now obsolete.
-If you are still using it with any regularity, please file a bug
-report with some details.
+*** New 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.
** Gnus
-+++
-*** New user option 'gnus-topic-display-predicate'.
-This can be used to inhibit the display of some topics completely.
-
-+++
-*** nnimap now supports the oauth2.el library.
-
-+++
-*** New Summary buffer sort options for extra headers.
-The extra header sort option ('C-c C-s C-x') prompts for a header
-and fails if no sort function has been defined. Sorting by
-Newsgroups ('C-c C-s C-u') has been pre-defined.
-
-+++
-*** The '#' command in the Group and Summary buffer now toggles,
-instead of sets, the process mark.
-
-+++
-*** New user option 'gnus-process-mark-toggle'.
-If non-nil (the default), the '#' command in the Group and Summary
-buffers will toggle, instead of set, the process mark.
-
-+++
-*** New user option 'gnus-registry-register-all'.
-If non-nil (the default), create registry entries for all messages.
-If nil, don't automatically create entries, they must be created
-manually.
-
-+++
-*** New user options to customise the summary line specs "%[" and "%]".
-Four new options introduced in customisation group
-'gnus-summary-format'. These are 'gnus-sum-opening-bracket',
-'gnus-sum-closing-bracket', 'gnus-sum-opening-bracket-adopted', and
-'gnus-sum-closing-bracket-adopted'. Their default values are "[", "]",
-"<", ">" respectively. These options control the appearance of "%["
-and "%]" specs in the summary line format. "%[" will normally display
-the value of 'gnus-sum-opening-bracket', but can also be
-'gnus-sum-opening-bracket-adopted' for the adopted articles. "%]" will
-normally display the value of 'gnus-sum-closing-bracket', but can also
-be 'gnus-sum-closing-bracket-adopted' for the adopted articles.
-
-+++
-*** New user option 'gnus-paging-select-next'.
-This controls what happens when using commands like 'SPC' and 'DEL' to
-page the current article. If non-nil (the default), go to the
-next/prev article, but if nil, do nothing at the end/start of the article.
-
-+++
-*** New gnus-search library.
-A new unified search syntax which can be used across multiple
-supported search engines. Set 'gnus-search-use-parsed-queries' to
-non-nil to enable.
-
-+++
-*** New value for user option 'smiley-style'.
-Smileys can now be rendered with emojis instead of small images when
-using the new 'emoji' value in 'smiley-style'.
-
-+++
-*** New user option 'gnus-agent-eagerly-store-articles'.
-If non-nil (which is the default), the Gnus Agent will store all read
-articles in the Agent cache.
-
-+++
-*** New user option 'gnus-global-groups'.
-Gnus handles private groups differently from public (i.e., NNTP-like)
-groups. Most importantly, Gnus doesn't download external images from
-mail-like groups. This can be overridden by putting group names in
-'gnus-global-groups': Any group present in that list will be treated
-like a public group.
-
-+++
-*** New scoring types for the Date header.
-You can now score based on the relative age of an article with the new
-'<' and '>' date scoring types.
-
-+++
-*** User-defined scoring is now possible.
-The new type is 'score-fn'. More information in the Gnus manual node
-"(gnus) Score File Format".
-
-+++
-*** New backend 'nnselect'.
-The newly added 'nnselect' backend allows creating groups from an
-arbitrary list of articles that may come from multiple groups and
-servers. These groups generally behave like any other group: they may
-be ephemeral or persistent, and allow article marking, moving,
-deletion, etc. 'nnselect' groups may be created like any other group,
-but there are three convenience functions for the common case of
-obtaining the list of articles as a result of a search:
-'gnus-group-make-search-group' ('G g') that will prompt for an 'nnir'
-search query and create a persistent group for that search;
-'gnus-group-read-ephemeral-search-group' ('G G') that will prompt for
-an 'nnir' search query and create an ephemeral group for that search;
-and 'gnus-summary-make-group-from-search' ('C-c C-p') that will create
-a persistent group with the search parameters of a current ephemeral
-search group.
-
-As part of this addition, the user option 'nnir-summary-line-format'
-has been removed; its functionality is now available directly in the
-'gnus-summary-line-format' specs '%G' and '%g'. The user option
-'gnus-refer-thread-use-nnir' has been renamed to
-'gnus-refer-thread-use-search'.
-
-+++
-*** New user option 'gnus-dbus-close-on-sleep'.
-On systems with D-Bus support, it is now possible to register a signal
-to close all Gnus servers before the system sleeps.
-
-+++
-*** The key binding of 'gnus-summary-search-article-forward' has changed.
-This command was previously on 'M-s' and shadowed the global 'M-s'
-search prefix. The command has now been moved to 'M-s M-s'. (For
-consistency, the 'M-s M-r' key binding has been added for the
-'gnus-summary-search-article-backward' command.)
-
----
-*** The value for "all" in the 'large-newsgroup-initial' group parameter has changed.
-It was previously nil, which didn't work, because nil is
-indistinguishable from not being present. The new value for "all" is
-the symbol 'all'.
-
-+++
-*** The name of dependent Gnus sessions has changed from "slave" to "child".
-The names of the commands 'gnus-slave', 'gnus-slave-no-server' and
-'gnus-slave-unplugged' have changed to 'gnus-child',
-'gnus-child-no-server' and 'gnus-child-unplugged' respectively.
-
-+++
-*** The 'W Q' summary mode command now takes a numerical prefix to
-allow adjusting the fill width.
-
-+++
-*** New variable 'mm-inline-font-lock'.
-This variable is supposed to be bound by callers to determine whether
-inline MIME parts (that support it) are supposed to be font-locked or
-not.
-
-** Message
-
---
-*** Respect 'message-forward-ignored-headers' more.
-Previously, this user option would not be consulted if
-'message-forward-show-mml' was nil and forwarding as MIME.
+*** 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:
-+++
-*** New user option 'message-forward-included-mime-headers'.
-This is used when forwarding messages as MIME, but not using MML.
-
-+++
-*** Message now supports the OpenPGP header.
-To generate these headers, add the new function
-'message-add-openpgp-header' to 'message-send-hook'. The header will
-be generated according to the new 'message-openpgp-header' user
-option.
+ (set-face-attribute 'gnus-header nil :inherit 'unspecified)
---
-*** A change to how "Mail-Copies-To: never" is handled.
-If a user has specified "Mail-Copies-To: never", and Message was asked
-to do a "wide reply", some other arbitrary recipient would end up in
-the resulting "To" header, while the remaining recipients would be put
-in the "Cc" header. This is somewhat misleading, as it looks like
-you're responding to a specific person in particular. This has been
-changed so that all the recipients are put in the "To" header in these
-instances.
-
-+++
-*** New command to start Emacs in Message mode to send an email.
-Emacs can be defined as a handler for the "x-scheme-handler/mailto"
-MIME type with the following command: "emacs -f message-mailto %u".
-An "emacs-mail.desktop" file has been included, suitable for
-installing in desktop directories like "/usr/share/applications" or
-"~/.local/share/applications".
-Clicking on a 'mailto:' link in other applications will then open
-Emacs with headers filled out according to the link, e.g.
-"mailto:larsi@gnus.org?subject=This+is+a+test". If you prefer
-emacsclient, use "emacsclient -e '(message-mailto "%u")'"
-or "emacsclient-mail.desktop".
+*** The default value of 'gnus-treat-fold-headers' is now 'head'.
---
-*** Change to default value of 'message-draft-headers' user option.
-The 'Date' symbol has been removed from the default value, meaning that
-draft or delayed messages will get a date reflecting when the message
-was sent. To restore the original behavior of dating a message
-from when it is first saved or delayed, add the symbol 'Date' back to
-this user option.
-
-+++
-*** New command to take screenshots.
-In Message mode buffers, the 'C-c C-p' ('message-insert-screenshot')
-command has been added. It depends on using an external program to
-take the actual screenshot, and defaults to "ImageMagick import".
-
-** Smtpmail
-
-+++
-*** smtpmail now supports using the oauth2.el library.
+*** New face 'gnus-header'.
+All other 'gnus-header-*' faces inherit from this face now.
+++
-*** New user option 'smtpmail-store-queue-variables'.
-If non-nil, SMTP variables will be stored together with the queued
-messages, and will then be used when sending with
-'M-x smtpmail-send-queued-mail'.
+*** New user option 'gnus-treat-emojize-symbols'.
+If non-nil, symbols that have an emoji representation will be
+displayed as emojis. Default nil.
+++
-*** Allow direct selection of smtp authentication mechanism.
-A server entry retrieved by auth-source can request a desired smtp
-authentication mechanism by setting a value for the key 'smtp-auth'.
-
-** ElDoc
+*** New command 'gnus-article-emojize-symbols'.
+This is bound to 'W D e' and will display symbols that have emoji
+representation as emojis.
-+++
-*** New user option 'eldoc-echo-area-display-truncation-message'.
-If non-nil (the default), eldoc will display a message saying
-something like "(Documentation truncated. Use `M-x eldoc-doc-buffer'
-to see rest)" when a message has been truncated. If nil, truncated
-messages will be marked with just "..." at the end.
-
-+++
-*** New hook 'eldoc-documentation-functions'.
-This hook is intended to be used for registering doc string functions.
-These functions don't need to produce the doc string right away, they
-may arrange for it to be produced asynchronously. The results of all
-doc string functions are accessible to the user through the user
-option 'eldoc-documentation-strategy'.
-
-*** New hook 'eldoc-display-functions'.
-This hook is intended to be used for displaying doc strings. The
-functions receive the doc string composed according to
-'eldoc-documentation-strategy' and are tasked with displaying it to
-the user. Examples of such functions would use the echo area, a
-separate buffer, or a tooltip.
-
-+++
-*** New user option 'eldoc-documentation-strategy'.
-The built-in choices available for this user option let users compose
-the results of 'eldoc-documentation-functions' in various ways, even
-if some of those functions are synchronous and some asynchronous.
-The user option replaces 'eldoc-documentation-function', which is now
-obsolete.
-
-*** 'eldoc-echo-area-use-multiline-p' is now handled by ElDoc.
-The user option 'eldoc-echo-area-use-multiline-p' is now handled
-by the ElDoc library itself. Functions in
-'eldoc-documentation-functions' don't need to worry about consulting
-it when producing a doc string.
-
-** Tramp
+** EIEIO
+++
-*** New connection method "mtp".
-It allows accessing media devices like cell phones, tablets or
-cameras.
+*** 'slot-value' can now be used to access slots of 'cl-defstruct' objects.
-+++
-*** New connection method "sshfs".
-It allows accessing remote files via a file system mounted with
-'sshfs'.
-
-+++
-*** Tramp supports SSH authentication via a hardware security key now.
-This requires at least OpenSSH 8.2, and a FIDO U2F compatible
-security key, like yubikey, solokey, or nitrokey.
-
-+++
-*** Trashed remote files are moved to the local trash directory.
-All remote files that are trashed are moved to the local trash
-directory, except remote encrypted files, which are always deleted.
-
-+++
-*** New command 'tramp-crypt-add-directory'.
-This command marks a remote directory to contain only encrypted files.
-See the "(tramp) Keeping files encrypted" node of the Tramp manual for
-details. This feature is experimental.
-
-+++
-*** Support of direct asynchronous process invocation.
-When Tramp connection property "direct-async-process" is set to
-non-nil for a given connection, 'make-process' and 'start-file-process'
-calls are performed directly as in "ssh ... <command>". This avoids
-initialization performance penalties. See the "(tramp) Improving
-performance of asynchronous remote processes" node of the Tramp manual
-for details, and also for a discussion or restrictions. This feature
-is experimental.
-
-+++
-*** New user option 'tramp-debug-to-file'.
-When non-nil, this user option instructs Tramp to mirror the debug
-buffer to a file under the "/tmp/" directory. This is useful, if (in
-rare cases) Tramp blocks Emacs, and we need further debug information.
-
-+++
-*** Tramp supports lock files now.
-In order to deactivate this, set user option
-'remote-file-name-inhibit-locks' to t.
-
-+++
-*** Writing sensitive data locally requires confirmation.
-Writing auto-save, backup or lock files to the local temporary
-directory must be confirmed. In order to suppress this confirmation,
-set user option 'tramp-allow-unsafe-temporary-files' to t.
-
-+++
-*** 'make-directory' of a remote directory honors the default file modes.
-
-** gdb-mi
-
-*** New user option 'gdb-registers-enable-filter'.
-If non-nil, apply a register filter based on
-'gdb-registers-filter-pattern-list'.
-
-+++
-*** gdb-mi can now save and restore window configurations.
-Use 'gdb-save-window-configuration' to save window configuration to a
-file and 'gdb-load-window-configuration' to load from a file. These
-commands can also be accessed through the menu bar under "Gud =>
-GDB-Windows". 'gdb-default-window-configuration-file', when non-nil,
-is loaded when GDB starts up.
-
-+++
-*** gdb-mi can now restore window configuration after quitting.
-Set 'gdb-restore-window-configuration-after-quit' to non-nil and Emacs
-will remember the window configuration before GDB started and restore
-it after GDB quits. A toggle button is also provided under "Gud =>
-GDB-Windows" menu item.
-
-+++
-*** gdb-mi now has a better logic for displaying source buffers.
-Now GDB only uses one source window to display source file by default.
-Customize 'gdb-max-source-window-count' to use more than one window.
-Control source file display by 'gdb-display-source-buffer-action'.
-
-+++
-*** The default value of 'gdb-mi-decode-strings' is now t.
-This means that the default coding-system is now used to decode strings
-and source file names from GDB.
-
-** Compilation mode
-
----
-*** New function 'ansi-color-compilation-filter'.
-This function is meant to be used in 'compilation-filter-hook'.
-
----
-*** New user option 'ansi-color-for-compilation-mode'.
-This controls what 'ansi-color-compilation-filter' does.
-
-*** Regexp matching of messages is now case-sensitive by default.
-The variable 'compilation-error-case-fold-search' can be set for
-case-insensitive matching of messages when the old behavior is
-required, but the recommended solution is to use a correctly matching
-regexp instead.
-
----
-*** New user option 'compilation-search-all-directories'.
-When doing parallel builds, directories and compilation errors may
-arrive in the "*compilation*" buffer out-of-order. If this option is
-non-nil (the default), Emacs will now search backwards in the buffer
-for any directory the file with errors may be in. If nil, this won't
-be done (and this restores how this previously worked).
+** align
---
-*** Messages from ShellCheck are now recognized.
+*** 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.
----
-*** Messages from Visual Studio that mention column numbers are now recognized.
-
-** Hi Lock mode
-
----
-*** Matching in 'hi-lock-mode' can be case-sensitive.
-The matching is case-sensitive when a regexp contains upper case
-characters and 'search-upper-case' is non-nil. 'highlight-phrase'
-also uses 'search-whitespace-regexp' to substitute spaces in regexp
-search.
-
----
-*** The default value of 'hi-lock-highlight-range' was enlarged.
-The new default value is 2000000 (2 megabytes).
-
-** Whitespace mode
+** eww
+++
-*** New style 'missing-newline-at-eof'.
-If present in 'whitespace-style' (as it is by default), the final
-character in the buffer will be highlighted if the buffer doesn't end
-with a newline.
-
----
-*** The default 'whitespace-enable-predicate' predicate has changed.
-It used to check elements in the list version of
-'whitespace-global-modes' with 'eq', but now uses 'derived-mode-p'.
+*** New user option to automatically rename EWW buffers.
+The 'eww-auto-rename-buffer' user option can be configured to rename
+rendered web pages by using their title, URL, or a user-defined
+function which returns a string. For the first two cases, the length
+of the resulting name is controlled by 'eww-buffer-name-length'. By
+default, no automatic renaming is performed.
-** Texinfo
-
----
-*** New user option 'texinfo-texi2dvi-options'.
-This is used when invoking 'texi2dvi' from 'texinfo-tex-buffer'.
-
----
-*** New commands for moving in and between environments.
-An "environment" is something that ends with '@end'. The commands are
-'C-c C-c C-f' (next end), 'C-c C-c C-b' (previous end),
-'C-c C-c C-n' (next start) and 'C-c C-c C-p' (previous start), as well
-as 'C-c .', which will alternate between the start and the end of the
-current environment.
-
-** Rmail
-
----
-*** New user option 'rmail-re-abbrevs'.
-Its default value matches localized abbreviations of the "reply"
-prefix on the Subject line in various languages.
-
----
-*** New user option 'rmail-show-message-set-modified'.
-If set non-nil, showing an unseen message will set the Rmail buffer's
-modified flag. The default is nil, to preserve the old behavior.
-
-** CC Mode
-
-+++
-*** Added support for Doxygen documentation style.
-'doxygen' is now a valid 'c-doc-comment-style' which recognises all
-comment styles supported by Doxygen (namely '///', '//!', '/** … */'
-and '/*! … */'. 'gtkdoc' remains the default for C and C++ modes; to
-use 'doxygen' by default one might evaluate:
-
- (setq-default c-doc-comment-style
- '((java-mode . javadoc)
- (pike-mode . autodoc)
- (c-mode . doxygen)
- (c++-mode . doxygen)))
-
-or use it in a custom 'c-style'.
-
-+++
-*** Added support to line up '?' and ':' of a ternary operator.
-The new 'c-lineup-ternary-bodies' function can be used as a lineup
-function to align question mark and colon which are part of a ternary
-operator ('?:'). For example:
-
- return arg % 2 == 0 ? arg / 2
- : (3 * arg + 1);
-
-To enable, add it to appropriate entries in 'c-offsets-alist', e.g.:
-
- (c-set-offset 'arglist-cont '(c-lineup-ternary-bodies
- c-lineup-gcc-asm-reg))
- (c-set-offset 'arglist-cont-nonempty '(c-lineup-ternary-bodies
- c-lineup-gcc-asm-reg
- c-lineup-arglist))
- (c-set-offset 'statement-cont '(c-lineup-ternary-bodies +))
-
-** Images
-
----
-*** You can explicitly specify base_uri for svg images.
-':base-uri' image property can be used to explicitly specify base_uri
-for embedded images into svg. ':base-uri' is supported for both file
-and data svg images.
-
-+++
-*** 'svg-embed-base-uri-image' added to embed images.
-'svg-embed-base-uri-image' can be used to embed images located
-relatively to 'file-name-directory' of the ':base-uri' svg image property.
-This works much faster than 'svg-embed'.
-
-+++
-*** New function 'image-cache-size'.
-This function returns the size of the current image cache, in bytes.
-
----
-*** Animated images stop automatically under high CPU pressure sooner.
-Previously, an animated image would stop animating if any single image
-took more than two seconds to display. The new algorithm maintains a
-decaying average of delays, and if this number gets too high, the
-animation is stopped.
-
-+++
-*** The 'n' and 'p' commands (next/previous image) now respect Dired order.
-These commands would previously display the next/previous image in
-lexicographic order, but will now find the "parent" Dired buffer and
-select the next/previous image file according to how the files are
-sorted there. The commands have also been extended to work when the
-"parent" buffer is an archive mode (i.e., zip file or the like) or tar
-mode buffer.
-
----
-*** 'image-converter' is now restricted to formats in 'auto-mode-alist'.
-When using external image converters, the external program is queried
-for what formats it supports. This list may contain formats that are
-problematic in some contexts (like PDFs), so this list is now filtered
-based on 'auto-mode-alist'. Only file names that map to 'image-mode'
-are now supported.
-
----
-*** The background and foreground of images now default to face colors.
-When an image doesn't specify a foreground or background color, Emacs
-now uses colors from the face used to draw the surrounding text
-instead of the frame's default colors.
-
-To load images with the default frame colors use the ':foreground' and
-':background' image attributes, for example:
-
- (create-image "filename" nil nil
- :foreground (face-attribute 'default :foreground)
- :background (face-attribute 'default :background))
-
-This change only affects image types that support foreground and
-background colors or transparency, such as xbm, pbm, svg, png and gif.
-
-+++
-*** Image smoothing can now be explicitly enabled or disabled.
-Smoothing applies a bilinear filter while scaling or rotating an image
-to prevent aliasing and other unwanted effects. The new image
-property ':transform-smoothing' can be set to t to force smoothing
-and nil to disable smoothing.
-
-The default behavior of smoothing on down-scaling and not smoothing
-on up-scaling remains unchanged.
-
-+++
-*** New user option 'image-transform-smoothing'.
-This controls whether to use smoothing or not for an image. Values
-include nil (no smoothing), t (do smoothing) or a predicate function
-that's called with the image object and should return nil/t.
-
-+++
-*** SVG images now support user stylesheets.
-The ':css' image attribute can be used to override the default CSS
-stylesheet for an image. The default sets 'font-family' and
-'font-size' to match the current face, so an image with 'height="1em"'
-will match the font size in use where it is embedded.
-
-This feature relies on librsvg 2.48 or above being available.
-
-+++
-*** Image properties support 'em' sizes.
-Size image properties, for example ':height', ':max-height', etc., can
-be given a cons of the form '(SIZE . em)', where SIZE is an integer or
-float which is multiplied by the font size to calculate the image
-size, and 'em' is a symbol.
-
-** EWW
-
-+++
-*** New user option 'eww-use-browse-url'.
-This is a regexp that can be set to alter how links are followed in eww.
-
-+++
-*** New user option 'eww-retrieve-command'.
-This can be used to download data via an external command. If nil
-(the default), then 'url-retrieve' is used. When 'sync', then
-'url-retrieve-synchronously' is used. A list of strings specifies
-an external program with parameters.
-
-+++
-*** New Emacs command line convenience command.
-The 'eww-browse' command has been added, which allows you to register
-Emacs as a MIME handler for "text/x-uri", and will call 'eww' on the
-supplied URL. Usage example: "emacs -f eww-browse https://gnu.org".
-
-+++
-*** 'eww-download-directory' will now use the XDG location, if defined.
-However, if "~/Downloads/" already exists, that will continue to be
-used.
-
----
-*** The command 'eww-follow-link' now supports custom mailto: handlers.
-The function that is invoked when clicking on or otherwise following a
-'mailto:' link in an EWW buffer can now be customized. For more
-information, see the related entry about 'shr-browse-url' below.
+** Help
----
-*** Support for bookmark.el.
-The command 'bookmark-set' (bound to 'C-x r m') is now supported, and
-will create a bookmark that opens the current URL in EWW.
+*** 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').
-** SHR
+** info-look
---
-*** The command 'shr-browse-url' now supports custom mailto handlers.
-Clicking on or otherwise following a 'mailto:' link in an HTML buffer
-rendered by SHR previously invoked the command 'browse-url-mailto'.
-This is still the case by default, but if you customize
-'browse-url-mailto-function' or 'browse-url-handlers' to call some
-other function, it will now be called instead of the default.
+*** 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).
----
-*** New user option 'shr-offer-extend-specpdl'.
-If this is nil, rendering of HTML that requires enlarging
-'max-specpdl-size', the number of Lisp variable bindings, will be
-aborted, and Emacs will not ask you whether to enlarge
-'max-specpdl-size' to complete the rendering. The default is t, which
-preserves the original behavior.
+** subr-x
+++
-*** New user option 'shr-max-width'.
-If this user option is non-nil, and 'shr-width' is nil, then SHR will
-use the value of 'shr-max-width' to limit the width of the rendered
-HTML. The default is 120 characters, so even if you have very wide
-frames, HTML text will be rendered more narrowly, which usually leads
-to a more readable text. Customize it to nil to get the previous
-behavior of rendering as wide as the 'window-width' allows. If
-'shr-width' is non-nil, it overrides this option.
+*** New macro 'with-memoization' provides a very primitive form of memoization.
----
-*** New faces for heading elements.
-Those are 'shr-h1', 'shr-h2', 'shr-h3', 'shr-h4', 'shr-h5', 'shr-h6'.
-
-** Project
+** ansi-color
---
-*** New user option 'project-vc-merge-submodules'.
-
----
-*** Project commands now have their own history.
-Previously used project directories are now suggested by all commands
-that prompt for a project directory.
-
-+++
-*** New prefix keymap 'project-prefix-map'.
-Key sequences that invoke project-related commands start with the
-prefix 'C-x p'. Type 'C-x p C-h' to show the full list.
-
-+++
-*** New commands 'project-dired', 'project-vc-dir', 'project-shell',
-'project-eshell'. These commands run Dired/VC-Dir and Shell/Eshell in
-a project's root directory, respectively.
-
-+++
-*** New command 'project-compile'.
-This command runs compilation in the current project's root directory.
-
-+++
-*** New command 'project-switch-project'.
-This command lets you "switch" to another project and run a project
-command chosen from a dispatch menu.
-
-+++
-*** New commands 'project-shell-command' and 'project-async-shell-command'.
-These commands run 'shell-command' and 'async-shell-command' in a
-project's root directory, respectively.
-
-+++
-*** New user option 'project-list-file'.
-This specifies the file in which to save the list of known projects.
-
-+++
-*** New command 'project-remember-projects-under'.
-This command can automatically locate and index projects in a
-directory and optionally also its subdirectories, storing them in
-'project-list-file'.
-
-+++
-*** New commands 'project-forget-project' and 'project-forget-projects-under'.
-These commands let you interactively remove entries from the list of projects
-in 'project-list-file'.
+*** 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.
-+++
-*** New command 'project-forget-zombie-projects'.
-This command detects indexed projects that have since been deleted,
-and removes them from the list of known projects in 'project-list-file'.
+** term-mode
---
-*** 'project-find-file' now accepts non-existent file names.
-This is to allow easy creation of files inside some nested
-sub-directory.
-
-+++
-*** 'project-find-file' doesn't use the string at point as default input.
-Now it's only suggested as part of the "future history", accessible
-via 'M-n'.
-
-+++
-*** New command 'project-find-dir' runs Dired in a directory inside project.
+*** 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.
** Xref
-+++
-*** New user options to automatically show the first Xref match.
-The new user option 'xref-auto-jump-to-first-definition' controls the
-behavior of 'xref-find-definitions' and its variants, like
-'xref-find-definitions-other-window': if it's t or 'show', the first
-match is automatically displayed; if it's 'move', point in the
-"*xref*" buffer is automatically moved to the first match without
-displaying it.
-The new user option 'xref-auto-jump-to-first-xref' changes the
-behavior of Xref commands such as 'xref-find-references',
-'xref-find-apropos', and 'project-find-regexp', which are expected to
-display many matches that the user would like to
-visit. 'xref-auto-jump-to-first-xref' changes their behavior much in
-the same way as 'xref-auto-jump-to-first-definition' affects the
-"find-definitions" commands.
+*** 'project-find-file' and 'project-or-external-find-file' now accept
+a prefix argument which is interpreted to mean "include all files".
----
-*** New user options 'xref-search-program' and 'xref-search-program-alist'.
-So far 'grep' and 'ripgrep' are supported. 'ripgrep' seems to offer better
-performance in certain cases, in particular for case-insensitive
-searches.
+*** '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 commands 'xref-prev-group' and 'xref-next-group'.
-These commands are bound respectively to 'P' and 'N', and navigate to
-the first item of the previous or next group in the "*xref*" buffer.
+*** New command 'xref-go-forward'.
+It is bound to 'C-M-,' and jumps to the location where 'xref-go-back'
+('M-,', also known as 'xref-pop-marker-stack') was invoked previously.
----
-*** New alternative value for 'xref-show-definitions-function':
-'xref-show-definitions-completing-read'.
-
----
-*** The two existing alternatives for 'xref-show-definitions-function'
-have been renamed to have "proper" public names and documented
-('xref-show-definitions-buffer' and
-'xref-show-definitions-buffer-at-bottom').
+** File notifications
+++
-*** New command 'xref-quit-and-pop-marker-stack'.
-This command is bound to 'M-,' in "*xref*" buffers. This combination
-is easy to press semi-accidentally if the user wants to go back in the
-middle of choosing the exact definition to go to, and this should do
-TRT.
+*** The new command 'file-notify-rm-all-watches' removes all file notifications.
----
-*** New value 'project-relative' for 'xref-file-name-display'.
-If chosen, file names in "*xref*" buffers will be displayed relative
-to the 'project-root' of the current project, when available.
+** Sql
---
-*** Prefix arg of 'xref-goto-xref' quits the "*xref*" buffer.
-So typing 'C-u RET' in the "*xref*" buffer quits its window
-before navigating to the selected location.
-
-+++
-*** The 'TAB' key binding in "*xref*" buffers is obsolete.
-Use 'C-u RET' instead. The 'TAB' binding in "*xref*" buffers is still
-supported, but we plan on removing it in a future version; at that
-time, the command 'xref-quit-and-goto-xref' will no longer have a key
-binding in 'xref--xref-buffer-mode-map'.
+*** 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.
----
-*** New user option 'etags-xref-prefer-current-file'.
-When non-nil, matches for identifiers in the file visited by the
-current buffer will be shown first in the "*xref*" buffer.
+** Image Mode
+++
-*** The etags Xref backend now honors 'tags-apropos-additional-actions'.
-You can customize it to augment the output of 'xref-find-apropos',
-like it affected the output of 'tags-apropos', which is obsolete since
-Emacs 25.1.
-
-** Battery
-
----
-*** UPower is now the default battery status backend when available.
-UPower support via the function 'battery-upower' was added in Emacs
-26.1, but was disabled by default. It is now the default value of
-'battery-status-function' when the system provides a UPower D-Bus
-service. The user options 'battery-upower-device' and
-'battery-upower-subscribe' control which power sources to query and
-whether to respond to status change notifications in addition to
-polling, respectively.
-
----
-*** A richer syntax can be used to format battery status information.
-The user options 'battery-mode-line-format' and
-'battery-echo-area-format' now support the full formatting syntax of
-the function 'format-spec' documented under node "(elisp) Custom Format
-Strings". The new syntax includes specifiers for padding and
-truncation, amongst other things.
-
-** bug-reference.el
-
----
-*** Bug reference mode uses auto-setup.
-If 'bug-reference-mode' or 'bug-reference-prog-mode' have been
-activated, their respective hook has been run, and both
-'bug-reference-bug-regexp' and 'bug-reference-url-format' are still
-not set, it tries to guess appropriate values for those two variables.
-There are three guessing mechanisms so far: based on version control
-information of the current buffer's file, based on
-newsgroup/mail-folder name and several news and mail message headers
-in Gnus buffers, and based on IRC channel and network in rcirc and ERC
-buffers. All the mechanisms are extensible with custom rules, see the
-variables 'bug-reference-setup-from-vc-alist',
-'bug-reference-setup-from-mail-alist', and
-'bug-reference-setup-from-irc-alist'.
-
-** HTML Mode
-
----
-*** A new skeleton for adding relative URLs has been added.
-It's bound to the 'C-c C-c f' keystroke, and prompts for a local file
-name.
-
-** Widget
+*** 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 does not
+only scale the image down, but up as well. It is bound to "s w" in
+Image Mode by default.
+++
-*** 'widget-choose' now supports menus in extended format.
+*** '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'.
---
-*** The 'editable-list' widget now supports moving items up and down.
-You can now move items up and down by deleting and then reinserting
-them, using the 'DEL' and 'INS' buttons respectively. This is useful
-in Custom buffers, for example, to change the order of the elements in
-a list.
+*** User option 'image-auto-resize' can now be set to 'fit-window'.
+This works like 'image-transform-fit-to-window'.
-** Diff
+*** 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 face 'diff-changed-unspecified'.
-This is used to highlight "changed" lines (those marked with '!') in
-context diffs, when 'diff-use-changed-face' is non-nil.
-
----
-*** New 'diff-mode' font locking face 'diff-error'.
-This face is used for error messages from 'diff'.
-
-+++
-*** New command 'diff-refresh-hunk'.
-This new command (bound to 'C-c C-l') regenerates the current hunk.
-
-** thing-at-point
-
-+++
-*** New 'thing-at-point' target: 'existing-filename'.
-This is like 'filename', but is a full path, and is nil if the file
-doesn't exist.
-
-+++
-*** New 'thing-at-point' target: 'string'.
-If point is inside a string, it returns that string.
-
-+++
-*** New variable 'thing-at-point-provider-alist'.
-This allows mode-specific alterations to how 'thing-at-point' works.
-
----
-*** thing-at-point now respects fields.
-'thing-at-point' (and all functions that use it, like
-'symbol-at-point') will narrow to the current field (if any) before
-trying to identify the thing at point.
-
----
-*** New function 'thing-at-mouse'.
-This is like 'thing-at-point', but uses the mouse event position instead.
+*** New user option 'image-text-based-formats'.
+This controls whether or not to show a message when opening certain
+image formats saying how to edit it as text. The default is to show
+this message for SVG and XPM.
** Image-Dired
+++
-*** New user option 'image-dired-thumb-visible-marks'.
-If non-nil (the default), use the new face 'image-dired-thumb-mark'
-for marked images.
+*** 'image-dired-display-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. Finally, some commands and
+user options that are no longer needed 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'.
---
-*** New command 'image-dired-delete-marked'.
-
----
-*** 'image-dired-mouse-toggle-mark' is now sensitive to the active region.
-If the region is active, this command now toggles Dired marks of all
-the thumbnails in the region.
-
-** Flymake mode
-
-+++
-*** New command 'flymake-show-project-diagnostics'.
-This lists all diagnostics for buffers in the currently active
-project. The listing is similar to the one obtained by
-'flymake-show-buffer-diagnostics', but adds a column for the
-project-relative file name. For backends which support it,
-'flymake-show-project-diagnostics' also lists diagnostics for files
-that have not yet been visited.
-
-+++
-*** New user options to customize Flymake's mode-line.
-The new user option 'flymake-mode-line-format' is a mix of strings and
-symbols like 'flymake-mode-line-title', 'flymake-mode-line-exception'
-and 'flymake-mode-line-counters'. The new user option
-'flymake-mode-line-counter-format' is a mix of strings and symbols
-like 'flymake-mode-line-error-counter',
-'flymake-mode-line-warning-counter' and 'flymake-mode-line-note-counter'.
+*** Navigation and marking commands now work in image display buffer.
+The following new bindings have been added:
-** Time
+ n / SPC image-dired-display-next-thumbnail-original
+ p / DEL image-dired-display-previous-thumbnail-original
+ m image-dired-mark-thumb-original-file
+ d image-dired-flag-thumb-original-file
+ u image-dired-unmark-thumb-original-file
---
-*** 'display-time-world' has been renamed to 'world-clock'.
-'world-clock' creates a buffer with an updating time display using
-several time zones. It is hoped that the new names are more
-discoverable.
-
-The following commands have been renamed:
-
- 'display-time-world' to 'world-clock'
- 'display-time-world-mode' to 'world-clock-mode'
- 'display-time-world-display' to 'world-clock-display'
- 'display-time-world-timer' to 'world-clock-update'
-
-The following user options have been renamed:
-
- 'display-time-world-list' to 'world-clock-list'
- 'display-time-world-time-format' to 'world-clock-time-format'
- 'display-time-world-buffer-name' to 'world-clock-buffer-name'
- 'display-time-world-timer-enable' to 'world-clock-timer-enable'
- 'display-time-world-timer-second' to 'world-clock-timer-second'
-
-The old names are now obsolete.
+*** Reduce dependency on external "exiftool" command.
+The 'image-dired-copy-with-exif-file-name' no longer requires an
+external "exiftool" command to be available. The user options
+'image-dired-cmd-read-exif-data-program' and
+'image-dired-cmd-read-exif-data-options' are now obsolete.
---
-*** 'world-clock-mode' can no longer be turned on interactively.
-Use 'world-clock' to turn on that mode.
-
-** Python mode
+*** New command for the thumbnail buffer.
+The new command 'image-dired-unmark-all-marks' has been added. It is
+bound to 'U' in the thumbnail and display buffer.
---
-*** New user option 'python-forward-sexp-function'.
-This allows the user easier customization of whether to use block-based
-navigation or not.
+*** 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.
---
-*** 'python-shell-interpreter' now defaults to python3 on systems with python3.
+*** Support GraphicsMagick command line tools.
+Support for the GraphicsMagick command line tool ("gm") has been
+added, and is used instead of ImageMagick when it is available.
---
-*** 'C-c C-r' can now be used on arbitrary regions.
-The command previously extended the start of the region to the start
-of the line, but will now actually send the marked region, as
-documented.
-
-** Ruby Mode
+*** 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.
---
-*** 'ruby-use-smie' is declared obsolete.
-SMIE is now always enabled and 'ruby-use-smie' only controls whether
-indentation is done using SMIE or with the old ad-hoc code.
+*** 'image-dired-slideshow-start' is now bound to 'S'.
+It is bound in both the thumbnail and display buffer.
---
-*** Indentation has changed when 'ruby-align-chained-calls' is non-nil.
-This previously used to align subsequent lines with the last sibling,
-but it now aligns with the first sibling (which is the preferred style
-in Ruby).
-
-** CPerl Mode
+*** 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.
---
-*** New face 'perl-heredoc', used for heredoc elements.
+*** 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 command 'cperl-set-style' offers the new value "PBP".
-This value customizes Emacs to use the style recommended in Damian
-Conway's book "Perl Best Practices" for indentation and formatting
-of conditionals.
-
-** Perl mode
+*** 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 'perl-non-scalar-variable'.
-This is used to fontify non-scalar variables.
-
-** Octave Mode
-
-+++
-*** Line continuations in double-quoted strings now use a backslash.
-Typing 'C-M-j' (bound to 'octave-indent-new-comment-line') now follows
-the behavior introduced in Octave 3.8 of using a backslash as a line
-continuation marker within double-quoted strings, and an ellipsis
-everywhere else.
-
-+++
-** EasyPG
-GPG key servers can now be queried for keys with the
-'M-x epa-search-keys' command. Keys can then be added to your
-personal key ring.
-
-** Etags
-
-+++
-*** Etags now supports the Mercury programming language.
-See https://mercurylang.org.
-
-+++
-*** Etags command line option '--declarations' now has Mercury-specific behavior.
-All Mercury declarations are tagged by default. However, for
-compatibility with 'etags' support for Prolog, predicates and
-functions appearing first in clauses will also be tagged if 'etags' is
-invoked with the '--declarations' command-line option.
-
-** Comint
+*** Image information is now shown in the header line.
+This replaces the message most navigation commands in the thumbnail
+buffer used to show at the bottom of the screen.
+++
-*** Support for OSC escape sequences.
-Adding the new 'comint-osc-process-output' to
-'comint-output-filter-functions' enables the interpretation of OSC
-("Operating System Command") escape sequences in comint buffers. By
-default, only OSC 8, for hyperlinks, and OSC 7, for directory
-tracking, are acted upon. Adding more entries to
-'comint-osc-handlers' allows a customized treatment of further escape
-sequences.
-
-+++
-*** 'comint-delete-output' can now save deleted text in the kill-ring.
-Interactively, 'C-u C-c C-o' triggers this new optional behavior.
-
-** ansi-color.el
-
----
-*** Colors are now defined by faces.
-ANSI SGR codes now have corresponding faces to describe their
-appearance, e.g. 'ansi-color-bold'.
-
----
-*** Support for "bright" color codes.
-"Bright" ANSI color codes are now displayed when applying ANSI color
-filters using the color values defined by the faces
-'ansi-color-bright-COLOR'. In addition, bold text with regular ANSI
-colors can be displayed as "bright" if 'ansi-color-bold-is-bright' is
-non-nil.
-
-** ERC
-
-*** Starting with Emacs 28.1 and ERC 5.4, see the ERC-NEWS file for
-user-visible changes in ERC.
-
-** xwidget-webkit mode
-
----
-*** New xwidget commands.
-'xwidget-webkit-uri' (return the current URL), 'xwidget-webkit-title'
-(return the current title), and 'xwidget-webkit-goto-history' (goto a
-point in history).
-
----
-*** Downloading files from xwidget-webkit is now supported.
-The new user option 'xwidget-webkit-download-dir' says where to download to.
-
----
-*** New command 'xwidget-webkit-clone-and-split-below'.
-Open a new window below displaying the current URL.
-
----
-*** New command 'xwidget-webkit-clone-and-split-right'.
-Open a new window to the right displaying the current URL.
-
----
-*** Pixel-based scrolling.
-The 'xwidget-webkit-scroll-up', 'xwidget-webkit-scroll-down' commands
-now supports scrolling arbitrary pixel values. It now treats the
-optional 2nd argument as the pixel values to scroll.
-
----
-*** New commands for scrolling.
-The new commands 'xwidget-webkit-scroll-up-line',
-'xwidget-webkit-scroll-down-line', 'xwidget-webkit-scroll-forward',
-'xwidget-webkit-scroll-backward' can be used to scroll webkit by the
-height of lines or width of chars.
-
----
-*** New user option 'xwidget-webkit-bookmark-jump-new-session'.
-When non-nil, use a new xwidget webkit session after bookmark jump.
-Otherwise, it will use 'xwidget-webkit-last-session'.
-
-** Checkdoc
-
----
-*** No longer warns about command substitutions by default.
-Checkdoc used to warn about "too many command substitutions" (as in
-"\\[foo-command]"), even if you only used ten of them in a docstring.
-On modern machines, you can have hundreds or thousands of command
-substitutions before it becomes a performance issue, so this warning
-is now disabled by default. To re-enable this warning, customize the
-user option 'checkdoc-max-keyref-before-warn'.
-
----
-*** New user option 'checkdoc-column-zero-backslash-before-paren'.
-Checkdoc warns if there is a left parenthesis in column zero of a
-documentation string. That warning can now be disabled by customizing
-this new user option to nil. This is useful if you don't expect
-your code to be edited with an Emacs older than version 27.1.
-
----
-*** Now checks the prompt format for 'yes-or-no-p'.
-In addition to verifying the format of the prompt for 'y-or-n-p',
-checkdoc will now check the format of 'yes-or-no-p'.
-
----
-*** New command 'checkdoc-dired'.
-This can be used to run checkdoc on files from a Dired buffer.
+*** 'image-dired-show-all-from-dir-max-files' has been increased to 500.
+This option controls asking for confirmation when starting Image-Dired
+in a directory with many files. However, Image-Dired creates
+thumbnails in the background these days, so this is not as important
+as it used to be, back when entering a large directory could lock up
+Emacs for tens of seconds. In addition, you can now customize this
+option to nil to disable this confirmation completely.
---
-*** No longer checks for 'A-' modifiers.
-Checkdoc recommends usage of command substitutions ("\\[foo-command]")
-in favor of writing keybindings like 'C-c f'. It now no longer warns
-about the 'A-' modifier as it is not used very much in practice, and
-this warning therefore mostly led to false positives.
+*** Make 'image-dired-rotate-thumbnail-(left|right)' obsolete.
+Instead, use 'M-x image-dired-refresh-thumb' to generate a new
+thumbnail, or 'M-x image-rotate' to rotate the thumbnail without
+updating the thumbnail file.
-** Enriched mode
+** Dired
----
-*** 'C-a' is by default no longer bound to 'beginning-of-line-text'.
-This is so 'C-a' works as in other modes, and in particular holding
-Shift while typing 'C-a', i.e. 'C-S-a', will now highlight the text.
+*** 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:
-** Gravatar
+ (setq dired-free-space 'separate)
---
-*** New user option 'gravatar-service' for host to query for gravatars.
-Defaults to 'libravatar', with 'unicornify' and 'gravatar' as options.
-
-** MH-E mail handler for Emacs
-
-Functions and variables related to handling junk mail have been
-renamed to not associate color with sender quality.
-
-+++
-*** New names for mh-junk interactive functions.
-Function 'mh-junk-whitelist' is renamed 'mh-junk-allowlist'.
-Function 'mh-junk-blacklist' is renamed 'mh-junk-blocklist'.
+*** New 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 binding for 'mh-junk-allowlist'.
-The key binding for 'mh-junk-allowlist' is changed from 'J w' to 'J a'.
-The old binding is supported but warns that it is obsolete.
+** Exif
-+++
-*** New names for some hooks.
-'mh-whitelist-msg-hook' is renamed 'mh-allowlist-msg-hook'.
-'mh-blacklist-msg-hook' is renamed 'mh-blocklist-msg-hook'.
+*** New function 'exif-field'.
+This is a convenience function to extract the field data from
+'exif-parse-file' and 'exif-parse-buffer'.
-+++
-*** New names for some user options.
-User option 'mh-whitelist-preserves-sequences-flag' is renamed
-'mh-allowlist-preserves-sequences-flag'.
-
-+++
-*** New names for some faces.
-Face 'mh-folder-blacklisted' is renamed 'mh-folder-blocklisted'.
-Face 'mh-folder-whitelisted' is renamed 'mh-folder-allowlisted'.
-
-** Rcirc
-
-+++
-*** rcirc now supports SASL authentication.
+** Xwidgets
---
-*** #emacs on Libera.chat has been added to 'rcirc-server-alist'.
+*** New user option 'xwidget-webkit-buffer-name-format'.
+Using this option you can control how the xwidget-webkit buffers are
+named.
---
-*** rcirc connects asynchronously.
-
----
-*** Integrate formatting into 'rcirc-send-string'.
-The function now accepts a variable number of arguments.
+*** New user option 'xwidget-webkit-cookie-file'.
+Using this option you can control whether the xwidget-webkit buffers
+save cookies set by web pages, and if so, in which file to save them.
+++
-*** Deprecate 'rcirc-command' in favor of 'rcirc-define-command'.
-The new macro handles multiple and optional arguments.
-
----
-*** Add basic IRCv3 support.
-This includes support for the capabilities: 'server-time', 'batch',
-'message-ids', 'invite-notify', 'multi-prefix' and 'standard-replies'.
-
----
-*** Add mouse property support to 'rcirc-track-minor-mode'.
-
----
-*** Improve support for IRC markup codes.
-
----
-*** Check 'auth-sources' for server passwords.
+*** 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.
+++
-*** Implement repeated reconnection strategy.
-See 'rcirc-reconnect-attempts'.
-
-** MPC
-
----
-*** New command 'mpc-goto-playing-song'.
-This command, bound to 'o' in any 'mpc-mode' buffer, moves point to
-the currently playing song in the "*MPC-Songs*" buffer.
-
----
-*** New user option 'mpc-cover-image-re'.
-If non-nil, it is a regexp that should match a valid cover image.
-
-** Miscellaneous
-
----
-*** 'shell-script-mode' now supports 'outline-minor-mode'.
-The outline headings have lines that start with "###".
-
----
-*** fileloop will now skip missing files instead of signalling an error.
-
----
-*** 'tabulated-list-mode' can now restore original display order.
-Many commands (like 'C-x C-b') are derived from 'tabulated-list-mode',
-and that mode allows the user to sort on any column. There was
-previously no easy way to get back to the original displayed order
-after sorting, but giving a -1 numerical prefix to the sorting command
-will now restore the original order.
-
----
-*** 'M-left' and 'M-right' now move between columns in 'tabulated-list-mode'.
-
----
-*** New variable 'hl-line-overlay-priority'.
-This can be used to change the priority of the hl-line overlays.
+*** New 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 'mailcap-view-file'.
-This command will open a viewer based on the file type, as determined
-by "~/.mailcap" and related files and variables.
-
----
-*** New user option 'remember-diary-regexp'.
-
----
-*** New user option 'remember-text-format-function'.
-
----
-*** New user option 'authinfo-hide-elements'.
-This can be set to nil to inhibit hiding passwords in ".authinfo" files.
-
----
-*** 'hexl-mode' scrolling commands now heed 'next-screen-context-lines'.
-Previously, 'hexl-scroll-down' and 'hexl-scroll-up' would scroll
-up/down an entire window, but they now work more like the standard
-scrolling commands.
-
----
-*** New user option 'bibtex-unify-case-function'.
-This new option allows the user to customize how case is converted
-when unifying entries.
+*** 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.
---
-*** The user option 'bibtex-maintain-sorted-entries' now permits
-user-defined sorting schemes.
+*** On X11, the WebKit inspector is now available inside xwidgets.
+To access the inspector, right click on the widget and select "Inspect
+Element".
---
-*** New user option 'reveal-auto-hide'.
-If non-nil (the default), revealed text is automatically hidden when
-point leaves the text. If nil, the text is not hidden again. Instead
-'M-x reveal-hide-revealed' can be used to hide all the revealed text.
+*** "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.
----
-*** New user option 'ffap-file-name-with-spaces'.
-If non-nil, 'find-file-at-point' and friends will try to guess more
-expansively to identify a file name with spaces. Default value is
-nil.
-
----
-*** Two new commands for centering in 'doc-view-mode'.
-The new commands 'doc-view-center-page-horizontally' (bound to 'c h')
-and 'doc-view-center-page-vertically' (bound to 'c v') center the page
-horizontally and vertically, respectively.
-
----
-*** 'tempo-define-template' can now re-assign templates to tags.
-Previously, assigning a new template to an already defined tag had no
-effect.
+** Tramp
---
-*** The width of the buffer-name column in 'list-buffers' is now dynamic.
-The width now depends on the width of the window, but will never be
-wider than the length of the longest buffer name, except that it will
-never be narrower than 19 characters.
-
-+++
-*** New diary sexp 'diary-offset'.
-It offsets another diary sexp by a number of days. This is useful
-when for example your organization has a committee meeting two days
-after every monthly meeting which takes place on the third Thursday,
-or if you would like to attend a virtual meeting scheduled in a
-different timezone causing a difference in the date.
+*** Tramp supports abbreviating remote home directories now.
+When calling 'abbreviate-file-name' on a Tramp filename, the result
+will abbreviate the user's home directory, for example by abbreviating
+"/ssh:user@host:/home/user" to "/ssh:user@host:~".
----
-*** The old non-SMIE indentation of 'sh-mode' has been removed.
+** Browse URL
---
-*** 'mspools-show' is now autoloaded.
+*** 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.
---
-*** Loading dunnet.el in batch mode doesn't start the game any more.
-Instead you need to do "emacs -f dun-batch" to start the game in
-batch mode.
+*** 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.
-* New Modes and Packages in Emacs 28.1
+* New Modes and Packages in Emacs 29.1
+++
-** New mode 'repeat-mode' to allow shorter key sequences.
-Type 'M-x repeat-mode' to enable this mode. You can then type
-'C-x u u' instead of 'C-x u C-x u' to undo many changes, 'C-x o o'
-instead of 'C-x o C-x o' to switch windows, 'C-x { { } } ^ ^ v v' to
-resize the selected window interactively, 'M-g n n p p' to navigate
-next-error matches. Any other key exits this temporarily enabled
-transient mode that supports shorter keys, and then after exiting from
-this mode, the last typed key uses the default key binding.
-
-The user option 'repeat-exit-key' defines an additional key usable to
-exit the mode like 'isearch-exit' ('RET').
-
-The user option 'repeat-exit-timeout' (default nil, which means
-forever) specifies the number of seconds of idle time after which to
-break the repetition chain automatically.
-
-When user option 'repeat-keep-prefix' is non-nil, the prefix arg of
-the previous command is kept. This can be used to e.g. reverse the
-window navigation direction with 'C-x o M-- o o' or to set a new step
-with 'C-x { C-5 { { {', which will set the window resizing step to 5
-columns.
-
-'M-x describe-repeat-maps' will display a buffer showing
-which commands are repeatable in 'repeat-mode'.
-
----
-** New themes 'modus-vivendi' and 'modus-operandi'.
-These themes are designed to conform with the highest standard for
-color-contrast accessibility (WCAG AAA). You can load either of them
-using 'M-x customize-themes' or 'load-theme' from your init file.
-Consult the Modus Themes Info manual for more information on the user
-options they provide.
-
-** Dictionary mode
-This is a mode for searching a RFC 2229 dictionary server.
-'dictionary' opens a buffer for starting operations.
-'dictionary-search' performs a lookup for a word. It also supports a
-'dictionary-tooltip-mode' which performs a lookup of the word under
-the mouse in 'dictionary-tooltip-dictionary' (which must be customized
-first).
-
----
-** Lisp Data mode
-The new command 'lisp-data-mode' enables a major mode for buffers
-composed of Lisp symbolic expressions that do not form a computer
-program. The ".dir-locals.el" file is automatically set to use this
-mode, as are other data files produced by Emacs.
-
-+++
-** New global mode 'global-goto-address-mode'.
-This will enable 'goto-address-mode' in all buffers.
-
-** transient.el
-This library implements support for powerful keyboard-driven menus.
-Such menus can be used as simple visual command dispatchers. More
-complex menus take advantage of infix arguments, which are somewhat
-similar to prefix arguments, but are more flexible and discoverable.
-
-** hierarchy.el
-This library can create, query, navigate and display hierarchical
-structures.
-
----
-** New major mode for displaying the "etc/AUTHORS" file.
-This new 'etc-authors-mode' provides font-locking for displaying the
-"etc/AUTHORS" file from the Emacs distribution, and not much else.
+** 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.
-* Incompatible Lisp Changes in Emacs 28.1
+* Incompatible Lisp Changes in Emacs 29.1
-+++
-** Emacs now prints a backtrace when signaling an error in batch mode.
-This makes debugging Emacs Lisp scripts run in batch mode easier. To
-get back the old behavior, set the new variable
-'backtrace-on-error-noninteractive' to a nil value.
+** 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.
----
-** Some floating-point numbers are now handled differently by the Lisp reader.
-In previous versions of Emacs, numbers with a trailing dot and an exponent
-were read as integers and the exponent ignored: 2.e6 was interpreted as the
-integer 2. Such numerals are now read as floats with the exponent included:
-2.e6 is now read as the floating-point value 2000000.0.
-That is, '(read-from-string "1.e3")' => '(1000.0 . 4)' now.
+** Fonts
---
-** 'equal' no longer examines some contents of window configurations.
-Instead, it considers window configurations to be equal only if they
-are 'eq'. To compare contents, use 'compare-window-configurations'
-instead. This change helps fix a bug in 'sxhash-equal', which returned
-incorrect hashes for window configurations and some other objects.
+*** 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 previously specified
+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.
-+++
-** The 'lexical-binding' local variable is always enabled.
-Previously, if 'enable-local-variables' was nil, a 'lexical-binding'
-local variable would not be heeded. This has now changed, and a file
-with a 'lexical-binding' cookie is always heeded. To revert to the
-old behavior, set 'permanently-enabled-local-variables' to nil.
-
-+++
-** '&rest' in argument lists must always be followed by a variable name.
-Omitting the variable name after '&rest' was previously tolerated in
-some cases but not consistently so; it could lead to crashes or
-outright wrong results. Since the utility was marginal at best, it is
-now an error to omit the variable.
+** Keymap descriptions 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,
+"[closure]"/"[lambda]" is output.
---
-** 'kill-all-local-variables' has changed how it handles non-symbol hooks.
-The function is documented to eliminate all buffer-local bindings
-except variables with a 'permanent-local' property, or hooks that
-have elements with a 'permanent-local-hook' property. In addition, it
-would also keep lambda expressions in hooks sometimes. The latter has
-now been changed: The function will now also remove these.
-
-+++
-** Temporary buffers no longer run certain buffer hooks.
-The macros 'with-temp-buffer' and 'with-temp-file' no longer run the
-hooks 'kill-buffer-hook', 'kill-buffer-query-functions', and
-'buffer-list-update-hook' for the temporary buffers they create. This
-avoids slowing them down when a lot of these hooks are defined.
-
-+++
-** New face 'child-frame-border' and frame parameter 'child-frame-border-width'.
-The face and width of child frames borders can now be determined
-separately from those of normal frames. To minimize backward
-incompatibility, child frames without a 'child-frame-border-width'
-parameter will fall back to using 'internal-border-width'. However,
-the new 'child-frame-border' face does constitute a breaking change
-since child frames' borders no longer use the 'internal-border' face.
+** '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.)
---
-** 'run-at-time' now tries harder to implement the t TIME parameter.
-If TIME is t, the timer runs at an integral multiple of REPEAT.
-(I.e., if given a REPEAT of 60, it'll run at 08:11:00, 08:12:00,
-08:13:00.) However, when a machine goes to sleep (or otherwise didn't
-get a time slot to run when the timer was scheduled), the timer would
-then fire every 60 seconds after the time the timer was fired. This
-has now changed, and the timer code now recomputes the integral
-multiple every time it runs, which means that if the laptop wakes at
-08:16:43, it'll fire at that time, but then at 08:17:00, 08:18:00...
+** 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.
---
-** 'parse-partial-sexp' now signals an error if TO is smaller than FROM.
-Previously, this would lead to the function interpreting FROM as TO and
-vice versa, which would be confusing when passing in OLDSTATE, which
-refers to the old state at FROM.
+** '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:
-+++
-** 'global-mode-string' constructs should end with a space.
-This was previously not formalized, which led to combinations of modes
-displaying data "smushed together" on the mode line.
+ (defzot 1
+ 2 3)
-+++
-** 'overlays-in' now handles zero-length overlays slightly differently.
-Previously, zero-length overlays at the end of the buffer were included
-in the result (if the region queried for stopped at that position).
-The same was not the case if the buffer had been narrowed to exclude
-the real end of the buffer. This has now been changed, and
-zero-length overlays at 'point-max' are always included in the results.
+This heuristic has now been removed, and all functions/macros that
+want to be indented this way have to be marked with
----
-** 'replace-match' now runs modification hooks slightly later.
-The function is documented to leave point after the replacement text,
-but this was not always the case if a modification hook inserted text
-in front of the replaced text -- 'replace-match' would instead leave
-point where the end of the inserted text would have been before the
-hook ran. 'replace-match' now always leaves point after the
-replacement text.
-
-+++
-** 'completing-read-default' sets completion variables buffer-locally.
-'minibuffer-completion-table' and related variables are now set buffer-locally
-in the minibuffer instead of being set via a global let-binding.
-
----
-** XML serialization functions now reject invalid characters.
-Previously, 'xml-print' would produce invalid XML when given a string
-with characters that are not valid in XML (see
-https://www.w3.org/TR/xml/#charsets). Now it rejects such strings.
+ (declare (indent defun))
----
-** JSON
+or the like. If the function/macro definition itself can't be
+changed, the indentation can also be adjusted by saying something
+like:
----
-*** JSON number parsing is now stricter.
-Numbers with a leading plus sign, leading zeros, or a missing integer
-component are now rejected by 'json-read' and friends. This makes
-them more compliant with the JSON specification and consistent with
-the native JSON parsing functions.
+ (put 'defzot 'lisp-indent-function 'defun)
---
-*** JSON functions support the semantics of RFC 8259.
-The JSON functions 'json-serialize', 'json-insert',
-'json-parse-string', and 'json-parse-buffer' now implement some of the
-semantics of RFC 8259 instead of the earlier RFC 4627. In particular,
-these functions now accept top-level JSON values that are neither
-arrays nor objects.
+** The 'inhibit-changing-match-data' variable is now obsolete.
+Instead, functions like 'string-match' and 'looking-at' now take an
+optional 'inhibit-modify' argument.
---
-*** Some JSON encoding functions are now obsolete.
-The functions 'json-encode-number', 'json-encode-hash-table',
-'json-encode-key', and 'json-encode-list' are now obsolete.
-
-The first two are kept as aliases of 'json-encode', which should be
-used instead. Uses of 'json-encode-list' should be changed to call
-one of 'json-encode', 'json-encode-alist', 'json-encode-plist', or
-'json-encode-array' instead.
-
-+++
-*** Native JSON functions now signal an error if libjansson is unavailable.
-This affects 'json-serialize', 'json-insert', 'json-parse-string',
-and 'json-parse-buffer'. This can happen if Emacs was compiled with
-libjansson, but the DLL cannot be found and/or loaded by Emacs at run
-time. Previously, Emacs would display a message and return nil in
-these cases.
-
-+++
-** The use of positional arguments in 'define-minor-mode' is obsolete.
-These were actually rendered obsolete in Emacs 21 but were never
-marked as such.
+** 'gnus-define-keys' is now obsolete.
+Use 'define-keymap' instead.
---
-** 'pcomplete-ignore-case' is now an obsolete alias of 'completion-ignore-case'.
-
-+++
-** 'completions-annotations' face is not used when the caller puts own face.
-This affects the suffix specified by completion 'annotation-function'.
-
-+++
-** An active minibuffer now has major mode 'minibuffer-mode'.
-This is instead of the erroneous 'minibuffer-inactive-mode' it
-formerly had.
+** 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.
---
-** 'make-text-button' no longer modifies text properties of its first argument.
-When its first argument is a string, 'make-text-button' no longer
-modifies the string's text properties; instead, it uses and returns
-a copy of the string. This helps avoid trouble when strings are
-shared or constants.
-
-+++
-** Some properties from completion tables are now preserved.
-If 'minibuffer-allow-text-properties' is non-nil, doing completion
-over a table of strings with properties will no longer remove all the
-properties before returning. This affects things like 'completing-read'.
+** The function 'image-dired-get-exif-data' is now obsolete.
+Use 'exif-parse-file' and 'exif-field' instead.
---
-** 'dns-query' now consistently uses Lisp integers to represent integers.
-Formerly it made an exception for integer components of SOA records,
-because SOA serial numbers can exceed fixnum ranges on 32-bit platforms.
-Emacs now supports bignums so this old glitch is no longer needed.
+** 'insert-directory' alternatives should not change the free disk space line.
+This change is now applied in 'dired-insert-directory'.
-+++
-** The '&define' keyword in an Edebug specification now disables backtracking.
-The implementation was buggy, and multiple '&define' forms in an '&or'
-form should be exceedingly rare. See the Info node "(elisp) Backtracking" in
-the Emacs Lisp reference manual for background.
-
-+++
-** The error 'ftp-error' belongs also to category 'remote-file-error'.
-
-+++
-** The WHEN argument of 'make-obsolete' and related functions is mandatory.
-The use of those functions without a WHEN argument was marked obsolete
-back in Emacs 23.1. The affected functions are: 'make-obsolete',
-'define-obsolete-function-alias', 'make-obsolete-variable',
-'define-obsolete-variable-alias'.
-
-+++
-** 'inhibit-nul-byte-detection' is renamed to 'inhibit-null-byte-detection'.
-
----
-** Some functions are no longer considered safe by 'unsafep':
-'replace-regexp-in-string', 'catch', 'throw', 'error', 'signal'
-and 'play-sound-file'.
-
----
-** 'sql-*-statement-starters' are no longer user options.
-These variables describe facts about the SQL standard and
-product-specific additions. There should be no need for users to
-customize them.
-
----
-** Some locale-related variables have been removed.
-The Lisp variables 'previous-system-messages-locale' and
-'previous-system-time-locale' have been removed, as they were created
-by mistake and were not useful to Lisp code.
-
----
-** Function 'lm-maintainer' is replaced with 'lm-maintainers'.
-The former is now declared obsolete.
-
-+++
-** facemenu.el is no longer preloaded.
-To use functions/variables from the package, you now have to say
-'(require 'facemenu)' or similar.
-
----
-** 'facemenu-color-alist' is now obsolete, and is not used.
-
----
-** The variable 'keyboard-type' is obsolete and not dynamically scoped any more.
-
-+++
-** The 'values' variable is now obsolete.
-Using it just contributes to the growth of the Emacs memory
-footprint.
-
----
-** The 'load-dangerous-libraries' variable is now obsolete.
-It was used to allow loading Lisp libraries compiled by XEmacs, a
-modified version of Emacs which is no longer actively maintained.
-This is no longer supported, and setting this variable has no effect.
-
-+++
-** The macro 'with-displayed-buffer-window' is now obsolete.
-Use macro 'with-current-buffer-window' with action alist entry 'body-function'.
-
----
-** The rfc2368.el library is now obsolete.
-Use rfc6068.el instead. The main difference is that
-'rfc2368-parse-mailto-url' and 'rfc2368-unhexify-string' assumed that
-the strings were all-ASCII, while 'rfc6068-parse-mailto-url' and
-'rfc6068-unhexify-string' parse UTF-8 strings.
-
----
-** The inversion.el library is now obsolete.
-
----
-** The metamail.el library is now obsolete.
-
-** Edebug changes
-
----
-*** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'.
-
-+++
-*** The spec operator ':name NAME' is obsolete, use '&name' instead.
-
-+++
-*** The spec element 'function-form' is obsolete, use 'form' instead.
-
-+++
-*** New function 'def-edebug-elem-spec' to define Edebug spec elements.
-These used to be defined with 'def-edebug-spec' thus conflating the
-two name spaces, which lead to name collisions.
-The use of 'def-edebug-spec' to define Edebug spec elements is
-declared obsolete.
-
----
-** The sb-image.el library is now obsolete.
-This was a compatibility kludge which is no longer needed.
-
----
-** Some libraries obsolete since Emacs 23 have been removed:
-ledit.el, lmenu.el, lucid.el and old-whitespace.el.
-
----
** Some functions and variables obsolete since Emacs 23 have been removed:
-'GOLD-map', 'advertised-xscheme-send-previous-expression',
-'allout-init', 'bookmark-jump-noselect',
-'bookmark-read-annotation-text-func', 'buffer-menu-mode-hook',
-'c-forward-into-nomenclature', 'char-coding-system-table',
-'char-valid-p', 'charset-bytes', 'charset-id', 'charset-list',
-'choose-completion-delete-max-match', 'complete-in-turn',
-'completion-base-size', 'completion-common-substring',
-'crm-minibuffer-complete', 'crm-minibuffer-complete-and-exit',
-'crm-minibuffer-completion-help', 'custom-mode', 'custom-mode-hook',
-'define-key-rebound-commands', 'define-mode-overload-implementation',
-'detect-coding-with-priority', 'dirtrack-debug',
-'dirtrack-debug-toggle', 'dynamic-completion-table',
-'easy-menu-precalculate-equivalent-keybindings',
-'epa-display-verify-result', 'epg-passphrase-callback-function',
-'erc-announced-server-name', 'erc-default-coding-system',
-'erc-process', 'erc-send-command', 'eshell-report-bug',
-'eval-next-after-load', 'exchange-dot-and-mark', 'ffap-bug',
-'ffap-submit-bug', 'ffap-version', 'file-cache-mouse-choose-completion',
-'forward-point', 'generic-char-p', 'global-highlight-changes',
-'hi-lock-face-history', 'hi-lock-regexp-history',
-'highlight-changes-active-string', 'highlight-changes-initial-state',
-'highlight-changes-passive-string',
-'icalendar--datetime-to-noneuropean-date', 'image-mode-maybe',
-'imenu-example--name-and-position', 'ispell-aspell-supports-utf8',
-'lisp-mode-auto-fill', 'locate-file-completion', 'make-coding-system',
-'menu-bar-files-menu', 'minibuffer-local-must-match-filename-map',
-'mouse-choose-completion', 'mouse-major-mode-menu',
-'mouse-popup-menubar', 'mouse-popup-menubar-stuff',
-'newsticker-groups-filename', 'nnir-swish-e-index-file',
-'nnmail-fix-eudora-headers', 'non-iso-charset-alist',
-'nonascii-insert-offset', 'nonascii-translation-table',
-'password-read-and-add', 'pre-abbrev-expand-hook', 'princ-list',
-'print-help-return-message', 'process-filter-multibyte-p',
-'read-file-name-predicate', 'remember-buffer', 'rmail-highlight-face',
-'rmail-message-filter', 'semantic-after-idle-scheduler-reparse-hooks',
-'semantic-after-toplevel-bovinate-hook',
-'semantic-before-idle-scheduler-reparse-hooks',
-'semantic-before-toplevel-bovination-hook',
-'semantic-bovinate-from-nonterminal-full',
-'semantic-bovinate-region-until-error', 'semantic-bovinate-toplevel',
-'semantic-bovination-working-type',
-'semantic-decorate-pending-decoration-hooks',
-'semantic-edits-incremental-reparse-failed-hooks',
-'semantic-eldoc-current-symbol-info', 'semantic-expand-nonterminal',
-'semantic-file-token-stream', 'semantic-find-dependency',
-'semantic-find-nonterminal', 'semantic-flex', 'semantic-flex-buffer',
-'semantic-flex-keyword-get', 'semantic-flex-keyword-p',
-'semantic-flex-keyword-put', 'semantic-flex-keywords',
-'semantic-flex-list', 'semantic-flex-make-keyword-table',
-'semantic-flex-map-keywords', 'semantic-flex-token-end',
-'semantic-flex-token-start', 'semantic-flex-token-text',
-'semantic-imenu-bucketize-type-parts',
-'semantic-imenu-expand-type-parts', 'semantic-imenu-expandable-token',
-'semantic-init-db-hooks', 'semantic-init-hooks',
-'semantic-init-mode-hooks', 'semantic-java-prototype-nonterminal',
-'semantic-nonterminal-abstract', 'semantic-nonterminal-full-name',
-'semantic-nonterminal-leaf', 'semantic-nonterminal-protection',
-'semantic-something-to-stream', 'semantic-tag-make-assoc-list',
-'semantic-token-type-parent', 'semantic-toplevel-bovine-cache',
-'semantic-toplevel-bovine-table', 'semanticdb-mode-hooks',
-'set-coding-priority', 'set-process-filter-multibyte',
-'shadows-compare-text-p', 'shell-dirtrack-toggle',
-'speedbar-navigating-speed', 'speedbar-update-speed', 't-mouse-mode',
-'term-dynamic-simple-complete', 'tooltip-hook', 'tpu-have-ispell',
-'url-generate-unique-filename', 'url-temporary-directory',
-'vc-arch-command', 'vc-default-working-revision' (variable),
-'vc-mtn-command', 'vc-revert-buffer', 'vc-workfile-version',
-'vcursor-toggle-vcursor-map', 'w32-focus-frame', 'w32-select-font',
-'wisent-lex-make-token-table'.
-
----
-** Some functions and variables obsolete since Emacs 22 have been removed:
-'erc-current-network', 'gnus-article-hide-pgp-hook',
-'gnus-inews-mark-gcc-as-read', 'gnus-treat-display-xface',
-'gnus-treat-strip-pgp', 'nnmail-spool-file'.
-
----
-** The obsolete function 'thread-alive-p' has been removed.
-
----
-** The variable 'force-new-style-backquotes' has been removed.
-This removes the final remaining trace of old-style backquotes.
-
----
-** Some obsolete variable and function aliases in dbus.el have been removed.
-In Emacs 24.3, the variable 'dbus-event-error-hooks' was renamed to
-'dbus-event-error-functions' and the function
-'dbus-call-method-non-blocking' was renamed to 'dbus-call-method'.
-The old names, which were kept as obsolete aliases of the new names,
-have now been removed.
-
----
-** 'find-function-source-path' renamed and re-documented.
-The 'find-function' command (and various related commands) were
-documented to respect 'find-function-source-path', and to search for
-objects in files specified by that variable. It's unclear when this
-actually changed, but at some point (perhaps decades ago) these
-commands started using 'load-history' to determine where symbols had
-been defined (which is much faster). The doc strings of all the
-affected function have been updated. 'find-function-source-path' was
-still being used by 'find-library' and related commands, so the
-user option has been renamed to 'find-library-source-path', and
-'find-function-source-path' is now an obsolete variable alias.
-
----
-** The macro 'vc-call' no longer evaluates its second argument twice.
-
-** Xref migrated from EIEIO to cl-defstruct for its core objects.
-This means that 'oref' and 'with-slots' no longer works on them, and
-'make-instance' can no longer be used to create those instances (which
-wasn't recommended anyway). Packages should restrict themselves to
-using functions like 'xref-make', 'xref-make-match',
-'xref-make-*-location', as well as accessor functions
-'xref-item-summary' and 'xref-item-location'.
-
-Among the benefits are better performance (noticeable when there are a
-lot of matches) and improved flexibility: 'xref-match-item' instances
-do not require that 'location' inherits from 'xref-location' anymore
-(that class was removed), so packages can create new location types to
-use with "match items" without adding EIEIO as a dependency.
+'find-emacs-lisp-shadows', 'newsticker-cache-filename',
+'unify-8859-on-decoding-mode', 'unify-8859-on-encoding-mode',
+'vc-arch-command'.
-* Lisp Changes in Emacs 28.1
+* Lisp Changes in Emacs 29.1
+++
-** The 'interactive' syntax has been extended to allow listing applicable modes.
-Forms like '(interactive "p" dired-mode)' can be used to annotate the
-commands as being applicable for modes derived from 'dired-mode',
-or if the mode is a minor mode, when the current buffer has that
-minor mode activated. Note that using this form will create byte code
-that is not compatible with byte code in previous Emacs versions.
+** New facility for handling session state: 'multisession-value'.
+This can be used as a convenient way to store (simple) application
+state, and 'M-x list-multisession-values' allows users to list
+(and edit) this data.
+++
-** New forms to declare how completion should happen has been added.
-'(declare (completion PREDICATE))' can be used as a general predicate
-to say whether the command should be present when completing with
-'M-x TAB'. '(declare (modes MODE...))' can be used as a short-hand
-way of saying that the command should be present when completing from
-buffers in major modes derived from MODE..., or, if it's a minor mode,
-when that minor mode is enabled in the current buffer.
+** New function 'get-display-property'.
+This is like 'get-text-property', but works on the 'display' text
+property.
+++
-** 'define-minor-mode' now takes an ':interactive' argument.
-This can be used for specifying which modes this minor mode is meant
-for, or to make the new minor mode non-interactive. The default value
-is t.
+** New function 'add-text-display-property'.
+This is like 'put-text-property', but works on the 'display' text
+property.
+++
-** 'define-derived-mode' now takes an ':interactive' argument.
-This can be used to control whether the defined mode is a command
-or not, and is useful when defining commands that aren't meant to be
-used by users directly.
+** New 'min-width' 'display' property.
+This allows setting a minimum display width for a region of text.
+++
-** 'define-globalized-minor-mode' now takes a ':predicate' parameter.
-This can be used to control which major modes the minor mode should be
-used in.
+** 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.
-+++
-** 'condition-case' now allows for a success handler.
-It is written as '(:success BODY...)' where BODY is executed
-whenever the protected form terminates without error, with the
-specified variable bound to the value of the protected form.
+** Keymaps and key definitions
+++
-** New function 'benchmark-call' to measure the execution time of a function.
-Additionally, the number of repetitions can be expressed as a minimal duration
-in seconds.
+*** New functions for defining and manipulating keystrokes have been added.
+These all take just the syntax defined by 'key-valid-p'. None of the
+older functions have been depreciated or altered, but are deemphasised
+in the documentation.
+++
-** The value thrown to the 'exit' label can now be a function.
-This is in addition to values t or nil. If the value is a function,
-the command loop will call it with zero arguments before returning.
+*** Use 'keymap-set' instead of 'define-key'.
+++
-** The behavior of 'format-spec' is now closer to that of 'format'.
-In order for the two functions to behave more consistently,
-'format-spec' now pads and truncates based on string width rather than
-length, and also supports format specifications that include a
-truncating precision field, such as "%.2a".
-
----
-** 'defvar' detects the error of defining a variable currently lexically bound.
-Such mixes are always signs that the outer lexical binding was an
-error and should have used dynamic binding instead.
-
----
-** New variable 'inhibit-mouse-event-check'.
-If bound to non-nil, a command with '(interactive "e")' doesn't signal
-an error when invoked by input event that is not a mouse click (e.g.,
-a key sequence).
-
----
-** New variable 'redisplay-skip-initial-frame' to enable batch redisplay tests.
-Setting it to nil forces the redisplay to do its job even in the
-initial frame used in batch mode.
+*** Use 'keymap-global-set' instead of 'global-set-key'.
+++
-** Doc strings can now link to customization groups.
-Text like "customization group `whitespace'" will be made into a
-button. When clicked, it will open a Custom buffer displaying that
-customization group.
+*** Use 'keymap-local-set' instead of 'local-set-key'.
+++
-** Doc strings can now link to man pages.
-Text like "man page `chmod(1)'" will be made into a button. When
-clicked, it will open a Man mode buffer displaying that man page.
+*** Use 'keymap-global-unset' instead of 'global-unset-key'.
+++
-** Buffers can now be created with certain hooks disabled.
-The functions 'get-buffer-create' and 'generate-new-buffer' accept a
-new optional argument INHIBIT-BUFFER-HOOKS. If non-nil, the new
-buffer does not run the hooks 'kill-buffer-hook',
-'kill-buffer-query-functions', and 'buffer-list-update-hook'. This
-avoids slowing down internal or temporary buffers that are never
-presented to users or passed on to other applications.
-
-+++
-** New command 'make-directory-autoloads'.
-This does the same as the old command 'update-directory-autoloads',
-but has different semantics: Instead of passing in the output file via
-the dynamically bound 'generated-autoload-file' variable, the output
-file is now a explicit parameter.
-
----
-** Dragging a file into Emacs pushes the file name onto 'file-name-history'.
-
----
-** The 'easymenu' library is now preloaded.
-
----
-** The 'iso-transl' library is now preloaded.
-This means that keystrokes like 'Alt-[' are defined by default,
-instead of only becoming available after doing (for instance)
-'C-x 8 <letter>'.
-
----
-** ':safe' settings in 'defcustom' are now propagated to the loaddefs files.
+*** Use 'keymap-local-unset' instead of 'local-unset-key'.
+++
-** New ':type' for 'defcustom' for nonnegative integers.
-The new 'natnum' type can be used for options that should be
-nonnegative integers.
+*** Use 'keymap-substitute' instead of 'substitute-key-definition'.
+++
-** ERT can now output more verbose test failure reports.
-If the 'EMACS_TEST_VERBOSE' environment variable is set, failure
-summaries will include the failing condition.
-
-** Byte compiler changes
+*** Use 'keymap-set-after' instead of 'define-key-after'.
+++
-*** New byte-compiler check for missing dynamic variable declarations.
-It is meant as an (experimental) aid for converting Emacs Lisp code
-to lexical binding, where dynamic (special) variables bound in one
-file can affect code in another. For details, see the manual section
-"(elisp) Converting to Lexical Binding".
+*** Use 'keymap-lookup' instead of 'lookup-keymap' and 'key-binding'.
+++
-*** 'byte-recompile-directory' can now compile symlinked ".el" files.
-This is achieved by giving a non-nil FOLLOW-SYMLINKS parameter.
-
----
-*** The byte-compiler now warns about too wide documentation strings.
-By default, it will warn if a documentation string is wider than the
-largest of 'byte-compile-docstring-max-column' or 'fill-column'
-characters.
+*** Use 'keymap-local-lookup' instead of 'local-key-binding'.
+++
-*** 'byte-compile-file' optional argument LOAD is now obsolete.
-To load the file after byte-compiling, add a call to 'load' from Lisp
-or use 'M-x emacs-lisp-byte-compile-and-load' interactively.
-
-** Macroexp
-
----
-*** New function 'macroexp-file-name' to know the name of the current file.
-
----
-*** New function 'macroexp-compiling-p' to know if we're compiling.
-
----
-*** New function 'macroexp-warn-and-return' to help emit warnings.
-This used to be named 'macroexp--warn-and-return' and has proved useful
-and well-behaved enough to lose the "internal" marker.
-
-** map.el
-
----
-*** Alist keys are now consistently compared with 'equal' by default.
-Until now, 'map-elt' and 'map-delete' compared alist keys with 'eq' by
-default. They now use 'equal' instead, for consistency with
-'map-put!' and 'map-contains-key'.
-
-*** Pcase 'map' pattern added keyword symbols abbreviation.
-A pattern like '(map :sym)' binds the map's value for ':sym' to 'sym',
-equivalent to '(map (:sym sym))'.
-
----
-*** The function 'map-copy' now uses 'copy-alist' on alists.
-This is a slightly deeper copy than the previous 'copy-sequence'.
-
----
-*** The function 'map-contains-key' now supports plists.
-
----
-*** More consistent duplicate key handling in 'map-merge-with'.
-Until now, 'map-merge-with' promised to call its function argument
-whenever multiple maps contained 'eql' keys. However, this did not
-always coincide with the keys that were actually merged, which could
-be 'equal' instead. The function argument is now called whenever keys
-are merged, for greater consistency with 'map-merge' and 'map-elt'.
-
-** pcase
+*** Use 'keymap-global-lookup' instead of 'global-key-binding'.
+++
-*** The 'or' pattern now binds the union of the vars of its sub-patterns.
-If a variable is not bound by the subpattern that matched, it gets bound
-to nil. This was already sometimes the case, but it is now guaranteed.
+*** '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).
+++
-*** The 'pred' pattern can now take the form '(pred (not FUN))'.
-This is like '(pred (lambda (x) (not (FUN x))))' but results
-in better code.
+*** New function '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 'pcase-compile-patterns' to write other macros.
+*** New function 'key-parse'.
+This is like 'kbd', but only returns vectors instead of a mix of
+vectors and strings.
+++
-*** Added 'cl-type' pattern.
-The new 'cl-type' pattern compares types using 'cl-typep', which allows
-comparing simple types like '(cl-type integer)', as well as forms like
-'(cl-type (integer 0 10))'.
-
-+++
-*** New macro 'pcase-setq'.
-This macro is the 'setq' equivalent of 'pcase-let', which allows for
-destructuring patterns in a 'setq' form.
-
-** Edebug
-
-*** Edebug specification lists can use some new keywords:
+** 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'.
+++
-**** '&interpose SPEC FUN ARGS..' lets FUN control parsing after SPEC.
-More specifically, FUN is called with 'HEAD PF ARGS..' where
-PF is a parsing function that expects a single argument (the specs to
-use) and HEAD is the code that matched SPEC.
+** New function 'file-name-split'.
+This returns a list of all the components of a file name.
+++
-**** '&error MSG' unconditionally aborts the current edebug instrumentation.
+** New macro 'with-undo-amalgamate'.
+It records a particular sequence of operations as a single undo step.
+++
-**** '&name SPEC FUN' extracts the current name from the code matching SPEC.
-
-** Dynamic modules changes
-
-+++
-*** Type aliases for module functions and finalizers.
-The module header 'emacs-module.h' now contains type aliases
-'emacs_function' and 'emacs_finalizer' for module functions and
-finalizers, respectively.
-
-+++
-*** Module functions can now be made interactive.
-Use 'make_interactive' to give a module function an interactive
-specification.
-
-+++
-*** Module functions can now install an optional finalizer.
-The finalizer is called when the function object is garbage-collected.
-Use 'set_function_finalizer' to set the finalizer and
-'get_function_finalizer' to retrieve it.
-
-+++
-*** Modules can now open a channel to an existing pipe process.
-Modules can use the new module function 'open_channel' to do that.
-On capable systems, modules can use this functionality to
-asynchronously send data back to Emacs.
-
-+++
-*** A new module API 'make_unibyte_string'.
-It can be used to create Lisp strings with arbitrary byte sequences
-(a.k.a. "raw bytes").
-
-+++
-** Shorthands for Lisp symbols.
-Shorthands are a general purpose namespacing system to make Emacs
-Lisp's symbol-naming etiquette easier to use. A shorthand is any
-symbolic form found in Lisp source that "abbreviates" a symbol's print
-name. Among other applications, this feature can be used to avoid
-name clashes and namespace pollution by renaming an entire file's
-worth of symbols with proper and longer prefixes, without actually
-touching the Lisp source. For details, see the manual section
-"(elisp) Shorthands".
-
-+++
-** New function 'string-search'.
-This function takes two string parameters and returns the position of
-the first instance of the former string in the latter.
-
-+++
-** New function 'string-replace'.
-This function works along the line of 'replace-regexp-in-string', but
-it matches on fixed strings instead of regexps, and does not change
-the global match state.
-
-+++
-** New function 'ensure-list'.
-This function makes a list of its object if it's not a list already.
-If it's already a list, the list is returned as is.
-
-+++
-** New function 'split-string-shell-command'.
-This splits a shell command string into separate components,
-respecting quoting with single ('like this') and double ("like this")
-quotes, as well as backslash quoting (like\ this).
-
-+++
-** New function 'string-clean-whitespace'.
-This removes whitespace from a string.
-
-+++
-** New function 'string-fill'.
-Word-wrap a string so that no lines are longer that a specific length.
-
-+++
-** New function 'string-limit'.
-Return (up to) a specific substring length.
-
-+++
-** New function 'string-lines'.
-Return a list of strings representing the individual lines in a
-string.
-
-+++
-** New function 'string-pad'.
-Pad a string to a specific length.
-
-+++
-** New function 'string-chop-newline'.
-Remove a trailing newline from a string.
-
-+++
-** New function 'replace-regexp-in-region'.
-
-+++
-** New function 'replace-string-in-region'.
-
-+++
-** New function 'file-name-with-extension'.
-This function allows a canonical way to set/replace the extension of a
-file name.
-
-+++
-** New function 'file-modes-number-to-symbolic' to convert a numeric
-file mode specification into symbolic form.
-
-+++
-** New function 'file-name-concat'.
-This appends file name components to a directory name and returns the
-result.
-
-+++
-** New function 'file-backup-file-names'.
-This function returns the list of file names of all the backup files
-for the specified file.
-
-+++
-** New function 'directory-empty-p'.
-This predicate tests whether a given file name is an accessible
-directory and whether it contains no other directories or files.
-
-+++
-** New function 'buffer-local-boundp'.
-This predicate says whether a symbol is bound in a specific buffer.
-
-+++
-** New function 'always'.
-This is identical to 'ignore', but returns t instead.
+** New 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 function 'sxhash-equal-including-properties'.
-This is identical to 'sxhash-equal' but also accounts for string
-properties.
-
----
-** New function 'buffer-line-statistics'.
-This function returns some statistics about the line lengths in a buffer.
-
----
-** New function 'color-values-from-color-spec'.
-This can be used to parse RGB color specs in several formats and
-convert them to a list '(R G B)' of primary color values.
-
----
-** New function 'custom-add-choice'.
-This function can be used by modes to add elements to the
-'choice' customization type of a variable.
-
----
-** New function 'decoded-time-period'.
-It interprets a decoded time structure as a period and returns the
-equivalent period in seconds.
+** New 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 function 'dom-print'.
+** 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.
+++
-** New function 'dom-remove-attribute'.
+** 'insert-image' now takes an INHIBIT-ISEARCH optional parameter.
+It marks the image with the 'inhibit-isearch' text property, which
+inhibits 'isearch' matching the STRING parameter.
---
-** New function 'dns-query-asynchronous'.
-It takes the same parameters as 'dns-query', but adds a callback
-parameter.
-
-** New function 'garbage-collect-maybe' to trigger GC early.
+** New user option 'pp-use-max-width'.
+If non-nil, 'pp' will attempt to limit the line length when formatting
+long lists and vectors.
---
-** New function 'get-locale-names'.
-This utility function returns a list of names of locales available on
-the current system.
+** 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.
+++
-** New function 'insert-into-buffer'.
-This inserts the contents of the current buffer into another buffer.
+** 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.
+++
-** New function 'json-available-p'.
-This predicate returns non-nil if Emacs is built with libjansson
-support, and it is available on the current system.
+** 'abbreviate-file-name' now respects magic file name handlers.
---
-** New function 'mail-header-parse-addresses-lax'.
-This takes a comma-separated string and returns a list of mail/name
-pairs.
-
----
-** New function 'mail-header-parse-address-lax'.
-Parse a string as a mail address-like string.
-
----
-** New function 'make-separator-line'.
-Make a string appropriate for usage as a visual separator line.
-
-+++
-** New function 'num-processors'.
-Return the number of processors on the system.
-
-+++
-** New function 'object-intervals'.
-This function returns a copy of the list of intervals (i.e., text
-properties) in the object in question (which must either be a string
-or a buffer).
-
-+++
-** New function 'process-lines-ignore-status'.
-This is like 'process-lines', but does not signal an error if the
-return status is non-zero. 'process-lines-handling-status' has also
-been added, and takes a callback to handle the return status.
-
-+++
-** New function 'require-theme'.
-This function is like 'require', but searches 'custom-theme-load-path'
-instead of 'load-path'. It can be used by Custom themes to load
-supporting Lisp files when 'require' is unsuitable.
-
-+++
-** New function 'seq-union'.
-This function takes two sequences and returns a list of all elements
-that appear in either of them, with no two elements that compare equal
-appearing in the result.
-
-+++
-** New function 'syntax-class-to-char'.
-This does almost the opposite of 'string-to-syntax' -- it returns the
-syntax descriptor (a character) given a raw syntax descriptor (an
-integer).
-
-+++
-** New functions 'null-device' and 'path-separator'.
-These functions return the connection local value of the respective
-variables. This can be used for remote hosts.
+** New function 'font-has-char-p'.
+This can be used to check whether a specific font has a glyph for a
+character.
+++
-** New predicate functions 'length<', 'length>' and 'length='.
-Using these functions may be more efficient than using 'length' (if
-the length of a (long) list is being computed just to compare this
-length to a number).
+** '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.
-+++
-** New macro 'dlet' to dynamically bind variables.
+** XDG support
-+++
-** New macro 'with-existing-directory'.
-This macro binds 'default-directory' to some other existing directory
-if 'default-directory' doesn't exist, and then executes the body forms.
-
-+++
-** New variable 'current-minibuffer-command'.
-This is like 'this-command', but it is bound recursively when entering
-the minibuffer.
+*** New function 'xdg-state-home' returns 'XDG_STATE_HOME' environment variable.
+This new location, introduced in the XDG Base Directory Specification
+version 0.8 (8th May 2021), "contains state data that should persist
+between (application) restarts, but that is not important or portable
+enough to the user that it should be stored in $XDG_DATA_HOME".
+++
-** New variable 'inhibit-interaction' to make user prompts signal an error.
-If this is bound to something non-nil, functions like
-'read-from-minibuffer', 'read-char' (and related) will signal an
-'inhibited-interaction' error.
+** New 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 variable 'indent-line-ignored-functions'.
-This allows modes to cycle through a set of indentation functions
-appropriate for those modes.
-
-+++
-** New variable 'print-integers-as-characters' modifies integer printing.
-If this variable is non-nil, character syntax is used for printing
-numbers when this makes sense, such as '?A' for 65.
-
-+++
-** New variable 'tty-menu-calls-mouse-position-function'.
-This controls whether 'mouse-position-function' is called by functions
-that retrieve the mouse position when that happens during TTY menu
-handling. Lisp programs that set 'mouse-position-function' should
-also set this variable non-nil if they are compatible with the tty
-menu handling.
+** New 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.
-+++
-** New variables that hold default buffer names for shell output.
-The new constants 'shell-command-buffer-name' and
-'shell-command-buffer-name-async' store the default buffer names
-for the output of, respectively, synchronous and async shell
-commands.
+** Locale
---
-** New variables 'read-char-choice-use-read-key' and 'y-or-n-p-use-read-key'.
-When non-nil, then functions 'read-char-choice' and 'y-or-n-p'
-(respectively) use the function 'read-key' to read a character instead
-of using the minibuffer.
-
-+++
-** New variable 'global-minor-modes'.
-This variable holds a list of currently enabled global minor modes (as
-a list of symbols).
-
-+++
-** New buffer-local variable 'local-minor-modes'.
-This permanently buffer-local variable holds a list of currently
-enabled non-global minor modes in the current buffer (as a list of
-symbols).
-
-+++
-** New completion function 'affixation-function' to add prefix/suffix.
-It accepts a list of completions and should return a list where
-each element is a list with three elements: a completion,
-a prefix string, and a suffix string.
-
-+++
-** New completion function 'group-function' for grouping candidates.
-It takes two arguments: a completion candidate and a 'transform' flag.
-
-+++
-** New error symbol 'minibuffer-quit'.
-Signaling it has almost the same effect as 'quit' except that it
-doesn't cause keyboard macro termination.
-
-+++
-** New error 'remote-file-error', a subcategory of 'file-error'.
-It is signaled if a remote file operation fails due to internal
-reasons, and could block Emacs. It does not replace 'file-error'
-signals for the usual cases. Timers, process filters and process
-functions, which run remote file operations, shall protect themselves
-against this error.
-
-If such an error occurs, please report this as bug via 'M-x report-emacs-bug'.
-Until it is solved you could ignore such errors by performing
-
- (setq debug-ignored-errors (cons 'remote-file-error debug-ignored-errors))
-
-+++
-** New macro 'named-let' added to subr-x.el.
-It provides Scheme's "named let" looping construct.
+*** New variable 'current-locale-environment'.
+This holds the value of the previous call to 'set-locale-environment'.
---
-** Emacs now attempts to test for high-rate subprocess output more fairly.
-When several subprocesses produce output simultaneously at high rate,
-Emacs will now by default attempt to service them all in a round-robin
-fashion. Set the new variable 'process-prioritize-lower-fds' to a
-non-nil value to get back the old behavior, whereby after reading
-from a subprocess, Emacs would check for output of other subprocesses
-in a way that is likely to read from the same process again.
+*** New macro 'with-locale-environment'.
+This macro can be used to change the locale temporarily while
+executing code.
-+++
-** 'set-process-buffer' now updates the process mark.
-The mark will be set to point to the end of the new buffer.
+** Tabulated List Mode
+++
-** 'unlock-buffer' displays warnings instead of signaling.
-Instead of signaling 'file-error' conditions for file system level
-errors, the function now calls 'display-warning' and continues as if
-the error did not occur.
-
-+++
-** 'read-char-from-minibuffer' and 'y-or-n-p' support 'help-form'.
-If you bind 'help-form' to a non-nil value while calling these functions,
-then pressing 'C-h' ('help-char') causes the function to evaluate 'help-form'
-and display the result.
-
-+++
-** 'read-number' now has its own history variable.
-Additionally, the function now accepts a HIST argument which can be
-used to specify a custom history variable.
-
-+++
-** 'set-window-configuration' now takes two optional parameters,
-'dont-set-frame' and 'dont-set-miniwindow'. The first of these, when
-non-nil, instructs the function not to select the frame recorded in
-the configuration. The second prevents the current minibuffer being
-replaced by the one stored in the configuration.
-
----
-** 'count-windows' now takes an optional parameter ALL-FRAMES.
-The semantics are as with 'walk-windows'.
+*** 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.
+++
-** 'truncate-string-ellipsis' now uses '…' by default.
-Modes that use 'truncate-string-to-width' with non-nil, non-string
-argument ELLIPSIS, will now indicate truncation using '…' when
-the selected frame can display it, and using "..." otherwise.
+** :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.
+++
-** 'string-width' now accepts two optional arguments FROM and TO.
-This allows calculating the width of a substring without consing a
-new string.
+** 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.
+++
-** 'directory-files' now takes an additional COUNT parameter.
-The parameter makes 'directory-files' return COUNT first file names
-from a directory. If MATCH is also given, the function will return
-first COUNT file names that match the expression. The same COUNT
-parameter has been added to 'directory-files-and-attributes'.
+** 'kill-all-local-variables' can now kill all local variables.
+If given the new optional KILL-PERMANENT argument, also kill permanent
+local variables.
+++
-** 'count-lines' can now ignore invisible lines.
-This is controlled by the optional parameter IGNORE-INVISIBLE-LINES.
+** Third 'mapconcat' argument SEPARATOR is now optional.
+An explicit nil always meant the empty string, now it can be left out.
---
-** 'count-words' now crosses field boundaries.
-Originally, 'count-words' would stop counting at the first field
-boundary it encountered; now it keeps counting all the way to the
-region's (or buffer's) end.
+** 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.
+++
-** File-related APIs can optionally follow symlinks.
-The functions 'file-modes', 'set-file-modes', and 'set-file-times' now
-have an optional argument specifying whether to follow symbolic links.
+** New function 'define-keymap'.
+This function allows defining a number of keystrokes with one form.
+++
-** 'format-seconds' can now be used for sub-second times.
-The new optional "," parameter has been added, and
-'(format-seconds "%mm %,1ss" 66.4)' will now result in "1m 6.4s".
-
-+++
-** 'parse-time-string' can now parse ISO 8601 format strings.
-These have a format like "2020-01-15T16:12:21-08:00".
+** New macro 'defvar-keymap'.
+This macro allows defining keymap variables more conveniently.
---
-** 'lookup-key' is more allowing when searching for extended menu items.
-When looking for a menu item '[menu-bar Foo-Bar]', first try to find
-an exact match, then look for the lowercased '[menu-bar foo-bar]'.
-It will only try to downcase ASCII characters in the range "A-Z".
-This improves backwards-compatibility when converting menus to use
-'easy-menu-define'.
-
----
-** 'make-network-process', 'make-serial-process' ':coding' behavior change.
-Previously, passing ':coding nil' to either of these functions would
-override any non-nil binding for 'coding-system-for-read' and
-'coding-system-for-write'. For consistency with 'make-process' and
-'make-pipe-process', passing ':coding nil' is now ignored. No code in
-Emacs depended on the previous behavior; if you really want the
-process' coding-system to be nil, use 'set-process-coding-system'
-after the process has been created, or pass in ':coding '(nil nil)'.
+** 'kbd' can now be used in built-in, preloaded libraries.
+It no longer depends on edmacro.el and cl-lib.el.
+++
-** 'open-network-stream' now accepts a ':coding' argument.
-This allows specifying the coding systems used by a network process
-for encoding and decoding without having to bind
-'coding-system-for-{read,write}' or call 'set-process-coding-system'.
+** New function 'image-at-point-p'.
+This function returns t if point is on a valid image, and nil
+otherwise.
+++
-** 'open-network-stream' can now take a ':capability-command' that's a function.
-The function is called with the greeting from the server as its only
-parameter, and allows sending different TLS capability commands to the
-server based on that greeting.
+** 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.
+++
-** 'open-gnutls-stream' now also accepts a ':coding' argument.
-
----
-** 'process-attributes' now works under OpenBSD, too.
-
-+++
-** 'format-spec' now takes an optional SPLIT parameter.
-If non-nil, 'format-spec' will split the resulting string into a list
-of strings, based on where the format specs (and expansions) were.
-
----
-** 'unload-feature' now also tries to undo additions to buffer-local hooks.
+** 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.
---
-** 'while-no-input-ignore-events' accepts more special events.
-The special events 'dbus-event' and 'file-notify' are now ignored in
-'while-no-input' when added to this variable.
+** '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]'.
----
-** 'start-process-shell-command' and 'start-file-process-shell-command'
-do not support the old calling conventions any longer.
+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'.
-+++
-** 'yes-or-no-p' and 'y-or-n-p' PROMPT parameter no longer needs trailing space.
-In other words, the prompt can now end with "?" instead of "? ". This
-has been the case since Emacs 24.4 but was not announced or documented
-until now. (Checkdoc has also been updated to accept this convention.)
+** xwidgets
+++
-** The 'uniquify' argument in 'auto-save-file-name-transforms' can be a symbol.
-If this symbol is one of the members of 'secure-hash-algorithms',
-Emacs constructs the nondirectory part of the auto-save file name by
-applying that 'secure-hash' to the buffer file name. This avoids any
-risk of excessively long file names.
+*** 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 user option 'process-file-return-signal-string'.
-It controls, whether 'process-file' returns a string when a remote
-process is interrupted by a signal.
+*** 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.
-** EIEIO Changes
+On GTK+, only key and function key events are implemented.
+++
-*** The macro 'oref-default' can now be used with 'setf'.
-It is now defined as a generalized variable that can be used with
-'setf' to modify the value stored in a given class slot.
-
----
-*** 'form' in '(eql form)' specializers in 'cl-defmethod' is now evaluated.
-This corresponds to the behavior of defmethod in Common Lisp Object System.
-For compatibility, '(eql SYMBOL)' does not evaluate SYMBOL, for now.
-
-** D-Bus
+*** 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'.
+++
-*** Property values can be typed explicitly.
-'dbus-register-property' and 'dbus-set-property' accept now optional
-type symbols. Both functions propagate D-Bus errors.
+*** 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.
+++
-*** Registered properties can have the new access type ':write'.
+*** New function 'xwidget-webkit-back-forward-list'.
+This function is used to obtain the history of page-loads in a given
+WebKit xwidget.
+++
-*** In case of problems, handlers can emit proper D-Bus error messages now.
+*** New function 'xwidget-webkit-estimated-load-progress'.
+This function is used to obtain the estimated progress of page loading
+in a given WebKit xwidget.
+++
-*** D-Bus errors, which have been converted from incoming D-Bus error
-messages, contain the error name of that message now.
+*** New function 'xwidget-webkit-stop-loading'.
+This function is used to terminate all data transfer during page loads
+in a given WebKit xwidget.
+++
-*** D-Bus messages can be monitored with the new command 'dbus-monitor'.
+*** '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.
+++
-*** D-Bus events have changed their internal structure.
-They carry now the destination and the error-name of an event. They
-also keep the type information of their arguments. Use the
-'dbus-event-*' accessor functions.
-
-** Buttons
+*** New event type 'xwidget-display-event'.
+These events are sent whenever an xwidget requests that Emacs display
+another xwidget. The only arguments to this event are the xwidget
+that should be displayed, and the xwidget that asked to display it.
+++
-*** New minor mode 'button-mode'.
-This minor mode does nothing except install 'button-buffer-map' as
-a minor mode map (which binds the 'TAB' / 'S-TAB' key bindings to navigate
-to buttons), and can be used in any view-mode-like buffer that has
-buttons in it.
+*** New 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 utility function 'button-buttonize'.
-This function takes a string and returns a string propertized in a way
-that makes it a valid button.
-
----
-** 'text-scale-mode' can now adjust font size of the header line.
-When the new buffer local variable 'text-scale-remap-header-line'
-is non-nil, 'text-scale-adjust' will also scale the text in the header
-line when displaying that buffer.
-
-This is useful for major modes that arrange their display in a tabular
-form below the header line. It is enabled by default in
-'tabulated-list-mode' and its derived modes, and disabled by default
-elsewhere.
-
----
-** 'ascii' is now a coding system alias for 'us-ascii'.
-
----
-** New coding-systems for EBCDIC variants.
-New coding-systems 'ibm256', 'ibm273', 'ibm274', 'ibm277', 'ibm278',
-'ibm280', 'ibm281', 'ibm284', 'ibm285', 'ibm290', 'ibm297'. These are
-variants of the EBCDIC encoding tailored to some European and Japanese
-locales. They are also available as aliases 'ebcdic-cp-*' (e.g.,
-'ebcdic-cp-fi' for the Finnish variant 'ibm278'), and 'cp2xx' (e.g.,
-'cp278' for 'ibm278'). There are also new charsets 'ibm2xx' to
-support these coding-systems.
+** New variable 'help-buffer-under-preparation'.
+This variable is bound to t during the preparation of a "*Help*" buffer.
+++
-** New 'Bindat type expression' description language.
-This new system is provided by the new macro 'bindat-type' and
-obsoletes the old data layout specifications. It supports
-arbitrary-size integers, recursive types, and more. See the Info node
-"(elisp) Byte Packing" in the ELisp manual for more details.
+** 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.
+++
-** New macro 'with-environment-variables'.
-This macro allows setting environment variables temporarily when
-executing a form.
-
-
-* Changes in Emacs 28.1 on Non-Free Operating Systems
+** 'date-to-time' now assumes earliest values if its argument lacks
+month, day, or time. For example, (date-to-time "2021-12-04") now
+assumes a time of 00:00 instead of signaling an error.
+++
-** On MS-Windows, Emacs can now use the native image API to display images.
-Emacs can now use the MS-Windows GDI+ library to load and display
-images in JPEG, PNG, GIF and TIFF formats. This support is available
-unless Emacs was configured '--without-native-image-api'.
-
-This feature is experimental, and needs to be turned on to be used.
-To turn this on, set the variable 'w32-use-native-image-API' to a
-non-nil value. Please report any bugs you find while using the native
-image API via 'M-x report-emacs-bug'.
+** 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.
+++
-** On MS-Windows, Emacs can now toggle the IME.
-A new function 'w32-set-ime-open-status' can now be used to disable
-and enable the MS-Windows native Input Method Editor (IME) at run
-time. A companion function 'w32-get-ime-open-status' returns the
-current IME activation status.
+** 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.
---
-** On macOS, 's-<left>' and 's-<right>' are now bound to
-'move-beginning-of-line' and 'move-end-of-line' respectively. The commands
-to select previous/next frame are still bound to 's-~' and 's-`'.
-
-+++
-** On macOS, Emacs can now load dynamic modules with a ".dylib" suffix.
-'module-file-suffix' now has the value ".dylib" on macOS, but the
-".so" suffix is supported as well.
-
----
-** On macOS, the user option 'make-pointer-invisible' is now honored.
-
----
-** On macOS, Xwidget is now supported.
-If Emacs was built with xwidget support, you can access the embedded
-webkit browser with 'M-x xwidget-webkit-browse-url'. Viewing two
-instances of xwidget webkit is not supported.
+
+* Changes in Emacs 29.1 on Non-Free Operating Systems
----
-*** New user option 'xwidget-webkit-enable-plugins'.
-If non-nil, enable plugins in xwidget. (This is only available on
-macOS.)
+** MS-Windows
+++
-** New macOS Contacts back-end for EUDC.
-This backend works on newer versions of macOS and is generally
-preferred over the eudcb-mab.el backend.
+*** 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.
----------------------------------------------------------------------
diff --git a/etc/NEWS.28 b/etc/NEWS.28
new file mode 100644
index 00000000000..e7d72159023
--- /dev/null
+++ b/etc/NEWS.28
@@ -0,0 +1,4603 @@
+GNU Emacs NEWS -- history of user-visible changes.
+
+Copyright (C) 2019-2021 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 28.
+
+See file HISTORY for a list of GNU Emacs versions and release dates.
+See files NEWS.27, NEWS.26, ..., 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'.
+
+Temporary note:
++++ indicates that all relevant manuals in doc/ have been updated.
+--- means no change in the manuals is needed.
+When you add a new item, use the appropriate mark if you are sure it
+applies, and please also update docstrings as needed.
+
+
+* Installation Changes in Emacs 28.1
+
+** Emacs now optionally supports native compilation of Lisp files.
+To enable this, configure Emacs with the '--with-native-compilation' option.
+This requires the libgccjit library to be installed and functional,
+and also requires GCC and Binutils to be available when Lisp code is
+natively compiled. See the Info node "(elisp) Native Compilation" for
+more details.
+
+If you build Emacs with native compilation, but without zlib, be sure
+to configure with the '--without-compress-install' option, so that the
+installed *.el files are not compressed; otherwise, you will not be
+able to use JIT native compilation of the installed *.el files.
+
+Note that JIT native compilation is done in a fresh session of Emacs
+that is run in a subprocess, so it can legitimately report some
+warnings and errors that aren't uncovered by byte-compilation. We
+recommend examining any such warnings before you decide they are
+false.
+
+** The Cairo graphics library is now used by default if present.
+'--with-cairo' is now the default, if the appropriate development files
+are found by 'configure'. Note that building with Cairo means using
+Pango instead of libXFT for font support. Since Pango 1.44 has
+removed support for bitmapped fonts, this may require you to adjust
+your font settings.
+
+Note also that 'FontBackend' settings in ".Xdefaults" or
+".Xresources", or 'font-backend' frame parameter settings in your init
+files, may need to be adjusted, as 'xft' is no longer a valid backend
+when using Cairo. Use 'ftcrhb' if your Emacs was built with HarfBuzz
+text shaping support, and 'ftcr' otherwise. You can determine this by
+checking 'system-configuration-features'. The 'ftcr' backend will
+still be available when HarfBuzz is supported, but will not be used by
+default. We strongly recommend building with HarfBuzz support. 'x' is
+still a valid backend.
+
+---
+** 'configure' now warns about building with libXft support.
+libXft is unmaintained, and causes a number of problems with modern
+fonts including but not limited to crashes; support for it may be
+removed in a future version of Emacs. Please consider using
+Cairo + HarfBuzz instead.
+
+---
+** 'configure' now warns about not using HarfBuzz if using Cairo.
+We want to encourage people to use the most modern font features
+available, and this is the Cairo graphics library + HarfBuzz for font
+shaping, so 'configure' now recommends that combination.
+
+---
+** Building without double buffering support.
+'configure --with-xdbe=no' can now be used to disable double buffering
+at build time.
+
+---
+** Support for building with Motif has been removed.
+
+---
+** The configure option '--without-makeinfo' has been removed.
+This was only ever relevant when building from a repository checkout.
+This now requires makeinfo, which is part of the texinfo package.
+
+---
+** New configure option '--disable-year2038'.
+This causes Emacs to use only 32-bit time_t on platforms that have
+both 32- and 64-bit time_t. This may help when linking Emacs with a
+library with an ABI requiring traditional 32-bit time_t. This option
+currently affects only 32-bit ARM and x86 running GNU/Linux with glibc
+2.34 and later. Emacs now defaults to 64-bit time_t on these
+platforms.
+
+---
+** Support for building with '-fcheck-pointer-bounds' has been removed.
+GCC has withdrawn the '-fcheck-pointer-bounds' option and support for
+its implementation has been removed from the Linux kernel.
+
+---
+** The ftx font backend driver has been removed.
+It was declared obsolete in Emacs 27.1.
+
+---
+** Emacs no longer supports old OpenBSD systems.
+OpenBSD 5.3 and older releases are no longer supported, as they lack
+proper pty support that Emacs needs.
+
+
+* Startup Changes in Emacs 28.1
+
+---
+** In GTK builds, Emacs now supports startup notification.
+This means that Emacs won't steal keyboard focus upon startup
+(when started via the Desktop) if the user is typing into another
+application.
+
+---
+** Errors in 'kill-emacs-hook' no longer prevent Emacs from shutting down.
+If a function in that hook signals an error in an interactive Emacs,
+the user will be prompted on whether to continue. If the user doesn't
+answer within five seconds, Emacs will continue shutting down anyway.
+
+** Emacs now supports loading a Secure Computing filter.
+This is supported only on capable GNU/Linux systems. To activate,
+invoke Emacs with the '--seccomp=FILE' command-line option. FILE must
+name a binary file containing an array of 'struct sock_filter'
+structures. Emacs will then install that list of Secure Computing
+filters into its own process early during the startup process. You
+can use this functionality to put an Emacs process in a sandbox to
+avoid security issues when executing untrusted code. See the manual
+page for 'seccomp' system call, for details about Secure Computing
+filters.
+
+** Emacs can support 24-bit color TTY without terminfo database.
+If your text-mode terminal supports 24-bit true color, but your system
+lacks the terminfo database, you can instruct Emacs to support 24-bit
+true color by setting 'COLORTERM=truecolor' in the environment. This is
+useful on systems such as FreeBSD which ships only with "etc/termcap".
+
+---
+** File names given on the command line are now be pushed onto history.
+The file names will be pushed onto 'file-name-history', like the names
+of files visited via 'C-x C-f' and other commands.
+
+
+* Changes in Emacs 28.1
+
+---
+** Emacs now supports Unicode Standard version 14.0.
+
++++
+** Improved support for Emoji.
+On capable systems, Emacs now correctly displays Emoji and Emoji
+sequences by default, provided that a suitable font is available to
+Emacs. With a few exceptions, all of the Emoji sequences specified by
+Unicode 14.0 are automatically composed and displayed as a single
+colorful glyph. This is achieved by changes in the Emacs font
+configuration, and by additional character-composition rules for the
+Emoji codepoints that follow from the Unicode-defined sequences.
+
+If your system lacks a suitable font, we recommend to install "Noto
+Color Emoji"; Emacs will use it automatically if it's installed. If
+you prefer to use another font for Emoji, customize your fontset like
+this:
+
+ (set-fontset-font t 'emoji
+ '("My New Emoji Font" . "iso10646-1") nil 'prepend)
+
+The Emoji characters are now assigned to a special script, 'emoji', so
+as to make it easier to customize fontsets for Emoji display, as in
+the above example. (Previously, the Emoji characters were assigned to
+the 'symbol' script, together with other symbol and punctuation
+characters.)
+
++++
+** 'glyphless-char-display-control' now applies to Variation Selectors.
+VS-1 through VS-16 are now displayed as 'thin-space' by default when
+not composed with previous characters (typically, as part of Emoji
+sequences).
+
++++
+** New command 'execute-extended-command-for-buffer'.
+This new command, bound to 'M-S-x', works like
+'execute-extended-command', but limits the set of commands to the
+commands that have been determined to be particularly useful with the
+current mode.
+
++++
+** New user option 'read-extended-command-predicate'.
+This user option controls how 'M-x' performs completion of commands when
+you type 'TAB'. By default, any command that matches what you have
+typed is considered a completion candidate, but you can customize this
+option to exclude commands that are not applicable to the current
+buffer's major and minor modes, and respect the command's completion
+predicate (if any).
+
++++
+** Completion on 'M-x' shows key bindings for commands.
+When 'suggest-key-bindings' is non-nil (as it is by default), the
+completion list popped up by 'M-x' shows the key bindings for all the
+commands shown in the list of candidate completions that have a key
+binding.
+
++++
+** New user option 'completions-detailed'.
+When non-nil, some commands like 'describe-symbol' show more detailed
+completions with more information in completion prefix and suffix.
+The default is nil.
+
+---
+** 'C-s' in 'M-x' now once again searches over completions.
+In Emacs 23, typing 'M-x' ('read-extended-command') and then 'C-s' (to
+do an interactive search) would search over possible completions.
+This was lost in Emacs 24, but is now back again.
+
++++
+** User option 'completions-format' supports a new value 'one-column'.
+
++++
+** New system for displaying documentation for groups of functions.
+This can either be used by saying 'M-x shortdoc-display-group' and
+choosing a group, or clicking a button in the "*Help*" buffers when
+looking at the doc string of a function that belongs to one of these
+groups.
+
++++
+** New minor mode 'context-menu-mode' for context menus popped by 'mouse-3'.
+When this mode is enabled, clicking 'down-mouse-3' (usually, the
+right mouse button) anywhere in the buffer pops up a menu whose
+contents depends on surrounding context near the mouse click.
+You can change the order of the default sub-menus in the context menu
+by customizing the user option 'context-menu-functions'. You can also
+invoke the context menu by pressing 'S-<F10>' or, on macOS, by
+clicking 'C-down-mouse-1'.
+
++++
+** A new keymap for buffer actions has been added.
+The 'C-x x' keymap now holds keystrokes for various buffer-oriented
+commands. The new keystrokes are 'C-x x g' ('revert-buffer-quick'),
+'C-x x r' ('rename-buffer'), 'C-x x u' ('rename-uniquely'), 'C-x x n'
+('clone-buffer'), 'C-x x i' ('insert-buffer'), 'C-x x t'
+('toggle-truncate-lines') and 'C-x x f' ('font-lock-update').
+
++++
+** Modifiers now go outside angle brackets in pretty-printed key bindings.
+For example, 'RET' with Control and Meta modifiers is now shown as
+'C-M-<return>' instead of '<C-M-return>'. Either variant can be used
+as input; functions such as 'kbd' and 'read-kbd-macro' accept both
+styles as equivalent (they have done so for a long time).
+
+---
+** 'eval-expression' no longer signals an error on incomplete expressions.
+Previously, typing 'M-: ( RET' would result in Emacs saying "End of
+file during parsing" and dropping out of the minibuffer. The user
+would have to type 'M-: M-p' to edit and redo the expression. Now
+Emacs will echo the message and allow the user to continue editing.
+
++++
+** 'eval-last-sexp' now handles 'defvar'/'defcustom'/'defface' specially.
+This command would previously not redefine values defined by these
+forms, but this command has now been changed to work more like
+'eval-defun', and reset the values as specified.
+
+---
+** New user option 'use-short-answers'.
+When non-nil, the function 'y-or-n-p' is used instead of
+'yes-or-no-p'. This eliminates the need to define an alias that maps
+one to another in the init file. The same user option also controls
+whether the function 'read-answer' accepts short answers.
+
++++
+** New user option 'kill-buffer-delete-auto-save-files'.
+If non-nil, killing a buffer that has an auto-save file will prompt
+the user for whether that auto-save file should be deleted. (Note
+that 'delete-auto-save-files', if non-nil, was previously documented
+to result in deletion of auto-save files when killing a buffer without
+unsaved changes, but this has apparently not worked for several
+decades, so the documented semantics of this variable has been changed
+to match the behavior.)
+
++++
+** New user option 'next-error-message-highlight'.
+In addition to a fringe arrow, 'next-error' error may now optionally
+highlight the current error message in the 'next-error' buffer.
+This user option can be also customized to keep highlighting on all
+visited errors, so you can have an overview what errors were already visited.
+
+---
+** New choice 'next-error-quit-window' for 'next-error-found-function'.
+When 'next-error-found-function' is customized to 'next-error-quit-window',
+then typing the numeric prefix argument 0 before the command 'next-error'
+will quit the source window after visiting the next occurrence.
+
++++
+** New user option 'file-preserve-symlinks-on-save'.
+This controls what Emacs does when saving buffers that visit files via
+symbolic links, and 'file-precious-flag' is non-nil.
+
++++
+** New user option 'copy-directory-create-symlink'.
+If non-nil, will make 'copy-directory' (when used on a symbolic
+link) copy the link instead of following the link. The default is
+nil, so the default behavior is unchanged.
+
++++
+** New user option 'ignored-local-variable-values'.
+This is the opposite of 'safe-local-variable-values' -- it's an alist
+of variable-value pairs that are to be ignored when reading a
+local-variables section of a file.
+
+---
+** Specific warnings can now be disabled from the warning buffer.
+When a warning is displayed to the user, the resulting buffer now has
+buttons which allow making permanent changes to the treatment of that
+warning. Automatic showing of the warning can be disabled (although
+it is still logged to the "*Messages*" buffer), or the warning can be
+disabled entirely.
+
++++
+** ".dir-locals.el" now supports setting 'auto-mode-alist'.
+The new 'auto-mode-alist' specification in ".dir-locals.el" files can
+now be used to override the global 'auto-mode-alist' in the current
+directory tree.
+
+---
+** User option 'uniquify-buffer-name-style' can now be a function.
+This user option can be one of the predefined styles or a function to
+personalize the uniquified buffer name.
+
+---
+** 'remove-hook' is now an interactive command.
+
+---
+** 'expand-file-name' now checks for null bytes in filenames.
+The function will now check for null bytes in both NAME and
+DEFAULT-DIRECTORY arguments, as well as in the 'default-directory'
+buffer-local variable, when its value is used. If null bytes are
+found, 'expand-file-name' will signal an error.
+This means that practically all file-related operations will now check
+file names for null bytes, thus avoiding subtle bugs with silently
+using only the part of file name up to the first null byte.
+
+---
+** Frames
+
++++
+*** The key prefix 'C-x 5 5' displays next command buffer in a new frame.
+It's bound to the command 'other-frame-prefix' that requests the buffer
+of the next command to be displayed in a new frame.
+
++++
+*** New command 'clone-frame' (bound to 'C-x 5 c').
+This is like 'C-x 5 2', but uses the window configuration and frame
+parameters of the current frame instead of 'default-frame-alist'.
+When called interactively with a prefix arg, the window configuration
+is not cloned.
+
+---
+*** Default values of 'frame-title-format' and 'icon-title-format' have changed.
+These variables are used to display the title bar of visible frames
+and the title bar of an iconified frame. They now show the name of
+the current buffer and the text "GNU Emacs" instead of the value of
+'invocation-name'. To get the old behavior back, add the following to
+your init file:
+
+ (setq frame-title-format '(multiple-frames "%b"
+ ("" invocation-name "@" system-name)))
+
++++
+*** New frame parameter 'drag-with-tab-line'.
+This parameter, similar to 'drag-with-header-line', allows moving frames
+by dragging the tab lines of their topmost windows with the mouse.
+
++++
+*** New optional behavior of 'delete-other-frames'.
+When invoked with a prefix argument, 'delete-other-frames' now
+iconifies frames, rather than deleting them.
+
+---
+*** Commands 'set-frame-width' and 'set-frame-height' now prompt for values.
+These commands now prompt for the value via the minibuffer, instead of
+requiring the user to specify the value via the prefix argument.
+
+** Windows
+
++++
+*** The key prefix 'C-x 4 1' displays next command buffer in the same window.
+It's bound to the command 'same-window-prefix' that requests the buffer
+of the next command to be displayed in the same window.
+
++++
+*** The key prefix 'C-x 4 4' displays next command buffer in a new window.
+It's bound to the command 'other-window-prefix' that requests the buffer
+of the next command to be displayed in a new window.
+
++++
+*** New command 'recenter-other-window', bound to 'S-M-C-l'.
+Like 'recenter-top-bottom', but acting on the other window.
+
++++
+*** New user option 'delete-window-choose-selected'.
+This allows specifying how Emacs chooses which window will be the
+frame's selected window after the currently selected window is
+deleted.
+
++++
+*** New argument NO-OTHER for some window functions.
+'get-lru-window', 'get-mru-window' and 'get-largest-window' now accept a
+new optional argument NO-OTHER which, if non-nil, avoids returning a
+window whose 'no-other-window' parameter is non-nil.
+
++++
+*** New 'display-buffer' function 'display-buffer-use-least-recent-window'.
+This is like 'display-buffer-use-some-window', but won't reuse the
+current window, and when called repeatedly will try not to reuse a
+previously selected window.
+
++++
+*** New function 'window-bump-use-time'.
+This updates the use time of a window.
+
+** Minibuffer
+
++++
+*** Minibuffer scrolling is now conservative by default.
+This is controlled by the new variable 'scroll-minibuffer-conservatively'.
+It is t by default; setting it to nil will cause scrolling in the
+minibuffer obey the value of 'scroll-conservatively'.
+
++++
+*** Improved handling of minibuffers on switching frames.
+By default, when you switch to another frame, an active minibuffer now
+moves to the newly selected frame. Nevertheless, the effect of what
+you type in the minibuffer happens in the frame where the minibuffer
+was first activated. An alternative behavior is available by
+customizing 'minibuffer-follows-selected-frame' to nil. Here, the
+minibuffer stays in the frame where you first opened it, and you must
+switch back to this frame to continue or abort its command. The old
+behavior, which mixed these two, can be approximated by customizing
+'minibuffer-follows-selected-frame' to a value which is neither nil
+nor t.
+
++++
+*** New user option 'read-minibuffer-restore-windows'.
+When customized to nil, it uses 'minibuffer-restore-windows' in
+'minibuffer-exit-hook' to remove only the window showing the
+"*Completions*" buffer, but keeps all other windows created
+while the minibuffer was active.
+
+---
+*** New variable 'redisplay-adhoc-scroll-in-resize-mini-windows'.
+Customizing it to nil will disable the ad-hoc auto-scrolling of
+minibuffer text shown in mini-windows when resizing those windows.
+The default heuristics of that scrolling can be counter productive in
+some corner cases, though the cure might be worse than the disease.
+This said, the effect should be negligible in the vast majority of
+cases anyway.
+
+** Mode Line
+
++++
+*** New user option 'mode-line-compact'.
+If non-nil, repeating spaces are compressed into a single space. If
+'long', this is only done when the mode line is longer than the
+current window width (in columns).
+
++++
+*** New user options to control format of line/column numbers in the mode line.
+'mode-line-position-line-format' is the line number format (when
+'line-number-mode' is on), 'mode-line-position-column-format' is
+the column number format (when 'column-number-mode' is on), and
+'mode-line-position-column-line-format' is the combined format (when
+both modes are on).
+
+** Tab Bars and Tab Lines
+
++++
+*** The prefix key 'C-x t t' can be used to display a buffer in a new tab.
+Typing 'C-x t t' before a command will cause the buffer shown by that
+command to be displayed in a new tab. 'C-x t t' is bound to the
+command 'other-tab-prefix'.
+
++++
+*** New command 'C-x t C-r' to open file read-only in the other tab.
+
++++
+*** The tab bar now supports more mouse commands.
+Clicking 'mouse-2' closes the tab, 'mouse-3' displays the context menu
+with items that operate on the clicked tab. Dragging the tab with
+'mouse-1' moves it to another position on the tab bar. Mouse wheel
+scrolling switches to the previous/next tab, and holding the Shift key
+during scrolling moves the tab to the left/right.
+
++++
+*** Frame-specific appearance of the tab bar when 'tab-bar-show' is a number.
+When 'tab-bar-show' is a number, the tab bar on different frames can
+be shown or hidden independently, as determined by the number of tabs
+on each frame compared to the numerical value of 'tab-bar-show'.
+
++++
+*** New command 'toggle-frame-tab-bar'.
+It can be used to enable/disable the tab bar on the currently selected
+frame regardless of the values of 'tab-bar-mode' and 'tab-bar-show'.
+This allows enabling/disabling the tab bar independently on different
+frames.
+
++++
+*** New user option 'tab-bar-format' defines a list of tab bar items.
+When it contains 'tab-bar-format-global' (possibly appended after
+'tab-bar-format-align-right'), then after enabling 'display-time-mode'
+(or any other mode that uses 'global-mode-string') it displays time
+aligned to the right on the tab bar instead of on the mode line.
+When 'tab-bar-format-tabs' is replaced with 'tab-bar-format-tabs-groups',
+the tab bar displays tab groups.
+
++++
+*** New optional key binding for 'tab-last'.
+If you customize the user option 'tab-bar-select-tab-modifiers' to
+allow selecting tabs using their index numbers, the '<MODIFIER>-9' key
+is bound to 'tab-last', and switches to the last tab. Here <MODIFIER>
+is any of the modifiers in the list that is the value of
+'tab-bar-select-tab-modifiers'. You can also use positive indices,
+which count from the last tab: 1 is the last tab, 2 the one before
+that, etc.
+
+---
+*** New command 'tab-duplicate' bound to 'C-x t n'.
+
+---
+*** 'C-x t N' creates a new tab at the specified absolute position.
+The position is provided as prefix arg, and specifies an index that
+starts at 1. Negative values count from the end of the tab bar.
+
+---
+*** 'C-x t M' moves the current tab to the specified absolute position.
+The position is provided as prefix arg, whose interpretation is as in
+'C-x t N'.
+
+---
+*** 'C-x t G' assigns a tab to a named group of tabs.
+'tab-close-group' closes all tabs that belong to the selected group.
+The user option 'tab-bar-new-tab-group' defines the default group of
+new tabs. After customizing 'tab-bar-tab-post-change-group-functions'
+to 'tab-bar-move-tab-to-group', changing the group of a tab will also
+move it closer to other tabs in the same group.
+
+---
+*** New user option 'tab-bar-tab-name-format-function'.
+
+---
+*** New user option 'tab-line-tab-name-format-function'.
+
+---
+*** The tabs in the tab line can now be scrolled using horizontal scroll.
+If your mouse or trackpad supports it, you can now scroll tabs when
+the mouse pointer is in the tab line by scrolling left or right.
+
+---
+*** New tab-line faces and user options.
+The face 'tab-line-tab-special' is used for tabs whose buffers are
+special, i.e. buffers that don't visit a file. The face
+'tab-line-tab-modified' is used to display modified, file-backed
+buffers. The face 'tab-line-tab-inactive-alternate' is used to
+display inactive tabs with an alternating background color, making
+them easier to distinguish, especially if the face 'tab-line-tab' is
+configured to not display with a box; this alternate face is only
+applied when the user option 'tab-line-tab-face-functions' is so
+configured. That option may also be used to customize tab-line faces
+in other ways.
+
+** Mouse wheel
+
+---
+*** Mouse wheel scrolling now defaults to one line at a time.
+
+---
+*** Mouse wheel scrolling now works on more parts of frame's display.
+When using 'mouse-wheel-mode', the mouse wheel will now scroll also when
+the mouse cursor is on the scroll bars, fringes, margins, header line,
+and mode line. ('mouse-wheel-mode' is enabled by default on most graphical
+displays.)
+
++++
+*** Mouse wheel scrolling with Shift modifier now scrolls horizontally.
+This works in text buffers and over images. Typing a numeric prefix arg
+(e.g. 'M-5') before starting horizontal scrolling changes its step value.
+The value is saved in the user option 'mouse-wheel-scroll-amount-horizontal'.
+
+** Customize
+
+---
+*** Customize buffers can now be reverted with 'C-x x g'.
+
+---
+*** Most customize commands now hide obsolete user options.
+Obsolete user options are no longer shown in the listings produced by
+the commands 'customize', 'customize-group', 'customize-apropos' and
+'customize-changed'.
+
+To customize obsolete user options, use 'customize-option' or
+'customize-saved'.
+
+---
+*** New SVG icons for checkboxes and arrows.
+They will be used automatically instead of the old icons. If Emacs is
+built without SVG support, the old icons will be used instead.
+
+** Help
+
+---
+*** The order of things displayed in the "*Help*" buffer has been changed.
+The indented "administrative" block (containing the "probably
+introduced" and "other relevant functions" (and similar things) has
+been moved to after the doc string.
+
++++
+*** New command 'describe-command' shows help for a command.
+This can be used instead of 'describe-function' for interactive
+commands and is globally bound to 'C-h x'.
+
++++
+*** New command 'describe-keymap' describes keybindings in a keymap.
+
+---
+*** New command 'apropos-function'.
+This works like 'C-u M-x apropos-command' but is more discoverable.
+
+---
+*** New keybinding 'C-h R' prompts for an Info manual and displays it.
+
+---
+*** Keybindings in 'help-mode' use the new 'help-key-binding' face.
+This face is added by 'substitute-command-keys' to any "\[command]"
+substitution. The return value of that function should consequently
+be assumed to be a propertized string. To prevent the function from
+adding the 'help-key-binding' face, call 'substitute-command-keys'
+with the new optional argument NO-FACE non-nil.
+
+Note that the new face will also be used in tooltips. When using the
+GTK toolkit, this is only true if 'x-gtk-use-system-tooltips' is t.
+
++++
+*** New user option 'help-enable-symbol-autoload'.
+If non-nil, displaying help for an autoloaded function whose
+'autoload' form provides no documentation string will try to load the
+file it's from. This will give more extensive help for such
+functions.
+
+---
+*** The 'help-for-help' ('C-h C-h') screen has been redesigned.
+
++++
+*** New convenience commands with short keys in the Help buffer.
+New command 'help-view-source' ('s') will view the source file (if
+any) of the current help topic. New command 'help-goto-info' ('i')
+will look up the current symbol (if any) in Info. New command
+'help-customize' ('c') will customize the user option or the face
+(if any) whose doc string is being shown in the Help buffer.
+
+---
+*** New user option 'describe-bindings-outline'.
+It enables outlines in the output buffer of 'describe-bindings' that
+can provide a better overview in a long list of available bindings.
+
++++
+*** New commands to describe buttons and widgets.
+'widget-describe' (on a widget) will pop up a help buffer and give a
+description of the properties. Likewise 'button-describe' does the
+same for a button.
+
+---
+*** Improved "find definition" feature of "*Help*" buffers.
+Now clicking on the link to find the definition of functions generated
+by 'cl-defstruct', or variables generated by 'define-derived-mode',
+for example, will go to the exact place where they are defined.
+
+---
+*** New commands 'apropos-next-symbol' and 'apropos-previous-symbol'.
+These new navigation commands are bound to 'n' and 'p' in
+'apropos-mode'.
+
+---
+*** The command 'view-lossage' can now be invoked from the menu bar.
+The menu bar "Help" menu now has a "Show Recent Inputs" item under the
+"Describe" sub-menu.
+
++++
+*** New command 'lossage-size'.
+It allows users to change the maximum number of keystrokes and
+commands recorded for the purpose of 'view-lossage'.
+
+---
+*** Closing the "*Help*" buffer from the toolbar now buries the buffer.
+In previous Emacs versions, the "*Help*" buffer was killed instead when
+clicking the "X" icon in the tool bar.
+
+---
+*** 'g' ('revert-buffer') in 'help-mode' no longer requires confirmation.
+
+** File Locks
+
++++
+*** New user option 'lock-file-name-transforms'.
+This option allows controlling where lock files are written. It uses
+the same syntax as 'auto-save-file-name-transforms'.
+
++++
+*** New user option 'remote-file-name-inhibit-locks'.
+When non-nil, this option suppresses lock files for remote files.
+Default is nil.
+
++++
+*** New minor mode 'lock-file-mode'.
+This command, called interactively, toggles the local value of
+'create-lockfiles' in the current buffer.
+
+** Emacs Server
+
++++
+*** New user option 'server-client-instructions'.
+When emacsclient connects, Emacs will (by default) output a message
+about how to exit the client frame. If 'server-client-instructions'
+is set to nil, this message is inhibited.
+
++++
+*** New command 'server-edit-abort'.
+This command (not bound to any key by default) can be used to abort
+an edit instead of marking it as "Done" (which the 'C-x #' command
+does). The 'emacsclient' program exits with an abnormal status as
+result of this command.
+
++++
+*** New desktop integration for connecting to the server.
+If your operating system’s desktop environment is
+freedesktop.org-compatible (which is true of most GNU/Linux and other
+recent Unix-like desktops), you may use the new "Emacs (Client)"
+desktop menu entry to open files in an existing Emacs instance rather
+than starting a new one. The daemon starts if it is not already
+running.
+
+** Miscellaneous
+
++++
+*** New command 'font-lock-update', bound to 'C-x x f'.
+This command updates the syntax highlighting in this buffer.
+
++++
+*** New command 'memory-report'.
+This command opens a new buffer called "*Memory Report*" and gives a
+summary of where Emacs is using memory currently.
+
++++
+*** New command 'submit-emacs-patch'.
+This works like 'report-emacs-bug', but is more geared towards sending
+patches to the Emacs issue tracker.
+
+---
+*** New face 'apropos-button'.
+Applies to buttons that indicate a face.
+
++++
+*** New face 'font-lock-doc-markup-face'.
+Intended for documentation mark-up syntax and tags inside text that
+uses 'font-lock-doc-face', which it should appropriately stand out
+against and harmonize with. It would typically be used in structured
+documentation comments in program source code by language-specific
+modes, for mark-up conventions like Haddock, Javadoc or Doxygen. By
+default this face inherits from 'font-lock-constant-face'.
+
++++
+*** New face box style 'flat-button'.
+This is a plain 2D button, but uses the background color instead of
+the foreground color.
+
+---
+*** New faces 'shortdoc-heading' and 'shortdoc-section'.
+Applied to shortdoc headings and sections.
+
+---
+*** New face 'separator-line'.
+This is used by 'make-separator-line' (see below).
+
++++
+*** 'redisplay-skip-fontification-on-input' helps Emacs keep up with fast input.
+This is another attempt to solve the problem of handling high key repeat rate
+and other "slow scrolling" situations. It is hoped it behaves better
+than 'fast-but-imprecise-scrolling' and 'jit-lock-defer-time'.
+It is not enabled by default.
+
+---
+*** Obsolete aliases are no longer hidden from command completion.
+Completion of command names now considers obsolete aliases as
+candidates, if they were marked obsolete in the current major version
+of Emacs. Invoking a command via an obsolete alias now mentions the
+obsolescence fact and shows the new name of the command.
+
++++
+*** Support for '(box . SIZE)' 'cursor-type'.
+By default, 'box' cursor always has a filled box shape. But if you
+specify 'cursor-type' to be '(box . SIZE)', the cursor becomes a hollow
+box if the point is on an image larger than SIZE pixels in any
+dimension.
+
++++
+*** The user can now customize how "default" values are prompted for.
+The new utility function 'format-prompt' has been added which uses the
+new 'minibuffer-default-prompt-format' user option to format "default"
+prompts. This means that prompts that look like "Enter a number
+(default 10)" can be customized to look like, for instance, "Enter a
+number [10]", or not have the default displayed at all, like "Enter a
+number". (This only affects callers that were altered to use
+'format-prompt'.)
+
+---
+*** New help window when Emacs prompts before opening a large file.
+Commands like 'find-file' or 'visit-tags-table' ask to visit a file
+normally or literally when the file is larger than a certain size (by
+default, 9.5 MiB). Press '?' or 'C-h' in that prompt to read more
+about the different options to visit a file, how you can disable the
+prompt, and how you can tweak the file size threshold.
+
++++
+*** Emacs now defaults to UTF-8 instead of ISO-8859-1.
+This is only for the default, where the user has set no 'LANG' (or
+similar) variable or environment. This change should lead to no
+user-visible changes for normal usage.
+
+---
+*** 'global-display-fill-column-indicator-mode' skips some buffers.
+By default, turning on 'global-display-fill-column-indicator-mode'
+doesn't turn on 'display-fill-column-indicator-mode' in special-mode
+buffers. This can be controlled by customizing the user option
+'global-display-fill-column-indicator-modes'.
+
++++
+*** 'nobreak-char-display' now also affects all non-ASCII space characters.
+Previously, this was limited only to 'NO-BREAK SPACE' and hyphen
+characters. Now it also covers the rest of the non-ASCII Unicode
+space characters. Also, unlike in previous versions of Emacs, the
+non-ASCII characters are displayed as themselves when
+'nobreak-char-display' is t, i.e. they are not replaced on display
+with the ASCII space and hyphen characters.
+
+---
+*** New backward compatibility variable 'nobreak-char-ascii-display'.
+This variable is nil by default, and non-ASCII space and hyphen
+characters are displayed as themselves, even if 'nobreak-char-display'
+is non-nil. If 'nobreak-char-ascii-display' is set to a non-nil
+value, the non-ASCII space and hyphen characters are instead displayed
+as their ASCII counterparts: spaces and ASCII hyphen (a.k.a. "dash")
+characters. This provides backward compatibility feature for the
+change described above, where the non-ASCII characters are no longer
+replaced with their ASCII counterparts when 'nobreak-char-display' is
+t. You may need this on text-mode terminals that produce messed up
+display when non-ASCII spaces and hyphens are written to the display.
+(This variable is only effective when 'nobreak-char-display' is t.)
+
++++
+*** Improved support for terminal emulators that encode the Meta flag.
+Some terminal emulators set the 8th bit of Meta characters, and then
+encode the resulting character code as if it were non-ASCII character
+above codepoint 127. Previously, the only way of using these in Emacs
+was to set up the terminal emulator to use the 'ESC' characters to send
+Meta characters to Emacs, e.g., send "ESC x" when the user types
+'M-x'. You can now avoid the need for this setup of such terminal
+emulators by using the new input-meta-mode with the special value
+'encoded' with these terminal emulators.
+
+---
+*** 'auto-composition-mode' can now be selectively disabled on some TTYs.
+Some text-mode terminals produce display glitches trying to compose
+characters. The 'auto-composition-mode' can now have a string value
+that names a terminal type; if the value returned by the 'tty-type'
+function compares equal with that string, automatic composition will
+be disabled in windows shown on that terminal. The Linux terminal
+sets this up by default.
+
+---
+*** Support for the 'strike-through' face attribute on TTY frames.
+If your terminal's termcap or terminfo database entry has the 'smxx'
+capability defined, Emacs will now emit the prescribed escape
+sequences necessary to render faces with the 'strike-through'
+attribute on TTY frames.
+
+---
+*** TTY menu navigation is now supported in 'xterm-mouse-mode'.
+TTY menus support mouse navigation and selection when 'xterm-mouse-mode'
+is active. When run on a terminal, clicking on the menu bar with the
+mouse now pops up a TTY menu by default instead of running the command
+'tmm-menubar'. To restore the old behavior, set the user option
+'tty-menu-open-use-tmm' to non-nil.
+
+---
+*** 'M-x report-emacs-bug' will no longer include "Recent messages" section.
+These were taken from the "*Messages*" buffer, and may inadvertently
+leak information from the reporting user.
+
+---
+*** 'C-u M-x dig' will now prompt for a query type to use.
+
+---
+*** Rudimentary support for the 'st' terminal emulator.
+Emacs now supports 256 color display on the 'st' terminal emulator.
+
++++
+*** Update IRC-related references to point to Libera.Chat.
+The Free Software Foundation and the GNU Project have moved their
+official IRC channels from the Freenode network to Libera.Chat. For the
+original announcement and the follow-up update, including more details,
+see:
+
+https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00005.html
+https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00007.html
+
+Given the relocation of GNU and FSF's official IRC channels, as well
+as #emacs and various other Emacs-themed channels (see the link below)
+to Libera.Chat, IRC-related references in the Emacs repository have
+now been updated to point to Libera.Chat.
+
+https://lists.gnu.org/archive/html/info-gnu-emacs/2021-06/msg00000.html
+
+
+* Incompatible Editing Changes in Emacs 28.1
+
+---
+** 'toggle-truncate-lines' now disables 'visual-line-mode'.
+This is for symmetry with 'visual-line-mode', which disables
+'truncate-lines'.
+
+---
+** 'electric-indent-mode' now also indents inside strings and comments.
+(This only happens when indentation function also supports this.)
+
+To recover the previous behavior you can use:
+
+ (add-hook 'electric-indent-functions
+ (lambda (_) (if (nth 8 (syntax-ppss)) 'no-indent)))
+
+---
+** The 'M-o' ('facemenu-keymap') global binding has been removed.
+To restore the old binding, say something like:
+
+ (require 'facemenu)
+ (define-key global-map "\M-o" 'facemenu-keymap)
+ (define-key facemenu-keymap "\es" 'center-line)
+ (define-key facemenu-keymap "\eS" 'center-paragraph)
+
+The last two lines are not strictly necessary if you don't care about
+having those two commands on the 'M-o' keymap; see the next section.
+
+---
+** The 'M-o M-s' and 'M-o M-S' global bindings have been removed.
+Use 'M-x center-line' and 'M-x center-paragraph' instead. See the
+previous section for how to get back the old bindings. Alternatively,
+if you only want these two commands to have the global bindings they
+had before, you can add the following to your init file:
+
+ (define-key global-map "\M-o\M-s" 'center-line)
+ (define-key global-map "\M-o\M-S" 'center-paragraph)
+
+---
+** The 'M-o M-o' global binding has been removed.
+Use 'M-x font-lock-fontify-block' instead, or the new 'C-x x f'
+command, which updates the syntax highlighting in the current buffer.
+
+---
+** The escape sequence '\e[29~' in Xterm is now mapped to 'menu'.
+Xterm sends this sequence for both 'F16' and 'Menu' keys
+It used to be mapped to 'print' but we couldn't find a terminal
+that uses this sequence for any kind of 'Print' key.
+This makes the Menu key (see https://en.wikipedia.org/wiki/Menu_key)
+work for 'context-menu-mode' in Xterm.
+
+---
+** New user option 'xterm-store-paste-on-kill-ring'.
+If non-nil (the default), Emacs pushes pasted text onto the kill ring
+(if using an xterm-like terminal that supports bracketed paste).
+Setting this to nil inhibits that.
+
+---
+** 'vc-print-branch-log' shows the change log from its root directory.
+It previously used to use the default directory.
+
+---
+** 'project-shell' and 'shell' now use 'pop-to-buffer-same-window'.
+This is to keep the same behavior as Eshell.
+
+---
+** In 'nroff-mode', 'center-line' is no longer bound to a key.
+The original key binding was 'M-s', which interfered with I-search,
+since the latter uses 'M-s' as a prefix key of the search prefix map.
+
+---
+** In 'f90-mode', the backslash character ('\') no longer escapes.
+For about a decade, the backslash character has no longer had a
+special escape syntax in Fortran F90. To get the old behavior back,
+say something like:
+
+ (modify-syntax-entry ?\\ "\\" f90-mode-syntax-table)
+
++++
+** Setting 'fill-column' to nil is obsolete.
+This undocumented use of 'fill-column' is now obsolete. To disable
+auto filling, turn off 'auto-fill-mode' instead.
+
+For instance, you could add something like the following to your init
+file:
+
+ (add-hook 'foo-mode-hook (lambda () (auto-fill-mode -1))
+
+
+* Editing Changes in Emacs 28.1
+
+** Input methods
+
++++
+*** Emacs now supports "transient" input methods.
+A transient input method is enabled for inserting a single character,
+and is then automatically disabled. 'C-x \' temporarily enables the
+selected transient input method. Use 'C-u C-x \' to select a
+transient input method (which can be different from the input method
+enabled by 'C-\'). For example, 'C-u C-x \ compose RET' selects the
+'compose' input method; then typing 'C-x \ 1 2' will insert the
+character '½', and disable the 'compose' input method afterwards.
+You can use 'C-x \' in incremental search to insert a single character
+to the search string.
+
+---
+*** New input method 'compose' based on X Multi_key sequences.
+
+---
+*** New input method 'iso-transl' with the same keys as 'C-x 8'.
+After selecting it as a transient input method with 'C-u C-x \
+iso-transl RET', it supports the same key sequences as 'C-x 8',
+so e.g. like 'C-x 8 [' inserts a left single quotation mark,
+'C-x \ [' does the same.
+
+---
+*** New user option 'read-char-by-name-sort'.
+It defines the sorting order of characters for completion of 'C-x 8 RET TAB'
+and can be customized to sort them by codepoints instead of character names.
+Additionally, you can group characters by Unicode blocks after customizing
+'completions-group' and 'completions-group-sort'.
+
+---
+*** Improved language transliteration in Malayalam input methods.
+Added a new Mozhi scheme. The inapplicable ITRANS scheme is now
+deprecated. Errors in the Inscript method were corrected.
+
+---
+*** New input method 'cham'.
+There's also a Cham greeting in "etc/HELLO".
+
+---
+*** New input methods for Lakota language orthographies.
+Two orthographies are represented here, the Suggested Lakota
+Orthography and what is known as the White Hat Orthography. Input
+methods 'lakota-slo-prefix', 'lakota-slo-postfix', and
+'lakota-white-hat-postfix' have been added. There is also a Lakota
+greeting in "etc/HELLO".
+
++++
+** Standalone 'M-y' allows interactive selection from previous kills.
+'M-y' can now be typed after a command that is not a yank command.
+When invoked like that, it prompts in the minibuffer for one of the
+previous kills, offering completion and minibuffer-history navigation
+through previous kills recorded in the kill ring. A similar feature
+in Isearch can be invoked if you bind 'C-s M-y' to the command
+'isearch-yank-pop'. When the user option 'yank-from-kill-ring-rotate'
+is nil the kill ring is not rotated after 'yank-from-kill-ring'.
+
++++
+** New user option 'word-wrap-by-category'.
+When word-wrap is enabled, and this option is non-nil, that allows
+Emacs to break lines after more characters than just whitespace
+characters. In particular, this significantly improves word-wrapping
+for CJK text mixed with Latin text.
+
++++
+** New command 'undo-redo'.
+It undoes previous undo commands, but doesn't record itself as an
+undoable command. It is bound to 'C-?' and 'C-M-_', the first binding
+works well in graphical mode, and the second one is easy to hit on tty.
+
+For full conventional undo/redo behavior, you can also customize the
+user option 'undo-no-redo' to t.
+
++++
+** New commands 'copy-matching-lines' and 'kill-matching-lines'.
+These commands are similar to the command 'flush-lines',
+but add the matching lines to the kill ring as a single string,
+including the newlines that separate the lines.
+
++++
+** New user option 'kill-transform-function'.
+This can be used to transform (and suppress) strings from entering the
+kill ring.
+
++++
+** 'save-interprogram-paste-before-kill' can now be a number.
+In that case, it's interpreted as a limit on the size of the clipboard
+data that will be saved to the 'kill-ring' prior to killing text: if
+the size of the clipboard data is greater than or equal to the limit,
+it will not be saved.
+
++++
+** New user option 'tab-first-completion'.
+If 'tab-always-indent' is 'complete', this new user option can be used to
+further tweak whether to complete or indent.
+
+---
+** 'indent-tabs-mode' is now a global minor mode instead of just a variable.
+
++++
+** New choice 'permanent' for 'shift-select-mode'.
+When the mark was activated by shifted motion keys, non-shifted motion
+keys don't deactivate the mark after customizing 'shift-select-mode'
+to 'permanent'. Similarly, the active mark will not be deactivated by
+typing shifted motion keys.
+
++++
+** The "Edit => Clear" menu item now obeys a rectangular region.
+
++++
+** New command 'revert-buffer-with-fine-grain'.
+Revert a buffer trying to be as non-destructive as possible,
+preserving markers, properties and overlays. The new variable
+'revert-buffer-with-fine-grain-max-seconds' specifies the maximum
+number of seconds that 'revert-buffer-with-fine-grain' should spend
+trying to be non-destructive, with a default value of 2 seconds.
+
++++
+** New command 'revert-buffer-quick'.
+This is bound to 'C-x x g' and is like 'revert-buffer', but prompts
+less.
+
++++
+** New user option 'revert-buffer-quick-short-answers'.
+This controls how the new 'revert-buffer-quick' ('C-x x g') command
+prompts. A non-nil value will make it use 'y-or-n-p' rather than
+'yes-or-no-p'. Defaults to nil.
+
++++
+** New user option 'query-about-changed-file'.
+If non-nil (the default), Emacs prompts as before when re-visiting a
+file that has changed externally after it was visited the first time.
+If nil, Emacs does not prompt, but instead shows the buffer with its
+contents before the change, and provides instructions how to revert
+the buffer.
+
+---
+** New value 'save-some-buffers-root' of 'save-some-buffers-default-predicate'.
+When using this predicate, only buffers under the current project root
+will be considered when saving buffers with 'save-some-buffers'.
+
+---
+** New user option 'save-place-abbreviate-file-names'.
+This can simplify sharing the 'save-place-file' file across
+different hosts.
+
+---
+** New user options 'copy-region-blink-delay' and 'delete-pair-blink-delay'.
+'copy-region-blink-delay' specifies a delay to indicate the region
+copied by 'kill-ring-save'. 'delete-pair-blink-delay' specifies
+a delay to show the paired character to delete.
+
+---
+** 'zap-up-to-char' now uses 'read-char-from-minibuffer'.
+This allows navigating through the history of characters that have
+been input. This is mostly useful for characters that have complex
+input methods where inputting the character again may involve many
+keystrokes.
+
++++
+** Input history for 'goto-line' can now be made local to every buffer.
+In any event, line numbers used with 'goto-line' are kept in their own
+history list. This should help make faster the process of finding
+line numbers that were previously jumped to. By default, all buffers
+share a single history list. To make every buffer have its own
+history list, customize the user option 'goto-line-history-local'.
+
++++
+** New command 'goto-line-relative' for use in a narrowed buffer.
+It moves point to the line relative to the accessible portion of the
+narrowed buffer. 'M-g M-g' in Info is rebound to this command.
+When 'widen-automatically' is non-nil, 'goto-line' widens the narrowed
+buffer to be able to move point to the inaccessible portion.
+'goto-line-relative' is bound to 'C-x n g'.
+
++++
+** 'goto-char' prompts for the character position.
+When called interactively, 'goto-char' now offers the position at
+point as the default.
+
+** Auto-saving via 'auto-save-visited-mode' can now be inhibited.
+Set the variable 'auto-save-visited-mode' buffer-locally to nil to
+achieve that.
+
++++
+** New command 'kdb-macro-redisplay' to force redisplay in keyboard macros.
+This command is bound to 'C-x C-k d'.
+
+---
+** 'blink-cursor-mode' is now enabled by default regardless of the UI.
+It used to be enabled when Emacs is started in GUI mode but not when started
+in text mode. The cursor still only actually blinks in GUI frames.
+
+** 'show-paren-mode' is now enabled by default.
+To go back to the previous behavior, customize the user option of the
+same name to nil.
+
++++
+** New minor mode 'show-paren-local-mode'.
+It serves as a local counterpart for 'show-paren-mode', allowing you
+to toggle it separately in different buffers. To use it only in
+programming modes, for example, add the following to your init file:
+
+ (add-hook 'prog-mode-hook #'show-paren-local-mode)
+
+
+* Changes in Specialized Modes and Packages in Emacs 28.1
+
+** Isearch and Replace
+
++++
+*** Interactive regular expression search now uses faces for sub-groups.
+E.g., 'C-M-s foo-\([0-9]+\)' will now use the 'isearch-group-1' face
+on the part of the regexp that matches the sub-expression "[0-9]+".
+By default, there are two faces for sub-group highlighting, but you
+can define more faces whose names are of the form 'isearch-group-N',
+where N are successive numbers above 2.
+
+This is controlled by the 'search-highlight-submatches' user option.
+This feature is available only on terminals that have enough colors to
+distinguish between sub-expression highlighting.
+
++++
+*** Interactive regular expression replace now uses faces for sub-groups.
+Like 'search-highlight-submatches', this is controlled by the new user option
+'query-replace-highlight-submatches'.
+
++++
+*** New key 'M-s M-.' starts isearch looking for the thing at point.
+This key is bound to the new command 'isearch-forward-thing-at-point'.
+The new user option 'isearch-forward-thing-at-point' defines
+a list of symbols to try to get the "thing" at point. By default,
+the first element of the list is 'region' that tries to yank
+the currently active region to the search string.
+
++++
+*** New user option 'isearch-wrap-pause' defines how to wrap the search.
+There are choices to disable wrapping completely and to wrap immediately.
+When wrapping immediately, it consistently handles the numeric arguments
+of 'C-s' ('isearch-repeat-forward') and 'C-r' ('isearch-repeat-backward'),
+continuing with the remaining count after wrapping.
+
++++
+*** New user option 'isearch-repeat-on-direction-change'.
+When this option is set, direction changes in Isearch move to another
+search match, if there is one, instead of moving point to the other
+end of the current match.
+
++++
+*** New user option 'isearch-allow-motion'.
+When 'isearch-allow-motion' is set, the commands 'beginning-of-buffer',
+'end-of-buffer', 'scroll-up-command' and 'scroll-down-command', when
+invoked during I-search, move respectively to the first occurrence of
+the current search string in the buffer, the last one, the first one
+after the current window, and the last one before the current window.
+Additionally, users can change the meaning of other motion commands
+during I-search by using their 'isearch-motion' property. The user
+option 'isearch-motion-changes-direction' controls whether the
+direction of the search changes after a motion command.
+
++++
+*** New user option 'lazy-highlight-no-delay-length'.
+Lazy highlighting of matches in Isearch now starts immediately if the
+search string is at least this long. 'lazy-highlight-initial-delay'
+still applies for shorter search strings, which avoids flicker in the
+search buffer due to too many matches being highlighted.
+
++++
+*** The default 'search-whitespace-regexp' value has changed.
+This used to be "\\s-+", which meant that it was mode-dependent whether
+newlines were included in the whitespace set. This has now been
+changed to only match spaces and tab characters.
+
+** Dired
+
++++
+*** New user option 'dired-kill-when-opening-new-dired-buffer'.
+If non-nil, Dired will kill the current buffer when selecting a new
+directory to display.
+
++++
+*** Behavior change on 'dired-do-chmod'.
+As a security precaution, Dired's M command no longer follows symbolic
+links. Instead, it changes the symbolic link's own mode; this always
+fails on platforms where such modes are immutable.
+
+---
+*** Behavior change on 'dired-clean-confirm-killing-deleted-buffers'.
+Previously, if 'dired-clean-up-buffers-too' was non-nil, and
+'dired-clean-confirm-killing-deleted-buffers' was nil, the buffers
+wouldn't be killed. This combination will now kill the buffers.
+
++++
+*** New user option 'dired-switches-in-mode-line'.
+This user option controls how 'ls' switches are displayed in the mode
+line, and allows truncating them (to preserve space on the mode line)
+or showing them literally, either instead of, or in addition to,
+displaying "by name" or "by date" sort order.
+
++++
+*** New user option 'dired-compress-directory-default-suffix'.
+This user option controls the default suffix for compressing a
+directory. If it's nil, ".tar.gz" will be used. Refer to
+'dired-compress-files-alist' for a list of supported suffixes.
+
++++
+*** New user option 'dired-compress-file-default-suffix'.
+This user option controls the default suffix for compressing files.
+If it's nil, ".gz" will be used. Refer to 'dired-compress-file-alist'
+for a list of supported suffixes.
+
+---
+*** Broken and circular links are shown with the 'dired-broken-symlink' face.
+
+---
+*** '=' ('dired-diff') will now put all backup files into the 'M-n' history.
+When using '=' on a file with backup files, the default file to use
+for diffing is the newest backup file. You can now use 'M-n' to quickly
+select a different backup file instead.
+
++++
+*** New user option 'dired-maybe-use-globstar'.
+If set, enables globstar (recursive globbing) in shells that support
+this feature, but have it turned off by default. This allows producing
+directory listings with files matching a wildcard in all the
+subdirectories of a given directory. The new variable
+'dired-enable-globstar-in-shell' lists which shells can have globstar
+enabled, and how to enable it.
+
++++
+*** New user option 'dired-copy-dereference'.
+If set to non-nil, Dired will dereference symbolic links when copying.
+This can be switched off on a per-usage basis by providing
+'dired-do-copy' with a 'C-u' prefix.
+
+---
+*** New user option 'dired-do-revert-buffer'.
+Non-nil reverts the destination Dired buffer after performing one
+of these operations: 'dired-do-copy', 'dired-do-rename',
+'dired-do-symlink', 'dired-do-hardlink'.
+
+---
+*** New user option 'dired-mark-region'.
+This option affects all Dired commands that mark files. When non-nil
+and the region is active in Transient Mark mode, then Dired commands
+operate only on files in the active region. The values 'file' and
+'line' of this user option define the details of marking the file at
+the end of the region.
+
++++
+*** State changing VC operations are supported in Dired.
+These operations are supported on files and directories via the new
+command 'dired-vc-next-action'.
+
++++
+*** 'dired-jump' and 'dired-jump-other-window' moved from 'dired-x' to 'dired'.
+The 'dired-jump' and 'dired-jump-other-window' commands have been
+moved from the 'dired-x' package to 'dired'. The user option
+'dired-bind-jump' no longer has any effect and is now obsolete.
+The commands are now bound to 'C-x C-j' and 'C-x 4 C-j' by default.
+
+To get the old behavior of 'dired-bind-jump' back and unbind the above
+keys, add the following to your init file:
+
+ (global-set-key "\C-x\C-j" nil)
+ (global-set-key "\C-x4\C-j" nil)
+
+---
+*** 'dired-query' now uses 'read-char-from-minibuffer'.
+Using it instead of 'read-char-choice' allows using 'C-x o'
+to switch to the help window displayed after typing 'C-h'.
+
++++
+** Emacs 28.1 comes with Org v9.5.
+See the file ORG-NEWS for user-visible changes in Org.
+
+** Outline
+
++++
+*** New commands to cycle heading visibility.
+Typing 'TAB' on a heading line cycles the current section between
+"hide all", "subheadings", and "show all" states. Typing 'S-TAB'
+anywhere in the buffer cycles the whole buffer between "only top-level
+headings", "all headings and subheadings", and "show all" states.
+
++++
+*** New user option 'outline-minor-mode-cycle'.
+This user option customizes 'outline-minor-mode', with the difference
+that 'TAB' and 'S-TAB' on heading lines cycle heading visibility.
+Typing 'TAB' on a heading line cycles the current section between
+"hide all", "subheadings", and "show all" states. Typing 'S-TAB' on a
+heading line cycles the whole buffer between "only top-level
+headings", "all headings and subheadings", and "show all" states.
+
+---
+*** New user option 'outline-minor-mode-highlight'.
+This user option customizes 'outline-minor-mode'. It puts
+highlighting on heading lines using standard outline faces. This
+works well only when there are no conflicts with faces used by the
+major mode.
+
+** Ispell
+
++++
+*** 'ispell-comments-and-strings' now accepts START and END arguments.
+These arguments default to the active region when used interactively.
+
++++
+*** New command 'ispell-comment-or-string-at-point'.
+
+---
+*** New user option 'ispell-help-timeout'.
+This controls how long the ispell help (on the '?' key) is displayed.
+
+** Flyspell mode
+
++++
+*** Corrections and actions menu can be optionally bound to 'mouse-3'.
+When Flyspell mode highlights a word as misspelled, you can click on
+it to display a menu of possible corrections and actions. You can now
+easily bind this menu to 'down-mouse-3' (usually the right mouse button)
+instead of 'mouse-2' (the default) by enabling 'context-menu-mode'.
+
+---
+*** The current dictionary is now displayed in the minor mode lighter.
+Clicking the dictionary name changes the current dictionary.
+
+** Package
+
+*** The new NonGNU ELPA archive is enabled by default alongside GNU ELPA.
+Thus, packages on NonGNU ELPA will appear by default in the list shown
+by 'list-packages'.
+
+---
+*** '/ s' ('package-menu-filter-by-status') changed parameter handling.
+The command was documented to take a comma-separated list of statuses
+to filter by, but instead it used the parameter as a regexp. The
+command has been changed so that it now works as documented, and
+checks statuses not as a regexp, but instead an exact match from the
+comma-separated list.
+
++++
+*** New command 'package-browse-url' and keystroke 'w'.
+
++++
+*** New commands to filter the package list.
+The filter commands are bound to the following keys:
+
+key binding
+--- -------
+/ a package-menu-filter-by-archive
+/ d package-menu-filter-by-description
+/ k package-menu-filter-by-keyword
+/ N package-menu-filter-by-name-or-description
+/ n package-menu-filter-by-name
+/ s package-menu-filter-by-status
+/ v package-menu-filter-by-version
+/ m package-menu-filter-marked
+/ u package-menu-filter-upgradable
+/ / package-menu-filter-clear
+
+*** Option to automatically native-compile packages upon installation.
+Customize the user option 'package-native-compile' to enable automatic
+native compilation of packages when they are installed. That option
+is nil by default; if set non-nil, and if your Emacs was built with
+native-compilation support, each package will be natively compiled
+when it is installed, by invoking an asynchronous Emacs subprocess to
+run the native-compilation of the package files. (Be sure to leave
+Emacs running until these asynchronous subprocesses exit, or else the
+native-compilation will be aborted when you exit Emacs.)
+
+---
+*** Column widths in 'list-packages' display can now be customized.
+See the new user options 'package-name-column-width',
+'package-version-column-width', 'package-status-column-width', and
+'package-archive-column-width'.
+
+** Info
+
+---
+*** New user option 'Info-warn-on-index-alternatives-wrap'.
+This option affects what happens when using the ',' command after
+looking up an entry with 'i' in info buffers. If non-nil (the
+default), the ',' command will now display a warning when proceeding
+beyond the final index match, and tapping ',' once more will then take
+you to the first match.
+
+** Abbrev mode
+
++++
+*** Emacs can now suggest to use an abbrev based on text you type.
+A new user option, 'abbrev-suggest', enables the new abbrev suggestion
+feature. When enabled, if a user manually types a piece of text that
+could have saved enough typing by using an abbrev, a hint will be
+displayed in the echo area, mentioning the abbrev that could have been
+used instead.
+
+** Bookmarks
+
+---
+*** Bookmarks can now be targets for new tabs.
+When the bookmark.el library is loaded, a customize choice is added
+to 'tab-bar-new-tab-choice' for new tabs to show the bookmark list.
+
+---
+*** New user option 'bookmark-set-fringe-mark'.
+If non-nil, setting a bookmark will set a fringe mark on the current
+line, and jumping to a bookmark will also set this mark.
+
+---
+*** New user option 'bookmark-menu-confirm-deletion'.
+In Bookmark Menu mode, Emacs by default does not prompt for
+confirmation when you type 'x' to execute the deletion of bookmarks
+that have been marked for deletion. However, if this new option is
+non-nil then Emacs will require confirmation with 'yes-or-no-p' before
+deleting.
+
+---
+*** The 'list-bookmarks' menu is now based on 'tabulated-list-mode'.
+The interactive bookmark list will now benefit from features in
+'tabulated-list-mode' like sorting columns or changing column width.
+
+Support for the optional "inline" header line, allowing for a
+header without using 'header-line-format', has been dropped.
+The variables 'bookmark-bmenu-use-header-line' and
+'bookmark-bmenu-inline-header-height' are now obsolete.
+
+** Recentf
+
+---
+*** The recentf files are no longer backed up.
+
+---
+*** 'recentf-auto-cleanup' now repeats daily when set to a time string.
+When 'recentf-auto-cleanup' is set to a time string, it now repeats
+every day, rather than only running once after the mode is turned on.
+
+** Calc
+
+---
+*** The behavior when doing forward-delete has been changed.
+Previously, using the 'C-d' command would delete the final number in
+the input field, no matter where point was. This has been changed to
+work more traditionally, with 'C-d' deleting the next character.
+Likewise, point isn't moved to the end of the string before inserting
+digits.
+
++++
+*** Setting the word size to zero disables word clipping.
+The word size normally clips the results of certain bit-oriented
+operations such as shifts and bitwise XOR. A word size of zero, set
+by 'b w', makes the operation have effect on the whole argument values
+and the result is not truncated in any way.
+
+---
+*** The '/' operator now has higher precedence in (La)TeX input mode.
+It no longer has lower precedence than '+' and '-'.
+
+---
+*** New user option 'calc-make-windows-dedicated'.
+When this user option is non-nil, Calc will mark its windows as
+dedicated.
+
+** Calendar
+
++++
+*** New user option 'calendar-time-zone-style'.
+If 'numeric', calendar functions (eg 'calendar-sunrise-sunset') that display
+time zones will use a form like "+0100" instead of "CET".
+
+** Imenu
+
++++
+*** New user option 'imenu-max-index-time'.
+If creating the imenu index takes longer than specified by this
+option (default 5 seconds), imenu indexing is stopped.
+
+** ido
+
+---
+*** Switching on 'ido-mode' now also overrides 'ffap-file-finder'.
+
+---
+*** Killing virtual ido buffers interactively will make them go away.
+Previously, killing a virtual ido buffer with 'ido-kill-buffer' didn't
+do anything. This has now been changed, and killing virtual buffers
+with that command will remove the buffer from recentf.
+
+** So Long
+
+---
+*** New 'so-long-predicate' function 'so-long-statistics-excessive-p'.
+It efficiently detects the presence of a long line anywhere in the
+buffer using 'buffer-line-statistics' (see above). This is now the
+default predicate (replacing 'so-long-detected-long-line-p').
+
+---
+*** Default values 'so-long-threshold' and 'so-long-max-lines' increased.
+The values of these user options have been raised to 10000 bytes and 500
+lines respectively, to reduce the likelihood of false-positives when
+'global-so-long-mode' is enabled. The latter value is now only used
+by the old predicate, as the new predicate knows the longest line in
+the entire buffer.
+
+---
+*** 'so-long-target-modes' now includes 'fundamental-mode' by default.
+This means that 'global-so-long-mode' will also process files which were
+not recognised. (This only has an effect if 'set-auto-mode' chooses
+'fundamental-mode'; buffers which are simply in 'fundamental-mode' by
+default are unaffected.)
+
+---
+*** New user options to preserve modes and variables.
+The new options 'so-long-mode-preserved-minor-modes' and
+'so-long-mode-preserved-variables' allow specified mode and variable
+states to be maintained if 'so-long-mode' replaces the original major
+mode. By default, these new options support 'view-mode'.
+
+** Grep
+
++++
+*** New user option 'grep-match-regexp' matches grep markers to highlight.
+Grep emits SGR ANSI escape sequences to color its output. The new
+user option 'grep-match-regexp' holds the regular expression to match
+the appropriate markers in order to provide highlighting in the source
+buffer. The user option can be customized to accommodate other
+grep-like tools.
+
+---
+*** The 'lgrep' command now ignores directories.
+On systems where the grep command supports it, directories will be
+skipped.
+
+*** Commands that use 'grep-find' now follow symlinks for command-line args.
+This is because the default value of 'grep-find-template' now includes
+the 'find' option '-H'. Commands that use that variable, including
+indirectly via a call to 'xref-matches-in-directory', might be
+affected. In particular, there should be no need anymore to ensure
+any directory names on the 'find' command lines end in a slash.
+This change is for better compatibility with old versions of non-GNU
+'find', such as the one used on macOS.
+
+---
+*** New utility function 'grep-file-at-point'.
+This returns the name of the file at point (if any) in 'grep-mode'
+buffers.
+
+** Shell
+
+---
+*** New command in 'shell-mode': 'narrow-to-prompt'.
+This is bound to 'C-x n d' in 'shell-mode' buffers, and narrows to the
+command line under point (and any following output).
+
+---
+*** New user option 'shell-has-auto-cd'.
+If non-nil, 'shell-mode' handles implicit "cd" commands, changing the
+directory if the command is a directory. Useful for shells like "zsh"
+that has this feature.
+
+** term-mode
+
+---
+*** New user option 'term-scroll-snap-to-bottom'.
+By default, 'term' and 'ansi-term' will now recenter the buffer so
+that the prompt is on the final line in the window. Setting this new
+user option to nil inhibits this behavior.
+
+---
+*** New user option 'term-set-terminal-size'
+If non-nil, the 'LINES' and 'COLUMNS' environment variables will be set
+based on the current window size. In previous versions of Emacs, this
+was always done (and that could lead to odd displays when resizing the
+window after starting). This variable defaults to nil.
+
+---
+*** 'term-mode' now supports "bright" color codes.
+"Bright" ANSI color codes are now displayed using the color values
+defined in 'term-color-bright-*'. In addition, bold text with regular
+ANSI colors can be displayed as "bright" if 'ansi-color-bold-is-bright'
+is non-nil.
+
+** Eshell
+
+---
+*** 'eshell-hist-ignoredups' can now also be used to mimic "erasedups" in bash.
+
+---
+*** Environment variable 'INSIDE_EMACS' is now copied to subprocesses.
+Its value contains the result of evaluating '(format "%s,eshell"
+emacs-version)'. Other package names, like "tramp", could also be included.
+
+---
+*** Eshell no longer re-initializes its keymap every call.
+This allows users to use (define-key eshell-mode-map ...) as usual.
+Some modules have their own minor mode now to account for these
+changes.
+
+*** Support for bookmark.el.
+The command 'bookmark-set' (bound to 'C-x r m') is now supported, and
+will create a bookmark that opens the current directory in Eshell.
+
+** Archive mode
+
+---
+*** Archive Mode can now parse ".squashfs" files.
+
+*** Can now modify members of 'ar' archives.
+
+*** Display of summaries is unified between backends.
+
+*** New user option and command to control displayed columns.
+New user option 'archive-hidden-columns' and new command
+'archive-hideshow-column' let you control which columns are displayed
+and which are kept hidden.
+
+---
+*** New command bound to 'C': 'archive-copy-file'.
+This command extracts the file at point and writes its data to a
+file.
+
+** browse-url
+
+*** Added support for custom URL handlers.
+There is a new variable 'browse-url-default-handlers' and a user
+option 'browse-url-handlers' being alists with '(REGEXP-OR-PREDICATE
+. FUNCTION)' entries allowing to define different browsing FUNCTIONs
+depending on the URL to be browsed. The variable is for default
+handlers provided by Emacs itself or external packages, the user
+option is for the user (and allows for overriding the default
+handlers).
+
+Formerly, one could do the same by setting
+'browse-url-browser-function' to such an alist. This usage is still
+supported but deprecated.
+
+*** Categorization of browsing commands into internal vs. external.
+All standard browsing commands such as 'browse-url-firefox',
+'browse-url-mail', or 'eww' have been categorized into internal (URL
+is browsed in Emacs) or external (an external application is spawned
+with the URL). This is done by adding a 'browse-url-browser-kind'
+symbol property to the browsing commands. With a new command
+'browse-url-with-browser-kind', an URL can explicitly be browsed with
+either an internal or external browser.
+
+---
+*** Support for browsing of remote files.
+If a remote file is specified, a local temporary copy of that file is
+passed to the browser.
+
+---
+*** Support for the conkeror browser is now obsolete.
+
+---
+*** Support for the Mosaic browser has been removed.
+This support has been obsolete since 25.1.
+
+** Completion List Mode
+
+*** Improved navigation in the "*Completions*" buffer.
+New key bindings have been added to 'completion-list-mode': 'n' and
+'p' now navigate completions, and 'M-g M-c' switches to the
+minibuffer and back to the completion list buffer.
+
++++
+** profiler.el
+The results displayed by 'profiler-report' now have the usage figures
+at the left hand side followed by the function name. This is intended
+to make better use of the horizontal space, in particular eliminating
+the truncation of function names. There is no way to get the former
+layout back.
+
+** Icomplete
+
+---
+*** New user option 'icomplete-matches-format'.
+This allows controlling the current/total number of matches for the
+prompt prefix.
+
++++
+*** New minor modes 'icomplete-vertical-mode' and 'fido-vertical-mode'.
+These modes modify Icomplete ('M-x icomplete-mode') and Fido ('M-x
+fido-mode'), to display completion candidates vertically instead of
+horizontally. In Icomplete, completions are rotated and selection
+kept at the top. In Fido, completions scroll like a typical dropdown
+widget. Both these new minor modes will turn on their non-vertical
+counterparts first, if they are not on already.
+
+---
+*** Default value of 'icomplete-compute-delay' has been changed to 0.15 s.
+
+---
+*** Default value of 'icomplete-max-delay-chars' has been changed to 2.
+
+---
+*** Reduced blinking while completing the next completions set.
+Icomplete doesn't hide the hint with the previously computed
+completions anymore when compute delay is in effect, or the previous
+computation has been aborted by input. Instead it shows the previous
+completions until the new ones are ready.
+
+---
+*** Change in meaning of 'icomplete-show-matches-on-no-input'.
+Previously, choosing a different completion with commands like 'C-.'
+and then hitting 'RET' would choose the default completion. Doing this
+will now choose the completion under point instead. Also when this option
+is nil, completions are not shown when the minibuffer reads a file name
+with initial input as the default directory.
+
+** Windmove
+
++++
+*** New user options to customize windmove keybindings.
+These options include 'windmove-default-keybindings',
+'windmove-display-default-keybindings',
+'windmove-delete-default-keybindings',
+'windmove-swap-states-default-keybindings'.
+Also new mode 'windmove-mode' enables the customized keybindings.
+
+** Occur mode
+
+---
+*** New bindings in occur-mode.
+The command 'next-error-no-select' is now bound to 'n' and
+'previous-error-no-select' is bound to 'p'.
+
+---
+*** New command 'recenter-current-error'.
+It is bound to 'l' in Occur or compilation buffers, and recenters the
+current displayed occurrence/error.
+
+---
+*** Matches in target buffers are now highlighted as in 'compilation-mode'.
+The method of highlighting is specified by the user options
+'next-error-highlight' and 'next-error-highlight-no-select'.
+
+---
+*** A fringe arrow in the "*Occur*" buffer indicates the selected match.
+
+---
+*** Occur mode may use a different type for 'occur-target' property values.
+The value was previously always a marker set to the start of the first
+match on the line but can now also be a list of '(BEGIN . END)' pairs
+of markers delimiting each match on the line.
+This is a fully compatible change to the internal occur-mode
+implementation, and code creating their own occur-mode buffers will
+work as before.
+
+** Emacs Lisp mode
+
+---
+*** The mode-line now indicates whether we're using lexical or dynamic scoping.
+
++++
+*** A space between an open paren and a symbol changes the indentation rule.
+The presence of a space between an open paren and a symbol now is
+taken as a statement by the programmer that this should be indented
+as a data list rather than as a piece of code.
+
+** Lisp Mode
+
+*** New minor mode 'cl-font-lock-built-in-mode' for 'lisp-mode'.
+The mode provides refined highlighting of built-in functions, types,
+and variables.
+
+---
+*** Lisp mode now uses 'common-lisp-indent-function'.
+To revert to the previous behavior,
+'(setq lisp-indent-function 'lisp-indent-function)' from 'lisp-mode-hook'.
+
+** Change Logs and VC
+
++++
+*** 'vc-revert-show-diff' now has a third possible value: 'kill'.
+If this user option is 'kill', then the diff buffer will be killed
+after the 'vc-revert' action instead of buried.
+
+---
+*** More VC commands can be used from non-file buffers.
+The relevant commands are those that don't change the VC state.
+The non-file buffers which can use VC commands are those that have
+their 'default-directory' under VC.
+
+---
+*** New face 'log-view-commit-body'.
+This is used when expanding commit messages from 'vc-print-root-log'
+and similar commands.
+
+---
+*** New faces for 'vc-dir' buffers.
+Those are: 'vc-dir-header', 'vc-dir-header-value', 'vc-dir-directory',
+'vc-dir-file', 'vc-dir-mark-indicator', 'vc-dir-status-warning',
+'vc-dir-status-edited', 'vc-dir-status-up-to-date',
+'vc-dir-status-ignored'.
+
+---
+*** The responsible VC backend is now the most specific one.
+'vc-responsible-backend' loops over the backends in
+'vc-handled-backends' to determine which backend is responsible for a
+specific (unregistered) file. Previously, the first matching backend
+was chosen, but now the one with the most specific path is chosen (in
+case there's a directory handled by one backend inside another).
+
+---
+*** New command 'vc-dir-root' uses the root directory without asking.
+
+---
+*** New commands 'vc-dir-mark-registered-files' (bound to '* r') and
+'vc-dir-mark-unregistered-files'.
+
+---
+*** Support for bookmark.el.
+Bookmark locations can refer to VC directory buffers.
+
+---
+*** New user option 'vc-hg-create-bookmark'.
+It controls whether a bookmark or branch will be created when you
+invoke 'C-u C-x v s' ('vc-create-tag').
+
+---
+*** 'vc-hg' now uses 'hg summary' to populate extra 'vc-dir' headers.
+
+---
+*** New user option 'vc-git-revision-complete-only-branches'.
+If non-nil, only branches and remotes are considered when doing
+completion over Git branch names. The default is nil, which causes
+tags to be considered as well.
+
+---
+*** New user option 'vc-git-log-switches'.
+String or list of strings specifying switches for Git log under VC.
+
+---
+*** Command 'vc-switch-backend' is now obsolete.
+If you are still using it with any regularity, please file a bug
+report with some details.
+
+** Gnus
+
++++
+*** New user option 'gnus-topic-display-predicate'.
+This can be used to inhibit the display of some topics completely.
+
++++
+*** nnimap now supports the oauth2.el library.
+
++++
+*** New Summary buffer sort options for extra headers.
+The extra header sort option ('C-c C-s C-x') prompts for a header
+and fails if no sort function has been defined. Sorting by
+Newsgroups ('C-c C-s C-u') has been pre-defined.
+
++++
+*** The '#' command in the Group and Summary buffer now toggles,
+instead of sets, the process mark.
+
++++
+*** New user option 'gnus-process-mark-toggle'.
+If non-nil (the default), the '#' command in the Group and Summary
+buffers will toggle, instead of set, the process mark.
+
++++
+*** New user option 'gnus-registry-register-all'.
+If non-nil (the default), create registry entries for all messages.
+If nil, don't automatically create entries, they must be created
+manually.
+
++++
+*** New user options to customise the summary line specs "%[" and "%]".
+Four new options introduced in customisation group
+'gnus-summary-format'. These are 'gnus-sum-opening-bracket',
+'gnus-sum-closing-bracket', 'gnus-sum-opening-bracket-adopted', and
+'gnus-sum-closing-bracket-adopted'. Their default values are "[", "]",
+"<", ">" respectively. These options control the appearance of "%["
+and "%]" specs in the summary line format. "%[" will normally display
+the value of 'gnus-sum-opening-bracket', but can also be
+'gnus-sum-opening-bracket-adopted' for the adopted articles. "%]" will
+normally display the value of 'gnus-sum-closing-bracket', but can also
+be 'gnus-sum-closing-bracket-adopted' for the adopted articles.
+
++++
+*** New user option 'gnus-paging-select-next'.
+This controls what happens when using commands like 'SPC' and 'DEL' to
+page the current article. If non-nil (the default), go to the
+next/prev article, but if nil, do nothing at the end/start of the article.
+
++++
+*** New gnus-search library.
+A new unified search syntax which can be used across multiple
+supported search engines. Set 'gnus-search-use-parsed-queries' to
+non-nil to enable.
+
++++
+*** New value for user option 'smiley-style'.
+Smileys can now be rendered with emojis instead of small images when
+using the new 'emoji' value in 'smiley-style'.
+
++++
+*** New user option 'gnus-agent-eagerly-store-articles'.
+If non-nil (which is the default), the Gnus Agent will store all read
+articles in the Agent cache.
+
++++
+*** New user option 'gnus-global-groups'.
+Gnus handles private groups differently from public (i.e., NNTP-like)
+groups. Most importantly, Gnus doesn't download external images from
+mail-like groups. This can be overridden by putting group names in
+'gnus-global-groups': Any group present in that list will be treated
+like a public group.
+
++++
+*** New scoring types for the Date header.
+You can now score based on the relative age of an article with the new
+'<' and '>' date scoring types.
+
++++
+*** User-defined scoring is now possible.
+The new type is 'score-fn'. More information in the Gnus manual node
+"(gnus) Score File Format".
+
++++
+*** New backend 'nnselect'.
+The newly added 'nnselect' backend allows creating groups from an
+arbitrary list of articles that may come from multiple groups and
+servers. These groups generally behave like any other group: they may
+be ephemeral or persistent, and allow article marking, moving,
+deletion, etc. 'nnselect' groups may be created like any other group,
+but there are three convenience functions for the common case of
+obtaining the list of articles as a result of a search:
+'gnus-group-make-search-group' ('G g') that will prompt for an 'nnir'
+search query and create a persistent group for that search;
+'gnus-group-read-ephemeral-search-group' ('G G') that will prompt for
+an 'nnir' search query and create an ephemeral group for that search;
+and 'gnus-summary-make-group-from-search' ('C-c C-p') that will create
+a persistent group with the search parameters of a current ephemeral
+search group.
+
+As part of this addition, the user option 'nnir-summary-line-format'
+has been removed; its functionality is now available directly in the
+'gnus-summary-line-format' specs '%G' and '%g'. The user option
+'gnus-refer-thread-use-nnir' has been renamed to
+'gnus-refer-thread-use-search'.
+
++++
+*** New user option 'gnus-dbus-close-on-sleep'.
+On systems with D-Bus support, it is now possible to register a signal
+to close all Gnus servers before the system sleeps.
+
++++
+*** The key binding of 'gnus-summary-search-article-forward' has changed.
+This command was previously on 'M-s' and shadowed the global 'M-s'
+search prefix. The command has now been moved to 'M-s M-s'. (For
+consistency, the 'M-s M-r' key binding has been added for the
+'gnus-summary-search-article-backward' command.)
+
+---
+*** The value for "all" in the 'large-newsgroup-initial' group parameter has changed.
+It was previously nil, which didn't work, because nil is
+indistinguishable from not being present. The new value for "all" is
+the symbol 'all'.
+
++++
+*** The name of dependent Gnus sessions has changed from "slave" to "child".
+The names of the commands 'gnus-slave', 'gnus-slave-no-server' and
+'gnus-slave-unplugged' have changed to 'gnus-child',
+'gnus-child-no-server' and 'gnus-child-unplugged' respectively.
+
++++
+*** The 'W Q' summary mode command now takes a numerical prefix to
+allow adjusting the fill width.
+
++++
+*** New variable 'mm-inline-font-lock'.
+This variable is supposed to be bound by callers to determine whether
+inline MIME parts (that support it) are supposed to be font-locked or
+not.
+
+** Message
+
+---
+*** Respect 'message-forward-ignored-headers' more.
+Previously, this user option would not be consulted if
+'message-forward-show-mml' was nil and forwarding as MIME.
+
++++
+*** New user option 'message-forward-included-mime-headers'.
+This is used when forwarding messages as MIME, but not using MML.
+
++++
+*** Message now supports the OpenPGP header.
+To generate these headers, add the new function
+'message-add-openpgp-header' to 'message-send-hook'. The header will
+be generated according to the new 'message-openpgp-header' user
+option.
+
+---
+*** A change to how "Mail-Copies-To: never" is handled.
+If a user has specified "Mail-Copies-To: never", and Message was asked
+to do a "wide reply", some other arbitrary recipient would end up in
+the resulting "To" header, while the remaining recipients would be put
+in the "Cc" header. This is somewhat misleading, as it looks like
+you're responding to a specific person in particular. This has been
+changed so that all the recipients are put in the "To" header in these
+instances.
+
++++
+*** New command to start Emacs in Message mode to send an email.
+Emacs can be defined as a handler for the "x-scheme-handler/mailto"
+MIME type with the following command: "emacs -f message-mailto %u".
+An "emacs-mail.desktop" file has been included, suitable for
+installing in desktop directories like "/usr/share/applications" or
+"~/.local/share/applications".
+Clicking on a 'mailto:' link in other applications will then open
+Emacs with headers filled out according to the link, e.g.
+"mailto:larsi@gnus.org?subject=This+is+a+test". If you prefer
+emacsclient, use "emacsclient -e '(message-mailto "%u")'"
+or "emacsclient-mail.desktop".
+
+---
+*** Change to default value of 'message-draft-headers' user option.
+The 'Date' symbol has been removed from the default value, meaning that
+draft or delayed messages will get a date reflecting when the message
+was sent. To restore the original behavior of dating a message
+from when it is first saved or delayed, add the symbol 'Date' back to
+this user option.
+
++++
+*** New command to take screenshots.
+In Message mode buffers, the 'C-c C-p' ('message-insert-screenshot')
+command has been added. It depends on using an external program to
+take the actual screenshot, and defaults to "ImageMagick import".
+
+** Smtpmail
+
++++
+*** smtpmail now supports using the oauth2.el library.
+
++++
+*** New user option 'smtpmail-store-queue-variables'.
+If non-nil, SMTP variables will be stored together with the queued
+messages, and will then be used when sending with
+'M-x smtpmail-send-queued-mail'.
+
++++
+*** Allow direct selection of smtp authentication mechanism.
+A server entry retrieved by auth-source can request a desired smtp
+authentication mechanism by setting a value for the key 'smtp-auth'.
+
+** ElDoc
+
++++
+*** New user option 'eldoc-echo-area-display-truncation-message'.
+If non-nil (the default), eldoc will display a message saying
+something like "(Documentation truncated. Use `M-x eldoc-doc-buffer'
+to see rest)" when a message has been truncated. If nil, truncated
+messages will be marked with just "..." at the end.
+
++++
+*** New hook 'eldoc-documentation-functions'.
+This hook is intended to be used for registering doc string functions.
+These functions don't need to produce the doc string right away, they
+may arrange for it to be produced asynchronously. The results of all
+doc string functions are accessible to the user through the user
+option 'eldoc-documentation-strategy'.
+
+*** New hook 'eldoc-display-functions'.
+This hook is intended to be used for displaying doc strings. The
+functions receive the doc string composed according to
+'eldoc-documentation-strategy' and are tasked with displaying it to
+the user. Examples of such functions would use the echo area, a
+separate buffer, or a tooltip.
+
++++
+*** New user option 'eldoc-documentation-strategy'.
+The built-in choices available for this user option let users compose
+the results of 'eldoc-documentation-functions' in various ways, even
+if some of those functions are synchronous and some asynchronous.
+The user option replaces 'eldoc-documentation-function', which is now
+obsolete.
+
+*** 'eldoc-echo-area-use-multiline-p' is now handled by ElDoc.
+The user option 'eldoc-echo-area-use-multiline-p' is now handled
+by the ElDoc library itself. Functions in
+'eldoc-documentation-functions' don't need to worry about consulting
+it when producing a doc string.
+
+** Tramp
+
++++
+*** New connection method "mtp".
+It allows accessing media devices like cell phones, tablets or
+cameras.
+
++++
+*** New connection method "sshfs".
+It allows accessing remote files via a file system mounted with
+'sshfs'.
+
++++
+*** Tramp supports SSH authentication via a hardware security key now.
+This requires at least OpenSSH 8.2, and a FIDO U2F compatible
+security key, like yubikey, solokey, or nitrokey.
+
++++
+*** Trashed remote files are moved to the local trash directory.
+All remote files that are trashed are moved to the local trash
+directory, except remote encrypted files, which are always deleted.
+
++++
+*** New command 'tramp-crypt-add-directory'.
+This command marks a remote directory to contain only encrypted files.
+See the "(tramp) Keeping files encrypted" node of the Tramp manual for
+details. This feature is experimental.
+
++++
+*** Support of direct asynchronous process invocation.
+When Tramp connection property "direct-async-process" is set to
+non-nil for a given connection, 'make-process' and 'start-file-process'
+calls are performed directly as in "ssh ... <command>". This avoids
+initialization performance penalties. See the "(tramp) Improving
+performance of asynchronous remote processes" node of the Tramp manual
+for details, and also for a discussion or restrictions. This feature
+is experimental.
+
++++
+*** New user option 'tramp-debug-to-file'.
+When non-nil, this user option instructs Tramp to mirror the debug
+buffer to a file under the "/tmp/" directory. This is useful, if (in
+rare cases) Tramp blocks Emacs, and we need further debug information.
+
++++
+*** Tramp supports lock files now.
+In order to deactivate this, set user option
+'remote-file-name-inhibit-locks' to t.
+
++++
+*** Writing sensitive data locally requires confirmation.
+Writing auto-save, backup or lock files to the local temporary
+directory must be confirmed. In order to suppress this confirmation,
+set user option 'tramp-allow-unsafe-temporary-files' to t.
+
++++
+*** 'make-directory' of a remote directory honors the default file modes.
+
+** gdb-mi
+
+*** New user option 'gdb-registers-enable-filter'.
+If non-nil, apply a register filter based on
+'gdb-registers-filter-pattern-list'.
+
++++
+*** gdb-mi can now save and restore window configurations.
+Use 'gdb-save-window-configuration' to save window configuration to a
+file and 'gdb-load-window-configuration' to load from a file. These
+commands can also be accessed through the menu bar under "Gud =>
+GDB-Windows". 'gdb-default-window-configuration-file', when non-nil,
+is loaded when GDB starts up.
+
++++
+*** gdb-mi can now restore window configuration after quitting.
+Set 'gdb-restore-window-configuration-after-quit' to non-nil and Emacs
+will remember the window configuration before GDB started and restore
+it after GDB quits. A toggle button is also provided under "Gud =>
+GDB-Windows" menu item.
+
++++
+*** gdb-mi now has a better logic for displaying source buffers.
+Now GDB only uses one source window to display source file by default.
+Customize 'gdb-max-source-window-count' to use more than one window.
+Control source file display by 'gdb-display-source-buffer-action'.
+
++++
+*** The default value of 'gdb-mi-decode-strings' is now t.
+This means that the default coding-system is now used to decode strings
+and source file names from GDB.
+
+** Compilation mode
+
+---
+*** New function 'ansi-color-compilation-filter'.
+This function is meant to be used in 'compilation-filter-hook'.
+
+---
+*** New user option 'ansi-color-for-compilation-mode'.
+This controls what 'ansi-color-compilation-filter' does.
+
+*** Regexp matching of messages is now case-sensitive by default.
+The variable 'compilation-error-case-fold-search' can be set for
+case-insensitive matching of messages when the old behavior is
+required, but the recommended solution is to use a correctly matching
+regexp instead.
+
+---
+*** New user option 'compilation-search-all-directories'.
+When doing parallel builds, directories and compilation errors may
+arrive in the "*compilation*" buffer out-of-order. If this option is
+non-nil (the default), Emacs will now search backwards in the buffer
+for any directory the file with errors may be in. If nil, this won't
+be done (and this restores how this previously worked).
+
+---
+*** Messages from ShellCheck are now recognized.
+
+---
+*** Messages from Visual Studio that mention column numbers are now recognized.
+
+** Hi Lock mode
+
+---
+*** Matching in 'hi-lock-mode' can be case-sensitive.
+The matching is case-sensitive when a regexp contains upper case
+characters and 'search-upper-case' is non-nil. 'highlight-phrase'
+also uses 'search-whitespace-regexp' to substitute spaces in regexp
+search.
+
+---
+*** The default value of 'hi-lock-highlight-range' was enlarged.
+The new default value is 2000000 (2 megabytes).
+
+** Whitespace mode
+
++++
+*** New style 'missing-newline-at-eof'.
+If present in 'whitespace-style' (as it is by default), the final
+character in the buffer will be highlighted if the buffer doesn't end
+with a newline.
+
+---
+*** The default 'whitespace-enable-predicate' predicate has changed.
+It used to check elements in the list version of
+'whitespace-global-modes' with 'eq', but now uses 'derived-mode-p'.
+
+** Texinfo
+
+---
+*** New user option 'texinfo-texi2dvi-options'.
+This is used when invoking 'texi2dvi' from 'texinfo-tex-buffer'.
+
+---
+*** New commands for moving in and between environments.
+An "environment" is something that ends with '@end'. The commands are
+'C-c C-c C-f' (next end), 'C-c C-c C-b' (previous end),
+'C-c C-c C-n' (next start) and 'C-c C-c C-p' (previous start), as well
+as 'C-c .', which will alternate between the start and the end of the
+current environment.
+
+** Rmail
+
+---
+*** New user option 'rmail-re-abbrevs'.
+Its default value matches localized abbreviations of the "reply"
+prefix on the Subject line in various languages.
+
+---
+*** New user option 'rmail-show-message-set-modified'.
+If set non-nil, showing an unseen message will set the Rmail buffer's
+modified flag. The default is nil, to preserve the old behavior.
+
+** CC Mode
+
++++
+*** Added support for Doxygen documentation style.
+'doxygen' is now a valid 'c-doc-comment-style' which recognises all
+comment styles supported by Doxygen (namely '///', '//!', '/** … */'
+and '/*! … */'. 'gtkdoc' remains the default for C and C++ modes; to
+use 'doxygen' by default one might evaluate:
+
+ (setq-default c-doc-comment-style
+ '((java-mode . javadoc)
+ (pike-mode . autodoc)
+ (c-mode . doxygen)
+ (c++-mode . doxygen)))
+
+or use it in a custom 'c-style'.
+
++++
+*** Added support to line up '?' and ':' of a ternary operator.
+The new 'c-lineup-ternary-bodies' function can be used as a lineup
+function to align question mark and colon which are part of a ternary
+operator ('?:'). For example:
+
+ return arg % 2 == 0 ? arg / 2
+ : (3 * arg + 1);
+
+To enable, add it to appropriate entries in 'c-offsets-alist', e.g.:
+
+ (c-set-offset 'arglist-cont '(c-lineup-ternary-bodies
+ c-lineup-gcc-asm-reg))
+ (c-set-offset 'arglist-cont-nonempty '(c-lineup-ternary-bodies
+ c-lineup-gcc-asm-reg
+ c-lineup-arglist))
+ (c-set-offset 'statement-cont '(c-lineup-ternary-bodies +))
+
+** Images
+
+---
+*** You can explicitly specify base_uri for svg images.
+':base-uri' image property can be used to explicitly specify base_uri
+for embedded images into svg. ':base-uri' is supported for both file
+and data svg images.
+
++++
+*** 'svg-embed-base-uri-image' added to embed images.
+'svg-embed-base-uri-image' can be used to embed images located
+relatively to 'file-name-directory' of the ':base-uri' svg image property.
+This works much faster than 'svg-embed'.
+
++++
+*** New function 'image-cache-size'.
+This function returns the size of the current image cache, in bytes.
+
+---
+*** Animated images stop automatically under high CPU pressure sooner.
+Previously, an animated image would stop animating if any single image
+took more than two seconds to display. The new algorithm maintains a
+decaying average of delays, and if this number gets too high, the
+animation is stopped.
+
++++
+*** The 'n' and 'p' commands (next/previous image) now respect Dired order.
+These commands would previously display the next/previous image in
+lexicographic order, but will now find the "parent" Dired buffer and
+select the next/previous image file according to how the files are
+sorted there. The commands have also been extended to work when the
+"parent" buffer is an archive mode (i.e., zip file or the like) or tar
+mode buffer.
+
+---
+*** 'image-converter' is now restricted to formats in 'auto-mode-alist'.
+When using external image converters, the external program is queried
+for what formats it supports. This list may contain formats that are
+problematic in some contexts (like PDFs), so this list is now filtered
+based on 'auto-mode-alist'. Only file names that map to 'image-mode'
+are now supported.
+
+---
+*** The background and foreground of images now default to face colors.
+When an image doesn't specify a foreground or background color, Emacs
+now uses colors from the face used to draw the surrounding text
+instead of the frame's default colors.
+
+To load images with the default frame colors use the ':foreground' and
+':background' image attributes, for example:
+
+ (create-image "filename" nil nil
+ :foreground (face-attribute 'default :foreground)
+ :background (face-attribute 'default :background))
+
+This change only affects image types that support foreground and
+background colors or transparency, such as xbm, pbm, svg, png and gif.
+
++++
+*** Image smoothing can now be explicitly enabled or disabled.
+Smoothing applies a bilinear filter while scaling or rotating an image
+to prevent aliasing and other unwanted effects. The new image
+property ':transform-smoothing' can be set to t to force smoothing
+and nil to disable smoothing.
+
+The default behavior of smoothing on down-scaling and not smoothing
+on up-scaling remains unchanged.
+
++++
+*** New user option 'image-transform-smoothing'.
+This controls whether to use smoothing or not for an image. Values
+include nil (no smoothing), t (do smoothing) or a predicate function
+that's called with the image object and should return nil/t.
+
++++
+*** SVG images now support user stylesheets.
+The ':css' image attribute can be used to override the default CSS
+stylesheet for an image. The default sets 'font-family' and
+'font-size' to match the current face, so an image with 'height="1em"'
+will match the font size in use where it is embedded.
+
+This feature relies on librsvg 2.48 or above being available.
+
++++
+*** Image properties support 'em' sizes.
+Size image properties, for example ':height', ':max-height', etc., can
+be given a cons of the form '(SIZE . em)', where SIZE is an integer or
+float which is multiplied by the font size to calculate the image
+size, and 'em' is a symbol.
+
+** EWW
+
++++
+*** New user option 'eww-use-browse-url'.
+This is a regexp that can be set to alter how links are followed in eww.
+
++++
+*** New user option 'eww-retrieve-command'.
+This can be used to download data via an external command. If nil
+(the default), then 'url-retrieve' is used. When 'sync', then
+'url-retrieve-synchronously' is used. A list of strings specifies
+an external program with parameters.
+
++++
+*** New Emacs command line convenience command.
+The 'eww-browse' command has been added, which allows you to register
+Emacs as a MIME handler for "text/x-uri", and will call 'eww' on the
+supplied URL. Usage example: "emacs -f eww-browse https://gnu.org".
+
++++
+*** 'eww-download-directory' will now use the XDG location, if defined.
+However, if "~/Downloads/" already exists, that will continue to be
+used.
+
+---
+*** The command 'eww-follow-link' now supports custom mailto: handlers.
+The function that is invoked when clicking on or otherwise following a
+'mailto:' link in an EWW buffer can now be customized. For more
+information, see the related entry about 'shr-browse-url' below.
+
+---
+*** Support for bookmark.el.
+The command 'bookmark-set' (bound to 'C-x r m') is now supported, and
+will create a bookmark that opens the current URL in EWW.
+
+** SHR
+
+---
+*** The command 'shr-browse-url' now supports custom mailto handlers.
+Clicking on or otherwise following a 'mailto:' link in an HTML buffer
+rendered by SHR previously invoked the command 'browse-url-mailto'.
+This is still the case by default, but if you customize
+'browse-url-mailto-function' or 'browse-url-handlers' to call some
+other function, it will now be called instead of the default.
+
+---
+*** New user option 'shr-offer-extend-specpdl'.
+If this is nil, rendering of HTML that requires enlarging
+'max-specpdl-size', the number of Lisp variable bindings, will be
+aborted, and Emacs will not ask you whether to enlarge
+'max-specpdl-size' to complete the rendering. The default is t, which
+preserves the original behavior.
+
++++
+*** New user option 'shr-max-width'.
+If this user option is non-nil, and 'shr-width' is nil, then SHR will
+use the value of 'shr-max-width' to limit the width of the rendered
+HTML. The default is 120 characters, so even if you have very wide
+frames, HTML text will be rendered more narrowly, which usually leads
+to a more readable text. Customize it to nil to get the previous
+behavior of rendering as wide as the 'window-width' allows. If
+'shr-width' is non-nil, it overrides this option.
+
+---
+*** New faces for heading elements.
+Those are 'shr-h1', 'shr-h2', 'shr-h3', 'shr-h4', 'shr-h5', 'shr-h6'.
+
+** Project
+
+---
+*** New user option 'project-vc-merge-submodules'.
+
+---
+*** Project commands now have their own history.
+Previously used project directories are now suggested by all commands
+that prompt for a project directory.
+
++++
+*** New prefix keymap 'project-prefix-map'.
+Key sequences that invoke project-related commands start with the
+prefix 'C-x p'. Type 'C-x p C-h' to show the full list.
+
++++
+*** New commands 'project-dired', 'project-vc-dir', 'project-shell',
+'project-eshell'. These commands run Dired/VC-Dir and Shell/Eshell in
+a project's root directory, respectively.
+
++++
+*** New command 'project-compile'.
+This command runs compilation in the current project's root directory.
+
++++
+*** New command 'project-switch-project'.
+This command lets you "switch" to another project and run a project
+command chosen from a dispatch menu.
+
++++
+*** New commands 'project-shell-command' and 'project-async-shell-command'.
+These commands run 'shell-command' and 'async-shell-command' in a
+project's root directory, respectively.
+
++++
+*** New user option 'project-list-file'.
+This specifies the file in which to save the list of known projects.
+
++++
+*** New command 'project-remember-projects-under'.
+This command can automatically locate and index projects in a
+directory and optionally also its subdirectories, storing them in
+'project-list-file'.
+
++++
+*** New commands 'project-forget-project' and 'project-forget-projects-under'.
+These commands let you interactively remove entries from the list of projects
+in 'project-list-file'.
+
++++
+*** New command 'project-forget-zombie-projects'.
+This command detects indexed projects that have since been deleted,
+and removes them from the list of known projects in 'project-list-file'.
+
+---
+*** 'project-find-file' now accepts non-existent file names.
+This is to allow easy creation of files inside some nested
+sub-directory.
+
++++
+*** 'project-find-file' doesn't use the string at point as default input.
+Now it's only suggested as part of the "future history", accessible
+via 'M-n'.
+
++++
+*** New command 'project-find-dir' runs Dired in a directory inside project.
+
+** Xref
+
++++
+*** New user options to automatically show the first Xref match.
+The new user option 'xref-auto-jump-to-first-definition' controls the
+behavior of 'xref-find-definitions' and its variants, like
+'xref-find-definitions-other-window': if it's t or 'show', the first
+match is automatically displayed; if it's 'move', point in the
+"*xref*" buffer is automatically moved to the first match without
+displaying it.
+The new user option 'xref-auto-jump-to-first-xref' changes the
+behavior of Xref commands such as 'xref-find-references',
+'xref-find-apropos', and 'project-find-regexp', which are expected to
+display many matches that the user would like to
+visit. 'xref-auto-jump-to-first-xref' changes their behavior much in
+the same way as 'xref-auto-jump-to-first-definition' affects the
+"find-definitions" commands.
+
+---
+*** New user options 'xref-search-program' and 'xref-search-program-alist'.
+So far 'grep' and 'ripgrep' are supported. 'ripgrep' seems to offer better
+performance in certain cases, in particular for case-insensitive
+searches.
+
++++
+*** New commands 'xref-prev-group' and 'xref-next-group'.
+These commands are bound respectively to 'P' and 'N', and navigate to
+the first item of the previous or next group in the "*xref*" buffer.
+
+---
+*** New alternative value for 'xref-show-definitions-function':
+'xref-show-definitions-completing-read'.
+
+---
+*** The two existing alternatives for 'xref-show-definitions-function'
+have been renamed to have "proper" public names and documented
+('xref-show-definitions-buffer' and
+'xref-show-definitions-buffer-at-bottom').
+
++++
+*** New command 'xref-quit-and-pop-marker-stack'.
+This command is bound to 'M-,' in "*xref*" buffers. This combination
+is easy to press semi-accidentally if the user wants to go back in the
+middle of choosing the exact definition to go to, and this should do
+TRT.
+
+---
+*** New value 'project-relative' for 'xref-file-name-display'.
+If chosen, file names in "*xref*" buffers will be displayed relative
+to the 'project-root' of the current project, when available.
+
+---
+*** Prefix arg of 'xref-goto-xref' quits the "*xref*" buffer.
+So typing 'C-u RET' in the "*xref*" buffer quits its window
+before navigating to the selected location.
+
++++
+*** The 'TAB' key binding in "*xref*" buffers is obsolete.
+Use 'C-u RET' instead. The 'TAB' binding in "*xref*" buffers is still
+supported, but we plan on removing it in a future version; at that
+time, the command 'xref-quit-and-goto-xref' will no longer have a key
+binding in 'xref--xref-buffer-mode-map'.
+
+---
+*** New user option 'etags-xref-prefer-current-file'.
+When non-nil, matches for identifiers in the file visited by the
+current buffer will be shown first in the "*xref*" buffer.
+
++++
+*** The etags Xref backend now honors 'tags-apropos-additional-actions'.
+You can customize it to augment the output of 'xref-find-apropos',
+like it affected the output of 'tags-apropos', which is obsolete since
+Emacs 25.1.
+
+** Battery
+
+---
+*** UPower is now the default battery status backend when available.
+UPower support via the function 'battery-upower' was added in Emacs
+26.1, but was disabled by default. It is now the default value of
+'battery-status-function' when the system provides a UPower D-Bus
+service. The user options 'battery-upower-device' and
+'battery-upower-subscribe' control which power sources to query and
+whether to respond to status change notifications in addition to
+polling, respectively.
+
+---
+*** A richer syntax can be used to format battery status information.
+The user options 'battery-mode-line-format' and
+'battery-echo-area-format' now support the full formatting syntax of
+the function 'format-spec' documented under node "(elisp) Custom Format
+Strings". The new syntax includes specifiers for padding and
+truncation, amongst other things.
+
+** bug-reference.el
+
+---
+*** Bug reference mode uses auto-setup.
+If 'bug-reference-mode' or 'bug-reference-prog-mode' have been
+activated, their respective hook has been run, and both
+'bug-reference-bug-regexp' and 'bug-reference-url-format' are still
+not set, it tries to guess appropriate values for those two variables.
+There are three guessing mechanisms so far: based on version control
+information of the current buffer's file, based on
+newsgroup/mail-folder name and several news and mail message headers
+in Gnus buffers, and based on IRC channel and network in rcirc and ERC
+buffers. All the mechanisms are extensible with custom rules, see the
+variables 'bug-reference-setup-from-vc-alist',
+'bug-reference-setup-from-mail-alist', and
+'bug-reference-setup-from-irc-alist'.
+
+** HTML Mode
+
+---
+*** A new skeleton for adding relative URLs has been added.
+It's bound to the 'C-c C-c f' keystroke, and prompts for a local file
+name.
+
+** Widget
+
++++
+*** 'widget-choose' now supports menus in extended format.
+
+---
+*** The 'editable-list' widget now supports moving items up and down.
+You can now move items up and down by deleting and then reinserting
+them, using the 'DEL' and 'INS' buttons respectively. This is useful
+in Custom buffers, for example, to change the order of the elements in
+a list.
+
+** Diff
+
+---
+*** New face 'diff-changed-unspecified'.
+This is used to highlight "changed" lines (those marked with '!') in
+context diffs, when 'diff-use-changed-face' is non-nil.
+
+---
+*** New 'diff-mode' font locking face 'diff-error'.
+This face is used for error messages from 'diff'.
+
++++
+*** New command 'diff-refresh-hunk'.
+This new command (bound to 'C-c C-l') regenerates the current hunk.
+
+** thing-at-point
+
++++
+*** New 'thing-at-point' target: 'existing-filename'.
+This is like 'filename', but is a full path, and is nil if the file
+doesn't exist.
+
++++
+*** New 'thing-at-point' target: 'string'.
+If point is inside a string, it returns that string.
+
++++
+*** New variable 'thing-at-point-provider-alist'.
+This allows mode-specific alterations to how 'thing-at-point' works.
+
+---
+*** thing-at-point now respects fields.
+'thing-at-point' (and all functions that use it, like
+'symbol-at-point') will narrow to the current field (if any) before
+trying to identify the thing at point.
+
+---
+*** New function 'thing-at-mouse'.
+This is like 'thing-at-point', but uses the mouse event position instead.
+
+** Image-Dired
+
++++
+*** New user option 'image-dired-thumb-visible-marks'.
+If non-nil (the default), use the new face 'image-dired-thumb-mark'
+for marked images.
+
+---
+*** New command 'image-dired-delete-marked'.
+
+---
+*** 'image-dired-mouse-toggle-mark' is now sensitive to the active region.
+If the region is active, this command now toggles Dired marks of all
+the thumbnails in the region.
+
+** Flymake mode
+
++++
+*** New command 'flymake-show-project-diagnostics'.
+This lists all diagnostics for buffers in the currently active
+project. The listing is similar to the one obtained by
+'flymake-show-buffer-diagnostics', but adds a column for the
+project-relative file name. For backends which support it,
+'flymake-show-project-diagnostics' also lists diagnostics for files
+that have not yet been visited.
+
++++
+*** New user options to customize Flymake's mode-line.
+The new user option 'flymake-mode-line-format' is a mix of strings and
+symbols like 'flymake-mode-line-title', 'flymake-mode-line-exception'
+and 'flymake-mode-line-counters'. The new user option
+'flymake-mode-line-counter-format' is a mix of strings and symbols
+like 'flymake-mode-line-error-counter',
+'flymake-mode-line-warning-counter' and 'flymake-mode-line-note-counter'.
+
+** Time
+
+---
+*** 'display-time-world' has been renamed to 'world-clock'.
+'world-clock' creates a buffer with an updating time display using
+several time zones. It is hoped that the new names are more
+discoverable.
+
+The following commands have been renamed:
+
+ 'display-time-world' to 'world-clock'
+ 'display-time-world-mode' to 'world-clock-mode'
+ 'display-time-world-display' to 'world-clock-display'
+ 'display-time-world-timer' to 'world-clock-update'
+
+The following user options have been renamed:
+
+ 'display-time-world-list' to 'world-clock-list'
+ 'display-time-world-time-format' to 'world-clock-time-format'
+ 'display-time-world-buffer-name' to 'world-clock-buffer-name'
+ 'display-time-world-timer-enable' to 'world-clock-timer-enable'
+ 'display-time-world-timer-second' to 'world-clock-timer-second'
+
+The old names are now obsolete.
+
+---
+*** 'world-clock-mode' can no longer be turned on interactively.
+Use 'world-clock' to turn on that mode.
+
+** Python mode
+
+---
+*** New user option 'python-forward-sexp-function'.
+This allows the user easier customization of whether to use block-based
+navigation or not.
+
+---
+*** 'python-shell-interpreter' now defaults to python3 on systems with python3.
+
+---
+*** 'C-c C-r' can now be used on arbitrary regions.
+The command previously extended the start of the region to the start
+of the line, but will now actually send the marked region, as
+documented.
+
+** Ruby Mode
+
+---
+*** 'ruby-use-smie' is declared obsolete.
+SMIE is now always enabled and 'ruby-use-smie' only controls whether
+indentation is done using SMIE or with the old ad-hoc code.
+
+---
+*** Indentation has changed when 'ruby-align-chained-calls' is non-nil.
+This previously used to align subsequent lines with the last sibling,
+but it now aligns with the first sibling (which is the preferred style
+in Ruby).
+
+** CPerl Mode
+
+---
+*** New face 'perl-heredoc', used for heredoc elements.
+
+---
+*** The command 'cperl-set-style' offers the new value "PBP".
+This value customizes Emacs to use the style recommended in Damian
+Conway's book "Perl Best Practices" for indentation and formatting
+of conditionals.
+
+** Perl mode
+
+---
+*** New face 'perl-non-scalar-variable'.
+This is used to fontify non-scalar variables.
+
+** Octave Mode
+
++++
+*** Line continuations in double-quoted strings now use a backslash.
+Typing 'C-M-j' (bound to 'octave-indent-new-comment-line') now follows
+the behavior introduced in Octave 3.8 of using a backslash as a line
+continuation marker within double-quoted strings, and an ellipsis
+everywhere else.
+
++++
+** EasyPG
+GPG key servers can now be queried for keys with the
+'M-x epa-search-keys' command. Keys can then be added to your
+personal key ring.
+
+** Etags
+
++++
+*** Etags now supports the Mercury programming language.
+See https://mercurylang.org.
+
++++
+*** Etags command line option '--declarations' now has Mercury-specific behavior.
+All Mercury declarations are tagged by default. However, for
+compatibility with 'etags' support for Prolog, predicates and
+functions appearing first in clauses will also be tagged if 'etags' is
+invoked with the '--declarations' command-line option.
+
+** Comint
+
++++
+*** Support for OSC escape sequences.
+Adding the new 'comint-osc-process-output' to
+'comint-output-filter-functions' enables the interpretation of OSC
+("Operating System Command") escape sequences in comint buffers. By
+default, only OSC 8, for hyperlinks, and OSC 7, for directory
+tracking, are acted upon. Adding more entries to
+'comint-osc-handlers' allows a customized treatment of further escape
+sequences.
+
++++
+*** 'comint-delete-output' can now save deleted text in the kill-ring.
+Interactively, 'C-u C-c C-o' triggers this new optional behavior.
+
+** ansi-color.el
+
+---
+*** Colors are now defined by faces.
+ANSI SGR codes now have corresponding faces to describe their
+appearance, e.g. 'ansi-color-bold'.
+
+---
+*** Support for "bright" color codes.
+"Bright" ANSI color codes are now displayed when applying ANSI color
+filters using the color values defined by the faces
+'ansi-color-bright-COLOR'. In addition, bold text with regular ANSI
+colors can be displayed as "bright" if 'ansi-color-bold-is-bright' is
+non-nil.
+
+** ERC
+
+*** Starting with Emacs 28.1 and ERC 5.4, see the ERC-NEWS file for
+user-visible changes in ERC.
+
+** xwidget-webkit mode
+
+---
+*** New xwidget commands.
+'xwidget-webkit-uri' (return the current URL), 'xwidget-webkit-title'
+(return the current title), and 'xwidget-webkit-goto-history' (goto a
+point in history).
+
+---
+*** Downloading files from xwidget-webkit is now supported.
+The new user option 'xwidget-webkit-download-dir' says where to download to.
+
+---
+*** New command 'xwidget-webkit-clone-and-split-below'.
+Open a new window below displaying the current URL.
+
+---
+*** New command 'xwidget-webkit-clone-and-split-right'.
+Open a new window to the right displaying the current URL.
+
+---
+*** Pixel-based scrolling.
+The 'xwidget-webkit-scroll-up', 'xwidget-webkit-scroll-down' commands
+now supports scrolling arbitrary pixel values. It now treats the
+optional 2nd argument as the pixel values to scroll.
+
+---
+*** New commands for scrolling.
+The new commands 'xwidget-webkit-scroll-up-line',
+'xwidget-webkit-scroll-down-line', 'xwidget-webkit-scroll-forward',
+'xwidget-webkit-scroll-backward' can be used to scroll webkit by the
+height of lines or width of chars.
+
+---
+*** New user option 'xwidget-webkit-bookmark-jump-new-session'.
+When non-nil, use a new xwidget webkit session after bookmark jump.
+Otherwise, it will use 'xwidget-webkit-last-session'.
+
+** Checkdoc
+
+---
+*** No longer warns about command substitutions by default.
+Checkdoc used to warn about "too many command substitutions" (as in
+"\\[foo-command]"), even if you only used ten of them in a docstring.
+On modern machines, you can have hundreds or thousands of command
+substitutions before it becomes a performance issue, so this warning
+is now disabled by default. To re-enable this warning, customize the
+user option 'checkdoc-max-keyref-before-warn'.
+
+---
+*** New user option 'checkdoc-column-zero-backslash-before-paren'.
+Checkdoc warns if there is a left parenthesis in column zero of a
+documentation string. That warning can now be disabled by customizing
+this new user option to nil. This is useful if you don't expect
+your code to be edited with an Emacs older than version 27.1.
+
+---
+*** Now checks the prompt format for 'yes-or-no-p'.
+In addition to verifying the format of the prompt for 'y-or-n-p',
+checkdoc will now check the format of 'yes-or-no-p'.
+
+---
+*** New command 'checkdoc-dired'.
+This can be used to run checkdoc on files from a Dired buffer.
+
+---
+*** No longer checks for 'A-' modifiers.
+Checkdoc recommends usage of command substitutions ("\\[foo-command]")
+in favor of writing keybindings like 'C-c f'. It now no longer warns
+about the 'A-' modifier as it is not used very much in practice, and
+this warning therefore mostly led to false positives.
+
+** Enriched mode
+
+---
+*** 'C-a' is by default no longer bound to 'beginning-of-line-text'.
+This is so 'C-a' works as in other modes, and in particular holding
+Shift while typing 'C-a', i.e. 'C-S-a', will now highlight the text.
+
+** Gravatar
+
+---
+*** New user option 'gravatar-service' for host to query for gravatars.
+Defaults to 'libravatar', with 'unicornify' and 'gravatar' as options.
+
+** MH-E mail handler for Emacs
+
+Functions and variables related to handling junk mail have been
+renamed to not associate color with sender quality.
+
++++
+*** New names for mh-junk interactive functions.
+Function 'mh-junk-whitelist' is renamed 'mh-junk-allowlist'.
+Function 'mh-junk-blacklist' is renamed 'mh-junk-blocklist'.
+
++++
+*** New binding for 'mh-junk-allowlist'.
+The key binding for 'mh-junk-allowlist' is changed from 'J w' to 'J a'.
+The old binding is supported but warns that it is obsolete.
+
++++
+*** New names for some hooks.
+'mh-whitelist-msg-hook' is renamed 'mh-allowlist-msg-hook'.
+'mh-blacklist-msg-hook' is renamed 'mh-blocklist-msg-hook'.
+
++++
+*** New names for some user options.
+User option 'mh-whitelist-preserves-sequences-flag' is renamed
+'mh-allowlist-preserves-sequences-flag'.
+
++++
+*** New names for some faces.
+Face 'mh-folder-blacklisted' is renamed 'mh-folder-blocklisted'.
+Face 'mh-folder-whitelisted' is renamed 'mh-folder-allowlisted'.
+
+** Rcirc
+
++++
+*** rcirc now supports SASL authentication.
+
+---
+*** #emacs on Libera.chat has been added to 'rcirc-server-alist'.
+
+---
+*** rcirc connects asynchronously.
+
+---
+*** Integrate formatting into 'rcirc-send-string'.
+The function now accepts a variable number of arguments.
+
++++
+*** Deprecate 'rcirc-command' in favor of 'rcirc-define-command'.
+The new macro handles multiple and optional arguments.
+
+---
+*** Add basic IRCv3 support.
+This includes support for the capabilities: 'server-time', 'batch',
+'message-ids', 'invite-notify', 'multi-prefix' and 'standard-replies'.
+
+---
+*** Add mouse property support to 'rcirc-track-minor-mode'.
+
+---
+*** Improve support for IRC markup codes.
+
+---
+*** Check 'auth-sources' for server passwords.
+
++++
+*** Implement repeated reconnection strategy.
+See 'rcirc-reconnect-attempts'.
+
+** MPC
+
+---
+*** New command 'mpc-goto-playing-song'.
+This command, bound to 'o' in any 'mpc-mode' buffer, moves point to
+the currently playing song in the "*MPC-Songs*" buffer.
+
+---
+*** New user option 'mpc-cover-image-re'.
+If non-nil, it is a regexp that should match a valid cover image.
+
+** Miscellaneous
+
+---
+*** 'shell-script-mode' now supports 'outline-minor-mode'.
+The outline headings have lines that start with "###".
+
+---
+*** fileloop will now skip missing files instead of signalling an error.
+
+---
+*** 'tabulated-list-mode' can now restore original display order.
+Many commands (like 'C-x C-b') are derived from 'tabulated-list-mode',
+and that mode allows the user to sort on any column. There was
+previously no easy way to get back to the original displayed order
+after sorting, but giving a -1 numerical prefix to the sorting command
+will now restore the original order.
+
+---
+*** 'M-left' and 'M-right' now move between columns in 'tabulated-list-mode'.
+
+---
+*** New variable 'hl-line-overlay-priority'.
+This can be used to change the priority of the hl-line overlays.
+
++++
+*** New command 'mailcap-view-file'.
+This command will open a viewer based on the file type, as determined
+by "~/.mailcap" and related files and variables.
+
+---
+*** New user option 'remember-diary-regexp'.
+
+---
+*** New user option 'remember-text-format-function'.
+
+---
+*** New user option 'authinfo-hide-elements'.
+This can be set to nil to inhibit hiding passwords in ".authinfo" files.
+
+---
+*** 'hexl-mode' scrolling commands now heed 'next-screen-context-lines'.
+Previously, 'hexl-scroll-down' and 'hexl-scroll-up' would scroll
+up/down an entire window, but they now work more like the standard
+scrolling commands.
+
+---
+*** New user option 'bibtex-unify-case-function'.
+This new option allows the user to customize how case is converted
+when unifying entries.
+
+---
+*** The user option 'bibtex-maintain-sorted-entries' now permits
+user-defined sorting schemes.
+
+---
+*** New user option 'reveal-auto-hide'.
+If non-nil (the default), revealed text is automatically hidden when
+point leaves the text. If nil, the text is not hidden again. Instead
+'M-x reveal-hide-revealed' can be used to hide all the revealed text.
+
+---
+*** New user option 'ffap-file-name-with-spaces'.
+If non-nil, 'find-file-at-point' and friends will try to guess more
+expansively to identify a file name with spaces. Default value is
+nil.
+
+---
+*** Two new commands for centering in 'doc-view-mode'.
+The new commands 'doc-view-center-page-horizontally' (bound to 'c h')
+and 'doc-view-center-page-vertically' (bound to 'c v') center the page
+horizontally and vertically, respectively.
+
+---
+*** 'tempo-define-template' can now re-assign templates to tags.
+Previously, assigning a new template to an already defined tag had no
+effect.
+
+---
+*** The width of the buffer-name column in 'list-buffers' is now dynamic.
+The width now depends on the width of the window, but will never be
+wider than the length of the longest buffer name, except that it will
+never be narrower than 19 characters.
+
++++
+*** New diary sexp 'diary-offset'.
+It offsets another diary sexp by a number of days. This is useful
+when for example your organization has a committee meeting two days
+after every monthly meeting which takes place on the third Thursday,
+or if you would like to attend a virtual meeting scheduled in a
+different timezone causing a difference in the date.
+
+---
+*** The old non-SMIE indentation of 'sh-mode' has been removed.
+
+---
+*** 'mspools-show' is now autoloaded.
+
+---
+*** Loading dunnet.el in batch mode doesn't start the game any more.
+Instead you need to do "emacs -f dun-batch" to start the game in
+batch mode.
+
+
+* New Modes and Packages in Emacs 28.1
+
++++
+** New mode 'repeat-mode' to allow shorter key sequences.
+Type 'M-x repeat-mode' to enable this mode. You can then type
+'C-x u u' instead of 'C-x u C-x u' to undo many changes, 'C-x o o'
+instead of 'C-x o C-x o' to switch windows, 'C-x { { } } ^ ^ v v' to
+resize the selected window interactively, 'M-g n n p p' to navigate
+next-error matches. Any other key exits this temporarily enabled
+transient mode that supports shorter keys, and then after exiting from
+this mode, the last typed key uses the default key binding.
+
+The user option 'repeat-exit-key' defines an additional key usable to
+exit the mode like 'isearch-exit' ('RET').
+
+The user option 'repeat-exit-timeout' (default nil, which means
+forever) specifies the number of seconds of idle time after which to
+break the repetition chain automatically.
+
+When user option 'repeat-keep-prefix' is non-nil, the prefix arg of
+the previous command is kept. This can be used to e.g. reverse the
+window navigation direction with 'C-x o M-- o o' or to set a new step
+with 'C-x { C-5 { { {', which will set the window resizing step to 5
+columns.
+
+'M-x describe-repeat-maps' will display a buffer showing
+which commands are repeatable in 'repeat-mode'.
+
+---
+** New themes 'modus-vivendi' and 'modus-operandi'.
+These themes are designed to conform with the highest standard for
+color-contrast accessibility (WCAG AAA). You can load either of them
+using 'M-x customize-themes' or 'load-theme' from your init file.
+Consult the Modus Themes Info manual for more information on the user
+options they provide.
+
+** Dictionary mode
+This is a mode for searching a RFC 2229 dictionary server.
+'dictionary' opens a buffer for starting operations.
+'dictionary-search' performs a lookup for a word. It also supports a
+'dictionary-tooltip-mode' which performs a lookup of the word under
+the mouse in 'dictionary-tooltip-dictionary' (which must be customized
+first).
+
+---
+** Lisp Data mode
+The new command 'lisp-data-mode' enables a major mode for buffers
+composed of Lisp symbolic expressions that do not form a computer
+program. The ".dir-locals.el" file is automatically set to use this
+mode, as are other data files produced by Emacs.
+
++++
+** New global mode 'global-goto-address-mode'.
+This will enable 'goto-address-mode' in all buffers.
+
+** transient.el
+This library implements support for powerful keyboard-driven menus.
+Such menus can be used as simple visual command dispatchers. More
+complex menus take advantage of infix arguments, which are somewhat
+similar to prefix arguments, but are more flexible and discoverable.
+
+** hierarchy.el
+This library can create, query, navigate and display hierarchical
+structures.
+
+---
+** New major mode for displaying the "etc/AUTHORS" file.
+This new 'etc-authors-mode' provides font-locking for displaying the
+"etc/AUTHORS" file from the Emacs distribution, and not much else.
+
+
+* Incompatible Lisp Changes in Emacs 28.1
+
++++
+** Emacs now prints a backtrace when signaling an error in batch mode.
+This makes debugging Emacs Lisp scripts run in batch mode easier. To
+get back the old behavior, set the new variable
+'backtrace-on-error-noninteractive' to a nil value.
+
+---
+** Some floating-point numbers are now handled differently by the Lisp reader.
+In previous versions of Emacs, numbers with a trailing dot and an exponent
+were read as integers and the exponent ignored: 2.e6 was interpreted as the
+integer 2. Such numerals are now read as floats with the exponent included:
+2.e6 is now read as the floating-point value 2000000.0.
+That is, '(read-from-string "1.e3")' => '(1000.0 . 4)' now.
+
+---
+** 'equal' no longer examines some contents of window configurations.
+Instead, it considers window configurations to be equal only if they
+are 'eq'. To compare contents, use 'compare-window-configurations'
+instead. This change helps fix a bug in 'sxhash-equal', which returned
+incorrect hashes for window configurations and some other objects.
+
++++
+** The 'lexical-binding' local variable is always enabled.
+Previously, if 'enable-local-variables' was nil, a 'lexical-binding'
+local variable would not be heeded. This has now changed, and a file
+with a 'lexical-binding' cookie is always heeded. To revert to the
+old behavior, set 'permanently-enabled-local-variables' to nil.
+
++++
+** '&rest' in argument lists must always be followed by a variable name.
+Omitting the variable name after '&rest' was previously tolerated in
+some cases but not consistently so; it could lead to crashes or
+outright wrong results. Since the utility was marginal at best, it is
+now an error to omit the variable.
+
+---
+** 'kill-all-local-variables' has changed how it handles non-symbol hooks.
+The function is documented to eliminate all buffer-local bindings
+except variables with a 'permanent-local' property, or hooks that
+have elements with a 'permanent-local-hook' property. In addition, it
+would also keep lambda expressions in hooks sometimes. The latter has
+now been changed: The function will now also remove these.
+
++++
+** Temporary buffers no longer run certain buffer hooks.
+The macros 'with-temp-buffer' and 'with-temp-file' no longer run the
+hooks 'kill-buffer-hook', 'kill-buffer-query-functions', and
+'buffer-list-update-hook' for the temporary buffers they create. This
+avoids slowing them down when a lot of these hooks are defined.
+
++++
+** New face 'child-frame-border' and frame parameter 'child-frame-border-width'.
+The face and width of child frames borders can now be determined
+separately from those of normal frames. To minimize backward
+incompatibility, child frames without a 'child-frame-border-width'
+parameter will fall back to using 'internal-border-width'. However,
+the new 'child-frame-border' face does constitute a breaking change
+since child frames' borders no longer use the 'internal-border' face.
+
+---
+** 'run-at-time' now tries harder to implement the t TIME parameter.
+If TIME is t, the timer runs at an integral multiple of REPEAT.
+(I.e., if given a REPEAT of 60, it'll run at 08:11:00, 08:12:00,
+08:13:00.) However, when a machine goes to sleep (or otherwise didn't
+get a time slot to run when the timer was scheduled), the timer would
+then fire every 60 seconds after the time the timer was fired. This
+has now changed, and the timer code now recomputes the integral
+multiple every time it runs, which means that if the laptop wakes at
+08:16:43, it'll fire at that time, but then at 08:17:00, 08:18:00...
+
+---
+** 'parse-partial-sexp' now signals an error if TO is smaller than FROM.
+Previously, this would lead to the function interpreting FROM as TO and
+vice versa, which would be confusing when passing in OLDSTATE, which
+refers to the old state at FROM.
+
++++
+** 'global-mode-string' constructs should end with a space.
+This was previously not formalized, which led to combinations of modes
+displaying data "smushed together" on the mode line.
+
++++
+** 'overlays-in' now handles zero-length overlays slightly differently.
+Previously, zero-length overlays at the end of the buffer were included
+in the result (if the region queried for stopped at that position).
+The same was not the case if the buffer had been narrowed to exclude
+the real end of the buffer. This has now been changed, and
+zero-length overlays at 'point-max' are always included in the results.
+
+---
+** 'replace-match' now runs modification hooks slightly later.
+The function is documented to leave point after the replacement text,
+but this was not always the case if a modification hook inserted text
+in front of the replaced text -- 'replace-match' would instead leave
+point where the end of the inserted text would have been before the
+hook ran. 'replace-match' now always leaves point after the
+replacement text.
+
++++
+** 'completing-read-default' sets completion variables buffer-locally.
+'minibuffer-completion-table' and related variables are now set buffer-locally
+in the minibuffer instead of being set via a global let-binding.
+
+---
+** XML serialization functions now reject invalid characters.
+Previously, 'xml-print' would produce invalid XML when given a string
+with characters that are not valid in XML (see
+https://www.w3.org/TR/xml/#charsets). Now it rejects such strings.
+
+---
+** JSON
+
+---
+*** JSON number parsing is now stricter.
+Numbers with a leading plus sign, leading zeros, or a missing integer
+component are now rejected by 'json-read' and friends. This makes
+them more compliant with the JSON specification and consistent with
+the native JSON parsing functions.
+
+---
+*** JSON functions support the semantics of RFC 8259.
+The JSON functions 'json-serialize', 'json-insert',
+'json-parse-string', and 'json-parse-buffer' now implement some of the
+semantics of RFC 8259 instead of the earlier RFC 4627. In particular,
+these functions now accept top-level JSON values that are neither
+arrays nor objects.
+
+---
+*** Some JSON encoding functions are now obsolete.
+The functions 'json-encode-number', 'json-encode-hash-table',
+'json-encode-key', and 'json-encode-list' are now obsolete.
+
+The first two are kept as aliases of 'json-encode', which should be
+used instead. Uses of 'json-encode-list' should be changed to call
+one of 'json-encode', 'json-encode-alist', 'json-encode-plist', or
+'json-encode-array' instead.
+
++++
+*** Native JSON functions now signal an error if libjansson is unavailable.
+This affects 'json-serialize', 'json-insert', 'json-parse-string',
+and 'json-parse-buffer'. This can happen if Emacs was compiled with
+libjansson, but the DLL cannot be found and/or loaded by Emacs at run
+time. Previously, Emacs would display a message and return nil in
+these cases.
+
++++
+** The use of positional arguments in 'define-minor-mode' is obsolete.
+These were actually rendered obsolete in Emacs 21 but were never
+marked as such.
+
+---
+** 'pcomplete-ignore-case' is now an obsolete alias of 'completion-ignore-case'.
+
++++
+** 'completions-annotations' face is not used when the caller puts own face.
+This affects the suffix specified by completion 'annotation-function'.
+
++++
+** An active minibuffer now has major mode 'minibuffer-mode'.
+This is instead of the erroneous 'minibuffer-inactive-mode' it
+formerly had.
+
+---
+** 'make-text-button' no longer modifies text properties of its first argument.
+When its first argument is a string, 'make-text-button' no longer
+modifies the string's text properties; instead, it uses and returns
+a copy of the string. This helps avoid trouble when strings are
+shared or constants.
+
++++
+** Some properties from completion tables are now preserved.
+If 'minibuffer-allow-text-properties' is non-nil, doing completion
+over a table of strings with properties will no longer remove all the
+properties before returning. This affects things like 'completing-read'.
+
+---
+** 'dns-query' now consistently uses Lisp integers to represent integers.
+Formerly it made an exception for integer components of SOA records,
+because SOA serial numbers can exceed fixnum ranges on 32-bit platforms.
+Emacs now supports bignums so this old glitch is no longer needed.
+
++++
+** The '&define' keyword in an Edebug specification now disables backtracking.
+The implementation was buggy, and multiple '&define' forms in an '&or'
+form should be exceedingly rare. See the Info node "(elisp) Backtracking" in
+the Emacs Lisp reference manual for background.
+
++++
+** The error 'ftp-error' belongs also to category 'remote-file-error'.
+
++++
+** The WHEN argument of 'make-obsolete' and related functions is mandatory.
+The use of those functions without a WHEN argument was marked obsolete
+back in Emacs 23.1. The affected functions are: 'make-obsolete',
+'define-obsolete-function-alias', 'make-obsolete-variable',
+'define-obsolete-variable-alias'.
+
++++
+** 'inhibit-nul-byte-detection' is renamed to 'inhibit-null-byte-detection'.
+
+---
+** Some functions are no longer considered safe by 'unsafep':
+'replace-regexp-in-string', 'catch', 'throw', 'error', 'signal'
+and 'play-sound-file'.
+
+---
+** 'sql-*-statement-starters' are no longer user options.
+These variables describe facts about the SQL standard and
+product-specific additions. There should be no need for users to
+customize them.
+
+---
+** Some locale-related variables have been removed.
+The Lisp variables 'previous-system-messages-locale' and
+'previous-system-time-locale' have been removed, as they were created
+by mistake and were not useful to Lisp code.
+
+---
+** Function 'lm-maintainer' is replaced with 'lm-maintainers'.
+The former is now declared obsolete.
+
++++
+** facemenu.el is no longer preloaded.
+To use functions/variables from the package, you now have to say
+'(require 'facemenu)' or similar.
+
+---
+** 'facemenu-color-alist' is now obsolete, and is not used.
+
+---
+** The variable 'keyboard-type' is obsolete and not dynamically scoped any more.
+
++++
+** The 'values' variable is now obsolete.
+Using it just contributes to the growth of the Emacs memory
+footprint.
+
+---
+** The 'load-dangerous-libraries' variable is now obsolete.
+It was used to allow loading Lisp libraries compiled by XEmacs, a
+modified version of Emacs which is no longer actively maintained.
+This is no longer supported, and setting this variable has no effect.
+
++++
+** The macro 'with-displayed-buffer-window' is now obsolete.
+Use macro 'with-current-buffer-window' with action alist entry 'body-function'.
+
+---
+** The rfc2368.el library is now obsolete.
+Use rfc6068.el instead. The main difference is that
+'rfc2368-parse-mailto-url' and 'rfc2368-unhexify-string' assumed that
+the strings were all-ASCII, while 'rfc6068-parse-mailto-url' and
+'rfc6068-unhexify-string' parse UTF-8 strings.
+
+---
+** The inversion.el library is now obsolete.
+
+---
+** The metamail.el library is now obsolete.
+
+** Edebug changes
+
+---
+*** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'.
+
++++
+*** The spec operator ':name NAME' is obsolete, use '&name' instead.
+
++++
+*** The spec element 'function-form' is obsolete, use 'form' instead.
+
++++
+*** New function 'def-edebug-elem-spec' to define Edebug spec elements.
+These used to be defined with 'def-edebug-spec' thus conflating the
+two name spaces, which lead to name collisions.
+The use of 'def-edebug-spec' to define Edebug spec elements is
+declared obsolete.
+
+---
+** The sb-image.el library is now obsolete.
+This was a compatibility kludge which is no longer needed.
+
+---
+** Some libraries obsolete since Emacs 23 have been removed:
+ledit.el, lmenu.el, lucid.el and old-whitespace.el.
+
+---
+** Some functions and variables obsolete since Emacs 23 have been removed:
+'GOLD-map', 'advertised-xscheme-send-previous-expression',
+'allout-init', 'bookmark-jump-noselect',
+'bookmark-read-annotation-text-func', 'buffer-menu-mode-hook',
+'c-forward-into-nomenclature', 'char-coding-system-table',
+'char-valid-p', 'charset-bytes', 'charset-id', 'charset-list',
+'choose-completion-delete-max-match', 'complete-in-turn',
+'completion-base-size', 'completion-common-substring',
+'crm-minibuffer-complete', 'crm-minibuffer-complete-and-exit',
+'crm-minibuffer-completion-help', 'custom-mode', 'custom-mode-hook',
+'define-key-rebound-commands', 'define-mode-overload-implementation',
+'detect-coding-with-priority', 'dirtrack-debug',
+'dirtrack-debug-toggle', 'dynamic-completion-table',
+'easy-menu-precalculate-equivalent-keybindings',
+'epa-display-verify-result', 'epg-passphrase-callback-function',
+'erc-announced-server-name', 'erc-default-coding-system',
+'erc-process', 'erc-send-command', 'eshell-report-bug',
+'eval-next-after-load', 'exchange-dot-and-mark', 'ffap-bug',
+'ffap-submit-bug', 'ffap-version', 'file-cache-mouse-choose-completion',
+'forward-point', 'generic-char-p', 'global-highlight-changes',
+'hi-lock-face-history', 'hi-lock-regexp-history',
+'highlight-changes-active-string', 'highlight-changes-initial-state',
+'highlight-changes-passive-string',
+'icalendar--datetime-to-noneuropean-date', 'image-mode-maybe',
+'imenu-example--name-and-position', 'ispell-aspell-supports-utf8',
+'lisp-mode-auto-fill', 'locate-file-completion', 'make-coding-system',
+'menu-bar-files-menu', 'minibuffer-local-must-match-filename-map',
+'mouse-choose-completion', 'mouse-major-mode-menu',
+'mouse-popup-menubar', 'mouse-popup-menubar-stuff',
+'newsticker-groups-filename', 'nnir-swish-e-index-file',
+'nnmail-fix-eudora-headers', 'non-iso-charset-alist',
+'nonascii-insert-offset', 'nonascii-translation-table',
+'password-read-and-add', 'pre-abbrev-expand-hook', 'princ-list',
+'print-help-return-message', 'process-filter-multibyte-p',
+'read-file-name-predicate', 'remember-buffer', 'rmail-highlight-face',
+'rmail-message-filter', 'semantic-after-idle-scheduler-reparse-hooks',
+'semantic-after-toplevel-bovinate-hook',
+'semantic-before-idle-scheduler-reparse-hooks',
+'semantic-before-toplevel-bovination-hook',
+'semantic-bovinate-from-nonterminal-full',
+'semantic-bovinate-region-until-error', 'semantic-bovinate-toplevel',
+'semantic-bovination-working-type',
+'semantic-decorate-pending-decoration-hooks',
+'semantic-edits-incremental-reparse-failed-hooks',
+'semantic-eldoc-current-symbol-info', 'semantic-expand-nonterminal',
+'semantic-file-token-stream', 'semantic-find-dependency',
+'semantic-find-nonterminal', 'semantic-flex', 'semantic-flex-buffer',
+'semantic-flex-keyword-get', 'semantic-flex-keyword-p',
+'semantic-flex-keyword-put', 'semantic-flex-keywords',
+'semantic-flex-list', 'semantic-flex-make-keyword-table',
+'semantic-flex-map-keywords', 'semantic-flex-token-end',
+'semantic-flex-token-start', 'semantic-flex-token-text',
+'semantic-imenu-bucketize-type-parts',
+'semantic-imenu-expand-type-parts', 'semantic-imenu-expandable-token',
+'semantic-init-db-hooks', 'semantic-init-hooks',
+'semantic-init-mode-hooks', 'semantic-java-prototype-nonterminal',
+'semantic-nonterminal-abstract', 'semantic-nonterminal-full-name',
+'semantic-nonterminal-leaf', 'semantic-nonterminal-protection',
+'semantic-something-to-stream', 'semantic-tag-make-assoc-list',
+'semantic-token-type-parent', 'semantic-toplevel-bovine-cache',
+'semantic-toplevel-bovine-table', 'semanticdb-mode-hooks',
+'set-coding-priority', 'set-process-filter-multibyte',
+'shadows-compare-text-p', 'shell-dirtrack-toggle',
+'speedbar-navigating-speed', 'speedbar-update-speed', 't-mouse-mode',
+'term-dynamic-simple-complete', 'tooltip-hook', 'tpu-have-ispell',
+'url-generate-unique-filename', 'url-temporary-directory',
+'vc-arch-command', 'vc-default-working-revision' (variable),
+'vc-mtn-command', 'vc-revert-buffer', 'vc-workfile-version',
+'vcursor-toggle-vcursor-map', 'w32-focus-frame', 'w32-select-font',
+'wisent-lex-make-token-table'.
+
+---
+** Some functions and variables obsolete since Emacs 22 have been removed:
+'erc-current-network', 'gnus-article-hide-pgp-hook',
+'gnus-inews-mark-gcc-as-read', 'gnus-treat-display-xface',
+'gnus-treat-strip-pgp', 'nnmail-spool-file'.
+
+---
+** The obsolete function 'thread-alive-p' has been removed.
+
+---
+** The variable 'force-new-style-backquotes' has been removed.
+This removes the final remaining trace of old-style backquotes.
+
+---
+** Some obsolete variable and function aliases in dbus.el have been removed.
+In Emacs 24.3, the variable 'dbus-event-error-hooks' was renamed to
+'dbus-event-error-functions' and the function
+'dbus-call-method-non-blocking' was renamed to 'dbus-call-method'.
+The old names, which were kept as obsolete aliases of the new names,
+have now been removed.
+
+---
+** 'find-function-source-path' renamed and re-documented.
+The 'find-function' command (and various related commands) were
+documented to respect 'find-function-source-path', and to search for
+objects in files specified by that variable. It's unclear when this
+actually changed, but at some point (perhaps decades ago) these
+commands started using 'load-history' to determine where symbols had
+been defined (which is much faster). The doc strings of all the
+affected function have been updated. 'find-function-source-path' was
+still being used by 'find-library' and related commands, so the
+user option has been renamed to 'find-library-source-path', and
+'find-function-source-path' is now an obsolete variable alias.
+
+---
+** The macro 'vc-call' no longer evaluates its second argument twice.
+
+** Xref migrated from EIEIO to cl-defstruct for its core objects.
+This means that 'oref' and 'with-slots' no longer works on them, and
+'make-instance' can no longer be used to create those instances (which
+wasn't recommended anyway). Packages should restrict themselves to
+using functions like 'xref-make', 'xref-make-match',
+'xref-make-*-location', as well as accessor functions
+'xref-item-summary' and 'xref-item-location'.
+
+Among the benefits are better performance (noticeable when there are a
+lot of matches) and improved flexibility: 'xref-match-item' instances
+do not require that 'location' inherits from 'xref-location' anymore
+(that class was removed), so packages can create new location types to
+use with "match items" without adding EIEIO as a dependency.
+
+
+* Lisp Changes in Emacs 28.1
+
++++
+** The 'interactive' syntax has been extended to allow listing applicable modes.
+Forms like '(interactive "p" dired-mode)' can be used to annotate the
+commands as being applicable for modes derived from 'dired-mode',
+or if the mode is a minor mode, when the current buffer has that
+minor mode activated. Note that using this form will create byte code
+that is not compatible with byte code in previous Emacs versions.
+
++++
+** New forms to declare how completion should happen has been added.
+'(declare (completion PREDICATE))' can be used as a general predicate
+to say whether the command should be present when completing with
+'M-x TAB'. '(declare (modes MODE...))' can be used as a short-hand
+way of saying that the command should be present when completing from
+buffers in major modes derived from MODE..., or, if it's a minor mode,
+when that minor mode is enabled in the current buffer.
+
++++
+** 'define-minor-mode' now takes an ':interactive' argument.
+This can be used for specifying which modes this minor mode is meant
+for, or to make the new minor mode non-interactive. The default value
+is t.
+
++++
+** 'define-derived-mode' now takes an ':interactive' argument.
+This can be used to control whether the defined mode is a command
+or not, and is useful when defining commands that aren't meant to be
+used by users directly.
+
++++
+** 'define-globalized-minor-mode' now takes a ':predicate' parameter.
+This can be used to control which major modes the minor mode should be
+used in.
+
++++
+** 'condition-case' now allows for a success handler.
+It is written as '(:success BODY...)' where BODY is executed
+whenever the protected form terminates without error, with the
+specified variable bound to the value of the protected form.
+
++++
+** New function 'benchmark-call' to measure the execution time of a function.
+Additionally, the number of repetitions can be expressed as a minimal duration
+in seconds.
+
++++
+** The value thrown to the 'exit' label can now be a function.
+This is in addition to values t or nil. If the value is a function,
+the command loop will call it with zero arguments before returning.
+
++++
+** The behavior of 'format-spec' is now closer to that of 'format'.
+In order for the two functions to behave more consistently,
+'format-spec' now pads and truncates based on string width rather than
+length, and also supports format specifications that include a
+truncating precision field, such as "%.2a".
+
+---
+** 'defvar' detects the error of defining a variable currently lexically bound.
+Such mixes are always signs that the outer lexical binding was an
+error and should have used dynamic binding instead.
+
+---
+** New variable 'inhibit-mouse-event-check'.
+If bound to non-nil, a command with '(interactive "e")' doesn't signal
+an error when invoked by input event that is not a mouse click (e.g.,
+a key sequence).
+
+---
+** New variable 'redisplay-skip-initial-frame' to enable batch redisplay tests.
+Setting it to nil forces the redisplay to do its job even in the
+initial frame used in batch mode.
+
++++
+** Doc strings can now link to customization groups.
+Text like "customization group `whitespace'" will be made into a
+button. When clicked, it will open a Custom buffer displaying that
+customization group.
+
++++
+** Doc strings can now link to man pages.
+Text like "man page `chmod(1)'" will be made into a button. When
+clicked, it will open a Man mode buffer displaying that man page.
+
++++
+** Buffers can now be created with certain hooks disabled.
+The functions 'get-buffer-create' and 'generate-new-buffer' accept a
+new optional argument INHIBIT-BUFFER-HOOKS. If non-nil, the new
+buffer does not run the hooks 'kill-buffer-hook',
+'kill-buffer-query-functions', and 'buffer-list-update-hook'. This
+avoids slowing down internal or temporary buffers that are never
+presented to users or passed on to other applications.
+
++++
+** New command 'make-directory-autoloads'.
+This does the same as the old command 'update-directory-autoloads',
+but has different semantics: Instead of passing in the output file via
+the dynamically bound 'generated-autoload-file' variable, the output
+file is now a explicit parameter.
+
+---
+** Dragging a file into Emacs pushes the file name onto 'file-name-history'.
+
+---
+** The 'easymenu' library is now preloaded.
+
+---
+** The 'iso-transl' library is now preloaded.
+This means that keystrokes like 'Alt-[' are defined by default,
+instead of only becoming available after doing (for instance)
+'C-x 8 <letter>'.
+
+---
+** ':safe' settings in 'defcustom' are now propagated to the loaddefs files.
+
++++
+** New ':type' for 'defcustom' for nonnegative integers.
+The new 'natnum' type can be used for options that should be
+nonnegative integers.
+
++++
+** ERT can now output more verbose test failure reports.
+If the 'EMACS_TEST_VERBOSE' environment variable is set, failure
+summaries will include the failing condition.
+
+** Byte compiler changes
+
++++
+*** New byte-compiler check for missing dynamic variable declarations.
+It is meant as an (experimental) aid for converting Emacs Lisp code
+to lexical binding, where dynamic (special) variables bound in one
+file can affect code in another. For details, see the manual section
+"(elisp) Converting to Lexical Binding".
+
++++
+*** 'byte-recompile-directory' can now compile symlinked ".el" files.
+This is achieved by giving a non-nil FOLLOW-SYMLINKS parameter.
+
+---
+*** The byte-compiler now warns about too wide documentation strings.
+By default, it will warn if a documentation string is wider than the
+largest of 'byte-compile-docstring-max-column' or 'fill-column'
+characters.
+
++++
+*** 'byte-compile-file' optional argument LOAD is now obsolete.
+To load the file after byte-compiling, add a call to 'load' from Lisp
+or use 'M-x emacs-lisp-byte-compile-and-load' interactively.
+
+** Macroexp
+
+---
+*** New function 'macroexp-file-name' to know the name of the current file.
+
+---
+*** New function 'macroexp-compiling-p' to know if we're compiling.
+
+---
+*** New function 'macroexp-warn-and-return' to help emit warnings.
+This used to be named 'macroexp--warn-and-return' and has proved useful
+and well-behaved enough to lose the "internal" marker.
+
+** map.el
+
+---
+*** Alist keys are now consistently compared with 'equal' by default.
+Until now, 'map-elt' and 'map-delete' compared alist keys with 'eq' by
+default. They now use 'equal' instead, for consistency with
+'map-put!' and 'map-contains-key'.
+
+*** Pcase 'map' pattern added keyword symbols abbreviation.
+A pattern like '(map :sym)' binds the map's value for ':sym' to 'sym',
+equivalent to '(map (:sym sym))'.
+
+---
+*** The function 'map-copy' now uses 'copy-alist' on alists.
+This is a slightly deeper copy than the previous 'copy-sequence'.
+
+---
+*** The function 'map-contains-key' now supports plists.
+
+---
+*** More consistent duplicate key handling in 'map-merge-with'.
+Until now, 'map-merge-with' promised to call its function argument
+whenever multiple maps contained 'eql' keys. However, this did not
+always coincide with the keys that were actually merged, which could
+be 'equal' instead. The function argument is now called whenever keys
+are merged, for greater consistency with 'map-merge' and 'map-elt'.
+
+** pcase
+
++++
+*** The 'or' pattern now binds the union of the vars of its sub-patterns.
+If a variable is not bound by the subpattern that matched, it gets bound
+to nil. This was already sometimes the case, but it is now guaranteed.
+
++++
+*** The 'pred' pattern can now take the form '(pred (not FUN))'.
+This is like '(pred (lambda (x) (not (FUN x))))' but results
+in better code.
+
+---
+*** New function 'pcase-compile-patterns' to write other macros.
+
++++
+*** Added 'cl-type' pattern.
+The new 'cl-type' pattern compares types using 'cl-typep', which allows
+comparing simple types like '(cl-type integer)', as well as forms like
+'(cl-type (integer 0 10))'.
+
++++
+*** New macro 'pcase-setq'.
+This macro is the 'setq' equivalent of 'pcase-let', which allows for
+destructuring patterns in a 'setq' form.
+
+** Edebug
+
+*** Edebug specification lists can use some new keywords:
+
++++
+**** '&interpose SPEC FUN ARGS..' lets FUN control parsing after SPEC.
+More specifically, FUN is called with 'HEAD PF ARGS..' where
+PF is a parsing function that expects a single argument (the specs to
+use) and HEAD is the code that matched SPEC.
+
++++
+**** '&error MSG' unconditionally aborts the current edebug instrumentation.
+
++++
+**** '&name SPEC FUN' extracts the current name from the code matching SPEC.
+
+** Dynamic modules changes
+
++++
+*** Type aliases for module functions and finalizers.
+The module header 'emacs-module.h' now contains type aliases
+'emacs_function' and 'emacs_finalizer' for module functions and
+finalizers, respectively.
+
++++
+*** Module functions can now be made interactive.
+Use 'make_interactive' to give a module function an interactive
+specification.
+
++++
+*** Module functions can now install an optional finalizer.
+The finalizer is called when the function object is garbage-collected.
+Use 'set_function_finalizer' to set the finalizer and
+'get_function_finalizer' to retrieve it.
+
++++
+*** Modules can now open a channel to an existing pipe process.
+Modules can use the new module function 'open_channel' to do that.
+On capable systems, modules can use this functionality to
+asynchronously send data back to Emacs.
+
++++
+*** A new module API 'make_unibyte_string'.
+It can be used to create Lisp strings with arbitrary byte sequences
+(a.k.a. "raw bytes").
+
++++
+** Shorthands for Lisp symbols.
+Shorthands are a general purpose namespacing system to make Emacs
+Lisp's symbol-naming etiquette easier to use. A shorthand is any
+symbolic form found in Lisp source that "abbreviates" a symbol's print
+name. Among other applications, this feature can be used to avoid
+name clashes and namespace pollution by renaming an entire file's
+worth of symbols with proper and longer prefixes, without actually
+touching the Lisp source. For details, see the manual section
+"(elisp) Shorthands".
+
++++
+** New function 'string-search'.
+This function takes two string parameters and returns the position of
+the first instance of the former string in the latter.
+
++++
+** New function 'string-replace'.
+This function works along the line of 'replace-regexp-in-string', but
+it matches on fixed strings instead of regexps, and does not change
+the global match state.
+
++++
+** New function 'ensure-list'.
+This function makes a list of its object if it's not a list already.
+If it's already a list, the list is returned as is.
+
++++
+** New function 'split-string-shell-command'.
+This splits a shell command string into separate components,
+respecting quoting with single ('like this') and double ("like this")
+quotes, as well as backslash quoting (like\ this).
+
++++
+** New function 'string-clean-whitespace'.
+This removes whitespace from a string.
+
++++
+** New function 'string-fill'.
+Word-wrap a string so that no lines are longer that a specific length.
+
++++
+** New function 'string-limit'.
+Return (up to) a specific substring length.
+
++++
+** New function 'string-lines'.
+Return a list of strings representing the individual lines in a
+string.
+
++++
+** New function 'string-pad'.
+Pad a string to a specific length.
+
++++
+** New function 'string-chop-newline'.
+Remove a trailing newline from a string.
+
++++
+** New function 'replace-regexp-in-region'.
+
++++
+** New function 'replace-string-in-region'.
+
++++
+** New function 'file-name-with-extension'.
+This function allows a canonical way to set/replace the extension of a
+file name.
+
++++
+** New function 'file-modes-number-to-symbolic' to convert a numeric
+file mode specification into symbolic form.
+
++++
+** New function 'file-name-concat'.
+This appends file name components to a directory name and returns the
+result.
+
++++
+** New function 'file-backup-file-names'.
+This function returns the list of file names of all the backup files
+for the specified file.
+
++++
+** New function 'directory-empty-p'.
+This predicate tests whether a given file name is an accessible
+directory and whether it contains no other directories or files.
+
++++
+** New function 'buffer-local-boundp'.
+This predicate says whether a symbol is bound in a specific buffer.
+
++++
+** New function 'always'.
+This is identical to 'ignore', but returns t instead.
+
++++
+** New function 'sxhash-equal-including-properties'.
+This is identical to 'sxhash-equal' but also accounts for string
+properties.
+
+---
+** New function 'buffer-line-statistics'.
+This function returns some statistics about the line lengths in a buffer.
+
+---
+** New function 'color-values-from-color-spec'.
+This can be used to parse RGB color specs in several formats and
+convert them to a list '(R G B)' of primary color values.
+
+---
+** New function 'custom-add-choice'.
+This function can be used by modes to add elements to the
+'choice' customization type of a variable.
+
+---
+** New function 'decoded-time-period'.
+It interprets a decoded time structure as a period and returns the
+equivalent period in seconds.
+
++++
+** New function 'dom-print'.
+
++++
+** New function 'dom-remove-attribute'.
+
+---
+** New function 'dns-query-asynchronous'.
+It takes the same parameters as 'dns-query', but adds a callback
+parameter.
+
+** New function 'garbage-collect-maybe' to trigger GC early.
+
+---
+** New function 'get-locale-names'.
+This utility function returns a list of names of locales available on
+the current system.
+
++++
+** New function 'insert-into-buffer'.
+This inserts the contents of the current buffer into another buffer.
+
++++
+** New function 'json-available-p'.
+This predicate returns non-nil if Emacs is built with libjansson
+support, and it is available on the current system.
+
+---
+** New function 'mail-header-parse-addresses-lax'.
+This takes a comma-separated string and returns a list of mail/name
+pairs.
+
+---
+** New function 'mail-header-parse-address-lax'.
+Parse a string as a mail address-like string.
+
+---
+** New function 'make-separator-line'.
+Make a string appropriate for usage as a visual separator line.
+
++++
+** New function 'num-processors'.
+Return the number of processors on the system.
+
++++
+** New function 'object-intervals'.
+This function returns a copy of the list of intervals (i.e., text
+properties) in the object in question (which must either be a string
+or a buffer).
+
++++
+** New function 'process-lines-ignore-status'.
+This is like 'process-lines', but does not signal an error if the
+return status is non-zero. 'process-lines-handling-status' has also
+been added, and takes a callback to handle the return status.
+
++++
+** New function 'require-theme'.
+This function is like 'require', but searches 'custom-theme-load-path'
+instead of 'load-path'. It can be used by Custom themes to load
+supporting Lisp files when 'require' is unsuitable.
+
++++
+** New function 'seq-union'.
+This function takes two sequences and returns a list of all elements
+that appear in either of them, with no two elements that compare equal
+appearing in the result.
+
++++
+** New function 'syntax-class-to-char'.
+This does almost the opposite of 'string-to-syntax' -- it returns the
+syntax descriptor (a character) given a raw syntax descriptor (an
+integer).
+
++++
+** New functions 'null-device' and 'path-separator'.
+These functions return the connection local value of the respective
+variables. This can be used for remote hosts.
+
++++
+** New predicate functions 'length<', 'length>' and 'length='.
+Using these functions may be more efficient than using 'length' (if
+the length of a (long) list is being computed just to compare this
+length to a number).
+
++++
+** New macro 'dlet' to dynamically bind variables.
+
++++
+** New macro 'with-existing-directory'.
+This macro binds 'default-directory' to some other existing directory
+if 'default-directory' doesn't exist, and then executes the body forms.
+
++++
+** New variable 'current-minibuffer-command'.
+This is like 'this-command', but it is bound recursively when entering
+the minibuffer.
+
++++
+** New variable 'inhibit-interaction' to make user prompts signal an error.
+If this is bound to something non-nil, functions like
+'read-from-minibuffer', 'read-char' (and related) will signal an
+'inhibited-interaction' error.
+
+---
+** New variable 'indent-line-ignored-functions'.
+This allows modes to cycle through a set of indentation functions
+appropriate for those modes.
+
++++
+** New variable 'print-integers-as-characters' modifies integer printing.
+If this variable is non-nil, character syntax is used for printing
+numbers when this makes sense, such as '?A' for 65.
+
++++
+** New variable 'tty-menu-calls-mouse-position-function'.
+This controls whether 'mouse-position-function' is called by functions
+that retrieve the mouse position when that happens during TTY menu
+handling. Lisp programs that set 'mouse-position-function' should
+also set this variable non-nil if they are compatible with the tty
+menu handling.
+
++++
+** New variables that hold default buffer names for shell output.
+The new constants 'shell-command-buffer-name' and
+'shell-command-buffer-name-async' store the default buffer names
+for the output of, respectively, synchronous and async shell
+commands.
+
+---
+** New variables 'read-char-choice-use-read-key' and 'y-or-n-p-use-read-key'.
+When non-nil, then functions 'read-char-choice' and 'y-or-n-p'
+(respectively) use the function 'read-key' to read a character instead
+of using the minibuffer.
+
++++
+** New variable 'global-minor-modes'.
+This variable holds a list of currently enabled global minor modes (as
+a list of symbols).
+
++++
+** New buffer-local variable 'local-minor-modes'.
+This permanently buffer-local variable holds a list of currently
+enabled non-global minor modes in the current buffer (as a list of
+symbols).
+
++++
+** New completion function 'affixation-function' to add prefix/suffix.
+It accepts a list of completions and should return a list where
+each element is a list with three elements: a completion,
+a prefix string, and a suffix string.
+
++++
+** New completion function 'group-function' for grouping candidates.
+It takes two arguments: a completion candidate and a 'transform' flag.
+
++++
+** New error symbol 'minibuffer-quit'.
+Signaling it has almost the same effect as 'quit' except that it
+doesn't cause keyboard macro termination.
+
++++
+** New error 'remote-file-error', a subcategory of 'file-error'.
+It is signaled if a remote file operation fails due to internal
+reasons, and could block Emacs. It does not replace 'file-error'
+signals for the usual cases. Timers, process filters and process
+functions, which run remote file operations, shall protect themselves
+against this error.
+
+If such an error occurs, please report this as bug via 'M-x report-emacs-bug'.
+Until it is solved you could ignore such errors by performing
+
+ (setq debug-ignored-errors (cons 'remote-file-error debug-ignored-errors))
+
++++
+** New macro 'named-let' added to subr-x.el.
+It provides Scheme's "named let" looping construct.
+
+---
+** Emacs now attempts to test for high-rate subprocess output more fairly.
+When several subprocesses produce output simultaneously at high rate,
+Emacs will now by default attempt to service them all in a round-robin
+fashion. Set the new variable 'process-prioritize-lower-fds' to a
+non-nil value to get back the old behavior, whereby after reading
+from a subprocess, Emacs would check for output of other subprocesses
+in a way that is likely to read from the same process again.
+
++++
+** 'set-process-buffer' now updates the process mark.
+The mark will be set to point to the end of the new buffer.
+
++++
+** 'unlock-buffer' displays warnings instead of signaling.
+Instead of signaling 'file-error' conditions for file system level
+errors, the function now calls 'display-warning' and continues as if
+the error did not occur.
+
++++
+** 'read-char-from-minibuffer' and 'y-or-n-p' support 'help-form'.
+If you bind 'help-form' to a non-nil value while calling these functions,
+then pressing 'C-h' ('help-char') causes the function to evaluate 'help-form'
+and display the result.
+
++++
+** 'read-number' now has its own history variable.
+Additionally, the function now accepts a HIST argument which can be
+used to specify a custom history variable.
+
++++
+** 'set-window-configuration' now takes two optional parameters,
+'dont-set-frame' and 'dont-set-miniwindow'. The first of these, when
+non-nil, instructs the function not to select the frame recorded in
+the configuration. The second prevents the current minibuffer being
+replaced by the one stored in the configuration.
+
+---
+** 'count-windows' now takes an optional parameter ALL-FRAMES.
+The semantics are as with 'walk-windows'.
+
++++
+** 'truncate-string-ellipsis' now uses '…' by default.
+Modes that use 'truncate-string-to-width' with non-nil, non-string
+argument ELLIPSIS, will now indicate truncation using '…' when
+the selected frame can display it, and using "..." otherwise.
+
++++
+** 'string-width' now accepts two optional arguments FROM and TO.
+This allows calculating the width of a substring without consing a
+new string.
+
++++
+** 'directory-files' now takes an additional COUNT parameter.
+The parameter makes 'directory-files' return COUNT first file names
+from a directory. If MATCH is also given, the function will return
+first COUNT file names that match the expression. The same COUNT
+parameter has been added to 'directory-files-and-attributes'.
+
++++
+** 'count-lines' can now ignore invisible lines.
+This is controlled by the optional parameter IGNORE-INVISIBLE-LINES.
+
+---
+** 'count-words' now crosses field boundaries.
+Originally, 'count-words' would stop counting at the first field
+boundary it encountered; now it keeps counting all the way to the
+region's (or buffer's) end.
+
++++
+** File-related APIs can optionally follow symlinks.
+The functions 'file-modes', 'set-file-modes', and 'set-file-times' now
+have an optional argument specifying whether to follow symbolic links.
+
++++
+** 'format-seconds' can now be used for sub-second times.
+The new optional "," parameter has been added, and
+'(format-seconds "%mm %,1ss" 66.4)' will now result in "1m 6.4s".
+
++++
+** 'parse-time-string' can now parse ISO 8601 format strings.
+These have a format like "2020-01-15T16:12:21-08:00".
+
+---
+** 'lookup-key' is more allowing when searching for extended menu items.
+When looking for a menu item '[menu-bar Foo-Bar]', first try to find
+an exact match, then look for the lowercased '[menu-bar foo-bar]'.
+It will only try to downcase ASCII characters in the range "A-Z".
+This improves backwards-compatibility when converting menus to use
+'easy-menu-define'.
+
+---
+** 'make-network-process', 'make-serial-process' ':coding' behavior change.
+Previously, passing ':coding nil' to either of these functions would
+override any non-nil binding for 'coding-system-for-read' and
+'coding-system-for-write'. For consistency with 'make-process' and
+'make-pipe-process', passing ':coding nil' is now ignored. No code in
+Emacs depended on the previous behavior; if you really want the
+process' coding-system to be nil, use 'set-process-coding-system'
+after the process has been created, or pass in ':coding '(nil nil)'.
+
++++
+** 'open-network-stream' now accepts a ':coding' argument.
+This allows specifying the coding systems used by a network process
+for encoding and decoding without having to bind
+'coding-system-for-{read,write}' or call 'set-process-coding-system'.
+
++++
+** 'open-network-stream' can now take a ':capability-command' that's a function.
+The function is called with the greeting from the server as its only
+parameter, and allows sending different TLS capability commands to the
+server based on that greeting.
+
++++
+** 'open-gnutls-stream' now also accepts a ':coding' argument.
+
+---
+** 'process-attributes' now works under OpenBSD, too.
+
++++
+** 'format-spec' now takes an optional SPLIT parameter.
+If non-nil, 'format-spec' will split the resulting string into a list
+of strings, based on where the format specs (and expansions) were.
+
+---
+** 'unload-feature' now also tries to undo additions to buffer-local hooks.
+
+---
+** 'while-no-input-ignore-events' accepts more special events.
+The special events 'dbus-event' and 'file-notify' are now ignored in
+'while-no-input' when added to this variable.
+
+---
+** 'start-process-shell-command' and 'start-file-process-shell-command'
+do not support the old calling conventions any longer.
+
++++
+** 'yes-or-no-p' and 'y-or-n-p' PROMPT parameter no longer needs trailing space.
+In other words, the prompt can now end with "?" instead of "? ". This
+has been the case since Emacs 24.4 but was not announced or documented
+until now. (Checkdoc has also been updated to accept this convention.)
+
++++
+** The 'uniquify' argument in 'auto-save-file-name-transforms' can be a symbol.
+If this symbol is one of the members of 'secure-hash-algorithms',
+Emacs constructs the nondirectory part of the auto-save file name by
+applying that 'secure-hash' to the buffer file name. This avoids any
+risk of excessively long file names.
+
++++
+** New user option 'process-file-return-signal-string'.
+It controls, whether 'process-file' returns a string when a remote
+process is interrupted by a signal.
+
+** EIEIO Changes
+
++++
+*** The macro 'oref-default' can now be used with 'setf'.
+It is now defined as a generalized variable that can be used with
+'setf' to modify the value stored in a given class slot.
+
+---
+*** 'form' in '(eql form)' specializers in 'cl-defmethod' is now evaluated.
+This corresponds to the behavior of defmethod in Common Lisp Object System.
+For compatibility, '(eql SYMBOL)' does not evaluate SYMBOL, for now.
+
+** D-Bus
+
++++
+*** Property values can be typed explicitly.
+'dbus-register-property' and 'dbus-set-property' accept now optional
+type symbols. Both functions propagate D-Bus errors.
+
++++
+*** Registered properties can have the new access type ':write'.
+
++++
+*** In case of problems, handlers can emit proper D-Bus error messages now.
+
++++
+*** D-Bus errors, which have been converted from incoming D-Bus error
+messages, contain the error name of that message now.
+
++++
+*** D-Bus messages can be monitored with the new command 'dbus-monitor'.
+
++++
+*** D-Bus events have changed their internal structure.
+They carry now the destination and the error-name of an event. They
+also keep the type information of their arguments. Use the
+'dbus-event-*' accessor functions.
+
+** Buttons
+
++++
+*** New minor mode 'button-mode'.
+This minor mode does nothing except install 'button-buffer-map' as
+a minor mode map (which binds the 'TAB' / 'S-TAB' key bindings to navigate
+to buttons), and can be used in any view-mode-like buffer that has
+buttons in it.
+
++++
+*** New utility function 'button-buttonize'.
+This function takes a string and returns a string propertized in a way
+that makes it a valid button.
+
+---
+** 'text-scale-mode' can now adjust font size of the header line.
+When the new buffer local variable 'text-scale-remap-header-line'
+is non-nil, 'text-scale-adjust' will also scale the text in the header
+line when displaying that buffer.
+
+This is useful for major modes that arrange their display in a tabular
+form below the header line. It is enabled by default in
+'tabulated-list-mode' and its derived modes, and disabled by default
+elsewhere.
+
+---
+** 'ascii' is now a coding system alias for 'us-ascii'.
+
+---
+** New coding-systems for EBCDIC variants.
+New coding-systems 'ibm256', 'ibm273', 'ibm274', 'ibm277', 'ibm278',
+'ibm280', 'ibm281', 'ibm284', 'ibm285', 'ibm290', 'ibm297'. These are
+variants of the EBCDIC encoding tailored to some European and Japanese
+locales. They are also available as aliases 'ebcdic-cp-*' (e.g.,
+'ebcdic-cp-fi' for the Finnish variant 'ibm278'), and 'cp2xx' (e.g.,
+'cp278' for 'ibm278'). There are also new charsets 'ibm2xx' to
+support these coding-systems.
+
++++
+** New 'Bindat type expression' description language.
+This new system is provided by the new macro 'bindat-type' and
+obsoletes the old data layout specifications. It supports
+arbitrary-size integers, recursive types, and more. See the Info node
+"(elisp) Byte Packing" in the ELisp manual for more details.
+
++++
+** New macro 'with-environment-variables'.
+This macro allows setting environment variables temporarily when
+executing a form.
+
+
+* Changes in Emacs 28.1 on Non-Free Operating Systems
+
++++
+** On MS-Windows, Emacs can now use the native image API to display images.
+Emacs can now use the MS-Windows GDI+ library to load and display
+images in JPEG, PNG, GIF and TIFF formats. This support is available
+unless Emacs was configured '--without-native-image-api'.
+
+This feature is experimental, and needs to be turned on to be used.
+To turn this on, set the variable 'w32-use-native-image-API' to a
+non-nil value. Please report any bugs you find while using the native
+image API via 'M-x report-emacs-bug'.
+
++++
+** On MS-Windows, Emacs can now toggle the IME.
+A new function 'w32-set-ime-open-status' can now be used to disable
+and enable the MS-Windows native Input Method Editor (IME) at run
+time. A companion function 'w32-get-ime-open-status' returns the
+current IME activation status.
+
+--
+** On macOS, 's-<left>' and 's-<right>' are now bound to
+'move-beginning-of-line' and 'move-end-of-line' respectively. The commands
+to select previous/next frame are still bound to 's-~' and 's-`'.
+
++++
+** On macOS, Emacs can now load dynamic modules with a ".dylib" suffix.
+'module-file-suffix' now has the value ".dylib" on macOS, but the
+".so" suffix is supported as well.
+
+---
+** On macOS, the user option 'make-pointer-invisible' is now honored.
+
+---
+** On macOS, Xwidget is now supported.
+If Emacs was built with xwidget support, you can access the embedded
+webkit browser with 'M-x xwidget-webkit-browse-url'. Viewing two
+instances of xwidget webkit is not supported.
+
+---
+*** New user option 'xwidget-webkit-enable-plugins'.
+If non-nil, enable plugins in xwidget. (This is only available on
+macOS.)
+
++++
+** New macOS Contacts back-end for EUDC.
+This backend works on newer versions of macOS and is generally
+preferred over the eudcb-mab.el backend.
+
+
+----------------------------------------------------------------------
+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
+paragraph-separate: "[ ]*$"
+end:
diff --git a/etc/PROBLEMS b/etc/PROBLEMS
index f94d8492d57..e70f61b7192 100644
--- a/etc/PROBLEMS
+++ b/etc/PROBLEMS
@@ -1022,6 +1022,15 @@ modern fonts are used, such as Noto Emoji or Ebrima.
The solution is to switch to a configuration that uses HarfBuzz as its
shaping engine, where these problems don't exist.
+** On Haiku, some proportionally-spaced fonts display with artifacting.
+
+This is a Haiku bug: https://dev.haiku-os.org/ticket/17229, which can
+be remedied by using a different font that does not exhibit this
+problem, or by configuring Emacs '--with-be-cairo'.
+
+So far, Bitstream Charter and Noto Sans have been known to exhibit
+this problem, while Noto Sans Display is known to not do so.
+
* Internationalization problems
** M-{ does not work on a Spanish PC keyboard.
@@ -1087,13 +1096,30 @@ The solution is to remove the corresponding lines from the appropriate
'fonts.alias' file, then run 'mkfontdir' in that directory, and then run
'xset fp rehash'.
-** The 'oc-unicode' package doesn't work with Emacs 21.
+** fcitx input methods don't work with xwidgets.
+
+fcitx-based input methods might not work when xwidgets are displayed,
+such as inside an xwidget-webkit buffer. This manifests as the pre-edit
+window of the input method disappearing, and the Emacs frame losing
+input focus as soon as you try to type anything. You can work around
+this problem by switching to IBus, or by using a native Emacs input
+method and disabling XIM altogether. For example, you can add the
+following line:
+
+ Emacs.useXIM: false
+
+In your ~/.Xresources file, then run
-This package tries to define more private charsets than there are free
-slots now. The current built-in Unicode support is actually more
-flexible. (Use option 'utf-translate-cjk-mode' if you need CJK
-support.) Files encoded as emacs-mule using oc-unicode aren't
-generally read correctly by Emacs 21.
+ $ xrdb ~/.Xresources
+
+And restart Emacs.
+
+** On Haiku, BeCJK doesn't work properly with Emacs
+
+Some popular Haiku input methods such BeCJK are known to behave badly
+when interacting with Emacs, in ways such as stealing input focus and
+displaying popup windows that don't disappear. If you are affected,
+you should use an Emacs input method instead.
* X runtime problems
@@ -1302,6 +1328,12 @@ A better approach might be to avoid navigation from Nautilus to Emacs
for such files, and instead to open the file in Emacs using Tramp
remote file name syntax.
+*** Gnome: GTK builds with XInput2 freeze when making a frame fullscreen.
+
+This problem exists with GTK 3.24.30 in GNOME 41.1 and possibly other
+versions. The solution is to upgrade GNOME Shell to the version that
+comes with GNOME 41.2.
+
*** KDE: When running on KDE, colors or fonts are not as specified for Emacs,
or messed up.
@@ -2292,20 +2324,6 @@ are compiling with the system's 'cc' and CFLAGS containing '-O5'. If
so, you have hit a compiler bug. Please make sure to re-configure
Emacs so that it isn't compiled with '-O5'.
-*** AIX 4.3.x or 4.4: Compiling fails.
-
-This could happen if you use /bin/c89 as your compiler, instead of
-the default 'cc'. /bin/c89 treats certain warnings, such as benign
-redefinitions of macros, as errors, and fails the build. A solution
-is to use the default compiler 'cc'.
-
-*** AIX 4: Some programs fail when run in a Shell buffer
-with an error message like No terminfo entry for "unknown".
-
-On AIX, many terminal type definitions are not installed by default.
-'unknown' is one of them. Install the "Special Generic Terminal
-Definitions" to make them defined.
-
** Solaris
We list bugs in current versions here. See also the section on legacy
@@ -2357,13 +2375,6 @@ runtime shared library, distributed with Windows 9X.
A workaround is to build Emacs with MinGW runtime 3.x (the latest
version is 3.20).
-** addpm fails to run on Windows NT4, complaining about Shell32.dll
-
-This is likely to happen because Shell32.dll shipped with NT4 lacks
-the updates required by Emacs. Installing Internet Explorer 4 solves
-the problem. Note that it is NOT enough to install IE6, because doing
-so will not install the Shell32.dll update.
-
** A few seconds delay is seen at startup and for many file operations
This happens when the Net Logon service is enabled. During Emacs
@@ -2477,15 +2488,6 @@ C:\Users\<UserName>\):
Look for the file 'emacs.lnk' there.
-** Windows 95 and networking.
-
-To support server sockets, Emacs loads ws2_32.dll. If this file is
-missing, all Emacs networking features are disabled.
-
-Old versions of Windows 95 may not have the required DLL. To use
-Emacs's networking features on Windows 95, you must install the
-"Windows Socket 2" update available from MicroSoft's support Web.
-
** Emacs exits with "X protocol error" when run with an X server for MS-Windows.
A certain X server for Windows had a bug which caused this.
@@ -2522,11 +2524,6 @@ other) messages while waiting for a system function, which popped up
the menu/dialog, to return the result of the dialog or pop-up menu
interaction.
-** Help text in tooltips does not work on old Windows versions
-
-Windows 95 and Windows NT up to version 4.0 do not support help text
-for menus. Help text is only available in later versions of Windows.
-
** Display problems with ClearType method of smoothing
When "ClearType" method is selected as the "method to smooth edges of
@@ -3145,15 +3142,6 @@ of PURESIZE in puresize.h.
But in some of the cases listed above, this problem is a consequence
of something else that is wrong. Be sure to check and fix the real problem.
-*** OpenBSD 4.0 macppc: Segfault during dumping.
-
-The build aborts with signal 11 when the command './temacs --batch
---load loadup bootstrap' tries to load files.el. A workaround seems
-to be to reduce the level of compiler optimization used during the
-build (from -O2 to -O1). It is possible this is an OpenBSD
-GCC problem specific to the macppc architecture, possibly only
-occurring with older versions of GCC (e.g. 3.3.5).
-
*** openSUSE 10.3: Segfault in bcopy during dumping.
This is due to a bug in the bcopy implementation in openSUSE 10.3.
@@ -3308,8 +3296,51 @@ should do.
pen@lysator.liu.se says (Feb 1998) that the Compose key does work
if you link with the MIT X11 libraries instead of the Solaris X11 libraries.
+** OpenBSD
+
+*** OpenBSD 4.0 macppc: Segfault during dumping.
+
+The build aborts with signal 11 when the command './temacs --batch
+--load loadup bootstrap' tries to load files.el. A workaround seems
+to be to reduce the level of compiler optimization used during the
+build (from -O2 to -O1). It is possible this is an OpenBSD
+GCC problem specific to the macppc architecture, possibly only
+occurring with older versions of GCC (e.g. 3.3.5).
+
+** AIX
+
+*** AIX 4.3.x or 4.4: Compiling fails.
+
+This could happen if you use /bin/c89 as your compiler, instead of
+the default 'cc'. /bin/c89 treats certain warnings, such as benign
+redefinitions of macros, as errors, and fails the build. A solution
+is to use the default compiler 'cc'.
+
+*** AIX 4: Some programs fail when run in a Shell buffer
+with an error message like No terminfo entry for "unknown".
+
+On AIX, many terminal type definitions are not installed by default.
+'unknown' is one of them. Install the "Special Generic Terminal
+Definitions" to make them defined.
+
** MS-Windows 95, 98, ME, and NT
+*** MS-Windows 95: Networking.
+
+To support server sockets, Emacs loads ws2_32.dll. If this file is
+missing, all Emacs networking features are disabled.
+
+Old versions of Windows 95 may not have the required DLL. To use
+Emacs's networking features on Windows 95, you must install the
+"Windows Socket 2" update available from MicroSoft's support Web.
+
+*** MS-Windows NT4: addpm fails to run, complaining about Shell32.dll
+
+This is likely to happen because Shell32.dll shipped with NT4 lacks
+the updates required by Emacs. Installing Internet Explorer 4 solves
+the problem. Note that it is NOT enough to install IE6, because doing
+so will not install the Shell32.dll update.
+
*** MS-Windows NT/95: Problems running Perl under Emacs
'perl -de 0' just hangs when executed in an Emacs subshell.
@@ -3373,6 +3404,11 @@ For Perl 4:
}
else {
+*** MS-Windows NT/95: Help text in tooltips does not work
+
+Windows 95 and Windows NT up to version 4.0 do not support help text
+for menus. Help text is only available in later versions of Windows.
+
*** MS-Windows 95: Alt-f6 does not get through to Emacs.
This character seems to be trapped by the kernel in Windows 95.
diff --git a/etc/TODO b/etc/TODO
index cd06b1ea26e..22f5c099607 100644
--- a/etc/TODO
+++ b/etc/TODO
@@ -80,6 +80,10 @@ all interactive commands to see if they are only relevant in one
particular mode. This requires care as some commands might be useful
outside of the mode they were written for.
+** Convert defvar foo-mode-map to defvar-keymap
+Verify the conversion by comparing the value of the keymap before
+converting it and after (you can see the value in 'C-h v').
+
** Write more tests
Pick a fixed bug from the database, write a test case to make sure it
stays fixed. Or pick your favorite programming major-mode, and write
diff --git a/etc/compilation.txt b/etc/compilation.txt
index 01d4df1b09d..34d8c53c9a6 100644
--- a/etc/compilation.txt
+++ b/etc/compilation.txt
@@ -310,6 +310,9 @@ G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found.
file:G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found.
{standard input}:27041: Warning: end of file not at end of a line; newline inserted
boost/container/detail/flat_tree.hpp:589:25: [ skipping 5 instantiation contexts, use -ftemplate-backtrace-limit=0 to disable ]
+ |
+ |board.h:60:21:
+ | 60 | #define I(b, C) ((C).y * (b)->width + (C).x)
* Guile backtrace, 2.0.11
diff --git a/etc/e/README b/etc/e/README
index dd2c8d64e25..1293292a878 100644
--- a/etc/e/README
+++ b/etc/e/README
@@ -1,12 +1,12 @@
-eterm-color.ti is a terminfo source file. eterm-color is a compiled
-version produced by the terminfo compiler (tic). The compiled files
-are binary, and depend on the version of tic, but they seem to be
-system-independent and backwardly compatible. So there should be no
-need to recompile the distributed binary version. If it is
-necessary, use:
+eterm-color.ti is a terminfo source file. eterm-color and
+eterm-direct are compiled versions produced by the terminfo compiler
+(tic). The compiled files are binary, and depend on the version of
+tic, but they seem to be system-independent and backwardly compatible.
+So there should be no need to recompile the distributed binary
+version. If it is necessary, use:
tic -o ../ ./eterm-color.ti
-The compiled file is used by lisp/term.el, so if it is moved term.el
-needs to be changed. terminfo requires it to be stored in an 'e'
-subdirectory (the first character of the file name).
+The compiled files are used by lisp/term.el, so if they are moved,
+term.el needs to be changed. terminfo requires them to be stored in
+an 'e' subdirectory (the first character of the file name).
diff --git a/etc/e/eterm-color b/etc/e/eterm-color
index bd3f5003ae6..bf44fa0f36d 100644
--- a/etc/e/eterm-color
+++ b/etc/e/eterm-color
Binary files differ
diff --git a/etc/e/eterm-color.ti b/etc/e/eterm-color.ti
index a6ef8149900..eeb9b0b6e6a 100644
--- a/etc/e/eterm-color.ti
+++ b/etc/e/eterm-color.ti
@@ -9,15 +9,16 @@ eterm-color|Emacs term.el terminal emulator term-protocol-version 0.96,
# Any change to this file should be done at the same time with a
# corresponding change to the TERMCAP environment variable in term.el.
# Comments in term.el specify where each of these capabilities is implemented.
- colors#8,
+ colors#256,
cols#80,
lines#24,
- pairs#64,
+ pairs#32767,
am,
mir,
msgr,
xenl,
bel=^G,
+ blink=\E[5m,
bold=\E[1m,
clear=\E[H\E[J,
cr=\r,
@@ -31,6 +32,7 @@ eterm-color|Emacs term.el terminal emulator term-protocol-version 0.96,
cup=\E[%i%p1%d;%p2%dH,
cuu1=\E[A,
cuu=\E[%p1%dA,
+ dim=\E[2m,
dch1=\E[P,
dch=\E[%p1%dP,
dl1=\E[M,
@@ -60,14 +62,16 @@ eterm-color|Emacs term.el terminal emulator term-protocol-version 0.96,
rc=\E8,
rev=\E[7m,
ri=\EM,
+ ritm=\E[23m,
rmir=\E[4l,
rmso=\E[27m,
rmul=\E[24m,
rs1=\Ec,
sc=\E7,
- setab=\E[%p1%{40}%+%dm,
- setaf=\E[%p1%{30}%+%dm,
+ setab=\E[%?%p1%{8}%<%t4%p1%d%e%p1%{16}%<%t10%p1%{8}%-%d%e48;5;%p1%d%;m,
+ setaf=\E[%?%p1%{8}%<%t3%p1%d%e%p1%{16}%<%t9%p1%{8}%-%d%e38;5;%p1%d%;m,
sgr0=\E[m,
+ sitm=\E[3m,
smir=\E[4h,
smul=\E[4m,
smso=\E[7m,
@@ -76,3 +80,10 @@ eterm-color|Emacs term.el terminal emulator term-protocol-version 0.96,
# smcup=\E[?47h,
# rmcup=\E[?47l,
# rs2 may need to be added
+
+eterm-direct|Emacs term.el with direct-color indexing term-protocol-version 0.96,
+ use=eterm-color,
+ colors#0x1000000,
+ pairs#0x10000,
+ setab=\E[%?%p1%{8}%<%t4%p1%d%e48;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m,
+ setaf=\E[%?%p1%{8}%<%t3%p1%d%e38;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m,
diff --git a/etc/e/eterm-direct b/etc/e/eterm-direct
new file mode 100644
index 00000000000..c113c371369
--- /dev/null
+++ b/etc/e/eterm-direct
Binary files differ
diff --git a/etc/images/README b/etc/images/README
index 9bbe796cc95..561cfff7653 100644
--- a/etc/images/README
+++ b/etc/images/README
@@ -68,6 +68,7 @@ Emacs images and their source in the GNOME icons stock/ directory:
bookmark_add.xpm actions/bookmark_add
cancel.xpm slightly modified generic/stock_stop
connect.xpm net/stock_connect
+ connect-to-url.xpm net/stock_connect-to-url
contact.xpm net/stock_contact
data-save.xpm data/stock_data-save
delete.xpm generic/stock_delete
diff --git a/etc/images/connect-to-url.pbm b/etc/images/connect-to-url.pbm
new file mode 100644
index 00000000000..f142349f4a9
--- /dev/null
+++ b/etc/images/connect-to-url.pbm
Binary files differ
diff --git a/etc/images/connect-to-url.xpm b/etc/images/connect-to-url.xpm
new file mode 100644
index 00000000000..38fefeaf611
--- /dev/null
+++ b/etc/images/connect-to-url.xpm
@@ -0,0 +1,281 @@
+/* XPM */
+static char *connect_to_url[] = {
+/* columns rows colors chars-per-pixel */
+"24 24 251 2 ",
+" c black",
+". c #010101",
+"X c #000103",
+"o c #010204",
+"O c #010305",
+"+ c #020407",
+"@ c #020609",
+"# c #03070C",
+"$ c #04080D",
+"% c #0F0F0D",
+"& c #030A10",
+"* c #050B10",
+"= c #060C11",
+"- c #070D13",
+"; c #070D14",
+": c #060C15",
+"> c #070E14",
+", c #0B1824",
+"< c #0A1B2B",
+"1 c #0A1C2E",
+"2 c #141A20",
+"3 c #161E25",
+"4 c #181E23",
+"5 c #0D2032",
+"6 c #142534",
+"7 c #1F2830",
+"8 c #1D2933",
+"9 c #102438",
+"0 c #272622",
+"q c #21292F",
+"w c #272F36",
+"e c #282F33",
+"r c #222F3A",
+"t c #2E3337",
+"y c #2D373E",
+"u c #32383C",
+"i c #33383C",
+"p c #343A3E",
+"a c #43423C",
+"s c #112941",
+"d c #102A44",
+"f c #132D47",
+"g c #192F46",
+"h c #17314B",
+"j c #15314F",
+"k c #163351",
+"l c #163554",
+"z c #173554",
+"x c #1F3A53",
+"c c #1D3955",
+"v c #1A3958",
+"b c #1C3B5B",
+"n c #1F3C58",
+"m c #1D3C5C",
+"M c #1E3E5D",
+"N c #1F3F5F",
+"B c #303B44",
+"V c #313C44",
+"C c #313D47",
+"Z c #213C56",
+"A c #233E57",
+"S c #1F405F",
+"D c #374148",
+"F c #2D4050",
+"G c #25405B",
+"H c #25425E",
+"J c #214262",
+"K c #244565",
+"L c #264665",
+"P c #254666",
+"I c #2A4967",
+"U c #284969",
+"Y c #2A4C6C",
+"T c #2C4F6F",
+"R c #33526E",
+"E c #385269",
+"W c #2D5070",
+"Q c #2E5172",
+"! c #335473",
+"~ c #3F5B75",
+"^ c #3D5F7D",
+"/ c #41494F",
+"( c #646056",
+") c #6C685E",
+"_ c #505F6C",
+"` c #48657C",
+"' c #556A7A",
+"] c #5B6C78",
+"[ c #5F6F7B",
+"{ c #5D6F7D",
+"} c #706C62",
+"| c #726D63",
+" . c #78756B",
+".. c #7D786E",
+"X. c #60727F",
+"o. c #807D74",
+"O. c #8A857B",
+"+. c #8B877E",
+"@. c #4E6A83",
+"#. c #4A6A86",
+"$. c #4A7090",
+"%. c #587790",
+"&. c #5F7E95",
+"*. c #587B98",
+"=. c #6F7980",
+"-. c #697F8F",
+";. c #66839B",
+":. c #6A879F",
+">. c #708391",
+",. c #728A9A",
+"<. c #748898",
+"1. c #758A99",
+"2. c #7B8F9F",
+"3. c #708DA4",
+"4. c #7990A1",
+"5. c #7292AB",
+"6. c #7691A8",
+"7. c #7693AB",
+"8. c #7B98AE",
+"9. c #7E98AD",
+"0. c #7E9DB3",
+"q. c #7F9EB4",
+"w. c #8C8981",
+"e. c #989389",
+"r. c #A6A29B",
+"t. c #8093A1",
+"y. c #8598A3",
+"u. c #8498A7",
+"i. c #809AAD",
+"p. c #8F9FAA",
+"a. c #899FAE",
+"s. c #819FB5",
+"d. c #86A2B8",
+"f. c #87A5BB",
+"g. c #88A3B8",
+"h. c #89A5BA",
+"j. c #8FABBF",
+"k. c #97A7B1",
+"l. c #90AABE",
+"z. c #91ABBF",
+"x. c #98ACB9",
+"c. c #AAA7A0",
+"v. c #B1ADA4",
+"b. c #B3B1AA",
+"n. c #B7B3AA",
+"m. c #A3B1BC",
+"M. c #A5B1BC",
+"N. c #A9B6BF",
+"B. c #BEBBB5",
+"V. c #C4C2BD",
+"C. c #94AEC1",
+"Z. c #96AEC1",
+"A. c #94AFC2",
+"S. c #95AFC2",
+"D. c #96B0C3",
+"F. c #98B0C3",
+"G. c #9FB5C3",
+"H. c #99B3C6",
+"J. c #98B3C7",
+"K. c #9AB3C6",
+"L. c #9BB4C7",
+"P. c #9FB8CA",
+"I. c #9FB8CB",
+"U. c #A2B8C9",
+"Y. c #A3B9C9",
+"T. c #A0B9CB",
+"R. c #A3BACB",
+"E. c #A0B9CC",
+"W. c #A2BACC",
+"Q. c #A4BDCE",
+"!. c #A6BECF",
+"~. c #B8BEC2",
+"^. c #B8C3CA",
+"/. c #BCC5CB",
+"(. c #BDC8CE",
+"). c #A8C0D1",
+"_. c #AAC0D0",
+"`. c #ABC1D1",
+"'. c #ACC2D3",
+"]. c #AAC5D7",
+"[. c #B4C8D6",
+"{. c #BDCBD5",
+"}. c #B4C9D8",
+"|. c #B6CAD8",
+" X c #B8CBD9",
+".X c #BBCDDB",
+"XX c #B7D0E0",
+"oX c #BDD3E2",
+"OX c #BCD5E5",
+"+X c #CECAC3",
+"@X c #C5D2C8",
+"#X c #C0D2DE",
+"$X c #C4D3DF",
+"%X c #CCD7DE",
+"&X c #D2D8DC",
+"*X c #E1DFDB",
+"=X c #E2E1DD",
+"-X c #C2D3E0",
+";X c #C2D4E1",
+":X c #C5D5E1",
+">X c #C6D6E1",
+",X c #C4D6E2",
+"<X c #C5D6E3",
+"1X c #C6D7E3",
+"2X c #C3D7E4",
+"3X c #C1D7E6",
+"4X c #C7D8E3",
+"5X c #C5D8E5",
+"6X c #C7D9E5",
+"7X c #CBD9E4",
+"8X c #CBDAE5",
+"9X c #CDDAE4",
+"0X c #CCDBE5",
+"qX c #CFDBE5",
+"wX c #CBDCE7",
+"eX c #C0D9E8",
+"rX c #C2DBEA",
+"tX c #C4DAE8",
+"yX c #D0DEE7",
+"uX c #D1DFE8",
+"iX c #D0DFE9",
+"pX c #D0E0EA",
+"aX c #D1E1EB",
+"sX c #D3E1EA",
+"dX c #D4E1E9",
+"fX c #D4E1EA",
+"gX c #D5E2EA",
+"hX c #D4E2EB",
+"jX c #D6E2EB",
+"kX c #D3E2EC",
+"lX c #D8E3EA",
+"zX c #DFE6EB",
+"xX c #D9E4EC",
+"cX c #D9E5ED",
+"vX c #DAE5ED",
+"bX c #DAE6ED",
+"nX c #DCE7EE",
+"mX c #DBE8EF",
+"MX c #DDE8EF",
+"NX c #DFE8EF",
+"BX c #EAE8E3",
+"VX c #EBEAE6",
+"CX c #ECEBE8",
+"ZX c #E9EEEA",
+"AX c #F0EFEC",
+"SX c #F2F0ED",
+"DX c #E1ECF3",
+"FX c #E4EDF3",
+"GX c #E8EFF4",
+"HX c #F0F3F1",
+"JX c None",
+/* pixels */
+"JXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJX",
+"JXJXJXJXJXJXJXJXu D p t i V w JXJXJXJXJXJXJXJXJX",
+"JXJXJXJXJXJXC X./.&XDXGX%X{.m._ r JXJXJXJXJXJXJX",
+"JXJXJXJXJXi /.DXnXnXFXuX7X$X$XjXM.w JXJXJXJXJXJX",
+"JXJXJXJX/ ^.qXbX1XkX5X5X-X;XsXqXjXN.B JXJXJXJXJX",
+"JXJXJXe (.bXMXDXaXtXtX3XoXbXjXsXyX7Xx.q JXJXJXJX",
+"JXJX7 k.jXbXbX5X3XeXrXOXXX1XsXyXwX$X|.4.3 JXJXJX",
+"JXJXX.:XuXjX'.]._.y. G.sXW.|..X$X[.H.' JXJXJX",
+"JXJXu.$XqXT.H.>. e.o. sXwX}.R.R.`.H.1.- JXJX",
+"JX4 a.9.C.h.] a n.V.BXo. p.!.T.l.4.- JXJX",
+"JX2 F.d.5.7. =XAXc.BXo. @X@XZX !.C.F.@.> JXJX",
+" o.=XAXc.BXo. t.U.z.3.Y $ JXJX",
+"BXBXBXBXVXBXBXAXVXO.CXo. P.C.!.I.J.C.;.L * JXJX",
+"o.o.o.o.o. . .B.b...*X . $.*.T.J.A.h.Y c @ JXJX",
+" .w.r.| +X . 1.C.3.L h JXJX",
+"JXJX6 Q ^ 1.% w.r.| +X . @X@XHX h.:.M , JXJX",
+"JXJXO x T #.] 0 +.} v.) -.s.H 9 O JXJXJX",
+"JXJXJX+ n ! i.X.% % e.( Q Y %.0.&.f O JXJXJX",
+"JXJXJXJX& A s.8.E A % % A K J R ` g @ JXJXJXJX",
+"JXJXJXJXJX@ C ~ m M J N M b v l < O JXJXJXJXJX",
+"JXJXJXJXJXJX : 5 d k z k d 1 & JXJXJXJXJXJX",
+"JXJXJXJXJXJXJXJX JXJXJXJXJXJXJXJX",
+"JXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJX",
+"JXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJX"
+};
diff --git a/etc/org.gnu.emacs.defaults.gschema.xml b/etc/org.gnu.emacs.defaults.gschema.xml
new file mode 100644
index 00000000000..7c700ac0b65
--- /dev/null
+++ b/etc/org.gnu.emacs.defaults.gschema.xml
@@ -0,0 +1,51 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!-- Copyright (C) 2019-2020 Free Software Foundation, Inc. -->
+<schemalist>
+
+ <schema id="org.gnu.emacs.defaults">
+
+ <key name='alpha' type='s'><default>''</default></key>
+ <key name='auto-raise-lower' type='s'><default>''</default></key>
+ <key name='auto-lower' type='s'><default>''</default></key>
+ <key name='auto-raise' type='s'><default>''</default></key>
+ <key name='background' type='s'><default>''</default></key>
+ <key name='background-mode' type='s'><default>''</default></key>
+ <key name='bitmap-icon' type='s'><default>''</default></key>
+ <key name='border-color' type='s'><default>''</default></key>
+ <key name='border-width' type='s'><default>''</default></key>
+ <key name='buffer-predicate' type='s'><default>''</default></key>
+ <key name='cursor-blink' type='s'><default>''</default></key>
+ <key name='cursor-type' type='s'><default>''</default></key>
+ <key name='cursor-color' type='s'><default>''</default></key>
+ <key name='font' type='s'><default>''</default></key>
+ <key name='font-backend' type='s'><default>''</default></key>
+ <key name='foreground' type='s'><default>''</default></key>
+ <key name='fullscreen' type='s'><default>''</default></key>
+ <key name='horizontal-scroll-bars' type='s'><default>''</default></key>
+ <key name='icon-name' type='s'><default>''</default></key>
+ <key name='inhibit-double-buffering' type='s'><default>''</default></key>
+ <key name='internal-border' type='s'><default>''</default></key>
+ <key name='internal-border-width' type='s'><default>''</default></key>
+ <key name='left-fringe' type='s'><default>''</default></key>
+ <key name='line-spacing' type='s'><default>''</default></key>
+ <key name='menu-bar' type='s'><default>''</default></key>
+ <key name='minibuffer' type='s'><default>''</default></key>
+ <key name='name' type='s'><default>''</default></key>
+ <key name='pointer-color' type='s'><default>''</default></key>
+ <key name='reverse-video' type='s'><default>''</default></key>
+ <key name='right-fringe' type='s'><default>''</default></key>
+ <key name='screen-gamma' type='s'><default>''</default></key>
+ <key name='scroll-bar' type='s'><default>''</default></key>
+ <key name='scroll-bar-background' type='s'><default>''</default></key>
+ <key name='scroll-bar-foreground' type='s'><default>''</default></key>
+ <key name='scroll-bar-height' type='s'><default>''</default></key>
+ <key name='scroll-bar-width' type='s'><default>''</default></key>
+ <key name='scroll-bars' type='s'><default>''</default></key>
+ <key name='title' type='s'><default>''</default></key>
+ <key name='tool-bar' type='s'><default>''</default></key>
+ <key name='vertical-scroll-bars' type='s'><default>''</default></key>
+ <key name='wait-for-w-m' type='s'><default>''</default></key>
+
+ </schema>
+
+</schemalist>
diff --git a/etc/publicsuffix.txt b/etc/publicsuffix.txt
index 5cc95b9000c..5529554d82d 100644
--- a/etc/publicsuffix.txt
+++ b/etc/publicsuffix.txt
@@ -7132,7 +7132,7 @@ org.zw
// newGTLDs
-// List of new gTLDs imported from https://www.icann.org/resources/registries/gtlds/v2/gtlds.json on 2021-10-08T15:12:46Z
+// List of new gTLDs imported from https://www.icann.org/resources/registries/gtlds/v2/gtlds.json on 2021-11-13T15:12:42Z
// This list is auto-generated, don't edit it manually.
// aaa : 2015-02-26 American Automobile Association, Inc.
aaa
@@ -7647,7 +7647,7 @@ cars
// casa : 2013-11-21 Registry Services, LLC
casa
-// case : 2015-09-03 CNH Industrial N.V.
+// case : 2015-09-03 Helium TLDs Ltd
case
// cash : 2014-03-06 Binky Moon, LLC
@@ -10317,9 +10317,6 @@ xin
// xn--3ds443g : 2013-09-08 TLD REGISTRY LIMITED OY
在线
-// xn--3oq18vl8pn36a : 2015-07-02 Volkswagen (China) Investment Co., Ltd.
-大众汽车
-
// xn--3pxu8k : 2015-01-15 VeriSign Sarl
点看
@@ -10785,10 +10782,6 @@ s3-website.eu-west-2.amazonaws.com
s3-website.eu-west-3.amazonaws.com
s3-website.us-east-2.amazonaws.com
-// Amsterdam Wireless: https://www.amsterdamwireless.nl/
-// Submitted by Imre Jonk <hostmaster@amsterdamwireless.nl>
-amsw.nl
-
// Amune : https://amune.org/
// Submitted by Team Amune <cert@amune.org>
t3l3p0rt.net
@@ -10982,7 +10975,6 @@ za.com
// No longer operated by CentralNic, these entries should be adopted and/or removed by current operators
// Submitted by Gavin Brown <gavin.brown@centralnic.com>
ar.com
-gb.com
hu.com
kr.com
no.com
@@ -11036,10 +11028,6 @@ cx.ua
discourse.group
discourse.team
-// ClearVox : http://www.clearvox.nl/
-// Submitted by Leon Rowland <leon@clearvox.nl>
-virtueeldomein.nl
-
// Clever Cloud : https://www.clever-cloud.com/
// Submitted by Quentin Adam <noc@clever-cloud.com>
cleverapps.io
@@ -11642,12 +11630,6 @@ blogsite.xyz
// Submitted by Dominik Menke <dom@digineo.de>
dynv6.net
-// Ellucian : https://ellucian.com
-// Submitted by Josue Colon <CloudOps-Network@ellucian.com>
-elluciancrmadvance.com
-elluciancrmadvise.com
-elluciancrmrecruit.com
-
// E4YOU spol. s.r.o. : https://e4you.cz/
// Submitted by Vladimir Dudr <info@e4you.cz>
e4.cz
@@ -11915,6 +11897,11 @@ fireweb.app
// Submitted by Louis Chemineau <louis@chmn.me>
flap.id
+// FlashDrive : https://flashdrive.io
+// Submitted by Eric Chan <support@flashdrive.io>
+onflashdrive.app
+fldrv.com
+
// fly.io: https://fly.io
// Submitted by Kurt Mackey <kurt@fly.io>
fly.dev
diff --git a/etc/refcards/ru-refcard.tex b/etc/refcards/ru-refcard.tex
index 179be0af885..018be36eb46 100644
--- a/etc/refcards/ru-refcard.tex
+++ b/etc/refcards/ru-refcard.tex
@@ -40,7 +40,7 @@
\newlength{\ColThreeWidth}
\setlength{\ColThreeWidth}{25mm}
-\newcommand{\versionemacs}[0]{28} % version of Emacs this is for
+\newcommand{\versionemacs}[0]{29} % version of Emacs this is for
\newcommand{\cyear}[0]{2021} % copyright year
\newcommand\shortcopyrightnotice[0]{\vskip 1ex plus 2 fill
diff --git a/etc/themes/adwaita-theme.el b/etc/themes/adwaita-theme.el
index c98bec6cfa5..7d297df5260 100644
--- a/etc/themes/adwaita-theme.el
+++ b/etc/themes/adwaita-theme.el
@@ -96,6 +96,9 @@ default look of the Gnome 3 desktop.")
`(gnus-cite-1 ((,class (:foreground "#00578E"))))
`(gnus-cite-2 ((,class (:foreground "#0084C8"))))
+ `(image-dired-thumb-mark ((,class (:background "#CE5C00"))))
+ `(image-dired-thumb-flagged ((,class (:background "#B50000"))))
+
`(diff-added ((,class (:bold t :foreground "#4E9A06"))))
`(diff-removed ((,class (:bold t :foreground "#F5666D"))))))
diff --git a/etc/themes/deeper-blue-theme.el b/etc/themes/deeper-blue-theme.el
index cfe8a5bfb28..5895693386c 100644
--- a/etc/themes/deeper-blue-theme.el
+++ b/etc/themes/deeper-blue-theme.el
@@ -82,6 +82,8 @@
`(ido-first-match ((,class (:weight normal :foreground "orange"))))
`(ido-only-match ((,class (:foreground "green"))))
`(ido-subdir ((,class (:foreground nil :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"))))
`(info-header-xref ((,class (:foreground "SeaGreen2"))))
`(info-menu-header ((,class (:family "helv" :weight bold))))
diff --git a/etc/themes/dichromacy-theme.el b/etc/themes/dichromacy-theme.el
index c59b24bef50..148ebd434cd 100644
--- a/etc/themes/dichromacy-theme.el
+++ b/etc/themes/dichromacy-theme.el
@@ -101,6 +101,9 @@ Ansi-Color faces are included.")
`(gnus-header-subject ((,class (:foreground ,orange))))
`(gnus-header-name ((,class (:foreground ,skyblue))))
`(gnus-header-newsgroups ((,class (:foreground ,vermillion))))
+ ;; Image-Dired
+ `(image-dired-thumb-flagged ((,class (:background ,vermillion))))
+ `(image-dired-thumb-mark ((,class (:background ,orange))))
;; Message faces
`(message-header-name ((,class (:foreground ,skyblue))))
`(message-header-cc ((,class (:foreground ,vermillion))))
diff --git a/etc/themes/leuven-theme.el b/etc/themes/leuven-theme.el
index 95ec303f706..514384ca2af 100644
--- a/etc/themes/leuven-theme.el
+++ b/etc/themes/leuven-theme.el
@@ -632,6 +632,8 @@ more...")
`(ilog-echo-face ((,class (:height 2.0 :foreground "#006FE0"))))
`(ilog-load-face ((,class (:foreground "#BA36A5"))))
`(ilog-message-face ((,class (:foreground "#808080"))))
+ `(image-dired-thumb-flagged ((,class (:background "red"))))
+ `(image-dired-thumb-mark ((,class :background "#FFAAAA")))
`(indent-guide-face ((,class (:foreground "#D3D3D3"))))
`(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
diff --git a/etc/themes/light-blue-theme.el b/etc/themes/light-blue-theme.el
index f49b37a15fd..547d2df04c0 100644
--- a/etc/themes/light-blue-theme.el
+++ b/etc/themes/light-blue-theme.el
@@ -29,6 +29,8 @@
(deftheme light-blue
"Face colors utilizing a light blue background.")
+(make-obsolete 'light-blue nil "29.1")
+
(let ((class '((class color) (min-colors 89))))
(custom-theme-set-faces
'light-blue
diff --git a/etc/themes/manoj-dark-theme.el b/etc/themes/manoj-dark-theme.el
index 0e5fb391198..e80403f5b34 100644
--- a/etc/themes/manoj-dark-theme.el
+++ b/etc/themes/manoj-dark-theme.el
@@ -221,6 +221,9 @@ jarring angry fruit salad look to reduce eye fatigue.")
'(gnus-group-news-low-empty ((t (:foreground "DarkTurquoise"))))
'(gnus-group-news-low-empty-face ((t (:foreground "DarkTurquoise"))))
+ ;; '(image-dired-thumb-flagged ((t (:background "red"))))
+ ;; '(image-dired-thumb-mark ((t (:background "Pink"))))
+
;;message faces
'(message-cited-text ((t (:foreground "red3"))))
'(message-header-cc ((t (:bold t :foreground "chartreuse1" :weight bold))))
@@ -538,7 +541,6 @@ jarring angry fruit salad look to reduce eye fatigue.")
'(ido-indicator ((t (:background "red1" :foreground "yellow1" :width condensed))))
'(ido-only-match ((t (:foreground "ForestGreen"))))
'(ido-subdir ((t (:foreground "red1"))))
- '(info-menu-5 ((t (:underline t))))
'(info-menu-header ((t (:bold t :weight bold))))
'(info-node ((t (:bold t :italic t :foreground "yellow"))))
'(info-node ((t (:italic t :bold t :foreground "white" :slant italic :weight bold))))
diff --git a/etc/themes/modus-operandi-theme.el b/etc/themes/modus-operandi-theme.el
index 350524779d6..5a73e655f30 100644
--- a/etc/themes/modus-operandi-theme.el
+++ b/etc/themes/modus-operandi-theme.el
@@ -4,8 +4,8 @@
;; Author: Protesilaos Stavrou <info@protesilaos.com>
;; URL: https://gitlab.com/protesilaos/modus-themes
-;; Version: 1.6.0
-;; Package-Requires: ((emacs "26.1"))
+;; Version: 1.7.0
+;; Package-Requires: ((emacs "27.1"))
;; Keywords: faces, theme, accessibility
;; This file is part of GNU Emacs.
diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el
index 7ab985c0771..f7d38ac2dea 100644
--- a/etc/themes/modus-themes.el
+++ b/etc/themes/modus-themes.el
@@ -4,8 +4,8 @@
;; Author: Protesilaos Stavrou <info@protesilaos.com>
;; URL: https://gitlab.com/protesilaos/modus-themes
-;; Version: 1.6.0
-;; Last-Modified: <2021-09-29 08:47:03 +0300>
+;; Version: 1.7.0
+;; Last-Modified: <2021-11-18 12:28:22 +0200>
;; Package-Requires: ((emacs "27.1"))
;; Keywords: faces, theme, accessibility
@@ -31,7 +31,7 @@
;; 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/modus-themes>).
+;; themes, or available at: <https://protesilaos.com/emacs/modus-themes>).
;;
;; The themes share the following customization variables:
;;
@@ -39,8 +39,9 @@
;; modus-themes-org-agenda (alist)
;; modus-themes-bold-constructs (boolean)
;; modus-themes-inhibit-reload (boolean)
+;; modus-themes-intense-markup (boolean)
;; modus-themes-italic-constructs (boolean)
-;; modus-themes-no-mixed-fonts (boolean)
+;; modus-themes-mixed-fonts (boolean)
;; modus-themes-scale-headings (boolean)
;; modus-themes-subtle-line-numbers (boolean)
;; modus-themes-success-deuteranopia (boolean)
@@ -59,6 +60,7 @@
;; modus-themes-prompts (choice)
;; modus-themes-region (choice)
;; modus-themes-syntax (choice)
+;; modus-themes-mode-line-padding (natnum)
;;
;; The default scale for headings is as follows (it can be customized as
;; well---remember, no scaling takes place by default):
@@ -238,6 +240,7 @@
;; ido-mode
;; iedit
;; iflipb
+;; image-dired
;; imenu-list
;; indium
;; info
@@ -278,6 +281,7 @@
;; mu4e
;; mu4e-conversation
;; multiple-cursors
+;; nano-modeline
;; neotree
;; no-emoji
;; notmuch
@@ -378,6 +382,7 @@
;; vc-annotate (C-x v g)
;; vdiff
;; vertico
+;; vertico-quick
;; vimish-fold
;; visible-mark
;; visual-regexp
@@ -1475,7 +1480,7 @@ The actual styling of the face is done by `modus-themes-faces'."
(defface modus-themes-variable-pitch nil
"Generic face for applying a conditional `variable-pitch'.
-This behaves in accordance with `modus-themes-no-mixed-fonts',
+This behaves in accordance with `modus-themes-mixed-fonts',
`modus-themes-variable-pitch-headings' for all heading levels,
and `modus-themes-variable-pitch-ui'.
@@ -1484,7 +1489,7 @@ The actual styling of the face is done by `modus-themes-faces'."
(defface modus-themes-fixed-pitch nil
"Generic face for applying a conditional `fixed-pitch'.
-This behaves in accordance with `modus-themes-no-mixed-fonts'.
+This behaves in accordance with `modus-themes-mixed-fonts'.
The actual styling of the face is done by `modus-themes-faces'."
:group 'modus-theme-faces)
@@ -1782,30 +1787,43 @@ This includes the mode line, header line, tab bar, and tab line."
:initialize #'custom-initialize-default
:link '(info-link "(modus-themes) UI typeface"))
-(defcustom modus-themes-no-mixed-fonts nil
- "Disable inheritance from `fixed-pitch' in some faces.
-
-This is done by default to allow spacing-sensitive constructs,
-such as Org tables and code blocks, to remain monospaced when
-users opt for something like the command `variable-pitch-mode'.
-The downside with the default is that users need to explicitly
-configure the font family of `fixed-pitch' in order to get a
-consistent experience. That may be something they do not want to
-do. Hence this option to disable any kind of technique for
-mixing fonts."
+(define-obsolete-variable-alias
+ 'modus-themes-no-mixed-fonts
+ 'modus-themes-mixed-fonts "On 2021-10-02 for version 1.7.0")
+
+(defcustom modus-themes-mixed-fonts nil
+ "Non-nil to enable inheritance from `fixed-pitch' in some faces.
+
+This is done to allow spacing-sensitive constructs, such as Org
+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."
:group 'modus-themes
- :package-version '(modus-themes . "1.0.0")
- :version "28.1"
+ :package-version '(modus-themes . "1.7.0")
+ :version "29.1"
:type 'boolean
:set #'modus-themes--set-option
:initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) No mixed fonts"))
+ :link '(info-link "(modus-themes) Mixed fonts"))
(defconst modus-themes--headings-choice
'(set :tag "Properties" :greedy t
(const :tag "Background color" background)
(const :tag "Overline" overline)
- (const :tag "No bold weight" no-bold)
+ (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))
(choice :tag "Colors"
(const :tag "Subtle colors" nil)
(const :tag "Rainbow colors" rainbow)
@@ -1839,21 +1857,27 @@ heading.
A `background' property adds a subtle tinted color to the
background of the heading.
-A `no-bold' property removes the bold weight from the heading's
-text.
-
A `monochrome' property makes all headings the same base color,
which is that of the default for the active theme (black/white).
When `background' is also set, `monochrome' changes its color to
gray. If both `monochrome' and `rainbow' are set, the former
takes precedence.
+The symbol of a weight attribute adjusts the font of the heading
+accordingly, such as `light', `semibold', etc. Valid symbols are
+defined in the internal variable `modus-themes--heading-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.
+
Combinations of any of those properties are expressed as a list,
like in these examples:
- (no-bold)
+ (semibold)
(rainbow background)
- (overline monochrome no-bold)
+ (overline monochrome semibold)
The order in which the properties are set is not significant.
@@ -1862,7 +1886,7 @@ In user configuration files the form may look like this:
(setq modus-themes-headings
'((1 . (background overline rainbow))
(2 . (background overline))
- (t . (overline no-bold))))
+ (t . (overline semibold))))
When defining the styles per heading level, it is possible to
pass a non-nil value (t) instead of a list of properties. This
@@ -1875,7 +1899,7 @@ will retain the original aesthetic for that level. For example:
(setq modus-themes-headings
'((1 . (background overline))
- (2 . (rainbow no-bold))
+ (2 . (rainbow semibold))
(t . t))) ; default style for all other levels
For Org users, the extent of the heading depends on the variable
@@ -1887,8 +1911,8 @@ Also read `modus-themes-scale-headings' to change the height of
headings and `modus-themes-variable-pitch-headings' to make them
use a proportionately spaced font."
:group 'modus-themes
- :package-version '(modus-themes . "1.5.0")
- :version "28.1"
+ :package-version '(modus-themes . "1.7.0")
+ :version "29.1"
:type `(alist
:options ,(mapcar (lambda (el)
(list el modus-themes--headings-choice))
@@ -1909,7 +1933,7 @@ combinations:
(setq modus-themes-org-agenda
'((header-block . (variable-pitch scale-title))
(header-date . (grayscale workaholic bold-today))
- (event . (accented scale-small))
+ (event . (accented italic varied))
(scheduled . uniform)
(habit . traffic-light)))
@@ -1963,26 +1987,42 @@ For example:
(header-date . (grayscale workaholic bold-today))
(header-date . (grayscale workaholic bold-today scale-heading))
-An `event' key covers events from the diary and other entries
-that derive from a symbolic expression or sexp (e.g. phases of
-the moon, holidays). By default those have a gray
-foreground (the default is a nil value or an empty list). This
-key accepts a list of properties. Those are:
+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:
- `scale-small' reduces the height of the entries to the value of
the user option `modus-themes-scale-small' (0.9 the height of
- the main font size by default).
+ the main font size by default). This work best when the
+ relevant entries have no tags associated with them and when the
+ user is interested in reducing their presence in the agenda
+ view.
- `accented' applies an accent value to the event's foreground,
- replacing the original gray.
+ 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)
+ 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 . (scale-small))
- (event . (scale-small accented))
- (event . (scale-small accented italic))
+ (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
@@ -2038,8 +2078,8 @@ For example:
(habit . simplified)
(habit . traffic-light)"
:group 'modus-themes
- :package-version '(modus-themes . "1.6.0")
- :version "28.1"
+ :package-version '(modus-themes . "1.7.0")
+ :version "29.1"
:type '(set
(cons :tag "Block header"
(const header-block)
@@ -2065,7 +2105,8 @@ For example:
(set :tag "Text presentation" :greedy t
(const :tag "Use smaller font size (`modus-themes-scale-small')" scale-small)
(const :tag "Apply an accent color" accented)
- (const :tag "Italic font slant (oblique forms)" italic)))
+ (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)
@@ -2289,12 +2330,12 @@ to the affected text.
The property `background' adds a color-coded background.
The property `intense' amplifies the applicable colors if
-`background' and/or `text-only' are set. If `intense' is set on
-its own, then it implies `text-only'.
+`background' and/or `text-also' are set. If `intense' is set on
+its own, then it implies `text-also'.
-To disable fringe indicators for Flymake or Flycheck, refer to
-variables `flymake-fringe-indicator-position' and
-`flycheck-indication-mode', respectively.
+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:
@@ -2312,15 +2353,21 @@ In user configuration files the form may look like this:
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'."
+`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.5.0")
- :version "28.1"
+ :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 "Increase color intensity" intense)
- (const :tag "With background" background))
+ (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"))
@@ -2502,6 +2549,17 @@ instead of a box style, it is advised to set
:initialize #'custom-initialize-default
:link '(info-link "(modus-themes) Mode line"))
+(defcustom modus-themes-mode-line-padding 6
+ "Padding for `modus-themes-mode-line'.
+The value is expressed as a positive integer."
+ :group 'modus-themes
+ :package-version '(modus-themes . "1.7.0")
+ :version "29.1"
+ :type 'natnum
+ :set #'modus-themes--set-option
+ :initialize #'custom-initialize-default
+ :link '(info-link "(modus-themes) Mode line"))
+
(defcustom modus-themes-diffs nil
"Adjust the overall style of diffs.
@@ -2643,16 +2701,6 @@ In user configuration files the form may look like this:
:initialize #'custom-initialize-default
:link '(info-link "(modus-themes) Command prompts"))
-(defcustom modus-themes-intense-hl-line nil
- "Use a more prominent background for command `hl-line-mode'."
- :group 'modus-themes
- :package-version '(modus-themes . "1.0.0")
- :version "28.1"
- :type 'boolean
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Line highlighting"))
-
(make-obsolete 'modus-themes-intense-hl-line 'modus-themes-hl-line "1.3.0")
(defcustom modus-themes-hl-line nil
@@ -2708,6 +2756,22 @@ results with underlines."
:initialize #'custom-initialize-default
:link '(info-link "(modus-themes) Line numbers"))
+(defcustom modus-themes-intense-markup nil
+ "Use more intense markup in Org, Markdown, and related.
+The default style for certain markup types like inline code and
+verbatim constructs in Org and related major modes is a subtle
+foreground color combined with a subtle background.
+
+With a non-nil value (t), these constructs will use a more
+prominent background and foreground color combination instead."
+ :group 'modus-themes
+ :package-version '(modus-themes . "1.7.0")
+ :version "29.1"
+ :type 'boolean
+ :set #'modus-themes--set-option
+ :initialize #'custom-initialize-default
+ :link '(info-link "(modus-themes) Intense markup"))
+
(defcustom modus-themes-paren-match nil
"Control the style of matching parentheses or delimiters.
@@ -2913,12 +2977,14 @@ In user configuration files the form may look like this:
This is to account for red-green color deficiency.
-The present customization option should apply to all contexts where
-there can be a color-coded distinction between success and failure,
-to-do and done, and so on.
+The present customization option applies to all contexts where
+there can be a color-coded distinction between success or
+failure, to-do or done, mark for selection or deletion (e.g. in
+Dired), current and lazily highlighted search matches, and so on.
-Diffs, which have a red/green dichotomy by default, can also be
-configured to conform with deuteranopia: `modus-themes-diffs'."
+Diffs, which rely on a red/green dichotomy by default, can also
+be configured to meet the needs of users with deuteranopia via
+the option `modus-themes-diffs'."
:group 'modus-themes
:package-version '(modus-themes . "1.4.0")
:version "28.1"
@@ -3024,7 +3090,7 @@ Those are stored in `modus-themes-faces' and
(defun modus-themes--fixed-pitch ()
"Conditional application of `fixed-pitch' inheritance."
- (unless modus-themes-no-mixed-fonts
+ (when modus-themes-mixed-fonts
(list :inherit 'fixed-pitch)))
(defun modus-themes--variable-pitch ()
@@ -3054,14 +3120,23 @@ combines with the theme's primary background (white/black)."
(list :background (or altbg 'unspecified) :foreground altfg)
(list :background mainbg :foreground mainfg)))
-(defun modus-themes--lang-check (underline subtlefg intensefg intensefg-alt subtlebg intensebg)
+(defun modus-themes--markup (mainfg intensefg &optional mainbg intensebg)
+ "Conditional use of colors for markup in Org and others.
+MAINBG is the default background. MAINFG is the default
+foreground. INTENSEBG and INTENSEFG must be more colorful
+variants."
+ (if modus-themes-intense-markup
+ (list :background (or intensebg 'unspecified) :foreground intensefg)
+ (list :background (or mainbg 'unspecified) :foreground 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."
+differ in overall intensity. FAINTFG is a nuanced color."
(let ((modus-themes-lang-checkers
(if (listp modus-themes-lang-checkers)
modus-themes-lang-checkers
@@ -3074,19 +3149,26 @@ differ in overall intensity."
('straight-underline '(straight-underline))))))
(list :underline
(list :color
- underline
+ (if (memq 'faint modus-themes-lang-checkers)
+ faintfg underline)
:style
(if (memq 'straight-underline modus-themes-lang-checkers)
'line 'wave))
:background
(cond
((and (memq 'background modus-themes-lang-checkers)
+ (memq 'faint modus-themes-lang-checkers))
+ subtlebg)
+ ((and (memq 'background modus-themes-lang-checkers)
(memq 'intense modus-themes-lang-checkers))
intensebg)
((memq 'background modus-themes-lang-checkers)
subtlebg))
:foreground
(cond
+ ((and (memq 'faint modus-themes-lang-checkers)
+ (memq 'text-also modus-themes-lang-checkers))
+ faintfg)
((and (memq 'background modus-themes-lang-checkers)
(memq 'intense modus-themes-lang-checkers))
intensefg-alt)
@@ -3312,6 +3394,18 @@ an alternative to the default value."
"Get cdr of KEY in ALIST."
(cdr (assoc key alist)))
+(defvar modus-themes--heading-weights
+ '( thin ultralight extralight light semilight regular medium
+ semibold bold heavy extrabold ultrabold)
+ "List of font weights used by `modus-themes--heading'.")
+
+(defun modus-themes--heading-weight (list)
+ "Search for `modus-themes--heading' weight in LIST."
+ (catch 'found
+ (dolist (elt list)
+ (when (memq elt modus-themes--heading-weights)
+ (throw 'found elt)))))
+
(defun modus-themes--heading (level fg fg-alt bg bg-gray border)
"Conditional styles for `modus-themes-headings'.
@@ -3323,8 +3417,9 @@ 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)))
+ (style-listp (listp style))
(modus-themes-headings
- (if (listp style)
+ (if style-listp
style
;; translation layer for legacy values
(pcase style
@@ -3345,15 +3440,16 @@ that combines well with the background and foreground."
('rainbow-section-no-bold '(no-bold rainbow background overline))
('section '(background overline))
('section-no-bold '(background overline no-bold)))))
- (var (if modus-themes-variable-pitch-headings
- 'variable-pitch
- 'unspecified))
+ (var (when modus-themes-variable-pitch-headings 'variable-pitch))
(varbold (if var
(append (list 'bold) (list var))
- 'bold)))
+ 'bold))
+ (weight (when style-listp (modus-themes--heading-weight style))))
(list :inherit
(cond
- ((memq 'no-bold modus-themes-headings)
+ ;; `no-bold' is for backward compatibility because we cannot
+ ;; deprecate a variable's value.
+ ((or weight (memq 'no-bold modus-themes-headings))
var)
(varbold))
:background
@@ -3371,6 +3467,8 @@ that combines well with the background and foreground."
((memq 'rainbow modus-themes-headings)
fg-alt)
(fg))
+ :weight
+ (or weight 'unspecified)
:overline
(if (memq 'overline modus-themes-headings)
border
@@ -3430,24 +3528,42 @@ weight. Optional UL applies an underline."
t
'unspecified))))
-(defun modus-themes--agenda-event (fg)
+(defun modus-themes--agenda-event (fg-accent &optional varied)
"Control the style of the Org agenda events.
-FG is the accent color to use."
+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 :height
(if (memq 'scale-small properties)
modus-themes-scale-small
'unspecified)
:foreground
- (if (memq 'accented properties)
- fg
+ (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 'italic properties))
- 'italic)
- ((memq 'italic 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)))))
@@ -3512,6 +3628,13 @@ set to `rainbow'."
('rainbow (list :background bgaccent :foreground fgaccent))
(_ (list :background bg :foreground fg))))
+(defun modus-themes--mode-line-padding ()
+ "Determine mode line padding value.
+See `modus-themes--mode-line-attrs'."
+ (if (natnump modus-themes-mode-line-padding)
+ modus-themes-mode-line-padding
+ 6)) ; the default value
+
(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'.
@@ -3528,7 +3651,8 @@ 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 ((modus-themes-mode-line
+ (let ((padding (modus-themes--mode-line-padding))
+ (modus-themes-mode-line
(if (listp modus-themes-mode-line)
modus-themes-mode-line
;; translation layer for legacy values
@@ -3552,10 +3676,10 @@ property."
(cons fg-alt bg-alt))
((cons fg bg))))
(box (cond ((memq 'moody modus-themes-mode-line)
- nil)
+ 'unspecified)
((and (memq '3d modus-themes-mode-line)
(memq 'padded modus-themes-mode-line))
- (list :line-width 4
+ (list :line-width padding
:color
(cond ((and (memq 'accented modus-themes-mode-line)
(memq 'borderless modus-themes-mode-line))
@@ -3567,9 +3691,9 @@ property."
:style (when alt-style 'released-button)))
((and (memq 'accented modus-themes-mode-line)
(memq 'padded modus-themes-mode-line))
- (list :line-width 6 :color bg-accent))
+ (list :line-width padding :color bg-accent))
((memq 'padded modus-themes-mode-line)
- (list :line-width 6 :color bg))
+ (list :line-width padding :color bg))
((memq '3d modus-themes-mode-line)
(list :line-width 1
:color
@@ -3579,14 +3703,17 @@ property."
((memq 'borderless modus-themes-mode-line) bg)
(border-3d))
:style (when alt-style 'released-button)))
+ ((and (memq 'accented modus-themes-mode-line)
+ (memq 'borderless modus-themes-mode-line))
+ bg-accent)
((memq 'borderless modus-themes-mode-line)
bg)
((memq 'padded modus-themes-mode-line)
- (list :line-width 6 :color bg))
+ (list :line-width padding :color bg))
(border)))
(line (cond ((not (or (memq 'moody modus-themes-mode-line)
(memq 'padded modus-themes-mode-line)))
- nil)
+ 'unspecified)
((and (memq 'borderless modus-themes-mode-line)
(memq 'accented modus-themes-mode-line))
bg-accent)
@@ -4007,6 +4134,7 @@ as when they are declared in the `:config' phase)."
(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))
@@ -4015,6 +4143,7 @@ Also run `modus-themes-after-load-theme-hook'."
(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))
@@ -4169,7 +4298,11 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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 ,bg-mark-sel :foreground ,fg-mark-sel)))
+ `(modus-themes-mark-sel ((,class :inherit bold
+ :background ,@(modus-themes--success-deuteran
+ cyan-refine-bg
+ bg-mark-sel)
+ :foreground ,fg-mark-sel)))
`(modus-themes-mark-symbol ((,class :inherit bold :foreground ,blue-alt)))
;;;;; heading levels
;; styles for regular headings used in Org, Markdown, Info, etc.
@@ -4225,13 +4358,13 @@ by virtue of calling either of `modus-themes-load-operandi' and
;;;;; 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 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-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 yellow-refine-fg yellow-nuanced-bg yellow-refine-bg yellow-faint))))
;;;;; other custom faces
`(modus-themes-bold ((,class ,@(modus-themes--bold-weight))))
`(modus-themes-hl-line ((,class ,@(modus-themes--hl-line
@@ -4276,15 +4409,16 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(buffer-menu-buffer ((,class :inherit bold)))
`(comint-highlight-input ((,class :inherit bold)))
`(comint-highlight-prompt ((,class :inherit modus-themes-prompt)))
+ `(confusingly-reordered ((,class :inherit modus-themes-lang-error)))
`(error ((,class :inherit bold :foreground ,red)))
`(escape-glyph ((,class :foreground ,fg-escape-char-construct)))
- `(file-name-shadow ((,class :foreground ,fg-unfocused)))
+ `(file-name-shadow ((,class :inherit (shadow italic))))
`(header-line ((,class ,@(modus-themes--variable-pitch-ui)
:background ,bg-header :foreground ,fg-header)))
`(header-line-highlight ((,class :inherit modus-themes-active-blue)))
`(help-argument-name ((,class :inherit modus-themes-slant :foreground ,cyan)))
- `(help-key-binding ((,class :box (:line-width (1 . -1) :color ,bg-region) ; NOTE: box syntax is for Emacs28
- :background ,bg-inactive)))
+ `(help-key-binding ((,class :box (:line-width (-1 . -1) :color ,bg-active) ; NOTE: box syntax is for Emacs28
+ :background ,bg-alt)))
`(homoglyph ((,class :foreground ,red-alt-faint)))
`(ibuffer-locked-buffer ((,class :foreground ,yellow-alt-other-faint)))
`(italic ((,class :slant italic)))
@@ -4316,7 +4450,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(widget-button-pressed ((,class :inherit widget-button :foreground ,magenta)))
`(widget-documentation ((,class :foreground ,green)))
`(widget-field ((,class :background ,bg-alt :foreground ,fg-dim)))
- `(widget-inactive ((,class :foreground ,fg-alt)))
+ `(widget-inactive ((,class :inherit shadow :background ,bg-dim)))
`(widget-single-line-field ((,class :inherit widget-field)))
;;;;; ag
`(ag-hit-face ((,class :foreground ,fg-special-cold)))
@@ -4505,7 +4639,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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 :foreground ,fg-alt)))
+ `(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)))
;;;;; boon
@@ -4569,7 +4703,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
;;;;; cfrs
`(cfrs-border-color ((,class :background ,fg-window-divider-inner)))
;;;;; change-log and log-view (`vc-print-log' and `vc-print-root-log')
- `(change-log-acknowledgment ((,class :foreground ,fg-alt)))
+ `(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)))
@@ -4609,7 +4743,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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 italic :foreground ,fg-alt)))
+ `(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)))
@@ -4658,6 +4792,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(company-tooltip-annotation-selection ((,class :inherit bold :foreground ,fg-main)))
`(company-tooltip-common ((,class :inherit bold :foreground ,blue-alt)))
`(company-tooltip-common-selection ((,class :foreground ,fg-main)))
+ `(company-tooltip-deprecated ((,class :inherit company-tooltip :strike-through t)))
`(company-tooltip-mouse ((,class :inherit modus-themes-intense-blue)))
`(company-tooltip-search ((,class :inherit (modus-themes-search-success-lazy bold))))
`(company-tooltip-search-selection ((,class :inherit (modus-themes-search-success bold) :underline t)))
@@ -4698,10 +4833,10 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(consult-preview-error ((,class :inherit modus-themes-intense-red)))
`(consult-preview-line ((,class :background ,bg-hl-alt-intense)))
;;;;; corfu
- `(corfu-background ((,class :background ,bg-alt)))
`(corfu-current ((,class :inherit bold :background ,cyan-subtle-bg)))
`(corfu-bar ((,class :background ,fg-alt)))
`(corfu-border ((,class :background ,bg-active)))
+ `(corfu-default ((,class :background ,bg-alt)))
;;;;; counsel
`(counsel-active-mode ((,class :foreground ,magenta-alt-other)))
`(counsel-application-name ((,class :foreground ,red-alt-other)))
@@ -4758,7 +4893,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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 bold :foreground ,green-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)))
@@ -4814,7 +4949,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(deft-filter-string-face ((,class :foreground ,green-intense)))
`(deft-header-face ((,class :inherit bold :foreground ,fg-special-warm)))
`(deft-separator-face ((,class :inherit shadow)))
- `(deft-summary-face ((,class :inherit modus-themes-slant :foreground ,fg-alt)))
+ `(deft-summary-face ((,class :inherit (shadow modus-themes-slant))))
`(deft-time-face ((,class :foreground ,fg-special-cold)))
`(deft-title-face ((,class :inherit bold :foreground ,fg-main)))
;;;;; dictionary
@@ -4862,7 +4997,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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 bold :family "Font Awesome" :foreground ,fg-alt)))
+ `(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)))
@@ -5484,8 +5619,8 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(git-gutter-fr:modified ((,class :inherit modus-themes-fringe-yellow)))
;;;;; git-{gutter,fringe}+
`(git-gutter+-added ((,class :inherit ,@(modus-themes--diff-deuteran
- 'modus-themes-fringe-blue
- 'modus-themes-fringe-green))))
+ 'modus-themes-fringe-blue
+ 'modus-themes-fringe-green))))
`(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)))
@@ -5851,6 +5986,11 @@ by virtue of calling either of `modus-themes-load-operandi' and
;;;;; iflipb
`(iflipb-current-buffer-face ((,class :inherit bold :foreground ,cyan-alt)))
`(iflipb-other-buffer-face ((,class :inherit shadow)))
+;;;;; image-dired
+ `(image-dired-thumb-flagged ((,class :background ,red-intense-bg)))
+ `(image-dired-thumb-mark ((,class :background ,@(modus-themes--success-deuteran
+ cyan-intense-bg
+ green-intense-bg))))
;;;;; imenu-list
`(imenu-list-entry-face-0 ((,class :foreground ,cyan)))
`(imenu-list-entry-face-1 ((,class :foreground ,blue)))
@@ -5862,7 +6002,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(imenu-list-entry-subalist-face-3 ((,class :inherit bold :foreground ,red-alt-other :underline t)))
;;;;; indium
`(indium-breakpoint-face ((,class :foreground ,red-active)))
- `(indium-frame-url-face ((,class :inherit button :foreground ,fg-alt)))
+ `(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)))
@@ -5870,8 +6010,9 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(indium-repl-stdout-face ((,class :foreground ,fg-main)))
;;;;; info
`(Info-quoted ((,class :inherit modus-themes-fixed-pitch ; the capitalization is canonical
- :background ,bg-alt :foreground ,fg-special-calm)))
- `(info-header-node ((,class :inherit bold :foreground ,fg-alt)))
+ ,@(modus-themes--markup fg-special-calm magenta-alt
+ bg-alt magenta-nuanced-bg))))
+ `(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-heading-3)))
@@ -5882,7 +6023,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(info-title-3 ((,class :inherit modus-themes-heading-3)))
`(info-title-4 ((,class :inherit modus-themes-heading-4)))
;;;;; info-colors
- `(info-colors-lisp-code-block ((,class :inherit fixed-pitch)))
+ `(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)))
@@ -6089,7 +6230,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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 :height 0.8 :foreground ,fg-alt)))
+ `(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)))
@@ -6309,13 +6450,14 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(markdown-html-tag-name-face ((,class :inherit modus-themes-fixed-pitch
:foreground ,magenta-alt)))
`(markdown-inline-code-face ((,class :inherit modus-themes-fixed-pitch
- :background ,bg-alt :foreground ,fg-special-calm)))
+ ,@(modus-themes--markup fg-special-calm magenta-alt
+ bg-alt magenta-nuanced-bg))))
`(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)))
+ ,@(modus-themes--markup fg-alt red-alt
+ bg-alt red-nuanced-bg))))
`(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)))
@@ -6349,7 +6491,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(markup-meta-face ((,class :inherit shadow)))
`(markup-meta-hide-face ((,class :foreground "gray50")))
`(markup-reference-face ((,class :foreground ,blue-alt :underline ,bg-region)))
- `(markup-replacement-face ((,class :inherit fixed-pitch :foreground ,red-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)))
@@ -6479,7 +6621,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(mu4e-title-face ((,class :foreground ,fg-main)))
`(mu4e-trashed-face ((,class :foreground ,red)))
`(mu4e-unread-face ((,class :inherit bold)))
- `(mu4e-url-number-face ((,class :foreground ,fg-alt)))
+ `(mu4e-url-number-face ((,class :inherit shadow)))
`(mu4e-view-body-face ((,class :foreground ,fg-main)))
`(mu4e-warning-face ((,class :inherit warning)))
;;;;; mu4e-conversation
@@ -6498,6 +6640,17 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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)))
;;;;; neotree
`(neo-banner-face ((,class :foreground ,magenta)))
`(neo-button-face ((,class :inherit button)))
@@ -6507,7 +6660,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(neo-header-face ((,class :inherit bold :foreground ,fg-main)))
`(neo-root-dir-face ((,class :inherit bold :foreground ,cyan-alt)))
`(neo-vc-added-face ((,class :foreground ,@(modus-themes--diff-deuteran blue green))))
- `(neo-vc-conflict-face ((,class :inherit bold :foreground ,red)))
+ `(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)))
@@ -6601,17 +6754,20 @@ by virtue of calling either of `modus-themes-load-operandi' and
yellow-refine-bg yellow-refine-fg))))
;;;;; org
`(org-agenda-calendar-event ((,class ,@(modus-themes--agenda-event blue-alt))))
- `(org-agenda-calendar-sexp ((,class :inherit org-agenda-calendar-event)))
+ `(org-agenda-calendar-sexp ((,class ,@(modus-themes--agenda-event blue-alt t))))
`(org-agenda-clocking ((,class :inherit modus-themes-special-cold :extend t)))
`(org-agenda-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 blue-active fg-main
- cyan-active fg-main
- bg-active t t))))
- `(org-agenda-date-weekend ((,class ,@(modus-themes--agenda-date cyan-alt-other fg-alt
+ `(org-agenda-date-today ((,class ,@(modus-themes--agenda-date cyan fg-main
+ nil nil
+ bg-inactive t t))))
+ `(org-agenda-date-weekend ((,class ,@(modus-themes--agenda-date cyan-alt-other-faint fg-alt
cyan fg-main))))
- `(org-agenda-diary ((,class :inherit org-agenda-calendar-event)))
+ `(org-agenda-date-weekend-today ((,class ,@(modus-themes--agenda-date cyan-alt-other-faint fg-alt
+ cyan fg-main
+ bg-inactive t t))))
+ `(org-agenda-diary ((,class :inherit org-agenda-calendar-sexp)))
`(org-agenda-dimmed-todo-face ((,class :inherit shadow)))
`(org-agenda-done ((,class :foreground ,@(modus-themes--success-deuteran
blue-nuanced-fg
@@ -6622,6 +6778,8 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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))))
@@ -6636,23 +6794,24 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(org-checkbox-statistics-todo ((,class :inherit org-todo)))
`(org-clock-overlay ((,class :inherit modus-themes-special-cold)))
`(org-code ((,class :inherit modus-themes-fixed-pitch
- :background ,bg-alt :foreground ,fg-special-mild
+ ,@(modus-themes--markup fg-special-mild green-alt-other
+ bg-alt green-nuanced-bg)
:extend t)))
`(org-column ((,class :background ,bg-alt)))
`(org-column-title ((,class :inherit bold :underline t :background ,bg-alt)))
- `(org-date ((,class :inherit ,(if modus-themes-no-mixed-fonts
- 'button
- '(button fixed-pitch))
+ `(org-date ((,class :inherit ,(if modus-themes-mixed-fonts
+ '(button fixed-pitch)
+ 'button)
,@(modus-themes--link-color
cyan cyan-faint))))
`(org-date-selected ((,class :inherit bold :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 modus-themes-fixed-pitch :foreground ,fg-alt)))
+ `(org-document-info-keyword ((,class :inherit (shadow modus-themes-fixed-pitch))))
`(org-document-title ((,class :inherit (bold modus-themes-variable-pitch) :foreground ,fg-special-cold
,@(modus-themes--scale modus-themes-scale-title))))
`(org-done ((,class :foreground ,@(modus-themes--success-deuteran blue green))))
- `(org-drawer ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-alt)))
+ `(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
@@ -6701,6 +6860,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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-refine-fg)))
`(org-level-1 ((,class :inherit modus-themes-heading-1)))
`(org-level-2 ((,class :inherit modus-themes-heading-2)))
@@ -6713,8 +6873,9 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(org-link ((,class :inherit button)))
`(org-list-dt ((,class :inherit bold)))
`(org-macro ((,class :inherit modus-themes-fixed-pitch
- :background ,cyan-nuanced-bg :foreground ,cyan-nuanced-fg)))
- `(org-meta-line ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-alt)))
+ ,@(modus-themes--markup cyan-nuanced-fg cyan
+ cyan-nuanced-bg cyan-nuanced-bg))))
+ `(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)))
@@ -6724,18 +6885,19 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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 :inherit org-date)))
- `(org-special-keyword ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-alt)))
+ `(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-intense-neutral))))
`(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 :foreground ,fg-unfocused)))
+ `(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-fixed-pitch
- :background ,bg-alt :foreground ,fg-special-calm)))
+ ,@(modus-themes--markup fg-special-calm magenta-alt
+ bg-alt magenta-nuanced-bg))))
`(org-verse ((,class :inherit org-quote)))
`(org-warning ((,class :inherit bold :foreground ,red-alt-other)))
;;;;; org-journal
@@ -6764,7 +6926,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(org-roam-link-shielded ((,class :inherit button
,@(modus-themes--link-color
yellow yellow-faint))))
- `(org-roam-tag ((,class :inherit italic :foreground ,fg-alt)))
+ `(org-roam-tag ((,class :inherit (shadow italic))))
;;;;; org-superstar
`(org-superstar-item ((,class :foreground ,fg-main)))
`(org-superstar-leading ((,class :foreground ,fg-whitespace)))
@@ -6863,7 +7025,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
;;;;; pomidor
`(pomidor-break-face ((,class :foreground ,blue-alt-other)))
`(pomidor-overwork-face ((,class :foreground ,red-alt-other)))
- `(pomidor-skip-face ((,class :inherit modus-themes-slant :foreground ,fg-alt)))
+ `(pomidor-skip-face ((,class :inherit (shadow modus-themes-slant))))
`(pomidor-work-face ((,class :foreground ,@(modus-themes--success-deuteran
blue-alt
green-alt-other))))
@@ -6914,7 +7076,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
:foreground ,green)))
`(racket-here-string-face ((,class :foreground ,blue-alt)))
`(racket-keyword-argument-face ((,class :foreground ,red-alt)))
- `(racket-logger-config-face ((,class :inherit modus-themes-slant :foreground ,fg-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)))
@@ -7208,7 +7370,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(spray-base-face ((,class :inherit default :foreground ,fg-special-cold)))
;;;;; stripes
`(stripes ((,class :background ,bg-alt)))
-;;;;; success
+;;;;; suggest
`(suggest-heading ((,class :inherit bold :foreground ,yellow-alt-other)))
;;;;; switch-window
`(switch-window-background ((,class :background ,bg-dim)))
@@ -7255,7 +7417,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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 bold :foreground ,fg-alt)))
+ `(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)))
@@ -7318,9 +7480,9 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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 fixed-pitch)))
+ `(telega-entity-type-code ((,class :inherit modus-themes-fixed-pitch)))
`(telega-entity-type-mention ((,class :foreground ,cyan)))
- `(telega-entity-type-pre ((,class :inherit fixed-pitch)))
+ `(telega-entity-type-pre ((,class :inherit modus-themes-fixed-pitch)))
`(telega-msg-heading ((,class :background ,bg-alt)))
`(telega-msg-self-title ((,class :inherit bold)))
`(telega-root-heading ((,class :inherit modus-themes-subtle-neutral)))
@@ -7329,9 +7491,9 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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 fixed-pitch :height 0.85)))
+ `(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 fixed-pitch :background ,bg-alt)))
+ `(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)))
@@ -7383,10 +7545,7 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(transient-heading ((,class :inherit bold :foreground ,fg-main)))
`(transient-inactive-argument ((,class :inherit shadow)))
`(transient-inactive-value ((,class :inherit shadow)))
- ;; FIXME 2021-08-28: using `modus-themes-key-binding' leads to
- ;; misalignments because of the added box property.
- ;; `(transient-key ((,class :inherit modus-themes-key-binding)))
- `(transient-key ((,class :inherit bold :foreground ,blue-alt-other)))
+ `(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)))
@@ -7473,10 +7632,10 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(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 :foreground ,fg-unfocused)))
+ `(vc-dir-status-ignored ((,class :inherit shadow)))
`(vc-dir-status-up-to-date ((,class :foreground ,cyan)))
- `(vc-dir-status-warning ((,class :foreground ,red)))
- `(vc-conflict-state ((,class :inherit modus-themes-slant :foreground ,red-active)))
+ `(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)))
@@ -7498,6 +7657,9 @@ by virtue of calling either of `modus-themes-load-operandi' and
:background ,@(pcase modus-themes-completions
('opinionated (list bg-active))
(_ (list bg-inactive))))))
+;;;;; vertico-quick
+ `(vertico-quick1 ((,class :inherit (modus-themes-intense-magenta bold))))
+ `(vertico-quick2 ((,class :inherit (modus-themes-refine-cyan bold))))
;;;;; vimish-fold
`(vimish-fold-fringe ((,class :foreground ,cyan-active)))
`(vimish-fold-mouse-face ((,class :inherit modus-themes-intense-blue)))
diff --git a/etc/themes/modus-vivendi-theme.el b/etc/themes/modus-vivendi-theme.el
index 919009278b1..6dffbf07e94 100644
--- a/etc/themes/modus-vivendi-theme.el
+++ b/etc/themes/modus-vivendi-theme.el
@@ -4,8 +4,8 @@
;; Author: Protesilaos Stavrou <info@protesilaos.com>
;; URL: https://gitlab.com/protesilaos/modus-themes
-;; Version: 1.6.0
-;; Package-Requires: ((emacs "26.1"))
+;; Version: 1.7.0
+;; Package-Requires: ((emacs "27.1"))
;; Keywords: faces, theme, accessibility
;; This file is part of GNU Emacs.
diff --git a/etc/themes/whiteboard-theme.el b/etc/themes/whiteboard-theme.el
index 729c082a331..9cf8e7dfc93 100644
--- a/etc/themes/whiteboard-theme.el
+++ b/etc/themes/whiteboard-theme.el
@@ -63,6 +63,8 @@
`(ido-first-match ((,class (:weight normal :foreground "DarkOrange3"))))
`(ido-only-match ((,class (:foreground "SeaGreen4"))))
`(ido-subdir ((,class (:foreground nil :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"))))
`(info-header-xref ((,class (:foreground "SeaGreen2"))))
`(info-menu-header ((,class (:family "helv" :weight bold))))
diff --git a/etc/tutorials/TUTORIAL b/etc/tutorials/TUTORIAL
index dcdb61f23ec..c5f2e684c42 100644
--- a/etc/tutorials/TUTORIAL
+++ b/etc/tutorials/TUTORIAL
@@ -304,8 +304,8 @@ position, type <DEL>. This is the key on the keyboard usually labeled
"Backspace"--the same one you normally use, outside Emacs, to delete
the last character typed.
-There may also be another key on your keyboard labeled <Delete>, but
-that's not the one we refer to as <DEL>.
+There is usually another key on your keyboard labeled <Delete>, but
+that's not the one we refer to as <DEL> in Emacs.
>> Do this now--type a few characters, then delete them by
typing <DEL> a few times. Don't worry about this file
@@ -1099,6 +1099,20 @@ manual in the node called "Dired".
The manual also describes many other Emacs features.
+* INSTALLING PACKAGES
+---------------------
+
+There's a rich set of packages for Emacs written by the community,
+which extend Emacs' capabilities. These packages include support for
+new languages, additional themes, plugins for integrating with
+external applications, and much, much more.
+
+To see a list of all available packages, type M-x list-packages. In
+the display this shows, you can install or uninstall packages, as well
+as read packages' descriptions. For more information about package
+management, consult the manual.
+
+
* CONCLUSION
------------
diff --git a/etc/tutorials/TUTORIAL.he b/etc/tutorials/TUTORIAL.he
index 2ee4f74c324..fc4b769599e 100644
--- a/etc/tutorials/TUTORIAL.he
+++ b/etc/tutorials/TUTORIAL.he
@@ -1,4 +1,4 @@
-שיעור ראשון בשימוש ב־‫Emacs‬. זכויות שימוש ראה בסוף המסמך.
+שיעור ראשון בשימוש ב־‪Emacs‬. זכויות שימוש ראה בסוף המסמך.
פקודות רבות של Emacs משתמשות במקש CONTROL (בדרך־כלל מסומן ב־CTRL)
או במקש META (בדרך־כלל מסומן ALT). במקום לציין את כל השמות האפשריים
@@ -24,7 +24,7 @@
שימו לב לחפיפה של שתי שורות כאשר אתם עוברים ממסך למסך, מה שמבטיח רציפות
מסוימת בעת קריאת הטקסט.
-הטקסט שלפניכם הינו עותק של שיעור בשימוש ב־‫Emacs‬ שהותאם קלות עבורכם.
+הטקסט שלפניכם הינו עותק של שיעור בשימוש ב־‪Emacs‬ שהותאם קלות עבורכם.
בהמשך תקבלו הוראות לנסות פקודות שונות כדי לבצע שינויים בטקסט הזה. אם
במקרה תשנו את הטקסט לפני שנבקש, אל דאגה: זוהי "עריכה" שהיא יעודו של
Emacs.
@@ -985,6 +985,17 @@ find-file.
בנוסף, מדריך למשתמש מתאר עוד הרבה מאד תכונות של Emacs.
+* התקנת חבילות הרחבה
+--------------------
+קיימות לא מעט חבילות תוכנה עבור Emacs אשר מרחיבות את היכולות שלו. חבילות
+הרחבה אלו נכתבו ע״י קהילת משתמשי Emacs והן מהוות אוסף עשיר של תכונות
+התומכות בשפות תכנות נוספות, ערכות נושא נוספות, תוספים לשילוב יישומים
+חיצוניים, ועוד ועוד.
+
+לצפיה ברשימת חבילות ההרחבה הזמינות, יש להקיש M-x list-packages. בתצוגה
+שתיפתח בעקבות זאת תוכלו לעיין בתיאור של חבילות, לבחור חבילות להתקנה במחשב
+שלכם, להסיר חבילות, ועוד. פרטים נוספים לגבי ניהול חבילות הרחבה ניתן למצוא
+במדריך למשתמש.
* לסיום
-------
diff --git a/etc/tutorials/TUTORIAL.it b/etc/tutorials/TUTORIAL.it
index cd5c6de9db5..aa2fb4560a7 100644
--- a/etc/tutorials/TUTORIAL.it
+++ b/etc/tutorials/TUTORIAL.it
@@ -1178,6 +1178,19 @@ quei file. Dired è descritta nel manuale Emacs nel nodo chiamato
Il manuale descrive molte altre funzionalità di Emacs.
+* INSTALLAZIONE DI ULTERIORI PACCHETTI
+
+Ci sono tantissimi pacchetti che estendono le funzionalità di Emacs,
+scritti dalla comunità. Questi pacchetti includono il supporto a
+nuovi linguaggi, aggiungono temi addizionali, rendono possibile
+interoperare con applicazioni esterne e molto, molto altro.
+
+Per vedere una lista di tutti i pacchetti disponibili, inserisci
+M-x list-packages. Nell'elenco che viene mostrato, puoi installare o
+disinstallare pacchetti, o leggerne la descrizione. Consulta il
+manuale per ulteriori informazioni sulla gestione dei pacchetti.
+
+
* CONCLUSIONI
-------------
diff --git a/etc/tutorials/TUTORIAL.sv b/etc/tutorials/TUTORIAL.sv
index dacc66d916f..5c9703f8066 100644
--- a/etc/tutorials/TUTORIAL.sv
+++ b/etc/tutorials/TUTORIAL.sv
@@ -1119,6 +1119,20 @@ Emacs-manualen i noden "Dired".
Manualen beskriver även många andra funktioner i Emacs.
+* INSTALLERA PAKET
+------------------
+
+Det finns en stor mängd paket för Emacs skrivna av användare, som
+utökar Emacs funktionalitet. Detta kan innefatta stöd för nya språk,
+fler teman, insticksmoduler för integration med externa program och
+mycket, mycket annat.
+
+Skriv M-x list-packages för att se en lista över alla tillgängliga
+paket. I detta läge kan du installera eller avinstallera paket samt
+läsa mer om olika paket. Se användarmanualen för mer information om
+pakethantering.
+
+
* SLUTORD
---------
diff --git a/leim/SKK-DIC/SKK-JISYO.L b/leim/SKK-DIC/SKK-JISYO.L
index f1e06ccfca1..2d4f6198984 100644
--- a/leim/SKK-DIC/SKK-JISYO.L
+++ b/leim/SKK-DIC/SKK-JISYO.L
@@ -143454,7 +143454,7 @@ zyklus /륹/ĥ륹/
Ϥä /ȯDz/
Ϥä /ȯ/
Ϥä /ȯϩ/
-Ϥä /ȯΩ/
+Ϥä /ȯΨ/
Ϥä /ȯս/
Ϥä󤫤 /ȯֳ/
Ϥä /ȯ/
diff --git a/lib-src/Makefile.in b/lib-src/Makefile.in
index f5d9db932ab..c07b678839c 100644
--- a/lib-src/Makefile.in
+++ b/lib-src/Makefile.in
@@ -27,7 +27,9 @@ EMACSOPT = -batch --no-site-file --no-site-lisp
# ==================== Things 'configure' will edit ====================
CC=@CC@
+CXX=@CXX@
CFLAGS=@CFLAGS@
+CXXFLAGS=@CXXFLAGS@
CPPFLAGS = @CPPFLAGS@
LDFLAGS = @LDFLAGS@
@@ -130,6 +132,11 @@ MKDIR_P = @MKDIR_P@
# ========================== Lists of Files ===========================
+## Haiku build-time support
+HAVE_BE_APP=@HAVE_BE_APP@
+HAIKU_LIBS=@HAIKU_LIBS@
+HAIKU_CFLAGS=@HAIKU_CFLAGS@
+
# emacsclientw.exe for MinGW, empty otherwise
CLIENTW = @CLIENTW@
@@ -143,7 +150,11 @@ UTILITIES = hexl${EXEEXT} \
$(if $(with_mailutils), , movemail${EXEEXT}) \
$(and $(use_gamedir), update-game-score${EXEEXT})
+ifeq ($(HAVE_BE_APP),yes)
+DONT_INSTALL= make-docfile${EXEEXT} make-fingerprint${EXEEXT} be-resources
+else
DONT_INSTALL= make-docfile${EXEEXT} make-fingerprint${EXEEXT}
+endif
# Like UTILITIES, but they're not system-dependent, and should not be
# deleted by the distclean target.
@@ -232,6 +243,10 @@ WINDRES = @WINDRES@
## Some systems define this to request special libraries.
LIBS_SYSTEM = @LIBS_SYSTEM@
+# Flags that could be in WARN_CFLAGS, but are invalid for C++.
+NON_CXX_CFLAGS = -Wmissing-prototypes -Wnested-externs -Wold-style-definition \
+ -Wstrict-prototypes -Wno-override-init
+
BASE_CFLAGS = $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) \
$(WARN_CFLAGS) $(WERROR_CFLAGS) \
-I. -I../src -I../lib \
@@ -240,6 +255,9 @@ BASE_CFLAGS = $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) \
ALL_CFLAGS = ${BASE_CFLAGS} ${PROFILING_CFLAGS} ${LDFLAGS} ${CPPFLAGS} ${CFLAGS}
CPP_CFLAGS = ${BASE_CFLAGS} ${PROFILING_CFLAGS} ${CPPFLAGS} ${CFLAGS}
+ALL_CXXFLAGS = $(filter-out ${NON_CXX_CFLAGS},${BASE_CFLAGS}) \
+ ${PROFILING_CFLAGS} ${LDFLAGS} ${CPPFLAGS} ${CFLAGS} ${CXXFLAGS} ${HAIKU_CFLAGS}
+
# Configuration files for .o files to depend on.
config_h = ../src/config.h $(srcdir)/../src/conf_post.h
@@ -409,6 +427,9 @@ emacsclientw${EXEEXT}: ${srcdir}/emacsclient.c $(NTLIB) $(CLIENTRES) $(config_h)
$(LOADLIBES) \
$(LIB_WSOCK32) $(LIB_EACCESS) $(LIBS_ECLIENT) -o $@
+be-resources: ${srcdir}/be_resources.cc ${config_h}
+ $(AM_V_CXXLD)$(CXX) ${ALL_CXXFLAGS} ${HAIKU_LIBS} $< -o $@
+
NTINC = ${srcdir}/../nt/inc
NTDEPS = $(NTINC)/ms-w32.h $(NTINC)/sys/stat.h $(NTINC)/inttypes.h \
$(NTINC)/stdint.h $(NTINC)/pwd.h $(NTINC)/sys/time.h $(NTINC)/stdbool.h \
diff --git a/lib-src/be_resources.cc b/lib-src/be_resources.cc
new file mode 100644
index 00000000000..e6a14f037b6
--- /dev/null
+++ b/lib-src/be_resources.cc
@@ -0,0 +1,144 @@
+/* Haiku window system support
+ Copyright (C) 2021 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 <cstdio>
+#include <cstring>
+#include <cstdlib>
+
+#include <SupportDefs.h>
+#include <Path.h>
+#include <AppFileInfo.h>
+#include <TranslationUtils.h>
+#include <Application.h>
+#include <Catalog.h>
+#include <Roster.h>
+
+using namespace std;
+
+static void
+be_perror (status_t code, char *arg)
+{
+ if (code != B_OK)
+ {
+ switch (code)
+ {
+ case B_BAD_VALUE:
+ fprintf (stderr, "%s: Bad value\n", arg);
+ break;
+ case B_ENTRY_NOT_FOUND:
+ fprintf (stderr, "%s: Not found\n", arg);
+ break;
+ case B_PERMISSION_DENIED:
+ fprintf (stderr, "%s: Permission denied\n", arg);
+ break;
+ case B_NO_MEMORY:
+ fprintf (stderr, "%s: No memory\n", arg);
+ break;
+ case B_LINK_LIMIT:
+ fprintf (stderr, "%s: Link limit reached\n", arg);
+ break;
+ case B_BUSY:
+ fprintf (stderr, "%s: Busy\n", arg);
+ break;
+ case B_NO_MORE_FDS:
+ fprintf (stderr, "%s: No more file descriptors\n", arg);
+ break;
+ case B_FILE_ERROR:
+ fprintf (stderr, "%s: File error\n", arg);
+ break;
+ default:
+ fprintf (stderr, "%s: Unknown error\n", arg);
+ }
+ }
+ else
+ {
+ abort ();
+ }
+}
+
+int
+main (int argc, char **argv)
+{
+ BApplication app ("application/x-vnd.GNU-emacs-resource-helper");
+ BFile file;
+ BBitmap *icon;
+ BAppFileInfo info;
+ status_t code;
+ struct version_info vinfo;
+ char *v = strdup (PACKAGE_VERSION);
+
+ if (argc != 3)
+ {
+ printf ("be-resources ICON FILE: make FILE appropriate for Emacs.\n");
+ return EXIT_FAILURE;
+ }
+
+ code = file.SetTo (argv[2], B_READ_WRITE);
+ if (code != B_OK)
+ {
+ be_perror (code, argv[2]);
+ return EXIT_FAILURE;
+ }
+ code = info.SetTo (&file);
+ if (code != B_OK)
+ {
+ be_perror (code, argv[2]);
+ return EXIT_FAILURE;
+ }
+ code = info.SetAppFlags (B_EXCLUSIVE_LAUNCH | B_ARGV_ONLY);
+ if (code != B_OK)
+ {
+ be_perror (code, argv[2]);
+ return EXIT_FAILURE;
+ }
+
+ icon = BTranslationUtils::GetBitmapFile (argv[1], NULL);
+
+ if (!icon)
+ {
+ be_perror (B_ERROR, argv[1]);
+ return EXIT_FAILURE;
+ }
+
+ info.SetIcon (icon, B_MINI_ICON);
+ info.SetIcon (icon, B_LARGE_ICON);
+ info.SetSignature ("application/x-vnd.GNU-emacs");
+
+ v = strtok (v, ".");
+ vinfo.major = atoi (v);
+
+ v = strtok (NULL, ".");
+ vinfo.middle = atoi (v);
+
+ v = strtok (NULL, ".");
+ vinfo.minor = v ? atoi (v) : 0;
+
+ vinfo.variety = 0;
+ vinfo.internal = 0;
+
+ strncpy ((char *) &vinfo.short_info, PACKAGE_VERSION,
+ sizeof vinfo.short_info - 1);
+ strncpy ((char *) &vinfo.long_info, PACKAGE_STRING,
+ sizeof vinfo.long_info - 1);
+
+ info.SetVersionInfo (&vinfo, B_APP_VERSION_KIND);
+
+ return EXIT_SUCCESS;
+}
diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c
index d11fd88c45e..7769e015edc 100644
--- a/lib-src/emacsclient.c
+++ b/lib-src/emacsclient.c
@@ -116,6 +116,9 @@ static bool eval;
/* True means open a new frame. --create-frame etc. */
static bool create_frame;
+/* True means reuse a frame if it already exists. */
+static bool reuse_frame;
+
/* The display on which Emacs should work. --display. */
static char const *display;
@@ -165,6 +168,7 @@ static struct option const longopts[] =
{ "tty", no_argument, NULL, 't' },
{ "nw", no_argument, NULL, 't' },
{ "create-frame", no_argument, NULL, 'c' },
+ { "reuse-frame", no_argument, NULL, 'r' },
{ "alternate-editor", required_argument, NULL, 'a' },
{ "frame-parameters", required_argument, NULL, 'F' },
#ifdef SOCKETS_IN_FILE_SYSTEM
@@ -551,6 +555,11 @@ decode_options (int argc, char **argv)
create_frame = true;
break;
+ case 'r':
+ create_frame = true;
+ reuse_frame = true;
+ break;
+
case 'p':
parent_id = optarg;
create_frame = true;
@@ -594,9 +603,16 @@ decode_options (int argc, char **argv)
alt_display = "ns";
#elif defined (HAVE_NTGUI)
alt_display = "w32";
+#elif defined (HAVE_HAIKU)
+ alt_display = "be";
#endif
+#ifdef HAVE_PGTK
+ display = egetenv ("WAYLAND_DISPLAY");
+ alt_display = egetenv ("DISPLAY");
+#else
display = egetenv ("DISPLAY");
+#endif
}
if (!display)
@@ -647,6 +663,8 @@ The following OPTIONS are accepted:\n\
-nw, -t, --tty Open a new Emacs frame on the current terminal\n\
-c, --create-frame Create a new frame instead of trying to\n\
use the current Emacs frame\n\
+-r, --reuse-frame Create a new frame if none exists, otherwise\n\
+ use the current Emacs frame\n\
", "\
-F ALIST, --frame-parameters=ALIST\n\
Set the parameters of a new frame\n\
@@ -1744,8 +1762,9 @@ start_daemon_and_retry_set_socket (void)
}
/* Try connecting, the daemon should have started by now. */
- message (true,
- "Emacs daemon should have started, trying to connect again\n");
+ if (!quiet)
+ message (true,
+ "Emacs daemon should have started, trying to connect again\n");
}
else if (dpid < 0)
{
@@ -1836,7 +1855,7 @@ start_daemon_and_retry_set_socket (void)
/* Try connecting, the daemon should have started by now. */
/* It's just a progress message, so don't pop a dialog if this is
emacsclientw. */
- if (!w32_window_app ())
+ if (!quiet && !w32_window_app ())
message (true,
"Emacs daemon should have started, trying to connect again\n");
#endif /* WINDOWSNT */
@@ -1940,7 +1959,7 @@ main (int argc, char **argv)
if (nowait)
send_to_emacs (emacs_socket, "-nowait ");
- if (!create_frame)
+ if (!create_frame || reuse_frame)
send_to_emacs (emacs_socket, "-current-frame ");
if (display)
diff --git a/lib-src/etags.c b/lib-src/etags.c
index bd4d4fcf53a..71f3464661c 100644
--- a/lib-src/etags.c
+++ b/lib-src/etags.c
@@ -5773,7 +5773,7 @@ static void
TEX_decode_env (const char *evarname, const char *defenv)
{
const char *env, *p;
- ptrdiff_t len;
+ ptrdiff_t len = 1;
/* Append default string to environment. */
env = getenv (evarname);
@@ -5782,8 +5782,13 @@ TEX_decode_env (const char *evarname, const char *defenv)
else
env = concat (env, defenv, "");
+ /* If the environment variable doesn't start with a colon, increase
+ the length of the token table. */
+ if (*env != ':')
+ len++;
+
/* Allocate a token table */
- for (len = 1, p = env; (p = strchr (p, ':')); )
+ for (p = env; (p = strchr (p, ':')); )
if (*++p)
len++;
TEX_toktab = xnew (len, linebuffer);
diff --git a/lib-src/ntlib.c b/lib-src/ntlib.c
index ccf827cf526..c8bcf742fea 100644
--- a/lib-src/ntlib.c
+++ b/lib-src/ntlib.c
@@ -20,14 +20,8 @@ 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/>. */
-/* Temporary workaround for compilation problems with MinGW64 GCC 11.
- The funky #ifdef's are to avoid warnings about unused macros. */
-#define _GL_ATTRIBUTE_MALLOC
-#define _GL_ATTRIBUTE_DEALLOC_FREE
-#ifdef _GL_ATTRIBUTE_MALLOC
-#endif
-#ifdef _GL_ATTRIBUTE_DEALLOC_FREE
-#endif
+#define DEFER_MS_W32_H
+#include <config.h>
#include <windows.h>
#include <stdlib.h>
@@ -296,9 +290,6 @@ is_exec (const char * name)
stricmp (p, ".cmd") == 0));
}
-/* FIXME? This is in configure.ac now - is this still needed? */
-#define IS_DIRECTORY_SEP(x) ((x) == '/' || (x) == '\\')
-
/* We need stat/fsfat below because nt/inc/sys/stat.h defines struct
stat that is incompatible with the MS run-time libraries. */
int
diff --git a/lib/cdefs.h b/lib/cdefs.h
index 4dac9d264d2..a05b538579b 100644
--- a/lib/cdefs.h
+++ b/lib/cdefs.h
@@ -1,4 +1,5 @@
/* Copyright (C) 1992-2021 Free Software Foundation, Inc.
+ Copyright The GNU Toolchain Authors.
This file is part of the GNU C Library.
The GNU C Library is free software; you can redistribute it and/or
@@ -150,6 +151,53 @@
# 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) \
+ ((__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. The -1 check is
+ redundant because since it implies that __glibc_safe_len_cond is true. */
+#define __glibc_safe_or_unknown_len(__l, __s, __osz) \
+ (__glibc_unsigned_or_positive (__l) \
+ && __builtin_constant_p (__glibc_safe_len_cond ((__SIZE_TYPE__) (__l), \
+ __s, __osz)) \
+ && __glibc_safe_len_cond ((__SIZE_TYPE__) (__l), __s, __osz))
+
+/* 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) \
+ (__glibc_unsigned_or_positive (__l) \
+ && __builtin_constant_p (__glibc_safe_len_cond ((__SIZE_TYPE__) (__l), \
+ __s, __osz)) \
+ && !__glibc_safe_len_cond ((__SIZE_TYPE__) (__l), __s, __osz))
+
+/* Fortify function f. __f_alias, __f_chk and __f_chk_warn must be
+ declared. */
+
+#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) \
+ ? __ ## f ## _chk_warn (__VA_ARGS__, __osz) \
+ : __ ## f ## _chk (__VA_ARGS__, __osz))) \
+
+/* 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, ...) \
+ (__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)))) \
+
#if __GNUC_PREREQ (4,3)
# define __warnattr(msg) __attribute__((__warning__ (msg)))
# define __errordecl(name, msg) \
@@ -243,6 +291,15 @@
# define __attribute_alloc_size__(params) /* Ignore. */
#endif
+/* Tell the compiler which argument to an allocation function
+ indicates the alignment of the allocation. */
+#if __GNUC_PREREQ (4, 9) || __glibc_has_attribute (__alloc_align__)
+# define __attribute_alloc_align__(param) \
+ __attribute__ ((__alloc_align__ param))
+#else
+# define __attribute_alloc_align__(param) /* Ignore. */
+#endif
+
/* At some point during the gcc 2.96 development the `pure' attribute
for functions was introduced. We don't want to use it unconditionally
(although this would be possible) since it generates warnings. */
@@ -605,12 +662,22 @@ _Static_assert (0, "IEEE 128-bits long double requires redirection on this platf
size-index is not provided:
access (access-mode, <ref-index> [, <size-index>]) */
# define __attr_access(x) __attribute__ ((__access__ x))
+/* For _FORTIFY_SOURCE == 3 we use __builtin_dynamic_object_size, which may
+ use the access attribute to get object sizes from function definition
+ arguments, so we can't use them on functions we fortify. Drop the object
+ size hints for such functions. */
+# if __USE_FORTIFY_LEVEL == 3
+# define __fortified_attr_access(a, o, s) __attribute__ ((__access__ (a, o)))
+# else
+# define __fortified_attr_access(a, o, s) __attr_access ((a, o, s))
+# endif
# if __GNUC_PREREQ (11, 0)
# define __attr_access_none(argno) __attribute__ ((__access__ (__none__, argno)))
# else
# define __attr_access_none(argno)
# endif
#else
+# define __fortified_attr_access(a, o, s)
# define __attr_access(x)
# define __attr_access_none(argno)
#endif
diff --git a/lib/gettext.h b/lib/gettext.h
index f1c7a240757..a573da35460 100644
--- a/lib/gettext.h
+++ b/lib/gettext.h
@@ -138,7 +138,7 @@
#define dcnpgettext(Domainname, Msgctxt, Msgid, MsgidPlural, N, Category) \
npgettext_aux (Domainname, Msgctxt GETTEXT_CONTEXT_GLUE Msgid, Msgid, MsgidPlural, N, Category)
-#ifdef __GNUC__
+#if defined __GNUC__ || defined __clang__
__inline
#else
#ifdef __cplusplus
@@ -157,7 +157,7 @@ pgettext_aux (const char *domain,
return translation;
}
-#ifdef __GNUC__
+#if defined __GNUC__ || defined __clang__
__inline
#else
#ifdef __cplusplus
@@ -191,9 +191,8 @@ npgettext_aux (const char *domain,
or may have security implications due to non-deterministic stack usage. */
#if (!defined GNULIB_NO_VLA \
- && (((__GNUC__ >= 3 || __GNUG__ >= 2) && !defined __STRICT_ANSI__) \
- /* || (__STDC_VERSION__ == 199901L && !defined __HP_cc)
- || (__STDC_VERSION__ >= 201112L && !defined __STDC_NO_VLA__) */ ))
+ && defined __STDC_VERSION__ && 199901L <= __STDC_VERSION__ \
+ && !defined __STDC_NO_VLA__)
# define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS 1
#else
# define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS 0
@@ -208,7 +207,7 @@ npgettext_aux (const char *domain,
#define dpgettext_expr(Domainname, Msgctxt, Msgid) \
dcpgettext_expr (Domainname, Msgctxt, Msgid, LC_MESSAGES)
-#ifdef __GNUC__
+#if defined __GNUC__ || defined __clang__
__inline
#else
#ifdef __cplusplus
@@ -255,7 +254,7 @@ dcpgettext_expr (const char *domain,
#define dnpgettext_expr(Domainname, Msgctxt, Msgid, MsgidPlural, N) \
dcnpgettext_expr (Domainname, Msgctxt, Msgid, MsgidPlural, N, LC_MESSAGES)
-#ifdef __GNUC__
+#if defined __GNUC__ || defined __clang__
__inline
#else
#ifdef __cplusplus
diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in
index c7c7eb455be..fbec70c135c 100644
--- a/lib/gnulib.mk.in
+++ b/lib/gnulib.mk.in
@@ -202,6 +202,9 @@ COM_ERRLIB = @COM_ERRLIB@
CPP = @CPP@
CPPFLAGS = @CPPFLAGS@
CRYPTOLIB = @CRYPTOLIB@
+CXX = @CXX@
+CXXCPP = @CXXCPP@
+CXXFLAGS = @CXXFLAGS@
CYGWIN_OBJ = @CYGWIN_OBJ@
C_SWITCH_MACHINE = @C_SWITCH_MACHINE@
C_SWITCH_SYSTEM = @C_SWITCH_SYSTEM@
@@ -244,18 +247,22 @@ GETOPT_CDEFS_H = @GETOPT_CDEFS_H@
GETOPT_H = @GETOPT_H@
GFILENOTIFY_CFLAGS = @GFILENOTIFY_CFLAGS@
GFILENOTIFY_LIBS = @GFILENOTIFY_LIBS@
-GL_COND_LIBTOOL = @GL_COND_LIBTOOL@
-GL_GENERATE_ALLOCA_H = @GL_GENERATE_ALLOCA_H@
-GL_GENERATE_BYTESWAP_H = @GL_GENERATE_BYTESWAP_H@
-GL_GENERATE_ERRNO_H = @GL_GENERATE_ERRNO_H@
-GL_GENERATE_EXECINFO_H = @GL_GENERATE_EXECINFO_H@
-GL_GENERATE_GMP_GMP_H = @GL_GENERATE_GMP_GMP_H@
-GL_GENERATE_IEEE754_H = @GL_GENERATE_IEEE754_H@
-GL_GENERATE_LIMITS_H = @GL_GENERATE_LIMITS_H@
-GL_GENERATE_MINI_GMP_H = @GL_GENERATE_MINI_GMP_H@
-GL_GENERATE_STDALIGN_H = @GL_GENERATE_STDALIGN_H@
-GL_GENERATE_STDDEF_H = @GL_GENERATE_STDDEF_H@
-GL_GENERATE_STDINT_H = @GL_GENERATE_STDINT_H@
+GLIB_COMPILE_SCHEMAS = @GLIB_COMPILE_SCHEMAS@
+GL_COND_LIBTOOL_CONDITION = @GL_COND_LIBTOOL_CONDITION@
+GL_GENERATE_ALLOCA_H_CONDITION = @GL_GENERATE_ALLOCA_H_CONDITION@
+GL_GENERATE_BYTESWAP_H_CONDITION = @GL_GENERATE_BYTESWAP_H_CONDITION@
+GL_GENERATE_ERRNO_H_CONDITION = @GL_GENERATE_ERRNO_H_CONDITION@
+GL_GENERATE_EXECINFO_H_CONDITION = @GL_GENERATE_EXECINFO_H_CONDITION@
+GL_GENERATE_GETOPT_CDEFS_H_CONDITION = @GL_GENERATE_GETOPT_CDEFS_H_CONDITION@
+GL_GENERATE_GETOPT_H_CONDITION = @GL_GENERATE_GETOPT_H_CONDITION@
+GL_GENERATE_GMP_GMP_H_CONDITION = @GL_GENERATE_GMP_GMP_H_CONDITION@
+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_STDDEF_H_CONDITION = @GL_GENERATE_STDDEF_H_CONDITION@
+GL_GENERATE_STDINT_H_CONDITION = @GL_GENERATE_STDINT_H_CONDITION@
GL_GNULIB_ACCESS = @GL_GNULIB_ACCESS@
GL_GNULIB_ALIGNED_ALLOC = @GL_GNULIB_ALIGNED_ALLOC@
GL_GNULIB_ALPHASORT = @GL_GNULIB_ALPHASORT@
@@ -556,17 +563,24 @@ GOBJECT_CFLAGS = @GOBJECT_CFLAGS@
GOBJECT_LIBS = @GOBJECT_LIBS@
GREP = @GREP@
GSETTINGS_CFLAGS = @GSETTINGS_CFLAGS@
+GSETTINGS_DISABLE_SCHEMAS_COMPILE = @GSETTINGS_DISABLE_SCHEMAS_COMPILE@
GSETTINGS_LIBS = @GSETTINGS_LIBS@
+GSETTINGS_RULES = @GSETTINGS_RULES@
GTK_CFLAGS = @GTK_CFLAGS@
GTK_LIBS = @GTK_LIBS@
GTK_OBJ = @GTK_OBJ@
GZIP_PROG = @GZIP_PROG@
+HAIKU_CFLAGS = @HAIKU_CFLAGS@
+HAIKU_CXX_OBJ = @HAIKU_CXX_OBJ@
+HAIKU_LIBS = @HAIKU_LIBS@
+HAIKU_OBJ = @HAIKU_OBJ@
HARFBUZZ_CFLAGS = @HARFBUZZ_CFLAGS@
HARFBUZZ_LIBS = @HARFBUZZ_LIBS@
HAVE_ALIGNED_ALLOC = @HAVE_ALIGNED_ALLOC@
HAVE_ALLOCA_H = @HAVE_ALLOCA_H@
HAVE_ALPHASORT = @HAVE_ALPHASORT@
HAVE_ATOLL = @HAVE_ATOLL@
+HAVE_BE_APP = @HAVE_BE_APP@
HAVE_C99_STDINT_H = @HAVE_C99_STDINT_H@
HAVE_CANONICALIZE_FILE_NAME = @HAVE_CANONICALIZE_FILE_NAME@
HAVE_CHOWN = @HAVE_CHOWN@
@@ -600,6 +614,7 @@ HAVE_DECL_LOCALTIME_R = @HAVE_DECL_LOCALTIME_R@
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_SETENV = @HAVE_DECL_SETENV@
HAVE_DECL_SETHOSTNAME = @HAVE_DECL_SETHOSTNAME@
HAVE_DECL_SETSTATE = @HAVE_DECL_SETSTATE@
@@ -690,6 +705,10 @@ HAVE_POPEN = @HAVE_POPEN@
HAVE_POSIX_MEMALIGN = @HAVE_POSIX_MEMALIGN@
HAVE_POSIX_OPENPT = @HAVE_POSIX_OPENPT@
HAVE_POSIX_SIGNALBLOCKING = @HAVE_POSIX_SIGNALBLOCKING@
+HAVE_POSIX_SPAWN = @HAVE_POSIX_SPAWN@
+HAVE_POSIX_SPAWNATTR_SETFLAGS = @HAVE_POSIX_SPAWNATTR_SETFLAGS@
+HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR = @HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR@
+HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP = @HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP@
HAVE_PREAD = @HAVE_PREAD@
HAVE_PSELECT = @HAVE_PSELECT@
HAVE_PTHREAD_SIGMASK = @HAVE_PTHREAD_SIGMASK@
@@ -726,6 +745,7 @@ HAVE_SIGNED_WCHAR_T = @HAVE_SIGNED_WCHAR_T@
HAVE_SIGNED_WINT_T = @HAVE_SIGNED_WINT_T@
HAVE_SIGSET_T = @HAVE_SIGSET_T@
HAVE_SLEEP = @HAVE_SLEEP@
+HAVE_SPAWN_H = @HAVE_SPAWN_H@
HAVE_STDINT_H = @HAVE_STDINT_H@
HAVE_STPCPY = @HAVE_STPCPY@
HAVE_STPNCPY = @HAVE_STPNCPY@
@@ -923,6 +943,8 @@ PATH_SEPARATOR = @PATH_SEPARATOR@
PAXCTL = @PAXCTL@
PAXCTL_dumped = @PAXCTL_dumped@
PAXCTL_notdumped = @PAXCTL_notdumped@
+PGTK_LIBS = @PGTK_LIBS@
+PGTK_OBJ = @PGTK_OBJ@
PKG_CONFIG = @PKG_CONFIG@
PKG_CONFIG_LIBDIR = @PKG_CONFIG_LIBDIR@
PKG_CONFIG_PATH = @PKG_CONFIG_PATH@
@@ -1104,6 +1126,7 @@ SETTINGS_LIBS = @SETTINGS_LIBS@
SHELL = @SHELL@
SIG_ATOMIC_T_SUFFIX = @SIG_ATOMIC_T_SUFFIX@
SIZE_T_SUFFIX = @SIZE_T_SUFFIX@
+SQLITE3_LIBS = @SQLITE3_LIBS@
STDALIGN_H = @STDALIGN_H@
STDDEF_H = @STDDEF_H@
STDINT_H = @STDINT_H@
@@ -1132,6 +1155,8 @@ WARN_CFLAGS = @WARN_CFLAGS@
WCHAR_T_SUFFIX = @WCHAR_T_SUFFIX@
WEBKIT_CFLAGS = @WEBKIT_CFLAGS@
WEBKIT_LIBS = @WEBKIT_LIBS@
+WEBP_CFLAGS = @WEBP_CFLAGS@
+WEBP_LIBS = @WEBP_LIBS@
WERROR_CFLAGS = @WERROR_CFLAGS@
WIDGET_OBJ = @WIDGET_OBJ@
WINDOWS_64_BIT_OFF_T = @WINDOWS_64_BIT_OFF_T@
@@ -1153,6 +1178,8 @@ XFT_LIBS = @XFT_LIBS@
XGSELOBJ = @XGSELOBJ@
XINERAMA_CFLAGS = @XINERAMA_CFLAGS@
XINERAMA_LIBS = @XINERAMA_LIBS@
+XINPUT_CFLAGS = @XINPUT_CFLAGS@
+XINPUT_LIBS = @XINPUT_LIBS@
XMENU_OBJ = @XMENU_OBJ@
XMKMF = @XMKMF@
XOBJ = @XOBJ@
@@ -1162,6 +1189,7 @@ XRENDER_LIBS = @XRENDER_LIBS@
XWIDGETS_OBJ = @XWIDGETS_OBJ@
X_TOOLKIT_TYPE = @X_TOOLKIT_TYPE@
ac_ct_CC = @ac_ct_CC@
+ac_ct_CXX = @ac_ct_CXX@
ac_ct_OBJC = @ac_ct_OBJC@
archlibdir = @archlibdir@
bindir = @bindir@
@@ -1188,34 +1216,35 @@ exec_prefix = @exec_prefix@
gamedir = @gamedir@
gamegroup = @gamegroup@
gameuser = @gameuser@
-gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7 = @gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7@
-gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b = @gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b@
-gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31 = @gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31@
-gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c = @gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c@
-gl_GNULIB_ENABLED_61bcaca76b3e6f9ae55d57a1c3193bc4 = @gl_GNULIB_ENABLED_61bcaca76b3e6f9ae55d57a1c3193bc4@
-gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec = @gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec@
-gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c = @gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c@
-gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1 = @gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1@
-gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36 = @gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36@
-gl_GNULIB_ENABLED_cloexec = @gl_GNULIB_ENABLED_cloexec@
-gl_GNULIB_ENABLED_d3b2383720ee0e541357aa2aac598e2b = @gl_GNULIB_ENABLED_d3b2383720ee0e541357aa2aac598e2b@
-gl_GNULIB_ENABLED_dirfd = @gl_GNULIB_ENABLED_dirfd@
-gl_GNULIB_ENABLED_dynarray = @gl_GNULIB_ENABLED_dynarray@
-gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866 = @gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866@
-gl_GNULIB_ENABLED_euidaccess = @gl_GNULIB_ENABLED_euidaccess@
-gl_GNULIB_ENABLED_getdtablesize = @gl_GNULIB_ENABLED_getdtablesize@
-gl_GNULIB_ENABLED_getgroups = @gl_GNULIB_ENABLED_getgroups@
-gl_GNULIB_ENABLED_lchmod = @gl_GNULIB_ENABLED_lchmod@
-gl_GNULIB_ENABLED_open = @gl_GNULIB_ENABLED_open@
-gl_GNULIB_ENABLED_rawmemchr = @gl_GNULIB_ENABLED_rawmemchr@
-gl_GNULIB_ENABLED_scratch_buffer = @gl_GNULIB_ENABLED_scratch_buffer@
-gl_GNULIB_ENABLED_strtoll = @gl_GNULIB_ENABLED_strtoll@
-gl_GNULIB_ENABLED_utimens = @gl_GNULIB_ENABLED_utimens@
+gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7_CONDITION = @gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7_CONDITION@
+gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b_CONDITION = @gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b_CONDITION@
+gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31_CONDITION = @gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31_CONDITION@
+gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c_CONDITION = @gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c_CONDITION@
+gl_GNULIB_ENABLED_61bcaca76b3e6f9ae55d57a1c3193bc4_CONDITION = @gl_GNULIB_ENABLED_61bcaca76b3e6f9ae55d57a1c3193bc4_CONDITION@
+gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec_CONDITION = @gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec_CONDITION@
+gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c_CONDITION = @gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c_CONDITION@
+gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1_CONDITION = @gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1_CONDITION@
+gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36_CONDITION = @gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36_CONDITION@
+gl_GNULIB_ENABLED_cloexec_CONDITION = @gl_GNULIB_ENABLED_cloexec_CONDITION@
+gl_GNULIB_ENABLED_d3b2383720ee0e541357aa2aac598e2b_CONDITION = @gl_GNULIB_ENABLED_d3b2383720ee0e541357aa2aac598e2b_CONDITION@
+gl_GNULIB_ENABLED_dirfd_CONDITION = @gl_GNULIB_ENABLED_dirfd_CONDITION@
+gl_GNULIB_ENABLED_dynarray_CONDITION = @gl_GNULIB_ENABLED_dynarray_CONDITION@
+gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866_CONDITION = @gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866_CONDITION@
+gl_GNULIB_ENABLED_euidaccess_CONDITION = @gl_GNULIB_ENABLED_euidaccess_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@
+gl_GNULIB_ENABLED_open_CONDITION = @gl_GNULIB_ENABLED_open_CONDITION@
+gl_GNULIB_ENABLED_rawmemchr_CONDITION = @gl_GNULIB_ENABLED_rawmemchr_CONDITION@
+gl_GNULIB_ENABLED_scratch_buffer_CONDITION = @gl_GNULIB_ENABLED_scratch_buffer_CONDITION@
+gl_GNULIB_ENABLED_strtoll_CONDITION = @gl_GNULIB_ENABLED_strtoll_CONDITION@
+gl_GNULIB_ENABLED_utimens_CONDITION = @gl_GNULIB_ENABLED_utimens_CONDITION@
gl_LIBOBJS = @gl_LIBOBJS@
gl_LTLIBOBJS = @gl_LTLIBOBJS@
gltests_LIBOBJS = @gltests_LIBOBJS@
gltests_LTLIBOBJS = @gltests_LTLIBOBJS@
gltests_WITNESS = @gltests_WITNESS@
+gsettingsschemadir = @gsettingsschemadir@
host = @host@
host_alias = @host_alias@
host_cpu = @host_cpu@
@@ -1296,9 +1325,10 @@ BUILT_SOURCES += $(ALLOCA_H)
# We need the following in order to create <alloca.h> when the system
# doesn't have one that works with the given compiler.
-ifneq (,$(GL_GENERATE_ALLOCA_H))
+ifneq (,$(GL_GENERATE_ALLOCA_H_CONDITION))
alloca.h: alloca.in.h $(top_builddir)/config.status
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''HAVE_ALLOCA_H''@|$(HAVE_ALLOCA_H)|g' < $(srcdir)/alloca.in.h; \
} > $@-t && \
@@ -1327,7 +1357,7 @@ endif
## begin gnulib module at-internal
ifeq (,$(OMIT_GNULIB_MODULE_at-internal))
-ifneq (,$(gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b))
+ifneq (,$(gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b_CONDITION))
libgnu_a_SOURCES += openat-priv.h openat-proc.c
endif
@@ -1358,9 +1388,10 @@ BUILT_SOURCES += $(BYTESWAP_H)
# We need the following in order to create <byteswap.h> when the system
# doesn't have one.
-ifneq (,$(GL_GENERATE_BYTESWAP_H))
+ifneq (,$(GL_GENERATE_BYTESWAP_H_CONDITION))
byteswap.h: byteswap.in.h $(top_builddir)/config.status
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
cat $(srcdir)/byteswap.in.h; \
} > $@-t && \
@@ -1416,7 +1447,7 @@ endif
## begin gnulib module cloexec
ifeq (,$(OMIT_GNULIB_MODULE_cloexec))
-ifneq (,$(gl_GNULIB_ENABLED_cloexec))
+ifneq (,$(gl_GNULIB_ENABLED_cloexec_CONDITION))
libgnu_a_SOURCES += cloexec.c
endif
@@ -1541,6 +1572,7 @@ BUILT_SOURCES += dirent.h
# doesn't have one that works with the given compiler.
dirent.h: dirent.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's|@''HAVE_DIRENT_H''@|$(HAVE_DIRENT_H)|g' \
@@ -1585,7 +1617,7 @@ endif
## begin gnulib module dirfd
ifeq (,$(OMIT_GNULIB_MODULE_dirfd))
-ifneq (,$(gl_GNULIB_ENABLED_dirfd))
+ifneq (,$(gl_GNULIB_ENABLED_dirfd_CONDITION))
endif
EXTRA_DIST += dirfd.c
@@ -1629,11 +1661,11 @@ endif
## begin gnulib module dynarray
ifeq (,$(OMIT_GNULIB_MODULE_dynarray))
-ifneq (,$(gl_GNULIB_ENABLED_dynarray))
+ifneq (,$(gl_GNULIB_ENABLED_dynarray_CONDITION))
BUILT_SOURCES += malloc/dynarray.gl.h malloc/dynarray-skeleton.gl.h
malloc/dynarray.gl.h: malloc/dynarray.h
- $(AM_V_at)$(MKDIR_P) malloc
+ $(AM_V_at)$(MKDIR_P) 'malloc'
$(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e '/libc_hidden_proto/d' < $(srcdir)/malloc/dynarray.h; \
@@ -1642,7 +1674,7 @@ malloc/dynarray.gl.h: malloc/dynarray.h
MOSTLYCLEANFILES += malloc/dynarray.gl.h malloc/dynarray.gl.h-t
malloc/dynarray-skeleton.gl.h: malloc/dynarray-skeleton.c
- $(AM_V_at)$(MKDIR_P) malloc
+ $(AM_V_at)$(MKDIR_P) 'malloc'
$(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|<malloc/dynarray\.h>|<malloc/dynarray.gl.h>|g' \
@@ -1669,7 +1701,7 @@ endif
## begin gnulib module eloop-threshold
ifeq (,$(OMIT_GNULIB_MODULE_eloop-threshold))
-ifneq (,$(gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c))
+ifneq (,$(gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c_CONDITION))
endif
EXTRA_DIST += eloop-threshold.h
@@ -1684,9 +1716,10 @@ BUILT_SOURCES += $(ERRNO_H)
# We need the following in order to create <errno.h> when the system
# doesn't have one that is POSIX compliant.
-ifneq (,$(GL_GENERATE_ERRNO_H))
+ifneq (,$(GL_GENERATE_ERRNO_H_CONDITION))
errno.h: errno.in.h $(top_builddir)/config.status
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -1716,7 +1749,7 @@ endif
## begin gnulib module euidaccess
ifeq (,$(OMIT_GNULIB_MODULE_euidaccess))
-ifneq (,$(gl_GNULIB_ENABLED_euidaccess))
+ifneq (,$(gl_GNULIB_ENABLED_euidaccess_CONDITION))
endif
EXTRA_DIST += euidaccess.c
@@ -1733,9 +1766,10 @@ BUILT_SOURCES += $(EXECINFO_H)
# We need the following in order to create <execinfo.h> when the system
# doesn't have one that works.
-ifneq (,$(GL_GENERATE_EXECINFO_H))
+ifneq (,$(GL_GENERATE_EXECINFO_H_CONDITION))
execinfo.h: execinfo.in.h $(top_builddir)/config.status
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
cat $(srcdir)/execinfo.in.h; \
} > $@-t && \
@@ -1806,6 +1840,7 @@ BUILT_SOURCES += fcntl.h
# doesn't have one that works with the given compiler.
fcntl.h: fcntl.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -1966,7 +2001,7 @@ endif
## begin gnulib module getdtablesize
ifeq (,$(OMIT_GNULIB_MODULE_getdtablesize))
-ifneq (,$(gl_GNULIB_ENABLED_getdtablesize))
+ifneq (,$(gl_GNULIB_ENABLED_getdtablesize_CONDITION))
endif
EXTRA_DIST += getdtablesize.c
@@ -1979,7 +2014,7 @@ endif
## begin gnulib module getgroups
ifeq (,$(OMIT_GNULIB_MODULE_getgroups))
-ifneq (,$(gl_GNULIB_ENABLED_getgroups))
+ifneq (,$(gl_GNULIB_ENABLED_getgroups_CONDITION))
endif
EXTRA_DIST += getgroups.c
@@ -2007,8 +2042,10 @@ BUILT_SOURCES += $(GETOPT_H) $(GETOPT_CDEFS_H)
# We need the following in order to create <getopt.h> when the system
# doesn't have one that works with the given compiler.
+ifneq (,$(GL_GENERATE_GETOPT_H_CONDITION))
getopt.h: getopt.in.h $(top_builddir)/config.status $(ARG_NONNULL_H)
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's|@''HAVE_GETOPT_H''@|$(HAVE_GETOPT_H)|g' \
@@ -2020,7 +2057,12 @@ getopt.h: getopt.in.h $(top_builddir)/config.status $(ARG_NONNULL_H)
< $(srcdir)/getopt.in.h; \
} > $@-t && \
mv -f $@-t $@
+else
+getopt.h: $(top_builddir)/config.status
+ rm -f $@
+endif
+ifneq (,$(GL_GENERATE_GETOPT_CDEFS_H_CONDITION))
getopt-cdefs.h: getopt-cdefs.in.h $(top_builddir)/config.status
$(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
@@ -2028,6 +2070,10 @@ getopt-cdefs.h: getopt-cdefs.in.h $(top_builddir)/config.status
< $(srcdir)/getopt-cdefs.in.h; \
} > $@-t && \
mv -f $@-t $@
+else
+getopt-cdefs.h: $(top_builddir)/config.status
+ rm -f $@
+endif
MOSTLYCLEANFILES += getopt.h getopt.h-t getopt-cdefs.h getopt-cdefs.h-t
@@ -2052,7 +2098,7 @@ endif
## begin gnulib module gettext-h
ifeq (,$(OMIT_GNULIB_MODULE_gettext-h))
-ifneq (,$(gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36))
+ifneq (,$(gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36_CONDITION))
libgnu_a_SOURCES += gettext.h
endif
@@ -2090,7 +2136,7 @@ endif
## begin gnulib module group-member
ifeq (,$(OMIT_GNULIB_MODULE_group-member))
-ifneq (,$(gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1))
+ifneq (,$(gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1_CONDITION))
endif
EXTRA_DIST += group-member.c
@@ -2115,9 +2161,10 @@ BUILT_SOURCES += $(IEEE754_H)
# We need the following in order to create <ieee754.h> when the system
# doesn't have one that works with the given compiler.
-ifneq (,$(GL_GENERATE_IEEE754_H))
+ifneq (,$(GL_GENERATE_IEEE754_H_CONDITION))
ieee754.h: ieee754.in.h $(top_builddir)/config.status
$(AM_V_GEN)rm -f $@-t && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's/ifndef _GL_GNULIB_HEADER/if 0/g' \
$(srcdir)/ieee754.in.h; \
@@ -2161,6 +2208,7 @@ BUILT_SOURCES += inttypes.h
# doesn't have one that works with the given compiler.
inttypes.h: inttypes.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(WARN_ON_USE_H) $(ARG_NONNULL_H)
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's/@''HAVE_INTTYPES_H''@/$(HAVE_INTTYPES_H)/g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -2200,7 +2248,7 @@ endif
## begin gnulib module lchmod
ifeq (,$(OMIT_GNULIB_MODULE_lchmod))
-ifneq (,$(gl_GNULIB_ENABLED_lchmod))
+ifneq (,$(gl_GNULIB_ENABLED_lchmod_CONDITION))
endif
EXTRA_DIST += lchmod.c
@@ -2224,22 +2272,25 @@ ifeq (,$(OMIT_GNULIB_MODULE_libgmp))
BUILT_SOURCES += $(GMP_H)
-ifneq (,$(GL_GENERATE_MINI_GMP_H))
+ifneq (,$(GL_GENERATE_GMP_H_CONDITION))
+ifneq (,$(GL_GENERATE_MINI_GMP_H_CONDITION))
# Build gmp.h as a wrapper for mini-gmp.h when using mini-gmp.
gmp.h: $(top_builddir)/config.status
- echo '#include "mini-gmp.h"' >$@-t
+ $(MKDIR_P) '.'
+ echo '#include "mini-gmp.h"' > $@-t
mv $@-t $@
-else
-ifneq (,$(GL_GENERATE_GMP_GMP_H))
+endif
+ifneq (,$(GL_GENERATE_GMP_GMP_H_CONDITION))
# Build gmp.h as a wrapper for gmp/gmp.h.
gmp.h: $(top_builddir)/config.status
- echo '#include <gmp/gmp.h>' >$@-t
+ $(MKDIR_P) '.'
+ echo '#include <gmp/gmp.h>' > $@-t
mv $@-t $@
+endif
else
gmp.h: $(top_builddir)/config.status
rm -f $@
endif
-endif
MOSTLYCLEANFILES += gmp.h gmp.h-t
EXTRA_DIST += mini-gmp-gnulib.c mini-gmp.c mini-gmp.h
@@ -2256,9 +2307,10 @@ BUILT_SOURCES += $(LIMITS_H)
# We need the following in order to create <limits.h> when the system
# doesn't have one that is compatible with GNU.
-ifneq (,$(GL_GENERATE_LIMITS_H))
+ifneq (,$(GL_GENERATE_LIMITS_H_CONDITION))
limits.h: limits.in.h $(top_builddir)/config.status
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -2293,7 +2345,7 @@ endif
## begin gnulib module malloc-posix
ifeq (,$(OMIT_GNULIB_MODULE_malloc-posix))
-ifneq (,$(gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866))
+ifneq (,$(gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866_CONDITION))
endif
EXTRA_DIST += malloc.c
@@ -2369,7 +2421,7 @@ endif
## begin gnulib module mktime-internal
ifeq (,$(OMIT_GNULIB_MODULE_mktime-internal))
-ifneq (,$(gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31))
+ifneq (,$(gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31_CONDITION))
endif
EXTRA_DIST += mktime-internal.h mktime.c
@@ -2402,7 +2454,7 @@ endif
## begin gnulib module open
ifeq (,$(OMIT_GNULIB_MODULE_open))
-ifneq (,$(gl_GNULIB_ENABLED_open))
+ifneq (,$(gl_GNULIB_ENABLED_open_CONDITION))
endif
EXTRA_DIST += open.c
@@ -2415,7 +2467,7 @@ endif
## begin gnulib module openat-h
ifeq (,$(OMIT_GNULIB_MODULE_openat-h))
-ifneq (,$(gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7))
+ifneq (,$(gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7_CONDITION))
endif
EXTRA_DIST += openat.h
@@ -2473,7 +2525,7 @@ endif
## begin gnulib module rawmemchr
ifeq (,$(OMIT_GNULIB_MODULE_rawmemchr))
-ifneq (,$(gl_GNULIB_ENABLED_rawmemchr))
+ifneq (,$(gl_GNULIB_ENABLED_rawmemchr_CONDITION))
endif
EXTRA_DIST += rawmemchr.c rawmemchr.valgrind
@@ -2508,7 +2560,7 @@ endif
## begin gnulib module realloc-gnu
ifeq (,$(OMIT_GNULIB_MODULE_realloc-gnu))
-ifneq (,$(gl_GNULIB_ENABLED_d3b2383720ee0e541357aa2aac598e2b))
+ifneq (,$(gl_GNULIB_ENABLED_d3b2383720ee0e541357aa2aac598e2b_CONDITION))
endif
EXTRA_DIST += realloc.c
@@ -2521,7 +2573,7 @@ endif
## begin gnulib module realloc-posix
ifeq (,$(OMIT_GNULIB_MODULE_realloc-posix))
-ifneq (,$(gl_GNULIB_ENABLED_61bcaca76b3e6f9ae55d57a1c3193bc4))
+ifneq (,$(gl_GNULIB_ENABLED_61bcaca76b3e6f9ae55d57a1c3193bc4_CONDITION))
endif
EXTRA_DIST += realloc.c
@@ -2545,7 +2597,7 @@ endif
## begin gnulib module root-uid
ifeq (,$(OMIT_GNULIB_MODULE_root-uid))
-ifneq (,$(gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c))
+ifneq (,$(gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c_CONDITION))
endif
EXTRA_DIST += root-uid.h
@@ -2556,11 +2608,11 @@ endif
## begin gnulib module scratch_buffer
ifeq (,$(OMIT_GNULIB_MODULE_scratch_buffer))
-ifneq (,$(gl_GNULIB_ENABLED_scratch_buffer))
+ifneq (,$(gl_GNULIB_ENABLED_scratch_buffer_CONDITION))
BUILT_SOURCES += malloc/scratch_buffer.gl.h
malloc/scratch_buffer.gl.h: malloc/scratch_buffer.h
- $(AM_V_at)$(MKDIR_P) malloc
+ $(AM_V_at)$(MKDIR_P) 'malloc'
$(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|__always_inline|inline _GL_ATTRIBUTE_ALWAYS_INLINE|g' \
@@ -2611,6 +2663,7 @@ BUILT_SOURCES += signal.h
# doesn't have a complete one.
signal.h: signal.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -2719,9 +2772,10 @@ 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))
+ifneq (,$(GL_GENERATE_STDALIGN_H_CONDITION))
stdalign.h: stdalign.in.h $(top_builddir)/config.status
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
cat $(srcdir)/stdalign.in.h; \
} > $@-t && \
@@ -2744,9 +2798,10 @@ BUILT_SOURCES += $(STDDEF_H)
# We need the following in order to create <stddef.h> when the system
# doesn't have one that works with the given compiler.
-ifneq (,$(GL_GENERATE_STDDEF_H))
+ifneq (,$(GL_GENERATE_STDDEF_H_CONDITION))
stddef.h: stddef.in.h $(top_builddir)/config.status
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -2777,9 +2832,10 @@ BUILT_SOURCES += $(STDINT_H)
# We need the following in order to create <stdint.h> when the system
# doesn't have one that works with the given compiler.
-ifneq (,$(GL_GENERATE_STDINT_H))
+ifneq (,$(GL_GENERATE_STDINT_H_CONDITION))
stdint.h: stdint.in.h $(top_builddir)/config.status
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's/@''HAVE_STDINT_H''@/$(HAVE_STDINT_H)/g' \
@@ -2831,6 +2887,7 @@ BUILT_SOURCES += stdio.h
# doesn't have one that works with the given compiler.
stdio.h: stdio.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -2969,6 +3026,7 @@ BUILT_SOURCES += stdlib.h
stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \
$(_NORETURN_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -3125,6 +3183,7 @@ BUILT_SOURCES += string.h
# doesn't have one that works with the given compiler.
string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -3256,7 +3315,7 @@ endif
## begin gnulib module strtoll
ifeq (,$(OMIT_GNULIB_MODULE_strtoll))
-ifneq (,$(gl_GNULIB_ENABLED_strtoll))
+ifneq (,$(gl_GNULIB_ENABLED_strtoll_CONDITION))
endif
EXTRA_DIST += strtol.c strtoll.c
@@ -3285,7 +3344,7 @@ BUILT_SOURCES += sys/random.h
# We need the following in order to create <sys/random.h> when the system
# doesn't have one.
sys/random.h: sys_random.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
- $(AM_V_at)$(MKDIR_P) sys
+ $(AM_V_at)$(MKDIR_P) 'sys'
$(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
@@ -3319,7 +3378,7 @@ BUILT_SOURCES += sys/select.h
# We need the following in order to create <sys/select.h> when the system
# doesn't have one that works with the given compiler.
sys/select.h: sys_select.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(WARN_ON_USE_H)
- $(AM_V_at)$(MKDIR_P) sys
+ $(AM_V_at)$(MKDIR_P) 'sys'
$(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
@@ -3355,7 +3414,7 @@ BUILT_SOURCES += sys/stat.h
# We need the following in order to create <sys/stat.h> when the system
# has one that is incomplete.
sys/stat.h: sys_stat.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
- $(AM_V_at)$(MKDIR_P) sys
+ $(AM_V_at)$(MKDIR_P) 'sys'
$(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
@@ -3430,7 +3489,7 @@ BUILT_SOURCES += sys/time.h
# We need the following in order to create <sys/time.h> when the system
# doesn't have one that works with the given compiler.
sys/time.h: sys_time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
- $(AM_V_at)$(MKDIR_P) sys
+ $(AM_V_at)$(MKDIR_P) 'sys'
$(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
@@ -3466,7 +3525,7 @@ BUILT_SOURCES += sys/types.h
# We need the following in order to create <sys/types.h> when the system
# doesn't have one that works with the given compiler.
sys/types.h: sys_types.in.h $(top_builddir)/config.status
- $(AM_V_at)$(MKDIR_P) sys
+ $(AM_V_at)$(MKDIR_P) 'sys'
$(AM_V_GEN)rm -f $@-t $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
@@ -3505,6 +3564,7 @@ BUILT_SOURCES += time.h
# doesn't have one that works with the given compiler.
time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -3635,6 +3695,7 @@ libgnu_a_SOURCES += unistd.c
# <unistd.h> when the system doesn't have one.
unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f $@-t $@ && \
+ $(MKDIR_P) '.' && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''GUARD_PREFIX''@|GL|g' \
-e 's|@''HAVE_UNISTD_H''@|$(HAVE_UNISTD_H)|g' \
@@ -3853,7 +3914,7 @@ endif
## begin gnulib module utimens
ifeq (,$(OMIT_GNULIB_MODULE_utimens))
-ifneq (,$(gl_GNULIB_ENABLED_utimens))
+ifneq (,$(gl_GNULIB_ENABLED_utimens_CONDITION))
libgnu_a_SOURCES += utimens.c
endif
@@ -3894,7 +3955,7 @@ endif
## begin gnulib module xalloc-oversized
ifeq (,$(OMIT_GNULIB_MODULE_xalloc-oversized))
-ifneq (,$(gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec))
+ifneq (,$(gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec_CONDITION))
endif
EXTRA_DIST += xalloc-oversized.h
diff --git a/lib/intprops.h b/lib/intprops.h
index 3fe64e82e9f..7f20f09fa06 100644
--- a/lib/intprops.h
+++ b/lib/intprops.h
@@ -229,18 +229,18 @@
/* True if __builtin_add_overflow (A, B, P) and __builtin_sub_overflow
(A, B, P) work when P is non-null. */
+#if defined __has_builtin
+# define _GL_HAS_BUILTIN_ADD_OVERFLOW __has_builtin (__builtin_add_overflow)
/* __builtin_{add,sub}_overflow exists but is not reliable in GCC 5.x and 6.x,
see <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=98269>. */
-#if 7 <= __GNUC__ && !defined __ICC
+#elif 7 <= __GNUC__ && !defined __EDG__
# define _GL_HAS_BUILTIN_ADD_OVERFLOW 1
-#elif defined __has_builtin
-# define _GL_HAS_BUILTIN_ADD_OVERFLOW __has_builtin (__builtin_add_overflow)
#else
# define _GL_HAS_BUILTIN_ADD_OVERFLOW 0
#endif
/* True if __builtin_mul_overflow (A, B, P) works when P is non-null. */
-#ifdef __clang__
+#if defined __clang_major_ && __clang_major__ < 14
/* Work around Clang bug <https://bugs.llvm.org/show_bug.cgi?id=16404>. */
# define _GL_HAS_BUILTIN_MUL_OVERFLOW 0
#else
@@ -249,9 +249,8 @@
/* True if __builtin_add_overflow_p (A, B, C) works, and similarly for
__builtin_sub_overflow_p and __builtin_mul_overflow_p. */
-#if defined __clang__ || defined __ICC
-/* Clang 11 lacks __builtin_mul_overflow_p, and even if it did it
- would presumably run afoul of Clang bug 16404. ICC 2021.1's
+#ifdef __EDG__
+/* In EDG-based compilers like ICC 2021.3 and earlier,
__builtin_add_overflow_p etc. are not treated as integral constant
expressions even when all arguments are. */
# define _GL_HAS_BUILTIN_OVERFLOW_P 0
@@ -400,7 +399,7 @@
#if _GL_HAS_BUILTIN_MUL_OVERFLOW
# if ((9 < __GNUC__ + (3 <= __GNUC_MINOR__) \
|| (__GNUC__ == 8 && 4 <= __GNUC_MINOR__)) \
- && !defined __ICC)
+ && !defined __EDG__)
# define INT_MULTIPLY_WRAPV(a, b, r) __builtin_mul_overflow (a, b, r)
# else
/* Work around GCC bug 91450. */
diff --git a/lib/nproc.c b/lib/nproc.c
index a9e369dd3f7..1af989d6dd0 100644
--- a/lib/nproc.c
+++ b/lib/nproc.c
@@ -307,10 +307,11 @@ num_processors_ignoring_omp (enum nproc_query query)
NPROC_CURRENT and NPROC_ALL. */
#if HAVE_SYSCTL && ! defined __GLIBC__ && defined HW_NCPU
- { /* This works on Mac OS X, FreeBSD, NetBSD, OpenBSD. */
+ { /* This works on macOS, FreeBSD, NetBSD, OpenBSD.
+ macOS 10.14 does not allow mib to be const. */
int nprocs;
size_t len = sizeof (nprocs);
- static int const mib[][2] = {
+ static int mib[][2] = {
# ifdef HW_NCPUONLINE
{ CTL_HW, HW_NCPUONLINE },
# endif
diff --git a/lib/nstrftime.c b/lib/nstrftime.c
index 7f258e8727f..25baf76c60f 100644
--- a/lib/nstrftime.c
+++ b/lib/nstrftime.c
@@ -22,7 +22,7 @@
# define HAVE_TZNAME 1
# include "../locale/localeinfo.h"
#else
-# include <config.h>
+# include <libc-config.h>
# if FPRINTFTIME
# include "fprintftime.h"
# else
@@ -367,10 +367,7 @@ tm_diff (const struct tm *a, const struct tm *b)
#define ISO_WEEK1_WDAY 4 /* Thursday */
#define YDAY_MINIMUM (-366)
static int iso_week_days (int, int);
-#if defined __GNUC__ || defined __clang__
-__inline__
-#endif
-static int
+static __inline int
iso_week_days (int yday, int wday)
{
/* Add enough to the first operand of % to make it nonnegative. */
@@ -428,9 +425,7 @@ my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
return __strftime_internal (s, STRFTIME_ARG (maxsize) format, tp, false,
0, -1, &tzset_called extra_args LOCALE_ARG);
}
-#if defined _LIBC && ! FPRINTFTIME
libc_hidden_def (my_strftime)
-#endif
/* Just like my_strftime, above, but with more parameters.
UPCASE indicates that the result should be converted to upper case.
diff --git a/lib/regcomp.c b/lib/regcomp.c
index 887e5b50684..6a97fdee478 100644
--- a/lib/regcomp.c
+++ b/lib/regcomp.c
@@ -27,14 +27,10 @@ static void re_compile_fastmap_iter (regex_t *bufp,
const re_dfastate_t *init_state,
char *fastmap);
static reg_errcode_t init_dfa (re_dfa_t *dfa, size_t pat_len);
-#ifdef RE_ENABLE_I18N
static void free_charset (re_charset_t *cset);
-#endif /* RE_ENABLE_I18N */
static void free_workarea_compile (regex_t *preg);
static reg_errcode_t create_initial_state (re_dfa_t *dfa);
-#ifdef RE_ENABLE_I18N
static void optimize_utf8 (re_dfa_t *dfa);
-#endif
static reg_errcode_t analyze (regex_t *preg);
static reg_errcode_t preorder (bin_tree_t *root,
reg_errcode_t (fn (void *, bin_tree_t *)),
@@ -89,7 +85,6 @@ static reg_errcode_t parse_bracket_element (bracket_elem_t *elem,
static reg_errcode_t parse_bracket_symbol (bracket_elem_t *elem,
re_string_t *regexp,
re_token_t *token);
-#ifdef RE_ENABLE_I18N
static reg_errcode_t build_equiv_class (bitset_t sbcset,
re_charset_t *mbcset,
Idx *equiv_class_alloc,
@@ -100,14 +95,6 @@ static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans,
Idx *char_class_alloc,
const char *class_name,
reg_syntax_t syntax);
-#else /* not RE_ENABLE_I18N */
-static reg_errcode_t build_equiv_class (bitset_t sbcset,
- const unsigned char *name);
-static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans,
- bitset_t sbcset,
- const char *class_name,
- reg_syntax_t syntax);
-#endif /* not RE_ENABLE_I18N */
static bin_tree_t *build_charclass_op (re_dfa_t *dfa,
RE_TRANSLATE_TYPE trans,
const char *class_name,
@@ -279,8 +266,7 @@ re_compile_fastmap (struct re_pattern_buffer *bufp)
}
weak_alias (__re_compile_fastmap, re_compile_fastmap)
-static inline void
-__attribute__ ((always_inline))
+static __always_inline void
re_set_fastmap (char *fastmap, bool icase, int ch)
{
fastmap[ch] = 1;
@@ -306,7 +292,6 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state,
if (type == CHARACTER)
{
re_set_fastmap (fastmap, icase, dfa->nodes[node].opr.c);
-#ifdef RE_ENABLE_I18N
if ((bufp->syntax & RE_ICASE) && dfa->mb_cur_max > 1)
{
unsigned char buf[MB_LEN_MAX];
@@ -327,7 +312,6 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state,
!= (size_t) -1))
re_set_fastmap (fastmap, false, buf[0]);
}
-#endif
}
else if (type == SIMPLE_BRACKET)
{
@@ -341,13 +325,12 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state,
re_set_fastmap (fastmap, icase, ch);
}
}
-#ifdef RE_ENABLE_I18N
else if (type == COMPLEX_BRACKET)
{
re_charset_t *cset = dfa->nodes[node].opr.mbcset;
Idx i;
-# ifdef _LIBC
+#ifdef _LIBC
/* See if we have to try all bytes which start multiple collation
elements.
e.g. In da_DK, we want to catch 'a' since "aa" is a valid
@@ -363,7 +346,7 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state,
if (table[i] < 0)
re_set_fastmap (fastmap, icase, i);
}
-# endif /* _LIBC */
+#endif /* _LIBC */
/* See if we have to start the match at all multibyte characters,
i.e. where we would not find an invalid sequence. This only
@@ -371,9 +354,9 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state,
sets, the SIMPLE_BRACKET again suffices. */
if (dfa->mb_cur_max > 1
&& (cset->nchar_classes || cset->non_match || cset->nranges
-# ifdef _LIBC
+#ifdef _LIBC
|| cset->nequiv_classes
-# endif /* _LIBC */
+#endif /* _LIBC */
))
{
unsigned char c = 0;
@@ -406,12 +389,7 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state,
}
}
}
-#endif /* RE_ENABLE_I18N */
- else if (type == OP_PERIOD
-#ifdef RE_ENABLE_I18N
- || type == OP_UTF8_PERIOD
-#endif /* RE_ENABLE_I18N */
- || type == END_OF_RE)
+ else if (type == OP_PERIOD || type == OP_UTF8_PERIOD || type == END_OF_RE)
{
memset (fastmap, '\1', sizeof (char) * SBC_MAX);
if (type == END_OF_RE)
@@ -550,7 +528,6 @@ regerror (int errcode, const regex_t *__restrict preg, char *__restrict errbuf,
weak_alias (__regerror, regerror)
-#ifdef RE_ENABLE_I18N
/* This static array is used for the map to single-byte characters when
UTF-8 is used. Otherwise we would allocate memory just to initialize
it the same all the time. UTF-8 is the preferred encoding so this is
@@ -558,25 +535,24 @@ weak_alias (__regerror, regerror)
static const bitset_t utf8_sb_map =
{
/* Set the first 128 bits. */
-# if (defined __GNUC__ || __clang_major__ >= 4) && !defined __STRICT_ANSI__
+#if (defined __GNUC__ || __clang_major__ >= 4) && !defined __STRICT_ANSI__
[0 ... 0x80 / BITSET_WORD_BITS - 1] = BITSET_WORD_MAX
-# else
-# if 4 * BITSET_WORD_BITS < ASCII_CHARS
-# error "bitset_word_t is narrower than 32 bits"
-# elif 3 * BITSET_WORD_BITS < ASCII_CHARS
+#else
+# if 4 * BITSET_WORD_BITS < ASCII_CHARS
+# error "bitset_word_t is narrower than 32 bits"
+# elif 3 * BITSET_WORD_BITS < ASCII_CHARS
BITSET_WORD_MAX, BITSET_WORD_MAX, BITSET_WORD_MAX,
-# elif 2 * BITSET_WORD_BITS < ASCII_CHARS
+# elif 2 * BITSET_WORD_BITS < ASCII_CHARS
BITSET_WORD_MAX, BITSET_WORD_MAX,
-# elif 1 * BITSET_WORD_BITS < ASCII_CHARS
+# elif 1 * BITSET_WORD_BITS < ASCII_CHARS
BITSET_WORD_MAX,
-# endif
+# endif
(BITSET_WORD_MAX
>> (SBC_MAX % BITSET_WORD_BITS == 0
? 0
: BITSET_WORD_BITS - SBC_MAX % BITSET_WORD_BITS))
-# endif
-};
#endif
+};
static void
@@ -614,10 +590,8 @@ free_dfa_content (re_dfa_t *dfa)
re_free (entry->array);
}
re_free (dfa->state_table);
-#ifdef RE_ENABLE_I18N
if (dfa->sb_char != utf8_sb_map)
re_free (dfa->sb_char);
-#endif
re_free (dfa->subexp_map);
#ifdef DEBUG
re_free (dfa->re_str);
@@ -796,11 +770,9 @@ re_compile_internal (regex_t *preg, const char * pattern, size_t length,
if (__glibc_unlikely (err != REG_NOERROR))
goto re_compile_internal_free_return;
-#ifdef RE_ENABLE_I18N
/* If possible, do searching in single byte encoding to speed things up. */
if (dfa->is_utf8 && !(syntax & RE_ICASE) && preg->translate == NULL)
optimize_utf8 (dfa);
-#endif
/* Then create the initial state of the dfa. */
err = create_initial_state (dfa);
@@ -830,11 +802,7 @@ init_dfa (re_dfa_t *dfa, size_t pat_len)
#ifndef _LIBC
const char *codeset_name;
#endif
-#ifdef RE_ENABLE_I18N
size_t max_i18n_object_size = MAX (sizeof (wchar_t), sizeof (wctype_t));
-#else
- size_t max_i18n_object_size = 0;
-#endif
size_t max_object_size =
MAX (sizeof (struct re_state_table_entry),
MAX (sizeof (re_token_t),
@@ -886,7 +854,6 @@ init_dfa (re_dfa_t *dfa, size_t pat_len)
dfa->map_notascii = 0;
#endif
-#ifdef RE_ENABLE_I18N
if (dfa->mb_cur_max > 1)
{
if (dfa->is_utf8)
@@ -906,14 +873,13 @@ init_dfa (re_dfa_t *dfa, size_t pat_len)
wint_t wch = __btowc (ch);
if (wch != WEOF)
dfa->sb_char[i] |= (bitset_word_t) 1 << j;
-# ifndef _LIBC
+#ifndef _LIBC
if (isascii (ch) && wch != ch)
dfa->map_notascii = 1;
-# endif
+#endif
}
}
}
-#endif
if (__glibc_unlikely (dfa->nodes == NULL || dfa->state_table == NULL))
return REG_ESPACE;
@@ -933,8 +899,6 @@ init_word_char (re_dfa_t *dfa)
dfa->word_ops_used = 1;
if (__glibc_likely (dfa->map_notascii == 0))
{
- /* Avoid uint32_t and uint64_t as some non-GCC platforms lack
- them, an issue when this code is used in Gnulib. */
bitset_word_t bits0 = 0x00000000;
bitset_word_t bits1 = 0x03ff0000;
bitset_word_t bits2 = 0x87fffffe;
@@ -1074,7 +1038,6 @@ create_initial_state (re_dfa_t *dfa)
return REG_NOERROR;
}
-#ifdef RE_ENABLE_I18N
/* If it is possible to do searching in single byte encoding instead of UTF-8
to speed things up, set dfa->mb_cur_max to 1, clear is_utf8 and change
DFA nodes where needed. */
@@ -1154,7 +1117,6 @@ optimize_utf8 (re_dfa_t *dfa)
dfa->is_utf8 = 0;
dfa->has_mb_node = dfa->nbackref > 0 || has_period;
}
-#endif
/* Analyze the structure tree, and calculate "first", "next", "edest",
"eclosure", and "inveclosure". */
@@ -1792,7 +1754,6 @@ peek_token (re_token_t *token, re_string_t *input, reg_syntax_t syntax)
token->opr.c = c;
token->word_char = 0;
-#ifdef RE_ENABLE_I18N
token->mb_partial = 0;
if (input->mb_cur_max > 1
&& !re_string_first_byte (input, re_string_cur_idx (input)))
@@ -1801,7 +1762,6 @@ peek_token (re_token_t *token, re_string_t *input, reg_syntax_t syntax)
token->mb_partial = 1;
return 1;
}
-#endif
if (c == '\\')
{
unsigned char c2;
@@ -1814,7 +1774,6 @@ peek_token (re_token_t *token, re_string_t *input, reg_syntax_t syntax)
c2 = re_string_peek_byte_case (input, 1);
token->opr.c = c2;
token->type = CHARACTER;
-#ifdef RE_ENABLE_I18N
if (input->mb_cur_max > 1)
{
wint_t wc = re_string_wchar_at (input,
@@ -1822,7 +1781,6 @@ peek_token (re_token_t *token, re_string_t *input, reg_syntax_t syntax)
token->word_char = IS_WIDE_WORD_CHAR (wc) != 0;
}
else
-#endif
token->word_char = IS_WORD_CHAR (c2) != 0;
switch (c2)
@@ -1928,14 +1886,12 @@ peek_token (re_token_t *token, re_string_t *input, reg_syntax_t syntax)
}
token->type = CHARACTER;
-#ifdef RE_ENABLE_I18N
if (input->mb_cur_max > 1)
{
wint_t wc = re_string_wchar_at (input, re_string_cur_idx (input));
token->word_char = IS_WIDE_WORD_CHAR (wc) != 0;
}
else
-#endif
token->word_char = IS_WORD_CHAR (token->opr.c);
switch (c)
@@ -2027,14 +1983,12 @@ peek_token_bracket (re_token_t *token, re_string_t *input, reg_syntax_t syntax)
c = re_string_peek_byte (input, 0);
token->opr.c = c;
-#ifdef RE_ENABLE_I18N
if (input->mb_cur_max > 1
&& !re_string_first_byte (input, re_string_cur_idx (input)))
{
token->type = CHARACTER;
return 1;
}
-#endif /* RE_ENABLE_I18N */
if (c == '\\' && (syntax & RE_BACKSLASH_ESCAPE_IN_LISTS)
&& re_string_cur_idx (input) + 1 < re_string_length (input))
@@ -2256,7 +2210,6 @@ parse_expression (re_string_t *regexp, regex_t *preg, re_token_t *token,
*err = REG_ESPACE;
return NULL;
}
-#ifdef RE_ENABLE_I18N
if (dfa->mb_cur_max > 1)
{
while (!re_string_eoi (regexp)
@@ -2273,7 +2226,6 @@ parse_expression (re_string_t *regexp, regex_t *preg, re_token_t *token,
}
}
}
-#endif
break;
case OP_OPEN_SUBEXP:
@@ -2666,40 +2618,30 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa,
#ifndef _LIBC
-# ifdef RE_ENABLE_I18N
/* Convert the byte B to the corresponding wide character. In a
unibyte locale, treat B as itself. In a multibyte locale, return
WEOF if B is an encoding error. */
static wint_t
-parse_byte (unsigned char b, re_charset_t *mbcset)
+parse_byte (unsigned char b, re_dfa_t const *dfa)
{
- return mbcset == NULL ? b : __btowc (b);
+ return dfa->mb_cur_max > 1 ? __btowc (b) : b;
}
-# endif
- /* Local function for parse_bracket_exp only used in case of NOT _LIBC.
- Build the range expression which starts from START_ELEM, and ends
- at END_ELEM. The result are written to MBCSET and SBCSET.
- RANGE_ALLOC is the allocated size of mbcset->range_starts, and
- mbcset->range_ends, is a pointer argument since we may
- update it. */
+/* Local function for parse_bracket_exp used in _LIBC environment.
+ Build the range expression which starts from START_ELEM, and ends
+ at END_ELEM. The result are written to MBCSET and SBCSET.
+ RANGE_ALLOC is the allocated size of mbcset->range_starts, and
+ mbcset->range_ends, is a pointer argument since we may
+ update it. */
static reg_errcode_t
-# ifdef RE_ENABLE_I18N
-build_range_exp (const reg_syntax_t syntax,
- bitset_t sbcset,
- re_charset_t *mbcset,
- Idx *range_alloc,
- const bracket_elem_t *start_elem,
- const bracket_elem_t *end_elem)
-# else /* not RE_ENABLE_I18N */
-build_range_exp (const reg_syntax_t syntax,
- bitset_t sbcset,
- const bracket_elem_t *start_elem,
- const bracket_elem_t *end_elem)
-# endif /* not RE_ENABLE_I18N */
+build_range_exp (bitset_t sbcset, re_charset_t *mbcset, Idx *range_alloc,
+ bracket_elem_t *start_elem, bracket_elem_t *end_elem,
+ re_dfa_t *dfa, reg_syntax_t syntax, uint_fast32_t nrules,
+ const unsigned char *collseqmb, const char *collseqwc,
+ int_fast32_t table_size, const void *symb_table,
+ const unsigned char *extra)
{
- unsigned int start_ch, end_ch;
/* Equivalence Classes and Character Classes can't be a range start/end. */
if (__glibc_unlikely (start_elem->type == EQUIV_CLASS
|| start_elem->type == CHAR_CLASS
@@ -2715,110 +2657,88 @@ build_range_exp (const reg_syntax_t syntax,
&& strlen ((char *) end_elem->opr.name) > 1)))
return REG_ECOLLATE;
-# ifdef RE_ENABLE_I18N
- {
- wchar_t wc;
- wint_t start_wc;
- wint_t end_wc;
-
+ unsigned int
start_ch = ((start_elem->type == SB_CHAR) ? start_elem->opr.ch
: ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0]
- : 0));
+ : 0)),
end_ch = ((end_elem->type == SB_CHAR) ? end_elem->opr.ch
: ((end_elem->type == COLL_SYM) ? end_elem->opr.name[0]
: 0));
+ wint_t
start_wc = ((start_elem->type == SB_CHAR || start_elem->type == COLL_SYM)
- ? parse_byte (start_ch, mbcset) : start_elem->opr.wch);
+ ? parse_byte (start_ch, dfa) : start_elem->opr.wch),
end_wc = ((end_elem->type == SB_CHAR || end_elem->type == COLL_SYM)
- ? parse_byte (end_ch, mbcset) : end_elem->opr.wch);
- if (start_wc == WEOF || end_wc == WEOF)
- return REG_ECOLLATE;
- else if (__glibc_unlikely ((syntax & RE_NO_EMPTY_RANGES)
- && start_wc > end_wc))
- return REG_ERANGE;
-
- /* Got valid collation sequence values, add them as a new entry.
- However, for !_LIBC we have no collation elements: if the
- character set is single byte, the single byte character set
- that we build below suffices. parse_bracket_exp passes
- no MBCSET if dfa->mb_cur_max == 1. */
- if (mbcset)
- {
- /* Check the space of the arrays. */
- if (__glibc_unlikely (*range_alloc == mbcset->nranges))
- {
- /* There is not enough space, need realloc. */
- wchar_t *new_array_start, *new_array_end;
- Idx new_nranges;
-
- /* +1 in case of mbcset->nranges is 0. */
- new_nranges = 2 * mbcset->nranges + 1;
- /* Use realloc since mbcset->range_starts and mbcset->range_ends
- are NULL if *range_alloc == 0. */
- new_array_start = re_realloc (mbcset->range_starts, wchar_t,
- new_nranges);
- new_array_end = re_realloc (mbcset->range_ends, wchar_t,
- new_nranges);
+ ? parse_byte (end_ch, dfa) : end_elem->opr.wch);
- if (__glibc_unlikely (new_array_start == NULL
- || new_array_end == NULL))
- {
- re_free (new_array_start);
- re_free (new_array_end);
- return REG_ESPACE;
- }
+ if (start_wc == WEOF || end_wc == WEOF)
+ return REG_ECOLLATE;
+ else if (__glibc_unlikely ((syntax & RE_NO_EMPTY_RANGES)
+ && start_wc > end_wc))
+ return REG_ERANGE;
- mbcset->range_starts = new_array_start;
- mbcset->range_ends = new_array_end;
- *range_alloc = new_nranges;
- }
+ /* Got valid collation sequence values, add them as a new entry.
+ However, for !_LIBC we have no collation elements: if the
+ character set is single byte, the single byte character set
+ that we build below suffices. parse_bracket_exp passes
+ no MBCSET if dfa->mb_cur_max == 1. */
+ if (dfa->mb_cur_max > 1)
+ {
+ /* Check the space of the arrays. */
+ if (__glibc_unlikely (*range_alloc == mbcset->nranges))
+ {
+ /* There is not enough space, need realloc. */
+ wchar_t *new_array_start, *new_array_end;
+ Idx new_nranges;
- mbcset->range_starts[mbcset->nranges] = start_wc;
- mbcset->range_ends[mbcset->nranges++] = end_wc;
- }
+ /* +1 in case of mbcset->nranges is 0. */
+ new_nranges = 2 * mbcset->nranges + 1;
+ /* Use realloc since mbcset->range_starts and mbcset->range_ends
+ are NULL if *range_alloc == 0. */
+ new_array_start = re_realloc (mbcset->range_starts, wchar_t,
+ new_nranges);
+ new_array_end = re_realloc (mbcset->range_ends, wchar_t,
+ new_nranges);
+
+ if (__glibc_unlikely (new_array_start == NULL
+ || new_array_end == NULL))
+ {
+ re_free (new_array_start);
+ re_free (new_array_end);
+ return REG_ESPACE;
+ }
+
+ mbcset->range_starts = new_array_start;
+ mbcset->range_ends = new_array_end;
+ *range_alloc = new_nranges;
+ }
+
+ mbcset->range_starts[mbcset->nranges] = start_wc;
+ mbcset->range_ends[mbcset->nranges++] = end_wc;
+ }
+
+ /* Build the table for single byte characters. */
+ for (wchar_t wc = 0; wc < SBC_MAX; ++wc)
+ {
+ if (start_wc <= wc && wc <= end_wc)
+ bitset_set (sbcset, wc);
+ }
- /* Build the table for single byte characters. */
- for (wc = 0; wc < SBC_MAX; ++wc)
- {
- if (start_wc <= wc && wc <= end_wc)
- bitset_set (sbcset, wc);
- }
- }
-# else /* not RE_ENABLE_I18N */
- {
- unsigned int ch;
- start_ch = ((start_elem->type == SB_CHAR ) ? start_elem->opr.ch
- : ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0]
- : 0));
- end_ch = ((end_elem->type == SB_CHAR ) ? end_elem->opr.ch
- : ((end_elem->type == COLL_SYM) ? end_elem->opr.name[0]
- : 0));
- if (start_ch > end_ch)
- return REG_ERANGE;
- /* Build the table for single byte characters. */
- for (ch = 0; ch < SBC_MAX; ++ch)
- if (start_ch <= ch && ch <= end_ch)
- bitset_set (sbcset, ch);
- }
-# endif /* not RE_ENABLE_I18N */
return REG_NOERROR;
}
#endif /* not _LIBC */
#ifndef _LIBC
-/* Helper function for parse_bracket_exp only used in case of NOT _LIBC..
+/* Helper function for parse_bracket_exp only used in case of NOT _LIBC.
Build the collating element which is represented by NAME.
The result are written to MBCSET and SBCSET.
COLL_SYM_ALLOC is the allocated size of mbcset->coll_sym, is a
pointer argument since we may update it. */
static reg_errcode_t
-# ifdef RE_ENABLE_I18N
build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset,
- Idx *coll_sym_alloc, const unsigned char *name)
-# else /* not RE_ENABLE_I18N */
-build_collating_symbol (bitset_t sbcset, const unsigned char *name)
-# endif /* not RE_ENABLE_I18N */
+ Idx *coll_sym_alloc, const unsigned char *name,
+ uint_fast32_t nrules, int_fast32_t table_size,
+ const void *symb_table, const unsigned char *extra)
{
size_t name_len = strlen ((const char *) name);
if (__glibc_unlikely (name_len != 1))
@@ -2831,271 +2751,280 @@ build_collating_symbol (bitset_t sbcset, const unsigned char *name)
}
#endif /* not _LIBC */
-/* This function parse bracket expression like "[abc]", "[a-c]",
- "[[.a-a.]]" etc. */
-
-static bin_tree_t *
-parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token,
- reg_syntax_t syntax, reg_errcode_t *err)
-{
#ifdef _LIBC
- const unsigned char *collseqmb;
- const char *collseqwc;
- uint32_t nrules;
- int32_t table_size;
- const int32_t *symb_table;
- const unsigned char *extra;
-
- /* Local function for parse_bracket_exp used in _LIBC environment.
- Seek the collating symbol entry corresponding to NAME.
- Return the index of the symbol in the SYMB_TABLE,
- or -1 if not found. */
-
- auto inline int32_t
- __attribute__ ((always_inline))
- seek_collating_symbol_entry (const unsigned char *name, size_t name_len)
- {
- int32_t elem;
-
- for (elem = 0; elem < table_size; elem++)
- if (symb_table[2 * elem] != 0)
- {
- int32_t idx = symb_table[2 * elem + 1];
- /* Skip the name of collating element name. */
- idx += 1 + extra[idx];
- if (/* Compare the length of the name. */
- name_len == extra[idx]
- /* Compare the name. */
- && memcmp (name, &extra[idx + 1], name_len) == 0)
- /* Yep, this is the entry. */
- return elem;
- }
- return -1;
- }
+/* Local function for parse_bracket_exp used in _LIBC environment.
+ Seek the collating symbol entry corresponding to NAME.
+ Return the index of the symbol in the SYMB_TABLE,
+ or -1 if not found. */
+
+static __always_inline int32_t
+seek_collating_symbol_entry (const unsigned char *name, size_t name_len,
+ const int32_t *symb_table,
+ int_fast32_t table_size,
+ const unsigned char *extra)
+{
+ int_fast32_t elem;
- /* Local function for parse_bracket_exp used in _LIBC environment.
- Look up the collation sequence value of BR_ELEM.
- Return the value if succeeded, UINT_MAX otherwise. */
+ for (elem = 0; elem < table_size; elem++)
+ if (symb_table[2 * elem] != 0)
+ {
+ int32_t idx = symb_table[2 * elem + 1];
+ /* Skip the name of collating element name. */
+ idx += 1 + extra[idx];
+ if (/* Compare the length of the name. */
+ name_len == extra[idx]
+ /* Compare the name. */
+ && memcmp (name, &extra[idx + 1], name_len) == 0)
+ /* Yep, this is the entry. */
+ return elem;
+ }
+ return -1;
+}
- auto inline unsigned int
- __attribute__ ((always_inline))
- lookup_collation_sequence_value (bracket_elem_t *br_elem)
+/* Local function for parse_bracket_exp used in _LIBC environment.
+ Look up the collation sequence value of BR_ELEM.
+ Return the value if succeeded, UINT_MAX otherwise. */
+
+static __always_inline unsigned int
+lookup_collation_sequence_value (bracket_elem_t *br_elem, uint32_t nrules,
+ const unsigned char *collseqmb,
+ const char *collseqwc,
+ int_fast32_t table_size,
+ const int32_t *symb_table,
+ const unsigned char *extra)
+{
+ if (br_elem->type == SB_CHAR)
{
- if (br_elem->type == SB_CHAR)
- {
- /*
- if (MB_CUR_MAX == 1)
- */
- if (nrules == 0)
- return collseqmb[br_elem->opr.ch];
- else
- {
- wint_t wc = __btowc (br_elem->opr.ch);
- return __collseq_table_lookup (collseqwc, wc);
- }
- }
- else if (br_elem->type == MB_CHAR)
+ /* if (MB_CUR_MAX == 1) */
+ if (nrules == 0)
+ return collseqmb[br_elem->opr.ch];
+ else
{
- if (nrules != 0)
- return __collseq_table_lookup (collseqwc, br_elem->opr.wch);
+ wint_t wc = __btowc (br_elem->opr.ch);
+ return __collseq_table_lookup (collseqwc, wc);
}
- else if (br_elem->type == COLL_SYM)
+ }
+ else if (br_elem->type == MB_CHAR)
+ {
+ if (nrules != 0)
+ return __collseq_table_lookup (collseqwc, br_elem->opr.wch);
+ }
+ else if (br_elem->type == COLL_SYM)
+ {
+ size_t sym_name_len = strlen ((char *) br_elem->opr.name);
+ if (nrules != 0)
{
- size_t sym_name_len = strlen ((char *) br_elem->opr.name);
- if (nrules != 0)
+ int32_t elem, idx;
+ elem = seek_collating_symbol_entry (br_elem->opr.name,
+ sym_name_len,
+ symb_table, table_size,
+ extra);
+ if (elem != -1)
{
- int32_t elem, idx;
- elem = seek_collating_symbol_entry (br_elem->opr.name,
- sym_name_len);
- if (elem != -1)
- {
- /* We found the entry. */
- idx = symb_table[2 * elem + 1];
- /* Skip the name of collating element name. */
- idx += 1 + extra[idx];
- /* Skip the byte sequence of the collating element. */
- idx += 1 + extra[idx];
- /* Adjust for the alignment. */
- idx = (idx + 3) & ~3;
- /* Skip the multibyte collation sequence value. */
- idx += sizeof (unsigned int);
- /* Skip the wide char sequence of the collating element. */
- idx += sizeof (unsigned int) *
- (1 + *(unsigned int *) (extra + idx));
- /* Return the collation sequence value. */
- return *(unsigned int *) (extra + idx);
- }
- else if (sym_name_len == 1)
- {
- /* No valid character. Match it as a single byte
- character. */
- return collseqmb[br_elem->opr.name[0]];
- }
+ /* We found the entry. */
+ idx = symb_table[2 * elem + 1];
+ /* Skip the name of collating element name. */
+ idx += 1 + extra[idx];
+ /* Skip the byte sequence of the collating element. */
+ idx += 1 + extra[idx];
+ /* Adjust for the alignment. */
+ idx = (idx + 3) & ~3;
+ /* Skip the multibyte collation sequence value. */
+ idx += sizeof (unsigned int);
+ /* Skip the wide char sequence of the collating element. */
+ idx += sizeof (unsigned int) *
+ (1 + *(unsigned int *) (extra + idx));
+ /* Return the collation sequence value. */
+ return *(unsigned int *) (extra + idx);
}
else if (sym_name_len == 1)
- return collseqmb[br_elem->opr.name[0]];
+ {
+ /* No valid character. Match it as a single byte
+ character. */
+ return collseqmb[br_elem->opr.name[0]];
+ }
}
- return UINT_MAX;
+ else if (sym_name_len == 1)
+ return collseqmb[br_elem->opr.name[0]];
}
+ return UINT_MAX;
+}
- /* Local function for parse_bracket_exp used in _LIBC environment.
- Build the range expression which starts from START_ELEM, and ends
- at END_ELEM. The result are written to MBCSET and SBCSET.
- RANGE_ALLOC is the allocated size of mbcset->range_starts, and
- mbcset->range_ends, is a pointer argument since we may
- update it. */
+/* Local function for parse_bracket_exp used in _LIBC environment.
+ Build the range expression which starts from START_ELEM, and ends
+ at END_ELEM. The result are written to MBCSET and SBCSET.
+ RANGE_ALLOC is the allocated size of mbcset->range_starts, and
+ mbcset->range_ends, is a pointer argument since we may
+ update it. */
+
+static __always_inline reg_errcode_t
+build_range_exp (bitset_t sbcset, re_charset_t *mbcset, Idx *range_alloc,
+ bracket_elem_t *start_elem, bracket_elem_t *end_elem,
+ re_dfa_t *dfa, reg_syntax_t syntax, uint32_t nrules,
+ const unsigned char *collseqmb, const char *collseqwc,
+ int_fast32_t table_size, const int32_t *symb_table,
+ const unsigned char *extra)
+{
+ unsigned int ch;
+ uint32_t start_collseq;
+ uint32_t end_collseq;
- auto inline reg_errcode_t
- __attribute__ ((always_inline))
- build_range_exp (bitset_t sbcset, re_charset_t *mbcset, int *range_alloc,
- bracket_elem_t *start_elem, bracket_elem_t *end_elem)
- {
- unsigned int ch;
- uint32_t start_collseq;
- uint32_t end_collseq;
-
- /* Equivalence Classes and Character Classes can't be a range
- start/end. */
- if (__glibc_unlikely (start_elem->type == EQUIV_CLASS
- || start_elem->type == CHAR_CLASS
- || end_elem->type == EQUIV_CLASS
- || end_elem->type == CHAR_CLASS))
- return REG_ERANGE;
+ /* Equivalence Classes and Character Classes can't be a range
+ start/end. */
+ if (__glibc_unlikely (start_elem->type == EQUIV_CLASS
+ || start_elem->type == CHAR_CLASS
+ || end_elem->type == EQUIV_CLASS
+ || end_elem->type == CHAR_CLASS))
+ return REG_ERANGE;
- /* FIXME: Implement rational ranges here, too. */
- start_collseq = lookup_collation_sequence_value (start_elem);
- end_collseq = lookup_collation_sequence_value (end_elem);
- /* Check start/end collation sequence values. */
- if (__glibc_unlikely (start_collseq == UINT_MAX
- || end_collseq == UINT_MAX))
- return REG_ECOLLATE;
- if (__glibc_unlikely ((syntax & RE_NO_EMPTY_RANGES)
- && start_collseq > end_collseq))
- return REG_ERANGE;
+ /* FIXME: Implement rational ranges here, too. */
+ start_collseq = lookup_collation_sequence_value (start_elem, nrules, collseqmb, collseqwc,
+ table_size, symb_table, extra);
+ end_collseq = lookup_collation_sequence_value (end_elem, nrules, collseqmb, collseqwc,
+ table_size, symb_table, extra);
+ /* Check start/end collation sequence values. */
+ if (__glibc_unlikely (start_collseq == UINT_MAX
+ || end_collseq == UINT_MAX))
+ return REG_ECOLLATE;
+ if (__glibc_unlikely ((syntax & RE_NO_EMPTY_RANGES)
+ && start_collseq > end_collseq))
+ return REG_ERANGE;
- /* Got valid collation sequence values, add them as a new entry.
- However, if we have no collation elements, and the character set
- is single byte, the single byte character set that we
- build below suffices. */
- if (nrules > 0 || dfa->mb_cur_max > 1)
+ /* Got valid collation sequence values, add them as a new entry.
+ However, if we have no collation elements, and the character set
+ is single byte, the single byte character set that we
+ build below suffices. */
+ if (nrules > 0 || dfa->mb_cur_max > 1)
+ {
+ /* Check the space of the arrays. */
+ if (__glibc_unlikely (*range_alloc == mbcset->nranges))
{
- /* Check the space of the arrays. */
- if (__glibc_unlikely (*range_alloc == mbcset->nranges))
- {
- /* There is not enough space, need realloc. */
- uint32_t *new_array_start;
- uint32_t *new_array_end;
- Idx new_nranges;
-
- /* +1 in case of mbcset->nranges is 0. */
- new_nranges = 2 * mbcset->nranges + 1;
- new_array_start = re_realloc (mbcset->range_starts, uint32_t,
- new_nranges);
- new_array_end = re_realloc (mbcset->range_ends, uint32_t,
- new_nranges);
-
- if (__glibc_unlikely (new_array_start == NULL
- || new_array_end == NULL))
- return REG_ESPACE;
+ /* There is not enough space, need realloc. */
+ uint32_t *new_array_start;
+ uint32_t *new_array_end;
+ int new_nranges;
- mbcset->range_starts = new_array_start;
- mbcset->range_ends = new_array_end;
- *range_alloc = new_nranges;
- }
+ /* +1 in case of mbcset->nranges is 0. */
+ new_nranges = 2 * mbcset->nranges + 1;
+ new_array_start = re_realloc (mbcset->range_starts, uint32_t,
+ new_nranges);
+ new_array_end = re_realloc (mbcset->range_ends, uint32_t,
+ new_nranges);
- mbcset->range_starts[mbcset->nranges] = start_collseq;
- mbcset->range_ends[mbcset->nranges++] = end_collseq;
- }
+ if (__glibc_unlikely (new_array_start == NULL
+ || new_array_end == NULL))
+ return REG_ESPACE;
- /* Build the table for single byte characters. */
- for (ch = 0; ch < SBC_MAX; ch++)
- {
- uint32_t ch_collseq;
- /*
- if (MB_CUR_MAX == 1)
- */
- if (nrules == 0)
- ch_collseq = collseqmb[ch];
- else
- ch_collseq = __collseq_table_lookup (collseqwc, __btowc (ch));
- if (start_collseq <= ch_collseq && ch_collseq <= end_collseq)
- bitset_set (sbcset, ch);
+ mbcset->range_starts = new_array_start;
+ mbcset->range_ends = new_array_end;
+ *range_alloc = new_nranges;
}
- return REG_NOERROR;
+
+ mbcset->range_starts[mbcset->nranges] = start_collseq;
+ mbcset->range_ends[mbcset->nranges++] = end_collseq;
}
- /* Local function for parse_bracket_exp used in _LIBC environment.
- Build the collating element which is represented by NAME.
- The result are written to MBCSET and SBCSET.
- COLL_SYM_ALLOC is the allocated size of mbcset->coll_sym, is a
- pointer argument since we may update it. */
+ /* Build the table for single byte characters. */
+ for (ch = 0; ch < SBC_MAX; ch++)
+ {
+ uint32_t ch_collseq;
+ /* if (MB_CUR_MAX == 1) */
+ if (nrules == 0)
+ ch_collseq = collseqmb[ch];
+ else
+ ch_collseq = __collseq_table_lookup (collseqwc, __btowc (ch));
+ if (start_collseq <= ch_collseq && ch_collseq <= end_collseq)
+ bitset_set (sbcset, ch);
+ }
+ return REG_NOERROR;
+}
- auto inline reg_errcode_t
- __attribute__ ((always_inline))
- build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset,
- Idx *coll_sym_alloc, const unsigned char *name)
+/* Local function for parse_bracket_exp used in _LIBC environment.
+ Build the collating element which is represented by NAME.
+ The result are written to MBCSET and SBCSET.
+ COLL_SYM_ALLOC is the allocated size of mbcset->coll_sym, is a
+ pointer argument since we may update it. */
+
+static __always_inline reg_errcode_t
+build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset,
+ Idx *coll_sym_alloc, const unsigned char *name,
+ uint_fast32_t nrules, int_fast32_t table_size,
+ const int32_t *symb_table, const unsigned char *extra)
+{
+ int32_t elem, idx;
+ size_t name_len = strlen ((const char *) name);
+ if (nrules != 0)
{
- int32_t elem, idx;
- size_t name_len = strlen ((const char *) name);
- if (nrules != 0)
+ elem = seek_collating_symbol_entry (name, name_len, symb_table,
+ table_size, extra);
+ if (elem != -1)
{
- elem = seek_collating_symbol_entry (name, name_len);
- if (elem != -1)
- {
- /* We found the entry. */
- idx = symb_table[2 * elem + 1];
- /* Skip the name of collating element name. */
- idx += 1 + extra[idx];
- }
- else if (name_len == 1)
- {
- /* No valid character, treat it as a normal
- character. */
- bitset_set (sbcset, name[0]);
- return REG_NOERROR;
- }
- else
- return REG_ECOLLATE;
-
- /* Got valid collation sequence, add it as a new entry. */
- /* Check the space of the arrays. */
- if (__glibc_unlikely (*coll_sym_alloc == mbcset->ncoll_syms))
- {
- /* Not enough, realloc it. */
- /* +1 in case of mbcset->ncoll_syms is 0. */
- Idx new_coll_sym_alloc = 2 * mbcset->ncoll_syms + 1;
- /* Use realloc since mbcset->coll_syms is NULL
- if *alloc == 0. */
- int32_t *new_coll_syms = re_realloc (mbcset->coll_syms, int32_t,
- new_coll_sym_alloc);
- if (__glibc_unlikely (new_coll_syms == NULL))
- return REG_ESPACE;
- mbcset->coll_syms = new_coll_syms;
- *coll_sym_alloc = new_coll_sym_alloc;
- }
- mbcset->coll_syms[mbcset->ncoll_syms++] = idx;
+ /* We found the entry. */
+ idx = symb_table[2 * elem + 1];
+ /* Skip the name of collating element name. */
+ idx += 1 + extra[idx];
+ }
+ else if (name_len == 1)
+ {
+ /* No valid character, treat it as a normal
+ character. */
+ bitset_set (sbcset, name[0]);
return REG_NOERROR;
}
else
+ return REG_ECOLLATE;
+
+ /* Got valid collation sequence, add it as a new entry. */
+ /* Check the space of the arrays. */
+ if (__glibc_unlikely (*coll_sym_alloc == mbcset->ncoll_syms))
{
- if (__glibc_unlikely (name_len != 1))
- return REG_ECOLLATE;
- else
- {
- bitset_set (sbcset, name[0]);
- return REG_NOERROR;
- }
+ /* Not enough, realloc it. */
+ /* +1 in case of mbcset->ncoll_syms is 0. */
+ int new_coll_sym_alloc = 2 * mbcset->ncoll_syms + 1;
+ /* Use realloc since mbcset->coll_syms is NULL
+ if *alloc == 0. */
+ int32_t *new_coll_syms = re_realloc (mbcset->coll_syms, int32_t,
+ new_coll_sym_alloc);
+ if (__glibc_unlikely (new_coll_syms == NULL))
+ return REG_ESPACE;
+ mbcset->coll_syms = new_coll_syms;
+ *coll_sym_alloc = new_coll_sym_alloc;
}
+ mbcset->coll_syms[mbcset->ncoll_syms++] = idx;
+ return REG_NOERROR;
}
-#endif
+ else
+ {
+ if (__glibc_unlikely (name_len != 1))
+ return REG_ECOLLATE;
+ else
+ {
+ bitset_set (sbcset, name[0]);
+ return REG_NOERROR;
+ }
+ }
+}
+#endif /* _LIBC */
+
+/* This function parse bracket expression like "[abc]", "[a-c]",
+ "[[.a-a.]]" etc. */
+
+static bin_tree_t *
+parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token,
+ reg_syntax_t syntax, reg_errcode_t *err)
+{
+ const unsigned char *collseqmb = NULL;
+ const char *collseqwc = NULL;
+ uint_fast32_t nrules = 0;
+ int_fast32_t table_size = 0;
+ const void *symb_table = NULL;
+ const unsigned char *extra = NULL;
re_token_t br_token;
re_bitset_ptr_t sbcset;
-#ifdef RE_ENABLE_I18N
re_charset_t *mbcset;
Idx coll_sym_alloc = 0, range_alloc = 0, mbchar_alloc = 0;
Idx equiv_class_alloc = 0, char_class_alloc = 0;
-#endif /* not RE_ENABLE_I18N */
bool non_match = false;
bin_tree_t *work_tree;
int token_len;
@@ -3111,26 +3040,17 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token,
*/
collseqwc = _NL_CURRENT (LC_COLLATE, _NL_COLLATE_COLLSEQWC);
table_size = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_SYMB_HASH_SIZEMB);
- symb_table = (const int32_t *) _NL_CURRENT (LC_COLLATE,
- _NL_COLLATE_SYMB_TABLEMB);
+ symb_table = _NL_CURRENT (LC_COLLATE, _NL_COLLATE_SYMB_TABLEMB);
extra = (const unsigned char *) _NL_CURRENT (LC_COLLATE,
_NL_COLLATE_SYMB_EXTRAMB);
}
#endif
sbcset = (re_bitset_ptr_t) calloc (sizeof (bitset_t), 1);
-#ifdef RE_ENABLE_I18N
mbcset = (re_charset_t *) calloc (sizeof (re_charset_t), 1);
-#endif /* RE_ENABLE_I18N */
-#ifdef RE_ENABLE_I18N
if (__glibc_unlikely (sbcset == NULL || mbcset == NULL))
-#else
- if (__glibc_unlikely (sbcset == NULL))
-#endif /* RE_ENABLE_I18N */
{
re_free (sbcset);
-#ifdef RE_ENABLE_I18N
re_free (mbcset);
-#endif
*err = REG_ESPACE;
return NULL;
}
@@ -3143,9 +3063,7 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token,
}
if (token->type == OP_NON_MATCH_LIST)
{
-#ifdef RE_ENABLE_I18N
mbcset->non_match = 1;
-#endif /* not RE_ENABLE_I18N */
non_match = true;
if (syntax & RE_HAT_LISTS_NOT_NEWLINE)
bitset_set (sbcset, '\n');
@@ -3228,18 +3146,10 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token,
token_len = peek_token_bracket (token, regexp, syntax);
-#ifdef _LIBC
*err = build_range_exp (sbcset, mbcset, &range_alloc,
- &start_elem, &end_elem);
-#else
-# ifdef RE_ENABLE_I18N
- *err = build_range_exp (syntax, sbcset,
- dfa->mb_cur_max > 1 ? mbcset : NULL,
- &range_alloc, &start_elem, &end_elem);
-# else
- *err = build_range_exp (syntax, sbcset, &start_elem, &end_elem);
-# endif
-#endif /* RE_ENABLE_I18N */
+ &start_elem, &end_elem,
+ dfa, syntax, nrules, collseqmb, collseqwc,
+ table_size, symb_table, extra);
if (__glibc_unlikely (*err != REG_NOERROR))
goto parse_bracket_exp_free_return;
}
@@ -3250,7 +3160,6 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token,
case SB_CHAR:
bitset_set (sbcset, start_elem.opr.ch);
break;
-#ifdef RE_ENABLE_I18N
case MB_CHAR:
/* Check whether the array has enough space. */
if (__glibc_unlikely (mbchar_alloc == mbcset->nmbchars))
@@ -3268,30 +3177,24 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token,
}
mbcset->mbchars[mbcset->nmbchars++] = start_elem.opr.wch;
break;
-#endif /* RE_ENABLE_I18N */
case EQUIV_CLASS:
*err = build_equiv_class (sbcset,
-#ifdef RE_ENABLE_I18N
mbcset, &equiv_class_alloc,
-#endif /* RE_ENABLE_I18N */
start_elem.opr.name);
if (__glibc_unlikely (*err != REG_NOERROR))
goto parse_bracket_exp_free_return;
break;
case COLL_SYM:
*err = build_collating_symbol (sbcset,
-#ifdef RE_ENABLE_I18N
mbcset, &coll_sym_alloc,
-#endif /* RE_ENABLE_I18N */
- start_elem.opr.name);
+ start_elem.opr.name,
+ nrules, table_size, symb_table, extra);
if (__glibc_unlikely (*err != REG_NOERROR))
goto parse_bracket_exp_free_return;
break;
case CHAR_CLASS:
*err = build_charclass (regexp->trans, sbcset,
-#ifdef RE_ENABLE_I18N
mbcset, &char_class_alloc,
-#endif /* RE_ENABLE_I18N */
(const char *) start_elem.opr.name,
syntax);
if (__glibc_unlikely (*err != REG_NOERROR))
@@ -3317,7 +3220,6 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token,
if (non_match)
bitset_not (sbcset);
-#ifdef RE_ENABLE_I18N
/* Ensure only single byte characters are set. */
if (dfa->mb_cur_max > 1)
bitset_mask (sbcset, dfa->sb_char);
@@ -3361,11 +3263,8 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token,
}
}
else
-#endif /* not RE_ENABLE_I18N */
{
-#ifdef RE_ENABLE_I18N
free_charset (mbcset);
-#endif
/* Build a tree for simple bracket. */
br_token.type = SIMPLE_BRACKET;
br_token.opr.sbcset = sbcset;
@@ -3379,9 +3278,7 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token,
*err = REG_ESPACE;
parse_bracket_exp_free_return:
re_free (sbcset);
-#ifdef RE_ENABLE_I18N
free_charset (mbcset);
-#endif /* RE_ENABLE_I18N */
return NULL;
}
@@ -3392,7 +3289,6 @@ parse_bracket_element (bracket_elem_t *elem, re_string_t *regexp,
re_token_t *token, int token_len, re_dfa_t *dfa,
reg_syntax_t syntax, bool accept_hyphen)
{
-#ifdef RE_ENABLE_I18N
int cur_char_size;
cur_char_size = re_string_char_size_at (regexp, re_string_cur_idx (regexp));
if (cur_char_size > 1)
@@ -3402,7 +3298,6 @@ parse_bracket_element (bracket_elem_t *elem, re_string_t *regexp,
re_string_skip_bytes (regexp, cur_char_size);
return REG_NOERROR;
}
-#endif /* RE_ENABLE_I18N */
re_string_skip_bytes (regexp, token_len); /* Skip a token. */
if (token->type == OP_OPEN_COLL_ELEM || token->type == OP_OPEN_CHAR_CLASS
|| token->type == OP_OPEN_EQUIV_CLASS)
@@ -3475,12 +3370,8 @@ parse_bracket_symbol (bracket_elem_t *elem, re_string_t *regexp,
is a pointer argument since we may update it. */
static reg_errcode_t
-#ifdef RE_ENABLE_I18N
build_equiv_class (bitset_t sbcset, re_charset_t *mbcset,
Idx *equiv_class_alloc, const unsigned char *name)
-#else /* not RE_ENABLE_I18N */
-build_equiv_class (bitset_t sbcset, const unsigned char *name)
-#endif /* not RE_ENABLE_I18N */
{
#ifdef _LIBC
uint32_t nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES);
@@ -3560,14 +3451,9 @@ build_equiv_class (bitset_t sbcset, const unsigned char *name)
is a pointer argument since we may update it. */
static reg_errcode_t
-#ifdef RE_ENABLE_I18N
build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset,
re_charset_t *mbcset, Idx *char_class_alloc,
const char *class_name, reg_syntax_t syntax)
-#else /* not RE_ENABLE_I18N */
-build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset,
- const char *class_name, reg_syntax_t syntax)
-#endif /* not RE_ENABLE_I18N */
{
int i;
const char *name = class_name;
@@ -3578,7 +3464,6 @@ build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset,
&& (strcmp (name, "upper") == 0 || strcmp (name, "lower") == 0))
name = "alpha";
-#ifdef RE_ENABLE_I18N
/* Check the space of the arrays. */
if (__glibc_unlikely (*char_class_alloc == mbcset->nchar_classes))
{
@@ -3594,7 +3479,6 @@ build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset,
*char_class_alloc = new_char_class_alloc;
}
mbcset->char_classes[mbcset->nchar_classes++] = __wctype (name);
-#endif /* RE_ENABLE_I18N */
#define BUILD_CHARCLASS_LOOP(ctype_func) \
do { \
@@ -3649,10 +3533,8 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans,
reg_errcode_t *err)
{
re_bitset_ptr_t sbcset;
-#ifdef RE_ENABLE_I18N
re_charset_t *mbcset;
Idx alloc = 0;
-#endif /* not RE_ENABLE_I18N */
reg_errcode_t ret;
bin_tree_t *tree;
@@ -3662,7 +3544,6 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans,
*err = REG_ESPACE;
return NULL;
}
-#ifdef RE_ENABLE_I18N
mbcset = (re_charset_t *) calloc (sizeof (re_charset_t), 1);
if (__glibc_unlikely (mbcset == NULL))
{
@@ -3671,21 +3552,14 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans,
return NULL;
}
mbcset->non_match = non_match;
-#endif /* RE_ENABLE_I18N */
/* We don't care the syntax in this case. */
- ret = build_charclass (trans, sbcset,
-#ifdef RE_ENABLE_I18N
- mbcset, &alloc,
-#endif /* RE_ENABLE_I18N */
- class_name, 0);
+ ret = build_charclass (trans, sbcset, mbcset, &alloc, class_name, 0);
if (__glibc_unlikely (ret != REG_NOERROR))
{
re_free (sbcset);
-#ifdef RE_ENABLE_I18N
free_charset (mbcset);
-#endif /* RE_ENABLE_I18N */
*err = ret;
return NULL;
}
@@ -3697,11 +3571,9 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans,
if (non_match)
bitset_not (sbcset);
-#ifdef RE_ENABLE_I18N
/* Ensure only single byte characters are set. */
if (dfa->mb_cur_max > 1)
bitset_mask (sbcset, dfa->sb_char);
-#endif
/* Build a tree for simple bracket. */
re_token_t br_token = { .type = SIMPLE_BRACKET, .opr.sbcset = sbcset };
@@ -3709,7 +3581,6 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans,
if (__glibc_unlikely (tree == NULL))
goto build_word_op_espace;
-#ifdef RE_ENABLE_I18N
if (dfa->mb_cur_max > 1)
{
bin_tree_t *mbc_tree;
@@ -3730,15 +3601,10 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans,
free_charset (mbcset);
return tree;
}
-#else /* not RE_ENABLE_I18N */
- return tree;
-#endif /* not RE_ENABLE_I18N */
build_word_op_espace:
re_free (sbcset);
-#ifdef RE_ENABLE_I18N
free_charset (mbcset);
-#endif /* RE_ENABLE_I18N */
*err = REG_ESPACE;
return NULL;
}
@@ -3771,21 +3637,19 @@ fetch_number (re_string_t *input, re_token_t *token, reg_syntax_t syntax)
return num;
}
-#ifdef RE_ENABLE_I18N
static void
free_charset (re_charset_t *cset)
{
re_free (cset->mbchars);
-# ifdef _LIBC
+#ifdef _LIBC
re_free (cset->coll_syms);
re_free (cset->equiv_classes);
-# endif
+#endif
re_free (cset->range_starts);
re_free (cset->range_ends);
re_free (cset->char_classes);
re_free (cset);
}
-#endif /* RE_ENABLE_I18N */
/* Functions for binary tree operation. */
@@ -3851,13 +3715,10 @@ mark_opt_subexp (void *extra, bin_tree_t *node)
static void
free_token (re_token_t *node)
{
-#ifdef RE_ENABLE_I18N
if (node->type == COMPLEX_BRACKET && node->duplicated == 0)
free_charset (node->opr.mbcset);
- else
-#endif /* RE_ENABLE_I18N */
- if (node->type == SIMPLE_BRACKET && node->duplicated == 0)
- re_free (node->opr.sbcset);
+ else if (node->type == SIMPLE_BRACKET && node->duplicated == 0)
+ re_free (node->opr.sbcset);
}
/* Worker function for tree walking. Free the allocated memory inside NODE
diff --git a/lib/regex_internal.c b/lib/regex_internal.c
index aefcfa2f52e..9767cd0d07f 100644
--- a/lib/regex_internal.c
+++ b/lib/regex_internal.c
@@ -30,10 +30,8 @@ static re_dfastate_t *create_cd_newstate (const re_dfa_t *dfa,
re_hashval_t hash);
static reg_errcode_t re_string_realloc_buffers (re_string_t *pstr,
Idx new_buf_len);
-#ifdef RE_ENABLE_I18N
static void build_wcs_buffer (re_string_t *pstr);
static reg_errcode_t build_wcs_upper_buffer (re_string_t *pstr);
-#endif /* RE_ENABLE_I18N */
static void build_upper_buffer (re_string_t *pstr);
static void re_string_translate_buffer (re_string_t *pstr);
static unsigned int re_string_context_at (const re_string_t *input, Idx idx,
@@ -91,7 +89,6 @@ re_string_construct (re_string_t *pstr, const char *str, Idx len,
if (icase)
{
-#ifdef RE_ENABLE_I18N
if (dfa->mb_cur_max > 1)
{
while (1)
@@ -109,16 +106,13 @@ re_string_construct (re_string_t *pstr, const char *str, Idx len,
}
}
else
-#endif /* RE_ENABLE_I18N */
build_upper_buffer (pstr);
}
else
{
-#ifdef RE_ENABLE_I18N
if (dfa->mb_cur_max > 1)
build_wcs_buffer (pstr);
else
-#endif /* RE_ENABLE_I18N */
{
if (trans != NULL)
re_string_translate_buffer (pstr);
@@ -139,7 +133,6 @@ static reg_errcode_t
__attribute_warn_unused_result__
re_string_realloc_buffers (re_string_t *pstr, Idx new_buf_len)
{
-#ifdef RE_ENABLE_I18N
if (pstr->mb_cur_max > 1)
{
wint_t *new_wcs;
@@ -162,7 +155,6 @@ re_string_realloc_buffers (re_string_t *pstr, Idx new_buf_len)
pstr->offsets = new_offsets;
}
}
-#endif /* RE_ENABLE_I18N */
if (pstr->mbs_allocated)
{
unsigned char *new_mbs = re_realloc (pstr->mbs, unsigned char,
@@ -194,7 +186,6 @@ re_string_construct_common (const char *str, Idx len, re_string_t *pstr,
pstr->raw_stop = pstr->stop;
}
-#ifdef RE_ENABLE_I18N
/* Build wide character buffer PSTR->WCS.
If the byte sequence of the string are:
@@ -530,7 +521,6 @@ re_string_skip_chars (re_string_t *pstr, Idx new_raw_idx, wint_t *last_wc)
*last_wc = wc;
return rawbuf_idx;
}
-#endif /* RE_ENABLE_I18N */
/* Build the buffer PSTR->MBS, and apply the translation if we need.
This function is used in case of REG_ICASE. */
@@ -585,10 +575,8 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags)
else
{
/* Reset buffer. */
-#ifdef RE_ENABLE_I18N
if (pstr->mb_cur_max > 1)
memset (&pstr->cur_state, '\0', sizeof (mbstate_t));
-#endif /* RE_ENABLE_I18N */
pstr->len = pstr->raw_len;
pstr->stop = pstr->raw_stop;
pstr->valid_len = 0;
@@ -608,7 +596,6 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags)
if (__glibc_likely (offset < pstr->valid_raw_len))
{
/* Yes, move them to the front of the buffer. */
-#ifdef RE_ENABLE_I18N
if (__glibc_unlikely (pstr->offsets_needed))
{
Idx low = 0, high = pstr->valid_len, mid;
@@ -672,15 +659,12 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags)
}
}
else
-#endif
{
pstr->tip_context = re_string_context_at (pstr, offset - 1,
eflags);
-#ifdef RE_ENABLE_I18N
if (pstr->mb_cur_max > 1)
memmove (pstr->wcs, pstr->wcs + offset,
(pstr->valid_len - offset) * sizeof (wint_t));
-#endif /* RE_ENABLE_I18N */
if (__glibc_unlikely (pstr->mbs_allocated))
memmove (pstr->mbs, pstr->mbs + offset,
pstr->valid_len - offset);
@@ -691,7 +675,6 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags)
}
else
{
-#ifdef RE_ENABLE_I18N
/* No, skip all characters until IDX. */
Idx prev_valid_len = pstr->valid_len;
@@ -701,9 +684,7 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags)
pstr->stop = pstr->raw_stop - idx + offset;
pstr->offsets_needed = 0;
}
-#endif
pstr->valid_len = 0;
-#ifdef RE_ENABLE_I18N
if (pstr->mb_cur_max > 1)
{
Idx wcs_idx;
@@ -787,7 +768,6 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags)
pstr->valid_raw_len = pstr->valid_len;
}
else
-#endif /* RE_ENABLE_I18N */
{
int c = pstr->raw_mbs[pstr->raw_mbs_idx + offset - 1];
pstr->valid_raw_len = 0;
@@ -807,7 +787,6 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags)
pstr->stop -= offset;
/* Then build the buffers. */
-#ifdef RE_ENABLE_I18N
if (pstr->mb_cur_max > 1)
{
if (pstr->icase)
@@ -820,7 +799,6 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags)
build_wcs_buffer (pstr);
}
else
-#endif /* RE_ENABLE_I18N */
if (__glibc_unlikely (pstr->mbs_allocated))
{
if (pstr->icase)
@@ -846,28 +824,22 @@ re_string_peek_byte_case (const re_string_t *pstr, Idx idx)
if (__glibc_likely (!pstr->mbs_allocated))
return re_string_peek_byte (pstr, idx);
-#ifdef RE_ENABLE_I18N
if (pstr->mb_cur_max > 1
&& ! re_string_is_single_byte_char (pstr, pstr->cur_idx + idx))
return re_string_peek_byte (pstr, idx);
-#endif
off = pstr->cur_idx + idx;
-#ifdef RE_ENABLE_I18N
if (pstr->offsets_needed)
off = pstr->offsets[off];
-#endif
ch = pstr->raw_mbs[pstr->raw_mbs_idx + off];
-#ifdef RE_ENABLE_I18N
/* Ensure that e.g. for tr_TR.UTF-8 BACKSLASH DOTLESS SMALL LETTER I
this function returns CAPITAL LETTER I instead of first byte of
DOTLESS SMALL LETTER I. The latter would confuse the parser,
since peek_byte_case doesn't advance cur_idx in any way. */
if (pstr->offsets_needed && !isascii (ch))
return re_string_peek_byte (pstr, idx);
-#endif
return ch;
}
@@ -878,7 +850,6 @@ re_string_fetch_byte_case (re_string_t *pstr)
if (__glibc_likely (!pstr->mbs_allocated))
return re_string_fetch_byte (pstr);
-#ifdef RE_ENABLE_I18N
if (pstr->offsets_needed)
{
Idx off;
@@ -904,7 +875,6 @@ re_string_fetch_byte_case (re_string_t *pstr)
re_string_char_size_at (pstr, pstr->cur_idx));
return ch;
}
-#endif
return pstr->raw_mbs[pstr->raw_mbs_idx + pstr->cur_idx++];
}
@@ -912,10 +882,8 @@ re_string_fetch_byte_case (re_string_t *pstr)
static void
re_string_destruct (re_string_t *pstr)
{
-#ifdef RE_ENABLE_I18N
re_free (pstr->wcs);
re_free (pstr->offsets);
-#endif /* RE_ENABLE_I18N */
if (pstr->mbs_allocated)
re_free (pstr->mbs);
}
@@ -933,7 +901,6 @@ re_string_context_at (const re_string_t *input, Idx idx, int eflags)
if (__glibc_unlikely (idx == input->len))
return ((eflags & REG_NOTEOL) ? CONTEXT_ENDBUF
: CONTEXT_NEWLINE | CONTEXT_ENDBUF);
-#ifdef RE_ENABLE_I18N
if (input->mb_cur_max > 1)
{
wint_t wc;
@@ -953,7 +920,6 @@ re_string_context_at (const re_string_t *input, Idx idx, int eflags)
? CONTEXT_NEWLINE : 0);
}
else
-#endif
{
c = re_string_byte_at (input, idx);
if (bitset_contain (input->word_char, c))
@@ -1451,11 +1417,9 @@ re_dfa_add_node (re_dfa_t *dfa, re_token_t token)
}
dfa->nodes[dfa->nodes_len] = token;
dfa->nodes[dfa->nodes_len].constraint = 0;
-#ifdef RE_ENABLE_I18N
dfa->nodes[dfa->nodes_len].accept_mb =
((token.type == OP_PERIOD && dfa->mb_cur_max > 1)
|| token.type == COMPLEX_BRACKET);
-#endif
dfa->nexts[dfa->nodes_len] = -1;
re_node_set_init_empty (dfa->edests + dfa->nodes_len);
re_node_set_init_empty (dfa->eclosures + dfa->nodes_len);
@@ -1651,9 +1615,7 @@ create_ci_newstate (const re_dfa_t *dfa, const re_node_set *nodes,
re_token_type_t type = node->type;
if (type == CHARACTER && !node->constraint)
continue;
-#ifdef RE_ENABLE_I18N
newstate->accept_mb |= node->accept_mb;
-#endif /* RE_ENABLE_I18N */
/* If the state has the halt node, the state is a halt state. */
if (type == END_OF_RE)
@@ -1705,9 +1667,7 @@ create_cd_newstate (const re_dfa_t *dfa, const re_node_set *nodes,
if (type == CHARACTER && !constraint)
continue;
-#ifdef RE_ENABLE_I18N
newstate->accept_mb |= node->accept_mb;
-#endif /* RE_ENABLE_I18N */
/* If the state has the halt node, the state is a halt state. */
if (type == END_OF_RE)
diff --git a/lib/regex_internal.h b/lib/regex_internal.h
index 1245e782ffc..8493db2701a 100644
--- a/lib/regex_internal.h
+++ b/lib/regex_internal.h
@@ -116,10 +116,6 @@
# define gettext_noop(String) String
#endif
-#if (defined MB_CUR_MAX && HAVE_WCTYPE_H && HAVE_ISWCTYPE) || _LIBC
-# define RE_ENABLE_I18N
-#endif
-
/* Number of ASCII characters. */
#define ASCII_CHARS 0x80
@@ -150,6 +146,11 @@
# define __regfree regfree
#endif /* not _LIBC */
+/* Types related to integers. Unless protected by #ifdef _LIBC, the
+ regex code should avoid exact-width types like int32_t and uint64_t
+ 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
@@ -246,10 +247,8 @@ typedef enum
SIMPLE_BRACKET = 3,
OP_BACK_REF = 4,
OP_PERIOD = 5,
-#ifdef RE_ENABLE_I18N
COMPLEX_BRACKET = 6,
OP_UTF8_PERIOD = 7,
-#endif /* RE_ENABLE_I18N */
/* We define EPSILON_BIT as a macro so that OP_OPEN_SUBEXP is used
when the debugger shows values of this enum type. */
@@ -287,30 +286,29 @@ typedef enum
} re_token_type_t;
-#ifdef RE_ENABLE_I18N
typedef struct
{
/* Multibyte characters. */
wchar_t *mbchars;
+#ifdef _LIBC
/* Collating symbols. */
-# ifdef _LIBC
int32_t *coll_syms;
-# endif
+#endif
+#ifdef _LIBC
/* Equivalence classes. */
-# ifdef _LIBC
int32_t *equiv_classes;
-# endif
+#endif
/* Range expressions. */
-# ifdef _LIBC
+#ifdef _LIBC
uint32_t *range_starts;
uint32_t *range_ends;
-# else /* not _LIBC */
+#else
wchar_t *range_starts;
wchar_t *range_ends;
-# endif /* not _LIBC */
+#endif
/* Character classes. */
wctype_t *char_classes;
@@ -333,7 +331,6 @@ typedef struct
/* # of character classes. */
Idx nchar_classes;
} re_charset_t;
-#endif /* RE_ENABLE_I18N */
typedef struct
{
@@ -341,9 +338,7 @@ typedef struct
{
unsigned char c; /* for CHARACTER */
re_bitset_ptr_t sbcset; /* for SIMPLE_BRACKET */
-#ifdef RE_ENABLE_I18N
re_charset_t *mbcset; /* for COMPLEX_BRACKET */
-#endif /* RE_ENABLE_I18N */
Idx idx; /* for BACK_REF */
re_context_type ctx_type; /* for ANCHOR */
} opr;
@@ -355,12 +350,10 @@ typedef struct
unsigned int constraint : 10; /* context constraint */
unsigned int duplicated : 1;
unsigned int opt_subexp : 1;
-#ifdef RE_ENABLE_I18N
unsigned int accept_mb : 1;
/* These 2 bits can be moved into the union if needed (e.g. if running out
of bits; move opr.c to opr.c.c and move the flags to opr.c.flags). */
unsigned int mb_partial : 1;
-#endif
unsigned int word_char : 1;
} re_token_t;
@@ -375,12 +368,10 @@ struct re_string_t
REG_ICASE, upper cases of the string are stored, otherwise MBS points
the same address that RAW_MBS points. */
unsigned char *mbs;
-#ifdef RE_ENABLE_I18N
/* Store the wide character string which is corresponding to MBS. */
wint_t *wcs;
Idx *offsets;
mbstate_t cur_state;
-#endif
/* Index in RAW_MBS. Each character mbs[i] corresponds to
raw_mbs[raw_mbs_idx + i]. */
Idx raw_mbs_idx;
@@ -779,7 +770,6 @@ bitset_mask (bitset_t dest, const bitset_t src)
dest[bitset_i] &= src[bitset_i];
}
-#ifdef RE_ENABLE_I18N
/* Functions for re_string. */
static int
__attribute__ ((pure, unused))
@@ -803,15 +793,15 @@ re_string_wchar_at (const re_string_t *pstr, Idx idx)
return (wint_t) pstr->wcs[idx];
}
-# ifdef _LIBC
-# include <locale/weight.h>
-# endif
+#ifdef _LIBC
+# include <locale/weight.h>
+#endif
static int
__attribute__ ((pure, unused))
re_string_elem_size_at (const re_string_t *pstr, Idx idx)
{
-# ifdef _LIBC
+#ifdef _LIBC
const unsigned char *p, *extra;
const int32_t *table, *indirect;
uint_fast32_t nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES);
@@ -827,11 +817,10 @@ re_string_elem_size_at (const re_string_t *pstr, Idx idx)
findidx (table, indirect, extra, &p, pstr->len - idx);
return p - pstr->mbs - idx;
}
- else
-# endif /* _LIBC */
- return 1;
+#endif /* _LIBC */
+
+ return 1;
}
-#endif /* RE_ENABLE_I18N */
#ifdef _LIBC
# if __GNUC__ >= 7
diff --git a/lib/regexec.c b/lib/regexec.c
index 83e9aaf8cad..3196708373f 100644
--- a/lib/regexec.c
+++ b/lib/regexec.c
@@ -67,11 +67,9 @@ static reg_errcode_t set_regs (const regex_t *preg,
bool fl_backtrack);
static reg_errcode_t free_fail_stack_return (struct re_fail_stack_t *fs);
-#ifdef RE_ENABLE_I18N
static int sift_states_iter_mb (const re_match_context_t *mctx,
re_sift_context_t *sctx,
Idx node_idx, Idx str_idx, Idx max_str_idx);
-#endif /* RE_ENABLE_I18N */
static reg_errcode_t sift_states_backward (const re_match_context_t *mctx,
re_sift_context_t *sctx);
static reg_errcode_t build_sifted_states (const re_match_context_t *mctx,
@@ -123,10 +121,8 @@ static re_dfastate_t *transit_state_sb (reg_errcode_t *err,
re_match_context_t *mctx,
re_dfastate_t *pstate);
#endif
-#ifdef RE_ENABLE_I18N
static reg_errcode_t transit_state_mb (re_match_context_t *mctx,
re_dfastate_t *pstate);
-#endif /* RE_ENABLE_I18N */
static reg_errcode_t transit_state_bkref (re_match_context_t *mctx,
const re_node_set *nodes);
static reg_errcode_t get_subexp (re_match_context_t *mctx,
@@ -156,14 +152,12 @@ static reg_errcode_t expand_bkref_cache (re_match_context_t *mctx,
re_node_set *cur_nodes, Idx cur_str,
Idx subexp_num, int type);
static bool build_trtable (const re_dfa_t *dfa, re_dfastate_t *state);
-#ifdef RE_ENABLE_I18N
static int check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx,
const re_string_t *input, Idx idx);
-# ifdef _LIBC
+#ifdef _LIBC
static unsigned int find_collation_sequence_value (const unsigned char *mbs,
size_t name_len);
-# endif /* _LIBC */
-#endif /* RE_ENABLE_I18N */
+#endif
static Idx group_nodes_into_DFAstates (const re_dfa_t *dfa,
const re_dfastate_t *state,
re_node_set *states_node,
@@ -758,10 +752,9 @@ re_search_internal (const regex_t *preg, const char *string, Idx length,
offset = match_first - mctx.input.raw_mbs_idx;
}
- /* If MATCH_FIRST is out of the buffer, leave it as '\0'.
- Note that MATCH_FIRST must not be smaller than 0. */
- ch = (match_first >= length
- ? 0 : re_string_byte_at (&mctx.input, offset));
+ /* Use buffer byte if OFFSET is in buffer, otherwise '\0'. */
+ ch = (offset < mctx.input.valid_len
+ ? re_string_byte_at (&mctx.input, offset) : 0);
if (fastmap[ch])
break;
match_first += incr;
@@ -780,12 +773,10 @@ re_search_internal (const regex_t *preg, const char *string, Idx length,
if (__glibc_unlikely (err != REG_NOERROR))
goto free_return;
-#ifdef RE_ENABLE_I18N
- /* Don't consider this char as a possible match start if it part,
- yet isn't the head, of a multibyte character. */
+ /* Don't consider this char as a possible match start if it part,
+ yet isn't the head, of a multibyte character. */
if (!sb && !re_string_first_byte (&mctx.input, 0))
continue;
-#endif
/* It seems to be appropriate one, then use the matcher. */
/* We assume that the matching starts from 0. */
@@ -859,7 +850,6 @@ re_search_internal (const regex_t *preg, const char *string, Idx length,
for (reg_idx = 0; reg_idx < nmatch; ++reg_idx)
if (pmatch[reg_idx].rm_so != -1)
{
-#ifdef RE_ENABLE_I18N
if (__glibc_unlikely (mctx.input.offsets_needed != 0))
{
pmatch[reg_idx].rm_so =
@@ -871,9 +861,6 @@ re_search_internal (const regex_t *preg, const char *string, Idx length,
? mctx.input.valid_raw_len
: mctx.input.offsets[pmatch[reg_idx].rm_eo]);
}
-#else
- DEBUG_ASSERT (mctx.input.offsets_needed == 0);
-#endif
pmatch[reg_idx].rm_so += match_first;
pmatch[reg_idx].rm_eo += match_first;
}
@@ -997,8 +984,7 @@ prune_impossible_nodes (re_match_context_t *mctx)
We must select appropriate initial state depending on the context,
since initial states may have constraints like "\<", "^", etc.. */
-static inline re_dfastate_t *
-__attribute__ ((always_inline))
+static __always_inline re_dfastate_t *
acquire_init_state_context (reg_errcode_t *err, const re_match_context_t *mctx,
Idx idx)
{
@@ -1262,12 +1248,9 @@ proceed_next_node (const re_match_context_t *mctx, Idx nregs, regmatch_t *regs,
Idx naccepted = 0;
re_token_type_t type = dfa->nodes[node].type;
-#ifdef RE_ENABLE_I18N
if (dfa->nodes[node].accept_mb)
naccepted = check_node_accept_bytes (dfa, node, &mctx->input, *pidx);
- else
-#endif /* RE_ENABLE_I18N */
- if (type == OP_BACK_REF)
+ else if (type == OP_BACK_REF)
{
Idx subexp_idx = dfa->nodes[node].opr.idx + 1;
if (subexp_idx < nregs)
@@ -1635,12 +1618,10 @@ build_sifted_states (const re_match_context_t *mctx, re_sift_context_t *sctx,
bool ok;
DEBUG_ASSERT (!IS_EPSILON_NODE (dfa->nodes[prev_node].type));
-#ifdef RE_ENABLE_I18N
/* If the node may accept "multi byte". */
if (dfa->nodes[prev_node].accept_mb)
naccepted = sift_states_iter_mb (mctx, sctx, prev_node,
str_idx, sctx->last_str_idx);
-#endif /* RE_ENABLE_I18N */
/* We don't check backreferences here.
See update_cur_sifted_state(). */
@@ -1689,6 +1670,7 @@ clean_state_log_if_needed (re_match_context_t *mctx, Idx next_state_log_idx)
if (top < next_state_log_idx)
{
+ DEBUG_ASSERT (mctx->state_log != NULL);
memset (mctx->state_log + top + 1, '\0',
sizeof (re_dfastate_t *) * (next_state_log_idx - top));
mctx->state_log_top = next_state_log_idx;
@@ -2177,7 +2159,6 @@ sift_states_bkref (const re_match_context_t *mctx, re_sift_context_t *sctx,
}
-#ifdef RE_ENABLE_I18N
static int
sift_states_iter_mb (const re_match_context_t *mctx, re_sift_context_t *sctx,
Idx node_idx, Idx str_idx, Idx max_str_idx)
@@ -2197,8 +2178,6 @@ sift_states_iter_mb (const re_match_context_t *mctx, re_sift_context_t *sctx,
'naccepted' bytes input. */
return naccepted;
}
-#endif /* RE_ENABLE_I18N */
-
/* Functions for state transition. */
@@ -2216,7 +2195,6 @@ transit_state (reg_errcode_t *err, re_match_context_t *mctx,
re_dfastate_t **trtable;
unsigned char ch;
-#ifdef RE_ENABLE_I18N
/* If the current state can accept multibyte. */
if (__glibc_unlikely (state->accept_mb))
{
@@ -2224,7 +2202,6 @@ transit_state (reg_errcode_t *err, re_match_context_t *mctx,
if (__glibc_unlikely (*err != REG_NOERROR))
return NULL;
}
-#endif /* RE_ENABLE_I18N */
/* Then decide the next state with the single byte. */
#if 0
@@ -2445,7 +2422,6 @@ transit_state_sb (reg_errcode_t *err, re_match_context_t *mctx,
}
#endif
-#ifdef RE_ENABLE_I18N
static reg_errcode_t
transit_state_mb (re_match_context_t *mctx, re_dfastate_t *pstate)
{
@@ -2513,7 +2489,6 @@ transit_state_mb (re_match_context_t *mctx, re_dfastate_t *pstate)
}
return REG_NOERROR;
}
-#endif /* RE_ENABLE_I18N */
static reg_errcode_t
transit_state_bkref (re_match_context_t *mctx, const re_node_set *nodes)
@@ -3003,9 +2978,7 @@ check_arrival_add_next_nodes (re_match_context_t *mctx, Idx str_idx,
const re_dfa_t *const dfa = mctx->dfa;
bool ok;
Idx cur_idx;
-#ifdef RE_ENABLE_I18N
reg_errcode_t err = REG_NOERROR;
-#endif
re_node_set union_set;
re_node_set_init_empty (&union_set);
for (cur_idx = 0; cur_idx < cur_nodes->nelem; ++cur_idx)
@@ -3014,7 +2987,6 @@ check_arrival_add_next_nodes (re_match_context_t *mctx, Idx str_idx,
Idx cur_node = cur_nodes->elems[cur_idx];
DEBUG_ASSERT (!IS_EPSILON_NODE (dfa->nodes[cur_node].type));
-#ifdef RE_ENABLE_I18N
/* If the node may accept "multi byte". */
if (dfa->nodes[cur_node].accept_mb)
{
@@ -3052,7 +3024,7 @@ check_arrival_add_next_nodes (re_match_context_t *mctx, Idx str_idx,
}
}
}
-#endif /* RE_ENABLE_I18N */
+
if (naccepted
|| check_node_accept (mctx, dfa->nodes + cur_node, str_idx))
{
@@ -3476,18 +3448,15 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state,
}
else if (type == OP_PERIOD)
{
-#ifdef RE_ENABLE_I18N
if (dfa->mb_cur_max > 1)
bitset_merge (accepts, dfa->sb_char);
else
-#endif
bitset_set_all (accepts);
if (!(dfa->syntax & RE_DOT_NEWLINE))
bitset_clear (accepts, '\n');
if (dfa->syntax & RE_DOT_NOT_NULL)
bitset_clear (accepts, '\0');
}
-#ifdef RE_ENABLE_I18N
else if (type == OP_UTF8_PERIOD)
{
if (ASCII_CHARS % BITSET_WORD_BITS == 0)
@@ -3499,7 +3468,6 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state,
if (dfa->syntax & RE_DOT_NOT_NULL)
bitset_clear (accepts, '\0');
}
-#endif
else
continue;
@@ -3530,12 +3498,10 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state,
bitset_empty (accepts);
continue;
}
-#ifdef RE_ENABLE_I18N
if (dfa->mb_cur_max > 1)
for (j = 0; j < BITSET_WORDS; ++j)
any_set |= (accepts[j] &= (dfa->word_char[j] | ~dfa->sb_char[j]));
else
-#endif
for (j = 0; j < BITSET_WORDS; ++j)
any_set |= (accepts[j] &= dfa->word_char[j]);
if (!any_set)
@@ -3549,12 +3515,10 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state,
bitset_empty (accepts);
continue;
}
-#ifdef RE_ENABLE_I18N
if (dfa->mb_cur_max > 1)
for (j = 0; j < BITSET_WORDS; ++j)
any_set |= (accepts[j] &= ~(dfa->word_char[j] & dfa->sb_char[j]));
else
-#endif
for (j = 0; j < BITSET_WORDS; ++j)
any_set |= (accepts[j] &= ~dfa->word_char[j]);
if (!any_set)
@@ -3631,7 +3595,6 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state,
return -1;
}
-#ifdef RE_ENABLE_I18N
/* Check how many bytes the node 'dfa->nodes[node_idx]' accepts.
Return the number of the bytes the node accepts.
STR_IDX is the current index of the input string.
@@ -3640,9 +3603,9 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state,
one collating element like '.', '[a-z]', opposite to the other nodes
can only accept one byte. */
-# ifdef _LIBC
-# include <locale/weight.h>
-# endif
+#ifdef _LIBC
+# include <locale/weight.h>
+#endif
static int
check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx,
@@ -3726,12 +3689,12 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx,
if (node->type == COMPLEX_BRACKET)
{
const re_charset_t *cset = node->opr.mbcset;
-# ifdef _LIBC
+#ifdef _LIBC
const unsigned char *pin
= ((const unsigned char *) re_string_get_buffer (input) + str_idx);
Idx j;
uint32_t nrules;
-# endif /* _LIBC */
+#endif
int match_len = 0;
wchar_t wc = ((cset->nranges || cset->nchar_classes || cset->nmbchars)
? re_string_wchar_at (input, str_idx) : 0);
@@ -3754,7 +3717,7 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx,
}
}
-# ifdef _LIBC
+#ifdef _LIBC
nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES);
if (nrules != 0)
{
@@ -3843,7 +3806,7 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx,
}
}
else
-# endif /* _LIBC */
+#endif /* _LIBC */
{
/* match with range expression? */
for (i = 0; i < cset->nranges; ++i)
@@ -3869,7 +3832,7 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx,
return 0;
}
-# ifdef _LIBC
+#ifdef _LIBC
static unsigned int
find_collation_sequence_value (const unsigned char *mbs, size_t mbs_len)
{
@@ -3927,8 +3890,7 @@ find_collation_sequence_value (const unsigned char *mbs, size_t mbs_len)
return UINT_MAX;
}
}
-# endif /* _LIBC */
-#endif /* RE_ENABLE_I18N */
+#endif /* _LIBC */
/* Check whether the node accepts the byte which is IDX-th
byte of the INPUT. */
@@ -3951,12 +3913,10 @@ check_node_accept (const re_match_context_t *mctx, const re_token_t *node,
return false;
break;
-#ifdef RE_ENABLE_I18N
case OP_UTF8_PERIOD:
if (ch >= ASCII_CHARS)
return false;
FALLTHROUGH;
-#endif
case OP_PERIOD:
if ((ch == '\n' && !(mctx->dfa->syntax & RE_DOT_NEWLINE))
|| (ch == '\0' && (mctx->dfa->syntax & RE_DOT_NOT_NULL)))
@@ -4017,7 +3977,6 @@ extend_buffers (re_match_context_t *mctx, int min_len)
/* Then reconstruct the buffers. */
if (pstr->icase)
{
-#ifdef RE_ENABLE_I18N
if (pstr->mb_cur_max > 1)
{
ret = build_wcs_upper_buffer (pstr);
@@ -4025,16 +3984,13 @@ extend_buffers (re_match_context_t *mctx, int min_len)
return ret;
}
else
-#endif /* RE_ENABLE_I18N */
build_upper_buffer (pstr);
}
else
{
-#ifdef RE_ENABLE_I18N
if (pstr->mb_cur_max > 1)
build_wcs_buffer (pstr);
else
-#endif /* RE_ENABLE_I18N */
{
if (pstr->trans != NULL)
re_string_translate_buffer (pstr);
diff --git a/lib/string.in.h b/lib/string.in.h
index 8d77ae38000..afe73508677 100644
--- a/lib/string.in.h
+++ b/lib/string.in.h
@@ -67,6 +67,35 @@
# include <strings.h>
#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. */
+#ifndef _GL_ATTRIBUTE_DEALLOC
+# if __GNUC__ >= 11
+# define _GL_ATTRIBUTE_DEALLOC(f, i) __attribute__ ((__malloc__ (f, i)))
+# else
+# define _GL_ATTRIBUTE_DEALLOC(f, i)
+# endif
+#endif
+
+/* _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. */
+#ifndef _GL_ATTRIBUTE_DEALLOC_FREE
+# define _GL_ATTRIBUTE_DEALLOC_FREE _GL_ATTRIBUTE_DEALLOC (free, 1)
+#endif
+
+/* _GL_ATTRIBUTE_MALLOC declares that the function returns a pointer to freshly
+ allocated memory. */
+/* Applies to: functions. */
+#ifndef _GL_ATTRIBUTE_MALLOC
+# if __GNUC__ >= 3 || defined __clang__
+# define _GL_ATTRIBUTE_MALLOC __attribute__ ((__malloc__))
+# else
+# define _GL_ATTRIBUTE_MALLOC
+# 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
diff --git a/lib/sys_random.in.h b/lib/sys_random.in.h
index 1abd6c544e0..8b4b934a1e7 100644
--- a/lib/sys_random.in.h
+++ b/lib/sys_random.in.h
@@ -23,8 +23,10 @@
#if @HAVE_SYS_RANDOM_H@
-/* On uClibc, <sys/random.h> assumes prior inclusion of <stddef.h>. */
-# if defined __UCLIBC__
+/* On uClibc < 1.0.35, <sys/random.h> assumes prior inclusion of <stddef.h>.
+ Do not use __UCLIBC__ here, as it might not be defined yet.
+ But avoid namespace pollution on glibc systems. */
+# ifndef __GLIBC__
# include <stddef.h>
# endif
/* On Mac OS X 10.5, <sys/random.h> assumes prior inclusion of <sys/types.h>.
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 3e764c5a787..df9e5c36ee1 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -60,7 +60,7 @@ BYTE_COMPILE_EXTRA_FLAGS =
# The example above is just for developers, it should not be used by default.
# Those automatically generated autoload files that need special rules
-# to build; ie not including things created via generated-autoload-file
+# to build; i.e. not including things created via generated-autoload-file
# (eg calc/calc-loaddefs.el).
LOADDEFS = $(lisp)/calendar/cal-loaddefs.el \
$(lisp)/calendar/diary-loaddefs.el \
@@ -91,25 +91,14 @@ COMPILE_FIRST = \
$(lisp)/emacs-lisp/byte-opt.elc \
$(lisp)/emacs-lisp/bytecomp.elc
ifeq ($(HAVE_NATIVE_COMP),yes)
-COMPILE_FIRST += \
- $(lisp)/emacs-lisp/comp.elc \
- $(lisp)/emacs-lisp/comp-cstr.elc \
- $(lisp)/emacs-lisp/cl-macs.elc \
- $(lisp)/emacs-lisp/rx.elc \
- $(lisp)/emacs-lisp/cl-seq.elc \
- $(lisp)/help-mode.elc \
- $(lisp)/emacs-lisp/cl-extra.elc \
- $(lisp)/emacs-lisp/gv.elc \
- $(lisp)/emacs-lisp/seq.elc \
- $(lisp)/emacs-lisp/cl-lib.elc \
- $(lisp)/emacs-lisp/warnings.elc \
- $(lisp)/emacs-lisp/subr-x.elc
+COMPILE_FIRST += $(lisp)/emacs-lisp/comp.elc
+COMPILE_FIRST += $(lisp)/emacs-lisp/comp-cstr.elc
endif
COMPILE_FIRST += $(lisp)/emacs-lisp/autoload.elc
# Files to compile early in compile-main. Works around bug#25556.
MAIN_FIRST = ./emacs-lisp/eieio.el ./emacs-lisp/eieio-base.el \
- ./cedet/semantic/db.el
+ ./cedet/semantic/db.el ./emacs-lisp/cconv.el
# Prevent any settings in the user environment causing problems.
unexport EMACSDATA EMACSDOC EMACSPATH
@@ -216,6 +205,9 @@ autoloads-force:
rm -f $(lisp)/loaddefs.el
$(MAKE) autoloads
+ldefs-boot.el: autoloads-force
+ cp $(lisp)/loaddefs.el $(lisp)/ldefs-boot.el
+
# This is required by the bootstrap-emacs target in ../src/Makefile, so
# we know that if we have an emacs executable, we also have a subdirs.el.
$(lisp)/subdirs.el:
@@ -346,10 +338,10 @@ endif
# Compile all the Elisp files that need it. Beware: it approximates
# 'no-byte-compile', so watch out for false-positives!
-compile-main: gen-lisp compile-clean
+compile-main: gen-lisp compile-clean main-first
@(cd $(lisp) && \
els=`echo "${SUBDIRS_REL} " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \
- for el in ${MAIN_FIRST} $$els; do \
+ for el in $$els; do \
test -f $$el || continue; \
test ! -f $${el}c && \
GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el > /dev/null && \
@@ -362,6 +354,18 @@ compile-main: gen-lisp compile-clean
TARGETS="$$chunk"; \
done
+# Compile some important files first.
+main-first:
+ @(cd $(lisp) && \
+ for el in ${MAIN_FIRST}; do \
+ echo "$${el}c"; \
+ done | xargs $(XARGS_LIMIT) echo) | \
+ while read chunk; do \
+ $(MAKE) compile-targets \
+ NATIVE_DISABLED=$(NATIVE_SKIP_NONDUMP) \
+ TARGETS="$$chunk"; \
+ done
+
.PHONY: compile-clean
# Erase left-over .elc files that do not have a corresponding .el file.
compile-clean:
diff --git a/lisp/abbrev.el b/lisp/abbrev.el
index b0e8a4fa99c..386aff16270 100644
--- a/lisp/abbrev.el
+++ b/lisp/abbrev.el
@@ -403,7 +403,7 @@ argument."
(defun expand-region-abbrevs (start end &optional noquery)
"For abbrev occurrence in the region, offer to expand it.
-The user is asked to type `y' or `n' for each occurrence.
+The user is asked to type \\`y' or \\`n' for each occurrence.
A prefix argument means don't query; expand all abbrevs."
(interactive "r\nP")
(save-excursion
@@ -583,6 +583,7 @@ PROPS is a property list. The following properties are special:
An obsolete but still supported calling form is:
\(define-abbrev TABLE NAME EXPANSION &optional HOOK COUNT SYSTEM)."
+ (declare (indent defun))
(when (and (consp props) (or (null (car props)) (numberp (car props))))
;; Old-style calling convention.
(setq props `(:count ,(car props)
@@ -1139,7 +1140,7 @@ Properties with special meaning:
- `:enable-function' can be set to a function of no argument which returns
non-nil if and only if the abbrevs in this table should be used for this
instance of `expand-abbrev'."
- (declare (doc-string 3))
+ (declare (doc-string 3) (indent defun))
;; We used to manually add the docstring, but we also want to record this
;; location as the definition of the variable (in load-history), so we may
;; as well just use `defvar'.
diff --git a/lisp/align.el b/lisp/align.el
index 7ced7b70445..2fd6dcda6d7 100644
--- a/lisp/align.el
+++ b/lisp/align.el
@@ -553,8 +553,7 @@ The possible settings for `align-region-separate' are:
(modes . align-text-modes)
(repeat . t)
(run-if . ,(lambda ()
- (and current-prefix-arg
- (not (eq '- current-prefix-arg))))))
+ (not (eq '- current-prefix-arg)))))
;; With a negative prefix argument, lists of dollar figures will
;; be aligned.
@@ -836,11 +835,22 @@ See the variable `align-exclude-rules-list' for more details.")
;;;###autoload
(defun align (beg end &optional separate rules exclude-rules)
"Attempt to align a region based on a set of alignment rules.
-BEG and END mark the region. If BEG and END are specifically set to
-nil (this can only be done programmatically), the beginning and end of
-the current alignment section will be calculated based on the location
-of point, and the value of `align-region-separate' (or possibly each
-rule's `separate' attribute).
+Interactively, BEG and END are the mark/point of the current region.
+
+Many modes define specific alignment rules, and some of these
+rules in some modes react to the current prefix argument. For
+instance, in `text-mode', `M-x align' will align into columns
+based on space delimiters, while `C-u - M-x align' will align
+into columns based on the \"$\" character. See the
+`align-rules-list' variable definition for the specific rules.
+
+Also see `align-regexp', which will guide you through various
+parameters for aligning text.
+
+Non-interactively, if BEG and END are nil, the beginning and end
+of the current alignment section will be calculated based on the
+location of point, and the value of `align-region-separate' (or
+possibly each rule's `separate' attribute).
If SEPARATE is non-nil, it overrides the value of
`align-region-separate' for all rules, except those that have their
@@ -889,6 +899,15 @@ on the format of these lists."
BEG and END mark the limits of the region. Interactively, this function
prompts for the regular expression REGEXP to align with.
+Interactively, if you specify a prefix argument, the function
+will guide you through entering the full regular expression, and
+then prompts for which subexpression parenthesis GROUP (default
+1) within REGEXP to modify, the amount of SPACING (default
+`align-default-spacing') to use, and whether or not to REPEAT the
+rule throughout the line.
+
+See `align-rules-list' for more information about these options.
+
For example, let's say you had a list of phone numbers, and wanted to
align them so that the opening parentheses would line up:
@@ -908,15 +927,8 @@ regular expression after you enter it. Interactively, you only
need to supply the characters to be lined up, and any preceding
whitespace is replaced.
-Non-interactively (or if you specify a prefix argument), you must
-enter the full regular expression, including the subexpression.
-Interactively, the function also then prompts for which
-subexpression parenthesis GROUP (default 1) within REGEXP to
-modify, the amount of SPACING (default `align-default-spacing')
-to use, and whether or not to REPEAT the rule throughout the
-line.
-
-See `align-rules-list' for more information about these options.
+Non-interactively, you must enter the full regular expression,
+including the subexpression.
The non-interactive form of the previous example would look something like:
(align-regexp (point-min) (point-max) \"\\\\(\\\\s-*\\\\)(\")
@@ -928,7 +940,7 @@ construct a rule to pass to `align-region', which does the real work."
(list (region-beginning) (region-end))
(if current-prefix-arg
(list (read-string "Complex align using regexp: "
- "\\(\\s-*\\)" 'align-regexp-history)
+ "\\(\\s-*\\) " 'align-regexp-history)
(string-to-number
(read-string
"Parenthesis group to modify (justify if negative): " "1"))
diff --git a/lisp/allout.el b/lisp/allout.el
index 5102ee73412..f684751a2a4 100644
--- a/lisp/allout.el
+++ b/lisp/allout.el
@@ -133,15 +133,10 @@ respective `allout-mode' keybinding variables, `allout-command-prefix',
(when (boundp 'allout-unprefixed-keybindings)
(dolist (entry allout-unprefixed-keybindings)
(define-key map (car (read-from-string (car entry))) (cadr entry))))
- (substitute-key-definition #'beginning-of-line #'allout-beginning-of-line
- map global-map)
- (substitute-key-definition #'move-beginning-of-line
- #'allout-beginning-of-line
- map global-map)
- (substitute-key-definition #'end-of-line #'allout-end-of-line
- map global-map)
- (substitute-key-definition #'move-end-of-line #'allout-end-of-line
- map global-map)
+ (define-key map [remap beginning-of-line] #'allout-beginning-of-line)
+ (define-key map [remap move-beginning-of-line] #'allout-beginning-of-line)
+ (define-key map [remap end-of-line] #'allout-end-of-line)
+ (define-key map [remap move-end-of-line] #'allout-end-of-line)
(allout-institute-keymap map)))
;;;_ > allout-institute-keymap (map)
(defun allout-institute-keymap (map)
@@ -3079,6 +3074,8 @@ Move to buffer limit in indicated direction if headings are exhausted."
(backward (if (< arg 0) (setq arg (* -1 arg))))
(step (if backward -1 1))
(progress (allout-current-bullet-pos))
+ ;; Move to the next physical line.
+ (line-move-visual nil)
prev got)
(while (> arg 0)
diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el
index b1c9cdaeca4..c962cbd4780 100644
--- a/lisp/ansi-color.el
+++ b/lisp/ansi-color.el
@@ -91,7 +91,7 @@ as a PDF file."
:group 'processes)
(defface ansi-color-bold
- '((t :inherit 'bold))
+ '((t :inherit bold))
"Face used to render bold text."
:group 'ansi-colors
:version "28.1")
@@ -103,13 +103,13 @@ as a PDF file."
:version "28.1")
(defface ansi-color-italic
- '((t :inherit 'italic))
+ '((t :inherit italic))
"Face used to render italic text."
:group 'ansi-colors
:version "28.1")
(defface ansi-color-underline
- '((t :inherit 'underline))
+ '((t :inherit underline))
"Face used to render underlined text."
:group 'ansi-colors
:version "28.1")
@@ -458,11 +458,18 @@ variable, and is meant to be used in `compilation-filter-hook'."
;; Working with strings
(defvar-local ansi-color-context nil
"Context saved between two calls to `ansi-color-apply'.
-This is a list of the form (CODES FRAGMENT) or nil. CODES
+This is a list of the form (FACE-VEC FRAGMENT) or nil. FACE-VEC
represents the state the last call to `ansi-color-apply' ended
-with, currently a list of ansi codes, and FRAGMENT is a string
-starting with an escape sequence, possibly the start of a new
-escape sequence.")
+with, currently a list of the form:
+
+ (BASIC-FACES FG BG)
+
+BASIC-FACES is a bool-vector that specifies which basic faces
+from `ansi-color-basic-faces-vector' to apply. FG and BG are
+ANSI color codes for the foreground and background color.
+
+FRAGMENT is a string starting with an escape sequence, possibly
+the start of a new escape sequence.")
(defun ansi-color-filter-apply (string)
"Filter out all ANSI control sequences from STRING.
@@ -473,17 +480,17 @@ will be used for the next call to `ansi-color-apply'. Set
`ansi-color-context' to nil if you don't want this.
This function can be added to `comint-preoutput-filter-functions'."
- (let ((start 0) end result)
+ (let ((context (ansi-color--ensure-context 'ansi-color-context nil))
+ (start 0) end result)
;; if context was saved and is a string, prepend it
- (if (cadr ansi-color-context)
- (setq string (concat (cadr ansi-color-context) string)
- ansi-color-context nil))
+ (setq string (concat (cadr context) string))
+ (setcar (cdr context) "")
;; find the next escape sequence
(while (setq end (string-match ansi-color-control-seq-regexp string start))
(push (substring string start end) result)
(setq start (match-end 0)))
;; save context, add the remainder of the string to the result
- (let (fragment)
+ (let ((fragment ""))
(push (substring string start
(if (string-match "\033" string start)
(let ((pos (match-beginning 0)))
@@ -491,25 +498,9 @@ This function can be added to `comint-preoutput-filter-functions'."
pos)
nil))
result)
- (setq ansi-color-context (if fragment (list nil fragment))))
+ (setcar (cdr context) fragment))
(apply #'concat (nreverse result))))
-(defun ansi-color--find-face (codes)
- "Return the face corresponding to CODES."
- ;; Sort the codes in ascending order to guarantee that "bold" comes before
- ;; any of the colors. This ensures that `ansi-color-bold-is-bright' is
- ;; applied correctly.
- (let (faces bright (codes (sort (copy-sequence codes) #'<)))
- (while codes
- (when-let ((face (ansi-color-get-face-1 (pop codes) bright)))
- (when (and ansi-color-bold-is-bright (eq face 'ansi-color-bold))
- (setq bright t))
- (push face faces)))
- ;; Avoid some long-lived conses in the common case.
- (if (cdr faces)
- (nreverse faces)
- (car faces))))
-
(defun ansi-color-apply (string)
"Translates SGR control sequences into text properties.
Delete all other control sequences without processing them.
@@ -524,49 +515,157 @@ This information will be used for the next call to `ansi-color-apply'.
Set `ansi-color-context' to nil if you don't want this.
This function can be added to `comint-preoutput-filter-functions'."
- (let ((codes (car ansi-color-context))
- (start 0) end result)
+ (let* ((context
+ (ansi-color--ensure-context 'ansi-color-context nil))
+ (face-vec (car context))
+ (start 0)
+ end result)
;; If context was saved and is a string, prepend it.
- (if (cadr ansi-color-context)
- (setq string (concat (cadr ansi-color-context) string)
- ansi-color-context nil))
+ (setq string (concat (cadr context) string))
+ (setcar (cdr context) "")
;; Find the next escape sequence.
(while (setq end (string-match ansi-color-control-seq-regexp string start))
(let ((esc-end (match-end 0)))
;; Colorize the old block from start to end using old face.
- (when codes
+ (when-let ((face (ansi-color--face-vec-face face-vec)))
(put-text-property start end 'font-lock-face
- (ansi-color--find-face codes) string))
+ face string))
(push (substring string start end) result)
(setq start (match-end 0))
;; If this is a color escape sequence,
(when (eq (aref string (1- esc-end)) ?m)
;; create a new face from it.
- (setq codes (ansi-color-apply-sequence
- (substring string end esc-end) codes)))))
+ (let ((cur-pos end))
+ (ansi-color--update-face-vec
+ face-vec
+ (lambda ()
+ (when (string-match ansi-color-parameter-regexp
+ string cur-pos)
+ (setq cur-pos (match-end 0))
+ (when (<= cur-pos esc-end)
+ (string-to-number (match-string 1 string))))))))))
;; if the rest of the string should have a face, put it there
- (when codes
+ (when-let ((face (ansi-color--face-vec-face face-vec)))
(put-text-property start (length string)
- 'font-lock-face (ansi-color--find-face codes) string))
+ 'font-lock-face face string))
;; save context, add the remainder of the string to the result
- (let (fragment)
- (if (string-match "\033" string start)
- (let ((pos (match-beginning 0)))
- (setq fragment (substring string pos))
- (push (substring string start pos) result))
- (push (substring string start) result))
- (setq ansi-color-context (if (or codes fragment) (list codes fragment))))
+ (if (string-match "\033" string start)
+ (let ((pos (match-beginning 0)))
+ (setcar (cdr context) (substring string pos))
+ (push (substring string start pos) result))
+ (push (substring string start) result))
(apply 'concat (nreverse result))))
+(defun ansi-color--ensure-context (context-sym position)
+ "Return CONTEXT-SYM's value as a valid context.
+If it is nil, set CONTEXT-SYM's value to a new context and return
+it. Context is a list of the form as described in
+`ansi-color-context' if POSITION is nil, or
+`ansi-color-context-region' if POSITION is non-nil.
+
+If CONTEXT-SYM's value is already non-nil, return it. If its
+marker doesn't point anywhere yet, position it before character
+number POSITION, if non-nil."
+ (let ((context (symbol-value context-sym)))
+ (if context
+ (if position
+ (let ((marker (cadr context)))
+ (unless (marker-position marker)
+ (set-marker marker position))
+ context)
+ context)
+ (set context-sym
+ (list (list (make-bool-vector 8 nil)
+ nil nil)
+ (if position
+ (copy-marker position)
+ ""))))))
+
+(defun ansi-color--face-vec-face (face-vec)
+ "Return the face corresponding to FACE-VEC.
+FACE-VEC is a list containing information about the ANSI sequence
+code. It is usually stored as the car of the variable
+`ansi-color-context-region'."
+ (let* ((basic-faces (car face-vec))
+ (colors (cdr face-vec))
+ (bright (and ansi-color-bold-is-bright (aref basic-faces 1)))
+ (faces nil))
+
+ (when-let ((fg (car colors)))
+ (push
+ `(:foreground
+ ,(or (ansi-color--code-as-hex fg)
+ (face-foreground
+ (aref (if (or bright (>= fg 8))
+ ansi-color-bright-colors-vector
+ ansi-color-normal-colors-vector)
+ (mod fg 8))
+ nil 'default)))
+ faces))
+ (when-let ((bg (cadr colors)))
+ (push
+ `(:background
+ ,(or (ansi-color--code-as-hex bg)
+ (face-background
+ (aref (if (or bright (>= bg 8))
+ ansi-color-bright-colors-vector
+ ansi-color-normal-colors-vector)
+ (mod bg 8))
+ nil 'default)))
+ faces))
+
+ (let ((i 8))
+ (while (> i 0)
+ (setq i (1- i))
+ (when (aref basic-faces i)
+ (push (aref ansi-color-basic-faces-vector i) faces))))
+ ;; Avoid some long-lived conses in the common case.
+ (if (cdr faces)
+ faces
+ (car faces))))
+
+(defun ansi-color--code-as-hex (color)
+ "Convert COLOR to hexadecimal string representation.
+COLOR is an ANSI color code. If it is between 16 and 255
+inclusive, it corresponds to a color from an 8-bit color cube.
+If it is greater or equal than 256, it is subtracted by 256 to
+directly specify a 24-bit color.
+
+Return a hexadecimal string, specifying the color, or nil, if
+COLOR is less than 16."
+ (cond
+ ((< color 16) nil)
+ ((>= color 256) (format "#%06X" (- color 256)))
+ ((>= color 232) ;; Grayscale
+ (format "#%06X" (* #x010101 (+ 8 (* 10 (- color 232))))))
+ (t ;; 6x6x6 color cube
+ (setq color (- color 16))
+ (let ((res 0)
+ (frac (* 6 6)))
+ (while (<= 1 frac) ; Repeat 3 times
+ (setq res (* res #x000100))
+ (let ((color-num (mod (/ color frac) 6)))
+ (unless (zerop color-num)
+ (setq res (+ res #x37 (* #x28 color-num)))))
+ (setq frac (/ frac 6)))
+ (format "#%06X" res)))))
+
;; Working with regions
(defvar-local ansi-color-context-region nil
"Context saved between two calls to `ansi-color-apply-on-region'.
-This is a list of the form (CODES MARKER) or nil. CODES
+This is a list of the form (FACE-VEC MARKER) or nil. FACE-VEC
represents the state the last call to `ansi-color-apply-on-region'
-ended with, currently a list of ansi codes, and MARKER is a
-buffer position within an escape sequence or the last position
-processed.")
+ended with, currently a list of the form:
+
+ (BASIC-FACES FG BG).
+
+BASIC-FACES is a bool-vector that specifies which basic faces
+from `ansi-color-basic-faces-vector' to apply. FG and BG are
+ANSI color codes for the foreground and background color.
+
+MARKER is a buffer position within an escape sequence or the last
+position processed.")
(defun ansi-color-filter-region (begin end)
"Filter out all ANSI control sequences from region BEGIN to END.
@@ -576,8 +675,10 @@ Every call to this function will set and use the buffer-local variable
used for the next call to `ansi-color-apply-on-region'. Specifically,
it will override BEGIN, the start of the region. Set
`ansi-color-context-region' to nil if you don't want this."
- (let ((end-marker (copy-marker end))
- (start (or (cadr ansi-color-context-region) begin)))
+ (let* ((end-marker (copy-marker end))
+ (context (ansi-color--ensure-context
+ 'ansi-color-context-region begin))
+ (start (cadr context)))
(save-excursion
(goto-char start)
;; Delete escape sequences.
@@ -585,8 +686,8 @@ it will override BEGIN, the start of the region. Set
(delete-region (match-beginning 0) (match-end 0)))
;; save context, add the remainder of the string to the result
(if (re-search-forward "\033" end-marker t)
- (setq ansi-color-context-region (list nil (match-beginning 0)))
- (setq ansi-color-context-region nil)))))
+ (set-marker start (match-beginning 0))
+ (set-marker start nil)))))
(defun ansi-color-apply-on-region (begin end &optional preserve-sequences)
"Translates SGR control sequences into overlays or extents.
@@ -608,58 +709,58 @@ this.
If PRESERVE-SEQUENCES is t, the sequences are hidden instead of
being deleted."
- (let ((codes (car ansi-color-context-region))
- (start-marker (or (cadr ansi-color-context-region)
- (copy-marker begin)))
- (end-marker (copy-marker end)))
+ (let* ((context (ansi-color--ensure-context
+ 'ansi-color-context-region begin))
+ (face-vec (car context))
+ (start-marker (cadr context))
+ (end-marker (copy-marker end)))
(save-excursion
(goto-char start-marker)
;; Find the next escape sequence.
(while (re-search-forward ansi-color-control-seq-regexp end-marker t)
;; Extract escape sequence.
- (let ((esc-seq (buffer-substring
- (match-beginning 0) (point))))
- (if preserve-sequences
- ;; Make the escape sequence transparent.
- (overlay-put (make-overlay (match-beginning 0) (point))
- 'invisible t)
- ;; Otherwise, strip.
- (delete-region (match-beginning 0) (point)))
-
+ (let ((esc-beg (match-beginning 0))
+ (esc-end (point)))
;; Colorize the old block from start to end using old face.
(funcall ansi-color-apply-face-function
(prog1 (marker-position start-marker)
;; Store new start position.
- (set-marker start-marker (point)))
- (match-beginning 0) (ansi-color--find-face codes))
+ (set-marker start-marker esc-end))
+ esc-beg (ansi-color--face-vec-face face-vec))
;; If this is a color sequence,
- (when (eq (aref esc-seq (1- (length esc-seq))) ?m)
- ;; update the list of ansi codes.
- (setq codes (ansi-color-apply-sequence esc-seq codes)))))
+ (when (eq (char-before esc-end) ?m)
+ (goto-char esc-beg)
+ (ansi-color--update-face-vec
+ face-vec (lambda ()
+ (when (re-search-forward ansi-color-parameter-regexp
+ esc-end t)
+ (string-to-number (match-string 1))))))
+
+ (if preserve-sequences
+ ;; Make the escape sequence transparent.
+ (overlay-put (make-overlay esc-beg esc-end) 'invisible t)
+ ;; Otherwise, strip.
+ (delete-region esc-beg esc-end))))
;; search for the possible start of a new escape sequence
(if (re-search-forward "\033" end-marker t)
- (progn
- ;; if the rest of the region should have a face, put it there
- (funcall ansi-color-apply-face-function
- start-marker (point) (ansi-color--find-face codes))
- ;; save codes and point
- (setq ansi-color-context-region
- (list codes (copy-marker (match-beginning 0)))))
- ;; if the rest of the region should have a face, put it there
- (funcall ansi-color-apply-face-function
- start-marker end-marker (ansi-color--find-face codes))
- ;; Save a restart position when there are codes active. It's
- ;; convenient for man.el's process filter to pass `begin'
- ;; positions that overlap regions previously colored; these
- ;; `codes' should not be applied to that overlap, so we need
- ;; to know where they should really start.
- (setq ansi-color-context-region
- (if codes (list codes (copy-marker (point)))))))
- ;; Clean up our temporary markers.
- (unless (eq start-marker (cadr ansi-color-context-region))
- (set-marker start-marker nil))
- (unless (eq end-marker (cadr ansi-color-context-region))
- (set-marker end-marker nil))))
+ (progn
+ (while (re-search-forward "\033" end-marker t))
+ (backward-char)
+ (funcall ansi-color-apply-face-function
+ start-marker (point)
+ (ansi-color--face-vec-face face-vec))
+ (set-marker start-marker (point)))
+ (let ((faces (ansi-color--face-vec-face face-vec)))
+ (funcall ansi-color-apply-face-function
+ start-marker end-marker faces)
+ ;; Save a restart position when there are codes active. It's
+ ;; convenient for man.el's process filter to pass `begin'
+ ;; positions that overlap regions previously colored; these
+ ;; `codes' should not be applied to that overlap, so we need
+ ;; to know where they should really start.
+ (set-marker start-marker (when faces end-marker)))))
+ ;; Clean up our temporary marker.
+ (set-marker end-marker nil)))
(defun ansi-color-apply-overlay-face (beg end face)
"Make an overlay from BEG to END, and apply face FACE.
@@ -767,6 +868,7 @@ the foreground color code is replaced or added resp. deleted; if it
is 40-47 (or 100-107) resp. 49, the background color code is replaced
or added resp. deleted; any other code is discarded together with the
old codes. Finally, the so changed list of codes is returned."
+ (declare (obsolete ansi-color--update-face-vec "29.1"))
(let ((new-codes (ansi-color-parse-sequence escape-sequence)))
(while new-codes
(let* ((new (pop new-codes))
@@ -795,6 +897,72 @@ old codes. Finally, the so changed list of codes is returned."
(_ nil)))))
codes))
+(defun ansi-color--update-face-vec (face-vec iterator)
+ "Apply escape sequences to FACE-VEC.
+
+Destructively modify FACE-VEC, which should be a list containing
+face information. It is described in
+`ansi-color-context-region'. ITERATOR is a function which is
+called repeatedly with zero arguments and should return either
+the next ANSI code in the current sequence as a number or nil if
+there are no more ANSI codes left.
+
+For each new code, the following happens: if it is 1-7, set the
+corresponding properties; if it is 21-25 or 27, unset appropriate
+properties; if it is 30-37 (or 90-97) or resp. 39, set the
+foreground color or resp. unset it; if it is 40-47 (or 100-107)
+resp. 49, set the background color or resp. unset it; if it is 38
+or 48, the following codes are used to set the foreground or
+background color and the correct color mode; any other code will
+unset all properties and colors."
+ (let ((basic-faces (car face-vec))
+ (colors (cdr face-vec))
+ new q do-clear)
+ (while (setq new (funcall iterator))
+ (setq q (/ new 10))
+ (pcase q
+ (0 (if (memq new '(0 8 9))
+ (setq do-clear t)
+ (aset basic-faces new t)))
+ (2 (if (memq new '(20 26 28 29))
+ (setq do-clear t)
+ ;; The standard says `21 doubly underlined' while
+ ;; https://en.wikipedia.org/wiki/ANSI_escape_code claims
+ ;; `21 Bright/Bold: off or Underline: Double'.
+ (aset basic-faces (- new 20) nil)
+ (aset basic-faces (pcase new (22 1) (25 6) (_ 0)) nil)))
+ ((or 3 4 9 10)
+ (let ((r (mod new 10))
+ (cell (if (memq q '(3 9)) colors (cdr colors))))
+ (pcase r
+ (8
+ (pcase (funcall iterator)
+ (5 (setq new (setcar cell (funcall iterator)))
+ (setq do-clear (or (null new) (>= new 256))))
+ (2
+ (let ((red (funcall iterator))
+ (green (funcall iterator))
+ (blue (funcall iterator)))
+ (if (and red green blue
+ (progn
+ (setq new (+ (* #x010000 red)
+ (* #x000100 green)
+ (* #x000001 blue)))
+ (<= new #xFFFFFF)))
+ (setcar cell (+ 256 new))
+ (setq do-clear t))))
+ (_ (setq do-clear t))))
+ (9 (setcar cell nil))
+ (_ (setcar cell (+ (if (memq q '(3 4)) 0 8) r))))))
+ (_ (setq do-clear t)))
+
+ (when do-clear
+ (setq do-clear nil)
+ ;; Zero out our bool vector without any allocation.
+ (bool-vector-intersection basic-faces #&8"\0" basic-faces)
+ (setcar colors nil)
+ (setcar (cdr colors) nil)))))
+
(defun ansi-color-make-color-map ()
"Create a vector of face definitions and return it.
@@ -859,6 +1027,7 @@ This function is obsolete, and no longer needed to use ansi-color."
"Get face definition for ANSI-CODE.
BRIGHT, if non-nil, requests \"bright\" ANSI colors, even if ANSI-CODE
is a normal-intensity color."
+ (declare (obsolete ansi-color--face-vec-face "29.1"))
(when (and bright (<= 30 ansi-code 49))
(setq ansi-code (+ ansi-code 60)))
(cond ((<= 0 ansi-code 7)
diff --git a/lisp/apropos.el b/lisp/apropos.el
index fc15cd3e011..66a594d588d 100644
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -515,9 +515,9 @@ variables, not just user options."
current-prefix-arg))
(apropos-command pattern nil
(if (or do-all apropos-do-all)
- #'(lambda (symbol)
- (and (boundp symbol)
- (get symbol 'variable-documentation)))
+ (lambda (symbol)
+ (and (boundp symbol)
+ (get symbol 'variable-documentation)))
#'custom-variable-p)))
;;;###autoload
@@ -1322,17 +1322,18 @@ as a heading."
(defun apropos-describe-plist (symbol)
"Display a pretty listing of SYMBOL's plist."
- (help-setup-xref (list 'apropos-describe-plist symbol)
- (called-interactively-p 'interactive))
- (with-help-window (help-buffer)
- (set-buffer standard-output)
- (princ "Symbol ")
- (prin1 symbol)
- (princ (substitute-command-keys "'s plist is\n ("))
- (put-text-property (+ (point-min) 7) (- (point) 14)
- 'face 'apropos-symbol)
- (insert (apropos-format-plist symbol "\n "))
- (princ ")")))
+ (let ((help-buffer-under-preparation t))
+ (help-setup-xref (list 'apropos-describe-plist symbol)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (set-buffer standard-output)
+ (princ "Symbol ")
+ (prin1 symbol)
+ (princ (substitute-command-keys "'s plist is\n ("))
+ (put-text-property (+ (point-min) 7) (- (point) 14)
+ 'face 'apropos-symbol)
+ (insert (apropos-format-plist symbol "\n "))
+ (princ ")"))))
(provide 'apropos)
diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index 5576ae35053..ece30fec003 100644
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -431,12 +431,8 @@ be added."
;; Let mouse-1 follow the link.
(define-key map [follow-link] 'mouse-face)
- (if (fboundp 'command-remapping)
- (progn
- (define-key map [remap advertised-undo] 'archive-undo)
- (define-key map [remap undo] 'archive-undo))
- (substitute-key-definition 'advertised-undo 'archive-undo map global-map)
- (substitute-key-definition 'undo 'archive-undo map global-map))
+ (define-key map [remap advertised-undo] #'archive-undo)
+ (define-key map [remap undo] #'archive-undo)
(define-key map [mouse-2] 'archive-extract)
@@ -621,12 +617,8 @@ OLDMODE will be modified accordingly just like chmod(2) would have done."
(defun archive-unixdate (low high)
"Stringify Unix (LOW HIGH) date."
- (let* ((time (list high low))
- (str (current-time-string time)))
- (format "%s-%s-%s"
- (substring str 8 10)
- (substring str 4 7)
- (format-time-string "%Y" time))))
+ (let ((system-time-locale "C"))
+ (format-time-string "%e-%b-%Y" (list high low))))
(defun archive-unixtime (low high)
"Stringify Unix (LOW HIGH) time."
diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el
index 063d0a14d63..b448c0f8da9 100644
--- a/lisp/autoinsert.el
+++ b/lisp/autoinsert.el
@@ -415,6 +415,7 @@ Matches the visited file name against the elements of `auto-insert-alist'."
"Associate CONDITION with (additional) ACTION in `auto-insert-alist'.
Optional AFTER means to insert action after all existing actions for CONDITION,
or if CONDITION had no actions, after all other CONDITIONs."
+ (declare (indent defun))
(let ((elt (assoc condition auto-insert-alist)))
(if elt
(setcdr elt
diff --git a/lisp/bindings.el b/lisp/bindings.el
index 121e484a0ee..ba3bf81b3e3 100644
--- a/lisp/bindings.el
+++ b/lisp/bindings.el
@@ -288,7 +288,7 @@ mnemonics of the following coding systems:
Value is used for `mode-line-frame-identification', which see."
(if (or (null window-system)
(eq window-system 'pc))
- "-%F "
+ " %F "
" "))
;; We need to defer the call to mode-line-frame-control to the time
@@ -501,8 +501,9 @@ mouse-1: Display Line and Column Mode Menu"))
(defvar mode-line-position
`((:propertize
- mode-line-percent-position
+ (" " mode-line-percent-position)
local-map ,mode-line-column-line-number-mode-map
+ display (min-width (5.0))
mouse-face mode-line-highlight
;; XXX needs better description
help-echo "Window Scroll Percentage
@@ -521,26 +522,31 @@ mouse-1: Display Line and Column Mode Menu")))
(10
(:propertize
mode-line-position-column-line-format
+ display (min-width (10.0))
,@mode-line-position--column-line-properties))
(10
(:propertize
(:eval (string-replace
"%c" "%C" (car mode-line-position-column-line-format)))
+ display (min-width (10.0))
,@mode-line-position--column-line-properties)))
(6
(:propertize
mode-line-position-line-format
+ display (min-width (6.0))
,@mode-line-position--column-line-properties))))
(column-number-mode
(column-number-indicator-zero-based
(6
(:propertize
mode-line-position-column-format
+ display (min-width (6.0))
(,@mode-line-position--column-line-properties)))
(6
(:propertize
(:eval (string-replace
"%c" "%C" (car mode-line-position-column-format)))
+ display (min-width (6.0))
,@mode-line-position--column-line-properties))))))
"Mode line construct for displaying the position in the buffer.
Normally displays the buffer percentage and, optionally, the
@@ -597,10 +603,14 @@ By default, this shows the information specified by `global-mode-string'.")
(let ((standard-mode-line-format
(list "%e"
'mode-line-front-space
- 'mode-line-mule-info
- 'mode-line-client
- 'mode-line-modified
- 'mode-line-remote
+ (list
+ :propertize
+ (list ""
+ 'mode-line-mule-info
+ 'mode-line-client
+ 'mode-line-modified
+ 'mode-line-remote)
+ 'display '(min-width (5.0)))
'mode-line-frame-identification
'mode-line-buffer-identification
" "
@@ -1251,6 +1261,8 @@ if `inhibit-field-text-motion' is non-nil."
;; (define-key global-map [kp-9] 'function-key-error)
;; (define-key global-map [kp-equal] 'function-key-error)
+(define-key global-map [touch-end] 'ignore)
+
;; X11 distinguishes these keys from the non-kp keys.
;; Make them behave like the non-kp keys unless otherwise bound.
;; FIXME: rather than list such mappings for every modifier-combination,
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index 623f0acd28a..f35cbc1a5ec 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -214,31 +214,28 @@ A non-nil value may result in truncated bookmark names."
;;;###autoload (define-key ctl-x-r-map "l" 'bookmark-bmenu-list)
;;;###autoload
-(defvar bookmark-map
- (let ((map (make-sparse-keymap)))
- ;; Read the help on all of these functions for details...
- (define-key map "x" 'bookmark-set)
- (define-key map "m" 'bookmark-set) ;"m"ark
- (define-key map "M" 'bookmark-set-no-overwrite) ;"M"aybe mark
- (define-key map "j" 'bookmark-jump)
- (define-key map "g" 'bookmark-jump) ;"g"o
- (define-key map "o" 'bookmark-jump-other-window)
- (define-key map "5" 'bookmark-jump-other-frame)
- (define-key map "i" 'bookmark-insert)
- (define-key map "e" 'edit-bookmarks)
- (define-key map "f" 'bookmark-insert-location) ;"f"ind
- (define-key map "r" 'bookmark-rename)
- (define-key map "d" 'bookmark-delete)
- (define-key map "D" 'bookmark-delete-all)
- (define-key map "l" 'bookmark-load)
- (define-key map "w" 'bookmark-write)
- (define-key map "s" 'bookmark-save)
- map)
- "Keymap containing bindings to bookmark functions.
+(defvar-keymap bookmark-map
+ :doc "Keymap containing bindings to bookmark functions.
It is not bound to any key by default: to bind it
so that you have a bookmark prefix, just use `global-set-key' and bind a
key of your choice to variable `bookmark-map'. All interactive bookmark
-functions have a binding in this keymap.")
+functions have a binding in this keymap."
+ "x" #'bookmark-set
+ "m" #'bookmark-set ;"m"ark
+ "M" #'bookmark-set-no-overwrite ;"M"aybe mark
+ "j" #'bookmark-jump
+ "g" #'bookmark-jump ;"g"o
+ "o" #'bookmark-jump-other-window
+ "5" #'bookmark-jump-other-frame
+ "i" #'bookmark-insert
+ "e" #'edit-bookmarks
+ "f" #'bookmark-insert-location ;"f"ind
+ "r" #'bookmark-rename
+ "d" #'bookmark-delete
+ "D" #'bookmark-delete-all
+ "l" #'bookmark-load
+ "w" #'bookmark-write
+ "s" #'bookmark-save)
;;;###autoload (fset 'bookmark-map bookmark-map)
@@ -501,11 +498,8 @@ If DEFAULT is nil then return empty string for empty input."
'string-lessp)
(bookmark-all-names)))
(let* ((completion-ignore-case bookmark-completion-ignore-case)
- (default (unless (equal "" default) default))
- (prompt (concat prompt (if default
- (format " (%s): " default)
- ": "))))
- (completing-read prompt
+ (default (unless (equal "" default) default)))
+ (completing-read (format-prompt prompt default)
(lambda (string pred action)
(if (eq action 'metadata)
'(metadata (category . bookmark))
@@ -516,8 +510,9 @@ If DEFAULT is nil then return empty string for empty input."
(defmacro bookmark-maybe-historicize-string (string)
"Put STRING into the bookmark prompt history, if caller non-interactive.
-We need this because sometimes bookmark functions are invoked from
-menus, so `completing-read' never gets a chance to set `bookmark-history'."
+We need this because sometimes bookmark functions are invoked
+from other commands that pass in the bookmark name, so
+`completing-read' never gets a chance to set `bookmark-history'."
`(or
(called-interactively-p 'interactive)
(setq bookmark-history (cons ,string bookmark-history))))
@@ -816,11 +811,9 @@ CODING is the symbol of the coding-system in which the file is encoded."
(define-obsolete-function-alias 'bookmark-maybe-message 'message "27.1")
-(defvar bookmark-minibuffer-read-name-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map minibuffer-local-map)
- (define-key map "\C-w" 'bookmark-yank-word)
- map))
+(defvar-keymap bookmark-minibuffer-read-name-map
+ :parent minibuffer-local-map
+ "C-w" #'bookmark-yank-word)
(defun bookmark-set-internal (prompt name overwrite-or-push)
"Set a bookmark using specified NAME or prompting with PROMPT.
@@ -924,7 +917,7 @@ it removes only the first instance of a bookmark with that name from
the list of bookmarks.)"
(interactive (list nil current-prefix-arg))
(let ((prompt
- (if no-overwrite "Set bookmark" "Set bookmark unconditionally")))
+ (if no-overwrite "Append bookmark named" "Set bookmark named")))
(bookmark-set-internal prompt name (if no-overwrite 'push 'overwrite))))
;;;###autoload
@@ -995,12 +988,10 @@ annotations."
"Function to return default text to use for a bookmark annotation.
It takes one argument, the name of the bookmark, as a string.")
-(defvar bookmark-edit-annotation-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map text-mode-map)
- (define-key map "\C-c\C-c" 'bookmark-send-edited-annotation)
- map)
- "Keymap for editing an annotation of a bookmark.")
+(defvar-keymap bookmark-edit-annotation-mode-map
+ :doc "Keymap for editing an annotation of a bookmark."
+ :parent text-mode-map
+ "C-c C-c" #'bookmark-send-edited-annotation)
(defun bookmark-insert-annotation (bookmark-name-or-record)
"Insert annotation for BOOKMARK-NAME-OR-RECORD at point."
@@ -1703,44 +1694,42 @@ unique numeric suffixes \"<2>\", \"<3>\", etc."
(defvar bookmark-bmenu-hidden-bookmarks ())
-
-(defvar bookmark-bmenu-mode-map
- (let ((map (make-keymap)))
- (set-keymap-parent map tabulated-list-mode-map)
- (define-key map "v" 'bookmark-bmenu-select)
- (define-key map "w" 'bookmark-bmenu-locate)
- (define-key map "5" 'bookmark-bmenu-other-frame)
- (define-key map "2" 'bookmark-bmenu-2-window)
- (define-key map "1" 'bookmark-bmenu-1-window)
- (define-key map "j" 'bookmark-bmenu-this-window)
- (define-key map "\C-c\C-c" 'bookmark-bmenu-this-window)
- (define-key map "f" 'bookmark-bmenu-this-window)
- (define-key map "\C-m" 'bookmark-bmenu-this-window)
- (define-key map "o" 'bookmark-bmenu-other-window)
- (define-key map "\C-o" 'bookmark-bmenu-switch-other-window)
- (define-key map "s" 'bookmark-bmenu-save)
- (define-key map "\C-x\C-s" 'bookmark-bmenu-save)
- (define-key map "k" 'bookmark-bmenu-delete)
- (define-key map "\C-d" 'bookmark-bmenu-delete-backwards)
- (define-key map "x" 'bookmark-bmenu-execute-deletions)
- (define-key map "d" 'bookmark-bmenu-delete)
- (define-key map "D" 'bookmark-bmenu-delete-all)
- (define-key map " " 'next-line)
- (define-key map "\177" 'bookmark-bmenu-backup-unmark)
- (define-key map "u" 'bookmark-bmenu-unmark)
- (define-key map "U" 'bookmark-bmenu-unmark-all)
- (define-key map "m" 'bookmark-bmenu-mark)
- (define-key map "M" 'bookmark-bmenu-mark-all)
- (define-key map "l" 'bookmark-bmenu-load)
- (define-key map "r" 'bookmark-bmenu-rename)
- (define-key map "R" 'bookmark-bmenu-relocate)
- (define-key map "t" 'bookmark-bmenu-toggle-filenames)
- (define-key map "a" 'bookmark-bmenu-show-annotation)
- (define-key map "A" 'bookmark-bmenu-show-all-annotations)
- (define-key map "e" 'bookmark-bmenu-edit-annotation)
- (define-key map "/" 'bookmark-bmenu-search)
- (define-key map [mouse-2] 'bookmark-bmenu-other-window-with-mouse)
- map))
+(defvar-keymap bookmark-bmenu-mode-map
+ :doc "Keymap for `bookmark-bmenu-mode'."
+ :parent tabulated-list-mode-map
+ "v" #'bookmark-bmenu-select
+ "w" #'bookmark-bmenu-locate
+ "5" #'bookmark-bmenu-other-frame
+ "2" #'bookmark-bmenu-2-window
+ "1" #'bookmark-bmenu-1-window
+ "j" #'bookmark-bmenu-this-window
+ "C-c C-c" #'bookmark-bmenu-this-window
+ "f" #'bookmark-bmenu-this-window
+ "C-m" #'bookmark-bmenu-this-window
+ "o" #'bookmark-bmenu-other-window
+ "C-o" #'bookmark-bmenu-switch-other-window
+ "s" #'bookmark-bmenu-save
+ "C-x C-s" #'bookmark-bmenu-save
+ "k" #'bookmark-bmenu-delete
+ "C-d" #'bookmark-bmenu-delete-backwards
+ "x" #'bookmark-bmenu-execute-deletions
+ "d" #'bookmark-bmenu-delete
+ "D" #'bookmark-bmenu-delete-all
+ "SPC" #'next-line
+ "DEL" #'bookmark-bmenu-backup-unmark
+ "u" #'bookmark-bmenu-unmark
+ "U" #'bookmark-bmenu-unmark-all
+ "m" #'bookmark-bmenu-mark
+ "M" #'bookmark-bmenu-mark-all
+ "l" #'bookmark-bmenu-load
+ "r" #'bookmark-bmenu-rename
+ "R" #'bookmark-bmenu-relocate
+ "t" #'bookmark-bmenu-toggle-filenames
+ "a" #'bookmark-bmenu-show-annotation
+ "A" #'bookmark-bmenu-show-all-annotations
+ "e" #'bookmark-bmenu-edit-annotation
+ "/" #'bookmark-bmenu-search
+ "<mouse-2>" #'bookmark-bmenu-other-window-with-mouse)
(easy-menu-define bookmark-menu bookmark-bmenu-mode-map
"Menu for `bookmark-bmenu'."
@@ -2320,10 +2309,10 @@ Prompt with completion for the new path."
(lambda ()
(setq timer (run-with-idle-timer
bookmark-search-delay 'repeat
- #'(lambda (buf)
- (with-current-buffer buf
- (bookmark-bmenu-filter-alist-by-regexp
- (minibuffer-contents))))
+ (lambda (buf)
+ (with-current-buffer buf
+ (bookmark-bmenu-filter-alist-by-regexp
+ (minibuffer-contents))))
(current-buffer))))
(read-string "Pattern: ")
(when timer (cancel-timer timer) (setq timer nil)))
diff --git a/lisp/button.el b/lisp/button.el
index aedd07b762d..dd5a71d116a 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -130,6 +130,7 @@ 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
changes to a supertype are not reflected in its subtypes)."
+ (declare (indent defun))
(let ((catsym (make-symbol (concat (symbol-name name) "-button")))
(super-catsym
(button-category-symbol
@@ -603,7 +604,8 @@ When called from Lisp, pass BUTTON-OR-POS as the button to describe, or a
buffer position where a button is present. If BUTTON-OR-POS is nil, the
button at point is the button to describe."
(interactive "d")
- (let* ((button (cond ((integer-or-marker-p button-or-pos)
+ (let* ((help-buffer-under-preparation t)
+ (button (cond ((integer-or-marker-p button-or-pos)
(button-at button-or-pos))
((null button-or-pos) (button-at (point)))
((overlayp button-or-pos) button-or-pos)))
@@ -615,13 +617,19 @@ button at point is the button to describe."
(button--describe props)
t)))
-(defun button-buttonize (string callback &optional data)
+(define-obsolete-function-alias 'button-buttonize #'buttonize "29.1")
+
+(defun buttonize (string callback &optional data help-echo)
"Make STRING into a button and return it.
When clicked, CALLBACK will be called with the DATA as the
function argument. If DATA isn't present (or is nil), the button
-itself will be used instead as the function argument."
+itself will be used instead as the function argument.
+
+If HELP-ECHO, use that as the `help-echo' property."
(propertize string
'face 'button
+ 'mouse-face 'highlight
+ 'help-echo help-echo
'button t
'follow-link t
'category t
diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el
index dbe2f689d85..93ba8c4b6bb 100644
--- a/lisp/calc/calc-ext.el
+++ b/lisp/calc/calc-ext.el
@@ -1266,27 +1266,23 @@ calc-kill calc-kill-region calc-yank))))
(math-normalize val)))))
-(defvar calc-help-map nil)
-
-(if calc-help-map
- nil
- (setq calc-help-map (make-keymap))
- (define-key calc-help-map "b" 'calc-describe-bindings)
- (define-key calc-help-map "c" 'calc-describe-key-briefly)
- (define-key calc-help-map "f" 'calc-describe-function)
- (define-key calc-help-map "h" 'calc-full-help)
- (define-key calc-help-map "i" 'calc-info)
- (define-key calc-help-map "k" 'calc-describe-key)
- (define-key calc-help-map "n" 'calc-view-news)
- (define-key calc-help-map "s" 'calc-info-summary)
- (define-key calc-help-map "t" 'calc-tutorial)
- (define-key calc-help-map "v" 'calc-describe-variable)
- (define-key calc-help-map "\C-c" 'calc-describe-copying)
- (define-key calc-help-map "\C-d" 'calc-describe-distribution)
- (define-key calc-help-map "\C-n" 'calc-view-news)
- (define-key calc-help-map "\C-w" 'calc-describe-no-warranty)
- (define-key calc-help-map "?" 'calc-help-for-help)
- (define-key calc-help-map "\C-h" 'calc-help-for-help))
+(defvar-keymap calc-help-map
+ "b" 'calc-describe-bindings
+ "c" 'calc-describe-key-briefly
+ "f" 'calc-describe-function
+ "h" 'calc-full-help
+ "i" 'calc-info
+ "k" 'calc-describe-key
+ "n" 'calc-view-news
+ "s" 'calc-info-summary
+ "t" 'calc-tutorial
+ "v" 'calc-describe-variable
+ "C-c" 'calc-describe-copying
+ "C-d" 'calc-describe-distribution
+ "C-n" 'calc-view-news
+ "C-w" 'calc-describe-no-warranty
+ "?" 'calc-help-for-help
+ "C-h" 'calc-help-for-help)
(defvar calc-prefix-help-retry nil)
(defvar calc-prefix-help-phase 0)
diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el
index 7891e35c40f..b6ee124a72f 100644
--- a/lisp/calc/calc-graph.el
+++ b/lisp/calc/calc-graph.el
@@ -969,7 +969,8 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(define-key calc-dumb-map "\C-c\C-c" 'exit-recursive-edit)))
(use-local-map calc-dumb-map)
(setq truncate-lines t)
- (message "Type `q' or `C-c C-c' to return to Calc")
+ (message (substitute-command-keys
+ "Type \\`q' or \\`C-c C-c' to return to Calc"))
(recursive-edit)
(bury-buffer "*Gnuplot Trail*")))
diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el
index dd5063f27d5..2633d64fe42 100644
--- a/lisp/calc/calc-help.el
+++ b/lisp/calc/calc-help.el
@@ -50,25 +50,25 @@
(beep))))
(defun calc-help-for-help (arg)
- "You have typed `h', the Calc help character. Type a Help option:
+ "You have typed \\`h', the Calc help character. Type a Help option:
-B calc-describe-bindings. Display a table of all key bindings.
-H calc-full-help. Display all `?' key messages at once.
+\\`B' calc-describe-bindings. Display a table of all key bindings.
+\\`H' calc-full-help. Display all \\`?' key messages at once.
-I calc-info. Read the Calc manual using the Info system.
-T calc-tutorial. Read the Calc tutorial using the Info system.
-S calc-info-summary. Read the Calc summary using the Info system.
+\\`I' calc-info. Read the Calc manual using the Info system.
+\\`T' calc-tutorial. Read the Calc tutorial using the Info system.
+\\`S' calc-info-summary. Read the Calc summary using the Info system.
-C calc-describe-key-briefly. Look up the command name for a given key.
-K calc-describe-key. Look up a key's documentation in the manual.
-F calc-describe-function. Look up a function's documentation in the manual.
-V calc-describe-variable. Look up a variable's documentation in the manual.
+\\`C' calc-describe-key-briefly. Look up the command name for a given key.
+\\`K' calc-describe-key. Look up a key's documentation in the manual.
+\\`F' calc-describe-function. Look up a function's documentation in the manual.
+\\`V' calc-describe-variable. Look up a variable's documentation in the manual.
-N calc-view-news. Display Calc history of changes.
+\\`N' calc-view-news. Display Calc history of changes.
-C-c Describe conditions for copying Calc.
-C-d Describe how you can get a new copy of Calc or report a bug.
-C-w Describe how there is no warranty for Calc."
+\\`C-c' Describe conditions for copying Calc.
+\\`C-d' Describe how you can get a new copy of Calc or report a bug.
+\\`C-w' Describe how there is no warranty for Calc."
(interactive "P")
(if calc-dispatch-help
(let (key)
@@ -111,9 +111,6 @@ C-w Describe how there is no warranty for Calc."
(with-current-buffer "*Help*"
(let ((inhibit-read-only t))
(goto-char (point-min))
- (when (search-forward "Major Mode Bindings:" nil t)
- (delete-region (point-min) (point))
- (insert "Calc Mode Bindings:"))
(when (search-forward "Global bindings:" nil t)
(forward-line -1)
(delete-region (point) (point-max)))
diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el
index 1c2e7bcf2bc..ba2b6b2ca9c 100644
--- a/lisp/calc/calc-math.el
+++ b/lisp/calc/calc-math.el
@@ -618,8 +618,9 @@ If this can't be done, return NIL."
(defun math-nth-root-float (a nrf-n &optional guess)
(math-inexact-result)
(math-with-extra-prec 1
- (let ((math-nrf-nf (math-float nrf-n))
- (math-nrf-nfm1 (math-float (1- nrf-n))))
+ (let ((math-nrf-n nrf-n)
+ (math-nrf-nf (math-float nrf-n))
+ (math-nrf-nfm1 (math-float (1- nrf-n))))
(math-nth-root-float-iter a (or guess
(math-make-float
1 (/ (+ (math-numdigs (nth 1 a))
diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el
index c8394e8c2fa..1c4438e7f7a 100644
--- a/lisp/calc/calc-misc.el
+++ b/lisp/calc/calc-misc.el
@@ -216,26 +216,28 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C)."
(defun calc-help ()
(interactive)
(let ((msgs
- '("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)"
- "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"
- " Calc by Dave Gillespie, daveg@synaptics.com")))
+ ;; 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)"
+ "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"
+ " Calc by Dave Gillespie, daveg@synaptics.com"))))
(if calc-full-help-flag
msgs
(if (or calc-inverse-flag calc-hyperbolic-flag)
diff --git a/lisp/calc/calc-mode.el b/lisp/calc/calc-mode.el
index 68c8b90ac3b..211b8e661fd 100644
--- a/lisp/calc/calc-mode.el
+++ b/lisp/calc/calc-mode.el
@@ -109,11 +109,14 @@
(setq n (and (not (eq calc-auto-why t)) (if calc-auto-why t 1))))
(calc-change-mode 'calc-auto-why n nil)
(cond ((null n)
- (message "User must press `w' to explain unsimplified results"))
+ (message (substitute-command-keys
+ "User must press \\`w' to explain unsimplified results")))
((eq n t)
- (message "Automatically doing `w' to explain unsimplified results"))
+ (message (substitute-command-keys
+ "Automatically doing \\`w' to explain unsimplified results")))
(t
- (message "Automatically doing `w' only for unusual messages")))))
+ (message (substitute-command-keys
+ "Automatically doing \\`w' only for unusual messages"))))))
(defun calc-group-digits (n)
(interactive "P")
diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el
index 3492b6d831b..b381f8afcf9 100644
--- a/lisp/calc/calc-prog.el
+++ b/lisp/calc/calc-prog.el
@@ -205,9 +205,8 @@
(progn
(setq cmd-base-default (concat "User-" keyname))
(setq cmd (completing-read
- (concat "Define M-x command name (default calc-"
- cmd-base-default
- "): ")
+ (format-prompt "Define M-x command name"
+ (concat "calc-" cmd-base-default))
obarray 'commandp nil
(if (and odef (symbolp (cdr odef)))
(symbol-name (cdr odef))
@@ -241,8 +240,8 @@
(setq func
(concat "calcFunc-"
(completing-read
- (concat "Define algebraic function name (default "
- cmd-base-default "): ")
+ (format-prompt "Define algebraic function name"
+ cmd-base-default)
(mapcar (lambda (x) (substring x 9))
(all-completions "calcFunc-"
obarray))
diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el
index ee29c440fe4..817b50951dd 100644
--- a/lisp/calc/calc-store.el
+++ b/lisp/calc/calc-store.el
@@ -163,19 +163,19 @@
tag (and (not val) 1))
(message "Variable \"%s\" changed" (calc-var-name var)))))))
-(defvar calc-var-name-map nil "Keymap for reading Calc variable names.")
-(if calc-var-name-map
- ()
- (setq calc-var-name-map (copy-keymap minibuffer-local-completion-map))
- (define-key calc-var-name-map " " 'self-insert-command)
- (mapc (lambda (x)
- (define-key calc-var-name-map (char-to-string x)
- 'calcVar-digit))
- "0123456789")
- (mapc (lambda (x)
- (define-key calc-var-name-map (char-to-string x)
- 'calcVar-oper))
- "+-*/^|"))
+(defvar calc-var-name-map
+ (let ((map (copy-keymap minibuffer-local-completion-map)))
+ (define-key map " " #'self-insert-command)
+ (mapc (lambda (x)
+ (define-key map (char-to-string x)
+ #'calcVar-digit))
+ "0123456789")
+ (mapc (lambda (x)
+ (define-key map (char-to-string x)
+ #'calcVar-oper))
+ "+-*/^|")
+ map)
+ "Keymap for reading Calc variable names.")
(defvar calc-store-opers)
@@ -188,12 +188,15 @@
(let* ((calc-store-opers store-opers)
(var (concat
"var-"
- (let ((minibuffer-completion-table
- (mapcar (lambda (x) (substring x 4))
- (all-completions "var-" obarray)))
- (minibuffer-completion-predicate
- (lambda (x) (boundp (intern (concat "var-" x)))))
- (minibuffer-completion-confirm t))
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (setq-local minibuffer-completion-table
+ (mapcar (lambda (x) (substring x 4))
+ (all-completions "var-" obarray)))
+ (setq-local minibuffer-completion-predicate
+ (lambda (x)
+ (boundp (intern (concat "var-" x)))))
+ (setq-local minibuffer-completion-confirm t))
(read-from-minibuffer
prompt nil calc-var-name-map nil
'calc-read-var-name-history)))))
@@ -586,7 +589,7 @@
(defun calc-permanent-variable (&optional var)
(interactive)
(calc-wrapper
- (or var (setq var (calc-read-var-name "Save variable (default all): ")))
+ (or var (setq var (calc-read-var-name (format-prompt "Save variable" "all"))))
(let (calc-pv-pos)
(and var (or (and (boundp var) (symbol-value var))
(error "No such variable")))
diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el
index fd6f3a7b67b..f6d749db117 100644
--- a/lisp/calc/calc-units.el
+++ b/lisp/calc/calc-units.el
@@ -486,18 +486,13 @@ If COMP or STD is non-nil, put that in the units table instead."
(setq defunits (math-get-default-units expr))
(unless new-units
(setq new-units
- (read-string (concat
+ (read-string (format-prompt
(if (and uoldname (not nouold))
(concat "Old units: "
uoldname
", new units")
"New units")
- (if defunits
- (concat
- " (default "
- defunits
- "): ")
- ": "))))
+ defunits)))
(if (and
(string= new-units "")
defunits)
@@ -533,14 +528,7 @@ If COMP or STD is non-nil, put that in the units table instead."
(let* ((old-units (math-extract-units expr))
(defunits (math-get-default-units expr))
units
- (new-units
- (read-string (concat "New units"
- (if defunits
- (concat
- " (default "
- defunits
- "): ")
- ": ")))))
+ (new-units (read-string (format-prompt "New units" defunits))))
(if (and
(string= new-units "")
defunits)
@@ -596,19 +584,14 @@ If COMP or STD is non-nil, put that in the units table instead."
(setq expr (math-mul expr uold)))
(setq defunits (math-get-default-units expr))
(setq unew (or new-units
- (completing-read
- (concat
- (if uoldname
- (concat "Old temperature units: "
- uoldname
- ", new units")
- "New temperature units")
- (if defunits
- (concat " (default "
- defunits
- "): ")
- ": "))
- tempunits)))
+ (completing-read (format-prompt
+ (if uoldname
+ (concat "Old temperature units: "
+ uoldname
+ ", new units")
+ "New temperature units")
+ defunits)
+ tempunits)))
(setq unew (math-read-expr (if (string= unew "") defunits unew)))
(when (eq (car-safe unew) 'error)
(error "Bad format in units expression: %s" (nth 2 unew)))
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el
index e97315165b3..d426e2829f8 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -494,7 +494,7 @@ This setting only applies to floats in normal display mode.")
(defmacro defcalcmodevar (var defval &optional doc)
"Declare VAR as a Calc variable, with default value DEFVAL and doc-string DOC.
The variable VAR will be added to `calc-mode-var-list'."
- (declare (doc-string 3))
+ (declare (doc-string 3) (indent defun))
`(progn
(defvar ,var ,defval ,doc)
(add-to-list 'calc-mode-var-list (list (quote ,var) ,defval))))
@@ -1621,7 +1621,8 @@ See calc-keypad for details."
(stringp (nth 1 err))
(string-match "max-specpdl-size\\|max-lisp-eval-depth"
(nth 1 err)))
- (error "Computation got stuck or ran too long. Type `M' to increase the limit")
+ (error (substitute-command-keys
+ "Computation got stuck or ran too long. Type \\`M' to increase the limit"))
(setq calc-aborted-prefix nil)
(signal (car err) (cdr err)))))
(when calc-aborted-prefix
@@ -3439,7 +3440,7 @@ The prefix `calcFunc-' is added to the specified name to get the
actual Lisp function name.
See Info node `(calc)Defining Functions'."
- (declare (doc-string 3)) ;; FIXME: Edebug spec?
+ (declare (doc-string 3) (indent defun)) ;; FIXME: Edebug spec?
(require 'calc-ext)
(math-do-defmath func args body))
diff --git a/lisp/calculator.el b/lisp/calculator.el
index 6bcea2d885e..0c255c0cf9d 100644
--- a/lisp/calculator.el
+++ b/lisp/calculator.el
@@ -593,15 +593,15 @@ except when using a non-decimal radix mode for input (in this case `e'
will be the hexadecimal digit).
Here are the editing keys:
-* `RET' `=' evaluate the current expression
-* `C-insert' copy the whole current expression to the `kill-ring'
-* `C-return' evaluate, save result the `kill-ring' and exit
-* `insert' paste a number if the one was copied (normally)
-* `delete' `C-d' clear last argument or whole expression (hit twice)
-* `backspace' delete a digit or a previous expression element
-* `h' `?' pop-up a quick reference help
-* `ESC' `q' exit (`ESC' can be used if `calculator-bind-escape' is
- non-nil, otherwise use three consecutive `ESC's)
+* \\`RET' \\`=' evaluate the current expression
+* \\`C-<insert>' copy the whole current expression to the `kill-ring'
+* \\`C-<return>' evaluate, save result the `kill-ring' and exit
+* \\`<insert>' paste a number if the one was copied (normally)
+* \\`<delete>' \\`C-d' clear last argument or whole expression (hit twice)
+* \\`<backspace>' delete a digit or a previous expression element
+* \\`h' \\`?' pop-up a quick reference help
+* \\`ESC' \\`q' exit (\\`ESC' can be used if `calculator-bind-escape' is
+ non-nil, otherwise use three consecutive \\`ESC's)
These operators are pre-defined:
* `+' `-' `*' `/' the common binary operators
@@ -623,10 +623,10 @@ argument.
hex/oct/bin modes can be set for input and for display separately.
Another toggle-able mode is for using degrees instead of radians for
trigonometric functions.
-The keys to switch modes are (both `H' and `X' are for hex):
-* `D' switch to all-decimal mode, or toggle degrees/radians
-* `B' `O' `H' `X' binary/octal/hexadecimal modes for input & display
-* `i' `o' followed by one of `D' `B' `O' `H' `X' (case
+The keys to switch modes are (both \\`H' and \\`X' are for hex):
+* \\`D' switch to all-decimal mode, or toggle degrees/radians
+* \\`B' \\`O' \\`H' \\`X' binary/octal/hexadecimal modes for input & display
+* \\`i' \\`o' followed by one of \\`D' \\`B' \\`O' \\`H' \\`X' (case
insensitive) sets only the input or display radix mode
The prompt indicates the current modes:
* \"==\": decimal mode (using radians);
@@ -649,17 +649,17 @@ collected data. It is possible to navigate in this list, and if the
value shown is the current one on the list, an indication is displayed
as \"[N]\" if this is the last number and there are N numbers, or
\"[M/N]\" if the M-th value is shown.
-* `SPC' evaluate the current value as usual, but also adds
+* \\`SPC' evaluate the current value as usual, but also adds
the result to the list of saved values
-* `l' `v' computes total / average of saved values
-* `up' `C-p' browse to the previous value in the list
-* `down' `C-n' browse to the next value in the list
-* `delete' `C-d' remove current value from the list (if it is on it)
-* `C-delete' `C-c' delete the whole list
+* \\`l' \\`v' computes total / average of saved values
+* \\`<up>' \\`C-p' browse to the previous value in the list
+* \\`<down>' \\`C-n' browse to the next value in the list
+* \\`<delete>' \\`C-d' remove current value from the list (if it is on it)
+* \\`C-<delete>' \\`C-c' delete the whole list
Registers are variable-like place-holders for values:
-* `s' followed by a character attach the current value to that character
-* `g' followed by a character fetches the attached value
+* \\`s' followed by a character attach the current value to that character
+* \\`g' followed by a character fetches the attached value
There are many variables that can be used to customize the calculator.
Some interesting customization variables are:
diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el
index 2d31101e50e..15778ea14bc 100644
--- a/lisp/calendar/icalendar.el
+++ b/lisp/calendar/icalendar.el
@@ -644,13 +644,13 @@ FIXME: multiple comma-separated values should be allowed!"
;; seconds present
(setq second (read (substring isodatetimestring 13 15))))
;; FIXME: Support subseconds.
- (when (and (> (length isodatetimestring) 15)
- ;; UTC specifier present
- (char-equal ?Z (aref isodatetimestring 15)))
- (setq source-zone t
- ;; decode to local time unless result-zone is explicitly given,
- ;; i.e. do not decode to UTC, i.e. do not (setq result-zone t)
- ))
+ (when (> (length isodatetimestring) 15)
+ (pcase (aref isodatetimestring 15)
+ (?Z
+ (setq source-zone t))
+ ((or ?- ?+)
+ (setq source-zone
+ (concat "UTC" (substring isodatetimestring 15))))))
;; shift if necessary
(if day-shift
(let ((mdy (calendar-gregorian-from-absolute
diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el
index 0aa38166bc1..b36171259c0 100644
--- a/lisp/calendar/time-date.el
+++ b/lisp/calendar/time-date.el
@@ -69,7 +69,7 @@ list (HIGH LOW MICRO PICO)."
(pop elt)))
(time-value (car elt))
(gensym (make-symbol "time")))
- `(let* ,(append `((,gensym (or ,time-value (current-time)))
+ `(let* ,(append `((,gensym (or ,time-value (time-convert nil 'list)))
(,gensym
(cond
((integerp ,gensym)
@@ -154,7 +154,10 @@ it is assumed that PICO was omitted and should be treated as zero."
DATE should be in one of the forms recognized by `parse-time-string'.
If DATE lacks timezone information, GMT is assumed."
(condition-case err
- (encode-time (parse-time-string date))
+ (let ((parsed (parse-time-string date)))
+ (when (decoded-time-year parsed)
+ (decoded-time-set-defaults parsed))
+ (encode-time parsed))
(error
(let ((overflow-error '(error "Specified time is not representable")))
(if (equal err overflow-error)
@@ -406,7 +409,11 @@ entries only for the values that should be altered.
For instance, if you want to \"add two months\" to TIME, then
leave all other fields but the month field in DELTA nil, and make
-the month field 2. The values in DELTA can be negative.
+the month field 2. For instance:
+
+ (decoded-time-add (decode-time) (make-decoded-time :month 2))
+
+The values in DELTA can be negative.
If applying a month/year delta leaves the time spec invalid, it
is decreased to be valid (\"add one month\" to January 31st 2019
diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el
index 18fb05e7eb4..e0717fbfe5a 100644
--- a/lisp/cedet/mode-local.el
+++ b/lisp/cedet/mode-local.el
@@ -156,7 +156,7 @@ local variables have been defined."
DOCSTRING is optional and not used.
To work properly, this should be put after PARENT mode local variables
definition."
- (declare (obsolete define-derived-mode "27.1"))
+ (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)
@@ -567,6 +567,7 @@ appropriate arguments deduced from ARGS.
OVERARGS is a list of arguments passed to the override and
`NAME-default' function, in place of those deduced from ARGS."
(declare (doc-string 3)
+ (indent defun)
(debug (&define name lambda-list stringp def-body)))
`(eval-and-compile
(defun ,name ,args
@@ -595,6 +596,7 @@ DOCSTRING is the documentation string.
BODY is the implementation of this function."
;; FIXME: Make this obsolete and use cl-defmethod with &context instead.
(declare (doc-string 4)
+ (indent defun)
(debug (&define name symbolp lambda-list stringp def-body)))
(let ((newname (intern (format "%s-%s" name mode))))
`(progn
diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el
index c7d59def1f1..19e2fee2bac 100644
--- a/lisp/cedet/semantic/bovine/c.el
+++ b/lisp/cedet/semantic/bovine/c.el
@@ -1466,36 +1466,32 @@ Override function for `semantic-tag-protection'."
(prot nil))
;; Check the modifiers for protection if we are not a child
;; of some class type.
- (when (or (not parent) (not (eq (semantic-tag-class parent) 'type)))
- (while (and (not prot) mods)
- (if (stringp (car mods))
- (let ((s (car mods)))
- ;; A few silly defaults to get things started.
- (cond ((or (string= s "extern")
- (string= s "export"))
- 'public)
- ((string= s "static")
- 'private))))
- (setq mods (cdr mods))))
- ;; If we have a typed parent, look for :public style labels.
- (when (and parent (eq (semantic-tag-class parent) 'type))
+ (if (not (and parent (eq (semantic-tag-class parent) 'type)))
+ (while (and (not prot) mods)
+ (if (stringp (car mods))
+ (let ((s (car mods)))
+ ;; A few silly defaults to get things started.
+ (setq prot (pcase s
+ ((or "extern" "export") 'public)
+ ("static" 'private)))))
+ (setq mods (cdr mods)))
+ ;; If we have a typed parent, look for :public style labels.
(let ((pp (semantic-tag-type-members parent)))
(while (and pp (not (semantic-equivalent-tag-p (car pp) tag)))
(when (eq (semantic-tag-class (car pp)) 'label)
(setq prot
- (cond ((string= (semantic-tag-name (car pp)) "public")
- 'public)
- ((string= (semantic-tag-name (car pp)) "private")
- 'private)
- ((string= (semantic-tag-name (car pp)) "protected")
- 'protected)))
+ (pcase (semantic-tag-name (car pp))
+ ("public" 'public)
+ ("private" 'private)
+ ("protected" 'protected)))
)
(setq pp (cdr pp)))))
(when (and (not prot) (eq (semantic-tag-class parent) 'type))
(setq prot
- (cond ((string= (semantic-tag-type parent) "class") 'private)
- ((string= (semantic-tag-type parent) "struct") 'public)
- (t 'unknown))))
+ (pcase (semantic-tag-type parent)
+ ("class" 'private)
+ ("struct" 'public)
+ (_ 'unknown))))
(or prot
(if (and parent (semantic-tag-of-class-p parent 'type))
'public
diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el
index 6cfbdd5f03f..375b97a7a5d 100644
--- a/lisp/cedet/semantic/complete.el
+++ b/lisp/cedet/semantic/complete.el
@@ -224,11 +224,10 @@ HISTORY is a symbol representing a variable to story the history in."
;; @todo - move from () to into the editable area
(if (string-match ":" prompt)
- (setq prompt (concat
- (substring prompt 0 (match-beginning 0))
- " (default " default-as-string ")"
- (substring prompt (match-beginning 0))))
- (setq prompt (concat prompt " (" default-as-string "): "))))
+ (setq prompt (format-prompt
+ (substring prompt 0 (match-beginning 0))
+ default-as-string))
+ (setq prompt (format-prompt prompt default-as-string))))
;;
;; Perform the Completion
;;
diff --git a/lisp/cedet/semantic/decorate/mode.el b/lisp/cedet/semantic/decorate/mode.el
index 6271fb1ced6..0a234b3000d 100644
--- a/lisp/cedet/semantic/decorate/mode.el
+++ b/lisp/cedet/semantic/decorate/mode.el
@@ -391,6 +391,7 @@ etc., found in the semantic-decorate library.
To add other kind of decorations on a tag, `NAME-highlight' must use
`semantic-decorate-tag', and other functions of the semantic
decoration API found in this library."
+ (declare (indent 1))
(let ((predicate (semantic-decorate-style-predicate name))
(highlighter (semantic-decorate-style-highlighter name))
(predicatedef (semantic-decorate-style-predicate-default name))
diff --git a/lisp/cedet/semantic/dep.el b/lisp/cedet/semantic/dep.el
index 0694b9c2329..cae38e6f111 100644
--- a/lisp/cedet/semantic/dep.el
+++ b/lisp/cedet/semantic/dep.el
@@ -82,6 +82,7 @@ users will customize.
Creates a customizable variable users can customize that will
keep semantic data structures up to date."
+ (declare (indent defun))
`(progn
;; Create a variable users can customize.
(defcustom ,name ,value
diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el
index 16e8ce8de95..3502cda500e 100644
--- a/lisp/cedet/semantic/fw.el
+++ b/lisp/cedet/semantic/fw.el
@@ -66,8 +66,6 @@
(defalias 'semantic-mode-line-update #'force-mode-line-update)
-;; Since Emacs 22 major mode functions should use `run-mode-hooks' to
-;; run major mode hooks.
(define-obsolete-function-alias 'semantic-run-mode-hooks #'run-mode-hooks "28.1")
;; Fancy compat usage now handled in cedet-compat
diff --git a/lisp/cedet/semantic/grm-wy-boot.el b/lisp/cedet/semantic/grm-wy-boot.el
index a6bf211713a..ce63421fb37 100644
--- a/lisp/cedet/semantic/grm-wy-boot.el
+++ b/lisp/cedet/semantic/grm-wy-boot.el
@@ -149,10 +149,10 @@
((type_decl))
((use_macros_decl)))
(default_prec_decl
- ((DEFAULT-PREC)
- `(wisent-raw-tag
- (semantic-tag "default-prec" 'assoc :value
- '("t")))))
+ ((DEFAULT-PREC)
+ `(wisent-raw-tag
+ (semantic-tag "default-prec" 'assoc :value
+ '("t")))))
(no_default_prec_decl
((NO-DEFAULT-PREC)
`(wisent-raw-tag
diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el
index 8073640a8bd..3297367db90 100644
--- a/lisp/cedet/semantic/lex-spp.el
+++ b/lisp/cedet/semantic/lex-spp.el
@@ -1165,7 +1165,8 @@ of type `spp-macro-def' is to be created.
VALFORM are forms that return the value to be saved for this macro, or nil.
When implementing a macro, you can use `semantic-lex-spp-stream-for-macro'
to convert text into a lexical stream for storage in the macro."
- (declare (debug (&define name stringp stringp form def-body)))
+ (declare (debug (&define name stringp stringp form def-body))
+ (indent 1))
(let ((start (make-symbol "start"))
(end (make-symbol "end"))
(val (make-symbol "val"))
@@ -1199,7 +1200,8 @@ REGEXP is a regular expression for the analyzer to match.
See `define-lex-regex-analyzer' for more on regexp.
TOKIDX is an index into REGEXP for which a new lexical token
of type `spp-macro-undef' is to be created."
- (declare (debug (&define name stringp stringp form)))
+ (declare (debug (&define name stringp stringp form))
+ (indent 1))
(let ((start (make-symbol "start"))
(end (make-symbol "end")))
`(define-lex-regex-analyzer ,name
@@ -1260,7 +1262,8 @@ type of include. The return value should be of the form:
(NAME . TYPE)
where NAME is the name of the include, and TYPE is the type of the include,
where a valid symbol is `system', or nil."
- (declare (debug (&define name stringp stringp form def-body)))
+ (declare (debug (&define name stringp stringp form def-body))
+ (indent 1))
(let ((start (make-symbol "start"))
(end (make-symbol "end"))
(val (make-symbol "val"))
diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el
index 69f20deeb76..d524b733db5 100644
--- a/lisp/cedet/semantic/lex.el
+++ b/lisp/cedet/semantic/lex.el
@@ -760,7 +760,7 @@ If two analyzers can match the same text, it is important to order the
analyzers so that the one you want to match first occurs first. For
example, it is good to put a number analyzer in front of a symbol
analyzer which might mistake a number for a symbol."
- (declare (debug (&define name stringp (&rest symbolp))))
+ (declare (debug (&define name stringp (&rest symbolp))) (indent 1))
`(defun ,name (start end &optional depth length)
,(concat doc "\nSee `semantic-lex' for more information.")
;; Make sure the state of block parsing starts over.
@@ -1096,7 +1096,7 @@ Proper action in FORMS is to move the value of `semantic-lex-end-point' to
after the location of the analyzed entry, and to add any discovered tokens
at the beginning of `semantic-lex-token-stream'.
This can be done by using `semantic-lex-push-token'."
- (declare (debug (&define name stringp form def-body)))
+ (declare (debug (&define name stringp form def-body)) (indent 1))
`(eval-and-compile
;; This is the real info used by `define-lex' (via semantic-lex-one-token).
(defconst ,name '(,condition ,@forms) ,doc)
@@ -1118,7 +1118,7 @@ This can be done by using `semantic-lex-push-token'."
"Create a lexical analyzer with NAME and DOC that will match REGEXP.
FORMS are evaluated upon a successful match.
See `define-lex-analyzer' for more about analyzers."
- (declare (debug (&define name stringp form def-body)))
+ (declare (debug (&define name stringp form def-body)) (indent 1))
`(define-lex-analyzer ,name
,doc
(looking-at ,regexp)
@@ -1137,7 +1137,8 @@ FORMS are evaluated upon a successful match BEFORE the new token is
created. It is valid to ignore FORMS.
See `define-lex-analyzer' for more about analyzers."
(declare (debug
- (&define name stringp form symbolp [ &optional form ] def-body)))
+ (&define name stringp form symbolp [ &optional form ] def-body))
+ (indent 1))
`(define-lex-analyzer ,name
,doc
(looking-at ,regexp)
@@ -1162,7 +1163,8 @@ where BLOCK-SYM is the symbol returned in a block token. OPEN-DELIM
and CLOSE-DELIM are respectively the open and close delimiters
identifying a block. OPEN-SYM and CLOSE-SYM are respectively the
symbols returned in open and close tokens."
- (declare (debug (&define name stringp form (&rest form))))
+ (declare (debug (&define name stringp form (&rest form)))
+ (indent 1))
(let ((specs (cons spec1 specs))
spec open olist clist)
(while specs
@@ -1471,6 +1473,7 @@ syntax as specified by the syntax table."
(defmacro define-lex-keyword-type-analyzer (name doc syntax)
"Define a keyword type analyzer NAME with DOC string.
SYNTAX is the regexp that matches a keyword syntactic expression."
+ (declare (indent 1))
(let ((key (make-symbol "key")))
`(define-lex-analyzer ,name
,doc
@@ -1486,6 +1489,7 @@ SYNTAX is the regexp that matches a keyword syntactic expression."
"Define a sexp type analyzer NAME with DOC string.
SYNTAX is the regexp that matches the beginning of the s-expression.
TOKEN is the lexical token returned when SYNTAX matches."
+ (declare (indent 1))
`(define-lex-regex-analyzer ,name
,doc
,syntax
@@ -1504,6 +1508,7 @@ SYNTAX is the regexp that matches a syntactic expression.
MATCHES is an alist of lexical elements used to refine the syntactic
expression.
DEFAULT is the default lexical token returned when no MATCHES."
+ (declare (indent 1))
(if matches
(let* ((val (make-symbol "val"))
(lst (make-symbol "lst"))
@@ -1536,6 +1541,7 @@ SYNTAX is the regexp that matches a syntactic expression.
MATCHES is an alist of lexical elements used to refine the syntactic
expression.
DEFAULT is the default lexical token returned when no MATCHES."
+ (declare (indent 1))
(if matches
(let* ((val (make-symbol "val"))
(lst (make-symbol "lst"))
@@ -1633,6 +1639,7 @@ When the lexer encounters the open-paren delimiter \"(\":
- If the maximum depth of parenthesis tracking is reached (current
depth >= max depth), it returns the whole parenthesis block as
a (PAREN_BLOCK start . end) token."
+ (declare (indent 1))
(let* ((val (make-symbol "val"))
(lst (make-symbol "lst"))
(elt (make-symbol "elt")))
diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el
index f5f381d4079..afcdd142822 100644
--- a/lisp/cedet/semantic/wisent.el
+++ b/lisp/cedet/semantic/wisent.el
@@ -66,7 +66,7 @@ Returned tokens must have the form:
(TOKSYM VALUE START . END)
where VALUE is the buffer substring between START and END positions."
- (declare (debug (&define name stringp def-body)))
+ (declare (debug (&define name stringp def-body)) (indent 1))
`(defun
,name () ,doc
(cond
diff --git a/lisp/char-fold.el b/lisp/char-fold.el
index e3ab7d5b64c..b8e3d2f6791 100644
--- a/lisp/char-fold.el
+++ b/lisp/char-fold.el
@@ -26,6 +26,7 @@
(eval-and-compile
(put 'char-fold-table 'char-table-extra-slots 1)
+ (defconst char-fold--default-override nil)
(defconst char-fold--default-include
'((?\" """ "“" "”" "”" "„" "⹂" "〞" "‟" "‟" "❞" "❝" "❠" "“" "„" "〝" "〟" "🙷" "🙶" "🙸" "«" "»")
(?' "❟" "❛" "❜" "‘" "’" "‚" "‛" "‚" "󠀢" "❮" "❯" "‹" "›")
@@ -40,7 +41,8 @@
))
(defconst char-fold--default-symmetric nil)
(defvar char-fold--previous
- (list char-fold--default-include
+ (list char-fold--default-override
+ char-fold--default-include
char-fold--default-exclude
char-fold--default-symmetric)))
@@ -67,48 +69,50 @@
;; - A single char of the decomp might be allowed to match the
;; character.
;; Some examples in the comments below.
- (map-char-table
- (lambda (char decomp)
- (when (consp decomp)
- ;; Skip trivial cases like ?a decomposing to (?a).
- (unless (and (not (cdr decomp))
- (eq char (car decomp)))
- (if (symbolp (car decomp))
- ;; Discard a possible formatting tag.
- (setq decomp (cdr decomp))
- ;; If there's no formatting tag, ensure that char matches
- ;; its decomp exactly. This is because we want 'ä' to
- ;; match 'ä', but we don't want '¹' to match '1'.
- (aset equiv char
- (cons (apply #'string decomp)
- (aref equiv char))))
-
- ;; Allow the entire decomp to match char. If decomp has
- ;; multiple characters, this is done by adding an entry
- ;; to the alist of the first character in decomp. This
- ;; allows 'ff' to match 'ff', 'ä' to match 'ä', and '1' to
- ;; match '¹'.
- (let ((make-decomp-match-char
- (lambda (decomp char)
- (if (cdr decomp)
- (aset equiv-multi (car decomp)
- (cons (cons (apply #'string (cdr decomp))
- (regexp-quote (string char)))
- (aref equiv-multi (car decomp))))
- (aset equiv (car decomp)
- (cons (char-to-string char)
- (aref equiv (car decomp))))))))
- (funcall make-decomp-match-char decomp char)
- ;; Check to see if the first char of the decomposition
- ;; has a further decomposition. If so, add a mapping
- ;; back from that second decomposition to the original
- ;; character. This allows e.g. 'ι' (GREEK SMALL LETTER
- ;; IOTA) to match both the Basic Greek block and
- ;; Extended Greek block variants of IOTA +
- ;; diacritical(s). Repeat until there are no more
- ;; decompositions.
- (let ((dec decomp)
- next-decomp)
+ (unless (or (bound-and-true-p char-fold-override)
+ char-fold--default-override)
+ (map-char-table
+ (lambda (char decomp)
+ (when (consp decomp)
+ ;; Skip trivial cases like ?a decomposing to (?a).
+ (unless (and (not (cdr decomp))
+ (eq char (car decomp)))
+ (if (symbolp (car decomp))
+ ;; Discard a possible formatting tag.
+ (setq decomp (cdr decomp))
+ ;; If there's no formatting tag, ensure that char matches
+ ;; its decomp exactly. This is because we want 'ä' to
+ ;; match 'ä', but we don't want '¹' to match '1'.
+ (aset equiv char
+ (cons (apply #'string decomp)
+ (aref equiv char))))
+
+ ;; Allow the entire decomp to match char. If decomp has
+ ;; multiple characters, this is done by adding an entry
+ ;; to the alist of the first character in decomp. This
+ ;; allows 'ff' to match 'ff', 'ä' to match 'ä', and '1' to
+ ;; match '¹'.
+ (let ((make-decomp-match-char
+ (lambda (decomp char)
+ (if (cdr decomp)
+ (aset equiv-multi (car decomp)
+ (cons (cons (apply #'string (cdr decomp))
+ (regexp-quote (string char)))
+ (aref equiv-multi (car decomp))))
+ (aset equiv (car decomp)
+ (cons (char-to-string char)
+ (aref equiv (car decomp))))))))
+ (funcall make-decomp-match-char decomp char)
+ ;; Check to see if the first char of the decomposition
+ ;; has a further decomposition. If so, add a mapping
+ ;; back from that second decomposition to the original
+ ;; character. This allows e.g. 'ι' (GREEK SMALL LETTER
+ ;; IOTA) to match both the Basic Greek block and
+ ;; Extended Greek block variants of IOTA +
+ ;; diacritical(s). Repeat until there are no more
+ ;; decompositions.
+ (let ((dec decomp)
+ next-decomp)
(while dec
(setq next-decomp (char-table-range table (car dec)))
(when (consp next-decomp)
@@ -118,24 +122,24 @@
(car next-decomp)))
(funcall make-decomp-match-char (list (car next-decomp)) char)))
(setq dec next-decomp)))
- ;; Do it again, without the non-spacing characters.
- ;; This allows 'a' to match 'ä'.
- (let ((simpler-decomp nil)
- (found-one nil))
- (dolist (c decomp)
- (if (> (get-char-code-property c 'canonical-combining-class) 0)
- (setq found-one t)
- (push c simpler-decomp)))
- (when (and simpler-decomp found-one)
- (funcall make-decomp-match-char simpler-decomp char)
- ;; Finally, if the decomp only had one spacing
- ;; character, we allow this character to match the
- ;; decomp. This is to let 'a' match 'ä'.
- (unless (cdr simpler-decomp)
- (aset equiv (car simpler-decomp)
- (cons (apply #'string decomp)
- (aref equiv (car simpler-decomp)))))))))))
- table)
+ ;; Do it again, without the non-spacing characters.
+ ;; This allows 'a' to match 'ä'.
+ (let ((simpler-decomp nil)
+ (found-one nil))
+ (dolist (c decomp)
+ (if (> (get-char-code-property c 'canonical-combining-class) 0)
+ (setq found-one t)
+ (push c simpler-decomp)))
+ (when (and simpler-decomp found-one)
+ (funcall make-decomp-match-char simpler-decomp char)
+ ;; Finally, if the decomp only had one spacing
+ ;; character, we allow this character to match the
+ ;; decomp. This is to let 'a' match 'ä'.
+ (unless (cdr simpler-decomp)
+ (aset equiv (car simpler-decomp)
+ (cons (apply #'string decomp)
+ (aref equiv (car simpler-decomp)))))))))))
+ table))
;; Add some entries to default decomposition
(dolist (it (or (bound-and-true-p char-fold-include)
@@ -232,7 +236,9 @@ Exceptionally for the space character (32), ALIST is ignored.")
(defun char-fold-update-table ()
"Update char-fold-table only when one of the options changes its value."
- (let ((new (list (or (bound-and-true-p char-fold-include)
+ (let ((new (list (or (bound-and-true-p char-fold-override)
+ char-fold--default-override)
+ (or (bound-and-true-p char-fold-include)
char-fold--default-include)
(or (bound-and-true-p char-fold-exclude)
char-fold--default-exclude)
@@ -242,6 +248,22 @@ Exceptionally for the space character (32), ALIST is ignored.")
(setq char-fold-table (char-fold--make-table)
char-fold--previous new))))
+(defcustom char-fold-override char-fold--default-override
+ "Non-nil means to override the default definitions of equivalent characters.
+When nil (the default), the table of character equivalences used
+for character-folding is populated with the default set of equivalent
+characters; customize `char-fold-exclude' to remove unneeded equivalences,
+and `char-fold-include' to add your own.
+When this variable is non-nil, the table of equivalences starts empty,
+and you can add your own equivalences by customizing `char-fold-include'."
+ :type 'boolean
+ :initialize #'custom-initialize-default
+ :set (lambda (sym val)
+ (custom-set-default sym val)
+ (char-fold-update-table))
+ :group 'isearch
+ :version "29.1")
+
(defcustom char-fold-include char-fold--default-include
"Additional character foldings to include.
Each entry is a list of a character and the strings that fold into it."
diff --git a/lisp/cmuscheme.el b/lisp/cmuscheme.el
index e197069d6b8..47113ad8c2e 100644
--- a/lisp/cmuscheme.el
+++ b/lisp/cmuscheme.el
@@ -245,7 +245,8 @@ Search in the directories \"~\" and `user-emacs-directory',
in this order. Return nil if no start file found."
(let* ((progname (file-name-nondirectory prog))
(start-file (concat "~/.emacs_" progname))
- (alt-start-file (concat user-emacs-directory "init_" progname ".scm")))
+ (alt-start-file (locate-user-emacs-file
+ (concat "init_" progname ".scm"))))
(if (file-exists-p start-file)
start-file
(and (file-exists-p alt-start-file) alt-start-file))))
diff --git a/lisp/comint.el b/lisp/comint.el
index a0873c0b6a1..3decb80ff0b 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -385,10 +385,12 @@ This variable is buffer-local."
"\\(?: [[:alpha:]]+ .+\\)?[[:blank:]]*[::៖][[:space:]]*\\'"
;; The ccrypt encryption dialogue doesn't end with a colon, so
;; treat it specially.
- "\\|^Enter encryption key: (repeat) *\\'")
+ "\\|^Enter encryption key: (repeat) *\\'"
+ ;; openssh-8.6p1 format: "(user@host) Password:".
+ "\\|^([^)@ \t\n]+@[^)@ \t\n]+) Password: *\\'")
"Regexp matching prompts for passwords in the inferior process.
This is used by `comint-watch-for-password-prompt'."
- :version "28.1"
+ :version "29.1"
:type 'regexp
:group 'comint)
@@ -728,6 +730,8 @@ Entry to this mode runs the hooks on `comint-mode-hook'."
(or (file-remote-p default-directory) ""))
(setq-local comint-accum-marker (make-marker))
(setq-local font-lock-defaults '(nil t))
+ (add-function :filter-return (local 'filter-buffer-substring-function)
+ #'comint--unmark-string-as-output)
(add-hook 'change-major-mode-hook 'font-lock-defontify nil t)
(add-hook 'isearch-mode-hook 'comint-history-isearch-setup nil t)
(add-hook 'completion-at-point-functions 'comint-completion-at-point nil t)
@@ -889,12 +893,13 @@ series of processes in the same Comint buffer. The hook
;; and there is no way for us to define it here.
;; Some programs that use terminfo get very confused
;; if TERM is not a valid terminal type.
- (if (and (boundp 'system-uses-terminfo) system-uses-terminfo)
- (list (format "TERM=%s" comint-terminfo-terminal)
- "TERMCAP="
- (format "COLUMNS=%d" (window-width)))
- (list "TERM=emacs"
- (format "TERMCAP=emacs:co#%d:tc=unknown:" (window-width)))))
+ (with-connection-local-variables
+ (if system-uses-terminfo
+ (list (format "TERM=%s" comint-terminfo-terminal)
+ "TERMCAP="
+ (format "COLUMNS=%d" (window-width)))
+ (list "TERM=emacs"
+ (format "TERMCAP=emacs:co#%d:tc=unknown:" (window-width))))))
(defun comint-nonblank-p (str)
"Return non-nil if STR contains non-whitespace syntax."
@@ -1812,7 +1817,8 @@ Ignore duplicates if `comint-input-ignoredups' is non-nil."
(ring-insert comint-input-ring cmd)))
(defconst comint--prompt-rear-nonsticky
- '(field inhibit-line-move-field-capture read-only font-lock-face)
+ '( field inhibit-line-move-field-capture read-only font-lock-face
+ insert-in-front-hooks)
"Text properties we set on the prompt and don't want to leak past it.")
(defun comint-send-input (&optional no-newline artificial)
@@ -1904,6 +1910,14 @@ Similarly for Soar, Scheme, etc."
(delete-region pmark start)
copy))))
+ ;; Delete and reinsert input. This seems like a no-op, except
+ ;; for the resulting entries in the undo list: undoing this
+ ;; insertion will delete the region, moving the process mark
+ ;; back to its original position.
+ (let ((inhibit-read-only t))
+ (delete-region pmark (point))
+ (insert input))
+
(unless no-newline
(insert ?\n))
@@ -1947,7 +1961,7 @@ Similarly for Soar, Scheme, etc."
;; in case we get output amidst sending the input.
(set-marker comint-last-input-start pmark)
(set-marker comint-last-input-end (point))
- (set-marker (process-mark proc) (point))
+ (set-marker pmark (point))
;; clear the "accumulation" marker
(set-marker comint-accum-marker nil)
(let ((comint-input-sender-no-newline no-newline))
@@ -2022,7 +2036,7 @@ the start, the cdr to the end of the last prompt recognized.")
Freezes the `font-lock-face' text property in place."
(when comint-last-prompt
(with-silent-modifications
- (font-lock-prepend-text-property
+ (font-lock-append-text-property
(car comint-last-prompt)
(cdr comint-last-prompt)
'font-lock-face 'comint-highlight-prompt))
@@ -2141,14 +2155,7 @@ Make backspaces delete the previous character."
(goto-char (process-mark process)) ; In case a filter moved it.
(unless comint-use-prompt-regexp
- (with-silent-modifications
- (add-text-properties comint-last-output-start (point)
- `(rear-nonsticky
- ,comint--prompt-rear-nonsticky
- front-sticky
- (field inhibit-line-move-field-capture)
- field output
- inhibit-line-move-field-capture t))))
+ (comint--mark-as-output comint-last-output-start (point)))
;; Highlight the prompt, where we define `prompt' to mean
;; the most recent output that doesn't end with a newline.
@@ -2180,6 +2187,46 @@ Make backspaces delete the previous character."
,comint--prompt-rear-nonsticky)))
(goto-char saved-point)))))))
+(defun comint--mark-as-output (beg end)
+ (with-silent-modifications
+ (add-text-properties
+ beg end
+ `(rear-nonsticky
+ ,comint--prompt-rear-nonsticky
+ front-sticky
+ (field inhibit-line-move-field-capture)
+ field output
+ inhibit-line-move-field-capture t
+ ;; 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
+ (,#'comint--mark-as-output ,#'comint--mark-yanked-as-output)))))
+
+(defun comint--mark-yanked-as-output (beg end)
+ ;; `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'.
+ (let (fun)
+ (setq
+ fun
+ (lambda (beg1 end1 _len1)
+ (remove-hook 'after-change-functions fun t)
+ (when (and (= beg beg1)
+ (= end end1))
+ (comint--mark-as-output beg1 end1))))
+ (add-hook 'after-change-functions fun nil t)))
+
+(defun comint--unmark-string-as-output (string)
+ (remove-list-of-text-properties
+ 0 (length string)
+ '( rear-nonsticky front-sticky field
+ inhibit-line-move-field-capture insert-in-front-hooks)
+ string)
+ string)
+
(defun comint-preinput-scroll-to-bottom ()
"Go to the end of buffer in all windows showing it.
Movement occurs if point in the selected window is not after the process mark,
@@ -2455,11 +2502,19 @@ This function could be in the list `comint-output-filter-functions'."
(when (let ((case-fold-search t))
(string-match comint-password-prompt-regexp
(string-replace "\r" "" string)))
- (let ((comint--prompt-recursion-depth (1+ comint--prompt-recursion-depth)))
- (if (> comint--prompt-recursion-depth 10)
- (message "Password prompt recursion too deep")
- (comint-send-invisible
- (string-trim string "[ \n\r\t\v\f\b\a]+" "\n+"))))))
+ ;; Use `run-at-time' in order not to pause execution of the
+ ;; process filter with a minibuffer
+ (run-at-time
+ 0 nil
+ (lambda (current-buf)
+ (with-current-buffer current-buf
+ (let ((comint--prompt-recursion-depth
+ (1+ comint--prompt-recursion-depth)))
+ (if (> comint--prompt-recursion-depth 10)
+ (message "Password prompt recursion too deep")
+ (comint-send-invisible
+ (string-trim string "[ \n\r\t\v\f\b\a]+" "\n+"))))))
+ (current-buffer))))
;; Low-level process communication
@@ -3509,6 +3564,20 @@ to send all the accumulated input, at once.
The entire accumulated text becomes one item in the input history
when you send it."
(interactive)
+ (when-let* ((proc (get-buffer-process (current-buffer)))
+ (pmark (process-mark proc))
+ ((or (marker-position comint-accum-marker)
+ (set-marker comint-accum-marker pmark)
+ t))
+ ((>= (point) comint-accum-marker pmark)))
+ ;; Delete and reinsert input. This seems like a no-op, except for
+ ;; the resulting entries in the undo list: undoing this insertion
+ ;; will delete the region, moving the accumulation marker back to
+ ;; its original position.
+ (let ((text (buffer-substring comint-accum-marker (point)))
+ (inhibit-read-only t))
+ (delete-region comint-accum-marker (point))
+ (insert text)))
(insert "\n")
(set-marker comint-accum-marker (point))
(if comint-input-ring-index
diff --git a/lisp/completion.el b/lisp/completion.el
index 643f2da0d21..a77cccde643 100644
--- a/lisp/completion.el
+++ b/lisp/completion.el
@@ -492,7 +492,7 @@ Used to decide whether to save completions.")
table))
;; Old name, non-namespace-clean.
-(defvaralias 'cmpl-syntax-table 'completion-syntax-table)
+(define-obsolete-variable-alias 'cmpl-syntax-table 'completion-syntax-table "29.1")
(defvar-local completion-syntax-table completion-standard-syntax-table
"This variable holds the current completion syntax table.")
@@ -2220,7 +2220,7 @@ TYPE is the type of the wrapper to be added. Can be :before or :under."
(completion-def-wrapper 'delete-backward-char-untabify :backward)
;; Old name, non-namespace-clean.
-(defalias 'initialize-completions #'completion-initialize)
+(define-obsolete-function-alias 'initialize-completions #'completion-initialize "29.1")
(provide 'completion)
diff --git a/lisp/composite.el b/lisp/composite.el
index 99f528a0779..c2289e8998f 100644
--- a/lisp/composite.el
+++ b/lisp/composite.el
@@ -901,6 +901,4 @@ For more information on Auto Composition mode, see
(provide 'composite)
-
-
;;; composite.el ends here
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index 5c4448ae71a..ae71140e262 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -1133,7 +1133,7 @@ for the MODE to customize."
(defun customize-read-group ()
(let ((completion-ignore-case t))
- (completing-read "Customize group (default emacs): "
+ (completing-read (format-prompt "Customize group" "emacs")
obarray
(lambda (symbol)
(or (and (get symbol 'custom-loads)
@@ -1205,7 +1205,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 "27.2"
+(defvar customize-changed-options-previous-release "28.1"
"Version for `customize-changed' to refer back to by default.")
;; Packages will update this variable, so make it available.
@@ -2176,7 +2176,7 @@ and `face'."
;;; The `custom' Widget.
(defface custom-button
- '((((type x w32 ns) (class color)) ; Like default mode line
+ '((((type x w32 ns haiku pgtk) (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."
@@ -2184,7 +2184,7 @@ and `face'."
:group 'custom-faces)
(defface custom-button-mouse
- '((((type x w32 ns) (class color))
+ '((((type x w32 ns haiku pgtk) (class color))
:box (:line-width 2 :style released-button)
:background "grey90" :foreground "black")
(t
@@ -2209,7 +2209,7 @@ and `face'."
(if custom-raised-buttons 'custom-button-mouse 'highlight))
(defface custom-button-pressed
- '((((type x w32 ns) (class color))
+ '((((type x w32 ns haiku pgtk) (class color))
:box (:line-width 2 :style pressed-button)
:background "lightgrey" :foreground "black")
(t :inverse-video t))
@@ -3458,6 +3458,10 @@ MS Windows.")
:sibling-args (:help-echo "\
GNUstep or Macintosh OS Cocoa interface.")
ns)
+ (const :format "PGTK "
+ :sibling-args (:help-echo "\
+Pure-GTK interface.")
+ ns)
(const :format "DOS "
:sibling-args (:help-echo "\
Plain MS-DOS.")
diff --git a/lisp/cus-face.el b/lisp/cus-face.el
index 6c0052bf860..c78a327fdfa 100644
--- a/lisp/cus-face.el
+++ b/lisp/cus-face.el
@@ -31,6 +31,9 @@
(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)))
+ (error "Invalid (or missing) doc string %S" doc))
(unless (get face 'face-defface-spec)
(face-spec-set face (purecopy spec) 'face-defface-spec)
(push (cons 'defface face) current-load-list)
@@ -51,6 +54,7 @@
(string :tag "Font Foundry"
:help-echo "Font foundry name."))
+ ;; The width, weight, and slant should be in sync with font.c.
(:width
(choice :tag "Width"
:help-echo "Font width."
@@ -60,15 +64,21 @@
(const :tag "demiexpanded" semi-expanded)
(const :tag "expanded" expanded)
(const :tag "extracondensed" extra-condensed)
+ (const :tag "extra-condensed" extra-condensed)
(const :tag "extraexpanded" extra-expanded)
- (const :tag "medium" normal)
+ (const :tag "extra-expanded" extra-expanded)
(const :tag "narrow" condensed)
(const :tag "normal" normal)
+ (const :tag "medium" normal)
(const :tag "regular" normal)
(const :tag "semicondensed" semi-condensed)
+ (const :tag "demicondensed" semi-condensed)
+ (const :tag "semi-condensed" semi-condensed)
(const :tag "semiexpanded" semi-expanded)
(const :tag "ultracondensed" ultra-condensed)
+ (const :tag "ultra-condensed" ultra-condensed)
(const :tag "ultraexpanded" ultra-expanded)
+ (const :tag "ultra-expanded" ultra-expanded)
(const :tag "wide" extra-expanded)))
(:height
@@ -82,22 +92,32 @@
(choice :tag "Weight"
:help-echo "Font weight."
:value normal ; default
+ (const :tag "thin" thin)
(const :tag "ultralight" ultra-light)
- (const :tag "extralight" extra-light)
+ (const :tag "ultra-light" ultra-light)
+ (const :tag "extralight" ultra-light)
+ (const :tag "extra-light" ultra-light)
(const :tag "light" light)
- (const :tag "thin" thin)
(const :tag "semilight" semi-light)
- (const :tag "book" semi-light)
+ (const :tag "semi-light" semi-light)
+ (const :tag "demilight" semi-light)
(const :tag "normal" normal)
- (const :tag "regular" normal)
- (const :tag "medium" normal)
+ (const :tag "regular" regular)
+ (const :tag "book" normal)
+ (const :tag "medium" medium)
(const :tag "semibold" semi-bold)
+ (const :tag "semi-bold" semi-bold)
(const :tag "demibold" semi-bold)
+ (const :tag "demi-bold" semi-bold)
(const :tag "bold" bold)
(const :tag "extrabold" extra-bold)
- (const :tag "heavy" extra-bold)
- (const :tag "ultrabold" ultra-bold)
- (const :tag "black" ultra-bold)))
+ (const :tag "extra-bold" extra-bold)
+ (const :tag "ultrabold" extra-bold)
+ (const :tag "ultra-bold" extra-bold)
+ (const :tag "heavy" heavy)
+ (const :tag "black" heavy)
+ (const :tag "ultra-heavy" ultra-heavy)
+ (const :tag "ultraheavy" ultra-heavy)))
(:slant
(choice :tag "Slant"
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index 1a3e5682bba..579beae123f 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -386,7 +386,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(const :tag "When sent SIGUSR1" sigusr1)
(const :tag "When sent SIGUSR2" sigusr2))
"24.1")
-
+ (translate-upper-case-key-bindings keyboard boolean "29.1")
;; This is not good news because it will use the wrong
;; version-specific directories when you upgrade. We need
;; customization of the front of the list, maintaining the
@@ -572,8 +572,10 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(ns-use-native-fullscreen ns boolean "24.4")
(ns-use-fullscreen-animation ns boolean "25.1")
(ns-use-srgb-colorspace ns boolean "24.4")
+ (ns-scroll-event-delta-factor ns float "29.1")
;; process.c
(delete-exited-processes processes-basics boolean)
+ (process-error-pause-time processes-basics integer "29.1")
;; syntax.c
(parse-sexp-ignore-comments editing-basics boolean)
(words-include-escapes editing-basics boolean)
@@ -826,10 +828,15 @@ since it could result in memory overflow and make Emacs crash."
(x-underline-at-descent-line display boolean "22.1")
(x-stretch-cursor display boolean "21.1")
(scroll-bar-adjust-thumb-portion windows boolean "24.4")
+ (x-scroll-event-delta-factor mouse float "29.1")
;; xselect.c
(x-select-enable-clipboard-manager killing boolean "24.1")
;; xsettings.c
- (font-use-system-font font-selection boolean "23.2")))
+ (font-use-system-font font-selection boolean "23.2")
+ ;; haikuterm.c
+ (haiku-debug-on-fatal-error debug boolean "29.1")
+ ;; haikufns.c
+ (haiku-use-system-tooltips tooltip boolean "29.1")))
(setq ;; If we did not specify any standard value expression above,
;; use the current value as the standard value.
standard (if (setq prop (memq :standard rest))
@@ -846,10 +853,17 @@ since it could result in memory overflow and make Emacs crash."
(eq system-type 'windows-nt))
((string-match "\\`ns-" (symbol-name symbol))
(featurep 'ns))
+ ((string-match "\\`haiku-" (symbol-name symbol))
+ (featurep 'haiku))
((string-match "\\`x-.*gtk" (symbol-name symbol))
(featurep 'gtk))
((string-match "clipboard-manager" (symbol-name symbol))
(boundp 'x-select-enable-clipboard-manager))
+ ((or (equal "scroll-bar-adjust-thumb-portion"
+ (symbol-name symbol))
+ (equal "x-scroll-event-delta-factor"
+ (symbol-name symbol)))
+ (featurep 'x))
((string-match "\\`x-" (symbol-name symbol))
(fboundp 'x-create-frame))
((string-match "selection" (symbol-name symbol))
@@ -870,9 +884,6 @@ since it could result in memory overflow and make Emacs crash."
(symbol-name symbol))
;; Any function from fontset.c will do.
(fboundp 'new-fontset))
- ((equal "scroll-bar-adjust-thumb-portion"
- (symbol-name symbol))
- (featurep 'x))
(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 07881e9b74e..f618e3341cb 100644
--- a/lisp/cus-theme.el
+++ b/lisp/cus-theme.el
@@ -627,22 +627,24 @@ Theme files are named *-theme.el in `"))
(let ((help-echo "mouse-2: Enable this theme for this session")
widget)
(dolist (theme (custom-available-themes))
- (setq widget (widget-create 'checkbox
- :value (custom-theme-enabled-p theme)
- :theme-name theme
- :help-echo help-echo
- :action #'custom-theme-checkbox-toggle))
- (push (cons theme widget) custom--listed-themes)
- (widget-create-child-and-convert widget 'push-button
- :button-face-get 'ignore
- :mouse-face-get 'ignore
- :value (format " %s" theme)
- :action #'widget-parent-action
- :help-echo help-echo)
- (widget-insert " -- "
- (propertize (custom-theme-summary theme)
- 'face 'shadow)
- ?\n)))
+ ;; Don't list obsolete themes.
+ (unless (get theme 'byte-obsolete-info)
+ (setq widget (widget-create 'checkbox
+ :value (custom-theme-enabled-p theme)
+ :theme-name theme
+ :help-echo help-echo
+ :action #'custom-theme-checkbox-toggle))
+ (push (cons theme widget) custom--listed-themes)
+ (widget-create-child-and-convert widget 'push-button
+ :button-face-get 'ignore
+ :mouse-face-get 'ignore
+ :value (format " %s" theme)
+ :action #'widget-parent-action
+ :help-echo help-echo)
+ (widget-insert " -- "
+ (propertize (custom-theme-summary theme)
+ 'face 'shadow)
+ ?\n))))
(goto-char (point-min))
(widget-setup))
diff --git a/lisp/custom.el b/lisp/custom.el
index cc817403871..9252e80411f 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -364,7 +364,8 @@ call that function directly.
See Info node `(elisp) Customization' in the Emacs Lisp manual
for more information."
- (declare (doc-string 3) (debug (name body)))
+ (declare (doc-string 3) (debug (name body))
+ (indent defun))
;; It is better not to use backquote in this file,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
@@ -447,7 +448,7 @@ In the ATTS property list, possible attributes are `:family',
See Info node `(elisp) Faces' in the Emacs Lisp manual for more
information."
- (declare (doc-string 3))
+ (declare (doc-string 3) (indent defun))
;; It is better not to use backquote in this file,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
@@ -515,7 +516,7 @@ non-nil.
See Info node `(elisp) Customization' in the Emacs Lisp manual
for more information."
- (declare (doc-string 3))
+ (declare (doc-string 3) (indent defun))
;; It is better not to use backquote in this file,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
@@ -1135,29 +1136,24 @@ list, in which A occurs before B if B was defined with a
;; (provide-theme 'THEME)
-;; The IGNORED arguments to deftheme come from the XEmacs theme code, where
-;; they were used to supply keyword-value pairs like `:immediate',
-;; `:variable-reset-string', etc. We don't use any of these, so ignore them.
-
-(defmacro deftheme (theme &optional doc &rest _ignored)
+(defmacro deftheme (theme &optional doc)
"Declare THEME to be a Custom theme.
The optional argument DOC is a doc string describing the theme.
Any theme `foo' should be defined in a file called `foo-theme.el';
see `custom-make-theme-feature' for more information."
(declare (doc-string 2)
- (advertised-calling-convention (theme &optional doc) "22.1"))
+ (indent 1))
(let ((feature (custom-make-theme-feature theme)))
;; It is better not to use backquote in this file,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
(list 'custom-declare-theme (list 'quote theme) (list 'quote feature) doc)))
-(defun custom-declare-theme (theme feature &optional doc &rest _ignored)
+(defun custom-declare-theme (theme feature &optional doc)
"Like `deftheme', but THEME is evaluated as a normal argument.
FEATURE is the feature this theme provides. Normally, this is a symbol
created from THEME by `custom-make-theme-feature'."
- (declare (advertised-calling-convention (theme feature &optional doc) "22.1"))
(unless (custom-theme-name-valid-p theme)
(error "Custom theme cannot be named %S" theme))
(unless (memq theme custom-known-themes)
@@ -1335,6 +1331,13 @@ Return t if THEME was successfully loaded, nil otherwise."
t))))
(t
(error "Unable to load theme `%s'" theme))))
+ (when-let ((obs (get theme 'byte-obsolete-info)))
+ (display-warning 'initialization
+ (format "The `%s' theme is obsolete%s"
+ theme
+ (if (nth 2 obs)
+ (format " since Emacs %s" (nth 2 obs))
+ ""))))
;; Optimization: if the theme changes the `default' face, put that
;; entry first. This avoids some `frame-set-background-mode' rigmarole
;; by assigning the new background immediately.
diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index 98871164f2a..2a239f81002 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -417,6 +417,7 @@ The character information includes:
(display-table (or (window-display-table)
buffer-display-table
standard-display-table))
+ (composition-string nil)
(disp-vector (and display-table (aref display-table char)))
(multibyte-p enable-multibyte-characters)
(overlays (mapcar (lambda (o) (overlay-properties o))
@@ -538,7 +539,8 @@ The character information includes:
(setcar composition nil)))
(setcar (cdr composition)
(format "composed to form \"%s\" (see below)"
- (buffer-substring from to)))))
+ (setq composition-string
+ (buffer-substring from to))))))
(setq composition nil)))
(setq item-list
@@ -682,6 +684,11 @@ The character information includes:
(if display
(format "terminal code %s" display)
"not encodable for terminal"))))))
+ ,@(when-let ((composition-name
+ (and composition-string
+ (eq (aref char-script-table char) 'emoji)
+ (emoji-describe composition-string))))
+ (list (list "composition name" composition-name)))
,@(let ((face
(if (not (or disp-vector composition))
(cond
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 8adda9a2727..5301a3a27ff 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -444,10 +444,10 @@ List has a form of (file-name full-file-name (attribute-list))."
((eq op-symbol 'chgrp)
(file-attribute-group-id
(file-attributes default-file 'string))))))
- (prompt (concat "Change " attribute-name " of %s to"
- (if (eq op-symbol 'touch)
- " (default now): "
- ": ")))
+ (prompt (format-prompt "Change %s of %%s to"
+ (when (eq op-symbol 'touch)
+ "now")
+ attribute-name))
(new-attribute (dired-mark-read-string prompt nil op-symbol
arg files default
(cond ((eq op-symbol 'chown)
@@ -1009,6 +1009,7 @@ the offending ARGUMENTS or PROGRAM if no ARGUMENTS were provided."
(erase-buffer)
(setq default-directory dir ; caller's default-directory
err (not (eq 0 (apply #'process-file program nil t nil arguments))))
+ (dired-uncache dir)
(if err
(progn
(dired-log (concat program " " (prin1-to-string arguments) "\n"))
@@ -1034,6 +1035,7 @@ Return the result of `process-file' - zero for success."
nil
shell-command-switch
cmd)))
+ (dired-uncache dir)
(unless (zerop res)
(pop-to-buffer out-buffer))
res))))
@@ -1282,9 +1284,9 @@ Return nil if no change in files."
(prog1 (setq newname (file-name-as-directory newname))
(dired-shell-command
(replace-regexp-in-string
- "%o" (shell-quote-argument newname)
+ "%o" (shell-quote-argument (file-local-name newname))
(replace-regexp-in-string
- "%i" (shell-quote-argument file)
+ "%i" (shell-quote-argument (file-local-name file))
command
nil t)
nil t)))
@@ -1295,10 +1297,10 @@ Return nil if no change in files."
(dired-check-process msg
(substring command 0 match)
(substring command (1+ match))
- file)
+ (file-local-name file))
(dired-check-process msg
command
- file))
+ (file-local-name file)))
newname))))
(t
;; We don't recognize the file as compressed, so compress it.
@@ -1316,7 +1318,8 @@ Return nil if no change in files."
(default-directory (file-name-directory file)))
(dired-shell-command
(replace-regexp-in-string
- "%o" (shell-quote-argument out-name)
+ "%o" (shell-quote-argument
+ (file-local-name out-name))
(replace-regexp-in-string
"%i" (shell-quote-argument
(file-name-nondirectory file))
@@ -1346,9 +1349,10 @@ see `dired-compress-file-alist' for the supported suffixes list"
out-name)))
(dired-shell-command
(replace-regexp-in-string
- "%o" (shell-quote-argument out-name)
+ "%o" (shell-quote-argument
+ (file-local-name out-name))
(replace-regexp-in-string
- "%i" (shell-quote-argument file)
+ "%i" (shell-quote-argument (file-local-name file))
(cdr rule)
nil t)
nil t))
@@ -1363,7 +1367,8 @@ see `dired-compress-file-alist' for the supported suffixes list"
out-name)))))
(file-error
(if (not (dired-check-process (concat "Compressing " file)
- "compress" "-f" file))
+ "compress" "-f"
+ (file-local-name file)))
;; Don't use NEWNAME with `compress'.
(concat file ".Z"))))))))
@@ -1784,13 +1789,46 @@ Special value `always' suppresses confirmation."
"Whether Dired should create destination dirs when copying/removing files.
If nil, don't create them.
If `always', create them without asking.
-If `ask', ask for user confirmation."
+If `ask', ask for user confirmation.
+
+Also see `dired-create-destination-dirs-on-trailing-dirsep'."
:type '(choice (const :tag "Never create non-existent dirs" nil)
(const :tag "Always create non-existent dirs" always)
(const :tag "Ask for user confirmation" ask))
:group 'dired
:version "27.1")
+(defcustom dired-create-destination-dirs-on-trailing-dirsep nil
+ "If non-nil, treat a trailing slash at queried destination dir specially.
+
+If this variable is non-nil and a single destination filename is
+queried which ends in a directory separator (/), it will be
+treated as a non-existent directory and acted on according to
+`dired-create-destination-dirs'.
+
+This option is only relevant if `dired-create-destination-dirs'
+is non-nil, too.
+
+For example, if both `dired-create-destination-dirs' and this
+option are non-nil, renaming a directory named `old_name' to
+`new_name/' (note the trailing directory separator) where
+`new_name' does not exists already, it will be created and
+`old_name' be moved into it. If only `new_name' (without the
+trailing /) is given or this option or
+`dired-create-destination-dirs' is `nil', `old_name' will be
+renamed to `new_name'."
+ :type '(choice
+ (const :tag
+ (concat "Do not treat destination dirs with a "
+ "trailing directory separator specially")
+ nil)
+ (const :tag
+ (concat "Treat destination dirs with trailing "
+ "directory separator specially")
+ t))
+ :group 'dired
+ :version "29.1")
+
(defun dired-maybe-create-dirs (dir)
"Create DIR if doesn't exist according to `dired-create-destination-dirs'."
(when (and dired-create-destination-dirs (not (file-exists-p dir)))
@@ -1986,11 +2024,12 @@ or with the current marker character if MARKER-CHAR is t."
(let* ((overwrite (file-exists-p to))
(dired-overwrite-confirmed ; for dired-handle-overwrite
(and overwrite
- (let ((help-form (format-message "\
-Type SPC or `y' to overwrite file `%s',
-DEL or `n' to skip to next,
-ESC or `q' to not overwrite any of the remaining files,
-`!' to overwrite all remaining files with no more questions." to)))
+ (let ((help-form (format-message
+ (substitute-command-keys "\
+Type \\`SPC' or \\`y' to overwrite file `%s',
+\\`DEL' or \\`n' to skip to next,
+\\`ESC' or \\`q' to not overwrite any of the remaining files,
+\\`!' to overwrite all remaining files with no more questions.") to)))
(dired-query 'overwrite-query
"Overwrite `%s'?" to))))
;; must determine if FROM is marked before file-creator
@@ -2159,7 +2198,12 @@ Optional arg HOW-TO determines how to treat the target.
target-dir op-symbol arg rfn-list default))))
(into-dir
(progn
- (unless dired-one-file (dired-maybe-create-dirs target))
+ (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
@@ -2483,11 +2527,12 @@ Also see `dired-do-revert-buffer'."
;; Optional arg MARKER-CHAR as in dired-create-files.
(let* ((fn-list (dired-get-marked-files nil arg))
(operation-prompt (concat operation " `%s' to `%s'?"))
- (rename-regexp-help-form (format-message "\
-Type SPC or `y' to %s one match, DEL or `n' to skip to next,
-`!' to %s all remaining matches with no more questions."
- (downcase operation)
- (downcase operation)))
+ (rename-regexp-help-form (format-message
+ (substitute-command-keys "\
+Type \\`SPC' or \\`y' to %s one match, \\`DEL' or \\`n' to skip to next,
+\\`!' to %s all remaining matches with no more questions.")
+ (downcase operation)
+ (downcase operation)))
(regexp-name-constructor
;; Function to construct new filename using REGEXP and NEWNAME:
(if whole-name ; easy (but rare) case
@@ -2608,11 +2653,12 @@ See function `dired-do-rename-regexp' for more info."
(let ((to (concat (file-name-directory from)
(funcall basename-constructor
(file-name-nondirectory from)))))
- (and (let ((help-form (format-message "\
-Type SPC or `y' to %s one file, DEL or `n' to skip to next,
-`!' to %s all remaining matches with no more questions."
- (downcase operation)
- (downcase operation))))
+ (and (let ((help-form (format-message
+ (substitute-command-keys "\
+Type \\`SPC' or \\`y' to %s one file, \\`DEL' or \\`n' to skip to next,
+\\`!' to %s all remaining matches with no more questions.")
+ (downcase operation)
+ (downcase operation))))
(dired-query 'rename-non-directory-query
(concat operation " `%s' to `%s'")
(dired-make-relative from)
@@ -2862,8 +2908,8 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well."
;; if dired-actual-switches contained t.
(setq dir1 (file-name-as-directory dir1)
dir2 (file-name-as-directory dir2))
- (let ((components-1 (dired-split "/" dir1))
- (components-2 (dired-split "/" dir2)))
+ (let ((components-1 (split-string dir1 "/"))
+ (components-2 (split-string dir2 "/")))
(while (and components-1
components-2
(equal (car components-1) (car components-2)))
@@ -2882,7 +2928,6 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well."
nil)
(t (error "This can't happen"))))))
-;; There should be a builtin split function - inverse to mapconcat.
(defun dired-split (pat str &optional limit)
"Splitting on regexp PAT, turn string STR into a list of substrings.
Optional third arg LIMIT (>= 1) is a limit to the length of the
@@ -2892,6 +2937,7 @@ Thus, if SEP is a regexp that only matches itself,
(mapconcat #'identity (dired-split SEP STRING) SEP)
is always equal to STRING."
+ (declare (obsolete split-string "29.1"))
(let* ((start (string-match pat str))
(result (list (substring str 0 start)))
(count 1)
diff --git a/lisp/dired-x.el b/lisp/dired-x.el
index 7c6f49f2ae4..38d8a954a83 100644
--- a/lisp/dired-x.el
+++ b/lisp/dired-x.el
@@ -554,7 +554,7 @@ If the region is active in Transient Mark mode, operate only on
files in the active region if `dired-mark-region' is non-nil."
(interactive
(list (read-regexp
- "Mark unmarked files matching regexp (default all): "
+ (format-prompt "Mark unmarked files matching regexp" "all")
nil 'dired-regexp-history)
nil current-prefix-arg nil))
(let ((dired-marker-char (if unflag-p ?\s dired-marker-char)))
@@ -580,23 +580,24 @@ files in the active region if `dired-mark-region' is non-nil."
(defalias 'virtual-dired 'dired-virtual)
(defun dired-virtual (dirname &optional switches)
- "Put this Dired buffer into Virtual Dired mode.
+ "Treat the current buffer as a Dired buffer showing directory DIRNAME.
+Interactively, prompt for DIRNAME.
-In Virtual Dired mode, all commands that do not actually consult the
-filesystem will work.
+This command is rarely useful, but may be convenient if you want
+to peruse and move around in the output you got from \"ls
+-lR\" (or something similar), without having access to the actual
+file system.
-This is useful if you want to peruse and move around in an ls -lR
-output file, for example one you got from an ftp server. With
-ange-ftp, you can even Dired a directory containing an ls-lR file,
-visit that file and turn on Virtual Dired mode. But don't try to save
-this file, as `dired-virtual' indents the listing and thus changes the
-buffer.
+Most Dired commands that don't consult the file system will work
+as advertised, but commands that try to alter the file system
+will usually fail. (However, if the output is from the current
+system, most of those commands will work fine.)
If you have saved a Dired buffer in a file you can use \\[dired-virtual] to
resume it in a later session.
Type \\<dired-mode-map>\\[revert-buffer] \
-in the Virtual Dired buffer and answer `y' to convert
+in the Virtual Dired buffer and answer \\`y' to convert
the virtual to a real Dired buffer again. You don't have to do this, though:
you can relist single subdirs using \\[dired-do-redisplay]."
@@ -1264,13 +1265,21 @@ sure that a trailing letter in STR is one of BKkMGTPEZY."
(let* ((val (string-to-number str))
(u (unless (zerop val)
(aref str (1- (length str))))))
- (when (and u (> u ?9))
- (when (= u ?k)
- (setq u ?K))
- (let ((units '(?B ?K ?M ?G ?T ?P ?E ?Z ?Y)))
- (while (and units (/= (pop units) u))
- (setq val (* 1024.0 val)))))
- val))
+ ;; If we don't have a unit at the end, but we have some
+ ;; non-numeric strings in the string, then the string may be
+ ;; something like "4.134" or "4,134" meant to represent 4134
+ ;; (seen in some locales).
+ (if (and u
+ (<= ?0 u ?9)
+ (string-match-p "[^0-9]" str))
+ (string-to-number (replace-regexp-in-string "[^0-9]+" "" str))
+ (when (and u (> u ?9))
+ (when (= u ?k)
+ (setq u ?K))
+ (let ((units '(?B ?K ?M ?G ?T ?P ?E ?Z ?Y)))
+ (while (and units (/= (pop units) u))
+ (setq val (* 1024.0 val)))))
+ val)))
(defun dired-mark-sexp (predicate &optional unflag-p)
"Mark files for which PREDICATE returns non-nil.
@@ -1478,12 +1487,12 @@ a prefix argument, when it offers the filename near point as a default."
;;; Internal functions
-;; Fixme: This should probably use `thing-at-point'. -- fx
(define-obsolete-function-alias 'dired-filename-at-point
#'dired-x-guess-file-name-at-point "28.1")
(defun dired-x-guess-file-name-at-point ()
"Return the filename closest to point, expanded.
Point should be in or after a filename."
+ (declare (obsolete "use (thing-at-point 'filename) instead." "29.1"))
(save-excursion
;; First see if just past a filename.
(or (eobp) ; why?
@@ -1515,7 +1524,7 @@ Point should be in or after a filename."
"Return filename prompting with PROMPT with completion.
If `current-prefix-arg' is non-nil, uses name at point as guess."
(if current-prefix-arg
- (let ((guess (dired-x-guess-file-name-at-point)))
+ (let ((guess (thing-at-point 'filename)))
(read-file-name prompt
(file-name-directory guess)
guess
diff --git a/lisp/dired.el b/lisp/dired.el
index 46525891224..a8841214156 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -35,6 +35,7 @@
;;; Code:
(eval-when-compile (require 'subr-x))
+(eval-when-compile (require 'cl-lib))
;; When bootstrapping dired-loaddefs has not been generated.
(require 'dired-loaddefs nil t)
@@ -208,6 +209,18 @@ If a character, new links are unconditionally marked with that character."
(character :tag "Mark"))
:group 'dired-mark)
+(defcustom dired-free-space 'first
+ "Whether and how to display the amount of free disk space in Dired buffers.
+If nil, don't display.
+If `separate', display on a separate line (along with used count).
+If `first', display only the free disk space on the first line,
+following the directory name."
+ :type '(choice (const :tag "On a separate line" separate)
+ (const :tag "On the first line, after directory name" first)
+ (const :tag "Don't display" nil))
+ :version "29.1"
+ :group 'dired)
+
(defcustom dired-dwim-target nil
"If non-nil, Dired tries to guess a default target directory.
This means: if there is a Dired buffer displayed in some window,
@@ -281,6 +294,11 @@ with the buffer narrowed to the listing."
;; Note this can't simply be run inside function `dired-ls' as the hook
;; functions probably depend on the dired-subdir-alist to be OK.
+(defcustom dired-make-directory-clickable t
+ "When non-nil, make the directory at the start of the dired buffer clickable."
+ :version "29.1"
+ :type 'boolean)
+
(defcustom dired-initial-position-hook nil
"This hook is used to position the point.
It is run by the function `dired-initial-position'."
@@ -339,11 +357,11 @@ When `file', the region marking is based on the file name.
This means don't mark the file if the end of the region is
before the file name displayed on the Dired line, so the file name
is visually outside the region. This behavior is consistent with
-marking files without the region using the key `m' that advances
+marking files without the region using the key \\`m' that advances
point to the next line after marking the file. Thus the number
of keys used to mark files is the same as the number of keys
-used to select the region, e.g. `M-2 m' marks 2 files, and
-`C-SPC M-2 n m' marks 2 files, and `M-2 S-down m' marks 2 files.
+used to select the region, for example \\`M-2 m' marks 2 files, and
+\\`C-SPC M-2 n m' marks 2 files, and \\`M-2 S-<down> m' marks 2 files.
When `line', the region marking is based on Dired lines,
so include the file into marking if the end of the region
@@ -1247,8 +1265,7 @@ The return value is the target column for the file names."
;; Don't try to find a wildcard as a subdirectory.
(string-equal dirname (file-name-directory dirname)))
(let* ((cur-buf (current-buffer))
- (buffers (nreverse
- (dired-buffers-for-dir (expand-file-name dirname))))
+ (buffers (nreverse (dired-buffers-for-dir dirname)))
(cur-buf-matches (and (memq cur-buf buffers)
;; Wildcards must match, too:
(equal dired-directory dirname))))
@@ -1326,6 +1343,8 @@ wildcards, erases the buffer, and builds the subdir-alist anew
(set-visited-file-modtime (file-attribute-modification-time
attributes))))
(set-buffer-modified-p nil)
+ (when dired-make-directory-clickable
+ (dired--make-directory-clickable))
;; No need to narrow since the whole buffer contains just
;; dired-readin's output, nothing else. The hook can
;; successfully use dired functions (e.g. dired-get-filename)
@@ -1606,15 +1625,55 @@ see `dired-use-ls-dired' for more details.")
;; 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")
+ (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")))
+ "\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.
+ (save-excursion
+ (goto-char beg)
+ ;; First find the line to put it on.
+ (if (not (re-search-forward "^ *\\(total\\)" nil t))
+ beg
+ (if (or (not dired-free-space)
+ (eq dired-free-space 'first))
+ (delete-region (match-beginning 0) (line-beginning-position 2))
+ ;; Replace "total" with "total used in directory" to
+ ;; avoid confusion.
+ (replace-match "total used in directory" nil nil nil 1))
+ (if-let ((available (get-free-disk-space file)))
+ (cond
+ ((eq dired-free-space 'separate)
+ (end-of-line)
+ (insert " available " available)
+ (forward-line 1)
+ (point))
+ ((eq dired-free-space 'first)
+ (goto-char beg)
+ (when (and (looking-at
+ (if (memq system-type '(windows-nt ms-dos))
+ " *[A-Za-z]:/"
+ " */"))
+ (progn
+ (end-of-line)
+ (eq (char-after (1- (point))) ?:)))
+ (put-text-property (1- (point)) (point)
+ 'display
+ (concat ": (" available " available)")))
+ (forward-line 1)
+ (point))
+ (t
+ beg))
+ beg))))
+
(defun dired-insert-set-properties (beg end)
"Add various text properties to the lines in the region, from BEG to END."
(save-excursion
@@ -1643,6 +1702,32 @@ see `dired-use-ls-dired' for more details.")
'invisible 'dired-hide-details-link))))
(forward-line 1))))
+(defun dired--make-directory-clickable ()
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "^ /" nil t 1)
+ (let ((bound (line-end-position))
+ (segment-start (point))
+ (inhibit-read-only t)
+ (dir "/"))
+ (while (search-forward "/" bound t 1)
+ (setq dir (concat dir (buffer-substring segment-start (point))))
+ (add-text-properties
+ segment-start (1- (point))
+ `( mouse-face highlight
+ help-echo "mouse-1: goto this directory"
+ keymap ,(let* ((current-dir dir)
+ (click (lambda ()
+ (interactive)
+ (if (assoc current-dir dired-subdir-alist)
+ (dired-goto-subdir current-dir)
+ (dired current-dir)))))
+ (define-keymap
+ "<mouse-2>" click
+ "<follow-link>" 'mouse-face
+ "RET" click))))
+ (setq segment-start (point)))))))
+
;;; Reverting a dired buffer
@@ -1835,160 +1920,152 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
;;; Dired mode key bindings and menus
-(defvar dired-mode-map
+(defvar-keymap dired-mode-map
+ :doc "Local keymap for Dired mode buffers."
+ :full t
+ :parent special-mode-map
;; This looks ugly when substitute-command-keys uses C-d instead d:
- ;; (define-key dired-mode-map "\C-d" 'dired-flag-file-deletion)
- (let ((map (make-keymap)))
- (set-keymap-parent map special-mode-map)
- (define-key map [mouse-2] 'dired-mouse-find-file-other-window)
- (define-key map [follow-link] 'mouse-face)
- ;; Commands to mark or flag certain categories of files
- (define-key map "#" 'dired-flag-auto-save-files)
- (define-key map "." 'dired-clean-directory)
- (define-key map "~" 'dired-flag-backup-files)
- ;; Upper case keys (except !) for operating on the marked files
- (define-key map "A" 'dired-do-find-regexp)
- (define-key map "C" 'dired-do-copy)
- (define-key map "B" 'dired-do-byte-compile)
- (define-key map "D" 'dired-do-delete)
- (define-key map "G" 'dired-do-chgrp)
- (define-key map "H" 'dired-do-hardlink)
- (define-key map "L" 'dired-do-load)
- (define-key map "M" 'dired-do-chmod)
- (define-key map "O" 'dired-do-chown)
- (define-key map "P" 'dired-do-print)
- (define-key map "Q" 'dired-do-find-regexp-and-replace)
- (define-key map "R" 'dired-do-rename)
- (define-key map "S" 'dired-do-symlink)
- (define-key map "T" 'dired-do-touch)
- (define-key map "X" 'dired-do-shell-command)
- (define-key map "Z" 'dired-do-compress)
- (define-key map "c" 'dired-do-compress-to)
- (define-key map "!" 'dired-do-shell-command)
- (define-key map "&" 'dired-do-async-shell-command)
- ;; Comparison commands
- (define-key map "=" 'dired-diff)
- ;; Tree Dired commands
- (define-key map "\M-\C-?" 'dired-unmark-all-files)
- (define-key map "\M-\C-d" 'dired-tree-down)
- (define-key map "\M-\C-u" 'dired-tree-up)
- (define-key map "\M-\C-n" 'dired-next-subdir)
- (define-key map "\M-\C-p" 'dired-prev-subdir)
- ;; move to marked files
- (define-key map "\M-{" 'dired-prev-marked-file)
- (define-key map "\M-}" 'dired-next-marked-file)
- ;; Make all regexp commands share a `%' prefix:
- ;; We used to get to the submap via a symbol dired-regexp-prefix,
- ;; but that seems to serve little purpose, and copy-keymap
- ;; does a better job without it.
- (define-key map "%" nil)
- (define-key map "%u" 'dired-upcase)
- (define-key map "%l" 'dired-downcase)
- (define-key map "%d" 'dired-flag-files-regexp)
- (define-key map "%g" 'dired-mark-files-containing-regexp)
- (define-key map "%m" 'dired-mark-files-regexp)
- (define-key map "%r" 'dired-do-rename-regexp)
- (define-key map "%C" 'dired-do-copy-regexp)
- (define-key map "%H" 'dired-do-hardlink-regexp)
- (define-key map "%R" 'dired-do-rename-regexp)
- (define-key map "%S" 'dired-do-symlink-regexp)
- (define-key map "%&" 'dired-flag-garbage-files)
- ;; Commands for marking and unmarking.
- (define-key map "*" nil)
- (define-key map "**" 'dired-mark-executables)
- (define-key map "*/" 'dired-mark-directories)
- (define-key map "*@" 'dired-mark-symlinks)
- (define-key map "*%" 'dired-mark-files-regexp)
- (define-key map "*N" 'dired-number-of-marked-files)
- (define-key map "*c" 'dired-change-marks)
- (define-key map "*s" 'dired-mark-subdir-files)
- (define-key map "*m" 'dired-mark)
- (define-key map "*u" 'dired-unmark)
- (define-key map "*?" 'dired-unmark-all-files)
- (define-key map "*!" 'dired-unmark-all-marks)
- (define-key map "U" 'dired-unmark-all-marks)
- (define-key map "*\177" 'dired-unmark-backward)
- (define-key map "*\C-n" 'dired-next-marked-file)
- (define-key map "*\C-p" 'dired-prev-marked-file)
- (define-key map "*t" 'dired-toggle-marks)
- ;; Lower keys for commands not operating on all the marked files
- (define-key map "a" 'dired-find-alternate-file)
- (define-key map "d" 'dired-flag-file-deletion)
- (define-key map "e" 'dired-find-file)
- (define-key map "f" 'dired-find-file)
- (define-key map "\C-m" 'dired-find-file)
- (put 'dired-find-file :advertised-binding "\C-m")
- (define-key map "g" 'revert-buffer)
- (define-key map "i" 'dired-maybe-insert-subdir)
- (define-key map "j" 'dired-goto-file)
- (define-key map "k" 'dired-do-kill-lines)
- (define-key map "l" 'dired-do-redisplay)
- (define-key map "m" 'dired-mark)
- (define-key map "n" 'dired-next-line)
- (define-key map "o" 'dired-find-file-other-window)
- (define-key map "\C-o" 'dired-display-file)
- (define-key map "p" 'dired-previous-line)
- (define-key map "s" 'dired-sort-toggle-or-edit)
- (define-key map "t" 'dired-toggle-marks)
- (define-key map "u" 'dired-unmark)
- (define-key map "v" 'dired-view-file)
- (define-key map "w" 'dired-copy-filename-as-kill)
- (define-key map "W" 'browse-url-of-dired-file)
- (define-key map "x" 'dired-do-flagged-delete)
- (define-key map "y" 'dired-show-file-type)
- (define-key map "+" 'dired-create-directory)
- ;; moving
- (define-key map "<" 'dired-prev-dirline)
- (define-key map ">" 'dired-next-dirline)
- (define-key map "^" 'dired-up-directory)
- (define-key map " " 'dired-next-line)
- (define-key map [?\S-\ ] 'dired-previous-line)
- (define-key map [remap next-line] 'dired-next-line)
- (define-key map [remap previous-line] 'dired-previous-line)
- ;; hiding
- (define-key map "$" 'dired-hide-subdir)
- (define-key map "\M-$" 'dired-hide-all)
- (define-key map "(" 'dired-hide-details-mode)
- ;; isearch
- (define-key map (kbd "M-s a C-s") 'dired-do-isearch)
- (define-key map (kbd "M-s a M-C-s") 'dired-do-isearch-regexp)
- (define-key map (kbd "M-s f C-s") 'dired-isearch-filenames)
- (define-key map (kbd "M-s f M-C-s") 'dired-isearch-filenames-regexp)
- ;; misc
- (define-key map [remap read-only-mode] 'dired-toggle-read-only)
- ;; `toggle-read-only' is an obsolete alias for `read-only-mode'
- (define-key map [remap toggle-read-only] 'dired-toggle-read-only)
- (define-key map "?" 'dired-summary)
- (define-key map "\177" 'dired-unmark-backward)
- (define-key map [remap undo] 'dired-undo)
- (define-key map [remap advertised-undo] 'dired-undo)
- (define-key map [remap vc-next-action] 'dired-vc-next-action)
- ;; thumbnail manipulation (image-dired)
- (define-key map "\C-td" 'image-dired-display-thumbs)
- (define-key map "\C-tt" 'image-dired-tag-files)
- (define-key map "\C-tr" 'image-dired-delete-tag)
- (define-key map "\C-tj" 'image-dired-jump-thumbnail-buffer)
- (define-key map "\C-ti" 'image-dired-dired-display-image)
- (define-key map "\C-tx" 'image-dired-dired-display-external)
- (define-key map "\C-ta" 'image-dired-display-thumbs-append)
- (define-key map "\C-t." 'image-dired-display-thumb)
- (define-key map "\C-tc" 'image-dired-dired-comment-files)
- (define-key map "\C-tf" 'image-dired-mark-tagged-files)
- (define-key map "\C-t\C-t" 'image-dired-dired-toggle-marked-thumbs)
- (define-key map "\C-te" 'image-dired-dired-edit-comment-and-tags)
- ;; encryption and decryption (epa-dired)
- (define-key map ":d" 'epa-dired-do-decrypt)
- (define-key map ":v" 'epa-dired-do-verify)
- (define-key map ":s" 'epa-dired-do-sign)
- (define-key map ":e" 'epa-dired-do-encrypt)
-
- ;; No need to do this, now that top-level items are fewer.
- ;;;;
- ;; Get rid of the Edit menu bar item to save space.
- ;;(define-key map [menu-bar edit] 'undefined)
-
- map)
- "Local keymap for Dired mode buffers.")
+ ;; "C-d" #'dired-flag-file-deletion
+ "<mouse-2>" #'dired-mouse-find-file-other-window
+ "<follow-link>" 'mouse-face
+ ;; Commands to mark or flag certain categories of files
+ "#" #'dired-flag-auto-save-files
+ "." #'dired-clean-directory
+ "~" #'dired-flag-backup-files
+ ;; Upper case keys (except !) for operating on the marked files
+ "A" #'dired-do-find-regexp
+ "C" #'dired-do-copy
+ "B" #'dired-do-byte-compile
+ "D" #'dired-do-delete
+ "G" #'dired-do-chgrp
+ "H" #'dired-do-hardlink
+ "L" #'dired-do-load
+ "M" #'dired-do-chmod
+ "O" #'dired-do-chown
+ "P" #'dired-do-print
+ "Q" #'dired-do-find-regexp-and-replace
+ "R" #'dired-do-rename
+ "S" #'dired-do-symlink
+ "T" #'dired-do-touch
+ "X" #'dired-do-shell-command
+ "Z" #'dired-do-compress
+ "c" #'dired-do-compress-to
+ "!" #'dired-do-shell-command
+ "&" #'dired-do-async-shell-command
+ ;; Comparison commands
+ "=" #'dired-diff
+ ;; Tree Dired commands
+ "M-DEL" #'dired-unmark-all-files
+ "C-M-d" #'dired-tree-down
+ "C-M-u" #'dired-tree-up
+ "C-M-n" #'dired-next-subdir
+ "C-M-p" #'dired-prev-subdir
+ ;; move to marked files
+ "M-{" #'dired-prev-marked-file
+ "M-}" #'dired-next-marked-file
+ ;; Make all regexp commands share a `%' prefix:
+ ;; We used to get to the submap via a symbol dired-regexp-prefix,
+ ;; but that seems to serve little purpose, and copy-keymap
+ ;; does a better job without it.
+ "% u" #'dired-upcase
+ "% l" #'dired-downcase
+ "% d" #'dired-flag-files-regexp
+ "% g" #'dired-mark-files-containing-regexp
+ "% m" #'dired-mark-files-regexp
+ "% r" #'dired-do-rename-regexp
+ "% C" #'dired-do-copy-regexp
+ "% H" #'dired-do-hardlink-regexp
+ "% R" #'dired-do-rename-regexp
+ "% S" #'dired-do-symlink-regexp
+ "% &" #'dired-flag-garbage-files
+ ;; Commands for marking and unmarking.
+ "* *" #'dired-mark-executables
+ "* /" #'dired-mark-directories
+ "* @" #'dired-mark-symlinks
+ "* %" #'dired-mark-files-regexp
+ "* N" #'dired-number-of-marked-files
+ "* c" #'dired-change-marks
+ "* s" #'dired-mark-subdir-files
+ "* m" #'dired-mark
+ "* u" #'dired-unmark
+ "* ?" #'dired-unmark-all-files
+ "* !" #'dired-unmark-all-marks
+ "U" #'dired-unmark-all-marks
+ "* DEL" #'dired-unmark-backward
+ "* C-n" #'dired-next-marked-file
+ "* C-p" #'dired-prev-marked-file
+ "* t" #'dired-toggle-marks
+ ;; Lower keys for commands not operating on all the marked files
+ "a" #'dired-find-alternate-file
+ "d" #'dired-flag-file-deletion
+ "e" #'dired-find-file
+ "f" #'dired-find-file
+ "C-m" #'dired-find-file
+ "g" #'revert-buffer
+ "i" #'dired-maybe-insert-subdir
+ "j" #'dired-goto-file
+ "k" #'dired-do-kill-lines
+ "l" #'dired-do-redisplay
+ "m" #'dired-mark
+ "n" #'dired-next-line
+ "o" #'dired-find-file-other-window
+ "C-o" #'dired-display-file
+ "p" #'dired-previous-line
+ "s" #'dired-sort-toggle-or-edit
+ "t" #'dired-toggle-marks
+ "u" #'dired-unmark
+ "v" #'dired-view-file
+ "w" #'dired-copy-filename-as-kill
+ "W" #'browse-url-of-dired-file
+ "x" #'dired-do-flagged-delete
+ "y" #'dired-show-file-type
+ "+" #'dired-create-directory
+ ;; moving
+ "<" #'dired-prev-dirline
+ ">" #'dired-next-dirline
+ "^" #'dired-up-directory
+ "SPC" #'dired-next-line
+ "S-SPC" #'dired-previous-line
+ "<remap> <next-line>" #'dired-next-line
+ "<remap> <previous-line>" #'dired-previous-line
+ ;; hiding
+ "$" #'dired-hide-subdir
+ "M-$" #'dired-hide-all
+ "(" #'dired-hide-details-mode
+ ;; isearch
+ "M-s a C-s" #'dired-do-isearch
+ "M-s a C-M-s" #'dired-do-isearch-regexp
+ "M-s f C-s" #'dired-isearch-filenames
+ "M-s f C-M-s" #'dired-isearch-filenames-regexp
+ ;; misc
+ "<remap> <read-only-mode>" #'dired-toggle-read-only
+ ;; `toggle-read-only' is an obsolete alias for `read-only-mode'
+ "<remap> <toggle-read-only>" #'dired-toggle-read-only
+ "?" #'dired-summary
+ "DEL" #'dired-unmark-backward
+ "<remap> <undo>" #'dired-undo
+ "<remap> <advertised-undo>" #'dired-undo
+ "<remap> <vc-next-action>" #'dired-vc-next-action
+ ;; thumbnail manipulation (image-dired)
+ "C-t d" #'image-dired-display-thumbs
+ "C-t t" #'image-dired-tag-files
+ "C-t r" #'image-dired-delete-tag
+ "C-t j" #'image-dired-jump-thumbnail-buffer
+ "C-t i" #'image-dired-dired-display-image
+ "C-t x" #'image-dired-dired-display-external
+ "C-t a" #'image-dired-display-thumbs-append
+ "C-t ." #'image-dired-display-thumb
+ "C-t c" #'image-dired-dired-comment-files
+ "C-t f" #'image-dired-mark-tagged-files
+ "C-t C-t" #'image-dired-dired-toggle-marked-thumbs
+ "C-t e" #'image-dired-dired-edit-comment-and-tags
+ ;; encryption and decryption (epa-dired)
+ ": d" #'epa-dired-do-decrypt
+ ": v" #'epa-dired-do-verify
+ ": s" #'epa-dired-do-sign
+ ": e" #'epa-dired-do-encrypt)
+
+(put 'dired-find-file :advertised-binding (kbd "RET"))
(easy-menu-define dired-mode-subdir-menu dired-mode-map
"Subdir menu for Dired mode."
@@ -2415,7 +2492,9 @@ directory in another window."
file-name
(if (file-symlink-p file-name)
(error "File is a symlink to a nonexistent target")
- (error "File no longer exists; type `g' to update Dired buffer")))))
+ (error (substitute-command-keys
+ (concat "File no longer exists; type \\<dired-mode-map>"
+ "\\[revert-buffer] to update Dired buffer")))))))
;; Force C-m keybinding rather than `f' or `e' in the mode doc:
(define-obsolete-function-alias 'dired-advertised-find-file
@@ -2879,7 +2958,7 @@ directories below DIR.
The list is in reverse order of buffer creation, most recent last.
As a side effect, killed dired buffers for DIR are removed from
`dired-buffers'."
- (setq dir (file-name-as-directory dir))
+ (setq dir (file-name-as-directory (expand-file-name dir)))
(let (result buf)
(dolist (elt dired-buffers)
(setq buf (cdr elt))
@@ -3430,7 +3509,7 @@ If the buffer has a wildcard pattern, check that it matches FILE.
FILE may be nil, in which case ignore it.
Return list of buffers where FUN succeeded (i.e., returned non-nil)."
(let (success-list)
- (dolist (buf (dired-buffers-for-dir (expand-file-name directory) file))
+ (dolist (buf (dired-buffers-for-dir directory file))
(with-current-buffer buf
(when (apply fun args)
(push (buffer-name buf) success-list))))
@@ -3479,8 +3558,7 @@ confirmation. To disable the confirmation, see
(file-name-nondirectory fn))))
(not dired-clean-confirm-killing-deleted-buffers))
(kill-buffer buf)))
- (let ((buf-list (dired-buffers-for-dir (expand-file-name fn)
- nil 'subdirs)))
+ (let ((buf-list (dired-buffers-for-dir fn nil 'subdirs)))
(and buf-list
(or (and dired-clean-confirm-killing-deleted-buffers
(y-or-n-p
@@ -4066,9 +4144,9 @@ Type \\[help-command] at that time for help."
(inhibit-read-only t) case-fold-search
dired-unmark-all-files-query
(string (format "\n%c" mark))
- (help-form "\
-Type SPC or `y' to unmark one file, DEL or `n' to skip to next,
-`!' to unmark all remaining files with no more questions."))
+ (help-form (substitute-command-keys "\
+Type \\`SPC' or \\`y' to unmark one file, \\`DEL' or \\`n' to skip to next,
+\\`!' to unmark all remaining files with no more questions.")))
(goto-char (point-min))
(while (if (eq mark ?\r)
(re-search-forward dired-re-mark nil t)
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index 088ca5bfeae..11559bf2f50 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -493,24 +493,69 @@ Typically \"page-%s.png\".")
(easy-menu-define doc-view-menu doc-view-mode-map
"Menu for Doc View mode."
'("DocView"
- ["Toggle display" doc-view-toggle-display]
- ("Continuous"
+ ["Next page" doc-view-next-page
+ :help "Go to the next page"]
+ ["Previous page" doc-view-previous-page
+ :help "Go to the previous page"]
+ ("Other Navigation"
+ ["Go to page..." doc-view-goto-page
+ :help "Go to specific page"]
+ "---"
+ ["First page" doc-view-first-page
+ :help "View the first page"]
+ ["Last page" doc-view-last-page
+ :help "View the last page"]
+ "---"
+ ["Move forward" doc-view-scroll-up-or-next-page
+ :help "Scroll page up or go to next page"]
+ ["Move backward" doc-view-scroll-down-or-previous-page
+ :help "Scroll page down or go to previous page"])
+ ("Continuous Scrolling"
["Off" (setq doc-view-continuous nil)
- :style radio :selected (eq doc-view-continuous nil)]
+ :style radio :selected (eq doc-view-continuous nil)
+ :help "Scrolling stops at page beginning and end"]
["On" (setq doc-view-continuous t)
- :style radio :selected (eq doc-view-continuous t)]
+ :style radio :selected (eq doc-view-continuous t)
+ :help "Scrolling continues to next or previous page"]
"---"
- ["Save as Default"
- (customize-save-variable 'doc-view-continuous doc-view-continuous) t]
+ ["Save as Default" (customize-save-variable 'doc-view-continuous doc-view-continuous)
+ :help "Save current continuous scrolling option as default"]
)
"---"
- ["Set Slice" doc-view-set-slice-using-mouse]
- ["Set Slice (BoundingBox)" doc-view-set-slice-from-bounding-box]
- ["Set Slice (manual)" doc-view-set-slice]
- ["Reset Slice" doc-view-reset-slice]
+ ("Toggle edit/display"
+ ["Edit document" doc-view-toggle-display
+ :style radio :selected (eq major-mode 'doc-view--text-view-mode)]
+ ["Display document" (lambda ()) ; ignore but show no keybinding
+ :style radio :selected (eq major-mode 'doc-view-mode)])
+ ("Adjust Display"
+ ["Fit to window" doc-view-fit-page-to-window
+ :help "Fit the image to the window"]
+ ["Fit width" doc-view-fit-width-to-window
+ :help "Fit the image width to the window width"]
+ ["Fit height" doc-view-fit-height-to-window
+ :help "Fit the image height to the window height"]
+ "---"
+ ["Enlarge" doc-view-enlarge
+ :help "Enlarge the document"]
+ ["Shrink" doc-view-shrink
+ :help "Shrink the document"]
+ "---"
+ ["Set Slice" doc-view-set-slice-using-mouse
+ :help "Set the slice of the images that should be displayed"]
+ ["Set Slice (BoundingBox)" doc-view-set-slice-from-bounding-box
+ :help "Set the slice from the document's BoundingBox information"]
+ ["Set Slice (manual)" doc-view-set-slice
+ :help "Set the slice of the images that should be displayed"]
+ ["Reset Slice" doc-view-reset-slice
+ :help "Reset the current slice"
+ :enabled (image-mode-window-get 'slice)])
"---"
- ["Search" doc-view-search]
- ["Search Backwards" doc-view-search-backward]
+ ["New Search" (doc-view-search t)
+ :help "Initiate a new search"]
+ ["Search Forward" doc-view-search
+ :help "Jump to the next match or initiate a new search"]
+ ["Search Backward" doc-view-search-backward
+ :help "Jump to the previous match or initiate a new search"]
))
(defvar doc-view-minor-mode-map
@@ -520,6 +565,16 @@ Typically \"page-%s.png\".")
map)
"Keymap used by `doc-view-minor-mode'.")
+(easy-menu-define doc-view-minor-mode-menu doc-view-minor-mode-map
+ "Menu for Doc View minor mode."
+ '("DocView (edit)"
+ ("Toggle edit/display"
+ ["Edit document" (lambda ()) ; ignore but show no keybinding
+ :style radio :selected (eq major-mode 'doc-view--text-view-mode)]
+ ["Display document" doc-view-toggle-display
+ :style radio :selected (eq major-mode 'doc-view-mode)])
+ ["Exit DocView Mode" doc-view-minor-mode]))
+
;;;; Navigation Commands
;; FIXME: The doc-view-current-* definitions below are macros because they
@@ -756,9 +811,10 @@ OpenDocument format)."
(and doc-view-dvipdfm-program
(executable-find doc-view-dvipdfm-program)))))
((memq type '(postscript ps eps pdf))
- ;; FIXME: allow mupdf here
- (and doc-view-ghostscript-program
- (executable-find doc-view-ghostscript-program)))
+ (or (and doc-view-ghostscript-program
+ (executable-find doc-view-ghostscript-program))
+ (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)
@@ -1530,16 +1586,16 @@ have the page we want to view."
(overlay-put (doc-view-current-overlay) 'display
(concat (propertize "Welcome to DocView!" 'face 'bold)
"\n"
- "
+ (substitute-command-keys "
If you see this buffer it means that the document you want to view is being
converted to PNG and the conversion of the first page hasn't finished yet or
`doc-view-conversion-refresh-interval' is set to nil.
For now these keys are useful:
-
-`q' : Bury this buffer. Conversion will go on in background.
-`k' : Kill the conversion process and this buffer.
-`K' : Kill the conversion process.\n"))))
+\\<doc-view-mode-map>
+\\[quit-window] : Bury this buffer. Conversion will go on in background.
+\\[image-kill-buffer] : Kill the conversion process and this buffer.
+\\[doc-view-kill-proc] : Kill the conversion process.\n")))))
(declare-function tooltip-show "tooltip" (text &optional use-echo-area))
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index 42c164a0881..29900a9595c 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -610,6 +610,12 @@ This function assumes that the events can be stored in a string."
(defun edmacro-fix-menu-commands (macro &optional noerror)
(if (vectorp macro)
(let (result)
+ ;; Not preloaded in without-x builds.
+ (require 'mwheel)
+ (defvar mouse-wheel-down-event)
+ (defvar mouse-wheel-left-event)
+ (defvar mouse-wheel-right-event)
+ (defvar mouse-wheel-up-event)
;; Make a list of the elements.
(setq macro (append macro nil))
(dolist (ev macro)
@@ -640,101 +646,10 @@ This function assumes that the events can be stored in a string."
;;; Parsing a human-readable keyboard macro.
(defun edmacro-parse-keys (string &optional need-vector)
- (let ((case-fold-search nil)
- (len (length string)) ; We won't alter string in the loop below.
- (pos 0)
- (res []))
- (while (and (< pos len)
- (string-match "[^ \t\n\f]+" string pos))
- (let* ((word-beg (match-beginning 0))
- (word-end (match-end 0))
- (word (substring string word-beg len))
- (times 1)
- key)
- ;; Try to catch events of the form "<as df>".
- (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word)
- (setq word (match-string 0 word)
- pos (+ word-beg (match-end 0)))
- (setq word (substring string word-beg word-end)
- pos word-end))
- (when (string-match "\\([0-9]+\\)\\*." word)
- (setq times (string-to-number (substring word 0 (match-end 1))))
- (setq word (substring word (1+ (match-end 1)))))
- (cond ((string-match "^<<.+>>$" word)
- (setq key (vconcat (if (eq (key-binding [?\M-x])
- 'execute-extended-command)
- [?\M-x]
- (or (car (where-is-internal
- 'execute-extended-command))
- [?\M-x]))
- (substring word 2 -2) "\r")))
- ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word)
- (progn
- (setq word (concat (match-string 1 word)
- (match-string 3 word)))
- (not (string-match
- "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$"
- word))))
- (setq key (list (intern word))))
- ((or (equal word "REM") (string-match "^;;" word))
- (setq pos (string-match "$" string pos)))
- (t
- (let ((orig-word word) (prefix 0) (bits 0))
- (while (string-match "^[ACHMsS]-." word)
- (cl-incf bits (cdr (assq (aref word 0)
- '((?A . ?\A-\^@) (?C . ?\C-\^@)
- (?H . ?\H-\^@) (?M . ?\M-\^@)
- (?s . ?\s-\^@) (?S . ?\S-\^@)))))
- (cl-incf prefix 2)
- (cl-callf substring word 2))
- (when (string-match "^\\^.$" word)
- (cl-incf bits ?\C-\^@)
- (cl-incf prefix)
- (cl-callf substring word 1))
- (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r")
- ("LFD" . "\n") ("TAB" . "\t")
- ("ESC" . "\e") ("SPC" . " ")
- ("DEL" . "\177")))))
- (when found (setq word (cdr found))))
- (when (string-match "^\\\\[0-7]+$" word)
- (cl-loop for ch across word
- for n = 0 then (+ (* n 8) ch -48)
- finally do (setq word (vector n))))
- (cond ((= bits 0)
- (setq key word))
- ((and (= bits ?\M-\^@) (stringp word)
- (string-match "^-?[0-9]+$" word))
- (setq key (cl-loop for x across word
- collect (+ x bits))))
- ((/= (length word) 1)
- (error "%s must prefix a single character, not %s"
- (substring orig-word 0 prefix) word))
- ((and (/= (logand bits ?\C-\^@) 0) (stringp word)
- ;; We used to accept . and ? here,
- ;; but . is simply wrong,
- ;; and C-? is not used (we use DEL instead).
- (string-match "[@-_a-z]" word))
- (setq key (list (+ bits (- ?\C-\^@)
- (logand (aref word 0) 31)))))
- (t
- (setq key (list (+ bits (aref word 0)))))))))
- (when key
- (cl-loop repeat times do (cl-callf vconcat res key)))))
- (when (and (>= (length res) 4)
- (eq (aref res 0) ?\C-x)
- (eq (aref res 1) ?\()
- (eq (aref res (- (length res) 2)) ?\C-x)
- (eq (aref res (- (length res) 1)) ?\)))
- (setq res (cl-subseq res 2 -2)))
- (if (and (not need-vector)
- (cl-loop for ch across res
- always (and (characterp ch)
- (let ((ch2 (logand ch (lognot ?\M-\^@))))
- (and (>= ch2 0) (<= ch2 127))))))
- (concat (cl-loop for ch across res
- collect (if (= (logand ch ?\M-\^@) 0)
- ch (+ ch 128))))
- res)))
+ (let ((result (kbd string)))
+ (if (and need-vector (stringp result))
+ (seq-into result 'vector)
+ result)))
(provide 'edmacro)
diff --git a/lisp/elec-pair.el b/lisp/elec-pair.el
index ba88c819133..f907bba4c6e 100644
--- a/lisp/elec-pair.el
+++ b/lisp/elec-pair.el
@@ -308,51 +308,51 @@ If point is not enclosed by any lists, return ((t) . (t))."
;; called when `scan-sexps' ran perfectly, when it found
;; a parenthesis pointing in the direction of travel.
;; Also when travel started inside a comment and exited it.
- #'(lambda ()
- (setq outermost (list t))
- (unless innermost
- (setq innermost (list t)))))
+ (lambda ()
+ (setq outermost (list t))
+ (unless innermost
+ (setq innermost (list t)))))
(ended-prematurely-fn
;; called when `scan-sexps' crashed against a parenthesis
;; pointing opposite the direction of travel. After
;; traversing that character, the idea is to travel one sexp
;; in the opposite direction looking for a matching
;; delimiter.
- #'(lambda ()
- (let* ((pos (point))
- (matched
- (save-excursion
- (cond ((< direction 0)
- (condition-case nil
- (eq (char-after pos)
- (electric-pair--with-uncached-syntax
- (table)
- (matching-paren
- (char-before
- (scan-sexps (point) 1)))))
- (scan-error nil)))
- (t
- ;; In this case, no need to use
- ;; `scan-sexps', we can use some
- ;; `electric-pair--syntax-ppss' in this
- ;; case (which uses the quicker
- ;; `syntax-ppss' in some cases)
- (let* ((ppss (electric-pair--syntax-ppss
- (1- (point))))
- (start (car (last (nth 9 ppss))))
- (opener (char-after start)))
- (and start
- (eq (char-before pos)
- (or (with-syntax-table table
- (matching-paren opener))
- opener))))))))
- (actual-pair (if (> direction 0)
- (char-before (point))
- (char-after (point)))))
- (unless innermost
- (setq innermost (cons matched actual-pair)))
- (unless matched
- (setq outermost (cons matched actual-pair)))))))
+ (lambda ()
+ (let* ((pos (point))
+ (matched
+ (save-excursion
+ (cond ((< direction 0)
+ (condition-case nil
+ (eq (char-after pos)
+ (electric-pair--with-uncached-syntax
+ (table)
+ (matching-paren
+ (char-before
+ (scan-sexps (point) 1)))))
+ (scan-error nil)))
+ (t
+ ;; In this case, no need to use
+ ;; `scan-sexps', we can use some
+ ;; `electric-pair--syntax-ppss' in this
+ ;; case (which uses the quicker
+ ;; `syntax-ppss' in some cases)
+ (let* ((ppss (electric-pair--syntax-ppss
+ (1- (point))))
+ (start (car (last (nth 9 ppss))))
+ (opener (char-after start)))
+ (and start
+ (eq (char-before pos)
+ (or (with-syntax-table table
+ (matching-paren opener))
+ opener))))))))
+ (actual-pair (if (> direction 0)
+ (char-before (point))
+ (char-after (point)))))
+ (unless innermost
+ (setq innermost (cons matched actual-pair)))
+ (unless matched
+ (setq outermost (cons matched actual-pair)))))))
(save-excursion
(while (not outermost)
(condition-case err
diff --git a/lisp/electric.el b/lisp/electric.el
index 4394fae4366..a2f24ca05c6 100644
--- a/lisp/electric.el
+++ b/lisp/electric.el
@@ -506,11 +506,11 @@ This list's members correspond to left single quote, right single
quote, left double quote, and right double quote, respectively."
:version "26.1"
:type '(list character character character character)
- :safe #'(lambda (x)
- (pcase x
- (`(,(pred characterp) ,(pred characterp)
- ,(pred characterp) ,(pred characterp))
- t)))
+ :safe (lambda (x)
+ (pcase x
+ (`(,(pred characterp) ,(pred characterp)
+ ,(pred characterp) ,(pred characterp))
+ t)))
:group 'electricity)
(defcustom electric-quote-paragraph t
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index aaacba2c8e5..d8b4c1f8850 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -32,7 +32,7 @@
(require 'lisp-mode) ;for `doc-string-elt' properties.
(require 'lisp-mnt)
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
(defvar generated-autoload-file nil
"File into which to write autoload definitions.
@@ -393,6 +393,8 @@ FILE's name."
(concat ";;; " basename
" --- automatically extracted " (or type "autoloads")
" -*- lexical-binding: t -*-\n"
+ (when (string-match "/lisp/loaddefs\\.el\\'" file)
+ ";; This file will be copied to ldefs-boot.el and checked in periodically.\n")
";;\n"
";;; Code:\n\n"
(if lp
@@ -1194,9 +1196,17 @@ directory or directories specified."
(goto-char (point-max))
(search-backward "\f" nil t)
(autoload-insert-section-header
- (current-buffer) nil nil no-autoloads (if autoload-timestamps
- no-autoloads-time
- autoload--non-timestamp))
+ (current-buffer) nil nil
+ ;; Filter out the other loaddefs files, because it makes
+ ;; the list unstable (and leads to spurious changes in
+ ;; ldefs-boot.el) since the loaddef files can be created in
+ ;; any order.
+ (seq-filter (lambda (file)
+ (not (string-match-p "[/-]loaddefs.el" file)))
+ no-autoloads)
+ (if autoload-timestamps
+ no-autoloads-time
+ autoload--non-timestamp))
(insert generate-autoload-section-trailer)))
;; Don't modify the file if its content has not been changed, so `make'
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el
index a5721aa3193..a8b484aee0b 100644
--- a/lisp/emacs-lisp/backtrace.el
+++ b/lisp/emacs-lisp/backtrace.el
@@ -55,9 +55,9 @@ order to debug the code that does fontification."
(defcustom backtrace-line-length 5000
"Target length for lines in Backtrace buffers.
Backtrace mode will attempt to abbreviate printing of backtrace
-frames to make them shorter than this, but success is not
-guaranteed. If set to nil or zero, Backtrace mode will not
-abbreviate the forms it prints."
+frames by setting `print-level' and `print-length' to make them
+shorter than this, but success is not guaranteed. If set to nil
+or zero, backtrace mode will not abbreviate the forms it prints."
:type 'integer
:group 'backtrace
:version "27.1")
@@ -751,6 +751,13 @@ property for use by navigation."
(insert (make-string (- backtrace--flags-width (- (point) beg)) ?\s))
(put-text-property beg (point) 'backtrace-section 'func)))
+(defun backtrace--line-length-or-nil ()
+ "Return `backtrace-line-length' if valid, nil else."
+ ;; mirror the logic in `cl-print-to-string-with-limits'
+ (and (natnump backtrace-line-length)
+ (not (zerop backtrace-line-length))
+ backtrace-line-length))
+
(defun backtrace--print-func-and-args (frame _view)
"Print the function, arguments and buffer position of a backtrace FRAME.
Format it according to VIEW."
@@ -769,11 +776,16 @@ Format it according to VIEW."
(if (atom fun)
(funcall backtrace-print-function fun)
(insert
- (backtrace--print-to-string fun (when args (/ backtrace-line-length 2)))))
+ (backtrace--print-to-string
+ fun
+ (when (and args (backtrace--line-length-or-nil))
+ (/ backtrace-line-length 2)))))
(if args
(insert (backtrace--print-to-string
- args (max (truncate (/ backtrace-line-length 5))
- (- backtrace-line-length (- (point) beg)))))
+ args
+ (if (backtrace--line-length-or-nil)
+ (max (truncate (/ backtrace-line-length 5))
+ (- backtrace-line-length (- (point) beg))))))
;; The backtrace-form property is so that backtrace-multi-line
;; will find it. backtrace-multi-line doesn't do anything
;; useful with it, just being consistent.
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index c8990f23531..2bdf1f55111 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -342,8 +342,12 @@ for speeding up processing.")
(numberp expr)
(stringp expr)
(and (consp expr)
- (memq (car expr) '(quote function))
- (symbolp (cadr 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)))))
(keywordp expr)))
(defmacro byte-optimize--pcase (exp &rest cases)
@@ -1261,7 +1265,7 @@ See Info node `(elisp) Integer Basics'."
(list 'or (car (car clauses))
(byte-optimize-cond
(cons (car form) (cdr (cdr form)))))
- form))
+ (and clauses form)))
form))
(defun byte-optimize-if (form)
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index da86fa5cecf..2ce2efd2aa7 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -134,6 +134,7 @@ The return value of this function is not used."
:autoload-end
(eval-and-compile
(defun ,cfname (,@(car data) ,@args)
+ (ignore ,@(delq '&rest (delq '&optional (copy-sequence args))))
,@(cdr data))))))))
(defalias 'byte-run--set-doc-string
@@ -380,7 +381,7 @@ You don't need this. (See bytecomp.el commentary for more details.)
"Define an inline function. The syntax is just like that of `defun'.
\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)"
- (declare (debug defun) (doc-string 3))
+ (declare (debug defun) (doc-string 3) (indent 2))
(or (memq (get name 'byte-optimizer)
'(nil byte-compile-inline-expand))
(error "`%s' is a primitive" name))
@@ -434,7 +435,7 @@ WHEN should be a string indicating when the function was first
made obsolete, for example a date or a release number.
See the docstrings of `defalias' and `make-obsolete' for more details."
- (declare (doc-string 4))
+ (declare (doc-string 4) (indent defun))
`(progn
(defalias ,obsolete-name ,current-name ,docstring)
(make-obsolete ,obsolete-name ,current-name ,when)))
@@ -483,7 +484,7 @@ For the benefit of Customize, if OBSOLETE-NAME has
any of the following properties, they are copied to
CURRENT-NAME, if it does not already have them:
`saved-value', `saved-variable-comment'."
- (declare (doc-string 4))
+ (declare (doc-string 4) (indent defun))
`(progn
(defvaralias ,obsolete-name ,current-name ,docstring)
;; See Bug#4706.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 3f050d1b799..a98c9197a06 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -299,7 +299,7 @@ The information is logged to `byte-compile-log-buffer'."
'(redefine callargs free-vars unresolved
obsolete noruntime interactive-only
make-local mapcar constants suspicious lexical lexical-dynamic
- docstrings)
+ docstrings not-unused)
"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 all).
@@ -321,6 +321,7 @@ Elements of the list may be:
lexically bound variable declared dynamic elsewhere
make-local calls to `make-variable-buffer-local' that may be incorrect.
mapcar mapcar called for effect.
+ 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
@@ -343,6 +344,7 @@ suppress. For example, (not mapcar) will suppress warnings about mapcar."
(or (symbolp v)
(null (delq nil (mapcar (lambda (x) (not (symbolp x))) v))))))
+;;;###autoload
(defun byte-compile-warning-enabled-p (warning &optional symbol)
"Return non-nil if WARNING is enabled, according to `byte-compile-warnings'."
(let ((suppress nil))
@@ -1671,9 +1673,14 @@ URLs."
;; known at compile time. So instead, we assume that these
;; substitutions are of some length N.
(replace-regexp-in-string
- (rx "\\" (or (seq "[" (* (not "]")) "]")))
+ (rx "\\[" (* (not "]")) "]")
(make-string byte-compile--wide-docstring-substitution-len ?x)
- docstring))))
+ ;; 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)))))
(defcustom byte-compile-docstring-max-column 80
"Recommended maximum width of doc string lines.
@@ -1705,10 +1712,10 @@ It is too wide if it has any lines longer than the largest of
(nth 2 form)))))
(when (and (consp name) (eq (car name) 'quote))
(setq name (cadr name)))
- (setq name (if name (format " `%s'" name) ""))
+ (setq name (if name (format " `%s' " name) ""))
(when (and kind docs (stringp docs)
(byte-compile--wide-docstring-p docs col))
- (byte-compile-warn "%s%s docstring wider than %s characters"
+ (byte-compile-warn "%s%sdocstring wider than %s characters"
kind name col))))
form)
@@ -2223,8 +2230,7 @@ With argument ARG, insert value in current buffer after the form."
(byte-compile-depth 0)
(byte-compile-maxdepth 0)
(byte-compile-output nil)
- ;; This allows us to get the positions of symbols read; it's
- ;; new in Emacs 22.1.
+ ;; This allows us to get the positions of symbols read.
(read-with-symbol-positions inbuffer)
(read-symbol-positions-list nil)
;; #### This is bound in b-c-close-variables.
@@ -2671,15 +2677,6 @@ list that represents a doc string reference.
(prog1 (byte-compile-keep-pending form)
(apply 'make-obsolete (mapcar 'eval (cdr form)))))
-;; This handler is not necessary, but it makes the output from dont-compile
-;; and similar macros cleaner.
-(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval)
-(defun byte-compile-file-form-eval (form)
- (if (and (eq (car-safe (nth 1 form)) 'quote)
- (equal (nth 2 form) lexical-binding))
- (nth 1 (nth 1 form))
- (byte-compile-keep-pending form)))
-
(defun byte-compile-file-form-defmumble (name macro arglist body rest)
"Process a `defalias' for NAME.
If MACRO is non-nil, the definition is known to be a macro.
@@ -5042,6 +5039,8 @@ binding slots have been popped."
nil))
(_ (byte-compile-keep-pending form))))
+
+
;;; tags
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 0a6b04b4c1f..7cec91bfa82 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -304,6 +304,25 @@ of converted forms."
`(,@(nreverse special-forms) ,@(macroexp-unprogn body))))
funcbody)))
+(defun cconv--lifted-arg (var env)
+ "The argument to use for VAR in λ-lifted calls according to ENV.
+This is used when VAR is being shadowed; we may still need its value for
+such calls."
+ (let ((mapping (cdr (assq var env))))
+ (pcase-exhaustive mapping
+ (`(internal-get-closed-var . ,_)
+ ;; The variable is captured.
+ mapping)
+ (`(car-safe ,exp)
+ ;; The variable is mutably captured; skip
+ ;; the indirection step because the variable is
+ ;; passed "by reference" to the λ-lifted function.
+ exp)
+ (_
+ ;; The variable is not captured; use the (shadowed) variable value.
+ ;; (If the mapping is `(car-safe SYMBOL)', SYMBOL is always VAR.
+ var))))
+
(defun cconv-convert (form env extend)
;; This function actually rewrites the tree.
"Return FORM with all its lambdas changed so they are closed.
@@ -428,10 +447,11 @@ places where they originally did not directly appear."
;; One of the lambda-lifted vars is shadowed, so add
;; a reference to the outside binding and arrange to use
;; that reference.
- (let ((closedsym (make-symbol (format "closed-%s" var))))
+ (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))
(setq new-extend (cons closedsym (remq var new-extend)))
- (push `(,closedsym ,var) binders-new)))
+ (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
@@ -449,14 +469,13 @@ places where they originally did not directly appear."
;; 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, so add
- ;; a reference to the outside binding and arrange to use
- ;; that reference.
+ ;; 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) binders-new)))))
+ (push `(,closedsym ,var-def) binders-new)))))
`(,letsym ,(nreverse binders-new)
. ,(mapcar (lambda (form)
@@ -608,10 +627,9 @@ FORM is the parent form that binds this var."
(`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_)
,_ ,_ ,_ ,_)
;; FIXME: Convert this warning to use `macroexp--warn-wrap'
- ;; so as to give better position information and obey
- ;; `byte-compile-warnings'.
- (byte-compile-warn
- "%s `%S' not left unused" varkind var))
+ ;; so as to give better position information.
+ (when (byte-compile-warning-enabled-p 'not-unused var)
+ (byte-compile-warn "%s `%S' not left unused" varkind var)))
((and (let (or 'let* 'let) (car form))
`((,var) ;; (or `(,var nil) : Too many false positives: bug#47080
t nil ,_ ,_))
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index e03ddc4c666..ab2f34c3104 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -339,6 +339,7 @@ See Info node `(elisp) Documentation Tips' for background."
;; (setq checkdoc--argument-missing-flag nil) ; optional
;; (setq checkdoc--disambiguate-symbol-flag nil) ; optional
;; (setq checkdoc--interactive-docstring-flag nil) ; optional
+;; (setq checkdoc-verb-check-experimental-flag nil)
;; Then use `M-x find-dired' ("-name '*.el'") and `M-x checkdoc-dired'
(defvar checkdoc--argument-missing-flag t
@@ -493,6 +494,9 @@ be re-created.")
(defconst checkdoc--help-buffer "*Checkdoc Help*"
"Name of buffer used for Checkdoc Help.")
+(defvar checkdoc-commentary-header-string "\n;;; Commentary:\n;; \n\n"
+ "String inserted as commentary marker in `checkdoc-file-comments-engine'.")
+
;;; User level commands
;;
;;;###autoload
@@ -1112,6 +1116,7 @@ space at the end of each line."
";;; lisp/trampver.el. Generated from trampver.el.in by configure."))
"Regexp that when it matches tells `checkdoc-dired' to skip a file.")
+;;;###autoload
(defun checkdoc-dired (files)
"In Dired, run `checkdoc' on marked files.
Skip anything that doesn't have the Emacs Lisp library file
@@ -2125,13 +2130,11 @@ Examples of recognized abbreviations: \"e.g.\", \"i.e.\", \"cf.\"."
;; a part of a list.
(rx letter ".")
(rx (or
- ;; The abbreviations:
+ ;; The abbreviations (a trailing dot is added below).
(seq (any "cC") "f") ; cf.
(seq (any "eE") ".g") ; e.g.
(seq (any "iI") "." (any "eE")) ; i.e.
- "a.k.a" ; a.k.a.
- "etc" ; etc.
- "vs" ; vs.
+ "a.k.a" "etc" "vs" "N.B"
;; Some non-standard or less common ones that we
;; might as well accept.
"Inc" "Univ" "misc" "resp")
@@ -2410,7 +2413,7 @@ Code:, and others referenced in the style guide."
nil nil t)))
(if (checkdoc-y-or-n-p
"You should have a \";;; Commentary:\", add one?")
- (insert "\n;;; Commentary:\n;; \n\n")
+ (insert checkdoc-commentary-header-string)
(checkdoc-create-error
"You should have a section marked \";;; Commentary:\""
nil nil t)))
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 4834fb13c6a..9de47e4987d 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -86,6 +86,14 @@
;;; Code:
+;; We provide a mechanism to define new specializers.
+;; Related work can be found in:
+;; - http://www.p-cos.net/documents/filtered-dispatch.pdf
+;; - Generalizers: New metaobjects for generalized dispatch
+;; http://research.gold.ac.uk/9924/1/els-specializers.pdf
+;; This second one is closely related to what we do here (and that's
+;; the name "generalizer" comes from).
+
;; The autoloads.el mechanism which adds package--builtin-versions
;; maintenance to loaddefs.el doesn't work for preloaded packages (such
;; as this one), so we have to do it by hand!
@@ -100,6 +108,7 @@
(eval-when-compile (require 'cl-lib))
(eval-when-compile (require 'cl-macs)) ;For cl--find-class.
(eval-when-compile (require 'pcase))
+(eval-when-compile (require 'subr-x))
(cl-defstruct (cl--generic-generalizer
(:constructor nil)
@@ -589,19 +598,10 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
;; e.g. for tracing/debug-on-entry.
(defalias sym gfun)))))
-(defmacro cl--generic-with-memoization (place &rest code)
- (declare (indent 1) (debug t))
- (gv-letplace (getter setter) place
- `(or ,getter
- ,(macroexp-let2 nil val (macroexp-progn code)
- `(progn
- ,(funcall setter val)
- ,val)))))
-
(defvar cl--generic-dispatchers (make-hash-table :test #'equal))
(defun cl--generic-get-dispatcher (dispatch)
- (cl--generic-with-memoization
+ (with-memoization
(gethash dispatch cl--generic-dispatchers)
;; (message "cl--generic-get-dispatcher (%S)" dispatch)
(let* ((dispatch-arg (car dispatch))
@@ -644,10 +644,13 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
;; overkill: better just use a `cl-typep' test.
(byte-compile
`(lambda (generic dispatches-left methods)
+ ;; FIXME: We should find a way to expand `with-memoize' once
+ ;; and forall so we don't need `subr-x' when we get here.
+ (eval-when-compile (require 'subr-x))
(let ((method-cache (make-hash-table :test #'eql)))
(lambda (,@fixedargs &rest args)
(let ,bindings
- (apply (cl--generic-with-memoization
+ (apply (with-memoization
(gethash ,tag-exp method-cache)
(cl--generic-cache-miss
generic ',dispatch-arg dispatches-left methods
@@ -684,14 +687,14 @@ This is particularly useful when many different tags select the same set
of methods, since this table then allows us to share a single combined-method
for all those different tags in the method-cache.")
-(define-error 'cl--generic-cyclic-definition "Cyclic definition: %S")
+(define-error 'cl--generic-cyclic-definition "Cyclic definition")
(defun cl--generic-build-combined-method (generic methods)
(if (null methods)
;; Special case needed to fix a circularity during bootstrap.
(cl--generic-standard-method-combination generic methods)
(let ((f
- (cl--generic-with-memoization
+ (with-memoization
;; FIXME: Since the fields of `generic' are modified, this
;; hash-table won't work right, because the hashes will change!
;; It's not terribly serious, but reduces the effectiveness of
@@ -1143,7 +1146,7 @@ These match if the argument is a cons cell whose car is `eql' to VAL."
;; since we can't use the `head' specializer to implement itself.
(if (not (eq (car-safe specializer) 'head))
(cl-call-next-method)
- (cl--generic-with-memoization
+ (with-memoization
(gethash (cadr specializer) cl--generic-head-used)
specializer)
(list cl--generic-head-generalizer)))
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 317a4c62309..b01a32ca60c 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -560,4 +560,9 @@ of record objects."
(t
(advice-remove 'type-of #'cl--old-struct-type-of))))
+(defun cl-constantly (value)
+ "Return a function that takes any number of arguments, but returns VALUE."
+ (lambda (&rest _)
+ value))
+
;;; cl-lib.el ends here
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 1852471bcbb..f78fdcf0085 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3050,7 +3050,7 @@ To see the documentation for a defined struct type, use
`(,predicate cl-x))))
(when pred-form
(push `(,defsym ,predicate (cl-x)
- (declare (side-effect-free error-free))
+ (declare (side-effect-free error-free) (pure t))
,(if (eq (car pred-form) 'and)
(append pred-form '(t))
`(and ,pred-form t)))
@@ -3365,6 +3365,7 @@ Of course, we really can't know that for sure, so it's just a heuristic."
(integer . integerp)
(keyword . keywordp)
(list . listp)
+ (natnum . natnump)
(number . numberp)
(null . null)
(real . numberp)
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 5518cdb4c90..3e816195209 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -70,7 +70,7 @@
(irange &aux
(range (list irange))
(typeset ())))
- (:copier comp-cstr-shallow-copy))
+ (:copier nil))
"Internal representation of a type/value constraint."
(typeset '(t) :type list
:documentation "List of possible types the mvar can assume.
@@ -133,6 +133,14 @@ Integer values are handled in the `range' slot.")
:range (copy-tree (range cstr))
:neg (neg cstr))))
+(defsubst comp-cstr-shallow-copy (dst src)
+ "Copy the content of SRC into DST."
+ (with-comp-cstr-accessors
+ (setf (range dst) (range src)
+ (valset dst) (valset src)
+ (typeset dst) (typeset src)
+ (neg dst) (neg src))))
+
(defsubst comp-cstr-empty-p (cstr)
"Return t if CSTR is equivalent to the nil type specifier or nil otherwise."
(with-comp-cstr-accessors
@@ -438,10 +446,7 @@ Return them as multiple value."
ext-range)
ext-range)
(neg dst) nil)
- (setf (typeset dst) (typeset old-dst)
- (valset dst) (valset old-dst)
- (range dst) (range old-dst)
- (neg dst) (neg old-dst)))))
+ (comp-cstr-shallow-copy dst old-dst))))
(defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body)
;; Prevent some code duplication for `comp-cstr-add-2'
@@ -581,10 +586,8 @@ DST is returned."
(when (range pos)
'(integer)))))
(typeset neg)))
- (setf (typeset dst) (typeset pos)
- (valset dst) (valset pos)
- (range dst) (range pos)
- (neg dst) nil)
+ (comp-cstr-shallow-copy dst pos)
+ (setf (neg dst) nil)
(cl-return-from comp-cstr-union-1-no-mem dst))
;; Verify disjoint condition between positive types and
@@ -631,15 +634,9 @@ DST is returned."
(comp-range-negation (range neg))
(range pos))))))
- (if (comp-cstr-empty-p neg)
- (setf (typeset dst) (typeset pos)
- (valset dst) (valset pos)
- (range dst) (range pos)
- (neg dst) nil)
- (setf (typeset dst) (typeset neg)
- (valset dst) (valset neg)
- (range dst) (range neg)
- (neg dst) (neg neg)))))
+ (comp-cstr-shallow-copy dst (if (comp-cstr-empty-p neg)
+ pos
+ neg))))
;; (not null) => t
(when (and (neg dst)
@@ -663,10 +660,7 @@ DST is returned."
(mapcar #'comp-cstr-copy srcs)
(apply #'comp-cstr-union-1-no-mem range srcs)
mem-h))))
- (setf (typeset dst) (typeset res)
- (valset dst) (valset res)
- (range dst) (range res)
- (neg dst) (neg res))
+ (comp-cstr-shallow-copy dst res)
res)))
(cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs)
@@ -753,10 +747,8 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
;; In case pos is not relevant return directly the content
;; of neg.
(when (equal (typeset pos) '(t))
- (setf (typeset dst) (typeset neg)
- (valset dst) (valset neg)
- (range dst) (range neg)
- (neg dst) t)
+ (comp-cstr-shallow-copy dst neg)
+ (setf (neg dst) t)
;; (not t) => nil
(when (and (null (valset dst))
@@ -800,10 +792,8 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
(cl-set-difference (valset pos) (valset neg)))
;; Return a non negated form.
- (setf (typeset dst) (typeset pos)
- (valset dst) (valset pos)
- (range dst) (range pos)
- (neg dst) nil)))
+ (comp-cstr-shallow-copy dst pos)
+ (setf (neg dst) nil)))
dst))))
@@ -883,7 +873,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
"Constraint OP1 being = OP2 setting the result into DST."
(with-comp-cstr-accessors
(cl-flet ((relax-cstr (cstr)
- (setf cstr (comp-cstr-shallow-copy cstr))
+ (setf cstr (copy-sequence cstr))
;; If can be any float extend it to all integers.
(when (memq 'float (typeset cstr))
(setf (range cstr) '((- . +))))
@@ -1008,10 +998,7 @@ DST is returned."
(mapcar #'comp-cstr-copy srcs)
(apply #'comp-cstr-intersection-no-mem srcs)
mem-h))))
- (setf (typeset dst) (typeset res)
- (valset dst) (valset res)
- (range dst) (range res)
- (neg dst) (neg res))
+ (comp-cstr-shallow-copy dst res)
res)))
(defun comp-cstr-intersection-no-hashcons (dst &rest srcs)
@@ -1067,10 +1054,9 @@ DST is returned."
(valset dst) ()
(range dst) nil
(neg dst) nil))
- (t (setf (typeset dst) (typeset src)
- (valset dst) (valset src)
- (range dst) (range src)
- (neg dst) (not (neg src)))))
+ (t
+ (comp-cstr-shallow-copy dst src)
+ (setf (neg dst) (not (neg src)))))
dst))
(defun comp-cstr-value-negation (dst src)
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 0a105052570..b51224088f1 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -3086,13 +3086,6 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or
(`(setimm ,lval ,v)
(setf (comp-cstr-imm lval) v))))))
-(defun comp-mvar-propagate (lval rval)
- "Propagate into LVAL properties of RVAL."
- (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval)
- (comp-mvar-valset lval) (comp-mvar-valset rval)
- (comp-mvar-range lval) (comp-mvar-range rval)
- (comp-mvar-neg lval) (comp-mvar-neg rval)))
-
(defun comp-function-foldable-p (f args)
"Given function F called with ARGS, return non-nil when optimizable."
(and (comp-function-pure-p f)
@@ -3142,10 +3135,7 @@ Fold the call in case."
(when (comp-cstr-empty-p cstr)
;; Store it to be rewritten as non local exit.
(setf (comp-block-lap-non-ret-insn comp-block) insn))
- (setf (comp-mvar-range lval) (comp-cstr-range cstr)
- (comp-mvar-valset lval) (comp-cstr-valset cstr)
- (comp-mvar-typeset lval) (comp-cstr-typeset cstr)
- (comp-mvar-neg lval) (comp-cstr-neg cstr))))
+ (comp-cstr-shallow-copy lval cstr)))
(cl-case f
(+ (comp-cstr-add lval args))
(- (comp-cstr-sub lval args))
@@ -3163,9 +3153,9 @@ Fold the call in case."
(let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt)))))
(comp-fwprop-call insn lval f args)))
(_
- (comp-mvar-propagate lval rval))))
+ (comp-cstr-shallow-copy lval rval))))
(`(assume ,lval ,(and (pred comp-mvar-p) rval))
- (comp-mvar-propagate lval rval))
+ (comp-cstr-shallow-copy lval rval))
(`(assume ,lval (,kind . ,operands))
(cl-case kind
(and
diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el
index d24ea355a51..59cbc0e50d5 100644
--- a/lisp/emacs-lisp/crm.el
+++ b/lisp/emacs-lisp/crm.el
@@ -244,30 +244,29 @@ contents of the minibuffer are \"alice,bob,eve\" and point is between
This function returns a list of the strings that were read,
with empty strings removed."
- (unwind-protect
- (progn
- (add-hook 'choose-completion-string-functions
- 'crm--choose-completion-string)
- (let* ((minibuffer-completion-table #'crm--collection-fn)
- (minibuffer-completion-predicate predicate)
- ;; see completing_read in src/minibuf.c
- (minibuffer-completion-confirm
- (unless (eq require-match t) require-match))
- (crm-completion-table table)
- (map (if require-match
- crm-local-must-match-map
- crm-local-completion-map))
- ;; If the user enters empty input, `read-from-minibuffer'
- ;; returns the empty string, not DEF.
- (input (read-from-minibuffer
- prompt initial-input map
- nil hist def inherit-input-method)))
- (when (and def (string-equal input ""))
- (setq input (if (consp def) (car def) def)))
- ;; Remove empty strings in the list of read strings.
- (split-string input crm-separator t)))
- (remove-hook 'choose-completion-string-functions
- 'crm--choose-completion-string)))
+ (let* ((map (if require-match
+ crm-local-must-match-map
+ crm-local-completion-map))
+ input)
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (add-hook 'choose-completion-string-functions
+ 'crm--choose-completion-string nil 'local)
+ (setq-local minibuffer-completion-table #'crm--collection-fn)
+ (setq-local minibuffer-completion-predicate predicate)
+ ;; see completing_read in src/minibuf.c
+ (setq-local minibuffer-completion-confirm
+ (unless (eq require-match t) require-match))
+ (setq-local crm-completion-table table))
+ (setq input (read-from-minibuffer
+ prompt initial-input map
+ nil hist def inherit-input-method)))
+ ;; If the user enters empty input, `read-from-minibuffer'
+ ;; returns the empty string, not DEF.
+ (when (and def (string-equal input ""))
+ (setq input (if (consp def) (car def) def)))
+ ;; Remove empty strings in the list of read strings.
+ (split-string input crm-separator t)))
;; testing and debugging
;; (defun crm-init-test-environ ()
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 0592db85df4..163528acf6f 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -701,7 +701,8 @@ To specify a nil argument interactively, exit with an empty minibuffer."
(interactive
(list (let ((name
(completing-read
- "Cancel debug on entry to function (default all functions): "
+ (format-prompt "Cancel debug on entry to function"
+ "all functions")
(mapcar #'symbol-name (debug--function-list)) nil t)))
(when name
(unless (string= name "")
@@ -804,7 +805,8 @@ To specify a nil argument interactively, exit with an empty minibuffer."
(interactive
(list (let ((name
(completing-read
- "Cancel debug on set for variable (default all variables): "
+ (format-prompt "Cancel debug on set for variable"
+ "all variables")
(mapcar #'symbol-name (debug--variable-list)) nil t)))
(when name
(unless (string= name "")
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index dd30846546b..af5eecc22a5 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -175,12 +175,7 @@ See Info node `(elisp)Derived Modes' for more details.
(declare (debug (&define name symbolp sexp [&optional stringp]
[&rest keywordp sexp] def-body))
(doc-string 4)
- ;; Ask not what
- ;;(indent 3)
- ;; can do for you, ask what it can do to others. IOW, the
- ;; missing of indentation setting here is the indentation
- ;; setting and not an oversight.
- )
+ (indent defun))
(when (and docstring (not (stringp docstring)))
;; Some trickiness, since what appears to be the docstring may really be
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index f752861d80a..db86e0e0292 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -198,6 +198,7 @@ INIT-VALUE LIGHTER KEYMAP.
\(fn MODE DOC [KEYWORD VAL ... &rest BODY])"
(declare (doc-string 2)
+ (indent defun)
(debug (&define name string-or-null-p
[&optional [&not keywordp] sexp
&optional [&not keywordp] sexp
@@ -450,7 +451,7 @@ after running the major mode's hook. However, MODE is not turned
on if the hook has explicitly disabled it.
\(fn GLOBAL-MODE MODE TURN-ON [KEY VALUE]... BODY...)"
- (declare (doc-string 2))
+ (declare (doc-string 2) (indent defun))
(let* ((global-mode-name (symbol-name global-mode))
(mode-name (symbol-name mode))
(pretty-name (easy-mmode-pretty-mode-name mode))
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 1ef29599512..ac1cd22ac27 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -3519,7 +3519,8 @@ The removes the effect of `edebug-on-entry'. If FUNCTION is
nil, remove `edebug-on-entry' on all functions."
(interactive
(list (let ((name (completing-read
- "Cancel edebug on entry to (default all functions): "
+ (format-prompt "Cancel edebug on entry to"
+ "all functions")
(let ((functions (edebug--edebug-on-entry-functions)))
(unless functions
(user-error "No functions have `edebug-on-entry'"))
@@ -4548,7 +4549,8 @@ instrumentation for, defaulting to all functions."
(user-error "Found no functions to remove instrumentation from"))
(let ((name
(completing-read
- "Remove instrumentation from (default all functions): "
+ (format-prompt "Remove instrumentation from"
+ "all functions")
functions)))
(if (and name
(not (equal name "")))
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index 6d84839c341..a5f37500092 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -5,6 +5,7 @@
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: OO, lisp
;; Package: eieio
+;; Obsolete-Since: 25.1
;; This file is part of GNU Emacs.
@@ -70,7 +71,8 @@ is appropriate to use. Uses `defmethod' to create methods, and calls
`defgeneric' for you. With this implementation the ARGS are
currently ignored. You can use `defgeneric' to apply specialized
top level documentation to a method."
- (declare (doc-string 3) (obsolete cl-defgeneric "25.1"))
+ (declare (doc-string 3) (obsolete cl-defgeneric "25.1")
+ (indent defun))
`(eieio--defalias ',method
(eieio--defgeneric-init-form
',method
@@ -103,6 +105,7 @@ Summary:
\"doc-string\"
body)"
(declare (doc-string 3) (obsolete cl-defmethod "25.1")
+ (indent defun)
(debug
(&define ; this means we are defining something
[&name sexp] ;Allow (setf ...) additionally to symbols.
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 80d1711d817..ca47ec77f76 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -450,7 +450,7 @@ See `defclass' for more information."
))
;; Now that everything has been loaded up, all our lists are backwards!
- ;; Fix that up now and then them into vectors.
+ ;; Fix that up now and turn them into vectors.
(cl-callf (lambda (slots) (apply #'vector (nreverse slots)))
(eieio--class-slots newc))
(cl-callf nreverse (eieio--class-initarg-tuples newc))
@@ -478,7 +478,8 @@ See `defclass' for more information."
;; (dotimes (cnt (length cslots))
;; (setf (gethash (cl--slot-descriptor-name (aref cslots cnt)) oa) (- -1 cnt)))
(dotimes (cnt (length slots))
- (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) cnt))
+ (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa)
+ (+ (eval-when-compile eieio--object-num-slots) cnt)))
(setf (eieio--class-index-table newc) oa))
;; Set up a specialized doc string.
@@ -508,6 +509,7 @@ See `defclass' for more information."
;; Create the cached default object.
(let ((cache (make-record newc
(+ (length (eieio--class-slots newc))
+ ;; FIXME: Why +1 -1 ?
(eval-when-compile eieio--object-num-slots)
-1)
nil)))
@@ -702,11 +704,15 @@ an error."
nil
;; Trim off object IDX junk added in for the object index.
(setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots)))
- (let ((st (cl--slot-descriptor-type (aref (eieio--class-slots class)
- slot-idx))))
- (if (not (eieio--perform-slot-validation st value))
- (signal 'invalid-slot-type
- (list (eieio--class-name class) slot st value))))))
+ (let* ((sd (aref (eieio--class-slots class)
+ slot-idx))
+ (st (cl--slot-descriptor-type sd)))
+ (cond
+ ((not (eieio--perform-slot-validation st value))
+ (signal 'invalid-slot-type
+ (list (eieio--class-name class) slot st value)))
+ ((alist-get :read-only (cl--slot-descriptor-props sd))
+ (signal 'eieio-read-only (list (eieio--class-name class) slot)))))))
(defun eieio--validate-class-slot-value (class slot-idx value slot)
"Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
@@ -747,7 +753,7 @@ Argument FN is the function calling this verifier."
(_ exp))))
(gv-setter eieio-oset))
(cl-check-type slot symbol)
- (cl-check-type obj (or eieio-object class))
+ (cl-check-type obj (or eieio-object class cl-structure-object))
(let* ((class (cond ((symbolp obj)
(error "eieio-oref called on a class: %s" obj)
(eieio--full-class-object obj))
@@ -763,7 +769,7 @@ Argument FN is the function calling this verifier."
;; to intercept missing slot definitions. Since it is also the LAST
;; thing called in this fn, its return value would be retrieved.
(slot-missing obj slot 'oref))
- (cl-check-type obj eieio-object)
+ (cl-check-type obj (or eieio-object cl-structure-object))
(eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref))))
@@ -811,7 +817,7 @@ Fills in CLASS's SLOT with its default value."
(defun eieio-oset (obj slot value)
"Do the work for the macro `oset'.
Fills in OBJ's SLOT with VALUE."
- (cl-check-type obj eieio-object)
+ (cl-check-type obj (or eieio-object cl-structure-object))
(cl-check-type slot symbol)
(let* ((class (eieio--object-class obj))
(c (eieio--slot-name-index class slot)))
@@ -892,7 +898,7 @@ reverse-lookup that name, and recurse with the associated slot value."
;; Removed checks to outside this call
(let* ((fsi (gethash slot (eieio--class-index-table class))))
(if (integerp fsi)
- (+ (eval-when-compile eieio--object-num-slots) fsi)
+ fsi
(let ((fn (eieio--initarg-to-attribute class slot)))
(if fn
;; Accessing a slot via its :initarg is accepted by EIEIO
@@ -1061,6 +1067,7 @@ method invocation orders of the involved classes."
;;
(define-error 'invalid-slot-name "Invalid slot name")
(define-error 'invalid-slot-type "Invalid slot type")
+(define-error 'eieio-read-only "Read-only slot")
(define-error 'unbound-slot "Unbound slot")
(define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy")
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index 9c842f46829..680395387c2 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -130,6 +130,7 @@ are not abstract."
;;;###autoload
(defun eieio-help-constructor (ctr)
"Describe CTR if it is a class constructor."
+ (declare (obsolete "use `describe-function' or `cl--describe-class'." "29.1"))
(when (class-p ctr)
(erase-buffer)
(let ((location (find-lisp-object-file-name ctr 'define-type))
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 2dc3e0aeffa..2850c91ecdf 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -110,7 +110,7 @@ Options in CLOS not supported in EIEIO:
Due to the way class options are set up, you can add any tags you wish,
and reference them using the function `class-option'."
- (declare (doc-string 4))
+ (declare (doc-string 4) (indent defun))
(cl-check-type superclasses list)
(cond ((and (stringp (car options-and-doc))
@@ -359,9 +359,7 @@ variable name of the same name as the slot."
(defun eieio-pcase-slot-index-from-index-table (index-table slot)
"Find the index to pass to `aref' to access SLOT."
- (let ((index (gethash slot index-table)))
- (if index (+ (eval-when-compile eieio--object-num-slots)
- index))))
+ (gethash slot index-table))
(pcase-defmacro eieio (&rest fields)
"Pcase patterns that match EIEIO object EXPVAL.
@@ -994,11 +992,6 @@ of `eq'."
(error "EIEIO: `change-class' is unimplemented"))
(define-obsolete-function-alias 'change-class #'eieio-change-class "26.1")
-;; Hook ourselves into help system for describing classes and methods.
-;; FIXME: This is not actually needed any more since we can click on the
-;; hyperlink from the constructor's docstring to see the type definition.
-(add-hook 'help-fns-describe-function-functions #'eieio-help-constructor)
-
(provide 'eieio)
;;; eieio.el ends here
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index a1c3c3268f2..cd0e7dca7cf 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -380,7 +380,15 @@ Also store it in `eldoc-last-message' and return that value."
;; it undesirable to print eldoc messages right this instant.
(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))))
+ (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.
+ (and (boundp 'show-paren-context-when-offscreen)
+ show-paren-context-when-offscreen
+ (not (pos-visible-in-window-p
+ (overlay-end show-paren--overlay)))))))
(defvar eldoc-documentation-functions nil
diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el
index 8c33b7c9948..fdd0ad6666e 100644
--- a/lisp/emacs-lisp/elp.el
+++ b/lisp/emacs-lisp/elp.el
@@ -202,14 +202,13 @@ This variable is set by the master function.")
(defvar elp-not-profilable
;; First, the functions used inside each instrumented function:
'(called-interactively-p
- ;; Then the functions used by the above functions. I used
- ;; (delq nil (mapcar (lambda (x) (and (symbolp x) (fboundp x) x))
- ;; (aref (symbol-function 'elp-wrapper) 2)))
- ;; to help me find this list.
- error call-interactively apply current-time
+ ;; (delq
+ ;; nil (mapcar
+ ;; (lambda (x) (and (symbolp x) (fboundp x) x))
+ ;; (aref (aref (aref (symbol-function 'elp--make-wrapper) 2) 1) 2)))
+ error apply current-time float-time time-subtract
;; Andreas Politz reports problems profiling these (Bug#4233):
- + byte-code-function-p functionp byte-code subrp
- indirect-function fboundp)
+ + byte-code-function-p functionp byte-code subrp fboundp)
"List of functions that cannot be profiled.
Those functions are used internally by the profiling code and profiling
them would thus lead to infinite recursion.")
@@ -299,10 +298,18 @@ For example, to instrument all ELP functions, do the following:
'intern
(all-completions prefix obarray 'elp-profilable-p))))
+(defun elp-restore-package (prefix)
+ "Remove instrumentation from functions with names starting with PREFIX."
+ (interactive "SPrefix: ")
+ (elp-restore-list
+ (mapcar #'intern
+ (all-completions (symbol-name prefix)
+ obarray 'elp-profilable-p))))
+
(defun elp-restore-list (&optional list)
"Restore the original definitions for all functions in `elp-function-list'.
Use optional LIST if provided instead."
- (interactive "PList of functions to restore: ") ;FIXME: Doesn't work!?
+ (interactive)
(mapcar #'elp-restore-function (or list elp-function-list)))
(defun elp-restore-all ()
@@ -324,7 +331,7 @@ Use optional LIST if provided instead."
(defun elp-reset-list (&optional list)
"Reset the profiling information for all functions in `elp-function-list'.
Use optional LIST if provided instead."
- (interactive "PList of functions to reset: ") ;FIXME: Doesn't work!?
+ (interactive)
(let ((list (or list elp-function-list)))
(mapcar 'elp-reset-function list)))
diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el
index 3fc57d5182d..7fc316d1469 100644
--- a/lisp/emacs-lisp/ert-x.el
+++ b/lisp/emacs-lisp/ert-x.el
@@ -352,7 +352,6 @@ convert it to a string and pass it to COLLECTOR first."
(defvar ert-resource-directory-trim-right-regexp "\\(-tests?\\)?\\.el"
"Regexp for `string-trim' (right) used by `ert-resource-directory'.")
-;; Has to be a macro for `load-file-name'.
(defmacro ert-resource-directory ()
"Return absolute file name of the resource (test data) directory.
@@ -368,17 +367,17 @@ variable `ert-resource-directory-format'. Before formatting, the
file name will be trimmed using `string-trim' with arguments
`ert-resource-directory-trim-left-regexp' and
`ert-resource-directory-trim-right-regexp'."
- `(let* ((testfile ,(or (macroexp-file-name)
- buffer-file-name))
- (default-directory (file-name-directory testfile)))
- (file-truename
- (if (file-accessible-directory-p "resources/")
- (expand-file-name "resources/")
- (expand-file-name
- (format ert-resource-directory-format
- (string-trim testfile
- ert-resource-directory-trim-left-regexp
- ert-resource-directory-trim-right-regexp)))))))
+ `(when-let ((testfile ,(or (macroexp-file-name)
+ buffer-file-name)))
+ (let ((default-directory (file-name-directory testfile)))
+ (file-truename
+ (if (file-accessible-directory-p "resources/")
+ (expand-file-name "resources/")
+ (expand-file-name
+ (format ert-resource-directory-format
+ (string-trim testfile
+ ert-resource-directory-trim-left-regexp
+ ert-resource-directory-trim-right-regexp))))))))
(defmacro ert-resource-file (file)
"Return absolute file name of resource (test data) file named FILE.
@@ -386,6 +385,96 @@ A resource file is defined as any file placed in the resource
directory as returned by `ert-resource-directory'."
`(expand-file-name ,file (ert-resource-directory)))
+(defvar ert-temp-file-prefix "emacs-test-"
+ "Prefix used by `ert-with-temp-file' and `ert-with-temp-directory'.")
+
+(defvar ert-temp-file-suffix nil
+ "Suffix used by `ert-with-temp-file' and `ert-with-temp-directory'.")
+
+(defun ert--with-temp-file-generate-suffix (filename)
+ "Generate temp file suffix from FILENAME."
+ (thread-last
+ (file-name-base filename)
+ (replace-regexp-in-string (rx string-start
+ (group (+? not-newline))
+ (regexp "-?tests?")
+ string-end)
+ "\\1")
+ (concat "-")))
+
+(defmacro ert-with-temp-file (name &rest body)
+ "Bind NAME to the name of a new temporary file and evaluate BODY.
+Delete the temporary file after BODY exits normally or
+non-locally. NAME will be bound to the file name of the temporary
+file.
+
+The following keyword arguments are supported:
+
+:prefix STRING If non-nil, pass STRING to `make-temp-file' as
+ the PREFIX argument. Otherwise, use the value of
+ `ert-temp-file-prefix'.
+
+:suffix STRING If non-nil, pass STRING to `make-temp-file' as the
+ SUFFIX argument. Otherwise, use the value of
+ `ert-temp-file-suffix'; if the value of that
+ variable is nil, generate a suffix based on the
+ name of the file that `ert-with-temp-file' is
+ called from.
+
+:text STRING If non-nil, pass STRING to `make-temp-file' as
+ the TEXT argument.
+
+See also `ert-with-temp-directory'."
+ (declare (indent 1) (debug (symbolp body)))
+ (cl-check-type name symbol)
+ (let (keyw prefix suffix directory text extra-keywords)
+ (while (keywordp (setq keyw (car body)))
+ (setq body (cdr body))
+ (pcase keyw
+ (:prefix (setq prefix (pop body)))
+ (:suffix (setq suffix (pop body)))
+ (:directory (setq directory (pop body)))
+ (:text (setq text (pop body)))
+ (_ (push keyw extra-keywords) (pop body))))
+ (when extra-keywords
+ (error "Invalid keywords: %s" (mapconcat #'symbol-name extra-keywords " ")))
+ (let ((temp-file (make-symbol "temp-file"))
+ (prefix (or prefix ert-temp-file-prefix))
+ (suffix (or suffix ert-temp-file-suffix
+ (ert--with-temp-file-generate-suffix
+ (or (macroexp-file-name) buffer-file-name)))))
+ `(let* ((,temp-file (,(if directory 'file-name-as-directory 'identity)
+ (make-temp-file ,prefix ,directory ,suffix ,text)))
+ (,name ,(if directory
+ `(file-name-as-directory ,temp-file)
+ temp-file)))
+ (unwind-protect
+ (progn ,@body)
+ (ignore-errors
+ ,(if directory
+ `(delete-directory ,temp-file :recursive)
+ `(delete-file ,temp-file))))))))
+
+(defmacro ert-with-temp-directory (name &rest body)
+ "Bind NAME to the name of a new temporary directory and evaluate BODY.
+Delete the temporary directory after BODY exits normally or
+non-locally.
+
+NAME is bound to the directory name, not the directory file
+name. (In other words, it will end with the directory delimiter;
+on Unix-like systems, it will end with \"/\".)
+
+The same keyword arguments are supported as in
+`ert-with-temp-file' (which see), except for :text."
+ (declare (indent 1) (debug (symbolp body)))
+ (let ((tail body) keyw)
+ (while (keywordp (setq keyw (car tail)))
+ (setq tail (cddr tail))
+ (pcase keyw (:text (error "Invalid keyword for directory: :text")))))
+ `(ert-with-temp-file ,name
+ :directory t
+ ,@body))
+
(provide 'ert-x)
;;; ert-x.el ends here
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index b7d984374cb..cc464a0f819 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -63,6 +63,9 @@
(require 'ewoc)
(require 'find-func)
(require 'pp)
+(require 'map)
+
+(autoload 'xml-escape-string "xml.el")
;;; UI customization options.
@@ -76,6 +79,35 @@
Use nil for no limit (caution: backtrace lines can be very long)."
:type '(choice (const :tag "No truncation" nil) integer))
+(defvar ert-batch-print-length 10
+ "`print-length' setting used in `ert-run-tests-batch'.
+
+When formatting lists in test conditions, `print-length' will be
+temporarily set to this value. See also
+`ert-batch-backtrace-line-length' for its effect on stack
+traces.")
+
+(defvar ert-batch-print-level 5
+ "`print-level' setting used in `ert-run-tests-batch'.
+
+When formatting lists in test conditions, `print-level' will be
+temporarily set to this value. See also
+`ert-batch-backtrace-line-length' for its effect on stack
+traces.")
+
+(defvar ert-batch-backtrace-line-length t
+ "Target length for lines in ERT batch backtraces.
+
+Even modest settings for `print-length' and `print-level' can
+produce extremely long lines in backtraces and lengthy delays in
+forming them. This variable governs the target maximum line
+length by manipulating these two variables while printing stack
+traces. Setting this variable to t will re-use the value of
+`backtrace-line-length' while printing stack traces in ERT batch
+mode. Any other value will be temporarily bound to
+`backtrace-line-length' when producing stack traces in batch
+mode.")
+
(defface ert-test-result-expected '((((class color) (background light))
:background "green1")
(((class color) (background dark))
@@ -88,23 +120,6 @@ Use nil for no limit (caution: backtrace lines can be very long)."
:background "red3"))
"Face used for unexpected results in the ERT results buffer.")
-
-;;; Copies/reimplementations of cl functions.
-
-(defun ert-equal-including-properties (a b)
- "Return t if A and B have similar structure and contents.
-
-This is like `equal-including-properties' except that it compares
-the property values of text properties structurally (by
-recursing) rather than with `eq'. Perhaps this is what
-`equal-including-properties' should do in the first place; see
-Emacs bug 6581 at URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'."
- ;; This implementation is inefficient. Rather than making it
- ;; efficient, let's hope bug 6581 gets fixed so that we can delete
- ;; it altogether.
- (not (ert--explain-equal-including-properties a b)))
-
-
;;; Defining and locating tests.
;; The data structure that represents a test case.
@@ -136,6 +151,10 @@ Emacs bug 6581 at URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'."
;; Note that nil is still a valid value for the `name' slot in
;; ert-test objects. It designates an anonymous test.
(error "Attempt to define a test named nil"))
+ (when (and noninteractive (get symbol 'ert--test))
+ ;; Make sure duplicated tests are discovered since the older test would
+ ;; be ignored silently otherwise.
+ (error "Test `%s' redefined" symbol))
(define-symbol-prop symbol 'ert--test definition)
definition)
@@ -191,6 +210,9 @@ Macros in BODY are expanded when the test is defined, not when it
is run. If a macro (possibly with side effects) is to be tested,
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 signalled.
+
\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
[:tags \\='(TAG...)] BODY...)"
(declare (debug (&define [&name "test@" symbolp]
@@ -218,11 +240,7 @@ it has to be wrapped in `(eval (quote ...))'.
`(:expected-result-type ,expected-result))
,@(when tags-supplied-p
`(:tags ,tags))
- :body (lambda ()
- ;; Use the value of `lexical-binding' in
- ;; the source file when evaluating the body.
- (let ((lexical-binding ,lexical-binding))
- ,@body))))
+ :body (lambda () ,@body)))
',name))))
(defvar ert--find-test-regexp
@@ -231,7 +249,6 @@ it has to be wrapped in `(eval (quote ...))'.
"%s\\(\\s-\\|$\\)")
"The regexp the `find-function' mechanisms use for finding test definitions.")
-
(define-error 'ert-test-failed "Test failed")
(define-error 'ert-test-skipped "Test skipped")
@@ -469,7 +486,7 @@ Errors during evaluation are caught and handled like nil."
(defun ert--explain-equal-rec (a b)
"Return a programmer-readable explanation of why A and B are not `equal'.
-Returns nil if they are."
+Return nil if they are."
(if (not (eq (type-of a) (type-of b)))
`(different-types ,a ,b)
(pcase a
@@ -602,14 +619,9 @@ If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix."
(t
(substring s 0 len)))))
-;; TODO(ohler): Once bug 6581 is fixed, rename this to
-;; `ert--explain-equal-including-properties-rec' and add a fast-path
-;; wrapper like `ert--explain-equal'.
-(defun ert--explain-equal-including-properties (a b)
- "Explainer function for `ert-equal-including-properties'.
-
-Returns a programmer-readable explanation of why A and B are not
-`ert-equal-including-properties', or nil if they are."
+(defun ert--explain-equal-including-properties-rec (a b)
+ "Return explanation of why A and B are not `equal-including-properties'.
+Return nil if they are."
(if (not (equal a b))
(ert--explain-equal a b)
(cl-assert (stringp a) t)
@@ -631,15 +643,17 @@ Returns a programmer-readable explanation of why A and B are not
,(ert--abbreviate-string
(substring-no-properties a (1+ i))
10 nil))))
- ;; TODO(ohler): Get `equal-including-properties' fixed in
- ;; Emacs, delete `ert-equal-including-properties', and
- ;; re-enable this assertion.
- ;;finally (cl-assert (equal-including-properties a b) t)
- )))
-(put 'ert-equal-including-properties
- 'ert-explainer
- 'ert--explain-equal-including-properties)
+ finally (cl-assert (equal-including-properties a b) t))))
+(defun ert--explain-equal-including-properties (a b)
+ "Explainer function for `equal-including-properties'."
+ ;; Do a quick comparison in C to avoid running our expensive
+ ;; comparison when possible.
+ (if (equal-including-properties a b)
+ nil
+ (ert--explain-equal-including-properties-rec a b)))
+(put 'equal-including-properties 'ert-explainer
+ 'ert--explain-equal-including-properties)
;;; Implementation of `ert-info'.
@@ -664,7 +678,6 @@ and is displayed in front of the value of MESSAGE-FORM."
,@body))
-
;;; Facilities for running a single test.
(defvar ert-debug-on-error nil
@@ -779,7 +792,8 @@ This mainly sets up debugger-related bindings."
;; handle ert errors. Once that's done, remove
;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for
;; details.
- (let ((debugger (lambda (&rest args)
+ (let ((lexical-binding t)
+ (debugger (lambda (&rest args)
(ert--run-test-debugger test-execution-info
args)))
(debug-on-error t)
@@ -1423,9 +1437,10 @@ Returns the stats object."
(if (getenv "EMACS_TEST_VERBOSE")
(ert-reason-for-test-result result)
""))))
- (message "%s" "")))))
- (test-started
- )
+ (message "%s" ""))
+ (when (getenv "EMACS_TEST_JUNIT_REPORT")
+ (ert-write-junit-test-report stats)))))
+ (test-started)
(test-ended
(cl-destructuring-bind (stats test result) event-args
(unless (ert-test-result-expected-p test result)
@@ -1435,8 +1450,14 @@ Returns the stats object."
(ert-test-result-with-condition
(message "Test %S backtrace:" (ert-test-name test))
(with-temp-buffer
- (insert (backtrace-to-string
- (ert-test-result-with-condition-backtrace result)))
+ (let ((backtrace-line-length
+ (if (eq ert-batch-backtrace-line-length t)
+ backtrace-line-length
+ ert-batch-backtrace-line-length))
+ (print-level ert-batch-print-level)
+ (print-length ert-batch-print-length))
+ (insert (backtrace-to-string
+ (ert-test-result-with-condition-backtrace result))))
(if (not ert-batch-backtrace-right-margin)
(message "%s"
(buffer-substring-no-properties (point-min)
@@ -1455,8 +1476,8 @@ Returns the stats object."
(ert--insert-infos result)
(insert " ")
(let ((print-escape-newlines t)
- (print-level 5)
- (print-length 10))
+ (print-level ert-batch-print-level)
+ (print-length ert-batch-print-length))
(ert--pp-with-indentation-and-newline
(ert-test-result-with-condition-condition result)))
(goto-char (1- (point-max)))
@@ -1506,6 +1527,183 @@ the tests)."
(backtrace))
(kill-emacs 2))))
+(defvar ert-load-file-name nil
+ "The name of the loaded ERT test file, a string.
+Usually, it is not needed to be defined, but if different ERT
+test packages depend on each other, it might be helpful.")
+
+(defun ert-write-junit-test-report (stats)
+ "Write a JUnit test report, generated from STATS."
+ ;; https://www.ibm.com/docs/en/developer-for-zos/14.1.0?topic=formats-junit-xml-format
+ ;; https://llg.cubic.org/docs/junit/
+ (when-let ((symbol (car (apropos-internal "" #'ert-test-boundp)))
+ (test-file (symbol-file symbol 'ert--test))
+ (test-report
+ (file-name-with-extension
+ (or ert-load-file-name test-file) "xml")))
+ (with-temp-file test-report
+ (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
+ (insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n"
+ (file-name-nondirectory test-report)
+ (ert-stats-total stats)
+ (if (ert--stats-aborted-p stats) 1 0)
+ (ert-stats-completed-unexpected stats)
+ (ert-stats-skipped stats)
+ (float-time
+ (time-subtract
+ (ert--stats-end-time stats)
+ (ert--stats-start-time stats)))))
+ (insert (format " <testsuite id=\"0\" name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\" timestamp=\"%s\">\n"
+ (file-name-nondirectory test-report)
+ (ert-stats-total stats)
+ (if (ert--stats-aborted-p stats) 1 0)
+ (ert-stats-completed-unexpected stats)
+ (ert-stats-skipped stats)
+ (float-time
+ (time-subtract
+ (ert--stats-end-time stats)
+ (ert--stats-start-time stats)))
+ (ert--format-time-iso8601 (ert--stats-end-time stats))))
+ ;; If the test has aborted, `ert--stats-selector' might return
+ ;; huge junk. Skip this.
+ (when (< (length (format "%s" (ert--stats-selector stats))) 1024)
+ (insert " <properties>\n"
+ (format " <property name=\"selector\" value=\"%s\"/>\n"
+ (xml-escape-string
+ (format "%s" (ert--stats-selector stats)) 'noerror))
+ " </properties>\n"))
+ (cl-loop for test across (ert--stats-tests stats)
+ for result = (ert-test-most-recent-result test) do
+ (insert (format " <testcase name=\"%s\" status=\"%s\" time=\"%s\""
+ (xml-escape-string
+ (symbol-name (ert-test-name test)) 'noerror)
+ (ert-string-for-test-result
+ result
+ (ert-test-result-expected-p test result))
+ (ert-test-result-duration result)))
+ (if (and (ert-test-result-expected-p test result)
+ (not (ert-test-aborted-with-non-local-exit-p result))
+ (not (ert-test-skipped-p result))
+ (zerop (length (ert-test-result-messages result))))
+ (insert "/>\n")
+ (insert ">\n")
+ (cond
+ ((ert-test-skipped-p result)
+ (insert (format " <skipped message=\"%s\" type=\"%s\">\n"
+ (xml-escape-string
+ (string-trim
+ (ert-reason-for-test-result result))
+ 'noerror)
+ (ert-string-for-test-result
+ result
+ (ert-test-result-expected-p
+ test result)))
+ (xml-escape-string
+ (string-trim
+ (ert-reason-for-test-result result))
+ 'noerror)
+ "\n"
+ " </skipped>\n"))
+ ((ert-test-aborted-with-non-local-exit-p result)
+ (insert (format " <error message=\"%s\" type=\"%s\">\n"
+ (file-name-nondirectory test-report)
+ (ert-string-for-test-result
+ result
+ (ert-test-result-expected-p
+ test result)))
+ (format "Test %s aborted with non-local exit\n"
+ (xml-escape-string
+ (symbol-name (ert-test-name test)) 'noerror))
+ " </error>\n"))
+ ((not (ert-test-result-type-p
+ result (ert-test-expected-result-type test)))
+ (insert (format " <failure message=\"%s\" type=\"%s\">\n"
+ (xml-escape-string
+ (string-trim
+ (ert-reason-for-test-result result))
+ 'noerror)
+ (ert-string-for-test-result
+ result
+ (ert-test-result-expected-p
+ test result)))
+ (xml-escape-string
+ (string-trim
+ (ert-reason-for-test-result result))
+ 'noerror)
+ "\n"
+ " </failure>\n")))
+ (unless (zerop (length (ert-test-result-messages result)))
+ (insert " <system-out>\n"
+ (xml-escape-string
+ (ert-test-result-messages result) 'noerror)
+ " </system-out>\n"))
+ (insert " </testcase>\n")))
+ (insert " </testsuite>\n")
+ (insert "</testsuites>\n"))))
+
+(defun ert-write-junit-test-summary-report (&rest logfiles)
+ "Write a JUnit summary test report, generated from LOGFILES."
+ (let ((report (file-name-with-extension
+ (getenv "EMACS_TEST_JUNIT_REPORT") "xml"))
+ (tests 0) (errors 0) (failures 0) (skipped 0) (time 0) (id 0))
+ (with-temp-file report
+ (dolist (logfile logfiles)
+ (let ((test-report (file-name-with-extension logfile "xml")))
+ (if (not (file-readable-p test-report))
+ (let* ((logfile (file-name-with-extension logfile "log"))
+ (logfile-contents
+ (when (file-readable-p logfile)
+ (with-temp-buffer
+ (insert-file-contents-literally logfile)
+ (buffer-string)))))
+ (unless
+ ;; No defined tests, perhaps a helper file.
+ (and logfile-contents
+ (string-match-p "^Running 0 tests" logfile-contents))
+ (insert (format " <testsuite id=\"%s\" name=\"%s\" tests=\"1\" errors=\"1\" failures=\"0\" skipped=\"0\" time=\"0\" timestamp=\"%s\">\n"
+ id test-report
+ (ert--format-time-iso8601 (current-time))))
+ (insert (format " <testcase name=\"Test report missing %s\" status=\"error\" time=\"0\">\n"
+ (file-name-nondirectory test-report)))
+ (insert (format " <error message=\"Test report missing %s\" type=\"error\">\n"
+ (file-name-nondirectory test-report)))
+ (when logfile-contents
+ (insert (xml-escape-string logfile-contents 'noerror)))
+ (insert " </error>\n"
+ " </testcase>\n"
+ " </testsuite>\n")
+ (cl-incf errors 1)
+ (cl-incf id 1)))
+
+ (insert-file-contents-literally test-report)
+ (when (looking-at-p
+ (regexp-quote "<?xml version=\"1.0\" encoding=\"utf-8\"?>"))
+ (delete-region (point) (line-beginning-position 2)))
+ (when (looking-at
+ "<testsuites name=\".+\" tests=\"\\(.+\\)\" errors=\"\\(.+\\)\" failures=\"\\(.+\\)\" skipped=\"\\(.+\\)\" time=\"\\(.+\\)\">")
+ (cl-incf tests (string-to-number (match-string 1)))
+ (cl-incf errors (string-to-number (match-string 2)))
+ (cl-incf failures (string-to-number (match-string 3)))
+ (cl-incf skipped (string-to-number (match-string 4)))
+ (cl-incf time (string-to-number (match-string 5)))
+ (delete-region (point) (line-beginning-position 2)))
+ (when (looking-at " <testsuite id=\"\\(0\\)\"")
+ (replace-match (number-to-string id) nil nil nil 1)
+ (cl-incf id 1))
+ (goto-char (point-max))
+ (beginning-of-line 0)
+ (when (looking-at-p "</testsuites>")
+ (delete-region (point) (line-beginning-position 2))))
+
+ (narrow-to-region (point-max) (point-max))))
+
+ (insert "</testsuites>\n")
+ (widen)
+ (goto-char (point-min))
+ (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
+ (insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n"
+ (file-name-nondirectory report)
+ tests errors failures skipped time)))))
(defun ert-summarize-tests-batch-and-exit (&optional high)
"Summarize the results of testing.
@@ -1521,6 +1719,8 @@ If HIGH is a natural number, the HIGH long lasting tests are summarized."
;; behavior.
(setq attempt-stack-overflow-recovery nil
attempt-orderly-shutdown-on-fatal-signal nil)
+ (when (getenv "EMACS_TEST_JUNIT_REPORT")
+ (apply #'ert-write-junit-test-summary-report command-line-args-left))
(let ((nlogs (length command-line-args-left))
(ntests 0) (nrun 0) (nexpected 0) (nunexpected 0) (nskipped 0)
nnotrun logfile notests badtests unexpected skipped tests)
@@ -1836,7 +2036,6 @@ Also sets `ert--results-progress-bar-button-begin'."
;; should test it again.)
"\n")))
-
(defvar ert-test-run-redisplay-interval-secs .1
"How many seconds ERT should wait between redisplays while running tests.
@@ -1984,13 +2183,13 @@ otherwise."
(ewoc-refresh ert--results-ewoc)
(font-lock-default-function enabledp))
-(defun ert--setup-results-buffer (stats listener buffer-name)
+(defvar ert--output-buffer-name "*ert*")
+
+(defun ert--setup-results-buffer (stats listener)
"Set up a test results buffer.
-STATS is the stats object; LISTENER is the results listener;
-BUFFER-NAME, if non-nil, is the buffer name to use."
- (unless buffer-name (setq buffer-name "*ert*"))
- (let ((buffer (get-buffer-create buffer-name)))
+STATS is the stats object; LISTENER is the results listener."
+ (let ((buffer (get-buffer-create ert--output-buffer-name)))
(with-current-buffer buffer
(let ((inhibit-read-only t))
(buffer-disable-undo)
@@ -2018,22 +2217,14 @@ BUFFER-NAME, if non-nil, is the buffer name to use."
(goto-char (1- (point-max)))
buffer)))))
-
(defvar ert--selector-history nil
"List of recent test selectors read from terminal.")
-;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here?
-;; They are needed only for our automated self-tests at the moment.
-;; Or should there be some other mechanism?
;;;###autoload
-(defun ert-run-tests-interactively (selector
- &optional output-buffer-name message-fn)
+(defun ert-run-tests-interactively (selector)
"Run the tests specified by SELECTOR and display the results in a buffer.
-SELECTOR works as described in `ert-select-tests'.
-OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they
-are used for automated self-tests and specify which buffer to use
-and how to display message."
+SELECTOR works as described in `ert-select-tests'."
(interactive
(list (let ((default (if ert--selector-history
;; Can't use `first' here as this form is
@@ -2044,25 +2235,18 @@ and how to display message."
(read
(completing-read (format-prompt "Run tests" default)
obarray #'ert-test-boundp nil nil
- 'ert--selector-history default nil)))
- nil))
- (unless message-fn (setq message-fn 'message))
- (let ((output-buffer-name output-buffer-name)
- buffer
- listener
- (message-fn message-fn))
+ 'ert--selector-history default nil)))))
+ (let (buffer listener)
(setq listener
(lambda (event-type &rest event-args)
(cl-ecase event-type
(run-started
(cl-destructuring-bind (stats) event-args
- (setq buffer (ert--setup-results-buffer stats
- listener
- output-buffer-name))
+ (setq buffer (ert--setup-results-buffer stats listener))
(pop-to-buffer buffer)))
(run-ended
(cl-destructuring-bind (stats abortedp) event-args
- (funcall message-fn
+ (message
"%sRan %s tests, %s results were as expected%s%s"
(if (not abortedp)
""
@@ -2416,7 +2600,7 @@ To be used in the ERT results buffer."
(interactive nil ert-results-mode)
(cl-assert (eql major-mode 'ert-results-mode))
(let ((selector (ert--stats-selector ert--results-stats)))
- (ert-run-tests-interactively selector (buffer-name))))
+ (ert-run-tests-interactively selector)))
(defun ert-results-rerun-test-at-point ()
"Re-run the test at point.
@@ -2665,9 +2849,135 @@ To be used in the ERT results buffer."
'ert--activate-font-lock-keywords)
nil)
+(defun ert-test-erts-file (file &optional transform)
+ "Parse FILE as a file containing before/after parts.
+TRANSFORM will be called to get from before to after."
+ (with-temp-buffer
+ (insert-file-contents file)
+ (let ((gen-specs (list (cons 'dummy t)
+ (cons 'code transform))))
+ ;; Find the start of a test.
+ (while (re-search-forward "^=-=\n" nil t)
+ (setq gen-specs (ert-test--erts-test gen-specs file))
+ ;; Search to the end of the test.
+ (re-search-forward "^=-=-=\n")))))
+
+(defun ert-test--erts-test (gen-specs file)
+ (let* ((file-buffer (current-buffer))
+ (specs (ert--erts-specifications (match-beginning 0)))
+ (name (cdr (assq 'name specs)))
+ (start-before (point))
+ (end-after (if (re-search-forward "^=-=-=\n" nil t)
+ (match-beginning 0)
+ (point-max)))
+ (skip (cdr (assq 'skip specs)))
+ end-before start-after
+ after after-point)
+ (unless name
+ (error "No name for test case"))
+ (if (and skip
+ (eval (car (read-from-string skip))))
+ ;; Skipping this test.
+ ()
+ ;; Do the test.
+ (goto-char end-after)
+ ;; We have a separate after section.
+ (if (re-search-backward "^=-=\n" start-before t)
+ (setq end-before (match-beginning 0)
+ start-after (match-end 0))
+ (setq end-before end-after
+ start-after start-before))
+ ;; Update persistent specs.
+ (when-let ((point-char (assq 'point-char specs)))
+ (setq gen-specs
+ (map-insert gen-specs 'point-char (cdr point-char))))
+ (when-let ((code (cdr (assq 'code specs))))
+ (setq gen-specs
+ (map-insert gen-specs 'code (car (read-from-string code)))))
+ ;; Get the "after" strings.
+ (with-temp-buffer
+ (insert-buffer-substring file-buffer start-after end-after)
+ (ert--erts-unquote)
+ ;; Remove the newline at the end of the buffer.
+ (when-let ((no-newline (cdr (assq 'no-after-newline specs))))
+ (goto-char (point-min))
+ (when (re-search-forward "\n\\'" nil t)
+ (delete-region (match-beginning 0) (match-end 0))))
+ ;; Get the expected "after" point.
+ (when-let ((point-char (cdr (assq 'point-char gen-specs))))
+ (goto-char (point-min))
+ (when (search-forward point-char nil t)
+ (delete-region (match-beginning 0) (match-end 0))
+ (setq after-point (point))))
+ (setq after (buffer-string)))
+ ;; Do the test.
+ (with-temp-buffer
+ (insert-buffer-substring file-buffer start-before end-before)
+ (ert--erts-unquote)
+ ;; Remove the newline at the end of the buffer.
+ (when-let ((no-newline (cdr (assq 'no-before-newline specs))))
+ (goto-char (point-min))
+ (when (re-search-forward "\n\\'" nil t)
+ (delete-region (match-beginning 0) (match-end 0))))
+ (goto-char (point-min))
+ ;; Place point in the specified place.
+ (when-let ((point-char (cdr (assq 'point-char gen-specs))))
+ (when (search-forward point-char nil t)
+ (delete-region (match-beginning 0) (match-end 0))))
+ (let ((code (cdr (assq 'code gen-specs))))
+ (unless code
+ (error "No code to run the transform"))
+ (funcall code))
+ (unless (equal (buffer-string) after)
+ (ert-fail (list (format "Mismatch in test \"%s\", file %s"
+ name file)
+ (buffer-string)
+ after)))
+ (when (and after-point
+ (not (= after-point (point))))
+ (ert-fail (list (format "Point wrong in test \"%s\", expected point %d, actual %d, file %s"
+ name
+ after-point (point)
+ file)
+ (buffer-string)))))))
+ ;; Return the new value of the general specifications.
+ gen-specs)
+
+(defun ert--erts-unquote ()
+ (goto-char (point-min))
+ (while (re-search-forward "^\\=-=\\(-=\\)$" nil t)
+ (delete-region (match-beginning 0) (1+ (match-beginning 0)))))
+
+(defun ert--erts-specifications (end)
+ "Find specifications before point (back to the previous test)."
+ (save-excursion
+ (goto-char end)
+ (goto-char
+ (if (re-search-backward "^=-=-=\n" nil t)
+ (match-end 0)
+ (point-min)))
+ (let ((specs nil))
+ (while (< (point) end)
+ (if (looking-at "\\([^ \n\t:]+\\):\\([ \t]+\\)?\\(.*\\)")
+ (let ((name (intern (downcase (match-string 1))))
+ (value (match-string 3)))
+ (forward-line 1)
+ (while (looking-at "[ \t]+\\(.*\\)")
+ (setq value (concat value (match-string 1)))
+ (forward-line 1))
+ (push (cons name (substring-no-properties value)) specs))
+ (forward-line 1)))
+ (nreverse specs))))
+
(defvar ert-unload-hook ())
(add-hook 'ert-unload-hook #'ert--unload-function)
+;;; Obsolete
+
+(define-obsolete-function-alias 'ert-equal-including-properties
+ #'equal-including-properties "29.1")
+(put 'ert-equal-including-properties 'ert-explainer
+ 'ert--explain-equal-including-properties)
(provide 'ert)
diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el
index 2075ac472d1..ac1412704b0 100644
--- a/lisp/emacs-lisp/generator.el
+++ b/lisp/emacs-lisp/generator.el
@@ -143,8 +143,7 @@ the CPS state machinery."
(setf ,static-var ,dynamic-var)))))
(defmacro cps--with-dynamic-binding (dynamic-var static-var &rest body)
- "Evaluate BODY such that generated atomic evaluations run with
-DYNAMIC-VAR bound to STATIC-VAR."
+ "Run BODY's atomic evaluations run with DYNAMIC-VAR bound to STATIC-VAR."
(declare (indent 2))
`(cps--with-value-wrapper
(cps--make-dynamic-binding-wrapper ,dynamic-var ,static-var)
@@ -291,22 +290,28 @@ DYNAMIC-VAR bound to STATIC-VAR."
(cps--transform-1 `(progn ,@rest)
next-state)))
- ;; Process `let' in a helper function that transforms it into a
- ;; let* with temporaries.
+ (`(,(or 'let 'let*) () . ,body)
+ (cps--transform-1 `(progn ,@body) next-state))
+
+ ;; Transform multi-variable `let' into `let*':
+ ;; (let ((v1 e1) ... (vN eN)) BODY)
+ ;; -> (let* ((t1 e1) ... (tN-1 eN-1) (vN eN) (v1 t1) (vN-1 tN-1)) BODY)
(`(let ,bindings . ,body)
(let* ((bindings (cl-loop for binding in bindings
collect (if (symbolp binding)
(list binding nil)
binding)))
- (temps (cl-loop for (var _value-form) in bindings
+ (butlast-bindings (butlast bindings))
+ (temps (cl-loop for (var _value-form) in butlast-bindings
collect (cps--add-binding var))))
(cps--transform-1
`(let* ,(append
- (cl-loop for (_var value-form) in bindings
+ (cl-loop for (_var value-form) in butlast-bindings
for temp in temps
collect (list temp value-form))
- (cl-loop for (var _binding) in bindings
+ (last bindings)
+ (cl-loop for (var _binding) in butlast-bindings
for temp in temps
collect (list var temp)))
,@body)
@@ -315,9 +320,6 @@ DYNAMIC-VAR bound to STATIC-VAR."
;; Process `let*' binding: process one binding at a time. Flatten
;; lexical bindings.
- (`(let* () . ,body)
- (cps--transform-1 `(progn ,@body) next-state))
-
(`(let* (,binding . ,more-bindings) . ,body)
(let* ((var (if (symbolp binding) binding (car binding)))
(value-form (car (cdr-safe binding)))
@@ -642,12 +644,11 @@ modified copy."
(iter-close iterator)))))
iterator))))
-(defun iter-yield (value)
+(defun iter-yield (_value)
"When used inside a generator, yield control to caller.
The caller of `iter-next' receives VALUE, and the next call to
`iter-next' resumes execution with the form immediately following this
`iter-yield' call."
- (identity value)
(error "`iter-yield' used outside a generator"))
(defmacro iter-yield-from (value)
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index d6272a52469..ebcc63cc2a5 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -74,7 +74,7 @@
;; (defvar gv--macro-environment nil
;; "Macro expanders for generalized variables.")
-(define-error 'gv-invalid-place "%S is not a valid place expression")
+(define-error 'gv-invalid-place "Invalid place expression")
;;;###autoload
(defun gv-get (place do)
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index bb00a97f8e3..416d64558d9 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -29,6 +29,7 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'subr-x))
(defvar font-lock-comment-face)
(defvar font-lock-doc-face)
@@ -590,6 +591,8 @@ containing STARTPOS."
(defun lisp-string-after-doc-keyword-p (listbeg startpos)
"Return non-nil if `:documentation' symbol ends at STARTPOS inside a list.
+`:doc' can also be used.
+
LISTBEG is the position of the start of the innermost list
containing STARTPOS."
(and listbeg ; We are inside a Lisp form.
@@ -597,7 +600,7 @@ containing STARTPOS."
(goto-char startpos)
(ignore-errors
(progn (backward-sexp 1)
- (looking-at ":documentation\\_>"))))))
+ (looking-at ":documentation\\_>\\|:doc\\_>"))))))
(defun lisp-font-lock-syntactic-face-function (state)
"Return syntactic face function for the position represented by STATE.
@@ -1106,6 +1109,53 @@ is the buffer position of the start of the containing expression."
(t
normal-indent))))))
+(defun lisp--local-defform-body-p (state)
+ "Return non-nil when at local definition body according to STATE.
+STATE is the `parse-partial-sexp' state for current position."
+ (when-let ((start-of-innermost-containing-list (nth 1 state)))
+ (let* ((parents (nth 9 state))
+ (first-cons-after (cdr parents))
+ (second-cons-after (cdr first-cons-after))
+ first-order-parent second-order-parent)
+ (while second-cons-after
+ (when (= start-of-innermost-containing-list
+ (car second-cons-after))
+ (setq second-order-parent (pop parents)
+ first-order-parent (pop parents)
+ ;; Leave the loop.
+ second-cons-after nil))
+ (pop second-cons-after)
+ (pop parents))
+ (when second-order-parent
+ (let (local-definitions-starting-point)
+ (and (save-excursion
+ (goto-char (1+ second-order-parent))
+ (when-let ((head (ignore-errors
+ ;; FIXME: This does not distinguish
+ ;; between reading nil and a read error.
+ ;; We don't care but still, better fix this.
+ (read (current-buffer)))))
+ (when (memq head '( cl-flet cl-labels cl-macrolet cl-flet*
+ cl-symbol-macrolet))
+ ;; In what follows, we rely on (point) returning non-nil.
+ (setq local-definitions-starting-point
+ (progn
+ (parse-partial-sexp
+ (point) first-order-parent nil
+ ;; From docstring of `parse-partial-sexp':
+ ;; Fourth arg non-nil means stop
+ ;; when we come to any character
+ ;; that starts a sexp.
+ t)
+ (point))))))
+ (save-excursion
+ (when (ignore-errors
+ ;; We rely on `backward-up-list' working
+ ;; even when sexp is incomplete “to the right”.
+ (backward-up-list 2)
+ t)
+ (= local-definitions-starting-point (point))))))))))
+
(defun lisp-indent-function (indent-point state)
"This function is the normal value of the variable `lisp-indent-function'.
The function `calculate-lisp-indent' calls this to determine
@@ -1139,16 +1189,19 @@ Lisp function does not specify a special indentation."
(if (and (elt state 2)
(not (looking-at "\\sw\\|\\s_")))
;; car of form doesn't seem to be a symbol
- (progn
+ (if (lisp--local-defform-body-p state)
+ ;; We nevertheless check whether we are in flet-like form
+ ;; as we presume local function names could be non-symbols.
+ (lisp-indent-defform state indent-point)
(if (not (> (save-excursion (forward-line 1) (point))
calculate-lisp-indent-last-sexp))
- (progn (goto-char calculate-lisp-indent-last-sexp)
- (beginning-of-line)
- (parse-partial-sexp (point)
- calculate-lisp-indent-last-sexp 0 t)))
- ;; Indent under the list or under the first sexp on the same
- ;; line as calculate-lisp-indent-last-sexp. Note that first
- ;; thing on that line has to be complete sexp since we are
+ (progn (goto-char calculate-lisp-indent-last-sexp)
+ (beginning-of-line)
+ (parse-partial-sexp (point)
+ calculate-lisp-indent-last-sexp 0 t)))
+ ;; Indent under the list or under the first sexp on the same
+ ;; line as calculate-lisp-indent-last-sexp. Note that first
+ ;; thing on that line has to be complete sexp since we are
;; inside the innermost containing sexp.
(backward-prefix-chars)
(current-column))
@@ -1159,15 +1212,14 @@ Lisp function does not specify a special indentation."
'lisp-indent-function)
(get (intern-soft function) 'lisp-indent-hook)))
(cond ((or (eq method 'defun)
- (and (null method)
- (> (length function) 3)
- (string-match "\\`def" function)))
+ ;; Check whether we are in flet-like form.
+ (lisp--local-defform-body-p state))
(lisp-indent-defform state indent-point))
((integerp method)
(lisp-indent-specform method state
indent-point normal-indent))
(method
- (funcall method indent-point state)))))))
+ (funcall method indent-point state)))))))
(defcustom lisp-body-indent 2
"Number of columns to indent the second line of a `(def...)' form."
@@ -1235,6 +1287,13 @@ Lisp function does not specify a special indentation."
(put 'autoload 'lisp-indent-function 'defun) ;Elisp
(put 'progn 'lisp-indent-function 0)
+(put 'defvar 'lisp-indent-function 'defun)
+(put 'defalias 'lisp-indent-function 'defun)
+(put 'defvaralias 'lisp-indent-function 'defun)
+(put 'defconst 'lisp-indent-function 'defun)
+(put 'define-category 'lisp-indent-function 'defun)
+(put 'define-charset-internal 'lisp-indent-function 'defun)
+(put 'define-fringe-bitmap 'lisp-indent-function 'defun)
(put 'prog1 'lisp-indent-function 1)
(put 'save-excursion 'lisp-indent-function 0) ;Elisp
(put 'save-restriction 'lisp-indent-function 0) ;Elisp
@@ -1249,6 +1308,7 @@ Lisp function does not specify a special indentation."
(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)
"Indent each line of the list starting just after point.
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 1e4fdd126cb..a20c424e2bd 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -136,9 +136,12 @@ Other uses risk returning non-nil value that point to the wrong file."
(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key))
(defun macroexp--warn-wrap (msg form category)
- (let ((when-compiled (lambda ()
- (when (byte-compile-warning-enabled-p category)
- (byte-compile-warn "%s" msg)))))
+ (let ((when-compiled
+ (lambda ()
+ (when (if (consp category)
+ (apply #'byte-compile-warning-enabled-p category)
+ (byte-compile-warning-enabled-p category))
+ (byte-compile-warn "%s" msg)))))
`(progn
(macroexp--funcall-if-compiled ',when-compiled)
,form)))
@@ -220,7 +223,7 @@ is executed without being compiled first."
fun obsolete
(if (symbolp (symbol-function fun))
"alias" "macro"))
- new-form 'obsolete))
+ new-form (list 'obsolete fun)))
new-form)))
(defun macroexp--unfold-lambda (form &optional name)
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index b95f11eab64..2f2f96ca0da 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -215,12 +215,12 @@ The function's value is the number of actions taken."
(action (or (nth 2 help) "act on")))
(concat
(format-message
- "\
-Type SPC or `y' to %s the current %s;
-DEL or `n' to skip the current %s;
-RET or `q' to skip the current and all remaining %s;
-C-g to quit (cancel the whole command);
-! to %s all remaining %s;\n"
+ (substitute-command-keys "\
+Type \\`SPC' or \\`y' to %s the current %s;
+\\`DEL' or \\`n' to skip the current %s;
+\\`RET' or \\`q' to skip the current and all remaining %s;
+\\`C-g' to quit (cancel the whole command);
+\\`!' to %s all remaining %s;\n")
action object object objects action objects)
(mapconcat (lambda (elt)
(format "%s to %s;\n"
diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el
index 3166d33e029..450cdaa7a84 100644
--- a/lisp/emacs-lisp/memory-report.el
+++ b/lisp/emacs-lisp/memory-report.el
@@ -31,7 +31,7 @@
(require 'subr-x)
(require 'cl-lib)
-(defvar memory-report--type-size (make-hash-table))
+(defvar memory-report--type-size nil)
;;;###autoload
(defun memory-report ()
@@ -84,6 +84,7 @@ by counted more than once."
(gethash 'object memory-report--type-size)))
(defun memory-report--set-size (elems)
+ (setq memory-report--type-size (make-hash-table))
(setf (gethash 'string memory-report--type-size)
(cadr (assq 'strings elems)))
(setf (gethash 'cons memory-report--type-size)
@@ -282,7 +283,7 @@ by counted more than once."
buffers)
do (insert (memory-report--format size)
" "
- (button-buttonize
+ (buttonize
(buffer-name buffer)
#'memory-report--buffer-details buffer)
"\n"))
diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el
new file mode 100644
index 00000000000..6ef0da10f77
--- /dev/null
+++ b/lisp/emacs-lisp/multisession.el
@@ -0,0 +1,446 @@
+;;; multisession.el --- Multisession storage for variables -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 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 'cl-lib)
+(require 'eieio)
+(require 'sqlite)
+(require 'tabulated-list)
+
+(defcustom multisession-storage 'files
+ "Storage method for multisession variables.
+Valid methods are `sqlite' and `files'."
+ :type '(choice (const :tag "SQLite" sqlite)
+ (const :tag "Files" files))
+ :version "29.1"
+ :group 'files)
+
+(defcustom multisession-directory (expand-file-name "multisession/"
+ user-emacs-directory)
+ "Directory to store multisession variables."
+ :type 'file
+ :version "29.1"
+ :group 'files)
+
+;;;###autoload
+(defmacro define-multisession-variable (name initial-value &optional doc
+ &rest args)
+ "Make NAME into a multisession variable initialized from INITIAL-VALUE.
+DOC should be a doc string, and ARGS are keywords as applicable to
+`make-multisession'."
+ (declare (indent defun))
+ (unless (plist-get args :package)
+ (setq args (nconc (list :package
+ (replace-regexp-in-string "-.*" ""
+ (symbol-name name)))
+ args)))
+ `(defvar ,name
+ (make-multisession :key ,(symbol-name name)
+ :initial-value ,initial-value
+ ,@args)
+ ,@(list doc)))
+
+(defconst multisession--unbound (make-symbol "unbound"))
+
+(cl-defstruct (multisession
+ (:constructor nil)
+ (:constructor multisession--create)
+ (:conc-name multisession--))
+ "A persistent variable that will live across Emacs invocations."
+ key
+ (initial-value nil)
+ package
+ (storage multisession-storage)
+ (synchronized nil)
+ (cached-value multisession--unbound)
+ (cached-sequence 0))
+
+(cl-defun make-multisession (&key key initial-value package synchronized
+ storage)
+ "Create a multisession object."
+ (unless package
+ (error "No package for the multisession object"))
+ (unless key
+ (error "No key for the multisession object"))
+ (unless (stringp package)
+ (error "The package has to be a string"))
+ (unless (stringp key)
+ (error "The key has to be a string"))
+ (multisession--create
+ :key key
+ :synchronized synchronized
+ :initial-value initial-value
+ :package package
+ :storage (or storage multisession-storage)))
+
+(defun multisession-value (object)
+ "Return the value of the multisession OBJECT."
+ (if (null user-init-file)
+ ;; If we don't have storage, then just return the value from the
+ ;; object.
+ (if (eq (multisession--cached-value object) multisession--unbound)
+ (multisession--initial-value object)
+ (multisession--cached-value object))
+ ;; We have storage, so we update from storage.
+ (multisession-backend-value (multisession--storage object) object)))
+
+(defun multisession--set-value (object value)
+ "Set the stored value of OBJECT to VALUE."
+ (if (null user-init-file)
+ ;; We have no backend, so just store the value.
+ (setf (multisession--cached-value object) value)
+ ;; We have a backend.
+ (multisession--backend-set-value (multisession--storage object)
+ object value)))
+
+(defun multisession-delete (object)
+ "Delete OBJECT from the backend storage."
+ (multisession--backend-delete (multisession--storage object) object))
+
+(gv-define-simple-setter multisession-value multisession--set-value)
+
+;; SQLite Backend
+
+(declare-function sqlite-execute "sqlite.c")
+(declare-function sqlite-select "sqlite.c")
+(declare-function sqlite-open "sqlite.c")
+(declare-function sqlite-pragma "sqlite.c")
+(declare-function sqlite-transaction "sqlite.c")
+(declare-function sqlite-commit "sqlite.c")
+
+(defvar multisession--db nil)
+
+(defun multisession--ensure-db ()
+ (unless multisession--db
+ (let* ((file (expand-file-name "sqlite/multisession.sqlite"
+ multisession-directory))
+ (dir (file-name-directory file)))
+ (unless (file-exists-p dir)
+ (make-directory dir t))
+ (setq multisession--db (sqlite-open file)))
+ (with-sqlite-transaction multisession--db
+ ;; Use a write-ahead-log (available since 2010), which makes
+ ;; writes a lot faster.
+ (sqlite-pragma multisession--db "journal_mode = WAL")
+ (sqlite-pragma multisession--db "synchronous = NORMAL")
+ (unless (sqlite-select
+ multisession--db
+ "select name from sqlite_master where type = 'table' and name = 'multisession'")
+ ;; Tidy up the database automatically.
+ (sqlite-pragma multisession--db "auto_vacuum = FULL")
+ ;; Create the table.
+ (sqlite-execute
+ multisession--db
+ "create table multisession (package text not null, key text not null, sequence number not null default 1, value text not null)")
+ (sqlite-execute
+ multisession--db
+ "create unique index multisession_idx on multisession (package, key)")))))
+
+(cl-defmethod multisession-backend-value ((_type (eql 'sqlite)) object)
+ (multisession--ensure-db)
+ (let ((id (list (multisession--package object)
+ (multisession--key object))))
+ (cond
+ ;; We have no value yet; check the database.
+ ((eq (multisession--cached-value object) multisession--unbound)
+ (let ((stored
+ (car
+ (sqlite-select
+ multisession--db
+ "select value, sequence from multisession where package = ? and key = ?"
+ id))))
+ (if stored
+ (let ((value (car (read-from-string (car stored)))))
+ (setf (multisession--cached-value object) value
+ (multisession--cached-sequence object) (cadr stored))
+ value)
+ ;; Nothing; return the initial value.
+ (multisession--initial-value object))))
+ ;; We have a value, but we want to update in case some other
+ ;; Emacs instance has updated.
+ ((multisession--synchronized object)
+ (let ((stored
+ (car
+ (sqlite-select
+ multisession--db
+ "select value, sequence from multisession where sequence > ? and package = ? and key = ?"
+ (cons (multisession--cached-sequence object) id)))))
+ (if stored
+ (let ((value (car (read-from-string (car stored)))))
+ (setf (multisession--cached-value object) value
+ (multisession--cached-sequence object) (cadr stored))
+ value)
+ ;; Nothing, return the cached value.
+ (multisession--cached-value object))))
+ ;; Just return the cached value.
+ (t
+ (multisession--cached-value object)))))
+
+(cl-defmethod multisession--backend-set-value ((_type (eql 'sqlite))
+ object value)
+ (catch 'done
+ (let ((i 0))
+ (while (< i 10)
+ (condition-case nil
+ (throw 'done (multisession--set-value-sqlite object value))
+ (sqlite-locked-error
+ (setq i (1+ i))
+ (sleep-for (+ 0.1 (/ (float (random 10)) 10))))))
+ (signal 'sqlite-locked-error "Database is locked"))))
+
+(defun multisession--set-value-sqlite (object value)
+ (multisession--ensure-db)
+ (with-sqlite-transaction multisession--db
+ (let ((id (list (multisession--package object)
+ (multisession--key object)))
+ (pvalue
+ (let ((print-length nil)
+ (print-circle t)
+ (print-level nil))
+ (prin1-to-string value))))
+ (condition-case nil
+ (ignore (read-from-string pvalue))
+ (error (error "Unable to store unreadable value: %s" pvalue)))
+ (sqlite-execute
+ multisession--db
+ "insert into multisession(package, key, sequence, value) values(?, ?, 1, ?) on conflict(package, key) do update set sequence = sequence + 1, value = ?"
+ (append id (list pvalue pvalue)))
+ (setf (multisession--cached-sequence object)
+ (caar (sqlite-select
+ multisession--db
+ "select sequence from multisession where package = ? and key = ?"
+ id)))
+ (setf (multisession--cached-value object) value))))
+
+(cl-defmethod multisession--backend-values ((_type (eql 'sqlite)))
+ (multisession--ensure-db)
+ (sqlite-select
+ multisession--db
+ "select package, key, value from multisession order by package, key"))
+
+(cl-defmethod multisession--backend-delete ((_type (eql 'sqlite)) object)
+ (sqlite-execute multisession--db
+ "delete from multisession where package = ? and key = ?"
+ (list (multisession--package object)
+ (multisession--key object))))
+
+;; Files Backend
+
+(defun multisession--encode-file-name (name)
+ (url-hexify-string name))
+
+(defun multisession--read-file-value (file object)
+ (catch 'done
+ (let ((i 0)
+ last-error)
+ (while (< i 10)
+ (condition-case err
+ (throw 'done
+ (with-temp-buffer
+ (let* ((time (file-attribute-modification-time
+ (file-attributes file)))
+ (coding-system-for-read 'utf-8))
+ (insert-file-contents file)
+ (let ((stored (read (current-buffer))))
+ (setf (multisession--cached-value object) stored
+ (multisession--cached-sequence object) time)
+ stored))))
+ ;; Windows uses OS-level file locking that may preclude
+ ;; reading the file in some circumstances. So when that
+ ;; happens, wait a bit and try again.
+ (file-error
+ (setq i (1+ i)
+ last-error err)
+ (sleep-for (+ 0.1 (/ (float (random 10)) 10))))))
+ (signal (car last-error) (cdr last-error)))))
+
+(defun multisession--object-file-name (object)
+ (expand-file-name
+ (concat "files/"
+ (multisession--encode-file-name (multisession--package object))
+ "/"
+ (multisession--encode-file-name (multisession--key object))
+ ".value")
+ multisession-directory))
+
+(cl-defmethod multisession-backend-value ((_type (eql 'files)) object)
+ (let ((file (multisession--object-file-name object)))
+ (cond
+ ;; We have no value yet; see whether it's stored.
+ ((eq (multisession--cached-value object) multisession--unbound)
+ (if (file-exists-p file)
+ (multisession--read-file-value file object)
+ ;; Nope; return the initial value.
+ (multisession--initial-value object)))
+ ;; We have a value, but we want to update in case some other
+ ;; Emacs instance has updated.
+ ((multisession--synchronized object)
+ (if (and (file-exists-p file)
+ (time-less-p (multisession--cached-sequence object)
+ (file-attribute-modification-time
+ (file-attributes file))))
+ (multisession--read-file-value file object)
+ ;; Nothing, return the cached value.
+ (multisession--cached-value object)))
+ ;; Just return the cached value.
+ (t
+ (multisession--cached-value object)))))
+
+(cl-defmethod multisession--backend-set-value ((_type (eql 'files))
+ object value)
+ (let ((file (multisession--object-file-name object))
+ (time (current-time)))
+ ;; Ensure that the directory exists.
+ (let ((dir (file-name-directory file)))
+ (unless (file-exists-p dir)
+ (make-directory dir t)))
+ (with-temp-buffer
+ (let ((print-length nil)
+ (print-circle t)
+ (print-level nil))
+ (prin1 value (current-buffer)))
+ (goto-char (point-min))
+ (condition-case nil
+ (read (current-buffer))
+ (error (error "Unable to store unreadable value: %s" (buffer-string))))
+ ;; Write to a temp file in the same directory and rename to the
+ ;; file for somewhat better atomicity.
+ (let ((coding-system-for-write 'utf-8)
+ (create-lockfiles nil)
+ (temp (make-temp-name file))
+ (write-region-inhibit-fsync nil))
+ (write-region (point-min) (point-max) temp nil 'silent)
+ (set-file-times temp time)
+ (rename-file temp file t)))
+ (setf (multisession--cached-sequence object) time
+ (multisession--cached-value object) value)))
+
+(cl-defmethod multisession--backend-values ((_type (eql 'files)))
+ (mapcar (lambda (file)
+ (let ((bits (file-name-split file)))
+ (list (url-unhex-string (car (last bits 2)))
+ (url-unhex-string
+ (file-name-sans-extension (car (last bits))))
+ (with-temp-buffer
+ (let ((coding-system-for-read 'utf-8))
+ (insert-file-contents file)
+ (read (current-buffer)))))))
+ (directory-files-recursively
+ (expand-file-name "files" multisession-directory)
+ "\\.value\\'")))
+
+(cl-defmethod multisession--backend-delete ((_type (eql 'files)) object)
+ (let ((file (multisession--object-file-name object)))
+ (when (file-exists-p file)
+ (delete-file file))))
+
+;; Mode for editing.
+
+(defvar-keymap multisession-edit-mode-map
+ :parent tabulated-list-mode-map
+ "d" #'multisession-delete-value
+ "e" #'multisession-edit-value)
+
+(define-derived-mode multisession-edit-mode special-mode "Multisession"
+ "This mode lists all elements in the \"multisession\" database."
+ :interactive nil
+ (buffer-disable-undo)
+ (setq-local buffer-read-only t
+ truncate-lines t)
+ (setq tabulated-list-format
+ [("Package" 10)
+ ("Key" 30)
+ ("Value" 30)])
+ (setq-local revert-buffer-function #'multisession-edit-mode--revert))
+
+;;;###autoload
+(defun list-multisession-values (&optional choose-storage)
+ "List all values in the \"multisession\" database.
+If CHOOSE-STORAGE (interactively, the prefix), query for the
+storage method to list."
+ (interactive "P")
+ (let ((storage
+ (if choose-storage
+ (intern (completing-read "Storage method: " '(sqlite files) nil t))
+ multisession-storage)))
+ (pop-to-buffer (get-buffer-create (format "*Multisession %s*" storage)))
+ (multisession-edit-mode)
+ (setq-local multisession-storage storage)
+ (multisession-edit-mode--revert)
+ (goto-char (point-min))))
+
+(defun multisession-edit-mode--revert (&rest _)
+ (let ((inhibit-read-only t)
+ (id (get-text-property (point) 'tabulated-list-id)))
+ (erase-buffer)
+ (tabulated-list-init-header)
+ (setq tabulated-list-entries
+ (mapcar (lambda (elem)
+ (list
+ (cons (car elem) (cadr elem))
+ (vector (car elem) (cadr elem)
+ (string-replace "\n" "\\n"
+ (format "%s" (caddr elem))))))
+ (multisession--backend-values multisession-storage)))
+ (tabulated-list-print t)
+ (goto-char (point-min))
+ (when id
+ (when-let ((match
+ (text-property-search-forward 'tabulated-list-id id t)))
+ (goto-char (prop-match-beginning match))))))
+
+(defun multisession-delete-value (id)
+ "Delete the value at point."
+ (interactive (list (get-text-property (point) 'tabulated-list-id))
+ multisession-edit-mode)
+ (unless id
+ (error "No value on the current line"))
+ (unless (yes-or-no-p "Really delete this item? ")
+ (user-error "Not deleting"))
+ (multisession--backend-delete multisession-storage
+ (make-multisession :package (car id)
+ :key (cdr id)))
+ (let ((inhibit-read-only t))
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point)))))
+
+(defun multisession-edit-value (id)
+ "Edit the value at point."
+ (interactive (list (get-text-property (point) 'tabulated-list-id))
+ multisession-edit-mode)
+ (unless id
+ (error "No value on the current line"))
+ (let* ((object (make-multisession
+ :package (car id)
+ :key (cdr id)
+ :storage multisession-storage))
+ (value (multisession-value object)))
+ (setf (multisession-value object)
+ (car (read-from-string
+ (read-string "New value: " (prin1-to-string value))))))
+ (multisession-edit-mode--revert))
+
+(provide 'multisession)
+
+;;; multisession.el ends here
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 2c37e19980d..de4cebccca3 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -714,6 +714,7 @@ REQUIREMENTS is a list of dependencies on other packages.
where OTHER-VERSION is a string.
EXTRA-PROPERTIES is currently unused."
+ (declare (indent defun))
;; FIXME: Placeholder! Should we keep it?
(error "Don't call me!"))
@@ -757,47 +758,47 @@ PKG-DESC is a `package-desc' object."
(format "%s-autoloads" (package-desc-name pkg-desc))
(package-desc-dir pkg-desc)))
-(defun package--activate-autoloads-and-load-path (pkg-desc)
- "Load the autoloads file and add package dir to `load-path'.
-PKG-DESC is a `package-desc' object."
- (let* ((old-lp load-path)
- (pkg-dir (package-desc-dir pkg-desc))
- (pkg-dir-dir (file-name-as-directory pkg-dir)))
- (with-demoted-errors "Error loading autoloads: %s"
- (load (package--autoloads-file-name pkg-desc) nil t))
- (when (and (eq old-lp load-path)
- (not (or (member pkg-dir load-path)
- (member pkg-dir-dir load-path))))
- ;; Old packages don't add themselves to the `load-path', so we have to
- ;; do it ourselves.
- (push pkg-dir load-path))))
-
(defvar Info-directory-list)
(declare-function info-initialize "info" ())
(defvar package--quickstart-pkgs t
"If set to a list, we're computing the set of pkgs to activate.")
-(defun package--load-files-for-activation (pkg-desc reload)
- "Load files for activating a package given by PKG-DESC.
-Load the autoloads file, and ensure `load-path' is setup. If
-RELOAD is non-nil, also load all files in the package that
-correspond to previously loaded files."
- (let* ((loaded-files-list
- (when reload
- (package--list-loaded-files (package-desc-dir pkg-desc)))))
- ;; Add to load path, add autoloads, and activate the package.
- (package--activate-autoloads-and-load-path pkg-desc)
- ;; Call `load' on all files in `package-desc-dir' already present in
- ;; `load-history'. This is done so that macros in these files are updated
- ;; to their new definitions. If another package is being installed which
- ;; depends on this new definition, not doing this update would cause
- ;; compilation errors and break the installation.
- (with-demoted-errors "Error in package--load-files-for-activation: %s"
- (mapc (lambda (feature) (load feature nil t))
- ;; Skip autoloads file since we already evaluated it above.
- (remove (file-truename (package--autoloads-file-name pkg-desc))
- loaded-files-list)))))
+(defsubst package--library-stem (file)
+ (catch 'done
+ (let (result)
+ (dolist (suffix (get-load-suffixes) file)
+ (setq result (string-trim file nil suffix))
+ (unless (equal file result)
+ (throw 'done result))))))
+
+(defun package--reload-previously-loaded (pkg-desc)
+ "Force reimportation of files in PKG-DESC already present in `load-history'.
+New editions of files contain macro definitions and
+redefinitions, the overlooking of which would cause
+byte-compilation of the new package to fail."
+ (with-demoted-errors "Error in package--load-files-for-activation: %s"
+ (let* (result
+ (dir (package-desc-dir pkg-desc))
+ (load-path-sans-dir
+ (cl-remove-if (apply-partially #'string= dir)
+ (or (bound-and-true-p find-function-source-path)
+ load-path)))
+ (files (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))
+ (history (mapcar #'file-truename
+ (cl-remove-if-not #'stringp
+ (mapcar #'car load-history)))))
+ (dolist (file files)
+ (when-let ((library (package--library-stem
+ (file-relative-name file dir)))
+ (canonical (locate-library library nil load-path-sans-dir))
+ (found (member (file-truename canonical) history))
+ (recent-index (length found)))
+ (unless (equal (file-name-base library)
+ (format "%s-autoloads" (package-desc-name pkg-desc)))
+ (push (cons (expand-file-name library dir) recent-index) result))))
+ (mapc (lambda (c) (load (car c) nil t))
+ (sort result (lambda (x y) (< (cdr x) (cdr y))))))))
(defun package-activate-1 (pkg-desc &optional reload deps)
"Activate package given by PKG-DESC, even if it was already active.
@@ -824,7 +825,11 @@ correspond to previously loaded files (those returned by
(if (listp package--quickstart-pkgs)
;; We're only collecting the set of packages to activate!
(push pkg-desc package--quickstart-pkgs)
- (package--load-files-for-activation pkg-desc reload))
+ (when reload
+ (package--reload-previously-loaded pkg-desc))
+ (with-demoted-errors "Error loading autoloads: %s"
+ (load (package--autoloads-file-name pkg-desc) nil t))
+ (add-to-list 'load-path (directory-file-name pkg-dir)))
;; Add info node.
(when (file-exists-p (expand-file-name "dir" pkg-dir))
;; FIXME: not the friendliest, but simple.
@@ -835,48 +840,6 @@ correspond to previously loaded files (those returned by
;; Don't return nil.
t)))
-(defun package--files-load-history ()
- (delq nil
- (mapcar (lambda (x)
- (let ((f (car x)))
- (and (stringp f)
- (file-name-sans-extension (file-truename f)))))
- load-history)))
-
-(defun package--list-of-conflicts (dir history)
- (require 'find-func)
- (declare-function find-library-name "find-func" (library))
- (delq
- nil
- (mapcar
- (lambda (x) (let* ((file (file-relative-name x dir))
- ;; Previously loaded file, if any.
- (previous
- (ignore-error file-error ;"Can't find library"
- (file-name-sans-extension
- (file-truename (find-library-name file)))))
- (pos (when previous (member previous history))))
- ;; Return (RELATIVE-FILENAME . HISTORY-POSITION)
- (when pos
- (cons (file-name-sans-extension file) (length pos)))))
- (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))))
-
-(defun package--list-loaded-files (dir)
- "Recursively list all files in DIR which correspond to loaded features.
-Returns the `file-name-sans-extension' of each file, relative to
-DIR, sorted by most recently loaded last."
- (let* ((history (package--files-load-history))
- (dir (file-truename dir))
- ;; List all files that have already been loaded.
- (list-of-conflicts (package--list-of-conflicts dir history)))
- ;; Turn the list of (FILENAME . POS) back into a list of features. Files in
- ;; subdirectories are returned relative to DIR (so not actually features).
- (let ((default-directory (file-name-as-directory dir)))
- (mapcar (lambda (x) (file-truename (car x)))
- (sort list-of-conflicts
- ;; Sort the files by ascending HISTORY-POSITION.
- (lambda (x y) (< (cdr x) (cdr y))))))))
-
;;;; `package-activate'
(defun package--get-activatable-pkg (pkg-name)
@@ -995,7 +958,7 @@ untar into a directory named DIR; otherwise, signal an error."
(package--native-compile-async new-desc))
;; After compilation, load again any files loaded by
;; `activate-1', so that we use the byte-compiled definitions.
- (package--load-files-for-activation new-desc :reload)))
+ (package--reload-previously-loaded new-desc)))
pkg-dir))
(defun package-generate-description-file (pkg-desc pkg-file)
@@ -1218,13 +1181,17 @@ The return result is a `package-desc'."
info)
(while files
(with-temp-buffer
- (insert-file-contents (pop files))
- ;; When we find the file with the data,
- (when (setq info (ignore-errors (package-buffer-info)))
- ;; stop looping,
- (setq files nil)
- ;; set the 'dir kind,
- (setf (package-desc-kind info) 'dir))))
+ (let ((file (pop files)))
+ ;; The file may be a link to a nonexistent file; e.g., a
+ ;; lock file.
+ (when (file-exists-p file)
+ (insert-file-contents file)
+ ;; When we find the file with the data,
+ (when (setq info (ignore-errors (package-buffer-info)))
+ ;; stop looping,
+ (setq files nil)
+ ;; set the 'dir kind,
+ (setf (package-desc-kind info) 'dir))))))
(unless info
(error "No .el files with package headers in `%s'" default-directory))
;; and return the info.
@@ -2488,6 +2455,15 @@ The description is read from the installed package files."
(format "%s.el" (package-desc-name desc)) srcdir))
"")))
+(defun package--describe-add-library-links ()
+ "Add links to library names in package description."
+ (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t)
+ (if (locate-library (match-string 1))
+ (make-text-button (match-beginning 1) (match-end 1)
+ 'xref (match-string-no-properties 1)
+ 'help-echo "Read this file's commentary"
+ :type 'package--finder-xref))))
+
(defun describe-package-1 (pkg)
"Insert the package description for PKG.
Helper function for `describe-package'."
@@ -2714,6 +2690,9 @@ Helper function for `describe-package'."
t)
(insert (or readme-string
"This package does not provide a description.")))))
+ ;; Make library descriptions into links.
+ (goto-char start-of-description)
+ (package--describe-add-library-links)
;; Make URLs in the description into links.
(goto-char start-of-description)
(browse-url-add-buttons))))
@@ -2759,6 +2738,15 @@ function is a convenience wrapper used by `describe-package-1'."
(apply #'insert-text-button button-text 'face button-face 'follow-link t
properties)))
+(defun package--finder-goto-xref (button)
+ "Jump to a Lisp file for the BUTTON at point."
+ (let* ((file (button-get button 'xref))
+ (lib (locate-library file)))
+ (if lib (finder-commentary lib)
+ (message "Unable to locate `%s'" file))))
+
+(define-button-type 'package--finder-xref 'action #'package--finder-goto-xref)
+
(defun package--print-email-button (recipient)
"Insert a button whose action will send an email to RECIPIENT.
NAME should have the form (FULLNAME . EMAIL) where FULLNAME is
@@ -2780,35 +2768,33 @@ either a full name or nil, and EMAIL is a valid email address."
;;;; Package menu mode.
-(defvar package-menu-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map tabulated-list-mode-map)
- (define-key map "\C-m" 'package-menu-describe-package)
- (define-key map "u" 'package-menu-mark-unmark)
- (define-key map "\177" 'package-menu-backup-unmark)
- (define-key map "d" 'package-menu-mark-delete)
- (define-key map "i" 'package-menu-mark-install)
- (define-key map "U" 'package-menu-mark-upgrades)
- (define-key map "r" 'revert-buffer)
- (define-key map "~" 'package-menu-mark-obsolete-for-deletion)
- (define-key map "w" 'package-browse-url)
- (define-key map "x" 'package-menu-execute)
- (define-key map "h" 'package-menu-quick-help)
- (define-key map "H" #'package-menu-hide-package)
- (define-key map "?" 'package-menu-describe-package)
- (define-key map "(" #'package-menu-toggle-hiding)
- (define-key map (kbd "/ /") 'package-menu-clear-filter)
- (define-key map (kbd "/ a") 'package-menu-filter-by-archive)
- (define-key map (kbd "/ d") 'package-menu-filter-by-description)
- (define-key map (kbd "/ k") 'package-menu-filter-by-keyword)
- (define-key map (kbd "/ N") 'package-menu-filter-by-name-or-description)
- (define-key map (kbd "/ n") 'package-menu-filter-by-name)
- (define-key map (kbd "/ s") 'package-menu-filter-by-status)
- (define-key map (kbd "/ v") 'package-menu-filter-by-version)
- (define-key map (kbd "/ m") 'package-menu-filter-marked)
- (define-key map (kbd "/ u") 'package-menu-filter-upgradable)
- map)
- "Local keymap for `package-menu-mode' buffers.")
+(defvar-keymap package-menu-mode-map
+ :doc "Local keymap for `package-menu-mode' buffers."
+ :parent tabulated-list-mode-map
+ "C-m" #'package-menu-describe-package
+ "u" #'package-menu-mark-unmark
+ "DEL" #'package-menu-backup-unmark
+ "d" #'package-menu-mark-delete
+ "i" #'package-menu-mark-install
+ "U" #'package-menu-mark-upgrades
+ "r" #'revert-buffer
+ "~" #'package-menu-mark-obsolete-for-deletion
+ "w" #'package-browse-url
+ "x" #'package-menu-execute
+ "h" #'package-menu-quick-help
+ "H" #'package-menu-hide-package
+ "?" #'package-menu-describe-package
+ "(" #'package-menu-toggle-hiding
+ "/ /" #'package-menu-clear-filter
+ "/ a" #'package-menu-filter-by-archive
+ "/ d" #'package-menu-filter-by-description
+ "/ k" #'package-menu-filter-by-keyword
+ "/ N" #'package-menu-filter-by-name-or-description
+ "/ n" #'package-menu-filter-by-name
+ "/ s" #'package-menu-filter-by-status
+ "/ v" #'package-menu-filter-by-version
+ "/ m" #'package-menu-filter-marked
+ "/ u" #'package-menu-filter-upgradable)
(easy-menu-define package-menu-mode-menu package-menu-mode-map
"Menu for `package-menu-mode'."
@@ -4195,6 +4181,7 @@ activations need to be changed, such as when `package-load-list' is modified."
(replace-match (if (match-end 1) "" pfile) t t)))
(unless (bolp) (insert "\n"))
(insert ")\n")))
+ (pp `(defvar package-activated-list) (current-buffer))
(pp `(setq package-activated-list
(append ',(mapcar #'package-desc-name package--quickstart-pkgs)
package-activated-list))
@@ -4212,6 +4199,7 @@ activations need to be changed, such as when `package-load-list' is modified."
;; Local\sVariables:
;; version-control: never
;; no-update-autoloads: t
+;; byte-compile-warnings: (not make-local)
;; End:
"))
;; FIXME: Do it asynchronously in an Emacs subprocess, and
diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el
index 0bf774dffd8..8464b5a5198 100644
--- a/lisp/emacs-lisp/pp.el
+++ b/lisp/emacs-lisp/pp.el
@@ -33,22 +33,43 @@
(defcustom pp-escape-newlines t
"Value of `print-escape-newlines' used by pp-* functions."
+ :type 'boolean)
+
+(defcustom pp-max-width t
+ "Max width to use when formatting.
+If nil, there's no max width. If t, use the window width.
+Otherwise this should be a number."
+ :type '(choice (const :tag "none" nil)
+ (const :tag "window width" t)
+ number)
+ :version "29.1")
+
+(defcustom pp-use-max-width nil
+ "If non-nil, `pp'-related functions will try to fold lines.
+The target width is given by the `pp-max-width' variable."
:type 'boolean
- :group 'pp)
+ :version "29.1")
+
+(defvar pp--inhibit-function-formatting nil)
;;;###autoload
(defun pp-to-string (object)
"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."
- (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)))
+ (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))))
;;;###autoload
(defun pp-buffer ()
@@ -56,7 +77,6 @@ to make output that `read' can handle, whenever this is possible."
(interactive)
(goto-char (point-min))
(while (not (eobp))
- ;; (message "%06d" (- (point-max) (point)))
(cond
((ignore-errors (down-list 1) t)
(save-excursion
@@ -82,11 +102,21 @@ to make output that `read' can handle, whenever this is possible."
"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.
+
Output stream is STREAM, or value of `standard-output' (which see)."
(princ (pp-to-string object) (or stream standard-output)))
-(defun pp-display-expression (expression out-buffer-name)
+;;;###autoload
+(defun pp-display-expression (expression out-buffer-name &optional lisp)
"Prettify and display EXPRESSION in an appropriate way, depending on length.
+If LISP, format with `pp-emacs-lisp-code'; use `pp' otherwise.
+
If a temporary buffer is needed for representation, it will be named
after OUT-BUFFER-NAME."
(let* ((old-show-function temp-buffer-show-function)
@@ -110,11 +140,13 @@ after OUT-BUFFER-NAME."
(select-window window)
(run-hooks 'temp-buffer-show-hook))
(when (window-live-p old-selected)
- (select-window old-selected))
- (message "See buffer %s." out-buffer-name)))
+ (select-window old-selected))))
(message "%s" (buffer-substring (point-min) (point))))))))
(with-output-to-temp-buffer out-buffer-name
- (pp expression)
+ (if lisp
+ (with-current-buffer standard-output
+ (pp-emacs-lisp-code expression))
+ (pp expression))
(with-current-buffer standard-output
(emacs-lisp-mode)
(setq buffer-read-only nil)
@@ -179,6 +211,188 @@ Ignores leading comment characters."
(insert (pp-to-string (macroexpand-1 (pp-last-sexp))))
(pp-macroexpand-expression (pp-last-sexp))))
+;;;###autoload
+(defun pp-emacs-lisp-code (sexp)
+ "Insert SEXP into the current buffer, formatted as Emacs Lisp code.
+Use the `pp-max-width' variable to control the desired line length."
+ (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))))
+
+(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)
+ (eq (car sexp) 'quote))
+ (cond
+ ((symbolp (cadr sexp))
+ (let ((print-quoted t))
+ (prin1 sexp (current-buffer))))
+ ((consp (cadr sexp))
+ (insert "'")
+ (pp--format-list (cadr sexp)
+ (set-marker (make-marker) (1- (point))))))
+ (pp--format-list sexp)))
+ (t
+ (princ sexp (current-buffer)))))
+ ;; Print some of the smaller integers as characters, perhaps?
+ (integer
+ (if (<= ?0 sexp ?z)
+ (let ((print-integers-as-characters t))
+ (princ sexp (current-buffer)))
+ (princ sexp (current-buffer))))
+ (string
+ (let ((print-escape-newlines t))
+ (prin1 sexp (current-buffer))))
+ (otherwise (princ sexp (current-buffer)))))
+
+(defun pp--format-vector (sexp)
+ (insert "[")
+ (cl-loop for i from 0
+ for element across sexp
+ do (pp--insert (and (> i 0) " ") element))
+ (insert "]"))
+
+(defun pp--format-list (sexp &optional start)
+ (if (and (symbolp (car sexp))
+ (not pp--inhibit-function-formatting)
+ (not (keywordp (car sexp))))
+ (pp--format-function sexp)
+ (insert "(")
+ (pp--insert start (pop sexp))
+ (while sexp
+ (pp--insert " " (pop sexp)))
+ (insert ")")))
+
+(defun pp--format-function (sexp)
+ (let* ((sym (car sexp))
+ (edebug (get sym 'edebug-form-spec))
+ (indent (get sym 'lisp-indent-function))
+ (doc (get sym 'doc-string-elt)))
+ (when (eq indent 'defun)
+ (setq indent 2))
+ ;; We probably want to keep all the elements before the doc string
+ ;; on a single line.
+ (when doc
+ (setq indent (1- doc)))
+ ;; Special-case closures -- these shouldn't really exist in actual
+ ;; source code, so there's no indentation information. But make
+ ;; them output slightly better.
+ (when (and (not indent)
+ (eq sym 'closure))
+ (setq indent 0))
+ (pp--insert "(" sym)
+ (pop sexp)
+ ;; Get the first entries on the first line.
+ (if indent
+ (pp--format-definition sexp indent edebug)
+ (let ((prev 0))
+ (while sexp
+ (let ((start (point)))
+ ;; Don't put sexps on the same line as a multi-line sexp
+ ;; preceding it.
+ (pp--insert (if (> prev 1) "\n" " ")
+ (pop sexp))
+ (setq prev (count-lines start (point)))))))
+ (insert ")")))
+
+(defun pp--format-definition (sexp indent edebug)
+ (while (and (cl-plusp indent)
+ sexp)
+ (insert " ")
+ ;; We don't understand all the edebug specs.
+ (unless (consp edebug)
+ (setq edebug nil))
+ (if (and (consp (car edebug))
+ (eq (caar edebug) '&rest))
+ (pp--insert-binding (pop sexp))
+ (if (null (car sexp))
+ (insert "()")
+ (pp--insert-lisp (car sexp)))
+ (pop sexp))
+ (pop edebug)
+ (cl-decf indent))
+ (when (stringp (car sexp))
+ (insert "\n")
+ (prin1 (pop sexp) (current-buffer)))
+ ;; Then insert the rest with line breaks before each form.
+ (while sexp
+ (insert "\n")
+ (if (keywordp (car sexp))
+ (progn
+ (pp--insert-lisp (pop sexp))
+ (when sexp
+ (pp--insert " " (pop sexp))))
+ (pp--insert-lisp (pop sexp)))))
+
+(defun pp--insert-binding (sexp)
+ (insert "(")
+ (while sexp
+ (if (consp (car sexp))
+ ;; Newlines after each (...) binding.
+ (progn
+ (pp--insert-lisp (car sexp))
+ (when (cdr sexp)
+ (insert "\n")))
+ ;; Keep plain symbols on the same line.
+ (pp--insert " " (car sexp)))
+ (pop sexp))
+ (insert ")"))
+
+(defun pp--insert (delim &rest things)
+ (let ((start (if (markerp delim)
+ (prog1
+ delim
+ (setq delim nil))
+ (point-marker))))
+ (when delim
+ (insert delim))
+ (dolist (thing things)
+ (pp--insert-lisp thing))
+ ;; We need to indent what we have so far to see if we have to fold.
+ (pp--indent-buffer)
+ (when (> (current-column) (pp--max-width))
+ (save-excursion
+ (goto-char start)
+ (unless (looking-at "[ \t]+$")
+ (insert "\n"))
+ (pp--indent-buffer)
+ (goto-char (point-max))
+ ;; If we're still too wide, then go up one step and try to
+ ;; insert a newline there.
+ (when (> (current-column) (pp--max-width))
+ (condition-case ()
+ (backward-up-list 1)
+ (:success (when (looking-back " " 2)
+ (insert "\n")))
+ (error nil)))))))
+
+(defun pp--max-width ()
+ (cond ((numberp pp-max-width)
+ pp-max-width)
+ ((null pp-max-width)
+ most-positive-fixnum)
+ ((eq pp-max-width t)
+ (window-width))
+ (t
+ (error "Invalid pp-max-width value: %s" pp-max-width))))
+
+(defun pp--indent-buffer ()
+ (goto-char (point-min))
+ (while (not (eobp))
+ (lisp-indent-line)
+ (forward-line 1)))
+
(provide 'pp) ; so (require 'pp) works
;;; pp.el ends here
diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el
index aec438ed994..9be6ac649f3 100644
--- a/lisp/emacs-lisp/re-builder.el
+++ b/lisp/emacs-lisp/re-builder.el
@@ -274,8 +274,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
emacs-lisp-mode "RE Builder Lisp"
"Major mode for interactively building symbolic Regular Expressions."
;; Pull in packages as needed
- (cond ((memq reb-re-syntax '(sregex rx)) ; rx-to-string is autoloaded
- (require 'rx))) ; require rx anyway
+ (when (eq reb-re-syntax 'rx) ; rx-to-string is autoloaded
+ (require 'rx)) ; require rx anyway
(reb-mode-common))
(defvar reb-subexp-mode-map
@@ -307,8 +307,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
(eq 'color (frame-parameter nil 'display-type)))
(defsubst reb-lisp-syntax-p ()
- "Return non-nil if RE Builder uses a Lisp syntax."
- (memq reb-re-syntax '(sregex rx)))
+ "Return non-nil if RE Builder uses `rx' syntax."
+ (eq reb-re-syntax 'rx))
(defmacro reb-target-binding (symbol)
"Return binding for SYMBOL in the RE Builder target buffer."
@@ -448,7 +448,8 @@ provided in the Commentary section of this library."
(setq reb-subexp-mode t)
(reb-update-modestring)
(use-local-map reb-subexp-mode-map)
- (message "`0'-`9' to display subexpressions `q' to quit subexp mode"))
+ (message (substitute-command-keys
+ "\\`0'-\\`9' to display subexpressions \\`q' to quit subexp mode")))
(defun reb-show-subexp (subexp &optional pause)
"Visually show limit of subexpression SUBEXP of recent search.
@@ -482,11 +483,11 @@ Optional argument SYNTAX must be specified if called non-interactively."
(list (intern
(completing-read
(format-prompt "Select syntax" reb-re-syntax)
- '(read string sregex rx)
+ '(read string rx)
nil t nil nil (symbol-name reb-re-syntax)
'reb-change-syntax-hist))))
- (if (memq syntax '(read string sregex rx))
+ (if (memq syntax '(read string rx))
(let ((buffer (get-buffer reb-buffer)))
(setq reb-re-syntax syntax)
(when buffer
@@ -605,9 +606,9 @@ optional fourth argument FORCE is non-nil."
(defun reb-cook-regexp (re)
"Return RE after processing it according to `reb-re-syntax'."
- (cond ((memq reb-re-syntax '(sregex rx))
- (rx-to-string (eval (car (read-from-string re)))))
- (t re)))
+ (if (eq reb-re-syntax 'rx)
+ (rx-to-string (eval (car (read-from-string re))))
+ re))
(defun reb-update-regexp ()
"Update the regexp for the target buffer.
diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el
index e2a24e9949c..1fbe946a7f9 100644
--- a/lisp/emacs-lisp/shadow.el
+++ b/lisp/emacs-lisp/shadow.el
@@ -151,9 +151,6 @@ See the documentation for `list-load-path-shadows' for further information."
;; Return the list of shadowings.
shadows))
-(define-obsolete-function-alias 'find-emacs-lisp-shadows
- 'load-path-shadows-find "23.3")
-
;; Return true if neither file exists, or if both exist and have identical
;; contents.
(defun load-path-shadows-same-file-or-nonexistent (f1 f2)
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index 17ac3e471c0..b9e000cc05f 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -71,6 +71,7 @@ string, it'll be inserted as is, then the string will be `read',
and then evaluated.
There can be any number of :example/:result elements."
+ (declare (indent defun))
`(progn
(setq shortdoc--groups (delq (assq ',group shortdoc--groups)
shortdoc--groups))
@@ -195,6 +196,13 @@ There can be any number of :example/:result elements."
:eval (substring-no-properties (propertize "foobar" 'face 'bold) 0 3))
(try-completion
:eval (try-completion "foo" '("foobar" "foozot" "gazonk")))
+ "Unicode Strings"
+ (string-glyph-split
+ :eval (string-glyph-split "Hello, 👼🏻🧑🏼‍🤝‍🧑🏻"))
+ (string-glyph-compose
+ :eval (string-glyph-compose "Å"))
+ (string-glyph-decompose
+ :eval (string-glyph-decompose "Å"))
"Predicates for Strings"
(string-equal
:eval (string-equal "foo" "foo"))
@@ -241,7 +249,14 @@ There can be any number of :example/:result elements."
:eval (number-to-string 42))
"Data About Strings"
(length
- :eval (length "foo"))
+ :eval (length "foo")
+ :eval (length "avocado: 🥑"))
+ (string-width
+ :eval (string-width "foo")
+ :eval (string-width "avocado: 🥑"))
+ (string-pixel-width
+ :eval (string-pixel-width "foo")
+ :eval (string-pixel-width "avocado: 🥑"))
(string-search
:eval (string-search "bar" "foobarzot"))
(assoc-string
@@ -271,6 +286,9 @@ There can be any number of :example/:result elements."
:eval (file-name-base "/tmp/foo.txt"))
(file-relative-name
:eval (file-relative-name "/tmp/foo" "/tmp"))
+ (file-name-split
+ :eval (file-name-split "/tmp/foo")
+ :eval (file-name-split "foo/bar"))
(make-temp-name
:eval (make-temp-name "/tmp/foo-"))
(file-name-concat
@@ -348,6 +366,9 @@ There can be any number of :example/:result elements."
(file-newer-than-file-p
:no-eval (file-newer-than-file-p "/tmp/foo" "/tmp/bar")
:eg-result nil)
+ (file-has-changed-p
+ :no-eval (file-has-changed-p "/tmp/foo")
+ :eg-result t)
(file-equal-p
:no-eval (file-equal-p "/tmp/foo" "/tmp/bar")
:eg-result nil)
@@ -1206,6 +1227,39 @@ There can be any number of :example/:result elements."
(text-property-search-backward
:no-eval (text-property-search-backward 'face nil t)))
+(define-short-documentation-group keymaps
+ "Defining keymaps"
+ (define-keymap
+ :no-eval (define-keymap "C-c C-c" #'quit-buffer))
+ (defvar-keymap
+ :no-eval (defvar-keymap my-keymap "C-c C-c" #'quit-buffer))
+ "Setting keys"
+ (keymap-set
+ :no-eval (keymap-set map "C-c C-c" #'quit-buffer))
+ (keymap-local-set
+ :no-eval (keymap-local-set "C-c C-c" #'quit-buffer))
+ (keymap-global-set
+ :no-eval (keymap-global-set "C-c C-c" #'quit-buffer))
+ (keymap-unset
+ :no-eval (keymap-unset map "C-c C-c"))
+ (keymap-local-unset
+ :no-eval (keymap-local-unset "C-c C-c"))
+ (keymap-global-unset
+ :no-eval (keymap-global-unset "C-c C-c"))
+ (keymap-substitute
+ :no-eval (keymap-substitute map "C-c C-c" "M-a"))
+ (keymap-set-after
+ :no-eval (keymap-set-after map "<separator-2>" menu-bar-separator))
+ "Predicates"
+ (keymapp
+ :eval (keymapp (define-keymap)))
+ (key-valid-p
+ :eval (key-valid-p "C-c C-c")
+ :eval (key-valid-p "C-cC-c"))
+ "Lookup"
+ (keymap-lookup
+ :eval (keymap-lookup (current-global-map) "C-x x g")))
+
;;;###autoload
(defun shortdoc-display-group (group &optional function)
"Pop to a buffer with short documentation summary for functions in GROUP.
@@ -1369,14 +1423,12 @@ Example:
(setq slist (cdr slist)))
(setcdr slist (cons elem (cdr slist))))))
-(defvar shortdoc-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "n") 'shortdoc-next)
- (define-key map (kbd "p") 'shortdoc-previous)
- (define-key map (kbd "C-c C-n") 'shortdoc-next-section)
- (define-key map (kbd "C-c C-p") 'shortdoc-previous-section)
- map)
- "Keymap for `shortdoc-mode'.")
+(defvar-keymap shortdoc-mode-map
+ :doc "Keymap for `shortdoc-mode'."
+ "n" #'shortdoc-next
+ "p" #'shortdoc-previous
+ "C-c C-n" #'shortdoc-next-section
+ "C-c C-p" #'shortdoc-previous-section)
(define-derived-mode shortdoc-mode special-mode "shortdoc"
"Mode for shortdoc."
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 788cd0f34bf..b53245b9b5f 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -208,7 +208,9 @@ The variable list SPEC is the same as in `if-let'."
(string= string ""))
(defsubst string-join (strings &optional separator)
- "Join all STRINGS using 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))
(define-obsolete-function-alias 'string-reverse 'reverse "25.1")
@@ -400,6 +402,114 @@ as the new values of the bound variables in the recursive invocation."
(cl-labels ((,name ,fargs . ,body)) #',name)
. ,aargs)))
+(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
+and return the value found in PLACE instead."
+ (declare (indent 1) (debug (gv-place body)))
+ (gv-letplace (getter setter) place
+ `(or ,getter
+ ,(macroexp-let2 nil val (macroexp-progn code)
+ `(progn
+ ,(funcall setter val)
+ ,val)))))
+
+;;;###autoload
+(defun ensure-empty-lines (&optional lines)
+ "Ensure that there are LINES number of empty lines before point.
+If LINES is nil or omitted, ensure that there is a single empty
+line before point.
+
+If called interactively, LINES is given by the prefix argument.
+
+If there are more than LINES empty lines before point, the number
+of empty lines is reduced to LINES.
+
+If point is not at the beginning of a line, a newline character
+is inserted before adjusting the number of empty lines."
+ (interactive "p")
+ (unless (bolp)
+ (insert "\n"))
+ (let ((lines (or lines 1))
+ (start (save-excursion
+ (if (re-search-backward "[^\n]" nil t)
+ (+ (point) 2)
+ (point-min)))))
+ (cond
+ ((> (- (point) start) lines)
+ (delete-region (point) (- (point) (- (point) start lines))))
+ ((< (- (point) start) lines)
+ (insert (make-string (- lines (- (point) start)) ?\n))))))
+
+;;;###autoload
+(defun string-pixel-width (string)
+ "Return the width of STRING in pixels."
+ (with-temp-buffer
+ (insert string)
+ (car (buffer-text-pixel-size nil nil t))))
+
+;;;###autoload
+(defun string-glyph-split (string)
+ "Split STRING into a list of strings representing separate glyphs.
+This takes into account combining characters and grapheme clusters."
+ (let ((result nil)
+ (start 0)
+ comp)
+ (while (< start (length string))
+ (if (setq comp (find-composition-internal
+ start
+ ;; Don't search backward in the string for the
+ ;; start of the composition.
+ (min (length string) (1+ start))
+ string nil))
+ (progn
+ (push (substring string (car comp) (cadr comp)) result)
+ (setq start (cadr comp)))
+ (push (substring string start (1+ start)) result)
+ (setq start (1+ start))))
+ (nreverse result)))
+
+;;;###autoload
+(defun add-display-text-property (start end prop value
+ &optional object)
+ "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
+properties are retained.
+
+If OBJECT is non-nil, it should be a string or a buffer. If nil,
+this defaults to the current buffer."
+ (let ((sub-start start)
+ (sub-end 0)
+ disp)
+ (while (< sub-end end)
+ (setq sub-end (next-single-property-change sub-start 'display object
+ (if (stringp object)
+ (min (length object) end)
+ (min end (point-max)))))
+ (if (not (setq disp (get-text-property sub-start 'display object)))
+ ;; No old properties in this range.
+ (put-text-property sub-start sub-end 'display (list prop value))
+ ;; We have old properties.
+ (let ((vector nil))
+ ;; Make disp into a list.
+ (setq disp
+ (cond
+ ((vectorp disp)
+ (setq vector t)
+ (seq-into disp 'list))
+ ((not (consp (car disp)))
+ (list disp))
+ (t
+ disp)))
+ ;; Remove any old instances.
+ (when-let ((old (assoc prop disp)))
+ (setq disp (delete old disp)))
+ (setq disp (cons (list prop value) disp))
+ (when vector
+ (setq disp (seq-into disp 'vector)))
+ ;; Finally update the range.
+ (put-text-property sub-start sub-end 'display disp)))
+ (setq sub-start sub-end))))
(provide 'subr-x)
diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el
index 0ae355e5917..075fe836f6b 100644
--- a/lisp/emacs-lisp/tabulated-list.el
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -115,16 +115,25 @@ where:
This should be either a function, or a list.
If a list, each element has the form (ID [DESC1 ... DESCN]),
where:
+
- ID is nil, or a Lisp object uniquely identifying this entry,
which is used to keep the cursor on the \"same\" entry when
rearranging the list. Comparison is done with `equal'.
- Each DESC is a column descriptor, one for each column
- specified in `tabulated-list-format'. A descriptor is either
- a string, which is printed as-is, or a list (LABEL . PROPS),
- which means to use `insert-text-button' to insert a text
- button with label LABEL and button properties PROPS.
- The string, or button label, must not contain any newline.
+ specified in `tabulated-list-format'. The descriptor DESC is
+ one of:
+
+ - A string, which is printed as-is, and must not contain any
+ newlines.
+
+ - An image descriptor (a list), which is used to insert an
+ image (see Info node `(elisp) Image Descriptors').
+
+ - A list (LABEL . PROPS), which means to use
+ `insert-text-button' to insert a text button with label
+ LABEL and button properties PROPS. LABEL must not contain
+ any newlines.
If `tabulated-list-entries' is a function, it is called with no
arguments and must return a list of the above form.")
@@ -547,7 +556,9 @@ Return the column number after insertion."
(props (nthcdr 3 format))
(pad-right (or (plist-get props :pad-right) 1))
(right-align (plist-get props :right-align))
- (label (if (stringp col-desc) col-desc (car col-desc)))
+ (label (cond ((stringp col-desc) col-desc)
+ ((eq (car col-desc) 'image) " ")
+ (t (car col-desc))))
(label-width (string-width label))
(help-echo (concat (car format) ": " label))
(opoint (point))
@@ -571,11 +582,15 @@ Return the column number after insertion."
'display `(space :align-to ,(+ x shift))))
(setq width (- width shift))
(setq x (+ x shift))))
- (if (stringp col-desc)
- (insert (if (get-text-property 0 'help-echo label)
- label
- (propertize label 'help-echo help-echo)))
- (apply 'insert-text-button label (cdr col-desc)))
+ (cond ((stringp col-desc)
+ (insert (if (get-text-property 0 'help-echo label)
+ label
+ (propertize label 'help-echo help-echo))))
+ ((eq (car col-desc) 'image)
+ (insert (propertize " "
+ 'display col-desc
+ 'help-echo help-echo)))
+ ((apply 'insert-text-button label (cdr col-desc))))
(let ((next-x (+ x pad-right width)))
;; No need to append any spaces if this is the last column.
(when not-last-col
@@ -669,6 +684,10 @@ With a numeric prefix argument N, sort the Nth column.
If the numeric prefix is -1, restore order the list was
originally displayed in."
(interactive "P")
+ (when (and n
+ (or (>= n (length tabulated-list-format))
+ (< n -1)))
+ (user-error "Invalid column number"))
(if (equal n -1)
;; Restore original order.
(progn
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index 1ef4931b7be..c7d02cc7487 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -314,7 +314,7 @@ This function is called, by name, directly by the C code."
(not (timer--idle-delay timer)))
(setf (timer--time timer)
(timer-next-integral-multiple-of-time
- (current-time) (timer--repeat-delay timer))))
+ nil (timer--repeat-delay timer))))
;; Place it back on the timer-list before running
;; timer--function, so it can cancel-timer itself.
(timer-activate timer t cell)
@@ -351,19 +351,27 @@ This function is called, by name, directly by the C code."
Repeat the action every REPEAT seconds, if REPEAT is non-nil.
REPEAT may be an integer or floating point number.
TIME should be one of:
+
- a string giving today's time like \"11:23pm\"
(the acceptable formats are HHMM, H:MM, HH:MM, HHam, HHAM,
HHpm, HHPM, HH:MMam, HH:MMAM, HH:MMpm, or HH:MMPM;
a period `.' can be used instead of a colon `:' to separate
the hour and minute parts);
+
- a string giving a relative time like \"90\" or \"2 hours 35 minutes\"
(the acceptable forms are a number of seconds without units
or some combination of values using units in `timer-duration-words');
+
- nil, meaning now;
+
- a number of seconds from now;
+
- a value from `encode-time';
-- or t (with non-nil REPEAT) meaning the next integral
- multiple of REPEAT.
+
+- or t (with non-nil REPEAT) meaning the next integral multiple
+ of REPEAT. This is handy when you want the function to run at
+ a certain \"round\" number. For instance, (run-at-time t 60 ...)
+ will run at 11:04:00, 11:05:00, etc.
The action is to call FUNCTION with arguments ARGS.
@@ -383,7 +391,7 @@ This function returns a timer object which you can use in
;; Special case: t means the next integral multiple of REPEAT.
(when (and (eq time t) repeat)
- (setq time (timer-next-integral-multiple-of-time (current-time) repeat))
+ (setq time (timer-next-integral-multiple-of-time nil repeat))
(setf (timer--integral-multiple timer) t))
;; Handle numbers as relative times in seconds.
diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el
index 36b275e2d3c..1d061364a03 100644
--- a/lisp/emacs-lisp/warnings.el
+++ b/lisp/emacs-lisp/warnings.el
@@ -307,7 +307,9 @@ entirely by setting `warning-suppress-types' or
'type 'warning-suppress-log-warning
'warning-type type))
(funcall newline)
- (when (and warning-fill-prefix (not (string-search "\n" message)))
+ (when (and warning-fill-prefix
+ (not (string-search "\n" message))
+ (not noninteractive))
(let ((fill-prefix warning-fill-prefix)
(fill-column warning-fill-column))
(fill-region start (point))))
diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el
index 3976c1ea063..befcb423823 100644
--- a/lisp/emulation/cua-base.el
+++ b/lisp/emulation/cua-base.el
@@ -396,17 +396,17 @@ and after the region marked by the rectangle to search."
(defcustom cua-rectangle-mark-key [(control return)]
"Global key used to toggle the cua rectangle mark."
- :set #'(lambda (symbol value)
- (set symbol value)
- (when (and (boundp 'cua--keymaps-initialized)
- cua--keymaps-initialized)
- (define-key cua-global-keymap value
- #'cua-set-rectangle-mark)
- (when (boundp 'cua--rectangle-keymap)
- (define-key cua--rectangle-keymap value
- #'cua-clear-rectangle-mark)
- (define-key cua--region-keymap value
- #'cua-toggle-rectangle-mark))))
+ :set (lambda (symbol value)
+ (set symbol value)
+ (when (and (boundp 'cua--keymaps-initialized)
+ cua--keymaps-initialized)
+ (define-key cua-global-keymap value
+ #'cua-set-rectangle-mark)
+ (when (boundp 'cua--rectangle-keymap)
+ (define-key cua--rectangle-keymap value
+ #'cua-clear-rectangle-mark)
+ (define-key cua--region-keymap value
+ #'cua-toggle-rectangle-mark))))
:type 'key-sequence)
(defcustom cua-rectangle-modifier-key 'meta
@@ -699,6 +699,11 @@ Repeating prefix key when region is active works as a single prefix key."
(interactive)
(cua--prefix-override-replay 0))
+;; These aliases are so that we can look up the commands and find the
+;; correct keys when generating menus.
+(defalias 'cua-cut-handler #'cua--prefix-override-handler)
+(defalias 'cua-copy-handler #'cua--prefix-override-handler)
+
(defun cua--prefix-repeat-handler ()
"Repeating prefix key when region is active works as a single prefix key."
(interactive)
@@ -1258,10 +1263,8 @@ If ARG is the atom `-', scroll upward by nearly full screen."
(define-key cua--cua-keys-keymap [(meta v)]
#'delete-selection-repeat-replace-region))
- (define-key cua--prefix-override-keymap [(control x)]
- #'cua--prefix-override-handler)
- (define-key cua--prefix-override-keymap [(control c)]
- #'cua--prefix-override-handler)
+ (define-key cua--prefix-override-keymap [(control x)] #'cua-cut-handler)
+ (define-key cua--prefix-override-keymap [(control c)] #'cua-copy-handler)
(define-key cua--prefix-repeat-keymap [(control x) (control x)]
#'cua--prefix-repeat-handler)
diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el
index 65ae2f192fa..7df45e705d3 100644
--- a/lisp/emulation/cua-rect.el
+++ b/lisp/emulation/cua-rect.el
@@ -486,10 +486,8 @@ Activates the region if needed. Only lasts until the region is deactivated."
(cua--deactivate t))
(setq cua--last-rectangle nil)
(mouse-set-point event)
- ;; FIX ME -- need to calculate virtual column.
- (cua-set-rectangle-mark)
- (setq cua--buffer-and-point-before-command nil)
- (setq cua--mouse-last-pos nil))
+ (activate-mark)
+ (cua-rectangle-mark-mode))
(defun cua-mouse-save-then-kill-rectangle (event arg)
"Expand rectangle to mouse click position and copy rectangle.
diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el
index 9f3d515bc6d..849ad3d8241 100644
--- a/lisp/emulation/viper-cmd.el
+++ b/lisp/emulation/viper-cmd.el
@@ -35,9 +35,7 @@
(defvar viper--key-maps)
(defvar viper--intercept-key-maps)
(defvar iso-accents-mode)
-(defvar quail-mode)
(defvar quail-current-str)
-(defvar mark-even-if-inactive)
(defvar viper--init-message)
(defvar viper-initial)
(defvar undo-beg-posn)
@@ -69,8 +67,7 @@
(nm-p (intern (concat snm "-p")))
(nms (intern (concat snm "s"))))
`(defun ,nm-p (com)
- (consp (viper-memq-char com ,nms)
- ))))
+ (consp (memq com ,nms)))))
;; Variables for defining VI commands
@@ -1035,23 +1032,23 @@ as a Meta key and any number of multiple escapes are allowed."
cmd-info
cmd-to-exec-at-end)
(while (and cont
- (viper-memq-char char
- (list ?c ?d ?y ?! ?< ?> ?= ?# ?r ?R ?\"
- viper-buffer-search-char)))
+ (memq char
+ (list ?c ?d ?y ?! ?< ?> ?= ?# ?r ?R ?\"
+ viper-buffer-search-char)))
(if com
;; this means that we already have a command character, so we
;; construct a com list and exit while. however, if char is "
;; it is an error.
(progn
;; new com is (CHAR . OLDCOM)
- (if (viper-memq-char char '(?# ?\")) (user-error viper-ViperBell))
+ (if (memq char '(?# ?\")) (user-error viper-ViperBell))
(setq com (cons char com))
(setq cont nil))
;; If com is nil we set com as char, and read more. Again, if char is
;; ", we read the name of register and store it in viper-use-register.
;; if char is !, =, or #, a complete com is formed so we exit the while
;; loop.
- (cond ((viper-memq-char char '(?! ?=))
+ (cond ((memq char '(?! ?=))
(setq com char)
(setq char (read-char))
(setq cont nil))
@@ -1091,7 +1088,7 @@ as a Meta key and any number of multiple escapes are allowed."
`(key-binding (char-to-string ,char)))))
;; as com is non-nil, this means that we have a command to execute
- (if (viper-memq-char (car com) '(?r ?R))
+ (if (memq (car com) '(?r ?R))
;; execute appropriate region command.
(let ((char (car com)) (com (cdr com)))
(setq prefix-arg (cons value com))
@@ -2314,7 +2311,6 @@ problems."
(viper-downgrade-to-insert))
(defun viper-start-R-mode ()
- ;; Leave arg as 1, not t: XEmacs insists that it must be a pos number
(overwrite-mode 1)
(add-hook
'viper-post-command-hooks #'viper-R-state-post-command-sentinel t 'local)
@@ -2603,12 +2599,12 @@ On reaching beginning of line, stop and signal error."
(let ((prev-char (viper-char-at-pos 'backward))
(saved-point (point)))
;; skip non-newline separators backward
- (while (and (not (viper-memq-char prev-char '(nil \n)))
+ (while (and (not (memq prev-char '(nil \n)))
(< lim (point))
;; must be non-newline separator
(if (eq viper-syntax-preference 'strict-vi)
- (viper-memq-char prev-char '(?\ ?\t))
- (viper-memq-char (char-syntax prev-char) '(?\ ?-))))
+ (memq prev-char '(?\ ?\t))
+ (memq (char-syntax prev-char) '(?\ ?-))))
(viper-backward-char-carefully)
(setq prev-char (viper-char-at-pos 'backward)))
@@ -2622,12 +2618,12 @@ On reaching beginning of line, stop and signal error."
;; skip again, but make sure we don't overshoot the limit
(if twice
- (while (and (not (viper-memq-char prev-char '(nil \n)))
+ (while (and (not (memq prev-char '(nil \n)))
(< lim (point))
;; must be non-newline separator
(if (eq viper-syntax-preference 'strict-vi)
- (viper-memq-char prev-char '(?\ ?\t))
- (viper-memq-char (char-syntax prev-char) '(?\ ?-))))
+ (memq prev-char '(?\ ?\t))
+ (memq (char-syntax prev-char) '(?\ ?-))))
(viper-backward-char-carefully)
(setq prev-char (viper-char-at-pos 'backward))))
@@ -2645,10 +2641,10 @@ On reaching beginning of line, stop and signal error."
(viper-forward-word-kernel val)
(if com
(progn
- (cond ((viper-char-equal com ?c)
+ (cond ((eq com ?c)
(viper-separator-skipback-special 'twice viper-com-point))
;; Yank words including the whitespace, but not newline
- ((viper-char-equal com ?y)
+ ((eq com ?y)
(viper-separator-skipback-special nil viper-com-point))
((viper-dotable-command-p com)
(viper-separator-skipback-special nil viper-com-point)))
@@ -2666,10 +2662,10 @@ On reaching beginning of line, stop and signal error."
(viper-skip-nonseparators 'forward)
(viper-skip-separators t))
(if com (progn
- (cond ((viper-char-equal com ?c)
+ (cond ((eq com ?c)
(viper-separator-skipback-special 'twice viper-com-point))
;; Yank words including the whitespace, but not newline
- ((viper-char-equal com ?y)
+ ((eq com ?y)
(viper-separator-skipback-special nil viper-com-point))
((viper-dotable-command-p com)
(viper-separator-skipback-special nil viper-com-point)))
@@ -4714,15 +4710,15 @@ Please, specify your level now: "))
(defun viper-submit-report ()
"Submit bug report on Viper."
(interactive)
- (defvar viper-color-display-p)
+ (defvar x-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)
- (viper-color-display-p (if (viper-window-display-p)
- (viper-color-display-p)
- 'non-x))
+ (x-display-color-p (if (viper-window-display-p)
+ (x-display-color-p)
+ 'non-x))
(viper-frame-parameters (frame-parameters (selected-frame)))
(viper-minibuffer-emacs-face (if (viper-has-face-support-p)
(facep
@@ -4780,7 +4776,7 @@ Please, specify your level now: "))
'viper-expert-level
'major-mode
'window-system
- 'viper-color-display-p
+ 'x-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 ef15779e1bf..85c8b87b9a1 100644
--- a/lisp/emulation/viper-ex.el
+++ b/lisp/emulation/viper-ex.el
@@ -25,7 +25,6 @@
;;; Code:
;; Compiler pacifier
-(defvar read-file-name-map)
(defvar viper-use-register)
(defvar viper-s-string)
(defvar viper-shift-width)
diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el
index fe3704841ac..368a5dc40a6 100644
--- a/lisp/emulation/viper-init.el
+++ b/lisp/emulation/viper-init.el
@@ -25,16 +25,12 @@
;;; Code:
;; compiler pacifier
-(defvar mark-even-if-inactive)
-(defvar quail-mode)
(defvar iso-accents-mode)
(defvar viper-current-state)
(defvar viper-version)
(defvar viper-expert-level)
(defvar current-input-method)
(defvar default-input-method)
-(defvar describe-current-input-method-function)
-(defvar bar-cursor)
(defvar cursor-type)
;; end pacifier
@@ -48,12 +44,6 @@
(define-obsolete-function-alias 'viper-device-type #'window-system "27.1")
-(defun viper-color-display-p ()
- (condition-case nil
- (display-color-p)
- (error nil)))
-
-;; in XEmacs: device-type is tty on tty and stream in batch.
(defun viper-window-display-p ()
(and window-system (not (memq window-system '(tty stream pc)))))
@@ -81,7 +71,7 @@ In all likelihood, you don't need to bother with this setting."
(defun viper-has-face-support-p ()
(cond ((viper-window-display-p))
(viper-force-faces)
- ((viper-color-display-p))
+ ((x-display-color-p))
(t (memq window-system '(pc)))))
diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el
index 02db39f1cb0..879d8edca6f 100644
--- a/lisp/emulation/viper-mous.el
+++ b/lisp/emulation/viper-mous.el
@@ -26,7 +26,6 @@
;; compiler pacifier
(defvar double-click-time)
-(defvar mouse-track-multi-click-time)
(defvar viper-search-start-marker)
(defvar viper-local-search-start-marker)
(defvar viper-search-history)
@@ -76,8 +75,8 @@ or a triple-click."
;; remembers prefix argument to pass along to commands invoked by second
;; click.
-;; This is needed because in Emacs (not XEmacs), assigning to prefix-arg
-;; causes Emacs to count the second click as if it was a single click
+;; This is needed because assigning to prefix-arg causes Emacs to
+;; count the second click as if it was a single click
(defvar viper-global-prefix-argument nil)
@@ -199,8 +198,7 @@ is ignored."
(setq result (buffer-substring word-beg (point))))
) ; if
- ;; XEmacs doesn't have set-text-properties, but there buffer-substring
- ;; doesn't return properties together with the string, so it's not needed.
+ ;; FIXME: Use `buffer-substring-no-properties' above instead?
(set-text-properties 0 (length result) nil result)
result))
diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el
index 0f6dceb13cf..0af54b37432 100644
--- a/lisp/emulation/viper-util.el
+++ b/lisp/emulation/viper-util.el
@@ -29,9 +29,6 @@
;; Compiler pacifier
(defvar viper-minibuffer-current-face)
-(defvar viper-minibuffer-insert-face)
-(defvar viper-minibuffer-vi-face)
-(defvar viper-minibuffer-emacs-face)
(defvar viper-replace-overlay-face)
(defvar viper-fast-keyseq-timeout)
(defvar ex-unix-type-shell)
@@ -64,22 +61,8 @@
(define-obsolete-function-alias 'viper-iconify
#'iconify-or-deiconify-frame "27.1")
-
-;; CHAR is supposed to be a char or an integer (positive or negative)
-;; LIST is a list of chars, nil, and negative numbers
-;; Check if CHAR is a member by trying to convert in characters, if necessary.
-;; Introduced for compatibility with XEmacs, where integers are not the same as
-;; chars.
-(defun viper-memq-char (char list)
- (cond ((and (integerp char) (>= char 0))
- (memq char list))
- ((memq char list))))
-
-;; Check if char-or-int and char are the same as characters
-(defun viper-char-equal (char-or-int char)
- (cond ((and (integerp char-or-int) (>= char-or-int 0))
- (= char-or-int char))
- ((eq char-or-int char))))
+(define-obsolete-function-alias 'viper-memq-char #'memq "29.1")
+(define-obsolete-function-alias 'viper-char-equal #'eq "29.1")
;; Like =, but accommodates null and also is t for eq-objects
(defun viper= (char char1)
@@ -88,8 +71,7 @@
(= char char1))
(t nil)))
-(defsubst viper-color-display-p ()
- (x-display-color-p))
+(define-obsolete-function-alias 'viper-color-display-p #'x-display-color-p "29.1")
(defun viper-get-cursor-color (&optional _frame)
(cdr (assoc 'cursor-color (frame-parameters))))
@@ -97,9 +79,6 @@
(defmacro viper-frame-value (variable)
"Return the value of VARIABLE local to the current frame, if there is one.
Otherwise return the normal value."
- ;; Frame-local variables are obsolete from Emacs 22.2 onwards,
- ;; so we do it by hand instead.
- ;; Buffer-local values take precedence over frame-local ones.
`(if (local-variable-p ',variable)
,variable
;; Distinguish between no frame parameter and a frame parameter
@@ -110,7 +89,7 @@ Otherwise return the normal value."
;; cursor colors
(defun viper-change-cursor-color (new-color &optional frame)
- (if (and (viper-window-display-p) (viper-color-display-p)
+ (if (and (viper-window-display-p) (x-display-color-p)
(stringp new-color) (x-color-defined-p new-color)
(not (string= new-color (viper-get-cursor-color))))
(modify-frame-parameters
@@ -142,7 +121,7 @@ Otherwise return the normal value."
;; By default, saves current frame cursor color before changing viper state
(defun viper-save-cursor-color (before-which-mode)
- (if (and (viper-window-display-p) (viper-color-display-p))
+ (if (and (viper-window-display-p) (x-display-color-p))
(let ((color (viper-get-cursor-color)))
(if (and (stringp color) (x-color-defined-p color)
;; there is something fishy in that the color is not saved if
@@ -1183,25 +1162,23 @@ This option is appropriate if you like Emacs-style words."
(looking-at (concat "[" viper-strict-ALPHA-chars addl-chars "]"))
(or
;; or one of the additional chars being asked to include
- (viper-memq-char char (viper-string-to-list addl-chars))
+ (memq char (viper-string-to-list addl-chars))
(and
;; not one of the excluded word chars (note:
;; viper-non-word-characters is a list)
- (not (viper-memq-char char viper-non-word-characters))
+ (not (memq char viper-non-word-characters))
;; char of the Viper-word syntax class
- (viper-memq-char (char-syntax char)
- (viper-string-to-list viper-ALPHA-char-class))))))
- ))
+ (memq (char-syntax char)
+ (viper-string-to-list viper-ALPHA-char-class))))))))
(defun viper-looking-at-separator ()
(let ((char (char-after (point))))
(if char
(if (eq viper-syntax-preference 'strict-vi)
- (viper-memq-char char (viper-string-to-list viper-strict-SEP-chars))
+ (memq char (viper-string-to-list viper-strict-SEP-chars))
(or (eq char ?\n) ; RET is always a separator in Vi
- (viper-memq-char (char-syntax char)
- (viper-string-to-list viper-SEP-char-class)))))
- ))
+ (memq (char-syntax char)
+ (viper-string-to-list viper-SEP-char-class)))))))
(defsubst viper-looking-at-alphasep (&optional addl-chars)
(or (viper-looking-at-separator) (viper-looking-at-alpha addl-chars)))
@@ -1327,8 +1304,7 @@ This option is appropriate if you like Emacs-style words."
;; of the excluded characters
(if (and (eq syntax-of-char-looked-at ?w)
(not negated-syntax))
- (not (viper-memq-char
- char-looked-at viper-non-word-characters))
+ (not (memq char-looked-at viper-non-word-characters))
t))
(funcall skip-syntax-func 1)
0)
diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el
index e9c0fb5e24b..1ee53651264 100644
--- a/lisp/emulation/viper.el
+++ b/lisp/emulation/viper.el
@@ -304,7 +304,6 @@
;; compiler pacifier
(defvar mark-even-if-inactive)
-(defvar quail-mode)
(defvar viper-expert-level)
(defvar viper-mode-string)
(defvar viper-major-mode-modifier-list)
diff --git a/lisp/epa-hook.el b/lisp/epa-hook.el
index aa196851d4d..5b250af6d70 100644
--- a/lisp/epa-hook.el
+++ b/lisp/epa-hook.el
@@ -56,15 +56,15 @@ through Custom does that automatically."
May either be a string or a list of strings.")
(put 'epa-file-encrypt-to 'safe-local-variable
- #'(lambda (val)
- (or (stringp val)
- (and (listp val)
- (catch 'safe
- (mapc (lambda (elt)
- (unless (stringp elt)
- (throw 'safe nil)))
- val)
- t)))))
+ (lambda (val)
+ (or (stringp val)
+ (and (listp val)
+ (catch 'safe
+ (mapc (lambda (elt)
+ (unless (stringp elt)
+ (throw 'safe nil)))
+ val)
+ t)))))
(put 'epa-file-encrypt-to 'permanent-local t)
diff --git a/lisp/epa-ks.el b/lisp/epa-ks.el
index 35caa1a93c5..186b0ac9d1c 100644
--- a/lisp/epa-ks.el
+++ b/lisp/epa-ks.el
@@ -210,7 +210,8 @@ KEYS is a list of `epa-ks-key' structures, as parsed by
(with-current-buffer buf
(setq tabulated-list-entries entries)
(tabulated-list-print t t))
- (message "Press `f' to mark a key, `x' to fetch all marked keys."))))
+ (message (substitute-command-keys
+ "Press \\`f' to mark a key, \\`x' to fetch all marked keys.")))))
(defun epa-ks--restart-search ()
(when epa-ks-last-query
@@ -294,12 +295,12 @@ enough, since keyservers have strict timeout settings."
:created
(and (match-string 4)
(not (string-empty-p (match-string 4)))
- (seconds-to-time
+ (time-convert
(string-to-number (match-string 4))))
:expires
(and (match-string 5)
(not (string-empty-p (match-string 5)))
- (seconds-to-time
+ (time-convert
(string-to-number (match-string 5))))
:flags
(mapcar (lambda (flag)
@@ -318,15 +319,11 @@ enough, since keyservers have strict timeout settings."
:created
(and (match-string 2)
(not (string-empty-p (match-string 2)))
- (decode-time (seconds-to-time
- (string-to-number
- (match-string 2)))))
+ (decode-time (string-to-number (match-string 2))))
:expires
(and (match-string 3)
(not (string-empty-p (match-string 3)))
- (decode-time (seconds-to-time
- (string-to-number
- (match-string 3)))))
+ (decode-time (string-to-number (match-string 3))))
:flags
(mapcar (lambda (flag)
(cdr (assq flag '((?r revoked)
diff --git a/lisp/epa.el b/lisp/epa.el
index 57d355cb3e0..93c85bfd37c 100644
--- a/lisp/epa.el
+++ b/lisp/epa.el
@@ -607,7 +607,11 @@ If SECRET is non-nil, list secret keys instead of public keys."
(_ "Error while executing \"%s\":\n\n"))
(epg-context-program context))
"\n\n"
- (epg-context-error-output context)))
+ (epg-context-error-output context)
+ (if (string-search "Unexpected error"
+ (epg-context-error-output context))
+ "\n(File possibly not an encrypted file, but is perhaps a key ring file?)\n"
+ "")))
(epa-info-mode)
(goto-char (point-min)))
(display-buffer buffer)))))
@@ -648,7 +652,7 @@ If SECRET is non-nil, list secret keys instead of public keys."
(setq input (file-name-sans-extension (expand-file-name input)))
(expand-file-name
(read-file-name
- (concat "To file (default " (file-name-nondirectory input) ") ")
+ (format-prompt "To file" (file-name-nondirectory input))
(file-name-directory input)
input)))
@@ -1236,9 +1240,7 @@ If no one is selected, symmetric encryption will be performed. ")
(list keys
(expand-file-name
(read-file-name
- (concat "To file (default "
- (file-name-nondirectory default-name)
- ") ")
+ (format-prompt "To file" (file-name-nondirectory default-name))
(file-name-directory default-name)
default-name)))))
(let ((context (epg-make-context epa-protocol)))
diff --git a/lisp/epg.el b/lisp/epg.el
index ea7aa869a0f..3354eb2c1ed 100644
--- a/lisp/epg.el
+++ b/lisp/epg.el
@@ -334,6 +334,7 @@ callback data (if any)."
(cl-defstruct (epg-key
(:constructor nil)
+ (:copier epg--copy-key)
(:constructor epg-make-key (owner-trust))
(:predicate nil))
(owner-trust nil :read-only t)
@@ -1389,7 +1390,7 @@ NAME is either a string or a list of strings."
(if (seq-find (lambda (user)
(eq (epg-user-id-validity user) 'revoked))
(epg-key-user-id-list key))
- (let ((copy (copy-epg-key key)))
+ (let ((copy (epg--copy-key key)))
(setf (epg-key-user-id-list copy)
(seq-remove (lambda (user)
(eq (epg-user-id-validity user) 'revoked))
diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el
index 140755fab51..69f63dfbc44 100644
--- a/lisp/erc/erc-backend.el
+++ b/lisp/erc/erc-backend.el
@@ -199,6 +199,11 @@ active, use the `erc-server-process-alive' function instead.")
(defvar-local erc-server-reconnecting nil
"Non-nil if the user requests an explicit reconnect, and the
current IRC process is still alive.")
+(make-obsolete-variable 'erc-server-reconnecting
+ "see `erc--server-reconnecting'" "29.1")
+
+(defvar-local erc--server-reconnecting nil
+ "Non-nil when reconnecting.")
(defvar-local erc-server-timed-out nil
"Non-nil if the IRC server failed to respond to a ping.")
@@ -533,7 +538,8 @@ TLS (see `erc-session-client-certificate' for more details)."
(with-current-buffer buffer
(setq erc-server-process process)
(setq erc-server-quitting nil)
- (setq erc-server-reconnecting nil)
+ (setq erc-server-reconnecting nil
+ erc--server-reconnecting nil)
(setq erc-server-timed-out nil)
(setq erc-server-banned nil)
(setq erc-server-error-occurred nil)
@@ -616,36 +622,42 @@ Make sure you are in an ERC buffer when running this."
(erc-log-irc-protocol line nil)
(erc-parse-server-response process line)))))))
-(define-inline erc-server-reconnect-p (event)
+(defun erc--server-reconnect-p (event)
+ "Return non-nil when ERC should attempt to reconnect.
+EVENT is the message received from the closed connection process."
+ (and erc-server-auto-reconnect
+ (not erc-server-banned)
+ ;; make sure we don't infinitely try to reconnect, unless the
+ ;; user wants that
+ (or (eq erc-server-reconnect-attempts t)
+ (and (integerp erc-server-reconnect-attempts)
+ (< erc-server-reconnect-count
+ erc-server-reconnect-attempts)))
+ (or erc-server-timed-out
+ (not (string-match "^deleted" event)))
+ ;; open-network-stream-nowait error for connection refused
+ (if (string-match "^failed with code 111" event) 'nonblocking t)))
+
+(defun erc-server-reconnect-p (event)
"Return non-nil if ERC should attempt to reconnect automatically.
EVENT is the message received from the closed connection process."
- (inline-letevals (event)
- (inline-quote
- (or erc-server-reconnecting
- (and erc-server-auto-reconnect
- (not erc-server-banned)
- ;; make sure we don't infinitely try to reconnect, unless the
- ;; user wants that
- (or (eq erc-server-reconnect-attempts t)
- (and (integerp erc-server-reconnect-attempts)
- (< erc-server-reconnect-count
- erc-server-reconnect-attempts)))
- (or erc-server-timed-out
- (not (string-match "^deleted" ,event)))
- ;; open-network-stream-nowait error for connection refused
- (if (string-match "^failed with code 111" ,event) 'nonblocking t))))))
+ (declare (obsolete "see `erc--server-reconnect-p'" "29.1"))
+ (or (with-suppressed-warnings ((obsolete erc-server-reconnecting))
+ erc-server-reconnecting)
+ (erc--server-reconnect-p event)))
(defun erc-process-sentinel-2 (event buffer)
"Called when `erc-process-sentinel-1' has detected an unexpected disconnect."
(if (not (buffer-live-p buffer))
(erc-update-mode-line)
(with-current-buffer buffer
- (let ((reconnect-p (erc-server-reconnect-p event)) message delay)
+ (let ((reconnect-p (erc--server-reconnect-p event)) message delay)
(setq message (if reconnect-p 'disconnected 'disconnected-noreconnect))
(erc-display-message nil 'error (current-buffer) message)
(if (not reconnect-p)
;; terminate, do not reconnect
(progn
+ (setq erc--server-reconnecting nil)
(erc-display-message nil 'error (current-buffer)
'terminated ?e event)
;; Update mode line indicators
@@ -654,7 +666,8 @@ EVENT is the message received from the closed connection process."
;; reconnect
(condition-case nil
(progn
- (setq erc-server-reconnecting nil
+ (setq erc-server-reconnecting nil
+ erc--server-reconnecting t
erc-server-reconnect-count (1+ erc-server-reconnect-count))
(setq delay erc-server-reconnect-timeout)
(run-at-time delay nil
@@ -1169,7 +1182,8 @@ 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)]
- &optional sexp sexp def-body)))
+ &optional sexp sexp def-body))
+ (indent defun))
(if (numberp name) (setq name (intern (format "%03i" name))))
(setq aliases (mapcar (lambda (a)
(if (numberp a)
diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el
index 6b1da2f9054..9bbc1f6a0d1 100644
--- a/lisp/erc/erc-compat.el
+++ b/lisp/erc/erc-compat.el
@@ -27,8 +27,6 @@
;;; Code:
-(require 'format-spec)
-
;;;###autoload(autoload 'erc-define-minor-mode "erc-compat")
(define-obsolete-function-alias 'erc-define-minor-mode
#'define-minor-mode "28.1")
diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el
index db278a1275c..f27425ac8a1 100644
--- a/lisp/erc/erc-dcc.el
+++ b/lisp/erc/erc-dcc.el
@@ -1,7 +1,6 @@
;;; erc-dcc.el --- CTCP DCC module for ERC -*- lexical-binding: t; -*-
-;; Copyright (C) 1993-1995, 1998, 2002-2004, 2006-2021 Free Software
-;; Foundation, Inc.
+;; Copyright (C) 1993-2021 Free Software Foundation, Inc.
;; Author: Ben A. Mesander <ben@gnu.ai.mit.edu>
;; Noah Friedman <friedman@prep.ai.mit.edu>
@@ -183,9 +182,7 @@ compared with `erc-nick-equal-p' which is IRC case-insensitive."
(let ((prop (car prem))
(val (cadr prem)))
(setq prem (cddr prem)
- ;; plist-member is a predicate in xemacs
- test (and (plist-member elt prop)
- (plist-get elt prop)))
+ test (cadr (plist-member elt prop)))
;; if the property exists and is equal, we continue, else, try the
;; next element of the list
(or (and (eq prop :nick) (if (>= emacs-major-version 28)
diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el
index fc9a8d39ef4..683ac2d37c5 100644
--- a/lisp/erc/erc-goodies.el
+++ b/lisp/erc/erc-goodies.el
@@ -137,7 +137,7 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'."
(goto-char (point-max))))
(defun erc-move-to-prompt-setup ()
- "Initialize the move-to-prompt module for XEmacs."
+ "Initialize the move-to-prompt module."
(add-hook 'pre-command-hook #'erc-move-to-prompt nil t))
;;; Keep place in unvisited channels
diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el
index dcf6db7407a..522bc805f8d 100644
--- a/lisp/erc/erc-imenu.el
+++ b/lisp/erc/erc-imenu.el
@@ -1,7 +1,6 @@
;;; erc-imenu.el --- Imenu support for ERC -*- lexical-binding: t; -*-
-;; Copyright (C) 2001-2002, 2004, 2006-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Maintainer: Amin Bandali <bandali@gnu.org>
diff --git a/lisp/erc/erc-replace.el b/lisp/erc/erc-replace.el
index 90c0ee6f8a4..b2e9047ce77 100644
--- a/lisp/erc/erc-replace.el
+++ b/lisp/erc/erc-replace.el
@@ -1,7 +1,6 @@
;;; erc-replace.el --- wash and massage messages inserted into the buffer -*- lexical-binding: t; -*-
-;; Copyright (C) 2001-2002, 2004, 2006-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Author: Andreas Fuchs <asf@void.at>
;; Maintainer: Amin Bandali <bandali@gnu.org>
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 885d311cf38..df6c3c09d90 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -12,7 +12,7 @@
;; David Edmondson (dme@dme.org)
;; Michael Olson (mwolson@gnu.org)
;; Kelvin White (kwhite@gnu.org)
-;; Version: 5.4
+;; Version: 5.4.1
;; Package-Requires: ((emacs "27.1"))
;; Keywords: IRC, chat, client, Internet
;; URL: https://www.gnu.org/software/emacs/erc.html
@@ -69,7 +69,7 @@
(require 'iso8601)
(eval-when-compile (require 'subr-x))
-(defconst erc-version "5.4"
+(defconst erc-version "5.4.1"
"This version of ERC.")
(defvar erc-official-location
@@ -83,7 +83,8 @@
'customize-package-emacs-version-alist
'(ERC ("5.2" . "22.1")
("5.3" . "23.1")
- ("5.4" . "28.1")))
+ ("5.4" . "28.1")
+ ("5.4.1" . "29.1")))
(defgroup erc nil
"Emacs Internet Relay Chat client."
@@ -871,8 +872,8 @@ See `erc-server-flood-margin' for other flood-related parameters.")
;; Script parameters
(defcustom erc-startup-file-list
- (list (concat user-emacs-directory ".ercrc.el")
- (concat user-emacs-directory ".ercrc")
+ (list (locate-user-emacs-file ".ercrc.el")
+ (locate-user-emacs-file ".ercrc")
"~/.ercrc.el" "~/.ercrc" ".ercrc.el" ".ercrc")
"List of files to try for a startup script.
The first existent and readable one will get executed.
@@ -1291,7 +1292,7 @@ Example:
#\\='erc-replace-insert))
((remove-hook \\='erc-insert-modify-hook
#\\='erc-replace-insert)))"
- (declare (doc-string 3))
+ (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))))
@@ -1478,6 +1479,7 @@ Defaults to the server buffer."
(define-derived-mode erc-mode fundamental-mode "ERC"
"Major mode for Emacs IRC."
+ :interactive nil
(setq local-abbrev-table erc-mode-abbrev-table)
(setq-local next-line-add-newlines nil)
(setq line-move-ignore-invisible t)
@@ -2403,7 +2405,8 @@ If ARG is non-nil, show the *erc-protocol* buffer."
(concat "This buffer displays all IRC protocol "
"traffic exchanged with servers."))
(erc-make-notice "Kill it to disable logging.")
- (erc-make-notice "Press `t' to toggle."))))
+ (erc-make-notice (substitute-command-keys
+ "Press \\`t' to toggle.")))))
(insert (string-join msg "\r\n")))
(use-local-map (make-sparse-keymap))
(local-set-key (kbd "t") 'erc-toggle-debug-irc-protocol))
@@ -2816,20 +2819,17 @@ 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)
+(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).")
(defun erc-send-input-line (target line &optional force)
- "Send LINE to TARGET.
-
-See also `erc-server-send'."
- (setq line (format "PRIVMSG %s :%s"
- target
- ;; If the line is empty, we still want to
- ;; send it - i.e. an empty pasted line.
- (if (string= line "\n")
- " \n"
- line)))
- (erc-server-send line force target))
+ "Send LINE to TARGET."
+ (erc-message "PRIVMSG" (concat target " " line) force))
(defun erc-get-arglist (fun)
"Return the argument list of a function without the parens."
@@ -2967,7 +2967,7 @@ Commands for which no erc-cmd-xxx exists, are tunneled through
this function. LINE is sent to the server verbatim, and
therefore has to contain the command itself as well."
(erc-log (format "cmd: DEFAULT: %s" line))
- (erc-server-send (substring line 1))
+ (erc-server-send (string-trim-right (substring line 1) "[\r\n]"))
t)
(defvar erc--read-time-period-history nil)
@@ -3608,11 +3608,13 @@ other people should be displayed."
(defun erc-cmd-QUERY (&optional user)
"Open a query with USER.
-The type of query window/frame/etc will depend on the value of
-`erc-query-display'.
-
-If USER is omitted, close the current query buffer if one exists
-- except this is broken now ;-)"
+How the query is displayed (in a new window, frame, etc.) depends
+on the value of `erc-query-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 ;-)"
+ ;; Does it make sense to have that functionality? What's wrong with
+ ;; `kill-buffer'? If it makes sense, re-add it. -- SK @ 2021-11-11
(interactive
(list (read-string "Start a query with: ")))
(let ((session-buffer (erc-server-buffer))
@@ -3754,13 +3756,17 @@ the message given by REASON."
(setq buffer (current-buffer)))
(with-current-buffer buffer
(setq erc-server-quitting nil)
- (setq erc-server-reconnecting t)
+ (with-suppressed-warnings ((obsolete erc-server-reconnecting))
+ (setq erc-server-reconnecting t))
+ (setq erc--server-reconnecting t)
(setq erc-server-reconnect-count 0)
(setq process (get-buffer-process (erc-server-buffer)))
(if process
(delete-process process)
(erc-server-reconnect))
- (setq erc-server-reconnecting nil)))
+ (with-suppressed-warnings ((obsolete erc-server-reconnecting))
+ (setq erc-server-reconnecting nil))
+ (setq erc--server-reconnecting nil)))
t)
(put 'erc-cmd-RECONNECT 'process-not-needed t)
diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el
index 8e6506c301c..cae5236d894 100644
--- a/lisp/eshell/esh-mode.el
+++ b/lisp/eshell/esh-mode.el
@@ -308,7 +308,7 @@ and the hook `eshell-exit-hook'."
(make-local-variable 'eshell-command-running-string)
(let ((fmt (copy-sequence mode-line-format)))
(setq-local mode-line-format fmt))
- (let ((mode-line-elt (memq 'mode-line-modified mode-line-format)))
+ (let ((mode-line-elt (cdr (memq 'mode-line-front-space mode-line-format))))
(if mode-line-elt
(setcar mode-line-elt 'eshell-command-running-string))))
@@ -616,6 +616,14 @@ newline."
(and eshell-send-direct-to-subprocesses
proc-running-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
+ ;; insertion will delete the region, moving the process mark
+ ;; back to its original position.
+ (let ((text (buffer-substring eshell-last-output-end (point)))
+ (inhibit-read-only t))
+ (delete-region eshell-last-output-end (point))
+ (insert text))
(if proc-running-p
(progn
(eshell-update-markers eshell-last-output-end)
@@ -939,7 +947,14 @@ This function could be in the list `eshell-output-filter-functions'."
(beginning-of-line)
(if (re-search-forward eshell-password-prompt-regexp
eshell-last-output-end t)
- (eshell-send-invisible))))))
+ ;; Use `run-at-time' in order not to pause execution of
+ ;; the process filter with a minibuffer
+ (run-at-time
+ 0 nil
+ (lambda (current-buf)
+ (with-current-buffer current-buf
+ (eshell-send-invisible)))
+ (current-buffer)))))))
(custom-add-option 'eshell-output-filter-functions
'eshell-watch-for-password-prompt)
diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el
index 72de6b13e2e..0eef45e0efb 100644
--- a/lisp/eshell/esh-util.el
+++ b/lisp/eshell/esh-util.el
@@ -63,11 +63,11 @@ has no effect."
Setting this to nil is offered as an aid to debugging only."
:type 'boolean)
-(defcustom eshell-private-file-modes 384 ; umask 177
+(defcustom eshell-private-file-modes #o600 ; umask 177
"The file-modes value to use for creating \"private\" files."
:type 'integer)
-(defcustom eshell-private-directory-modes 448 ; umask 077
+(defcustom eshell-private-directory-modes #o700 ; umask 077
"The file-modes value to use for creating \"private\" directories."
:type 'integer)
diff --git a/lisp/ezimage.el b/lisp/ezimage.el
index 13f5c039a7f..57033cde058 100644
--- a/lisp/ezimage.el
+++ b/lisp/ezimage.el
@@ -45,6 +45,7 @@
(defmacro defezimage (variable imagespec docstring)
"Define VARIABLE as an image if `defimage' is not available.
IMAGESPEC is the image data, and DOCSTRING is documentation for the image."
+ (declare (indent defun))
`(progn
(defimage ,variable ,imagespec ,docstring)
(put (quote ,variable) 'ezimage t)))
diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 7417bb12030..fe458b8c07b 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -551,8 +551,8 @@ If the optional argument CALLBACK is non-nil, it should be a
function to call each time the user types RET or clicks on a
color. The function should accept a single argument, the color name."
(interactive)
- (when (and (null list) (> (display-color-cells) 0))
- (setq list (list-colors-duplicates (defined-colors)))
+ (when (> (display-color-cells) 0)
+ (setq list (list-colors-duplicates (or list (defined-colors))))
(when list-colors-sort
;; Schwartzian transform with `(color key1 key2 key3 ...)'.
(setq list (mapcar
diff --git a/lisp/faces.el b/lisp/faces.el
index 327b0ac01ec..97579877efa 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -88,9 +88,9 @@ a font height that isn't optimal."
:tag "Font selection order"
:type '(list symbol symbol symbol symbol)
:group 'font-selection
- :set #'(lambda (symbol value)
- (set-default symbol value)
- (internal-set-font-selection-order value)))
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (internal-set-font-selection-order value)))
;; In the absence of Fontconfig support, Monospace and Sans Serif are
@@ -140,9 +140,9 @@ ALTERNATIVE2 etc."
:tag "Alternative font families to try"
:type '(repeat (repeat string))
:group 'font-selection
- :set #'(lambda (symbol value)
- (set-default symbol value)
- (internal-set-alternative-font-family-alist value)))
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (internal-set-alternative-font-family-alist value)))
;; This is defined originally in xfaces.c.
@@ -167,9 +167,9 @@ REGISTRY, ALTERNATIVE1, ALTERNATIVE2, and etc."
:type '(repeat (repeat string))
:version "21.1"
:group 'font-selection
- :set #'(lambda (symbol value)
- (set-default symbol value)
- (internal-set-alternative-font-registry-alist value)))
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (internal-set-alternative-font-registry-alist value)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -702,9 +702,10 @@ for it to be relative to).
`:weight'
-VALUE specifies the weight of the font to use. It must be one of the
-symbols `ultra-bold', `extra-bold', `bold', `semi-bold', `normal',
-`semi-light', `light', `extra-light', `ultra-light'.
+VALUE specifies the weight of the font to use. It must be one of
+the symbols `ultra-heavy', `heavy', `ultra-bold', `extra-bold',
+`bold', `semi-bold', `medium', `normal', `book', `semi-light',
+`light', `extra-light', `ultra-light', or `thin'.
`:slant'
@@ -861,8 +862,8 @@ is specified, `:italic' is ignored."
(defun make-face-bold (face &optional frame _noerror)
"Make the font of FACE be bold, if possible.
FRAME nil or not specified means change face on all frames.
-Argument NOERROR is ignored and retained for compatibility.
Use `set-face-attribute' for finer control of the font weight."
+ (declare (advertised-calling-convention (face &optional frame) "29.1"))
(interactive (list (read-face-name "Make which face bold"
(face-at-point t))))
(set-face-attribute face frame :weight 'bold))
@@ -870,8 +871,8 @@ Use `set-face-attribute' for finer control of the font weight."
(defun make-face-unbold (face &optional frame _noerror)
"Make the font of FACE be non-bold, if possible.
-FRAME nil or not specified means change face on all frames.
-Argument NOERROR is ignored and retained for compatibility."
+FRAME nil or not specified means change face on all frames."
+ (declare (advertised-calling-convention (face &optional frame) "29.1"))
(interactive (list (read-face-name "Make which face non-bold"
(face-at-point t))))
(set-face-attribute face frame :weight 'normal))
@@ -880,8 +881,8 @@ Argument NOERROR is ignored and retained for compatibility."
(defun make-face-italic (face &optional frame _noerror)
"Make the font of FACE be italic, if possible.
FRAME nil or not specified means change face on all frames.
-Argument NOERROR is ignored and retained for compatibility.
Use `set-face-attribute' for finer control of the font slant."
+ (declare (advertised-calling-convention (face &optional frame) "29.1"))
(interactive (list (read-face-name "Make which face italic"
(face-at-point t))))
(set-face-attribute face frame :slant 'italic))
@@ -889,8 +890,8 @@ Use `set-face-attribute' for finer control of the font slant."
(defun make-face-unitalic (face &optional frame _noerror)
"Make the font of FACE be non-italic, if possible.
-FRAME nil or not specified means change face on all frames.
-Argument NOERROR is ignored and retained for compatibility."
+FRAME nil or not specified means change face on all frames."
+ (declare (advertised-calling-convention (face &optional frame) "29.1"))
(interactive (list (read-face-name "Make which face non-italic"
(face-at-point t))))
(set-face-attribute face frame :slant 'normal))
@@ -899,8 +900,8 @@ Argument NOERROR is ignored and retained for compatibility."
(defun make-face-bold-italic (face &optional frame _noerror)
"Make the font of FACE be bold and italic, if possible.
FRAME nil or not specified means change face on all frames.
-Argument NOERROR is ignored and retained for compatibility.
Use `set-face-attribute' for finer control of font weight and slant."
+ (declare (advertised-calling-convention (face &optional frame) "29.1"))
(interactive (list (read-face-name "Make which face bold-italic"
(face-at-point t))))
(set-face-attribute face frame :weight 'bold :slant 'italic))
@@ -1100,7 +1101,7 @@ returned. Otherwise, DEFAULT is returned verbatim."
;; prompt. If so, remove it.
(setq prompt (replace-regexp-in-string ": ?\\'" "" prompt))
(let ((prompt (if default
- (format-message "%s (default `%s'): " prompt default)
+ (format-prompt prompt default)
(format "%s: " prompt)))
aliasfaces nonaliasfaces faces)
;; Build up the completion tables.
@@ -1146,42 +1147,42 @@ an integer value."
(:foundry
(list nil))
(:width
- (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
+ (mapcar (lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
font-width-table))
(:weight
- (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
+ (mapcar (lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
font-weight-table))
(:slant
- (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
+ (mapcar (lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
font-slant-table))
((or :inverse-video :extend)
- (mapcar #'(lambda (x) (cons (symbol-name x) x))
+ (mapcar (lambda (x) (cons (symbol-name x) x))
(internal-lisp-face-attribute-values attribute)))
((or :underline :overline :strike-through :box)
(if (window-system frame)
- (nconc (mapcar #'(lambda (x) (cons (symbol-name x) x))
+ (nconc (mapcar (lambda (x) (cons (symbol-name x) x))
(internal-lisp-face-attribute-values attribute))
- (mapcar #'(lambda (c) (cons c c))
+ (mapcar (lambda (c) (cons c c))
(defined-colors frame)))
- (mapcar #'(lambda (x) (cons (symbol-name x) x))
+ (mapcar (lambda (x) (cons (symbol-name x) x))
(internal-lisp-face-attribute-values attribute))))
((or :foreground :background)
- (mapcar #'(lambda (c) (cons c c))
+ (mapcar (lambda (c) (cons c c))
(defined-colors frame)))
(:height
'integerp)
(:stipple
- (and (memq (window-system frame) '(x ns)) ; No stipple on w32
+ (and (memq (window-system frame) '(x ns pgtk)) ; No stipple on w32 or haiku
(mapcar #'list
(apply #'nconc
(mapcar (lambda (dir)
(and (file-readable-p dir)
(file-directory-p dir)
- (directory-files dir)))
+ (directory-files dir 'full)))
x-bitmap-file-path)))))
(:inherit
(cons '("none" . nil)
- (mapcar #'(lambda (c) (cons (symbol-name c) c))
+ (mapcar (lambda (c) (cons (symbol-name c) c))
(face-list))))
(_
(error "Internal error")))))
@@ -1515,7 +1516,7 @@ If FRAME is nil, the current FRAME is used."
match (cond ((eq req 'type)
(or (memq (window-system frame) options)
(and (memq 'graphic options)
- (memq (window-system frame) '(x w32 ns)))
+ (memq (window-system frame) '(x w32 ns pgtk)))
;; FIXME: This should be revisited to use
;; display-graphic-p, provided that the
;; color selection depends on the number
@@ -2285,19 +2286,19 @@ If you set `term-file-prefix' to nil, this function does nothing."
(let* (term-init-func)
;; First, load the terminal initialization file, if it is
;; available and it hasn't been loaded already.
- (tty-find-type #'(lambda (type)
- (let ((file (locate-library (concat term-file-prefix type))))
- (and file
- (or (assoc file load-history)
- (load (replace-regexp-in-string
- "\\.el\\(\\.gz\\)?\\'" ""
- file)
- t t)))))
- type)
+ (tty-find-type (lambda (type)
+ (let ((file (locate-library (concat term-file-prefix type))))
+ (and file
+ (or (assoc file load-history)
+ (load (replace-regexp-in-string
+ "\\.el\\(\\.gz\\)?\\'" ""
+ file)
+ t t)))))
+ type)
;; Next, try to find a matching initialization function, and call it.
- (tty-find-type #'(lambda (type)
- (fboundp (setq term-init-func
- (intern (concat "terminal-init-" type)))))
+ (tty-find-type (lambda (type)
+ (fboundp (setq term-init-func
+ (intern (concat "terminal-init-" type)))))
type)
(when (fboundp term-init-func)
(funcall term-init-func))
@@ -2380,6 +2381,15 @@ If you set `term-file-prefix' to nil, this function does nothing."
"The basic variable-pitch face."
:group 'basic-faces)
+(defface variable-pitch-text
+ '((t :inherit variable-pitch
+ :height 1.1))
+ "The proportional face used for longer texts.
+This is like the `variable-pitch' face, but is slightly bigger by
+default."
+ :version "29.1"
+ :group 'basic-faces)
+
(defface shadow
'((((class color grayscale) (min-colors 88) (background light))
:foreground "grey50")
@@ -2613,14 +2623,23 @@ non-nil."
:background "grey75" :foreground "black")
(t
:inverse-video t))
- "Basic mode line face for selected window."
+ "Face for the mode lines (for the selected window) as well as header lines.
+See `mode-line-display' for the face used on mode lines."
:version "21.1"
:group 'mode-line-faces
:group 'basic-faces)
+(defface mode-line-active
+ '((t :inherit (mode-line variable-pitch)))
+ "Face for the selected mode line.
+This inherits from the `mode-line' face."
+ :version "29.1"
+ :group 'mode-line-faces
+ :group 'basic-faces)
+
(defface mode-line-inactive
'((default
- :inherit mode-line)
+ :inherit (mode-line variable-pitch))
(((class color) (min-colors 88) (background light))
:weight light
:box (:line-width -1 :color "grey75" :style nil)
@@ -2821,7 +2840,7 @@ Note: Other faces cannot inherit from the cursor face."
'((default
:box (:line-width 1 :style released-button)
:foreground "black")
- (((type x w32 ns) (class color))
+ (((type x w32 ns haiku pgtk) (class color))
:background "grey75")
(((type x) (class mono))
:background "grey"))
@@ -2877,14 +2896,22 @@ Note: Other faces cannot inherit from the cursor face."
:background "grey96" :foreground "DarkBlue"
;; We use negative thickness of the horizontal box border line to
;; avoid enlarging the height of the echo-area display, which
- ;; would then move the mode line a few pixels up.
- :box (:line-width (1 . -1) :color "grey80"))
+ ;; would then move the mode line a few pixels up. We use
+ ;; negative thickness for the vertical border line to avoid
+ ;; making the characters wider, which then would cause unpleasant
+ ;; horizontal shifts of the cursor during C-n/C-p movement
+ ;; through a line with this face.
+ :box (:line-width (-1 . -1) :color "grey80")
+ :inherit fixed-pitch)
(((class color) (min-colors 88) (background dark))
:background "grey19" :foreground "LightBlue"
- :box (:line-width (1 . -1) :color "grey35"))
- (((class color grayscale) (background light)) :background "grey90")
- (((class color grayscale) (background dark)) :background "grey25")
- (t :background "grey90"))
+ :box (:line-width (-1 . -1) :color "grey35")
+ :inherit fixed-pitch)
+ (((class color grayscale) (background light)) :background "grey90"
+ :inherit fixed-pitch)
+ (((class color grayscale) (background dark)) :background "grey25"
+ :inherit fixed-pitch)
+ (t :background "grey90" :inherit fixed-pitch))
"Face for keybindings in *Help* buffers.
This face is added by `substitute-command-keys', which see.
diff --git a/lisp/ffap.el b/lisp/ffap.el
index 964daaaa15d..5d3cee591be 100644
--- a/lisp/ffap.el
+++ b/lisp/ffap.el
@@ -651,7 +651,7 @@ also is substituted for the first empty-string component, if there is one.
Uses `path-separator' to separate the path into substrings."
;; We cannot use parse-colon-path (files.el), since it kills
;; "//" entries using file-name-as-directory.
- ;; Similar: dired-split, TeX-split-string, and RHOGEE's psg-list-env
+ ;; Similar: TeX-split-string, and RHOGEE's psg-list-env
;; in ff-paths and bib-cite. The EMPTY arg may help mimic kpathsea.
(if (or empty (getenv env)) ; should return something
(let ((start 0) match dir ret)
diff --git a/lisp/filenotify.el b/lisp/filenotify.el
index 271fa270836..26954cc73f2 100644
--- a/lisp/filenotify.el
+++ b/lisp/filenotify.el
@@ -480,6 +480,14 @@ DESCRIPTOR should be an object returned by `file-notify-add-watch'."
;; Modify `file-notify-descriptors' and send a `stopped' event.
(file-notify--rm-descriptor descriptor))))
+(defun file-notify-rm-all-watches ()
+ "Remove all existing file notification watches from Emacs."
+ (interactive)
+ (maphash
+ (lambda (key _value)
+ (file-notify-rm-watch key))
+ file-notify-descriptors))
+
(defun file-notify-valid-p (descriptor)
"Check a watch specified by its DESCRIPTOR.
DESCRIPTOR should be an object returned by `file-notify-add-watch'."
diff --git a/lisp/files.el b/lisp/files.el
index 32b7faa43d0..9ed63a60f81 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -68,6 +68,31 @@ a regexp matching the name it is linked to."
:group 'abbrev
:group 'find-file)
+(defun directory-abbrev-make-regexp (directory)
+ "Create a regexp to match DIRECTORY for `directory-abbrev-alist'."
+ (let ((regexp
+ ;; We include a slash at the end, to avoid spurious
+ ;; matches such as `/usr/foobar' when the home dir is
+ ;; `/usr/foo'.
+ (concat "\\`" (regexp-quote directory) "\\(/\\|\\'\\)")))
+ ;; The value of regexp could be multibyte or unibyte. In the
+ ;; latter case, we need to decode it.
+ (if (multibyte-string-p regexp)
+ regexp
+ (decode-coding-string regexp
+ (if (eq system-type 'windows-nt)
+ 'utf-8
+ locale-coding-system)))))
+
+(defun directory-abbrev-apply (filename)
+ "Apply the abbreviations in `directory-abbrev-alist' to FILENAME.
+Note that when calling this, you should set `case-fold-search' as
+appropriate for the filesystem used for FILENAME."
+ (dolist (dir-abbrev directory-abbrev-alist filename)
+ (when (string-match (car dir-abbrev) filename)
+ (setq filename (concat (cdr dir-abbrev)
+ (substring filename (match-end 0)))))))
+
(defcustom make-backup-files t
"Non-nil means make a backup of a file the first time it is saved.
This can be done by renaming the file or by copying.
@@ -2015,73 +2040,54 @@ if you want to permanently change your home directory after having
started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)."
;; Get rid of the prefixes added by the automounter.
(save-match-data ;FIXME: Why?
- (if (and automount-dir-prefix
- (string-match automount-dir-prefix filename)
- (file-exists-p (file-name-directory
- (substring filename (1- (match-end 0))))))
- (setq filename (substring filename (1- (match-end 0)))))
- ;; Avoid treating /home/foo as /home/Foo during `~' substitution.
- (let ((case-fold-search (file-name-case-insensitive-p filename)))
- ;; If any elt of directory-abbrev-alist matches this name,
- ;; abbreviate accordingly.
- (dolist (dir-abbrev directory-abbrev-alist)
- (if (string-match (car dir-abbrev) filename)
- (setq filename
- (concat (cdr dir-abbrev)
- (substring filename (match-end 0))))))
- ;; Compute and save the abbreviated homedir name.
- ;; We defer computing this until the first time it's needed, to
- ;; give time for directory-abbrev-alist to be set properly.
- ;; We include a slash at the end, to avoid spurious matches
- ;; such as `/usr/foobar' when the home dir is `/usr/foo'.
- (unless abbreviated-home-dir
- (put 'abbreviated-home-dir 'home (expand-file-name "~"))
- (setq abbreviated-home-dir
- (let* ((abbreviated-home-dir "\\`\\'.") ;Impossible regexp.
- (regexp
- (concat "\\`"
- (regexp-quote
- (abbreviate-file-name
- (get 'abbreviated-home-dir 'home)))
- "\\(/\\|\\'\\)")))
- ;; Depending on whether default-directory does or
- ;; doesn't include non-ASCII characters, the value
- ;; of abbreviated-home-dir could be multibyte or
- ;; unibyte. In the latter case, we need to decode
- ;; it. Note that this function is called for the
- ;; first time (from startup.el) when
- ;; locale-coding-system is already set up.
- (if (multibyte-string-p regexp)
- regexp
- (decode-coding-string regexp
- (if (eq system-type 'windows-nt)
- 'utf-8
- locale-coding-system))))))
-
- ;; If FILENAME starts with the abbreviated homedir,
- ;; and ~ hasn't changed since abbreviated-home-dir was set,
- ;; make it start with `~' instead.
- ;; If ~ has changed, we ignore abbreviated-home-dir rather than
- ;; invalidating it, on the assumption that a change in HOME
- ;; is likely temporary (eg for testing).
- ;; FIXME Is it even worth caching abbreviated-home-dir?
- ;; Ref: https://debbugs.gnu.org/19657#20
- (let (mb1)
- (if (and (string-match abbreviated-home-dir filename)
- (setq mb1 (match-beginning 1))
- ;; If the home dir is just /, don't change it.
- (not (and (= (match-end 0) 1)
- (= (aref filename 0) ?/)))
- ;; MS-DOS root directories can come with a drive letter;
- ;; Novell Netware allows drive letters beyond `Z:'.
- (not (and (memq system-type '(ms-dos windows-nt cygwin))
- (string-match "\\`[a-zA-`]:/\\'" filename)))
- (equal (get 'abbreviated-home-dir 'home)
- (expand-file-name "~")))
- (setq filename
- (concat "~"
- (substring filename mb1))))
- filename))))
+ (if-let ((handler (find-file-name-handler filename 'abbreviate-file-name)))
+ (funcall handler 'abbreviate-file-name filename)
+ (if (and automount-dir-prefix
+ (string-match automount-dir-prefix filename)
+ (file-exists-p (file-name-directory
+ (substring filename (1- (match-end 0))))))
+ (setq filename (substring filename (1- (match-end 0)))))
+ ;; Avoid treating /home/foo as /home/Foo during `~' substitution.
+ (let ((case-fold-search (file-name-case-insensitive-p filename)))
+ ;; If any elt of directory-abbrev-alist matches this name,
+ ;; abbreviate accordingly.
+ (setq filename (directory-abbrev-apply filename))
+
+ ;; Compute and save the abbreviated homedir name.
+ ;; We defer computing this until the first time it's needed, to
+ ;; give time for directory-abbrev-alist to be set properly.
+ (unless abbreviated-home-dir
+ (put 'abbreviated-home-dir 'home (expand-file-name "~"))
+ (setq abbreviated-home-dir
+ (directory-abbrev-make-regexp
+ (let ((abbreviated-home-dir "\\`\\'.")) ;Impossible regexp.
+ (abbreviate-file-name
+ (get 'abbreviated-home-dir 'home))))))
+
+ ;; If FILENAME starts with the abbreviated homedir,
+ ;; and ~ hasn't changed since abbreviated-home-dir was set,
+ ;; make it start with `~' instead.
+ ;; If ~ has changed, we ignore abbreviated-home-dir rather than
+ ;; invalidating it, on the assumption that a change in HOME
+ ;; is likely temporary (eg for testing).
+ ;; FIXME Is it even worth caching abbreviated-home-dir?
+ ;; Ref: https://debbugs.gnu.org/19657#20
+ (let (mb1)
+ (if (and (string-match abbreviated-home-dir filename)
+ (setq mb1 (match-beginning 1))
+ ;; If the home dir is just /, don't change it.
+ (not (and (= (match-end 0) 1)
+ (= (aref filename 0) ?/)))
+ ;; MS-DOS root directories can come with a drive letter;
+ ;; Novell Netware allows drive letters beyond `Z:'.
+ (not (and (memq system-type '(ms-dos windows-nt cygwin))
+ (string-match "\\`[a-zA-`]:/\\'" filename)))
+ (equal (get 'abbreviated-home-dir 'home)
+ (expand-file-name "~")))
+ (setq filename
+ (concat "~"
+ (substring filename mb1))))
+ filename)))))
(defun find-buffer-visiting (filename &optional predicate)
"Return the buffer visiting file FILENAME (a string).
@@ -2761,6 +2767,7 @@ since only a single case-insensitive search through the alist is made."
("\\.gif\\'" . image-mode)
("\\.png\\'" . image-mode)
("\\.jpe?g\\'" . image-mode)
+ ("\\.webp\\'" . image-mode)
("\\.te?xt\\'" . text-mode)
("\\.[tT]e[xX]\\'" . tex-mode)
("\\.ins\\'" . tex-mode) ;Installation files for TeX packages.
@@ -2886,6 +2893,7 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\|SQUASHFS\\)\\'" .
("\\.[ds]?va?h?\\'" . verilog-mode)
("\\.by\\'" . bovine-grammar-mode)
("\\.wy\\'" . wisent-grammar-mode)
+ ("\\.erts\\'" . erts-mode)
;; .emacs or .gnus or .viper following a directory delimiter in
;; Unix or MS-DOS syntax.
("[:/\\]\\..*\\(emacs\\|gnus\\|viper\\)\\'" . emacs-lisp-mode)
@@ -2978,6 +2986,7 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\|SQUASHFS\\)\\'" .
("\\.dng\\'" . image-mode)
("\\.dpx\\'" . image-mode)
("\\.fax\\'" . image-mode)
+ ("\\.heic\\'" . image-mode)
("\\.hrz\\'" . image-mode)
("\\.icb\\'" . image-mode)
("\\.icc\\'" . image-mode)
@@ -4736,7 +4745,6 @@ using \\<minibuffer-local-map>\\[next-history-element].
If optional second arg CONFIRM is non-nil, this function
asks for confirmation before overwriting an existing file.
Interactively, confirmation is required unless you supply a prefix argument."
-;; (interactive "FWrite file: ")
(interactive
(list (if buffer-file-name
(read-file-name "Write file: "
@@ -4747,33 +4755,44 @@ Interactively, confirmation is required unless you supply a prefix argument."
default-directory)
nil nil))
(not current-prefix-arg)))
- (or (null filename) (string-equal filename "")
- (progn
- ;; If arg is a directory name,
- ;; use the default file name, but in that directory.
- (if (directory-name-p filename)
- (setq filename (concat filename
- (file-name-nondirectory
- (or buffer-file-name (buffer-name))))))
- (and confirm
- (file-exists-p filename)
- ;; NS does its own confirm dialog.
- (not (and (eq (framep-on-display) 'ns)
- (listp last-nonmenu-event)
- use-dialog-box))
- (or (y-or-n-p (format-message
- "File `%s' exists; overwrite? " filename))
- (user-error "Canceled")))
- (set-visited-file-name filename (not confirm))))
- (set-buffer-modified-p t)
- ;; Make buffer writable if file is writable.
- (and buffer-file-name
- (file-writable-p buffer-file-name)
- (setq buffer-read-only nil))
- (save-buffer)
- ;; It's likely that the VC status at the new location is different from
- ;; the one at the old location.
- (vc-refresh-state))
+ (let ((old-modes
+ (and buffer-file-name
+ ;; File may have gone away; ignore errors in that case.
+ (ignore-errors (file-modes buffer-file-name)))))
+ (or (null filename) (string-equal filename "")
+ (progn
+ ;; If arg is a directory name,
+ ;; use the default file name, but in that directory.
+ (if (directory-name-p filename)
+ (setq filename (concat filename
+ (file-name-nondirectory
+ (or buffer-file-name (buffer-name))))))
+ (and confirm
+ (file-exists-p filename)
+ ;; NS does its own confirm dialog.
+ (not (and (eq (framep-on-display) 'ns)
+ (listp last-nonmenu-event)
+ use-dialog-box))
+ (or (y-or-n-p (format-message
+ "File `%s' exists; overwrite? " filename))
+ (user-error "Canceled")))
+ (set-visited-file-name filename (not confirm))))
+ (set-buffer-modified-p t)
+ ;; Make buffer writable if file is writable.
+ (and buffer-file-name
+ (file-writable-p buffer-file-name)
+ (setq buffer-read-only nil))
+ (save-buffer)
+ ;; If the old file was executable, then make the new file
+ ;; executable, too.
+ (when (and old-modes
+ (not (zerop (logand #o111 old-modes))))
+ (set-file-modes buffer-file-name
+ (logior (logand #o111 old-modes)
+ (file-modes buffer-file-name))))
+ ;; It's likely that the VC status at the new location is different from
+ ;; the one at the old location.
+ (vc-refresh-state)))
(defun file-extended-attributes (filename)
"Return an alist of extended attributes of file FILENAME.
@@ -5048,6 +5067,29 @@ See also `file-name-sans-extension'."
(file-name-sans-extension
(file-name-nondirectory (or filename (buffer-file-name)))))
+(defun file-name-split (filename)
+ "Return a list of all the components of FILENAME.
+On most systems, this will be true:
+
+ (equal (string-join (file-name-split filename) \"/\") filename)"
+ (let ((components nil))
+ ;; If this is a directory file name, then we have a null file name
+ ;; at the end.
+ (when (directory-name-p filename)
+ (push "" components)
+ (setq filename (directory-file-name filename)))
+ ;; Loop, chopping off components.
+ (while (length> filename 0)
+ (push (file-name-nondirectory filename) components)
+ (let ((dir (file-name-directory filename)))
+ (setq filename (and dir (directory-file-name dir)))
+ ;; If there's nothing left to peel off, we're at the root and
+ ;; we can stop.
+ (when (and dir (equal dir filename))
+ (push "" components)
+ (setq filename nil))))
+ components))
+
(defcustom make-backup-file-name-function
#'make-backup-file-name--default-function
"A function that `make-backup-file-name' uses to create backup file names.
@@ -5774,13 +5816,13 @@ of the directory that was default during command invocation."
(defun save-some-buffers (&optional arg pred)
"Save some modified file-visiting buffers. Asks user about each one.
-You can answer `y' or SPC to save, `n' or DEL not to save, `C-r'
+You can answer \\`y' or \\`SPC' to save, \\`n' or \\`DEL' not to save, \\`C-r'
to look at the buffer in question with `view-buffer' before
-deciding, `d' to view the differences using
-`diff-buffer-with-file', `!' to save the buffer and all remaining
-buffers without any further querying, `.' to save only the
-current buffer and skip the remaining ones and `q' or RET to exit
-the function without saving any more buffers. `C-h' displays a
+deciding, \\`d' to view the differences using
+`diff-buffer-with-file', \\`!' to save the buffer and all remaining
+buffers without any further querying, \\`.' to save only the
+current buffer and skip the remaining ones and \\`q' or \\`RET' to exit
+the function without saving any more buffers. \\`C-h' displays a
help message describing these options.
This command first saves any buffers where `buffer-save-without-query' is
@@ -6180,6 +6222,29 @@ Return nil if DIR is not an existing directory."
(unless mismatch
(file-equal-p root dir)))))))
+(defvar file-has-changed-p--hash-table (make-hash-table :test #'equal)
+ "Internal variable used by `file-has-changed-p'.")
+
+(defun file-has-changed-p (file &optional tag)
+ "Return non-nil if FILE has changed.
+The size and modification time of FILE are compared to the size
+and modification time of the same FILE during a previous
+invocation of `file-has-changed-p'. Thus, the first invocation
+of `file-has-changed-p' always returns non-nil when FILE exists.
+The optional argument TAG, which must be a symbol, can be used to
+limit the comparison to invocations with identical tags; it can be
+the symbol of the calling function, for example."
+ (let* ((file (directory-file-name (expand-file-name file)))
+ (remote-file-name-inhibit-cache t)
+ (fileattr (file-attributes file 'integer))
+ (attr (and fileattr
+ (cons (file-attribute-size fileattr)
+ (file-attribute-modification-time fileattr))))
+ (sym (concat (symbol-name tag) "@" file))
+ (cachedattr (gethash sym file-has-changed-p--hash-table)))
+ (when (not (equal attr cachedattr))
+ (puthash sym attr file-has-changed-p--hash-table))))
+
(defun copy-directory (directory newname &optional keep-time parents copy-contents)
"Copy DIRECTORY to NEWNAME. Both args must be strings.
This function always sets the file modes of the output files to match
@@ -7132,16 +7197,16 @@ default directory. However, if FULL is non-nil, they are absolute."
(let ((this-dir-contents
;; Filter out "." and ".."
(delq nil
- (mapcar #'(lambda (name)
- (unless (string-match "\\`\\.\\.?\\'"
- (file-name-nondirectory name))
- name))
+ (mapcar (lambda (name)
+ (unless (string-match "\\`\\.\\.?\\'"
+ (file-name-nondirectory name))
+ name))
(directory-files (or dir ".") full
(wildcard-to-regexp nondir))))))
(setq contents
(nconc
(if (and dir (not full))
- (mapcar #'(lambda (name) (concat dir name))
+ (mapcar (lambda (name) (concat dir name))
this-dir-contents)
this-dir-contents)
contents)))))
@@ -7156,11 +7221,18 @@ DIRNAME is globbed by the shell if necessary.
Prefix arg (second arg if noninteractive) means supply -l switch to `ls'.
Actions controlled by variables `list-directory-brief-switches'
and `list-directory-verbose-switches'."
- (interactive (let ((pfx current-prefix-arg))
- (list (read-directory-name (if pfx "List directory (verbose): "
- "List directory (brief): ")
- nil default-directory nil)
- pfx)))
+ (interactive
+ (let ((pfx current-prefix-arg))
+ (list (read-file-name
+ (if pfx "List directory (verbose): "
+ "List directory (brief): ")
+ nil default-directory t
+ nil
+ (lambda (file)
+ (or (file-directory-p file)
+ (insert-directory-wildcard-in-dir-p
+ (expand-file-name file)))))
+ pfx)))
(let ((switches (if verbose list-directory-verbose-switches
list-directory-brief-switches))
buffer)
@@ -7611,21 +7683,7 @@ normally equivalent short `-D' option is just passed on to
(if val coding-no-eol coding))
(if val
(put-text-property pos (point)
- 'dired-filename t)))))))
-
- (if full-directory-p
- ;; Try to insert the amount of free space.
- (save-excursion
- (goto-char beg)
- ;; First find the line to put it on.
- (when (re-search-forward "^ *\\(total\\)" nil t)
- ;; Replace "total" with "total used in directory" to
- ;; avoid confusion.
- (replace-match "total used in directory" nil nil nil 1)
- (let ((available (get-free-disk-space file)))
- (when available
- (end-of-line)
- (insert " available " available))))))))))
+ 'dired-filename t)))))))))))
(defun insert-directory-adj-pos (pos error-lines)
"Convert `ls --dired' file name position value POS to a buffer position.
@@ -7786,10 +7844,11 @@ only these files will be asked to be saved."
;; Get a list of the indices of the args that are file names.
(file-arg-indices
(cdr (or (assq operation
- '(;; The first seven are special because they
+ '(;; The first eight are special because they
;; return a file name. We want to include
;; the /: in the return value. So just
;; avoid stripping it in the first place.
+ (abbreviate-file-name)
(directory-file-name)
(expand-file-name)
(file-name-as-directory)
diff --git a/lisp/finder.el b/lisp/finder.el
index c2b9a6d0ef9..00f321b8028 100644
--- a/lisp/finder.el
+++ b/lisp/finder.el
@@ -362,19 +362,13 @@ not `finder-known-keywords'."
(let ((package-list-unversioned t))
(package-show-package-list packages))))
-(define-button-type 'finder-xref 'action #'finder-goto-xref)
-
-(defun finder-goto-xref (button)
- "Jump to a Lisp file for the BUTTON at point."
- (let* ((file (button-get button 'xref))
- (lib (locate-library file)))
- (if lib (finder-commentary lib)
- (message "Unable to locate `%s'" file))))
-
;;;###autoload
(defun finder-commentary (file)
"Display FILE's commentary section.
FILE should be in a form suitable for passing to `locate-library'."
+ ;; FIXME: Merge this function into `describe-package', which is
+ ;; strictly better as it has links to URL's and is in a proper help
+ ;; buffer with navigation forward and backward, etc.
(interactive
(list
(completing-read "Library name: "
@@ -391,12 +385,7 @@ FILE should be in a form suitable for passing to `locate-library'."
(erase-buffer)
(insert str)
(goto-char (point-min))
- (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t)
- (if (locate-library (match-string 1))
- (make-text-button (match-beginning 1) (match-end 1)
- 'xref (match-string-no-properties 1)
- 'help-echo "Read this file's commentary"
- :type 'finder-xref)))
+ (package--describe-add-library-links)
(goto-char (point-min))
(setq buffer-read-only t)
(set-buffer-modified-p nil)
@@ -469,6 +458,9 @@ Quit the window and kill all Finder-related buffers."
;; continue standard unloading
nil)
+(define-obsolete-function-alias 'finder-goto-xref
+ #'package--finder-goto-xref "29.1")
+
(provide 'finder)
diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index a4ab897f6f2..c2590eb3c11 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -2075,7 +2075,7 @@ as the constructs of Haddock, Javadoc and similar systems."
(((class color) (min-colors 16) (background dark)) :foreground "PaleGreen")
(((class color) (min-colors 8)) :foreground "green")
(t :weight bold :underline t))
- "Font Lock mode face used to highlight type and classes."
+ "Font Lock mode face used to highlight type and class names."
:group 'font-lock-faces)
(defface font-lock-constant-face
diff --git a/lisp/format.el b/lisp/format.el
index 6c0ba11641e..8ae51f19ebc 100644
--- a/lisp/format.el
+++ b/lisp/format.el
@@ -320,7 +320,7 @@ If the format is not specified, attempt a regexp-based guess.
Set `buffer-file-format' to the format used, and call any
format-specific mode functions."
(interactive
- (list (format-read "Translate buffer from format (default guess): ")))
+ (list (format-read (format-prompt "Translate buffer from format" "guess"))))
(save-excursion
(goto-char (point-min))
(format-decode format (buffer-size) t)))
@@ -331,7 +331,7 @@ Arg FORMAT is optional; if omitted the format will be determined by looking
for identifying regular expressions at the beginning of the region."
(interactive
(list (region-beginning) (region-end)
- (format-read "Translate region from format (default guess): ")))
+ (format-read (format-prompt "Translate region from format" "guess"))))
(save-excursion
(goto-char from)
(format-decode format (- to from) nil)))
diff --git a/lisp/frame.el b/lisp/frame.el
index 2c73737a541..13929047d08 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -808,12 +808,16 @@ also select the new frame."
new-frame))
(defvar before-make-frame-hook nil
- "Functions to run before `make-frame' creates a new frame.")
+ "Functions to run before `make-frame' creates a new frame.
+Note that these functions are usually not run for the initial
+frame, unless you add them to the hook in your early-init file.")
(defvar after-make-frame-functions nil
"Functions to run after `make-frame' created a new frame.
The functions are run with one argument, the newly created
-frame.")
+frame.
+Note that these functions are usually not run for the initial
+frame, unless you add them to the hook in your early-init file.")
(defvar after-setting-font-hook nil
"Functions to run after a frame's font has been changed.")
@@ -1633,6 +1637,8 @@ live frame and defaults to the selected one."
(declare-function x-frame-geometry "xfns.c" (&optional frame))
(declare-function w32-frame-geometry "w32fns.c" (&optional frame))
(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))
(defun frame-geometry (&optional frame)
"Return geometric attributes of FRAME.
@@ -1682,6 +1688,10 @@ and width values are in pixels.
(w32-frame-geometry frame))
((eq frame-type 'ns)
(ns-frame-geometry frame))
+ ((eq frame-type 'pgtk)
+ (pgtk-frame-geometry frame))
+ ((eq frame-type 'haiku)
+ (haiku-frame-geometry frame))
(t
(list
'(outer-position 0 . 0)
@@ -1806,6 +1816,8 @@ of frames like calls to map a frame or change its visibility."
(declare-function x-frame-edges "xfns.c" (&optional frame type))
(declare-function w32-frame-edges "w32fns.c" (&optional frame type))
(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))
(defun frame-edges (&optional frame type)
"Return coordinates of FRAME's edges.
@@ -1829,12 +1841,18 @@ FRAME."
(w32-frame-edges frame type))
((eq frame-type 'ns)
(ns-frame-edges frame type))
+ ((eq frame-type 'pgtk)
+ (pgtk-frame-edges frame type))
+ ((eq frame-type 'haiku)
+ (haiku-frame-edges frame type))
(t
(list 0 0 (frame-width frame) (frame-height frame))))))
(declare-function w32-mouse-absolute-pixel-position "w32fns.c")
(declare-function x-mouse-absolute-pixel-position "xfns.c")
(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")
(defun mouse-absolute-pixel-position ()
"Return absolute position of mouse cursor in pixels.
@@ -1849,12 +1867,18 @@ position (0, 0) of the selected frame's terminal."
(w32-mouse-absolute-pixel-position))
((eq frame-type 'ns)
(ns-mouse-absolute-pixel-position))
+ ((eq frame-type 'pgtk)
+ (pgtk-mouse-absolute-pixel-position))
+ ((eq frame-type 'haiku)
+ (haiku-mouse-absolute-pixel-position))
(t
(cons 0 0)))))
+(declare-function pgtk-set-mouse-absolute-pixel-position "pgtkfns.c" (x y))
(declare-function ns-set-mouse-absolute-pixel-position "nsfns.m" (x y))
(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))
(defun set-mouse-absolute-pixel-position (x y)
"Move mouse pointer to absolute pixel position (X, Y).
@@ -1862,12 +1886,16 @@ The coordinates X and Y are interpreted in pixels relative to a
position (0, 0) of the selected frame's terminal."
(let ((frame-type (framep-on-display)))
(cond
+ ((eq frame-type 'pgtk)
+ (pgtk-set-mouse-absolute-pixel-position x y))
((eq frame-type 'ns)
(ns-set-mouse-absolute-pixel-position x y))
((eq frame-type 'x)
(x-set-mouse-absolute-pixel-position x y))
((eq frame-type 'w32)
- (w32-set-mouse-absolute-pixel-position x y)))))
+ (w32-set-mouse-absolute-pixel-position x y))
+ ((eq frame-type 'haiku)
+ (haiku-set-mouse-absolute-pixel-position x y)))))
(defun frame-monitor-attributes (&optional frame)
"Return the attributes of the physical monitor dominating FRAME.
@@ -1960,6 +1988,8 @@ workarea attribute."
(declare-function x-frame-list-z-order "xfns.c" (&optional display))
(declare-function w32-frame-list-z-order "w32fns.c" (&optional display))
(declare-function ns-frame-list-z-order "nsfns.m" (&optional display))
+(declare-function pgtk-frame-list-z-order "pgtkfns.c" (&optional display))
+(declare-function haiku-frame-list-z-order "haikufns.c" (&optional display))
(defun frame-list-z-order (&optional display)
"Return list of Emacs' frames, in Z (stacking) order.
@@ -1979,11 +2009,16 @@ Return nil if DISPLAY contains no Emacs frame."
((eq frame-type 'w32)
(w32-frame-list-z-order display))
((eq frame-type 'ns)
- (ns-frame-list-z-order display)))))
+ (ns-frame-list-z-order display))
+ ((eq frame-type 'pgtk)
+ (pgtk-frame-list-z-order display))
+ ((eq frame-type 'haiku)
+ (haiku-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))
(defun frame-restack (frame1 frame2 &optional above)
"Restack FRAME1 below FRAME2.
@@ -2013,7 +2048,9 @@ Some window managers may refuse to restack windows."
((eq frame-type 'w32)
(w32-frame-restack frame1 frame2 above))
((eq frame-type 'ns)
- (ns-frame-restack frame1 frame2 above))))
+ (ns-frame-restack frame1 frame2 above))
+ ((eq frame-type 'pgtk)
+ (pgtk-frame-restack frame1 frame2 above))))
(error "Cannot restack frames")))
(defun frame-size-changed-p (&optional frame)
@@ -2060,8 +2097,8 @@ frame's display)."
((eq frame-type 'w32)
(with-no-warnings
(> w32-num-mouse-buttons 0)))
- ((memq frame-type '(x ns))
- t) ;; We assume X and NeXTstep *always* have a pointing device
+ ((memq frame-type '(x ns haiku pgtk))
+ t) ;; We assume X, NeXTstep, GTK, and Haiku *always* have a pointing device
(t
(or (and (featurep 'xt-mouse)
xterm-mouse-mode)
@@ -2086,7 +2123,7 @@ 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)))))
+ (not (null (memq (framep-on-display display) '(x w32 ns pgtk haiku)))))
(defun display-images-p (&optional display)
"Return non-nil if DISPLAY can display images.
@@ -2114,7 +2151,7 @@ frame's display)."
;; a Windows DOS Box.
(with-no-warnings
(not (null dos-windows-version))))
- ((memq frame-type '(x w32 ns))
+ ((memq frame-type '(x w32 ns pgtk))
t)
(t
nil))))
@@ -2124,7 +2161,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))
+ (or (memq frame-type '(x w32 ns pc pgtk))
;; MS-DOS and MS-Windows terminals have built-in support for
;; function (symbol) keys
(memq system-type '(ms-dos windows-nt)))))
@@ -2137,7 +2174,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))
+ ((memq frame-type '(x w32 ns haiku pgtk))
(x-display-screens display))
(t
1))))
@@ -2157,7 +2194,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))
+ ((memq frame-type '(x w32 ns haiku pgtk))
(x-display-pixel-height display))
(t
(frame-height (if (framep display) display (selected-frame)))))))
@@ -2177,7 +2214,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))
+ ((memq frame-type '(x w32 ns haiku pgtk))
(x-display-pixel-width display))
(t
(frame-width (if (framep display) display (selected-frame)))))))
@@ -2215,7 +2252,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))
+ (and (memq (framep-on-display display) '(x w32 ns haiku pgtk))
(or (cddr (assoc (or display (frame-parameter nil 'display))
display-mm-dimensions-alist))
(cddr (assoc t display-mm-dimensions-alist))
@@ -2236,7 +2273,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))
+ (and (memq (framep-on-display display) '(x w32 ns haiku pgtk))
(or (cadr (assoc (or display (frame-parameter nil 'display))
display-mm-dimensions-alist))
(cadr (assoc t display-mm-dimensions-alist))
@@ -2254,7 +2291,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))
+ ((memq frame-type '(x w32 ns haiku pgtk))
(x-display-backing-store display))
(t
'not-useful))))
@@ -2267,7 +2304,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))
+ ((memq frame-type '(x w32 ns haiku pgtk))
(x-display-save-under display))
(t
'not-useful))))
@@ -2280,7 +2317,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))
+ ((memq frame-type '(x w32 ns haiku pgtk))
(x-display-planes display))
((eq frame-type 'pc)
4)
@@ -2295,7 +2332,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))
+ ((memq frame-type '(x w32 ns haiku pgtk))
(x-display-color-cells display))
((eq frame-type 'pc)
16)
@@ -2312,7 +2349,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))
+ ((memq frame-type '(x w32 ns haiku pgtk))
(x-display-visual-class display))
((and (memq frame-type '(pc t))
(tty-display-color-p display))
@@ -2326,6 +2363,8 @@ If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(&optional display))
(declare-function ns-display-monitor-attributes-list "nsfns.m"
(&optional terminal))
+(declare-function pgtk-display-monitor-attributes-list "pgtkfns.c"
+ (&optional terminal))
(defun display-monitor-attributes-list (&optional display)
"Return a list of physical monitor attributes on DISPLAY.
@@ -2343,6 +2382,7 @@ of attribute keys and values as follows:
mm-size -- Width and height in millimeters in the form of
(WIDTH HEIGHT)
frames -- List of frames dominated by the physical monitor
+ scale-factor (*) -- Scale factor (float)
name (*) -- Name of the physical monitor as a string
source (*) -- Source of multi-monitor information as a string
@@ -2374,6 +2414,8 @@ monitors."
(w32-display-monitor-attributes-list display))
((eq frame-type 'ns)
(ns-display-monitor-attributes-list display))
+ ((eq frame-type 'pgtk)
+ (pgtk-display-monitor-attributes-list display))
(t
(let ((geometry (list 0 0 (display-pixel-width display)
(display-pixel-height display))))
diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el
index bcf8dd014bc..68a90989046 100644
--- a/lisp/gnus/gmm-utils.el
+++ b/lisp/gnus/gmm-utils.el
@@ -239,6 +239,7 @@ 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))
(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 6426d825465..169a351c2c7 100644
--- a/lisp/gnus/gnus-agent.el
+++ b/lisp/gnus/gnus-agent.el
@@ -475,17 +475,16 @@ manipulated as follows:
(gnus-run-hooks 'gnus-agent-mode-hook
(intern (format "gnus-agent-%s-mode-hook" buffer)))))
-(defvar gnus-agent-group-mode-map (make-sparse-keymap))
-(gnus-define-keys gnus-agent-group-mode-map
- "Ju" gnus-agent-fetch-groups
- "Jc" gnus-enter-category-buffer
- "Jj" gnus-agent-toggle-plugged
- "Js" gnus-agent-fetch-session
- "JY" gnus-agent-synchronize-flags
- "JS" gnus-group-send-queue
- "Ja" gnus-agent-add-group
- "Jr" gnus-agent-remove-group
- "Jo" gnus-agent-toggle-group-plugged)
+(defvar-keymap gnus-agent-group-mode-map
+ "J u" #'gnus-agent-fetch-groups
+ "J c" #'gnus-enter-category-buffer
+ "J j" #'gnus-agent-toggle-plugged
+ "J s" #'gnus-agent-fetch-session
+ "J Y" #'gnus-agent-synchronize-flags
+ "J S" #'gnus-group-send-queue
+ "J a" #'gnus-agent-add-group
+ "J r" #'gnus-agent-remove-group
+ "J o" #'gnus-agent-toggle-group-plugged)
(defun gnus-agent-group-make-menu-bar ()
(unless (boundp 'gnus-agent-group-menu)
@@ -504,16 +503,15 @@ manipulated as follows:
["Synchronize flags" gnus-agent-synchronize-flags t]
))))
-(defvar gnus-agent-summary-mode-map (make-sparse-keymap))
-(gnus-define-keys gnus-agent-summary-mode-map
- "Jj" gnus-agent-toggle-plugged
- "Ju" gnus-agent-summary-fetch-group
- "JS" gnus-agent-fetch-group
- "Js" gnus-agent-summary-fetch-series
- "J#" gnus-agent-mark-article
- "J\M-#" gnus-agent-unmark-article
- "@" gnus-agent-toggle-mark
- "Jc" gnus-agent-catchup)
+(defvar-keymap gnus-agent-summary-mode-map
+ "J j" #'gnus-agent-toggle-plugged
+ "J u" #'gnus-agent-summary-fetch-group
+ "J S" #'gnus-agent-fetch-group
+ "J s" #'gnus-agent-summary-fetch-series
+ "J #" #'gnus-agent-mark-article
+ "J M-#" #'gnus-agent-unmark-article
+ "@" #'gnus-agent-toggle-mark
+ "J c" #'gnus-agent-catchup)
(defun gnus-agent-summary-make-menu-bar ()
(unless (boundp 'gnus-agent-summary-menu)
@@ -527,11 +525,10 @@ manipulated as follows:
["Fetch downloadable" gnus-agent-summary-fetch-group t]
["Catchup undownloaded" gnus-agent-catchup t]))))
-(defvar gnus-agent-server-mode-map (make-sparse-keymap))
-(gnus-define-keys gnus-agent-server-mode-map
- "Jj" gnus-agent-toggle-plugged
- "Ja" gnus-agent-add-server
- "Jr" gnus-agent-remove-server)
+(defvar-keymap gnus-agent-server-mode-map
+ "J j" #'gnus-agent-toggle-plugged
+ "J a" #'gnus-agent-add-server
+ "J r" #'gnus-agent-remove-server)
(defun gnus-agent-server-make-menu-bar ()
(unless (boundp 'gnus-agent-server-menu)
@@ -2597,25 +2594,20 @@ General format specifiers can also be used. See Info node
(defvar gnus-category-line-format-spec nil)
(defvar gnus-category-mode-line-format-spec nil)
-(defvar gnus-category-mode-map nil)
-
-(unless gnus-category-mode-map
- (setq gnus-category-mode-map (make-sparse-keymap))
- (suppress-keymap gnus-category-mode-map)
-
- (gnus-define-keys gnus-category-mode-map
- "q" gnus-category-exit
- "k" gnus-category-kill
- "c" gnus-category-copy
- "a" gnus-category-add
- "e" gnus-agent-customize-category
- "p" gnus-category-edit-predicate
- "g" gnus-category-edit-groups
- "s" gnus-category-edit-score
- "l" gnus-category-list
-
- "\C-c\C-i" gnus-info-find-node
- "\C-c\C-b" gnus-bug))
+(defvar-keymap gnus-category-mode-map
+ :suppress t
+ "q" #'gnus-category-exit
+ "k" #'gnus-category-kill
+ "c" #'gnus-category-copy
+ "a" #'gnus-category-add
+ "e" #'gnus-agent-customize-category
+ "p" #'gnus-category-edit-predicate
+ "g" #'gnus-category-edit-groups
+ "s" #'gnus-category-edit-score
+ "l" #'gnus-category-list
+
+ "C-c C-i" #'gnus-info-find-node
+ "C-c C-b" #'gnus-bug)
(defcustom gnus-category-menu-hook nil
"Hook run after the creation of the menu."
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index b97cd711c4e..b7701f10a5e 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -768,28 +768,37 @@ Obsolete; use the face `gnus-signature' for customizations instead."
:group 'gnus-article-highlight
:group 'gnus-article-signature)
+(defface gnus-header
+ '((t :inherit variable-pitch-text))
+ "Base face used for all Gnus header faces.
+All the other `gnus-header-' faces inherit from this face."
+ :version "29.1"
+ :group 'gnus-article-headers
+ :group 'gnus-article-highlight)
+
(defface gnus-header-from
'((((class color)
(background dark))
- (:foreground "PaleGreen1"))
+ (:foreground "PaleGreen1" :inherit gnus-header))
(((class color)
(background light))
- (:foreground "red3"))
+ (:foreground "red3" :inherit gnus-header))
(t
- (:italic t)))
+ (:italic t :inherit gnus-header)))
"Face used for displaying from headers."
+ :version "29.1"
:group 'gnus-article-headers
:group 'gnus-article-highlight)
(defface gnus-header-subject
'((((class color)
(background dark))
- (:foreground "SeaGreen1"))
+ (:foreground "SeaGreen1" :inherit gnus-header))
(((class color)
(background light))
- (:foreground "red4"))
+ (:foreground "red4" :inherit gnus-header))
(t
- (:bold t :italic t)))
+ (:bold t :italic t :inherit gnus-header)))
"Face used for displaying subject headers."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
@@ -797,7 +806,7 @@ Obsolete; use the face `gnus-signature' for customizations instead."
(defface gnus-header-newsgroups
'((((class color)
(background dark))
- (:foreground "yellow" :italic t))
+ (:foreground "yellow" :italic t :inherit gnus-header))
(((class color)
(background light))
(:foreground "MidnightBlue" :italic t))
@@ -812,12 +821,12 @@ articles."
(defface gnus-header-name
'((((class color)
(background dark))
- (:foreground "SpringGreen2"))
+ (:foreground "SpringGreen2" :inherit gnus-header))
(((class color)
(background light))
- (:foreground "maroon"))
+ (:foreground "maroon" :inherit gnus-header))
(t
- (:bold t)))
+ (:bold t :inherit gnus-header)))
"Face used for displaying header names."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
@@ -825,12 +834,13 @@ articles."
(defface gnus-header-content
'((((class color)
(background dark))
- (:foreground "SpringGreen1" :italic t))
+ (:foreground "SpringGreen1" :italic t :inherit gnus-header))
(((class color)
(background light))
- (:foreground "indianred4" :italic t))
+ (:foreground "indianred4" :italic t :inherit gnus-header))
(t
- (:italic t))) "Face used for displaying header content."
+ (:italic t :inherit gnus-header)))
+ "Face used for displaying header content."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
@@ -1167,6 +1177,19 @@ predicate. See Info node `(gnus)Customizing Articles'."
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
+(defcustom gnus-treat-emojize-symbols nil
+ "Display emoji versions of symbol.
+Some symbols have both a non-emoji presentation and an emoji
+presentation. This treatment will make Gnus display the latter
+as emojis even when they weren't sent as such.
+
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
+ :version "29.1"
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :type gnus-article-treat-custom)
+
(defcustom gnus-treat-unsplit-urls nil
"Remove newlines from within URLs.
Valid values are nil, t, `head', `first', `last', an integer or a
@@ -1360,11 +1383,11 @@ This variable has no effect if `gnus-treat-unfold-headers' is nil."
(const :tag "all" t)
(regexp)))
-(defcustom gnus-treat-fold-headers nil
+(defcustom gnus-treat-fold-headers 'head
"Fold headers.
Valid values are nil, t, `head', `first', `last', an integer or a
predicate. See Info node `(gnus)Customizing Articles'."
- :version "22.1"
+ :version "29.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
@@ -1650,6 +1673,7 @@ regexp."
(defvar gnus-article-mime-handle-alist-1 nil)
(defvar gnus-treatment-function-alist
'((gnus-treat-strip-cr gnus-article-remove-cr)
+ (gnus-treat-emojize-symbols gnus-article-emojize-symbols)
(gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
(gnus-treat-strip-banner gnus-article-strip-banner)
(gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
@@ -2188,6 +2212,14 @@ unfolded."
(replace-match " " t t))))
(goto-char (point-max)))))))
+(defun gnus--variable-pitch-p (face)
+ (when face
+ (or (eq face 'variable-pitch)
+ (let ((parent (face-attribute face :inherit)))
+ (if (eq parent 'unspecified)
+ nil
+ (seq-some #'gnus--variable-pitch-p (ensure-list parent)))))))
+
(defun gnus-article-treat-fold-headers ()
"Fold message headers."
(interactive nil gnus-article-mode gnus-summary-mode)
@@ -2195,7 +2227,10 @@ unfolded."
(while (not (eobp))
(save-restriction
(mail-header-narrow-to-field)
- (mail-header-fold-field)
+ (if (not (gnus--variable-pitch-p (get-text-property (point) 'face)))
+ (mail-header-fold-field)
+ (forward-char 1)
+ (pixel-fill-region (point) (point-max) (pixel-fill-width)))
(goto-char (point-max))))))
(defun gnus-treat-smiley ()
@@ -2360,6 +2395,20 @@ fill width."
(while (search-forward "\r" nil t)
(replace-match "\n" t t)))))
+(defun article-emojize-symbols ()
+ "Display symbols (that have an emoji version) as emojis."
+ (interactive nil gnus-article-mode)
+ (when-let ((font (and (display-multi-font-p)
+ (car (internal-char-font nil ?😀)))))
+ (save-excursion
+ (let ((inhibit-read-only t))
+ (goto-char (point-min))
+ (while (re-search-forward "[[:multibyte:]]" nil t)
+ ;; If there's already a grapheme cluster here, skip it.
+ (when (and (not (find-composition (point)))
+ (font-has-char-p font (char-after (match-beginning 0))))
+ (insert "\N{VARIATION SELECTOR-16}")))))))
+
(defun article-remove-trailing-blank-lines ()
"Remove all trailing blank lines from the article."
(interactive nil gnus-article-mode)
@@ -3933,8 +3982,8 @@ This format is defined by the `gnus-article-time-format' variable."
;; No split name was found.
((null split-name)
(read-file-name
- (concat prompt " (default "
- (file-name-nondirectory default-name) "): ")
+ (format-prompt prompt
+ (file-name-nondirectory default-name))
(file-name-directory default-name)
default-name))
;; A single group name is returned.
@@ -3943,8 +3992,8 @@ This format is defined by the `gnus-article-time-format' variable."
(funcall function split-name headers
(symbol-value variable)))
(read-file-name
- (concat prompt " (default "
- (file-name-nondirectory default-name) "): ")
+ (format-prompt prompt
+ (file-name-nondirectory default-name))
(file-name-directory default-name)
default-name))
;; A single split name was found
@@ -3956,9 +4005,8 @@ This format is defined by the `gnus-article-time-format' variable."
(file-name-as-directory name))
((file-exists-p name) name)
(t gnus-article-save-directory))))
- (read-file-name
- (concat prompt " (default " name "): ")
- dir name)))
+ (read-file-name (format-prompt prompt name)
+ dir name)))
;; A list of splits was found.
(t
(setq split-name (nreverse split-name))
@@ -4342,6 +4390,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is
article-fill-long-lines
article-capitalize-sentences
article-remove-cr
+ article-emojize-symbols
article-remove-leading-whitespace
article-display-x-face
article-display-face
@@ -4387,44 +4436,44 @@ If variable `gnus-use-long-file-name' is non-nil, it is
;;; Gnus article mode
;;;
-(set-keymap-parent gnus-article-mode-map button-buffer-map)
-
-(gnus-define-keys gnus-article-mode-map
- " " gnus-article-goto-next-page
- [?\S-\ ] gnus-article-goto-prev-page
- "\177" gnus-article-goto-prev-page
- [delete] gnus-article-goto-prev-page
- "\C-c^" gnus-article-refer-article
- "h" gnus-article-show-summary
- "s" gnus-article-show-summary
- "\C-c\C-m" gnus-article-mail
- "?" gnus-article-describe-briefly
- "<" beginning-of-buffer
- ">" end-of-buffer
- "\C-c\C-i" gnus-info-find-node
- "\C-c\C-b" gnus-bug
- "R" gnus-article-reply-with-original
- "F" gnus-article-followup-with-original
- "\C-hk" gnus-article-describe-key
- "\C-hc" gnus-article-describe-key-briefly
- "\C-hb" gnus-article-describe-bindings
-
- "e" gnus-article-read-summary-keys
- "\C-d" gnus-article-read-summary-keys
- "\C-c\C-f" gnus-summary-mail-forward
- "\M-*" gnus-article-read-summary-keys
- "\M-#" gnus-article-read-summary-keys
- "\M-^" gnus-article-read-summary-keys
- "\M-g" gnus-article-read-summary-keys)
+(defvar gnus-article-send-map nil)
+
+(define-keymap :keymap gnus-article-mode-map :suppress t
+ :parent button-buffer-map
+ "SPC" #'gnus-article-goto-next-page
+ "S-SPC" #'gnus-article-goto-prev-page
+ "DEL" #'gnus-article-goto-prev-page
+ "<delete>" #'gnus-article-goto-prev-page
+ "C-c ^" #'gnus-article-refer-article
+ "h" #'gnus-article-show-summary
+ "s" #'gnus-article-show-summary
+ "C-c C-m" #'gnus-article-mail
+ "?" #'gnus-article-describe-briefly
+ "<" #'beginning-of-buffer
+ ">" #'end-of-buffer
+ "C-c C-i" #'gnus-info-find-node
+ "C-c C-b" #'gnus-bug
+ "R" #'gnus-article-reply-with-original
+ "F" #'gnus-article-followup-with-original
+ "C-h k" #'gnus-article-describe-key
+ "C-h c" #'gnus-article-describe-key-briefly
+ "C-h b" #'gnus-article-describe-bindings
+
+ "e" #'gnus-article-read-summary-keys
+ "C-d" #'gnus-article-read-summary-keys
+ "C-c C-f" #'gnus-summary-mail-forward
+ "M-*" #'gnus-article-read-summary-keys
+ "M-#" #'gnus-article-read-summary-keys
+ "M-^" #'gnus-article-read-summary-keys
+ "M-g" #'gnus-article-read-summary-keys
+
+ "S" (define-keymap :prefix 'gnus-article-send-map
+ "W" #'gnus-article-wide-reply-with-original
+ "<t>" #'gnus-article-read-summary-send-keys))
(substitute-key-definition
#'undefined #'gnus-article-read-summary-keys gnus-article-mode-map)
-(defvar gnus-article-send-map)
-(gnus-define-keys (gnus-article-send-map "S" gnus-article-mode-map)
- "W" gnus-article-wide-reply-with-original
- [t] gnus-article-read-summary-send-keys)
-
(defun gnus-article-make-menu-bar ()
(unless (boundp 'gnus-article-commands-menu)
(gnus-summary-make-menu-bar))
@@ -4449,6 +4498,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is
["Treat overstrike" gnus-article-treat-overstrike t]
["Treat ANSI sequences" gnus-article-treat-ansi-sequences t]
["Remove carriage return" gnus-article-remove-cr t]
+ ["Emojize Symbols" gnus-article-emojize-symbols t]
["Remove leading whitespace" gnus-article-remove-leading-whitespace t]
["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
["Remove base64" gnus-article-de-base64-unreadable t]
@@ -4509,7 +4559,8 @@ commands:
(setq show-trailing-whitespace nil)
;; Arrange a callback from `mm-inline-message' if we're
;; displaying a message/rfc822 part.
- (setq-local mm-inline-message-prepare-function #'gnus-mime--inline-message)
+ (setq-local mm-inline-message-prepare-function
+ #'gnus-mime--inline-message-function)
(mm-enable-multibyte))
(defun gnus-article-setup-buffer ()
@@ -4549,7 +4600,6 @@ commands:
(let ((summary gnus-summary-buffer))
(with-current-buffer name
(setq-local gnus-article-edit-mode nil)
- (gnus-article-stop-animations)
(when gnus-article-mime-handles
(mm-destroy-parts gnus-article-mime-handles)
(setq gnus-article-mime-handles nil))
@@ -4575,6 +4625,7 @@ commands:
(current-buffer))))))
(defun gnus-article-stop-animations ()
+ (declare (obsolete nil "29.1"))
(cancel-function-timers 'image-animate-timeout))
(defun gnus-stop-downloads ()
@@ -6045,7 +6096,7 @@ If nil, don't show those extra buttons."
(defun gnus-mime-display-mixed (handles)
(mapcar #'gnus-mime-display-part handles))
-(defun gnus-mime--inline-message (handle charset)
+(defun gnus-mime--inline-message-function (handle charset)
(let ((handles
(let (gnus-article-mime-handles
;; disable prepare hook
@@ -7222,50 +7273,42 @@ other groups."
(defvar gnus-article-edit-done-function nil)
-(defvar gnus-article-edit-mode-map nil)
-
-;; Should we be using derived.el for this?
-(unless gnus-article-edit-mode-map
- (setq gnus-article-edit-mode-map (make-keymap))
- (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
-
- (gnus-define-keys gnus-article-edit-mode-map
- "\C-c?" describe-mode
- "\C-c\C-c" gnus-article-edit-done
- "\C-c\C-k" gnus-article-edit-exit
- "\C-c\C-f\C-t" message-goto-to
- "\C-c\C-f\C-o" message-goto-from
- "\C-c\C-f\C-b" message-goto-bcc
- ;;"\C-c\C-f\C-w" message-goto-fcc
- "\C-c\C-f\C-c" message-goto-cc
- "\C-c\C-f\C-s" message-goto-subject
- "\C-c\C-f\C-r" message-goto-reply-to
- "\C-c\C-f\C-n" message-goto-newsgroups
- "\C-c\C-f\C-d" message-goto-distribution
- "\C-c\C-f\C-f" message-goto-followup-to
- "\C-c\C-f\C-m" message-goto-mail-followup-to
- "\C-c\C-f\C-k" message-goto-keywords
- "\C-c\C-f\C-u" message-goto-summary
- "\C-c\C-f\C-i" message-insert-or-toggle-importance
- "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to
- "\C-c\C-b" message-goto-body
- "\C-c\C-i" message-goto-signature
-
- "\C-c\C-t" message-insert-to
- "\C-c\C-n" message-insert-newsgroups
- "\C-c\C-o" message-sort-headers
- "\C-c\C-e" message-elide-region
- "\C-c\C-v" message-delete-not-region
- "\C-c\C-z" message-kill-to-signature
- "\M-\r" message-newline-and-reformat
- "\C-c\C-a" mml-attach-file
- "\C-a" message-beginning-of-line
- "\t" message-tab
- "\M-;" comment-region)
-
- (gnus-define-keys (gnus-article-edit-wash-map
- "\C-c\C-w" gnus-article-edit-mode-map)
- "f" gnus-article-edit-full-stops))
+(defvar-keymap gnus-article-edit-mode-map
+ :full t :parent text-mode-map
+ "C-c ?" #'describe-mode
+ "C-c C-c" #'gnus-article-edit-done
+ "C-c C-k" #'gnus-article-edit-exit
+ "C-c C-f C-t" #'message-goto-to
+ "C-c C-f C-o" #'message-goto-from
+ "C-c C-f C-b" #'message-goto-bcc
+ "C-c C-f C-c" #'message-goto-cc
+ "C-c C-f C-s" #'message-goto-subject
+ "C-c C-f C-r" #'message-goto-reply-to
+ "C-c C-f C-n" #'message-goto-newsgroups
+ "C-c C-f C-d" #'message-goto-distribution
+ "C-c C-f C-f" #'message-goto-followup-to
+ "C-c C-f RET" #'message-goto-mail-followup-to
+ "C-c C-f C-k" #'message-goto-keywords
+ "C-c C-f C-u" #'message-goto-summary
+ "C-c C-f TAB" #'message-insert-or-toggle-importance
+ "C-c C-f C-a" #'message-generate-unsubscribed-mail-followup-to
+ "C-c C-b" #'message-goto-body
+ "C-c TAB" #'message-goto-signature
+
+ "C-c C-t" #'message-insert-to
+ "C-c C-n" #'message-insert-newsgroups
+ "C-c C-o" #'message-sort-headers
+ "C-c C-e" #'message-elide-region
+ "C-c C-v" #'message-delete-not-region
+ "C-c C-z" #'message-kill-to-signature
+ "M-RET" #'message-newline-and-reformat
+ "C-c C-a" #'mml-attach-file
+ "C-a" #'message-beginning-of-line
+ "TAB" #'message-tab
+ "M-;" #'comment-region
+
+ "C-c C-w" (define-keymap :prefix 'gnus-article-edit-wash-map
+ "f" #'gnus-article-edit-full-stops))
(easy-menu-define
gnus-article-edit-mode-field-menu gnus-article-edit-mode-map ""
diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el
index 83e482f14c1..e9696b66a9f 100644
--- a/lisp/gnus/gnus-bookmark.el
+++ b/lisp/gnus/gnus-bookmark.el
@@ -418,32 +418,29 @@ That is, all information but the name."
(defvar gnus-bookmark-bmenu-bookmark-column nil)
(defvar gnus-bookmark-bmenu-hidden-bookmarks ())
-(defvar gnus-bookmark-bmenu-mode-map nil)
-
-(if gnus-bookmark-bmenu-mode-map
- nil
- (setq gnus-bookmark-bmenu-mode-map (make-keymap))
- (suppress-keymap gnus-bookmark-bmenu-mode-map t)
- (define-key gnus-bookmark-bmenu-mode-map "q" 'quit-window)
- (define-key gnus-bookmark-bmenu-mode-map "\C-m" 'gnus-bookmark-bmenu-select)
- (define-key gnus-bookmark-bmenu-mode-map "v" 'gnus-bookmark-bmenu-select)
- (define-key gnus-bookmark-bmenu-mode-map "d" 'gnus-bookmark-bmenu-delete)
- (define-key gnus-bookmark-bmenu-mode-map "k" 'gnus-bookmark-bmenu-delete)
- (define-key gnus-bookmark-bmenu-mode-map "\C-d" 'gnus-bookmark-bmenu-delete-backwards)
- (define-key gnus-bookmark-bmenu-mode-map "x" 'gnus-bookmark-bmenu-execute-deletions)
- (define-key gnus-bookmark-bmenu-mode-map " " 'next-line)
- (define-key gnus-bookmark-bmenu-mode-map "n" 'next-line)
- (define-key gnus-bookmark-bmenu-mode-map "p" 'previous-line)
- (define-key gnus-bookmark-bmenu-mode-map "\177" 'gnus-bookmark-bmenu-backup-unmark)
- (define-key gnus-bookmark-bmenu-mode-map "?" 'describe-mode)
- (define-key gnus-bookmark-bmenu-mode-map "u" 'gnus-bookmark-bmenu-unmark)
- (define-key gnus-bookmark-bmenu-mode-map "m" 'gnus-bookmark-bmenu-mark)
- (define-key gnus-bookmark-bmenu-mode-map "l" 'gnus-bookmark-bmenu-load)
- (define-key gnus-bookmark-bmenu-mode-map "s" 'gnus-bookmark-bmenu-save)
- (define-key gnus-bookmark-bmenu-mode-map "t" 'gnus-bookmark-bmenu-toggle-infos)
- (define-key gnus-bookmark-bmenu-mode-map "a" 'gnus-bookmark-bmenu-show-details)
- (define-key gnus-bookmark-bmenu-mode-map [mouse-2]
- 'gnus-bookmark-bmenu-select-by-mouse))
+
+(defvar-keymap gnus-bookmark-bmenu-mode-map
+ :full t
+ :suppress 'nodigits
+ "q" #'quit-window
+ "RET" #'gnus-bookmark-bmenu-select
+ "v" #'gnus-bookmark-bmenu-select
+ "d" #'gnus-bookmark-bmenu-delete
+ "k" #'gnus-bookmark-bmenu-delete
+ "C-d" #'gnus-bookmark-bmenu-delete-backwards
+ "x" #'gnus-bookmark-bmenu-execute-deletions
+ "SPC" #'next-line
+ "n" #'next-line
+ "p" #'previous-line
+ "DEL" #'gnus-bookmark-bmenu-backup-unmark
+ "?" #'describe-mode
+ "u" #'gnus-bookmark-bmenu-unmark
+ "m" #'gnus-bookmark-bmenu-mark
+ "l" #'gnus-bookmark-bmenu-load
+ "s" #'gnus-bookmark-bmenu-save
+ "t" #'gnus-bookmark-bmenu-toggle-infos
+ "a" #'gnus-bookmark-bmenu-show-details
+ "<mouse-2>" #'gnus-bookmark-bmenu-select-by-mouse)
;; Bookmark Buffer Menu mode is suitable only for specially formatted
;; data.
diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el
index e9eddae942f..00769a5da6e 100644
--- a/lisp/gnus/gnus-dired.el
+++ b/lisp/gnus/gnus-dired.el
@@ -53,12 +53,10 @@
(autoload 'message-buffers "message")
(autoload 'gnus-print-buffer "gnus-sum")
-(defvar gnus-dired-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-m\C-a" 'gnus-dired-attach)
- (define-key map "\C-c\C-m\C-l" 'gnus-dired-find-file-mailcap)
- (define-key map "\C-c\C-m\C-p" 'gnus-dired-print)
- map))
+(defvar-keymap gnus-dired-mode-map
+ "C-c C-m C-a" #'gnus-dired-attach
+ "C-c C-m C-l" #'gnus-dired-find-file-mailcap
+ "C-c C-m C-p" #'gnus-dired-print)
;; FIXME: Make it customizable, change the default to `mail-user-agent' when
;; this file is renamed (e.g. to `dired-mime.el').
@@ -206,7 +204,8 @@ If ARG is non-nil, open it in a new buffer."
(find-file file-name)))
(if (file-symlink-p file-name)
(error "File is a symlink to a nonexistent target")
- (error "File no longer exists; type `g' to update Dired buffer"))))
+ (error (substitute-command-keys
+ "File no longer exists; type \\`g' to update Dired buffer")))))
(defun gnus-dired-print (&optional file-name print-to)
"In dired, print FILE-NAME according to the mailcap file.
@@ -246,9 +245,10 @@ of the file to save in."
(error "MIME print only implemented via Gnus")))
(ps-despool print-to))))
((file-symlink-p file-name)
- (error "File is a symlink to a nonexistent target"))
- (t
- (error "File no longer exists; type `g' to update Dired buffer"))))
+ (error "File is a symlink to a nonexistent target"))
+ (t
+ (error (substitute-command-keys
+ "File no longer exists; type \\`g' to update Dired buffer")))))
(provide 'gnus-dired)
diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el
index 9a0f21359f8..7c56db0ba45 100644
--- a/lisp/gnus/gnus-draft.el
+++ b/lisp/gnus/gnus-draft.el
@@ -33,15 +33,12 @@
;;; Draft minor mode
-(defvar gnus-draft-mode-map
- (let ((map (make-sparse-keymap)))
- (gnus-define-keys map
- "Dt" gnus-draft-toggle-sending
- "e" gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article'
- "De" gnus-draft-edit-message
- "Ds" gnus-draft-send-message
- "DS" gnus-draft-send-all-messages)
- map))
+(defvar-keymap gnus-draft-mode-map
+ "D t" #'gnus-draft-toggle-sending
+ "e" #' gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article'
+ "D e" #'gnus-draft-edit-message
+ "D s" #'gnus-draft-send-message
+ "D S" #'gnus-draft-send-all-messages)
(defun gnus-draft-make-menu-bar ()
(unless (boundp 'gnus-draft-menu)
diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el
index 3fd8bf51de4..c727926731b 100644
--- a/lisp/gnus/gnus-eform.el
+++ b/lisp/gnus/gnus-eform.el
@@ -48,13 +48,10 @@
(defvar gnus-edit-form-buffer "*Gnus edit form*")
(defvar gnus-edit-form-done-function nil)
-(defvar gnus-edit-form-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map emacs-lisp-mode-map)
- (gnus-define-keys map
- "\C-c\C-c" gnus-edit-form-done
- "\C-c\C-k" gnus-edit-form-exit)
- map))
+(defvar-keymap gnus-edit-form-mode-map
+ :parent emacs-lisp-mode-map
+ "C-c C-c" #'gnus-edit-form-done
+ "C-c C-k" #'gnus-edit-form-exit)
(defun gnus-edit-form-make-menu-bar ()
(unless (boundp 'gnus-edit-form-menu)
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index b1e486b0627..2ec001faee7 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -62,7 +62,7 @@
(defcustom gnus-keep-same-level nil
"Non-nil means that the newsgroup after this one will be on the same level.
-When you type, for instance, `n' after reading the last article in the
+When you type, for instance, \\`n' after reading the last article in the
current newsgroup, you will go to the next newsgroup. If this variable
is nil, the next newsgroup will be the next from the group
buffer.
@@ -573,209 +573,209 @@ simple manner."
;;; Gnus group mode
;;;
-(gnus-define-keys gnus-group-mode-map
- " " gnus-group-read-group
- "=" gnus-group-select-group
- "\r" gnus-group-select-group
- "\M-\r" gnus-group-quick-select-group
- "\M- " gnus-group-visible-select-group
- [(meta control return)] gnus-group-select-group-ephemerally
- "j" gnus-group-jump-to-group
- "n" gnus-group-next-unread-group
- "p" gnus-group-prev-unread-group
- "\177" gnus-group-prev-unread-group
- [delete] gnus-group-prev-unread-group
- "N" gnus-group-next-group
- "P" gnus-group-prev-group
- "\M-n" gnus-group-next-unread-group-same-level
- "\M-p" gnus-group-prev-unread-group-same-level
- "," gnus-group-best-unread-group
- "." gnus-group-first-unread-group
- "u" gnus-group-toggle-subscription-at-point
- "U" gnus-group-toggle-subscription
- "c" gnus-group-catchup-current
- "C" gnus-group-catchup-current-all
- "\M-c" gnus-group-clear-data
- "l" gnus-group-list-groups
- "L" gnus-group-list-all-groups
- "m" gnus-group-mail
- "i" gnus-group-news
- "g" gnus-group-get-new-news
- "\M-g" gnus-group-get-new-news-this-group
- "R" gnus-group-restart
- "r" gnus-group-read-init-file
- "B" gnus-group-browse-foreign-server
- "b" gnus-group-check-bogus-groups
- "F" gnus-group-find-new-groups
- "\C-c\C-d" gnus-group-describe-group
- "\M-d" gnus-group-describe-all-groups
- "\C-c\C-a" gnus-group-apropos
- "\C-c\M-\C-a" gnus-group-description-apropos
- "a" gnus-group-post-news
- "\ek" gnus-group-edit-local-kill
- "\eK" gnus-group-edit-global-kill
- "\C-k" gnus-group-kill-group
- "\C-y" gnus-group-yank-group
- "\C-w" gnus-group-kill-region
- "\C-x\C-t" gnus-group-transpose-groups
- "\C-c\C-l" gnus-group-list-killed
- "\C-c\C-x" gnus-group-expire-articles
- "\C-c\M-\C-x" gnus-group-expire-all-groups
- "V" gnus-version
- "s" gnus-group-save-newsrc
- "z" gnus-group-suspend
- "q" gnus-group-exit
- "Q" gnus-group-quit
- "?" gnus-group-describe-briefly
- "\C-c\C-i" gnus-info-find-node
- "\M-e" gnus-group-edit-group-method
- "^" gnus-group-enter-server-mode
- [mouse-2] gnus-mouse-pick-group
- [follow-link] mouse-face
- "<" beginning-of-buffer
- ">" end-of-buffer
- "\C-c\C-b" gnus-bug
- "\C-c\C-s" gnus-group-sort-groups
- "t" gnus-topic-mode
- "\C-c\M-g" gnus-activate-all-groups
- "\M-&" gnus-group-universal-argument
- "#" gnus-group-mark-group
- "\M-#" gnus-group-unmark-group)
-
-(gnus-define-keys (gnus-group-cloud-map "~" gnus-group-mode-map)
- "u" gnus-cloud-upload-all-data
- "~" gnus-cloud-upload-all-data
- "d" gnus-cloud-download-all-data
- "\r" gnus-cloud-download-all-data)
-
-(gnus-define-keys (gnus-group-mark-map "M" gnus-group-mode-map)
- "m" gnus-group-mark-group
- "u" gnus-group-unmark-group
- "w" gnus-group-mark-region
- "b" gnus-group-mark-buffer
- "r" gnus-group-mark-regexp
- "U" gnus-group-unmark-all-groups)
-
-(gnus-define-keys (gnus-group-sieve-map "D" gnus-group-mode-map)
- "u" gnus-sieve-update
- "g" gnus-sieve-generate)
-
-(gnus-define-keys (gnus-group-group-map "G" gnus-group-mode-map)
- "d" gnus-group-make-directory-group
- "h" gnus-group-make-help-group
- "u" gnus-group-make-useful-group
- "l" gnus-group-nnimap-edit-acl
- "m" gnus-group-make-group
- "E" gnus-group-edit-group
- "e" gnus-group-edit-group-method
- "p" gnus-group-edit-group-parameters
- "v" gnus-group-add-to-virtual
- "V" gnus-group-make-empty-virtual
- "D" gnus-group-enter-directory
- "f" gnus-group-make-doc-group
- "w" gnus-group-make-web-group
- "G" gnus-group-read-ephemeral-search-group
- "g" gnus-group-make-search-group
- "M" gnus-group-read-ephemeral-group
- "r" gnus-group-rename-group
- "R" gnus-group-make-rss-group
- "c" gnus-group-customize
- "z" gnus-group-compact-group
- "x" gnus-group-expunge-group
- "\177" gnus-group-delete-group
- [delete] gnus-group-delete-group)
-
-(gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map)
- "s" gnus-group-sort-groups
- "a" gnus-group-sort-groups-by-alphabet
- "u" gnus-group-sort-groups-by-unread
- "l" gnus-group-sort-groups-by-level
- "v" gnus-group-sort-groups-by-score
- "r" gnus-group-sort-groups-by-rank
- "m" gnus-group-sort-groups-by-method
- "n" gnus-group-sort-groups-by-real-name)
-
-(gnus-define-keys (gnus-group-sort-selected-map "P" gnus-group-group-map)
- "s" gnus-group-sort-selected-groups
- "a" gnus-group-sort-selected-groups-by-alphabet
- "u" gnus-group-sort-selected-groups-by-unread
- "l" gnus-group-sort-selected-groups-by-level
- "v" gnus-group-sort-selected-groups-by-score
- "r" gnus-group-sort-selected-groups-by-rank
- "m" gnus-group-sort-selected-groups-by-method
- "n" gnus-group-sort-selected-groups-by-real-name)
-
-(gnus-define-keys (gnus-group-list-map "A" gnus-group-mode-map)
- "k" gnus-group-list-killed
- "z" gnus-group-list-zombies
- "s" gnus-group-list-groups
- "u" gnus-group-list-all-groups
- "A" gnus-group-list-active
- "a" gnus-group-apropos
- "d" gnus-group-description-apropos
- "m" gnus-group-list-matching
- "M" gnus-group-list-all-matching
- "l" gnus-group-list-level
- "c" gnus-group-list-cached
- "?" gnus-group-list-dormant
- "!" gnus-group-list-ticked)
-
-(gnus-define-keys (gnus-group-list-limit-map "/" gnus-group-list-map)
- "k" gnus-group-list-limit
- "z" gnus-group-list-limit
- "s" gnus-group-list-limit
- "u" gnus-group-list-limit
- "A" gnus-group-list-limit
- "m" gnus-group-list-limit
- "M" gnus-group-list-limit
- "l" gnus-group-list-limit
- "c" gnus-group-list-limit
- "?" gnus-group-list-limit
- "!" gnus-group-list-limit)
-
-(gnus-define-keys (gnus-group-list-flush-map "f" gnus-group-list-map)
- "k" gnus-group-list-flush
- "z" gnus-group-list-flush
- "s" gnus-group-list-flush
- "u" gnus-group-list-flush
- "A" gnus-group-list-flush
- "m" gnus-group-list-flush
- "M" gnus-group-list-flush
- "l" gnus-group-list-flush
- "c" gnus-group-list-flush
- "?" gnus-group-list-flush
- "!" gnus-group-list-flush)
-
-(gnus-define-keys (gnus-group-list-plus-map "p" gnus-group-list-map)
- "k" gnus-group-list-plus
- "z" gnus-group-list-plus
- "s" gnus-group-list-plus
- "u" gnus-group-list-plus
- "A" gnus-group-list-plus
- "m" gnus-group-list-plus
- "M" gnus-group-list-plus
- "l" gnus-group-list-plus
- "c" gnus-group-list-plus
- "?" gnus-group-list-plus
- "!" gnus-group-list-plus)
-
-(gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map)
- "f" gnus-score-flush-cache
- "e" gnus-score-edit-all-score)
-
-(gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map)
- "d" gnus-group-describe-group
- "v" gnus-version)
-
-(gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map)
- "l" gnus-group-set-current-level
- "t" gnus-group-toggle-subscription-at-point
- "s" gnus-group-toggle-subscription
- "k" gnus-group-kill-group
- "y" gnus-group-yank-group
- "w" gnus-group-kill-region
- "\C-k" gnus-group-kill-level
- "z" gnus-group-kill-all-zombies)
+(define-keymap :keymap gnus-group-mode-map
+ "SPC" #'gnus-group-read-group
+ "=" #'gnus-group-select-group
+ "RET" #'gnus-group-select-group
+ "M-RET" #'gnus-group-quick-select-group
+ "M-SPC" #'gnus-group-visible-select-group
+ "C-M-<return>" #'gnus-group-select-group-ephemerally
+ "j" #'gnus-group-jump-to-group
+ "n" #'gnus-group-next-unread-group
+ "p" #'gnus-group-prev-unread-group
+ "DEL" #'gnus-group-prev-unread-group
+ "<delete>" #'gnus-group-prev-unread-group
+ "N" #'gnus-group-next-group
+ "P" #'gnus-group-prev-group
+ "M-n" #'gnus-group-next-unread-group-same-level
+ "M-p" #'gnus-group-prev-unread-group-same-level
+ "," #'gnus-group-best-unread-group
+ "." #'gnus-group-first-unread-group
+ "u" #'gnus-group-toggle-subscription-at-point
+ "U" #'gnus-group-toggle-subscription
+ "c" #'gnus-group-catchup-current
+ "C" #'gnus-group-catchup-current-all
+ "M-c" #'gnus-group-clear-data
+ "l" #'gnus-group-list-groups
+ "L" #'gnus-group-list-all-groups
+ "m" #'gnus-group-mail
+ "i" #'gnus-group-news
+ "g" #'gnus-group-get-new-news
+ "M-g" #'gnus-group-get-new-news-this-group
+ "R" #'gnus-group-restart
+ "r" #'gnus-group-read-init-file
+ "B" #'gnus-group-browse-foreign-server
+ "b" #'gnus-group-check-bogus-groups
+ "F" #'gnus-group-find-new-groups
+ "C-c C-d" #'gnus-group-describe-group
+ "M-d" #'gnus-group-describe-all-groups
+ "C-c C-a" #'gnus-group-apropos
+ "C-c C-M-a" #'gnus-group-description-apropos
+ "a" #'gnus-group-post-news
+ "ESC k" #'gnus-group-edit-local-kill
+ "ESC K" #'gnus-group-edit-global-kill
+ "C-k" #'gnus-group-kill-group
+ "C-y" #'gnus-group-yank-group
+ "C-w" #'gnus-group-kill-region
+ "C-x C-t" #'gnus-group-transpose-groups
+ "C-c C-l" #'gnus-group-list-killed
+ "C-c C-x" #'gnus-group-expire-articles
+ "C-c C-M-x" #'gnus-group-expire-all-groups
+ "V" #'gnus-version
+ "s" #'gnus-group-save-newsrc
+ "z" #'gnus-group-suspend
+ "q" #'gnus-group-exit
+ "Q" #'gnus-group-quit
+ "?" #'gnus-group-describe-briefly
+ "C-c C-i" #'gnus-info-find-node
+ "M-e" #'gnus-group-edit-group-method
+ "^" #'gnus-group-enter-server-mode
+ "<mouse-2>" #'gnus-mouse-pick-group
+ "<follow-link>" 'mouse-face
+ "<" #'beginning-of-buffer
+ ">" #'end-of-buffer
+ "C-c C-b" #'gnus-bug
+ "C-c C-s" #'gnus-group-sort-groups
+ "t" #'gnus-topic-mode
+ "C-c M-g" #'gnus-activate-all-groups
+ "M-&" #'gnus-group-universal-argument
+ "#" #'gnus-group-mark-group
+ "M-#" #'gnus-group-unmark-group
+
+ "~" (define-keymap :prefix 'gnus-group-cloud-map
+ "u" #'gnus-cloud-upload-all-data
+ "~" #'gnus-cloud-upload-all-data
+ "d" #'gnus-cloud-download-all-data
+ "RET" #'gnus-cloud-download-all-data)
+
+ "M" (define-keymap :prefix 'gnus-group-mark-map
+ "m" #'gnus-group-mark-group
+ "u" #'gnus-group-unmark-group
+ "w" #'gnus-group-mark-region
+ "b" #'gnus-group-mark-buffer
+ "r" #'gnus-group-mark-regexp
+ "U" #'gnus-group-unmark-all-groups)
+
+ "D" (define-keymap :prefix 'gnus-group-sieve-map
+ "u" #'gnus-sieve-update
+ "g" #'gnus-sieve-generate)
+
+ "G" (define-keymap :prefix 'gnus-group-group-map
+ "d" #'gnus-group-make-directory-group
+ "h" #'gnus-group-make-help-group
+ "u" #'gnus-group-make-useful-group
+ "l" #'gnus-group-nnimap-edit-acl
+ "m" #'gnus-group-make-group
+ "E" #'gnus-group-edit-group
+ "e" #'gnus-group-edit-group-method
+ "p" #'gnus-group-edit-group-parameters
+ "v" #'gnus-group-add-to-virtual
+ "V" #'gnus-group-make-empty-virtual
+ "D" #'gnus-group-enter-directory
+ "f" #'gnus-group-make-doc-group
+ "w" #'gnus-group-make-web-group
+ "G" #'gnus-group-read-ephemeral-search-group
+ "g" #'gnus-group-make-search-group
+ "M" #'gnus-group-read-ephemeral-group
+ "r" #'gnus-group-rename-group
+ "R" #'gnus-group-make-rss-group
+ "c" #'gnus-group-customize
+ "z" #'gnus-group-compact-group
+ "x" #'gnus-group-expunge-group
+ "DEL" #'gnus-group-delete-group
+ "<delete>" #'gnus-group-delete-group
+
+ "S" (define-keymap :prefix 'gnus-group-sort-map
+ "s" #'gnus-group-sort-groups
+ "a" #'gnus-group-sort-groups-by-alphabet
+ "u" #'gnus-group-sort-groups-by-unread
+ "l" #'gnus-group-sort-groups-by-level
+ "v" #'gnus-group-sort-groups-by-score
+ "r" #'gnus-group-sort-groups-by-rank
+ "m" #'gnus-group-sort-groups-by-method
+ "n" #'gnus-group-sort-groups-by-real-name)
+
+ "P" (define-keymap :prefix 'gnus-group-sort-selected-map
+ "s" #'gnus-group-sort-selected-groups
+ "a" #'gnus-group-sort-selected-groups-by-alphabet
+ "u" #'gnus-group-sort-selected-groups-by-unread
+ "l" #'gnus-group-sort-selected-groups-by-level
+ "v" #'gnus-group-sort-selected-groups-by-score
+ "r" #'gnus-group-sort-selected-groups-by-rank
+ "m" #'gnus-group-sort-selected-groups-by-method
+ "n" #'gnus-group-sort-selected-groups-by-real-name))
+
+ "A" (define-keymap :prefix 'gnus-group-list-map
+ "k" #'gnus-group-list-killed
+ "z" #'gnus-group-list-zombies
+ "s" #'gnus-group-list-groups
+ "u" #'gnus-group-list-all-groups
+ "A" #'gnus-group-list-active
+ "a" #'gnus-group-apropos
+ "d" #'gnus-group-description-apropos
+ "m" #'gnus-group-list-matching
+ "M" #'gnus-group-list-all-matching
+ "l" #'gnus-group-list-level
+ "c" #'gnus-group-list-cached
+ "?" #'gnus-group-list-dormant
+ "!" #'gnus-group-list-ticked
+
+ "/" (define-keymap :prefix 'gnus-group-list-limit-map
+ "k" #'gnus-group-list-limit
+ "z" #'gnus-group-list-limit
+ "s" #'gnus-group-list-limit
+ "u" #'gnus-group-list-limit
+ "A" #'gnus-group-list-limit
+ "m" #'gnus-group-list-limit
+ "M" #'gnus-group-list-limit
+ "l" #'gnus-group-list-limit
+ "c" #'gnus-group-list-limit
+ "?" #'gnus-group-list-limit
+ "!" #'gnus-group-list-limit)
+
+ "f" (define-keymap :prefix 'gnus-group-list-flush-map
+ "k" #'gnus-group-list-flush
+ "z" #'gnus-group-list-flush
+ "s" #'gnus-group-list-flush
+ "u" #'gnus-group-list-flush
+ "A" #'gnus-group-list-flush
+ "m" #'gnus-group-list-flush
+ "M" #'gnus-group-list-flush
+ "l" #'gnus-group-list-flush
+ "c" #'gnus-group-list-flush
+ "?" #'gnus-group-list-flush
+ "!" #'gnus-group-list-flush)
+
+ "p" (define-keymap :prefix 'gnus-group-list-plus-map
+ "k" #'gnus-group-list-plus
+ "z" #'gnus-group-list-plus
+ "s" #'gnus-group-list-plus
+ "u" #'gnus-group-list-plus
+ "A" #'gnus-group-list-plus
+ "m" #'gnus-group-list-plus
+ "M" #'gnus-group-list-plus
+ "l" #'gnus-group-list-plus
+ "c" #'gnus-group-list-plus
+ "?" #'gnus-group-list-plus
+ "!" #'gnus-group-list-plus))
+
+ "W" (define-keymap :prefix 'gnus-group-score-map
+ "f" #'gnus-score-flush-cache
+ "e" #'gnus-score-edit-all-score)
+
+ "H" (define-keymap :prefix 'gnus-group-help-map
+ "d" #'gnus-group-describe-group
+ "v" #'gnus-version)
+
+ "S" (define-keymap :prefix 'gnus-group-sub-map
+ "l" #'gnus-group-set-current-level
+ "t" #'gnus-group-toggle-subscription-at-point
+ "s" #'gnus-group-toggle-subscription
+ "k" #'gnus-group-kill-group
+ "y" #'gnus-group-yank-group
+ "w" #'gnus-group-kill-region
+ "C-k" #'gnus-group-kill-level
+ "z" #'gnus-group-kill-all-zombies))
(defun gnus-topic-mode-p ()
"Return non-nil in `gnus-topic-mode'."
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
index be62bfd81f5..ef376f138e7 100644
--- a/lisp/gnus/gnus-html.el
+++ b/lisp/gnus/gnus-html.el
@@ -71,21 +71,17 @@ fit these criteria."
:group 'gnus-art
:type 'float)
-(defvar gnus-html-image-map
- (let ((map (make-sparse-keymap)))
- (define-key map "u" 'gnus-article-copy-string)
- (define-key map "i" 'gnus-html-insert-image)
- (define-key map "v" 'gnus-html-browse-url)
- map))
-
-(defvar gnus-html-displayed-image-map
- (let ((map (make-sparse-keymap)))
- (define-key map "a" 'gnus-html-show-alt-text)
- (define-key map "i" 'gnus-html-browse-image)
- (define-key map "\r" 'gnus-html-browse-url)
- (define-key map "u" 'gnus-article-copy-string)
- (define-key map [tab] 'button-forward)
- map))
+(defvar-keymap gnus-html-image-map
+ "u" #'gnus-article-copy-string
+ "i" #'gnus-html-insert-image
+ "v" #'gnus-html-browse-url)
+
+(defvar-keymap gnus-html-displayed-image-map
+ "a" #'gnus-html-show-alt-text
+ "i" #'gnus-html-browse-image
+ "RET" #'gnus-html-browse-url
+ "u" #'gnus-article-copy-string
+ "<tab>" #'forward-button)
(defun gnus-html-encode-url (url)
"Encode URL."
diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el
index b6e5e7f786a..81e46d7a51e 100644
--- a/lisp/gnus/gnus-icalendar.el
+++ b/lisp/gnus/gnus-icalendar.el
@@ -194,7 +194,11 @@
(caddr event))))
(cl-labels
- ((attendee-role (prop) (plist-get (cadr prop) 'ROLE))
+ ((attendee-role (prop)
+ ;; RFC5546: default ROLE is REQ-PARTICIPANT
+ (and prop
+ (or (plist-get (cadr prop) 'ROLE)
+ "REQ-PARTICIPANT")))
(attendee-name
(prop)
(or (plist-get (cadr prop) 'CN)
@@ -225,7 +229,10 @@
(gnus-icalendar-event--find-attendee
ical attendee-name-or-email)))
(attendee-names (gnus-icalendar-event--get-attendee-names ical))
- (role (plist-get (cadr attendee) 'ROLE))
+ ;; RFC5546: default ROLE is REQ-PARTICIPANT
+ (role (and attendee
+ (or (plist-get (cadr attendee) 'ROLE)
+ "REQ-PARTICIPANT")))
(participation-type (pcase role
("REQ-PARTICIPANT" 'required)
("OPT-PARTICIPANT" 'optional)
@@ -345,10 +352,16 @@ status will be retrieved from the first matching attendee record."
(mapc #'process-event-line (split-string ical-request "\n"))
+ ;; RFC5546 refers to uninvited attendees as "party crashers".
+ ;; This situation is common if the invitation is sent to a group
+ ;; of people via a mailing list.
(unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x))
reply-event-lines)
(lwarn 'gnus-icalendar :warning
- "Could not find an event attendee matching given identity"))
+ "Could not find an event attendee matching given identity")
+ (push (format "ATTENDEE;RSVP=TRUE;PARTSTAT=%s;CN=%s:MAILTO:%s"
+ attendee-status user-full-name user-mail-address)
+ reply-event-lines))
(mapconcat #'identity `("BEGIN:VEVENT"
,@(nreverse reply-event-lines)
@@ -847,10 +860,14 @@ These will be used to retrieve the RSVP information from ical events."
button t
gnus-data ,data))))
-(defun gnus-icalendar-send-buffer-by-mail (buffer-name subject)
+(defun gnus-icalendar-send-buffer-by-mail (buffer-name subject organizer)
(let ((message-signature nil))
(with-current-buffer gnus-summary-buffer
(gnus-summary-reply)
+ ;; Reply to the organizer, not to whoever sent the invitation. person
+ ;; Some calendar systems use specific email address as organizer to
+ ;; receive these responses.
+ (message-replace-header "To" organizer)
(message-goto-body)
(mml-insert-multipart "alternative")
(mml-insert-empty-tag 'part 'type "text/plain")
@@ -866,7 +883,8 @@ These will be used to retrieve the RSVP information from ical events."
(event (caddr data))
(reply (gnus-icalendar-with-decoded-handle handle
(gnus-icalendar-event-reply-from-buffer
- (current-buffer) status (gnus-icalendar-identities)))))
+ (current-buffer) status (gnus-icalendar-identities))))
+ (organizer (gnus-icalendar-event:organizer event)))
(when reply
(cl-labels
@@ -883,7 +901,7 @@ These will be used to retrieve the RSVP information from ical events."
(delete-region (point-min) (point-max))
(insert reply)
(fold-icalendar-buffer)
- (gnus-icalendar-send-buffer-by-mail (buffer-name) subject))
+ (gnus-icalendar-send-buffer-by-mail (buffer-name) subject organizer))
;; Back in article buffer
(setq-local gnus-icalendar-reply-status status)
@@ -897,10 +915,16 @@ These will be used to retrieve the RSVP information from ical events."
(gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status))
(cl-defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event) handle)
- (when (gnus-icalendar-event:rsvp event)
- `(("Accept" gnus-icalendar-reply (,handle accepted ,event))
- ("Tentative" gnus-icalendar-reply (,handle tentative ,event))
- ("Decline" gnus-icalendar-reply (,handle declined ,event)))))
+ (let ((accept-btn "Accept")
+ (tentative-btn "Tentative")
+ (decline-btn "Decline"))
+ (unless (gnus-icalendar-event:rsvp event)
+ (setq accept-btn "Uninvited Accept"
+ tentative-btn "Uninvited Tentative"
+ decline-btn "Uninvited Decline"))
+ `((,accept-btn gnus-icalendar-reply (,handle accepted ,event))
+ (,tentative-btn gnus-icalendar-reply (,handle tentative ,event))
+ (,decline-btn gnus-icalendar-reply (,handle declined ,event)))))
(cl-defmethod gnus-icalendar-event:inline-reply-buttons ((_event gnus-icalendar-event-reply) _handle)
"No buttons for REPLY events."
@@ -1038,13 +1062,14 @@ These will be used to retrieve the RSVP information from ical events."
(add-to-list 'mm-automatic-display "text/calendar")
(add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity))
- (gnus-define-keys (gnus-summary-calendar-map "i" gnus-summary-mode-map)
- "a" gnus-icalendar-reply-accept
- "t" gnus-icalendar-reply-tentative
- "d" gnus-icalendar-reply-decline
- "c" gnus-icalendar-event-check-agenda
- "e" gnus-icalendar-event-export
- "s" gnus-icalendar-event-show)
+ (define-key gnus-summary-mode-map "i"
+ (define-keymap :prefix 'gnus-summary-calendar-map
+ "a" #'gnus-icalendar-reply-accept
+ "t" #'gnus-icalendar-reply-tentative
+ "d" #'gnus-icalendar-reply-decline
+ "c" #'gnus-icalendar-event-check-agenda
+ "e" #'gnus-icalendar-event-export
+ "s" #'gnus-icalendar-event-show))
(require 'gnus-art)
(add-to-list 'gnus-mime-action-alist
diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el
index 525823e72ce..7137efd7309 100644
--- a/lisp/gnus/gnus-kill.el
+++ b/lisp/gnus/gnus-kill.el
@@ -66,18 +66,15 @@ of time."
;;; Gnus Kill File Mode
;;;
-(defvar gnus-kill-file-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map emacs-lisp-mode-map)
- (gnus-define-keymap map
- "\C-c\C-k\C-s" gnus-kill-file-kill-by-subject
- "\C-c\C-k\C-a" gnus-kill-file-kill-by-author
- "\C-c\C-k\C-t" gnus-kill-file-kill-by-thread
- "\C-c\C-k\C-x" gnus-kill-file-kill-by-xref
- "\C-c\C-a" gnus-kill-file-apply-buffer
- "\C-c\C-e" gnus-kill-file-apply-last-sexp
- "\C-c\C-c" gnus-kill-file-exit)
- map))
+(defvar-keymap gnus-kill-file-mode-map
+ :parent emacs-lisp-mode-map
+ "C-c C-k C-s" #'gnus-kill-file-kill-by-subject
+ "C-c C-k C-a" #'gnus-kill-file-kill-by-author
+ "C-c C-k C-t" #'gnus-kill-file-kill-by-thread
+ "C-c C-k C-x" #'gnus-kill-file-kill-by-xref
+ "C-c C-a" #'gnus-kill-file-apply-buffer
+ "C-c C-e" #'gnus-kill-file-apply-last-sexp
+ "C-c C-c" #'gnus-kill-file-exit)
(define-derived-mode gnus-kill-file-mode emacs-lisp-mode "Kill"
"Major mode for editing kill files.
diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el
index ee3abf2f7be..a5358e9ff42 100644
--- a/lisp/gnus/gnus-ml.el
+++ b/lisp/gnus/gnus-ml.el
@@ -31,16 +31,13 @@
;;; Mailing list minor mode
-(defvar gnus-mailing-list-mode-map
- (let ((map (make-sparse-keymap)))
- (gnus-define-keys map
- "\C-c\C-nh" gnus-mailing-list-help
- "\C-c\C-ns" gnus-mailing-list-subscribe
- "\C-c\C-nu" gnus-mailing-list-unsubscribe
- "\C-c\C-np" gnus-mailing-list-post
- "\C-c\C-no" gnus-mailing-list-owner
- "\C-c\C-na" gnus-mailing-list-archive)
- map))
+(defvar-keymap gnus-mailing-list-mode-map
+ "C-c C-n h" #'gnus-mailing-list-help
+ "C-c C-n s" #'gnus-mailing-list-subscribe
+ "C-c C-n u" #'gnus-mailing-list-unsubscribe
+ "C-c C-n p" #'gnus-mailing-list-post
+ "C-c C-n o" #'gnus-mailing-list-owner
+ "C-c C-n a" #'gnus-mailing-list-archive)
(defvar gnus-mailing-list-menu)
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index 8a3272042f3..c60faa13263 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -349,39 +349,39 @@ only affect the Gcc copy, but not the original message."
;;; Gnus Posting Functions
;;;
-(gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map)
- "p" gnus-summary-post-news
- "i" gnus-summary-news-other-window
- "f" gnus-summary-followup
- "F" gnus-summary-followup-with-original
- "c" gnus-summary-cancel-article
- "s" gnus-summary-supersede-article
- "r" gnus-summary-reply
- "y" gnus-summary-yank-message
- "R" gnus-summary-reply-with-original
- "L" gnus-summary-reply-to-list-with-original
- "w" gnus-summary-wide-reply
- "W" gnus-summary-wide-reply-with-original
- "v" gnus-summary-very-wide-reply
- "V" gnus-summary-very-wide-reply-with-original
- "n" gnus-summary-followup-to-mail
- "N" gnus-summary-followup-to-mail-with-original
- "m" gnus-summary-mail-other-window
- "u" gnus-uu-post-news
- "A" gnus-summary-attach-article
- "\M-c" gnus-summary-mail-crosspost-complaint
- "Br" gnus-summary-reply-broken-reply-to
- "BR" gnus-summary-reply-broken-reply-to-with-original
- "om" gnus-summary-mail-forward
- "op" gnus-summary-post-forward
- "Om" gnus-uu-digest-mail-forward
- "Op" gnus-uu-digest-post-forward)
-
-(gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map)
- "b" gnus-summary-resend-bounced-mail
- ;; "c" gnus-summary-send-draft
- "r" gnus-summary-resend-message
- "e" gnus-summary-resend-message-edit)
+(define-keymap :prefix 'gnus-summary-send-map
+ "p" #'gnus-summary-post-news
+ "i" #'gnus-summary-news-other-window
+ "f" #'gnus-summary-followup
+ "F" #'gnus-summary-followup-with-original
+ "c" #'gnus-summary-cancel-article
+ "s" #'gnus-summary-supersede-article
+ "r" #'gnus-summary-reply
+ "y" #'gnus-summary-yank-message
+ "R" #'gnus-summary-reply-with-original
+ "L" #'gnus-summary-reply-to-list-with-original
+ "w" #'gnus-summary-wide-reply
+ "W" #'gnus-summary-wide-reply-with-original
+ "v" #'gnus-summary-very-wide-reply
+ "V" #'gnus-summary-very-wide-reply-with-original
+ "n" #'gnus-summary-followup-to-mail
+ "N" #'gnus-summary-followup-to-mail-with-original
+ "m" #'gnus-summary-mail-other-window
+ "u" #'gnus-uu-post-news
+ "A" #'gnus-summary-attach-article
+ "M-c" #'gnus-summary-mail-crosspost-complaint
+ "B r" #'gnus-summary-reply-broken-reply-to
+ "B R" #'gnus-summary-reply-broken-reply-to-with-original
+ "o m" #'gnus-summary-mail-forward
+ "o p" #'gnus-summary-post-forward
+ "O m" #'gnus-uu-digest-mail-forward
+ "O p" #'gnus-uu-digest-post-forward
+
+ "D" (define-keymap :prefix 'gnus-send-bounce-map
+ "b" #'gnus-summary-resend-bounced-mail
+ ;; "c" gnus-summary-send-draft
+ "r" #'gnus-summary-resend-message
+ "e" #'gnus-summary-resend-message-edit))
;;; Internal functions.
@@ -1305,7 +1305,7 @@ For the \"inline\" alternatives, also see the variable
(gnus-inews-insert-gcc)
(let ((gcc (message-unquote-tokens
(message-tokenize-header (mail-fetch-field "gcc" nil t)
- " ,")))
+ ",")))
(self (with-current-buffer gnus-summary-buffer
gnus-gcc-self-resent-messages)))
(message-remove-header "gcc")
@@ -1572,7 +1572,7 @@ this is a reply."
(message-remove-header "gcc")
(widen)
(setq groups (message-unquote-tokens
- (message-tokenize-header gcc " ,\n\t")))
+ (message-tokenize-header gcc ",\n\t")))
;; Copy the article over to some group(s).
(while (setq group (pop groups))
(setq method (gnus-inews-group-method group))
@@ -1748,7 +1748,7 @@ this is a reply."
(concat "\"" str "\"")
str)))
(when groups
- (insert " ")))
+ (insert ",")))
(insert "\n")))))))
(defun gnus-mailing-list-followup-to ()
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index 9b76f983227..163d543afd1 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -847,7 +847,8 @@ Overrides existing keywords with FORCE set non-nil."
(defun gnus-registry-register-message-ids ()
"Register the Message-ID of every article in the group."
(unless (or (gnus-parameter-registry-ignore gnus-newsgroup-name)
- (null gnus-registry-register-all))
+ (null gnus-registry-register-all)
+ (null (eieio-object-p gnus-registry-db)))
(dolist (article gnus-newsgroup-articles)
(let* ((id (gnus-registry-fetch-message-id-fast article))
(groups (gnus-registry-get-id-key id 'group)))
@@ -990,9 +991,9 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
gnus-registry-misc-menus)
(gnus-message 9 "Defined mark handling function %s"
function-name))))))
- (gnus-define-keys-1
- '(gnus-registry-mark-map "M" gnus-summary-mark-map)
- keys-plist)
+ (define-key gnus-summary-mark-map "M"
+ (apply #'define-keymap :prefix 'gnus-summary-mark-map
+ keys-plist))
(add-hook 'gnus-summary-menu-hook
(lambda ()
(easy-menu-add-item
@@ -1142,7 +1143,7 @@ non-nil."
entry)
(while (car-safe old)
(cl-incf count)
- ;; don't use progress reporters for backwards compatibility
+ ;; todo: use progress reporters.
(when (and (< 0 expected)
(= 0 (mod count 100)))
(message "importing: %d of %d (%.2f%%)"
diff --git a/lisp/gnus/gnus-rmail.el b/lisp/gnus/gnus-rmail.el
new file mode 100644
index 00000000000..f9dcc286a68
--- /dev/null
+++ b/lisp/gnus/gnus-rmail.el
@@ -0,0 +1,142 @@
+;;; gnus-rmail.el --- Saving to rmail/babyl files -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 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:
+
+;;; Functions for saving to babyl/mail files.
+
+(require 'rmail)
+(require 'rmailsum)
+(require 'nnmail)
+
+(defun gnus-output-to-rmail (filename &optional ask)
+ "Append the current article to an Rmail file named FILENAME.
+In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless
+FILENAME exists and is Babyl format."
+ ;; Some of this codes is borrowed from rmailout.el.
+ (setq filename (expand-file-name filename))
+ ;; FIXME should we really be messing with this defcustom?
+ ;; It is not needed for the operation of this function.
+ (if (boundp 'rmail-default-rmail-file)
+ (setq rmail-default-rmail-file filename) ; 22
+ (setq rmail-default-file filename)) ; 23
+ (let ((artbuf (current-buffer))
+ (tmpbuf (gnus-get-buffer-create " *Gnus-output*"))
+ ;; Babyl rmail.el defines this, mbox does not.
+ (babyl (fboundp 'rmail-insert-rmail-file-header)))
+ (save-excursion
+ ;; Note that we ignore the possibility of visiting a Babyl
+ ;; format buffer in Emacs 23, since Rmail no longer supports that.
+ (or (get-file-buffer filename)
+ (progn
+ ;; In case someone wants to write to a Babyl file from Emacs 23.
+ (when (file-exists-p filename)
+ (setq babyl (mail-file-babyl-p filename))
+ t))
+ (if (or (not ask)
+ (gnus-yes-or-no-p
+ (concat "\"" filename "\" does not exist, create it? ")))
+ (let ((file-buffer (create-file-buffer filename)))
+ (with-current-buffer file-buffer
+ (if (fboundp 'rmail-insert-rmail-file-header)
+ (rmail-insert-rmail-file-header))
+ (let ((require-final-newline nil)
+ (coding-system-for-write mm-text-coding-system))
+ (gnus-write-buffer filename)))
+ (kill-buffer file-buffer))
+ (error "Output file does not exist")))
+ (set-buffer tmpbuf)
+ (erase-buffer)
+ (insert-buffer-substring artbuf)
+ (if babyl
+ (gnus-convert-article-to-rmail)
+ ;; Non-Babyl case copied from gnus-output-to-mail.
+ (goto-char (point-min))
+ (if (looking-at "From ")
+ (forward-line 1)
+ (insert "From nobody " (current-time-string) "\n"))
+ (let (case-fold-search)
+ (while (re-search-forward "^From " nil t)
+ (beginning-of-line)
+ (insert ">"))))
+ ;; Decide whether to append to a file or to an Emacs buffer.
+ (let ((outbuf (get-file-buffer filename)))
+ (if (not outbuf)
+ (progn
+ (unless babyl ; from gnus-output-to-mail
+ (let ((buffer-read-only nil))
+ (goto-char (point-max))
+ (forward-char -2)
+ (unless (looking-at "\n\n")
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+ (insert "\n"))))
+ (let ((file-name-coding-system nnmail-pathname-coding-system))
+ (mm-append-to-file (point-min) (point-max) filename)))
+ ;; File has been visited, in buffer OUTBUF.
+ (set-buffer outbuf)
+ (let ((buffer-read-only nil)
+ (msg (and (boundp 'rmail-current-message)
+ (symbol-value 'rmail-current-message))))
+ ;; If MSG is non-nil, buffer is in RMAIL mode.
+ ;; Compare this with rmail-output-to-rmail-buffer in Emacs 23.
+ (when msg
+ (unless babyl
+ (rmail-swap-buffers-maybe)
+ (rmail-maybe-set-message-counters))
+ (widen)
+ (unless babyl
+ (goto-char (point-max))
+ ;; Ensure we have a blank line before the next message.
+ (unless (bolp)
+ (insert "\n"))
+ (insert "\n"))
+ (narrow-to-region (point-max) (point-max)))
+ (insert-buffer-substring tmpbuf)
+ (when msg
+ (when babyl
+ (goto-char (point-min))
+ (widen)
+ (search-backward "\n\^_")
+ (narrow-to-region (point) (point-max)))
+ (rmail-count-new-messages t)
+ (when (rmail-summary-exists)
+ (rmail-select-summary
+ (rmail-update-summary)))
+ (rmail-show-message msg))
+ (save-buffer)))))
+ (kill-buffer tmpbuf)))
+
+(defun gnus-convert-article-to-rmail ()
+ "Convert article in current buffer to Rmail message format."
+ (let ((buffer-read-only nil))
+ ;; Convert article directly into Babyl format.
+ (goto-char (point-min))
+ (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
+ (while (search-forward "\n\^_" nil t) ;single char
+ (replace-match "\n^_" t t)) ;2 chars: "^" and "_"
+ (goto-char (point-max))
+ (insert "\^_")))
+
+;;; gnus-rmail.el ends here
diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el
index dc81dfc5f6c..205e936bc7e 100644
--- a/lisp/gnus/gnus-salt.el
+++ b/lisp/gnus/gnus-salt.el
@@ -64,15 +64,12 @@ It accepts the same format specs that `gnus-summary-line-format' does."
;;; Internal variables.
-(defvar gnus-pick-mode-map
- (let ((map (make-sparse-keymap)))
- (gnus-define-keys map
- " " gnus-pick-next-page
- "u" gnus-pick-unmark-article-or-thread
- "." gnus-pick-article-or-thread
- [down-mouse-2] gnus-pick-mouse-pick-region
- "\r" gnus-pick-start-reading)
- map))
+(defvar-keymap gnus-pick-mode-map
+ "SPC" #'gnus-pick-next-page
+ "u" #'gnus-pick-unmark-article-or-thread
+ "." #'gnus-pick-article-or-thread
+ "<down-mouse-2>" #'gnus-pick-mouse-pick-region
+ "RET" #'gnus-pick-start-reading)
(defun gnus-pick-make-menu-bar ()
(unless (boundp 'gnus-pick-menu)
@@ -315,11 +312,8 @@ This must be bound to a button-down mouse event."
(defvar gnus-binary-mode-hook nil
"Hook run in summary binary mode buffers.")
-(defvar gnus-binary-mode-map
- (let ((map (make-sparse-keymap)))
- (gnus-define-keys map
- "g" gnus-binary-show-article)
- map))
+(defvar-keymap gnus-binary-mode-map
+ "g" #'gnus-binary-show-article)
(defun gnus-binary-make-menu-bar ()
(unless (boundp 'gnus-binary-menu)
@@ -424,21 +418,17 @@ Two predefined functions are available:
(defvar gnus-tree-displayed-thread nil)
(defvar gnus-tree-inhibit nil)
-(defvar gnus-tree-mode-map
- (let ((map (make-keymap)))
- (suppress-keymap map)
- (gnus-define-keys
- map
- "\r" gnus-tree-select-article
- [mouse-2] gnus-tree-pick-article
- "\C-?" gnus-tree-read-summary-keys
- "h" gnus-tree-show-summary
-
- "\C-c\C-i" gnus-info-find-node)
-
- (substitute-key-definition
- 'undefined 'gnus-tree-read-summary-keys map)
- map))
+(defvar-keymap gnus-tree-mode-map
+ :full t :suppress t
+ "RET" #'gnus-tree-select-article
+ "<mouse-2>" #'gnus-tree-pick-article
+ "DEL" #'gnus-tree-read-summary-keys
+ "h" #'gnus-tree-show-summary
+
+ "C-c C-i" #'gnus-info-find-node)
+
+(substitute-key-definition 'undefined #'gnus-tree-read-summary-keys
+ gnus-tree-mode-map)
(defun gnus-tree-make-menu-bar ()
(unless (boundp 'gnus-tree-menu)
diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el
index e0ad9f698d3..a25673a0e75 100644
--- a/lisp/gnus/gnus-score.el
+++ b/lisp/gnus/gnus-score.el
@@ -502,19 +502,20 @@ of the last successful match.")
;;; Summary mode score maps.
-(gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map)
- "s" gnus-summary-set-score
- "S" gnus-summary-current-score
- "c" gnus-score-change-score-file
- "C" gnus-score-customize
- "m" gnus-score-set-mark-below
- "x" gnus-score-set-expunge-below
- "R" gnus-summary-rescore
- "e" gnus-score-edit-current-scores
- "f" gnus-score-edit-file
- "F" gnus-score-flush-cache
- "t" gnus-score-find-trace
- "w" gnus-score-find-favorite-words)
+(define-key gnus-summary-mode-map "V"
+ (define-keymap :prefix 'gnus-summary-score-map
+ "s" #'gnus-summary-set-score
+ "S" #'gnus-summary-current-score
+ "c" #'gnus-score-change-score-file
+ "C" #'gnus-score-customize
+ "m" #'gnus-score-set-mark-below
+ "x" #'gnus-score-set-expunge-below
+ "R" #'gnus-summary-rescore
+ "e" #'gnus-score-edit-current-scores
+ "f" #'gnus-score-edit-file
+ "F" #'gnus-score-flush-cache
+ "t" #'gnus-score-find-trace
+ "w" #'gnus-score-find-favorite-words))
;; Summary score file commands
@@ -1748,7 +1749,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(setq type 'after
match-func 'string<
match (gnus-time-iso8601
- (time-subtract (current-time)
+ (time-subtract nil
(* 86400 (nth 0 kill))))))
((eq type 'before)
(setq match-func 'gnus-string>
@@ -1757,7 +1758,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(setq type 'before
match-func 'gnus-string>
match (gnus-time-iso8601
- (time-subtract (current-time)
+ (time-subtract nil
(* 86400 (nth 0 kill))))))
((eq type 'at)
(setq match-func 'string=
@@ -2561,16 +2562,17 @@ score in `gnus-newsgroup-scored' by SCORE."
(or (caddr s)
gnus-score-interactive-default-score))
trace))))
- (insert
- "\n\nQuick help:
+ (insert
+ (substitute-command-keys
+ "\n\nQuick help:
-Type `e' to edit score file corresponding to the score rule on current line,
-`f' to format (pretty print) the score file and edit it,
-`t' toggle to truncate long lines in this buffer,
-`q' to quit, `k' to kill score trace buffer.
+Type \\`e' to edit score file corresponding to the score rule on current line,
+\\`f' to format (pretty print) the score file and edit it,
+\\`t' toggle to truncate long lines in this buffer,
+\\`q' to quit, \\`k' to kill score trace buffer.
The first sexp on each line is the score rule, followed by the file name of
-the score file and its full name, including the directory.")
+the score file and its full name, including the directory."))
(goto-char (point-min))
(gnus-configure-windows 'score-trace)))
(set-buffer gnus-summary-buffer)
diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el
index 9c83d5fa376..d64c0cb90c3 100644
--- a/lisp/gnus/gnus-search.el
+++ b/lisp/gnus/gnus-search.el
@@ -105,9 +105,13 @@
(gnus-add-shutdown #'gnus-search-shutdown 'gnus)
-(define-error 'gnus-search-parse-error "Gnus search parsing error")
+(define-error 'gnus-search-error "Gnus search error")
-(define-error 'gnus-search-config-error "Gnus search configuration error")
+(define-error 'gnus-search-parse-error "Gnus search parsing error"
+ 'gnus-search-error)
+
+(define-error 'gnus-search-config-error "Gnus search configuration error"
+ 'gnus-search-error)
;;; User Customizable Variables:
@@ -568,15 +572,13 @@ REL-DATE, or (current-time) if REL-DATE is nil."
;; Time parsing doesn't seem to work with slashes.
(let ((value (string-replace "/" "-" value))
(now (append '(0 0 0)
- (seq-subseq (decode-time (or rel-date
- (current-time)))
- 3))))
+ (seq-subseq (decode-time rel-date) 3))))
;; Check for relative time parsing.
(if (string-match "\\([[:digit:]]+\\)\\([dwmy]\\)" value)
(seq-subseq
(decode-time
(time-subtract
- (apply #'encode-time now)
+ (encode-time now)
(days-to-time
(* (string-to-number (match-string 1 value))
(cdr (assoc (match-string 2 value)
@@ -595,7 +597,7 @@ REL-DATE, or (current-time) if REL-DATE is nil."
;; If DOW is given, handle that specially.
(if (and (seq-elt d-time 6) (null (seq-elt d-time 3)))
(decode-time
- (time-subtract (apply #'encode-time now)
+ (time-subtract (encode-time now)
(days-to-time
(+ (if (> (seq-elt d-time 6)
(seq-elt now 6))
@@ -1018,7 +1020,7 @@ Responsible for handling and, or, and parenthetical expressions.")
(single-search (gnus-search-single-p query))
(grouplist (or groups (gnus-search-get-active srv)))
q-string artlist group)
- (message "Opening server %s" server)
+ (gnus-message 7 "Opening server %s" server)
(gnus-open-server srv)
;; We should only be doing this once, in
;; `nnimap-open-connection', but it's too frustrating to try to
@@ -1058,11 +1060,11 @@ Responsible for handling and, or, and parenthetical expressions.")
q-string)))
(while (and (setq group (pop grouplist))
- (or (null single-search) (null artlist)))
+ (or (null single-search) (= 0 (length artlist))))
(when (nnimap-change-group
(gnus-group-short-name group) server)
(with-current-buffer (nnimap-buffer)
- (message "Searching %s..." group)
+ (gnus-message 7 "Searching %s..." group)
(let ((result
(gnus-search-imap-search-command engine q-string)))
(when (car result)
@@ -1075,7 +1077,7 @@ Responsible for handling and, or, and parenthetical expressions.")
(vector group artn 100))))
(cdr (assoc "SEARCH" (cdr result))))
artlist))))
- (message "Searching %s...done" group))))
+ (gnus-message 7 "Searching %s...done" group))))
(nreverse artlist))))
(cl-defmethod gnus-search-imap-search-command ((engine gnus-search-imap)
@@ -1084,7 +1086,8 @@ Responsible for handling and, or, and parenthetical expressions.")
Currently takes into account support for the LITERAL+ capability.
Other capabilities could be tested here."
(with-slots (literal-plus) engine
- (when literal-plus
+ (when (and literal-plus
+ (string-match-p "\n" query))
(setq query (split-string query "\n")))
(cond
((consp query)
@@ -1234,8 +1237,7 @@ nil (except that (dd nil yyyy) is not allowed). Massage those
numbers into the most recent past occurrence of whichever date
elements are present."
(pcase-let ((`(,nday ,nmonth ,nyear)
- (seq-subseq (decode-time (current-time))
- 3 6))
+ (seq-subseq (decode-time) 3 6))
(`(,dday ,dmonth ,dyear) date))
(unless (and dday dmonth dyear)
(unless dday (setq dday 1))
@@ -1255,9 +1257,7 @@ elements are present."
(setq dmonth 1))))
(format-time-string
"%e-%b-%Y"
- (apply #'encode-time
- (append '(0 0 0)
- (list dday dmonth dyear))))))
+ (encode-time 0 0 0 dday dmonth dyear))))
(cl-defmethod gnus-search-imap-handle-string ((engine gnus-search-imap)
(str string))
@@ -1329,8 +1329,8 @@ Returns a list of [group article score] vectors."
(erase-buffer)
(if groups
- (message "Doing %s query on %s..." program groups)
- (message "Doing %s query..." program))
+ (gnus-message 7 "Doing %s query on %s..." program groups)
+ (gnus-message 7 "Doing %s query..." program))
(setq proc (apply #'start-process (format "search-%s" server)
buffer program cp-list))
(while (process-live-p proc)
@@ -1836,8 +1836,8 @@ Assume \"size\" key is equal to \"larger\"."
(mapcar (lambda (x)
(let ((group x)
artlist)
- (message "Searching %s using find-grep..."
- (or group server))
+ (gnus-message 7 "Searching %s using find-grep..."
+ (or group server))
(save-window-excursion
(set-buffer buffer)
(if (> gnus-verbose 6)
@@ -1892,8 +1892,8 @@ Assume \"size\" key is equal to \"larger\"."
(vector (gnus-group-full-name group server) art 0)
artlist))
(forward-line 1)))
- (message "Searching %s using find-grep...done"
- (or group server))
+ (gnus-message 7 "Searching %s using find-grep...done"
+ (or group server))
artlist)))
grouplist))))
@@ -1926,7 +1926,7 @@ Assume \"size\" key is equal to \"larger\"."
(apply #'nnheader-message 4
"Search engine for %s improperly configured: %s"
server (cdr err))
- (signal 'gnus-search-config-error err)))))
+ (signal (car err) (cdr err))))))
(alist-get 'search-group-spec specs))
;; Some search engines do their own limiting, but some don't, so
;; do it again here. This is bad because, if the user is
diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el
index 5f2fc463330..fa880b7eddb 100644
--- a/lisp/gnus/gnus-srvr.el
+++ b/lisp/gnus/gnus-srvr.el
@@ -103,7 +103,43 @@ If nil, a faster, but more primitive, buffer is used instead."
(defvar gnus-server-mode-line-format-spec nil)
(defvar gnus-server-killed-servers nil)
-(defvar gnus-server-mode-map nil)
+(defvar-keymap gnus-server-mode-map
+ :full t :suppress t
+ "SPC" #'gnus-server-read-server-in-server-buffer
+ "RET" #'gnus-server-read-server
+ "<mouse-2>" #'gnus-server-pick-server
+ "q" #'gnus-server-exit
+ "l" #'gnus-server-list-servers
+ "k" #'gnus-server-kill-server
+ "y" #'gnus-server-yank-server
+ "c" #'gnus-server-copy-server
+ "a" #'gnus-server-add-server
+ "e" #'gnus-server-edit-server
+ "S" #'gnus-server-show-server
+ "s" #'gnus-server-scan-server
+
+ "O" #'gnus-server-open-server
+ "M-o" #'gnus-server-open-all-servers
+ "C" #'gnus-server-close-server
+ "M-c" #'gnus-server-close-all-servers
+ "D" #'gnus-server-deny-server
+ "L" #'gnus-server-offline-server
+ "R" #'gnus-server-remove-denials
+
+ "n" #'next-line
+ "p" #'previous-line
+
+ "g" #'gnus-server-regenerate-server
+
+ "G" #'gnus-group-read-ephemeral-search-group
+
+ "z" #'gnus-server-compact-server
+
+ "i" #'gnus-server-toggle-cloud-server
+ "I" #'gnus-server-set-cloud-method-server
+
+ "C-c C-i" #'gnus-info-find-node
+ "C-c C-b" #'gnus-bug)
(defcustom gnus-server-menu-hook nil
"Hook run after the creation of the server mode menu."
@@ -145,47 +181,6 @@ If nil, a faster, but more primitive, buffer is used instead."
(gnus-run-hooks 'gnus-server-menu-hook)))
-(unless gnus-server-mode-map
- (setq gnus-server-mode-map (make-keymap))
- (suppress-keymap gnus-server-mode-map)
-
- (gnus-define-keys gnus-server-mode-map
- " " gnus-server-read-server-in-server-buffer
- "\r" gnus-server-read-server
- [mouse-2] gnus-server-pick-server
- "q" gnus-server-exit
- "l" gnus-server-list-servers
- "k" gnus-server-kill-server
- "y" gnus-server-yank-server
- "c" gnus-server-copy-server
- "a" gnus-server-add-server
- "e" gnus-server-edit-server
- "S" gnus-server-show-server
- "s" gnus-server-scan-server
-
- "O" gnus-server-open-server
- "\M-o" gnus-server-open-all-servers
- "C" gnus-server-close-server
- "\M-c" gnus-server-close-all-servers
- "D" gnus-server-deny-server
- "L" gnus-server-offline-server
- "R" gnus-server-remove-denials
-
- "n" next-line
- "p" previous-line
-
- "g" gnus-server-regenerate-server
-
- "G" gnus-group-read-ephemeral-search-group
-
- "z" gnus-server-compact-server
-
- "i" gnus-server-toggle-cloud-server
- "I" gnus-server-set-cloud-method-server
-
- "\C-c\C-i" gnus-info-find-node
- "\C-c\C-b" gnus-bug))
-
(defface gnus-server-agent
'((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
(((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
@@ -697,37 +692,31 @@ claim them."
function
(repeat function)))
-(defvar gnus-browse-mode-map nil)
-
-(unless gnus-browse-mode-map
- (setq gnus-browse-mode-map (make-keymap))
- (suppress-keymap gnus-browse-mode-map)
-
- (gnus-define-keys
- gnus-browse-mode-map
- " " gnus-browse-read-group
- "=" gnus-browse-select-group
- "n" gnus-browse-next-group
- "p" gnus-browse-prev-group
- "\177" gnus-browse-prev-group
- [delete] gnus-browse-prev-group
- "N" gnus-browse-next-group
- "P" gnus-browse-prev-group
- "\M-n" gnus-browse-next-group
- "\M-p" gnus-browse-prev-group
- "\r" gnus-browse-select-group
- "u" gnus-browse-toggle-subscription-at-point
- "l" gnus-browse-exit
- "L" gnus-browse-exit
- "q" gnus-browse-exit
- "Q" gnus-browse-exit
- "d" gnus-browse-describe-group
- [delete] gnus-browse-delete-group
- "\C-c\C-c" gnus-browse-exit
- "?" gnus-browse-describe-briefly
-
- "\C-c\C-i" gnus-info-find-node
- "\C-c\C-b" gnus-bug))
+(defvar-keymap gnus-browse-mode-map
+ :full t :suppress t
+ "SPC" #'gnus-browse-read-group
+ "=" #'gnus-browse-select-group
+ "n" #'gnus-browse-next-group
+ "p" #'gnus-browse-prev-group
+ "DEL" #'gnus-browse-prev-group
+ "<delete>" #'gnus-browse-prev-group
+ "N" #'gnus-browse-next-group
+ "P" #'gnus-browse-prev-group
+ "M-n" #'gnus-browse-next-group
+ "M-p" #'gnus-browse-prev-group
+ "RET" #'gnus-browse-select-group
+ "u" #'gnus-browse-toggle-subscription-at-point
+ "l" #'gnus-browse-exit
+ "L" #'gnus-browse-exit
+ "q" #'gnus-browse-exit
+ "Q" #'gnus-browse-exit
+ "d" #'gnus-browse-describe-group
+ "<delete>" #'gnus-browse-delete-group
+ "C-c C-c" #'gnus-browse-exit
+ "?" #'gnus-browse-describe-briefly
+
+ "C-c C-i" #'gnus-info-find-node
+ "C-c C-b" #'gnus-bug)
(defun gnus-browse-make-menu-bar ()
(gnus-turn-off-edit-menu 'browse)
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index c7be958edd1..606bd3a39a4 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -663,6 +663,7 @@ the first newsgroup."
(defvar mail-sources)
(defvar nnmail-scan-directory-mail-source-once)
(defvar nnmail-split-history)
+(defvar gnus-save-newsrc-file-last-timestamp nil)
(defun gnus-close-all-servers ()
"Close all servers."
@@ -707,6 +708,7 @@ the first newsgroup."
gnus-current-select-method nil
nnmail-split-history nil
gnus-extended-servers nil
+ gnus-save-newsrc-file-last-timestamp nil
gnus-ephemeral-servers nil)
(gnus-shutdown 'gnus)
;; Kill the startup file.
@@ -2731,7 +2733,6 @@ The form should return either t or nil."
'msdos-long-file-names
(lambda () t))))
-(defvar gnus-save-newsrc-file-last-timestamp nil)
(defun gnus-save-newsrc-file (&optional force)
"Save .newsrc file.
Use the group string names in `gnus-group-list' to pull info
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index d790655aa90..1bd0e8847e2 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -1907,485 +1907,483 @@ increase the score of each group you read."
;; Non-orthogonal keys
-(gnus-define-keys gnus-summary-mode-map
- " " gnus-summary-next-page
- [?\S-\ ] gnus-summary-prev-page
- "\177" gnus-summary-prev-page
- [delete] gnus-summary-prev-page
- "\r" gnus-summary-scroll-up
- "\M-\r" gnus-summary-scroll-down
- "n" gnus-summary-next-unread-article
- "p" gnus-summary-prev-unread-article
- "N" gnus-summary-next-article
- "P" gnus-summary-prev-article
- "\M-\C-n" gnus-summary-next-same-subject
- "\M-\C-p" gnus-summary-prev-same-subject
- "\M-n" gnus-summary-next-unread-subject
- "\M-p" gnus-summary-prev-unread-subject
- "." gnus-summary-first-unread-article
- "," gnus-summary-best-unread-article
- "[" gnus-summary-prev-unseen-article
- "]" gnus-summary-next-unseen-article
- "\M-s\M-s" gnus-summary-search-article-forward
- "\M-s\M-r" gnus-summary-search-article-backward
- "\M-r" gnus-summary-search-article-backward
- "\M-S" gnus-summary-repeat-search-article-forward
- "\M-R" gnus-summary-repeat-search-article-backward
- "<" gnus-summary-beginning-of-article
- ">" gnus-summary-end-of-article
- "j" gnus-summary-goto-article
- "^" gnus-summary-refer-parent-article
- "\M-^" gnus-summary-refer-article
- "u" gnus-summary-tick-article-forward
- "!" gnus-summary-tick-article-forward
- "U" gnus-summary-tick-article-backward
- "d" gnus-summary-mark-as-read-forward
- "D" gnus-summary-mark-as-read-backward
- "E" gnus-summary-mark-as-expirable
- "\M-u" gnus-summary-clear-mark-forward
- "\M-U" gnus-summary-clear-mark-backward
- "k" gnus-summary-kill-same-subject-and-select
- "\C-k" gnus-summary-kill-same-subject
- "\M-\C-k" gnus-summary-kill-thread
- "\M-\C-l" gnus-summary-lower-thread
- "e" gnus-summary-edit-article
- "#" gnus-summary-mark-as-processable
- "\M-#" gnus-summary-unmark-as-processable
- "\M-\C-t" gnus-summary-toggle-threads
- "\M-\C-s" gnus-summary-show-thread
- "\M-\C-h" gnus-summary-hide-thread
- "\M-\C-f" gnus-summary-next-thread
- "\M-\C-b" gnus-summary-prev-thread
- [(meta down)] gnus-summary-next-thread
- [(meta up)] gnus-summary-prev-thread
- "\M-\C-u" gnus-summary-up-thread
- "\M-\C-d" gnus-summary-down-thread
- "&" gnus-summary-execute-command
- "c" gnus-summary-catchup-and-exit
- "\C-w" gnus-summary-mark-region-as-read
- "\C-t" toggle-truncate-lines
- "?" gnus-summary-mark-as-dormant
- "\C-c\M-\C-s" gnus-summary-limit-include-expunged
- "\C-c\C-s\C-n" gnus-summary-sort-by-number
- "\C-c\C-s\C-m\C-n" gnus-summary-sort-by-most-recent-number
- "\C-c\C-s\C-l" gnus-summary-sort-by-lines
- "\C-c\C-s\C-c" gnus-summary-sort-by-chars
- "\C-c\C-s\C-m\C-m" gnus-summary-sort-by-marks
- "\C-c\C-s\C-a" gnus-summary-sort-by-author
- "\C-c\C-s\C-t" gnus-summary-sort-by-recipient
- "\C-c\C-s\C-s" gnus-summary-sort-by-subject
- "\C-c\C-s\C-d" gnus-summary-sort-by-date
- "\C-c\C-s\C-m\C-d" gnus-summary-sort-by-most-recent-date
- "\C-c\C-s\C-i" gnus-summary-sort-by-score
- "\C-c\C-s\C-o" gnus-summary-sort-by-original
- "\C-c\C-s\C-r" gnus-summary-sort-by-random
- "\C-c\C-s\C-u" gnus-summary-sort-by-newsgroups
- "\C-c\C-s\C-x" gnus-summary-sort-by-extra
- "=" gnus-summary-expand-window
- "\C-x\C-s" gnus-summary-reselect-current-group
- "\M-g" gnus-summary-rescan-group
- "\C-c\C-r" gnus-summary-caesar-message
- "f" gnus-summary-followup
- "F" gnus-summary-followup-with-original
- "C" gnus-summary-cancel-article
- "r" gnus-summary-reply
- "R" gnus-summary-reply-with-original
- "\C-c\C-f" gnus-summary-mail-forward
- "o" gnus-summary-save-article
- "\C-o" gnus-summary-save-article-mail
- "|" gnus-summary-pipe-output
- "\M-k" gnus-summary-edit-local-kill
- "\M-K" gnus-summary-edit-global-kill
+(define-keymap :keymap gnus-summary-mode-map
+ "SPC" #'gnus-summary-next-page
+ "S-SPC" #'gnus-summary-prev-page
+ "DEL" #'gnus-summary-prev-page
+ "<delete>" #'gnus-summary-prev-page
+ "RET" #'gnus-summary-scroll-up
+ "M-RET" #'gnus-summary-scroll-down
+ "n" #'gnus-summary-next-unread-article
+ "p" #'gnus-summary-prev-unread-article
+ "N" #'gnus-summary-next-article
+ "P" #'gnus-summary-prev-article
+ "C-M-n" #'gnus-summary-next-same-subject
+ "C-M-p" #'gnus-summary-prev-same-subject
+ "M-n" #'gnus-summary-next-unread-subject
+ "M-p" #'gnus-summary-prev-unread-subject
+ "." #'gnus-summary-first-unread-article
+ "," #'gnus-summary-best-unread-article
+ "[" #'gnus-summary-prev-unseen-article
+ "]" #'gnus-summary-next-unseen-article
+ "M-s M-s" #'gnus-summary-search-article-forward
+ "M-s M-r" #'gnus-summary-search-article-backward
+ "M-r" #'gnus-summary-search-article-backward
+ "M-S" #'gnus-summary-repeat-search-article-forward
+ "M-R" #'gnus-summary-repeat-search-article-backward
+ "<" #'gnus-summary-beginning-of-article
+ ">" #'gnus-summary-end-of-article
+ "j" #'gnus-summary-goto-article
+ "^" #'gnus-summary-refer-parent-article
+ "M-^" #'gnus-summary-refer-article
+ "u" #'gnus-summary-tick-article-forward
+ "!" #'gnus-summary-tick-article-forward
+ "U" #'gnus-summary-tick-article-backward
+ "d" #'gnus-summary-mark-as-read-forward
+ "D" #'gnus-summary-mark-as-read-backward
+ "E" #'gnus-summary-mark-as-expirable
+ "M-u" #'gnus-summary-clear-mark-forward
+ "M-U" #'gnus-summary-clear-mark-backward
+ "k" #'gnus-summary-kill-same-subject-and-select
+ "C-k" #'gnus-summary-kill-same-subject
+ "C-M-k" #'gnus-summary-kill-thread
+ "C-M-l" #'gnus-summary-lower-thread
+ "e" #'gnus-summary-edit-article
+ "#" #'gnus-summary-mark-as-processable
+ "M-#" #'gnus-summary-unmark-as-processable
+ "C-M-t" #'gnus-summary-toggle-threads
+ "C-M-s" #'gnus-summary-show-thread
+ "C-M-h" #'gnus-summary-hide-thread
+ "C-M-f" #'gnus-summary-next-thread
+ "C-M-b" #'gnus-summary-prev-thread
+ "M-<down>" #'gnus-summary-next-thread
+ "M-<up>" #'gnus-summary-prev-thread
+ "C-M-u" #'gnus-summary-up-thread
+ "C-M-d" #'gnus-summary-down-thread
+ "&" #'gnus-summary-execute-command
+ "c" #'gnus-summary-catchup-and-exit
+ "C-w" #'gnus-summary-mark-region-as-read
+ "C-t" #'toggle-truncate-lines
+ "?" #'gnus-summary-mark-as-dormant
+ "C-c C-M-s" #'gnus-summary-limit-include-expunged
+ "C-c C-s C-n" #'gnus-summary-sort-by-number
+ "C-c C-s C-m C-n" #'gnus-summary-sort-by-most-recent-number
+ "C-c C-s C-l" #'gnus-summary-sort-by-lines
+ "C-c C-s C-c" #'gnus-summary-sort-by-chars
+ "C-c C-s C-m C-m" #'gnus-summary-sort-by-marks
+ "C-c C-s C-a" #'gnus-summary-sort-by-author
+ "C-c C-s C-t" #'gnus-summary-sort-by-recipient
+ "C-c C-s C-s" #'gnus-summary-sort-by-subject
+ "C-c C-s C-d" #'gnus-summary-sort-by-date
+ "C-c C-s C-m C-d" #'gnus-summary-sort-by-most-recent-date
+ "C-c C-s C-i" #'gnus-summary-sort-by-score
+ "C-c C-s C-o" #'gnus-summary-sort-by-original
+ "C-c C-s C-r" #'gnus-summary-sort-by-random
+ "C-c C-s C-u" #'gnus-summary-sort-by-newsgroups
+ "C-c C-s C-x" #'gnus-summary-sort-by-extra
+ "=" #'gnus-summary-expand-window
+ "C-x C-s" #'gnus-summary-reselect-current-group
+ "M-g" #'gnus-summary-rescan-group
+ "C-c C-r" #'gnus-summary-caesar-message
+ "f" #'gnus-summary-followup
+ "F" #'gnus-summary-followup-with-original
+ "C" #'gnus-summary-cancel-article
+ "r" #'gnus-summary-reply
+ "R" #'gnus-summary-reply-with-original
+ "C-c C-f" #'gnus-summary-mail-forward
+ "o" #'gnus-summary-save-article
+ "C-o" #'gnus-summary-save-article-mail
+ "|" #'gnus-summary-pipe-output
+ "M-k" #'gnus-summary-edit-local-kill
+ "M-K" #'gnus-summary-edit-global-kill
;; "V" gnus-version
- "\C-c\C-d" gnus-summary-describe-group
- "\C-c\C-p" gnus-summary-make-group-from-search
- "q" gnus-summary-exit
- "Q" gnus-summary-exit-no-update
- "\C-c\C-i" gnus-info-find-node
- [mouse-2] gnus-mouse-pick-article
- [follow-link] mouse-face
- "m" gnus-summary-mail-other-window
- "a" gnus-summary-post-news
- "x" gnus-summary-limit-to-unread
- "s" gnus-summary-isearch-article
- "\t" gnus-summary-button-forward
- [backtab] gnus-summary-button-backward
- "w" gnus-summary-browse-url
- "t" gnus-summary-toggle-header
- "g" gnus-summary-show-article
- "l" gnus-summary-goto-last-article
- "\C-c\C-v\C-v" gnus-uu-decode-uu-view
- "\C-d" gnus-summary-enter-digest-group
- "\M-\C-d" gnus-summary-read-document
- "\M-\C-e" gnus-summary-edit-parameters
- "\M-\C-a" gnus-summary-customize-parameters
- "\C-c\C-b" gnus-bug
- "*" gnus-cache-enter-article
- "\M-*" gnus-cache-remove-article
- "\M-&" gnus-summary-universal-argument
- "\C-l" gnus-recenter
- "I" gnus-summary-increase-score
- "L" gnus-summary-lower-score
- "\M-i" gnus-symbolic-argument
- "h" gnus-summary-select-article-buffer
-
- "b" gnus-article-view-part
- "\M-t" gnus-summary-toggle-display-buttonized
-
- "V" gnus-summary-score-map
- "X" gnus-uu-extract-map
- "S" gnus-summary-send-map)
-
-;; Sort of orthogonal keymap
-(gnus-define-keys (gnus-summary-mark-map "M" gnus-summary-mode-map)
- "t" gnus-summary-tick-article-forward
- "!" gnus-summary-tick-article-forward
- "d" gnus-summary-mark-as-read-forward
- "r" gnus-summary-mark-as-read-forward
- "c" gnus-summary-clear-mark-forward
- " " gnus-summary-clear-mark-forward
- "e" gnus-summary-mark-as-expirable
- "x" gnus-summary-mark-as-expirable
- "?" gnus-summary-mark-as-dormant
- "b" gnus-summary-set-bookmark
- "B" gnus-summary-remove-bookmark
- "#" gnus-summary-mark-as-processable
- "\M-#" gnus-summary-unmark-as-processable
- "S" gnus-summary-limit-include-expunged
- "C" gnus-summary-catchup
- "H" gnus-summary-catchup-to-here
- "h" gnus-summary-catchup-from-here
- "\C-c" gnus-summary-catchup-all
- "k" gnus-summary-kill-same-subject-and-select
- "K" gnus-summary-kill-same-subject
- "P" gnus-uu-mark-map)
-
-(gnus-define-keys (gnus-summary-mscore-map "V" gnus-summary-mark-map)
- "c" gnus-summary-clear-above
- "u" gnus-summary-tick-above
- "m" gnus-summary-mark-above
- "k" gnus-summary-kill-below)
-
-(gnus-define-keys (gnus-summary-limit-map "/" gnus-summary-mode-map)
- "/" gnus-summary-limit-to-subject
- "n" gnus-summary-limit-to-articles
- "b" gnus-summary-limit-to-bodies
- "h" gnus-summary-limit-to-headers
- "w" gnus-summary-pop-limit
- "s" gnus-summary-limit-to-subject
- "a" gnus-summary-limit-to-author
- "u" gnus-summary-limit-to-unread
- "m" gnus-summary-limit-to-marks
- "M" gnus-summary-limit-exclude-marks
- "v" gnus-summary-limit-to-score
- "*" gnus-summary-limit-include-cached
- "D" gnus-summary-limit-include-dormant
- "T" gnus-summary-limit-include-thread
- "d" gnus-summary-limit-exclude-dormant
- "t" gnus-summary-limit-to-age
- "." gnus-summary-limit-to-unseen
- "x" gnus-summary-limit-to-extra
- "p" gnus-summary-limit-to-display-predicate
- "E" gnus-summary-limit-include-expunged
- "c" gnus-summary-limit-exclude-childless-dormant
- "C" gnus-summary-limit-mark-excluded-as-read
- "o" gnus-summary-insert-old-articles
- "N" gnus-summary-insert-new-articles
- "S" gnus-summary-limit-to-singletons
- "r" gnus-summary-limit-to-replied
- "R" gnus-summary-limit-to-recipient
- "A" gnus-summary-limit-to-address)
-
-(gnus-define-keys (gnus-summary-goto-map "G" gnus-summary-mode-map)
- "n" gnus-summary-next-unread-article
- "p" gnus-summary-prev-unread-article
- "N" gnus-summary-next-article
- "P" gnus-summary-prev-article
- "\C-n" gnus-summary-next-same-subject
- "\C-p" gnus-summary-prev-same-subject
- "\M-n" gnus-summary-next-unread-subject
- "\M-p" gnus-summary-prev-unread-subject
- "f" gnus-summary-first-unread-article
- "b" gnus-summary-best-unread-article
- "u" gnus-summary-next-unseen-article
- "U" gnus-summary-prev-unseen-article
- "j" gnus-summary-goto-article
- "g" gnus-summary-goto-subject
- "l" gnus-summary-goto-last-article
- "o" gnus-summary-pop-article)
-
-(gnus-define-keys (gnus-summary-thread-map "T" gnus-summary-mode-map)
- "k" gnus-summary-kill-thread
- "E" gnus-summary-expire-thread
- "l" gnus-summary-lower-thread
- "i" gnus-summary-raise-thread
- "T" gnus-summary-toggle-threads
- "t" gnus-summary-rethread-current
- "^" gnus-summary-reparent-thread
- "\M-^" gnus-summary-reparent-children
- "s" gnus-summary-show-thread
- "S" gnus-summary-show-all-threads
- "h" gnus-summary-hide-thread
- "H" gnus-summary-hide-all-threads
- "n" gnus-summary-next-thread
- "p" gnus-summary-prev-thread
- "u" gnus-summary-up-thread
- "o" gnus-summary-top-thread
- "d" gnus-summary-down-thread
- "#" gnus-uu-mark-thread
- "\M-#" gnus-uu-unmark-thread)
-
-(gnus-define-keys (gnus-summary-buffer-map "Y" gnus-summary-mode-map)
- "g" gnus-summary-prepare
- "c" gnus-summary-insert-cached-articles
- "d" gnus-summary-insert-dormant-articles
- "t" gnus-summary-insert-ticked-articles)
-
-(gnus-define-keys (gnus-summary-exit-map "Z" gnus-summary-mode-map)
- "c" gnus-summary-catchup-and-exit
- "C" gnus-summary-catchup-all-and-exit
- "E" gnus-summary-exit-no-update
- "Q" gnus-summary-exit
- "Z" gnus-summary-exit
- "n" gnus-summary-catchup-and-goto-next-group
- "p" gnus-summary-catchup-and-goto-prev-group
- "R" gnus-summary-reselect-current-group
- "G" gnus-summary-rescan-group
- "N" gnus-summary-next-group
- "s" gnus-summary-save-newsrc
- "P" gnus-summary-prev-group)
-
-(gnus-define-keys (gnus-summary-article-map "A" gnus-summary-mode-map)
- " " gnus-summary-next-page
- "n" gnus-summary-next-page
- [?\S-\ ] gnus-summary-prev-page
- "\177" gnus-summary-prev-page
- [delete] gnus-summary-prev-page
- "p" gnus-summary-prev-page
- "\r" gnus-summary-scroll-up
- "\M-\r" gnus-summary-scroll-down
- "<" gnus-summary-beginning-of-article
- ">" gnus-summary-end-of-article
- "b" gnus-summary-beginning-of-article
- "e" gnus-summary-end-of-article
- "^" gnus-summary-refer-parent-article
- "r" gnus-summary-refer-parent-article
- "C" gnus-summary-show-complete-article
- "D" gnus-summary-enter-digest-group
- "R" gnus-summary-refer-references
- "T" gnus-summary-refer-thread
- "W" gnus-warp-to-article
- "g" gnus-summary-show-article
- "s" gnus-summary-isearch-article
- "\t" gnus-summary-button-forward
- [backtab] gnus-summary-button-backward
- "w" gnus-summary-browse-url
- "P" gnus-summary-print-article
- "S" gnus-sticky-article
- "M" gnus-mailing-list-insinuate
- "t" gnus-article-babel)
-
-(gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map)
- "b" gnus-article-add-buttons
- "B" gnus-article-add-buttons-to-head
- "o" gnus-article-treat-overstrike
- "e" gnus-article-emphasize
- "w" gnus-article-fill-cited-article
- "Q" gnus-article-fill-long-lines
- "L" gnus-article-toggle-truncate-lines
- "C" gnus-article-capitalize-sentences
- "c" gnus-article-remove-cr
- "q" gnus-article-de-quoted-unreadable
- "6" gnus-article-de-base64-unreadable
- "Z" gnus-article-decode-HZ
- "A" gnus-article-treat-ansi-sequences
- "h" gnus-article-wash-html
- "u" gnus-article-unsplit-urls
- "s" gnus-summary-force-verify-and-decrypt
- "f" gnus-article-display-x-face
- "l" gnus-summary-stop-page-breaking
- "r" gnus-summary-caesar-message
- "m" gnus-summary-morse-message
- "t" gnus-summary-toggle-header
- "g" gnus-treat-smiley
- "v" gnus-summary-verbose-headers
- "a" gnus-article-strip-headers-in-body ;; mnemonic: wash archive
- "p" gnus-article-verify-x-pgp-sig
- "d" gnus-article-treat-smartquotes
- "U" gnus-article-treat-non-ascii
- "i" gnus-summary-idna-message)
-
-(gnus-define-keys (gnus-summary-wash-deuglify-map "Y" gnus-summary-wash-map)
- ;; mnemonic: deuglif*Y*
- "u" gnus-article-outlook-unwrap-lines
- "a" gnus-article-outlook-repair-attribution
- "c" gnus-article-outlook-rearrange-citation
- "f" gnus-article-outlook-deuglify-article) ;; mnemonic: full deuglify
-
-(gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map)
- "a" gnus-article-hide
- "h" gnus-article-hide-headers
- "b" gnus-article-hide-boring-headers
- "s" gnus-article-hide-signature
- "c" gnus-article-hide-citation
- "C" gnus-article-hide-citation-in-followups
- "l" gnus-article-hide-list-identifiers
- "B" gnus-article-strip-banner
- "P" gnus-article-hide-pem
- "\C-c" gnus-article-hide-citation-maybe)
-
-(gnus-define-keys (gnus-summary-wash-highlight-map "H" gnus-summary-wash-map)
- "a" gnus-article-highlight
- "h" gnus-article-highlight-headers
- "c" gnus-article-highlight-citation
- "s" gnus-article-highlight-signature)
-
-(gnus-define-keys (gnus-summary-wash-header-map "G" gnus-summary-wash-map)
- "f" gnus-article-treat-fold-headers
- "u" gnus-article-treat-unfold-headers
- "n" gnus-article-treat-fold-newsgroups)
-
-(gnus-define-keys (gnus-summary-wash-display-map "D" gnus-summary-wash-map)
- "x" gnus-article-display-x-face
- "d" gnus-article-display-face
- "s" gnus-treat-smiley
- "D" gnus-article-remove-images
- "W" gnus-article-show-images
- "F" gnus-article-toggle-fonts
- "f" gnus-treat-from-picon
- "m" gnus-treat-mail-picon
- "n" gnus-treat-newsgroups-picon
- "g" gnus-treat-from-gravatar
- "h" gnus-treat-mail-gravatar)
-
-(gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map)
- "w" gnus-article-decode-mime-words
- "c" gnus-article-decode-charset
- "h" gnus-mime-buttonize-attachments-in-header
- "v" gnus-mime-view-all-parts
- "b" gnus-article-view-part)
-
-(gnus-define-keys (gnus-summary-wash-time-map "T" gnus-summary-wash-map)
- "z" gnus-article-date-ut
- "u" gnus-article-date-ut
- "l" gnus-article-date-local
- "p" gnus-article-date-english
- "e" gnus-article-date-lapsed
- "o" gnus-article-date-original
- "i" gnus-article-date-iso8601
- "s" gnus-article-date-user)
-
-(gnus-define-keys (gnus-summary-wash-empty-map "E" gnus-summary-wash-map)
- "t" gnus-article-remove-trailing-blank-lines
- "l" gnus-article-strip-leading-blank-lines
- "m" gnus-article-strip-multiple-blank-lines
- "a" gnus-article-strip-blank-lines
- "A" gnus-article-strip-all-blank-lines
- "s" gnus-article-strip-leading-space
- "e" gnus-article-strip-trailing-space
- "w" gnus-article-remove-leading-whitespace)
-
-(gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map)
- "v" gnus-version
- "d" gnus-summary-describe-group
- "h" gnus-summary-describe-briefly
- "i" gnus-info-find-node)
-
-(gnus-define-keys (gnus-summary-backend-map "B" gnus-summary-mode-map)
- "e" gnus-summary-expire-articles
- "\M-\C-e" gnus-summary-expire-articles-now
- "\177" gnus-summary-delete-article
- [delete] gnus-summary-delete-article
- [backspace] gnus-summary-delete-article
- "m" gnus-summary-move-article
- "r" gnus-summary-respool-article
- "w" gnus-summary-edit-article
- "c" gnus-summary-copy-article
- "B" gnus-summary-crosspost-article
- "q" gnus-summary-respool-query
- "t" gnus-summary-respool-trace
- "i" gnus-summary-import-article
- "I" gnus-summary-create-article
- "p" gnus-summary-article-posted-p)
-
-(gnus-define-keys (gnus-summary-save-map "O" gnus-summary-mode-map)
- "o" gnus-summary-save-article
- "m" gnus-summary-save-article-mail
- "F" gnus-summary-write-article-file
- "r" gnus-summary-save-article-rmail
- "f" gnus-summary-save-article-file
- "b" gnus-summary-save-article-body-file
- "B" gnus-summary-write-article-body-file
- "h" gnus-summary-save-article-folder
- "v" gnus-summary-save-article-vm
- "p" gnus-summary-pipe-output
- "P" gnus-summary-muttprint)
-
-(gnus-define-keys (gnus-summary-mime-map "K" gnus-summary-mode-map)
- "b" gnus-summary-display-buttonized
- "m" gnus-summary-repair-multipart
- "v" gnus-article-view-part
- "o" gnus-article-save-part
- "O" gnus-article-save-part-and-strip
- "r" gnus-article-replace-part
- "d" gnus-article-delete-part
- "t" gnus-article-view-part-as-type
- "j" gnus-article-jump-to-part
- "c" gnus-article-copy-part
- "C" gnus-article-view-part-as-charset
- "e" gnus-article-view-part-externally
- "H" gnus-article-browse-html-article
- "E" gnus-article-encrypt-body
- "i" gnus-article-inline-part
- "|" gnus-article-pipe-part)
-
-(gnus-define-keys (gnus-uu-mark-map "P" gnus-summary-mark-map)
- "p" gnus-summary-mark-as-processable
- "u" gnus-summary-unmark-as-processable
- "U" gnus-summary-unmark-all-processable
- "v" gnus-uu-mark-over
- "s" gnus-uu-mark-series
- "r" gnus-uu-mark-region
- "g" gnus-uu-unmark-region
- "R" gnus-uu-mark-by-regexp
- "G" gnus-uu-unmark-by-regexp
- "t" gnus-uu-mark-thread
- "T" gnus-uu-unmark-thread
- "a" gnus-uu-mark-all
- "b" gnus-uu-mark-buffer
- "S" gnus-uu-mark-sparse
- "k" gnus-summary-kill-process-mark
- "y" gnus-summary-yank-process-mark
- "w" gnus-summary-save-process-mark
- "i" gnus-uu-invert-processable)
-
-(gnus-define-keys (gnus-uu-extract-map "X" gnus-summary-mode-map)
- ;;"x" gnus-uu-extract-any
- "m" gnus-summary-save-parts
- "u" gnus-uu-decode-uu
- "U" gnus-uu-decode-uu-and-save
- "s" gnus-uu-decode-unshar
- "S" gnus-uu-decode-unshar-and-save
- "o" gnus-uu-decode-save
- "O" gnus-uu-decode-save
- "b" gnus-uu-decode-binhex
- "B" gnus-uu-decode-binhex
- "Y" gnus-uu-decode-yenc
- "p" gnus-uu-decode-postscript
- "P" gnus-uu-decode-postscript-and-save)
-
-(gnus-define-keys
- (gnus-uu-extract-view-map "v" gnus-uu-extract-map)
- "u" gnus-uu-decode-uu-view
- "U" gnus-uu-decode-uu-and-save-view
- "s" gnus-uu-decode-unshar-view
- "S" gnus-uu-decode-unshar-and-save-view
- "o" gnus-uu-decode-save-view
- "O" gnus-uu-decode-save-view
- "b" gnus-uu-decode-binhex-view
- "B" gnus-uu-decode-binhex-view
- "p" gnus-uu-decode-postscript-view
- "P" gnus-uu-decode-postscript-and-save-view)
+ "C-c C-d" #'gnus-summary-describe-group
+ "C-c C-p" #'gnus-summary-make-group-from-search
+ "q" #'gnus-summary-exit
+ "Q" #'gnus-summary-exit-no-update
+ "C-c C-i" #'gnus-info-find-node
+ "<mouse-2>" #'gnus-mouse-pick-article
+ "<follow-link>" 'mouse-face
+ "m" #'gnus-summary-mail-other-window
+ "a" #'gnus-summary-post-news
+ "x" #'gnus-summary-limit-to-unread
+ "s" #'gnus-summary-isearch-article
+ "TAB" #'gnus-summary-button-forward
+ "<backtab>" #'gnus-summary-button-backward
+ "w" #'gnus-summary-browse-url
+ "t" #'gnus-summary-toggle-header
+ "g" #'gnus-summary-show-article
+ "l" #'gnus-summary-goto-last-article
+ "C-c C-v C-v" #'gnus-uu-decode-uu-view
+ "C-d" #'gnus-summary-enter-digest-group
+ "C-M-d" #'gnus-summary-read-document
+ "C-M-e" #'gnus-summary-edit-parameters
+ "C-M-a" #'gnus-summary-customize-parameters
+ "C-c C-b" #'gnus-bug
+ "*" #'gnus-cache-enter-article
+ "M-*" #'gnus-cache-remove-article
+ "M-&" #'gnus-summary-universal-argument
+ "C-l" #'gnus-recenter
+ "I" #'gnus-summary-increase-score
+ "L" #'gnus-summary-lower-score
+ "M-i" #'gnus-symbolic-argument
+ "h" #'gnus-summary-select-article-buffer
+
+ "b" #'gnus-article-view-part
+ "M-t" #'gnus-summary-toggle-display-buttonized
+
+ "S" #'gnus-summary-send-map
+
+ ;; Sort of orthogonal keymaps.
+ "M" (define-keymap :prefix 'gnus-summary-mark-map
+ "t" #'gnus-summary-tick-article-forward
+ "!" #'gnus-summary-tick-article-forward
+ "d" #'gnus-summary-mark-as-read-forward
+ "r" #'gnus-summary-mark-as-read-forward
+ "c" #'gnus-summary-clear-mark-forward
+ "SPC" #'gnus-summary-clear-mark-forward
+ "e" #'gnus-summary-mark-as-expirable
+ "x" #'gnus-summary-mark-as-expirable
+ "?" #'gnus-summary-mark-as-dormant
+ "b" #'gnus-summary-set-bookmark
+ "B" #'gnus-summary-remove-bookmark
+ "#" #'gnus-summary-mark-as-processable
+ "M-#" #'gnus-summary-unmark-as-processable
+ "S" #'gnus-summary-limit-include-expunged
+ "C" #'gnus-summary-catchup
+ "H" #'gnus-summary-catchup-to-here
+ "h" #'gnus-summary-catchup-from-here
+ "C-c" #'gnus-summary-catchup-all
+ "k" #'gnus-summary-kill-same-subject-and-select
+ "K" #'gnus-summary-kill-same-subject
+
+ "P" (define-keymap :prefix 'gnus-uu-mark-map
+ "p" #'gnus-summary-mark-as-processable
+ "u" #'gnus-summary-unmark-as-processable
+ "U" #'gnus-summary-unmark-all-processable
+ "v" #'gnus-uu-mark-over
+ "s" #'gnus-uu-mark-series
+ "r" #'gnus-uu-mark-region
+ "g" #'gnus-uu-unmark-region
+ "R" #'gnus-uu-mark-by-regexp
+ "G" #'gnus-uu-unmark-by-regexp
+ "t" #'gnus-uu-mark-thread
+ "T" #'gnus-uu-unmark-thread
+ "a" #'gnus-uu-mark-all
+ "b" #'gnus-uu-mark-buffer
+ "S" #'gnus-uu-mark-sparse
+ "k" #'gnus-summary-kill-process-mark
+ "y" #'gnus-summary-yank-process-mark
+ "w" #'gnus-summary-save-process-mark
+ "i" #'gnus-uu-invert-processable)
+
+ "V" (define-keymap :prefix 'gnus-summary-mscore-map
+ "c" #'gnus-summary-clear-above
+ "u" #'gnus-summary-tick-above
+ "m" #'gnus-summary-mark-above
+ "k" #'gnus-summary-kill-below))
+
+ "/" (define-keymap :prefix 'gnus-summary-limit-map
+ "/" #'gnus-summary-limit-to-subject
+ "n" #'gnus-summary-limit-to-articles
+ "b" #'gnus-summary-limit-to-bodies
+ "h" #'gnus-summary-limit-to-headers
+ "w" #'gnus-summary-pop-limit
+ "s" #'gnus-summary-limit-to-subject
+ "a" #'gnus-summary-limit-to-author
+ "u" #'gnus-summary-limit-to-unread
+ "m" #'gnus-summary-limit-to-marks
+ "M" #'gnus-summary-limit-exclude-marks
+ "v" #'gnus-summary-limit-to-score
+ "*" #'gnus-summary-limit-include-cached
+ "D" #'gnus-summary-limit-include-dormant
+ "T" #'gnus-summary-limit-include-thread
+ "d" #'gnus-summary-limit-exclude-dormant
+ "t" #'gnus-summary-limit-to-age
+ "." #'gnus-summary-limit-to-unseen
+ "x" #'gnus-summary-limit-to-extra
+ "p" #'gnus-summary-limit-to-display-predicate
+ "E" #'gnus-summary-limit-include-expunged
+ "c" #'gnus-summary-limit-exclude-childless-dormant
+ "C" #'gnus-summary-limit-mark-excluded-as-read
+ "o" #'gnus-summary-insert-old-articles
+ "N" #'gnus-summary-insert-new-articles
+ "S" #'gnus-summary-limit-to-singletons
+ "r" #'gnus-summary-limit-to-replied
+ "R" #'gnus-summary-limit-to-recipient
+ "A" #'gnus-summary-limit-to-address)
+
+ "G" (define-keymap :prefix 'gnus-summary-goto-map
+ "n" #'gnus-summary-next-unread-article
+ "p" #'gnus-summary-prev-unread-article
+ "N" #'gnus-summary-next-article
+ "P" #'gnus-summary-prev-article
+ "C-n" #'gnus-summary-next-same-subject
+ "C-p" #'gnus-summary-prev-same-subject
+ "M-n" #'gnus-summary-next-unread-subject
+ "M-p" #'gnus-summary-prev-unread-subject
+ "f" #'gnus-summary-first-unread-article
+ "b" #'gnus-summary-best-unread-article
+ "u" #'gnus-summary-next-unseen-article
+ "U" #'gnus-summary-prev-unseen-article
+ "j" #'gnus-summary-goto-article
+ "g" #'gnus-summary-goto-subject
+ "l" #'gnus-summary-goto-last-article
+ "o" #'gnus-summary-pop-article)
+
+ "T" (define-keymap :prefix 'gnus-summary-thread-map
+ "k" #'gnus-summary-kill-thread
+ "E" #'gnus-summary-expire-thread
+ "l" #'gnus-summary-lower-thread
+ "i" #'gnus-summary-raise-thread
+ "T" #'gnus-summary-toggle-threads
+ "t" #'gnus-summary-rethread-current
+ "^" #'gnus-summary-reparent-thread
+ "M-^" #'gnus-summary-reparent-children
+ "s" #'gnus-summary-show-thread
+ "S" #'gnus-summary-show-all-threads
+ "h" #'gnus-summary-hide-thread
+ "H" #'gnus-summary-hide-all-threads
+ "n" #'gnus-summary-next-thread
+ "p" #'gnus-summary-prev-thread
+ "u" #'gnus-summary-up-thread
+ "o" #'gnus-summary-top-thread
+ "d" #'gnus-summary-down-thread
+ "#" #'gnus-uu-mark-thread
+ "M-#" #'gnus-uu-unmark-thread)
+
+ "Y" (define-keymap :prefix 'gnus-summary-buffer-map
+ "g" #'gnus-summary-prepare
+ "c" #'gnus-summary-insert-cached-articles
+ "d" #'gnus-summary-insert-dormant-articles
+ "t" #'gnus-summary-insert-ticked-articles)
+
+ "Z" (define-keymap :prefix 'gnus-summary-exit-map
+ "c" #'gnus-summary-catchup-and-exit
+ "C" #'gnus-summary-catchup-all-and-exit
+ "E" #'gnus-summary-exit-no-update
+ "Q" #'gnus-summary-exit
+ "Z" #'gnus-summary-exit
+ "n" #'gnus-summary-catchup-and-goto-next-group
+ "p" #'gnus-summary-catchup-and-goto-prev-group
+ "R" #'gnus-summary-reselect-current-group
+ "G" #'gnus-summary-rescan-group
+ "N" #'gnus-summary-next-group
+ "s" #'gnus-summary-save-newsrc
+ "P" #'gnus-summary-prev-group)
+
+ "A" (define-keymap :prefix 'gnus-summary-article-map
+ "SPC" #'gnus-summary-next-page
+ "n" #'gnus-summary-next-page
+ "S-SPC" #'gnus-summary-prev-page
+ "DEL" #'gnus-summary-prev-page
+ "<delete>" #'gnus-summary-prev-page
+ "p" #'gnus-summary-prev-page
+ "RET" #'gnus-summary-scroll-up
+ "M-RET" #'gnus-summary-scroll-down
+ "<" #'gnus-summary-beginning-of-article
+ ">" #'gnus-summary-end-of-article
+ "b" #'gnus-summary-beginning-of-article
+ "e" #'gnus-summary-end-of-article
+ "^" #'gnus-summary-refer-parent-article
+ "r" #'gnus-summary-refer-parent-article
+ "C" #'gnus-summary-show-complete-article
+ "D" #'gnus-summary-enter-digest-group
+ "R" #'gnus-summary-refer-references
+ "T" #'gnus-summary-refer-thread
+ "W" #'gnus-warp-to-article
+ "g" #'gnus-summary-show-article
+ "s" #'gnus-summary-isearch-article
+ "TAB" #'gnus-summary-button-forward
+ "<backtab>" #'gnus-summary-button-backward
+ "w" #'gnus-summary-browse-url
+ "P" #'gnus-summary-print-article
+ "S" #'gnus-sticky-article
+ "M" #'gnus-mailing-list-insinuate
+ "t" #'gnus-article-babel)
+
+ "W" (define-keymap :prefix 'gnus-summary-wash-map
+ "b" #'gnus-article-add-buttons
+ "B" #'gnus-article-add-buttons-to-head
+ "o" #'gnus-article-treat-overstrike
+ "e" #'gnus-article-emphasize
+ "w" #'gnus-article-fill-cited-article
+ "Q" #'gnus-article-fill-long-lines
+ "L" #'gnus-article-toggle-truncate-lines
+ "C" #'gnus-article-capitalize-sentences
+ "c" #'gnus-article-remove-cr
+ "q" #'gnus-article-de-quoted-unreadable
+ "6" #'gnus-article-de-base64-unreadable
+ "Z" #'gnus-article-decode-HZ
+ "A" #'gnus-article-treat-ansi-sequences
+ "h" #'gnus-article-wash-html
+ "u" #'gnus-article-unsplit-urls
+ "s" #'gnus-summary-force-verify-and-decrypt
+ "f" #'gnus-article-display-x-face
+ "l" #'gnus-summary-stop-page-breaking
+ "r" #'gnus-summary-caesar-message
+ "m" #'gnus-summary-morse-message
+ "t" #'gnus-summary-toggle-header
+ "g" #'gnus-treat-smiley
+ "v" #'gnus-summary-verbose-headers
+ "a" #'gnus-article-strip-headers-in-body ;; mnemonic: wash archive
+ "p" #'gnus-article-verify-x-pgp-sig
+ "d" #'gnus-article-treat-smartquotes
+ "U" #'gnus-article-treat-non-ascii
+ "i" #'gnus-summary-idna-message
+
+ "Y" (define-keymap :prefix 'gnus-summary-wash-deuglify-map
+ ;; mnemonic: deuglif*Y*
+ "u" #'gnus-article-outlook-unwrap-lines
+ "a" #'gnus-article-outlook-repair-attribution
+ "c" #'gnus-article-outlook-rearrange-citation
+ ;; mnemonic: full deuglify
+ "f" #'gnus-article-outlook-deuglify-article)
+
+ "W" (define-keymap :prefix 'gnus-summary-wash-hide-map
+ "a" #'gnus-article-hide
+ "h" #'gnus-article-hide-headers
+ "b" #'gnus-article-hide-boring-headers
+ "s" #'gnus-article-hide-signature
+ "c" #'gnus-article-hide-citation
+ "C" #'gnus-article-hide-citation-in-followups
+ "l" #'gnus-article-hide-list-identifiers
+ "B" #'gnus-article-strip-banner
+ "P" #'gnus-article-hide-pem
+ "C-c" #'gnus-article-hide-citation-maybe)
+
+ "H" (define-keymap :prefix 'gnus-summary-wash-highlight-map
+ "a" #'gnus-article-highlight
+ "h" #'gnus-article-highlight-headers
+ "c" #'gnus-article-highlight-citation
+ "s" #'gnus-article-highlight-signature)
+
+ "G" (define-keymap :prefix 'gnus-summary-wash-header-map
+ "f" #'gnus-article-treat-fold-headers
+ "u" #'gnus-article-treat-unfold-headers
+ "n" #'gnus-article-treat-fold-newsgroups)
+
+ "D" (define-keymap :prefix 'gnus-summary-wash-display-map
+ "x" #'gnus-article-display-x-face
+ "d" #'gnus-article-display-face
+ "s" #'gnus-treat-smiley
+ "e" #'gnus-article-emojize-symbols
+ "D" #'gnus-article-remove-images
+ "W" #'gnus-article-show-images
+ "F" #'gnus-article-toggle-fonts
+ "f" #'gnus-treat-from-picon
+ "m" #'gnus-treat-mail-picon
+ "n" #'gnus-treat-newsgroups-picon
+ "g" #'gnus-treat-from-gravatar
+ "h" #'gnus-treat-mail-gravatar)
+
+ "M" (define-keymap :prefix 'gnus-summary-wash-mime-map
+ "w" #'gnus-article-decode-mime-words
+ "c" #'gnus-article-decode-charset
+ "h" #'gnus-mime-buttonize-attachments-in-header
+ "v" #'gnus-mime-view-all-parts
+ "b" #'gnus-article-view-part)
+
+ "T" (define-keymap :prefix 'gnus-summary-wash-time-map
+ "z" #'gnus-article-date-ut
+ "u" #'gnus-article-date-ut
+ "l" #'gnus-article-date-local
+ "p" #'gnus-article-date-english
+ "e" #'gnus-article-date-lapsed
+ "o" #'gnus-article-date-original
+ "i" #'gnus-article-date-iso8601
+ "s" #'gnus-article-date-user)
+
+ "E" (define-keymap :prefix 'gnus-summary-wash-empty-map
+ "t" #'gnus-article-remove-trailing-blank-lines
+ "l" #'gnus-article-strip-leading-blank-lines
+ "m" #'gnus-article-strip-multiple-blank-lines
+ "a" #'gnus-article-strip-blank-lines
+ "A" #'gnus-article-strip-all-blank-lines
+ "s" #'gnus-article-strip-leading-space
+ "e" #'gnus-article-strip-trailing-space
+ "w" #'gnus-article-remove-leading-whitespace))
+
+ "H" (define-keymap :prefix 'gnus-summary-help-map
+ "v" #'gnus-version
+ "d" #'gnus-summary-describe-group
+ "h" #'gnus-summary-describe-briefly
+ "i" #'gnus-info-find-node)
+
+ "B" (define-keymap :prefix 'gnus-summary-backend-map
+ "e" #'gnus-summary-expire-articles
+ "C-M-e" #'gnus-summary-expire-articles-now
+ "DEL" #'gnus-summary-delete-article
+ "<delete>" #'gnus-summary-delete-article
+ "<backspace>" #'gnus-summary-delete-article
+ "m" #'gnus-summary-move-article
+ "r" #'gnus-summary-respool-article
+ "w" #'gnus-summary-edit-article
+ "c" #'gnus-summary-copy-article
+ "B" #'gnus-summary-crosspost-article
+ "q" #'gnus-summary-respool-query
+ "t" #'gnus-summary-respool-trace
+ "i" #'gnus-summary-import-article
+ "I" #'gnus-summary-create-article
+ "p" #'gnus-summary-article-posted-p)
+
+ "O" (define-keymap :prefix 'gnus-summary-save-map
+ "o" #'gnus-summary-save-article
+ "m" #'gnus-summary-save-article-mail
+ "F" #'gnus-summary-write-article-file
+ "r" #'gnus-summary-save-article-rmail
+ "f" #'gnus-summary-save-article-file
+ "b" #'gnus-summary-save-article-body-file
+ "B" #'gnus-summary-write-article-body-file
+ "h" #'gnus-summary-save-article-folder
+ "v" #'gnus-summary-save-article-vm
+ "p" #'gnus-summary-pipe-output
+ "P" #'gnus-summary-muttprint)
+
+ "K" (define-keymap :prefix 'gnus-summary-mime-map
+ "b" #'gnus-summary-display-buttonized
+ "m" #'gnus-summary-repair-multipart
+ "v" #'gnus-article-view-part
+ "o" #'gnus-article-save-part
+ "O" #'gnus-article-save-part-and-strip
+ "r" #'gnus-article-replace-part
+ "d" #'gnus-article-delete-part
+ "t" #'gnus-article-view-part-as-type
+ "j" #'gnus-article-jump-to-part
+ "c" #'gnus-article-copy-part
+ "C" #'gnus-article-view-part-as-charset
+ "e" #'gnus-article-view-part-externally
+ "H" #'gnus-article-browse-html-article
+ "E" #'gnus-article-encrypt-body
+ "i" #'gnus-article-inline-part
+ "|" #'gnus-article-pipe-part)
+
+ "X" (define-keymap :prefix 'gnus-uu-extract-map
+ ;;"x" gnus-uu-extract-any
+ "m" #'gnus-summary-save-parts
+ "u" #'gnus-uu-decode-uu
+ "U" #'gnus-uu-decode-uu-and-save
+ "s" #'gnus-uu-decode-unshar
+ "S" #'gnus-uu-decode-unshar-and-save
+ "o" #'gnus-uu-decode-save
+ "O" #'gnus-uu-decode-save
+ "b" #'gnus-uu-decode-binhex
+ "B" #'gnus-uu-decode-binhex
+ "Y" #'gnus-uu-decode-yenc
+ "p" #'gnus-uu-decode-postscript
+ "P" #'gnus-uu-decode-postscript-and-save
+
+ "v" (define-keymap :prefix 'gnus-uu-extract-view-map
+ "u" #'gnus-uu-decode-uu-view
+ "U" #'gnus-uu-decode-uu-and-save-view
+ "s" #'gnus-uu-decode-unshar-view
+ "S" #'gnus-uu-decode-unshar-and-save-view
+ "o" #'gnus-uu-decode-save-view
+ "O" #'gnus-uu-decode-save-view
+ "b" #'gnus-uu-decode-binhex-view
+ "B" #'gnus-uu-decode-binhex-view
+ "p" #'gnus-uu-decode-postscript-view
+ "P" #'gnus-uu-decode-postscript-and-save-view)))
(defvar gnus-article-post-menu nil)
@@ -3970,10 +3968,9 @@ Returns \" ? \" if there's bad input or if another error occurs.
Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"."
(condition-case ()
(let* ((messy-date (gnus-date-get-time messy-date))
- (now (current-time))
;;If we don't find something suitable we'll use this one
(my-format "%b %d '%y"))
- (let* ((difference (time-subtract now messy-date))
+ (let* ((difference (time-subtract nil messy-date))
(templist gnus-user-date-format-alist)
(top (eval (caar templist) t)))
(while (if (numberp top) (time-less-p top difference) (not top))
@@ -5004,23 +5001,13 @@ If LINE, insert the rebuilt thread starting on line LINE."
gnus-article-sort-functions)))
(gnus-message 7 "Sorting articles...done"))))
-;; Written by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
-(defmacro gnus-thread-header (thread)
- "Return header of first article in THREAD.
-Note that THREAD must never, ever be anything else than a variable -
-using some other form will lead to serious barfage."
- (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread)))
- ;; (8% speedup to gnus-summary-prepare, just for fun :-)
- (cond
- ((and (boundp 'lexical-binding) lexical-binding)
- ;; FIXME: This version could be a "defsubst" rather than a macro.
- `(#[257 "\211:\203\16\0\211@;\203\15\0A@@\207"
- [] 2]
- ,thread))
- (t
- ;; Not sure how XEmacs handles these things, so let's keep the old code.
- (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207"
- (vector thread) 2))))
+(defsubst gnus-thread-header (thread)
+ "Return header of first article in THREAD."
+ (if (consp thread)
+ (car (if (stringp (car thread))
+ (cadr thread)
+ thread))
+ thread))
(defsubst gnus-article-sort-by-number (h1 h2)
"Sort articles by article number."
@@ -7208,7 +7195,6 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(gnus-dribble-save)))
(declare-function gnus-cache-write-active "gnus-cache" (&optional force))
-(declare-function gnus-article-stop-animations "gnus-art" ())
(defun gnus-summary-exit (&optional temporary leave-hidden)
"Exit reading current newsgroup, and then return to group selection mode.
@@ -7272,7 +7258,6 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(not (string= group (gnus-group-group-name))))
(gnus-group-next-unread-group 1))
(setq group-point (point))
- (gnus-article-stop-animations)
(unless leave-hidden
(gnus-configure-windows 'group 'force))
(if temporary
@@ -7332,7 +7317,6 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(run-hooks 'gnus-summary-prepare-exit-hook)
(when (gnus-buffer-live-p gnus-article-buffer)
(with-current-buffer gnus-article-buffer
- (gnus-article-stop-animations)
(gnus-stop-downloads)
(mm-destroy-parts gnus-article-mime-handles)
;; Set it to nil for safety reason.
@@ -7364,7 +7348,6 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(gnus-group-update-group group nil t))
(when (gnus-group-goto-group group)
(gnus-group-next-unread-group 1))
- (gnus-article-stop-animations)
(when quit-config
(gnus-handle-ephemeral-exit quit-config)))))
@@ -8067,9 +8050,7 @@ Return nil if there are no unread articles."
Return nil if there are no unread articles."
(interactive nil gnus-summary-mode)
(prog1
- (when (gnus-summary-first-subject t)
- (gnus-summary-show-thread)
- (gnus-summary-first-subject t))
+ (gnus-summary--goto-and-possibly-unhide t)
(gnus-summary-position-point)))
(defun gnus-summary-next-unseen-article (&optional backward)
@@ -8103,23 +8084,27 @@ Return nil if there are no unread articles."
Return nil if there are no unseen articles."
(interactive nil gnus-summary-mode)
(prog1
- (when (gnus-summary-first-subject nil nil t)
- (gnus-summary-show-thread)
- (gnus-summary-first-subject nil nil t))
+ (gnus-summary--goto-and-possibly-unhide)
(gnus-summary-position-point)))
+(defun gnus-summary--goto-and-possibly-unhide (&optional unread undownloaded
+ unseen)
+ (let ((first (gnus-summary-first-subject unread undownloaded unseen)))
+ (if (and first
+ (not (= first (gnus-summary-article-number))))
+ (progn
+ (gnus-summary-show-thread)
+ (gnus-summary-first-subject unread undownloaded unseen))
+ first)))
+
(defun gnus-summary-first-unseen-or-unread-subject ()
"Place the point on the subject line of the first unseen and unread article.
If all articles have been seen, on the subject line of the first unread
article."
(interactive nil gnus-summary-mode)
(prog1
- (unless (when (gnus-summary-first-subject nil nil t)
- (gnus-summary-show-thread)
- (gnus-summary-first-subject nil nil t))
- (when (gnus-summary-first-subject t)
- (gnus-summary-show-thread)
- (gnus-summary-first-subject t)))
+ (unless (gnus-summary--goto-and-possibly-unhide nil nil t)
+ (gnus-summary-first-subject t))
(gnus-summary-position-point)))
(defun gnus-summary-first-article ()
@@ -9908,7 +9893,6 @@ article. Normally, the keystroke is `\\[universal-argument] \\[gnus-summary-sho
;; Destroy any MIME parts.
(when (gnus-buffer-live-p gnus-article-buffer)
(with-current-buffer gnus-article-buffer
- (gnus-article-stop-animations)
(gnus-stop-downloads)
(mm-destroy-parts gnus-article-mime-handles)
;; Set it to nil for safety reason.
@@ -10501,7 +10485,6 @@ latter case, they will be copied into the relevant groups."
"Create an article in a mail newsgroup."
(interactive nil gnus-summary-mode)
(let ((group gnus-newsgroup-name)
- (now (current-time))
group-art)
(unless (gnus-check-backend-function 'request-accept-article group)
(error "%s does not support article importing" group))
@@ -10511,7 +10494,7 @@ latter case, they will be copied into the relevant groups."
;; This doesn't look like an article, so we fudge some headers.
(insert "From: " (read-string "From: ") "\n"
"Subject: " (read-string "Subject: ") "\n"
- "Date: " (message-make-date now) "\n"
+ "Date: " (message-make-date) "\n"
"Message-ID: " (message-make-message-id) "\n")
(setq group-art (gnus-request-accept-article group nil t))
(kill-buffer (current-buffer)))
diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el
index c8bcccdfdde..0855e98917f 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -1056,63 +1056,56 @@ articles in the topic and its subtopics."
;;; Topic mode, commands and keymap.
-(defvar gnus-topic-mode-map nil)
-(defvar gnus-group-topic-map nil)
-
-(unless gnus-topic-mode-map
- (setq gnus-topic-mode-map (make-sparse-keymap))
-
+(defvar-keymap gnus-topic-mode-map
;; Override certain group mode keys.
- (gnus-define-keys gnus-topic-mode-map
- "=" gnus-topic-select-group
- "\r" gnus-topic-select-group
- " " gnus-topic-read-group
- "\C-c\C-x" gnus-topic-expire-articles
- "c" gnus-topic-catchup-articles
- "\C-k" gnus-topic-kill-group
- "\C-y" gnus-topic-yank-group
- "\M-g" gnus-topic-get-new-news-this-topic
- "AT" gnus-topic-list-active
- "Gp" gnus-topic-edit-parameters
- "#" gnus-topic-mark-topic
- "\M-#" gnus-topic-unmark-topic
- [tab] gnus-topic-indent
- [(meta tab)] gnus-topic-unindent
- "\C-i" gnus-topic-indent
- "\M-\C-i" gnus-topic-unindent
- [mouse-2] gnus-mouse-pick-topic)
-
- ;; Define a new submap.
- (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map)
- "#" gnus-topic-mark-topic
- "\M-#" gnus-topic-unmark-topic
- "n" gnus-topic-create-topic
- "m" gnus-topic-move-group
- "D" gnus-topic-remove-group
- "c" gnus-topic-copy-group
- "h" gnus-topic-hide-topic
- "s" gnus-topic-show-topic
- "j" gnus-topic-jump-to-topic
- "M" gnus-topic-move-matching
- "C" gnus-topic-copy-matching
- "\M-p" gnus-topic-goto-previous-topic
- "\M-n" gnus-topic-goto-next-topic
- "\C-i" gnus-topic-indent
- [tab] gnus-topic-indent
- "r" gnus-topic-rename
- "\177" gnus-topic-delete
- [delete] gnus-topic-delete
- "H" gnus-topic-toggle-display-empty-topics)
-
- (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map)
- "s" gnus-topic-sort-groups
- "a" gnus-topic-sort-groups-by-alphabet
- "u" gnus-topic-sort-groups-by-unread
- "l" gnus-topic-sort-groups-by-level
- "e" gnus-topic-sort-groups-by-server
- "v" gnus-topic-sort-groups-by-score
- "r" gnus-topic-sort-groups-by-rank
- "m" gnus-topic-sort-groups-by-method))
+ "=" #'gnus-topic-select-group
+ "RET" #'gnus-topic-select-group
+ "SPC" #'gnus-topic-read-group
+ "C-c C-x" #'gnus-topic-expire-articles
+ "c" #'gnus-topic-catchup-articles
+ "C-k" #'gnus-topic-kill-group
+ "C-y" #'gnus-topic-yank-group
+ "M-g" #'gnus-topic-get-new-news-this-topic
+ "A T" #'gnus-topic-list-active
+ "G p" #'gnus-topic-edit-parameters
+ "#" #'gnus-topic-mark-topic
+ "M-#" #'gnus-topic-unmark-topic
+ "<tab>" #'gnus-topic-indent
+ "M-<tab>" #'gnus-topic-unindent
+ "TAB" #'gnus-topic-indent
+ "C-M-i" #'gnus-topic-unindent
+ "<mouse-2>" #'gnus-mouse-pick-topic
+
+ "T" (define-keymap :prefix 'gnus-group-topic-map
+ "#" #'gnus-topic-mark-topic
+ "M-#" #'gnus-topic-unmark-topic
+ "n" #'gnus-topic-create-topic
+ "m" #'gnus-topic-move-group
+ "D" #'gnus-topic-remove-group
+ "c" #'gnus-topic-copy-group
+ "h" #'gnus-topic-hide-topic
+ "s" #'gnus-topic-show-topic
+ "j" #'gnus-topic-jump-to-topic
+ "M" #'gnus-topic-move-matching
+ "C" #'gnus-topic-copy-matching
+ "M-p" #'gnus-topic-goto-previous-topic
+ "M-n" #'gnus-topic-goto-next-topic
+ "TAB" #'gnus-topic-indent
+ "<tab>" #'gnus-topic-indent
+ "r" #'gnus-topic-rename
+ "DEL" #'gnus-topic-delete
+ "<delete>" #'gnus-topic-delete
+ "H" #'gnus-topic-toggle-display-empty-topics
+
+ "S" (define-keymap :prefix 'gnus-topic-sort-map
+ "s" #'gnus-topic-sort-groups
+ "a" #'gnus-topic-sort-groups-by-alphabet
+ "u" #'gnus-topic-sort-groups-by-unread
+ "l" #'gnus-topic-sort-groups-by-level
+ "e" #'gnus-topic-sort-groups-by-server
+ "v" #'gnus-topic-sort-groups-by-score
+ "r" #'gnus-topic-sort-groups-by-rank
+ "m" #'gnus-topic-sort-groups-by-method)))
(defun gnus-topic-make-menu-bar ()
(unless (boundp 'gnus-topic-menu)
diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el
index 07cf5d495a6..a82b1f87a3e 100644
--- a/lisp/gnus/gnus-undo.el
+++ b/lisp/gnus/gnus-undo.el
@@ -75,15 +75,12 @@
;;; Minor mode definition.
-(defvar gnus-undo-mode-map
- (let ((map (make-sparse-keymap)))
- (gnus-define-keys map
- "\M-\C-_" gnus-undo
- "\C-_" gnus-undo
- "\C-xu" gnus-undo
- ;; Many people are used to type `C-/' on GUI frames and get `C-_'.
- [(control /)] gnus-undo)
- map))
+(defvar-keymap gnus-undo-mode-map
+ "C-M-_" #'gnus-undo
+ "C-_" #'gnus-undo
+ "C-x u" #'gnus-undo
+ ;; many people are used to type `C-/' on GUI frames and get `C-_'.
+ "C-/" #'gnus-undo)
(defun gnus-undo-make-menu-bar ()
;; This is disabled for the time being.
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el
index fb285962d6f..8dbdcc83f8b 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -300,25 +300,26 @@ Symbols are also allowed; their print names are used instead."
(defmacro gnus-local-set-keys (&rest plist)
"Set the keys in PLIST in the current keymap."
- (declare (indent 1))
+ (declare (obsolete define-keymap "29.1") (indent 1))
`(gnus-define-keys-1 (current-local-map) ',plist))
(defmacro gnus-define-keys (keymap &rest plist)
"Define all keys in PLIST in KEYMAP."
- (declare (indent 1))
+ (declare (obsolete define-keymap "29.1") (indent 1))
`(gnus-define-keys-1 ,(if (symbolp keymap) keymap `',keymap) (quote ,plist)))
(defmacro gnus-define-keys-safe (keymap &rest plist)
"Define all keys in PLIST in KEYMAP without overwriting previous definitions."
- (declare (indent 1))
+ (declare (obsolete define-keymap "29.1") (indent 1))
`(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t))
(defmacro gnus-define-keymap (keymap &rest plist)
"Define all keys in PLIST in KEYMAP."
- (declare (indent 1))
+ (declare (obsolete define-keymap "29.1") (indent 1))
`(gnus-define-keys-1 ,keymap (quote ,plist)))
(defun gnus-define-keys-1 (keymap plist &optional safe)
+ (declare (obsolete define-keymap "29.1"))
(when (null keymap)
(error "Can't set keys in a null keymap"))
(cond ((symbolp keymap) (error "First arg should be a keymap object"))
@@ -857,126 +858,9 @@ variables and then do only the assignment atomically."
`(let ((inhibit-quit gnus-atomic-be-safe))
,@forms))
-;;; Functions for saving to babyl/mail files.
-
-(require 'rmail)
-(autoload 'rmail-update-summary "rmailsum")
-
(defvar mm-text-coding-system)
-
(declare-function mm-append-to-file "mm-util"
(start end filename &optional codesys inhibit))
-(declare-function rmail-swap-buffers-maybe "rmail" ())
-(declare-function rmail-maybe-set-message-counters "rmail" ())
-(declare-function rmail-count-new-messages "rmail" (&optional nomsg))
-(declare-function rmail-summary-exists "rmail" ())
-(declare-function rmail-show-message "rmail" (&optional n no-summary))
-;; Macroexpansion of rmail-select-summary:
-(declare-function rmail-summary-displayed "rmail" ())
-(declare-function rmail-pop-to-buffer "rmail" (&rest args))
-(declare-function rmail-maybe-display-summary "rmail" ())
-
-(defun gnus-output-to-rmail (filename &optional ask)
- "Append the current article to an Rmail file named FILENAME.
-In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless
-FILENAME exists and is Babyl format."
- (require 'rmail)
- (require 'mm-util)
- (require 'nnmail)
- ;; Some of this codes is borrowed from rmailout.el.
- (setq filename (expand-file-name filename))
- ;; FIXME should we really be messing with this defcustom?
- ;; It is not needed for the operation of this function.
- (if (boundp 'rmail-default-rmail-file)
- (setq rmail-default-rmail-file filename) ; 22
- (setq rmail-default-file filename)) ; 23
- (let ((artbuf (current-buffer))
- (tmpbuf (gnus-get-buffer-create " *Gnus-output*"))
- ;; Babyl rmail.el defines this, mbox does not.
- (babyl (fboundp 'rmail-insert-rmail-file-header)))
- (save-excursion
- ;; Note that we ignore the possibility of visiting a Babyl
- ;; format buffer in Emacs 23, since Rmail no longer supports that.
- (or (get-file-buffer filename)
- (progn
- ;; In case someone wants to write to a Babyl file from Emacs 23.
- (when (file-exists-p filename)
- (setq babyl (mail-file-babyl-p filename))
- t))
- (if (or (not ask)
- (gnus-yes-or-no-p
- (concat "\"" filename "\" does not exist, create it? ")))
- (let ((file-buffer (create-file-buffer filename)))
- (with-current-buffer file-buffer
- (if (fboundp 'rmail-insert-rmail-file-header)
- (rmail-insert-rmail-file-header))
- (let ((require-final-newline nil)
- (coding-system-for-write mm-text-coding-system))
- (gnus-write-buffer filename)))
- (kill-buffer file-buffer))
- (error "Output file does not exist")))
- (set-buffer tmpbuf)
- (erase-buffer)
- (insert-buffer-substring artbuf)
- (if babyl
- (gnus-convert-article-to-rmail)
- ;; Non-Babyl case copied from gnus-output-to-mail.
- (goto-char (point-min))
- (if (looking-at "From ")
- (forward-line 1)
- (insert "From nobody " (current-time-string) "\n"))
- (let (case-fold-search)
- (while (re-search-forward "^From " nil t)
- (beginning-of-line)
- (insert ">"))))
- ;; Decide whether to append to a file or to an Emacs buffer.
- (let ((outbuf (get-file-buffer filename)))
- (if (not outbuf)
- (progn
- (unless babyl ; from gnus-output-to-mail
- (let ((buffer-read-only nil))
- (goto-char (point-max))
- (forward-char -2)
- (unless (looking-at "\n\n")
- (goto-char (point-max))
- (unless (bolp)
- (insert "\n"))
- (insert "\n"))))
- (let ((file-name-coding-system nnmail-pathname-coding-system))
- (mm-append-to-file (point-min) (point-max) filename)))
- ;; File has been visited, in buffer OUTBUF.
- (set-buffer outbuf)
- (let ((buffer-read-only nil)
- (msg (and (boundp 'rmail-current-message)
- (symbol-value 'rmail-current-message))))
- ;; If MSG is non-nil, buffer is in RMAIL mode.
- ;; Compare this with rmail-output-to-rmail-buffer in Emacs 23.
- (when msg
- (unless babyl
- (rmail-swap-buffers-maybe)
- (rmail-maybe-set-message-counters))
- (widen)
- (unless babyl
- (goto-char (point-max))
- ;; Ensure we have a blank line before the next message.
- (unless (bolp)
- (insert "\n"))
- (insert "\n"))
- (narrow-to-region (point-max) (point-max)))
- (insert-buffer-substring tmpbuf)
- (when msg
- (when babyl
- (goto-char (point-min))
- (widen)
- (search-backward "\n\^_")
- (narrow-to-region (point) (point-max)))
- (rmail-count-new-messages t)
- (when (rmail-summary-exists)
- (rmail-select-summary
- (rmail-update-summary)))
- (rmail-show-message msg))
- (save-buffer)))))
- (kill-buffer tmpbuf)))
(defun gnus-output-to-mail (filename &optional ask)
"Append the current article to a mail file named FILENAME."
@@ -1034,17 +918,6 @@ FILENAME exists and is Babyl format."
(insert-buffer-substring tmpbuf)))))
(kill-buffer tmpbuf)))
-(defun gnus-convert-article-to-rmail ()
- "Convert article in current buffer to Rmail message format."
- (let ((buffer-read-only nil))
- ;; Convert article directly into Babyl format.
- (goto-char (point-min))
- (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
- (while (search-forward "\n\^_" nil t) ;single char
- (replace-match "\n^_" t t)) ;2 chars: "^" and "_"
- (goto-char (point-max))
- (insert "\^_")))
-
(defun gnus-map-function (funs arg)
"Apply the result of the first function in FUNS to the second, and so on.
ARG is passed to the first function."
@@ -1310,9 +1183,7 @@ SPEC is a predicate specifier that contains stuff like `or', `and',
initial-input history def)
"Call `gnus-completing-read-function'."
(funcall gnus-completing-read-function
- (concat prompt (when def
- (concat " (default " def ")"))
- ": ")
+ (format-prompt prompt def)
collection require-match initial-input history def))
(defun gnus-emacs-completing-read (prompt collection &optional require-match
@@ -1676,6 +1547,11 @@ lists of strings."
(while overlays
(delete-overlay (pop overlays)))))
+;; This function used to live in this file, but was moved to a
+;; separate file to avoid pulling in rmail.el when requiring
+;; gnus-util.
+(autoload 'gnus-output-to-rmail "gnus-rmail")
+
(provide 'gnus-util)
;;; gnus-util.el ends here
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 1d19a2ac565..1f1c39bb8b5 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -1467,11 +1467,11 @@ address was listed in gnus-group-split Addresses (see below).")
:variable-group gnus-group-parameter
:parameter-type '(gnus-email-address :tag "To List")
:parameter-document "\
-This address will be used when doing a `a' in the group.
+This address will be used when doing a \\`a' in the group.
It is totally ignored when doing a followup--except that if it is
present in a news group, you'll get mail group semantics when doing
-`f'.
+\\`f'.
The gnus-group-split mail splitting mechanism will behave as if this
address was listed in gnus-group-split Addresses (see below).")
@@ -2528,16 +2528,8 @@ are always t.")
("babel" babel-as-string)
("nnmail" nnmail-split-fancy nnmail-article-group)
("nnvirtual" nnvirtual-catchup-group nnvirtual-convert-headers)
- ;; This is only used in message.el, which has an autoload.
- ("rmailout" rmail-output)
- ;; Next two used in gnus-util, which has autoloads, and contrib/sendmail.
- ("rmail" rmail-count-new-messages rmail-show-message
- ;; Next two only used in gnus-util.
- rmail-summary-exists rmail-select-summary)
- ;; Only used in gnus-util, which has an autoload.
- ("rmailsum" rmail-update-summary)
("gnus-xmas" gnus-xmas-splash)
- ("score-mode" :interactive t gnus-score-mode)
+ ("score-mode" :interactive t gnus-score-mode gnus-score-edit-all-score)
("gnus-mh" gnus-summary-save-article-folder
gnus-Folder-save-name gnus-folder-save-name)
("gnus-mh" :interactive (gnus-summary-mode) gnus-summary-save-in-folder)
@@ -2609,7 +2601,11 @@ are always t.")
gnus-uu-decode-uu-and-save-view gnus-uu-decode-unshar-view
gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view
gnus-uu-decode-binhex-view gnus-uu-unmark-thread
- gnus-uu-mark-over gnus-uu-post-news gnus-uu-invert-processable)
+ gnus-uu-mark-over gnus-uu-post-news gnus-uu-invert-processable
+ gnus-uu-decode-postscript-and-save-view
+ gnus-uu-decode-postscript-view gnus-uu-decode-postscript-and-save
+ gnus-uu-decode-yenc gnus-uu-unmark-by-regexp gnus-uu-unmark-region
+ gnus-uu-decode-postscript)
("gnus-uu" gnus-uu-delete-work-dir gnus-uu-unmark-thread)
("gnus-msg" (gnus-summary-send-map keymap)
gnus-article-mail gnus-copy-article-buffer gnus-extended-version)
@@ -2656,6 +2652,7 @@ are always t.")
gnus-article-hide-headers gnus-article-hide-boring-headers
gnus-article-treat-overstrike
gnus-article-remove-cr gnus-article-remove-trailing-blank-lines
+ gnus-article-emojize-symbols
gnus-article-display-x-face gnus-article-de-quoted-unreadable
gnus-article-de-base64-unreadable
gnus-article-decode-HZ
@@ -2667,7 +2664,34 @@ are always t.")
gnus-article-edit-mode gnus-article-edit-article
gnus-article-edit-done gnus-article-decode-encoded-words
gnus-start-date-timer gnus-stop-date-timer
- gnus-mime-view-all-parts)
+ gnus-mime-view-all-parts gnus-article-pipe-part
+ gnus-article-inline-part gnus-article-encrypt-body
+ gnus-article-browse-html-article gnus-article-view-part-externally
+ gnus-article-view-part-as-charset gnus-article-copy-part
+ gnus-article-jump-to-part gnus-article-view-part-as-type
+ gnus-article-delete-part gnus-article-replace-part
+ gnus-article-save-part-and-strip gnus-article-save-part
+ gnus-article-remove-leading-whitespace gnus-article-strip-trailing-space
+ gnus-article-strip-leading-space gnus-article-strip-all-blank-lines
+ gnus-article-strip-blank-lines gnus-article-strip-multiple-blank-lines
+ gnus-article-date-user gnus-article-date-iso8601
+ gnus-article-date-english gnus-article-date-ut
+ gnus-article-decode-charset gnus-article-decode-mime-words
+ gnus-article-toggle-fonts gnus-article-show-images
+ gnus-article-remove-images gnus-article-display-face
+ gnus-article-treat-fold-newsgroups gnus-article-treat-unfold-headers
+ gnus-article-treat-fold-headers gnus-article-highlight-signature
+ gnus-article-highlight-headers gnus-article-highlight
+ gnus-article-strip-banner gnus-article-hide-list-identifiers
+ gnus-article-hide gnus-article-outlook-rearrange-citation
+ gnus-article-treat-non-ascii gnus-article-treat-smartquotes
+ gnus-article-verify-x-pgp-sig gnus-article-strip-headers-in-body
+ gnus-treat-smiley gnus-article-treat-ansi-sequences
+ gnus-article-capitalize-sentences gnus-article-toggle-truncate-lines
+ gnus-article-fill-long-lines gnus-article-emphasize
+ gnus-article-add-buttons-to-head gnus-article-add-button
+ gnus-article-babel gnus-sticky-article gnus-article-view-part
+ gnus-article-add-buttons)
("gnus-int" gnus-request-type)
("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1
gnus-dribble-enter gnus-read-init-file gnus-dribble-touch
@@ -3118,9 +3142,9 @@ g -- Group name."
"Check whether GROUP supports function FUNC.
GROUP can either be a string (a group name) or a select method."
(ignore-errors
- (let ((method (if (stringp group)
- (car (gnus-find-method-for-group group))
- group)))
+ (when-let ((method (if (stringp group)
+ (car (gnus-find-method-for-group group))
+ group)))
(unless (featurep method)
(require method))
(fboundp (intern (format "%s-%s" method func))))))
@@ -3754,6 +3778,8 @@ just the host name."
(setq foreign server
group (substring group (+ 1 colon))))
(setq foreign (concat foreign ":")))
+ ;; Remove braces from name (common in IMAP groups).
+ (setq group (replace-regexp-in-string "[][]+" "" group))
;; Collapse group name leaving LEVELS uncollapsed elements
(let* ((slist (split-string group "/"))
(slen (length slist))
diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el
index af0a1983766..efdddea69f6 100644
--- a/lisp/gnus/mail-source.el
+++ b/lisp/gnus/mail-source.el
@@ -224,12 +224,9 @@ Leave mails for this many days" :value 14)))))
(const :format "" :value :plugged)
(boolean :tag "Plugged"))))))))
-(defcustom mail-source-ignore-errors nil
- "Ignore errors when querying mail sources.
-If nil, the user will be prompted when an error occurs. If non-nil,
-the error will be ignored."
- :version "22.1"
- :type 'boolean)
+(make-obsolete-variable 'mail-source-ignore-errors
+ "configure `gnus-verbose' instead"
+ "29.1")
(defcustom mail-source-primary-source nil
"Primary source for incoming mail.
@@ -554,18 +551,16 @@ Return the number of files that were found."
(condition-case err
(funcall function source callback)
(error
- (if (and (not mail-source-ignore-errors)
- (not
- (yes-or-no-p
- (format "Mail source %s error (%s). Continue? "
+ (gnus-error
+ 5
+ (format "Mail source %s error (%s)"
(if (memq ':password source)
(let ((s (copy-sequence source)))
(setcar (cdr (memq ':password s))
"********")
s)
source)
- (cadr err)))))
- (error "Cannot get new mail"))
+ (cadr err)))
0)))))))))
(declare-function gnus-message "gnus-util" (level &rest args))
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index bbf1c78a01f..285369b84cc 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -48,6 +48,8 @@
(require 'puny)
(require 'rmc) ; read-multiple-choice
(require 'subr-x)
+(require 'yank-media)
+(require 'mailcap)
(autoload 'mailclient-send-it "mailclient")
@@ -2051,7 +2053,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'."
(autoload 'gnus-groups-from-server "gnus")
(autoload 'gnus-open-server "gnus-int")
(autoload 'gnus-output-to-mail "gnus-util")
-(autoload 'gnus-output-to-rmail "gnus-util")
+(autoload 'gnus-output-to-rmail "gnus-rmail")
(autoload 'gnus-request-post "gnus-int")
(autoload 'gnus-server-string "gnus")
(autoload 'message-setup-toolbar "messagexmas")
@@ -2870,84 +2872,78 @@ Consider adding this function to `message-header-setup-hook'"
;;; Set up keymap.
-(defvar message-mode-map nil)
-
-(unless message-mode-map
- (setq message-mode-map (make-keymap))
- (set-keymap-parent message-mode-map text-mode-map)
- (define-key message-mode-map "\C-c?" #'describe-mode)
-
- (define-key message-mode-map "\C-c\C-f\C-t" #'message-goto-to)
- (define-key message-mode-map "\C-c\C-f\C-o" #'message-goto-from)
- (define-key message-mode-map "\C-c\C-f\C-b" #'message-goto-bcc)
- (define-key message-mode-map "\C-c\C-f\C-w" #'message-goto-fcc)
- (define-key message-mode-map "\C-c\C-f\C-c" #'message-goto-cc)
- (define-key message-mode-map "\C-c\C-f\C-s" #'message-goto-subject)
- (define-key message-mode-map "\C-c\C-f\C-r" #'message-goto-reply-to)
- (define-key message-mode-map "\C-c\C-f\C-n" #'message-goto-newsgroups)
- (define-key message-mode-map "\C-c\C-f\C-d" #'message-goto-distribution)
- (define-key message-mode-map "\C-c\C-f\C-f" #'message-goto-followup-to)
- (define-key message-mode-map "\C-c\C-f\C-m" #'message-goto-mail-followup-to)
- (define-key message-mode-map "\C-c\C-f\C-k" #'message-goto-keywords)
- (define-key message-mode-map "\C-c\C-f\C-u" #'message-goto-summary)
- (define-key message-mode-map "\C-c\C-f\C-i"
- #'message-insert-or-toggle-importance)
- (define-key message-mode-map "\C-c\C-f\C-a"
- #'message-generate-unsubscribed-mail-followup-to)
+(defvar-keymap message-mode-map
+ :full t :parent text-mode-map
+ :doc "Message Mode keymap."
+ "C-c ?" #'describe-mode
+
+ "C-c C-f C-t" #'message-goto-to
+ "C-c C-f C-o" #'message-goto-from
+ "C-c C-f C-b" #'message-goto-bcc
+ "C-c C-f C-w" #'message-goto-fcc
+ "C-c C-f C-c" #'message-goto-cc
+ "C-c C-f C-s" #'message-goto-subject
+ "C-c C-f C-r" #'message-goto-reply-to
+ "C-c C-f C-n" #'message-goto-newsgroups
+ "C-c C-f C-d" #'message-goto-distribution
+ "C-c C-f C-f" #'message-goto-followup-to
+ "C-c C-f C-m" #'message-goto-mail-followup-to
+ "C-c C-f C-k" #'message-goto-keywords
+ "C-c C-f C-u" #'message-goto-summary
+ "C-c C-f C-i" #'message-insert-or-toggle-importance
+ "C-c C-f C-a" #'message-generate-unsubscribed-mail-followup-to
;; modify headers (and insert notes in body)
- (define-key message-mode-map "\C-c\C-fs" #'message-change-subject)
+ "C-c C-f s" #'message-change-subject
;;
- (define-key message-mode-map "\C-c\C-fx" #'message-cross-post-followup-to)
+ "C-c C-f x" #'message-cross-post-followup-to
;; prefix+message-cross-post-followup-to = same w/o cross-post
- (define-key message-mode-map "\C-c\C-ft" #'message-reduce-to-to-cc)
- (define-key message-mode-map "\C-c\C-fa" #'message-add-archive-header)
+ "C-c C-f t" #'message-reduce-to-to-cc
+ "C-c C-f a" #'message-add-archive-header
;; mark inserted text
- (define-key message-mode-map "\C-c\M-m" #'message-mark-inserted-region)
- (define-key message-mode-map "\C-c\M-f" #'message-mark-insert-file)
-
- (define-key message-mode-map "\C-c\C-b" #'message-goto-body)
- (define-key message-mode-map "\C-c\C-i" #'message-goto-signature)
-
- (define-key message-mode-map "\C-c\C-t" #'message-insert-to)
- (define-key message-mode-map "\C-c\C-fw" #'message-insert-wide-reply)
- (define-key message-mode-map "\C-c\C-n" #'message-insert-newsgroups)
- (define-key message-mode-map "\C-c\C-l" #'message-to-list-only)
- (define-key message-mode-map "\C-c\C-f\C-e" #'message-insert-expires)
-
- (define-key message-mode-map "\C-c\C-u" #'message-insert-or-toggle-importance)
- (define-key message-mode-map "\C-c\M-n"
- #'message-insert-disposition-notification-to)
-
- (define-key message-mode-map "\C-c\C-y" #'message-yank-original)
- (define-key message-mode-map "\C-c\M-\C-y" #'message-yank-buffer)
- (define-key message-mode-map "\C-c\C-q" #'message-fill-yanked-message)
- (define-key message-mode-map "\C-c\C-w" #'message-insert-signature)
- (define-key message-mode-map "\C-c\M-h" #'message-insert-headers)
- (define-key message-mode-map "\C-c\C-r" #'message-caesar-buffer-body)
- (define-key message-mode-map "\C-c\C-o" #'message-sort-headers)
- (define-key message-mode-map "\C-c\M-r" #'message-rename-buffer)
-
- (define-key message-mode-map "\C-c\C-c" #'message-send-and-exit)
- (define-key message-mode-map "\C-c\C-s" #'message-send)
- (define-key message-mode-map "\C-c\C-k" #'message-kill-buffer)
- (define-key message-mode-map "\C-c\C-d" #'message-dont-send)
- (define-key message-mode-map "\C-c\n" #'gnus-delay-article)
-
- (define-key message-mode-map "\C-c\M-k" #'message-kill-address)
- (define-key message-mode-map "\C-c\C-e" #'message-elide-region)
- (define-key message-mode-map "\C-c\C-v" #'message-delete-not-region)
- (define-key message-mode-map "\C-c\C-z" #'message-kill-to-signature)
- (define-key message-mode-map "\M-\r" #'message-newline-and-reformat)
- (define-key message-mode-map [remap split-line] #'message-split-line)
-
- (define-key message-mode-map "\C-c\C-a" #'mml-attach-file)
- (define-key message-mode-map "\C-c\C-p" #'message-insert-screenshot)
-
- (define-key message-mode-map "\C-a" #'message-beginning-of-line)
- (define-key message-mode-map "\t" #'message-tab)
-
- (define-key message-mode-map "\M-n" #'message-display-abbrev))
+ "C-c M-m" #'message-mark-inserted-region
+ "C-c M-f" #'message-mark-insert-file
+
+ "C-c C-b" #'message-goto-body
+ "C-c C-i" #'message-goto-signature
+
+ "C-c C-t" #'message-insert-to
+ "C-c C-f w" #'message-insert-wide-reply
+ "C-c C-n" #'message-insert-newsgroups
+ "C-c C-l" #'message-to-list-only
+ "C-c C-f C-e" #'message-insert-expires
+ "C-c C-u" #'message-insert-or-toggle-importance
+ "C-c M-n" #'message-insert-disposition-notification-to
+
+ "C-c C-y" #'message-yank-original
+ "C-c C-M-y" #'message-yank-buffer
+ "C-c C-q" #'message-fill-yanked-message
+ "C-c C-w" #'message-insert-signature
+ "C-c M-h" #'message-insert-headers
+ "C-c C-r" #'message-caesar-buffer-body
+ "C-c C-o" #'message-sort-headers
+ "C-c M-r" #'message-rename-buffer
+
+ "C-c C-c" #'message-send-and-exit
+ "C-c C-s" #'message-send
+ "C-c C-k" #'message-kill-buffer
+ "C-c C-d" #'message-dont-send
+ "C-c C-j" #'gnus-delay-article
+
+ "C-c M-k" #'message-kill-address
+ "C-c C-e" #'message-elide-region
+ "C-c C-v" #'message-delete-not-region
+ "C-c C-z" #'message-kill-to-signature
+ "M-RET" #'message-newline-and-reformat
+ "<remap> <split-line>" #'message-split-line
+
+ "C-c C-a" #'mml-attach-file
+ "C-c C-p" #'message-insert-screenshot
+
+ "C-a" #'message-beginning-of-line
+ "TAB" #'message-tab
+
+ "M-n" #'message-display-abbrev)
(easy-menu-define
message-mode-menu message-mode-map "Message Menu."
@@ -3161,6 +3157,7 @@ Like `text-mode', but with these additional commands:
(setq-local message-checksum nil)
(setq-local message-mime-part 0)
(message-setup-fill-variables)
+ (yank-media-handler "image/.*" #'message--yank-media-image-handler)
(when message-fill-column
(setq fill-column message-fill-column)
(turn-on-auto-fill))
@@ -4766,23 +4763,25 @@ Valid types are `send', `return', `exit', `kill' and `postpone'."
t
"\
The message size, "
- (/ (buffer-size) 1000) "KB, is too large.
+ (/ (buffer-size) 1000)
+ (substitute-command-keys "KB, is too large.
Some mail gateways (MTA's) bounce large messages. To avoid the
-problem, answer `y', and the message will be split into several
-smaller pieces, the size of each is about "
+problem, answer \\`y', and the message will be split into several
+smaller pieces, the size of each is about ")
(/ message-send-mail-partially-limit 1000)
- "KB except the last
+ (substitute-command-keys
+ "KB except the last
one.
However, some mail readers (MUA's) can't read split messages, i.e.,
-mails in message/partially format. Answer `n', and the message
+mails in message/partially format. Answer \\`n', and the message
will be sent in one piece.
The size limit is controlled by `message-send-mail-partially-limit'.
If you always want Gnus to send messages in one piece, set
`message-send-mail-partially-limit' to nil.
-")))
+"))))
(progn
(message "Sending via mail...")
(if message-send-mail-real-function
@@ -5358,7 +5357,7 @@ Otherwise, generate and save a value for `canlock-password' first."
(zerop
(length
(setq to (completing-read
- "Followups to (default no Followup-To header): "
+ (format-prompt "Followups to" "no Followup-To header")
(mapcar #'list
(cons "poster"
(message-tokenize-header
@@ -5829,15 +5828,15 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'."
;; You might for example insert a "." somewhere (not next to another dot
;; or string boundary), or modify the "fsf" string.
(defun message-unique-id ()
- ;; Don't use microseconds from (current-time), they may be unsupported.
+ ;; Don't use fractional seconds from timestamp; they may be unsupported.
;; Instead we use this randomly inited counter.
(setq message-unique-id-char
- (% (1+ (or message-unique-id-char
- (random (ash 1 20))))
- ;; (current-time) returns 16-bit ints,
- ;; and 2^16*25 just fits into 4 digits i base 36.
- (* 25 25)))
- (let ((tm (current-time)))
+ ;; 2^16 * 25 just fits into 4 digits i base 36.
+ (let ((base (* 25 25)))
+ (if message-unique-id-char
+ (% (1+ message-unique-id-char) base)
+ (random base))))
+ (let ((tm (time-convert nil 'integer)))
(concat
(if (or (eq system-type 'ms-dos)
;; message-number-base36 doesn't handle bigints.
@@ -5847,10 +5846,12 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'."
(aset user (match-beginning 0) ?_))
user)
(message-number-base36 (user-uid) -1))
- (message-number-base36 (+ (car tm)
- (ash (% message-unique-id-char 25) 16)) 4)
- (message-number-base36 (+ (nth 1 tm)
- (ash (/ message-unique-id-char 25) 16)) 4)
+ (message-number-base36 (+ (ash tm -16)
+ (ash (% message-unique-id-char 25) 16))
+ 4)
+ (message-number-base36 (+ (logand tm #xffff)
+ (ash (/ message-unique-id-char 25) 16))
+ 4)
;; Append a given name, because while the generated ID is unique
;; to this newsreader, other newsreaders might otherwise generate
;; the same ID via another algorithm.
@@ -5947,12 +5948,9 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'."
(defun message-make-expires ()
"Return an Expires header based on `message-expires'."
- (let ((current (current-time))
- (future (* 1.0 message-expires 60 60 24)))
+ (let ((future (* 60 60 24 message-expires)))
;; Add the future to current.
- (setcar current (+ (car current) (round (/ future (expt 2 16)))))
- (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
- (message-make-date current)))
+ (message-make-date (time-add nil future))))
(defun message-make-path ()
"Return uucp path."
@@ -8879,24 +8877,29 @@ used to take the screenshot."
(car message-screenshot-command) nil (current-buffer) nil
(cdr message-screenshot-command))
(buffer-string))))
- (set-mark (point))
- (insert-image
- (create-image image 'png t
- :max-width (truncate (* (frame-pixel-width) 0.8))
- :max-height (truncate (* (frame-pixel-height) 0.8))
- :scale 1)
- (format "<#part type=\"image/png\" disposition=inline data-encoding=base64 raw=t>\n%s\n<#/part>"
- ;; Get a base64 version of the image -- this avoids later
- ;; complications if we're auto-saving the buffer and
- ;; restoring from a file.
- (with-temp-buffer
- (set-buffer-multibyte nil)
- (insert image)
- (base64-encode-region (point-min) (point-max) t)
- (buffer-string))))
- (insert "\n\n")
+ (message--yank-media-image-handler 'image/png image)
(message "")))
+(defun message--yank-media-image-handler (type image)
+ (set-mark (point))
+ (insert-image
+ (create-image image (mailcap-mime-type-to-extension type) t
+ :max-width (truncate (* (frame-pixel-width) 0.8))
+ :max-height (truncate (* (frame-pixel-height) 0.8))
+ :scale 1)
+ (format "<#part type=\"%s\" disposition=inline data-encoding=base64 raw=t>\n%s\n<#/part>"
+ type
+ ;; Get a base64 version of the image -- this avoids later
+ ;; complications if we're auto-saving the buffer and
+ ;; restoring from a file.
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert image)
+ (base64-encode-region (point-min) (point-max) t)
+ (buffer-string)))
+ nil nil t)
+ (insert "\n\n"))
+
(declare-function gnus-url-unhex-string "gnus-util")
(defun message-parse-mailto-url (url)
diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index aca4bf2062d..d781407cdcd 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -446,10 +446,11 @@ If not set, `default-directory' will be used."
:type 'integer
:group 'mime-display)
-(defcustom mm-external-terminal-program "xterm"
- "The program to start an external terminal."
- :version "22.1"
- :type 'string
+(defcustom mm-external-terminal-program '("xterm" "-e")
+ "The program to start an external terminal.
+This should be a list of strings."
+ :version "29.1"
+ :type '(choice string (repeat string))
:group 'mime-display)
;;; Internal variables.
@@ -957,10 +958,16 @@ external if displayed external."
(unwind-protect
(if window-system
(set-process-sentinel
- (start-process "*display*" nil
- mm-external-terminal-program
- "-e" shell-file-name
- shell-command-switch command)
+ (apply #'start-process "*display*" nil
+ (append
+ (if (listp mm-external-terminal-program)
+ mm-external-terminal-program
+ ;; Be backwards-compatible.
+ (list mm-external-terminal-program
+ "-e"))
+ (list shell-file-name
+ shell-command-switch
+ command)))
(lambda (process _state)
(if (eq 'exit (process-status process))
(run-at-time
diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el
index 92e04f9d2ee..ddc228e4900 100644
--- a/lisp/gnus/mm-util.el
+++ b/lisp/gnus/mm-util.el
@@ -31,7 +31,7 @@
(defun mm-ucs-to-char (codepoint)
"Convert Unicode codepoint to character."
- (or (decode-char 'ucs codepoint) ?#))
+ (or codepoint ?#))
(defvar mm-coding-system-list nil)
(defun mm-get-coding-system-list ()
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index 5f35e73cd7c..e60d777e0d2 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -1143,48 +1143,40 @@ If HANDLES is non-nil, use it instead reparsing the buffer."
;;; Mode for inserting and editing MML forms
;;;
-(defvar mml-mode-map
- (let ((sign (make-sparse-keymap))
- (encrypt (make-sparse-keymap))
- (signpart (make-sparse-keymap))
- (encryptpart (make-sparse-keymap))
- (map (make-sparse-keymap))
- (main (make-sparse-keymap)))
- (define-key map "\C-s" 'mml-secure-message-sign)
- (define-key map "\C-c" 'mml-secure-message-encrypt)
- (define-key map "\C-e" 'mml-secure-message-sign-encrypt)
- (define-key map "\C-p\C-s" 'mml-secure-sign)
- (define-key map "\C-p\C-c" 'mml-secure-encrypt)
- (define-key sign "p" 'mml-secure-message-sign-pgpmime)
- (define-key sign "o" 'mml-secure-message-sign-pgp)
- (define-key sign "s" 'mml-secure-message-sign-smime)
- (define-key signpart "p" 'mml-secure-sign-pgpmime)
- (define-key signpart "o" 'mml-secure-sign-pgp)
- (define-key signpart "s" 'mml-secure-sign-smime)
- (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime)
- (define-key encrypt "o" 'mml-secure-message-encrypt-pgp)
- (define-key encrypt "s" 'mml-secure-message-encrypt-smime)
- (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime)
- (define-key encryptpart "o" 'mml-secure-encrypt-pgp)
- (define-key encryptpart "s" 'mml-secure-encrypt-smime)
- (define-key map "\C-n" 'mml-unsecure-message)
- (define-key map "f" 'mml-attach-file)
- (define-key map "b" 'mml-attach-buffer)
- (define-key map "e" 'mml-attach-external)
- (define-key map "q" 'mml-quote-region)
- (define-key map "m" 'mml-insert-multipart)
- (define-key map "p" 'mml-insert-part)
- (define-key map "v" 'mml-validate)
- (define-key map "P" 'mml-preview)
- (define-key map "s" sign)
- (define-key map "S" signpart)
- (define-key map "c" encrypt)
- (define-key map "C" encryptpart)
- ;;(define-key map "n" 'mml-narrow-to-part)
- ;; `M-m' conflicts with `back-to-indentation'.
- ;; (define-key main "\M-m" map)
- (define-key main "\C-c\C-m" map)
- main))
+(defvar-keymap mml-mode-map
+ "C-c C-m"
+ (define-keymap
+ "C-s" #'mml-secure-message-sign
+ "C-c" #'mml-secure-message-encrypt
+ "C-e" #'mml-secure-message-sign-encrypt
+ "C-p C-s" #'mml-secure-sign
+ "C-p C-c" #'mml-secure-encrypt
+
+ "s" (define-keymap
+ "p" #'mml-secure-message-sign-pgpmime
+ "o" #'mml-secure-message-sign-pgp
+ "s" #'mml-secure-message-sign-smime)
+ "S" (define-keymap
+ "p" #'mml-secure-sign-pgpmime
+ "o" #'mml-secure-sign-pgp
+ "s" #'mml-secure-sign-smime)
+ "c" (define-keymap
+ "p" #'mml-secure-message-encrypt-pgpmime
+ "o" #'mml-secure-message-encrypt-pgp
+ "s" #'mml-secure-message-encrypt-smime)
+ "C" (define-keymap
+ "p" #'mml-secure-encrypt-pgpmime
+ "o" #'mml-secure-encrypt-pgp
+ "s" #'mml-secure-encrypt-smime)
+ "C-n" #'mml-unsecure-message
+ "f" #'mml-attach-file
+ "b" #'mml-attach-buffer
+ "e" #'mml-attach-external
+ "q" #'mml-quote-region
+ "m" #'mml-insert-multipart
+ "p" #'mml-insert-part
+ "v" #'mml-validate
+ "P" #'mml-preview))
(easy-menu-define
mml-menu mml-mode-map ""
@@ -1409,6 +1401,13 @@ to specify options."
:version "22.1" ;; Gnus 5.10.9
:group 'message)
+(defcustom mml-attach-file-at-the-end nil
+ "If non-nil, \\[mml-attach-file] attaches files at the end of the message.
+If nil, files are attached at point."
+ :type 'boolean
+ :version "29.1"
+ :group 'message)
+
;;;###autoload
(defun mml-attach-file (file &optional type description disposition)
"Attach a file to the outgoing MIME message.
@@ -1423,6 +1422,8 @@ specifies how the attachment is intended to be displayed. It can
be either \"inline\" (displayed automatically within the message
body) or \"attachment\" (separate from the body).
+Also see the `mml-attach-file-at-the-end' variable.
+
If given a prefix interactively, no prompting will be done for
the TYPE, DESCRIPTION or DISPOSITION values. Instead defaults
will be computed and used."
@@ -1440,8 +1441,11 @@ will be computed and used."
(mml-minibuffer-read-disposition type nil file))))
(list file type description disposition)))
;; 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)))
+ (let ((at-end (and (or (not (message-in-body-p))
+ mml-attach-file-at-the-end)
+ (point))))
+ (when at-end
+ (goto-char (point-max)))
(mml-insert-empty-tag 'part
'type type
;; icicles redefines read-file-name and returns a
@@ -1451,13 +1455,13 @@ will be computed and used."
'description description)
;; When using Mail mode, make sure it does the mime encoding
;; when you send the message.
- (or (eq mail-user-agent 'message-user-agent)
- (setq mail-encode-mml t))
- (when head
+ (unless (eq mail-user-agent 'message-user-agent)
+ (setq mail-encode-mml t))
+ (when at-end
(unless (pos-visible-in-window-p)
(message "The file \"%s\" has been attached at the end of the message"
(file-name-nondirectory file)))
- (goto-char head))))
+ (goto-char at-end))))
(defun mml-dnd-attach-file (uri _action)
"Attach a drag and drop file.
diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el
index 133e0307a54..6f8917e2528 100644
--- a/lisp/gnus/nndiary.el
+++ b/lisp/gnus/nndiary.el
@@ -1308,7 +1308,7 @@ all. This may very well take some time.")
(let ((minute (nndiary-max (nth 0 sched)))
(hour (nndiary-max (nth 1 sched)))
(year (nndiary-max (nth 4 sched)))
- (time-zone (or (and (nth 6 sched) (car (nth 6 sched)))
+ (time-zone (or (car (nth 6 sched))
(current-time-zone))))
(when year
(or minute (setq minute 59))
@@ -1405,7 +1405,7 @@ all. This may very well take some time.")
t))
(dow-list (nth 5 sched))
(year (1- this-year))
- (time-zone (or (and (nth 6 sched) (car (nth 6 sched)))
+ (time-zone (or (car (nth 6 sched))
(current-time-zone))))
;; Special case: an asterisk in one of the days specifications means that
;; only the other should be taken into account. If both are unspecified,
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 6b627a4b756..b7082696b2c 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -429,8 +429,18 @@ during splitting, which may be slow."
now
(nnimap-last-command-time nnimap-object))))
(with-local-quit
- (ignore-errors ;E.g. "buffer foo has no process".
- (nnimap-send-command "NOOP")))))))))
+ (ignore-errors ;E.g. "buffer foo has no process".
+ (nnimap-send-command "NOOP"))
+ ;; If our connection has died in the meantime, clean it
+ ;; and its buffer up.
+ (unless (process-live-p (get-buffer-process buffer))
+ (setq nnimap-process-buffers
+ (delq buffer nnimap-process-buffers))
+ (setq nnimap-connection-alist
+ (seq-filter (lambda (elt)
+ (null (eq buffer (cdr elt))))
+ nnimap-connection-alist))
+ (kill-buffer buffer)))))))))
(defun nnimap-open-connection (buffer)
;; Be backwards-compatible -- the earlier value of nnimap-stream was
@@ -662,10 +672,17 @@ during splitting, which may be slow."
(deffoo nnimap-close-server (&optional server defs)
(when (nnoo-change-server 'nnimap server defs)
- (ignore-errors
- (delete-process (get-buffer-process (nnimap-buffer))))
- (nnoo-close-server 'nnimap server)
- t))
+ (let ((buf (nnimap-buffer)))
+ (ignore-errors
+ (delete-process (get-buffer-process buf)))
+ (setq nnimap-process-buffers
+ (delq buf nnimap-process-buffers)
+ nnimap-connection-alist
+ (seq-filter (lambda (elt)
+ (null (eq buf (cdr elt))))
+ nnimap-connection-alist))
+ (nnoo-close-server 'nnimap server)
+ t)))
(deffoo nnimap-request-close ()
t)
@@ -1937,10 +1954,13 @@ Return the server's response to the SELECT or EXAMINE command."
(when entry
(if (and (buffer-live-p (cadr entry))
(get-buffer-process (cadr entry))
- (memq (process-status (get-buffer-process (cadr entry)))
- '(open run)))
+ (process-live-p (get-buffer-process (cadr entry))))
(get-buffer-process (cadr entry))
- (setq nnimap-connection-alist (delq entry nnimap-connection-alist))
+ (setq nnimap-connection-alist (delq entry nnimap-connection-alist)
+ nnimap-process-buffers
+ (delq (cadr entry) nnimap-process-buffers))
+ (when (buffer-live-p (cadr entry))
+ (kill-buffer (cadr entry)))
nil))))
;; Leave room for `open-network-stream' to issue a couple of IMAP
diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el
index 0ac57e9e171..59a22f725a9 100644
--- a/lisp/gnus/nnrss.el
+++ b/lisp/gnus/nnrss.el
@@ -450,7 +450,7 @@ nnrss: %s: Not valid XML %s and libxml-parse-html-region doesn't work %s"
This function handles the ISO 8601 date format described in
URL `https://www.w3.org/TR/NOTE-datetime', and also the RFC 822 style
which RSS 2.0 allows."
- (let (case-fold-search vector year month day time zone cts given)
+ (let (case-fold-search vector year month day time zone given)
(cond ((null date)) ; do nothing for this case
;; if the date is just digits (unix time stamp):
((string-match "^[0-9]+$" date)
@@ -481,13 +481,13 @@ which RSS 2.0 allows."
0
(decoded-time-zone decoded))))))
(if month
- (progn
- (setq cts (current-time-string (encode-time 0 0 0 day month year)))
- (format "%s, %02d %s %04d %s%s"
- (substring cts 0 3) day (substring cts 4 7) year time
- (if zone
- (concat " " (format-time-string "%z" nil zone))
- "")))
+ (concat (let ((system-time-locale "C"))
+ (format-time-string "%a, %d %b %Y "
+ (encode-time 0 0 0 day month year)))
+ time
+ (if zone
+ (format-time-string " %z" nil zone)
+ ""))
(message-make-date given))))
;;; data functions
diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el
index ecec705b326..0130f689991 100644
--- a/lisp/gnus/nnselect.el
+++ b/lisp/gnus/nnselect.el
@@ -395,8 +395,7 @@ If this variable is nil, or if the provided function returns nil,
(gnus-search-run-query
(list
(cons 'search-query-spec
- (list (cons 'query `((id . ,article)))
- (cons 'criteria "") (cons 'shortcut t)))
+ (list (cons 'query (format "id:%s" article))))
(cons 'search-group-spec servers))))
(unless (zerop (nnselect-artlist-length artlist))
(setq
@@ -779,6 +778,10 @@ Return an article list."
(args (alist-get 'nnselect-args specs)))
(condition-case-unless-debug err
(funcall func args)
+ ;; Don't swallow gnus-search errors; the user should be made
+ ;; aware of them.
+ (gnus-search-error
+ (signal (car err) (cdr err)))
(error (gnus-error 3 "nnselect-run: %s on %s gave error %s" func args err)
[]))))
@@ -901,7 +904,7 @@ article came from is also searched."
;; make sure
(setq list
(sort (map-merge
- 'list list
+ 'alist list
(alist-get type (gnus-info-marks group-info)))
(lambda (elt1 elt2)
(< (car elt1) (car elt2))))))
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index 615a3c931bf..25289655bf2 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -331,9 +331,7 @@ retried once before actually displaying the error report."
(when nntp-record-commands
(nntp-record-command "*** CALLED nntp-report ***"))
- (nnheader-report 'nntp args)
-
- (apply #'error args)))
+ (nnheader-report 'nntp args)))
(defsubst nntp-copy-to-buffer (buffer start end)
"Copy string from unibyte current buffer to multibyte buffer."
diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el
index d00f0a60b66..508ef5424ea 100644
--- a/lisp/gnus/spam.el
+++ b/lisp/gnus/spam.el
@@ -663,13 +663,13 @@ order for SpamAssassin to recognize the new registered spam."
;;; Key bindings for spam control.
-(gnus-define-keys gnus-summary-mode-map
- "St" spam-generic-score
- "Sx" gnus-summary-mark-as-spam
- "Mst" spam-generic-score
- "Msx" gnus-summary-mark-as-spam
- "\M-d" gnus-summary-mark-as-spam
- "$" gnus-summary-mark-as-spam)
+(define-keymap :keymap gnus-summary-mode-map
+ "S t" #'spam-generic-score
+ "S x" #'gnus-summary-mark-as-spam
+ "M s t" #'spam-generic-score
+ "M s x" #'gnus-summary-mark-as-spam
+ "M-d" #'gnus-summary-mark-as-spam
+ "$" #'gnus-summary-mark-as-spam)
(defvar spam-cache-lookups t
"Whether spam.el will try to cache lookups using `spam-caches'.")
diff --git a/lisp/help-at-pt.el b/lisp/help-at-pt.el
index 233c50504bf..8eb397bc82d 100644
--- a/lisp/help-at-pt.el
+++ b/lisp/help-at-pt.el
@@ -229,11 +229,11 @@ this option, or use \"In certain situations\" and specify no text
properties, to enable buffer local values."
never))
:initialize 'custom-initialize-default
- :set #'(lambda (variable value)
- (set-default variable value)
- (if (eq value 'never)
- (help-at-pt-cancel-timer)
- (help-at-pt-set-timer)))
+ :set (lambda (variable value)
+ (set-default variable value)
+ (if (eq value 'never)
+ (help-at-pt-cancel-timer)
+ (help-at-pt-set-timer)))
:set-after '(help-at-pt-timer-delay)
:require 'help-at-pt)
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 2b759a5a5c5..32698420e1f 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -249,7 +249,8 @@ handling of autoloaded functions."
;; calling that.
(let ((describe-function-orig-buffer
(or describe-function-orig-buffer
- (current-buffer))))
+ (current-buffer)))
+ (help-buffer-under-preparation t))
(help-setup-xref
(list (lambda (function buffer)
@@ -1078,7 +1079,8 @@ it is displayed along with the global value."
(if (symbolp v) (symbol-name v))))
(list (if (equal val "")
v (intern val)))))
- (let (file-name)
+ (let (file-name
+ (help-buffer-under-preparation t))
(unless (buffer-live-p buffer) (setq buffer (current-buffer)))
(unless (frame-live-p frame) (setq frame (selected-frame)))
(if (not (symbolp variable))
@@ -1461,77 +1463,78 @@ If FRAME is omitted or nil, use the selected frame."
(interactive (list (read-face-name "Describe face"
(or (face-at-point t) 'default)
t)))
- (help-setup-xref (list #'describe-face face)
- (called-interactively-p 'interactive))
- (unless face
- (setq face 'default))
- (if (not (listp face))
- (setq face (list face)))
- (with-help-window (help-buffer)
- (with-current-buffer standard-output
- (dolist (f face (buffer-string))
- (if (stringp f) (setq f (intern f)))
- ;; We may get called for anonymous faces (i.e., faces
- ;; expressed using prop-value plists). Those can't be
- ;; usefully customized, so ignore them.
- (when (symbolp f)
- (insert "Face: " (symbol-name f))
- (if (not (facep f))
- (insert " undefined face.\n")
- (let ((customize-label "customize this face")
- file-name)
- (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
- (princ (concat " (" customize-label ")\n"))
- ;; FIXME not sure how much of this belongs here, and
- ;; how much in `face-documentation'. The latter is
- ;; not used much, but needs to return nil for
- ;; undocumented faces.
- (let ((alias (get f 'face-alias))
- (face f)
- obsolete)
- (when alias
- (setq face alias)
- (insert
- (format-message
- "\n %s is an alias for the face `%s'.\n%s"
- f alias
- (if (setq obsolete (get f 'obsolete-face))
- (format-message
- " This face is obsolete%s; use `%s' instead.\n"
- (if (stringp obsolete)
- (format " since %s" obsolete)
- "")
- alias)
- ""))))
- (insert "\nDocumentation:\n"
- (substitute-command-keys
- (or (face-documentation face)
- "Not documented as a face."))
- "\n\n"))
- (with-current-buffer standard-output
- (save-excursion
- (re-search-backward
- (concat "\\(" customize-label "\\)") nil t)
- (help-xref-button 1 'help-customize-face f)))
- (setq file-name (find-lisp-object-file-name f 'defface))
- (if (not file-name)
- (setq help-mode--current-data (list :symbol f))
- (setq help-mode--current-data (list :symbol f
- :file file-name))
- (princ (substitute-command-keys "Defined in `"))
- (princ (help-fns-short-filename file-name))
- (princ (substitute-command-keys "'"))
- ;; Make a hyperlink to the library.
- (save-excursion
- (re-search-backward
- (substitute-command-keys "`\\([^`']+\\)'") nil t)
- (help-xref-button 1 'help-face-def f file-name))
- (princ ".")
- (terpri)
- (terpri))))
- (terpri)
- (help-fns--run-describe-functions
- help-fns-describe-face-functions f frame))))))
+ (let ((help-buffer-under-preparation t))
+ (help-setup-xref (list #'describe-face face)
+ (called-interactively-p 'interactive))
+ (unless face
+ (setq face 'default))
+ (if (not (listp face))
+ (setq face (list face)))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (dolist (f face (buffer-string))
+ (if (stringp f) (setq f (intern f)))
+ ;; We may get called for anonymous faces (i.e., faces
+ ;; expressed using prop-value plists). Those can't be
+ ;; usefully customized, so ignore them.
+ (when (symbolp f)
+ (insert "Face: " (symbol-name f))
+ (if (not (facep f))
+ (insert " undefined face.\n")
+ (let ((customize-label "customize this face")
+ file-name)
+ (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
+ (princ (concat " (" customize-label ")\n"))
+ ;; FIXME not sure how much of this belongs here, and
+ ;; how much in `face-documentation'. The latter is
+ ;; not used much, but needs to return nil for
+ ;; undocumented faces.
+ (let ((alias (get f 'face-alias))
+ (face f)
+ obsolete)
+ (when alias
+ (setq face alias)
+ (insert
+ (format-message
+ "\n %s is an alias for the face `%s'.\n%s"
+ f alias
+ (if (setq obsolete (get f 'obsolete-face))
+ (format-message
+ " This face is obsolete%s; use `%s' instead.\n"
+ (if (stringp obsolete)
+ (format " since %s" obsolete)
+ "")
+ alias)
+ ""))))
+ (insert "\nDocumentation:\n"
+ (substitute-command-keys
+ (or (face-documentation face)
+ "Not documented as a face."))
+ "\n\n"))
+ (with-current-buffer standard-output
+ (save-excursion
+ (re-search-backward
+ (concat "\\(" customize-label "\\)") nil t)
+ (help-xref-button 1 'help-customize-face f)))
+ (setq file-name (find-lisp-object-file-name f 'defface))
+ (if (not file-name)
+ (setq help-mode--current-data (list :symbol f))
+ (setq help-mode--current-data (list :symbol f
+ :file file-name))
+ (princ (substitute-command-keys "Defined in `"))
+ (princ (help-fns-short-filename file-name))
+ (princ (substitute-command-keys "'"))
+ ;; Make a hyperlink to the library.
+ (save-excursion
+ (re-search-backward
+ (substitute-command-keys "`\\([^`']+\\)'") nil t)
+ (help-xref-button 1 'help-face-def f file-name))
+ (princ ".")
+ (terpri)
+ (terpri))))
+ (terpri)
+ (help-fns--run-describe-functions
+ help-fns-describe-face-functions f frame)))))))
(add-hook 'help-fns-describe-face-functions
#'help-fns--face-custom-version-info)
@@ -1561,7 +1564,7 @@ If FRAME is omitted or nil, use the selected frame."
(:fontset . "Fontset")
(:extend . "Extend")
(:inherit . "Inherit")))
- (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
+ (max-width (apply #'max (mapcar (lambda (x) (length (cdr x)))
attrs))))
(dolist (a attrs)
(let ((attr (face-attribute face (car a) frame)))
@@ -1602,43 +1605,44 @@ current buffer and the selected frame, respectively."
(if found (symbol-name v-or-f)))))
(list (if (equal val "")
(or v-or-f "") (intern val)))))
- (if (not (symbolp symbol))
- (user-error "You didn't specify a function or variable"))
- (unless (buffer-live-p buffer) (setq buffer (current-buffer)))
- (unless (frame-live-p frame) (setq frame (selected-frame)))
- (with-current-buffer (help-buffer)
- ;; Push the previous item on the stack before clobbering the output buffer.
- (help-setup-xref nil nil)
- (let* ((docs
- (nreverse
- (delq nil
- (mapcar (pcase-lambda (`(,name ,testfn ,descfn))
- (when (funcall testfn symbol)
- ;; Don't record the current entry in the stack.
- (setq help-xref-stack-item nil)
- (cons name
- (funcall descfn symbol buffer frame))))
- describe-symbol-backends))))
- (single (null (cdr docs))))
- (while (cdr docs)
- (goto-char (point-min))
- (let ((inhibit-read-only t)
- (name (caar docs)) ;Name of doc currently at BOB.
- (doc (cdr (cadr docs)))) ;Doc to add at BOB.
- (when doc
- (insert doc)
- (delete-region (point)
- (progn (skip-chars-backward " \t\n") (point)))
- (insert "\n\n" (make-separator-line) "\n")
- (when name
- (insert (symbol-name symbol)
- " is also a " name "." "\n\n"))))
- (setq docs (cdr docs)))
- (unless single
- ;; Don't record the `describe-variable' item in the stack.
- (setq help-xref-stack-item nil)
- (help-setup-xref (list #'describe-symbol symbol) nil))
- (goto-char (point-min)))))
+ (let ((help-buffer-under-preparation t))
+ (if (not (symbolp symbol))
+ (user-error "You didn't specify a function or variable"))
+ (unless (buffer-live-p buffer) (setq buffer (current-buffer)))
+ (unless (frame-live-p frame) (setq frame (selected-frame)))
+ (with-current-buffer (help-buffer)
+ ;; Push the previous item on the stack before clobbering the output buffer.
+ (help-setup-xref nil nil)
+ (let* ((docs
+ (nreverse
+ (delq nil
+ (mapcar (pcase-lambda (`(,name ,testfn ,descfn))
+ (when (funcall testfn symbol)
+ ;; Don't record the current entry in the stack.
+ (setq help-xref-stack-item nil)
+ (cons name
+ (funcall descfn symbol buffer frame))))
+ describe-symbol-backends))))
+ (single (null (cdr docs))))
+ (while (cdr docs)
+ (goto-char (point-min))
+ (let ((inhibit-read-only t)
+ (name (caar docs)) ;Name of doc currently at BOB.
+ (doc (cdr (cadr docs)))) ;Doc to add at BOB.
+ (when doc
+ (insert doc)
+ (delete-region (point)
+ (progn (skip-chars-backward " \t\n") (point)))
+ (insert "\n\n" (make-separator-line) "\n")
+ (when name
+ (insert (symbol-name symbol)
+ " is also a " name "." "\n\n"))))
+ (setq docs (cdr docs)))
+ (unless single
+ ;; Don't record the `describe-variable' item in the stack.
+ (setq help-xref-stack-item nil)
+ (help-setup-xref (list #'describe-symbol symbol) nil))
+ (goto-char (point-min))))))
;;;###autoload
(defun describe-syntax (&optional buffer)
@@ -1647,15 +1651,16 @@ The descriptions are inserted in a help buffer, which is then displayed.
BUFFER defaults to the current buffer."
(interactive)
(setq buffer (or buffer (current-buffer)))
- (help-setup-xref (list #'describe-syntax buffer)
- (called-interactively-p 'interactive))
- (with-help-window (help-buffer)
- (let ((table (with-current-buffer buffer (syntax-table))))
- (with-current-buffer standard-output
- (describe-vector table 'internal-describe-syntax-value)
- (while (setq table (char-table-parent table))
- (insert "\nThe parent syntax table is:")
- (describe-vector table 'internal-describe-syntax-value))))))
+ (let ((help-buffer-under-preparation t))
+ (help-setup-xref (list #'describe-syntax buffer)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (let ((table (with-current-buffer buffer (syntax-table))))
+ (with-current-buffer standard-output
+ (describe-vector table 'internal-describe-syntax-value)
+ (while (setq table (char-table-parent table))
+ (insert "\nThe parent syntax table is:")
+ (describe-vector table 'internal-describe-syntax-value)))))))
(defun help-describe-category-set (value)
(insert (cond
@@ -1672,59 +1677,60 @@ The descriptions are inserted in a buffer, which is then displayed.
If BUFFER is non-nil, then describe BUFFER's category table instead.
BUFFER should be a buffer or a buffer name."
(interactive)
- (setq buffer (or buffer (current-buffer)))
- (help-setup-xref (list #'describe-categories buffer)
- (called-interactively-p 'interactive))
- (with-help-window (help-buffer)
- (let* ((table (with-current-buffer buffer (category-table)))
- (docs (char-table-extra-slot table 0)))
- (if (or (not (vectorp docs)) (/= (length docs) 95))
- (error "Invalid first extra slot in this category table\n"))
- (with-current-buffer standard-output
- (setq-default help-button-cache (make-marker))
- (insert "Legend of category mnemonics ")
- (insert-button "(longer descriptions at the bottom)"
- 'action help-button-cache
- 'follow-link t
- 'help-echo "mouse-2, RET: show full legend")
- (insert "\n")
- (let ((pos (point)) (items 0) lines n)
- (dotimes (i 95)
- (if (aref docs i) (setq items (1+ items))))
- (setq lines (1+ (/ (1- items) 4)))
- (setq n 0)
+ (let ((help-buffer-under-preparation t))
+ (setq buffer (or buffer (current-buffer)))
+ (help-setup-xref (list #'describe-categories buffer)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (let* ((table (with-current-buffer buffer (category-table)))
+ (docs (char-table-extra-slot table 0)))
+ (if (or (not (vectorp docs)) (/= (length docs) 95))
+ (error "Invalid first extra slot in this category table\n"))
+ (with-current-buffer standard-output
+ (setq-default help-button-cache (make-marker))
+ (insert "Legend of category mnemonics ")
+ (insert-button "(longer descriptions at the bottom)"
+ 'action help-button-cache
+ 'follow-link t
+ 'help-echo "mouse-2, RET: show full legend")
+ (insert "\n")
+ (let ((pos (point)) (items 0) lines n)
+ (dotimes (i 95)
+ (if (aref docs i) (setq items (1+ items))))
+ (setq lines (1+ (/ (1- items) 4)))
+ (setq n 0)
+ (dotimes (i 95)
+ (let ((elt (aref docs i)))
+ (when elt
+ (string-match ".*" elt)
+ (setq elt (match-string 0 elt))
+ (if (>= (length elt) 17)
+ (setq elt (concat (substring elt 0 14) "...")))
+ (if (< (point) (point-max))
+ (move-to-column (* 20 (/ n lines)) t))
+ (insert (+ i ?\s) ?: elt)
+ (if (< (point) (point-max))
+ (forward-line 1)
+ (insert "\n"))
+ (setq n (1+ n))
+ (if (= (% n lines) 0)
+ (goto-char pos))))))
+ (goto-char (point-max))
+ (insert "\n"
+ "character(s)\tcategory mnemonics\n"
+ "------------\t------------------")
+ (describe-vector table 'help-describe-category-set)
+ (set-marker help-button-cache (point))
+ (insert "Legend of category mnemonics:\n")
(dotimes (i 95)
(let ((elt (aref docs i)))
(when elt
- (string-match ".*" elt)
- (setq elt (match-string 0 elt))
- (if (>= (length elt) 17)
- (setq elt (concat (substring elt 0 14) "...")))
- (if (< (point) (point-max))
- (move-to-column (* 20 (/ n lines)) t))
- (insert (+ i ?\s) ?: elt)
- (if (< (point) (point-max))
- (forward-line 1)
- (insert "\n"))
- (setq n (1+ n))
- (if (= (% n lines) 0)
- (goto-char pos))))))
- (goto-char (point-max))
- (insert "\n"
- "character(s)\tcategory mnemonics\n"
- "------------\t------------------")
- (describe-vector table 'help-describe-category-set)
- (set-marker help-button-cache (point))
- (insert "Legend of category mnemonics:\n")
- (dotimes (i 95)
- (let ((elt (aref docs i)))
- (when elt
- (if (string-match "\n" elt)
- (setq elt (substring elt (match-end 0))))
- (insert (+ i ?\s) ": " elt "\n"))))
- (while (setq table (char-table-parent table))
- (insert "\nThe parent category table is:")
- (describe-vector table 'help-describe-category-set))))))
+ (if (string-match "\n" elt)
+ (setq elt (substring elt (match-end 0))))
+ (insert (+ i ?\s) ": " elt "\n"))))
+ (while (setq table (char-table-parent table))
+ (insert "\nThe parent category table is:")
+ (describe-vector table 'help-describe-category-set)))))))
(defun help-fns-find-keymap-name (keymap)
"Find the name of the variable with value KEYMAP.
@@ -1778,7 +1784,8 @@ keymap value."
(unless (and km (keymapp (symbol-value km)))
(user-error "Not a keymap: %s" km))
(list km)))
- (let (used-gentemp)
+ (let (used-gentemp
+ (help-buffer-under-preparation t))
(unless (and (symbolp keymap)
(boundp keymap)
(keymapp (symbol-value keymap)))
@@ -1844,106 +1851,107 @@ whose documentation describes the minor mode.
If called from Lisp with a non-nil BUFFER argument, display
documentation for the major and minor modes of that buffer."
(interactive "@")
- (unless buffer (setq buffer (current-buffer)))
- (help-setup-xref (list #'describe-mode buffer)
- (called-interactively-p 'interactive))
- ;; For the sake of help-do-xref and help-xref-go-back,
- ;; don't switch buffers before calling `help-buffer'.
- (with-help-window (help-buffer)
- (with-current-buffer buffer
- (let (minors)
- ;; Older packages do not register in minor-mode-list but only in
- ;; minor-mode-alist.
- (dolist (x minor-mode-alist)
- (setq x (car x))
- (unless (memq x minor-mode-list)
- (push x minor-mode-list)))
- ;; Find enabled minor mode we will want to mention.
- (dolist (mode minor-mode-list)
- ;; Document a minor mode if it is listed in minor-mode-alist,
- ;; non-nil, and has a function definition.
- (let ((fmode (or (get mode :minor-mode-function) mode)))
- (and (boundp mode) (symbol-value mode)
- (fboundp fmode)
- (let ((pretty-minor-mode
- (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'"
- (symbol-name fmode))
- (capitalize
- (substring (symbol-name fmode)
- 0 (match-beginning 0)))
- fmode)))
- (push (list fmode pretty-minor-mode
- (format-mode-line (assq mode minor-mode-alist)))
- minors)))))
- ;; Narrowing is not a minor mode, but its indicator is part of
- ;; mode-line-modes.
- (when (buffer-narrowed-p)
- (push '(narrow-to-region "Narrow" " Narrow") minors))
- (setq minors
- (sort minors
- (lambda (a b) (string-lessp (cadr a) (cadr b)))))
- (when minors
- (princ "Enabled minor modes:\n")
- (make-local-variable 'help-button-cache)
- (with-current-buffer standard-output
- (dolist (mode minors)
- (let ((mode-function (nth 0 mode))
- (pretty-minor-mode (nth 1 mode))
- (indicator (nth 2 mode)))
- (save-excursion
- (goto-char (point-max))
- (princ "\n\f\n")
- (push (point-marker) help-button-cache)
- ;; Document the minor modes fully.
- (insert-text-button
- pretty-minor-mode 'type 'help-function
- 'help-args (list mode-function)
- 'button '(t))
- (princ (format " minor mode (%s):\n"
- (if (zerop (length indicator))
- "no indicator"
- (format "indicator%s"
- indicator))))
- (princ (help-split-fundoc (documentation mode-function)
- nil 'doc)))
- (insert-button pretty-minor-mode
- 'action (car help-button-cache)
- 'follow-link t
- 'help-echo "mouse-2, RET: show full information")
- (newline)))
- (forward-line -1)
- (fill-paragraph nil)
- (forward-line 1))
-
- (princ "\n(Information about these minor modes follows the major mode info.)\n\n"))
- ;; Document the major mode.
- (let ((mode mode-name))
- (with-current-buffer standard-output
- (let ((start (point)))
- (insert (format-mode-line mode nil nil buffer))
- (add-text-properties start (point) '(face bold)))))
- (princ " mode")
- (let* ((mode major-mode)
- (file-name (find-lisp-object-file-name mode nil)))
- (if (not file-name)
- (setq help-mode--current-data (list :symbol mode))
- (princ (format-message " defined in `%s'"
- (help-fns-short-filename file-name)))
- ;; Make a hyperlink to the library.
+ (let ((help-buffer-under-preparation t))
+ (unless buffer (setq buffer (current-buffer)))
+ (help-setup-xref (list #'describe-mode buffer)
+ (called-interactively-p 'interactive))
+ ;; For the sake of help-do-xref and help-xref-go-back,
+ ;; don't switch buffers before calling `help-buffer'.
+ (with-help-window (help-buffer)
+ (with-current-buffer buffer
+ (let (minors)
+ ;; Older packages do not register in minor-mode-list but only in
+ ;; minor-mode-alist.
+ (dolist (x minor-mode-alist)
+ (setq x (car x))
+ (unless (memq x minor-mode-list)
+ (push x minor-mode-list)))
+ ;; Find enabled minor mode we will want to mention.
+ (dolist (mode minor-mode-list)
+ ;; Document a minor mode if it is listed in minor-mode-alist,
+ ;; non-nil, and has a function definition.
+ (let ((fmode (or (get mode :minor-mode-function) mode)))
+ (and (boundp mode) (symbol-value mode)
+ (fboundp fmode)
+ (let ((pretty-minor-mode
+ (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'"
+ (symbol-name fmode))
+ (capitalize
+ (substring (symbol-name fmode)
+ 0 (match-beginning 0)))
+ fmode)))
+ (push (list fmode pretty-minor-mode
+ (format-mode-line (assq mode minor-mode-alist)))
+ minors)))))
+ ;; Narrowing is not a minor mode, but its indicator is part of
+ ;; mode-line-modes.
+ (when (buffer-narrowed-p)
+ (push '(narrow-to-region "Narrow" " Narrow") minors))
+ (setq minors
+ (sort minors
+ (lambda (a b) (string-lessp (cadr a) (cadr b)))))
+ (when minors
+ (princ "Enabled minor modes:\n")
+ (make-local-variable 'help-button-cache)
(with-current-buffer standard-output
- (save-excursion
- (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
- nil t)
- (setq help-mode--current-data (list :symbol mode
- :file file-name))
- (help-xref-button 1 'help-function-def mode file-name)))))
- (let ((fundoc (help-split-fundoc (documentation major-mode) nil 'doc)))
- (with-current-buffer standard-output
- (insert ":\n")
- (insert fundoc)
- (insert (help-fns--list-local-commands)))))))
- ;; For the sake of IELM and maybe others
- nil)
+ (dolist (mode minors)
+ (let ((mode-function (nth 0 mode))
+ (pretty-minor-mode (nth 1 mode))
+ (indicator (nth 2 mode)))
+ (save-excursion
+ (goto-char (point-max))
+ (princ "\n\f\n")
+ (push (point-marker) help-button-cache)
+ ;; Document the minor modes fully.
+ (insert-text-button
+ pretty-minor-mode 'type 'help-function
+ 'help-args (list mode-function)
+ 'button '(t))
+ (princ (format " minor mode (%s):\n"
+ (if (zerop (length indicator))
+ "no indicator"
+ (format "indicator%s"
+ indicator))))
+ (princ (help-split-fundoc (documentation mode-function)
+ nil 'doc)))
+ (insert-button pretty-minor-mode
+ 'action (car help-button-cache)
+ 'follow-link t
+ 'help-echo "mouse-2, RET: show full information")
+ (newline)))
+ (forward-line -1)
+ (fill-paragraph nil)
+ (forward-line 1))
+
+ (princ "\n(Information about these minor modes follows the major mode info.)\n\n"))
+ ;; Document the major mode.
+ (let ((mode mode-name))
+ (with-current-buffer standard-output
+ (let ((start (point)))
+ (insert (format-mode-line mode nil nil buffer))
+ (add-text-properties start (point) '(face bold)))))
+ (princ " mode")
+ (let* ((mode major-mode)
+ (file-name (find-lisp-object-file-name mode nil)))
+ (if (not file-name)
+ (setq help-mode--current-data (list :symbol mode))
+ (princ (format-message " defined in `%s'"
+ (help-fns-short-filename file-name)))
+ ;; Make a hyperlink to the library.
+ (with-current-buffer standard-output
+ (save-excursion
+ (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
+ nil t)
+ (setq help-mode--current-data (list :symbol mode
+ :file file-name))
+ (help-xref-button 1 'help-function-def mode file-name)))))
+ (let ((fundoc (help-split-fundoc (documentation major-mode) nil 'doc)))
+ (with-current-buffer standard-output
+ (insert ":\n")
+ (insert fundoc)
+ (insert (help-fns--list-local-commands))))))))
+ ;; For the sake of IELM and maybe others
+ nil)
(defun help-fns--list-local-commands ()
(let ((functions nil))
@@ -1998,7 +2006,8 @@ one of them returns non-nil."
(event-end key))
((eq key ?\C-g) (signal 'quit nil))
(t (user-error "You didn't specify a widget"))))))
- (let (buf)
+ (let (buf
+ (help-buffer-under-preparation t))
;; Allow describing a widget in a different window.
(when (posnp pos)
(setq buf (window-buffer (posn-window pos))
diff --git a/lisp/help-macro.el b/lisp/help-macro.el
index b3c7e2393a3..ecc7ebab412 100644
--- a/lisp/help-macro.el
+++ b/lisp/help-macro.el
@@ -93,7 +93,8 @@ and then returns."
"Help command."
(interactive)
(let ((line-prompt
- (substitute-command-keys ,help-line)))
+ (substitute-command-keys ,help-line))
+ (help-buffer-under-preparation t))
(when three-step-help
(message "%s" line-prompt))
(let* ((help-screen ,help-text)
@@ -140,6 +141,7 @@ and then returns."
(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
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index 0b404fe89f1..792f2e5af33 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -35,6 +35,8 @@
(let ((map (make-sparse-keymap)))
(set-keymap-parent map (make-composed-keymap button-buffer-map
special-mode-map))
+ (define-key map "n" 'help-goto-next-page)
+ (define-key map "p" 'help-goto-previous-page)
(define-key map "l" 'help-go-back)
(define-key map "r" 'help-go-forward)
(define-key map "\C-c\C-b" 'help-go-back)
@@ -273,6 +275,10 @@ The format is (FUNCTION ARGS...).")
(when (or (< position (point-min))
(> position (point-max)))
(widen))
+ ;; Save mark for the old location, unless the point is not
+ ;; actually going to move.
+ (unless (= (point) position)
+ (push-mark nil t))
(goto-char position))
(message "Unable to find location in file")))))
@@ -372,6 +378,13 @@ The format is (FUNCTION ARGS...).")
(view-buffer-other-window (find-file-noselect file))
(goto-char pos))
'help-echo (purecopy "mouse-2, RET: show corresponding NEWS announcement"))
+
+;;;###autoload
+(defun help-mode--add-function-link (str fun)
+ (make-text-button (copy-sequence str) nil
+ 'type 'help-function
+ 'help-args (list fun)))
+
(defvar bookmark-make-record-function)
(defvar help-mode--current-data nil)
@@ -631,34 +644,7 @@ that."
"\\<M-x\\s-+\\(\\sw\\(\\sw\\|\\s_\\)*\\sw\\)" nil t)
(let ((sym (intern-soft (match-string 1))))
(if (fboundp sym)
- (help-xref-button 1 'help-function sym)))))
- ;; Look for commands in whole keymap substitutions:
- (save-excursion
- ;; Make sure to find the first keymap.
- (goto-char (point-min))
- ;; Find a header and the column at which the command
- ;; name will be found.
-
- ;; If the keymap substitution isn't the last thing in
- ;; the doc string, and if there is anything on the same
- ;; line after it, this code won't recognize the end of it.
- (while (re-search-forward "^key +binding\n\\(-+ +\\)-+\n\n"
- nil t)
- (let ((col (- (match-end 1) (match-beginning 1))))
- (while
- (and (not (eobp))
- ;; Stop at a pair of blank lines.
- (not (looking-at-p "\n\\s-*\n")))
- ;; Skip a single blank line.
- (and (eolp) (forward-line))
- (end-of-line)
- (skip-chars-backward "^ \t\n")
- (if (and (>= (current-column) col)
- (looking-at "\\(\\sw\\|\\s_\\)+$"))
- (let ((sym (intern-soft (match-string 0))))
- (if (fboundp sym)
- (help-xref-button 0 'help-function sym))))
- (forward-line))))))
+ (help-xref-button 1 'help-function sym))))))
(set-syntax-table stab))
;; Delete extraneous newlines at the end of the docstring
(goto-char (point-max))
@@ -795,6 +781,26 @@ See `help-make-xrefs'."
(help-xref-go-forward (current-buffer))
(user-error "No next help buffer")))
+(defun help-goto-next-page ()
+ "Go to the next page (if any) in the current buffer.
+The help buffers are divided into \"pages\" by the ^L character."
+ (interactive nil help-mode)
+ (push-mark)
+ (forward-page)
+ (unless (eobp)
+ (forward-line 1)))
+
+(defun help-goto-previous-page ()
+ "Go to the previous page (if any) in the current buffer.
+(If not at the start of a page, go to the start of the current page.)
+
+The help buffers are divided into \"pages\" by the ^L character."
+ (interactive nil help-mode)
+ (push-mark)
+ (backward-page (if (looking-back "\f\n" (- (point) 5)) 2 1))
+ (unless (bobp)
+ (forward-line 1)))
+
(defun help-view-source ()
"View the source of the current help item."
(interactive nil help-mode)
diff --git a/lisp/help.el b/lisp/help.el
index 941d4cfab12..5114ddefba1 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -50,6 +50,11 @@
(defvar help-window-old-frame nil
"Frame selected at the time `with-help-window' is invoked.")
+(defvar help-buffer-under-preparation nil
+ "Whether a *Help* buffer is being prepared.
+This variable is bound to t during the preparation of a *Help*
+buffer.")
+
(defvar help-map
(let ((map (make-sparse-keymap)))
(define-key map (char-to-string help-char) 'help-for-help)
@@ -524,30 +529,31 @@ See `lossage-size' to update the number of recorded keystrokes.
To record all your input, use `open-dribble-file'."
(interactive)
- (help-setup-xref (list #'view-lossage)
- (called-interactively-p 'interactive))
- (with-help-window (help-buffer)
- (princ " ")
- (princ (mapconcat (lambda (key)
- (cond
- ((and (consp key) (null (car key)))
- (format ";; %s\n" (if (symbolp (cdr key)) (cdr key)
- "anonymous-command")))
- ((or (integerp key) (symbolp key) (listp key))
- (single-key-description key))
- (t
- (prin1-to-string key nil))))
- (recent-keys 'include-cmds)
- " "))
- (with-current-buffer standard-output
- (goto-char (point-min))
- (let ((comment-start ";; ")
- (comment-column 24))
- (while (not (eobp))
- (comment-indent)
- (forward-line 1)))
- ;; Show point near the end of "lossage", as we did in Emacs 24.
- (set-marker help-window-point-marker (point)))))
+ (let ((help-buffer-under-preparation t))
+ (help-setup-xref (list #'view-lossage)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (princ " ")
+ (princ (mapconcat (lambda (key)
+ (cond
+ ((and (consp key) (null (car key)))
+ (format ";; %s\n" (if (symbolp (cdr key)) (cdr key)
+ "anonymous-command")))
+ ((or (integerp key) (symbolp key) (listp key))
+ (single-key-description key))
+ (t
+ (prin1-to-string key nil))))
+ (recent-keys 'include-cmds)
+ " "))
+ (with-current-buffer standard-output
+ (goto-char (point-min))
+ (let ((comment-start ";; ")
+ (comment-column 24))
+ (while (not (eobp))
+ (comment-indent)
+ (forward-line 1)))
+ ;; Show point near the end of "lossage", as we did in Emacs 24.
+ (set-marker help-window-point-marker (point))))))
;; Key bindings
@@ -561,11 +567,13 @@ To record all your input, use `open-dribble-file'."
'font-lock-face 'help-key-binding
'face 'help-key-binding))
-(defcustom describe-bindings-outline nil
+(defcustom describe-bindings-outline t
"Non-nil enables outlines in the output buffer of `describe-bindings'."
:type 'boolean
:group 'help
- :version "28.1")
+ :version "29.1")
+
+(declare-function outline-hide-subtree "outline")
(defun describe-bindings (&optional prefix buffer)
"Display a buffer showing a list of all defined keys, and their definitions.
@@ -577,33 +585,32 @@ The optional argument BUFFER specifies which buffer's bindings
to display (default, the current buffer). BUFFER can be a buffer
or a buffer name."
(interactive)
- (or buffer (setq buffer (current-buffer)))
- (help-setup-xref (list #'describe-bindings prefix buffer)
- (called-interactively-p 'interactive))
- (with-help-window (help-buffer)
- ;; Be aware that `describe-buffer-bindings' puts its output into
- ;; the current buffer.
- (with-current-buffer (help-buffer)
- (describe-buffer-bindings buffer prefix)
-
- (when describe-bindings-outline
- (setq-local outline-regexp ".*:$")
- (setq-local outline-heading-end-regexp ":\n")
- (setq-local outline-level (lambda () 1))
- (setq-local outline-minor-mode-cycle t
- outline-minor-mode-highlight t)
- (outline-minor-mode 1)
- (save-excursion
- (let ((inhibit-read-only t))
+ (let ((help-buffer-under-preparation t))
+ (or buffer (setq buffer (current-buffer)))
+ (help-setup-xref (list #'describe-bindings prefix buffer)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (with-current-buffer (help-buffer)
+ (describe-buffer-bindings buffer prefix)
+
+ (when describe-bindings-outline
+ (setq-local outline-regexp ".*:$")
+ (setq-local outline-heading-end-regexp ":\n")
+ (setq-local outline-level (lambda () 1))
+ (setq-local outline-minor-mode-cycle t
+ outline-minor-mode-highlight t)
+ (setq-local outline-minor-mode-use-buttons t)
+ (outline-minor-mode 1)
+ (save-excursion
(goto-char (point-min))
- (insert (substitute-command-keys
- (concat "\\<outline-minor-mode-cycle-map>Type "
- "\\[outline-cycle] or \\[outline-cycle-buffer] "
- "on headings to cycle their visibility.\n\n")))
- ;; Hide the longest body
- (when (and (re-search-forward "Key translations" nil t)
- (fboundp 'outline-cycle))
- (outline-cycle))))))))
+ (let ((inhibit-read-only t))
+ ;; Hide the longest body.
+ (when (re-search-forward "Key translations" nil t)
+ (outline-hide-subtree))
+ ;; Hide ^Ls.
+ (while (search-forward "\n\f\n" nil t)
+ (put-text-property (1+ (match-beginning 0)) (1- (match-end 0))
+ 'invisible t)))))))))
(defun where-is (definition &optional insert)
"Print message listing key sequences that invoke the command DEFINITION.
@@ -903,7 +910,8 @@ current buffer."
(let ((raw (if (numberp buffer) (this-single-command-raw-keys) buffer)))
(setf (cdar (last key-list)) raw)))
(setq buffer nil))
- (let* ((buf (or buffer (current-buffer)))
+ (let* ((help-buffer-under-preparation t)
+ (buf (or buffer (current-buffer)))
(on-link
(mapcar (lambda (kr)
(let ((raw (cdr kr)))
@@ -1060,6 +1068,14 @@ is currently activated with completion."
result))
+(defcustom help-link-key-to-documentation t
+ "Non-nil means link keys to their command in *Help* buffers.
+This affects \\\\=\\[command] substitutions in documentation
+strings done by `substitute-command-keys'."
+ :type 'boolean
+ :version "29.1"
+ :group 'help)
+
(defun substitute-command-keys (string &optional no-face)
"Substitute key descriptions for command names in STRING.
Each substring of the form \\\\=[COMMAND] is replaced by either a
@@ -1067,6 +1083,9 @@ keystroke sequence that invokes COMMAND, or \"M-x COMMAND\" if COMMAND
is not on any keys. Keybindings will use the face `help-key-binding',
unless the optional argument NO-FACE is non-nil.
+Each substring of the form \\\\=`KEYBINDING' will be replaced by
+KEYBINDING and use the `help-key-binding' face.
+
Each substring of the form \\\\={MAPVAR} is replaced by a summary of
the value of MAPVAR as a keymap. This summary is similar to the one
produced by ‘describe-bindings’. The summary ends in two newlines
@@ -1119,6 +1138,23 @@ Otherwise, return a new string."
(delete-char 2)
(ignore-errors
(forward-char 1)))
+ ((and (= (following-char) ?`)
+ (save-excursion
+ (prog1 (search-forward "'" nil t)
+ (setq end-point (- (point) 2)))))
+ (goto-char orig-point)
+ (delete-char 2)
+ (goto-char (1- end-point))
+ (delete-char 1)
+ ;; (backward-char 1)
+ (let ((k (buffer-substring-no-properties orig-point (point))))
+ (cond ((= (length k) 0)
+ (error "Empty key sequence in substitution"))
+ ((not (key-valid-p k))
+ (error "Invalid key sequence in substitution: `%s'" k))))
+ (add-text-properties orig-point (point)
+ '( face help-key-binding
+ font-lock-face help-key-binding)))
;; 1C. \[foo] is replaced with the keybinding.
((and (= (following-char) ?\[)
(save-excursion
@@ -1150,9 +1186,19 @@ Otherwise, return a new string."
(delete-char 1))
;; Function is on a key.
(delete-char (- end-point (point)))
- (insert (if no-face
- (key-description key)
- (help--key-description-fontified key))))))
+
+ (insert
+ (if no-face
+ (key-description key)
+ (let ((key (help--key-description-fontified key)))
+ (if (and help-link-key-to-documentation
+ help-buffer-under-preparation
+ (functionp fun))
+ ;; The `fboundp' fixes bootstrap.
+ (if (fboundp 'help-mode--add-function-link)
+ (help-mode--add-function-link key fun)
+ key)
+ key)))))))
;; 1D. \{foo} is replaced with a summary of the keymap
;; (symbol-value foo).
;; \<foo> just sets the keymap used for \[cmd].
@@ -1212,8 +1258,8 @@ Otherwise, return a new string."
(buffer-string)))))
(defvar help--keymaps-seen nil)
-(defun describe-map-tree (startmap partial shadow prefix title no-menu
- transl always-title mention-shadow)
+(defun describe-map-tree (startmap &optional partial shadow prefix title
+ no-menu transl always-title mention-shadow)
"Insert a description of the key bindings in STARTMAP.
This is followed by the key bindings of all maps reachable
through STARTMAP.
@@ -1239,10 +1285,7 @@ maps to look through.
If MENTION-SHADOW is non-nil, then when something is shadowed by
SHADOW, don't omit it; instead, mention it but say it is
-shadowed.
-
-Any inserted text ends in two newlines (used by
-`help-make-xrefs')."
+shadowed."
(let* ((amaps (accessible-keymaps startmap prefix))
(orig-maps (if no-menu
(progn
@@ -1259,17 +1302,8 @@ Any inserted text ends in two newlines (used by
result))
amaps))
(maps orig-maps)
- (print-title (or maps always-title)))
- ;; Print title.
- (when print-title
- (insert (concat (if title
- (concat title
- (if prefix
- (concat " Starting With "
- (help--key-description-fontified prefix)))
- ":\n"))
- "key binding\n"
- "--- -------\n")))
+ (print-title (or maps always-title))
+ (start-point (point)))
;; Describe key bindings.
(setq help--keymaps-seen nil)
(while (consp maps)
@@ -1294,8 +1328,24 @@ Any inserted text ends in two newlines (used by
(describe-map (cdr elt) elt-prefix transl partial
sub-shadows no-menu mention-shadow)))
(setq maps (cdr maps)))
- (when print-title
- (insert "\n"))))
+ ;; Print title...
+ (when (and print-title
+ ;; ... unless the keymap was empty.
+ (/= (point) start-point))
+ (save-excursion
+ (goto-char start-point)
+ (when (eolp)
+ (delete-region (point) (1+ (point))))
+ (insert
+ (concat
+ (if title
+ (concat title
+ (if prefix
+ (concat " Starting With "
+ (help--key-description-fontified prefix)))
+ ":\n"))
+ "\nKey Binding\n"
+ (make-separator-line)))))))
(defun help--shadow-lookup (keymap key accept-default remap)
"Like `lookup-key', but with command remapping.
@@ -1308,48 +1358,37 @@ Return nil if the key sequence is too long."
value))
(t value))))
-(defvar help--previous-description-column 0)
-(defun help--describe-command (definition)
- ;; Converted from describe_command in keymap.c.
- ;; If column 16 is no good, go to col 32;
- ;; but don't push beyond that--go to next line instead.
- (let* ((column (current-column))
- (description-column (cond ((> column 30)
- (insert "\n")
- 32)
- ((or (> column 14)
- (and (> column 10)
- (= help--previous-description-column 32)))
- 32)
- (t 16))))
- ;; Avoid using the `help-keymap' face.
- (let ((op (point)))
- (indent-to description-column 1)
- (set-text-properties op (point) '( face nil
- font-lock-face nil)))
- (setq help--previous-description-column description-column)
- (cond ((symbolp definition)
- (insert (symbol-name definition) "\n"))
- ((or (stringp definition) (vectorp definition))
- (insert "Keyboard Macro\n"))
- ((keymapp definition)
- (insert "Prefix Command\n"))
- (t (insert "??\n")))))
-
-(defun help--describe-translation (definition)
- ;; Converted from describe_translation in keymap.c.
- ;; Avoid using the `help-keymap' face.
- (let ((op (point)))
- (indent-to 16 1)
- (set-text-properties op (point) '( face nil
- font-lock-face nil)))
+(defun help--describe-command (definition &optional translation)
(cond ((symbolp definition)
- (insert (symbol-name definition) "\n"))
+ (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))
- (insert (key-description definition nil) "\n"))
+ (if translation
+ (insert (key-description definition nil) "\n")
+ (insert "Keyboard Macro\n")))
((keymapp definition)
(insert "Prefix Command\n"))
- (t (insert "??\n"))))
+ ((byte-code-function-p definition)
+ (insert "[%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"))))
+
+(define-obsolete-function-alias 'help--describe-translation
+ #'help--describe-command "29.1")
(defun help--describe-map-compare (a b)
(let ((a (car a))
@@ -1363,7 +1402,8 @@ Return nil if the key sequence is too long."
(string-version-lessp (symbol-name a) (symbol-name b)))
(t nil))))
-(defun describe-map (map prefix transl partial shadow nomenu mention-shadow)
+(defun describe-map (map &optional prefix transl partial shadow
+ nomenu mention-shadow)
"Describe the contents of keymap MAP.
Assume that this keymap itself is reached by the sequence of
prefix keys PREFIX (a string or vector).
@@ -1375,14 +1415,22 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in
(map (keymap-canonicalize map))
(tail map)
(first t)
- (describer (if transl
- #'help--describe-translation
- #'help--describe-command))
done vect)
(while (and (consp tail) (not done))
(cond ((or (vectorp (car tail)) (char-table-p (car tail)))
- (help--describe-vector (car tail) prefix describer partial
- shadow map mention-shadow))
+ (let ((columns ()))
+ (help--describe-vector
+ (car tail) prefix
+ (lambda (def)
+ (let ((start-line (line-beginning-position))
+ (end-key (point))
+ (column (current-column)))
+ (help--describe-command def transl)
+ (push (list column start-line end-key (1- (point)))
+ columns)))
+ partial shadow map mention-shadow)
+ (when columns
+ (describe-map--align-section columns))))
((consp (car tail))
(let ((event (caar tail))
definition this-shadowed)
@@ -1425,7 +1473,9 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in
(push (cons tail prefix) help--keymaps-seen)))))
(setq tail (cdr tail)))
;; If we found some sparse map events, sort them.
- (let ((vect (sort vect 'help--describe-map-compare)))
+ (let ((vect (sort vect 'help--describe-map-compare))
+ (columns ())
+ line-start key-end column)
;; Now output them in sorted order.
(while vect
(let* ((elem (car vect))
@@ -1433,10 +1483,6 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in
(definition (cadr elem))
(shadowed (caddr elem))
(end start))
- (when first
- (setq help--previous-description-column 0)
- (insert "\n")
- (setq first nil))
;; Find consecutive chars that are identically defined.
(when (fixnump start)
(while (and (cdr vect)
@@ -1451,26 +1497,80 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in
(eq this-shadowed next-shadowed))))
(setq vect (cdr vect))
(setq end (caar vect))))
- ;; Now START .. END is the range to describe next.
- ;; Insert the string to describe the event START.
- (insert (help--key-description-fontified (vector start) prefix))
- (when (not (eq start end))
- (insert " .. " (help--key-description-fontified (vector end) prefix)))
- ;; Print a description of the definition of this character.
- ;; Called function will take care of spacing out far enough
- ;; for alignment purposes.
- (if transl
- (help--describe-translation definition)
- (help--describe-command definition))
- ;; Print a description of the definition of this character.
- ;; elt_describer will take care of spacing out far enough for
- ;; alignment purposes.
- (when shadowed
- (goto-char (max (1- (point)) (point-min)))
- (insert "\n (this binding is currently shadowed)")
- (goto-char (min (1+ (point)) (point-max)))))
+ (when (or (not (eq start end))
+ ;; Don't output keymap prefixes.
+ (not (keymapp definition)))
+ (when first
+ (insert "\n")
+ (setq first nil))
+ ;; Now START .. END is the range to describe next.
+ ;; Insert the string to describe the event START.
+ (setq line-start (point))
+ (insert (help--key-description-fontified (vector start) prefix))
+ (when (not (eq start end))
+ (insert " .. " (help--key-description-fontified (vector end)
+ prefix)))
+ (setq key-end (point)
+ column (current-column))
+ ;; Print a description of the definition of this character.
+ ;; Called function will take care of spacing out far enough
+ ;; for alignment purposes.
+ (help--describe-command definition transl)
+ (push (list column line-start key-end (1- (point))) columns)
+ ;; Print a description of the definition of this character.
+ ;; elt_describer will take care of spacing out far enough for
+ ;; alignment purposes.
+ (when shadowed
+ (goto-char (max (1- (point)) (point-min)))
+ (insert "\n (this binding is currently shadowed)")
+ (goto-char (min (1+ (point)) (point-max))))))
;; Next item in list.
- (setq vect (cdr vect))))))
+ (setq vect (cdr vect)))
+ (when columns
+ (describe-map--align-section columns)))))
+
+(defun describe-map--align-section (columns)
+ (save-excursion
+ (let ((max-key (apply #'max (mapcar #'car columns))))
+ (cond
+ ;; It's fine to use the minimum, so just do it, but quantize to
+ ;; two different widths, because having each block align slightly
+ ;; differently looks untidy.
+ ((< max-key 16)
+ (describe-map--fill-columns columns 16))
+ ((< max-key 24)
+ (describe-map--fill-columns columns 24))
+ ((< max-key 32)
+ (describe-map--fill-columns columns 32))
+ ;; We have some really wide ones in this block.
+ (t
+ (let ((window-width (window-width))
+ (max-def (apply #'max (mapcar
+ (lambda (elem)
+ (- (nth 3 elem) (nth 2 elem)))
+ columns))))
+ (if (< (+ max-def (max 16 max-key)) window-width)
+ ;; Can we do the block without continuation lines? Then do that.
+ (describe-map--fill-columns columns (1+ (max 16 max-key)))
+ ;; No, do continuation lines for some definitions.
+ (dolist (elem columns)
+ (goto-char (caddr elem))
+ (if (< (+ (car elem) (- (nth 3 elem) (nth 2 elem))) window-width)
+ ;; Indent.
+ (insert-char ?\s (- (1+ max-key) (car elem)))
+ ;; Continuation.
+ (insert "\n")
+ (insert-char ?\t 2))))))))))
+
+(defun describe-map--fill-columns (columns width)
+ (dolist (elem columns)
+ (goto-char (caddr elem))
+ (let ((tabs (- (/ width tab-width)
+ (/ (car elem) tab-width))))
+ (insert-char ?\t tabs)
+ (insert-char ?\s (if (zerop tabs)
+ (- width (car elem))
+ (mod width tab-width))))))
;;;; This Lisp version is 100 times slower than its C equivalent:
;;
@@ -1606,10 +1706,16 @@ and some others."
(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.")
+
(defun resize-temp-buffer-window (&optional window)
"Resize WINDOW to fit its contents.
WINDOW must be a live window and defaults to the selected one.
-Do not resize if WINDOW was not created by `display-buffer'.
+Do not resize if WINDOW was not created by `display-buffer'. Do
+not resize either if a `window-height', `window-width' or
+`window-size' entry in `display-buffer-alist' prescribes some
+alternative resizing for WINDOW's buffer.
If WINDOW is part of a vertical combination, restrain its new
size by `temp-buffer-max-height' and do not resize if its minimum
@@ -1624,27 +1730,33 @@ provided `fit-frame-to-buffer' is non-nil.
This function may call `preserve-window-size' to preserve the
size of WINDOW."
(setq window (window-normalize-window window t))
- (let ((height (if (functionp temp-buffer-max-height)
+ (let* ((buffer (window-buffer window))
+ (height (if (functionp temp-buffer-max-height)
+ (with-selected-window window
+ (funcall temp-buffer-max-height buffer))
+ temp-buffer-max-height))
+ (width (if (functionp temp-buffer-max-width)
(with-selected-window window
- (funcall temp-buffer-max-height (window-buffer)))
- temp-buffer-max-height))
- (width (if (functionp temp-buffer-max-width)
- (with-selected-window window
- (funcall temp-buffer-max-width (window-buffer)))
- temp-buffer-max-width))
- (quit-cadr (cadr (window-parameter window 'quit-restore))))
- ;; Resize WINDOW iff it was made by `display-buffer'.
+ (funcall temp-buffer-max-width buffer))
+ temp-buffer-max-width))
+ (quit-cadr (cadr (window-parameter window 'quit-restore))))
+ ;; Resize WINDOW only if it was made by `display-buffer'.
(when (or (and (eq quit-cadr 'window)
(or (and (window-combined-p window)
(not (eq fit-window-to-buffer-horizontally
'only))
- (pos-visible-in-window-p (point-min) window))
+ (pos-visible-in-window-p
+ (with-current-buffer buffer (point-min))
+ window)
+ (not resize-temp-buffer-window-inhibit))
(and (window-combined-p window t)
- fit-window-to-buffer-horizontally)))
+ fit-window-to-buffer-horizontally
+ (not resize-temp-buffer-window-inhibit))))
(and (eq quit-cadr 'frame)
fit-frame-to-buffer
- (eq window (frame-root-window window))))
- (fit-window-to-buffer window height nil width nil t))))
+ (eq window (frame-root-window window))
+ (not resize-temp-buffer-window-inhibit)))
+ (fit-window-to-buffer window height nil width nil t))))
;;; Help windows.
(defcustom help-window-select nil
@@ -1754,13 +1866,13 @@ Return VALUE."
(cond
((eq help-setup 'window)
;; ... and is new, ...
- "Type \"q\" to delete help window")
+ "Type \\<help-map>\\[help-quit] to delete help window")
((eq help-setup 'frame)
;; ... on a new frame, ...
- "Type \"q\" to quit the help frame")
+ "Type \\<help-map>\\[help-quit] to quit the help frame")
((eq help-setup 'other)
;; ... or displayed some other buffer before.
- "Type \"q\" to restore previous buffer"))
+ "Type \\<help-map>\\[help-quit] to restore previous buffer"))
window t))
((and (eq (window-frame window) help-window-old-frame)
(= (length (window-list nil 'no-mini)) 2))
@@ -1771,7 +1883,7 @@ Return VALUE."
((eq help-setup 'window)
"Type \\[delete-other-windows] to delete the help window")
((eq help-setup 'other)
- "Type \"q\" in help window to restore its previous buffer"))
+ "Type \\<help-map>\\[help-quit] in help window to restore its previous buffer"))
window 'other))
(t
;; The help window is not selected ...
@@ -1779,10 +1891,10 @@ Return VALUE."
(cond
((eq help-setup 'window)
;; ... and is new, ...
- "Type \"q\" in help window to delete it")
+ "Type \\<help-map>\\[help-quit] in help window to delete it")
((eq help-setup 'other)
;; ... or displayed some other buffer before.
- "Type \"q\" in help window to restore previous buffer"))
+ "Type \\<help-map>\\[help-quit] in help window to restore previous buffer"))
window))))
;; Return VALUE.
value))
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el
index 9fe6e825f78..8dc4cce3239 100644
--- a/lisp/htmlfontify.el
+++ b/lisp/htmlfontify.el
@@ -77,6 +77,7 @@
;; Changes: moved to changelog (CHANGES) file.
;;; Code:
+
(eval-when-compile (require 'cl-lib))
(require 'cus-edit)
@@ -2307,10 +2308,6 @@ See also `hfy-load-tags-cache'."
(interactive "D source directory: ")
(hfy-load-tags-cache (directory-file-name srcdir)))
-;;(defun hfy-test-read-args (foo bar)
-;; (interactive "D source directory: \nD target directory: ")
-;; (message "foo: %S\nbar: %S" foo bar))
-
(defun hfy-save-kill-buffers (buffer-list &optional dstdir)
(dolist (B buffer-list)
(set-buffer B)
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index 5b69a878e21..2d2365dc34d 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -1597,7 +1597,10 @@ to move by. The default is `ibuffer-marked-char'."
"Hide all of the currently marked lines."
(interactive)
(if (= (ibuffer-count-marked-lines) 0)
- (message "No buffers marked; use `m' to mark a buffer")
+ (message (substitute-command-keys
+ (concat
+ "No buffers marked; use \\<ibuffer-mode-map>"
+ "\\[ibuffer-mark-forward] to mark a buffer")))
(let ((count
(ibuffer-map-marked-lines
(lambda (_buf _mark)
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index 233127b0112..b461197abe9 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -1257,7 +1257,9 @@ Otherwise, toggle lock status."
"Unmark all buffers with mark MARK."
(interactive "cRemove marks (RET means all):")
(if (= (ibuffer-count-marked-lines t) 0)
- (message "No buffers marked; use `m' to mark a buffer")
+ (message (substitute-command-keys
+ "No buffers marked; use \\<ibuffer-mode-map>\
+\\[ibuffer-mark-forward] to mark a buffer"))
(let ((fn (lambda (_buf mk)
(unless (eq mk ?\s)
(ibuffer-set-mark-1 ?\s)) t)))
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index 01033474d38..f909a3b1771 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -380,13 +380,17 @@ if that doesn't produce a completion match."
(defun icomplete-fido-backward-updir ()
"Delete char before or go up directory, like `ido-mode'."
(interactive)
- (if (and (eq (char-before) ?/)
- (eq (icomplete--category) 'file))
- (save-excursion
- (goto-char (1- (point)))
- (when (search-backward "/" (point-min) t)
- (delete-region (1+ (point)) (point-max))))
- (call-interactively 'backward-delete-char)))
+ (cond ((and (eq (char-before) ?/)
+ (eq (icomplete--category) 'file))
+ (when (string-equal (icomplete--field-string) "~/")
+ (delete-region (icomplete--field-beg) (icomplete--field-end))
+ (insert (expand-file-name "~/"))
+ (goto-char (line-end-position)))
+ (save-excursion
+ (goto-char (1- (point)))
+ (when (search-backward "/" (point-min) t)
+ (delete-region (1+ (point)) (point-max)))))
+ (t (call-interactively 'backward-delete-char))))
(defvar icomplete-fido-mode-map
(let ((map (make-sparse-keymap)))
@@ -716,11 +720,6 @@ See `icomplete-mode' and `minibuffer-setup-hook'."
(delete-region (overlay-start rfn-eshadow-overlay)
(overlay-end rfn-eshadow-overlay)))
(let* ((field-string (icomplete--field-string))
- ;; Not sure why, but such requests seem to come
- ;; every once in a while. It's not fully
- ;; deterministic but `C-x C-f M-DEL M-DEL ...'
- ;; seems to trigger it fairly often!
- (while-no-input-ignore-events '(selection-request))
(text (while-no-input
(icomplete-completions
field-string
diff --git a/lisp/ido.el b/lisp/ido.el
index 7c2d2eb0d75..6767d669880 100644
--- a/lisp/ido.el
+++ b/lisp/ido.el
@@ -354,8 +354,8 @@ The following values are possible:
Setting this variable directly does not take effect;
use either \\[customize] or the function `ido-mode'."
- :set #'(lambda (_symbol value)
- (ido-mode (or value 0)))
+ :set (lambda (_symbol value)
+ (ido-mode (or value 0)))
:initialize #'custom-initialize-default
:require 'ido
:link '(emacs-commentary-link "ido.el")
@@ -620,9 +620,9 @@ hosts on first use of UNC path."
(function-item :tag "Use `NET VIEW'"
:value ido-unc-hosts-net-view)
(function :tag "Your own function"))
- :set #'(lambda (symbol value)
- (set symbol value)
- (setq ido-unc-hosts-cache t)))
+ :set (lambda (symbol value)
+ (set symbol value)
+ (setq ido-unc-hosts-cache t)))
(defcustom ido-downcase-unc-hosts t
"Non-nil if UNC host names should be downcased."
diff --git a/lisp/ielm.el b/lisp/ielm.el
index 39820a893a9..ec7f010a4d5 100644
--- a/lisp/ielm.el
+++ b/lisp/ielm.el
@@ -148,28 +148,28 @@ such as `edebug-defun' to work with such inputs."
This variable is buffer-local.")
(defvar ielm-header
- "*** Welcome to IELM *** Type (describe-mode) for help.\n"
+ (substitute-command-keys
+ "*** Welcome to IELM *** Type (describe-mode) or press \
+\\[describe-mode] for help.\n")
"Message to display when IELM is started.")
(defvaralias 'inferior-emacs-lisp-mode-map 'ielm-map)
-(defvar ielm-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\t" 'ielm-tab)
- (define-key map "\C-m" 'ielm-return)
- (define-key map "\e\C-m" 'ielm-return-for-effect)
- (define-key map "\C-j" 'ielm-send-input)
- (define-key map "\e\C-x" 'eval-defun) ; for consistency with
- (define-key map "\e\t" 'completion-at-point) ; lisp-interaction-mode
- ;; These bindings are from `lisp-mode-shared-map' -- can you inherit
- ;; from more than one keymap??
- (define-key map "\e\C-q" 'indent-sexp)
- (define-key map "\177" 'backward-delete-char-untabify)
- ;; Some convenience bindings for setting the working buffer
- (define-key map "\C-c\C-b" 'ielm-change-working-buffer)
- (define-key map "\C-c\C-f" 'ielm-display-working-buffer)
- (define-key map "\C-c\C-v" 'ielm-print-working-buffer)
- map)
- "Keymap for IELM mode.")
+(defvar-keymap ielm-map
+ :doc "Keymap for IELM mode."
+ "TAB" #'ielm-tab
+ "RET" #'ielm-return
+ "M-RET" #'ielm-return-for-effect
+ "C-j" #'ielm-send-input
+ "C-M-x" #'eval-defun ; for consistency with
+ "M-TAB" #'completion-at-point ; lisp-interaction-mode
+ ;; These bindings are from `lisp-mode-shared-map' -- can you inherit
+ ;; from more than one keymap??
+ "C-M-q" #'indent-sexp
+ "DEL" #'backward-delete-char-untabify
+ ;; Some convenience bindings for setting the working buffer
+ "C-c C-b" #'ielm-change-working-buffer
+ "C-c C-f" #'ielm-display-working-buffer
+ "C-c C-v" #'ielm-print-working-buffer)
(easy-menu-define ielm-menu ielm-map
"IELM mode menu."
diff --git a/lisp/image-dired.el b/lisp/image-dired.el
index 3ac44dac9fb..6ca0cd8831d 100644
--- a/lisp/image-dired.el
+++ b/lisp/image-dired.el
@@ -1,7 +1,7 @@
;;; image-dired.el --- use dired to browse and manipulate your images -*- lexical-binding: t -*-
-;;
+
;; Copyright (C) 2005-2021 Free Software Foundation, Inc.
-;;
+
;; Version: 0.4.11
;; Keywords: multimedia
;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com>
@@ -22,7 +22,7 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
-;;
+
;; BACKGROUND
;; ==========
;;
@@ -59,19 +59,22 @@
;; PREREQUISITES
;; =============
;;
-;; * The ImageMagick package. Currently, `convert' and `mogrify' are
-;; used. Find it here: https://www.imagemagick.org.
+;; * The GraphicsMagick or ImageMagick package; Image-Dired uses
+;; whichever is available.
+;;
+;; A) For GraphicsMagick, `gm' is used.
+;; Find it here: http://www.graphicsmagick.org/
+;;
+;; B) For ImageMagick, `convert' and `mogrify' are used.
+;; Find it here: https://www.imagemagick.org.
;;
;; * For non-lossy rotation of JPEG images, the JpegTRAN program is
-;; needed.
+;; needed.
;;
-;; * For `image-dired-get-exif-data' and `image-dired-set-exif-data' to work,
-;; the command line tool `exiftool' is needed. It can be found here:
-;; https://exiftool.org/. These two functions are, among other
-;; things, used for writing comments to image files using
-;; `image-dired-thumbnail-set-image-description' and to create
-;; "unique" file names using `image-dired-get-exif-file-name' (used by
-;; `image-dired-copy-with-exif-file-name').
+;; * For `image-dired-set-exif-data' to work, the command line tool `exiftool' is
+;; needed. It can be found here: https://exiftool.org/. This
+;; function is, among other things, used for writing comments to
+;; image files using `image-dired-thumbnail-set-image-description'.
;;
;;
;; USAGE
@@ -89,73 +92,60 @@
;; ===========
;;
;; * Supports all image formats that Emacs and convert supports, but
-;; the thumbnails are hard-coded to JPEG format.
+;; the thumbnails are hard-coded to JPEG or PNG format. It uses
+;; JPEG by default, but can optionally follow the Thumbnail Managing
+;; Standard (v0.9.0, Dec 2020), which mandates PNG. See the user
+;; option `image-dired-thumbnail-storage'.
;;
;; * WARNING: The "database" format used might be changed so keep a
-;; backup of `image-dired-db-file' when testing new versions.
-;;
-;; * `image-dired-display-image-mode' does not support animation
+;; backup of `image-dired-db-file' when testing new versions.
;;
;; TODO
;; ====
;;
-;; * Support gallery creation when using per-directory thumbnail
-;; storage.
-;;
-;; * Some sort of auto-rotate function based on rotate info in the
-;; EXIF data.
-;;
;; * Investigate if it is possible to also write the tags to the image
-;; files.
+;; files.
;;
;; * From thumbs.el: Add an option for clean-up/max-size functionality
;; for thumbnail directory.
;;
;; * From thumbs.el: Add setroot function.
;;
-;; * From thumbs.el: Add image resizing, if useful (image-dired's automatic
-;; "image fit" might be enough)
-;;
-;; * From thumbs.el: Add the "modify" commands (emboss, negate,
-;; monochrome etc).
-;;
-;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find
-;; out which is best, saving old batch just before inserting new, or
-;; saving the current batch in the ring when inserting it. Adding it
-;; probably needs rewriting `image-dired-display-thumbs' to be more general.
+;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find out
+;; which is best, saving old batch just before inserting new, or
+;; saving the current batch in the ring when inserting it. Adding
+;; it probably needs rewriting `image-dired-display-thumbs' to be more general.
;;
;; * Find some way of toggling on and off really nice keybindings in
-;; dired (for example, using C-n or <down> instead of C-S-n). Richard
-;; suggested that we could keep C-t as prefix for image-dired commands
-;; as it is currently not used in dired. He also suggested that
-;; `dired-next-line' and `dired-previous-line' figure out if
-;; image-dired is enabled in the current buffer and, if it is, call
-;; `image-dired-dired-next-line' and
-;; `image-dired-dired-previous-line', respectively. Update: This is
-;; partly done; some bindings have now been added to dired.
-;;
-;; * Enhanced gallery creation with basic CSS-support and pagination
-;; of tag pages with many pictures.
-;;
-;; * Rewrite `image-dired-modify-mark-on-thumb-original-file' to be
-;; less ugly.
+;; Dired (for example, using C-n or <down> instead of C-S-n).
+;; Richard suggested that we could keep C-t as prefix for
+;; image-dired commands as it is currently not used in Dired. He
+;; also suggested that `dired-next-line' and `dired-previous-line'
+;; figure out if image-dired is enabled in the current buffer and,
+;; if it is, call `image-dired-dired-next-line' and `image-dired-dired-previous-line',
+;; respectively. Update: This is partly done; some bindings have
+;; now been added to Dired.
;;
;; * In some way keep track of buffers and windows and stuff so that
-;; it works as the user expects.
-;;
-;; * More/better documentation
-;;
+;; it works as the user expects.
;;
+;; * More/better documentation.
+
;;; Code:
(require 'dired)
+(require 'exif)
(require 'image-mode)
(require 'widget)
+(require 'xdg)
(eval-when-compile
(require 'cl-lib)
(require 'wid-edit))
+
+;;; Customizable variables
+
(defgroup image-dired nil
"Use Dired to browse your images as thumbnails, and more."
:prefix "image-dired-"
@@ -165,108 +155,105 @@
(defcustom image-dired-dir (locate-user-emacs-file "image-dired/")
"Directory where thumbnail images are stored.
-The value of this option will be ignored if Image Dired is
+The value of this option will be ignored if Image-Dired is
customized to use the Thumbnail Managing Standard; they will be
saved in \"$XDG_CACHE_HOME/thumbnails/\" instead. See
`image-dired-thumbnail-storage'."
:type 'directory)
(defcustom image-dired-thumbnail-storage 'use-image-dired-dir
- "How to store image-dired's thumbnail files.
-Image-Dired can store thumbnail files in one of two ways and this is
-controlled by this variable. \"Use image-dired dir\" means that the
-thumbnails are stored in a central directory. \"Per directory\"
-means that each thumbnail is stored in a subdirectory called
-\".image-dired\" in the same directory where the image file is.
-\"Thumbnail Managing Standard\" means that the thumbnails are
-stored and generated according to the Thumbnail Managing Standard
-that allows sharing of thumbnails across different programs."
+ "How `image-dired' stores thumbnail files.
+There are two ways that Image-Dired can store and generate
+thumbnails. If you set this variable to one of the two following
+values, they will be stored in the JPEG format:
+
+- `use-image-dired-dir' means that the thumbnails are stored in a
+ central directory.
+
+- `per-directory' means that each thumbnail is stored in a
+ subdirectory called \".image-dired\" in the same directory
+ where the image file is.
+
+It can also use the \"Thumbnail Managing Standard\", which allows
+sharing of thumbnails across different programs. Thumbnails will
+be stored in \"$XDG_CACHE_HOME/thumbnails/\" instead of in
+`image-dired-dir'. Thumbnails are saved in the PNG format, and
+can be one of the following sizes:
+
+- `standard' means use thumbnails sized 128x128.
+- `standard-large' means use thumbnails sized 256x256.
+- `standard-x-large' means use thumbnails sized 512x512.
+- `standard-xx-large' means use thumbnails sized 1024x1024.
+
+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"
(const :tag "Use image-dired-dir" use-image-dired-dir)
- (const :tag "Thumbnail Managing Standard (normal 128x128)" standard)
- (const :tag "Thumbnail Managing Standard (large 256x256)" standard-large)
- (const :tag "Per-directory" per-directory)))
+ (const :tag "Thumbnail Managing Standard (normal 128x128)"
+ standard)
+ (const :tag "Thumbnail Managing Standard (large 256x256)"
+ standard-large)
+ (const :tag "Thumbnail Managing Standard (larger 512x512)"
+ standard-x-large)
+ (const :tag "Thumbnail Managing Standard (extra large 1024x1024)"
+ standard-xx-large)
+ (const :tag "Per-directory" per-directory))
+ :version "29.1")
+
+(defconst image-dired--thumbnail-standard-sizes
+ '( standard standard-large
+ standard-x-large standard-xx-large)
+ "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.")
(defcustom image-dired-db-file
(expand-file-name ".image-dired_db" image-dired-dir)
"Database file where file names and their associated tags are stored."
:type 'file)
-(defcustom image-dired-temp-image-file
- (expand-file-name ".image-dired_temp" image-dired-dir)
- "Name of temporary image file used by various commands."
- :type 'file)
-
-(defcustom image-dired-gallery-dir
- (expand-file-name ".image-dired_gallery" image-dired-dir)
- "Directory to store generated gallery html pages.
-This path needs to be \"shared\" to the public so that it can access
-the index.html page that image-dired creates."
- :type 'directory)
-
-(defcustom image-dired-gallery-image-root-url
-"https://your.own.server/image-diredpics"
- "URL where the full size images are to be found.
-Note that this path has to be configured in your web server. Image-Dired
-expects to find pictures in this directory."
- :type 'string)
-
-(defcustom image-dired-gallery-thumb-image-root-url
-"https://your.own.server/image-diredthumbs"
- "URL where the thumbnail images are to be found.
-Note that this path has to be configured in your web server. Image-Dired
-expects to find pictures in this directory."
- :type 'string)
-
(defcustom image-dired-cmd-create-thumbnail-program
- "convert"
+ (if (executable-find "gm") "gm" "convert")
"Executable used to create thumbnail.
Used together with `image-dired-cmd-create-thumbnail-options'."
- :type 'file)
+ :type 'file
+ :version "29.1")
(defcustom image-dired-cmd-create-thumbnail-options
- '("-size" "%wx%h" "%f[0]" "-resize" "%wx%h>" "-strip" "jpeg:%t")
+ (let ((opts '("-size" "%wx%h" "%f[0]"
+ "-resize" "%wx%h>"
+ "-strip" "jpeg:%t")))
+ (if (executable-find "gm") (cons "convert" opts) opts))
"Options of command used to create thumbnail image.
Used with `image-dired-cmd-create-thumbnail-program'.
Available format specifiers are: %w which is replaced by
`image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height',
%f which is replaced by the file name of the original image and %t
which is replaced by the file name of the thumbnail file."
- :version "26.1"
- :type '(repeat (string :tag "Argument")))
-
-(defcustom image-dired-cmd-create-temp-image-program "convert"
- "Executable used to create temporary image.
-Used together with `image-dired-cmd-create-temp-image-options'."
- :type 'file)
-
-(defcustom image-dired-cmd-create-temp-image-options
- '("-size" "%wx%h" "%f[0]" "-resize" "%wx%h>" "-strip" "jpeg:%t")
- "Options of command used to create temporary image for display window.
-Used together with `image-dired-cmd-create-temp-image-program',
-Available format specifiers are: %w and %h which are replaced by
-the calculated max size for width and height in the image display window,
-%f which is replaced by the file name of the original image and %t which
-is replaced by the file name of the temporary file."
- :version "26.1"
+ :version "29.1"
:type '(repeat (string :tag "Argument")))
(defcustom image-dired-cmd-pngnq-program
- (or (executable-find "pngnq")
- (executable-find "pngnq-s9"))
- "The file name of the `pngnq' program.
+ ;; Prefer pngquant to pngnq-s9 as it is faster on my machine.
+ ;; The project also seems more active than the alternatives.
+ ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq.
+ ;; The pngnq project seems dead (?) since 2011 or so.
+ (or (executable-find "pngquant")
+ (executable-find "pngnq-s9")
+ (executable-find "pngnq"))
+ "The file name of the `pngquant' or `pngnq' program.
It quantizes colors of PNG images down to 256 colors or fewer
using the NeuQuant algorithm."
- :version "26.1"
+ :version "29.1"
:type '(choice (const :tag "Not Set" nil) file))
(defcustom image-dired-cmd-pngnq-options
- '("-f" "%t")
+ (if (executable-find "pngquant")
+ '("--ext" "-nq8.png" "%t") ; same extension as "pngnq"
+ '("-f" "%t"))
"Arguments to pass `image-dired-cmd-pngnq-program'.
Available format specifiers are the same as in
`image-dired-cmd-create-thumbnail-options'."
- :version "26.1"
- :type '(repeat (string :tag "Argument")))
+ :type '(repeat (string :tag "Argument"))
+ :version "29.1")
(defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush")
"The file name of the `pngcrush' program.
@@ -321,23 +308,6 @@ Available format specifiers are the same as in
:version "26.1"
:type '(repeat (string :tag "Argument")))
-(defcustom image-dired-cmd-rotate-thumbnail-program
- "mogrify"
- "Executable used to rotate thumbnail.
-Used together with `image-dired-cmd-rotate-thumbnail-options'."
- :type 'file)
-
-(defcustom image-dired-cmd-rotate-thumbnail-options
- '("-rotate" "%d" "%t")
- "Arguments of command used to rotate thumbnail image.
-Used with `image-dired-cmd-rotate-thumbnail-program'.
-Available format specifiers are: %d which is replaced by the
-number of (positive) degrees to rotate the image, normally 90 or 270
-\(for 90 degrees right and left), %t which is replaced by the file name
-of the thumbnail file."
- :version "26.1"
- :type '(repeat (string :tag "Argument")))
-
(defcustom image-dired-cmd-rotate-original-program
"jpegtran"
"Executable used to rotate original image.
@@ -383,37 +353,18 @@ which is replaced by the tag value."
:version "26.1"
:type '(repeat (string :tag "Argument")))
-(defcustom image-dired-cmd-read-exif-data-program
- "exiftool"
- "Program used to read EXIF data to image.
-Used together with `image-dired-cmd-read-exif-data-options'."
- :type 'file)
-
-(defcustom image-dired-cmd-read-exif-data-options
- '("-s" "-s" "-s" "-%t" "%f")
- "Arguments of command used to read EXIF data.
-Used with `image-dired-cmd-read-exif-data-program'.
-Available format specifiers are: %f which is replaced
-by the image file name and %t which is replaced by the tag name."
- :version "26.1"
- :type '(repeat (string :tag "Argument")))
-
-(defcustom image-dired-gallery-hidden-tags
- (list "private" "hidden" "pending")
- "List of \"hidden\" tags.
-Used by `image-dired-gallery-generate' to leave out \"hidden\" images."
- :type '(repeat string))
-
(defcustom image-dired-thumb-size
(cond
((eq 'standard image-dired-thumbnail-storage) 128)
((eq 'standard-large image-dired-thumbnail-storage) 256)
+ ((eq 'standard-x-large image-dired-thumbnail-storage) 512)
+ ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024)
(t 100))
"Size of thumbnails, in pixels.
This is the default size for both `image-dired-thumb-width'
and `image-dired-thumb-height'.
-The value of this option will be ignored if Image Dired is
+The value of this option will be ignored if Image-Dired is
customized to use the Thumbnail Managing Standard; the standard
sizes will be used instead. See `image-dired-thumbnail-storage'."
:type 'integer)
@@ -436,17 +387,28 @@ This is where you see the cursor."
:type 'integer)
(defcustom image-dired-thumb-visible-marks t
- "Make marks visible in thumbnail buffer.
+ "Make marks and flags visible in thumbnail buffer.
If non-nil, apply the `image-dired-thumb-mark' face to marked
-images."
+images and `image-dired-thumb-flagged' to images flagged for
+deletion."
:type 'boolean
:version "28.1")
(defface image-dired-thumb-mark
- '((t (:background "orange")))
- "Background-color for marked images in thumbnail buffer."
- :group 'image-dired
- :version "28.1")
+ '((((class color) (min-colors 16)) :background "DarkOrange")
+ (((class color)) :foreground "yellow"))
+ "Face for marked images in thumbnail buffer."
+ :version "29.1")
+
+(defface image-dired-thumb-flagged
+ '((((class color) (min-colors 88) (background light)) :background "Red3")
+ (((class color) (min-colors 88) (background dark)) :background "Pink")
+ (((class color) (min-colors 16) (background light)) :background "Red3")
+ (((class color) (min-colors 16) (background dark)) :background "Pink")
+ (((class color) (min-colors 8)) :background "red")
+ (t :inverse-video t))
+ "Face for images flagged for deletion in thumbnail buffer."
+ :version "29.1")
(defcustom image-dired-line-up-method 'dynamic
"Default method for line-up of thumbnails in thumbnail buffer.
@@ -465,18 +427,6 @@ and No line-up means that no automatic line-up will be done."
"Number of thumbnails to display per row in thumb buffer."
:type 'integer)
-(defcustom image-dired-display-window-width-correction 1
- "Number to be used to correct image display window width.
-Change if the default (1) does not work (i.e. if the image does not
-completely fit)."
- :type 'integer)
-
-(defcustom image-dired-display-window-height-correction 0
- "Number to be used to correct image display window height.
-Change if the default (0) does not work (i.e. if the image does not
-completely fit)."
- :type 'integer)
-
(defcustom image-dired-track-movement t
"The current state of the tracking and mirroring.
For more information, see the documentation for
@@ -522,15 +472,45 @@ Including parameters. Used when displaying original image from
:type '(choice string
(const :tag "Not Set" nil)))
-(defcustom image-dired-main-image-directory "~/pics/"
+(defcustom image-dired-main-image-directory
+ (or (xdg-user-dir "PICTURES") "~/pics/")
"Name of main image directory, if any.
Used by `image-dired-copy-with-exif-file-name'."
- :type 'string)
+ :type 'string
+ :version "29.1")
+
+(defcustom image-dired-show-all-from-dir-max-files 500
+ "Maximum number of files in directory before prompting.
+
+If there are more image files than this in a selected directory,
+the `image-dired-show-all-from-dir' command will ask for
+confirmation before creating the thumbnail buffer. If this
+variable is nil, it will never ask."
+ :type '(choice integer
+ (const :tag "Disable warning" nil))
+ :version "29.1")
+
+(defcustom image-dired-marking-shows-next t
+ "If non-nil, marking, unmarking or flagging an image shows the next image.
+
+This affects the following commands:
+\\<image-dired-thumbnail-mode-map>
+ `image-dired-flag-thumb-original-file' (bound to \\[image-dired-flag-thumb-original-file])
+ `image-dired-mark-thumb-original-file' (bound to \\[image-dired-mark-thumb-original-file])
+ `image-dired-unmark-thumb-original-file' (bound to \\[image-dired-unmark-thumb-original-file])"
+ :type 'boolean
+ :version "29.1")
-(defcustom image-dired-show-all-from-dir-max-files 50
- "Maximum number of files to show using `image-dired-show-all-from-dir'
-before warning."
- :type 'integer)
+
+;;; Util functions
+
+(defvar image-dired-debug nil
+ "Non-nil means enable debug messages.")
+
+(defun image-dired-debug-message (&rest args)
+ "Display debug message ARGS when `image-dired-debug' is non-nil."
+ (when image-dired-debug
+ (apply #'message args)))
(defmacro image-dired--with-db-file (&rest body)
"Run BODY in a temp buffer containing `image-dired-db-file'.
@@ -542,14 +522,14 @@ Return the last form in BODY."
,@body))
(defun image-dired-dir ()
- "Return the current thumbnails directory (from variable `image-dired-dir').
-Create the thumbnails directory if it does not exist."
+ "Return the current thumbnail directory (from variable `image-dired-dir').
+Create the thumbnail directory if it does not exist."
(let ((image-dired-dir (file-name-as-directory
- (expand-file-name image-dired-dir))))
+ (expand-file-name image-dired-dir))))
(unless (file-directory-p image-dired-dir)
(with-file-modes #o700
(make-directory image-dired-dir t))
- (message "Creating thumbnails directory"))
+ (message "Thumbnail directory created: %s" image-dired-dir))
image-dired-dir))
(defun image-dired-insert-image (file type relief margin)
@@ -562,7 +542,7 @@ Create the thumbnails directory if it does not exist."
(defun image-dired-get-thumbnail-image (file)
"Return the image descriptor for a thumbnail of image file FILE."
- (unless (string-match (image-file-name-regexp) file)
+ (unless (string-match-p (image-file-name-regexp) file)
(error "%s is not a valid image file" file))
(let* ((thumb-file (image-dired-thumb-name file))
(thumb-attr (file-attributes thumb-file)))
@@ -571,11 +551,7 @@ Create the thumbnails directory if it does not exist."
(file-attribute-modification-time
(file-attributes file))))
(image-dired-create-thumb file thumb-file))
- (create-image thumb-file)
-;; (list 'image :type 'jpeg
-;; :file thumb-file
-;; :relief image-dired-thumb-relief :margin image-dired-thumb-margin)
- ))
+ (create-image thumb-file)))
(defun image-dired-insert-thumbnail (file original-file-name
associated-dired-buffer)
@@ -583,13 +559,19 @@ Create the thumbnails directory if it does not exist."
Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER."
(let (beg end)
(setq beg (point))
- (image-dired-insert-image file
- ;; TODO: this should depend on the real file type
- (if (memq image-dired-thumbnail-storage
- '(standard standard-large))
- 'png 'jpeg)
- image-dired-thumb-relief
- image-dired-thumb-margin)
+ (image-dired-insert-image
+ file
+ ;; Thumbnails are created asynchronously, so we might not yet
+ ;; have a file. But if it exists, it might have been cached from
+ ;; before and we should use it instead of our current settings.
+ (or (and (file-exists-p file)
+ (image-type-from-file-header file))
+ (and (memq image-dired-thumbnail-storage
+ image-dired--thumbnail-standard-sizes)
+ 'png)
+ 'jpeg)
+ image-dired-thumb-relief
+ image-dired-thumb-margin)
(setq end (point))
(add-text-properties
beg end
@@ -601,35 +583,39 @@ Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER."
'comment (image-dired-get-comment original-file-name)))))
(defun image-dired-thumb-name (file)
- "Return thumbnail file name for FILE.
-Depending on the value of `image-dired-thumbnail-storage', the file
-name will vary. For central thumbnail file storage, make a
-MD5-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."
- (cond ((memq image-dired-thumbnail-storage '(standard standard-large))
- (let* ((xdg (getenv "XDG_CACHE_HOME"))
- (dir (if (and xdg (file-name-absolute-p xdg))
- xdg "~/.cache"))
- (thumbdir (cl-case image-dired-thumbnail-storage
- (standard "thumbnails/normal")
- (standard-large "thumbnails/large"))))
+ "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'."
+ (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://" (expand-file-name file))) ".png")
- (expand-file-name thumbdir dir))))
+ (expand-file-name thumbdir (xdg-cache-home)))))
((eq 'use-image-dired-dir image-dired-thumbnail-storage)
(let* ((f (expand-file-name file))
- (md5-hash
- ;; Is MD5 hashes fast enough? The checksum of a
- ;; thumbnail file name need not be that
- ;; "cryptographically" good so a faster one could
- ;; be used here.
- (md5 (file-name-as-directory (file-name-directory f)))))
+ (hash
+ ;; SHA1 is slightly faster than MD5, so let's use it.
+ ;; (We don't need anything crytographically strong.)
+ (sha1 (file-name-as-directory (file-name-directory f)))))
(format "%s%s%s.thumb.%s"
(file-name-as-directory (expand-file-name (image-dired-dir)))
(file-name-base f)
- (if md5-hash (concat "_" md5-hash) "")
+ (if hash (concat "_" hash) "")
(file-name-extension f))))
((eq 'per-directory image-dired-thumbnail-storage)
(let ((f (expand-file-name file)))
@@ -642,16 +628,24 @@ according to the Thumbnail Managing Standard."
(unless (executable-find (symbol-value executable))
(error "Executable %S not found" executable)))
+
+;;; Creating thumbnails
+
(defun image-dired-thumb-size (dimension)
"Return thumb size depending on `image-dired-thumbnail-storage'.
DIMENSION should be either the symbol `width' or `height'."
(cond
((eq 'standard image-dired-thumbnail-storage) 128)
((eq 'standard-large image-dired-thumbnail-storage) 256)
+ ((eq 'standard-x-large image-dired-thumbnail-storage) 512)
+ ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024)
(t (cl-ecase dimension
(width image-dired-thumb-width)
(height image-dired-thumb-height)))))
+(defvar image-dired--generate-thumbs-start nil
+ "Time when `display-thumbs' was called.")
+
(defvar image-dired-queue nil
"List of items in the queue.
Each item has the form (ORIGINAL-FILE TARGET-FILE).")
@@ -659,11 +653,12 @@ Each item has the form (ORIGINAL-FILE TARGET-FILE).")
(defvar image-dired-queue-active-jobs 0
"Number of active jobs in `image-dired-queue'.")
-(defvar image-dired-queue-active-limit 2
+(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2)))
"Maximum number of concurrent jobs permitted for generating images.
-Increase at own risk.")
-
-(defvar image-dired-tag-history nil "Variable holding the tag history.")
+Increase at own risk. If you want to experiment with this,
+consider setting `image-dired-debug' to a non-nil value to see
+the time spent on generating thumbnails. Run `image-clear-cache'
+and remove the cached thumbnail files between each trial run.")
(defun image-dired-pngnq-thumb (spec)
"Quantize thumbnail described by format SPEC with pngnq(1)."
@@ -750,9 +745,9 @@ Increase at own risk.")
(thumbnail-dir (file-name-directory thumbnail-file))
process)
(when (not (file-exists-p thumbnail-dir))
- (message "Creating thumbnail directory")
(with-file-modes #o700
- (make-directory thumbnail-dir t)))
+ (make-directory thumbnail-dir t))
+ (message "Thumbnail directory created: %s" thumbnail-dir))
;; Thumbnail file creation processes begin here and are marshaled
;; in a queue by `image-dired-create-thumb'.
@@ -762,7 +757,7 @@ Increase at own risk.")
(mapcar
(lambda (arg) (format-spec arg spec))
(if (memq image-dired-thumbnail-storage
- '(standard standard-large))
+ image-dired--thumbnail-standard-sizes)
image-dired-cmd-create-standard-thumbnail-options
image-dired-cmd-create-thumbnail-options))))
@@ -771,6 +766,12 @@ Increase at own risk.")
;; Trigger next in queue once a thumbnail has been created
(cl-decf image-dired-queue-active-jobs)
(image-dired-thumb-queue-run)
+ (when (= image-dired-queue-active-jobs 0)
+ (image-dired-debug-message
+ (format-time-string
+ "Generated thumbnails in %s.%3N seconds"
+ (time-subtract nil
+ image-dired--generate-thumbs-start))))
(if (not (and (eq (process-status process) 'exit)
(zerop (process-exit-status process))))
(message "Thumb could not be created for %s: %s"
@@ -781,7 +782,7 @@ Increase at own risk.")
;; PNG thumbnail has been created since we are
;; following the XDG thumbnail spec, so try to optimize
(when (memq image-dired-thumbnail-storage
- '(standard standard-large))
+ image-dired--thumbnail-standard-sizes)
(cond
((and image-dired-cmd-pngnq-program
(executable-find image-dired-cmd-pngnq-program))
@@ -895,7 +896,7 @@ Otherwise, delete overlays."
(interactive)
(setq image-dired-append-when-browsing
(not image-dired-append-when-browsing))
- (message "Append browsing %s."
+ (message "Append browsing %s"
(if image-dired-append-when-browsing
"on"
"off")))
@@ -934,15 +935,6 @@ Otherwise, delete overlays."
(defvar image-dired-display-image-buffer "*image-dired-display-image*"
"Where larger versions of the images are display.")
-(defun image-dired-create-display-image-buffer ()
- "Create image display buffer and set `image-dired-display-image-mode'."
- (let ((buf (get-buffer-create image-dired-display-image-buffer)))
- (with-current-buffer buf
- (setq buffer-read-only t)
- (if (not (eq major-mode 'image-dired-display-image-mode))
- (image-dired-display-image-mode)))
- buf))
-
(defvar image-dired-saved-window-configuration nil
"Saved window configuration.")
@@ -966,7 +958,7 @@ The current window configuration is saved and can be restored by
calling `image-dired-restore-window-configuration'."
(interactive "DDirectory: \nP")
(let ((buf (image-dired-create-thumbnail-buffer))
- (buf2 (image-dired-create-display-image-buffer)))
+ (buf2 (get-buffer-create image-dired-display-image-buffer)))
(setq image-dired-saved-window-configuration
(current-window-configuration))
(dired dir)
@@ -985,7 +977,7 @@ calling `image-dired-restore-window-configuration'."
"Restore window configuration.
Restore any changes to the window configuration made by calling
`image-dired-dired-with-window-configuration'."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(if image-dired-saved-window-configuration
(set-window-configuration image-dired-saved-window-configuration)
(message "No saved window configuration")))
@@ -1025,6 +1017,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")
+ (setq image-dired--generate-thumbs-start (current-time))
(let ((buf (image-dired-create-thumbnail-buffer))
thumb-name files dired-buf)
(if arg
@@ -1048,30 +1041,38 @@ thumbnail buffer to be selected."
;;;###autoload
(defun image-dired-show-all-from-dir (dir)
- "Make a preview buffer for all images in DIR and display it.
-If the number of files in DIR matching `image-file-name-regexp'
-exceeds `image-dired-show-all-from-dir-max-files', a warning will be
-displayed."
- (interactive "DImage Dired: ")
+ "Make a thumbnail buffer for all images in DIR and display it.
+Any file matching `image-file-name-regexp' is considered an image
+file.
+
+If the number of image files in DIR exceeds
+`image-dired-show-all-from-dir-max-files', ask for confirmation
+before creating the thumbnail buffer. If that variable is nil,
+never ask for confirmation."
+ (interactive "DImage-Dired: ")
(dired dir)
(dired-mark-files-regexp (image-file-name-regexp))
- (let ((files (dired-get-marked-files)))
- (if (or (<= (length files) image-dired-show-all-from-dir-max-files)
- (and (> (length files) image-dired-show-all-from-dir-max-files)
- (y-or-n-p
- (format
- "Directory contains more than %d image files. Proceed? "
- image-dired-show-all-from-dir-max-files))))
- (progn
- (image-dired-display-thumbs)
- (pop-to-buffer image-dired-thumbnail-buffer))
- (message "Canceled."))))
+ (let ((files (dired-get-marked-files nil nil nil t)))
+ (cond ((and (null (cdr files)))
+ (message "No image files in directory"))
+ ((or (not image-dired-show-all-from-dir-max-files)
+ (<= (length (cdr files)) image-dired-show-all-from-dir-max-files)
+ (and (> (length (cdr files)) image-dired-show-all-from-dir-max-files)
+ (y-or-n-p
+ (format
+ "Directory contains more than %d image files. Proceed?"
+ image-dired-show-all-from-dir-max-files))))
+ (image-dired-display-thumbs)
+ (pop-to-buffer image-dired-thumbnail-buffer)
+ (setq default-directory dir)
+ (image-dired-unmark-all-marks))
+ (t (message "Image-Dired canceled")))))
;;;###autoload
(defalias 'image-dired 'image-dired-show-all-from-dir)
-;;;###autoload
-(define-obsolete-function-alias 'tumme 'image-dired "24.4")
+
+;;; Tags
(defun image-dired-sane-db-file ()
"Check if `image-dired-db-file' exists.
@@ -1091,6 +1092,8 @@ Signal error if there are problems creating it."
(file-exists-p image-dired-db-file))
(error "Could not create %s" image-dired-db-file)))
+(defvar image-dired-tag-history nil "Variable holding the tag history.")
+
(defun image-dired-write-tags (file-tags)
"Write file tags to database.
Write each file and tag in FILE-TAGS to the database.
@@ -1211,6 +1214,9 @@ With prefix argument ARG, remove tag from file at point."
(image-dired-update-property
'tags (image-dired-list-tags (image-dired-original-file-name))))))
+
+;;; Thumbnail mode (cont.)
+
(defun image-dired-original-file-name ()
"Get original file name for thumbnail or display image at point."
(get-text-property (point) 'original-file-name))
@@ -1254,7 +1260,7 @@ around in the thumbnail or dired buffer will find the matching
position in the other buffer."
(interactive)
(setq image-dired-track-movement (not image-dired-track-movement))
- (message "Tracking %s" (if image-dired-track-movement "on" "off")))
+ (message "Movement tracking %s" (if image-dired-track-movement "on" "off")))
(defun image-dired-track-thumbnail ()
"Track current Dired file's thumb in `image-dired-thumbnail-buffer'.
@@ -1276,7 +1282,7 @@ but the other way around."
(when found
(if (setq window (image-dired-thumbnail-window))
(set-window-point window (point)))
- (image-dired-display-thumb-properties))))))
+ (image-dired-update-header-line))))))
(defun image-dired-dired-next-line (&optional arg)
"Call `dired-next-line', then track thumbnail.
@@ -1296,51 +1302,59 @@ With prefix argument, move ARG lines."
(if image-dired-track-movement
(image-dired-track-thumbnail)))
-(defun image-dired-forward-image (&optional arg)
+(defun image-dired--display-thumb-properties-fun ()
+ (let ((old-buf (current-buffer))
+ (old-point (point)))
+ (lambda ()
+ (when (and (equal (current-buffer) old-buf)
+ (= (point) old-point))
+ (ignore-errors
+ (image-dired-update-header-line))))))
+
+(defun image-dired-forward-image (&optional arg wrap-around)
"Move to next image and display properties.
-Optional prefix ARG says how many images to move; default is one
-image."
+Optional prefix ARG says how many images to move; the default is
+one image. Negative means move backwards.
+On reaching end or beginning of buffer, stop and show a message.
+
+If optional argument WRAP-AROUND is non-nil, wrap around: if
+point is on the last image, move to the last one and vice versa."
(interactive "p")
- (let (pos (steps (or arg 1)))
- (dotimes (_ steps)
- (if (and (not (eobp))
+ (setq arg (or arg 1))
+ (let (pos)
+ (dotimes (_ (abs arg))
+ (if (and (not (if (> arg 0) (eobp) (bobp)))
(save-excursion
- (forward-char)
- (while (and (not (eobp))
+ (forward-char (if (> arg 0) 1 -1))
+ (while (and (not (if (> arg 0) (eobp) (bobp)))
(not (image-dired-image-at-point-p)))
- (forward-char))
+ (forward-char (if (> arg 0) 1 -1)))
(setq pos (point))
(image-dired-image-at-point-p)))
- (goto-char pos)
- (error "At last image"))))
+ (progn (goto-char pos)
+ (image-dired-update-header-line))
+ (if wrap-around
+ (progn (goto-char (if (> arg 0)
+ (point-min)
+ ;; There are two spaces after the last image.
+ (- (point-max) 2)))
+ (image-dired-update-header-line))
+ (message "At %s image" (if (> arg 0) "last" "first"))
+ (run-at-time 1 nil (image-dired--display-thumb-properties-fun))))))
(when image-dired-track-movement
- (image-dired-track-original-file))
- (image-dired-display-thumb-properties))
+ (image-dired-track-original-file)))
(defun image-dired-backward-image (&optional arg)
"Move to previous image and display properties.
-Optional prefix ARG says how many images to move; default is one
-image."
+Optional prefix ARG says how many images to move; the default is
+one image. Negative means move forward.
+On reaching end or beginning of buffer, stop and show a message."
(interactive "p")
- (let (pos (steps (or arg 1)))
- (dotimes (_ steps)
- (if (and (not (bobp))
- (save-excursion
- (backward-char)
- (while (and (not (bobp))
- (not (image-dired-image-at-point-p)))
- (backward-char))
- (setq pos (point))
- (image-dired-image-at-point-p)))
- (goto-char pos)
- (error "At first image"))))
- (when image-dired-track-movement
- (image-dired-track-original-file))
- (image-dired-display-thumb-properties))
+ (image-dired-forward-image (- (or arg 1))))
(defun image-dired-next-line ()
"Move to next line and display properties."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(let ((goal-column (current-column)))
(forward-line 1)
(move-to-column goal-column))
@@ -1349,12 +1363,12 @@ image."
(image-dired-backward-image))
(if image-dired-track-movement
(image-dired-track-original-file))
- (image-dired-display-thumb-properties))
+ (image-dired-update-header-line))
(defun image-dired-previous-line ()
"Move to previous line and display properties."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(let ((goal-column (current-column)))
(forward-line -1)
(move-to-column goal-column))
@@ -1366,7 +1380,29 @@ image."
(image-dired-backward-image))
(if image-dired-track-movement
(image-dired-track-original-file))
- (image-dired-display-thumb-properties))
+ (image-dired-update-header-line))
+
+(defun image-dired-beginning-of-buffer ()
+ "Move to the first image in the buffer and display properties."
+ (interactive nil image-dired-thumbnail-mode)
+ (goto-char (point-min))
+ (while (and (not (image-at-point-p))
+ (not (eobp)))
+ (forward-char 1))
+ (when image-dired-track-movement
+ (image-dired-track-original-file))
+ (image-dired-update-header-line))
+
+(defun image-dired-end-of-buffer ()
+ "Move to the last image in the buffer and display properties."
+ (interactive nil image-dired-thumbnail-mode)
+ (goto-char (point-max))
+ (while (and (not (image-at-point-p))
+ (not (bobp)))
+ (forward-char -1))
+ (when image-dired-track-movement
+ (image-dired-track-original-file))
+ (image-dired-update-header-line))
(defun image-dired-format-properties-string (buf file props comment)
"Format display properties.
@@ -1381,77 +1417,115 @@ comment."
(cons ?t (or props ""))
(cons ?c (or comment "")))))
-(defun image-dired-display-thumb-properties ()
- "Display thumbnail properties in the echo area."
- (if (not (eobp))
- (let ((file-name (file-name-nondirectory (image-dired-original-file-name)))
- (dired-buf (buffer-name (image-dired-associated-dired-buffer)))
- (props (mapconcat #'identity (get-text-property (point) 'tags) ", "))
- (comment (get-text-property (point) 'comment))
- (message-log-max nil))
- (if file-name
- (message "%s"
- (image-dired-format-properties-string
- dired-buf
- file-name
- props
- comment))))))
-
-(defun image-dired-dired-file-marked-p ()
- "Check whether file on current line is marked or not."
+(defun image-dired-update-header-line ()
+ "Update image information in the header line."
+ (when (and (not (eobp))
+ (memq major-mode '(image-dired-thumbnail-mode
+ image-dired-display-image-mode)))
+ (let ((file-name (file-name-nondirectory (image-dired-original-file-name)))
+ (dired-buf (buffer-name (image-dired-associated-dired-buffer)))
+ (props (mapconcat #'identity (get-text-property (point) 'tags) ", "))
+ (comment (get-text-property (point) 'comment))
+ (message-log-max nil))
+ (if file-name
+ (setq header-line-format
+ (image-dired-format-properties-string
+ dired-buf
+ file-name
+ props
+ comment))))))
+
+(defun image-dired-dired-file-marked-p (&optional marker)
+ "In Dired, return t if file on current line is marked.
+If optional argument MARKER is non-nil, it is a character to look
+for. The default is to look for `dired-marker-char'."
+ (setq marker (or marker dired-marker-char))
(save-excursion
(beginning-of-line)
- (looking-at-p dired-re-mark)))
-
-(defun image-dired-modify-mark-on-thumb-original-file (command)
- "Modify mark in Dired buffer.
-COMMAND is one of `mark' for marking file in Dired, `unmark' for
-unmarking file in Dired or `flag' for flagging file for delete in
-Dired."
- (let ((file-name (image-dired-original-file-name))
- (dired-buf (image-dired-associated-dired-buffer)))
- (if (not (and dired-buf file-name))
- (message "No image, or image with correct properties, at point.")
- (with-current-buffer dired-buf
- (message "%s" file-name)
- (when (dired-goto-file file-name)
- (cond ((eq command 'mark) (dired-mark 1))
- ((eq command 'unmark) (dired-unmark 1))
- ((eq command 'toggle)
- (if (image-dired-dired-file-marked-p)
- (dired-unmark 1)
- (dired-mark 1)))
- ((eq command 'flag) (dired-flag-file-deletion 1)))
- (image-dired-thumb-update-marks))))))
+ (and (looking-at dired-re-mark)
+ (= (aref (match-string 0) 0) marker))))
+
+(defun image-dired-dired-file-flagged-p ()
+ "In Dired, return t if file on current line is flagged for deletion."
+ (image-dired-dired-file-marked-p dired-del-marker))
+
+(defmacro image-dired--with-thumbnail-buffer (&rest body)
+ (declare (indent defun) (debug t))
+ `(if-let ((buf (get-buffer image-dired-thumbnail-buffer)))
+ (with-current-buffer buf
+ (if-let ((win (get-buffer-window buf)))
+ (with-selected-window win
+ ,@body)
+ ,@body))
+ (user-error "No such buffer: %s" image-dired-thumbnail-buffer)))
+
+(defmacro image-dired--on-file-in-dired-buffer (&rest body)
+ "Run BODY with point on file at point in Dired buffer.
+Should be called from commands in `image-dired-thumbnail-mode'."
+ (declare (indent defun) (debug t))
+ `(let ((file-name (image-dired-original-file-name))
+ (dired-buf (image-dired-associated-dired-buffer)))
+ (if (not (and dired-buf file-name))
+ (message "No image, or image with correct properties, at point.")
+ (with-current-buffer dired-buf
+ (when (dired-goto-file file-name)
+ ,@body
+ (image-dired-thumb-update-marks))))))
+
+(defmacro image-dired--do-mark-command (maybe-next &rest body)
+ "Helper macro for the mark, unmark and flag commands.
+Run BODY in Dired buffer.
+If optional argument MAYBE-NEXT is non-nil, show next image
+according to `image-dired-marking-shows-next'."
+ (declare (indent defun) (debug t))
+ `(image-dired--with-thumbnail-buffer
+ (image-dired--on-file-in-dired-buffer
+ ,@body)
+ ,(when maybe-next
+ '(if image-dired-marking-shows-next
+ (image-dired-display-next-thumbnail-original)
+ (image-dired-next-line)))))
(defun image-dired-mark-thumb-original-file ()
"Mark original image file in associated Dired buffer."
- (interactive)
- (image-dired-modify-mark-on-thumb-original-file 'mark)
- (image-dired-forward-image))
+ (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
+ (image-dired--do-mark-command t
+ (dired-mark 1)))
(defun image-dired-unmark-thumb-original-file ()
"Unmark original image file in associated Dired buffer."
- (interactive)
- (image-dired-modify-mark-on-thumb-original-file 'unmark)
- (image-dired-forward-image))
+ (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
+ (image-dired--do-mark-command t
+ (dired-unmark 1)))
(defun image-dired-flag-thumb-original-file ()
"Flag original image file for deletion in associated Dired buffer."
- (interactive)
- (image-dired-modify-mark-on-thumb-original-file 'flag)
- (image-dired-forward-image))
+ (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
+ (image-dired--do-mark-command t
+ (dired-flag-file-deletion 1)))
(defun image-dired-toggle-mark-thumb-original-file ()
"Toggle mark on original image file in associated Dired buffer."
- (interactive)
- (image-dired-modify-mark-on-thumb-original-file 'toggle))
+ (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
+ (image-dired--do-mark-command nil
+ (if (image-dired-dired-file-marked-p)
+ (dired-unmark 1)
+ (dired-mark 1))))
+
+(defun image-dired-unmark-all-marks ()
+ "Remove all marks from all files in associated Dired buffer.
+Also update the marks in the thumbnail buffer."
+ (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
+ (image-dired--do-mark-command nil
+ (dired-unmark-all-marks))
+ (image-dired--with-thumbnail-buffer
+ (image-dired-thumb-update-marks)))
(defun image-dired-jump-original-dired-buffer ()
"Jump to the Dired buffer associated with the current image file.
You probably want to use this together with
`image-dired-track-original-file'."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(let ((buf (image-dired-associated-dired-buffer))
window frame)
(setq window (image-dired-get-buffer-window buf))
@@ -1478,236 +1552,213 @@ You probably want to use this together with
(defvar image-dired-thumbnail-mode-line-up-map
(let ((map (make-sparse-keymap)))
;; map it to "g" so that the user can press it more quickly
- (define-key map "g" 'image-dired-line-up-dynamic)
+ (define-key map "g" #'image-dired-line-up-dynamic)
;; "f" for "fixed" number of thumbs per row
- (define-key map "f" 'image-dired-line-up)
+ (define-key map "f" #'image-dired-line-up)
;; "i" for "interactive"
- (define-key map "i" 'image-dired-line-up-interactive)
+ (define-key map "i" #'image-dired-line-up-interactive)
map)
"Keymap for line-up commands in `image-dired-thumbnail-mode'.")
(defvar image-dired-thumbnail-mode-tag-map
(let ((map (make-sparse-keymap)))
;; map it to "t" so that the user can press it more quickly
- (define-key map "t" 'image-dired-tag-thumbnail)
+ (define-key map "t" #'image-dired-tag-thumbnail)
;; "r" for "remove"
- (define-key map "r" 'image-dired-tag-thumbnail-remove)
+ (define-key map "r" #'image-dired-tag-thumbnail-remove)
map)
"Keymap for tag commands in `image-dired-thumbnail-mode'.")
(defvar image-dired-thumbnail-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map [right] 'image-dired-forward-image)
- (define-key map [left] 'image-dired-backward-image)
- (define-key map [up] 'image-dired-previous-line)
- (define-key map [down] 'image-dired-next-line)
- (define-key map "\C-f" 'image-dired-forward-image)
- (define-key map "\C-b" 'image-dired-backward-image)
- (define-key map "\C-p" 'image-dired-previous-line)
- (define-key map "\C-n" 'image-dired-next-line)
-
- (define-key map "d" 'image-dired-flag-thumb-original-file)
- (define-key map [delete] 'image-dired-flag-thumb-original-file)
- (define-key map "m" 'image-dired-mark-thumb-original-file)
- (define-key map "u" 'image-dired-unmark-thumb-original-file)
- (define-key map "." 'image-dired-track-original-file)
- (define-key map [tab] 'image-dired-jump-original-dired-buffer)
+ (define-key map [right] #'image-dired-forward-image)
+ (define-key map [left] #'image-dired-backward-image)
+ (define-key map [up] #'image-dired-previous-line)
+ (define-key map [down] #'image-dired-next-line)
+ (define-key map "\C-f" #'image-dired-forward-image)
+ (define-key map "\C-b" #'image-dired-backward-image)
+ (define-key map "\C-p" #'image-dired-previous-line)
+ (define-key map "\C-n" #'image-dired-next-line)
+
+ (define-key map "<" #'image-dired-beginning-of-buffer)
+ (define-key map ">" #'image-dired-end-of-buffer)
+ (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer)
+ (define-key map (kbd "M->") #'image-dired-end-of-buffer)
+
+ (define-key map "d" #'image-dired-flag-thumb-original-file)
+ (define-key map [delete] #'image-dired-flag-thumb-original-file)
+ (define-key map "m" #'image-dired-mark-thumb-original-file)
+ (define-key map "u" #'image-dired-unmark-thumb-original-file)
+ (define-key map "U" #'image-dired-unmark-all-marks)
+ (define-key map "." #'image-dired-track-original-file)
+ (define-key map [tab] #'image-dired-jump-original-dired-buffer)
;; add line-up map
(define-key map "g" image-dired-thumbnail-mode-line-up-map)
;; add tag map
(define-key map "t" image-dired-thumbnail-mode-tag-map)
- (define-key map "\C-m" 'image-dired-display-thumbnail-original-image)
- (define-key map [C-return] 'image-dired-thumbnail-display-external)
+ (define-key map "\C-m" #'image-dired-display-thumbnail-original-image)
+ (define-key map [C-return] #'image-dired-thumbnail-display-external)
- (define-key map "l" 'image-dired-rotate-thumbnail-left)
- (define-key map "r" 'image-dired-rotate-thumbnail-right)
- (define-key map "L" 'image-dired-rotate-original-left)
- (define-key map "R" 'image-dired-rotate-original-right)
+ (define-key map "L" #'image-dired-rotate-original-left)
+ (define-key map "R" #'image-dired-rotate-original-right)
- (define-key map "D" 'image-dired-thumbnail-set-image-description)
- (define-key map "\C-d" 'image-dired-delete-char)
- (define-key map " " 'image-dired-display-next-thumbnail-original)
- (define-key map (kbd "DEL") 'image-dired-display-previous-thumbnail-original)
- (define-key map "c" 'image-dired-comment-thumbnail)
+ (define-key map "D" #'image-dired-thumbnail-set-image-description)
+ (define-key map "S" #'image-dired-slideshow-start)
+ (define-key map "\C-d" #'image-dired-delete-char)
+ (define-key map " " #'image-dired-display-next-thumbnail-original)
+ (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original)
+ (define-key map "c" #'image-dired-comment-thumbnail)
;; Mouse
- (define-key map [mouse-2] 'image-dired-mouse-display-image)
- (define-key map [mouse-1] 'image-dired-mouse-select-thumbnail)
+ (define-key map [mouse-2] #'image-dired-mouse-display-image)
+ (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail)
+ (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail)
+ (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail)
+ (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail)
+ (define-key map [down-mouse-3] #'image-dired-mouse-select-thumbnail)
;; Seems I must first set C-down-mouse-1 to undefined, or else it
;; will trigger the buffer menu. If I try to instead bind
;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message
;; about C-mouse-1 not being defined afterwards. Annoying, but I
;; probably do not completely understand mouse events.
- (define-key map [C-down-mouse-1] 'undefined)
- (define-key map [C-mouse-1] 'image-dired-mouse-toggle-mark)
-
- ;; Menu
- (easy-menu-define nil map
- "Menu for `image-dired-thumbnail-mode'."
- '("Image-Dired"
- ["Display image" image-dired-display-thumbnail-original-image]
- ["Display in external viewer" image-dired-thumbnail-display-external]
-
- ["Mark original" image-dired-mark-thumb-original-file]
- ["Unmark original" image-dired-unmark-thumb-original-file]
- ["Flag original for deletion" image-dired-flag-thumb-original-file]
-
- ["Track original" image-dired-track-original-file]
- ["Jump to dired buffer" image-dired-jump-original-dired-buffer]
-
- ["Toggle movement tracking on/off" image-dired-toggle-movement-tracking]
-
- ["Rotate original right" image-dired-rotate-original-right]
- ["Rotate original left" image-dired-rotate-original-left]
- ["Rotate thumbnail right" image-dired-rotate-thumbnail-right]
- ["Rotate thumbnail left" image-dired-rotate-thumbnail-left]
-
- ["Line up thumbnails" image-dired-line-up]
- ["Dynamic line up" image-dired-line-up-dynamic]
- ["Refresh thumb" image-dired-refresh-thumb]
- ["Comment thumbnail" image-dired-comment-thumbnail]
- ["Tag current or marked thumbnails" image-dired-tag-thumbnail]
- ["Remove tag from current or marked thumbnails"
- image-dired-tag-thumbnail-remove]
- ["Delete marked images" image-dired-delete-marked]
- ["Delete thumbnail from buffer" image-dired-delete-char]
- ["Quit" quit-window]))
+ (define-key map [C-down-mouse-1] #'undefined)
+ (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark)
map)
"Keymap for `image-dired-thumbnail-mode'.")
+(easy-menu-define image-dired-thumbnail-mode-menu image-dired-thumbnail-mode-map
+ "Menu for `image-dired-thumbnail-mode'."
+ '("Image-Dired"
+ ["Display image" image-dired-display-thumbnail-original-image]
+ ["Display in external viewer" image-dired-thumbnail-display-external]
+ ["Jump to Dired buffer" image-dired-jump-original-dired-buffer]
+ "---"
+ ["Mark image" image-dired-mark-thumb-original-file]
+ ["Unmark image" image-dired-unmark-thumb-original-file]
+ ["Unmark all images" image-dired-unmark-all-marks]
+ ["Flag for deletion" image-dired-flag-thumb-original-file]
+ ["Delete marked images" image-dired-delete-marked]
+ "---"
+ ["Rotate original right" image-dired-rotate-original-right]
+ ["Rotate original left" image-dired-rotate-original-left]
+ "---"
+ ["Comment thumbnail" image-dired-comment-thumbnail]
+ ["Tag current or marked thumbnails" image-dired-tag-thumbnail]
+ ["Remove tag from current or marked thumbnails"
+ image-dired-tag-thumbnail-remove]
+ ["Start slideshow" image-dired-slideshow-start]
+ "---"
+ ("View Options"
+ ["Toggle movement tracking" image-dired-toggle-movement-tracking
+ :style toggle
+ :selected image-dired-track-movement]
+ "---"
+ ["Line up thumbnails" image-dired-line-up]
+ ["Dynamic line up" image-dired-line-up-dynamic]
+ ["Refresh thumb" image-dired-refresh-thumb])
+ ["Quit" quit-window]))
+
(defvar image-dired-display-image-mode-map
(let ((map (make-sparse-keymap)))
- ;; `image-mode-map' has bindings that do not make sense in image-dired
- ;; (set-keymap-parent map image-mode-map)
- (define-key map "f" 'image-dired-display-current-image-full)
- (define-key map "s" 'image-dired-display-current-image-sized)
- (define-key map "g" nil)
-
- ;; Useful bindings from `image-mode-map'
- (define-key map [remap forward-char] 'image-forward-hscroll)
- (define-key map [remap backward-char] 'image-backward-hscroll)
- (define-key map [remap right-char] 'image-forward-hscroll)
- (define-key map [remap left-char] 'image-backward-hscroll)
- (define-key map [remap previous-line] 'image-previous-line)
- (define-key map [remap next-line] 'image-next-line)
- (define-key map [remap scroll-up] 'image-scroll-up)
- (define-key map [remap scroll-down] 'image-scroll-down)
- (define-key map [remap scroll-up-command] 'image-scroll-up)
- (define-key map [remap scroll-down-command] 'image-scroll-down)
- (define-key map [remap scroll-left] 'image-scroll-left)
- (define-key map [remap scroll-right] 'image-scroll-right)
- (define-key map [remap move-beginning-of-line] 'image-bol)
- (define-key map [remap move-end-of-line] 'image-eol)
- (define-key map [remap beginning-of-buffer] 'image-bob)
- (define-key map [remap end-of-buffer] 'image-eob)
-
- (easy-menu-define nil map
- "Menu for `image-dired-display-image-mode-map'."
- '("Image-Dired"
- ["Display original, full size" image-dired-display-current-image-full]
- ["Display original, sized to fit" image-dired-display-current-image-sized]
- ["Quit" quit-window]))
+ (define-key map "S" #'image-dired-slideshow-start)
+ (define-key map (kbd "SPC") #'image-dired-display-next-thumbnail-original)
+ (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original)
+ (define-key map "n" #'image-dired-display-next-thumbnail-original)
+ (define-key map "p" #'image-dired-display-previous-thumbnail-original)
+ (define-key map "m" #'image-dired-mark-thumb-original-file)
+ (define-key map "d" #'image-dired-flag-thumb-original-file)
+ (define-key map "u" #'image-dired-unmark-thumb-original-file)
+ (define-key map "U" #'image-dired-unmark-all-marks)
+ ;; Disable keybindings from `image-mode-map' that doesn't make sense here.
+ (define-key map "o" nil) ; image-save
map)
"Keymap for `image-dired-display-image-mode'.")
-(defun image-dired-display-current-image-full ()
- "Display current image in full size."
- (interactive)
- (let ((file (image-dired-original-file-name)))
- (if file
- (progn
- (image-dired-display-image file t)
- (message "Full size image displayed"))
- (error "No original file name at point"))))
-
-(defun image-dired-display-current-image-sized ()
- "Display current image in sized to fit window dimensions."
- (interactive)
- (let ((file (image-dired-original-file-name)))
- (if file
- (progn
- (image-dired-display-image file)
- (message "Fitted image displayed"))
- (error "No original file name at point"))))
-
(define-derived-mode image-dired-thumbnail-mode
special-mode "image-dired-thumbnail"
"Browse and manipulate thumbnail images using Dired.
Use `image-dired-minor-mode' to get a nice setup."
+ :interactive nil
(buffer-disable-undo)
- (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t))
+ (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t)
+ (setq-local window-resize-pixelwise t)
+ (setq-local bookmark-make-record-function #'image-dired-bookmark-make-record)
+ ;; Use approximately as much vertical spacing as horizontal.
+ (setq-local line-spacing (frame-char-width)))
+
+
+;;; Display image mode
(define-derived-mode image-dired-display-image-mode
- special-mode "image-dired-image-display"
+ image-mode "image-dired-image-display"
"Mode for displaying and manipulating original image.
Resized or in full-size."
- (buffer-disable-undo)
- (image-mode-setup-winprops)
- (setq cursor-type nil)
- (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t))
+ :interactive nil
+ (add-hook 'file-name-at-point-functions #'image-dired-file-name-at-point nil t))
(defvar image-dired-minor-mode-map
(let ((map (make-sparse-keymap)))
;; (set-keymap-parent map dired-mode-map)
;; Hijack previous and next line movement. Let C-p and C-b be
;; though...
- (define-key map "p" 'image-dired-dired-previous-line)
- (define-key map "n" 'image-dired-dired-next-line)
- (define-key map [up] 'image-dired-dired-previous-line)
- (define-key map [down] 'image-dired-dired-next-line)
-
- (define-key map (kbd "C-S-n") 'image-dired-next-line-and-display)
- (define-key map (kbd "C-S-p") 'image-dired-previous-line-and-display)
- (define-key map (kbd "C-S-m") 'image-dired-mark-and-display-next)
-
- (define-key map "\C-td" 'image-dired-display-thumbs)
- (define-key map [tab] 'image-dired-jump-thumbnail-buffer)
- (define-key map "\C-ti" 'image-dired-dired-display-image)
- (define-key map "\C-tx" 'image-dired-dired-display-external)
- (define-key map "\C-ta" 'image-dired-display-thumbs-append)
- (define-key map "\C-t." 'image-dired-display-thumb)
- (define-key map "\C-tc" 'image-dired-dired-comment-files)
- (define-key map "\C-tf" 'image-dired-mark-tagged-files)
-
- ;; Menu for dired
- (easy-menu-define nil map
- "Menu for `image-dired-minor-mode'."
- '("Image-dired"
- ["Display thumb for next file" image-dired-next-line-and-display]
- ["Display thumb for previous file" image-dired-previous-line-and-display]
- ["Mark and display next" image-dired-mark-and-display-next]
-
- ["Create thumbnails for marked files" image-dired-create-thumbs]
-
- ["Display thumbnails append" image-dired-display-thumbs-append]
- ["Display this thumbnail" image-dired-display-thumb]
- ["Display image" image-dired-dired-display-image]
- ["Display in external viewer" image-dired-dired-display-external]
-
- ["Toggle display properties" image-dired-toggle-dired-display-properties]
- ["Toggle append browsing" image-dired-toggle-append-browsing]
- ["Toggle movement tracking" image-dired-toggle-movement-tracking]
-
- ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer]
- ["Mark tagged files" image-dired-mark-tagged-files]
- ["Comment files" image-dired-dired-comment-files]
- ["Copy with EXIF file name" image-dired-copy-with-exif-file-name]))
+ (define-key map "p" #'image-dired-dired-previous-line)
+ (define-key map "n" #'image-dired-dired-next-line)
+ (define-key map [up] #'image-dired-dired-previous-line)
+ (define-key map [down] #'image-dired-dired-next-line)
+
+ (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display)
+ (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display)
+ (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next)
+
+ (define-key map "\C-td" #'image-dired-display-thumbs)
+ (define-key map [tab] #'image-dired-jump-thumbnail-buffer)
+ (define-key map "\C-ti" #'image-dired-dired-display-image)
+ (define-key map "\C-tx" #'image-dired-dired-display-external)
+ (define-key map "\C-ta" #'image-dired-display-thumbs-append)
+ (define-key map "\C-t." #'image-dired-display-thumb)
+ (define-key map "\C-tc" #'image-dired-dired-comment-files)
+ (define-key map "\C-tf" #'image-dired-mark-tagged-files)
map)
"Keymap for `image-dired-minor-mode'.")
+(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map
+ "Menu for `image-dired-minor-mode'."
+ '("Image-dired"
+ ["Display thumb for next file" image-dired-next-line-and-display]
+ ["Display thumb for previous file" image-dired-previous-line-and-display]
+ ["Mark and display next" image-dired-mark-and-display-next]
+ "---"
+ ["Create thumbnails for marked files" image-dired-create-thumbs]
+ "---"
+ ["Display thumbnails append" image-dired-display-thumbs-append]
+ ["Display this thumbnail" image-dired-display-thumb]
+ ["Display image" image-dired-dired-display-image]
+ ["Display in external viewer" image-dired-dired-display-external]
+ "---"
+ ["Toggle display properties" image-dired-toggle-dired-display-properties
+ :style toggle
+ :selected image-dired-dired-disp-props]
+ ["Toggle append browsing" image-dired-toggle-append-browsing
+ :style toggle
+ :selected image-dired-append-when-browsing]
+ ["Toggle movement tracking" image-dired-toggle-movement-tracking
+ :style toggle
+ :selected image-dired-track-movement]
+ "---"
+ ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer]
+ ["Mark tagged files" image-dired-mark-tagged-files]
+ ["Comment files" image-dired-dired-comment-files]
+ ["Copy with EXIF file name" image-dired-copy-with-exif-file-name]))
+
;;;###autoload
(define-minor-mode image-dired-minor-mode
"Setup easy-to-use keybindings for the commands to be used in Dired mode.
Note that n, p and <down> and <up> will be hijacked and bound to
-`image-dired-dired-x-line'."
+`image-dired-dired-next-line' and `image-dired-dired-previous-line'."
:keymap image-dired-minor-mode-map)
-;;;###autoload
-(define-obsolete-function-alias 'image-dired-setup-dired-keybindings 'image-dired-minor-mode
- "26.1")
-
(declare-function clear-image-cache "image.c" (&optional filter))
(defun image-dired-create-thumbs (&optional arg)
@@ -1727,46 +1778,69 @@ With prefix argument ARG, create thumbnails even if they already exist
arg)
(image-dired-create-thumb curr-file thumb-name)))))
-(defvar image-dired-slideshow-timer nil
- "Slideshow timer.")
+
+;;; Slideshow
-(defvar image-dired-slideshow-count 0
- "Keeping track on number of images in slideshow.")
+(defcustom image-dired-slideshow-delay 5.0
+ "Seconds to wait before showing the next image in a slideshow.
+This is used by `image-dired-slideshow-start'."
+ :type 'float
+ :version "29.1")
-(defvar image-dired-slideshow-times 0
- "Number of pictures to display in slideshow.")
+(define-obsolete-variable-alias 'image-dired-slideshow-timer
+ 'image-dired--slideshow-timer "29.1")
+(defvar image-dired--slideshow-timer nil
+ "Slideshow timer.")
+
+(defvar image-dired--slideshow-initial nil)
(defun image-dired-slideshow-step ()
- "Step to next file, if `image-dired-slideshow-times' has not been reached."
- (if (< image-dired-slideshow-count image-dired-slideshow-times)
- (progn
- (message "%s" (1+ image-dired-slideshow-count))
- (setq image-dired-slideshow-count (1+ image-dired-slideshow-count))
- (image-dired-next-line-and-display))
+ "Step to next image in a slideshow."
+ (if-let ((buf (get-buffer image-dired-thumbnail-buffer)))
+ (with-current-buffer buf
+ (image-dired-display-next-thumbnail-original))
(image-dired-slideshow-stop)))
-(defun image-dired-slideshow-start ()
- "Start slideshow.
-Ask user for number of images to show and the delay in between."
- (interactive)
- (setq image-dired-slideshow-count 0)
- (setq image-dired-slideshow-times (string-to-number (read-string "How many: ")))
- (let ((repeat (string-to-number
- (read-string
- "Delay, in seconds. Decimals are accepted : " "1"))))
- (setq image-dired-slideshow-timer
+(defun image-dired-slideshow-start (&optional arg)
+ "Start a slideshow, waiting `image-dired-slideshow-delay' between images.
+
+With prefix argument ARG, wait that many seconds before going to
+the next image.
+
+With a negative prefix argument, prompt user for the delay."
+ (interactive "P" image-dired-thumbnail-mode image-dired-display-image-mode)
+ (let ((delay (if (not arg)
+ image-dired-slideshow-delay
+ (if (> arg 0)
+ arg
+ (string-to-number
+ (let ((delay (number-to-string image-dired-slideshow-delay)))
+ (read-string
+ (format-prompt "Delay, in seconds. Decimals are accepted" delay))
+ delay))))))
+ (setq image-dired--slideshow-timer
(run-with-timer
- 0 repeat
- 'image-dired-slideshow-step))))
+ 0 delay
+ 'image-dired-slideshow-step))
+ (add-hook 'post-command-hook 'image-dired-slideshow-stop)
+ (setq image-dired--slideshow-initial t)
+ (message "Running slideshow; use any command to stop")))
(defun image-dired-slideshow-stop ()
"Cancel slideshow."
- (interactive)
- (cancel-timer image-dired-slideshow-timer))
+ ;; Make sure we don't immediately stop after
+ ;; `image-dired-slideshow-start'.
+ (unless image-dired--slideshow-initial
+ (remove-hook 'post-command-hook 'image-dired-slideshow-stop)
+ (cancel-timer image-dired--slideshow-timer))
+ (setq image-dired--slideshow-initial nil))
+
+
+;;; Thumbnail mode (cont. 3)
(defun image-dired-delete-char ()
"Remove current thumbnail from thumbnail buffer and line up."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(let ((inhibit-read-only t))
(delete-char 1)
(when (= (following-char) ?\s)
@@ -1799,18 +1873,26 @@ See also `image-dired-line-up-dynamic'."
(not (eobp)))
(delete-char 1)))
(goto-char (point-min))
- (let ((count 0))
+ (let ((seen 0)
+ (thumb-prev-pos 0)
+ (thumb-width-chars
+ (ceiling (/ (+ (* 2 image-dired-thumb-relief)
+ (* 2 image-dired-thumb-margin)
+ (image-dired-thumb-size 'width))
+ (float (frame-char-width))))))
(while (not (eobp))
(forward-char)
(if (= image-dired-thumbs-per-row 1)
(insert "\n")
- (insert " ")
- (setq count (1+ count))
- (when (and (= count (- image-dired-thumbs-per-row 1))
+ (cl-incf thumb-prev-pos thumb-width-chars)
+ (insert (propertize " " 'display `(space :align-to ,thumb-prev-pos)))
+ (cl-incf seen)
+ (when (and (= seen (- image-dired-thumbs-per-row 1))
(not (eobp)))
(forward-char)
(insert "\n")
- (setq count 0)))))
+ (setq seen 0)
+ (setq thumb-prev-pos 0)))))
(goto-char (point-min))))
(defun image-dired-line-up-dynamic ()
@@ -1860,11 +1942,6 @@ Ask user how many thumbnails should be displayed per row."
"Calculate WINDOW width in pixels."
(* (window-width window) (frame-char-width)))
-(defun image-dired-window-height-pixels (window)
- "Calculate WINDOW height in pixels."
- ;; Note: The mode-line consumes one line
- (* (- (window-height window) 1) (frame-char-height)))
-
(defun image-dired-display-window ()
"Return window where `image-dired-display-image-buffer' is visible."
(get-window-with-predicate
@@ -1890,59 +1967,24 @@ Ask user how many thumbnails should be displayed per row."
(equal (window-buffer window) buf))))
(error "No thumbnail image at point"))))
-(defun image-dired-display-window-width (window)
- "Return width, in pixels, of WINDOW."
- (- (image-dired-window-width-pixels window)
- image-dired-display-window-width-correction))
-
-(defun image-dired-display-window-height (window)
- "Return height, in pixels, of WINDOW."
- (- (image-dired-window-height-pixels window)
- image-dired-display-window-height-correction))
-
-(defun image-dired-display-image (file &optional original-size)
+(defun image-dired-display-image (file &optional _ignored)
"Display image FILE in image buffer.
-Use this when you want to display the image, semi sized, in a new
-window. The image is sized to fit the display window (using a
-temporary file, don't worry). Because of this, it will not be as
-quick as opening it directly, but on most modern systems it
-should feel snappy enough.
-
-If optional argument ORIGINAL-SIZE is non-nil, display image in its
-original size."
- (image-dired--check-executable-exists
- 'image-dired-cmd-create-temp-image-program)
- (let ((new-file (expand-file-name image-dired-temp-image-file))
- (window (image-dired-display-window))
- (image-type 'jpeg))
- (setq file (expand-file-name file))
- (if (not original-size)
- (let* ((spec
- (list
- (cons ?p image-dired-cmd-create-temp-image-program)
- (cons ?w (image-dired-display-window-width window))
- (cons ?h (image-dired-display-window-height window))
- (cons ?f file)
- (cons ?t new-file)))
- (ret
- (apply #'call-process
- image-dired-cmd-create-temp-image-program nil nil nil
- (mapcar
- (lambda (arg) (format-spec arg spec))
- image-dired-cmd-create-temp-image-options))))
- (when (not (zerop ret))
- (error "Could not resize image")))
- (setq image-type (image-type-from-file-name file))
- (copy-file file new-file t))
- (with-current-buffer (image-dired-create-display-image-buffer)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (clear-image-cache)
- (image-dired-insert-image image-dired-temp-image-file image-type 0 0)
- (goto-char (point-min))
- (set-window-vscroll window 0)
- (set-window-hscroll window 0)
- (image-dired-update-property 'original-file-name file)))))
+Use this when you want to display the image, in a new window.
+The window will use `image-dired-display-image-mode' which is
+based on `image-mode'."
+ (declare (advertised-calling-convention (file) "29.1"))
+ (setq file (expand-file-name file))
+ (when (not (file-exists-p file))
+ (error "No such file: %s" file))
+ (let ((buf (get-buffer image-dired-display-image-buffer))
+ (cur-win (selected-window)))
+ (when buf
+ (kill-buffer buf))
+ (when-let ((buf (find-file-other-window file)))
+ (display-buffer buf)
+ (rename-buffer image-dired-display-image-buffer)
+ (image-dired-display-image-mode)
+ (select-window cur-win))))
(defun image-dired-display-thumbnail-original-image (&optional arg)
"Display current thumbnail's original image in display buffer.
@@ -1956,8 +1998,6 @@ With prefix argument ARG, display image in its original size."
(message "No thumbnail at point")
(if (not file)
(message "No original file name found")
- (image-dired-create-display-image-buffer)
- (display-buffer image-dired-display-image-buffer)
(image-dired-display-image file arg))))))
@@ -1967,41 +2007,15 @@ With prefix argument ARG, display image in its original size."
See documentation for `image-dired-display-image' for more information.
With prefix argument ARG, display image in its original size."
(interactive "P")
- (image-dired-create-display-image-buffer)
- (display-buffer image-dired-display-image-buffer)
(image-dired-display-image (dired-get-filename) arg))
(defun image-dired-image-at-point-p ()
"Return non-nil if there is an `image-dired' thumbnail at point."
(get-text-property (point) 'image-dired-thumbnail))
-(defun image-dired-rotate-thumbnail (degrees)
- "Rotate thumbnail DEGREES degrees."
- (image-dired--check-executable-exists
- 'image-dired-cmd-rotate-thumbnail-program)
- (if (not (image-dired-image-at-point-p))
- (message "No thumbnail at point")
- (let* ((file (image-dired-thumb-name (image-dired-original-file-name)))
- (thumb (expand-file-name file))
- (spec (list (cons ?d degrees) (cons ?t thumb))))
- (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil
- (mapcar (lambda (arg) (format-spec arg spec))
- image-dired-cmd-rotate-thumbnail-options))
- (clear-image-cache thumb))))
-
-(defun image-dired-rotate-thumbnail-left ()
- "Rotate thumbnail left (counter clockwise) 90 degrees."
- (interactive)
- (image-dired-rotate-thumbnail "270"))
-
-(defun image-dired-rotate-thumbnail-right ()
- "Rotate thumbnail counter right (clockwise) 90 degrees."
- (interactive)
- (image-dired-rotate-thumbnail "90"))
-
(defun image-dired-refresh-thumb ()
"Force creation of new image for current thumbnail."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(let* ((file (image-dired-original-file-name))
(thumb (expand-file-name (image-dired-thumb-name file))))
(clear-image-cache (expand-file-name thumb))
@@ -2020,7 +2034,7 @@ With prefix argument ARG, display image in its original size."
(cons ?o (expand-file-name file))
(cons ?t image-dired-temp-rotate-image-file))))
(unless (eq 'jpeg (image-type file))
- (error "Only JPEG images can be rotated!"))
+ (user-error "Only JPEG images can be rotated"))
(if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program
nil nil nil
(mapcar (lambda (arg) (format-spec arg spec))
@@ -2054,6 +2068,9 @@ overwritten. This confirmation can be turned off using
(interactive)
(image-dired-rotate-original "90"))
+
+;;; EXIF support
+
(defun image-dired-get-exif-file-name (file)
"Use the image's EXIF information to return a unique file name.
The file name should be unique as long as you do not take more than
@@ -2068,8 +2085,8 @@ YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from
"%Y:%m:%d %H:%M:%S"
(file-attribute-modification-time
(file-attributes (expand-file-name file)))))
- (setq data (image-dired-get-exif-data (expand-file-name file)
- "DateTimeOriginal")))
+ (setq data (exif-field 'date-time (exif-parse-file
+ (expand-file-name file)))))
(while (string-match "[ :]" data)
(setq data (replace-match "_" nil nil data)))
(format "%s%s%s" data
@@ -2086,7 +2103,7 @@ default value at the prompt."
(if (not (image-dired-image-at-point-p))
(message "No thumbnail at point")
(let* ((file (image-dired-original-file-name))
- (old-value (image-dired-get-exif-data file "ImageDescription")))
+ (old-value (or (exif-field 'description (exif-parse-file file)) "")))
(if (eq 0
(image-dired-set-exif-data file "ImageDescription"
(read-string "Value of ImageDescription: "
@@ -2107,33 +2124,9 @@ default value at the prompt."
(mapcar (lambda (arg) (format-spec arg spec))
image-dired-cmd-write-exif-data-options))))
-(defun image-dired-get-exif-data (file tag-name)
- "From FILE, return EXIF tag TAG-NAME."
- (image-dired--check-executable-exists
- 'image-dired-cmd-read-exif-data-program)
- (let ((buf (get-buffer-create "*image-dired-get-exif-data*"))
- (spec (list (cons ?f file) (cons ?t tag-name)))
- tag-value)
- (with-current-buffer buf
- (delete-region (point-min) (point-max))
- (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program
- nil t nil
- (mapcar
- (lambda (arg) (format-spec arg spec))
- image-dired-cmd-read-exif-data-options))
- 0))
- (error "Could not get EXIF tag")
- (goto-char (point-min))
- ;; Clean buffer from newlines and carriage returns before
- ;; getting final info
- (while (search-forward-regexp "[\n\r]" nil t)
- (replace-match "" nil t))
- (setq tag-value (buffer-substring (point-min) (point-max)))))
- tag-value))
-
(defun image-dired-copy-with-exif-file-name ()
"Copy file with unique name to main image directory.
-Copy current or all marked files in dired to a new file in your
+Copy current or all marked files in Dired to a new file in your
main image directory, using a file name generated by
`image-dired-get-exif-file-name'. A typical usage for this if when
copying images from a digital camera into the image directory.
@@ -2158,17 +2151,24 @@ function. The result is a couple of new files in
(copy-file curr-file new-name))
files)))
-(defun image-dired-display-next-thumbnail-original ()
- "In thumbnail buffer, move to next thumbnail and display the image."
- (interactive)
- (image-dired-forward-image)
- (image-dired-display-thumbnail-original-image))
+;;; Thumbnail mode (cont.)
-(defun image-dired-display-previous-thumbnail-original ()
- "Move to previous thumbnail and display image."
- (interactive)
- (image-dired-backward-image)
- (image-dired-display-thumbnail-original-image))
+(defun image-dired-display-next-thumbnail-original (&optional arg)
+ "Move to the next image in the thumbnail buffer and display it.
+With prefix ARG, move that many thumbnails."
+ (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode)
+ (image-dired--with-thumbnail-buffer
+ (image-dired-forward-image arg t)
+ (image-dired-display-thumbnail-original-image)))
+
+(defun image-dired-display-previous-thumbnail-original (arg)
+ "Move to the previous image in the thumbnail buffer and display it.
+With prefix ARG, move that many thumbnails."
+ (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode)
+ (image-dired-display-next-thumbnail-original (- arg)))
+
+
+;;; Image Comments
(defun image-dired-write-comments (file-comments)
"Write file comments to database.
@@ -2233,7 +2233,7 @@ FILE-COMMENTS is an alist on the following form:
(comment (image-dired-read-comment file)))
(image-dired-write-comments (list (cons file comment)))
(image-dired-update-property 'comment comment))
- (image-dired-display-thumb-properties))
+ (image-dired-update-header-line))
(defun image-dired-read-comment (&optional file)
"Read comment for an image.
@@ -2296,6 +2296,10 @@ matching tag will be marked in the Dired buffer."
(dired-mark 1))))
(message "%d files with matching tag marked." hits)))
+
+
+;;; Mouse support
+
(defun image-dired-mouse-display-image (event)
"Use mouse EVENT, call `image-dired-display-image' to display image.
Track this in associated Dired buffer if `image-dired-track-movement' is
@@ -2303,12 +2307,12 @@ non-nil."
(interactive "e")
(mouse-set-point event)
(goto-char (posn-point (event-end event)))
+ (unless (image-at-point-p)
+ (image-dired-backward-image))
(let ((file (image-dired-original-file-name)))
(when file
(if image-dired-track-movement
(image-dired-track-original-file))
- (image-dired-create-display-image-buffer)
- (display-buffer image-dired-display-image-buffer)
(image-dired-display-image file))))
(defun image-dired-mouse-select-thumbnail (event)
@@ -2318,19 +2322,33 @@ non-nil."
(interactive "e")
(mouse-set-point event)
(goto-char (posn-point (event-end event)))
+ (unless (image-at-point-p)
+ (image-dired-backward-image))
(if image-dired-track-movement
(image-dired-track-original-file))
- (image-dired-display-thumb-properties))
+ (image-dired-update-header-line))
+
+
+
+;;; Dired marks and tags
-(defun image-dired-thumb-file-marked-p ()
- "Check if file is marked in associated Dired buffer."
+(defun image-dired-thumb-file-marked-p (&optional flagged)
+ "Check if file is marked in associated Dired buffer.
+If optional argument FLAGGED is non-nil, check if file is flagged
+for deletion instead."
(let ((file-name (image-dired-original-file-name))
(dired-buf (image-dired-associated-dired-buffer)))
(when (and dired-buf file-name)
(with-current-buffer dired-buf
(save-excursion
(when (dired-goto-file file-name)
- (image-dired-dired-file-marked-p)))))))
+ (if flagged
+ (image-dired-dired-file-flagged-p)
+ (image-dired-dired-file-marked-p))))))))
+
+(defun image-dired-thumb-file-flagged-p ()
+ "Check if file is flagged for deletion in associated Dired buffer."
+ (image-dired-thumb-file-marked-p t))
(defun image-dired-delete-marked ()
"Delete current or marked thumbnails and associated images."
@@ -2351,11 +2369,14 @@ non-nil."
(let ((inhibit-read-only t))
(while (not (eobp))
(with-silent-modifications
- (if (image-dired-thumb-file-marked-p)
- (add-face-text-property (point) (1+ (point))
- 'image-dired-thumb-mark)
- (remove-text-properties (point) (1+ (point))
- '(face image-dired-thumb-mark))))
+ (cond ((image-dired-thumb-file-marked-p)
+ (add-face-text-property (point) (1+ (point))
+ 'image-dired-thumb-mark))
+ ((image-dired-thumb-file-flagged-p)
+ (add-face-text-property (point) (1+ (point))
+ 'image-dired-thumb-flagged))
+ (t (remove-text-properties (point) (1+ (point))
+ '(face image-dired-thumb-mark)))))
(forward-char)))))))
(defun image-dired-mouse-toggle-mark-1 ()
@@ -2402,6 +2423,53 @@ Track this in associated Dired buffer if
props
comment)))))
+
+
+;;; Gallery support
+
+;; TODO:
+;; * Support gallery creation when using per-directory thumbnail
+;; storage.
+;; * Enhanced gallery creation with basic CSS-support and pagination
+;; of tag pages with many pictures.
+
+(defgroup image-dired-gallery nil
+ "Image-Dired support for generating a HTML gallery."
+ :prefix "image-dired-"
+ :group 'image-dired
+ :version "29.1")
+
+(defcustom image-dired-gallery-dir
+ (expand-file-name ".image-dired_gallery" image-dired-dir)
+ "Directory to store generated gallery html pages.
+The name of this directory needs to be \"shared\" to the public
+so that it can access the index.html page that image-dired creates."
+ :type 'directory)
+
+(defcustom image-dired-gallery-image-root-url
+ "https://example.org/image-diredpics"
+ "URL where the full size images are to be found on your web server.
+Note that this URL has to be configured on your web server.
+Image-Dired expects to find pictures in this directory.
+This is used by `image-dired-gallery-generate'."
+ :type 'string
+ :version "29.1")
+
+(defcustom image-dired-gallery-thumb-image-root-url
+ "https://example.org/image-diredthumbs"
+ "URL where the thumbnail images are to be found on your web server.
+Note that URL path has to be configured on your web server.
+Image-Dired expects to find pictures in this directory.
+This is used by `image-dired-gallery-generate'."
+ :type 'string
+ :version "29.1")
+
+(defcustom image-dired-gallery-hidden-tags
+ (list "private" "hidden" "pending")
+ "List of \"hidden\" tags.
+Used by `image-dired-gallery-generate' to leave out \"hidden\" images."
+ :type '(repeat string))
+
(defvar image-dired-tag-file-list nil
"List to store tag-file structure.")
@@ -2411,19 +2479,8 @@ Track this in associated Dired buffer if
(defvar image-dired-file-comment-list nil
"List to store file comments.")
-(defun image-dired-add-to-tag-file-list (tag file)
- "Add relation between TAG and FILE."
- (let (curr)
- (if image-dired-tag-file-list
- (if (setq curr (assoc tag image-dired-tag-file-list))
- (if (not (member file curr))
- (setcdr curr (cons file (cdr curr))))
- (setcdr image-dired-tag-file-list
- (cons (list tag file) (cdr image-dired-tag-file-list))))
- (setq image-dired-tag-file-list (list (list tag file))))))
-
-(defun image-dired-add-to-tag-file-lists (tag file)
- "Helper function used from `image-dired-create-gallery-lists'.
+(defun image-dired--add-to-tag-file-lists (tag file)
+ "Helper function used from `image-dired--create-gallery-lists'.
Add TAG to FILE in one list and FILE to TAG in the other.
@@ -2457,8 +2514,8 @@ image-dired-tag-file-list:
(cons (list tag file) (cdr image-dired-tag-file-list))))
(setq image-dired-tag-file-list (list (list tag file))))))
-(defun image-dired-add-to-file-comment-list (file comment)
- "Helper function used from `image-dired-create-gallery-lists'.
+(defun image-dired--add-to-file-comment-list (file comment)
+ "Helper function used from `image-dired--create-gallery-lists'.
For FILE, add COMMENT to list.
@@ -2476,7 +2533,7 @@ image-dired-file-comment-list:
(cdr image-dired-file-comment-list))))
(setq image-dired-file-comment-list (list (cons file comment)))))
-(defun image-dired-create-gallery-lists ()
+(defun image-dired--create-gallery-lists ()
"Create temporary lists used by `image-dired-gallery-generate'."
(image-dired-sane-db-file)
(image-dired--with-db-file
@@ -2497,15 +2554,15 @@ image-dired-file-comment-list:
(setq file (car row-tags))
(dolist (x (cdr row-tags))
(if (not (string-match "^comment:\\(.*\\)" x))
- (image-dired-add-to-tag-file-lists x file)
- (image-dired-add-to-file-comment-list file (match-string 1 x)))))))
+ (image-dired--add-to-tag-file-lists x file)
+ (image-dired--add-to-file-comment-list file (match-string 1 x)))))))
;; Sort tag-file list
(setq image-dired-tag-file-list
(sort image-dired-tag-file-list
(lambda (x y)
(string< (car x) (car y))))))
-(defun image-dired-hidden-p (file)
+(defun image-dired--hidden-p (file)
"Return t if image FILE has a \"hidden\" tag."
(cl-loop for tag in (cdr (assoc file image-dired-file-tag-list))
if (member tag image-dired-gallery-hidden-tags) return t))
@@ -2519,7 +2576,7 @@ it easier to generate, then HTML-files are created in
(if (eq 'per-directory image-dired-thumbnail-storage)
(error "Currently, gallery generation is not supported \
when using per-directory thumbnail file storage"))
- (image-dired-create-gallery-lists)
+ (image-dired--create-gallery-lists)
(let ((tags image-dired-tag-file-list)
(index-file (format "%s/index.html" image-dired-gallery-dir))
count tag tag-file
@@ -2601,6 +2658,9 @@ when using per-directory thumbnail file storage"))
(insert " </body>\n")
(insert "</html>"))))
+
+;;; Tag support
+
(defvar image-dired-widget-list nil
"List to keep track of meta data in edit buffer.")
@@ -2702,6 +2762,285 @@ tags to their respective image file. Internal function used by
(dolist (tag tag-list)
(push (cons file tag) lst))))))
+
+;;; bookmark.el support
+
+(declare-function bookmark-make-record-default
+ "bookmark" (&optional no-file no-context posn))
+(declare-function bookmark-prop-get "bookmark" (bookmark prop))
+
+(defun image-dired-bookmark-name ()
+ "Create a default bookmark name for the current EWW buffer."
+ (file-name-nondirectory
+ (directory-file-name
+ (file-name-directory (image-dired-original-file-name)))))
+
+(defun image-dired-bookmark-make-record ()
+ "Create a bookmark for the current EWW buffer."
+ `(,(image-dired-bookmark-name)
+ ,@(bookmark-make-record-default t)
+ (location . ,(file-name-directory (image-dired-original-file-name)))
+ (image-dired-file . ,(file-name-nondirectory (image-dired-original-file-name)))
+ (handler . image-dired-bookmark-jump)))
+
+;;;###autoload
+(defun image-dired-bookmark-jump (bookmark)
+ "Default bookmark handler for Image-Dired buffers."
+ ;; User already cached thumbnails, so disable any checking.
+ (let ((image-dired-show-all-from-dir-max-files nil))
+ (image-dired (bookmark-prop-get bookmark 'location))
+ ;; TODO: Go to the bookmarked file, if it exists.
+ ;; (bookmark-prop-get bookmark 'image-dired-file)
+ (goto-char (point-min))))
+
+
+;;; Obsolete
+
+;;;###autoload
+(define-obsolete-function-alias 'tumme #'image-dired "24.4")
+
+;;;###autoload
+(define-obsolete-function-alias 'image-dired-setup-dired-keybindings
+ #'image-dired-minor-mode "26.1")
+
+(defcustom image-dired-temp-image-file
+ (expand-file-name ".image-dired_temp" image-dired-dir)
+ "Name of temporary image file used by various commands."
+ :type 'file)
+(make-obsolete-variable 'image-dired-temp-image-file
+ "no longer used." "29.1")
+
+(defcustom image-dired-cmd-create-temp-image-program
+ (if (executable-find "gm") "gm" "convert")
+ "Executable used to create temporary image.
+Used together with `image-dired-cmd-create-temp-image-options'."
+ :type 'file
+ :version "29.1")
+(make-obsolete-variable 'image-dired-cmd-create-temp-image-program
+ "no longer used." "29.1")
+
+(defcustom image-dired-cmd-create-temp-image-options
+ (let ((opts '("-size" "%wx%h" "%f[0]"
+ "-resize" "%wx%h>"
+ "-strip" "jpeg:%t")))
+ (if (executable-find "gm") (cons "convert" opts) opts))
+ "Options of command used to create temporary image for display window.
+Used together with `image-dired-cmd-create-temp-image-program',
+Available format specifiers are: %w and %h which are replaced by
+the calculated max size for width and height in the image display window,
+%f which is replaced by the file name of the original image and %t which
+is replaced by the file name of the temporary file."
+ :version "29.1"
+ :type '(repeat (string :tag "Argument")))
+(make-obsolete-variable 'image-dired-cmd-create-temp-image-options
+ "no longer used." "29.1")
+
+(defcustom image-dired-display-window-width-correction 1
+ "Number to be used to correct image display window width.
+Change if the default (1) does not work (i.e. if the image does not
+completely fit)."
+ :type 'integer)
+(make-obsolete-variable 'image-dired-display-window-width-correction
+ "no longer used." "29.1")
+
+(defcustom image-dired-display-window-height-correction 0
+ "Number to be used to correct image display window height.
+Change if the default (0) does not work (i.e. if the image does not
+completely fit)."
+ :type 'integer)
+(make-obsolete-variable 'image-dired-display-window-height-correction
+ "no longer used." "29.1")
+
+(defun image-dired-display-window-width (window)
+ "Return width, in pixels, of WINDOW."
+ (declare (obsolete nil "29.1"))
+ (- (image-dired-window-width-pixels window)
+ image-dired-display-window-width-correction))
+
+(defun image-dired-display-window-height (window)
+ "Return height, in pixels, of WINDOW."
+ (declare (obsolete nil "29.1"))
+ (- (image-dired-window-height-pixels window)
+ image-dired-display-window-height-correction))
+
+(defun image-dired-window-height-pixels (window)
+ "Calculate WINDOW height in pixels."
+ (declare (obsolete nil "29.1"))
+ ;; Note: The mode-line consumes one line
+ (* (- (window-height window) 1) (frame-char-height)))
+
+(defcustom image-dired-cmd-read-exif-data-program "exiftool"
+ "Program used to read EXIF data to image.
+Used together with `image-dired-cmd-read-exif-data-options'."
+ :type 'file)
+(make-obsolete-variable 'image-dired-cmd-read-exif-data-program
+ "use `exif-parse-file' and `exif-field' instead." "29.1")
+
+(defcustom image-dired-cmd-read-exif-data-options '("-s" "-s" "-s" "-%t" "%f")
+ "Arguments of command used to read EXIF data.
+Used with `image-dired-cmd-read-exif-data-program'.
+Available format specifiers are: %f which is replaced
+by the image file name and %t which is replaced by the tag name."
+ :version "26.1"
+ :type '(repeat (string :tag "Argument")))
+(make-obsolete-variable 'image-dired-cmd-read-exif-data-options
+ "use `exif-parse-file' and `exif-field' instead." "29.1")
+
+(defun image-dired-get-exif-data (file tag-name)
+ "From FILE, return EXIF tag TAG-NAME."
+ (declare (obsolete "use `exif-parse-file' and `exif-field' instead." "29.1"))
+ (image-dired--check-executable-exists
+ 'image-dired-cmd-read-exif-data-program)
+ (let ((buf (get-buffer-create "*image-dired-get-exif-data*"))
+ (spec (list (cons ?f file) (cons ?t tag-name)))
+ tag-value)
+ (with-current-buffer buf
+ (delete-region (point-min) (point-max))
+ (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program
+ nil t nil
+ (mapcar
+ (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-read-exif-data-options))
+ 0))
+ (error "Could not get EXIF tag")
+ (goto-char (point-min))
+ ;; Clean buffer from newlines and carriage returns before
+ ;; getting final info
+ (while (search-forward-regexp "[\n\r]" nil t)
+ (replace-match "" nil t))
+ (setq tag-value (buffer-substring (point-min) (point-max)))))
+ tag-value))
+
+(defcustom image-dired-cmd-rotate-thumbnail-program
+ (if (executable-find "gm") "gm" "mogrify")
+ "Executable used to rotate thumbnail.
+Used together with `image-dired-cmd-rotate-thumbnail-options'."
+ :type 'file
+ :version "29.1")
+(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-program nil "29.1")
+
+(defcustom image-dired-cmd-rotate-thumbnail-options
+ (let ((opts '("-rotate" "%d" "%t")))
+ (if (executable-find "gm") (cons "mogrify" opts) opts))
+ "Arguments of command used to rotate thumbnail image.
+Used with `image-dired-cmd-rotate-thumbnail-program'.
+Available format specifiers are: %d which is replaced by the
+number of (positive) degrees to rotate the image, normally 90 or 270
+\(for 90 degrees right and left), %t which is replaced by the file name
+of the thumbnail file."
+ :version "29.1"
+ :type '(repeat (string :tag "Argument")))
+(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-options nil "29.1")
+
+(defun image-dired-rotate-thumbnail (degrees)
+ "Rotate thumbnail DEGREES degrees."
+ (declare (obsolete image-dired-refresh-thumb "29.1"))
+ (image-dired--check-executable-exists
+ 'image-dired-cmd-rotate-thumbnail-program)
+ (if (not (image-dired-image-at-point-p))
+ (message "No thumbnail at point")
+ (let* ((file (image-dired-thumb-name (image-dired-original-file-name)))
+ (thumb (expand-file-name file))
+ (spec (list (cons ?d degrees) (cons ?t thumb))))
+ (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil
+ (mapcar (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-rotate-thumbnail-options))
+ (clear-image-cache thumb))))
+
+(defun image-dired-rotate-thumbnail-left ()
+ "Rotate thumbnail left (counter clockwise) 90 degrees."
+ (declare (obsolete image-dired-refresh-thumb "29.1"))
+ (interactive)
+ (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail))
+ (image-dired-rotate-thumbnail "270")))
+
+(defun image-dired-rotate-thumbnail-right ()
+ "Rotate thumbnail counter right (clockwise) 90 degrees."
+ (declare (obsolete image-dired-refresh-thumb "29.1"))
+ (interactive)
+ (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail))
+ (image-dired-rotate-thumbnail "90")))
+
+(defun image-dired-modify-mark-on-thumb-original-file (command)
+ "Modify mark in Dired buffer.
+COMMAND is one of `mark' for marking file in Dired, `unmark' for
+unmarking file in Dired or `flag' for flagging file for delete in
+Dired."
+ (declare (obsolete image-dired--on-file-in-dired-buffer "29.1"))
+ (let ((file-name (image-dired-original-file-name))
+ (dired-buf (image-dired-associated-dired-buffer)))
+ (if (not (and dired-buf file-name))
+ (message "No image, or image with correct properties, at point.")
+ (with-current-buffer dired-buf
+ (message "%s" file-name)
+ (when (dired-goto-file file-name)
+ (cond ((eq command 'mark) (dired-mark 1))
+ ((eq command 'unmark) (dired-unmark 1))
+ ((eq command 'toggle)
+ (if (image-dired-dired-file-marked-p)
+ (dired-unmark 1)
+ (dired-mark 1)))
+ ((eq command 'flag) (dired-flag-file-deletion 1)))
+ (image-dired-thumb-update-marks))))))
+
+(defun image-dired-display-current-image-full ()
+ "Display current image in full size."
+ (declare (obsolete image-transform-original "29.1"))
+ (interactive nil image-dired-thumbnail-mode)
+ (let ((file (image-dired-original-file-name)))
+ (if file
+ (progn
+ (image-dired-display-image file)
+ (with-current-buffer image-dired-display-image-buffer
+ (image-transform-original)))
+ (error "No original file name at point"))))
+
+(defun image-dired-display-current-image-sized ()
+ "Display current image in sized to fit window dimensions."
+ (declare (obsolete image-mode-fit-frame "29.1"))
+ (interactive nil image-dired-thumbnail-mode)
+ (let ((file (image-dired-original-file-name)))
+ (if file
+ (progn
+ (image-dired-display-image file))
+ (error "No original file name at point"))))
+
+(defun image-dired-add-to-tag-file-list (tag file)
+ "Add relation between TAG and FILE."
+ (declare (obsolete nil "29.1"))
+ (let (curr)
+ (if image-dired-tag-file-list
+ (if (setq curr (assoc tag image-dired-tag-file-list))
+ (if (not (member file curr))
+ (setcdr curr (cons file (cdr curr))))
+ (setcdr image-dired-tag-file-list
+ (cons (list tag file) (cdr image-dired-tag-file-list))))
+ (setq image-dired-tag-file-list (list (list tag file))))))
+
+(defun image-dired-display-thumb-properties ()
+ "Display thumbnail properties in the echo area."
+ (declare (obsolete image-dired-update-header-line "29.1"))
+ (image-dired-update-header-line))
+
+(defvar image-dired-slideshow-count 0
+ "Keeping track on number of images in slideshow.")
+(make-obsolete-variable 'image-dired-slideshow-count "no longer used." "29.1")
+
+(defvar image-dired-slideshow-times 0
+ "Number of pictures to display in slideshow.")
+(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1")
+
+(define-obsolete-function-alias 'image-dired-create-display-image-buffer
+ #'ignore "29.1")
+(define-obsolete-function-alias 'image-dired-create-gallery-lists
+ #'image-dired--create-gallery-lists "29.1")
+(define-obsolete-function-alias 'image-dired-add-to-file-comment-list
+ #'image-dired--add-to-file-comment-list "29.1")
+(define-obsolete-function-alias 'image-dired-add-to-tag-file-lists
+ #'image-dired--add-to-tag-file-lists "29.1")
+(define-obsolete-function-alias 'image-dired-hidden-p
+ #'image-dired--hidden-p "29.1")
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;; TEST-SECTION ;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -2733,23 +3072,6 @@ tags to their respective image file. Internal function used by
;; (setq dirsize (- dirsize (car (cdar files))))
;; (setq files (cdr files)))))
-;;;;;;;;;;;;;;;;;;;;;;,
-
-;; (defun dired-speedbar-buttons (dired-buffer)
-;; (when (and (boundp 'image-dired-use-speedbar)
-;; image-dired-use-speedbar)
-;; (let ((filename (with-current-buffer dired-buffer
-;; (dired-get-filename))))
-;; (when (and (not (string-equal filename (buffer-string)))
-;; (string-match (image-file-name-regexp) filename))
-;; (erase-buffer)
-;; (insert (propertize
-;; filename
-;; 'display
-;; (image-dired-get-thumbnail-image filename)))))))
-
-;; (setq image-dired-use-speedbar t)
-
(provide 'image-dired)
;;; image-dired.el ends here
diff --git a/lisp/image-file.el b/lisp/image-file.el
index fbc9eaaf94e..6df43f737dd 100644
--- a/lisp/image-file.el
+++ b/lisp/image-file.el
@@ -37,7 +37,7 @@
;;;###autoload
(defcustom image-file-name-extensions
- (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg"))
+ (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg" "webp"))
"A list of image-file filename extensions.
Filenames having one of these extensions are considered image files,
in addition to those matching `image-file-name-regexps'.
diff --git a/lisp/image-mode.el b/lisp/image-mode.el
index 4a326cdc693..6ff7859c835 100644
--- a/lisp/image-mode.el
+++ b/lisp/image-mode.el
@@ -58,16 +58,25 @@ It is called with one argument, the initial WINPROPS.")
"Non-nil to resize the image upon first display.
Its value should be one of the following:
- nil, meaning no resizing.
- - t, meaning to fit the image to the window height and width.
- - `fit-height', meaning to fit the image to the window height.
- - `fit-width', meaning to fit the image to the window width.
- - A number, which is a scale factor (the default size is 1)."
+ - t, meaning to scale the image down to fit in the window.
+ - `fit-window', meaning to fit the image to the window.
+ - A number, which is a scale factor (the default size is 1).
+
+Resizing will always preserve the aspect ratio of the image."
:type '(choice (const :tag "No resizing" nil)
- (other :tag "Fit height and width" t)
- (const :tag "Fit height" fit-height)
- (const :tag "Fit width" fit-width)
+ (const :tag "Fit to window" fit-window)
+ (other :tag "Scale down to fit window" t)
(number :tag "Scale factor" 1))
- :version "27.1"
+ :version "29.1"
+ :group 'image)
+
+(defcustom image-auto-resize-max-scale-percent nil
+ "Max size (in percent) to scale up to when `image-auto-resize' is `fit-window'.
+Can be either a number larger than 100, or nil, which means no
+max size."
+ :type '(choice (const :tag "No max" nil)
+ natnum)
+ :version "29.1"
:group 'image)
(defcustom image-auto-resize-on-window-resize 1
@@ -82,12 +91,18 @@ resizing according to the value specified in `image-auto-resize'."
(defvar-local image-transform-resize nil
"The image resize operation.
+Non-nil to resize the image upon first display.
Its value should be one of the following:
- nil, meaning no resizing.
- - t, meaning to fit the image to the window height and width.
+ - t, meaning to scale the image down to fit in the window.
+ - `fit-window', meaning to fit the image to the window.
+ - A number, which is a scale factor (the default size is 1).
+
+There is also support for these values, obsolete since Emacs 29.1:
- `fit-height', meaning to fit the image to the window height.
- `fit-width', meaning to fit the image to the window width.
- - A number, which is a scale factor (the default size is 1).")
+
+Resizing will always preserve the aspect ratio of the image.")
(defvar-local image-transform-scale 1.0
"The scale factor of the image being displayed.")
@@ -440,6 +455,15 @@ call."
;;; Image Mode setup
+(defcustom image-text-based-formats '(svg xpm)
+ "List of image formats that use a plain text format.
+For such formats, display a message that explains how to edit the
+image as text, when opening such images in `image-mode'."
+ :type '(choice (const :tag "Disable completely" nil)
+ (repeat :tag "List of formats" sexp))
+ :version "29.1"
+ :group 'image)
+
(defvar-local image-type nil
"The image type for the current Image mode buffer.")
@@ -455,8 +479,9 @@ call."
;; Transformation keys
(define-key map "sf" 'image-mode-fit-frame)
+ (define-key map "sw" 'image-transform-fit-to-window)
(define-key map "sh" 'image-transform-fit-to-height)
- (define-key map "sw" 'image-transform-fit-to-width)
+ (define-key map "si" 'image-transform-fit-to-width)
(define-key map "sb" 'image-transform-fit-both)
(define-key map "ss" 'image-transform-set-scale)
(define-key map "sr" 'image-transform-set-rotation)
@@ -511,12 +536,10 @@ call."
"--"
["Fit Frame to Image" image-mode-fit-frame :active t
:help "Resize frame to match image"]
- ["Fit Image to Window (Best Fit)" image-transform-fit-both
- :help "Resize image to match the window height and width"]
- ["Fit to Window Height" image-transform-fit-to-height
- :help "Resize image to match the window height"]
- ["Fit to Window Width" image-transform-fit-to-width
- :help "Resize image to match the window width"]
+ ["Fit Image to Window" image-transform-fit-to-window
+ :help "Resize image to match the window height and width"]
+ ["Fit Image to Window (Scale down only)" image-transform-fit-both
+ :help "Scale image down to match the window height and width"]
["Zoom In" image-increase-size
:help "Enlarge the image"]
["Zoom Out" image-decrease-size
@@ -605,8 +628,9 @@ call."
;;;###autoload
(defun image-mode ()
"Major mode for image files.
-You can use \\<image-mode-map>\\[image-toggle-display] or \\<image-mode-map>\\[image-toggle-hex-display]
-to toggle between display as an image and display as text or hex.
+You can use \\<image-mode-map>\\[image-toggle-display] or \
+\\[image-toggle-hex-display] to toggle between display
+as an image and display as text or hex.
Key bindings:
\\{image-mode-map}"
@@ -678,12 +702,10 @@ Key bindings:
(run-mode-hooks 'image-mode-hook)
(let ((image (image-get-display-property))
- (msg1 (substitute-command-keys
- "Type \\[image-toggle-display] or \\[image-toggle-hex-display] to view the image as "))
- animated)
+ msg animated)
(cond
((null image)
- (message "%s" (concat msg1 "an image.")))
+ (setq msg "an image"))
((setq animated (image-multi-frame-p image))
(setq image-multi-frame t
mode-line-process
@@ -701,10 +723,13 @@ Key bindings:
keymap
(down-mouse-1 . image-next-frame)
(down-mouse-3 . image-previous-frame)))))))
- (message "%s"
- (concat msg1 "text. This image has multiple frames.")))
+ (setq msg "text. This image has multiple frames"))
(t
- (message "%s" (concat msg1 "text or hex."))))))
+ (setq msg "text")))
+ (when (memq (plist-get (cdr image) :type) image-text-based-formats)
+ (message (substitute-command-keys
+ "Type \\[image-toggle-display] to view the image as %s")
+ msg))))
;;;###autoload
(define-minor-mode image-minor-mode
@@ -751,11 +776,11 @@ on these modes."
(image-mode-to-text)
;; Turn on hexl-mode
(hexl-mode)
- (message "%s" (concat
- (substitute-command-keys
- "Type \\[image-toggle-hex-display] or \\[image-toggle-display] to view the image as ")
- (if (image-get-display-property)
- "hex" "an image or text") ".")))
+ (message (substitute-command-keys
+ "Type \\[image-toggle-hex-display] or \
+\\[image-toggle-display] to view the image as %s")
+ (if (image-get-display-property)
+ "hex" "an image or text")))
(defun image-mode-as-text ()
"Set a non-image mode as major mode in combination with image minor mode.
@@ -771,11 +796,10 @@ See commands `image-mode' and `image-minor-mode' for more information
on these modes."
(interactive)
(image-mode-to-text)
- (message "%s" (concat
- (substitute-command-keys
- "Type \\[image-toggle-display] or \\[image-toggle-hex-display] to view the image as ")
- (if (image-get-display-property)
- "text" "an image or hex") ".")))
+ (message (substitute-command-keys
+ "Type \\[image-toggle-display] to view the image as %s")
+ (if (image-get-display-property)
+ "text" "an image")))
(defun image-toggle-display-text ()
"Show the image file as text.
@@ -803,6 +827,21 @@ Remove text properties that display the image."
(defvar tar-superior-buffer)
(declare-function image-flush "image.c" (spec &optional frame))
+(defun image--scale-within-limits-p (image)
+ "Return t if `fit-window' will scale image within the customized limits.
+The limits are given by the user option
+`image-auto-resize-max-scale-percent'."
+ (or (not image-auto-resize-max-scale-percent)
+ (let ((scale (/ image-auto-resize-max-scale-percent 100))
+ (mw (plist-get (cdr image) :max-width))
+ (mh (plist-get (cdr image) :max-height))
+ ;; Note: `image-size' looks up and thus caches the
+ ;; untransformed image. There's no easy way to
+ ;; prevent that.
+ (size (image-size image t)))
+ (or (<= mw (* (car size) scale))
+ (<= mh (* (cdr size) scale))))))
+
(defun image-toggle-display-image ()
"Show the image of the image file.
Turn the image data into a real image, but only if the whole file
@@ -837,7 +876,8 @@ was inserted."
filename))
;; If we have a `fit-width' or a `fit-height', don't limit
;; the size of the image to the window size.
- (edges (when (eq image-transform-resize t)
+ (edges (when (or (eq image-transform-resize t)
+ (eq image-transform-resize 'fit-window))
(window-inside-pixel-edges (get-buffer-window))))
(max-width (when edges
(- (nth 2 edges) (nth 0 edges))))
@@ -884,6 +924,14 @@ was inserted."
;; Type hint.
:format (and filename data-p))))
+ ;; Handle `fit-window'.
+ (when (and (eq image-transform-resize 'fit-window)
+ (image--scale-within-limits-p image))
+ (setq image
+ (cons (car image)
+ (plist-put (cdr image) :width
+ (plist-get (cdr image) :max-width)))))
+
;; Discard any stale image data before looking it up again.
(image-flush image)
(setq image (append image (image-transform-properties image)))
@@ -1494,21 +1542,29 @@ return value is suitable for appending to an image spec."
(defun image-transform-fit-to-height ()
"Fit the current image to the height of the current window."
(interactive)
+ (declare (obsolete nil "29.1"))
(setq image-transform-resize 'fit-height)
(image-toggle-display-image))
(defun image-transform-fit-to-width ()
"Fit the current image to the width of the current window."
+ (declare (obsolete nil "29.1"))
(interactive)
(setq image-transform-resize 'fit-width)
(image-toggle-display-image))
(defun image-transform-fit-both ()
- "Fit the current image both to the height and width of the current window."
+ "Scale the current image down to fit in the current window."
(interactive)
(setq image-transform-resize t)
(image-toggle-display-image))
+(defun image-transform-fit-to-window ()
+ "Fit the current image to the height and width of the current window."
+ (interactive)
+ (setq image-transform-resize 'fit-window)
+ (image-toggle-display-image))
+
(defun image-transform-set-rotation (rotation)
"Prompt for an angle ROTATION, and rotate the image by that amount.
ROTATION should be in degrees."
diff --git a/lisp/image.el b/lisp/image.el
index 6e1dbbdf5cd..cedefc038f0 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -27,6 +27,8 @@
(defgroup image ()
"Image support."
+ :prefix "image-"
+ :link '(info-link "(emacs) Image Mode")
:group 'multimedia)
(declare-function image-flush "image.c" (spec &optional frame))
@@ -48,6 +50,7 @@ static \\(unsigned \\)?char \\1_bits" . xbm)
("\\`\\(?:MM\0\\*\\|II\\*\0\\)" . tiff)
("\\`[\t\n\r ]*%!PS" . postscript)
("\\`\xff\xd8" . jpeg) ; used to be (image-jpeg-p . jpeg)
+ ("\\`RIFF....WEBPVP8" . webp)
(,(let* ((incomment-re "\\(?:[^-]\\|-[^-]\\)")
(comment-re (concat "\\(?:!--" incomment-re "*-->[ \t\r\n]*<\\)")))
(concat "\\(?:<\\?xml[ \t\r\n]+[^>]*>\\)?[ \t\r\n]*<"
@@ -67,6 +70,7 @@ a non-nil value, TYPE is the image's type.")
'(("\\.png\\'" . png)
("\\.gif\\'" . gif)
("\\.jpe?g\\'" . jpeg)
+ ("\\.webp\\'" . webp)
("\\.bmp\\'" . bmp)
("\\.xpm\\'" . xpm)
("\\.pbm\\'" . pbm)
@@ -92,6 +96,7 @@ be of image type IMAGE-TYPE.")
(jpeg . maybe)
(tiff . maybe)
(svg . maybe)
+ (webp . maybe)
(postscript . nil))
"Alist of (IMAGE-TYPE . AUTODETECT) pairs used to auto-detect image files.
\(See `image-type-auto-detected-p').
@@ -556,7 +561,12 @@ If VALUE is nil, PROPERTY is removed from IMAGE."
(declare (gv-setter image--set-property))
(plist-get (cdr image) property))
-(defun image-compute-scaling-factor (scaling)
+(defun image-compute-scaling-factor (&optional scaling)
+ "Compute the scaling factor based on SCALING.
+If a number, use that. If it's `auto', compute the factor.
+If nil, use the `image-scaling-factor' variable."
+ (unless scaling
+ (setq scaling image-scaling-factor))
(cond
((numberp scaling) scaling)
((eq scaling 'auto)
@@ -600,7 +610,7 @@ means display it in the right marginal area."
;;;###autoload
-(defun insert-image (image &optional string area slice)
+(defun insert-image (image &optional string area slice inhibit-isearch)
"Insert IMAGE into current buffer at point.
IMAGE is displayed by inserting STRING into the current buffer
with a `display' property whose value is the image.
@@ -617,7 +627,11 @@ SLICE specifies slice of IMAGE to insert. SLICE nil or omitted
means insert whole image. SLICE is a list (X Y WIDTH HEIGHT)
specifying the X and Y positions and WIDTH and HEIGHT of image area
to insert. A float value 0.0 - 1.0 means relative to the width or
-height of the image; integer values are taken as pixel values."
+height of the image; integer values are taken as pixel values.
+
+Normally `isearch' is able to search for STRING in the buffer
+even if it's hidden behind a displayed image. If INHIBIT-ISEARCH
+is non-nil, this is inhibited."
;; Use a space as least likely to cause trouble when it's a hidden
;; character in the buffer.
(unless string (setq string " "))
@@ -641,6 +655,7 @@ height of the image; integer values are taken as pixel values."
(list (cons 'slice slice) image)
image)
rear-nonsticky t
+ inhibit-isearch ,inhibit-isearch
keymap ,image-map))))
@@ -791,7 +806,7 @@ Example:
(defimage test-image ((:type xpm :file \"~/test1.xpm\")
(:type xbm :file \"~/test1.xbm\")))"
- (declare (doc-string 3))
+ (declare (doc-string 3) (indent defun))
`(defvar ,symbol (find-image ',specs) ,doc))
@@ -823,15 +838,18 @@ in which case you might want to use `image-default-frame-delay'."
(make-obsolete 'image-animated-p 'image-multi-frame-p "24.4")
-;; "Destructively"?
-(defun image-animate (image &optional index limit)
+(defun image-animate (image &optional index limit position)
"Start animating IMAGE.
Animation occurs by destructively altering the IMAGE spec list.
With optional INDEX, begin animating from that animation frame.
LIMIT specifies how long to animate the image. If omitted or
nil, play the animation until the end. If t, loop forever. If a
-number, play until that number of seconds has elapsed."
+number, play until that number of seconds has elapsed.
+
+If POSITION (which should be buffer position where the image is
+displayed), stop the animation if the image is no longer
+displayed."
(let ((animation (image-multi-frame-p image))
timer)
(when animation
@@ -839,6 +857,9 @@ number, play until that number of seconds has elapsed."
(cancel-timer timer))
(plist-put (cdr image) :animate-buffer (current-buffer))
(plist-put (cdr image) :animate-tardiness 0)
+ (when position
+ (plist-put (cdr image) :animate-position
+ (set-marker (make-marker) position (current-buffer))))
;; Stash the data about the animation here so that we don't
;; trigger image recomputation unnecessarily later.
(plist-put (cdr image) :animate-multi-frame-data animation)
@@ -912,40 +933,54 @@ for the animation speed. A negative value means to animate in reverse."
(plist-put (cdr image) :animate-tardiness
(+ (* (plist-get (cdr image) :animate-tardiness) 0.9)
(float-time (time-since target-time))))
- (when (and (buffer-live-p (plist-get (cdr image) :animate-buffer))
- ;; Cumulatively delayed two seconds more than expected.
- (or (< (plist-get (cdr image) :animate-tardiness) 2)
- (progn
- (message "Stopping animation; animation possibly too big")
- nil)))
- (image-show-frame image n t)
- (let* ((speed (image-animate-get-speed image))
- (time (current-time))
- (time-to-load-image (time-since time))
- (stated-delay-time
- (/ (or (cdr (plist-get (cdr image) :animate-multi-frame-data))
- image-default-frame-delay)
- (float (abs speed))))
- ;; Subtract off the time we took to load the image from the
- ;; stated delay time.
- (delay (max (float-time (time-subtract stated-delay-time
- time-to-load-image))
- image-minimum-frame-delay))
- done)
- (setq n (if (< speed 0)
- (1- n)
- (1+ n)))
- (if limit
- (cond ((>= n count) (setq n 0))
- ((< n 0) (setq n (1- count))))
- (and (or (>= n count) (< n 0)) (setq done t)))
- (setq time-elapsed (+ delay time-elapsed))
- (if (numberp limit)
- (setq done (>= time-elapsed limit)))
- (unless done
- (run-with-timer delay nil #'image-animate-timeout
- image n count time-elapsed limit
- (+ (float-time) delay))))))
+ (let ((buffer (plist-get (cdr image) :animate-buffer))
+ (position (plist-get (cdr image) :animate-position)))
+ (when (and (buffer-live-p buffer)
+ ;; If we have a :animate-position setting, the caller
+ ;; has requested that the animation be stopped if the
+ ;; image is no longer displayed in the buffer.
+ (or (null position)
+ (with-current-buffer buffer
+ (let ((disp (get-text-property position 'display)))
+ (and (consp disp)
+ (eq (car disp) 'image)
+ ;; We can't check `eq'-ness of the image
+ ;; itself, since that may change.
+ (eq position
+ (plist-get (cdr disp) :animate-position))))))
+ ;; Cumulatively delayed two seconds more than expected.
+ (or (< (plist-get (cdr image) :animate-tardiness) 2)
+ (progn
+ (message "Stopping animation; animation possibly too big")
+ nil)))
+ (let* ((time (prog1 (current-time)
+ (image-show-frame image n t)))
+ (speed (image-animate-get-speed image))
+ (time-to-load-image (time-since time))
+ (stated-delay-time
+ (/ (or (cdr (plist-get (cdr image) :animate-multi-frame-data))
+ image-default-frame-delay)
+ (float (abs speed))))
+ ;; Subtract off the time we took to load the image from the
+ ;; stated delay time.
+ (delay (max (float-time (time-subtract stated-delay-time
+ time-to-load-image))
+ image-minimum-frame-delay))
+ done)
+ (setq n (if (< speed 0)
+ (1- n)
+ (1+ n)))
+ (if limit
+ (cond ((>= n count) (setq n 0))
+ ((< n 0) (setq n (1- count))))
+ (and (or (>= n count) (< n 0)) (setq done t)))
+ (setq time-elapsed (+ delay time-elapsed))
+ (if (numberp limit)
+ (setq done (>= time-elapsed limit)))
+ (unless done
+ (run-with-timer delay nil #'image-animate-timeout
+ image n count time-elapsed limit
+ (+ (float-time) delay)))))))
(defvar imagemagick-types-inhibit)
@@ -1137,6 +1172,13 @@ default is 20%."
(error "No image under point"))
image))
+;;;###autoload
+(defun image-at-point-p ()
+ "Return non-nil if there is an image at point."
+ (condition-case nil
+ (prog1 t (image--get-image))
+ (error nil)))
+
(defun image--get-imagemagick-and-warn (&optional position)
(declare-function image-transforms-p "image.c" (&optional frame))
(unless (or (fboundp 'imagemagick-types) (image-transforms-p))
diff --git a/lisp/image/exif.el b/lisp/image/exif.el
index c2cf2346408..372e2d25553 100644
--- a/lisp/image/exif.el
+++ b/lisp/image/exif.el
@@ -58,6 +58,9 @@
;; (:tag 306 :tag-name date-time :format 2 :format-type ascii
;; :value "2019:09:21 16:22:13")
;; ...)
+;;
+;; (exif-field 'date-time (exif-parse-file "test.jpg")) =>
+;; "2022:09:14 18:46:19"
;;; Code:
@@ -65,6 +68,7 @@
(defvar exif-tag-alist
'((11 processing-software)
+ (270 description)
(271 make)
(272 model)
(274 orientation)
@@ -73,7 +77,8 @@
(296 resolution-unit)
(305 software)
(306 date-time)
- (315 artist))
+ (315 artist)
+ (33432 copyright))
"Alist of tag values and their names.")
(defconst exif--orientation
@@ -122,13 +127,20 @@ If the data is invalid, an `exif-error' is signaled."
(when-let ((app1 (cdr (assq #xffe1 (exif--parse-jpeg)))))
(exif--parse-exif-chunk app1))))))
+(defun exif-field (field data)
+ "Return raw FIELD from EXIF.
+If FIELD is not present in the data, return nil.
+FIELD is a symbol in the cdr of `exif-tag-alist'.
+DATA is the result of calling `exif-parse-file'."
+ (plist-get (seq-find (lambda (e)
+ (eq field (plist-get e :tag-name)))
+ data)
+ :value))
+
(defun exif-orientation (exif)
"Return the orientation (in degrees) in EXIF.
If the orientation isn't present in the data, return nil."
- (let ((code (plist-get (cl-find 'orientation exif
- :key (lambda (e)
- (plist-get e :tag-name)))
- :value)))
+ (let ((code (exif-field 'orientation exif)))
(cadr (assq code exif--orientation))))
(defun exif--parse-jpeg ()
diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el
index f6f056a2baf..87726a9b8c8 100644
--- a/lisp/image/gravatar.el
+++ b/lisp/image/gravatar.el
@@ -277,7 +277,7 @@ where GRAVATAR is either an image descriptor, or the symbol
;; Store the image in the cache.
(when image
(setf (gethash mail-address gravatar--cache)
- (cons (time-convert (current-time) 'integer)
+ (cons (time-convert nil 'integer)
image)))
(prog1
(apply callback (if data image 'error) cbargs)
@@ -286,7 +286,7 @@ where GRAVATAR is either an image descriptor, or the symbol
(defun gravatar--prune-cache ()
(let ((expired nil)
- (time (- (time-convert (current-time) 'integer)
+ (time (- (time-convert nil 'integer)
;; Twelve hours.
(* 12 60 60))))
(maphash (lambda (key val)
diff --git a/lisp/indent.el b/lisp/indent.el
index aa6b8d17c4a..ec01733d123 100644
--- a/lisp/indent.el
+++ b/lisp/indent.el
@@ -88,16 +88,20 @@ This variable has no effect unless `tab-always-indent' is `complete'."
indent-relative-first-indent-point)
"Values that are ignored by `indent-according-to-mode'.")
-(defun indent-according-to-mode ()
+(defun indent-according-to-mode (&optional inhibit-widen)
"Indent line in proper way for current major mode.
Normally, this is done by calling the function specified by the
variable `indent-line-function'. However, if the value of that
variable is present in the `indent-line-ignored-functions' variable,
handle it specially (since those functions are used for tabbing);
-in that case, indent by aligning to the previous non-blank line."
+in that case, indent by aligning to the previous non-blank line.
+
+Ignore restriction, unless the optional argument INHIBIT-WIDEN is
+non-nil."
(interactive)
(save-restriction
- (widen)
+ (unless inhibit-widen
+ (widen))
(syntax-propertize (line-end-position))
(if (memq indent-line-function indent-line-ignored-functions)
;; These functions are used for tabbing, but can't be used for
@@ -601,7 +605,10 @@ column to indent to; if it is nil, use one of the three methods above."
(funcall indent-region-function start end)))
;; Else, use a default implementation that calls indent-line-function on
;; each line.
- (t (indent-region-line-by-line start end)))
+ (t
+ (save-restriction
+ (widen)
+ (indent-region-line-by-line start end))))
;; In most cases, reindenting modifies the buffer, but it may also
;; leave it unmodified, in which case we have to deactivate the mark
;; by hand.
@@ -615,7 +622,7 @@ column to indent to; if it is nil, use one of the three methods above."
(make-progress-reporter "Indenting region..." (point) end))))
(while (< (point) end)
(or (and (bolp) (eolp))
- (indent-according-to-mode))
+ (indent-according-to-mode t))
(forward-line 1)
(and pr (progress-reporter-update pr (point))))
(and pr (progress-reporter-done pr))
diff --git a/lisp/info-look.el b/lisp/info-look.el
index cc6a806f56f..48120359193 100644
--- a/lisp/info-look.el
+++ b/lisp/info-look.el
@@ -43,6 +43,7 @@
(require 'info)
(eval-when-compile (require 'subr-x))
+(eval-when-compile (require 'cl-lib))
(defgroup info-lookup nil
"Major mode sensitive help agent."
@@ -123,6 +124,14 @@ OTHER-MODES is a list of cross references to other help modes.")
(defsubst info-lookup->mode-value (topic mode)
(assoc mode (info-lookup->topic-value topic)))
+(defun info-lookup--expand-info (info)
+ ;; We have a dynamic doc-spec function.
+ (when (and (null (nth 3 info))
+ (nth 6 info))
+ (setf (nth 3 info) (funcall (nth 6 info))
+ (nth 6 info) nil))
+ info)
+
(defsubst info-lookup->regexp (topic mode)
(nth 1 (info-lookup->mode-value topic mode)))
@@ -145,7 +154,11 @@ Function arguments are specified as keyword/argument pairs:
(KEYWORD . ARGUMENT)
KEYWORD is either `:topic', `:mode', `:regexp', `:ignore-case',
- `:doc-spec', `:parse-rule', or `:other-modes'.
+ `:doc-spec', `:parse-rule', `:other-modes' or `:doc-spec-function'.
+ `:doc-spec-function' is used to compute a `:doc-spec', but instead of
+ doing so at load time, this is done when the user asks for info on
+ the mode in question.
+
ARGUMENT has a value as explained in the documentation of the
variable `info-lookup-alist'.
@@ -161,7 +174,8 @@ for more details."
(defun info-lookup-add-help* (maybe &rest arg)
(let (topic mode regexp ignore-case doc-spec
- parse-rule other-modes keyword value)
+ parse-rule other-modes keyword value
+ doc-spec-function)
(setq topic 'symbol
mode major-mode
regexp "\\w+")
@@ -184,6 +198,8 @@ for more details."
(setq ignore-case value))
((eq keyword :doc-spec)
(setq doc-spec value))
+ ((eq keyword :doc-spec-function)
+ (setq doc-spec-function value))
((eq keyword :parse-rule)
(setq parse-rule value))
((eq keyword :other-modes)
@@ -191,7 +207,8 @@ for more details."
(t
(error "Unknown keyword \"%S\"" keyword))))
(or (and maybe (info-lookup->mode-value topic mode))
- (let* ((data (list regexp ignore-case doc-spec parse-rule other-modes))
+ (let* ((data (list regexp ignore-case doc-spec parse-rule other-modes
+ doc-spec-function))
(topic-cell (or (assoc topic info-lookup-alist)
(car (setq info-lookup-alist
(cons (cons topic nil)
@@ -341,11 +358,22 @@ If optional argument QUERY is non-nil, query for the help mode."
(error "No %s help available for `%s'" topic mode))
(setq info-lookup-mode mode)))
+(defun info-lookup--item-to-mode (item mode)
+ (let ((spec (cons mode (car (split-string (if (stringp item)
+ item
+ (symbol-name item))
+ "-")))))
+ (if (assoc spec (cdr (assq 'symbol info-lookup-alist)))
+ spec
+ mode)))
+
(defun info-lookup (topic item mode)
"Display the documentation of a help item."
(or mode (setq mode (info-lookup-select-mode)))
- (or (info-lookup->mode-value topic mode)
- (error "No %s help available for `%s'" topic mode))
+ (setq mode (info-lookup--item-to-mode item mode))
+ (if-let ((info (info-lookup->mode-value topic mode)))
+ (info-lookup--expand-info info)
+ (error "No %s help available for `%s'" topic mode))
(let* ((completions (info-lookup->completions topic mode))
(ignore-case (info-lookup->ignore-case topic mode))
(entry (or (assoc (if ignore-case (downcase item) item) completions)
@@ -724,6 +752,8 @@ Return nil if there is nothing appropriate in the buffer near point."
(defun info-complete (topic mode)
"Try to complete a help item."
(barf-if-buffer-read-only)
+ (when-let ((info (info-lookup->mode-value topic mode)))
+ (info-lookup--expand-info info))
(let ((data (info-lookup-completions-at-point topic mode)))
(if (null data)
(error "No %s completion available for `%s' at point" topic mode)
@@ -904,9 +934,16 @@ Return nil if there is nothing appropriate in the buffer near point."
(info-lookup-maybe-add-help
:mode 'python-mode
- :doc-spec `((,(if (Info-find-file "python3.9" t)
- "(python3.9)Index"
- "(python)Index"))))
+ ;; Debian includes Python info files, but they're version-named
+ ;; instead of having a symlink.
+ :doc-spec-function (lambda ()
+ (list
+ (list
+ (cl-loop for version from 20 downto 7
+ for name = (format "python3.%d" version)
+ if (Info-find-file name t)
+ return (format "(%s)Index" name)
+ finally return "(python)Index")))))
(info-lookup-maybe-add-help
:mode 'cperl-mode
@@ -944,6 +981,67 @@ Return nil if there is nothing appropriate in the buffer near point."
("(cl)Function Index" nil "^ -+ .*: " "\\( \\|$\\)")
("(cl)Variable Index" nil "^ -+ .*: " "\\( \\|$\\)")))
+(mapc
+ (lambda (elem)
+ (let* ((prefix (car elem)))
+ (info-lookup-add-help
+ :mode (cons 'emacs-lisp-mode prefix)
+ :regexp (concat "\\b" prefix "-[^][()`'‘’,\" \t\n]+")
+ :doc-spec (cl-loop for node in (cdr elem)
+ collect
+ (list (if (string-match-p "^(" node)
+ node
+ (format "(%s)%s" prefix node))
+ nil "^ -+ .*: " "\\( \\|$\\)")))))
+ ;; Below we have a list of prefixes (used to match on symbols in
+ ;; `emacs-lisp-mode') and the nodes where the function/variable
+ ;; indices live. If the prefix is different than the name of the
+ ;; manual, then the full "(manual)Node" name has to be used.
+ '(("auth" "Function Index" "Variable Index")
+ ("autotype" "Command Index" "Variable Index")
+ ("calc" "Lisp Function Index" "Variable Index")
+ ;;("cc-mode" "Variable Index" "Command and Function Index")
+ ("dbus" "Index")
+ ("ediff" "Index")
+ ("eieio" "Function Index")
+ ("gnutls" "(emacs-gnutls)Variable Index" "(emacs-gnutls)Function Index")
+ ("mm" "(emacs-mime)Index")
+ ("epa" "Variable Index" "Function Index")
+ ("ert" "Index")
+ ("eshell" "Function and Variable Index")
+ ("eudc" "Index")
+ ("eww" "Variable Index" "Lisp Function Index")
+ ("flymake" "Index")
+ ("forms" "Index")
+ ("gnus" "Index")
+ ("htmlfontify" "Functions" "Variables & Customization")
+ ("idlwave" "Index")
+ ("ido" "Variable Index" "Function Index")
+ ("info" "Index")
+ ("mairix" "(mairix-el)Variable Index" "(mairix-el)Function Index")
+ ("message" "Index")
+ ("mh" "(mh-e)Option Index" "(mh-e)Command Index")
+ ("newsticker" "Index")
+ ("octave" "(octave-mode)Variable Index" "(octave-mode)Lisp Function Index")
+ ("org" "Variable Index" "Command and Function Index")
+ ("pgg" "Variable Index" "Function Index")
+ ("rcirc" "Variable Index" "Index")
+ ("reftex" "Index")
+ ("sasl" "Variable Index" "Function Index")
+ ("sc" "Variable Index")
+ ("semantic" "Index")
+ ("ses" "Index")
+ ("sieve" "Index")
+ ("smtpmail" "Function and Variable Index")
+ ("srecode" "Index")
+ ("tramp" "Variable Index" "Function Index")
+ ("url" "Variable Index" "Function Index")
+ ("vhdl" "(vhdl-mode)Variable Index" "(vhdl-mode)Command Index")
+ ("viper" "Variable Index" "Function Index")
+ ("widget" "Index")
+ ("wisent" "Index")
+ ("woman" "Variable Index" "Command Index")))
+
;; docstrings talk about elisp, so have apropos-mode follow emacs-lisp-mode
(info-lookup-maybe-add-help
:mode 'apropos-mode
diff --git a/lisp/info.el b/lisp/info.el
index 8c08eaec3c8..559460e8d2c 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -115,7 +115,9 @@ The Lisp code is executed when the node is selected.")
(defface info-menu-star
'((((class color)) :foreground "red1")
(t :underline t))
- "Face for every third `*' in an Info menu.")
+ "Face used to emphasize `*' in an Info menu.
+The face is assigned to the third, sixth, and ninth `*' for easier
+orientation. See `Info-nth-menu-item'.")
(defface info-xref
'((t :inherit link))
@@ -1792,7 +1794,46 @@ of NODENAME; if none is found it then tries a case-insensitive match
(if trim (setq nodename (substring nodename 0 trim))))
(if transient-mark-mode (deactivate-mark))
(Info-find-node (if (equal filename "") nil filename)
- (if (equal nodename "") "Top" nodename) nil strict-case)))
+ (if (equal nodename "") "Top" nodename) nil strict-case)))
+
+(defun Info-goto-node-web (node)
+ "Use `browse-url' to go to the gnu.org web server's version of NODE.
+By default, go to the current Info node."
+ (interactive (list (Info-read-node-name
+ "Go to node (default current page): " Info-current-node))
+ Info-mode)
+ (browse-url-button-open-url
+ (Info-url-for-node (format "(%s)%s" (file-name-sans-extension
+ (file-name-nondirectory
+ Info-current-file))
+ 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 "/"
+ (url-hexify-string (string-replace " " "-" node))
+ ".html")))
(defvar Info-read-node-completion-table)
@@ -1877,7 +1918,7 @@ See `completing-read' for a description of arguments and usage."
code Info-read-node-completion-table string predicate))))
;; Arrange to highlight the proper letters in the completion list buffer.
-(defun Info-read-node-name (prompt)
+(defun Info-read-node-name (prompt &optional default)
"Read an Info node name with completion, prompting with PROMPT.
A node name can have the form \"NODENAME\", referring to a node
in the current Info file, or \"(FILENAME)NODENAME\", referring to
@@ -1885,7 +1926,8 @@ a node in FILENAME. \"(FILENAME)\" is a short format to go to
the Top node in FILENAME."
(let* ((completion-ignore-case t)
(Info-read-node-completion-table (Info-build-node-completions))
- (nodename (completing-read prompt #'Info-read-node-name-1 nil t)))
+ (nodename (completing-read prompt #'Info-read-node-name-1 nil t nil
+ 'Info-minibuf-history default)))
(if (equal nodename "")
(Info-read-node-name prompt)
nodename)))
@@ -2604,12 +2646,9 @@ new buffer."
(if (eq (length completions) 1)
(setq default (car completions)))
(if completions
- (let ((input (completing-read (if default
- (concat
- "Follow reference named (default "
- default "): ")
- "Follow reference named: ")
- completions nil t)))
+ (let ((input (completing-read (format-prompt "Follow reference named"
+ default)
+ completions nil t)))
(list (if (equal input "")
default input)
current-prefix-arg))
@@ -4049,6 +4088,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'."
(define-key map "e" 'end-of-buffer)
(define-key map "f" 'Info-follow-reference)
(define-key map "g" 'Info-goto-node)
+ (define-key map "G" 'Info-goto-node-web)
(define-key map "h" 'Info-help)
;; This is for compatibility with standalone info (>~ version 5.2).
;; Though for some time, standalone info had H and h reversed.
@@ -4858,9 +4898,16 @@ first line or header line, and for breadcrumb links.")
;; an end of sentence
(skip-syntax-backward " ("))
(setq other-tag
- (cond ((save-match-data (looking-back "\\(^\\| \\)see"
+ (cond ((save-match-data (looking-back "\\(^\\|[ (]\\)see"
(- (point) 4)))
"")
+ ;; We want "Also *note" to produce
+ ;; "Also see", but "See also *note" to produce
+ ;; "See also", so match case-sensitively.
+ ((save-match-data (let ((case-fold-search nil))
+ (looking-back "\\(^\\| \\)also"
+ (- (point) 5))))
+ "")
((save-match-data (looking-back "\\(^\\| \\)in"
(- (point) 3)))
"")
diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el
index 629cd4c2879..883b0b60fc9 100644
--- a/lisp/international/ccl.el
+++ b/lisp/international/ccl.el
@@ -1553,7 +1553,7 @@ MAP :=
MAP-IDs := MAP-ID ...
MAP-SET := MAP-IDs | (MAP-IDs) MAP-SET
MAP-ID := integer"
- (declare (doc-string 3))
+ (declare (doc-string 3) (indent defun))
`(let ((prog ,(unwind-protect
(progn
;; To make ,(charset-id CHARSET) works well.
diff --git a/lisp/international/characters.el b/lisp/international/characters.el
index 5aefda23283..a2156ee01aa 100644
--- a/lisp/international/characters.el
+++ b/lisp/international/characters.el
@@ -1493,6 +1493,9 @@ Setup `char-width-table' appropriate for non-CJK language environment."
(aset char-acronym-table #x202D "LRO") ; LEFT-TO-RIGHT OVERRIDE
(aset char-acronym-table #x202E "RLO") ; RIGHT-TO-LEFT OVERRIDE
(aset char-acronym-table #x2060 "WJ") ; WORD JOINER
+(aset char-acronym-table #x2066 "LRI") ; LEFT-TO-RIGHT ISOLATE
+(aset char-acronym-table #x2067 "RLI") ; RIGHT-TO-LEFT ISOLATE
+(aset char-acronym-table #x2069 "PDI") ; POP DIRECTIONAL ISOLATE
(aset char-acronym-table #x206A "ISS") ; INHIBIT SYMMETRIC SWAPPING
(aset char-acronym-table #x206B "ASS") ; ACTIVATE SYMMETRIC SWAPPING
(aset char-acronym-table #x206C "IAFS") ; INHIBIT ARABIC FORM SHAPING
@@ -1517,18 +1520,32 @@ Setup `char-width-table' appropriate for non-CJK language environment."
(aset char-acronym-table (+ #xE0021 i) (format " %c TAG" (+ 33 i))))
(aset char-acronym-table #xE007F "->|TAG") ; CANCEL TAG
+;; We can't use the \N{name} things here, because this file is used
+;; too early in the build process.
+(defvar glyphless--bidi-control-characters
+ '(#x202a ; ?\N{left-to-right embedding}
+ #x202b ; ?\N{right-to-left embedding}
+ #x202d ; ?\N{left-to-right override}
+ #x202e ; ?\N{right-to-left override}
+ #x2066 ; ?\N{left-to-right isolate}
+ #x2067 ; ?\N{right-to-left isolate}
+ #x2068 ; ?\N{first strong isolate}
+ #x202c ; ?\N{pop directional formatting}
+ #x2069)) ; ?\N{pop directional isolate})
+
(defun update-glyphless-char-display (&optional variable value)
"Make the setting of `glyphless-char-display-control' take effect.
This function updates the char-table `glyphless-char-display',
and is intended to be used in the `:set' attribute of the
option `glyphless-char-display'."
- (when value
+ (when variable
(set-default variable value))
(dolist (elt value)
(let ((target (car elt))
(method (cdr elt)))
- (or (memq method '(zero-width thin-space empty-box acronym hex-code))
- (error "Invalid glyphless character display method: %s" method))
+ (unless (memq method '( zero-width thin-space empty-box
+ acronym hex-code bidi-control))
+ (error "Invalid glyphless character display method: %s" method))
(cond ((eq target 'c0-control)
(glyphless-set-char-table-range glyphless-char-display
#x00 #x1F method)
@@ -1543,24 +1560,29 @@ option `glyphless-char-display'."
((eq target 'variation-selectors)
(glyphless-set-char-table-range glyphless-char-display
#xFE00 #xFE0F method))
- ((eq target 'format-control)
+ ((or (eq target 'format-control)
+ (eq target 'bidi-control))
(when unicode-category-table
(map-char-table
(lambda (char category)
- (if (eq category 'Cf)
- (let ((this-method method)
- from to)
- (if (consp char)
- (setq from (car char) to (cdr char))
- (setq from char to char))
- (while (<= from to)
- (when (/= from #xAD)
- (if (eq method 'acronym)
- (setq this-method
- (aref char-acronym-table from)))
+ (when (eq category 'Cf)
+ (let ((this-method method)
+ from to)
+ (if (consp char)
+ (setq from (car char) to (cdr char))
+ (setq from char to char))
+ (while (<= from to)
+ (when (/= from #xAD)
+ (when (eq method 'acronym)
+ (setq this-method
+ (or (aref char-acronym-table from)
+ "UNK")))
+ (when (or (eq target 'format-control)
+ (memq from
+ glyphless--bidi-control-characters))
(set-char-table-range glyphless-char-display
- from this-method))
- (setq from (1+ from))))))
+ from this-method)))
+ (setq from (1+ from))))))
unicode-category-table)))
((eq target 'no-font)
(set-char-table-extra-slot glyphless-char-display 0 method))
@@ -1576,6 +1598,19 @@ option `glyphless-char-display'."
(set-char-table-range chartable (cons from to) method)))
;;; Control of displaying glyphless characters.
+(define-widget 'glyphless-char-display-method 'lazy
+ "Display method for glyphless characters."
+ :group 'mule
+ :format "%v"
+ :value 'thin-space
+ :type
+ '(choice
+ (const :tag "Don't display" zero-width)
+ (const :tag "Display as thin space" thin-space)
+ (const :tag "Display as empty box" empty-box)
+ (const :tag "Display acronym" acronym)
+ (const :tag "Display hex code in a box" hex-code)))
+
(defcustom glyphless-char-display-control
'((format-control . thin-space)
(variation-selectors . thin-space)
@@ -1594,12 +1629,17 @@ GROUP must be one of these symbols:
such as U+200C (ZWNJ), U+200E (LRM), but
excluding characters that have graphic images,
such as U+00AD (SHY).
- `variation-selectors': U+FE00..U+FE0F, used for choosing between
- glyph variations (e.g. Emoji vs Text
- presentation).
- `no-font': characters for which no suitable font is found.
- For character terminals, characters that cannot
- be encoded by `terminal-coding-system'.
+ `bidi-control': A subset of `format-control', but only characters
+ that are relevant for bidirectional formatting control,
+ like U+2069 (PDI) and U+202B (RLE).
+ `variation-selectors':
+ Characters in the range U+FE00..U+FE0F, used for
+ selecting alternate glyph presentations, such as
+ Emoji vs Text presentation, of the preceding
+ character(s).
+ `no-font': For GUI frames, characters for which no suitable
+ font is found; for text-mode frames, characters
+ that cannot be encoded by `terminal-coding-system'.
METHOD must be one of these symbols:
`zero-width': don't display.
@@ -1617,36 +1657,12 @@ function (`update-glyphless-char-display'), which updates
:version "28.1"
:type '(alist :key-type (symbol :tag "Character Group")
:value-type (symbol :tag "Display Method"))
- :options '((c0-control
- (choice (const :tag "Don't display" zero-width)
- (const :tag "Display as thin space" thin-space)
- (const :tag "Display as empty box" empty-box)
- (const :tag "Display acronym" acronym)
- (const :tag "Display hex code in a box" hex-code)))
- (c1-control
- (choice (const :tag "Don't display" zero-width)
- (const :tag "Display as thin space" thin-space)
- (const :tag "Display as empty box" empty-box)
- (const :tag "Display acronym" acronym)
- (const :tag "Display hex code in a box" hex-code)))
- (format-control
- (choice (const :tag "Don't display" zero-width)
- (const :tag "Display as thin space" thin-space)
- (const :tag "Display as empty box" empty-box)
- (const :tag "Display acronym" acronym)
- (const :tag "Display hex code in a box" hex-code)))
- (variation-selectors
- (choice (const :tag "Don't display" zero-width)
- (const :tag "Display as thin space" thin-space)
- (const :tag "Display as empty box" empty-box)
- (const :tag "Display acronym" acronym)
- (const :tag "Display hex code in a box" hex-code)))
- (no-font
- (choice (const :tag "Don't display" zero-width)
- (const :tag "Display as thin space" thin-space)
- (const :tag "Display as empty box" empty-box)
- (const :tag "Display acronym" acronym)
- (const :tag "Display hex code in a box" hex-code))))
+ :options '((c0-control glyphless-char-display-method)
+ (c1-control glyphless-char-display-method)
+ (format-control glyphless-char-display-method)
+ (bidi-control glyphless-char-display-method)
+ (variation-selectors glyphless-char-display-method)
+ (no-font (glyphless-char-display-method :value hex-code)))
:set 'update-glyphless-char-display
:group 'display)
diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el
new file mode 100644
index 00000000000..cd6684c3f6a
--- /dev/null
+++ b/lisp/international/emoji.el
@@ -0,0 +1,688 @@
+;;; emoji.el --- Inserting emojis -*- lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: Lars Ingebrigtsen <larsi@gnus.org>
+;; Keywords: fun
+
+;; Package-Requires: ((emacs "28.0") (transient "0.3.7"))
+;; Package-Version: 0.1
+
+;; 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 'cl-lib)
+(require 'cl-extra)
+(require 'transient)
+(require 'multisession)
+
+(defgroup emoji nil
+ "Inserting Emojis."
+ :version "29.1"
+ :group 'play)
+
+(defface emoji-list-header
+ '((default :weight bold :inherit variable-pitch))
+ "Face for emoji list headers."
+ :version "29.1")
+
+(defface emoji
+ '((t :height 2.0))
+ "Face used when displaying an emoji."
+ :version "29.1")
+
+(defface emoji-with-derivations
+ '((((background dark))
+ (:background "#202020" :inherit emoji))
+ (((background light))
+ (:background "#e0e0e0" :inherit emoji)))
+ "Face for emojis that have derivations."
+ :version "29.1")
+
+(defvar emoji--labels nil)
+(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 (&optional text)
+ "Choose and insert an emoji glyph.
+If TEXT (interactively, the prefix argument), choose the emoji
+by typing its Unicode Standard name (with completion), instead
+of selecting from emoji display."
+ (interactive "*P")
+ (emoji--init)
+ (if text
+ (emoji--choose-emoji)
+ (unless (fboundp 'emoji--command-Emoji)
+ (emoji--define-transient))
+ (funcall (intern "emoji--command-Emoji"))))
+
+;;;###autoload
+(defun emoji-recent ()
+ "Choose and insert one of the recently-used emoji glyphs."
+ (interactive "*")
+ (emoji--init)
+ (unless (fboundp 'emoji--command-Emoji)
+ (emoji--define-transient))
+ (funcall (emoji--define-transient
+ (cons "Recent" (multisession-value emoji--recent)) t)))
+
+;;;###autoload
+(defun emoji-search ()
+ "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."
+ (interactive "*")
+ (emoji--init)
+ (emoji--choose-emoji))
+
+;;;###autoload
+(defun emoji-list ()
+ "List emojis and insert the one that's selected.
+Select the emoji by typing \\<emoji-list-mode-map>\\[emoji-list-select] on its picture.
+The glyph will be inserted into the buffer that was current
+when the command was invoked."
+ (interactive "*")
+ (let ((buf (current-buffer)))
+ (emoji--init)
+ (switch-to-buffer (get-buffer-create "*Emoji*"))
+ ;; Don't regenerate the buffer if it already exists -- this will
+ ;; leave point where it was the last time it was used.
+ (when (zerop (buffer-size))
+ (let ((inhibit-read-only t))
+ (emoji-list-mode)
+ (setq-local emoji--insert-buffer buf)
+ (emoji--list-generate nil (cons nil emoji--labels))
+ (goto-char (point-min))))))
+
+;;;###autoload
+(defun emoji-describe (glyph &optional interactive)
+ "Display the name of the grapheme cluster composed from GLYPH.
+GLYPH should be a string of one or more characters which together
+produce an emoji. Interactively, GLYPH is the emoji at point (it
+could also be any character, not just emoji).
+
+If called from Lisp, return the name as a string; return nil if
+the name is not known."
+ (interactive
+ (list (if (eobp)
+ (error "No glyph under point")
+ (let ((comp (find-composition (point) (1+ (point)))))
+ (if comp
+ (buffer-substring-no-properties (car comp) (cadr comp))
+ (buffer-substring-no-properties (point) (1+ (point))))))
+ t))
+ (require 'emoji-labels)
+ (if (not interactive)
+ ;; Don't return a name for non-compositions when called
+ ;; non-interactively.
+ (gethash glyph emoji--names)
+ ;; Give a name for (pretty much) any glyph, including non-emojis.
+ (let ((name (emoji--name glyph)))
+ (if (not name)
+ (message "No known name for \"%s\"" glyph)
+ (message "The name of \"%s\" is \"%s\"" glyph name)))))
+
+(defun emoji--list-generate (name alist)
+ (let ((width (/ (window-width) 5))
+ (mname (pop alist)))
+ (if (consp (car alist))
+ ;; Recurse.
+ (mapcar (lambda (elem)
+ (emoji--list-generate (if name
+ (concat name " > " mname)
+ mname)
+ elem))
+ alist)
+ ;; Output this block of emojis.
+ (insert (propertize
+ (if (zerop (length name))
+ mname
+ (concat name " > " mname))
+ 'face 'emoji-list-header)
+ "\n\n")
+ (cl-loop for i from 0
+ for glyph in alist
+ do
+ (when (and (cl-plusp i)
+ (zerop (mod i width)))
+ (insert "\n"))
+ (insert
+ (propertize
+ (emoji--fontify-glyph glyph)
+ 'emoji-glyph glyph
+ 'help-echo (emoji--name glyph))))
+ (insert "\n\n"))))
+
+(defun emoji--fontify-glyph (glyph &optional inhibit-derived)
+ (propertize glyph 'face
+ (if (and (not inhibit-derived)
+ (or (null emoji--done-derived)
+ (not (gethash glyph emoji--done-derived)))
+ (gethash glyph emoji--derived))
+ ;; If this emoji has derivations, use a special face
+ ;; to tell the user.
+ 'emoji-with-derivations
+ ;; Normal emoji.
+ 'emoji)))
+
+(defun emoji--name (glyph)
+ (or (gethash glyph emoji--names)
+ (get-char-code-property (aref glyph 0) 'name)))
+
+(defvar-keymap emoji-list-mode-map
+ "RET" #'emoji-list-select
+ "<mouse-2>" #'emoji-list-select
+ "h" #'emoji-list-help
+ "<follow-link>" 'mouse-face)
+
+(define-derived-mode emoji-list-mode special-mode "Emoji"
+ "Mode to display emojis."
+ :interactive nil
+ (setq-local truncate-lines t))
+
+(defun emoji-list-select (event)
+ "Select the emoji under point."
+ (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)
+ (switch-to-buffer buf)
+ (error "Buffer disappeared"))))))
+ (if (not derived)
+ ;; Glyph without derivations.
+ (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)))))))
+
+(defun emoji-list-help ()
+ "Display the name of the emoji at point."
+ (interactive nil emoji-list-mode)
+ (let ((glyph (get-text-property (point) 'emoji-glyph)))
+ (unless glyph
+ (error "No emoji here"))
+ (let ((name (emoji--name glyph)))
+ (if (not name)
+ (error "Emoji name is unknown")
+ (message "%s" name)))))
+
+(defun emoji--init (&optional force inhibit-adjust)
+ (when (or (not emoji--labels)
+ force)
+ (unless force
+ (ignore-errors (require 'emoji-labels)))
+ ;; The require should define the variable, but in case the .el
+ ;; file doesn't exist (yet), parse the file now.
+ (when (or force
+ (not emoji--labels))
+ (setq emoji--derived (make-hash-table :test #'equal))
+ (emoji--parse-emoji-test)))
+ (when (and (not inhibit-adjust)
+ (not emoji--all-bases))
+ (setq emoji--all-bases (make-hash-table :test #'equal))
+ (emoji--adjust-displayable (cons "Emoji" emoji--labels))))
+
+(defvar emoji--font nil)
+
+(defun emoji--adjust-displayable (alist)
+ "Remove glyphs we don't have fonts for."
+ (let ((emoji--font nil))
+ (emoji--adjust-displayable-1 alist)))
+
+(defun emoji--adjust-displayable-1 (alist)
+ (if (consp (caddr alist))
+ (dolist (child (cdr alist))
+ (emoji--adjust-displayable-1 child))
+ (while (cdr alist)
+ (let ((glyph (cadr alist)))
+ ;; Store all the emojis for later retrieval by
+ ;; the search feature.
+ (when-let ((name (emoji--name glyph)))
+ (setf (gethash (downcase name) emoji--all-bases) glyph))
+ (if (display-graphic-p)
+ ;; Remove glyphs we don't have in graphical displays.
+ (if (let ((char (elt glyph 0)))
+ (if emoji--font
+ (font-has-char-p emoji--font char)
+ (when-let ((font (car (internal-char-font nil char))))
+ (setq emoji--font font))))
+ (setq alist (cdr alist))
+ ;; Remove the element.
+ (setcdr alist (cddr alist)))
+ ;; We don't have font info on non-graphical displays.
+ (if (let ((char (elt glyph 0)))
+ ;; FIXME. Some grapheme clusters display more or less
+ ;; correctly in the terminal, but we don't really know
+ ;; which ones. None of these display totally
+ ;; correctly, though, so should they be filtered out?
+ (char-displayable-p char))
+ (setq alist (cdr alist))
+ ;; Remove the element.
+ (setcdr alist (cddr alist))))))))
+
+(defun emoji--parse-emoji-test ()
+ (setq emoji--labels nil)
+ (with-temp-buffer
+ (insert-file-contents (expand-file-name "../admin/unidata/emoji-test.txt"
+ data-directory))
+ (unless (re-search-forward "^# +group:" nil t)
+ (error "Can't find start of data"))
+ (beginning-of-line)
+ (setq emoji--names (make-hash-table :test #'equal))
+ (let ((derivations (make-hash-table :test #'equal))
+ (case-fold-search t)
+ (glyphs nil)
+ group subgroup)
+ (while (not (eobp))
+ (cond
+ ((looking-at "# +group: \\(.*\\)")
+ (setq group (match-string 1)
+ subgroup nil))
+ ((looking-at "# +subgroup: \\(.*\\)")
+ (setq subgroup (match-string 1)))
+ ((looking-at
+ "\\([[:xdigit:] \t]+\\); *\\([^ \t]+\\)[ \t]+#.*?E[.0-9]+ +\\(.*\\)")
+ (let* ((codes (match-string 1))
+ (qualification (match-string 2))
+ (name (match-string 3))
+ (glyph (mapconcat
+ (lambda (code)
+ (string (string-to-number code 16)))
+ (split-string codes))))
+ (push (list name qualification group subgroup glyph) glyphs))))
+ (forward-line 1))
+ ;; We sort the data so that the "person foo" variant comes
+ ;; first, so that that becomes the key.
+ (setq glyphs
+ (sort (nreverse glyphs)
+ (lambda (g1 g2)
+ (and (equal (nth 2 g1) (nth 2 g2))
+ (equal (nth 3 g1) (nth 3 g2))
+ (< (emoji--score (car g1))
+ (emoji--score (car g2)))))))
+ ;; Get the derivations.
+ (cl-loop for (name qualification group subgroup glyph) in glyphs
+ for base = (emoji--base-name name derivations)
+ do
+ ;; Special-case flags.
+ (when (equal base "flag")
+ (setq base name))
+ ;; Register all glyphs to that we can look up their names
+ ;; later.
+ (setf (gethash glyph emoji--names) name)
+ ;; For the interface, we only care about the fully qualified
+ ;; emojis.
+ (when (equal qualification "fully-qualified")
+ (when (equal base name)
+ (emoji--add-to-group group subgroup glyph))
+ ;; Create mapping from base glyph name to name of
+ ;; derived glyphs.
+ (setf (gethash base derivations)
+ (nconc (gethash base derivations) (list glyph)))))
+ ;; Finally create the mapping from the base glyphs to derived ones.
+ (setq emoji--derived (make-hash-table :test #'equal))
+ (maphash (lambda (_k v)
+ (setf (gethash (car v) emoji--derived)
+ (cdr v)))
+ derivations))))
+
+(defun emoji--score (string)
+ (if (string-match-p "person\\|people"
+ (replace-regexp-in-string ":.*" "" string))
+ 0
+ 1))
+
+(defun emoji--add-to-group (group subgroup glyph)
+ ;; "People & Body" is very large; split it up.
+ (cond
+ ((equal group "People & Body")
+ (if (or (string-match "\\`person" subgroup)
+ (equal subgroup "family"))
+ (emoji--add-glyph glyph "People"
+ (if (equal subgroup "family")
+ (list subgroup)
+ ;; Avoid "Person person".
+ (cdr (emoji--split-subgroup subgroup))))
+ (emoji--add-glyph glyph "Body" (emoji--split-subgroup subgroup))))
+ ;; "Smileys & Emotion" also seems sub-optimal.
+ ((equal group "Smileys & Emotion")
+ (if (equal subgroup "emotion")
+ (emoji--add-glyph glyph "Emotion" nil)
+ (let ((subs (emoji--split-subgroup subgroup)))
+ ;; Remove one level of menus in the face case.
+ (when (equal (car subs) "face")
+ (pop subs))
+ (emoji--add-glyph glyph "Smileys" subs))))
+ ;; Don't modify the rest.
+ (t
+ (emoji--add-glyph glyph group (emoji--split-subgroup subgroup)))))
+
+(defun emoji--generate-file (&optional file)
+ "Generate an .el file with emoji mapping data and write it to FILE."
+ ;; Running from Makefile.
+ (unless file
+ (setq file (pop command-line-args-left)))
+ (emoji--init t t)
+ ;; Weed out the elements that are empty.
+ (let ((glyphs nil))
+ (maphash (lambda (k v)
+ (unless v
+ (push k glyphs)))
+ emoji--derived)
+ (dolist (glyph glyphs)
+ (remhash glyph emoji--derived)))
+ (with-temp-buffer
+ (insert ";; Generated file -- do not edit. -*- lexical-binding:t -*-
+;; Copyright © 1991-2021 Unicode, Inc.
+;; Generated from Unicode data files by emoji.el.
+;; The source for this file is found in the admin/unidata/emoji-test.txt
+;; file in the Emacs sources. The Unicode data files are used under the
+;; Unicode Terms of Use, as contained in the file copyright.html in that
+;; same directory.\n\n")
+ (dolist (var '(emoji--labels emoji--derived emoji--names))
+ (insert (format "(defconst %s '" var))
+ (pp (symbol-value var) (current-buffer))
+ (insert (format "\n) ;; End %s\n\n" var)))
+ (insert ";; Local" " Variables:
+;; coding: utf-8
+;; version-control: never
+;; no-byte-"
+ ;; Obfuscate to not inhibit compilation of this file, too.
+ "compile: t
+;; no-update-autoloads: t
+;; End:
+
+(provide 'emoji-labels)
+
+;;; emoji-labels.el ends here\n")
+ (write-region (point-min) (point-max) file)))
+
+(defun emoji--base-name (name derivations)
+ (let* ((base (replace-regexp-in-string ":.*" "" name)))
+ (catch 'found
+ ;; If we have (for instance) "person golfing", and we're adding
+ ;; "man golfing", make the latter a derivation of the former.
+ (let ((non-binary (replace-regexp-in-string
+ "\\`\\(m[ae]n\\|wom[ae]n\\) " "" base)))
+ (dolist (prefix '("person " "people " ""))
+ (let ((key (concat prefix non-binary)))
+ (when (gethash key derivations)
+ (throw 'found key)))))
+ ;; We can also have the gender at the end of the string, like
+ ;; "merman" and "pregnant woman".
+ (let ((non-binary (replace-regexp-in-string
+ "\\(m[ae]n\\|wom[ae]n\\|maid\\)\\'" "" base)))
+ (dolist (suffix '(" person" "person" ""))
+ (let ((key (concat non-binary suffix)))
+ (when (gethash key derivations)
+ (throw 'found key)))))
+ ;; Just return the base.
+ base)))
+
+(defun emoji--split-subgroup (subgroup)
+ (let ((prefixes '("face" "hand" "person" "animal" "plant"
+ "food" "place")))
+ (cond
+ ((string-match (concat "\\`" (regexp-opt prefixes) "-") subgroup)
+ ;; Split these subgroups into hierarchies.
+ (list (substring subgroup 0 (1- (match-end 0)))
+ (substring subgroup (match-end 0))))
+ ((equal subgroup "person")
+ (list "person" "age"))
+ (t
+ (list subgroup)))))
+
+(defun emoji--add-glyph (glyph main subs)
+ (let (parent elem)
+ ;; Useless category.
+ (unless (member main '("Component"))
+ (unless (setq parent (assoc main emoji--labels))
+ (setq emoji--labels (append emoji--labels
+ (list (setq parent (list main))))))
+ (setq elem parent)
+ (while subs
+ (unless (setq elem (assoc (car subs) parent))
+ (nconc parent (list (setq elem (list (car subs))))))
+ (pop subs)
+ (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)
+ ;; 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)
+ (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
+ (cl-mapcan (lambda (s) (transient--parse-child name s))
+ 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--add-recent (glyph)
+ "Add GLYPH to the set of recently used emojis."
+ (let ((recent (multisession-value emoji--recent)))
+ (setq recent (delete glyph recent))
+ (push glyph recent)
+ ;; Shorten the list.
+ (when-let ((tail (nthcdr 30 recent)))
+ (setcdr tail nil))
+ (setf (multisession-value emoji--recent) recent)))
+
+(defun emoji--columnize (list columns)
+ "Split LIST into COLUMN columns."
+ (cl-loop with length = (ceiling (/ (float (length list)) columns))
+ for i upto columns
+ for part on list by (lambda (l) (nthcdr length l))
+ collect (apply #'vector (seq-take part length))))
+
+(defun emoji--compute-prefix (alist)
+ "Compute characters to use for entries in ALIST.
+We prefer the earliest unique letter."
+ (cl-loop with taken = (make-hash-table)
+ for entry in alist
+ for name = (car entry)
+ collect (cons (cl-loop for char across (concat
+ (downcase name)
+ (upcase name))
+ while (gethash char taken)
+ finally (progn
+ (setf (gethash char taken) t)
+ (cl-return (string char))))
+ entry)))
+
+(defun emoji--compute-name (entry)
+ "Add example emojis to the name."
+ (let* ((name (concat (car entry) " "))
+ (children (emoji--flatten entry))
+ (length (length name))
+ (max 30))
+ (cl-loop for i from 0 upto 20
+ ;; Choose from all the children.
+ while (< length max)
+ do (cl-loop for child in children
+ for glyph = (elt child i)
+ while (< length max)
+ when glyph
+ do (setq name (concat name glyph)
+ length (+ length 2))))
+ (if (= (length name) max)
+ ;; Make an ellipsis signal that we've not exhausted the
+ ;; possibilities.
+ (concat name "…")
+ name)))
+
+(defun emoji--flatten (alist)
+ (pop alist)
+ (if (consp (cadr alist))
+ (cl-loop for child in alist
+ append (emoji--flatten child))
+ (list alist)))
+
+(defun emoji--split-long-lists (alist)
+ (let ((whole alist))
+ (pop alist)
+ (if (consp (cadr alist))
+ ;; Descend.
+ (cl-loop for child in alist
+ do (emoji--split-long-lists child))
+ ;; We have a list.
+ (when (length> alist 77)
+ (setcdr whole
+ (cl-loop for prefix from ?a
+ for bit on alist by (lambda (l) (nthcdr 77 l))
+ collect (cons (concat (string prefix) "-group")
+ (seq-take bit 77))))))))
+
+(defun emoji--choose-emoji ()
+ ;; Use the list of names.
+ (let ((name
+ (completing-read
+ "Insert emoji: "
+ (lambda (string pred action)
+ (if (eq action 'metadata)
+ (list 'metadata
+ (cons
+ 'affixation-function
+ ;; Add the glyphs to the start of the displayed
+ ;; strings when TAB-ing.
+ (lambda (strings)
+ (mapcar
+ (lambda (name)
+ (list name
+ (concat
+ (or (gethash name emoji--all-bases) " ")
+ "\t")
+ ""))
+ strings))))
+ (complete-with-action action emoji--all-bases string pred)))
+ nil t)))
+ (when (cl-plusp (length name))
+ (let* ((glyph (gethash name emoji--all-bases))
+ (derived (gethash glyph emoji--derived)))
+ (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))))))))))
+
+(provide 'emoji)
+
+;;; emoji.el ends here
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index fcd22e09d29..7c3a7cd1a9e 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -816,11 +816,16 @@
(#x1D7EC #x1D7F5 mathematical-sans-serif-bold)
(#x1D7F6 #x1D7FF mathematical-monospace)))
(let ((slot (assq (nth 2 math-subgroup) script-representative-chars)))
+ ;; Add both ends of each subgroup to help filter out some
+ ;; incomplete fonts, e.g. those that cover MATHEMATICAL SCRIPT
+ ;; CAPITAL glyphs but not MATHEMATICAL SCRIPT SMALL ones.
(if slot
- (if (vectorp (cdr slot))
- (setcdr slot (vconcat (cdr slot) (vector (car math-subgroup))))
- (setcdr slot (vector (cadr slot) (car math-subgroup))))
- (setq slot (list (nth 2 math-subgroup) (car math-subgroup)))
+ (setcdr slot (append (list (nth 0 math-subgroup)
+ (nth 1 math-subgroup))
+ (cdr slot)))
+ (setq slot (list (nth 2 math-subgroup)
+ (nth 0 math-subgroup)
+ (nth 1 math-subgroup)))
(nconc script-representative-chars (list slot))))
(set-fontset-font
"fontset-default"
diff --git a/lisp/international/iso-transl.el b/lisp/international/iso-transl.el
index 2c7da2b7cdf..aea12179170 100644
--- a/lisp/international/iso-transl.el
+++ b/lisp/international/iso-transl.el
@@ -86,33 +86,46 @@
("\"y" . [?ÿ])
("''" . [?´])
("'A" . [?Á])
+ ("'C" . [?Ć])
("'E" . [?É])
("'I" . [?Í])
+ ("'N" . [?Ń])
("'O" . [?Ó])
+ ("'S" . [?Ś])
("'U" . [?Ú])
("'Y" . [?Ý])
+ ("'Z" . [?Ź])
("'a" . [?á])
+ ("'c" . [?ć])
("'e" . [?é])
("'i" . [?í])
+ ("'n" . [?ń])
("'o" . [?ó])
+ ("'s" . [?ś])
("'u" . [?ú])
("'y" . [?ý])
+ ("'z" . [?ź])
("*$" . [?¤])
("$" . [?¤])
("*+" . [?±])
("+" . [?±])
(",," . [?¸])
+ (",A" . [?Ą])
(",C" . [?Ç])
+ (",a" . [?ą])
(",c" . [?ç])
("*-" . [?­])
("-" . [?­])
("*." . [?·])
- ("." . [?·])
+ (".." . [?·])
+ (".z" . [?ż])
("//" . [?÷])
("/A" . [?Å])
+ ("/L" . [?Ł])
("/E" . [?Æ])
("/O" . [?Ø])
("/a" . [?å])
+ ("/l" . [?ł])
("/e" . [?æ])
("/o" . [?ø])
("1/2" . [?½])
@@ -294,6 +307,14 @@ sequence VECTOR. (VECTOR is normally one character long.)")
(setq alist (cdr alist))))
(defun iso-transl-set-language (lang)
+ "Set shorter key bindings for some characters relevant for LANG.
+This affects the `C-x 8' prefix.
+
+Note that only a few languages are supported, and for more
+rigorous support it is recommended to use an input method
+instead. Also note that many of these characters can be input
+with the regular `C-x 8' map without having to specify a language
+here."
(interactive (list (let ((completion-ignore-case t))
(completing-read "Set which language? "
iso-transl-language-alist nil t))))
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index a0a6557c95c..7f9b14bdfd9 100644
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -88,7 +88,7 @@
(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)))
+ :enable (null (memq initial-window-system '(x w32 ns haiku pgtk)))
:help "How to encode terminal output"))
(bindings--define-key map [set-keyboard-coding-system]
'(menu-item "For Keyboard" set-keyboard-coding-system
@@ -1638,30 +1638,31 @@ If `default-transient-input-method' was not yet defined, prompt for it."
(interactive
(list (read-input-method-name
(format-prompt "Describe input method" current-input-method))))
- (if (and input-method (symbolp input-method))
- (setq input-method (symbol-name input-method)))
- (help-setup-xref (list #'describe-input-method
- (or input-method current-input-method))
- (called-interactively-p 'interactive))
-
- (if (null input-method)
- (describe-current-input-method)
- (let ((current current-input-method))
- (condition-case nil
- (progn
- (save-excursion
- (activate-input-method input-method)
- (describe-current-input-method))
- (activate-input-method current))
- (error
- (activate-input-method current)
- (help-setup-xref (list #'describe-input-method input-method)
- (called-interactively-p 'interactive))
- (with-output-to-temp-buffer (help-buffer)
- (let ((elt (assoc input-method input-method-alist)))
- (princ (format-message
- "Input method: %s (`%s' in mode line) for %s\n %s\n"
- input-method (nth 3 elt) (nth 1 elt) (nth 4 elt))))))))))
+ (let ((help-buffer-under-preparation t))
+ (if (and input-method (symbolp input-method))
+ (setq input-method (symbol-name input-method)))
+ (help-setup-xref (list #'describe-input-method
+ (or input-method current-input-method))
+ (called-interactively-p 'interactive))
+
+ (if (null input-method)
+ (describe-current-input-method)
+ (let ((current current-input-method))
+ (condition-case nil
+ (progn
+ (save-excursion
+ (activate-input-method input-method)
+ (describe-current-input-method))
+ (activate-input-method current))
+ (error
+ (activate-input-method current)
+ (help-setup-xref (list #'describe-input-method input-method)
+ (called-interactively-p 'interactive))
+ (with-output-to-temp-buffer (help-buffer)
+ (let ((elt (assoc input-method input-method-alist)))
+ (princ (format-message
+ "Input method: %s (`%s' in mode line) for %s\n %s\n"
+ input-method (nth 3 elt) (nth 1 elt) (nth 4 elt)))))))))))
(defun describe-current-input-method ()
"Describe the input method currently in use.
@@ -2162,89 +2163,90 @@ See `set-language-info-alist' for use in programs."
(list (read-language-name
'documentation
(format-prompt "Describe language environment" current-language-environment))))
- (if (null language-name)
- (setq language-name current-language-environment))
- (if (or (null language-name)
- (null (get-language-info language-name 'documentation)))
- (error "No documentation for the specified language"))
- (if (symbolp language-name)
- (setq language-name (symbol-name language-name)))
- (dolist (feature (get-language-info language-name 'features))
- (require feature))
- (let ((doc (get-language-info language-name 'documentation)))
- (help-setup-xref (list #'describe-language-environment language-name)
- (called-interactively-p 'interactive))
- (with-output-to-temp-buffer (help-buffer)
- (with-current-buffer standard-output
- (insert language-name " language environment\n\n")
- (if (stringp doc)
- (insert (substitute-command-keys doc) "\n\n"))
- (condition-case nil
- (let ((str (eval (get-language-info language-name 'sample-text))))
- (if (stringp str)
- (insert "Sample text:\n "
- (string-replace "\n" "\n " str)
- "\n\n")))
- (error nil))
- (let ((input-method (get-language-info language-name 'input-method))
- (l (copy-sequence input-method-alist))
- (first t))
- (when (and input-method
- (setq input-method (assoc input-method l)))
- (insert "Input methods (default " (car input-method) ")\n")
- (setq l (cons input-method (delete input-method l))
- first nil))
- (dolist (elt l)
- (when (or (eq input-method elt)
- (eq t (compare-strings language-name nil nil
- (nth 1 elt) nil nil t)))
- (when first
- (insert "Input methods:\n")
- (setq first nil))
- (insert " " (car elt))
- (search-backward (car elt))
- (help-xref-button 0 'help-input-method (car elt))
- (goto-char (point-max))
- (insert " (\""
- (if (stringp (nth 3 elt)) (nth 3 elt) (car (nth 3 elt)))
- "\" in mode line)\n")))
- (or first
- (insert "\n")))
- (insert "Character sets:\n")
- (let ((l (get-language-info language-name 'charset)))
- (if (null l)
- (insert " nothing specific to " language-name "\n")
- (while l
- (insert " " (symbol-name (car l)))
- (search-backward (symbol-name (car l)))
- (help-xref-button 0 'help-character-set (car l))
- (goto-char (point-max))
- (insert ": " (charset-description (car l)) "\n")
- (setq l (cdr l)))))
- (insert "\n")
- (insert "Coding systems:\n")
- (let ((l (get-language-info language-name 'coding-system)))
- (if (null l)
- (insert " nothing specific to " language-name "\n")
- (while l
- (insert " " (symbol-name (car l)))
- (search-backward (symbol-name (car l)))
- (help-xref-button 0 'help-coding-system (car l))
- (goto-char (point-max))
- (insert (substitute-command-keys " (`")
- (coding-system-mnemonic (car l))
- (substitute-command-keys "' in mode line):\n\t")
- (substitute-command-keys
- (coding-system-doc-string (car l)))
- "\n")
- (let ((aliases (coding-system-aliases (car l))))
- (when aliases
- (insert "\t(alias:")
- (while aliases
- (insert " " (symbol-name (car aliases)))
- (setq aliases (cdr aliases)))
- (insert ")\n")))
- (setq l (cdr l)))))))))
+ (let ((help-buffer-under-preparation t))
+ (if (null language-name)
+ (setq language-name current-language-environment))
+ (if (or (null language-name)
+ (null (get-language-info language-name 'documentation)))
+ (error "No documentation for the specified language"))
+ (if (symbolp language-name)
+ (setq language-name (symbol-name language-name)))
+ (dolist (feature (get-language-info language-name 'features))
+ (require feature))
+ (let ((doc (get-language-info language-name 'documentation)))
+ (help-setup-xref (list #'describe-language-environment language-name)
+ (called-interactively-p 'interactive))
+ (with-output-to-temp-buffer (help-buffer)
+ (with-current-buffer standard-output
+ (insert language-name " language environment\n\n")
+ (if (stringp doc)
+ (insert (substitute-command-keys doc) "\n\n"))
+ (condition-case nil
+ (let ((str (eval (get-language-info language-name 'sample-text))))
+ (if (stringp str)
+ (insert "Sample text:\n "
+ (string-replace "\n" "\n " str)
+ "\n\n")))
+ (error nil))
+ (let ((input-method (get-language-info language-name 'input-method))
+ (l (copy-sequence input-method-alist))
+ (first t))
+ (when (and input-method
+ (setq input-method (assoc input-method l)))
+ (insert "Input methods (default " (car input-method) ")\n")
+ (setq l (cons input-method (delete input-method l))
+ first nil))
+ (dolist (elt l)
+ (when (or (eq input-method elt)
+ (eq t (compare-strings language-name nil nil
+ (nth 1 elt) nil nil t)))
+ (when first
+ (insert "Input methods:\n")
+ (setq first nil))
+ (insert " " (car elt))
+ (search-backward (car elt))
+ (help-xref-button 0 'help-input-method (car elt))
+ (goto-char (point-max))
+ (insert " (\""
+ (if (stringp (nth 3 elt)) (nth 3 elt) (car (nth 3 elt)))
+ "\" in mode line)\n")))
+ (or first
+ (insert "\n")))
+ (insert "Character sets:\n")
+ (let ((l (get-language-info language-name 'charset)))
+ (if (null l)
+ (insert " nothing specific to " language-name "\n")
+ (while l
+ (insert " " (symbol-name (car l)))
+ (search-backward (symbol-name (car l)))
+ (help-xref-button 0 'help-character-set (car l))
+ (goto-char (point-max))
+ (insert ": " (charset-description (car l)) "\n")
+ (setq l (cdr l)))))
+ (insert "\n")
+ (insert "Coding systems:\n")
+ (let ((l (get-language-info language-name 'coding-system)))
+ (if (null l)
+ (insert " nothing specific to " language-name "\n")
+ (while l
+ (insert " " (symbol-name (car l)))
+ (search-backward (symbol-name (car l)))
+ (help-xref-button 0 'help-coding-system (car l))
+ (goto-char (point-max))
+ (insert (substitute-command-keys " (`")
+ (coding-system-mnemonic (car l))
+ (substitute-command-keys "' in mode line):\n\t")
+ (substitute-command-keys
+ (coding-system-doc-string (car l)))
+ "\n")
+ (let ((aliases (coding-system-aliases (car l))))
+ (when aliases
+ (insert "\t(alias:")
+ (while aliases
+ (insert " " (symbol-name (car aliases)))
+ (setq aliases (cdr aliases)))
+ (insert ")\n")))
+ (setq l (cdr l))))))))))
;;; Locales.
@@ -2665,6 +2667,20 @@ For example, translate \"swedish\" into \"sv_SE.ISO8859-1\"."
locale))
locale))
+(defvar current-locale-environment nil
+ "The currently set locale environment.")
+
+(defmacro with-locale-environment (locale-name &rest body)
+ "Execute BODY with the locale set to LOCALE-NAME."
+ (declare (indent 1) (debug (sexp def-body)))
+ (let ((current (gensym)))
+ `(let ((,current current-locale-environment))
+ (unwind-protect
+ (progn
+ (set-locale-environment ,locale-name)
+ ,@body)
+ (set-locale-environment ,current)))))
+
(defun set-locale-environment (&optional locale-name frame)
"Set up multilingual environment for using LOCALE-NAME.
This sets the language environment, the coding system priority,
@@ -2690,6 +2706,10 @@ If FRAME is non-nil, only set the keyboard coding system and the
terminal coding system for the terminal of that frame, and don't
touch session-global parameters like the language environment.
+This function sets the `current-locale-environment' variable. To
+change the locale temporarily, `with-locale-environment' can be
+used.
+
See also `locale-charset-language-names', `locale-language-names',
`locale-preferred-coding-systems' and `locale-coding-system'."
(interactive (list (completing-read "Set environment for locale: "
@@ -2723,6 +2743,7 @@ See also `locale-charset-language-names', `locale-language-names',
(when locale
(setq locale (locale-translate locale))
+ (setq current-locale-environment locale)
;; Leave the system locales alone if the caller did not specify
;; an explicit locale name, as their defaults are set from
@@ -2927,6 +2948,7 @@ Optional 3rd argument DOCSTRING is a documentation string of the property.
See also the documentation of `get-char-code-property' and
`put-char-code-property'."
+ (declare (indent defun))
(or (symbolp name)
(error "Not a symbol: %s" name))
(if (char-table-p table)
@@ -3055,22 +3077,6 @@ on encoding."
0))
(substring enc2 i0 i2)))))
-;; Backwards compatibility. These might be better with :init-value t,
-;; but that breaks loadup.
-(define-minor-mode unify-8859-on-encoding-mode
- "Exists only for backwards compatibility."
- :group 'mule
- :global t)
-;; Doc said "obsolete" in 23.1, this statement only added in 24.1.
-(make-obsolete 'unify-8859-on-encoding-mode "don't use it." "23.1")
-
-(define-minor-mode unify-8859-on-decoding-mode
- "Exists only for backwards compatibility."
- :group 'mule
- :global t)
-;; Doc said "obsolete" in 23.1, this statement only added in 24.1.
-(make-obsolete 'unify-8859-on-decoding-mode "don't use it." "23.1")
-
(defvar ucs-names nil
"Hash table of cached CHAR-NAME keys to CHAR-CODE values.")
@@ -3238,5 +3244,116 @@ as names, not numbers."
(define-obsolete-function-alias 'ucs-insert 'insert-char "24.3")
(define-key ctl-x-map "8\r" 'insert-char)
+(define-key ctl-x-map "8e"
+ (define-keymap
+ "e" #'emoji-insert
+ "i" #'emoji-insert
+ "s" #'emoji-search
+ "d" #'emoji-describe
+ "r" #'emoji-recent
+ "l" #'emoji-list))
+
+(defface confusingly-reordered
+ '((((supports :underline (:style wave)))
+ :underline (:style wave :color "Red1"))
+ (t
+ :inherit warning))
+ "Face for highlighting text that was bidi-reordered in confusing ways."
+ :version "29.1")
+
+(defvar reorder-starters "[\u202A\u202B\u202D\u202E\u2066-\u2068]+"
+ "Regular expression for characters that start forced-reordered text.")
+(defvar reorder-enders "[\u202C\u2069]+\\|\n"
+ "Regular expression for characters that end forced-reordered text.")
+
+(autoload 'text-property-search-forward "text-property-search")
+(autoload 'prop-match-beginning "text-property-search")
+(autoload 'prop-match-end "text-property-search")
+
+(defun highlight-confusing-reorderings (beg end &optional remove)
+ "Highlight text in region that might be bidi-reordered in suspicious ways.
+This command find and highlights segments of buffer text that could have
+been reordered on display by using directional control characters, such
+as RLO and LRI, in a way that their display is deliberately meant to
+confuse the reader. These techniques can be used for obfuscating
+malicious source code. The suspicious stretches of buffer text are
+highlighted using the `confusingly-reordered' face.
+
+If the region is active, check the text inside the region. Otherwise
+check the entire buffer. When called from Lisp, pass BEG and END to
+specify the portion of the buffer to check.
+
+Optional argument REMOVE, if non-nil (interactively, prefix argument),
+means remove the highlighting from the region between BEG and END,
+or the active region if that is set."
+ (interactive
+ (if (use-region-p)
+ (list (region-beginning) (region-end) current-prefix-arg)
+ (list (point-min) (point-max) current-prefix-arg)))
+ (save-excursion
+ (if remove
+ (let (prop-match)
+ (goto-char beg)
+ (while (and
+ (setq prop-match
+ (text-property-search-forward 'font-lock-face
+ 'confusingly-reordered t))
+ (< (prop-match-beginning prop-match) end))
+ (with-silent-modifications
+ (remove-list-of-text-properties (prop-match-beginning prop-match)
+ (prop-match-end prop-match)
+ '(font-lock-face face mouse-face
+ help-echo)))))
+ (let ((count 0)
+ next)
+ (goto-char beg)
+ (while (setq next
+ (bidi-find-overridden-directionality
+ (point) end nil
+ (current-bidi-paragraph-direction)))
+ (goto-char next)
+ ;; We detect the problematic parts by watching directional
+ ;; properties of strong L2R and R2L characters. But
+ ;; malicious reordering in source buffers can, and usuually
+ ;; does, include syntactically-important punctuation
+ ;; characters. Those have "weak" directionality, so we
+ ;; cannot easily detect when they are affected in malicious
+ ;; ways. Therefore, once we find a strong directional
+ ;; character whose directionality was tweaked, we highlight
+ ;; the text around it, between the first bidi control
+ ;; character we find before it that starts an
+ ;; override/embedding/isolate, and the first control after
+ ;; it that ends these. This could sometimes highlight only
+ ;; part of the affected text. An alternative would be to
+ ;; find the first "starter" following BOL and the last
+ ;; "ender" before EOL, and highlight everything in between
+ ;; them -- this could sometimes highlight too much.
+ (let ((start
+ (save-excursion
+ (re-search-backward reorder-starters nil t)))
+ (finish
+ (save-excursion
+ (let ((fin (re-search-forward reorder-enders nil t)))
+ (if fin (1- fin)
+ (point-max))))))
+ (with-silent-modifications
+ (add-text-properties start finish
+ '(font-lock-face
+ confusingly-reordered
+ face confusingly-reordered
+ mouse-face highlight
+ help-echo "\
+This text is reordered on display in a way that could change its semantics;
+use \\[forward-char] and \\[backward-char] to see the actual order of characters.")))
+ (goto-char finish)
+ (setq count (1+ count))))
+ (message
+ (if (> count 0)
+ (ngettext
+ "Highlighted %d confusingly-reordered text string"
+ "Highlighted %d confusingly-reordered text strings"
+ count)
+ "No confusingly-reordered text strings were found")
+ count)))))
;;; mule-cmds.el ends here
diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el
index 9a68fce2e81..ec027e9a932 100644
--- a/lisp/international/mule-conf.el
+++ b/lisp/international/mule-conf.el
@@ -148,6 +148,7 @@
(defmacro define-iso-single-byte-charset (symbol iso-symbol name nickname
iso-ir iso-final
emacs-mule-id map)
+ (declare (indent defun))
`(progn
(define-charset ,symbol
,name
diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el
index 862c577bd5d..efb9296c110 100644
--- a/lisp/international/mule-diag.el
+++ b/lisp/international/mule-diag.el
@@ -299,65 +299,66 @@ meanings of these arguments."
(defun describe-character-set (charset)
"Display information about built-in character set CHARSET."
(interactive (list (read-charset "Charset: ")))
- (or (charsetp charset)
- (error "Invalid charset: %S" charset))
- (help-setup-xref (list #'describe-character-set charset)
- (called-interactively-p 'interactive))
- (with-output-to-temp-buffer (help-buffer)
- (with-current-buffer standard-output
- (insert "Character set: " (symbol-name charset))
- (let ((name (get-charset-property charset :name)))
- (if (not (eq name charset))
- (insert " (alias of " (symbol-name name) ?\))))
- (insert "\n\n" (charset-description charset) "\n\n")
- (insert "Number of contained characters: ")
- (dotimes (i (charset-dimension charset))
- (unless (= i 0)
- (insert ?x))
- (insert (format "%d" (charset-chars charset (1+ i)))))
- (insert ?\n)
- (let ((char (charset-iso-final-char charset)))
- (when (> char 0)
- (insert "Final char of ISO2022 designation sequence: ")
- (insert (format-message "`%c'\n" char))))
- (let (aliases)
- (dolist (c charset-list)
- (if (and (not (eq c charset))
- (eq charset (get-charset-property c :name)))
- (push c aliases)))
- (if aliases
- (insert "Aliases: " (mapconcat #'symbol-name aliases ", ") ?\n)))
-
- (dolist (elt `((:ascii-compatible-p "ASCII compatible." nil)
- (:map "Map file: " identity)
- (:unify-map "Unification map file: " identity)
- (:invalid-code
- nil
- ,(lambda (c)
- (format "Invalid character: %c (code %d)" c c)))
- (:emacs-mule-id "Id in emacs-mule coding system: "
- number-to-string)
- (:parents "Parents: "
- (lambda (parents)
- (mapconcat ,(lambda (elt)
- (format "%s" elt))
- parents
- ", ")))
- (:code-space "Code space: " ,(lambda (c)
- (format "%s" c)))
- (:code-offset "Code offset: " number-to-string)
- (:iso-revision-number "ISO revision number: "
- number-to-string)
- (:supplementary-p
- "Used only as a parent or a subset of some other charset,
+ (let ((help-buffer-under-preparation t))
+ (or (charsetp charset)
+ (error "Invalid charset: %S" charset))
+ (help-setup-xref (list #'describe-character-set charset)
+ (called-interactively-p 'interactive))
+ (with-output-to-temp-buffer (help-buffer)
+ (with-current-buffer standard-output
+ (insert "Character set: " (symbol-name charset))
+ (let ((name (get-charset-property charset :name)))
+ (if (not (eq name charset))
+ (insert " (alias of " (symbol-name name) ?\))))
+ (insert "\n\n" (charset-description charset) "\n\n")
+ (insert "Number of contained characters: ")
+ (dotimes (i (charset-dimension charset))
+ (unless (= i 0)
+ (insert ?x))
+ (insert (format "%d" (charset-chars charset (1+ i)))))
+ (insert ?\n)
+ (let ((char (charset-iso-final-char charset)))
+ (when (> char 0)
+ (insert "Final char of ISO2022 designation sequence: ")
+ (insert (format-message "`%c'\n" char))))
+ (let (aliases)
+ (dolist (c charset-list)
+ (if (and (not (eq c charset))
+ (eq charset (get-charset-property c :name)))
+ (push c aliases)))
+ (if aliases
+ (insert "Aliases: " (mapconcat #'symbol-name aliases ", ") ?\n)))
+
+ (dolist (elt `((:ascii-compatible-p "ASCII compatible." nil)
+ (:map "Map file: " identity)
+ (:unify-map "Unification map file: " identity)
+ (:invalid-code
+ nil
+ ,(lambda (c)
+ (format "Invalid character: %c (code %d)" c c)))
+ (:emacs-mule-id "Id in emacs-mule coding system: "
+ number-to-string)
+ (:parents "Parents: "
+ (lambda (parents)
+ (mapconcat ,(lambda (elt)
+ (format "%s" elt))
+ parents
+ ", ")))
+ (:code-space "Code space: " ,(lambda (c)
+ (format "%s" c)))
+ (:code-offset "Code offset: " number-to-string)
+ (:iso-revision-number "ISO revision number: "
+ number-to-string)
+ (:supplementary-p
+ "Used only as a parent or a subset of some other charset,
or provided just for backward compatibility." nil)))
- (let ((val (get-charset-property charset (car elt))))
- (when val
- (if (cadr elt) (insert (cadr elt)))
- (if (nth 2 elt)
- (let ((print-length 10) (print-level 2))
- (princ (funcall (nth 2 elt) val) (current-buffer))))
- (insert ?\n)))))))
+ (let ((val (get-charset-property charset (car elt))))
+ (when val
+ (if (cadr elt) (insert (cadr elt)))
+ (if (nth 2 elt)
+ (let ((print-length 10) (print-level 2))
+ (princ (funcall (nth 2 elt) val) (current-buffer))))
+ (insert ?\n))))))))
;;; CODING-SYSTEM
@@ -406,89 +407,90 @@ or provided just for backward compatibility." nil)))
(defun describe-coding-system (coding-system)
"Display information about CODING-SYSTEM."
(interactive "zDescribe coding system (default current choices): ")
- (if (null coding-system)
- (describe-current-coding-system)
- (help-setup-xref (list #'describe-coding-system coding-system)
- (called-interactively-p 'interactive))
- (with-output-to-temp-buffer (help-buffer)
- (print-coding-system-briefly coding-system 'doc-string)
- (let ((type (coding-system-type coding-system))
- ;; Fixme: use this
- ;; (extra-spec (coding-system-plist coding-system))
- )
- (princ "Type: ")
- (princ type)
- (cond ((eq type 'undecided)
- (princ " (do automatic conversion)"))
- ((eq type 'utf-8)
- (princ " (UTF-8: Emacs internal multibyte form)"))
- ((eq type 'utf-16)
- ;; (princ " (UTF-16)")
- )
- ((eq type 'shift-jis)
- (princ " (Shift-JIS, MS-KANJI)"))
- ((eq type 'iso-2022)
- (princ " (variant of ISO-2022)\n")
- (princ "Initial designations:\n")
- (print-designation (coding-system-get coding-system
- :designation))
-
- (when (coding-system-get coding-system :flags)
- (princ "Other specifications: \n ")
- (apply #'print-list
- (coding-system-get coding-system :flags))))
- ((eq type 'charset)
- (princ " (charset)"))
- ((eq type 'ccl)
- (princ " (do conversion by CCL program)"))
- ((eq type 'raw-text)
- (princ " (text with random binary characters)"))
- ((eq type 'emacs-mule)
- (princ " (Emacs 21 internal encoding)"))
- ((eq type 'big5))
- (t (princ ": invalid coding-system.")))
- (princ "\nEOL type: ")
- (let ((eol-type (coding-system-eol-type coding-system)))
- (cond ((vectorp eol-type)
- (princ "Automatic selection from:\n\t")
- (princ eol-type)
- (princ "\n"))
- ((or (null eol-type) (eq eol-type 0)) (princ "LF\n"))
- ((eq eol-type 1) (princ "CRLF\n"))
- ((eq eol-type 2) (princ "CR\n"))
- (t (princ "invalid\n")))))
- (let ((postread (coding-system-get coding-system :post-read-conversion)))
- (when postread
- (princ "After decoding text normally,")
- (princ " perform post-conversion using the function: ")
- (princ "\n ")
- (princ postread)
- (princ "\n")))
- (let ((prewrite (coding-system-get coding-system :pre-write-conversion)))
- (when prewrite
- (princ "Before encoding text normally,")
- (princ " perform pre-conversion using the function: ")
- (princ "\n ")
- (princ prewrite)
- (princ "\n")))
- (with-current-buffer standard-output
- (let ((charsets (coding-system-charset-list coding-system)))
- (when (and (not (eq (coding-system-base coding-system) 'raw-text))
- charsets)
- (cond
- ((eq charsets 'iso-2022)
- (insert "This coding system can encode all ISO 2022 charsets."))
- ((eq charsets 'emacs-mule)
- (insert "This coding system can encode all emacs-mule charsets\
+ (let ((help-buffer-under-preparation t))
+ (if (null coding-system)
+ (describe-current-coding-system)
+ (help-setup-xref (list #'describe-coding-system coding-system)
+ (called-interactively-p 'interactive))
+ (with-output-to-temp-buffer (help-buffer)
+ (print-coding-system-briefly coding-system 'doc-string)
+ (let ((type (coding-system-type coding-system))
+ ;; Fixme: use this
+ ;; (extra-spec (coding-system-plist coding-system))
+ )
+ (princ "Type: ")
+ (princ type)
+ (cond ((eq type 'undecided)
+ (princ " (do automatic conversion)"))
+ ((eq type 'utf-8)
+ (princ " (UTF-8: Emacs internal multibyte form)"))
+ ((eq type 'utf-16)
+ ;; (princ " (UTF-16)")
+ )
+ ((eq type 'shift-jis)
+ (princ " (Shift-JIS, MS-KANJI)"))
+ ((eq type 'iso-2022)
+ (princ " (variant of ISO-2022)\n")
+ (princ "Initial designations:\n")
+ (print-designation (coding-system-get coding-system
+ :designation))
+
+ (when (coding-system-get coding-system :flags)
+ (princ "Other specifications: \n ")
+ (apply #'print-list
+ (coding-system-get coding-system :flags))))
+ ((eq type 'charset)
+ (princ " (charset)"))
+ ((eq type 'ccl)
+ (princ " (do conversion by CCL program)"))
+ ((eq type 'raw-text)
+ (princ " (text with random binary characters)"))
+ ((eq type 'emacs-mule)
+ (princ " (Emacs 21 internal encoding)"))
+ ((eq type 'big5))
+ (t (princ ": invalid coding-system.")))
+ (princ "\nEOL type: ")
+ (let ((eol-type (coding-system-eol-type coding-system)))
+ (cond ((vectorp eol-type)
+ (princ "Automatic selection from:\n\t")
+ (princ eol-type)
+ (princ "\n"))
+ ((or (null eol-type) (eq eol-type 0)) (princ "LF\n"))
+ ((eq eol-type 1) (princ "CRLF\n"))
+ ((eq eol-type 2) (princ "CR\n"))
+ (t (princ "invalid\n")))))
+ (let ((postread (coding-system-get coding-system :post-read-conversion)))
+ (when postread
+ (princ "After decoding text normally,")
+ (princ " perform post-conversion using the function: ")
+ (princ "\n ")
+ (princ postread)
+ (princ "\n")))
+ (let ((prewrite (coding-system-get coding-system :pre-write-conversion)))
+ (when prewrite
+ (princ "Before encoding text normally,")
+ (princ " perform pre-conversion using the function: ")
+ (princ "\n ")
+ (princ prewrite)
+ (princ "\n")))
+ (with-current-buffer standard-output
+ (let ((charsets (coding-system-charset-list coding-system)))
+ (when (and (not (eq (coding-system-base coding-system) 'raw-text))
+ charsets)
+ (cond
+ ((eq charsets 'iso-2022)
+ (insert "This coding system can encode all ISO 2022 charsets."))
+ ((eq charsets 'emacs-mule)
+ (insert "This coding system can encode all emacs-mule charsets\
."""))
- (t
- (insert "This coding system encodes the following charsets:\n ")
- (while charsets
- (insert " " (symbol-name (car charsets)))
- (search-backward (symbol-name (car charsets)))
- (help-xref-button 0 'help-character-set (car charsets))
- (goto-char (point-max))
- (setq charsets (cdr charsets)))))))))))
+ (t
+ (insert "This coding system encodes the following charsets:\n ")
+ (while charsets
+ (insert " " (symbol-name (car charsets)))
+ (search-backward (symbol-name (car charsets)))
+ (help-xref-button 0 'help-character-set (car charsets))
+ (goto-char (point-max))
+ (setq charsets (cdr charsets))))))))))))
;;;###autoload
(defun describe-current-coding-system-briefly ()
@@ -833,7 +835,7 @@ The IGNORED argument is ignored."
"Display information about a font whose name is FONTNAME."
(interactive
(list (completing-read
- "Font name (default current choice for ASCII chars): "
+ (format-prompt "Font name" "current choice for ASCII chars")
(and window-system
;; Implied by `window-system'.
(fboundp 'x-list-fonts)
@@ -845,7 +847,8 @@ The IGNORED argument is ignored."
(or (and window-system (fboundp 'fontset-list))
(error "No fonts being used"))
(let ((xref-item (list #'describe-font fontname))
- font-info)
+ font-info
+ (help-buffer-under-preparation t))
(if (or (not fontname) (= (length fontname) 0))
(setq fontname (face-attribute 'default :font)))
(setq font-info (font-info fontname))
@@ -1004,16 +1007,17 @@ This shows which font is used for which character(s)."
(mapcar 'cdr fontset-alias-alist)))
(completion-ignore-case t))
(list (completing-read
- "Fontset (default used by the current frame): "
+ (format-prompt "Fontset" "used by the current frame")
fontset-list nil t)))))
- (if (= (length fontset) 0)
- (setq fontset (face-attribute 'default :fontset))
- (setq fontset (query-fontset fontset)))
- (help-setup-xref (list #'describe-fontset fontset)
- (called-interactively-p 'interactive))
- (with-output-to-temp-buffer (help-buffer)
- (with-current-buffer standard-output
- (print-fontset fontset t))))
+ (let ((help-buffer-under-preparation t))
+ (if (= (length fontset) 0)
+ (setq fontset (face-attribute 'default :fontset))
+ (setq fontset (query-fontset fontset)))
+ (help-setup-xref (list #'describe-fontset fontset)
+ (called-interactively-p 'interactive))
+ (with-output-to-temp-buffer (help-buffer)
+ (with-current-buffer standard-output
+ (print-fontset fontset t)))))
(declare-function fontset-plain-name "fontset" (fontset))
@@ -1024,39 +1028,41 @@ This shows the name, size, and style of each fontset.
With prefix arg, also list the fonts contained in each fontset;
see the function `describe-fontset' for the format of the list."
(interactive "P")
- (if (not (and window-system (fboundp 'fontset-list)))
- (error "No fontsets being used")
- (help-setup-xref (list #'list-fontsets arg)
- (called-interactively-p 'interactive))
- (with-output-to-temp-buffer (help-buffer)
- (with-current-buffer standard-output
- ;; This code is duplicated near the end of mule-diag.
- (let ((fontsets
- (sort (fontset-list)
- (lambda (x y)
- (string< (fontset-plain-name x)
- (fontset-plain-name y))))))
- (while fontsets
- (if arg
- (print-fontset (car fontsets) nil)
- (insert "Fontset: " (car fontsets) "\n"))
- (setq fontsets (cdr fontsets))))))))
+ (let ((help-buffer-under-preparation t))
+ (if (not (and window-system (fboundp 'fontset-list)))
+ (error "No fontsets being used")
+ (help-setup-xref (list #'list-fontsets arg)
+ (called-interactively-p 'interactive))
+ (with-output-to-temp-buffer (help-buffer)
+ (with-current-buffer standard-output
+ ;; This code is duplicated near the end of mule-diag.
+ (let ((fontsets
+ (sort (fontset-list)
+ (lambda (x y)
+ (string< (fontset-plain-name x)
+ (fontset-plain-name y))))))
+ (while fontsets
+ (if arg
+ (print-fontset (car fontsets) nil)
+ (insert "Fontset: " (car fontsets) "\n"))
+ (setq fontsets (cdr fontsets)))))))))
;;;###autoload
(defun list-input-methods ()
"Display information about all input methods."
(interactive)
- (help-setup-xref '(list-input-methods)
- (called-interactively-p 'interactive))
- (with-output-to-temp-buffer (help-buffer)
- (list-input-methods-1)
- (with-current-buffer standard-output
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward
- (substitute-command-keys "^ \\([^ ]+\\) (`.*' in mode line)$")
- nil t)
- (help-xref-button 1 'help-input-method (match-string 1)))))))
+ (let ((help-buffer-under-preparation t))
+ (help-setup-xref '(list-input-methods)
+ (called-interactively-p 'interactive))
+ (with-output-to-temp-buffer (help-buffer)
+ (list-input-methods-1)
+ (with-current-buffer standard-output
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward
+ (substitute-command-keys "^ \\([^ ]+\\) (`.*' in mode line)$")
+ nil t)
+ (help-xref-button 1 'help-input-method (match-string 1))))))))
(defun list-input-methods-1 ()
(if (not input-method-alist)
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index 5022a17db5a..3e45a64dc9a 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -218,6 +218,7 @@ corresponding Unicode character code.
If it is a string, it is a name of file that contains the above
information. The file format is the same as what described for `:map'
attribute."
+ (declare (indent defun))
(when (vectorp (car props))
;; Old style code:
;; (define-charset CHARSET-ID CHARSET-SYMBOL INFO-VECTOR)
@@ -890,6 +891,7 @@ non-nil.
VALUE non-nil means Emacs prefers UTF-8 on code detection for
non-ASCII files. This attribute is meaningful only when
`:coding-type' is `undecided'."
+ (declare (indent defun))
(let* ((common-attrs (mapcar 'list
'(:mnemonic
:coding-type
@@ -2320,6 +2322,7 @@ This function sets properties `translation-table' and
`translation-table-id' of SYMBOL to the created table itself and the
identification number of the table respectively. It also registers
the table in `translation-table-vector'."
+ (declare (indent defun))
(let ((table (if (and (char-table-p (car args))
(eq (char-table-subtype (car args))
'translation-table))
@@ -2394,6 +2397,7 @@ Value is what BODY returns."
Analogous to `define-translation-table', but updates
`translation-hash-table-vector' and the table is for use in the CCL
`lookup-integer' and `lookup-character' functions."
+ (declare (indent defun))
(unless (and (symbolp symbol)
(hash-table-p table))
(error "Bad args to define-translation-hash-table"))
diff --git a/lisp/international/quail.el b/lisp/international/quail.el
index ee935b11ec0..5cdd6d6242b 100644
--- a/lisp/international/quail.el
+++ b/lisp/international/quail.el
@@ -917,7 +917,7 @@ The format of KBD-LAYOUT is the same as `quail-keyboard-layout'."
The variable `quail-keyboard-layout-type' holds the currently selected
keyboard type."
(interactive
- (list (completing-read "Keyboard type (default current choice): "
+ (list (completing-read (format-prompt "Keyboard type" "current choice")
quail-keyboard-layout-alist
nil t)))
(or (and keyboard-type (> (length keyboard-type) 0))
diff --git a/lisp/international/robin.el b/lisp/international/robin.el
index c38cd822693..4c498d7f923 100644
--- a/lisp/international/robin.el
+++ b/lisp/international/robin.el
@@ -529,10 +529,10 @@ Use the longest match method to select a rule."
(insert (cadr tree))
(delete-char (- end begin)))))
-;; for backward compatibility
-
-(fset 'robin-transliterate-region 'robin-convert-region)
-(fset 'robin-transliterate-buffer 'robin-convert-buffer)
+(define-obsolete-function-alias 'robin-transliterate-region
+ #'robin-convert-region "29.1")
+(define-obsolete-function-alias 'robin-transliterate-buffer
+ #'robin-convert-buffer "29.1")
;;; Reverse conversion
diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el
index 0f8dedfc09b..3da47e701ab 100644
--- a/lisp/international/ucs-normalize.el
+++ b/lisp/international/ucs-normalize.el
@@ -536,74 +536,124 @@ COMPOSITION-PREDICATE will be used to compose region."
(,ucs-normalize-region (point-min) (point-max))
(buffer-string)))
-;;;###autoload
(defun ucs-normalize-NFD-region (from to)
- "Normalize the current region by the Unicode NFD."
+ "Decompose the region between FROM and TO according to the Unicode NFD.
+This replaces the text between FROM and TO with its canonical decomposition,
+a.k.a. the \"Unicode Normalization Form D\"."
(interactive "r")
(ucs-normalize-region from to
ucs-normalize-nfd-quick-check-regexp
'ucs-normalize-nfd-table nil))
-;;;###autoload
+
(defun ucs-normalize-NFD-string (str)
- "Normalize the string STR by the Unicode NFD."
+ "Decompose the string STR according to the Unicode NFD.
+This returns a new string that is the canonical decomposition of STR,
+a.k.a. the \"Unicode Normalization Form D\" of STR. For instance:
+
+ (ucs-normalize-NFD-string \"Å\") => \"Å\""
(ucs-normalize-string ucs-normalize-NFD-region))
-;;;###autoload
(defun ucs-normalize-NFC-region (from to)
- "Normalize the current region by the Unicode NFC."
+ "Compose the region between FROM and TO according to the Unicode NFC.
+This replaces the text between FROM and TO with the result of its
+canonical decomposition (see `ucs-normalize-NFD-region') followed by
+canonical composition, a.k.a. the \"Unicode Normalization Form C\"."
(interactive "r")
(ucs-normalize-region from to
ucs-normalize-nfc-quick-check-regexp
'ucs-normalize-nfd-table t))
+
;;;###autoload
+(defun string-glyph-compose (string)
+ "Compose STRING according to the Unicode NFC.
+This returns a new string obtained by canonical decomposition
+of STRING (see `ucs-normalize-NFC-string') followed by canonical
+composition, a.k.a. the \"Unicode Normalization Form C\" of STRING.
+For instance:
+
+ (string-glyph-compose \"Å\") => \"Å\""
+ (ucs-normalize-NFC-string string))
+
+;;;###autoload
+(defun string-glyph-decompose (string)
+ "Decompose STRING according to the Unicode NFD.
+This returns a new string that is the canonical decomposition of STRING,
+a.k.a. the \"Unicode Normalization Form D\" of STRING. For instance:
+
+ (ucs-normalize-NFD-string \"Å\") => \"Å\""
+ (ucs-normalize-NFD-string string))
+
(defun ucs-normalize-NFC-string (str)
- "Normalize the string STR by the Unicode NFC."
+ "Compose STR according to the Unicode NFC.
+This returns a new string obtained by canonical decomposition
+of STR (see `ucs-normalize-NFC-string') followed by canonical
+composition, a.k.a. the \"Unicode Normalization Form C\" of STR.
+For instance:
+
+ (string-glyph-compose \"Å\") => \"Å\""
(ucs-normalize-string ucs-normalize-NFC-region))
-;;;###autoload
(defun ucs-normalize-NFKD-region (from to)
- "Normalize the current region by the Unicode NFKD."
+ "Decompose the region between FROM and TO according to the Unicode NFKD.
+This replaces the text between FROM and TO with its compatibility
+decomposition, a.k.a. \"Unicode Normalization Form KD\"."
(interactive "r")
(ucs-normalize-region from to
ucs-normalize-nfkd-quick-check-regexp
'ucs-normalize-nfkd-table nil))
-;;;###autoload
+
(defun ucs-normalize-NFKD-string (str)
- "Normalize the string STR by the Unicode NFKD."
+ "Decompose the string STR according to the Unicode NFKD.
+This returns a new string obtained by compatibility decomposition
+of STR. This is much like the NFD (canonical decomposition) form,
+see `ucs-normalize-NFD-string', but mainly differs for precomposed
+characters. For instance:
+
+ (ucs-normalize-NFD-string \"fi\") => \"fi\"
+ (ucs-normalize-NFKD-string \"fi\") = \"fi\""
(ucs-normalize-string ucs-normalize-NFKD-region))
-;;;###autoload
(defun ucs-normalize-NFKC-region (from to)
- "Normalize the current region by the Unicode NFKC."
+ "Compose the region between FROM and TO according to the Unicode NFKC.
+This replaces the text between FROM and TO with the result of its
+compatibility decomposition (see `ucs-normalize-NFC-region') followed by
+canonical composition, a.k.a. the \"Unicode Normalization Form KC\"."
(interactive "r")
(ucs-normalize-region from to
ucs-normalize-nfkc-quick-check-regexp
'ucs-normalize-nfkd-table t))
-;;;###autoload
+
(defun ucs-normalize-NFKC-string (str)
- "Normalize the string STR by the Unicode NFKC."
+ "Compose STR according to the Unicode NFC.
+This returns a new string obtained by compatibility decomposition
+of STR (see `ucs-normalize-NFKD-string') followed by canonical
+composition, a.k.a. the \"Unicode Normalization Form KC\" of STR.
+This is much like the NFC (canonical composition) form, but mainly
+differs for precomposed characters. For instance:
+
+ (ucs-normalize-NFC-string \"fi\") => \"fi\"
+ (ucs-normalize-NFKC-string \"fi\") = \"fi\""
(ucs-normalize-string ucs-normalize-NFKC-region))
-;;;###autoload
(defun ucs-normalize-HFS-NFD-region (from to)
- "Normalize the current region by the Unicode NFD and Mac OS's HFS Plus."
+ "Normalize region between FROM and TO by Unicode NFD and Mac OS's HFS Plus."
(interactive "r")
(ucs-normalize-region from to
ucs-normalize-hfs-nfd-quick-check-regexp
'ucs-normalize-hfs-nfd-table
'ucs-normalize-hfs-nfd-comp-p))
-;;;###autoload
+
(defun ucs-normalize-HFS-NFD-string (str)
"Normalize the string STR by the Unicode NFD and Mac OS's HFS Plus."
(ucs-normalize-string ucs-normalize-HFS-NFD-region))
-;;;###autoload
+
(defun ucs-normalize-HFS-NFC-region (from to)
- "Normalize the current region by the Unicode NFC and Mac OS's HFS Plus."
+ "Normalize region between FROM and TO by Unicode NFC and Mac OS's HFS Plus."
(interactive "r")
(ucs-normalize-region from to
ucs-normalize-hfs-nfc-quick-check-regexp
'ucs-normalize-hfs-nfd-table t))
-;;;###autoload
+
(defun ucs-normalize-HFS-NFC-string (str)
"Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus."
(ucs-normalize-string ucs-normalize-HFS-NFC-region))
diff --git a/lisp/isearch.el b/lisp/isearch.el
index c382d0ad2a0..9e144ac2729 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -488,9 +488,9 @@ and doesn't remove full-buffer highlighting after a search."
"You have typed %THIS-KEY%, the help character. Type a Help option:
\(Type \\<isearch-help-map>\\[help-quit] to exit the Help command.)
-\\[isearch-describe-bindings] Display all Isearch key bindings.
-\\[isearch-describe-key] KEYS Display full documentation of Isearch key sequence.
-\\[isearch-describe-mode] Display documentation of Isearch mode.
+ \\[isearch-describe-bindings] Display all Isearch key bindings.
+ \\[isearch-describe-key] Display full documentation of Isearch key sequence.
+ \\[isearch-describe-mode] Display documentation of Isearch mode.
You can't type here other help keys available in the global help map,
but outside of this help window when you type them in Isearch mode,
@@ -2063,7 +2063,7 @@ The command then executes BODY and updates the isearch prompt."
#',function))
(setq isearch-regexp nil)))
,@body
- (setq isearch-success t isearch-adjusted t)
+ (setq isearch-success t isearch-adjusted 'toggle)
(isearch-update))
(define-key isearch-mode-map ,key #',command-name)
,@(when (and function (symbolp function))
@@ -2478,8 +2478,8 @@ The arguments passed to `highlight-regexp' are the regexp from
the last search and the face from `hi-lock-read-face-name'."
(interactive)
(isearch--highlight-regexp-or-lines
- #'(lambda (regexp face lighter)
- (highlight-regexp regexp face nil lighter))))
+ (lambda (regexp face lighter)
+ (highlight-regexp regexp face nil lighter))))
(defun isearch-highlight-lines-matching-regexp ()
"Exit Isearch mode and call `highlight-lines-matching-regexp'.
@@ -2487,8 +2487,8 @@ The arguments passed to `highlight-lines-matching-regexp' are the
regexp from the last search and the face from `hi-lock-read-face-name'."
(interactive)
(isearch--highlight-regexp-or-lines
- #'(lambda (regexp face _lighter)
- (highlight-lines-matching-regexp regexp face))))
+ (lambda (regexp face _lighter)
+ (highlight-lines-matching-regexp regexp face))))
(defun isearch-delete-char ()
@@ -2504,6 +2504,11 @@ If no input items have been entered yet, just beep."
(if (null (cdr isearch-cmds))
(ding)
(isearch-pop-state))
+ ;; When going back to the hidden match, reopen it.
+ (when (and (eq search-invisible 'open) isearch-hide-immediately
+ isearch-other-end)
+ (isearch-range-invisible (min (point) isearch-other-end)
+ (max (point) isearch-other-end)))
(isearch-update))
(defun isearch-del-char (&optional arg)
@@ -3412,7 +3417,7 @@ the word mode."
;; If currently failing, display no ellipsis.
(or isearch-success (setq ellipsis nil))
(let ((m (concat (if isearch-success "" "failing ")
- (if isearch-adjusted "pending " "")
+ (if (eq isearch-adjusted t) "pending " "")
(if (and isearch-wrapped
(not isearch-wrap-function)
(if isearch-forward
@@ -3516,10 +3521,10 @@ Can be changed via `isearch-search-fun-function' for special needs."
;; (Bug#35802).
(regexp
(cond (isearch-regexp-function
- (let ((lax (and (not bound)
+ (let ((lax (and (not bound) ; not lazy-highlight
(isearch--lax-regexp-function-p))))
(when lax
- (setq isearch-adjusted t))
+ (setq isearch-adjusted 'lax))
(if (functionp isearch-regexp-function)
(funcall isearch-regexp-function string lax)
(word-search-regexp string lax))))
@@ -3787,8 +3792,9 @@ Isearch, at least partially, as determined by `isearch-range-invisible'.
If `search-invisible' is t, which allows Isearch matches inside
invisible text, this function will always return non-nil, regardless
of what `isearch-range-invisible' says."
- (or (eq search-invisible t)
- (not (isearch-range-invisible beg end))))
+ (and (not (text-property-not-all beg end 'inhibit-isearch nil))
+ (or (eq search-invisible t)
+ (not (isearch-range-invisible beg end)))))
;; General utilities
diff --git a/lisp/keymap.el b/lisp/keymap.el
new file mode 100644
index 00000000000..fd91689f887
--- /dev/null
+++ b/lisp/keymap.el
@@ -0,0 +1,457 @@
+;;; keymap.el --- Keymap functions -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 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 library deals with the "new" keymap binding interface: The
+;; only key syntax allowed by these functions is the `kbd' one.
+
+;;; Code:
+
+
+
+(defun keymap--check (key)
+ "Signal an error if KEY doesn't have a valid syntax."
+ (unless (key-valid-p key)
+ (error "%S is not a valid key definition; see `key-valid-p'" key)))
+
+(defun keymap--compile-check (&rest keys)
+ (dolist (key keys)
+ (when (or (vectorp key)
+ (and (stringp key) (not (key-valid-p key))))
+ (byte-compile-warn "Invalid `kbd' syntax: %S" key))))
+
+(defun keymap-set (keymap key definition)
+ "Set key sequence KEY to DEFINITION in KEYMAP.
+KEY is a string that satisfies `key-valid-p'.
+
+DEFINITION is anything that can be a key's definition:
+ nil (means key is undefined in this keymap),
+ a command (a Lisp function suitable for interactive calling),
+ a string (treated as a keyboard macro),
+ a keymap (to define a prefix key),
+ a symbol (when the key is looked up, the symbol will stand for its
+ function definition, which should at that time be one of the above,
+ or another symbol whose function definition is used, etc.),
+ a cons (STRING . DEFN), meaning that DEFN is the definition
+ (DEFN should be a valid definition in its own right) and
+ STRING is the menu item name (which is used only if the containing
+ keymap has been created with a menu name, see `make-keymap'),
+ or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP,
+ or an extended menu item definition.
+ (See info node `(elisp)Extended Menu Items'.)"
+ (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
+ (keymap--check key)
+ ;; If we're binding this key to another key, then parse that other
+ ;; key, too.
+ (when (stringp definition)
+ (keymap--check definition)
+ (setq definition (key-parse definition)))
+ (define-key keymap (key-parse key) definition))
+
+(defun keymap-global-set (key command)
+ "Give KEY a global binding as COMMAND.
+COMMAND is the command definition to use; usually it is
+a symbol naming an interactively-callable function.
+
+KEY is a string that satisfies `key-valid-p'.
+
+Note that if KEY has a local binding in the current buffer,
+that local binding will continue to shadow any global binding
+that you make with this function."
+ (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
+ (interactive
+ (let* ((menu-prompting nil)
+ (key (read-key-sequence "Set key globally: " nil t)))
+ (list key
+ (read-command (format "Set key %s to command: "
+ (key-description key))))))
+ (keymap-set (current-global-map) key command))
+
+(defun keymap-local-set (key command)
+ "Give KEY a local binding as COMMAND.
+COMMAND is the command definition to use; usually it is
+a symbol naming an interactively-callable function.
+
+KEY is a string that satisfies `key-valid-p'.
+
+The binding goes in the current buffer's local map, which in most
+cases is shared with all other buffers in the same major mode."
+ (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
+ (interactive "KSet key locally: \nCSet key %s locally to command: ")
+ (let ((map (current-local-map)))
+ (unless map
+ (use-local-map (setq map (make-sparse-keymap))))
+ (keymap-set map key command)))
+
+(defun keymap-global-unset (key &optional remove)
+ "Remove global binding of KEY (if any).
+KEY is a string that satisfies `key-valid-p'.
+
+If REMOVE (interactively, the prefix arg), remove the binding
+instead of unsetting it. See `keymap-unset' for details."
+ (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
+ (interactive
+ (list (key-description (read-key-sequence "Set key locally: "))
+ current-prefix-arg))
+ (keymap-unset (current-global-map) key remove))
+
+(defun keymap-local-unset (key &optional remove)
+ "Remove local binding of KEY (if any).
+KEY is a string that satisfies `key-valid-p'.
+
+If REMOVE (interactively, the prefix arg), remove the binding
+instead of unsetting it. See `keymap-unset' for details."
+ (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
+ (interactive
+ (list (key-description (read-key-sequence "Unset key locally: "))
+ current-prefix-arg))
+ (when (current-local-map)
+ (keymap-unset (current-local-map) key remove)))
+
+(defun keymap-unset (keymap key &optional remove)
+ "Remove key sequence KEY from KEYMAP.
+KEY is a string that satisfies `key-valid-p'.
+
+If REMOVE, remove the binding instead of unsetting it. This only
+makes a difference when there's a parent keymap. When unsetting
+a key in a child map, it will still shadow the same key in the
+parent keymap. Removing the binding will allow the key in the
+parent keymap to be used."
+ (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
+ (keymap--check key)
+ (define-key keymap (key-parse key) nil remove))
+
+(defun keymap-substitute (keymap olddef newdef &optional oldmap prefix)
+ "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
+In other words, OLDDEF is replaced with NEWDEF wherever it appears.
+Alternatively, if optional fourth argument OLDMAP is specified, we redefine
+in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP.
+
+If you don't specify OLDMAP, you can usually get the same results
+in a cleaner way with command remapping, like this:
+ (define-key KEYMAP [remap OLDDEF] NEWDEF)
+\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)"
+ ;; Don't document PREFIX in the doc string because we don't want to
+ ;; advertise it. It's meant for recursive calls only. Here's its
+ ;; meaning
+
+ ;; If optional argument PREFIX is specified, it should be a key
+ ;; prefix, a string. Redefined bindings will then be bound to the
+ ;; original key, with PREFIX added at the front.
+ (unless prefix
+ (setq prefix ""))
+ (let* ((scan (or oldmap keymap))
+ (prefix1 (vconcat prefix [nil]))
+ (key-substitution-in-progress
+ (cons scan key-substitution-in-progress)))
+ ;; Scan OLDMAP, finding each char or event-symbol that
+ ;; has any definition, and act on it with hack-key.
+ (map-keymap
+ (lambda (char defn)
+ (aset prefix1 (length prefix) char)
+ (substitute-key-definition-key defn olddef newdef prefix1 keymap))
+ scan)))
+
+(defun keymap-set-after (keymap key definition &optional after)
+ "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
+This is like `keymap-set' except that the binding for KEY is placed
+just after the binding for the event AFTER, instead of at the beginning
+of the map. Note that AFTER must be an event type (like KEY), NOT a command
+\(like DEFINITION).
+
+If AFTER is t or omitted, the new binding goes at the end of the keymap.
+AFTER should be a single event type--a symbol or a character, not a sequence.
+
+Bindings are always added before any inherited map.
+
+The order of bindings in a keymap matters only when it is used as
+a menu, so this function is not useful for non-menu keymaps."
+ (declare (indent defun)
+ (compiler-macro (lambda (form) (keymap--compile-check key) form)))
+ (keymap--check key)
+ (when after
+ (keymap--check after))
+ (define-key-after keymap (key-parse key) definition
+ (and after (key-parse after))))
+
+(defun key-parse (keys)
+ "Convert KEYS to the internal Emacs key representation.
+See `kbd' for a descripion of KEYS."
+ (declare (pure t) (side-effect-free t))
+ ;; A pure function is expected to preserve the match data.
+ (save-match-data
+ (let ((case-fold-search nil)
+ (len (length keys)) ; We won't alter keys in the loop below.
+ (pos 0)
+ (res []))
+ (while (and (< pos len)
+ (string-match "[^ \t\n\f]+" keys pos))
+ (let* ((word-beg (match-beginning 0))
+ (word-end (match-end 0))
+ (word (substring keys word-beg len))
+ (times 1)
+ key)
+ ;; Try to catch events of the form "<as df>".
+ (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word)
+ (setq word (match-string 0 word)
+ pos (+ word-beg (match-end 0)))
+ (setq word (substring keys word-beg word-end)
+ pos word-end))
+ (when (string-match "\\([0-9]+\\)\\*." word)
+ (setq times (string-to-number (substring word 0 (match-end 1))))
+ (setq word (substring word (1+ (match-end 1)))))
+ (cond ((string-match "^<<.+>>$" word)
+ (setq key (vconcat (if (eq (key-binding [?\M-x])
+ 'execute-extended-command)
+ [?\M-x]
+ (or (car (where-is-internal
+ 'execute-extended-command))
+ [?\M-x]))
+ (substring word 2 -2) "\r")))
+ ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word)
+ (progn
+ (setq word (concat (match-string 1 word)
+ (match-string 3 word)))
+ (not (string-match
+ "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$"
+ word))))
+ (setq key (list (intern word))))
+ ((or (equal word "REM") (string-match "^;;" word))
+ (setq pos (string-match "$" keys pos)))
+ (t
+ (let ((orig-word word) (prefix 0) (bits 0))
+ (while (string-match "^[ACHMsS]-." word)
+ (setq bits (+ bits
+ (cdr
+ (assq (aref word 0)
+ '((?A . ?\A-\^@) (?C . ?\C-\^@)
+ (?H . ?\H-\^@) (?M . ?\M-\^@)
+ (?s . ?\s-\^@) (?S . ?\S-\^@))))))
+ (setq prefix (+ prefix 2))
+ (setq word (substring word 2)))
+ (when (string-match "^\\^.$" word)
+ (setq bits (+ bits ?\C-\^@))
+ (setq prefix (1+ prefix))
+ (setq word (substring word 1)))
+ (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r")
+ ("LFD" . "\n") ("TAB" . "\t")
+ ("ESC" . "\e") ("SPC" . " ")
+ ("DEL" . "\177")))))
+ (when found (setq word (cdr found))))
+ (when (string-match "^\\\\[0-7]+$" word)
+ (let ((n 0))
+ (dolist (ch (cdr (string-to-list word)))
+ (setq n (+ (* n 8) ch -48)))
+ (setq word (vector n))))
+ (cond ((= bits 0)
+ (setq key word))
+ ((and (= bits ?\M-\^@) (stringp word)
+ (string-match "^-?[0-9]+$" word))
+ (setq key (mapcar (lambda (x) (+ x bits))
+ (append word nil))))
+ ((/= (length word) 1)
+ (error "%s must prefix a single character, not %s"
+ (substring orig-word 0 prefix) word))
+ ((and (/= (logand bits ?\C-\^@) 0) (stringp word)
+ ;; We used to accept . and ? here,
+ ;; but . is simply wrong,
+ ;; and C-? is not used (we use DEL instead).
+ (string-match "[@-_a-z]" word))
+ (setq key (list (+ bits (- ?\C-\^@)
+ (logand (aref word 0) 31)))))
+ (t
+ (setq key (list (+ bits (aref word 0)))))))))
+ (when key
+ (dolist (_ (number-sequence 1 times))
+ (setq res (vconcat res key))))))
+ (if (and (>= (length res) 4)
+ (eq (aref res 0) ?\C-x)
+ (eq (aref res 1) ?\()
+ (eq (aref res (- (length res) 2)) ?\C-x)
+ (eq (aref res (- (length res) 1)) ?\)))
+ (apply #'vector (let ((lres (append res nil)))
+ ;; Remove the first and last two elements.
+ (setq lres (cdr (cdr lres)))
+ (nreverse lres)
+ (setq lres (cdr (cdr lres)))
+ (nreverse lres)))
+ res))))
+
+(defun key-valid-p (keys)
+ "Say whether KEYS is a valid `kbd' sequence.
+A `kbd' sequence is a string consisting of one and more key
+strokes. The key strokes are separated by a space character.
+
+Each key stroke is either a single character, or the name of an
+event, surrounded by angle brackets. In addition, any key stroke
+may be preceded by one or more modifier keys. Finally, a limited
+number of characters have a special shorthand syntax.
+
+Here's some example key sequences.
+
+ \"f\" (the key 'f')
+ \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm')
+ \"C-c o\" (a two key sequence of the keys 'c' with the control modifier
+ and then the key 'o')
+ \"H-<left>\" (the key named \"left\" with the hyper modifier)
+ \"M-RET\" (the \"return\" key with a meta modifier)
+ \"C-M-<space>\" (the \"space\" key with both the control and meta modifiers)
+
+These are the characters that have shorthand syntax:
+NUL, RET, TAB, LFD, ESC, SPC, DEL.
+
+Modifiers have to be specified in this order:
+
+ A-C-H-M-S-s
+
+which is
+
+ Alt-Control-Hyper-Meta-Shift-super"
+ (declare (pure t) (side-effect-free t))
+ (and
+ (stringp keys)
+ (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys)
+ (save-match-data
+ (catch 'exit
+ (let ((prefixes
+ "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?")
+ (case-fold-search nil))
+ (dolist (key (split-string keys " "))
+ ;; Every key might have these modifiers, and they should be
+ ;; in this order.
+ (when (string-match (concat "\\`" prefixes) key)
+ (setq key (substring key (match-end 0))))
+ (unless (or (and (= (length key) 1)
+ ;; Don't accept control characters as keys.
+ (not (< (aref key 0) ?\s))
+ ;; Don't accept Meta'd characters as keys.
+ (or (multibyte-string-p key)
+ (not (<= 127 (aref key 0) 255))))
+ (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key)
+ ;; Don't allow <M-C-down>.
+ (= (progn
+ (string-match
+ (concat "\\`<" prefixes) key)
+ (match-end 0))
+ 1))
+ (string-match-p
+ "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'"
+ key))
+ ;; Invalid.
+ (throw 'exit nil)))
+ t)))))
+
+(defun key-translate (from to)
+ "Translate character FROM to TO on the current terminal.
+This function creates a `keyboard-translate-table' if necessary
+and then modifies one entry in it.
+
+Both KEY and TO are strings that satisfy `key-valid-p'."
+ (declare (compiler-macro
+ (lambda (form) (keymap--compile-check from to) form)))
+ (keymap--check from)
+ (keymap--check to)
+ (or (char-table-p keyboard-translate-table)
+ (setq keyboard-translate-table
+ (make-char-table 'keyboard-translate-table nil)))
+ (aset keyboard-translate-table (key-parse from) (key-parse to)))
+
+(defun keymap-lookup (keymap key &optional accept-default no-remap position)
+ "Return the binding for command KEY.
+KEY is a string that satisfies `key-valid-p'.
+
+If KEYMAP is nil, look up in the current keymaps. If non-nil, it
+should either be a keymap or a list of keymaps, and only these
+keymap(s) will be consulted.
+
+The binding is probably a symbol with a function definition.
+
+Normally, `keymap-lookup' ignores bindings for t, which act as
+default bindings, used when nothing else in the keymap applies;
+this makes it usable as a general function for probing keymaps.
+However, if the optional second argument ACCEPT-DEFAULT is
+non-nil, `keymap-lookup' does recognize the default bindings,
+just as `read-key-sequence' does.
+
+Like the normal command loop, `keymap-lookup' will remap the
+command resulting from looking up KEY by looking up the command
+in the current keymaps. However, if the optional third argument
+NO-REMAP is non-nil, `keymap-lookup' returns the unmapped
+command.
+
+If KEY is a key sequence initiated with the mouse, the used keymaps
+will depend on the clicked mouse position with regard to the buffer
+and possible local keymaps on strings.
+
+If the optional argument POSITION is non-nil, it specifies a mouse
+position as returned by `event-start' and `event-end', and the lookup
+occurs in the keymaps associated with it instead of KEY. It can also
+be a number or marker, in which case the keymap properties at the
+specified buffer position instead of point are used."
+ (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
+ (keymap--check key)
+ (when (and keymap position)
+ (error "Can't pass in both keymap and position"))
+ (if keymap
+ (let ((value (lookup-key keymap (key-parse key) accept-default)))
+ (if (and (not no-remap)
+ (symbolp value))
+ (or (command-remapping value) value)
+ value))
+ (key-binding (kbd key) accept-default no-remap position)))
+
+(defun keymap-local-lookup (keys &optional accept-default)
+ "Return the binding for command KEYS in current local keymap only.
+KEY is a string that satisfies `key-valid-p'.
+
+The binding is probably a symbol with a function definition.
+
+If optional argument ACCEPT-DEFAULT is non-nil, recognize default
+bindings; see the description of `keymap-lookup' for more details
+about this."
+ (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form)))
+ (when-let ((map (current-local-map)))
+ (keymap-lookup map keys accept-default)))
+
+(defun keymap-global-lookup (keys &optional accept-default message)
+ "Return the binding for command KEYS in current global keymap only.
+KEY is a string that satisfies `key-valid-p'.
+
+The binding is probably a symbol with a function definition.
+This function's return values are the same as those of `keymap-lookup'
+\(which see).
+
+If optional argument ACCEPT-DEFAULT is non-nil, recognize default
+bindings; see the description of `keymap-lookup' for more details
+about this.
+
+If MESSAGE (and interactively), message the result."
+ (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form)))
+ (interactive
+ (list (key-description (read-key-sequence "Look up key in global keymap: "))
+ nil t))
+ (let ((def (keymap-lookup (current-global-map) keys accept-default)))
+ (when message
+ (message "%s is bound to %s globally" keys def))
+ def))
+
+(provide 'keymap)
+
+;;; keymap.el ends here
diff --git a/lisp/language/cyril-util.el b/lisp/language/cyril-util.el
index 04e681d743d..e404288ddca 100644
--- a/lisp/language/cyril-util.el
+++ b/lisp/language/cyril-util.el
@@ -60,7 +60,7 @@ If the argument is nil, we return the display table to its standard state."
(list
(let* ((completion-ignore-case t))
(completing-read
- "Cyrillic language (default nil): "
+ (format-prompt "Cyrillic language" "nil")
cyrillic-language-alist nil t nil nil nil))))
(or standard-display-table
diff --git a/lisp/language/hanja-util.el b/lisp/language/hanja-util.el
index 9e9213536cb..fe6323d42ba 100644
--- a/lisp/language/hanja-util.el
+++ b/lisp/language/hanja-util.el
@@ -6573,8 +6573,8 @@ The value is a hanja character that is selected interactively."
(hanja-filter (lambda (x) (car x))
(mapcar (lambda (c)
(if (listp c)
- (cons (decode-char 'ucs (car c)) (cdr c))
- (list (decode-char 'ucs c))))
+ (cons (car c) (cdr c))
+ (list c)))
(aref hanja-table char)))))
(unwind-protect
(when (aref hanja-conversions 2)
diff --git a/lisp/language/lao.el b/lisp/language/lao.el
index c699d57c15a..93849461eae 100644
--- a/lisp/language/lao.el
+++ b/lisp/language/lao.el
@@ -59,11 +59,11 @@
(let* ((chars (car l))
(len (length chars))
;; Replace `c', `t', `v' to consonant, tone, and vowel.
- (regexp (mapconcat #'(lambda (c)
- (cond ((= c ?c) consonant)
- ((= c ?t) tone)
- ((= c ?v) vowel-upper-lower)
- (t (string c))))
+ (regexp (mapconcat (lambda (c)
+ (cond ((= c ?c) consonant)
+ ((= c ?t) tone)
+ ((= c ?v) vowel-upper-lower)
+ (t (string c))))
(cdr l) ""))
;; Element of composition-function-table.
(elt (list (vector regexp 1 #'lao-composition-function)
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index 58de4c0cc4a..0fbae8508a0 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -1,4 +1,5 @@
;;; loaddefs.el --- automatically extracted autoloads -*- lexical-binding: t -*-
+;; This file will be copied to ldefs-boot.el and checked in periodically.
;;
;;; Code:
@@ -338,11 +339,22 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
(autoload 'align "align" "\
Attempt to align a region based on a set of alignment rules.
-BEG and END mark the region. If BEG and END are specifically set to
-nil (this can only be done programmatically), the beginning and end of
-the current alignment section will be calculated based on the location
-of point, and the value of `align-region-separate' (or possibly each
-rule's `separate' attribute).
+Interactively, BEG and END are the mark/point of the current region.
+
+Many modes define specific alignment rules, and some of these
+rules in some modes react to the current prefix argument. For
+instance, in `text-mode', `M-x align' will align into columns
+based on space delimiters, while `C-u - M-x align' will align
+into columns based on the \"$\" character. See the
+`align-rules-list' variable definition for the specific rules.
+
+Also see `align-regexp', which will guide you through various
+parameters for aligning text.
+
+Non-interactively, if BEG and END are nil, the beginning and end
+of the current alignment section will be calculated based on the
+location of point, and the value of `align-region-separate' (or
+possibly each rule's `separate' attribute).
If SEPARATE is non-nil, it overrides the value of
`align-region-separate' for all rules, except those that have their
@@ -360,6 +372,15 @@ Align the current region using an ad-hoc rule read from the minibuffer.
BEG and END mark the limits of the region. Interactively, this function
prompts for the regular expression REGEXP to align with.
+Interactively, if you specify a prefix argument, the function
+will guide you through entering the full regular expression, and
+then prompts for which subexpression parenthesis GROUP (default
+1) within REGEXP to modify, the amount of SPACING (default
+`align-default-spacing') to use, and whether or not to REPEAT the
+rule throughout the line.
+
+See `align-rules-list' for more information about these options.
+
For example, let's say you had a list of phone numbers, and wanted to
align them so that the opening parentheses would line up:
@@ -379,15 +400,8 @@ regular expression after you enter it. Interactively, you only
need to supply the characters to be lined up, and any preceding
whitespace is replaced.
-Non-interactively (or if you specify a prefix argument), you must
-enter the full regular expression, including the subexpression.
-Interactively, the function also then prompts for which
-subexpression parenthesis GROUP (default 1) within REGEXP to
-modify, the amount of SPACING (default `align-default-spacing')
-to use, and whether or not to REPEAT the rule throughout the
-line.
-
-See `align-rules-list' for more information about these options.
+Non-interactively, you must enter the full regular expression,
+including the subexpression.
The non-interactive form of the previous example would look something like:
(align-regexp (point-min) (point-max) \"\\\\(\\\\s-*\\\\)(\")
@@ -1665,6 +1679,8 @@ or if CONDITION had no actions, after all other CONDITIONs.
\(fn CONDITION ACTION &optional AFTER)" nil nil)
+(function-put 'define-auto-insert 'lisp-indent-function 'defun)
+
(defvar auto-insert-mode nil "\
Non-nil if Auto-Insert mode is enabled.
See the `auto-insert-mode' command
@@ -2366,12 +2382,7 @@ a reflection.
(define-key ctl-x-r-map "M" 'bookmark-set-no-overwrite)
(define-key ctl-x-r-map "l" 'bookmark-bmenu-list)
-(defvar bookmark-map (let ((map (make-sparse-keymap))) (define-key map "x" 'bookmark-set) (define-key map "m" 'bookmark-set) (define-key map "M" 'bookmark-set-no-overwrite) (define-key map "j" 'bookmark-jump) (define-key map "g" 'bookmark-jump) (define-key map "o" 'bookmark-jump-other-window) (define-key map "5" 'bookmark-jump-other-frame) (define-key map "i" 'bookmark-insert) (define-key map "e" 'edit-bookmarks) (define-key map "f" 'bookmark-insert-location) (define-key map "r" 'bookmark-rename) (define-key map "d" 'bookmark-delete) (define-key map "D" 'bookmark-delete-all) (define-key map "l" 'bookmark-load) (define-key map "w" 'bookmark-write) (define-key map "s" 'bookmark-save) map) "\
-Keymap containing bindings to bookmark functions.
-It is not bound to any key by default: to bind it
-so that you have a bookmark prefix, just use `global-set-key' and bind a
-key of your choice to variable `bookmark-map'. All interactive bookmark
-functions have a binding in this keymap.")
+(defvar-keymap bookmark-map :doc "Keymap containing bindings to bookmark functions.\nIt is not bound to any key by default: to bind it\nso that you have a bookmark prefix, just use `global-set-key' and bind a\nkey of your choice to variable `bookmark-map'. All interactive bookmark\nfunctions have a binding in this keymap." "x" #'bookmark-set "m" #'bookmark-set "M" #'bookmark-set-no-overwrite "j" #'bookmark-jump "g" #'bookmark-jump "o" #'bookmark-jump-other-window "5" #'bookmark-jump-other-frame "i" #'bookmark-insert "e" #'edit-bookmarks "f" #'bookmark-insert-location "r" #'bookmark-rename "d" #'bookmark-delete "D" #'bookmark-delete-all "l" #'bookmark-load "w" #'bookmark-write "s" #'bookmark-save)
(fset 'bookmark-map bookmark-map)
(autoload 'bookmark-set "bookmark" "\
@@ -2800,6 +2811,13 @@ used instead of `browse-url-new-window-flag'.
(make-obsolete 'browse-url-galeon 'nil '"25.1")
+(autoload 'browse-url-webpositive "browse-url" "\
+Ask the WebPositive WWW browser to load URL.
+Default to the URL around or before point.
+The optional argument NEW-WINDOW is not used.
+
+\(fn URL &optional NEW-WINDOW)" t nil)
+
(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
@@ -3082,6 +3100,11 @@ disabled.
(put 'byte-compile-warnings 'safe-local-variable (lambda (v) (or (symbolp v) (null (delq nil (mapcar (lambda (x) (not (symbolp x))) v))))))
+(autoload 'byte-compile-warning-enabled-p "bytecomp" "\
+Return non-nil if WARNING is enabled, according to `byte-compile-warnings'.
+
+\(fn WARNING &optional SYMBOL)" nil nil)
+
(autoload 'byte-compile-disable-warning "bytecomp" "\
Change `byte-compile-warnings' to disable WARNING.
If `byte-compile-warnings' is t, set it to `(not WARNING)'.
@@ -3438,6 +3461,8 @@ See Info node `(calc)Defining Functions'.
(function-put 'defmath 'doc-string-elt '3)
+(function-put 'defmath 'lisp-indent-function 'defun)
+
(register-definition-prefixes "calc" '("calc" "defcalcmodevar" "inexact-result" "math-" "var-"))
;;;***
@@ -4467,6 +4492,8 @@ MAP-ID := integer
(function-put 'define-ccl-program 'doc-string-elt '3)
+(function-put 'define-ccl-program 'lisp-indent-function 'defun)
+
(autoload 'check-ccl-program "ccl" "\
Check validity of CCL-PROGRAM.
If CCL-PROGRAM is a symbol denoting a CCL program, return
@@ -4753,6 +4780,14 @@ space at the end of each line.
\(fn &optional NO-ERROR)" t nil)
+(autoload 'checkdoc-dired "checkdoc" "\
+In Dired, run `checkdoc' on marked files.
+Skip anything that doesn't have the Emacs Lisp library file
+extension (\".el\").
+When called from Lisp, FILES is a list of filenames.
+
+\(fn FILES)" '(dired-mode) nil)
+
(autoload 'checkdoc-ispell "checkdoc" "\
Check the style and spelling of everything interactively.
Calls `checkdoc' with spell-checking turned on.
@@ -7409,6 +7444,8 @@ See Info node `(elisp)Derived Modes' for more details.
(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
@@ -8801,6 +8838,8 @@ INIT-VALUE LIGHTER KEYMAP.
(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)
@@ -8838,6 +8877,8 @@ on if the hook has explicitly disabled it.
(function-put 'define-globalized-minor-mode 'doc-string-elt '2)
+(function-put 'define-globalized-minor-mode 'lisp-indent-function 'defun)
+
(autoload 'easy-mmode-define-keymap "easy-mmode" "\
Return a keymap built from bindings BS.
BS must be a list of (KEY . BINDING) where
@@ -10487,6 +10528,40 @@ Emerge two RCS revisions of a file, with another revision as ancestor.
;;;***
+;;;### (autoloads nil "emoji" "international/emoji.el" (0 0 0 0))
+;;; Generated autoloads from international/emoji.el
+
+(autoload 'emoji-insert "emoji" "\
+Choose and insert an emoji glyph.
+If TEXT (interactively, the prefix), use a textual search instead
+of a visual interface.
+
+\(fn &optional TEXT)" t nil)
+
+(autoload 'emoji-recent "emoji" "\
+Choose and insert a recently used emoji glyph." t nil)
+
+(autoload 'emoji-search "emoji" "\
+Choose and insert an emoji glyph by searching for an emoji name." t nil)
+
+(autoload 'emoji-list "emoji" "\
+List emojis and insert the one that's selected.
+The character will be inserted into the buffer that was selected
+when the command was issued." t nil)
+
+(autoload 'emoji-describe "emoji" "\
+Say what the name of the composed grapheme cluster GLYPH is.
+If it's not known, this function returns nil.
+
+Interactively, it will message what the name of the emoji (or
+character) under point is.
+
+\(fn GLYPH &optional INTERACTIVE)" t nil)
+
+(register-definition-prefixes "emoji" '("emoji-"))
+
+;;;***
+
;;;### (autoloads nil "enriched" "textmodes/enriched.el" (0 0 0 0))
;;; Generated autoloads from textmodes/enriched.el
@@ -10929,7 +11004,7 @@ Look at CONFIG and try to expand GROUP.
;;;### (autoloads nil "erc" "erc/erc.el" (0 0 0 0))
;;; Generated autoloads from erc/erc.el
-(push (purecopy '(erc 5 4)) package--builtin-versions)
+(push (purecopy '(erc 5 4 1)) package--builtin-versions)
(autoload 'erc-select-read-args "erc" "\
Prompt the user for values of nick, server, port, and password." nil nil)
@@ -11076,6 +11151,9 @@ Macros in BODY are expanded when the test is defined, not when it
is run. If a macro (possibly with side effects) is to be tested,
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 signalled.
+
\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil t)
(function-put 'ert-deftest 'doc-string-elt '3)
@@ -11108,11 +11186,8 @@ the tests).
Run the tests specified by SELECTOR and display the results in a buffer.
SELECTOR works as described in `ert-select-tests'.
-OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they
-are used for automated self-tests and specify which buffer to use
-and how to display message.
-\(fn SELECTOR &optional OUTPUT-BUFFER-NAME MESSAGE-FN)" t nil)
+\(fn SELECTOR)" t nil)
(defalias 'ert #'ert-run-tests-interactively)
@@ -11135,6 +11210,22 @@ Kill all test buffers that are still live." t nil)
;;;***
+;;;### (autoloads nil "erts-mode" "progmodes/erts-mode.el" (0 0 0
+;;;;;; 0))
+;;; Generated autoloads from progmodes/erts-mode.el
+
+(autoload 'erts-mode "erts-mode" "\
+Major mode for editing erts (Emacs testing) files.
+This mode mainly provides some font locking.
+
+\\{erts-mode-map}
+
+\(fn)" t nil)
+
+(register-definition-prefixes "erts-mode" '("erts-"))
+
+;;;***
+
;;;### (autoloads nil "esh-arg" "eshell/esh-arg.el" (0 0 0 0))
;;; Generated autoloads from eshell/esh-arg.el
@@ -11479,7 +11570,7 @@ See documentation of variable `tags-file-name'.
(make-obsolete 'find-tag-regexp 'xref-find-apropos '"25.1")
-(defalias 'pop-tag-mark 'xref-pop-marker-stack)
+(defalias 'pop-tag-mark 'xref-go-back)
(defalias 'next-file 'tags-next-file)
@@ -11956,14 +12047,14 @@ Fetch URL and render the page.
If the input doesn't look like an URL or a domain name, the
word(s) will be searched for via `eww-search-prefix'.
-If called with a prefix ARG, use a new buffer instead of reusing
-the default EWW buffer.
+If NEW-BUFFER is non-nil (interactively, the prefix arg), use a
+new buffer instead of reusing the default EWW buffer.
If BUFFER, the data to be rendered is in that buffer. In that
case, this function doesn't actually fetch URL. BUFFER will be
killed after rendering.
-\(fn URL &optional ARG BUFFER)" t nil)
+\(fn URL &optional NEW-BUFFER BUFFER)" t nil)
(defalias 'browse-web 'eww)
(autoload 'eww-open-file "eww" "\
@@ -14456,7 +14547,7 @@ CLEAN is obsolete and ignored.
(autoload 'gnus-article-prepare-display "gnus-art" "\
Make the current buffer look like a nice article." nil nil)
-(register-definition-prefixes "gnus-art" '("article-" "gnus-"))
+(register-definition-prefixes "gnus-art" '(":keymap" "article-" "gnus-"))
;;;***
@@ -14764,7 +14855,7 @@ The arguments have the same meaning as those of
\(fn IDS &optional WINDOW-CONF)" t nil)
-(register-definition-prefixes "gnus-group" '("gnus-"))
+(register-definition-prefixes "gnus-group" '(":keymap" "gnus-"))
;;;***
@@ -14991,7 +15082,7 @@ Like `message-reply'.
(define-mail-user-agent 'gnus-user-agent 'gnus-msg-mail 'message-send-and-exit 'message-kill-buffer 'message-send-hook)
-(register-definition-prefixes "gnus-msg" '("gnus-"))
+(register-definition-prefixes "gnus-msg" '(":prefix" "gnus-"))
;;;***
@@ -15205,7 +15296,7 @@ BOOKMARK is a bookmark name or a bookmark record.
\(fn BOOKMARK)" nil nil)
-(register-definition-prefixes "gnus-sum" '("gnus-"))
+(register-definition-prefixes "gnus-sum" '(":keymap" "gnus-"))
;;;***
@@ -16232,6 +16323,11 @@ gives the window that lists the options.")
;;;### (autoloads nil "help-mode" "help-mode.el" (0 0 0 0))
;;; Generated autoloads from help-mode.el
+(autoload 'help-mode--add-function-link "help-mode" "\
+
+
+\(fn STR FUN)" nil nil)
+
(autoload 'help-mode "help-mode" "\
Major mode for viewing help text and navigating references in it.
Entry to this mode runs the normal hook `help-mode-hook'.
@@ -18256,7 +18352,11 @@ specifying the X and Y positions and WIDTH and HEIGHT of image area
to insert. A float value 0.0 - 1.0 means relative to the width or
height of the image; integer values are taken as pixel values.
-\(fn IMAGE &optional STRING AREA SLICE)" nil nil)
+Normally `isearch' is able to search for STRING in the buffer
+even if it's hidden behind a displayed image. If INHIBIT-ISEARCH
+is non-nil, this is inhibited.
+
+\(fn IMAGE &optional STRING AREA SLICE INHIBIT-ISEARCH)" nil nil)
(autoload 'insert-sliced-image "image" "\
Insert IMAGE into current buffer at point.
@@ -18325,6 +18425,8 @@ Example:
(function-put 'defimage 'doc-string-elt '3)
+(function-put 'defimage 'lisp-indent-function 'defun)
+
(autoload 'imagemagick-register-types "image" "\
Register file types that can be handled by ImageMagick.
This function is called at startup, after loading the init file.
@@ -18337,6 +18439,9 @@ recognizes these files as having image type `imagemagick'.
If Emacs is compiled without ImageMagick support, this does nothing." nil nil)
+(autoload 'image-at-point-p "image" "\
+Return non-nil if there is an image at point." nil nil)
+
(register-definition-prefixes "image" '("find-image--cache" "image" "unknown-image-type"))
;;;***
@@ -18406,17 +18511,19 @@ thumbnail buffer to be selected.
\(fn &optional ARG APPEND DO-NOT-POP)" t nil)
(autoload 'image-dired-show-all-from-dir "image-dired" "\
-Make a preview buffer for all images in DIR and display it.
-If the number of files in DIR matching `image-file-name-regexp'
-exceeds `image-dired-show-all-from-dir-max-files', a warning will be
-displayed.
+Make a thumbnail buffer for all images in DIR and display it.
+Any file matching `image-file-name-regexp' is considered an image
+file.
+
+If the number of image files in DIR exceeds
+`image-dired-show-all-from-dir-max-files', ask for confirmation
+before creating the thumbnail buffer. If that variable is nil,
+never ask for confirmation.
\(fn DIR)" t nil)
(defalias 'image-dired 'image-dired-show-all-from-dir)
-(define-obsolete-function-alias 'tumme 'image-dired "24.4")
-
(autoload 'image-dired-tag-files "image-dired" "\
Tag marked file(s) in Dired. With prefix ARG, tag file at point.
@@ -18434,7 +18541,7 @@ Jump to thumbnail buffer." t nil)
(autoload 'image-dired-minor-mode "image-dired" "\
Setup easy-to-use keybindings for the commands to be used in Dired mode.
Note that n, p and <down> and <up> will be hijacked and bound to
-`image-dired-dired-x-line'.
+`image-dired-dired-next-line' and `image-dired-dired-previous-line'.
This is a minor mode. If called interactively, toggle the
`Image-Dired minor mode' mode. If the prefix argument is positive,
@@ -18452,8 +18559,6 @@ disabled.
\(fn &optional ARG)" t nil)
-(define-obsolete-function-alias 'image-dired-setup-dired-keybindings 'image-dired-minor-mode "26.1")
-
(autoload 'image-dired-display-thumbs-append "image-dired" "\
Append thumbnails to `image-dired-thumbnail-buffer'." t nil)
@@ -18486,6 +18591,15 @@ Edit comment and tags of current or marked image files.
Edit comment and tags for all marked image files in an
easy-to-use form." t nil)
+(autoload 'image-dired-bookmark-jump "image-dired" "\
+Default bookmark handler for Image-Dired buffers.
+
+\(fn BOOKMARK)" nil nil)
+
+(define-obsolete-function-alias 'tumme #'image-dired "24.4")
+
+(define-obsolete-function-alias 'image-dired-setup-dired-keybindings #'image-dired-minor-mode "26.1")
+
(register-definition-prefixes "image-dired" '("image-dired-"))
;;;***
@@ -18493,7 +18607,7 @@ easy-to-use form." t nil)
;;;### (autoloads nil "image-file" "image-file.el" (0 0 0 0))
;;; Generated autoloads from image-file.el
-(defvar image-file-name-extensions (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg")) "\
+(defvar image-file-name-extensions (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg" "webp")) "\
A list of image-file filename extensions.
Filenames having one of these extensions are considered image files,
in addition to those matching `image-file-name-regexps'.
@@ -19440,24 +19554,24 @@ Display a list of the options available when a misspelling is encountered.
Selections are:
-DIGIT: Replace the word with a digit offered in the *Choices* buffer.
-SPC: Accept word this time.
-`i': Accept word and insert into private dictionary.
-`a': Accept word for this session.
-`A': Accept word and place in `buffer-local dictionary'.
-`r': Replace word with typed-in value. Rechecked.
-`R': Replace word with typed-in value. Query-replaced in buffer. Rechecked.
-`?': Show these commands.
-`x': Exit spelling buffer. Move cursor to original point.
-`X': Exit spelling buffer. Leaves cursor at the current point, and permits
+\\`0'..\\`9' Replace the word with a digit offered in the *Choices* buffer.
+\\`SPC' Accept word this time.
+\\`i' Accept word and insert into private dictionary.
+\\`a' Accept word for this session.
+\\`A' Accept word and place in `buffer-local dictionary'.
+\\`r' Replace word with typed-in value. Rechecked.
+\\`R' Replace word with typed-in value. Query-replaced in buffer. Rechecked.
+\\`?' Show these commands.
+\\`x' Exit spelling buffer. Move cursor to original point.
+\\`X' Exit spelling buffer. Leaves cursor at the current point, and permits
the aborted check to be completed later.
-`q': Quit spelling session (Kills ispell process).
-`l': Look up typed-in replacement in alternate dictionary. Wildcards okay.
-`u': Like `i', but the word is lower-cased first.
-`m': Place typed-in value in personal dictionary, then recheck current word.
-`C-l': Redraw screen.
-`C-r': Recursive edit.
-`C-z': Suspend Emacs or iconify frame." nil nil)
+\\`q' Quit spelling session (Kills ispell process).
+\\`l' Look up typed-in replacement in alternate dictionary. Wildcards okay.
+\\`u' Like \\`i', but the word is lower-cased first.
+\\`m' Place typed-in value in personal dictionary, then recheck current word.
+\\`C-l' Redraw screen.
+\\`C-r' Recursive edit.
+\\`C-z' Suspend Emacs or iconify frame." nil nil)
(autoload 'ispell-kill-ispell "ispell" "\
Kill current Ispell process (so that you may start a fresh one).
@@ -19564,8 +19678,8 @@ Don't check spelling of message headers except the Subject field.
Don't check included messages.
To abort spell checking of a message region and send the message anyway,
-use the `x' command. (Any subsequent regions will be checked.)
-The `X' command aborts sending the message so that you can edit the buffer.
+use the \\`x' command. (Any subsequent regions will be checked.)
+The \\`X' command aborts sending the message so that you can edit the buffer.
To spell-check whenever a message is sent, include the appropriate lines
in your init file:
@@ -19725,7 +19839,7 @@ one of the aforementioned options instead of using this mode.
(dolist (name (list "node" "nodejs" "gjs" "rhino")) (add-to-list 'interpreter-mode-alist (cons (purecopy name) 'js-mode)))
-(register-definition-prefixes "js" '("js-" "with-js"))
+(register-definition-prefixes "js" '("js-"))
;;;***
@@ -20922,6 +21036,12 @@ current header, calls `mail-complete-function' and passes prefix ARG if any.
;;;### (autoloads nil "mailcap" "net/mailcap.el" (0 0 0 0))
;;; Generated autoloads from net/mailcap.el
+(autoload 'mailcap-mime-type-to-extension "mailcap" "\
+Return a file name extension based on a MIME-TYPE.
+For instance, `image/png' will result in `png'.
+
+\(fn MIME-TYPE)" nil nil)
+
(register-definition-prefixes "mailcap" '("mailcap-"))
;;;***
@@ -21659,7 +21779,7 @@ perform the operation on all messages in that region.
\(fn)" t nil)
-(register-definition-prefixes "mh-folder" '("mh-"))
+(register-definition-prefixes "mh-folder" '(":keymap" "mh-"))
;;;***
@@ -21695,7 +21815,7 @@ perform the operation on all messages in that region.
;;;### (autoloads nil "mh-letter" "mh-e/mh-letter.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-letter.el
-(register-definition-prefixes "mh-letter" '("mh-"))
+(register-definition-prefixes "mh-letter" '(":keymap" "mh-"))
;;;***
@@ -21730,7 +21850,7 @@ perform the operation on all messages in that region.
;;;### (autoloads nil "mh-search" "mh-e/mh-search.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-search.el
-(register-definition-prefixes "mh-search" '("mh-"))
+(register-definition-prefixes "mh-search" '(":keymap" "mh-"))
;;;***
@@ -21744,14 +21864,14 @@ perform the operation on all messages in that region.
;;;### (autoloads nil "mh-show" "mh-e/mh-show.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-show.el
-(register-definition-prefixes "mh-show" '("mh-"))
+(register-definition-prefixes "mh-show" '(":keymap" "mh-"))
;;;***
;;;### (autoloads nil "mh-speed" "mh-e/mh-speed.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-speed.el
-(register-definition-prefixes "mh-speed" '("mh-"))
+(register-definition-prefixes "mh-speed" '(":keymap" "mh-"))
;;;***
@@ -22214,6 +22334,8 @@ specifies how the attachment is intended to be displayed. It can
be either \"inline\" (displayed automatically within the message
body) or \"attachment\" (separate from the body).
+Also see the `mml-attach-file-at-the-end' variable.
+
If given a prefix interactively, no prompting will be done for
the TYPE, DESCRIPTION or DISPOSITION values. Instead defaults
will be computed and used.
@@ -25758,6 +25880,14 @@ they are not by default assigned to keys." t nil)
;;;***
+;;;### (autoloads nil "pixel-fill" "textmodes/pixel-fill.el" (0 0
+;;;;;; 0 0))
+;;; Generated autoloads from textmodes/pixel-fill.el
+
+(register-definition-prefixes "pixel-fill" '("pixel-fill-"))
+
+;;;***
+
;;;### (autoloads nil "pixel-scroll" "pixel-scroll.el" (0 0 0 0))
;;; Generated autoloads from pixel-scroll.el
@@ -25790,6 +25920,38 @@ disabled.
\(fn &optional ARG)" t nil)
+(defvar pixel-scroll-precision-mode nil "\
+Non-nil if Pixel-Scroll-Precision mode is enabled.
+See the `pixel-scroll-precision-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 `pixel-scroll-precision-mode'.")
+
+(custom-autoload 'pixel-scroll-precision-mode "pixel-scroll" nil)
+
+(autoload 'pixel-scroll-precision-mode "pixel-scroll" "\
+Toggle pixel scrolling.
+When enabled, this minor mode allows to scroll the display
+precisely, according to the turning of the mouse wheel.
+
+This is a minor mode. If called interactively, toggle the
+`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.
+
+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.
+
+\(fn &optional ARG)" t nil)
+
(register-definition-prefixes "pixel-scroll" '("pixel-"))
;;;***
@@ -25870,10 +26032,26 @@ Prettify the current buffer with printed representation of a Lisp object." t nil
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.
+
Output stream is STREAM, or value of `standard-output' (which see).
\(fn OBJECT &optional STREAM)" nil nil)
+(autoload 'pp-display-expression "pp" "\
+Prettify and display EXPRESSION in an appropriate way, depending on length.
+If LISP, format with `pp-emacs-lisp-code'; use `pp' otherwise.
+
+If a temporary buffer is needed for representation, it will be named
+after OUT-BUFFER-NAME.
+
+\(fn EXPRESSION OUT-BUFFER-NAME &optional LISP)" nil nil)
+
(autoload 'pp-eval-expression "pp" "\
Evaluate EXPRESSION and pretty-print its value.
Also add the value to the front of the list in the variable `values'.
@@ -25899,6 +26077,12 @@ Ignores leading comment characters.
\(fn ARG)" t nil)
+(autoload 'pp-emacs-lisp-code "pp" "\
+Insert SEXP into the current buffer, formatted as Emacs Lisp code.
+Use the `pp-max-width' variable to control the desired line length.
+
+\(fn SEXP)" nil nil)
+
(register-definition-prefixes "pp" '("pp-"))
;;;***
@@ -26573,13 +26757,25 @@ pattern to search for.
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\"." t nil)
+is available as part of \"future history\".
+
+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'.
+
+\(fn &optional INCLUDE-ALL)" t nil)
(autoload 'project-or-external-find-file "project" "\
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\"." t nil)
+is available as part of \"future history\".
+
+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'.
+
+\(fn &optional INCLUDE-ALL)" t nil)
(autoload 'project-find-dir "project" "\
Start Dired in a directory inside the current project." t nil)
@@ -27536,11 +27732,11 @@ If ARG is non-nil, instead prompt for connection parameters.
(autoload 'rcirc-connect "rcirc" "\
Connect to SERVER.
The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD,
-ENCRYPTION, SERVER-ALIAS are interpreted as in
+ENCRYPTION, CERTFP, SERVER-ALIAS are interpreted as in
`rcirc-server-alist'. STARTUP-CHANNELS is a list of channels
that are joined after authentication.
-\(fn SERVER &optional PORT NICK USER-NAME FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION SERVER-ALIAS)" nil nil)
+\(fn SERVER &optional PORT NICK USER-NAME FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION CERTFP SERVER-ALIAS)" nil nil)
(defvar rcirc-track-minor-mode nil "\
Non-nil if Rcirc-Track minor mode is enabled.
@@ -30272,6 +30468,29 @@ only these files will be asked to be saved.
\(fn ARG)" nil nil)
+(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.
+
+\(fn ARG)" nil nil)
+
(register-definition-prefixes "server" '("server-"))
;;;***
@@ -30608,7 +30827,7 @@ If FUNCTION is non-nil, place point on the entry for FUNCTION (if any).
\(fn GROUP &optional FUNCTION)" t nil)
-(register-definition-prefixes "shortdoc" '("alist" "buffer" "define-short-documentation-group" "file" "hash-table" "list" "number" "overlay" "process" "regexp" "sequence" "shortdoc-" "string" "text-properties" "vector"))
+(register-definition-prefixes "shortdoc" '("alist" "buffer" "define-short-documentation-group" "file" "hash-table" "keymaps" "list" "number" "overlay" "process" "regexp" "sequence" "shortdoc-" "string" "text-properties" "vector"))
;;;***
@@ -30748,6 +30967,8 @@ SKELETON is as defined under `skeleton-insert'.
(function-put 'define-skeleton 'doc-string-elt '2)
+(function-put 'define-skeleton 'lisp-indent-function 'defun)
+
(autoload 'skeleton-proxy-new "skeleton" "\
Insert SKELETON.
Prefix ARG allows wrapping around words or regions (see `skeleton-insert').
@@ -31460,7 +31681,7 @@ installed through `spam-necessary-extra-headers'.
\(fn &rest SYMBOLS)" t nil)
-(register-definition-prefixes "spam" '("spam-"))
+(register-definition-prefixes "spam" '(":keymap" "spam-"))
;;;***
@@ -32344,7 +32565,43 @@ If OMIT-NULLS, empty lines will be removed from the results.
\(fn STRING &optional OMIT-NULLS)" nil nil)
-(register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let*" "internal--" "named-let" "replace-region-contents" "string-" "thread-" "when-let*"))
+(autoload 'ensure-empty-lines "subr-x" "\
+Ensure that there are LINES number of empty lines before point.
+If LINES is nil or omitted, ensure that there is a single empty
+line before point.
+
+If called interactively, LINES is given by the prefix argument.
+
+If there are more than LINES empty lines before point, the number
+of empty lines is reduced to LINES.
+
+If point is not at the beginning of a line, a newline character
+is inserted before adjusting the number of empty lines.
+
+\(fn &optional LINES)" t nil)
+
+(autoload 'string-pixel-width "subr-x" "\
+Return the width of STRING in pixels.
+
+\(fn STRING)" nil nil)
+
+(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.
+
+\(fn STRING)" nil nil)
+
+(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
+properties are retained.
+
+If OBJECT is non-nil, it should be a string or a buffer. If nil,
+this defaults to the current buffer.
+
+\(fn START END PROP VALUE &optional OBJECT)" nil nil)
+
+(register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let*" "internal--" "named-let" "replace-region-contents" "string-" "thread-" "when-let*" "with-memoization"))
;;;***
@@ -34978,7 +35235,7 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive
;;;;;; 0))
;;; Generated autoloads from net/tramp-compat.el
-(register-definition-prefixes "tramp-compat" '("tramp-"))
+(register-definition-prefixes "tramp-compat" '("tramp-compat-"))
;;;***
@@ -35064,7 +35321,7 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive
;;;### (autoloads nil "trampver" "net/trampver.el" (0 0 0 0))
;;; Generated autoloads from net/trampver.el
-(push (purecopy '(tramp 2 5 2 -1)) package--builtin-versions)
+(push (purecopy '(tramp 2 6 0 -1)) package--builtin-versions)
(register-definition-prefixes "trampver" '("tramp-"))
@@ -35387,65 +35644,25 @@ You might need to set `uce-mail-reader' before using this.
;;;;;; (0 0 0 0))
;;; Generated autoloads from international/ucs-normalize.el
-(autoload 'ucs-normalize-NFD-region "ucs-normalize" "\
-Normalize the current region by the Unicode NFD.
-
-\(fn FROM TO)" t nil)
-
-(autoload 'ucs-normalize-NFD-string "ucs-normalize" "\
-Normalize the string STR by the Unicode NFD.
-
-\(fn STR)" nil nil)
-
-(autoload 'ucs-normalize-NFC-region "ucs-normalize" "\
-Normalize the current region by the Unicode NFC.
-
-\(fn FROM TO)" t nil)
-
-(autoload 'ucs-normalize-NFC-string "ucs-normalize" "\
-Normalize the string STR by the Unicode NFC.
-
-\(fn STR)" nil nil)
-
-(autoload 'ucs-normalize-NFKD-region "ucs-normalize" "\
-Normalize the current region by the Unicode NFKD.
-
-\(fn FROM TO)" t nil)
-
-(autoload 'ucs-normalize-NFKD-string "ucs-normalize" "\
-Normalize the string STR by the Unicode NFKD.
-
-\(fn STR)" nil nil)
-
-(autoload 'ucs-normalize-NFKC-region "ucs-normalize" "\
-Normalize the current region by the Unicode NFKC.
-
-\(fn FROM TO)" t nil)
-
-(autoload 'ucs-normalize-NFKC-string "ucs-normalize" "\
-Normalize the string STR by the Unicode NFKC.
-
-\(fn STR)" nil nil)
-
-(autoload 'ucs-normalize-HFS-NFD-region "ucs-normalize" "\
-Normalize the current region by the Unicode NFD and Mac OS's HFS Plus.
-
-\(fn FROM TO)" t nil)
-
-(autoload 'ucs-normalize-HFS-NFD-string "ucs-normalize" "\
-Normalize the string STR by the Unicode NFD and Mac OS's HFS Plus.
+(autoload 'string-glyph-compose "ucs-normalize" "\
+Compose STRING according to the Unicode NFC.
+This returns a new string obtained by canonical decomposition
+of STRING (see `ucs-normalize-NFC-string') followed by canonical
+composition, a.k.a. the \"Unicode Normalization Form C\" of STRING.
+For instance:
-\(fn STR)" nil nil)
+ (string-glyph-compose \"Å\") => \"Å\"
-(autoload 'ucs-normalize-HFS-NFC-region "ucs-normalize" "\
-Normalize the current region by the Unicode NFC and Mac OS's HFS Plus.
+\(fn STRING)" nil nil)
-\(fn FROM TO)" t nil)
+(autoload 'string-glyph-decompose "ucs-normalize" "\
+Decompose STRING according to the Unicode NFD.
+This returns a new string that is the canonical decomposition of STRING,
+a.k.a. the \"Unicode Normalization Form D\" of STRING. For instance:
-(autoload 'ucs-normalize-HFS-NFC-string "ucs-normalize" "\
-Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus.
+ (ucs-normalize-NFD-string \"Å\") => \"Å\"
-\(fn STR)" nil nil)
+\(fn STRING)" nil nil)
(register-definition-prefixes "ucs-normalize" '("ucs-normalize-" "utf-8-hfs"))
@@ -36309,7 +36526,7 @@ Report an ERROR that occurred while unlocking a file.
\(fn ERROR)" nil nil)
-(register-definition-prefixes "userlock" '("ask-user-about-" "file-" "userlock--"))
+(register-definition-prefixes "userlock" '("ask-user-about-" "file-" "userlock--check-content-unchanged"))
;;;***
@@ -36439,6 +36656,10 @@ For old-style locking-based version control systems, like RCS:
If every file is locked by you and unchanged, unlock them.
If every file is locked by someone else, offer to steal the lock.
+When using this command to register a new file (or files), it
+will automatically deduce which VC repository to register it
+with, using the most specific one.
+
\(fn VERBOSE)" t nil)
(autoload 'vc-register "vc" "\
@@ -37093,7 +37314,7 @@ Key bindings:
;;;### (autoloads nil "verilog-mode" "progmodes/verilog-mode.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from progmodes/verilog-mode.el
-(push (purecopy '(verilog-mode 2021 9 23 89128420)) package--builtin-versions)
+(push (purecopy '(verilog-mode 2021 10 14 127365406)) package--builtin-versions)
(autoload 'verilog-mode "verilog-mode" "\
Major mode for editing Verilog code.
@@ -39018,7 +39239,7 @@ where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or
a single modifier.
If PREFIX is `none', no prefix is used. If MODIFIERS is `none',
the keybindings are directly bound to the arrow keys.
-Default value of PREFIX is `C-x' and MODIFIERS is `shift'.
+Default value of PREFIX is \\`C-x' and MODIFIERS is `shift'.
\(fn &optional PREFIX MODIFIERS)" t nil)
@@ -39241,15 +39462,24 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT.
;;;### (autoloads nil "xref" "progmodes/xref.el" (0 0 0 0))
;;; Generated autoloads from progmodes/xref.el
-(push (purecopy '(xref 1 3 0)) package--builtin-versions)
+(push (purecopy '(xref 1 3 2)) package--builtin-versions)
(autoload 'xref-find-backend "xref" nil nil nil)
-(autoload 'xref-pop-marker-stack "xref" "\
-Pop back to where \\[xref-find-definitions] was last invoked." t nil)
+(define-obsolete-function-alias 'xref-pop-marker-stack #'xref-go-back "29.1")
+
+(autoload 'xref-go-back "xref" "\
+Go back to the previous position in xref history.
+To undo, use \\[xref-go-forward]." t nil)
+
+(autoload 'xref-go-forward "xref" "\
+Got to the point where a previous \\[xref-go-back] was invoked." t nil)
(autoload 'xref-marker-stack-empty-p "xref" "\
-Return t if the marker stack is empty; nil otherwise." nil nil)
+Whether the xref back-history is empty." nil nil)
+
+(autoload 'xref-forward-history-empty-p "xref" "\
+Whether the xref forward-history is empty." nil nil)
(autoload 'xref-find-definitions "xref" "\
Find the definition of the identifier at point.
@@ -39261,7 +39491,7 @@ definition for IDENTIFIER, display it in the selected window.
Otherwise, display the list of the possible definitions in a
buffer where the user can select from the list.
-Use \\[xref-pop-marker-stack] to return back to where you invoked this command.
+Use \\[xref-go-back] to return back to where you invoked this command.
\(fn IDENTIFIER)" t nil)
@@ -39305,7 +39535,8 @@ output of this command when the backend is etags.
\(fn PATTERN)" t nil)
(define-key esc-map "." #'xref-find-definitions)
- (define-key esc-map "," #'xref-pop-marker-stack)
+ (define-key esc-map "," #'xref-go-back)
+ (define-key esc-map [?\C-,] #'xref-go-forward)
(define-key esc-map "?" #'xref-find-references)
(define-key esc-map [?\C-.] #'xref-find-apropos)
(define-key ctl-x-4-map "." #'xref-find-definitions-other-window)
@@ -39415,6 +39646,33 @@ Interactively, URL defaults to the string looking like a url around point.
;;;***
+;;;### (autoloads nil "yank-media" "yank-media.el" (0 0 0 0))
+;;; Generated autoloads from yank-media.el
+
+(autoload 'yank-media "yank-media" "\
+Yank media (images, HTML and the like) from the clipboard.
+This command depends on the current major mode having support for
+accepting the media type. The mode has to register itself using
+the `yank-media-handler' mechanism.
+
+Also see `yank-media-types' for a command that lets you explore
+all the different selection types." t nil)
+
+(autoload 'yank-media-handler "yank-media" "\
+Register HANDLER for dealing with `yank-media' actions for TYPES.
+TYPES should be a MIME media type symbol, a regexp, or a list
+that can contain both symbols and regexps.
+
+HANDLER is a function that will be called with two arguments: The
+MIME type (a symbol on the form `image/png') and the selection
+data (a string).
+
+\(fn TYPES HANDLER)" nil nil)
+
+(register-definition-prefixes "yank-media" '("yank-media-"))
+
+;;;***
+
;;;### (autoloads nil "yenc" "mail/yenc.el" (0 0 0 0))
;;; Generated autoloads from mail/yenc.el
@@ -39449,12 +39707,10 @@ Zone out, completely." t nil)
;;;### (autoloads nil nil ("abbrev.el" "bindings.el" "buff-menu.el"
;;;;;; "button.el" "calc/calc-aent.el" "calc/calc-embed.el" "calc/calc-misc.el"
-;;;;;; "calc/calc-yank.el" "calendar/cal-loaddefs.el" "calendar/diary-loaddefs.el"
-;;;;;; "calendar/hol-loaddefs.el" "case-table.el" "cedet/ede/base.el"
-;;;;;; "cedet/ede/config.el" "cedet/ede/cpp-root.el" "cedet/ede/custom.el"
-;;;;;; "cedet/ede/dired.el" "cedet/ede/emacs.el" "cedet/ede/files.el"
-;;;;;; "cedet/ede/generic.el" "cedet/ede/linux.el" "cedet/ede/locate.el"
-;;;;;; "cedet/ede/make.el" "cedet/ede/shell.el" "cedet/ede/speedbar.el"
+;;;;;; "calc/calc-yank.el" "case-table.el" "cedet/ede/cpp-root.el"
+;;;;;; "cedet/ede/custom.el" "cedet/ede/dired.el" "cedet/ede/emacs.el"
+;;;;;; "cedet/ede/files.el" "cedet/ede/generic.el" "cedet/ede/linux.el"
+;;;;;; "cedet/ede/locate.el" "cedet/ede/make.el" "cedet/ede/speedbar.el"
;;;;;; "cedet/ede/system.el" "cedet/ede/util.el" "cedet/semantic/analyze.el"
;;;;;; "cedet/semantic/analyze/complete.el" "cedet/semantic/analyze/refs.el"
;;;;;; "cedet/semantic/bovine.el" "cedet/semantic/bovine/c-by.el"
@@ -39486,8 +39742,8 @@ Zone out, completely." t nil)
;;;;;; "cedet/srecode/insert.el" "cedet/srecode/java.el" "cedet/srecode/map.el"
;;;;;; "cedet/srecode/mode.el" "cedet/srecode/srt-wy.el" "cedet/srecode/srt.el"
;;;;;; "cedet/srecode/template.el" "cedet/srecode/texi.el" "composite.el"
-;;;;;; "cus-face.el" "cus-start.el" "custom.el" "dired-aux.el" "dired-x.el"
-;;;;;; "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el"
+;;;;;; "cus-face.el" "cus-load.el" "cus-start.el" "custom.el" "dired-aux.el"
+;;;;;; "dired-x.el" "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el"
;;;;;; "emacs-lisp/cl-extra.el" "emacs-lisp/cl-macs.el" "emacs-lisp/cl-preloaded.el"
;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/easymenu.el" "emacs-lisp/eieio-compat.el"
;;;;;; "emacs-lisp/eieio-custom.el" "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el"
@@ -39509,44 +39765,46 @@ Zone out, completely." t nil)
;;;;;; "eshell/em-ls.el" "eshell/em-pred.el" "eshell/em-prompt.el"
;;;;;; "eshell/em-rebind.el" "eshell/em-script.el" "eshell/em-smart.el"
;;;;;; "eshell/em-term.el" "eshell/em-tramp.el" "eshell/em-unix.el"
-;;;;;; "eshell/em-xtra.el" "faces.el" "files.el" "font-core.el"
-;;;;;; "font-lock.el" "format.el" "frame.el" "help.el" "hfy-cmap.el"
-;;;;;; "ibuf-ext.el" "indent.el" "international/characters.el" "international/charprop.el"
+;;;;;; "eshell/em-xtra.el" "eshell/esh-groups.el" "faces.el" "files.el"
+;;;;;; "finder-inf.el" "font-core.el" "font-lock.el" "format.el"
+;;;;;; "frame.el" "help.el" "hfy-cmap.el" "ibuf-ext.el" "indent.el"
+;;;;;; "international/characters.el" "international/charprop.el"
;;;;;; "international/charscript.el" "international/cp51932.el"
-;;;;;; "international/emoji-zwj.el" "international/eucjp-ms.el"
-;;;;;; "international/iso-transl.el" "international/mule-cmds.el"
-;;;;;; "international/mule-conf.el" "international/mule.el" "international/uni-bidi.el"
-;;;;;; "international/uni-brackets.el" "international/uni-category.el"
-;;;;;; "international/uni-combining.el" "international/uni-comment.el"
-;;;;;; "international/uni-decimal.el" "international/uni-decomposition.el"
-;;;;;; "international/uni-digit.el" "international/uni-lowercase.el"
-;;;;;; "international/uni-mirrored.el" "international/uni-name.el"
-;;;;;; "international/uni-numeric.el" "international/uni-old-name.el"
-;;;;;; "international/uni-special-lowercase.el" "international/uni-special-titlecase.el"
-;;;;;; "international/uni-special-uppercase.el" "international/uni-titlecase.el"
-;;;;;; "international/uni-uppercase.el" "isearch.el" "jit-lock.el"
-;;;;;; "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el"
-;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el"
-;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el"
-;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el"
-;;;;;; "language/indian.el" "language/japanese.el" "language/khmer.el"
-;;;;;; "language/korean.el" "language/lao.el" "language/misc-lang.el"
-;;;;;; "language/romanian.el" "language/sinhala.el" "language/slovak.el"
-;;;;;; "language/tai-viet.el" "language/thai.el" "language/tibetan.el"
-;;;;;; "language/utf-8-lang.el" "language/vietnamese.el" "ldefs-boot.el"
-;;;;;; "leim/ja-dic/ja-dic.el" "leim/leim-list.el" "leim/quail/4Corner.el"
-;;;;;; "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el"
-;;;;;; "leim/quail/CTLau.el" "leim/quail/ECDICT.el" "leim/quail/ETZY.el"
-;;;;;; "leim/quail/PY-b5.el" "leim/quail/PY.el" "leim/quail/Punct-b5.el"
-;;;;;; "leim/quail/Punct.el" "leim/quail/QJ-b5.el" "leim/quail/QJ.el"
-;;;;;; "leim/quail/SW.el" "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el"
-;;;;;; "leim/quail/ZOZY.el" "leim/quail/arabic.el" "leim/quail/cham.el"
-;;;;;; "leim/quail/compose.el" "leim/quail/croatian.el" "leim/quail/cyril-jis.el"
-;;;;;; "leim/quail/cyrillic.el" "leim/quail/czech.el" "leim/quail/georgian.el"
-;;;;;; "leim/quail/greek.el" "leim/quail/hanja-jis.el" "leim/quail/hanja.el"
-;;;;;; "leim/quail/hanja3.el" "leim/quail/hebrew.el" "leim/quail/ipa-praat.el"
-;;;;;; "leim/quail/latin-alt.el" "leim/quail/latin-ltx.el" "leim/quail/latin-post.el"
-;;;;;; "leim/quail/latin-pre.el" "leim/quail/persian.el" "leim/quail/programmer-dvorak.el"
+;;;;;; "international/emoji-labels.el" "international/emoji-zwj.el"
+;;;;;; "international/eucjp-ms.el" "international/iso-transl.el"
+;;;;;; "international/mule-cmds.el" "international/mule-conf.el"
+;;;;;; "international/mule.el" "international/uni-bidi.el" "international/uni-brackets.el"
+;;;;;; "international/uni-category.el" "international/uni-combining.el"
+;;;;;; "international/uni-comment.el" "international/uni-decimal.el"
+;;;;;; "international/uni-decomposition.el" "international/uni-digit.el"
+;;;;;; "international/uni-lowercase.el" "international/uni-mirrored.el"
+;;;;;; "international/uni-name.el" "international/uni-numeric.el"
+;;;;;; "international/uni-old-name.el" "international/uni-special-lowercase.el"
+;;;;;; "international/uni-special-titlecase.el" "international/uni-special-uppercase.el"
+;;;;;; "international/uni-titlecase.el" "international/uni-uppercase.el"
+;;;;;; "isearch.el" "jit-lock.el" "jka-cmpr-hook.el" "keymap.el"
+;;;;;; "language/burmese.el" "language/cham.el" "language/chinese.el"
+;;;;;; "language/cyrillic.el" "language/czech.el" "language/english.el"
+;;;;;; "language/ethiopic.el" "language/european.el" "language/georgian.el"
+;;;;;; "language/greek.el" "language/hebrew.el" "language/indian.el"
+;;;;;; "language/japanese.el" "language/khmer.el" "language/korean.el"
+;;;;;; "language/lao.el" "language/misc-lang.el" "language/romanian.el"
+;;;;;; "language/sinhala.el" "language/slovak.el" "language/tai-viet.el"
+;;;;;; "language/thai.el" "language/tibetan.el" "language/utf-8-lang.el"
+;;;;;; "language/vietnamese.el" "ldefs-boot.el" "leim/ja-dic/ja-dic.el"
+;;;;;; "leim/leim-list.el" "leim/quail/4Corner.el" "leim/quail/ARRAY30.el"
+;;;;;; "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el" "leim/quail/CTLau.el"
+;;;;;; "leim/quail/ECDICT.el" "leim/quail/ETZY.el" "leim/quail/PY-b5.el"
+;;;;;; "leim/quail/PY.el" "leim/quail/Punct-b5.el" "leim/quail/Punct.el"
+;;;;;; "leim/quail/QJ-b5.el" "leim/quail/QJ.el" "leim/quail/SW.el"
+;;;;;; "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el" "leim/quail/ZOZY.el"
+;;;;;; "leim/quail/arabic.el" "leim/quail/cham.el" "leim/quail/compose.el"
+;;;;;; "leim/quail/croatian.el" "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el"
+;;;;;; "leim/quail/czech.el" "leim/quail/georgian.el" "leim/quail/greek.el"
+;;;;;; "leim/quail/hanja-jis.el" "leim/quail/hanja.el" "leim/quail/hanja3.el"
+;;;;;; "leim/quail/hebrew.el" "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el"
+;;;;;; "leim/quail/latin-ltx.el" "leim/quail/latin-post.el" "leim/quail/latin-pre.el"
+;;;;;; "leim/quail/persian.el" "leim/quail/programmer-dvorak.el"
;;;;;; "leim/quail/py-punct.el" "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el"
;;;;;; "leim/quail/quick-cns.el" "leim/quail/rfc1345.el" "leim/quail/sami.el"
;;;;;; "leim/quail/sgml-input.el" "leim/quail/slovak.el" "leim/quail/symbol-ksc.el"
@@ -39555,14 +39813,13 @@ Zone out, completely." t nil)
;;;;;; "loadup.el" "mail/blessmail.el" "mail/rmailedit.el" "mail/rmailkwd.el"
;;;;;; "mail/rmailmm.el" "mail/rmailmsc.el" "mail/rmailsort.el"
;;;;;; "mail/rmailsum.el" "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el"
-;;;;;; "mh-e/mh-loaddefs.el" "minibuffer.el" "mouse.el" "net/tramp-loaddefs.el"
-;;;;;; "newcomment.el" "obarray.el" "org/ob-core.el" "org/ob-lob.el"
-;;;;;; "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" "org/ol-bbdb.el"
-;;;;;; "org/ol-irc.el" "org/ol.el" "org/org-archive.el" "org/org-attach.el"
-;;;;;; "org/org-clock.el" "org/org-colview.el" "org/org-compat.el"
-;;;;;; "org/org-datetree.el" "org/org-duration.el" "org/org-element.el"
-;;;;;; "org/org-feed.el" "org/org-footnote.el" "org/org-goto.el"
-;;;;;; "org/org-id.el" "org/org-indent.el" "org/org-install.el"
+;;;;;; "minibuffer.el" "mouse.el" "newcomment.el" "obarray.el" "org/ob-core.el"
+;;;;;; "org/ob-lob.el" "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el"
+;;;;;; "org/ol-bbdb.el" "org/ol-irc.el" "org/ol.el" "org/org-archive.el"
+;;;;;; "org/org-attach.el" "org/org-clock.el" "org/org-colview.el"
+;;;;;; "org/org-compat.el" "org/org-datetree.el" "org/org-duration.el"
+;;;;;; "org/org-element.el" "org/org-feed.el" "org/org-footnote.el"
+;;;;;; "org/org-goto.el" "org/org-id.el" "org/org-indent.el" "org/org-install.el"
;;;;;; "org/org-keys.el" "org/org-lint.el" "org/org-list.el" "org/org-macs.el"
;;;;;; "org/org-mobile.el" "org/org-num.el" "org/org-plot.el" "org/org-refile.el"
;;;;;; "org/org-table.el" "org/org-timer.el" "org/ox-ascii.el" "org/ox-beamer.el"
diff --git a/lisp/leim/quail/hangul.el b/lisp/leim/quail/hangul.el
index c03e86b33c0..d069b5b68e1 100644
--- a/lisp/leim/quail/hangul.el
+++ b/lisp/leim/quail/hangul.el
@@ -429,7 +429,7 @@ When a Korean input method is off, convert the following hangul character."
(hangul3-input-method-jong char))
(t
(setq hangul-queue (make-vector 6 0))
- (insert (decode-char 'ucs char))
+ (insert char)
(move-overlay quail-overlay (point) (point))))))
(defun hangul3-input-method (key)
@@ -476,7 +476,7 @@ When a Korean input method is off, convert the following hangul character."
(hangul3-input-method-jong char))
(t
(setq hangul-queue (make-vector 6 0))
- (insert (decode-char 'ucs char))
+ (insert char)
(move-overlay quail-overlay (point) (point))))))
(defun hangul390-input-method (key)
diff --git a/lisp/leim/quail/ipa.el b/lisp/leim/quail/ipa.el
index c25687574ed..ba6ea938425 100644
--- a/lisp/leim/quail/ipa.el
+++ b/lisp/leim/quail/ipa.el
@@ -278,10 +278,10 @@ string."
(list
(apply #'vector
(mapcar
- #'(lambda (entry)
- (cl-assert (char-or-string-p entry) t)
- (format "%s%s" to-prepend
- (if (integerp entry) (string entry) entry)))
+ (lambda (entry)
+ (cl-assert (char-or-string-p entry) t)
+ (format "%s%s" to-prepend
+ (if (integerp entry) (string entry) entry)))
quail-keymap))))
(defun ipa-x-sampa-underscore-implosive (input-string length)
diff --git a/lisp/leim/quail/latin-post.el b/lisp/leim/quail/latin-post.el
index 8329fff82ed..0e1afba1a34 100644
--- a/lisp/leim/quail/latin-post.el
+++ b/lisp/leim/quail/latin-post.el
@@ -215,7 +215,15 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\='
others | / | s/ -> ß
Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\='
-" nil t nil nil nil nil nil nil nil nil t)
+"
+ '(("\C-?" . quail-delete-last-char)
+ (">" . quail-next-translation)
+ ("\C-f" . quail-next-translation)
+ ([right] . quail-next-translation)
+ ("<" . quail-prev-translation)
+ ("\C-b" . quail-prev-translation)
+ ([left] . quail-prev-translation))
+ t nil nil nil nil nil nil nil nil t)
(quail-define-rules
("A'" ?Á)
@@ -246,9 +254,9 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\='
("R'" ?Ŕ)
("R~" ?Ř)
("S'" ?Ś)
- ("S," ?Ş)
+ ("S," "ŞȘ") ; the second variant is for Romanian
("S~" ?Š)
- ("T," ?Ţ)
+ ("T," "ŢȚ") ; the second variant is for Romanian
("T~" ?Ť)
("U'" ?Ú)
("U:" ?Ű)
@@ -286,10 +294,10 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\='
("r'" ?ŕ)
("r~" ?ř)
("s'" ?ś)
- ("s," ?ş)
+ ("s," "şș") ; the second variant is for Romanian
("s/" ?ß)
("s~" ?š)
- ("t," ?ţ)
+ ("t," "ţț") ; the second variant is for Romanian
("t~" ?ť)
("u'" ?ú)
("u:" ?ű)
diff --git a/lisp/leim/quail/latin-pre.el b/lisp/leim/quail/latin-pre.el
index 3b9c942a8c1..3492de5fbae 100644
--- a/lisp/leim/quail/latin-pre.el
+++ b/lisp/leim/quail/latin-pre.el
@@ -497,7 +497,15 @@ Key translation rules are:
cedilla | \\=` | \\=`c -> ç \\=`e -> ?ę
misc | \\=' \\=` ~ | \\='d -> đ \\=`l -> ł \\=`z -> ż ~o -> ő ~u -> ű
symbol | ~ | \\=`. -> ˙ ~~ -> ˘ ~. -> ?¸
-" nil t nil nil nil nil nil nil nil nil t)
+"
+ '(("\C-?" . quail-delete-last-char)
+ (">" . quail-next-translation)
+ ("\C-f" . quail-next-translation)
+ ([right] . quail-next-translation)
+ ("<" . quail-prev-translation)
+ ("\C-b" . quail-prev-translation)
+ ([left] . quail-prev-translation))
+ t nil nil nil nil nil nil nil nil t)
(quail-define-rules
("'A" ?Á)
@@ -532,15 +540,15 @@ Key translation rules are:
("`C" ?Ç)
("`E" ?Ę)
("`L" ?Ł)
- ("`S" ?Ş)
- ("`T" ?Ţ)
+ ("`S" "ŞȘ")
+ ("`T" "ŢȚ") ; the second variant is for Romanian
("`Z" ?Ż)
("`a" ?ą)
("`l" ?ł)
("`c" ?ç)
("`e" ?ę)
- ("`s" ?ş)
- ("`t" ?ţ)
+ ("`s" "şș")
+ ("`t" "ţț") ; the second variant is for Romanian
("`z" ?ż)
("``" ?Ş)
("`." ?˙)
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 4da0ff73851..b87c0550fc5 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -131,6 +131,7 @@
(load "emacs-lisp/byte-run")
(load "emacs-lisp/backquote")
(load "subr")
+(load "keymap")
;; Do it after subr, since both after-load-functions and add-hook are
;; implemented in subr.el.
@@ -302,6 +303,11 @@
(load "term/common-win")
(load "term/x-win")))
+(if (featurep 'haiku)
+ (progn
+ (load "term/common-win")
+ (load "term/haiku-win")))
+
(if (or (eq system-type 'windows-nt)
(featurep 'w32))
(progn
@@ -334,6 +340,13 @@
(load "international/mule-util")
(load "international/ucs-normalize")
(load "term/ns-win"))))
+(if (featurep 'pgtk)
+ (progn
+ (load "term/common-win")
+ ;; Don't load ucs-normalize.el unless uni-*.el files were
+ ;; already produced, because it needs uni-*.el files that might
+ ;; not be built early enough during bootstrap.
+ (load "term/pgtk-win")))
(if (fboundp 'x-create-frame)
;; Do it after loading term/foo-win.el since the value of the
;; mouse-wheel-*-event vars depends on those files being loaded or not.
@@ -559,6 +572,7 @@ lost after dumping")))
(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"))))
diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el
index 82153ff0adb..25d196392ab 100644
--- a/lisp/ls-lisp.el
+++ b/lisp/ls-lisp.el
@@ -337,18 +337,7 @@ are also supported; unsupported long options are silently ignored."
(ls-lisp-insert-directory
file switches (ls-lisp-time-index switches)
nil full-directory-p))
- (signal (car err) (cdr err)))))
- ;; Try to insert the amount of free space.
- (save-excursion
- (goto-char (point-min))
- ;; First find the line to put it on.
- (when (re-search-forward "^total" nil t)
- (let ((available (get-free-disk-space ".")))
- (when available
- ;; Replace "total" with "total used", to avoid confusion.
- (replace-match "total used in directory")
- (end-of-line)
- (insert " available " available)))))))))
+ (signal (car err) (cdr err)))))))))
(advice-add 'insert-directory :around #'ls-lisp--insert-directory)
(defun ls-lisp-insert-directory
diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el
index fe686cb6f86..32edc292619 100644
--- a/lisp/mail/feedmail.el
+++ b/lisp/mail/feedmail.el
@@ -2336,19 +2336,14 @@ mapped to mostly alphanumerics for safety."
;; from a similar function in mail-utils.el
(defun feedmail-rfc822-time-zone (time)
+ (declare (obsolete format-time-string "29.1"))
(feedmail-say-debug ">in-> feedmail-rfc822-time-zone %s" time)
- (let* ((sec (or (car (current-time-zone time)) 0))
- (absmin (/ (abs sec) 60)))
- (format "%c%02d%02d" (if (< sec 0) ?- ?+) (/ absmin 60) (% absmin 60))))
+ (format-time-string "%z" time))
(defun feedmail-rfc822-date (arg-time)
(feedmail-say-debug ">in-> feedmail-rfc822-date %s" arg-time)
- (let ((time (or arg-time (current-time)))
- (system-time-locale "C"))
- (concat
- (format-time-string "%a, %e %b %Y %T " time)
- (feedmail-rfc822-time-zone time)
- )))
+ (let ((system-time-locale "C"))
+ (format-time-string "%a, %e %b %Y %T %z" arg-time)))
(defun feedmail-send-it-immediately-wrapper ()
"Wrapper to catch skip-me-i."
@@ -2847,10 +2842,9 @@ probably not appropriate for you."
(if (and (not feedmail-queue-use-send-time-for-message-id) maybe-file)
(setq date-time (file-attribute-modification-time
(file-attributes maybe-file))))
- (format "<%d-%s%s%s>"
+ (format "<%d-%s%s>"
(mod (random) 10000)
- (format-time-string "%a%d%b%Y%H%M%S" date-time)
- (feedmail-rfc822-time-zone date-time)
+ (format-time-string "%a%d%b%Y%H%M%S%z" date-time)
end-stuff))
)
diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el
index 716348a9c19..ef040ca90b3 100644
--- a/lisp/mail/footnote.el
+++ b/lisp/mail/footnote.el
@@ -898,7 +898,7 @@ play around with the following keys:
(make-local-variable 'footnote-end-tag)
(make-local-variable 'adaptive-fill-function)
- ;; Filladapt was an XEmacs package which is now in GNU ELPA.
+ ;; Filladapt is a GNU ELPA package.
(when (boundp 'filladapt-token-table)
;; add tokens to filladapt to match footnotes
;; 1] xxxxxxxxxxx x x x or [1] x x x x x x x
diff --git a/lisp/mail/mail-utils.el b/lisp/mail/mail-utils.el
index 3eb3ccb93de..f1b0590bec7 100644
--- a/lisp/mail/mail-utils.el
+++ b/lisp/mail/mail-utils.el
@@ -368,19 +368,12 @@ matches may be returned from the message body."
labels)
(defun mail-rfc822-time-zone (time)
- (let* ((sec (or (car (current-time-zone time)) 0))
- (absmin (/ (abs sec) 60)))
- (format "%c%02d%02d" (if (< sec 0) ?- ?+) (/ absmin 60) (% absmin 60))))
+ (declare (obsolete format-time-string "29.1"))
+ (format-time-string "%z" time))
(defun mail-rfc822-date ()
- (let* ((time (current-time))
- (s (current-time-string time)))
- (string-match "[^ ]+ +\\([^ ]+\\) +\\([^ ]+\\) \\([^ ]+\\) \\([^ ]+\\)" s)
- (concat (substring s (match-beginning 2) (match-end 2)) " "
- (substring s (match-beginning 1) (match-end 1)) " "
- (substring s (match-beginning 4) (match-end 4)) " "
- (substring s (match-beginning 3) (match-end 3)) " "
- (mail-rfc822-time-zone time))))
+ (let ((system-time-locale "C"))
+ (format-time-string "%-d %b %Y %T %z")))
(defun mail-mbox-from ()
"Return an mbox \"From \" line for the current message.
diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el
index 9fbc9ba180f..47fd28c18ef 100644
--- a/lisp/mail/rmail.el
+++ b/lisp/mail/rmail.el
@@ -41,8 +41,6 @@
(require 'rfc2047)
(require 'auth-source)
-(require 'rmail-loaddefs)
-
(declare-function compilation--message->loc "compile" (cl-x) t)
(declare-function epa--find-coding-system-for-mime-charset "epa" (mime-charset))
@@ -4125,10 +4123,8 @@ typically for purposes of moderating a list."
"A regexp that matches the separator before the text of a failed message.")
(defvar mail-mime-unsent-header "^Content-Type: message/rfc822 *$"
- "A regexp that matches the header of a MIME body part with a failed message.")
+ "A regexp that matches the header of a MIME body part with a failed message.")
-;; This is a cut-down version of rmail-clear-headers from Emacs 22.
-;; It doesn't have the same functionality, hence the name change.
(defun rmail-delete-headers (regexp)
"Delete any mail headers matching REGEXP.
The message should be narrowed to just the headers."
@@ -4136,10 +4132,6 @@ The message should be narrowed to just the headers."
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(beginning-of-line)
- ;; This code from Emacs 22 doesn't seem right, since r-n-h is
- ;; just for display.
-;;; (if (looking-at rmail-nonignored-headers)
-;;; (forward-line 1)
(delete-region (point)
(save-excursion
(if (re-search-forward "\n[^ \t]" nil t)
diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el
index fd24bdceccc..18859f2b28d 100644
--- a/lisp/mail/rmailedit.el
+++ b/lisp/mail/rmailedit.el
@@ -484,8 +484,4 @@ HEADER-DIFF should be a return value from `rmail-edit-diff-headers'."
(provide 'rmailedit)
-;; Local Variables:
-;; generated-autoload-file: "rmail-loaddefs.el"
-;; End:
-
;;; rmailedit.el ends here
diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el
index 58a8eb7a370..7efbfde27d1 100644
--- a/lisp/mail/rmailkwd.el
+++ b/lisp/mail/rmailkwd.el
@@ -74,12 +74,9 @@ according to the choice made, and returns a symbol."
(rmail-summary-exists)
(and (setq old (rmail-get-keywords))
(mapc #'rmail-make-label (split-string old ", "))))
- (completing-read (concat prompt
- (if rmail-last-label
- (concat " (default "
- (symbol-name rmail-last-label)
- "): ")
- ": "))
+ (completing-read (format-prompt prompt
+ (and rmail-last-label
+ (symbol-name rmail-last-label)))
rmail-label-obarray
nil
nil))))
@@ -191,8 +188,4 @@ With prefix argument N moves forward N messages with these labels."
(provide 'rmailkwd)
-;; Local Variables:
-;; generated-autoload-file: "rmail-loaddefs.el"
-;; End:
-
;;; rmailkwd.el ends here
diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el
index 99bff66657b..563ce9d0b82 100644
--- a/lisp/mail/rmailmm.el
+++ b/lisp/mail/rmailmm.el
@@ -254,7 +254,7 @@ TRUNCATED is non-nil if the text of this entity was truncated."))
(unless (y-or-n-p "This entity is truncated; save anyway? ")
(error "Aborted")))
(setq filename (expand-file-name
- (read-file-name (format "Save as (default: %s): " filename)
+ (read-file-name (format-prompt "Save as" filename)
directory
(expand-file-name filename directory))
directory))
@@ -1569,8 +1569,4 @@ This is the usual value of `rmail-insert-mime-forwarded-message-function'."
(provide 'rmailmm)
-;; Local Variables:
-;; generated-autoload-file: "rmail-loaddefs.el"
-;; End:
-
;;; rmailmm.el ends here
diff --git a/lisp/mail/rmailmsc.el b/lisp/mail/rmailmsc.el
index 673b2c5a7e5..f5e89f8f17c 100644
--- a/lisp/mail/rmailmsc.el
+++ b/lisp/mail/rmailmsc.el
@@ -54,8 +54,4 @@ This applies only to the current session."
(setq rmail-inbox-list inbox-list)))
(rmail-show-message-1 rmail-current-message))
-;; Local Variables:
-;; generated-autoload-file: "rmail-loaddefs.el"
-;; End:
-
;;; rmailmsc.el ends here
diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el
index 91f86a234d4..1f5bb2d9f1b 100644
--- a/lisp/mail/rmailout.el
+++ b/lisp/mail/rmailout.el
@@ -107,9 +107,8 @@ error: %S\n"
(read-file
(expand-file-name
(read-file-name
- (concat "Output message to mail file (default "
- (file-name-nondirectory default-file)
- "): ")
+ (format-prompt "Output message to mail file"
+ (file-name-nondirectory default-file))
(file-name-directory default-file)
(abbreviate-file-name default-file))
(file-name-directory default-file))))
diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el
index 1669c8cd7bb..8c790116a3b 100644
--- a/lisp/mail/rmailsort.el
+++ b/lisp/mail/rmailsort.el
@@ -250,8 +250,4 @@ Numeric keys are sorted numerically, all others as strings."
(provide 'rmailsort)
-;; Local Variables:
-;; generated-autoload-file: "rmail-loaddefs.el"
-;; End:
-
;;; rmailsort.el ends here
diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el
index 9dd9573a9fc..ef172bc106f 100644
--- a/lisp/mail/rmailsum.el
+++ b/lisp/mail/rmailsum.el
@@ -1480,13 +1480,11 @@ argument says to read a file name and use that file as the inbox."
(declare-function rmail-output-read-file-name "rmailout" ())
(declare-function mail-send-and-exit "sendmail" (&optional arg))
-(defvar rmail-summary-edit-map nil)
-(if rmail-summary-edit-map
- nil
- (setq rmail-summary-edit-map
- (nconc (make-sparse-keymap) text-mode-map))
- (define-key rmail-summary-edit-map "\C-c\C-c" 'rmail-cease-edit)
- (define-key rmail-summary-edit-map "\C-c\C-]" 'rmail-abort-edit))
+(defvar rmail-summary-edit-map
+ (let ((map (nconc (make-sparse-keymap) text-mode-map)))
+ (define-key map "\C-c\C-c" #'rmail-cease-edit)
+ (define-key map "\C-c\C-]" #'rmail-abort-edit)
+ map))
(defun rmail-summary-edit-current-message ()
"Edit the contents of this message."
@@ -1879,8 +1877,4 @@ the summary is only showing a subset of messages."
(provide 'rmailsum)
-;; Local Variables:
-;; generated-autoload-file: "rmail-loaddefs.el"
-;; End:
-
;;; rmailsum.el ends here
diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el
index d0aff093dfe..d1e8a2f3c69 100644
--- a/lisp/mail/sendmail.el
+++ b/lisp/mail/sendmail.el
@@ -1391,8 +1391,7 @@ just append to the file, in Babyl format if necessary."
(unless (markerp header-end)
(error "Value of `header-end' must be a marker"))
(let (fcc-list
- (mailbuf (current-buffer))
- (time (current-time)))
+ (mailbuf (current-buffer)))
(save-excursion
(goto-char (point-min))
(let ((case-fold-search t))
@@ -1408,14 +1407,11 @@ just append to the file, in Babyl format if necessary."
(with-temp-buffer
;; This initial newline is not written out if we create a new
;; file (see below).
- (insert "\nFrom " (user-login-name) " " (current-time-string time) "\n")
- ;; Insert the time zone before the year.
- (forward-char -1)
- (forward-word-strictly -1)
(require 'mail-utils)
- (insert (mail-rfc822-time-zone time) " ")
- (goto-char (point-max))
- (insert "Date: " (message-make-date) "\n")
+ (insert "\nFrom " (user-login-name) " "
+ (let ((system-time-locale "C"))
+ (format-time-string "%a %b %e %T %z %Y"))
+ "\nDate: " (message-make-date) "\n")
(insert-buffer-substring mailbuf)
;; Make sure messages are separated.
(goto-char (point-max))
diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el
index f393ac773f5..b3080ac416b 100644
--- a/lisp/mail/supercite.el
+++ b/lisp/mail/supercite.el
@@ -1767,7 +1767,7 @@ is determined non-interactively. The value is queried for in the
minibuffer exactly the same way that `set-variable' does it.
You can see the current value of the variable when the minibuffer is
-querying you by typing `C-h'. Note that the format is changed
+querying you by typing \\`C-h'. Note that the format is changed
slightly from that used by `set-variable' -- the current value is
printed just after the variable's name instead of at the bottom of the
help window."
diff --git a/lisp/mail/uce.el b/lisp/mail/uce.el
index 0a488e176f6..4347ff14022 100644
--- a/lisp/mail/uce.el
+++ b/lisp/mail/uce.el
@@ -30,26 +30,8 @@
;; uce-reply-to-uce. Please let me know about your changes so I can
;; incorporate them. I'd appreciate it.
-;; -- !!! NOTE !!! ---------------------------------------------
-;;
-;; Replying to spam is at best pointless, but most likely actively
-;; harmful.
-;;
-;; - You will confirm that your email address is valid, thus ensuring
-;; you get more spam.
-;;
-;; - You will leak information and open yourself up for further
-;; attack. For example, they could use your \"geolocation\" to find
-;; your home address and phone number.
-;;
-;; - The sender address is likely fake.
-;;
-;; - You help them refine their methods of spamming.
-;;
-;; Therefore, we strongly recommend that you do not use this package.
-;; Use a spam filter instead, or just delete the spam.
-;;
-;; -------------------------------------------------------------
+;; NOTE: We don't recommend using this feature; see the message in
+;; 'uce-reply-to-uce' for the reasons.
;; The command uce-reply-to-uce, if called when the current message
;; buffer is a UCE, will setup a reply *mail* buffer as follows. It
@@ -234,6 +216,8 @@ These are mostly meant for headers that prevent delivery errors reporting."
(declare-function rmail-maybe-set-message-counters "rmail" ())
(declare-function rmail-toggle-header "rmail" (&optional arg))
+(defvar uce--usage-warning-displayed nil)
+
;;;###autoload
(defun uce-reply-to-uce (&optional _ignored)
"Compose a reply to unsolicited commercial email (UCE).
@@ -379,7 +363,32 @@ You might need to set `uce-mail-reader' before using this."
;; Run hooks before we leave buffer for editing. Reasonable usage
;; might be to set up special key bindings, replace standard
;; functions in mail-mode, etc.
- (run-hooks 'mail-setup-hook 'uce-setup-hook))))
+ (run-hooks 'mail-setup-hook 'uce-setup-hook)))
+ (unless uce--usage-warning-displayed
+ (setq uce--usage-warning-displayed t)
+ (pop-to-buffer (get-buffer-create "uce-reply-to-uce warning"))
+ (insert "\
+-- !!! NOTE !!! ---------------------------------------------
+
+Replying to spam is at best pointless, but most likely actively
+harmful.
+
+- You will confirm that your email address is valid, thus ensuring
+ you get more spam.
+
+- You will leak information and open yourself up for further
+ attack. For example, they could use your \"geolocation\" to find
+ your home address and phone number.
+
+- The sender address is likely fake.
+
+- You help them refine their methods of spamming.
+
+Therefore, we strongly recommend that you do not use this package.
+Use a spam filter instead, or just delete the spam.
+
+-------------------------------------------------------------
+")))
(defun uce-insert-ranting (&optional _ignored)
"Insert text of the usual reply to UCE into current buffer."
diff --git a/lisp/man.el b/lisp/man.el
index 4ef2deac4f3..fff31baa5f3 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -1334,7 +1334,7 @@ default type, `Man-xref-man-page' is used for the buttons."
(defun Man-highlight-references0 (start-section regexp button-pos target type)
;; Based on `Man-build-references-alist'
- (when (or (null start-section) ;; Search regardless of sections.
+ (when (or (null start-section) ;; Search regardless of sections.
;; Section header is in this chunk.
(Man-find-section start-section))
(let ((end (if start-section
@@ -1347,18 +1347,24 @@ default type, `Man-xref-man-page' is used for the buttons."
(goto-char (point-min))
nil)))
(while (re-search-forward regexp end t)
- ;; An overlay button is preferable because the underlying text
- ;; may have text property highlights (Bug#7881).
- (make-button
- (match-beginning button-pos)
- (match-end button-pos)
- 'type type
- 'Man-target-string (cond
- ((numberp target)
- (match-string target))
- ((functionp target)
- target)
- (t nil)))))))
+ (let ((b (match-beginning button-pos))
+ (e (match-end button-pos))
+ (match (match-string button-pos)))
+ ;; Some lists of references end with ", and ...". Chop the
+ ;; "and" bit off before making a button.
+ (when (string-match "\\`and +" match)
+ (setq b (+ b (- (match-end 0) (match-beginning 0)))))
+ ;; An overlay button is preferable because the underlying text
+ ;; may have text property highlights (Bug#7881).
+ (make-button
+ b e
+ 'type type
+ 'Man-target-string (cond
+ ((numberp target)
+ (match-string target))
+ ((functionp target)
+ target)
+ (t nil))))))))
(defun Man-cleanup-manpage (&optional interactive)
"Remove overstriking and underlining from the current buffer.
@@ -1786,7 +1792,7 @@ Returns t if section is found, nil otherwise."
Man--last-section
(car Man--sections)))
(completion-ignore-case t)
- (prompt (concat "Go to section (default " default "): "))
+ (prompt (format-prompt "Go to section" default))
(chosen (completing-read prompt Man--sections
nil nil nil nil default)))
(list chosen))
@@ -1850,7 +1856,7 @@ Specify which REFERENCE to use; default is based on word at point."
(defaults
(mapcar 'substring-no-properties
(cons default Man--refpages)))
- (prompt (concat "Refer to (default " default "): "))
+ (prompt (format-prompt "Refer to" default))
(chosen (completing-read prompt Man--refpages
nil nil nil nil defaults)))
chosen)))
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index da79aae5295..bd110226618 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -413,8 +413,14 @@
(bindings--define-key menu [separator-tag-file]
'(menu-item "--" nil :visible (menu-bar-goto-uses-etags-p)))
+ (bindings--define-key menu [xref-forward]
+ '(menu-item "Forward" xref-go-forward
+ :visible (and (featurep 'xref)
+ (not (xref-forward-history-empty-p)))
+ :help "Forward to the position gone Back from"))
+
(bindings--define-key menu [xref-pop]
- '(menu-item "Back" xref-pop-marker-stack
+ '(menu-item "Back" xref-go-back
:visible (and (featurep 'xref)
(not (xref-marker-stack-empty-p)))
:help "Back to the position of the last search"))
@@ -514,7 +520,11 @@
(cdr yank-menu)
kill-ring))
(not buffer-read-only))))
- :help "Paste (yank) text most recently cut/copied"))
+ :help "Paste (yank) text most recently cut/copied"
+ :keys ,(lambda ()
+ (if cua-mode
+ "\\[cua-paste]"
+ "\\[yank]"))))
(bindings--define-key menu [copy]
;; ns-win.el said: Substitute a Copy function that works better
;; under X (for GNUstep).
@@ -523,14 +533,23 @@
'kill-ring-save)
:enable mark-active
:help "Copy text in region between mark and current position"
- :keys ,(if (featurep 'ns)
- "\\[ns-copy-including-secondary]"
- "\\[kill-ring-save]")))
+ :keys ,(lambda ()
+ (cond
+ ((featurep 'ns)
+ "\\[ns-copy-including-secondary]")
+ ((and cua-mode mark-active)
+ "\\[cua-copy-handler]")
+ (t
+ "\\[kill-ring-save]")))))
(bindings--define-key menu [cut]
- '(menu-item "Cut" kill-region
+ `(menu-item "Cut" kill-region
:enable (and mark-active (not buffer-read-only))
:help
- "Cut (kill) text in region between mark and current position"))
+ "Cut (kill) text in region between mark and current position"
+ :keys ,(lambda ()
+ (if (and cua-mode mark-active)
+ "\\[cua-cut-handler]"
+ "\\[kill-region]"))))
;; ns-win.el said: Separate undo from cut/paste section.
(if (featurep 'ns)
(bindings--define-key menu [separator-undo] menu-bar-separator))
@@ -1328,14 +1347,13 @@ mail status in mode line"))
(frame-parameter (menu-bar-frame-for-menubar)
'menu-bar-lines)))))
- (unless (featurep 'ns)
- (bindings--define-key menu [showhide-tab-bar]
- '(menu-item "Tab Bar" toggle-tab-bar-mode-from-frame
- :help "Turn tab bar on/off"
- :button
- (:toggle . (menu-bar-positive-p
- (frame-parameter (menu-bar-frame-for-menubar)
- 'tab-bar-lines))))))
+ (bindings--define-key menu [showhide-tab-bar]
+ '(menu-item "Tab Bar" toggle-tab-bar-mode-from-frame
+ :help "Turn tab bar on/off"
+ :button
+ (:toggle . (menu-bar-positive-p
+ (frame-parameter (menu-bar-frame-for-menubar)
+ 'tab-bar-lines)))))
(if (and (boundp 'menu-bar-showhide-tool-bar-menu)
(keymapp menu-bar-showhide-tool-bar-menu))
@@ -1918,10 +1936,7 @@ key, a click, or a menu-item"))
(let* ((default (thing-at-point 'sexp))
(topic
(read-from-minibuffer
- (format "Subject to look up%s: "
- (if default
- (format " (default \"%s\")" default)
- ""))
+ (format-prompt "Subject to look up" default)
nil nil nil nil default)))
(list (if (zerop (length topic))
default
@@ -2163,6 +2178,12 @@ otherwise it could decide to silently do nothing."
:type 'integer
:group 'menu)
+(defcustom yank-menu-max-items 60
+ "Maximum number of entries to display in the `yank-menu'."
+ :type 'integer
+ :group 'menu
+ :version "29.1")
+
(defun menu-bar-update-yank-menu (string old)
(let ((front (car (cdr yank-menu)))
(menu-string (if (<= (length string) yank-menu-length)
@@ -2186,8 +2207,9 @@ otherwise it could decide to silently do nothing."
(cons
(cons string (cons menu-string 'menu-bar-select-yank))
(cdr yank-menu)))))
- (if (> (length (cdr yank-menu)) kill-ring-max)
- (setcdr (nthcdr kill-ring-max yank-menu) nil)))
+ (let ((max-items (min yank-menu-max-items kill-ring-max)))
+ (if (> (length (cdr yank-menu)) max-items)
+ (setcdr (nthcdr max-items yank-menu) nil))))
(put 'menu-bar-select-yank 'apropos-inhibit t)
(defun menu-bar-select-yank ()
@@ -2517,6 +2539,8 @@ See `menu-bar-mode' for more information."
(declare-function x-menu-bar-open "term/x-win" (&optional frame))
(declare-function w32-menu-bar-open "term/w32-win" (&optional frame))
+(declare-function pgtk-menu-bar-open "term/pgtk-win" (&optional frame))
+(declare-function haiku-menu-bar-open "haikumenu.c" (&optional frame))
(defun lookup-key-ignore-too-long (map key)
"Call `lookup-key' and convert numeric values to nil."
@@ -2642,9 +2666,10 @@ first TTY menu-bar menu to be dropped down. Interactively,
this is the numeric argument to the command.
This function decides which method to use to access the menu
depending on FRAME's terminal device. On X displays, it calls
-`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; otherwise it
-calls either `popup-menu' or `tmm-menubar' depending on whether
-`tty-menu-open-use-tmm' is nil or not.
+`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; on Haiku,
+`haiku-menu-bar-open'; otherwise it calls either `popup-menu'
+or `tmm-menubar' depending on whether `tty-menu-open-use-tmm'
+is nil or not.
If FRAME is nil or not given, use the selected frame."
(interactive
@@ -2653,6 +2678,8 @@ If FRAME is nil or not given, use the selected frame."
(cond
((eq type 'x) (x-menu-bar-open frame))
((eq type 'w32) (w32-menu-bar-open frame))
+ ((eq type 'haiku) (haiku-menu-bar-open frame))
+ ((eq type 'pgtk) (pgtk-menu-bar-open frame))
((and (null tty-menu-open-use-tmm)
(not (zerop (or (frame-parameter nil 'menu-bar-lines) 0))))
;; Make sure the menu bar is up to date. One situation where
diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el
index 8fdcf3c62b4..25fff6a8e1b 100644
--- a/lisp/mh-e/mh-acros.el
+++ b/lisp/mh-e/mh-acros.el
@@ -47,19 +47,20 @@
;;;###mh-autoload
(defmacro mh-do-in-gnu-emacs (&rest body)
"Execute BODY if in GNU Emacs."
- (declare (debug t) (indent defun))
+ (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 (debug t) (indent defun))
+ (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 (debug (symbolp body)))
+ (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 :-(
@@ -72,7 +73,8 @@
"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) (doc-string 4)
+ (declare (obsolete defun "29.1")
+ (indent defun) (doc-string 4)
(debug (&define name symbolp sexp def-body)))
`(defalias ',name
(if (fboundp ',function)
@@ -84,7 +86,8 @@ Otherwise, create function NAME with ARG-LIST and BODY."
"Create macro NAME.
If MACRO exists, then NAME becomes an alias for MACRO.
Otherwise, create macro NAME with ARG-LIST and BODY."
- (declare (indent defun) (doc-string 4)
+ (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
@@ -99,22 +102,20 @@ Otherwise, create macro NAME with ARG-LIST and BODY."
"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)
- "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs.
-In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then
-check if variable `transient-mark-mode' is active."
- (cond ((featurep 'xemacs) ;XEmacs
- '(and (boundp 'zmacs-regions) zmacs-regions (region-active-p)))
- ((not check-transient-mark-mode-flag) ;GNU Emacs
- '(and (boundp 'mark-active) mark-active))
- (t ;GNU Emacs
- '(and (boundp 'transient-mark-mode) transient-mark-mode
- (boundp 'mark-active) mark-active))))
+ "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)
@@ -164,12 +165,8 @@ preserved."
(original-position (make-symbol "original-position"))
(modified-flag (make-symbol "modified-flag")))
`(save-excursion
- (let* ((,event-window
- (or (mh-funcall-if-exists posn-window (event-start ,event))
- (mh-funcall-if-exists event-window ,event)))
- (,event-position
- (or (mh-funcall-if-exists posn-point (event-start ,event))
- (mh-funcall-if-exists event-closest-point ,event)))
+ (let* ((,event-window (posn-window (event-start ,event)))
+ (,event-position (posn-point (event-start ,event)))
(,original-window (selected-window))
(,original-position (progn
(set-buffer (window-buffer ,event-window))
diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el
index 37fdb166011..d2666211002 100644
--- a/lisp/mh-e/mh-alias.el
+++ b/lisp/mh-e/mh-alias.el
@@ -67,8 +67,7 @@ Return t if any file listed in the Aliasfile MH profile component has
been modified since the timestamp.
If ARG is non-nil, set timestamp with the current time."
(if arg
- (let ((time (current-time)))
- (setq mh-alias-tstamp (list (nth 0 time) (nth 1 time))))
+ (setq mh-alias-tstamp (current-time))
(let ((stamp))
(car (memq t (mapcar
(lambda (file)
@@ -112,10 +111,10 @@ COMMA-SEPARATOR is non-nil."
(setq res (match-string 1 res)))
;; Replace "&" with capitalized username
(if (string-search "&" res)
- (setq res (mh-replace-regexp-in-string "&" (capitalize username) res)))
+ (setq res (replace-regexp-in-string "&" (capitalize username) res)))
;; Remove " character
(if (string-search "\"" res)
- (setq res (mh-replace-regexp-in-string "\"" "" res)))
+ (setq res (replace-regexp-in-string "\"" "" res)))
;; If empty string, use username instead
(if (string-equal "" res)
(setq res username))
@@ -155,7 +154,7 @@ Exclude all aliases already in `mh-alias-alist' from \"ali\""
(if (string-equal username realname)
(concat "<" username ">")
(concat realname " <" username ">"))))
- (when (not (mh-assoc-string alias-name mh-alias-alist t))
+ (when (not (assoc-string alias-name mh-alias-alist t))
(setq passwd-alist (cons (list alias-name alias-translation)
passwd-alist)))))))
(forward-line 1)))
@@ -184,12 +183,12 @@ been loaded."
(cond
((looking-at "^[ \t]")) ;Continuation line
((looking-at "\\(.+\\): .+: .*$") ; A new -blind- MH alias
- (when (not (mh-assoc-string (match-string 1) mh-alias-blind-alist t))
+ (when (not (assoc-string (match-string 1) mh-alias-blind-alist t))
(setq mh-alias-blind-alist
(cons (list (match-string 1)) mh-alias-blind-alist))
(setq mh-alias-alist (cons (list (match-string 1)) mh-alias-alist))))
((looking-at "\\(.+\\): .*$") ; A new MH alias
- (when (not (mh-assoc-string (match-string 1) mh-alias-alist t))
+ (when (not (assoc-string (match-string 1) mh-alias-alist t))
(setq mh-alias-alist
(cons (list (match-string 1)) mh-alias-alist)))))
(forward-line 1)))
@@ -200,7 +199,7 @@ been loaded."
user)
(while local-users
(setq user (car local-users))
- (if (not (mh-assoc-string (car user) mh-alias-alist t))
+ (if (not (assoc-string (car user) mh-alias-alist t))
(setq mh-alias-alist (append mh-alias-alist (list user))))
(setq local-users (cdr local-users)))))
(run-hooks 'mh-alias-reloaded-hook)
@@ -239,16 +238,16 @@ done here."
"Return expansion for ALIAS.
Blind aliases or users from /etc/passwd are not expanded."
(cond
- ((mh-assoc-string alias mh-alias-blind-alist t)
+ ((assoc-string alias mh-alias-blind-alist t)
alias) ; Don't expand a blind alias
- ((mh-assoc-string alias mh-alias-passwd-alist t)
- (cadr (mh-assoc-string alias mh-alias-passwd-alist t)))
+ ((assoc-string alias mh-alias-passwd-alist t)
+ (cadr (assoc-string alias mh-alias-passwd-alist t)))
(t
(mh-alias-ali alias))))
(eval-and-compile
- (mh-require 'crm nil t) ; completing-read-multiple
- (mh-require 'multi-prompt nil t))
+ (require 'crm nil t) ; completing-read-multiple
+ (require 'multi-prompt nil t))
;;;###mh-autoload
(defun mh-read-address (prompt)
@@ -258,15 +257,7 @@ Blind aliases or users from /etc/passwd are not expanded."
(read-string prompt)
(let* ((minibuffer-local-completion-map mh-alias-read-address-map)
(completion-ignore-case mh-alias-completion-ignore-case-flag)
- (the-answer
- (cond ((fboundp 'completing-read-multiple)
- (mh-funcall-if-exists
- completing-read-multiple prompt mh-alias-alist nil nil))
- ((featurep 'multi-prompt)
- (mh-funcall-if-exists
- multi-prompt "," nil prompt mh-alias-alist nil nil))
- (t (split-string
- (completing-read prompt mh-alias-alist nil nil) ",")))))
+ (the-answer (completing-read-multiple prompt mh-alias-alist nil nil)))
(if (not mh-alias-expand-aliases-flag)
(mapconcat #'identity the-answer ", ")
;; Loop over all elements, checking if in passwd alias or blind first
@@ -281,7 +272,7 @@ Blind aliases or users from /etc/passwd are not expanded."
(let* ((case-fold-search t)
(beg (mh-beginning-of-word))
(the-name (buffer-substring-no-properties beg (point))))
- (if (mh-assoc-string the-name mh-alias-alist t)
+ (if (assoc-string the-name mh-alias-alist t)
(message "%s -> %s" the-name (mh-alias-expand the-name))
;; Check if it was a single word likely to be an alias
(if (and (equal mh-alias-flash-on-comma 1)
@@ -313,7 +304,7 @@ Blind aliases or users from /etc/passwd are not expanded."
res)
res)))
((t) (all-completions string mh-alias-alist pred))
- ((lambda) (mh-test-completion string mh-alias-alist pred)))))))))
+ ((lambda) (test-completion string mh-alias-alist pred)))))))))
;;; Alias File Updating
diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el
index e44c42e2800..a47a6f9cca9 100644
--- a/lisp/mh-e/mh-comp.el
+++ b/lisp/mh-e/mh-comp.el
@@ -177,9 +177,8 @@ Used by the \\[mh-edit-again] and \\[mh-extract-rejected-mail] commands.")
"Messages annotated, either a sequence name or a list of message numbers.
This variable can be used by `mh-annotate-msg-hook'.")
-(defvar mh-insert-auto-fields-done-local nil
+(defvar-local mh-insert-auto-fields-done-local nil
"Buffer-local variable set when `mh-insert-auto-fields' called successfully.")
-(make-variable-buffer-local 'mh-insert-auto-fields-done-local)
@@ -304,21 +303,7 @@ message and scan line."
(let ((draft-buffer (current-buffer))
(file-name buffer-file-name)
(config mh-previous-window-config)
- ;; FIXME this is subtly different to select-message-coding-system.
- (coding-system-for-write
- (if (fboundp 'select-message-coding-system)
- (select-message-coding-system) ; Emacs has this since at least 21.1
- (if (and (local-variable-p 'buffer-file-coding-system
- (current-buffer)) ;XEmacs needs two args
- ;; We're not sure why, but buffer-file-coding-system
- ;; tends to get set to undecided-unix.
- (not (memq buffer-file-coding-system
- '(undecided undecided-unix undecided-dos))))
- buffer-file-coding-system
- (or (and (boundp 'sendmail-coding-system) sendmail-coding-system)
- (and (default-boundp 'buffer-file-coding-system)
- (default-value 'buffer-file-coding-system))
- 'utf-8)))))
+ (coding-system-for-write (select-message-coding-system)))
;; Older versions of spost do not support -msgid and -mime.
(unless mh-send-uses-spost-flag
;; Adding a Message-ID field looks good, makes it easier to search for
@@ -433,7 +418,7 @@ See also `mh-send'."
(mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)
(mh-insert-header-separator)
;; Merge in components
- (mh-mapc
+ (mapc
(lambda (header-field)
(let ((field (car header-field))
(value (cdr header-field))
@@ -593,11 +578,12 @@ See also `mh-compose-forward-as-mime-flag',
(goto-char (point-min))
;; Set the local value of mh-mail-header-separator according to what is
;; present in the buffer...
- (set (make-local-variable 'mh-mail-header-separator)
- (save-excursion
- (goto-char (mh-mail-header-end))
- (buffer-substring-no-properties (point) (mh-line-end-position))))
- (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) ;override sendmail.el
+ (setq-local mh-mail-header-separator
+ (save-excursion
+ (goto-char (mh-mail-header-end))
+ (buffer-substring-no-properties (point)
+ (line-end-position))))
+ (setq-local mail-header-separator mh-mail-header-separator) ;override sendmail.el
;; If using MML, translate MH-style directive
(if (equal mh-compose-insertion 'mml)
(save-excursion
@@ -699,7 +685,7 @@ message and scan line."
;; For "From", the first value wins, with the identity's "From"
;; trumping anything in the distcomps file.
(let ((components-file (mh-bare-components mh-dist-formfile)))
- (mh-mapc
+ (mapc
(lambda (header-field)
(let ((field (car header-field))
(value (cdr header-field))
@@ -1079,7 +1065,6 @@ letter."
;; Insert identity.
(mh-insert-identity mh-identity-default t)
(mh-identity-make-menu)
- (mh-identity-add-menu)
;; Cleanup possibly RFC2047 encoded subject header
(mh-decode-message-subject)
@@ -1098,7 +1083,6 @@ letter."
(setq mh-previous-window-config config)
(setq mode-line-buffer-identification (list " {%b}"))
(mh-logo-display)
- (mh-make-local-hook 'kill-buffer-hook)
(add-hook 'kill-buffer-hook #'mh-tidy-draft-buffer nil t)
(run-hook-with-args 'mh-compose-letter-function to subject cc))
@@ -1109,18 +1093,8 @@ The versions of MH-E, Emacs, and MH are shown."
;; Lazily initialize mh-x-mailer-string.
(when (and mh-insert-x-mailer-flag (null mh-x-mailer-string))
(setq mh-x-mailer-string
- (format "MH-E %s; %s; %sEmacs %s"
- mh-version mh-variant-in-use
- (if (featurep 'xemacs) "X" "GNU ")
- (cond ((not (featurep 'xemacs))
- (string-match "[0-9]+\\.[0-9]+\\(\\.[0-9]+\\)?"
- emacs-version)
- (match-string 0 emacs-version))
- ((string-match "[0-9.]*\\( +([ a-z]+[0-9]+)\\)?"
- emacs-version)
- (match-string 0 emacs-version))
- (t (format "%s.%s" emacs-major-version
- emacs-minor-version))))))
+ (format "MH-E %s; %s; Emacs %s"
+ mh-version mh-variant-in-use emacs-version)))
;; Insert X-Mailer, but only if it doesn't already exist.
(save-excursion
(when (and mh-insert-x-mailer-flag
@@ -1247,7 +1221,7 @@ discarded."
(cond ((and overwrite-flag
(mh-goto-header-field (concat field ":")))
(insert " " value)
- (delete-region (point) (mh-line-end-position)))
+ (delete-region (point) (line-end-position)))
((and (not overwrite-flag)
(mh-regexp-in-field-p (concat "\\b" (regexp-quote value) "\\b") field))
;; Already there, do nothing.
@@ -1290,11 +1264,8 @@ discarded."
(set-syntax-table old-syntax-table))))
(defun mh-ascii-buffer-p ()
- "Check if current buffer is entirely composed of ASCII.
-The function doesn't work for XEmacs since `find-charset-region'
-doesn't exist there."
- (cl-loop for charset in (mh-funcall-if-exists
- find-charset-region (point-min) (point-max))
+ "Check if current buffer is entirely composed of ASCII."
+ (cl-loop for charset in (find-charset-region (point-min) (point-max))
unless (eq charset 'ascii) return nil
finally return t))
diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el
index ade80e8b95e..23dc48a574c 100644
--- a/lisp/mh-e/mh-compat.el
+++ b/lisp/mh-e/mh-compat.el
@@ -34,53 +34,21 @@
;; Please use mh-gnus.el when providing compatibility with different
;; versions of Gnus.
-;; Items are listed alphabetically (except for mh-require which is
-;; needed sooner it would normally appear).
+;; Items are listed alphabetically.
(eval-when-compile (require 'mh-acros))
-(mh-do-in-gnu-emacs
- (defalias 'mh-require #'require))
-
-(mh-do-in-xemacs
- (defun mh-require (feature &optional filename noerror)
- "If feature FEATURE is not loaded, load it from FILENAME.
-If FEATURE is not a member of the list `features', then the feature
-is not loaded; so load the file FILENAME.
-If FILENAME is omitted, the printname of FEATURE is used as the file name.
-If the optional third argument NOERROR is non-nil,
-then return nil if the file is not found instead of signaling an error.
-
-Simulate NOERROR argument in XEmacs which lacks it."
- (if (not (featurep feature))
- (if filename
- (load filename noerror t)
- (load (format "%s" feature) noerror t)))))
-
-(defun-mh mh-assoc-string assoc-string (key list case-fold)
- "Like `assoc' but specifically for strings.
-Case is ignored if CASE-FOLD is non-nil.
-This function is used by Emacs versions that lack `assoc-string',
-introduced in Emacs 22."
- ;; Test for fboundp is solely to silence compiler for Emacs >= 22.1.
- (if (and case-fold (fboundp 'assoc-ignore-case))
- (assoc-ignore-case key list)
- (assoc key list)))
-
-;; For XEmacs.
-(defalias 'mh-cancel-timer
- (if (fboundp 'cancel-timer)
- 'cancel-timer
- 'delete-itimer))
+(define-obsolete-function-alias 'mh-require #'require "29.1")
+(define-obsolete-function-alias 'mh-assoc-string #'assoc-string "29.1")
+(define-obsolete-function-alias 'mh-cancel-timer #'cancel-timer "29.1")
;; Emacs 24 made flet obsolete and suggested either cl-flet or
;; cl-letf. This macro is based upon gmm-flet from Gnus.
(defmacro mh-flet (bindings &rest body)
"Make temporary overriding function definitions.
-This is an analogue of a dynamically scoped `let' that operates on
-the function cell of FUNCs rather than their value cell.
-
-\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
+That is, temporarily rebind the functions listed in BINDINGS and then
+execute BODY. BINDINGS is a list containing one or more lists of the
+form (FUNCNAME ARGLIST BODY...), similar to defun."
(declare (indent 1) (debug ((&rest (sexp sexp &rest form)) &rest form)))
(if (fboundp 'cl-letf)
`(cl-letf ,(mapcar (lambda (binding)
@@ -90,17 +58,8 @@ the function cell of FUNCs rather than their value cell.
,@body)
`(flet ,bindings ,@body)))
-(defun mh-display-color-cells (&optional display)
- "Return the number of color cells supported by DISPLAY.
-This function is used by XEmacs to return 2 when `device-color-cells'
-or `display-color-cells' returns nil. This happens when compiling or
-running on a tty and causes errors since `display-color-cells' is
-expected to return an integer."
- (cond ((fboundp 'display-color-cells) ; GNU Emacs, XEmacs 21.5b28
- (or (display-color-cells display) 2))
- ((fboundp 'device-color-cells) ; XEmacs 21.4
- (or (device-color-cells display) 2))
- (t 2)))
+(define-obsolete-function-alias 'mh-display-color-cells
+ #'display-color-cells "29.1")
(defmacro mh-display-completion-list (completions &optional common-substring)
"Display the list of COMPLETIONS.
@@ -110,209 +69,54 @@ The optional argument COMMON-SUBSTRING, if non-nil, should be a string
specifying a common substring for adding the faces
`completions-first-difference' and `completions-common-part' to
the completions."
- (cond ((< emacs-major-version 22) `(display-completion-list ,completions))
- ((fboundp 'completion-hilit-commonality) ; Emacs 23.1 and later
- `(display-completion-list
- (completion-hilit-commonality ,completions
- ,(length common-substring) nil)))
- (t ; Emacs 22
- `(display-completion-list ,completions ,common-substring))))
-
-(defmacro mh-face-foreground (face &optional frame inherit)
- "Return the foreground color name of FACE, or nil if unspecified.
-See documentation for `face-foreground' for a description of the
-arguments FACE, FRAME, and perhaps INHERIT.
-This macro is used by Emacs versions that lack an INHERIT argument,
-introduced in Emacs 22."
- (if (< emacs-major-version 22)
- `(face-foreground ,face ,frame)
- `(face-foreground ,face ,frame ,inherit)))
-
-(defmacro mh-face-background (face &optional frame inherit)
- "Return the background color name of face, or nil if unspecified.
-See documentation for `face-background' for a description of the
-arguments FACE, FRAME, and INHERIT.
-This macro is used by Emacs versions that lack an INHERIT argument,
-introduced in Emacs 22."
- (if (< emacs-major-version 22)
- `(face-background ,face ,frame)
- `(face-background ,face ,frame ,inherit)))
-
-(defun-mh mh-font-lock-add-keywords font-lock-add-keywords
- (_mode _keywords &optional _how)
- "XEmacs does not have `font-lock-add-keywords'.
-This function returns nil on that system.")
-
-(defun-mh mh-image-load-path-for-library
- image-load-path-for-library (library image &optional path no-error)
- "Return a suitable search path for images used by LIBRARY.
-
-It searches for IMAGE in `image-load-path' (excluding
-\"`data-directory'/images\") and `load-path', followed by a path
-suitable for LIBRARY, which includes \"../../etc/images\" and
-\"../etc/images\" relative to the library file itself, and then
-in \"`data-directory'/images\".
-
-Then this function returns a list of directories which contains
-first the directory in which IMAGE was found, followed by the
-value of `load-path'. If PATH is given, it is used instead of
-`load-path'.
-
-If NO-ERROR is non-nil and a suitable path can't be found, don't
-signal an error. Instead, return a list of directories as before,
-except that nil appears in place of the image directory.
-
-Here is an example that uses a common idiom to provide
-compatibility with versions of Emacs that lack the variable
-`image-load-path':
-
- ;; Shush compiler.
- (defvar image-load-path)
-
- (let* ((load-path (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\"))
- (image-load-path (cons (car load-path)
- (when (boundp \\='image-load-path)
- image-load-path))))
- (mh-tool-bar-folder-buttons-init))"
- (unless library (error "No library specified"))
- (unless image (error "No image specified"))
- (let (image-directory image-directory-load-path)
- ;; Check for images in image-load-path or load-path.
- (let ((img image)
- (dir (or
- ;; Images in image-load-path.
- (mh-image-search-load-path image)
- ;; Images in load-path.
- (locate-library image)))
- parent)
- ;; Since the image might be in a nested directory (for
- ;; example, mail/attach.pbm), adjust `image-directory'
- ;; accordingly.
- (when dir
- (setq dir (file-name-directory dir))
- (while (setq parent (file-name-directory img))
- (setq img (directory-file-name parent)
- dir (expand-file-name "../" dir))))
- (setq image-directory-load-path dir))
-
- ;; If `image-directory-load-path' isn't Emacs's image directory,
- ;; it's probably a user preference, so use it. Then use a
- ;; relative setting if possible; otherwise, use
- ;; `image-directory-load-path'.
- (cond
- ;; User-modified image-load-path?
- ((and image-directory-load-path
- (not (equal image-directory-load-path
- (file-name-as-directory
- (expand-file-name "images" data-directory)))))
- (setq image-directory image-directory-load-path))
- ;; Try relative setting.
- ((let (library-name d1ei d2ei)
- ;; First, find library in the load-path.
- (setq library-name (locate-library library))
- (if (not library-name)
- (error "Cannot find library %s in load-path" library))
- ;; And then set image-directory relative to that.
- (setq
- ;; Go down 2 levels.
- d2ei (file-name-as-directory
- (expand-file-name
- (concat (file-name-directory library-name) "../../etc/images")))
- ;; Go down 1 level.
- d1ei (file-name-as-directory
- (expand-file-name
- (concat (file-name-directory library-name) "../etc/images"))))
- (setq image-directory
- ;; Set it to nil if image is not found.
- (cond ((file-exists-p (expand-file-name image d2ei)) d2ei)
- ((file-exists-p (expand-file-name image d1ei)) d1ei)))))
- ;; Use Emacs's image directory.
- (image-directory-load-path
- (setq image-directory image-directory-load-path))
- (no-error
- (message "Could not find image %s for library %s" image library))
- (t
- (error "Could not find image %s for library %s" image library)))
-
- ;; Return an augmented `path' or `load-path'.
- (nconc (list image-directory)
- (delete image-directory (copy-sequence (or path load-path))))))
-
-(defun-mh mh-image-search-load-path
- image-search-load-path (_file &optional _path)
- "Emacs 21 and XEmacs don't have `image-search-load-path'.
-This function returns nil on those systems."
- nil)
-
-;; For XEmacs.
-(defalias 'mh-line-beginning-position
- (if (fboundp 'line-beginning-position)
- 'line-beginning-position
- 'point-at-bol))
-
-;; For XEmacs.
-(defalias 'mh-line-end-position
- (if (fboundp 'line-end-position)
- 'line-end-position
- 'point-at-eol))
-
-(mh-require 'mailabbrev nil t)
-(defun-mh mh-mail-abbrev-make-syntax-table
- mail-abbrev-make-syntax-table ()
- "Emacs 21 and XEmacs don't have `mail-abbrev-make-syntax-table'.
-This function returns nil on those systems."
- nil)
-
-(defmacro mh-define-obsolete-variable-alias
- (obsolete-name current-name &optional when docstring)
- "Make OBSOLETE-NAME a variable alias for CURRENT-NAME and mark it obsolete.
-See documentation for `define-obsolete-variable-alias' for a description
-of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN
-and DOCSTRING. This macro is used by XEmacs that lacks WHEN and
-DOCSTRING arguments."
- (if (featurep 'xemacs)
- `(define-obsolete-variable-alias ,obsolete-name ,current-name)
- `(define-obsolete-variable-alias ,obsolete-name ,current-name ,when ,docstring)))
-
-(defmacro mh-make-obsolete-variable (obsolete-name current-name &optional when access-type)
- "Make the byte-compiler warn that OBSOLETE-NAME is obsolete.
-See documentation for `make-obsolete-variable' for a description
-of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN
-and ACCESS-TYPE. This macro is used by XEmacs that lacks WHEN and
-ACCESS-TYPE arguments and by Emacs versions that lack ACCESS-TYPE,
-introduced in Emacs 24."
- (if (featurep 'xemacs)
- `(make-obsolete-variable ,obsolete-name ,current-name)
- (if (< emacs-major-version 24)
- `(make-obsolete-variable ,obsolete-name ,current-name ,when)
- `(make-obsolete-variable ,obsolete-name ,current-name ,when ,access-type))))
-
-(defun-mh mh-match-string-no-properties
- match-string-no-properties (num &optional _string)
- "Return string of text matched by last search, without text properties.
-This function is used by XEmacs that lacks `match-string-no-properties'.
-The function `buffer-substring-no-properties' is used instead.
-The argument STRING is ignored."
- (buffer-substring-no-properties
- (match-beginning num) (match-end num)))
-
-(defun-mh mh-replace-regexp-in-string replace-regexp-in-string
- (regexp rep string &optional _fixedcase literal _subexp _start)
- "Replace REGEXP with REP everywhere in STRING and return result.
-This function is used by XEmacs that lacks `replace-regexp-in-string'.
-The function `replace-in-string' is used instead.
-The arguments FIXEDCASE, SUBEXP, and START, used by
-`replace-in-string' are ignored."
- (if (featurep 'xemacs) ; silence Emacs compiler
- (replace-in-string string regexp rep literal)))
-
-(defun-mh mh-test-completion
- test-completion (_string _collection &optional _predicate)
- "Return non-nil if STRING is a valid completion.
-XEmacs does not have `test-completion'. This function returns nil
-on that system." nil)
-
-;; Copy of constant from url-util.el in Emacs 22; needed by Emacs 21.
+ `(display-completion-list
+ (completion-hilit-commonality ,completions
+ ,(length common-substring) nil)))
+
+(define-obsolete-function-alias 'mh-face-foreground
+ #'face-foreground "29.1")
+
+(define-obsolete-function-alias 'mh-face-background
+ #'face-background "29.1")
+
+(define-obsolete-function-alias 'mh-font-lock-add-keywords
+ #'font-lock-add-keywords "29.1")
+
+;; Not preloaded in without-x builds.
+(declare-function image-load-path-for-library "image")
+(define-obsolete-function-alias 'mh-image-load-path-for-library
+ #'image-load-path-for-library "29.1")
+
+;; Not preloaded in without-x builds.
+(declare-function image-search-load-path "image")
+(define-obsolete-function-alias 'mh-image-search-load-path
+ #'image-search-load-path "29.1")
+
+(define-obsolete-function-alias 'mh-line-beginning-position
+ #'line-beginning-position "29.1")
+
+(define-obsolete-function-alias 'mh-line-end-position
+ #'line-end-position "29.1")
+
+(require 'mailabbrev nil t)
+(define-obsolete-function-alias 'mh-mail-abbrev-make-syntax-table
+ #'mail-abbrev-make-syntax-table "29.1")
+
+(define-obsolete-function-alias 'mh-define-obsolete-variable-alias
+ #'define-obsolete-variable-alias "29.1")
+
+(define-obsolete-function-alias 'mh-make-obsolete-variable
+ #'make-obsolete-variable "29.1")
+
+(define-obsolete-function-alias 'mh-match-string-no-properties
+ #'match-string-no-properties "29.1")
+
+(define-obsolete-function-alias 'mh-replace-regexp-in-string
+ #'replace-regexp-in-string "29.1")
+
+(define-obsolete-function-alias 'mh-test-completion
+ #'test-completion "29.1")
+
(defconst mh-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
@@ -321,51 +125,21 @@ on that system." nil)
?- ?_ ?. ?! ?~ ?* ?' ?\( ?\))
"A list of characters that are _NOT_ reserved in the URL spec.
This is taken from RFC 2396.")
+(make-obsolete-variable 'mh-url-unreserved-chars 'url-unreserved-chars "29.1")
+
+(define-obsolete-function-alias 'mh-url-hexify-string
+ #'url-hexify-string "29.1")
+
+(define-obsolete-function-alias 'mh-view-mode-enter
+ #'view-mode-enter "29.1")
-(defun-mh mh-url-hexify-string url-hexify-string (str)
- "Escape characters in a string.
-This is a copy of `url-hexify-string' from url-util.el in Emacs
-22; needed by Emacs 21."
- (mapconcat
- (lambda (char)
- ;; Fixme: use a char table instead.
- (if (not (memq char mh-url-unreserved-chars))
- (if (> char 255)
- (error "Hexifying multibyte character %s" str)
- (format "%%%02X" char))
- (char-to-string char)))
- str ""))
-
-(defun-mh mh-view-mode-enter
- view-mode-enter (&optional return-to exit-action)
- "Enter View mode.
-This function is used by XEmacs that lacks `view-mode-enter'.
-The function `view-mode' is used instead.
-The arguments RETURN-TO and EXIT-ACTION are ignored."
- ;; Shush compiler.
- (if return-to nil)
- (if exit-action nil)
- (view-mode 1))
-
-(defun-mh mh-window-full-height-p
- window-full-height-p (&optional _window)
- "Return non-nil if WINDOW is not the result of a vertical split.
-This function is defined in XEmacs as it lacks
-`window-full-height-p'. The values of the functions
-`window-height' and `frame-height' are compared instead. The
-argument WINDOW is ignored."
- (= (1+ (window-height))
- (frame-height)))
+(define-obsolete-function-alias 'mh-window-full-height-p
+ #'window-full-height-p "29.1")
(defmacro mh-write-file-functions ()
- "Return `write-file-functions' if it exists.
-Otherwise return `local-write-file-hooks'.
-This macro exists purely for compatibility. The former symbol is used
-in Emacs 22 onward while the latter is used in previous versions and
-XEmacs."
- (if (boundp 'write-file-functions)
- ''write-file-functions ;Emacs 22 on
- ''local-write-file-hooks)) ;XEmacs
+ "Return `write-file-functions'."
+ (declare (obsolete nil "29.1"))
+ ''write-file-functions)
(provide 'mh-compat)
diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el
index 9cbc8cfb737..17faff0716c 100644
--- a/lisp/mh-e/mh-e.el
+++ b/lisp/mh-e/mh-e.el
@@ -88,29 +88,6 @@
(require 'mh-buffers)
(require 'mh-compat)
-(mh-do-in-xemacs
- (require 'mh-xemacs))
-
-(mh-font-lock-add-keywords
- 'emacs-lisp-mode
- (eval-when-compile
- `((,(concat "(\\("
- ;; Function declarations (use font-lock-function-name-face).
- "\\(def\\(un\\|macro\\)-mh\\)\\|"
- ;; Variable declarations (use font-lock-variable-name-face).
- "\\(def\\(custom\\|face\\)-mh\\)\\|"
- ;; Group declarations (use font-lock-type-face).
- "\\(defgroup-mh\\)"
- "\\)\\>"
- ;; Any whitespace and defined object.
- "[ \t'(]*"
- "\\(setf[ \t]+\\sw+)\\|\\sw+\\)?")
- (1 font-lock-keyword-face)
- (7 (cond ((match-beginning 2) font-lock-function-name-face)
- ((match-beginning 4) font-lock-variable-name-face)
- (t font-lock-type-face))
- nil t)))))
-
;;; Global Variables
@@ -368,15 +345,13 @@ when searching for a separator.")
"This regular expression matches the signature separator.
See `mh-signature-separator'.")
-(defvar mh-thread-scan-line-map nil
+(defvar-local mh-thread-scan-line-map nil
"Map of message index to various parts of the scan line.")
-(make-variable-buffer-local 'mh-thread-scan-line-map)
-(defvar mh-thread-scan-line-map-stack nil
+(defvar-local mh-thread-scan-line-map-stack nil
"Old map of message index to various parts of the scan line.
This is the original map that is stored when the folder is
narrowed.")
-(make-variable-buffer-local 'mh-thread-scan-line-map-stack)
(defcustom mh-x-mailer-string nil
"String containing the contents of the X-Mailer header field.
@@ -486,7 +461,7 @@ all the strings have been used."
(count 0))
(while (and (not (eobp)) (< count mh-index-max-cmdline-args))
(push (buffer-substring-no-properties (point)
- (mh-line-end-position))
+ (line-end-position))
arg-list)
(cl-incf count)
(forward-line))
@@ -619,23 +594,18 @@ Output is expected to be shown to user, not parsed by MH-E."
;; The bug wasn't seen in emacs21 but still occurred in XEmacs21.4.
(mh-exchange-point-and-mark-preserving-active-mark))
-;; Shush compiler.
-(mh-do-in-xemacs
- (defvar mark-active))
-
(defun mh-exchange-point-and-mark-preserving-active-mark ()
"Put the mark where point is now, and point where the mark is now.
This command works even when the mark is not active, and
preserves whether the mark is active or not."
(interactive nil)
- (let ((is-active (and (boundp 'mark-active) mark-active)))
+ (let ((is-active mark-active))
(let ((omark (mark t)))
(if (null omark)
(error "No mark set in this buffer"))
(set-mark (point))
(goto-char omark)
- (if (boundp 'mark-active)
- (setq mark-active is-active))
+ (setq mark-active is-active)
nil)))
(defun mh-exec-lib-cmd-output (command &rest args)
@@ -663,56 +633,39 @@ Set mark after inserted text."
;;; MH-E Customization Support Routines
-;; Shush compiler (Emacs 21 and XEmacs).
-(defvar customize-package-emacs-version-alist)
-
;; Temporary function and data structure used customization.
;; These will be unbound after the options are defined.
(defmacro mh-strip-package-version (args)
- "Strip :package-version keyword and its value from ARGS.
-In Emacs versions that support the :package-version keyword,
-ARGS is returned unchanged."
- `(if (boundp 'customize-package-emacs-version-alist)
- ,args
- (let (seen)
- (cl-loop for keyword in ,args
- if (cond ((eq keyword ':package-version) (setq seen t) nil)
- (seen (setq seen nil) nil)
- (t t))
- collect keyword))))
+ "ARGS is returned unchanged."
+ (declare (obsolete identity "29.1"))
+ args)
(defmacro defgroup-mh (symbol members doc &rest args)
"Declare SYMBOL as a customization group containing MEMBERS.
See documentation for `defgroup' for a description of the arguments
-SYMBOL, MEMBERS, DOC and ARGS.
-This macro is used by Emacs versions that lack the :package-version
-keyword, introduced in Emacs 22."
- (declare (doc-string 3) (indent defun))
- `(defgroup ,symbol ,members ,doc ,@(mh-strip-package-version args)))
+SYMBOL, MEMBERS, DOC and ARGS."
+ (declare (obsolete defgroup "29.1") (doc-string 3) (indent defun))
+ `(defgroup ,symbol ,members ,doc ,args))
(defmacro defcustom-mh (symbol value doc &rest args)
"Declare SYMBOL as a customizable variable that defaults to VALUE.
See documentation for `defcustom' for a description of the arguments
-SYMBOL, VALUE, DOC and ARGS.
-This macro is used by Emacs versions that lack the :package-version
-keyword, introduced in Emacs 22."
- (declare (doc-string 3) (indent defun))
- `(defcustom ,symbol ,value ,doc ,@(mh-strip-package-version args)))
+SYMBOL, VALUE, DOC and ARGS."
+ (declare (obsolete defcustom "29.1") (doc-string 3) (indent defun))
+ `(defcustom ,symbol ,value ,doc ,args))
(defmacro defface-mh (face spec doc &rest args)
"Declare FACE as a customizable face that defaults to SPEC.
See documentation for `defface' for a description of the arguments
-FACE, SPEC, DOC and ARGS.
-This macro is used by Emacs versions that lack the :package-version
-keyword, introduced in Emacs 22."
- (declare (doc-string 3) (indent defun))
- `(defface ,face ,spec ,doc ,@(mh-strip-package-version args)))
+FACE, SPEC, DOC and ARGS."
+ (declare (obsolete defface "29.1") (doc-string 3) (indent defun))
+ `(defface ,face ,spec ,doc ,args))
;;; Variant Support
-(defcustom-mh mh-path nil
+(defcustom mh-path nil
"Additional list of directories to search for MH.
See `mh-variant'."
:group 'mh-e
@@ -947,7 +900,7 @@ finally GNU mailutils MH."
(mapconcat (lambda (x) (format "%s" (car x)))
(mh-variants) " or "))))))
-(defcustom-mh mh-variant 'autodetect
+(defcustom mh-variant 'autodetect
"Specifies the variant used by MH-E.
The default setting of this option is \"Auto-detect\" which means
@@ -1023,19 +976,18 @@ windows in the frame are removed."
(when delete-other-windows-flag
(delete-other-windows)))
-(if (boundp 'customize-package-emacs-version-alist)
- (add-to-list 'customize-package-emacs-version-alist
- '(MH-E ("6.0" . "22.1") ("6.1" . "22.1") ("7.0" . "22.1")
- ("7.1" . "22.1") ("7.2" . "22.1") ("7.3" . "22.1")
- ("7.4" . "22.1") ("8.0" . "22.1") ("8.1" . "23.1")
- ("8.2" . "23.1") ("8.3" . "24.1") ("8.4" . "24.4")
- ("8.5" . "24.4") ("8.6" . "24.4"))))
+(add-to-list 'customize-package-emacs-version-alist
+ '(MH-E ("6.0" . "22.1") ("6.1" . "22.1") ("7.0" . "22.1")
+ ("7.1" . "22.1") ("7.2" . "22.1") ("7.3" . "22.1")
+ ("7.4" . "22.1") ("8.0" . "22.1") ("8.1" . "23.1")
+ ("8.2" . "23.1") ("8.3" . "24.1") ("8.4" . "24.4")
+ ("8.5" . "24.4") ("8.6" . "24.4")))
;;; MH-E Customization Groups
-(defgroup-mh mh-e nil
+(defgroup mh-e nil
"Emacs interface to the MH mail system.
MH is the Rand Mail Handler. Other implementations include nmh
and GNU mailutils."
@@ -1043,126 +995,126 @@ and GNU mailutils."
:group 'mail
:package-version '(MH-E . "8.0"))
-(defgroup-mh mh-alias nil
+(defgroup mh-alias nil
"Aliases."
:link '(custom-manual "(mh-e)Aliases")
:prefix "mh-alias-"
:group 'mh-e
:package-version '(MH-E . "7.1"))
-(defgroup-mh mh-folder nil
+(defgroup mh-folder nil
"Organizing your mail with folders."
:prefix "mh-"
:link '(custom-manual "(mh-e)Folders")
:group 'mh-e
:package-version '(MH-E . "7.1"))
-(defgroup-mh mh-folder-selection nil
+(defgroup mh-folder-selection nil
"Folder selection."
:prefix "mh-"
:link '(custom-manual "(mh-e)Folder Selection")
:group 'mh-e
:package-version '(MH-E . "8.0"))
-(defgroup-mh mh-identity nil
+(defgroup mh-identity nil
"Identities."
:link '(custom-manual "(mh-e)Identities")
:prefix "mh-identity-"
:group 'mh-e
:package-version '(MH-E . "7.1"))
-(defgroup-mh mh-inc nil
+(defgroup mh-inc nil
"Incorporating your mail."
:prefix "mh-inc-"
:link '(custom-manual "(mh-e)Incorporating Mail")
:group 'mh-e
:package-version '(MH-E . "8.0"))
-(defgroup-mh mh-junk nil
+(defgroup mh-junk nil
"Dealing with junk mail."
:link '(custom-manual "(mh-e)Junk")
:prefix "mh-junk-"
:group 'mh-e
:package-version '(MH-E . "7.3"))
-(defgroup-mh mh-letter nil
+(defgroup mh-letter nil
"Editing a draft."
:prefix "mh-"
:link '(custom-manual "(mh-e)Editing Drafts")
:group 'mh-e
:package-version '(MH-E . "7.1"))
-(defgroup-mh mh-ranges nil
+(defgroup mh-ranges nil
"Ranges."
:prefix "mh-"
:link '(custom-manual "(mh-e)Ranges")
:group 'mh-e
:package-version '(MH-E . "8.0"))
-(defgroup-mh mh-scan-line-formats nil
+(defgroup mh-scan-line-formats nil
"Scan line formats."
:link '(custom-manual "(mh-e)Scan Line Formats")
:prefix "mh-"
:group 'mh-e
:package-version '(MH-E . "8.0"))
-(defgroup-mh mh-search nil
+(defgroup mh-search nil
"Searching."
:link '(custom-manual "(mh-e)Searching")
:prefix "mh-search-"
:group 'mh-e
:package-version '(MH-E . "8.0"))
-(defgroup-mh mh-sending-mail nil
+(defgroup mh-sending-mail nil
"Sending mail."
:prefix "mh-"
:link '(custom-manual "(mh-e)Sending Mail")
:group 'mh-e
:package-version '(MH-E . "8.0"))
-(defgroup-mh mh-sequences nil
+(defgroup mh-sequences nil
"Sequences."
:prefix "mh-"
:link '(custom-manual "(mh-e)Sequences")
:group 'mh-e
:package-version '(MH-E . "8.0"))
-(defgroup-mh mh-show nil
+(defgroup mh-show nil
"Reading your mail."
:prefix "mh-"
:link '(custom-manual "(mh-e)Reading Mail")
:group 'mh-e
:package-version '(MH-E . "7.1"))
-(defgroup-mh mh-speedbar nil
+(defgroup mh-speedbar nil
"The speedbar."
:prefix "mh-speed-"
:link '(custom-manual "(mh-e)Speedbar")
:group 'mh-e
:package-version '(MH-E . "8.0"))
-(defgroup-mh mh-thread nil
+(defgroup mh-thread nil
"Threading."
:prefix "mh-thread-"
:link '(custom-manual "(mh-e)Threading")
:group 'mh-e
:package-version '(MH-E . "8.0"))
-(defgroup-mh mh-tool-bar nil
+(defgroup mh-tool-bar nil
"The tool bar"
:link '(custom-manual "(mh-e)Tool Bar")
:prefix "mh-"
:group 'mh-e
:package-version '(MH-E . "8.0"))
-(defgroup-mh mh-hooks nil
+(defgroup mh-hooks nil
"MH-E hooks."
:link '(custom-manual "(mh-e)Top")
:prefix "mh-"
:group 'mh-e
:package-version '(MH-E . "7.1"))
-(defgroup-mh mh-faces nil
+(defgroup mh-faces nil
"Faces used in MH-E."
:link '(custom-manual "(mh-e)Top")
:prefix "mh-"
@@ -1178,7 +1130,7 @@ and GNU mailutils."
;;; Aliases (:group 'mh-alias)
-(defcustom-mh mh-alias-completion-ignore-case-flag t
+(defcustom mh-alias-completion-ignore-case-flag t
"Non-nil means don't consider case significant in MH alias completion.
As MH ignores case in the aliases, so too does MH-E. However, you
@@ -1189,7 +1141,7 @@ lowercase for mailing lists and uppercase for people."
:group 'mh-alias
:package-version '(MH-E . "7.1"))
-(defcustom-mh mh-alias-expand-aliases-flag nil
+(defcustom mh-alias-expand-aliases-flag nil
"Non-nil means to expand aliases entered in the minibuffer.
In other words, aliases entered in the minibuffer will be
@@ -1199,7 +1151,7 @@ this expansion is not performed."
:group 'mh-alias
:package-version '(MH-E . "7.1"))
-(defcustom-mh mh-alias-flash-on-comma t
+(defcustom mh-alias-flash-on-comma t
"Specify whether to flash address or warn on translation.
This option controls the behavior when a [comma] is pressed while
@@ -1212,7 +1164,7 @@ does not display a warning if the alias is not found."
:group 'mh-alias
:package-version '(MH-E . "7.1"))
-(defcustom-mh mh-alias-insert-file nil
+(defcustom mh-alias-insert-file nil
"Filename used to store a new MH-E alias.
The default setting of this option is \"Use Aliasfile Profile
@@ -1226,7 +1178,7 @@ name, MH-E will prompt for one of them when MH-E adds an alias."
:group 'mh-alias
:package-version '(MH-E . "7.1"))
-(defcustom-mh mh-alias-insertion-location 'sorted
+(defcustom mh-alias-insertion-location 'sorted
"Specifies where new aliases are entered in alias files.
This option is set to \"Alphabetical\" by default. If you organize
@@ -1238,7 +1190,7 @@ or \"Bottom\" of your alias file might be more appropriate."
:group 'mh-alias
:package-version '(MH-E . "7.1"))
-(defcustom-mh mh-alias-local-users t
+(defcustom mh-alias-local-users t
"Non-nil means local users are added to alias completion.
Aliases are created from \"/etc/passwd\" entries with a user ID
@@ -1259,7 +1211,7 @@ NIS password file."
:group 'mh-alias
:package-version '(MH-E . "7.1"))
-(defcustom-mh mh-alias-local-users-prefix "local."
+(defcustom mh-alias-local-users-prefix "local."
"String prefixed to the real names of users from the password file.
This option can also be set to \"Use Login\".
@@ -1281,7 +1233,7 @@ turned off."
:group 'mh-alias
:package-version '(MH-E . "7.4"))
-(defcustom-mh mh-alias-passwd-gecos-comma-separator-flag t
+(defcustom mh-alias-passwd-gecos-comma-separator-flag t
"Non-nil means the gecos field in the password file uses a comma separator.
In the example in `mh-alias-local-users-prefix', commas are used
@@ -1295,7 +1247,7 @@ whose contents may contain commas, you can turn this option off."
;;; Organizing Your Mail with Folders (:group 'mh-folder)
-(defcustom-mh mh-new-messages-folders t
+(defcustom mh-new-messages-folders t
"Folders searched for the \"unseen\" sequence.
Set this option to \"Inbox\" to search the \"+inbox\" folder or
@@ -1310,7 +1262,7 @@ See also `mh-recursive-folders-flag'."
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-ticked-messages-folders t
+(defcustom mh-ticked-messages-folders t
"Folders searched for `mh-tick-seq'.
Set this option to \"Inbox\" to search the \"+inbox\" folder or
@@ -1325,7 +1277,7 @@ See also `mh-recursive-folders-flag'."
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-large-folder 200
+(defcustom mh-large-folder 200
"The number of messages that indicates a large folder.
If a folder is deemed to be large, that is the number of messages
@@ -1337,7 +1289,7 @@ folders are treated as if they are small."
:group 'mh-folder
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-recenter-summary-flag nil
+(defcustom mh-recenter-summary-flag nil
"Non-nil means to recenter the summary window.
If this option is turned on, recenter the summary window when the
@@ -1346,13 +1298,13 @@ show window is toggled off."
:group 'mh-folder
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-recursive-folders-flag nil
+(defcustom mh-recursive-folders-flag nil
"Non-nil means that commands which operate on folders do so recursively."
:type 'boolean
:group 'mh-folder
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-sortm-args nil
+(defcustom mh-sortm-args nil
"Additional arguments for \"sortm\"\\<mh-folder-mode-map>.
This option is consulted when a prefix argument is used with
@@ -1366,7 +1318,7 @@ an alternate view. For example, (\"-nolimit\" \"-textfield\"
;;; Folder Selection (:group 'mh-folder-selection)
-(defcustom-mh mh-default-folder-for-message-function nil
+(defcustom mh-default-folder-for-message-function nil
"Function to select a default folder for refiling or \"Fcc:\".
When this function is called, the current buffer contains the message
@@ -1378,7 +1330,7 @@ the default, or an empty string to suppress the default entirely."
:group 'mh-folder-selection
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-default-folder-list nil
+(defcustom mh-default-folder-list nil
"List of addresses and folders.
The folder name associated with the first address found in this
@@ -1396,7 +1348,7 @@ for more information."
:group 'mh-folder-selection
:package-version '(MH-E . "7.2"))
-(defcustom-mh mh-default-folder-must-exist-flag t
+(defcustom mh-default-folder-must-exist-flag t
"Non-nil means guessed folder name must exist to be used.
If the derived folder does not exist, and this option is on, then
@@ -1410,7 +1362,7 @@ for more information."
:group 'mh-folder-selection
:package-version '(MH-E . "7.2"))
-(defcustom-mh mh-default-folder-prefix ""
+(defcustom mh-default-folder-prefix ""
"Prefix used for folder names generated from aliases.
The prefix is used to prevent clutter in your mail directory.
@@ -1429,7 +1381,7 @@ for more information."
Real definition will take effect when mh-identity is loaded."
nil)))
-(defcustom-mh mh-identity-list nil
+(defcustom mh-identity-list nil
"List of identities.
To customize this option, click on the \"INS\" button and enter a label
@@ -1498,7 +1450,7 @@ fashion."
:group 'mh-identity
:package-version '(MH-E . "7.1"))
-(defcustom-mh mh-auto-fields-list nil
+(defcustom mh-auto-fields-list nil
"List of recipients for which header lines are automatically inserted.
This option can be used to set the identity depending on the
@@ -1559,14 +1511,14 @@ as the result is undefined."
:group 'mh-identity
:package-version '(MH-E . "7.3"))
-(defcustom-mh mh-auto-fields-prompt-flag t
+(defcustom mh-auto-fields-prompt-flag t
"Non-nil means to prompt before sending if fields inserted.
See `mh-auto-fields-list'."
:type 'boolean
:group 'mh-identity
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-identity-default nil
+(defcustom mh-identity-default nil
"Default identity to use when `mh-letter-mode' is called.
See `mh-identity-list'."
:type (append
@@ -1577,7 +1529,7 @@ See `mh-identity-list'."
:group 'mh-identity
:package-version '(MH-E . "7.1"))
-(defcustom-mh mh-identity-handlers
+(defcustom mh-identity-handlers
'(("From" . mh-identity-handler-top)
(":default" . mh-identity-handler-bottom)
(":attribution-verb" . mh-identity-handler-attribution-verb)
@@ -1613,7 +1565,7 @@ containing the VALUE for the field is given."
;;; Incorporating Your Mail (:group 'mh-inc)
-(defcustom-mh mh-inc-prog "inc"
+(defcustom mh-inc-prog "inc"
"Program to incorporate new mail into a folder.
This program generates a one-line summary for each of the new
@@ -1632,7 +1584,7 @@ several scan line format variables appropriately."
Real definition will take effect when mh-inc is loaded."
nil)))
-(defcustom-mh mh-inc-spool-list nil
+(defcustom mh-inc-spool-list nil
"Alternate spool files.
You can use the `mh-inc-spool-list' variable to direct MH-E to
@@ -1655,17 +1607,14 @@ on the \"INS\" button. Enter a \"Spool File\" of \"~/mail/mh-e\", a
\"Folder\" of \"mh-e\", and a \"Key Binding\" of \"m\".
You can use \"xbuffy\" to automate the incorporation of this mail
-using the Emacs 22 command \"emacsclient\" as follows:
+using \"emacsclient\" as follows:
box ~/mail/mh-e
title mh-e
origMode
polltime 10
headertime 0
- command emacsclient --eval \\='(mh-inc-spool-mh-e)\\='
-
-In XEmacs, the command \"gnuclient\" is used in a similar
-fashion."
+ command emacsclient --eval \\='(mh-inc-spool-mh-e)\\='"
:type '(repeat (list (file :tag "Spool File")
(string :tag "Folder")
(character :tag "Key Binding")))
@@ -1705,7 +1654,7 @@ The function is always called with SYMBOL bound to
until (executable-find (symbol-name (car element)))
finally return (car element)))))
-(defcustom-mh mh-junk-background nil
+(defcustom mh-junk-background nil
"If on, spam programs are run in background.
By default, the programs are run in the foreground, but this can
@@ -1723,14 +1672,14 @@ may be useful for debugging."
:group 'mh-junk
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-junk-disposition nil
+(defcustom mh-junk-disposition nil
"Disposition of junk mail."
:type '(choice (const :tag "Delete Spam" nil)
(string :tag "Spam Folder"))
:group 'mh-junk
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-junk-program nil
+(defcustom mh-junk-program nil
"Spam program that MH-E should use.
The default setting of this option is \"Auto-detect\" which means
@@ -1748,7 +1697,7 @@ bogofilter, then you can set this option to \"Bogofilter\"."
;;; Editing a Draft (:group 'mh-letter)
-(defcustom-mh mh-compose-insertion (if (locate-library "mml") 'mml 'mh)
+(defcustom mh-compose-insertion (if (locate-library "mml") 'mml 'mh)
"Type of tags used when composing MIME messages.
In addition to MH-style directives, MH-E also supports MML (MIME
@@ -1762,7 +1711,7 @@ MH-style directives are preferred."
:group 'mh-letter
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-compose-skipped-header-fields
+(defcustom mh-compose-skipped-header-fields
'("From" "Organization" "References" "In-Reply-To"
"X-Face" "Face" "X-Image-URL" "X-Mailer")
"List of header fields to skip over when navigating in draft."
@@ -1770,13 +1719,13 @@ MH-style directives are preferred."
:group 'mh-letter
:package-version '(MH-E . "7.4"))
-(defcustom-mh mh-compose-space-does-completion-flag nil
+(defcustom mh-compose-space-does-completion-flag nil
"Non-nil means \\<mh-letter-mode-map>\\[mh-letter-complete-or-space] does completion in message header."
:type 'boolean
:group 'mh-letter
:package-version '(MH-E . "7.4"))
-(defcustom-mh mh-delete-yanked-msg-window-flag nil
+(defcustom mh-delete-yanked-msg-window-flag nil
"Non-nil means delete any window displaying the message.
This deletes the window containing the original message after
@@ -1786,7 +1735,7 @@ more room on your screen for your reply."
:group 'mh-letter
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-extract-from-attribution-verb "wrote:"
+(defcustom mh-extract-from-attribution-verb "wrote:"
"Verb to use for attribution when a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg].
The attribution consists of the sender's name and email address
@@ -1800,7 +1749,7 @@ followed by the content of this option. This option can be set to
:group 'mh-letter
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-ins-buf-prefix "> "
+(defcustom mh-ins-buf-prefix "> "
"String to put before each line of a yanked or inserted message.
The prefix \"> \" is the default setting of this option. I
@@ -1816,17 +1765,17 @@ flavors of `mh-yank-behavior' or you have added a
:group 'mh-letter
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-letter-complete-function 'ispell-complete-word
+(defcustom mh-letter-complete-function 'ispell-complete-word
"Function to call when completing outside of address or folder fields.
In the body of the message,
-\\<mh-letter-mode-map>\\[mh-letter-complete] runs this function,
+\\<mh-letter-mode-map>\\[completion-at-point] runs this function,
which is set to \"ispell-complete-word\" by default."
:type '(choice function (const nil))
:group 'mh-letter
:package-version '(MH-E . "7.1"))
-(defcustom-mh mh-letter-fill-column 72
+(defcustom mh-letter-fill-column 72
"Fill column to use in MH Letter mode.
By default, this option is 72 to allow others to quote your
@@ -1835,7 +1784,7 @@ message without line wrapping."
:group 'mh-letter
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-mml-method-default (if mh-pgp-support-flag "pgpmime" "none")
+(defcustom mh-mml-method-default (if mh-pgp-support-flag "pgpmime" "none")
"Default method to use in security tags.
This option is used to select between a variety of mail security
@@ -1858,7 +1807,7 @@ you write!"
:group 'mh-letter
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-signature-file-name "~/.signature"
+(defcustom mh-signature-file-name "~/.signature"
"Source of user's signature.
By default, the text of your signature is taken from the file
@@ -1881,7 +1830,7 @@ The signature is inserted into your message with the command
:group 'mh-letter
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-signature-separator-flag t
+(defcustom mh-signature-separator-flag t
"Non-nil means a signature separator should be inserted.
It is not recommended that you change this option since various
@@ -1892,7 +1841,7 @@ replying or yanking a letter into a draft."
:group 'mh-letter
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-x-face-file "~/.face"
+(defcustom mh-x-face-file "~/.face"
"File containing face header field to insert in outgoing mail.
If the file starts with either of the strings \"X-Face:\", \"Face:\"
@@ -1921,7 +1870,7 @@ this option doesn't exist."
:group 'mh-letter
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-yank-behavior 'attribution
+(defcustom mh-yank-behavior 'attribution
"Controls which part of a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg].
To include the entire message, including the entire header, use
@@ -1968,7 +1917,7 @@ inserted."
;;; Ranges (:group 'mh-ranges)
-(defcustom-mh mh-interpret-number-as-range-flag t
+(defcustom mh-interpret-number-as-range-flag t
"Non-nil means interpret a number as a range.
Since one of the most frequent ranges used is \"last:N\", MH-E
@@ -1988,7 +1937,7 @@ message 200, then use the range \"200:200\"."
Real definition, below, uses variables that aren't defined yet."
(set-default symbol value))))
-(defcustom-mh mh-adaptive-cmd-note-flag t
+(defcustom mh-adaptive-cmd-note-flag t
"Non-nil means that the message number width is determined dynamically.
If you've created your own format to handle long message numbers,
@@ -2017,7 +1966,7 @@ set SYMBOL to VALUE."
"unless you use \"Use MH-E scan Format\"")
(set-default symbol value)))
-(defcustom-mh mh-scan-format-file t
+(defcustom mh-scan-format-file t
"Specifies the format file to pass to the scan program.
The default setting for this option is \"Use MH-E scan Format\". This
@@ -2056,7 +2005,7 @@ Otherwise, set SYMBOL to VALUE."
"is set to \"Use MH-E scan Format\"")
(set-default symbol value)))
-(defcustom-mh mh-scan-prog "scan"
+(defcustom mh-scan-prog "scan"
"Program used to scan messages.
The name of the program that generates a listing of one line per
@@ -2071,7 +2020,7 @@ directory. You may link another program to `scan' (see
;;; Searching (:group 'mh-search)
-(defcustom-mh mh-search-program nil
+(defcustom mh-search-program nil
"Search program that MH-E shall use.
The default setting of this option is \"Auto-detect\" which means
@@ -2094,7 +2043,7 @@ MH-E can be found in the documentation of `mh-search'."
;;; Sending Mail (:group 'mh-sending-mail)
-(defcustom-mh mh-compose-forward-as-mime-flag t
+(defcustom mh-compose-forward-as-mime-flag t
"Non-nil means that messages are forwarded as attachments.
By default, this option is on which means that the forwarded
@@ -2110,7 +2059,7 @@ regardless of the settings of this option."
:group 'mh-sending-mail
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-compose-letter-function nil
+(defcustom mh-compose-letter-function nil
"Invoked when starting a new draft.
However, it is the last function called before you edit your
@@ -2122,13 +2071,13 @@ fields."
:group 'mh-sending-mail
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-compose-prompt-flag nil
+(defcustom mh-compose-prompt-flag nil
"Non-nil means prompt for header fields when composing a new draft."
:type 'boolean
:group 'mh-sending-mail
:package-version '(MH-E . "7.4"))
-(defcustom-mh mh-forward-subject-format "%s: %s"
+(defcustom mh-forward-subject-format "%s: %s"
"Format string for forwarded message subject.
This option is a string which includes two escapes (\"%s\"). The
@@ -2138,7 +2087,7 @@ and the second one is replaced with the original \"Subject:\"."
:group 'mh-sending-mail
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-insert-x-mailer-flag t
+(defcustom mh-insert-x-mailer-flag t
"Non-nil means append an \"X-Mailer:\" header field to the header.
This header field includes the version of MH-E and Emacs that you
@@ -2148,7 +2097,7 @@ can turn this option off."
:group 'mh-sending-mail
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-redist-full-contents-flag nil
+(defcustom mh-redist-full-contents-flag nil
"Non-nil means the \"dist\" command needs entire letter for redistribution.
This option must be turned on if \"dist\" requires the whole
@@ -2160,7 +2109,7 @@ has been redistributed before, turn off this option."
:group 'mh-sending-mail
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-reply-default-reply-to nil
+(defcustom mh-reply-default-reply-to nil
"Sets the person or persons to whom a reply will be sent.
This option is set to \"Prompt\" by default so that you are
@@ -2176,7 +2125,7 @@ this option to \"cc\". Other choices include \"from\", \"to\", or
:group 'mh-sending-mail
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-reply-show-message-flag t
+(defcustom mh-reply-show-message-flag t
"Non-nil means the MH-Show buffer is displayed when replying.
If you include the message automatically, you can hide the
@@ -2193,7 +2142,7 @@ See also `mh-reply'."
;; the docstring: "Additional sequences that should not to be preserved can be
;; specified by setting `mh-unpropagated-sequences' appropriately." XXX
-(defcustom-mh mh-refile-preserves-sequences-flag t
+(defcustom mh-refile-preserves-sequences-flag t
"Non-nil means that sequences are preserved when messages are refiled.
If a message is in any sequence (except \"Previous-Sequence:\"
@@ -2204,7 +2153,7 @@ desired, then turn off this option."
:group 'mh-sequences
:package-version '(MH-E . "7.4"))
-(defcustom-mh mh-tick-seq 'tick
+(defcustom mh-tick-seq 'tick
"The name of the MH sequence for ticked messages.
You can customize this option if you already use the \"tick\"
@@ -2216,7 +2165,7 @@ there isn't much advantage to that."
:group 'mh-sequences
:package-version '(MH-E . "7.3"))
-(defcustom-mh mh-update-sequences-after-mh-show-flag t
+(defcustom mh-update-sequences-after-mh-show-flag t
"Non-nil means flush MH sequences to disk after message is shown\\<mh-folder-mode-map>.
Three sequences are maintained internally by MH-E and pushed out
@@ -2231,7 +2180,7 @@ commands."
:group 'mh-sequences
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-allowlist-preserves-sequences-flag t
+(defcustom mh-allowlist-preserves-sequences-flag t
"Non-nil means that sequences are preserved when messages are allowlisted.
If a message is in any sequence (except \"Previous-Sequence:\"
@@ -2244,7 +2193,7 @@ not desired, then turn off this option."
;;; Reading Your Mail (:group 'mh-show)
-(defcustom-mh mh-bury-show-buffer-flag t
+(defcustom mh-bury-show-buffer-flag t
"Non-nil means show buffer is buried.
One advantage of not burying the show buffer is that one can
@@ -2255,7 +2204,7 @@ running \\[electric-buffer-list] to see what I mean."
:group 'mh-show
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-clean-message-header-flag t
+(defcustom mh-clean-message-header-flag t
"Non-nil means remove extraneous header fields.
See also `mh-invisible-header-fields-default' and
@@ -2264,7 +2213,7 @@ See also `mh-invisible-header-fields-default' and
:group 'mh-show
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-decode-mime-flag (not (not (locate-library "mm-decode")))
+(defcustom mh-decode-mime-flag (not (not (locate-library "mm-decode")))
"Non-nil means attachments are handled\\<mh-folder-mode-map>.
MH-E can handle attachments as well if the Gnus `mm-decode'
@@ -2282,7 +2231,7 @@ messages and other graphical widgets. See the options
:group 'mh-show
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-display-buttons-for-alternatives-flag nil
+(defcustom mh-display-buttons-for-alternatives-flag nil
"Non-nil means display buttons for all alternative attachments.
Sometimes, a mail program will produce multiple alternatives of
@@ -2294,7 +2243,7 @@ inline and buttons are shown for each of the other alternatives."
:group 'mh-show
:package-version '(MH-E . "7.4"))
-(defcustom-mh mh-display-buttons-for-inline-parts-flag nil
+(defcustom mh-display-buttons-for-inline-parts-flag nil
"Non-nil means display buttons for all inline attachments\\<mh-folder-mode-map>.
The sender can request that attachments should be viewed inline so
@@ -2317,7 +2266,7 @@ text (including HTML) and images."
:group 'mh-show
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-do-not-confirm-flag nil
+(defcustom mh-do-not-confirm-flag nil
"Non-nil means non-reversible commands do not prompt for confirmation.
Commands such as `mh-pack-folder' prompt to confirm whether to
@@ -2329,7 +2278,7 @@ retracted--without question."
:group 'mh-show
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-fetch-x-image-url nil
+(defcustom mh-fetch-x-image-url nil
"Control fetching of \"X-Image-URL:\" header field image.
This option controls the fetching of the \"X-Image-URL:\" header
@@ -2365,7 +2314,7 @@ turned on."
:group 'mh-show
:package-version '(MH-E . "7.3"))
-(defcustom-mh mh-graphical-smileys-flag t
+(defcustom mh-graphical-smileys-flag t
"Non-nil means graphical smileys are displayed.
It is a long standing custom to inject body language using a
@@ -2380,7 +2329,7 @@ turned off."
:group 'mh-show
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-graphical-emphasis-flag t
+(defcustom mh-graphical-emphasis-flag t
"Non-nil means graphical emphasis is displayed.
A few typesetting features are indicated in ASCII text with
@@ -2397,7 +2346,7 @@ turned off."
:group 'mh-show
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-highlight-citation-style 'gnus
+(defcustom mh-highlight-citation-style 'gnus
"Style for highlighting citations.
If the sender of the message has cited other messages in his
@@ -2819,7 +2768,7 @@ Because the function `mh-invisible-headers' uses both
`mh-invisible-header-fields' and `mh-invisible-header-fields', it
cannot be run until both variables have been initialized.")
-(defcustom-mh mh-invisible-header-fields nil
+(defcustom mh-invisible-header-fields nil
"Additional header fields to hide.
Header fields that you would like to hide that aren't listed in
@@ -2842,7 +2791,7 @@ See also `mh-clean-message-header-flag'."
:group 'mh-show
:package-version '(MH-E . "7.1"))
-(defcustom-mh mh-invisible-header-fields-default nil
+(defcustom mh-invisible-header-fields-default nil
"List of hidden header fields.
The header fields listed in this option are hidden, although you
@@ -2899,7 +2848,7 @@ removed and entries from `mh-invisible-header-fields' are added."
;; Compile invisible header fields.
(mh-invisible-headers)
-(defcustom-mh mh-lpr-command-format "lpr -J '%s'"
+(defcustom mh-lpr-command-format "lpr -J '%s'"
"Command used to print\\<mh-folder-mode-map>.
This option contains the Unix command line which performs the
@@ -2916,7 +2865,7 @@ This option is not used by the commands \\[mh-ps-print-msg] or
:group 'mh-show
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-max-inline-image-height nil
+(defcustom mh-max-inline-image-height nil
"Maximum inline image height if \"Content-Disposition:\" is not present.
Some older mail programs do not insert this needed plumbing to
@@ -2932,7 +2881,7 @@ these numbers."
:group 'mh-show
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-max-inline-image-width nil
+(defcustom mh-max-inline-image-width nil
"Maximum inline image width if \"Content-Disposition:\" is not present.
Some older mail programs do not insert this needed plumbing to
@@ -2948,7 +2897,7 @@ these numbers."
:group 'mh-show
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-mhl-format-file nil
+(defcustom mh-mhl-format-file nil
"Specifies the format file to pass to the \"mhl\" program.
Normally MH-E takes care of displaying messages itself (rather than
@@ -2972,7 +2921,7 @@ file."
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-mime-save-parts-default-directory t
+(defcustom mh-mime-save-parts-default-directory t
"Default directory to use for \\<mh-folder-mode-map>\\[mh-mime-save-parts].
The default value for this option is \"Prompt Always\" so that
@@ -2988,7 +2937,7 @@ directory's name."
:group 'mh-show
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-print-background-flag nil
+(defcustom mh-print-background-flag nil
"Non-nil means messages should be printed in the background\\<mh-folder-mode-map>.
Normally messages are printed in the foreground. If this is slow on
@@ -3004,7 +2953,7 @@ This option is not used by the commands \\[mh-ps-print-msg] or
:group 'mh-show
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-show-maximum-size 0
+(defcustom mh-show-maximum-size 0
"Maximum size of message (in bytes) to display automatically.
This option provides an opportunity to skip over large messages
@@ -3014,7 +2963,7 @@ message are shown regardless of size."
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-show-use-xface-flag (>= emacs-major-version 21)
+(defcustom mh-show-use-xface-flag (>= emacs-major-version 21)
"Non-nil means display face images in MH-show buffers.
MH-E can display the content of \"Face:\", \"X-Face:\", and
@@ -3029,15 +2978,12 @@ and off. This feature will be turned on by default if your system
supports it.
The first header field used, if present, is the Gnus-specific
-\"Face:\" field. The \"Face:\" field appeared in GNU Emacs 21 and
-XEmacs. For more information, see URL
+\"Face:\" field. The \"Face:\" field appeared in Emacs 21.
+For more information, see URL
`https://quimby.gnus.org/circus/face/'. Next is the traditional
\"X-Face:\" header field. The display of this field requires the
\"uncompface\" program (see URL
-`ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.z'). Recent
-versions of XEmacs have internal support for \"X-Face:\" images. If
-your version of XEmacs does not, then you'll need both \"uncompface\"
-and the x-face package (see URL `https://www.jpl.org/ftp/pub/elisp/').
+`ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.z').
Finally, MH-E will display images referenced by the \"X-Image-URL:\"
header field if neither the \"Face:\" nor the \"X-Face:\" fields are
@@ -3054,7 +3000,7 @@ The option `mh-fetch-x-image-url' controls the fetching of the
:group 'mh-show
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-store-default-directory nil
+(defcustom mh-store-default-directory nil
"Default directory for \\<mh-folder-mode-map>\\[mh-store-msg].
If you would like to change the initial default directory,
@@ -3066,7 +3012,7 @@ the content of these messages."
:group 'mh-show
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-summary-height nil
+(defcustom mh-summary-height nil
"Number of lines in MH-Folder buffer (including the mode line).
The default value of this option is \"Automatic\" which means
@@ -3081,7 +3027,7 @@ lines you'd like to see."
;;; The Speedbar (:group 'mh-speedbar)
-(defcustom-mh mh-speed-update-interval 60
+(defcustom mh-speed-update-interval 60
"Time between speedbar updates in seconds.
Set to 0 to disable automatic update."
:type 'integer
@@ -3090,7 +3036,7 @@ Set to 0 to disable automatic update."
;;; Threading (:group 'mh-thread)
-(defcustom-mh mh-show-threads-flag nil
+(defcustom mh-show-threads-flag nil
"Non-nil means new folders start in threaded mode.
Threading large number of messages can be time consuming so this
@@ -3106,7 +3052,7 @@ threaded is less than `mh-large-folder'."
;; mh-tool-bar-folder-buttons and mh-tool-bar-letter-buttons defined
;; dynamically in mh-tool-bar.el.
-(defcustom-mh mh-tool-bar-search-function 'mh-search
+(defcustom mh-tool-bar-search-function 'mh-search
"Function called by the tool bar search button.
By default, this is set to `mh-search'. You can also choose
@@ -3117,47 +3063,11 @@ of your own choosing."
:group 'mh-tool-bar
:package-version '(MH-E . "7.0"))
-;; XEmacs has a couple of extra customizations...
-(mh-do-in-xemacs
- (defcustom-mh mh-xemacs-use-tool-bar-flag mh-xemacs-has-tool-bar-flag
- "If non-nil, use tool bar.
-
-This option controls whether to show the MH-E icons at all. By
-default, this option is turned on if the window system supports
-tool bars. If your system doesn't support tool bars, then you
-won't be able to turn on this option."
- :type 'boolean
- :group 'mh-tool-bar
- :set (lambda (symbol value)
- (if (and (eq value t)
- (not mh-xemacs-has-tool-bar-flag))
- (error "Tool bar not supported"))
- (set-default symbol value))
- :package-version '(MH-E . "7.3"))
-
- (defcustom-mh mh-xemacs-tool-bar-position nil
- "Tool bar location.
-
-This option controls the placement of the tool bar along the four
-edges of the frame. You can choose from one of \"Same As Default
-Tool Bar\", \"Top\", \"Bottom\", \"Left\", or \"Right\". If this
-variable is set to anything other than \"Same As Default Tool
-Bar\" and the default tool bar is in a different location, then
-two tool bars will be displayed: the MH-E tool bar and the
-default tool bar."
- :type '(radio (const :tag "Same As Default Tool Bar" :value nil)
- (const :tag "Top" :value top)
- (const :tag "Bottom" :value bottom)
- (const :tag "Left" :value left)
- (const :tag "Right" :value right))
- :group 'mh-tool-bar
- :package-version '(MH-E . "7.3")))
-
;;; Hooks (:group 'mh-hooks + group where hook described)
-(defcustom-mh mh-after-commands-processed-hook nil
+(defcustom mh-after-commands-processed-hook nil
"Hook run by \\<mh-folder-mode-map>\\[mh-execute-commands] after performing outstanding refile and delete requests.
Variables that are useful in this hook include
@@ -3169,14 +3079,14 @@ folder, which is also available in `mh-current-folder'."
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-alias-reloaded-hook nil
+(defcustom mh-alias-reloaded-hook nil
"Hook run by `mh-alias-reload' after loading aliases."
:type 'hook
:group 'mh-hooks
:group 'mh-alias
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-annotate-msg-hook nil
+(defcustom mh-annotate-msg-hook nil
"Hook run when a message is sent and after annotating the scan lines and message.
Hook functions can access the current folder name with
`mh-current-folder' and obtain the message numbers of the
@@ -3186,7 +3096,7 @@ annotated messages with `mh-annotate-list'."
:group 'mh-sending-mail
:package-version '(MH-E . "8.1"))
-(defcustom-mh mh-before-commands-processed-hook nil
+(defcustom mh-before-commands-processed-hook nil
"Hook run by \\<mh-folder-mode-map>\\[mh-execute-commands] before performing outstanding refile and delete requests.
Variables that are useful in this hook include `mh-delete-list',
@@ -3198,7 +3108,7 @@ used to see which changes will be made to the current folder,
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-before-quit-hook nil
+(defcustom mh-before-quit-hook nil
"Hook run by \\<mh-folder-mode-map>\\[mh-quit] before quitting MH-E.
This hook is called before the quit occurs, so you might use it
@@ -3211,7 +3121,7 @@ See also `mh-quit-hook'."
:group 'mh-folder
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-before-send-letter-hook nil
+(defcustom mh-before-send-letter-hook nil
"Hook run at the beginning of the \\<mh-letter-mode-map>\\[mh-send-letter] command.
For example, if you want to check your spelling in your message
@@ -3222,14 +3132,14 @@ before sending, add the `ispell-message' function."
:group 'mh-letter
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-blocklist-msg-hook nil
+(defcustom mh-blocklist-msg-hook nil
"Hook run by \\<mh-letter-mode-map>\\[mh-junk-blocklist] after marking each message for blocklisting."
:type 'hook
:group 'mh-hooks
:group 'mh-show
:package-version '(MH-E . "8.4"))
-(defcustom-mh mh-delete-msg-hook nil
+(defcustom mh-delete-msg-hook nil
"Hook run by \\<mh-letter-mode-map>\\[mh-delete-msg] after marking each message for deletion.
For example, a past maintainer of MH-E used this once when he
@@ -3239,7 +3149,7 @@ kept statistics on his mail usage."
:group 'mh-show
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-find-path-hook nil
+(defcustom mh-find-path-hook nil
"Hook run by `mh-find-path' after reading the user's MH profile.
This hook can be used the change the value of the variables that
@@ -3250,28 +3160,28 @@ between MH and MH-E."
:group 'mh-e
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-folder-mode-hook nil
+(defcustom mh-folder-mode-hook nil
"Hook run by `mh-folder-mode' when visiting a new folder."
:type 'hook
:group 'mh-hooks
:group 'mh-folder
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-forward-hook nil
+(defcustom mh-forward-hook nil
"Hook run by `mh-forward' on a forwarded letter."
:type 'hook
:group 'mh-hooks
:group 'mh-sending-mail
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-inc-folder-hook nil
+(defcustom mh-inc-folder-hook nil
"Hook run by \\<mh-folder-mode-map>\\[mh-inc-folder] after incorporating mail into a folder."
:type 'hook
:group 'mh-hooks
:group 'mh-inc
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-insert-signature-hook nil
+(defcustom mh-insert-signature-hook nil
"Hook run by \\<mh-letter-mode-map>\\[mh-insert-signature] after signature has been inserted.
Hook functions may access the actual name of the file or the
@@ -3282,9 +3192,9 @@ function used to insert the signature with
:group 'mh-letter
:package-version '(MH-E . "8.0"))
-(mh-define-obsolete-variable-alias 'mh-kill-folder-suppress-prompt-hooks
+(define-obsolete-variable-alias 'mh-kill-folder-suppress-prompt-hooks
'mh-kill-folder-suppress-prompt-functions "24.3")
-(defcustom-mh mh-kill-folder-suppress-prompt-functions '(mh-search-p)
+(defcustom mh-kill-folder-suppress-prompt-functions '(mh-search-p)
"Abnormal hook run at the beginning of \\<mh-folder-mode-map>\\[mh-kill-folder].
The hook functions are called with no arguments and should return
@@ -3302,7 +3212,7 @@ accident in the \"+inbox\" folder, you will not be happy."
:group 'mh-folder
:package-version '(MH-E . "7.4"))
-(defcustom-mh mh-letter-mode-hook nil
+(defcustom mh-letter-mode-hook nil
"Hook run by `mh-letter-mode' on a new letter.
This hook allows you to do some processing before editing a
@@ -3315,14 +3225,14 @@ go."
:group 'mh-sending-mail
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-mh-to-mime-hook nil
+(defcustom mh-mh-to-mime-hook nil
"Hook run on the formatted letter by \\<mh-letter-mode-map>\\[mh-mh-to-mime]."
:type 'hook
:group 'mh-hooks
:group 'mh-letter
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-search-mode-hook nil
+(defcustom mh-search-mode-hook nil
"Hook run upon entry to `mh-search-mode'\\<mh-folder-mode-map>.
If you find that you do the same thing over and over when editing
@@ -3334,7 +3244,7 @@ This can be done with this hook which is called when
:group 'mh-search
:package-version '(MH-E . "8.0"))
-(defcustom-mh mh-pack-folder-hook nil
+(defcustom mh-pack-folder-hook nil
"Hook run by \\<mh-folder-mode-map>\\[mh-pack-folder] after renumbering the messages.
Hook functions can access the current folder name with `mh-current-folder'."
:type 'hook
@@ -3342,7 +3252,7 @@ Hook functions can access the current folder name with `mh-current-folder'."
:group 'mh-folder
:package-version '(MH-E . "8.2"))
-(defcustom-mh mh-quit-hook nil
+(defcustom mh-quit-hook nil
"Hook run by \\<mh-folder-mode-map>\\[mh-quit] after quitting MH-E.
This hook is not run in an MH-E context, so you might use it to
@@ -3354,14 +3264,14 @@ See also `mh-before-quit-hook'."
:group 'mh-folder
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-refile-msg-hook nil
+(defcustom mh-refile-msg-hook nil
"Hook run by \\<mh-folder-mode-map>\\[mh-refile-msg] after marking each message for refiling."
:type 'hook
:group 'mh-hooks
:group 'mh-folder
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-show-hook nil
+(defcustom mh-show-hook nil
"Hook run after \\<mh-folder-mode-map>\\[mh-show] shows a message.
It is the last thing called after messages are displayed. It's
@@ -3372,7 +3282,7 @@ used to affect the behavior of MH-E in general or when
:group 'mh-show
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-show-mode-hook nil
+(defcustom mh-show-mode-hook nil
"Hook run upon entry to `mh-show-mode'.
This hook is called early on in the process of the message display,
@@ -3384,7 +3294,7 @@ buffer itself. See also `mh-show-hook'."
:group 'mh-show
:package-version '(MH-E . "8.7"))
-(defcustom-mh mh-unseen-updated-hook nil
+(defcustom mh-unseen-updated-hook nil
"Hook run after the unseen sequence has been updated.
The variable `mh-seen-list' can be used by this hook to obtain
@@ -3395,7 +3305,7 @@ sequence."
:group 'mh-sequences
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-allowlist-msg-hook nil
+(defcustom mh-allowlist-msg-hook nil
"Hook run by \\<mh-letter-mode-map>\\[mh-junk-allowlist] after marking each message for allowlisting."
:type 'hook
:group 'mh-hooks
@@ -3406,15 +3316,10 @@ sequence."
;;; Faces (:group 'mh-faces + group where faces described)
-(if (boundp 'facemenu-unlisted-faces)
- ;; This variable was removed in Emacs 22.1.
- (add-to-list 'facemenu-unlisted-faces "^mh-"))
-
;; To add a new face:
;; 1. Add entry to variable mh-face-data.
-;; 2. Create face using defface-mh (which removes min-color spec and
-;; :package-version keyword where these are not supported),
-;; accessing face data with function mh-face-data.
+;; 2. Create face using defface, accessing face data with function
+;; mh-face-data.
;; 3. Add inherit argument to function mh-face-data if applicable.
(defvar mh-face-data
'((mh-folder-followup
@@ -3561,18 +3466,17 @@ sequence."
(:underline t)))))
"MH-E face data.
Used by function `mh-face-data' which returns spec that is
-consumed by `defface-mh'.")
+consumed by `defface'.")
(require 'cus-face)
-(defvar mh-inherit-face-flag (assq :inherit custom-face-attributes)
- "Non-nil means that the `defface' :inherit keyword is available.
-The :inherit keyword is available on all supported versions of
-GNU Emacs and XEmacs from at least 21.5.23 on.")
+(defvar mh-inherit-face-flag t
+ "Non-nil means that the `defface' :inherit keyword is available.")
+(make-obsolete-variable 'mh-inherit-face-flag nil "29.1")
-(defvar mh-min-colors-defined-flag (and (not (featurep 'xemacs))
- (>= emacs-major-version 22))
+(defvar mh-min-colors-defined-flag t
"Non-nil means `defface' supports min-colors display requirement.")
+(make-obsolete-variable 'mh-min-colors-defined-flag nil "29.1")
(defun mh-face-data (face &optional inherit)
"Return spec for FACE.
@@ -3583,53 +3487,26 @@ keyword, return INHERIT literally; otherwise, return spec for
FACE from the variable `mh-face-data'. This isn't a perfect
implementation. In the case that the :inherit keyword is not
supported, any additional attributes in the inherit parameter are
-not added to the returned spec.
-
-Furthermore, when `mh-min-colors-defined-flag' is nil, this
-function finds display entries with \"min-colors\" requirements
-and either removes the \"min-colors\" requirement or strips the
-display entirely if the display does not support the number of
-specified colors."
- (let ((spec
- (if (and inherit mh-inherit-face-flag)
- inherit
- (or (cadr (assq face mh-face-data))
- (error "Could not find %s in mh-face-data" face)))))
-
- (if mh-min-colors-defined-flag
- spec
- (let ((cells (mh-display-color-cells))
- new-spec)
- ;; Remove entries with min-colors, or delete them if we have
- ;; fewer colors than they specify.
- (cl-loop
- for entry in (reverse spec) do
- (let ((requirement (if (eq (car entry) t)
- nil
- (assq 'min-colors (car entry)))))
- (if requirement
- (when (>= cells (nth 1 requirement))
- (setq new-spec (cons (cons (delq requirement (car entry))
- (cdr entry))
- new-spec)))
- (setq new-spec (cons entry new-spec)))))
- new-spec))))
-
-(defface-mh mh-folder-address
+not added to the returned spec."
+ (or inherit
+ (cadr (assq face mh-face-data))
+ (error "Could not find %s in mh-face-data" face)))
+
+(defface mh-folder-address
(mh-face-data 'mh-folder-subject '((t (:inherit mh-folder-subject))))
"Recipient face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-blocklisted
+(defface mh-folder-blocklisted
(mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-msg-number))))
"Blocklisted message face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.4"))
-(defface-mh mh-folder-body
+(defface mh-folder-body
(mh-face-data 'mh-folder-msg-number
'((((class color))
(:inherit mh-folder-msg-number))
@@ -3640,7 +3517,7 @@ specified colors."
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-cur-msg-number
+(defface mh-folder-cur-msg-number
(mh-face-data 'mh-folder-msg-number
'((t (:inherit mh-folder-msg-number :bold t))))
"Current message number face."
@@ -3648,39 +3525,39 @@ specified colors."
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-date
+(defface mh-folder-date
(mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-msg-number))))
"Date face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-deleted
+(defface mh-folder-deleted
(mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-msg-number))))
"Deleted message face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-followup (mh-face-data 'mh-folder-followup)
+(defface mh-folder-followup (mh-face-data 'mh-folder-followup)
"\"Re:\" face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-msg-number (mh-face-data 'mh-folder-msg-number)
+(defface mh-folder-msg-number (mh-face-data 'mh-folder-msg-number)
"Message number face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-refiled (mh-face-data 'mh-folder-refiled)
+(defface mh-folder-refiled (mh-face-data 'mh-folder-refiled)
"Refiled message face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-sent-to-me-hint
+(defface mh-folder-sent-to-me-hint
(mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-date))))
"Fontification hint face in messages sent directly to us.
The detection of messages sent to us is governed by the scan
@@ -3690,7 +3567,7 @@ format `mh-scan-format-nmh' and the regular expression
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-sent-to-me-sender
+(defface mh-folder-sent-to-me-sender
(mh-face-data 'mh-folder-followup '((t (:inherit mh-folder-followup))))
"Sender face in messages sent directly to us.
The detection of messages sent to us is governed by the scan
@@ -3700,105 +3577,105 @@ format `mh-scan-format-nmh' and the regular expression
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-subject (mh-face-data 'mh-folder-subject)
+(defface mh-folder-subject (mh-face-data 'mh-folder-subject)
"Subject face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-tick (mh-face-data 'mh-folder-tick)
+(defface mh-folder-tick (mh-face-data 'mh-folder-tick)
"Ticked message face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-to (mh-face-data 'mh-folder-to)
+(defface mh-folder-to (mh-face-data 'mh-folder-to)
"\"To:\" face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-allowlisted
+(defface mh-folder-allowlisted
(mh-face-data 'mh-folder-refiled '((t (:inherit mh-folder-refiled))))
"Allowlisted message face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.4"))
-(defface-mh mh-letter-header-field (mh-face-data 'mh-letter-header-field)
+(defface mh-letter-header-field (mh-face-data 'mh-letter-header-field)
"Editable header field value face in draft buffers."
:group 'mh-faces
:group 'mh-letter
:package-version '(MH-E . "8.0"))
-(defface-mh mh-search-folder (mh-face-data 'mh-search-folder)
+(defface mh-search-folder (mh-face-data 'mh-search-folder)
"Folder heading face in MH-Folder buffers created by searches."
:group 'mh-faces
:group 'mh-search
:package-version '(MH-E . "8.0"))
-(defface-mh mh-show-cc (mh-face-data 'mh-show-cc)
+(defface mh-show-cc (mh-face-data 'mh-show-cc)
"Face used to highlight \"cc:\" header fields."
:group 'mh-faces
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defface-mh mh-show-date (mh-face-data 'mh-show-date)
+(defface mh-show-date (mh-face-data 'mh-show-date)
"Face used to highlight \"Date:\" header fields."
:group 'mh-faces
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defface-mh mh-show-from (mh-face-data 'mh-show-from)
+(defface mh-show-from (mh-face-data 'mh-show-from)
"Face used to highlight \"From:\" header fields."
:group 'mh-faces
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defface-mh mh-show-header (mh-face-data 'mh-show-header)
+(defface mh-show-header (mh-face-data 'mh-show-header)
"Face used to deemphasize less interesting header fields."
:group 'mh-faces
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defface-mh mh-show-pgg-bad (mh-face-data 'mh-show-pgg-bad)
+(defface mh-show-pgg-bad (mh-face-data 'mh-show-pgg-bad)
"Bad PGG signature face."
:group 'mh-faces
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defface-mh mh-show-pgg-good (mh-face-data 'mh-show-pgg-good)
+(defface mh-show-pgg-good (mh-face-data 'mh-show-pgg-good)
"Good PGG signature face."
:group 'mh-faces
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defface-mh mh-show-pgg-unknown (mh-face-data 'mh-show-pgg-unknown)
+(defface mh-show-pgg-unknown (mh-face-data 'mh-show-pgg-unknown)
"Unknown or untrusted PGG signature face."
:group 'mh-faces
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defface-mh mh-show-signature (mh-face-data 'mh-show-signature)
+(defface mh-show-signature (mh-face-data 'mh-show-signature)
"Signature face."
:group 'mh-faces
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defface-mh mh-show-subject
+(defface mh-show-subject
(mh-face-data 'mh-folder-subject '((t (:inherit mh-folder-subject))))
"Face used to highlight \"Subject:\" header fields."
:group 'mh-faces
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defface-mh mh-show-to (mh-face-data 'mh-show-to)
+(defface mh-show-to (mh-face-data 'mh-show-to)
"Face used to highlight \"To:\" header fields."
:group 'mh-faces
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defface-mh mh-show-xface
+(defface mh-show-xface
(mh-face-data 'mh-show-from '((t (:inherit (mh-show-from highlight)))))
"X-Face image face.
The background and foreground are used in the image."
@@ -3806,13 +3683,13 @@ The background and foreground are used in the image."
:group 'mh-show
:package-version '(MH-E . "8.0"))
-(defface-mh mh-speedbar-folder (mh-face-data 'mh-speedbar-folder)
+(defface mh-speedbar-folder (mh-face-data 'mh-speedbar-folder)
"Basic folder face."
:group 'mh-faces
:group 'mh-speedbar
:package-version '(MH-E . "8.0"))
-(defface-mh mh-speedbar-folder-with-unseen-messages
+(defface mh-speedbar-folder-with-unseen-messages
(mh-face-data 'mh-speedbar-folder
'((t (:inherit mh-speedbar-folder :bold t))))
"Folder face when folder contains unread messages."
@@ -3820,14 +3697,14 @@ The background and foreground are used in the image."
:group 'mh-speedbar
:package-version '(MH-E . "8.0"))
-(defface-mh mh-speedbar-selected-folder
+(defface mh-speedbar-selected-folder
(mh-face-data 'mh-speedbar-selected-folder)
"Selected folder face."
:group 'mh-faces
:group 'mh-speedbar
:package-version '(MH-E . "8.0"))
-(defface-mh mh-speedbar-selected-folder-with-unseen-messages
+(defface mh-speedbar-selected-folder-with-unseen-messages
(mh-face-data 'mh-speedbar-selected-folder
'((t (:inherit mh-speedbar-selected-folder :bold t))))
"Selected folder face when folder contains unread messages."
diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el
index 35277ae46a1..132ac33d269 100644
--- a/lisp/mh-e/mh-folder.el
+++ b/lisp/mh-e/mh-folder.el
@@ -72,10 +72,8 @@ the MH mail system."
;;; Desktop Integration
-;; desktop-buffer-mode-handlers appeared in Emacs 22.
-(if (boundp 'desktop-buffer-mode-handlers)
- (add-to-list 'desktop-buffer-mode-handlers
- '(mh-folder-mode . mh-restore-desktop-buffer)))
+(add-to-list 'desktop-buffer-mode-handlers
+ '(mh-folder-mode . mh-restore-desktop-buffer))
(defun mh-restore-desktop-buffer (_file-name name _misc)
"Restore an MH folder buffer specified in a desktop file.
@@ -213,141 +211,137 @@ annotation.")
(defalias 'mh-alt-visit-folder #'mh-visit-folder)
;; Save the "b" binding for a future `back'. Maybe?
-(gnus-define-keys mh-folder-mode-map
- " " mh-page-msg
- "!" mh-refile-or-write-again
- "'" mh-toggle-tick
- "," mh-header-display
- "." mh-alt-show
- ":" mh-show-preferred-alternative
- ";" mh-toggle-mh-decode-mime-flag
- ">" mh-write-msg-to-file
- "?" mh-help
- "E" mh-extract-rejected-mail
- "M" mh-modify
- "\177" mh-previous-page
- "\C-d" mh-delete-msg-no-motion
- "\t" mh-index-next-folder
- [backtab] mh-index-previous-folder
- "\M-\t" mh-index-previous-folder
- "\e<" mh-first-msg
- "\e>" mh-last-msg
- "\ed" mh-redistribute
- "\r" mh-show
- "^" mh-alt-refile-msg
- "c" mh-copy-msg
- "d" mh-delete-msg
- "e" mh-edit-again
- "f" mh-forward
- "g" mh-goto-msg
- "i" mh-inc-folder
- "k" mh-delete-subject-or-thread
- "m" mh-alt-send
- "n" mh-next-undeleted-msg
- "\M-n" mh-next-unread-msg
- "o" mh-refile-msg
- "p" mh-previous-undeleted-msg
- "\M-p" mh-previous-unread-msg
- "q" mh-quit
- "r" mh-reply
- "s" mh-send
- "t" mh-toggle-showing
- "u" mh-undo
- "v" mh-index-visit-folder
- "x" mh-execute-commands
- "|" mh-pipe-msg)
-
-(gnus-define-keys (mh-folder-map "F" mh-folder-mode-map)
- "?" mh-prefix-help
- "'" mh-index-ticked-messages
- "S" mh-sort-folder
- "c" mh-catchup
- "f" mh-alt-visit-folder
- "k" mh-kill-folder
- "l" mh-list-folders
- "n" mh-index-new-messages
- "o" mh-alt-visit-folder
- "p" mh-pack-folder
- "q" mh-index-sequenced-messages
- "r" mh-rescan-folder
- "s" mh-search
- "u" mh-undo-folder
- "v" mh-visit-folder)
-
-(define-key mh-folder-mode-map "I" mh-inc-spool-map)
-
-(gnus-define-keys (mh-junk-map "J" mh-folder-mode-map)
- "?" mh-prefix-help
- "a" mh-junk-allowlist
- "b" mh-junk-blocklist
- "w" mh-junk-whitelist)
-
-(gnus-define-keys (mh-ps-print-map "P" mh-folder-mode-map)
- "?" mh-prefix-help
- "C" mh-ps-print-toggle-color
- "F" mh-ps-print-toggle-faces
- "f" mh-ps-print-msg-file
- "l" mh-print-msg
- "p" mh-ps-print-msg)
-
-(gnus-define-keys (mh-sequence-map "S" mh-folder-mode-map)
- "'" mh-narrow-to-tick
- "?" mh-prefix-help
- "d" mh-delete-msg-from-seq
- "k" mh-delete-seq
- "l" mh-list-sequences
- "n" mh-narrow-to-seq
- "p" mh-put-msg-in-seq
- "s" mh-msg-is-in-seq
- "w" mh-widen)
-
-(gnus-define-keys (mh-thread-map "T" mh-folder-mode-map)
- "?" mh-prefix-help
- "u" mh-thread-ancestor
- "p" mh-thread-previous-sibling
- "n" mh-thread-next-sibling
- "t" mh-toggle-threads
- "d" mh-thread-delete
- "o" mh-thread-refile)
-
-(gnus-define-keys (mh-limit-map "/" mh-folder-mode-map)
- "'" mh-narrow-to-tick
- "?" mh-prefix-help
- "c" mh-narrow-to-cc
- "g" mh-narrow-to-range
- "m" mh-narrow-to-from
- "s" mh-narrow-to-subject
- "t" mh-narrow-to-to
- "w" mh-widen)
-
-(gnus-define-keys (mh-extract-map "X" mh-folder-mode-map)
- "?" mh-prefix-help
- "s" mh-store-msg ;shar
- "u" mh-store-msg) ;uuencode
-
-(gnus-define-keys (mh-digest-map "D" mh-folder-mode-map)
- " " mh-page-digest
- "?" mh-prefix-help
- "\177" mh-page-digest-backwards
- "b" mh-burst-digest)
-
-(gnus-define-keys (mh-mime-map "K" mh-folder-mode-map)
- "?" mh-prefix-help
- "a" mh-mime-save-parts
- "e" mh-display-with-external-viewer
- "i" mh-folder-inline-mime-part
- "o" mh-folder-save-mime-part
- "t" mh-toggle-mime-buttons
- "v" mh-folder-toggle-mime-part
- "\t" mh-next-button
- [backtab] mh-prev-button
- "\M-\t" mh-prev-button)
-
-(cond
- ((featurep 'xemacs)
- (define-key mh-folder-mode-map [button2] 'mh-show-mouse))
- (t
- (define-key mh-folder-mode-map [mouse-2] 'mh-show-mouse)))
+(define-keymap :keymap mh-folder-mode-map
+ "SPC" #'mh-page-msg
+ "!" #'mh-refile-or-write-again
+ "'" #'mh-toggle-tick
+ "," #'mh-header-display
+ "." #'mh-alt-show
+ ":" #'mh-show-preferred-alternative
+ ";" #'mh-toggle-mh-decode-mime-flag
+ ">" #'mh-write-msg-to-file
+ "?" #'mh-help
+ "E" #'mh-extract-rejected-mail
+ "M" #'mh-modify
+ "DEL" #'mh-previous-page
+ "C-d" #'mh-delete-msg-no-motion
+ "TAB" #'mh-index-next-folder
+ "<backtab>" #'mh-index-previous-folder
+ "C-M-i" #'mh-index-previous-folder
+ "ESC <" #'mh-first-msg
+ "ESC >" #'mh-last-msg
+ "ESC d" #'mh-redistribute
+ "RET" #'mh-show
+ "^" #'mh-alt-refile-msg
+ "c" #'mh-copy-msg
+ "d" #'mh-delete-msg
+ "e" #'mh-edit-again
+ "f" #'mh-forward
+ "g" #'mh-goto-msg
+ "i" #'mh-inc-folder
+ "k" #'mh-delete-subject-or-thread
+ "m" #'mh-alt-send
+ "n" #'mh-next-undeleted-msg
+ "M-n" #'mh-next-unread-msg
+ "o" #'mh-refile-msg
+ "p" #'mh-previous-undeleted-msg
+ "M-p" #'mh-previous-unread-msg
+ "q" #'mh-quit
+ "r" #'mh-reply
+ "s" #'mh-send
+ "t" #'mh-toggle-showing
+ "u" #'mh-undo
+ "v" #'mh-index-visit-folder
+ "x" #'mh-execute-commands
+ "|" #'mh-pipe-msg
+
+ "F" (define-keymap :prefix 'mh-folder-map
+ "?" #'mh-prefix-help
+ "'" #'mh-index-ticked-messages
+ "S" #'mh-sort-folder
+ "c" #'mh-catchup
+ "f" #'mh-alt-visit-folder
+ "k" #'mh-kill-folder
+ "l" #'mh-list-folders
+ "n" #'mh-index-new-messages
+ "o" #'mh-alt-visit-folder
+ "p" #'mh-pack-folder
+ "q" #'mh-index-sequenced-messages
+ "r" #'mh-rescan-folder
+ "s" #'mh-search
+ "u" #'mh-undo-folder
+ "v" #'mh-visit-folder)
+
+ "I" mh-inc-spool-map
+
+ "J" (define-keymap :prefix 'mh-junk-map
+ "?" #'mh-prefix-help
+ "a" #'mh-junk-allowlist
+ "b" #'mh-junk-blocklist
+ "w" #'mh-junk-whitelist)
+
+ "P" (define-keymap :prefix 'mh-ps-print-map
+ "?" #'mh-prefix-help
+ "C" #'mh-ps-print-toggle-color
+ "F" #'mh-ps-print-toggle-faces
+ "f" #'mh-ps-print-msg-file
+ "l" #'mh-print-msg
+ "p" #'mh-ps-print-msg)
+
+ "S" (define-keymap :prefix 'mh-sequence-map
+ "'" #'mh-narrow-to-tick
+ "?" #'mh-prefix-help
+ "d" #'mh-delete-msg-from-seq
+ "k" #'mh-delete-seq
+ "l" #'mh-list-sequences
+ "n" #'mh-narrow-to-seq
+ "p" #'mh-put-msg-in-seq
+ "s" #'mh-msg-is-in-seq
+ "w" #'mh-widen)
+
+ "T" (define-keymap :prefix 'mh-thread-map
+ "?" #'mh-prefix-help
+ "u" #'mh-thread-ancestor
+ "p" #'mh-thread-previous-sibling
+ "n" #'mh-thread-next-sibling
+ "t" #'mh-toggle-threads
+ "d" #'mh-thread-delete
+ "o" #'mh-thread-refile)
+
+ "/" (define-keymap :prefix 'mh-limit-map
+ "'" #'mh-narrow-to-tick
+ "?" #'mh-prefix-help
+ "c" #'mh-narrow-to-cc
+ "g" #'mh-narrow-to-range
+ "m" #'mh-narrow-to-from
+ "s" #'mh-narrow-to-subject
+ "t" #'mh-narrow-to-to
+ "w" #'mh-widen)
+
+ "X" (define-keymap :prefix 'mh-extract-map
+ "?" #'mh-prefix-help
+ "s" #'mh-store-msg ;shar
+ "u" #'mh-store-msg) ;uuencode
+
+ "D" (define-keymap :prefix 'mh-digest-map
+ "SPC" #'mh-page-digest
+ "?" #'mh-prefix-help
+ "DEL" #'mh-page-digest-backwards
+ "b" #'mh-burst-digest)
+
+ "K" (define-keymap :prefix 'mh-mime-map
+ "?" #'mh-prefix-help
+ "a" #'mh-mime-save-parts
+ "e" #'mh-display-with-external-viewer
+ "i" #'mh-folder-inline-mime-part
+ "o" #'mh-folder-save-mime-part
+ "t" #'mh-toggle-mime-buttons
+ "v" #'mh-folder-toggle-mime-part
+ "TAB" #'mh-next-button
+ "<backtab>" #'mh-prev-button
+ "C-M-i" #'mh-prev-button)
+
+ "<mouse-2>" #'mh-show-mouse)
;; "C-c /" prefix is used in mh-folder-mode by pgp.el and mailcrypt
@@ -512,24 +506,14 @@ font-lock is done highlighting.")
;;; MH-Folder Mode
(defmacro mh-remove-xemacs-horizontal-scrollbar ()
- "Get rid of the horizontal scrollbar that XEmacs insists on putting in."
- (when (featurep 'xemacs)
- '(if (and (featurep 'scrollbar)
- (fboundp 'set-specifier))
- (set-specifier horizontal-scrollbar-visible-p nil
- (cons (current-buffer) nil)))))
+ (declare (obsolete nil "29.1"))
+ nil)
;; Register mh-folder-mode as supporting which-function-mode...
-(eval-and-compile (mh-require 'which-func nil t))
+(eval-and-compile (require 'which-func nil t))
(when (and (boundp 'which-func-modes) (listp which-func-modes))
(add-to-list 'which-func-modes 'mh-folder-mode))
-;; Shush compiler.
-(defvar desktop-save-buffer)
-(defvar font-lock-auto-fontify)
-(mh-do-in-xemacs
- (defvar font-lock-defaults))
-
;; Ensure new buffers won't get this mode if default major-mode is nil.
(put 'mh-folder-mode 'mode-class 'special)
@@ -590,80 +574,68 @@ region in the MH-Folder buffer, then the MH-E command will
perform the operation on all messages in that region.
\\{mh-folder-mode-map}"
- (mh-do-in-gnu-emacs
- (unless mh-folder-tool-bar-map
- (mh-tool-bar-folder-buttons-init))
- (if (boundp 'tool-bar-map)
- (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)))
- (mh-do-in-xemacs
- (mh-tool-bar-init :folder))
+ (unless mh-folder-tool-bar-map
+ (mh-tool-bar-folder-buttons-init))
+ (if (boundp 'tool-bar-map)
+ (setq-local tool-bar-map mh-folder-tool-bar-map))
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults '(mh-folder-font-lock-keywords t))
(make-local-variable 'desktop-save-buffer)
(setq desktop-save-buffer t)
- (mh-make-local-vars
- 'mh-colors-available-flag (mh-colors-available-p)
+ (setq-local
+ mh-colors-available-flag (mh-colors-available-p)
; Do we have colors available
- 'mh-current-folder (buffer-name) ; Name of folder, a string
- 'mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs
- 'mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/"
+ mh-current-folder (buffer-name) ; Name of folder, a string
+ mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs
+ mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/"
(file-name-as-directory (mh-expand-file-name (buffer-name)))
- 'mh-display-buttons-for-inline-parts-flag
+ mh-display-buttons-for-inline-parts-flag
mh-display-buttons-for-inline-parts-flag ; Allow for display of buttons to
; be toggled.
- 'mh-arrow-marker (make-marker) ; Marker where arrow is displayed
- 'overlay-arrow-position nil ; Allow for simultaneous display in
- 'overlay-arrow-string ">" ; different MH-E buffers.
- 'mh-showing-mode nil ; Show message also?
- 'mh-refile-list nil ; List of folder names in mh-seq-list
- 'mh-delete-list nil ; List of msgs nums to delete
- 'mh-blocklist nil ; List of messages to process as spam
- 'mh-allowlist nil ; List of messages to process as ham
- 'mh-seq-list nil ; Alist of (seq . msgs) nums
- 'mh-seen-list nil ; List of displayed messages
- 'mh-next-direction 'forward ; Direction to move to next message
- 'mh-view-ops () ; Stack that keeps track of the order
+ mh-arrow-marker (make-marker) ; Marker where arrow is displayed
+ overlay-arrow-position nil ; Allow for simultaneous display in
+ overlay-arrow-string ">" ; different MH-E buffers.
+ mh-showing-mode nil ; Show message also?
+ mh-refile-list nil ; List of folder names in mh-seq-list
+ mh-delete-list nil ; List of msgs nums to delete
+ mh-blocklist nil ; List of messages to process as spam
+ mh-allowlist nil ; List of messages to process as ham
+ mh-seq-list nil ; Alist of (seq . msgs) nums
+ mh-seen-list nil ; List of displayed messages
+ mh-next-direction 'forward ; Direction to move to next message
+ mh-view-ops () ; Stack that keeps track of the order
; in which narrowing/threading has been
; carried out.
- 'mh-folder-view-stack () ; Stack of previous views of the
+ mh-folder-view-stack () ; Stack of previous views of the
; folder.
- 'mh-index-data nil ; If the folder was created by a call
+ mh-index-data nil ; If the folder was created by a call
; to mh-search, this contains info
; about the search results.
- 'mh-index-previous-search nil ; folder, indexer, search-regexp
- 'mh-index-msg-checksum-map nil ; msg -> checksum map
- 'mh-index-checksum-origin-map nil ; checksum -> ( orig-folder, orig-msg )
- 'mh-index-sequence-search-flag nil ; folder resulted from sequence search
- 'mh-first-msg-num nil ; Number of first msg in buffer
- 'mh-last-msg-num nil ; Number of last msg in buffer
- 'mh-msg-count nil ; Number of msgs in buffer
- 'mh-mode-line-annotation nil ; Indicates message range
- 'mh-sequence-notation-history (make-hash-table)
+ mh-index-previous-search nil ; folder, indexer, search-regexp
+ mh-index-msg-checksum-map nil ; msg -> checksum map
+ mh-index-checksum-origin-map nil ; checksum -> ( orig-folder, orig-msg )
+ mh-index-sequence-search-flag nil ; folder resulted from sequence search
+ mh-first-msg-num nil ; Number of first msg in buffer
+ mh-last-msg-num nil ; Number of last msg in buffer
+ mh-msg-count nil ; Number of msgs in buffer
+ mh-mode-line-annotation nil ; Indicates message range
+ mh-sequence-notation-history (make-hash-table)
; Remember what is overwritten by
; mh-note-seq.
- 'imenu-create-index-function 'mh-index-create-imenu-index
+ imenu-create-index-function 'mh-index-create-imenu-index
; Setup imenu support
- 'mh-previous-window-config nil) ; Previous window configuration
- (mh-remove-xemacs-horizontal-scrollbar)
+ mh-previous-window-config nil) ; Previous window configuration
(setq truncate-lines t)
(auto-save-mode -1)
(setq buffer-offer-save t)
- (mh-make-local-hook (mh-write-file-functions))
- (add-hook (mh-write-file-functions) #'mh-execute-commands nil t)
+ (add-hook 'write-file-functions #'mh-execute-commands nil t)
(make-local-variable 'revert-buffer-function)
(make-local-variable 'hl-line-mode) ; avoid pollution
- (mh-funcall-if-exists hl-line-mode 1)
+ (hl-line-mode 1)
(setq revert-buffer-function #'mh-undo-folder)
(add-to-list 'minor-mode-alist '(mh-showing-mode " Show"))
- (mh-do-in-xemacs
- (easy-menu-add mh-folder-sequence-menu)
- (easy-menu-add mh-folder-message-menu)
- (easy-menu-add mh-folder-folder-menu))
(mh-inc-spool-make)
- (mh-set-help mh-folder-mode-help-messages)
- (if (and (featurep 'xemacs)
- font-lock-auto-fontify)
- (turn-on-font-lock))) ; Force font-lock in XEmacs.
+ (mh-set-help mh-folder-mode-help-messages))
@@ -1571,35 +1543,35 @@ after the commands are processed."
(append folders-changed (mh-index-execute-commands))))
;; Then refile messages
- (mh-mapc #'(lambda (folder-msg-list)
- (let* ((dest-folder (symbol-name (car folder-msg-list)))
- (last (car (mh-translate-range dest-folder "last")))
- (msgs (cdr folder-msg-list)))
- (push dest-folder folders-changed)
- (setq redraw-needed-flag t)
- (apply #'mh-exec-cmd
- "refile" "-src" folder dest-folder
- (mh-coalesce-msg-list msgs))
- (mh-delete-scan-msgs msgs)
- ;; Preserve sequences in destination folder...
- (when mh-refile-preserves-sequences-flag
- (clrhash dest-map)
- (cl-loop
- for i from (1+ (or last 0))
- for msg in (sort (copy-sequence msgs) #'<)
- do (cl-loop for seq-name in (gethash msg seq-map)
- do (push i (gethash seq-name dest-map))))
- (maphash
- #'(lambda (seq msgs)
- ;; Can't be run in the background, since the
- ;; current folder is changed by mark this could
- ;; lead to a race condition with the next refile.
- (apply #'mh-exec-cmd "mark"
- "-sequence" (symbol-name seq) dest-folder
- "-add" (mapcar #'(lambda (x) (format "%s" x))
- (mh-coalesce-msg-list msgs))))
- dest-map))))
- mh-refile-list)
+ (mapc (lambda (folder-msg-list)
+ (let* ((dest-folder (symbol-name (car folder-msg-list)))
+ (last (car (mh-translate-range dest-folder "last")))
+ (msgs (cdr folder-msg-list)))
+ (push dest-folder folders-changed)
+ (setq redraw-needed-flag t)
+ (apply #'mh-exec-cmd
+ "refile" "-src" folder dest-folder
+ (mh-coalesce-msg-list msgs))
+ (mh-delete-scan-msgs msgs)
+ ;; Preserve sequences in destination folder...
+ (when mh-refile-preserves-sequences-flag
+ (clrhash dest-map)
+ (cl-loop
+ for i from (1+ (or last 0))
+ for msg in (sort (copy-sequence msgs) #'<)
+ do (cl-loop for seq-name in (gethash msg seq-map)
+ do (push i (gethash seq-name dest-map))))
+ (maphash
+ #'(lambda (seq msgs)
+ ;; Can't be run in the background, since the
+ ;; current folder is changed by mark this could
+ ;; lead to a race condition with the next refile.
+ (apply #'mh-exec-cmd "mark"
+ "-sequence" (symbol-name seq) dest-folder
+ "-add" (mapcar #'(lambda (x) (format "%s" x))
+ (mh-coalesce-msg-list msgs))))
+ dest-map))))
+ mh-refile-list)
(setq mh-refile-list ())
;; Now delete messages
@@ -1642,14 +1614,14 @@ after the commands are processed."
do (cl-loop for seq-name in (gethash msg seq-map)
do (push i (gethash seq-name allow-map))))
(maphash
- #'(lambda (seq msgs)
- ;; Can't be run in background, since the current
- ;; folder is changed by mark this could lead to a
- ;; race condition with the next refile/allowlist.
- (apply #'mh-exec-cmd "mark"
- "-sequence" (symbol-name seq) mh-inbox
- "-add" (mapcar #'(lambda(x) (format "%s" x))
- (mh-coalesce-msg-list msgs))))
+ (lambda (seq msgs)
+ ;; Can't be run in background, since the current
+ ;; folder is changed by mark this could lead to a
+ ;; race condition with the next refile/allowlist.
+ (apply #'mh-exec-cmd "mark"
+ "-sequence" (symbol-name seq) mh-inbox
+ "-add" (mapcar #'(lambda(x) (format "%s" x))
+ (mh-coalesce-msg-list msgs))))
allow-map))
(setq mh-allowlist nil)))
diff --git a/lisp/mh-e/mh-funcs.el b/lisp/mh-e/mh-funcs.el
index 4a5e670c1ef..0c73aae0d79 100644
--- a/lisp/mh-e/mh-funcs.el
+++ b/lisp/mh-e/mh-funcs.el
@@ -147,7 +147,7 @@ Display the results only if something went wrong."
"-recurse"
"-norecurse"))
(goto-char (point-min))
- (mh-view-mode-enter)
+ (view-mode-enter)
(setq view-exit-action 'kill-buffer)
(message "Listing folders...done")))))
diff --git a/lisp/mh-e/mh-gnus.el b/lisp/mh-e/mh-gnus.el
index cc60f7b6640..0e1bde71f20 100644
--- a/lisp/mh-e/mh-gnus.el
+++ b/lisp/mh-e/mh-gnus.el
@@ -29,110 +29,49 @@
(require 'mh-e)
(eval-and-compile
- (mh-require 'gnus-util nil t)
- (mh-require 'mm-bodies nil t)
- (mh-require 'mm-decode nil t)
- (mh-require 'mm-view nil t)
- (mh-require 'mml nil t))
-
-;; Copy of function from gnus-util.el.
-;; TODO This is not in Gnus 5.11.
-(defun-mh mh-gnus-local-map-property gnus-local-map-property (map)
+ (require 'gnus-util nil t)
+ (require 'mm-bodies nil t)
+ (require 'mm-decode nil t)
+ (require 'mm-view nil t)
+ (require 'mml nil t))
+
+(defun mh-gnus-local-map-property (map)
"Return a list suitable for a text property list specifying keymap MAP."
- (cond ((featurep 'xemacs) (list 'keymap map))
- ((>= emacs-major-version 21) (list 'keymap map))
- (t (list 'local-map map))))
-
-;; Copy of function from mm-decode.el.
-(defun-mh mh-mm-merge-handles mm-merge-handles (handles1 handles2)
- (append
- (if (listp (car handles1))
- handles1
- (list handles1))
- (if (listp (car handles2))
- handles2
- (list handles2))))
-
-;; Copy of function from mm-decode.el.
-(defun-mh mh-mm-set-handle-multipart-parameter
- mm-set-handle-multipart-parameter (handle parameter value)
- ;; HANDLE could be a CTL.
- (when handle
- (put-text-property 0 (length (car handle)) parameter value
- (car handle))))
-
-;; Copy of function from mm-view.el.
-(defun-mh mh-mm-inline-text-vcard mm-inline-text-vcard (handle)
- (let ((inhibit-read-only t))
- (mm-insert-inline
- handle
- (concat "\n-- \n"
- (ignore-errors
- (if (fboundp 'vcard-pretty-print)
- (vcard-pretty-print (mm-get-part handle))
- (vcard-format-string
- (vcard-parse-string (mm-get-part handle)
- 'vcard-standard-filter))))))))
-
-;; Function from mm-decode.el used in PGP messages. Just define it with older
-;; Gnus to avoid compiler warning.
-(defun-mh mh-mm-possibly-verify-or-decrypt
- mm-possibly-verify-or-decrypt (_parts _ctl)
- nil)
-
-;; Copy of macro in mm-decode.el.
-(defmacro-mh mh-mm-handle-multipart-ctl-parameter
- mm-handle-multipart-ctl-parameter (handle parameter)
- `(get-text-property 0 ,parameter (car ,handle)))
-
-;; Copy of function in mm-decode.el.
-(defun-mh mh-mm-readable-p mm-readable-p (handle)
- "Say whether the content of HANDLE is readable."
- (and (< (with-current-buffer (mm-handle-buffer handle)
- (buffer-size)) 10000)
- (mm-with-unibyte-buffer
- (mm-insert-part handle)
- (and (eq (mm-body-7-or-8) '7bit)
- (not (mh-mm-long-lines-p 76))))))
-
-;; Copy of function in mm-bodies.el.
-(defun-mh mh-mm-long-lines-p mm-long-lines-p (length)
- "Say whether any of the lines in the buffer is longer than LENGTH."
- (save-excursion
- (goto-char (point-min))
- (end-of-line)
- (while (and (not (eobp))
- (not (> (current-column) length)))
- (forward-line 1)
- (end-of-line))
- (and (> (current-column) length)
- (current-column))))
-
-(defun-mh mh-mm-keep-viewer-alive-p mm-keep-viewer-alive-p (_handle)
- ;; Released Gnus doesn't keep handles associated with externally displayed
- ;; MIME parts. So this will always return nil.
- nil)
-
-(defun-mh mh-mm-destroy-parts mm-destroy-parts (_list)
- "Older versions of Emacs don't have this function."
- nil)
-
-(defun-mh mh-mm-uu-dissect-text-parts mm-uu-dissect-text-parts (_handles)
- "Emacs 21 and XEmacs don't have this function."
- nil)
-
-;; Copy of function in mml.el.
-(defun-mh mh-mml-minibuffer-read-disposition
- mml-minibuffer-read-disposition (type &optional default filename)
- (unless default
- (setq default (mml-content-disposition type filename)))
- (let ((disposition (completing-read
- (format-prompt "Disposition" default)
- '(("attachment") ("inline") (""))
- nil t nil nil default)))
- (if (not (equal disposition ""))
- disposition
- default)))
+ (declare (obsolete nil "29.1"))
+ (list 'keymap map))
+
+(define-obsolete-function-alias 'mh-mm-merge-handles
+ #'mm-merge-handles "29.1")
+
+(define-obsolete-function-alias 'mh-mm-set-handle-multipart-parameter
+ #'mm-set-handle-multipart-parameter "29.1")
+
+(define-obsolete-function-alias 'mh-mm-inline-text-vcard
+ #'mm-inline-text-vcard "29.1")
+
+(define-obsolete-function-alias 'mh-mm-possibly-verify-or-decrypt
+ #'mm-possibly-verify-or-decrypt "29.1")
+
+(define-obsolete-function-alias 'mh-mm-handle-multipart-ctl-parameter
+ #'mm-handle-multipart-ctl-parameter "29.1")
+
+(define-obsolete-function-alias 'mh-mm-readable-p
+ #'mm-readable-p "29.1")
+
+(define-obsolete-function-alias 'mh-mm-long-lines-p
+ #'mm-long-lines-p "29.1")
+
+(define-obsolete-function-alias 'mh-mm-keep-viewer-alive-p
+ #'mm-keep-viewer-alive-p "29.1")
+
+(define-obsolete-function-alias 'mh-mm-destroy-parts
+ #'mm-destroy-parts "29.1")
+
+(define-obsolete-function-alias 'mh-mm-uu-dissect-text-parts
+ #'mm-uu-dissect-text-parts "29.1")
+
+(define-obsolete-function-alias 'mh-mml-minibuffer-read-disposition
+ #'mml-minibuffer-read-disposition "29.1")
;; This is mm-save-part from Gnus 5.11 since that function in Emacs
;; 21.2 is buggy (the args to read-file-name are incorrect) and the
@@ -163,8 +102,8 @@ PROMPT overrides the default one used to ask user for a file name."
(defun mh-mm-text-html-renderer ()
"Find the renderer Gnus is using to display text/html MIME parts."
- (or (and (boundp 'mm-inline-text-html-renderer) mm-inline-text-html-renderer)
- (and (boundp 'mm-text-html-renderer) mm-text-html-renderer)))
+ (declare (obsolete mm-text-html-renderer "29.1"))
+ mm-text-html-renderer)
(provide 'mh-gnus)
diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el
index ceede0d07cb..994ab713915 100644
--- a/lisp/mh-e/mh-identity.el
+++ b/lisp/mh-e/mh-identity.el
@@ -39,11 +39,10 @@
(autoload 'mml-insert-tag "mml")
-(defvar mh-identity-pgg-default-user-id nil
+(defvar-local mh-identity-pgg-default-user-id nil
"Holds the GPG key ID to be used by pgg.el.
This is normally set as part of an Identity in
`mh-identity-list'.")
-(make-variable-buffer-local 'mh-identity-pgg-default-user-id)
(defvar mh-identity-menu nil
"The Identity menu.")
@@ -54,8 +53,7 @@ This is normally set as part of an Identity in
(defun mh-identity-make-menu ()
"Build the Identity menu.
This should be called any time `mh-identity-list' or
-`mh-auto-fields-list' change.
-See `mh-identity-add-menu'."
+`mh-auto-fields-list' change."
(easy-menu-define mh-identity-menu mh-letter-mode-map
"MH-E identity menu"
(append
@@ -88,12 +86,11 @@ See `mh-identity-add-menu'."
(defun mh-identity-add-menu ()
"Add the current Identity menu.
See `mh-identity-make-menu'."
- (if mh-identity-menu
- (mh-do-in-xemacs (easy-menu-add mh-identity-menu))))
+ (declare (obsolete nil "29.1"))
+ nil)
-(defvar mh-identity-local nil
+(defvar-local mh-identity-local nil
"Buffer-local variable that holds the identity currently in use.")
-(make-variable-buffer-local 'mh-identity-local)
(defun mh-header-field-delete (field value-only)
"Delete header FIELD, or only its value if VALUE-ONLY is t.
@@ -122,7 +119,7 @@ The field name is downcased. If the FIELD begins with the
character \":\", then it must have a special handler defined in
`mh-identity-handlers', else return an error since it is not a
valid header field."
- (or (cdr (mh-assoc-string field mh-identity-handlers t))
+ (or (cdr (assoc-string field mh-identity-handlers t))
(and (eq (aref field 0) ?:)
(error "Field %s not found in `mh-identity-handlers'" field))
(cdr (assoc ":default" mh-identity-handlers))
@@ -235,11 +232,9 @@ added."
(if (null value)
(mh-insert-signature)
(mh-insert-signature value))
- (set (make-local-variable 'mh-identity-signature-start)
- (point-min-marker))
+ (setq-local mh-identity-signature-start (point-min-marker))
(set-marker-insertion-type mh-identity-signature-start t)
- (set (make-local-variable 'mh-identity-signature-end)
- (point-max-marker)))))))
+ (setq-local mh-identity-signature-end (point-max-marker)))))))
(defvar mh-identity-attribution-verb-start nil
"Marker for the beginning of the attribution verb.")
@@ -271,11 +266,9 @@ If VALUE is nil, use `mh-extract-from-attribution-verb'."
(if (null value)
(insert mh-extract-from-attribution-verb)
(insert value))
- (set (make-local-variable 'mh-identity-attribution-verb-start)
- (point-min-marker))
+ (setq-local mh-identity-attribution-verb-start (point-min-marker))
(set-marker-insertion-type mh-identity-attribution-verb-start t)
- (set (make-local-variable 'mh-identity-attribution-verb-end)
- (point-max-marker))))
+ (setq-local mh-identity-attribution-verb-end (point-max-marker))))
(defun mh-identity-handler-default (field action top &optional value)
"Process header FIELD.
diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el
index ae5b80d5807..ebe94a7af83 100644
--- a/lisp/mh-e/mh-letter.el
+++ b/lisp/mh-e/mh-letter.el
@@ -114,68 +114,68 @@
;;; MH-Letter Keys
;; If this changes, modify mh-letter-mode-help-messages accordingly, above.
-(gnus-define-keys mh-letter-mode-map
- " " mh-letter-complete-or-space
- "," mh-letter-confirm-address
- "\C-c?" mh-help
- "\C-c\C-\\" mh-fully-kill-draft ;if no C-q
- "\C-c\C-^" mh-insert-signature ;if no C-s
- "\C-c\C-c" mh-send-letter
- "\C-c\C-d" mh-insert-identity
- "\C-c\C-e" mh-mh-to-mime
- "\C-c\C-f\C-a" mh-to-field
- "\C-c\C-f\C-b" mh-to-field
- "\C-c\C-f\C-c" mh-to-field
- "\C-c\C-f\C-d" mh-to-field
- "\C-c\C-f\C-f" mh-to-fcc
- "\C-c\C-f\C-l" mh-to-field
- "\C-c\C-f\C-m" mh-to-field
- "\C-c\C-f\C-r" mh-to-field
- "\C-c\C-f\C-s" mh-to-field
- "\C-c\C-f\C-t" mh-to-field
- "\C-c\C-fa" mh-to-field
- "\C-c\C-fb" mh-to-field
- "\C-c\C-fc" mh-to-field
- "\C-c\C-fd" mh-to-field
- "\C-c\C-ff" mh-to-fcc
- "\C-c\C-fl" mh-to-field
- "\C-c\C-fm" mh-to-field
- "\C-c\C-fr" mh-to-field
- "\C-c\C-fs" mh-to-field
- "\C-c\C-ft" mh-to-field
- "\C-c\C-i" mh-insert-letter
- "\C-c\C-m\C-e" mh-mml-secure-message-encrypt
- "\C-c\C-m\C-f" mh-compose-forward
- "\C-c\C-m\C-g" mh-mh-compose-anon-ftp
- "\C-c\C-m\C-i" mh-compose-insertion
- "\C-c\C-m\C-m" mh-mml-to-mime
- "\C-c\C-m\C-n" mh-mml-unsecure-message
- "\C-c\C-m\C-s" mh-mml-secure-message-sign
- "\C-c\C-m\C-t" mh-mh-compose-external-compressed-tar
- "\C-c\C-m\C-u" mh-mh-to-mime-undo
- "\C-c\C-m\C-x" mh-mh-compose-external-type
- "\C-c\C-mee" mh-mml-secure-message-encrypt
- "\C-c\C-mes" mh-mml-secure-message-signencrypt
- "\C-c\C-mf" mh-compose-forward
- "\C-c\C-mg" mh-mh-compose-anon-ftp
- "\C-c\C-mi" mh-compose-insertion
- "\C-c\C-mm" mh-mml-to-mime
- "\C-c\C-mn" mh-mml-unsecure-message
- "\C-c\C-mse" mh-mml-secure-message-signencrypt
- "\C-c\C-mss" mh-mml-secure-message-sign
- "\C-c\C-mt" mh-mh-compose-external-compressed-tar
- "\C-c\C-mu" mh-mh-to-mime-undo
- "\C-c\C-mx" mh-mh-compose-external-type
- "\C-c\C-o" mh-open-line
- "\C-c\C-q" mh-fully-kill-draft
- "\C-c\C-s" mh-insert-signature
- "\C-c\C-t" mh-letter-toggle-header-field-display
- "\C-c\C-w" mh-check-whom
- "\C-c\C-y" mh-yank-cur-msg
- "\C-c\M-d" mh-insert-auto-fields
- "\M-\t" mh-letter-complete
- "\t" mh-letter-next-header-field-or-indent
- [backtab] mh-letter-previous-header-field)
+(define-keymap :keymap mh-letter-mode-map
+ "SPC" #'mh-letter-complete-or-space
+ "," #'mh-letter-confirm-address
+ "C-c ?" #'mh-help
+ "C-c C-\\" #'mh-fully-kill-draft ;if no C-q
+ "C-c C-^" #'mh-insert-signature ;if no C-s
+ "C-c C-c" #'mh-send-letter
+ "C-c C-d" #'mh-insert-identity
+ "C-c C-e" #'mh-mh-to-mime
+ "C-c C-f C-a" #'mh-to-field
+ "C-c C-f C-b" #'mh-to-field
+ "C-c C-f C-c" #'mh-to-field
+ "C-c C-f C-d" #'mh-to-field
+ "C-c C-f C-f" #'mh-to-fcc
+ "C-c C-f C-l" #'mh-to-field
+ "C-c C-f C-m" #'mh-to-field
+ "C-c C-f C-r" #'mh-to-field
+ "C-c C-f C-s" #'mh-to-field
+ "C-c C-f C-t" #'mh-to-field
+ "C-c C-f a" #'mh-to-field
+ "C-c C-f b" #'mh-to-field
+ "C-c C-f c" #'mh-to-field
+ "C-c C-f d" #'mh-to-field
+ "C-c C-f f" #'mh-to-fcc
+ "C-c C-f l" #'mh-to-field
+ "C-c C-f m" #'mh-to-field
+ "C-c C-f r" #'mh-to-field
+ "C-c C-f s" #'mh-to-field
+ "C-c C-f t" #'mh-to-field
+ "C-c C-i" #'mh-insert-letter
+ "C-c C-m C-e" #'mh-mml-secure-message-encrypt
+ "C-c C-m C-f" #'mh-compose-forward
+ "C-c C-m C-g" #'mh-mh-compose-anon-ftp
+ "C-c C-m TAB" #'mh-compose-insertion
+ "C-c C-m C-m" #'mh-mml-to-mime
+ "C-c C-m C-n" #'mh-mml-unsecure-message
+ "C-c C-m C-s" #'mh-mml-secure-message-sign
+ "C-c C-m C-t" #'mh-mh-compose-external-compressed-tar
+ "C-c C-m C-u" #'mh-mh-to-mime-undo
+ "C-c C-m C-x" #'mh-mh-compose-external-type
+ "C-c C-m e e" #'mh-mml-secure-message-encrypt
+ "C-c C-m e s" #'mh-mml-secure-message-signencrypt
+ "C-c C-m f" #'mh-compose-forward
+ "C-c C-m g" #'mh-mh-compose-anon-ftp
+ "C-c C-m i" #'mh-compose-insertion
+ "C-c C-m m" #'mh-mml-to-mime
+ "C-c C-m n" #'mh-mml-unsecure-message
+ "C-c C-m s e" #'mh-mml-secure-message-signencrypt
+ "C-c C-m s s" #'mh-mml-secure-message-sign
+ "C-c C-m t" #'mh-mh-compose-external-compressed-tar
+ "C-c C-m u" #'mh-mh-to-mime-undo
+ "C-c C-m x" #'mh-mh-compose-external-type
+ "C-c C-o" #'mh-open-line
+ "C-c C-q" #'mh-fully-kill-draft
+ "C-c C-s" #'mh-insert-signature
+ "C-c C-t" #'mh-letter-toggle-header-field-display
+ "C-c C-w" #'mh-check-whom
+ "C-c C-y" #'mh-yank-cur-msg
+ "C-c M-d" #'mh-insert-auto-fields
+ "C-M-i" #'completion-at-point
+ "TAB" #'mh-letter-next-header-field-or-indent
+ "<backtab>" #'mh-letter-previous-header-field)
;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el.
@@ -253,17 +253,13 @@ searching for `mh-mail-header-separator' in the buffer."
(goto-char (point-min))
(cond ((equal mh-mail-header-separator "") (point-min))
((search-forward (format "\n%s\n" mh-mail-header-separator) nil t)
- (mh-line-beginning-position 0))
+ (line-beginning-position 0))
(t (point-min)))))
;;; MH-Letter Mode
-;; Shush compiler.
-(mh-do-in-xemacs
- (defvar font-lock-defaults))
-
;; Ensure new buffers won't get this mode if default major-mode is nil.
(put 'mh-letter-mode 'mode-class 'special)
@@ -295,24 +291,21 @@ order).
(make-local-variable 'mh-previous-window-config)
(make-local-variable 'mh-sent-from-folder)
(make-local-variable 'mh-sent-from-msg)
- (mh-do-in-gnu-emacs
- (unless mh-letter-tool-bar-map
- (mh-tool-bar-letter-buttons-init))
- (if (boundp 'tool-bar-map)
- (set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map)))
- (mh-do-in-xemacs
- (mh-tool-bar-init :letter))
+ (unless mh-letter-tool-bar-map
+ (mh-tool-bar-letter-buttons-init))
+ (if (boundp 'tool-bar-map)
+ (setq-local tool-bar-map mh-letter-tool-bar-map))
;; Set the local value of mh-mail-header-separator according to what is
;; present in the buffer...
- (set (make-local-variable 'mh-mail-header-separator)
- (save-excursion
- (goto-char (mh-mail-header-end))
- (buffer-substring-no-properties (point) (mh-line-end-position))))
+ (setq-local mh-mail-header-separator
+ (save-excursion
+ (goto-char (mh-mail-header-end))
+ (buffer-substring-no-properties (point) (line-end-position))))
(make-local-variable 'mail-header-separator)
(setq mail-header-separator mh-mail-header-separator) ;override sendmail.el
(mh-set-help mh-letter-mode-help-messages)
(setq buffer-invisibility-spec '((vanish . t) t))
- (set (make-local-variable 'line-move-ignore-invisible) t)
+ (setq-local line-move-ignore-invisible t)
;; Enable undo since a show-mode buffer might have been reused.
(buffer-enable-undo)
@@ -328,12 +321,10 @@ order).
(t
;; ...or the header only
(setq font-lock-defaults '((mh-show-font-lock-keywords) t))))
- (mh-do-in-xemacs (easy-menu-add mh-letter-menu))
;; Maybe we want to use the existing Mail menu from mail-mode in
;; 9.0; in the mean time, let's remove it since the redundancy will
;; only produce confusion.
(define-key mh-letter-mode-map [menu-bar mail] #'undefined)
- (mh-do-in-xemacs (easy-menu-remove mail-menubar-menu))
(setq fill-column mh-letter-fill-column)
(add-hook 'completion-at-point-functions
#'mh-letter-completion-at-point nil 'local)
@@ -488,29 +479,8 @@ This provides alias and folder completion in header fields according to
(or (funcall func) #'ignore)
mh-letter-complete-function)))
-;; TODO Now that completion-at-point performs the task of
-;; mh-letter-complete, perhaps mh-letter-complete along with
-;; mh-complete-word should be rewritten as a more general function for
-;; XEmacs, renamed to mh-completion-at-point, and moved to
-;; mh-compat.el.
-(defun-mh mh-letter-complete completion-at-point ()
- "Perform completion on header field or word preceding point.
-
-If the field contains addresses (for example, \"To:\" or \"Cc:\")
-or folders (for example, \"Fcc:\") then this command will provide
-alias completion. In the body of the message, this command runs
-`mh-letter-complete-function' instead, which is set to
-`ispell-complete-word' by default."
- (interactive)
- (let ((data (mh-letter-completion-at-point)))
- (cond
- ((functionp data) (funcall data))
- ((consp data)
- (let ((start (nth 0 data))
- (end (nth 1 data))
- (table (nth 2 data)))
- (mh-complete-word (buffer-substring-no-properties start end)
- table start end))))))
+(define-obsolete-function-alias 'mh-letter-complete
+ #'completion-at-point "29.1")
(defun mh-letter-complete-or-space (arg)
"Perform completion or insert space.
@@ -530,7 +500,7 @@ one space."
((> (point) end-of-prev) (self-insert-command arg))
((let ((mh-letter-complete-function nil))
(mh-letter-completion-at-point))
- (mh-letter-complete))
+ (completion-at-point))
(t (self-insert-command arg)))))
(defun mh-letter-confirm-address ()
@@ -722,7 +692,7 @@ and `mh-ins-buf-prefix' is not inserted."
;; Find displayed message
(with-current-buffer show-buffer
(let* ((from-attr (mh-extract-from-attribution))
- (yank-region (mh-mark-active-p nil))
+ (yank-region mark-active)
(mh-ins-str
(cond ((and yank-region
(or (eq 'supercite mh-yank-behavior)
@@ -834,7 +804,7 @@ body."
((< (point) (progn
(beginning-of-line)
(re-search-forward mh-letter-header-field-regexp
- (mh-line-end-position) t)
+ (line-end-position) t)
(point)))
(beginning-of-line))
(t (end-of-line)))
diff --git a/lisp/mh-e/mh-limit.el b/lisp/mh-e/mh-limit.el
index 39cf7c5d271..a00252284af 100644
--- a/lisp/mh-e/mh-limit.el
+++ b/lisp/mh-e/mh-limit.el
@@ -124,7 +124,7 @@ Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
(setq pick-expr
(let ((case-fold-search t))
(cl-loop for s in pick-expr
- collect (mh-replace-regexp-in-string "re: *" "" s))))
+ collect (replace-regexp-in-string "re: *" "" s))))
(mh-narrow-to-header-field 'subject pick-expr))
;;;###mh-autoload
@@ -214,7 +214,7 @@ Return number of messages put in the sequence:
(string-equal "" (match-string 3)))
(progn (message "No subject line")
nil)
- (let ((subject (mh-match-string-no-properties 3))
+ (let ((subject (match-string-no-properties 3))
(list))
(if (> (length subject) mh-limit-max-subject-size)
(setq subject (substring subject 0 mh-limit-max-subject-size)))
@@ -222,7 +222,7 @@ Return number of messages put in the sequence:
(if all
(goto-char (point-min)))
(while (re-search-forward mh-scan-subject-regexp nil t)
- (let ((this-subject (mh-match-string-no-properties 3)))
+ (let ((this-subject (match-string-no-properties 3)))
(if (> (length this-subject) mh-limit-max-subject-size)
(setq this-subject (substring this-subject
0 mh-limit-max-subject-size)))
@@ -313,7 +313,7 @@ The MH command pick is used to do the match."
(while (not (eobp))
(let ((num (ignore-errors
(string-to-number
- (buffer-substring (point) (mh-line-end-position))))))
+ (buffer-substring (point) (line-end-position))))))
(when num (push num msg-list))
(forward-line))))
(if (null msg-list)
diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el
index ad594aef906..714bf029bb7 100644
--- a/lisp/mh-e/mh-mime.el
+++ b/lisp/mh-e/mh-mime.el
@@ -39,6 +39,7 @@
;;; Code:
(require 'mh-e)
+(require 'mh-acros)
(require 'mh-gnus) ;needed because mh-gnus.el not compiled
(require 'font-lock)
@@ -135,13 +136,11 @@
("application/emacs-lisp" mm-display-elisp-inline identity)
("application/x-emacs-lisp" mm-display-elisp-inline identity)
("text/html"
- ,(if (fboundp 'mm-inline-text-html) 'mm-inline-text-html 'mm-inline-text)
+ mm-inline-text-html
(lambda (handle)
- (or (and (boundp 'mm-inline-text-html-renderer)
- mm-inline-text-html-renderer)
- (and (boundp 'mm-text-html-renderer) mm-text-html-renderer))))
+ mm-text-html-renderer))
("text/x-vcard"
- mh-mm-inline-text-vcard
+ mm-inline-text-vcard
(lambda (handle)
(or (featurep 'vcard)
(locate-library "vcard"))))
@@ -171,7 +170,7 @@
("audio/.*" ignore ignore)
("image/.*" ignore ignore)
;; Default to displaying as text
- (".*" mm-inline-text mh-mm-readable-p))
+ (".*" mm-inline-text mm-readable-p))
"Alist of media types/tests saying whether types can be displayed inline.")
(defvar mh-mime-save-parts-directory nil
@@ -184,13 +183,7 @@ Set from last use.")
'((mh-press-button "\r" "Toggle Display")))
(defvar mh-mime-button-map
(let ((map (make-sparse-keymap)))
- (unless (>= (string-to-number emacs-version) 21)
- ;; XEmacs doesn't care.
- (set-keymap-parent map mh-show-mode-map))
- (mh-do-in-gnu-emacs
- (define-key map [mouse-2] #'mh-push-button))
- (mh-do-in-xemacs
- (define-key map '(button2) #'mh-push-button))
+ (define-key map [mouse-2] #'mh-push-button)
(dolist (c mh-mime-button-commands)
(define-key map (cadr c) (car c)))
map))
@@ -210,13 +203,8 @@ Set from last use.")
(?D pressed-details ?s)))
(defvar mh-mime-security-button-map
(let ((map (make-sparse-keymap)))
- (unless (>= (string-to-number emacs-version) 21)
- (set-keymap-parent map mh-show-mode-map))
(define-key map "\r" #'mh-press-button)
- (mh-do-in-gnu-emacs
- (define-key map [mouse-2] #'mh-push-button))
- (mh-do-in-xemacs
- (define-key map '(button2) #'mh-push-button))
+ (define-key map [mouse-2] #'mh-push-button)
map))
@@ -251,24 +239,24 @@ usually reads the file \"/etc/mailcap\"."
(when (consp part-index) (setq part-index (car part-index)))
(mh-folder-mime-action
part-index
- #'(lambda ()
- (let* ((part (get-text-property (point) 'mh-data))
- (type (mm-handle-media-type part))
- (methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x))))
- (mailcap-mime-info type 'all)))
- (def (caar methods))
- (prompt (format-prompt "Viewer" def))
- (method (completing-read prompt methods nil nil nil nil def))
- (folder mh-show-folder-buffer)
- (buffer-read-only nil))
- (when (string-match "^[^% \t]+$" method)
- (setq method (concat method " %s")))
- (mh-flet
- ((mm-handle-set-external-undisplayer
- (handle function)
- (mh-handle-set-external-undisplayer folder handle function)))
- (unwind-protect (mm-display-external part method)
- (set-buffer-modified-p nil)))))
+ (lambda ()
+ (let* ((part (get-text-property (point) 'mh-data))
+ (type (mm-handle-media-type part))
+ (methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x))))
+ (mailcap-mime-info type 'all)))
+ (def (caar methods))
+ (prompt (format-prompt "Viewer" def))
+ (method (completing-read prompt methods nil nil nil nil def))
+ (folder mh-show-folder-buffer)
+ (buffer-read-only nil))
+ (when (string-match "^[^% \t]+$" method)
+ (setq method (concat method " %s")))
+ (mh-flet
+ ((mm-handle-set-external-undisplayer
+ (handle function)
+ (mh-handle-set-external-undisplayer folder handle function)))
+ (unwind-protect (mm-display-external part method)
+ (set-buffer-modified-p nil)))))
nil))
;;;###mh-autoload
@@ -299,14 +287,14 @@ the attachment labeled with that number."
start end)
(cond ((and data (not inserted-flag) (not displayed-flag))
(let ((contents (mm-get-part data)))
- (add-text-properties (mh-line-beginning-position)
- (mh-line-end-position) '(mh-mime-inserted t))
+ (add-text-properties (line-beginning-position)
+ (line-end-position) '(mh-mime-inserted t))
(setq start (point-marker))
(forward-line 1)
(mm-insert-inline data contents)
(setq end (point-marker))
(add-text-properties
- start (progn (goto-char start) (mh-line-end-position))
+ start (progn (goto-char start) (line-end-position))
`(mh-region (,start . ,end)))))
((and data (or inserted-flag displayed-flag))
(mh-press-button)
@@ -458,10 +446,10 @@ decoding the same message multiple times."
(setf (gethash handle (mh-mime-handles-cache (mh-buffer-data)))
(let ((handles (mm-dissect-buffer nil)))
(if handles
- (mh-mm-uu-dissect-text-parts handles)
+ (mm-uu-dissect-text-parts handles)
(setq handles (mm-uu-dissect)))
(setf (mh-mime-handles (mh-buffer-data))
- (mh-mm-merge-handles
+ (mm-merge-handles
handles (mh-mime-handles (mh-buffer-data))))
handles))))
@@ -532,10 +520,10 @@ parsed and then displayed."
(if pre-dissected-handles
(setq handles pre-dissected-handles)
(if (setq handles (mm-dissect-buffer nil))
- (mh-mm-uu-dissect-text-parts handles)
+ (mm-uu-dissect-text-parts handles)
(setq handles (mm-uu-dissect)))
(setf (mh-mime-handles (mh-buffer-data))
- (mh-mm-merge-handles handles
+ (mm-merge-handles handles
(mh-mime-handles (mh-buffer-data))))
(unless handles
(mh-decode-message-body)))
@@ -641,7 +629,7 @@ buttons for alternative parts that are usually suppressed."
(let ((mh-mime-security-button-line-format
mh-mime-security-button-end-line-format))
(mh-insert-mime-security-button handle))
- (mh-mm-set-handle-multipart-parameter
+ (mm-set-handle-multipart-parameter
handle 'mh-region (cons (point-min-marker) (point-max-marker)))))
(defun mh-mime-display-single (handle)
@@ -713,8 +701,7 @@ buttons for alternative parts that are usually suppressed."
;; Delete the button and displayed part (if any)
(let ((region (get-text-property point 'mh-region)))
(when region
- (mh-funcall-if-exists
- remove-images (car region) (cdr region)))
+ (remove-images (car region) (cdr region)))
(mm-display-part handle)
(when region
(delete-region (car region) (cdr region))))
@@ -752,8 +739,8 @@ buttons for alternative parts that are usually suppressed."
(mh-insert-mime-button handle id (mm-handle-displayed-p handle))
(goto-char point)
(when region
- (add-text-properties (mh-line-beginning-position)
- (mh-line-end-position)
+ (add-text-properties (line-beginning-position)
+ (line-end-position)
`(mh-region ,region)))))))
(defun mh-mime-part-index (handle)
@@ -777,20 +764,12 @@ This is only useful if a Content-Disposition header is not present."
; this only tells us if the image is
; something that emacs can display
(let ((image (mm-get-image handle)))
- (or (mh-do-in-xemacs
- (and (mh-funcall-if-exists glyphp image)
- (< (glyph-width image)
- (or mh-max-inline-image-width (window-pixel-width)))
- (< (glyph-height image)
- (or mh-max-inline-image-height
- (window-pixel-height)))))
- (mh-do-in-gnu-emacs
- (let ((size (and (fboundp 'image-size) (image-size image))))
- (and size
- (< (cdr size) (or mh-max-inline-image-height
- (1- (window-height))))
- (< (car size) (or mh-max-inline-image-width
- (window-width)))))))))))
+ (let ((size (and (fboundp 'image-size) (image-size image))))
+ (and size
+ (< (cdr size) (or mh-max-inline-image-height
+ (1- (window-height))))
+ (< (car size) (or mh-max-inline-image-width
+ (window-width)))))))))
(defun mh-inline-vcard-p (handle)
"Decide if HANDLE is a vcard that must be displayed inline."
@@ -813,27 +792,19 @@ being used to highlight the signature in a MIME part."
((not (and (equal (mm-handle-media-supertype handle) "text")
(equal (mm-handle-media-subtype handle) "html")))
"^-- $")
- ((eq (mh-mm-text-html-renderer) 'lynx) "^ --$")
+ ((eq mm-text-html-renderer 'lynx) "^ --$")
(t "^--$"))))
(save-excursion
(goto-char (point-max))
(when (re-search-backward regexp nil t)
- (mh-do-in-gnu-emacs
- (let ((ov (make-overlay (point) (point-max))))
- (overlay-put ov 'face 'mh-show-signature)
- (overlay-put ov 'evaporate t)))
- (mh-do-in-xemacs
- (set-extent-property (make-extent (point) (point-max))
- 'face 'mh-show-signature))))))
+ (let ((ov (make-overlay (point) (point-max))))
+ (overlay-put ov 'face 'mh-show-signature)
+ (overlay-put ov 'evaporate t))))))
;;; Button Display
-;; Shush compiler.
-(mh-do-in-xemacs
- (defvar ov))
-
(defun mh-insert-mime-button (handle index displayed)
"Insert MIME button for HANDLE.
INDEX is the part number that will be DISPLAYED. It is also used
@@ -865,10 +836,10 @@ by commands like \"K v\" which operate on individual MIME parts."
(setq begin (point))
(gnus-eval-format
mh-mime-button-line-format mh-mime-button-line-format-alist
- `(,@(mh-gnus-local-map-property mh-mime-button-map)
- mh-callback mh-mm-display-part
- mh-part ,index
- mh-data ,handle)))
+ `(keymap ,mh-mime-button-map
+ mh-callback mh-mm-display-part
+ mh-part ,index
+ mh-data ,handle)))
(setq end (point))
(widget-convert-button
'link begin end
@@ -877,16 +848,12 @@ by commands like \"K v\" which operate on individual MIME parts."
:button-keymap mh-mime-button-map
:help-echo
"Mouse-2 click or press RET (in show buffer) to toggle display")
- (dolist (ov (mh-funcall-if-exists overlays-in begin end))
- (mh-funcall-if-exists overlay-put ov 'evaporate t))))
-
-;; Shush compiler.
-(defvar mm-verify-function-alist) ; < Emacs 22
-(defvar mm-decrypt-function-alist) ; < Emacs 22
+ (dolist (ov (overlays-in begin end))
+ (overlay-put ov 'evaporate t))))
(defun mh-insert-mime-security-button (handle)
"Display buttons for PGP message, HANDLE."
- (let* ((protocol (mh-mm-handle-multipart-ctl-parameter handle 'protocol))
+ (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
(crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist))
(nth 2 (assoc protocol mm-decrypt-function-alist))
"Unknown"))
@@ -897,10 +864,10 @@ by commands like \"K v\" which operate on individual MIME parts."
(if (equal (car handle) "multipart/signed")
" Signed" " Encrypted")
" Part"))
- (info (or (mh-mm-handle-multipart-ctl-parameter
+ (info (or (mm-handle-multipart-ctl-parameter
handle 'gnus-info)
"Undecided"))
- (details (mh-mm-handle-multipart-ctl-parameter
+ (details (mm-handle-multipart-ctl-parameter
handle 'gnus-details))
pressed-details)
(setq details (if details (concat "\n" details) ""))
@@ -911,11 +878,11 @@ by commands like \"K v\" which operate on individual MIME parts."
(gnus-eval-format
mh-mime-security-button-line-format
mh-mime-security-button-line-format-alist
- `(,@(mh-gnus-local-map-property mh-mime-security-button-map)
- mh-button-pressed ,mh-mime-security-button-pressed
- mh-callback mh-mime-security-press-button
- mh-line-format ,mh-mime-security-button-line-format
- mh-data ,handle))
+ `(keymap ,mh-mime-security-button-map
+ mh-button-pressed ,mh-mime-security-button-pressed
+ mh-callback mh-mime-security-press-button
+ mh-line-format ,mh-mime-security-button-line-format
+ mh-data ,handle))
(setq end (point))
(widget-convert-button 'link begin end
:mime-handle handle
@@ -923,8 +890,8 @@ by commands like \"K v\" which operate on individual MIME parts."
:button-keymap mh-mime-security-button-map
:button-face face
:help-echo "Mouse-2 click or press RET (in show buffer) to see security details.")
- (dolist (ov (mh-funcall-if-exists overlays-in begin end))
- (mh-funcall-if-exists overlay-put ov 'evaporate t))
+ (dolist (ov (overlays-in begin end))
+ (overlay-put ov 'evaporate t))
(when (equal info "Failed")
(let* ((type (if (equal (car handle) "multipart/signed")
"verification" "decryption"))
@@ -1081,7 +1048,7 @@ This is only called in recent versions of Gnus. The MIME handles
are stored in data structures corresponding to MH-E folder buffer
FOLDER instead of in Gnus (as in the original). The MIME part,
HANDLE is associated with the undisplayer FUNCTION."
- (if (mh-mm-keep-viewer-alive-p handle)
+ (if (mm-keep-viewer-alive-p handle)
(let ((new-handle (copy-sequence handle)))
(mm-handle-set-undisplayer new-handle function)
(mm-handle-set-undisplayer handle nil)
@@ -1091,19 +1058,19 @@ HANDLE is associated with the undisplayer FUNCTION."
(defun mh-mime-security-press-button (handle)
"Callback from security button for part HANDLE."
- (if (mh-mm-handle-multipart-ctl-parameter handle 'gnus-info)
+ (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
(mh-mime-security-show-details handle)
- (let ((region (mh-mm-handle-multipart-ctl-parameter handle 'mh-region))
+ (let ((region (mm-handle-multipart-ctl-parameter handle 'mh-region))
point)
(setq point (point))
(goto-char (car region))
(delete-region (car region) (cdr region))
- (with-current-buffer (mh-mm-handle-multipart-ctl-parameter handle 'buffer)
+ (with-current-buffer (mm-handle-multipart-ctl-parameter handle 'buffer)
(let* ((mm-verify-option 'known)
(mm-decrypt-option 'known)
- (new (mh-mm-possibly-verify-or-decrypt (cdr handle) handle)))
+ (new (mm-possibly-verify-or-decrypt (cdr handle) handle)))
(unless (eq new (cdr handle))
- (mh-mm-destroy-parts (cdr handle))
+ (mm-destroy-parts (cdr handle))
(setcdr handle new))))
(mh-mime-display-security handle)
(goto-char point))))
@@ -1113,7 +1080,7 @@ HANDLE is associated with the undisplayer FUNCTION."
;; to be no way of getting rid of the inserted text.
(defun mh-mime-security-show-details (handle)
"Toggle display of detailed security info for HANDLE."
- (let ((details (mh-mm-handle-multipart-ctl-parameter handle 'gnus-details)))
+ (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
(when details
(let ((mh-mime-security-button-pressed
(not (get-text-property (point) 'mh-button-pressed)))
@@ -1158,7 +1125,7 @@ this ;-)"
(defun mh-display-smileys ()
"Display smileys."
(when (and mh-graphical-smileys-flag (mh-small-show-buffer-p))
- (mh-funcall-if-exists smiley-region (point-min) (point-max))))
+ (smiley-region (point-min) (point-max))))
;;;###mh-autoload
(defun mh-display-emphasis ()
@@ -1175,6 +1142,7 @@ this ;-)"
This is used to decide if smileys and graphical emphasis should be
displayed."
(let ((max nil))
+ ;; FIXME: font-lock-maximum-size is obsolete.
(when (and (boundp 'font-lock-maximum-size) font-lock-maximum-size)
(cond ((numberp font-lock-maximum-size)
(setq max font-lock-maximum-size))
@@ -1303,7 +1271,7 @@ automatically."
(type (mh-minibuffer-read-type file))
(description (mml-minibuffer-read-description))
(dispos (or disposition
- (mh-mml-minibuffer-read-disposition type))))
+ (mml-minibuffer-read-disposition type))))
(mml-insert-empty-tag 'part 'type type 'filename file
'disposition dispos 'description description)))
@@ -1507,9 +1475,9 @@ This function will quote all such characters."
(goto-char (point-min))
(while (re-search-forward "^#" nil t)
(beginning-of-line)
- (unless (mh-mh-directive-present-p (point) (mh-line-end-position))
+ (unless (mh-mh-directive-present-p (point) (line-end-position))
(insert "#"))
- (goto-char (mh-line-end-position)))))
+ (goto-char (line-end-position)))))
;;;###mh-autoload
(defun mh-mh-to-mime-undo (noconfirm)
@@ -1695,7 +1663,7 @@ buffer, while END defaults to the end of the buffer."
(goto-char begin)
(while (re-search-forward "^#" end t)
(let ((s (buffer-substring-no-properties
- (point) (mh-line-end-position))))
+ (point) (line-end-position))))
(cond ((equal s ""))
((string-match "^forw[ \t\n]+" s)
(cl-return-from search-for-mh-directive t))
@@ -1799,8 +1767,7 @@ initialized. Always use the command `mh-have-file-command'.")
'file -i' is used to get MIME type of composition insertion."
(when (eq mh-have-file-command 'undefined)
(setq mh-have-file-command
- (and (fboundp 'executable-find)
- (executable-find "file") ; file command exists
+ (and (executable-find "file") ; file command exists
; and accepts -i and -b args.
(zerop (call-process "file" nil nil nil "-i" "-b"
(expand-file-name "inc" mh-progs))))))
@@ -1814,10 +1781,9 @@ initialized. Always use the command `mh-have-file-command'.")
(defun mh-mime-cleanup ()
"Free the decoded MIME parts."
(let ((mime-data (gethash (current-buffer) mh-globals-hash)))
- ;; This is for Emacs, what about XEmacs?
- (mh-funcall-if-exists remove-images (point-min) (point-max))
+ (remove-images (point-min) (point-max))
(when mime-data
- (mh-mm-destroy-parts (mh-mime-handles mime-data))
+ (mm-destroy-parts (mh-mime-handles mime-data))
(remhash (current-buffer) mh-globals-hash))))
;;;###mh-autoload
@@ -1825,7 +1791,7 @@ initialized. Always use the command `mh-have-file-command'.")
"Free MIME data for externally displayed MIME parts."
(let ((mime-data (mh-buffer-data)))
(when mime-data
- (mh-mm-destroy-parts (mh-mime-handles mime-data)))
+ (mm-destroy-parts (mh-mime-handles mime-data)))
(remhash (current-buffer) mh-globals-hash)))
(provide 'mh-mime)
diff --git a/lisp/mh-e/mh-scan.el b/lisp/mh-e/mh-scan.el
index 5aa599942e3..9ac251e8b71 100644
--- a/lisp/mh-e/mh-scan.el
+++ b/lisp/mh-e/mh-scan.el
@@ -315,7 +315,7 @@ produced by \"inc\".")
;;; Widths, Offsets and Columns
-(defvar mh-cmd-note 4
+(defvar-local mh-cmd-note 4
"Column for notations.
This variable should be set with the function `mh-set-cmd-note'.
@@ -323,12 +323,15 @@ This variable may be updated dynamically if
`mh-adaptive-cmd-note-flag' is on.
Note that columns in Emacs start with 0.")
-(make-variable-buffer-local 'mh-cmd-note)
(defvar mh-scan-cmd-note-width 1
"Number of columns consumed by the cmd-note field in `mh-scan-format'.
-This column will have one of the values: \" \", \"^\", \"D\", \"B\", \"A\", \"+\", where
+This column will have one of the values:
+
+ \" \", \"^\", \"D\", \"B\", \"A\", \"+\"
+
+where
\" \" is the default value,
\"^\" is the `mh-note-refiled' character,
@@ -510,7 +513,7 @@ with `mh-scan-msg-format-string'."
Note that columns in Emacs start with 0.
If `mh-scan-format-file' is set to \"Use MH-E scan Format\" this
-means that either `mh-scan-format-mh' or `mh-scan-format-nmh' are
+means that either `mh-scan-format-mh' or `mh-scan-format-nmh' is
in use. This function therefore assumes that the first column is
empty (to provide room for the cursor), the following WIDTH
columns contain the message number, and the column for notations
diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el
index e03c9dc83f7..8012e624f16 100644
--- a/lisp/mh-e/mh-search.el
+++ b/lisp/mh-e/mh-search.el
@@ -42,6 +42,7 @@
;;; Code:
(require 'mh-e)
+(require 'mh-letter)
(require 'gnus-util)
(require 'imenu)
@@ -318,10 +319,6 @@ folder containing the index search results."
(cl-loop for msg-hash being the hash-values of mh-index-data
count (> (hash-table-count msg-hash) 0)))))))
-;; Shush compiler.
-(mh-do-in-xemacs
- (defvar pick-folder)) ;FIXME: Why?
-
(defun mh-search-folder (folder window-config)
"Search FOLDER for messages matching a pattern.
@@ -336,8 +333,8 @@ configuration and is used when the search folder is dismissed."
(not (y-or-n-p "Reuse pattern? ")))
(mh-make-pick-template)
(message ""))
- (mh-make-local-vars 'mh-current-folder folder
- 'mh-previous-window-config window-config)
+ (setq-local mh-current-folder folder
+ mh-previous-window-config window-config)
(message "%s" (substitute-command-keys
(concat "Type \\[mh-index-do-search] to search messages, "
"\\[mh-pick-do-search] to use pick, "
@@ -356,13 +353,13 @@ configuration and is used when the search folder is dismissed."
(goto-char (point-min))
(dotimes (_ 5)
(add-text-properties (point) (1+ (point)) '(front-sticky t))
- (add-text-properties (- (mh-line-end-position) 2)
- (1- (mh-line-end-position))
+ (add-text-properties (- (line-end-position) 2)
+ (1- (line-end-position))
'(rear-nonsticky t))
- (add-text-properties (point) (1- (mh-line-end-position)) '(read-only t))
+ (add-text-properties (point) (1- (line-end-position)) '(read-only t))
(forward-line))
(add-text-properties (point) (1+ (point)) '(front-sticky t))
- (add-text-properties (point) (1- (mh-line-end-position)) '(read-only t))
+ (add-text-properties (point) (1- (line-end-position)) '(read-only t))
(goto-char (point-max)))
;; Sequence Searches
@@ -522,10 +519,10 @@ group of results."
(cond ((and (bolp) (eolp))
(ignore-errors (forward-line -1))
(setq msg (mh-get-msg-num t)))
- ((equal (char-after (mh-line-beginning-position)) ?+)
+ ((equal (char-after (line-beginning-position)) ?+)
(setq folder (buffer-substring-no-properties
- (mh-line-beginning-position)
- (mh-line-end-position))))
+ (line-beginning-position)
+ (line-end-position))))
(t (setq msg (mh-get-msg-num t)))))
(when (not folder)
(setq folder (car (gethash (gethash msg mh-index-msg-checksum-map)
@@ -552,20 +549,20 @@ group of results."
;;; MH-Search Keys
;; If this changes, modify mh-search-mode-help-messages accordingly, below.
-(gnus-define-keys mh-search-mode-map
- "\C-c?" mh-help
- "\C-c\C-c" mh-index-do-search
- "\C-c\C-p" mh-pick-do-search
- "\C-c\C-f\C-b" mh-to-field
- "\C-c\C-f\C-c" mh-to-field
- "\C-c\C-f\C-m" mh-to-field
- "\C-c\C-f\C-s" mh-to-field
- "\C-c\C-f\C-t" mh-to-field
- "\C-c\C-fb" mh-to-field
- "\C-c\C-fc" mh-to-field
- "\C-c\C-fm" mh-to-field
- "\C-c\C-fs" mh-to-field
- "\C-c\C-ft" mh-to-field)
+(define-keymap :keymap mh-search-mode-map
+ "C-c ?" #'mh-help
+ "C-c C-c" #'mh-index-do-search
+ "C-c C-p" #'mh-pick-do-search
+ "C-c C-f C-b" #'mh-to-field
+ "C-c C-f C-c" #'mh-to-field
+ "C-c C-f C-m" #'mh-to-field
+ "C-c C-f C-s" #'mh-to-field
+ "C-c C-f C-t" #'mh-to-field
+ "C-c C-f b" #'mh-to-field
+ "C-c C-f c" #'mh-to-field
+ "C-c C-f m" #'mh-to-field
+ "C-c C-f s" #'mh-to-field
+ "C-c C-f t" #'mh-to-field)
@@ -616,7 +613,6 @@ The hook `mh-search-mode-hook' is called upon entry to this mode.
\\{mh-search-mode-map}"
- (mh-do-in-xemacs (easy-menu-add mh-pick-menu))
(mh-set-help mh-search-mode-help-messages))
@@ -653,13 +649,13 @@ The cdr of the element is the pattern to search."
start begin)
(goto-char (point-min))
(while (not (eobp))
- (if (search-forward "--------" (mh-line-end-position) t)
+ (if (search-forward "--------" (line-end-position) t)
(setq in-body-flag t)
(beginning-of-line)
(setq begin (point))
(setq start (if in-body-flag
(point)
- (search-forward ":" (mh-line-end-position) t)
+ (search-forward ":" (line-end-position) t)
(point)))
(push (cons (and (not in-body-flag)
(intern (downcase
@@ -667,7 +663,7 @@ The cdr of the element is the pattern to search."
begin (1- start)))))
(mh-index-parse-search-regexp
(buffer-substring-no-properties
- start (mh-line-end-position))))
+ start (line-end-position))))
pattern-list))
(forward-line))
pattern-list)))
@@ -977,8 +973,8 @@ is used to search."
(cl-return nil))
(when (equal (char-after (point)) ?#)
(cl-return 'error))
- (let* ((start (search-forward " " (mh-line-end-position) t))
- (end (search-forward " " (mh-line-end-position) t)))
+ (let* ((start (search-forward " " (line-end-position) t))
+ (end (search-forward " " (line-end-position) t)))
(unless (and start end)
(cl-return 'error))
(setq end (1- end))
@@ -1056,7 +1052,7 @@ SEARCH-REGEXP-LIST is used to search."
(cl-return 'error))
(let ((start (point))
end msg-start)
- (setq end (mh-line-end-position))
+ (setq end (line-end-position))
(unless (search-forward mh-mairix-folder end t)
(cl-return 'error))
(goto-char (match-beginning 0))
@@ -1197,7 +1193,7 @@ is used to search."
(cl-block nil
(when (eobp) (cl-return nil))
(let ((file-name (buffer-substring-no-properties
- (point) (mh-line-end-position))))
+ (point) (line-end-position))))
(unless (equal (string-match mh-namazu-folder file-name) 0)
(cl-return 'error))
(unless (file-exists-p file-name)
@@ -1245,17 +1241,17 @@ is used to search."
(prog1
(cl-block nil
(when (eobp) (cl-return nil))
- (when (search-forward-regexp "^\\+" (mh-line-end-position) t)
+ (when (search-forward-regexp "^\\+" (line-end-position) t)
(setq mh-index-pick-folder
- (buffer-substring-no-properties (mh-line-beginning-position)
- (mh-line-end-position)))
+ (buffer-substring-no-properties (line-beginning-position)
+ (line-end-position)))
(cl-return 'error))
- (unless (search-forward-regexp "^[1-9][0-9]*$" (mh-line-end-position) t)
+ (unless (search-forward-regexp "^[1-9][0-9]*$" (line-end-position) t)
(cl-return 'error))
(list mh-index-pick-folder
(string-to-number
- (buffer-substring-no-properties (mh-line-beginning-position)
- (mh-line-end-position)))
+ (buffer-substring-no-properties (line-beginning-position)
+ (line-end-position)))
nil))
(forward-line)))
@@ -1332,8 +1328,8 @@ record is invalid return `error'."
(cl-block nil
(when (eobp)
(cl-return nil))
- (let ((eol-pos (mh-line-end-position))
- (bol-pos (mh-line-beginning-position))
+ (let ((eol-pos (line-end-position))
+ (bol-pos (line-beginning-position))
folder-start msg-end)
(goto-char bol-pos)
(unless (search-forward mh-user-path eol-pos t)
@@ -1415,10 +1411,7 @@ being the list of messages originally from that folder."
(when cur-msg (mh-goto-msg cur-msg t t))
(set-buffer-modified-p old-buffer-modified-flag)))
-(eval-and-compile (mh-require 'which-func nil t))
-
-;; Shush compiler.
-(defvar which-func-mode) ; < Emacs 22, XEmacs
+(eval-and-compile (require 'which-func nil t))
;;;###mh-autoload
(defun mh-index-create-imenu-index ()
@@ -1432,7 +1425,7 @@ being the list of messages originally from that folder."
(save-excursion
(beginning-of-line)
(push (cons (buffer-substring-no-properties
- (point) (mh-line-end-position))
+ (point) (line-end-position))
(point-marker))
alist)))
(setq imenu--index-alist (nreverse alist)))))
@@ -1717,7 +1710,7 @@ folder, is removed from `mh-index-data'."
"-format" "%{x-mhe-checksum}\n" folder msg)
(goto-char (point-min))
(string-equal (buffer-substring-no-properties
- (point) (mh-line-end-position))
+ (point) (line-end-position))
checksum)))
@@ -1826,8 +1819,8 @@ PROC is used to convert the value to actual data."
(defun mh-md5sum-parser ()
"Parse md5sum output."
- (let ((begin (mh-line-beginning-position))
- (end (mh-line-end-position))
+ (let ((begin (line-beginning-position))
+ (end (line-end-position))
first-space last-slash)
(setq first-space (search-forward " " end t))
(goto-char end)
@@ -1840,8 +1833,8 @@ PROC is used to convert the value to actual data."
(defun mh-openssl-parser ()
"Parse openssl output."
- (let ((begin (mh-line-beginning-position))
- (end (mh-line-end-position))
+ (let ((begin (line-beginning-position))
+ (end (line-end-position))
last-space last-slash)
(goto-char end)
(setq last-space (search-backward " " begin t))
@@ -1874,7 +1867,7 @@ origin-index) map is updated too."
(let (msg checksum)
(while (not (eobp))
(setq msg (buffer-substring-no-properties
- (point) (mh-line-end-position)))
+ (point) (line-end-position)))
(forward-line)
(save-excursion
(cond ((not (string-match "^[0-9]*$" msg)))
@@ -1885,7 +1878,7 @@ origin-index) map is updated too."
(t
;; update maps
(setq checksum (buffer-substring-no-properties
- (point) (mh-line-end-position)))
+ (point) (line-end-position)))
(let ((msg (string-to-number msg)))
(set-buffer folder)
(mh-index-update-single-msg msg checksum origin-map)))))
diff --git a/lisp/mh-e/mh-seq.el b/lisp/mh-e/mh-seq.el
index a50319a455d..077e289c01d 100644
--- a/lisp/mh-e/mh-seq.el
+++ b/lisp/mh-e/mh-seq.el
@@ -38,9 +38,8 @@
(defvar mh-last-seq-used nil
"Name of seq to which a msg was last added.")
-(defvar mh-non-seq-mode-line-annotation nil
+(defvar-local mh-non-seq-mode-line-annotation nil
"Saved value of `mh-mode-line-annotation' when narrowed to a seq.")
-(make-variable-buffer-local 'mh-non-seq-mode-line-annotation)
(defvar mh-internal-seqs '(answered cur deleted forwarded printed))
@@ -167,7 +166,7 @@ The list appears in a buffer named \"*MH-E Sequences*\"."
(insert "\n"))
(setq seq-list (cdr seq-list)))
(goto-char (point-min))
- (mh-view-mode-enter)
+ (view-mode-enter)
(setq view-exit-action 'kill-buffer)
(message "Listing sequences...done")))))
@@ -193,11 +192,6 @@ MESSAGE appears."
(mh-list-to-string (mh-seq-containing-msg message t))
" "))))
-;; Shush compiler.
-(mh-do-in-xemacs
- (defvar tool-bar-mode))
-(defvar tool-bar-map)
-
;;;###mh-autoload
(defun mh-narrow-to-seq (sequence)
"Restrict display to messages in SEQUENCE.
@@ -229,12 +223,12 @@ When you want to widen the view to all your messages again, use
(mh-make-folder-mode-line)
(mh-recenter nil)
(when (and (boundp 'tool-bar-mode) tool-bar-mode)
- (set (make-local-variable 'tool-bar-map)
- mh-folder-seq-tool-bar-map)
+ (setq-local tool-bar-map
+ mh-folder-seq-tool-bar-map)
(when (buffer-live-p (get-buffer mh-show-buffer))
(with-current-buffer mh-show-buffer
- (set (make-local-variable 'tool-bar-map)
- mh-show-seq-tool-bar-map))))
+ (setq-local tool-bar-map
+ mh-show-seq-tool-bar-map))))
(push 'widen mh-view-ops)))
(t
(error "No messages in sequence %s" (symbol-name sequence))))))
@@ -362,10 +356,10 @@ remove all limits and sequence restrictions."
(mh-notate-cur)
(mh-recenter nil)))
(when (and (null mh-folder-view-stack) (boundp 'tool-bar-mode) tool-bar-mode)
- (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)
+ (setq-local tool-bar-map mh-folder-tool-bar-map)
(when (buffer-live-p (get-buffer mh-show-buffer))
(with-current-buffer mh-show-buffer
- (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)))))
+ (setq-local tool-bar-map mh-show-tool-bar-map)))))
@@ -582,7 +576,7 @@ Otherwise, the message number at point is returned.
This function is usually used with `mh-iterate-on-range' in order to
provide a uniform interface to MH-E functions."
- (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end)))
+ (cond ((and transient-mark-mode mark-active) (cons (region-beginning) (region-end)))
(current-prefix-arg (mh-read-range range-prompt nil nil t t))
(default default)
(t (mh-get-msg-num t))))
@@ -736,7 +730,7 @@ completion is over."
(cl-multiple-value-bind (folder unseen total)
(cl-values-list
(mh-parse-flist-output-line
- (buffer-substring (point) (mh-line-end-position))))
+ (buffer-substring (point) (line-end-position))))
(list total unseen folder))))
(defun mh-folder-size-folder (folder)
@@ -764,7 +758,7 @@ folders whose names end with a `+' character."
(when (search-backward " out of " (point-min) t)
(setq total (string-to-number
(buffer-substring-no-properties
- (match-end 0) (mh-line-end-position))))
+ (match-end 0) (line-end-position))))
(when (search-backward " in sequence " (point-min) t)
(setq p (point))
(when (search-backward " has " (point-min) t)
@@ -786,10 +780,10 @@ If SAVE-REFILES is non-nil, then keep the sequences
that note messages to be refiled."
(let ((seqs ()))
(cond (save-refiles
- (mh-mapc (lambda (seq) ; Save the refiling sequences
- (if (mh-folder-name-p (mh-seq-name seq))
- (setq seqs (cons seq seqs))))
- mh-seq-list)))
+ (mapc (lambda (seq) ; Save the refiling sequences
+ (if (mh-folder-name-p (mh-seq-name seq))
+ (setq seqs (cons seq seqs))))
+ mh-seq-list)))
(save-excursion
(if (eq 0 (mh-exec-cmd-quiet nil "mark" folder "-list"))
(progn
@@ -942,7 +936,7 @@ font-lock is turned on."
;; the case of user sequences.
(mh-notate nil nil mh-cmd-note)
(when font-lock-mode
- (font-lock-fontify-region (point) (mh-line-end-position))))
+ (font-lock-fontify-region (point) (line-end-position))))
(forward-char (+ mh-cmd-note mh-scan-field-destination-offset))
(let ((stack (gethash msg mh-sequence-notation-history)))
(setf (gethash msg mh-sequence-notation-history)
diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el
index 803f07e02b2..16489bf0172 100644
--- a/lisp/mh-e/mh-show.el
+++ b/lisp/mh-e/mh-show.el
@@ -144,7 +144,7 @@ displayed."
(if (not clean-message-header)
(mh-start-of-uncleaned-message)))
(mh-display-msg msg folder)))
- (unless (mh-window-full-height-p) ; not vertically split
+ (unless (window-full-height-p) ; not vertically split
(shrink-window (- (window-height) (or mh-summary-height
(mh-summary-height)))))
(mh-recenter nil)
@@ -328,17 +328,15 @@ ignored if VISIBLE-HEADERS is non-nil."
(defun mh-summary-height ()
"Return ideal value for the variable `mh-summary-height'.
The current frame height is taken into consideration."
- (or (and (fboundp 'frame-height)
- (> (frame-height) 24)
+ (or (and (> (frame-height) 24)
(min 10 (/ (frame-height) 6)))
4))
-;; Infrastructure to generate show-buffer functions from folder functions
-;; XEmacs does not have deactivate-mark? What is the equivalent of
-;; transient-mark-mode for XEmacs? Should we be restoring the mark in the
-;; folder buffer after the operation has been carried out.
+;; Infrastructure to generate show-buffer functions from folder functions.
+;; Should we be restoring the mark in the folder buffer after the
+;; operation has been carried out?
(defmacro mh-defun-show-buffer (function original-function
&optional dont-return)
"Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer.
@@ -363,13 +361,14 @@ still visible.\n")
folder-buffer)
(delete-other-windows))
(mh-goto-cur-msg t)
- (mh-funcall-if-exists deactivate-mark)
+ (deactivate-mark)
(unwind-protect
(prog1 (call-interactively (function ,original-function))
(setq normal-exit t))
- (mh-funcall-if-exists deactivate-mark)
+ (deactivate-mark)
(when (eq major-mode 'mh-folder-mode)
- (mh-funcall-if-exists hl-line-highlight))
+ (when (fboundp 'hl-line-highlight)
+ (hl-line-highlight)))
(cond ((not normal-exit)
(set-window-configuration config))
,(if dont-return
@@ -464,8 +463,7 @@ still visible.\n")
(mh-defun-show-buffer mh-show-toggle-tick mh-toggle-tick)
(mh-defun-show-buffer mh-show-narrow-to-tick mh-narrow-to-tick)
(mh-defun-show-buffer mh-show-junk-allowlist mh-junk-allowlist)
-(mh-defun-show-buffer mh-show-junk-whitelist mh-junk-allowlist)
-(make-obsolete 'mh-show-junk-whitelist 'mh-show-junk-allowlist "28.1")
+(mh-defun-show-buffer mh-show-junk-whitelist mh-junk-whitelist)
(mh-defun-show-buffer mh-show-junk-blocklist mh-junk-blocklist)
(mh-defun-show-buffer mh-show-index-new-messages mh-index-new-messages)
(mh-defun-show-buffer mh-show-index-ticked-messages mh-index-ticked-messages)
@@ -562,132 +560,132 @@ still visible.\n")
;;; MH-Show Keys
-(gnus-define-keys mh-show-mode-map
- " " mh-show-page-msg
- "!" mh-show-refile-or-write-again
- "'" mh-show-toggle-tick
- "," mh-show-header-display
- "." mh-show-show
- ":" mh-show-show-preferred-alternative
- ">" mh-show-write-message-to-file
- "?" mh-help
- "E" mh-show-extract-rejected-mail
- "M" mh-show-modify
- "\177" mh-show-previous-page
- "\C-d" mh-show-delete-msg-no-motion
- "\t" mh-show-next-button
- [backtab] mh-show-prev-button
- "\M-\t" mh-show-prev-button
- "\ed" mh-show-redistribute
- "^" mh-show-refile-msg
- "c" mh-show-copy-msg
- "d" mh-show-delete-msg
- "e" mh-show-edit-again
- "f" mh-show-forward
- "g" mh-show-goto-msg
- "i" mh-show-inc-folder
- "k" mh-show-delete-subject-or-thread
- "m" mh-show-send
- "n" mh-show-next-undeleted-msg
- "\M-n" mh-show-next-unread-msg
- "o" mh-show-refile-msg
- "p" mh-show-previous-undeleted-msg
- "\M-p" mh-show-previous-unread-msg
- "q" mh-show-quit
- "r" mh-show-reply
- "s" mh-show-send
- "t" mh-show-toggle-showing
- "u" mh-show-undo
- "x" mh-show-execute-commands
- "v" mh-show-index-visit-folder
- "|" mh-show-pipe-msg)
-
-(gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map)
- "?" mh-prefix-help
- "'" mh-index-ticked-messages
- "S" mh-show-sort-folder
- "c" mh-show-catchup
- "f" mh-show-visit-folder
- "k" mh-show-kill-folder
- "l" mh-show-list-folders
- "n" mh-index-new-messages
- "o" mh-show-visit-folder
- "p" mh-show-pack-folder
- "q" mh-show-index-sequenced-messages
- "r" mh-show-rescan-folder
- "s" mh-search
- "t" mh-show-toggle-threads
- "u" mh-show-undo-folder
- "v" mh-show-visit-folder)
-
-(gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map)
- "'" mh-show-narrow-to-tick
- "?" mh-prefix-help
- "d" mh-show-delete-msg-from-seq
- "k" mh-show-delete-seq
- "l" mh-show-list-sequences
- "n" mh-show-narrow-to-seq
- "p" mh-show-put-msg-in-seq
- "s" mh-show-msg-is-in-seq
- "w" mh-show-widen)
-
-(define-key mh-show-mode-map "I" mh-inc-spool-map)
-
-(gnus-define-keys (mh-show-junk-map "J" mh-show-mode-map)
- "?" mh-prefix-help
- "a" mh-show-junk-allowlist
- "b" mh-show-junk-blocklist
- "w" mh-show-junk-whitelist)
-
-(gnus-define-keys (mh-show-ps-print-map "P" mh-show-mode-map)
- "?" mh-prefix-help
- "C" mh-show-ps-print-toggle-color
- "F" mh-show-ps-print-toggle-faces
- "f" mh-show-ps-print-msg-file
- "l" mh-show-print-msg
- "p" mh-show-ps-print-msg)
-
-(gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map)
- "?" mh-prefix-help
- "u" mh-show-thread-ancestor
- "p" mh-show-thread-previous-sibling
- "n" mh-show-thread-next-sibling
- "t" mh-show-toggle-threads
- "d" mh-show-thread-delete
- "o" mh-show-thread-refile)
-
-(gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map)
- "'" mh-show-narrow-to-tick
- "?" mh-prefix-help
- "c" mh-show-narrow-to-cc
- "g" mh-show-narrow-to-range
- "m" mh-show-narrow-to-from
- "s" mh-show-narrow-to-subject
- "t" mh-show-narrow-to-to
- "w" mh-show-widen)
-
-(gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map)
- "?" mh-prefix-help
- "s" mh-show-store-msg
- "u" mh-show-store-msg)
-
-(gnus-define-keys (mh-show-digest-map "D" mh-show-mode-map)
- "?" mh-prefix-help
- " " mh-show-page-digest
- "\177" mh-show-page-digest-backwards
- "b" mh-show-burst-digest)
-
-(gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map)
- "?" mh-prefix-help
- "a" mh-mime-save-parts
- "e" mh-show-display-with-external-viewer
- "v" mh-show-toggle-mime-part
- "o" mh-show-save-mime-part
- "i" mh-show-inline-mime-part
- "t" mh-show-toggle-mime-buttons
- "\t" mh-show-next-button
- [backtab] mh-show-prev-button
- "\M-\t" mh-show-prev-button)
+(define-keymap :keymap mh-show-mode-map
+ "SPC" #'mh-show-page-msg
+ "!" #'mh-show-refile-or-write-again
+ "'" #'mh-show-toggle-tick
+ "," #'mh-show-header-display
+ "." #'mh-show-show
+ ":" #'mh-show-show-preferred-alternative
+ ">" #'mh-show-write-message-to-file
+ "?" #'mh-help
+ "E" #'mh-show-extract-rejected-mail
+ "M" #'mh-show-modify
+ "DEL" #'mh-show-previous-page
+ "C-d" #'mh-show-delete-msg-no-motion
+ "TAB" #'mh-show-next-button
+ "<backtab>" #'mh-show-prev-button
+ "C-M-i" #'mh-show-prev-button
+ "ESC d" #'mh-show-redistribute
+ "^" #'mh-show-refile-msg
+ "c" #'mh-show-copy-msg
+ "d" #'mh-show-delete-msg
+ "e" #'mh-show-edit-again
+ "f" #'mh-show-forward
+ "g" #'mh-show-goto-msg
+ "i" #'mh-show-inc-folder
+ "k" #'mh-show-delete-subject-or-thread
+ "m" #'mh-show-send
+ "n" #'mh-show-next-undeleted-msg
+ "M-n" #'mh-show-next-unread-msg
+ "o" #'mh-show-refile-msg
+ "p" #'mh-show-previous-undeleted-msg
+ "M-p" #'mh-show-previous-unread-msg
+ "q" #'mh-show-quit
+ "r" #'mh-show-reply
+ "s" #'mh-show-send
+ "t" #'mh-show-toggle-showing
+ "u" #'mh-show-undo
+ "x" #'mh-show-execute-commands
+ "v" #'mh-show-index-visit-folder
+ "|" #'mh-show-pipe-msg
+
+ "F" (define-keymap :prefix 'mh-show-folder-map
+ "?" #'mh-prefix-help
+ "'" #'mh-index-ticked-messages
+ "S" #'mh-show-sort-folder
+ "c" #'mh-show-catchup
+ "f" #'mh-show-visit-folder
+ "k" #'mh-show-kill-folder
+ "l" #'mh-show-list-folders
+ "n" #'mh-index-new-messages
+ "o" #'mh-show-visit-folder
+ "p" #'mh-show-pack-folder
+ "q" #'mh-show-index-sequenced-messages
+ "r" #'mh-show-rescan-folder
+ "s" #'mh-search
+ "t" #'mh-show-toggle-threads
+ "u" #'mh-show-undo-folder
+ "v" #'mh-show-visit-folder)
+
+ "S" (define-keymap :prefix 'mh-show-sequence-map
+ "'" #'mh-show-narrow-to-tick
+ "?" #'mh-prefix-help
+ "d" #'mh-show-delete-msg-from-seq
+ "k" #'mh-show-delete-seq
+ "l" #'mh-show-list-sequences
+ "n" #'mh-show-narrow-to-seq
+ "p" #'mh-show-put-msg-in-seq
+ "s" #'mh-show-msg-is-in-seq
+ "w" #'mh-show-widen)
+
+ "I" mh-inc-spool-map
+
+ "J" (define-keymap :prefix 'mh-show-junk-map
+ "?" #'mh-prefix-help
+ "a" #'mh-show-junk-allowlist
+ "b" #'mh-show-junk-blocklist
+ "w" #'mh-show-junk-whitelist)
+
+ "P" (define-keymap :prefix 'mh-show-ps-print-map
+ "?" #'mh-prefix-help
+ "C" #'mh-show-ps-print-toggle-color
+ "F" #'mh-show-ps-print-toggle-faces
+ "f" #'mh-show-ps-print-msg-file
+ "l" #'mh-show-print-msg
+ "p" #'mh-show-ps-print-msg)
+
+ "T" (define-keymap :prefix 'mh-show-thread-map
+ "?" #'mh-prefix-help
+ "u" #'mh-show-thread-ancestor
+ "p" #'mh-show-thread-previous-sibling
+ "n" #'mh-show-thread-next-sibling
+ "t" #'mh-show-toggle-threads
+ "d" #'mh-show-thread-delete
+ "o" #'mh-show-thread-refile)
+
+ "/" (define-keymap :prefix 'mh-show-limit-map
+ "'" #'mh-show-narrow-to-tick
+ "?" #'mh-prefix-help
+ "c" #'mh-show-narrow-to-cc
+ "g" #'mh-show-narrow-to-range
+ "m" #'mh-show-narrow-to-from
+ "s" #'mh-show-narrow-to-subject
+ "t" #'mh-show-narrow-to-to
+ "w" #'mh-show-widen)
+
+ "X" (define-keymap :prefix 'mh-show-extract-map
+ "?" #'mh-prefix-help
+ "s" #'mh-show-store-msg
+ "u" #'mh-show-store-msg)
+
+ "D" (define-keymap :prefix 'mh-show-digest-map
+ "?" #'mh-prefix-help
+ "SPC" #'mh-show-page-digest
+ "DEL" #'mh-show-page-digest-backwards
+ "b" #'mh-show-burst-digest)
+
+ "K" (define-keymap :prefix 'mh-show-mime-map
+ "?" #'mh-prefix-help
+ "a" #'mh-mime-save-parts
+ "e" #'mh-show-display-with-external-viewer
+ "v" #'mh-show-toggle-mime-part
+ "o" #'mh-show-save-mime-part
+ "i" #'mh-show-inline-mime-part
+ "t" #'mh-show-toggle-mime-buttons
+ "TAB" #'mh-show-next-button
+ "<backtab>" #'mh-show-prev-button
+ "C-M-i" #'mh-show-prev-button))
@@ -817,9 +815,6 @@ operation."
;; Ensure new buffers won't get this mode if default major-mode is nil.
(put 'mh-show-mode 'mode-class 'special)
-;; Shush compiler.
-(defvar font-lock-auto-fontify)
-
;;;###mh-autoload
(define-derived-mode mh-show-mode text-mode "MH-Show"
"Major mode for showing messages in MH-E.\\<mh-show-mode-map>
@@ -836,17 +831,14 @@ The hook `mh-show-mode-hook' is called upon entry to this mode.
See also `mh-folder-mode'.
\\{mh-show-mode-map}"
- (mh-do-in-gnu-emacs
- (if (boundp 'tool-bar-map)
- (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)))
- (mh-do-in-xemacs
- (mh-tool-bar-init :show))
- (set (make-local-variable 'mail-header-separator) mh-mail-header-separator)
+ (if (boundp 'tool-bar-map)
+ (setq-local tool-bar-map mh-show-tool-bar-map))
+ (setq-local mail-header-separator mh-mail-header-separator)
(setq paragraph-start (default-value 'paragraph-start))
(setq buffer-invisibility-spec '((vanish . t) t))
- (set (make-local-variable 'line-move-ignore-invisible) t)
+ (setq-local line-move-ignore-invisible t)
(make-local-variable 'font-lock-defaults)
- ;;(set (make-local-variable 'font-lock-support-mode) nil)
+ ;;(setq-local font-lock-support-mode nil)
(cond
((equal mh-highlight-citation-style 'font-lock)
(setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t)))
@@ -858,16 +850,8 @@ See also `mh-folder-mode'.
(mh-gnus-article-highlight-citation))
(t
(setq font-lock-defaults '(mh-show-font-lock-keywords t))))
- (if (and (featurep 'xemacs)
- font-lock-auto-fontify)
- (turn-on-font-lock))
(when mh-decode-mime-flag
- (mh-make-local-hook 'kill-buffer-hook)
(add-hook 'kill-buffer-hook #'mh-mime-cleanup nil t))
- (mh-do-in-xemacs
- (easy-menu-add mh-show-sequence-menu)
- (easy-menu-add mh-show-message-menu)
- (easy-menu-add mh-show-folder-menu))
(make-local-variable 'mh-show-folder-buffer)
(buffer-disable-undo)
(use-local-map mh-show-mode-map))
diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el
index 76ef990d825..d9909a034d9 100644
--- a/lisp/mh-e/mh-speed.el
+++ b/lisp/mh-e/mh-speed.el
@@ -63,13 +63,13 @@
'("--"
["Visit Folder" mh-speed-view
(with-current-buffer speedbar-buffer
- (get-text-property (mh-line-beginning-position) 'mh-folder))]
+ (get-text-property (line-beginning-position) 'mh-folder))]
["Expand Nested Folders" mh-speed-expand-folder
- (and (get-text-property (mh-line-beginning-position) 'mh-children-p)
- (not (get-text-property (mh-line-beginning-position) 'mh-expanded)))]
+ (and (get-text-property (line-beginning-position) 'mh-children-p)
+ (not (get-text-property (line-beginning-position) 'mh-expanded)))]
["Contract Nested Folders" mh-speed-contract-folder
- (and (get-text-property (mh-line-beginning-position) 'mh-children-p)
- (get-text-property (mh-line-beginning-position) 'mh-expanded))]
+ (and (get-text-property (line-beginning-position) 'mh-children-p)
+ (get-text-property (line-beginning-position) 'mh-expanded))]
["Refresh Speedbar" mh-speed-refresh t])
"Extra menu items for speedbar.")
@@ -83,11 +83,11 @@
(defvar mh-folder-speedbar-key-map (speedbar-make-specialized-keymap)
"Specialized speedbar keymap for MH-E buffers.")
-(gnus-define-keys mh-folder-speedbar-key-map
- "+" mh-speed-expand-folder
- "-" mh-speed-contract-folder
- "\r" mh-speed-view
- "r" mh-speed-refresh)
+(define-keymap :keymap mh-folder-speedbar-key-map
+ "+" #'mh-speed-expand-folder
+ "-" #'mh-speed-contract-folder
+ "RET" #'mh-speed-view
+ "r" #'mh-speed-refresh)
(defvar mh-show-speedbar-key-map mh-folder-speedbar-key-map)
(defvar mh-letter-speedbar-key-map mh-folder-speedbar-key-map)
@@ -150,7 +150,7 @@ The optional arguments from speedbar are IGNORED."
(forward-line -1)
(speedbar-change-expand-button-char ?+)
(add-text-properties
- (mh-line-beginning-position) (1+ (line-beginning-position))
+ (line-beginning-position) (1+ (line-beginning-position))
'(mh-expanded nil)))
(t
(forward-line)
@@ -158,14 +158,14 @@ The optional arguments from speedbar are IGNORED."
(goto-char point)
(speedbar-change-expand-button-char ?-)
(add-text-properties
- (mh-line-beginning-position) (1+ (line-beginning-position))
+ (line-beginning-position) (1+ (line-beginning-position))
'(mh-expanded t)))))))
(defun mh-speed-view (&rest _ignored)
"Visits the selected folder just as if you had used \\<mh-folder-mode-map>\\[mh-visit-folder].
The optional arguments from speedbar are IGNORED."
(interactive)
- (let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder))
+ (let* ((folder (get-text-property (line-beginning-position) 'mh-folder))
(range (and (stringp folder)
(mh-read-range "Scan" folder t nil nil
mh-interpret-number-as-range-flag))))
@@ -191,9 +191,9 @@ created."
(forward-line -1)
(setf (gethash nil mh-speed-folder-map)
(set-marker (or (gethash nil mh-speed-folder-map) (make-marker))
- (1+ (mh-line-beginning-position))))
+ (1+ (line-beginning-position))))
(add-text-properties
- (mh-line-beginning-position) (1+ (line-beginning-position))
+ (line-beginning-position) (1+ (line-beginning-position))
'(mh-folder nil mh-expanded nil mh-children-p t mh-level 0))
(mh-speed-stealth-update t)
(when (> mh-speed-update-interval 0)
@@ -260,12 +260,12 @@ The update is always carried out if FORCE is non-nil."
(speedbar-with-writable
(goto-char (gethash folder mh-speed-folder-map (point)))
(beginning-of-line)
- (if (re-search-forward "([1-9][0-9]*/[0-9]+)" (mh-line-end-position) t)
+ (if (re-search-forward "([1-9][0-9]*/[0-9]+)" (line-end-position) t)
(setq face (mh-speed-bold-face face))
(setq face (mh-speed-normal-face face)))
(beginning-of-line)
- (when (re-search-forward "\\[.\\] " (mh-line-end-position) t)
- (put-text-property (point) (mh-line-end-position) 'face face)))))
+ (when (re-search-forward "\\[.\\] " (line-end-position) t)
+ (put-text-property (point) (line-end-position) 'face face)))))
(defun mh-speed-normal-face (face)
"Return normal face for given FACE."
@@ -305,7 +305,7 @@ The function will expand out parent folders of FOLDER if needed."
(while suffix-list
;; We always need at least one toggle. We need two if the directory list
;; is stale since a folder was added.
- (when (equal prefix (get-text-property (mh-line-beginning-position)
+ (when (equal prefix (get-text-property (line-beginning-position)
'mh-folder))
(mh-speed-toggle)
(unless (get-text-property (point) 'mh-expanded)
@@ -359,9 +359,9 @@ uses."
(setf (gethash folder-name mh-speed-folder-map)
(set-marker (or (gethash folder-name mh-speed-folder-map)
(make-marker))
- (1+ (mh-line-beginning-position))))
+ (1+ (line-beginning-position))))
(add-text-properties
- (mh-line-beginning-position) (1+ (mh-line-beginning-position))
+ (line-beginning-position) (1+ (line-beginning-position))
`(mh-folder ,folder-name
mh-expanded nil
mh-children-p ,(not (not (cdr f)))
@@ -374,12 +374,9 @@ uses."
(defvar mh-speed-flists-folder nil)
(defmacro mh-process-kill-without-query (process)
- "PROCESS can be killed without query on Emacs exit.
-Avoid using `process-kill-without-query' if possible since it is
-now obsolete."
- (if (fboundp 'set-process-query-on-exit-flag)
- `(set-process-query-on-exit-flag ,process nil)
- `(process-kill-without-query ,process)))
+ "PROCESS can be killed without query on Emacs exit."
+ (declare (obsolete set-process-query-on-exit-flag "29.1"))
+ `(set-process-query-on-exit-flag ,process nil))
;;;###mh-autoload
(defun mh-speed-flists (force &rest folders)
@@ -391,7 +388,7 @@ flists is run only for that one folder."
(interactive (list t))
(when force
(when mh-speed-flists-timer
- (mh-cancel-timer mh-speed-flists-timer)
+ (cancel-timer mh-speed-flists-timer)
(setq mh-speed-flists-timer nil))
(when (and (processp mh-speed-flists-process)
(not (eq (process-status mh-speed-flists-process) 'exit)))
@@ -427,7 +424,7 @@ flists is run only for that one folder."
(or mh-speed-flists-folder '("-recurse"))))
;; Run flists on all folders the next time around...
(setq mh-speed-flists-folder nil)
- (mh-process-kill-without-query mh-speed-flists-process)
+ (set-process-query-on-exit-flag mh-speed-flists-process nil)
(set-process-filter mh-speed-flists-process
#'mh-speed-parse-flists-output)))))))
@@ -462,25 +459,25 @@ be handled next."
face)
(when pos
(goto-char pos)
- (goto-char (mh-line-beginning-position))
+ (goto-char (line-beginning-position))
(cond
((null (get-text-property (point) 'mh-count))
- (goto-char (mh-line-end-position))
+ (goto-char (line-end-position))
(setq face (get-text-property (1- (point)) 'face))
(insert (format " (%s/%s)" unseen total))
(mh-speed-highlight 'unknown face)
- (goto-char (mh-line-beginning-position))
+ (goto-char (line-beginning-position))
(add-text-properties (point) (1+ (point))
`(mh-count (,unseen . ,total))))
((not (equal (get-text-property (point) 'mh-count)
(cons unseen total)))
- (goto-char (mh-line-end-position))
+ (goto-char (line-end-position))
(setq face (get-text-property (1- (point)) 'face))
- (re-search-backward " " (mh-line-beginning-position) t)
- (delete-region (point) (mh-line-end-position))
+ (re-search-backward " " (line-beginning-position) t)
+ (delete-region (point) (line-end-position))
(insert (format " (%s/%s)" unseen total))
(mh-speed-highlight 'unknown face)
- (goto-char (mh-line-beginning-position))
+ (goto-char (line-beginning-position))
(add-text-properties
(point) (1+ (point))
`(mh-count (,unseen . ,total))))))))))))
@@ -509,15 +506,15 @@ be handled next."
(caar parent-kids)))
(setq parent-change ? ))))
(goto-char parent-position)
- (when (equal (get-text-property (mh-line-beginning-position) 'mh-folder)
+ (when (equal (get-text-property (line-beginning-position) 'mh-folder)
parent)
- (when (get-text-property (mh-line-beginning-position) 'mh-expanded)
+ (when (get-text-property (line-beginning-position) 'mh-expanded)
(mh-speed-toggle))
(when parent-change
(speedbar-with-writable
(mh-speedbar-change-expand-button-char parent-change)
(add-text-properties
- (mh-line-beginning-position) (1+ (mh-line-beginning-position))
+ (line-beginning-position) (1+ (line-beginning-position))
`(mh-children-p ,(equal parent-change ?+)))))
(mh-speed-highlight mh-speed-last-selected-folder 'mh-speedbar-folder)
(setq mh-speed-last-selected-folder nil)
@@ -531,15 +528,15 @@ be handled next."
"Change the expansion button character to CHAR for the current line."
(save-excursion
(beginning-of-line)
- (if (re-search-forward "\\[.\\]" (mh-line-end-position) t)
+ (if (re-search-forward "\\[.\\]" (line-end-position) t)
(speedbar-with-writable
(backward-char 2)
(delete-char 1)
(insert-char char 1 t)
(put-text-property (point) (1- (point)) 'invisible nil)
;; make sure we fix the image on the text here.
- (mh-funcall-if-exists
- speedbar-insert-image-button-maybe (- (point) 2) 3)))))
+ (when (fboundp 'speedbar-insert-image-button-maybe)
+ (speedbar-insert-image-button-maybe (- (point) 2) 3))))))
;;;###mh-autoload
(defun mh-speed-add-folder (folder)
@@ -562,9 +559,9 @@ The function invalidates the latest ancestor that is present."
(speedbar-with-writable
(mh-speedbar-change-expand-button-char ?+)
(add-text-properties
- (mh-line-beginning-position) (1+ (mh-line-beginning-position))
+ (line-beginning-position) (1+ (line-beginning-position))
'(mh-children-p t)))
- (when (get-text-property (mh-line-beginning-position) 'mh-expanded)
+ (when (get-text-property (line-beginning-position) 'mh-expanded)
(mh-speed-toggle))
(setq mh-speed-refresh-flag t))))
diff --git a/lisp/mh-e/mh-thread.el b/lisp/mh-e/mh-thread.el
index 89b0dbd9798..1be2185ecdf 100644
--- a/lisp/mh-e/mh-thread.el
+++ b/lisp/mh-e/mh-thread.el
@@ -86,41 +86,33 @@
message parent children
(real-child-p t))
-(defvar mh-thread-id-hash nil
+(defvar-local mh-thread-id-hash nil
"Hash table used to canonicalize message identifiers.")
-(make-variable-buffer-local 'mh-thread-id-hash)
-(defvar mh-thread-subject-hash nil
+(defvar-local mh-thread-subject-hash nil
"Hash table used to canonicalize subject strings.")
-(make-variable-buffer-local 'mh-thread-subject-hash)
-(defvar mh-thread-id-table nil
+(defvar-local mh-thread-id-table nil
"Thread ID table maps from message identifiers to message containers.")
-(make-variable-buffer-local 'mh-thread-id-table)
-(defvar mh-thread-index-id-map nil
+(defvar-local mh-thread-index-id-map nil
"Table to look up message identifier from message index.")
-(make-variable-buffer-local 'mh-thread-index-id-map)
-(defvar mh-thread-id-index-map nil
+(defvar-local mh-thread-id-index-map nil
"Table to look up message index number from message identifier.")
-(make-variable-buffer-local 'mh-thread-id-index-map)
-(defvar mh-thread-subject-container-hash nil
+(defvar-local mh-thread-subject-container-hash nil
"Hash table used to group messages by subject.")
-(make-variable-buffer-local 'mh-thread-subject-container-hash)
-(defvar mh-thread-duplicates nil
+(defvar-local mh-thread-duplicates nil
"Hash table used to associate messages with the same message identifier.")
-(make-variable-buffer-local 'mh-thread-duplicates)
-(defvar mh-thread-history ()
+(defvar-local mh-thread-history ()
"Variable to remember the transformations to the thread tree.
When new messages are added, these transformations are rewound,
then the links are added from the newly seen messages. Finally
the transformations are redone to get the new thread tree. This
makes incremental threading easier.")
-(make-variable-buffer-local 'mh-thread-history)
(defvar mh-thread-body-width nil
"Width of scan substring that contains subject and body of message.")
@@ -147,7 +139,7 @@ to the message that started everything."
(cond (thread-root-flag
(while (mh-thread-immediate-ancestor))
(mh-maybe-show))
- ((equal current-level 1)
+ ((equal current-level 0)
(message "Message has no ancestor"))
(t (mh-thread-immediate-ancestor)
(mh-maybe-show)))))
@@ -250,8 +242,8 @@ sibling."
(defun mh-thread-current-indentation-level ()
"Find the number of spaces by which current message is indented."
(save-excursion
- (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width
- mh-scan-date-width 1))
+ (let ((address-start-offset (+ mh-cmd-note
+ mh-scan-field-from-start-offset))
(level 0))
(beginning-of-line)
(forward-char address-start-offset)
@@ -283,8 +275,8 @@ at the end."
(beginning-of-line)
(if (eobp)
nil
- (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width
- mh-scan-date-width 1))
+ (let ((address-start-offset (+ mh-cmd-note
+ mh-scan-field-from-start-offset))
(level (mh-thread-current-indentation-level))
spaces begin)
(setq begin (point))
@@ -294,7 +286,7 @@ at the end."
(while (not (eobp))
(forward-char address-start-offset)
(unless (equal (string-match spaces (buffer-substring-no-properties
- (point) (mh-line-end-position)))
+ (point) (line-end-position)))
0)
(beginning-of-line)
(backward-char)
@@ -455,8 +447,8 @@ If optional argument STRING is given then that is assumed to be
the scan line. Otherwise uses the line at point as the scan line
to parse."
(let* ((string (or string (buffer-substring-no-properties
- (mh-line-beginning-position)
- (mh-line-end-position))))
+ (line-beginning-position)
+ (line-end-position))))
(address-start (+ mh-cmd-note mh-scan-field-from-start-offset))
(body-start (+ mh-cmd-note mh-scan-field-from-end-offset))
(first-string (substring string 0 address-start)))
@@ -597,20 +589,20 @@ Only information about messages in MSG-LIST are added to the tree."
(while (not (eobp))
(cl-block process-message
(let* ((index-line
- (prog1 (buffer-substring (point) (mh-line-end-position))
+ (prog1 (buffer-substring (point) (line-end-position))
(forward-line)))
(index (string-to-number index-line))
- (id (prog1 (buffer-substring (point) (mh-line-end-position))
+ (id (prog1 (buffer-substring (point) (line-end-position))
(forward-line)))
(refs (prog1
- (buffer-substring (point) (mh-line-end-position))
+ (buffer-substring (point) (line-end-position))
(forward-line)))
(in-reply-to (prog1 (buffer-substring (point)
- (mh-line-end-position))
+ (line-end-position))
(forward-line)))
(subject (prog1
(buffer-substring
- (point) (mh-line-end-position))
+ (point) (line-end-position))
(forward-line)))
(subject-re-p nil))
(unless (gethash index mh-thread-scan-line-map)
diff --git a/lisp/mh-e/mh-tool-bar.el b/lisp/mh-e/mh-tool-bar.el
index 94aa8dd4a92..d451ae34d29 100644
--- a/lisp/mh-e/mh-tool-bar.el
+++ b/lisp/mh-e/mh-tool-bar.el
@@ -27,10 +27,8 @@
;;; Code:
(require 'mh-e)
-(mh-do-in-gnu-emacs
- (require 'tool-bar))
-(mh-do-in-xemacs
- (require 'toolbar))
+(require 'mh-acros)
+(require 'tool-bar)
;;; Tool Bar Commands
@@ -79,9 +77,6 @@ When INCLUDE-FLAG is non-nil, include message body being replied to."
;;; Tool Bar Creation
-;; Shush compiler.
-(defvar image-load-path)
-
(defmacro mh-tool-bar-define (defaults &rest buttons)
"Define a tool bar for MH-E.
DEFAULTS is the list of buttons that are present by default. It
@@ -145,8 +140,6 @@ where,
(let* ((name (nth 0 button))
(name-str (symbol-name name))
(icon (nth 2 button))
- (xemacs-icon (mh-do-in-xemacs
- `(cdr (assoc (quote ,(intern icon)) mh-xemacs-icon-map))))
(full-doc (nth 3 button))
(doc (if (string-match "\\(.*\\)\n" full-doc)
(match-string 1 full-doc)
@@ -186,11 +179,10 @@ where,
(t 'folder-buttons)))
(docs (cond ((eq mbuttons 'letter-buttons) 'letter-docs)
((eq mbuttons 'folder-buttons) 'folder-docs))))
- (add-to-list vector-list `(vector ,xemacs-icon ',function t ,full-doc))
+ (add-to-list vector-list `(vector nil ',function t ,full-doc))
(add-to-list
setter `(when (member ',name ,list)
- (mh-funcall-if-exists
- tool-bar-add-item ,icon ',function ',key
+ (tool-bar-add-item ,icon ',function ',key
:help ,doc :enable ',enable-expr)))
(add-to-list mbuttons name)
(if docs (add-to-list docs doc))))))
@@ -209,145 +201,69 @@ where,
(unless (memq x letter-buttons)
(error "Letter defaults contains unknown button %s" x)))
`(eval-and-compile
- ;; GNU Emacs tool bar specific code
- (mh-do-in-gnu-emacs
- (defun mh-buffer-exists-p (mode)
- "Test whether a buffer with major mode MODE is present."
- (cl-loop for buf in (buffer-list)
- when (with-current-buffer buf
- (eq major-mode mode))
- return t))
- ;; Tool bar initialization functions
- (defun mh-tool-bar-folder-buttons-init ()
- (when (mh-buffer-exists-p 'mh-folder-mode)
- (let* ((load-path (mh-image-load-path-for-library "mh-e"
- "mh-logo.xpm"))
- (image-load-path (cons (car load-path)
- (when (boundp 'image-load-path)
- image-load-path))))
- (setq mh-folder-tool-bar-map
- (let ((tool-bar-map (make-sparse-keymap)))
- ,@(nreverse folder-button-setter)
- tool-bar-map))
- (setq mh-folder-seq-tool-bar-map
- (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map)))
- ,@(nreverse sequence-button-setter)
- tool-bar-map))
- (setq mh-show-tool-bar-map
- (let ((tool-bar-map (make-sparse-keymap)))
- ,@(nreverse show-button-setter)
- tool-bar-map))
- (setq mh-show-seq-tool-bar-map
- (let ((tool-bar-map (copy-keymap mh-show-tool-bar-map)))
- ,@(nreverse show-seq-button-setter)
- tool-bar-map)))))
- (defun mh-tool-bar-letter-buttons-init ()
- (when (mh-buffer-exists-p 'mh-letter-mode)
- (let* ((load-path (mh-image-load-path-for-library "mh-e"
- "mh-logo.xpm"))
- (image-load-path (cons (car load-path)
- (when (boundp 'image-load-path)
- image-load-path))))
- (setq mh-letter-tool-bar-map
- (let ((tool-bar-map (make-sparse-keymap)))
- ,@(nreverse letter-button-setter)
- tool-bar-map)))))
- ;; Custom setter functions
- (defun mh-tool-bar-update (mode default-map sequence-map)
- "Update `tool-bar-map' in all buffers of MODE.
+ (defun mh-buffer-exists-p (mode)
+ "Test whether a buffer with major mode MODE is present."
+ (cl-loop for buf in (buffer-list)
+ when (with-current-buffer buf
+ (eq major-mode mode))
+ return t))
+ ;; Tool bar initialization functions
+ (defun mh-tool-bar-folder-buttons-init ()
+ (when (mh-buffer-exists-p 'mh-folder-mode)
+ (mh--with-image-load-path
+ (setq mh-folder-tool-bar-map
+ (let ((tool-bar-map (make-sparse-keymap)))
+ ,@(nreverse folder-button-setter)
+ tool-bar-map))
+ (setq mh-folder-seq-tool-bar-map
+ (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map)))
+ ,@(nreverse sequence-button-setter)
+ tool-bar-map))
+ (setq mh-show-tool-bar-map
+ (let ((tool-bar-map (make-sparse-keymap)))
+ ,@(nreverse show-button-setter)
+ tool-bar-map))
+ (setq mh-show-seq-tool-bar-map
+ (let ((tool-bar-map (copy-keymap mh-show-tool-bar-map)))
+ ,@(nreverse show-seq-button-setter)
+ tool-bar-map)))))
+ (defun mh-tool-bar-letter-buttons-init ()
+ (when (mh-buffer-exists-p 'mh-letter-mode)
+ (mh--with-image-load-path
+ (setq mh-letter-tool-bar-map
+ (let ((tool-bar-map (make-sparse-keymap)))
+ ,@(nreverse letter-button-setter)
+ tool-bar-map)))))
+ ;; Custom setter functions
+ (defun mh-tool-bar-update (mode default-map sequence-map)
+ "Update `tool-bar-map' in all buffers of MODE.
Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise."
- (cl-loop for buf in (buffer-list)
- do (with-current-buffer buf
- (when (eq mode major-mode) ;FIXME: derived-mode-p?
- (let ((map (if mh-folder-view-stack
- sequence-map
- default-map)))
- ;; Yes, make-local-variable is necessary since we
- ;; get here during initialization when loading
- ;; mh-e.el, after the +inbox buffer has been
- ;; created, but before mh-folder-mode has run and
- ;; created the local map.
- (set (make-local-variable 'tool-bar-map) map))))))
- (defun mh-tool-bar-folder-buttons-set (symbol value)
- "Construct tool bar for `mh-folder-mode' and `mh-show-mode'."
- (set-default symbol value)
- (mh-tool-bar-folder-buttons-init)
- (mh-tool-bar-update 'mh-folder-mode mh-folder-tool-bar-map
- mh-folder-seq-tool-bar-map)
- (mh-tool-bar-update 'mh-show-mode mh-show-tool-bar-map
- mh-show-seq-tool-bar-map))
- (defun mh-tool-bar-letter-buttons-set (symbol value)
- "Construct tool bar for `mh-letter-mode'."
- (set-default symbol value)
- (mh-tool-bar-letter-buttons-init)
- (mh-tool-bar-update 'mh-letter-mode mh-letter-tool-bar-map
- mh-letter-tool-bar-map)))
- ;; XEmacs specific code
- (mh-do-in-xemacs
- (defvar mh-tool-bar-folder-vector-map
- (list ,@(cl-loop for button in folder-buttons
- for vector in folder-vectors
- collect `(cons ',button ,vector))))
- (defvar mh-tool-bar-show-vector-map
- (list ,@(cl-loop for button in show-buttons
- for vector in show-vectors
- collect `(cons ',button ,vector))))
- (defvar mh-tool-bar-letter-vector-map
- (list ,@(cl-loop for button in letter-buttons
- for vector in letter-vectors
- collect `(cons ',button ,vector))))
- (defvar mh-tool-bar-folder-buttons)
- (defvar mh-tool-bar-show-buttons)
- (defvar mh-tool-bar-letter-buttons)
- ;; Custom setter functions
- (defun mh-tool-bar-letter-buttons-set (symbol value)
- (set-default symbol value)
- (when mh-xemacs-has-tool-bar-flag
- (setq mh-tool-bar-letter-buttons
- (cl-loop
- for b in value
- collect (cdr (assoc b mh-tool-bar-letter-vector-map))))))
- (defun mh-tool-bar-folder-buttons-set (symbol value)
- (set-default symbol value)
- (when mh-xemacs-has-tool-bar-flag
- (setq mh-tool-bar-folder-buttons
- (cl-loop
- for b in value
- collect (cdr (assoc b mh-tool-bar-folder-vector-map))))
- (setq mh-tool-bar-show-buttons
- (cl-loop
- for b in value
- collect (cdr (assoc b mh-tool-bar-show-vector-map))))))
- (defun mh-tool-bar-init (mode)
- "Install tool bar in MODE."
- (when mh-xemacs-use-tool-bar-flag
- (let ((tool-bar (cond ((eq mode :folder)
- mh-tool-bar-folder-buttons)
- ((eq mode :letter)
- mh-tool-bar-letter-buttons)
- ((eq mode :show)
- mh-tool-bar-show-buttons)))
- (height 37)
- (width 40)
- (buffer (current-buffer)))
- (cond
- ((eq mh-xemacs-tool-bar-position 'top)
- (set-specifier top-toolbar tool-bar buffer)
- (set-specifier top-toolbar-visible-p t)
- (set-specifier top-toolbar-height height))
- ((eq mh-xemacs-tool-bar-position 'bottom)
- (set-specifier bottom-toolbar tool-bar buffer)
- (set-specifier bottom-toolbar-visible-p t)
- (set-specifier bottom-toolbar-height height))
- ((eq mh-xemacs-tool-bar-position 'left)
- (set-specifier left-toolbar tool-bar buffer)
- (set-specifier left-toolbar-visible-p t)
- (set-specifier left-toolbar-width width))
- ((eq mh-xemacs-tool-bar-position 'right)
- (set-specifier right-toolbar tool-bar buffer)
- (set-specifier right-toolbar-visible-p t)
- (set-specifier right-toolbar-width width))
- (t (set-specifier default-toolbar tool-bar buffer)))))))
+ (cl-loop for buf in (buffer-list)
+ do (with-current-buffer buf
+ (when (eq mode major-mode) ;FIXME: derived-mode-p?
+ (let ((map (if mh-folder-view-stack
+ sequence-map
+ default-map)))
+ ;; Yes, make-local-variable is necessary since we
+ ;; get here during initialization when loading
+ ;; mh-e.el, after the +inbox buffer has been
+ ;; created, but before mh-folder-mode has run and
+ ;; created the local map.
+ (setq-local tool-bar-map map))))))
+ (defun mh-tool-bar-folder-buttons-set (symbol value)
+ "Construct tool bar for `mh-folder-mode' and `mh-show-mode'."
+ (set-default symbol value)
+ (mh-tool-bar-folder-buttons-init)
+ (mh-tool-bar-update 'mh-folder-mode mh-folder-tool-bar-map
+ mh-folder-seq-tool-bar-map)
+ (mh-tool-bar-update 'mh-show-mode mh-show-tool-bar-map
+ mh-show-seq-tool-bar-map))
+ (defun mh-tool-bar-letter-buttons-set (symbol value)
+ "Construct tool bar for `mh-letter-mode'."
+ (set-default symbol value)
+ (mh-tool-bar-letter-buttons-init)
+ (mh-tool-bar-update 'mh-letter-mode mh-letter-tool-bar-map
+ mh-letter-tool-bar-map))
;; Declare customizable tool bars
(custom-declare-variable
'mh-tool-bar-folder-buttons
@@ -372,7 +288,6 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise."
;;:package-version '(MH-E "7.1")
))))
-;; The icon names are duplicated in the Makefile and mh-xemacs.el.
(mh-tool-bar-define
((:folder mh-inc-folder mh-mime-save-parts
mh-previous-undeleted-msg mh-page-msg
diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el
index bbce17013b1..b75025d6a4d 100644
--- a/lisp/mh-e/mh-utils.el
+++ b/lisp/mh-e/mh-utils.el
@@ -52,7 +52,7 @@ used in lieu of `search' in the CL package."
(let ((syntax-table (syntax-table)))
(unwind-protect
(save-excursion
- (mh-mail-abbrev-make-syntax-table)
+ (mail-abbrev-make-syntax-table)
(set-syntax-table mail-abbrev-syntax-table)
(backward-word n)
(point))
@@ -61,9 +61,9 @@ used in lieu of `search' in the CL package."
;;;###mh-autoload
(defun mh-colors-available-p ()
"Check if colors are available in the Emacs being used."
- (or (featurep 'xemacs)
- (let ((color-cells (mh-display-color-cells)))
- (and (numberp color-cells) (>= color-cells 8)))))
+ ;; FIXME: Can this be replaced with `display-color-p'?
+ (let ((color-cells (display-color-cells)))
+ (and (numberp color-cells) (>= color-cells 8))))
;;;###mh-autoload
(defun mh-colors-in-use-p ()
@@ -78,16 +78,13 @@ used in lieu of `search' in the CL package."
;;;###mh-autoload
(defun mh-make-local-vars (&rest pairs)
"Initialize local variables according to the variable-value PAIRS."
+ (declare (obsolete setq-local "29.1"))
(while pairs
(set (make-local-variable (car pairs)) (car (cdr pairs)))
(setq pairs (cdr (cdr pairs)))))
;;;###mh-autoload
-(defun mh-mapc (function list)
- "Apply FUNCTION to each element of LIST for side effects only."
- (while list
- (funcall function (car list))
- (setq list (cdr list))))
+(define-obsolete-function-alias 'mh-mapc #'mapc "29.1")
(defvar mh-pick-regexp-chars ".*$["
"List of special characters in pick regular expressions.")
@@ -102,7 +99,7 @@ PICK-EXPR is a list of strings. Return nil if PICK-EXPR is nil."
(not (string-equal string "")))
(cl-loop for i from 0 to (1- (length mh-pick-regexp-chars)) do
(let ((s (string ?\\ (aref mh-pick-regexp-chars i))))
- (setq string (mh-replace-regexp-in-string s s string t t))))
+ (setq string (replace-regexp-in-string s s string t t))))
(setq quoted-pick-expr (append quoted-pick-expr (list string)))))
quoted-pick-expr))
@@ -119,34 +116,32 @@ Ignores case when searching for OLD."
;;; Logo Display
-(defvar mh-logo-cache nil)
+;;;###mh-autoload
+(defmacro mh--with-image-load-path (&rest body)
+ "Load `image' and eval BODY with `image-load-path' set appropriately."
+ (declare (debug t) (indent 0))
+ `(progn
+ ;; Not preloaded in without-x builds.
+ (require 'image)
+ (defvar image-load-path)
+ (declare-function image-load-path-for-library "image")
+ (let* ((load-path (image-load-path-for-library "mh-e" "mh-logo.xpm"))
+ (image-load-path (cons (car load-path) image-load-path)))
+ ,@body)))
-;; Shush compiler.
-(defvar image-load-path)
+(defvar mh-logo-cache nil)
;;;###mh-autoload
(defun mh-logo-display ()
"Modify mode line to display MH-E logo."
- (mh-do-in-gnu-emacs
- (let* ((load-path (mh-image-load-path-for-library "mh-e" "mh-logo.xpm"))
- (image-load-path (cons (car load-path)
- (when (boundp 'image-load-path)
- image-load-path))))
- (add-text-properties
- 0 2
- `(display ,(or mh-logo-cache
- (setq mh-logo-cache
- (mh-funcall-if-exists
- find-image '((:type xpm :ascent center
- :file "mh-logo.xpm"))))))
- (car mode-line-buffer-identification))))
- (mh-do-in-xemacs
- (setq modeline-buffer-identification
- (list
- (if mh-modeline-glyph
- (cons modeline-buffer-id-left-extent mh-modeline-glyph)
- (cons modeline-buffer-id-left-extent "XEmacs%N:"))
- (cons modeline-buffer-id-right-extent " %17b")))))
+ (mh--with-image-load-path
+ (add-text-properties
+ 0 2
+ `(display ,(or mh-logo-cache
+ (setq mh-logo-cache
+ (find-image '(( :type xpm :ascent center
+ :file "mh-logo.xpm" ))))))
+ (car mode-line-buffer-identification))))
@@ -509,8 +504,8 @@ they will not be returned."
;; folder is specified, ensure it is nil to avoid adding the
;; folder to the folder-list and adding a slash to it.
(when folder
- (setq folder (mh-replace-regexp-in-string "^\\+" "" folder))
- (setq folder (mh-replace-regexp-in-string "/+$" "" folder))
+ (setq folder (replace-regexp-in-string "^\\+" "" folder))
+ (setq folder (replace-regexp-in-string "/+$" "" folder))
(if (equal folder "")
(setq folder nil)))
;; Add provided folder to list, unless all folders are asked for.
@@ -535,7 +530,12 @@ results of the actual folders call.
If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a
slash is added to each of the sub-folder names that may have
nested folders within them."
- (let* ((folder (mh-normalize-folder-name folder nil nil t))
+ ;; In most cases we want to remove a trailing slash. We keep the
+ ;; slash for "+/", because it refers to folders in the system root
+ ;; directory, whereas "+" refers to the user's top-level folders.
+ (let* ((folder (mh-normalize-folder-name folder nil
+ (string= folder "+/")
+ t))
(match (gethash folder mh-sub-folders-cache 'no-result))
(sub-folders (cond ((eq match 'no-result)
(setf (gethash folder mh-sub-folders-cache)
@@ -562,7 +562,6 @@ Expects FOLDER to have already been normalized with
(let ((arg-list `(,(expand-file-name "folders" mh-progs)
nil (t nil) nil "-noheader" "-norecurse" "-nototal"
,@(if (stringp folder) (list folder) ())))
- (results ())
(current-folder (concat
(with-temp-buffer
(call-process (expand-file-name "folder" mh-progs)
@@ -571,33 +570,48 @@ Expects FOLDER to have already been normalized with
"+")))
(with-temp-buffer
(apply #'call-process arg-list)
- (goto-char (point-min))
- (while (not (and (eolp) (bolp)))
- (goto-char (mh-line-end-position))
- (let ((start-pos (mh-line-beginning-position))
- (has-pos (search-backward " has "
- (mh-line-beginning-position) t)))
- (when (integerp has-pos)
- (while (equal (char-after has-pos) ? )
- (cl-decf has-pos))
- (cl-incf has-pos)
- (while (equal (char-after start-pos) ? )
- (cl-incf start-pos))
- (let* ((name (buffer-substring start-pos has-pos))
- (first-char (aref name 0))
- (last-char (aref name (1- (length name)))))
- (unless (member first-char '(?. ?# ?,))
- (when (and (equal last-char ?+) (equal name current-folder))
- (setq name (substring name 0 (1- (length name)))))
- (push
- (cons name
- (search-forward "(others)" (mh-line-end-position) t))
- results))))
- (forward-line 1))))
+ (mh-sub-folders-parse folder current-folder))))
+
+(defun mh-sub-folders-parse (folder current-folder)
+ "Parse the results of \"folders FOLDER\" and return a list of sub-folders.
+CURRENT-FOLDER is the result of \"folder -fast\".
+FOLDER will be nil or start with '+'; CURRENT-FOLDER will end with '+'.
+This function is a testable helper of `mh-sub-folders-actual'."
+ (let ((results ()))
+ (goto-char (point-min))
+ (while (not (and (eolp) (bolp)))
+ (goto-char (line-end-position))
+ (let ((start-pos (line-beginning-position))
+ (has-pos (search-backward " has "
+ (line-beginning-position) t)))
+ (when (integerp has-pos)
+ (while (equal (char-after has-pos) ? )
+ (cl-decf has-pos))
+ (cl-incf has-pos)
+ (while (equal (char-after start-pos) ? )
+ (cl-incf start-pos))
+ (let* ((name (buffer-substring start-pos has-pos))
+ (first-char (aref name 0))
+ (second-char (and (length> name 1) (aref name 1)))
+ (last-char (aref name (1- (length name)))))
+ (unless (member first-char '(?. ?# ?,))
+ (when (and (equal last-char ?+) (equal name current-folder))
+ (setq name (substring name 0 (1- (length name)))))
+ ;; nmh outputs double slash in root folder, e.g., "//tmp"
+ (when (and (equal first-char ?/) (equal second-char ?/))
+ (setq name (substring name 1)))
+ (push
+ (cons name
+ (search-forward "(others)" (line-end-position) t))
+ results))))
+ (forward-line 1)))
(setq results (nreverse results))
(when (stringp folder)
(setq results (cdr results))
(let ((folder-name-len (length (format "%s/" (substring folder 1)))))
+ (when (equal "+/" folder)
+ ;; folder "+/" includes a trailing slash
+ (cl-decf folder-name-len))
(setq results (mapcar (lambda (f)
(cons (substring (car f) folder-name-len)
(cdr f)))
@@ -727,16 +741,12 @@ See Info node `(elisp) Programmed Completion' for details."
((equal path mh-user-path) nil)
(t (file-directory-p path))))))))
-;; Shush compiler.
-(defvar completion-root-regexp) ;; Apparently used in XEmacs
-
(defun mh-folder-completing-read (prompt default allow-root-folder-flag)
"Read folder name with PROMPT and default result DEFAULT.
If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be
a folder name corresponding to `mh-user-path'."
(mh-normalize-folder-name
- (let ((completion-root-regexp "^[+/]") ;FIXME: Who/what uses that?
- (minibuffer-local-completion-map mh-folder-completion-map)
+ (let ((minibuffer-local-completion-map mh-folder-completion-map)
(mh-allow-root-folder-flag allow-root-folder-flag))
(completing-read prompt 'mh-folder-completion-function nil nil nil
'mh-folder-hist default))
@@ -920,11 +930,7 @@ Handle RFC 822 (or later) continuation lines."
(defvar mh-hidden-header-keymap
(let ((map (make-sparse-keymap)))
- (mh-do-in-gnu-emacs
- (define-key map [mouse-2] #'mh-letter-toggle-header-field-display-button))
- (mh-do-in-xemacs
- (define-key map '(button2)
- #'mh-letter-toggle-header-field-display-button))
+ (define-key map [mouse-2] #'mh-letter-toggle-header-field-display-button)
map))
;;;###mh-autoload
@@ -958,9 +964,9 @@ is hidden, if positive then the field is displayed."
(and (numberp arg)
(>= arg 0))
(and (eq arg 'long)
- (> (mh-line-beginning-position 5) end)))
+ (> (line-beginning-position 5) end)))
(remove-text-properties begin end '(invisible nil))
- (search-forward ":" (mh-line-end-position) t)
+ (search-forward ":" (line-end-position) t)
(mh-letter-skip-leading-whitespace-in-header-field))
;; XXX Redesign to make usable by user. Perhaps use a positive
;; numeric prefix to make that many lines visible.
diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el
index 58177c1794e..8350f3d0fbb 100644
--- a/lisp/mh-e/mh-xface.el
+++ b/lisp/mh-e/mh-xface.el
@@ -30,17 +30,11 @@
(autoload 'mail-header-parse-address "mail-parse")
(autoload 'message-fetch-field "message")
-(defvar mh-show-xface-function
- (cond ((and (featurep 'xemacs) (locate-library "x-face") (not (featurep 'xface)))
- (load "x-face" t t)
- #'mh-face-display-function)
- ((>= emacs-major-version 21)
- #'mh-face-display-function)
- (t #'ignore))
+(defvar mh-show-xface-function #'mh-face-display-function
"Determine at run time what function should be called to display X-Face.")
+(make-obsolete-variable 'mh-show-xface-function nil "29.1")
-(defvar mh-uncompface-executable
- (and (fboundp 'executable-find) (executable-find "uncompface")))
+(defvar mh-uncompface-executable (executable-find "uncompface"))
@@ -52,7 +46,7 @@
(when (and window-system mh-show-use-xface-flag
(or mh-decode-mime-flag mh-mhl-format-file
mh-clean-message-header-flag))
- (funcall mh-show-xface-function)))
+ (mh-face-display-function)))
(defun mh-face-display-function ()
"Display a Face, X-Face, or X-Image-URL header field.
@@ -77,53 +71,20 @@ in this order is used."
(when type
(goto-char (point-min))
(when (re-search-forward "^from:" (point-max) t)
- ;; GNU Emacs
- (mh-do-in-gnu-emacs
- (if (eq type 'url)
- (mh-x-image-url-display url)
- (mh-funcall-if-exists
- insert-image (create-image
- raw type t
- :foreground
- (mh-face-foreground 'mh-show-xface nil t)
- :background
- (mh-face-background 'mh-show-xface nil t))
- " ")))
- ;; XEmacs
- (mh-do-in-xemacs
- (cond
- ((eq type 'url)
- (mh-x-image-url-display url))
- ((eq type 'png)
- (when (featurep 'png)
- (set-extent-begin-glyph
- (make-extent (point) (point))
- (make-glyph (vector 'png ':data (mh-face-to-png face))))))
- ;; Try internal xface support if available...
- ((and (eq type 'pbm) (featurep 'xface))
- (set-glyph-face
- (set-extent-begin-glyph
- (make-extent (point) (point))
- (make-glyph (vector 'xface ':data (concat "X-Face: " x-face))))
- 'mh-show-xface))
- ;; Otherwise try external support with x-face...
- ((and (eq type 'pbm)
- (fboundp 'x-face-xmas-wl-display-x-face)
- (fboundp 'executable-find) (executable-find "uncompface"))
- (mh-funcall-if-exists x-face-xmas-wl-display-x-face))
- ;; Picon display
- ((and raw (member type '(xpm xbm gif)))
- (when (featurep type)
- (set-extent-begin-glyph
- (make-extent (point) (point))
- (make-glyph (vector type ':data raw))))))
- (when raw (insert " "))))))))
+ (if (eq type 'url)
+ (mh-x-image-url-display url)
+ (insert-image (create-image
+ raw type t
+ :foreground
+ (face-foreground 'mh-show-xface nil t)
+ :background
+ (face-background 'mh-show-xface nil t))
+ " ")))))))
(defun mh-face-to-png (data)
"Convert base64 encoded DATA to png image."
(with-temp-buffer
- (if (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte nil))
+ (set-buffer-multibyte nil)
(insert data)
(ignore-errors (base64-decode-region (point-min) (point-max)))
(buffer-string)))
@@ -131,8 +92,7 @@ in this order is used."
(defun mh-uncompface (data)
"Run DATA through `uncompface' to generate bitmap."
(with-temp-buffer
- (if (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte nil))
+ (set-buffer-multibyte nil)
(insert data)
(when (and mh-uncompface-executable
(equal (call-process-region (point-min) (point-max)
@@ -176,10 +136,8 @@ The directories are searched for in the order they appear in the list.")
(defvar mh-picon-image-types
(cl-loop for type in '(xpm xbm gif)
- when (or (mh-do-in-gnu-emacs
- (ignore-errors
- (mh-funcall-if-exists image-type-available-p type)))
- (mh-do-in-xemacs (featurep type)))
+ when (ignore-errors
+ (image-type-available-p type))
collect type))
(autoload 'message-tokenize-header "sendmail")
@@ -270,8 +228,7 @@ file contents as a string is returned. If FILE is nil, then both
elements of the list are nil."
(if (stringp file)
(with-temp-buffer
- (if (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte nil))
+ (set-buffer-multibyte nil)
(let ((type (and (string-match ".*\\.\\(...\\)$" file)
(intern (match-string 1 file)))))
(insert-file-contents-literally file)
@@ -321,7 +278,7 @@ If the URL isn't present in the cache then it is fetched with wget."
(let* ((cache-filename (mh-x-image-url-cache-canonicalize url))
(state (mh-x-image-get-download-state cache-filename))
(marker (point-marker)))
- (set (make-local-variable 'mh-x-image-marker) marker)
+ (setq-local mh-x-image-marker marker)
(cond ((not (mh-x-image-url-sane-p url)))
((eq state 'ok)
(mh-x-image-display cache-filename marker))
@@ -357,14 +314,14 @@ This is only done if `mh-x-image-cache-directory' is nil."
(defun mh-x-image-url-cache-canonicalize (url)
"Canonicalize URL.
Replace the ?/ character with a ?! character and append .png.
-Also replaces special characters with `mh-url-hexify-string'
+Also replaces special characters with `url-hexify-string'
since not all characters, such as :, are valid within Windows
filenames. In addition, replaces * with %2a. See URL
`https://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/ifaces/iitemnamelimits/GetValidCharacters.asp'."
(format "%s/%s.png" mh-x-image-cache-directory
- (mh-replace-regexp-in-string
+ (replace-regexp-in-string
"\\*" "%2a"
- (mh-url-hexify-string
+ (url-hexify-string
(with-temp-buffer
(insert url)
(mh-replace-string "/" "!")
@@ -404,16 +361,7 @@ filenames. In addition, replaces * with %2a. See URL
(when (and (file-readable-p image) (not (file-symlink-p image))
(eq marker mh-x-image-marker))
(goto-char marker)
- (mh-do-in-gnu-emacs
- (mh-funcall-if-exists insert-image (create-image image 'png)))
- (mh-do-in-xemacs
- (when (featurep 'png)
- (set-extent-begin-glyph
- (make-extent (point) (point))
- (make-glyph
- (vector 'png ':data (with-temp-buffer
- (insert-file-contents-literally image)
- (buffer-string))))))))
+ (insert-image (create-image image 'png)))
(set-buffer-modified-p buffer-modified-flag)))))
(defun mh-x-image-url-fetch-image (url cache-file marker sentinel)
@@ -423,12 +371,11 @@ be displayed in a buffer and position specified by MARKER. The
actual display is carried out by the SENTINEL function."
(if mh-wget-executable
(let ((buffer (generate-new-buffer mh-temp-fetch-buffer))
- (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch")
- (expand-file-name (make-temp-name "~/mhe-fetch")))))
+ (filename (make-temp-file "mhe-fetch")))
(with-current-buffer buffer
- (set (make-local-variable 'mh-x-image-url-cache-file) cache-file)
- (set (make-local-variable 'mh-x-image-marker) marker)
- (set (make-local-variable 'mh-x-image-temp-file) filename))
+ (setq-local mh-x-image-url-cache-file cache-file)
+ (setq-local mh-x-image-marker marker)
+ (setq-local mh-x-image-temp-file filename))
(set-process-sentinel
(start-process "*mh-x-image-url-fetch*" buffer
mh-wget-executable mh-wget-option filename url)
diff --git a/lisp/midnight.el b/lisp/midnight.el
index b3adbf00172..51173e7429f 100644
--- a/lisp/midnight.el
+++ b/lisp/midnight.el
@@ -159,7 +159,7 @@ the current date/time, buffer name, how many seconds ago it was
displayed (can be nil if the buffer was never displayed) and its
lifetime, i.e., its \"age\" when it will be purged."
(interactive)
- (let ((tm (current-time)) bts (ts (format-time-string "%Y-%m-%d %T"))
+ (let* ((tm (current-time)) bts (ts (format-time-string "%Y-%m-%d %T" tm))
delay cbld bn)
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 21d610fdf44..28bd1df59ab 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -1,4 +1,4 @@
-;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
+;;; minibuffer.el --- Minibuffer and completion functions -*- lexical-binding: t -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -2735,7 +2735,7 @@ not active.")
This is only used when the minibuffer area has no active minibuffer.
Note that the minibuffer may change to this mode more often than
-you might expect. For instance, typing `M-x' may change the
+you might expect. For instance, typing \\`M-x' may change the
buffer to this mode, then to a different mode, and then back
again to this mode upon exit. Code running from
`minibuffer-inactive-mode-hook' has to be prepared to run
diff --git a/lisp/mouse.el b/lisp/mouse.el
index 8474a821118..11fdd3f6391 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -184,8 +184,8 @@ items `Turn Off' and `Help'."
"-" " " (format "%S" minor-mode))))
(turn-off menu-item "Turn off minor mode" ,mm-fun)
(help menu-item "Help for minor mode"
- (lambda () (interactive)
- (describe-function ',mm-fun)))))))
+ ,(lambda () (interactive)
+ (describe-function mm-fun)))))))
(if menu
(popup-menu menu)
(message "No menu available")))))
@@ -271,7 +271,7 @@ not it is actually displayed."
;; FIXME: We have a problem here: we have to use the global/local/minor
;; so they're displayed in the expected order, but later on in the command
;; loop, they're actually looked up in the opposite order.
- (apply 'append
+ (apply #'append
global-menu
local-menu
minor-mode-menus)))
@@ -327,13 +327,23 @@ the function `context-menu-filter-function'."
(setq menu (funcall fun menu click))
nil)))
- ;; Remove duplicate separators
- (let ((l menu))
- (while (consp l)
- (when (and (equal (cdr-safe (car l)) menu-bar-separator)
- (equal (cdr-safe (cadr l)) menu-bar-separator))
- (setcdr l (cddr l)))
- (setq l (cdr l))))
+ ;; Remove duplicate separators as well as ones at the beginning or
+ ;; end of the menu.
+ (let ((l menu) saw-first-item)
+ (while (and (consp l)
+ (consp (cdr l)))
+ ;; If the next item is a separator, remove it if 1) we haven't
+ ;; seen any other items yet, or 2) it's followed by either
+ ;; another separator or the end of the list.
+ (if (and (equal (cdr-safe (cadr l)) menu-bar-separator)
+ (or (not saw-first-item)
+ (null (caddr l))
+ (equal (cdr-safe (caddr l)) menu-bar-separator)))
+ (setcdr l (cddr l))
+ ;; The "first item" is any cons cell; this excludes the
+ ;; `keymap' symbol and the menu name.
+ (when (consp (cadr l)) (setq saw-first-item t))
+ (setq l (cdr l)))))
(when (functionp context-menu-filter-function)
(setq menu (funcall context-menu-filter-function menu click)))
@@ -514,8 +524,8 @@ Some context functions add menu items below the separator."
menu)
(defvar context-menu-entry
- `(menu-item ,(purecopy "Context Menu") ignore
- :filter (lambda (_) (context-menu-map)))
+ `(menu-item ,(purecopy "Context Menu") ,(make-sparse-keymap)
+ :filter ,(lambda (_) (context-menu-map)))
"Menu item that creates the context menu and can be bound to a mouse key.")
(defvar context-menu-mode-map
@@ -536,7 +546,7 @@ Some context functions add menu items below the separator."
When Context Menu mode is enabled, clicking the mouse button down-mouse-3
activates the menu whose contents depends on its surrounding context."
- :global t :group 'mouse)
+ :global t)
(defun context-menu-open ()
"Start key navigation of the context menu.
@@ -548,7 +558,7 @@ This is the keyboard interface to \\[context-menu-map]."
(call-interactively map)
(popup-menu map (point)))))
-(global-set-key [S-f10] 'context-menu-open)
+(global-set-key [S-f10] #'context-menu-open)
(defun mark-thing-at-mouse (click thing)
"Activate the region around THING found near the mouse CLICK."
@@ -603,7 +613,7 @@ This command must be bound to a mouse click."
(or (eq frame oframe)
(set-mouse-position (selected-frame) (1- (frame-width)) 0))))
-(define-obsolete-function-alias 'mouse-tear-off-window 'tear-off-window "24.4")
+(define-obsolete-function-alias 'mouse-tear-off-window #'tear-off-window "24.4")
(defun tear-off-window (click)
"Delete the selected window, and create a new frame displaying its buffer."
(interactive (list last-nonmenu-event))
@@ -679,7 +689,6 @@ must be one of the symbols `header', `mode', or `vertical'."
;; previously sampled position. The difference of `position'
;; and `last-position' determines the size change of WINDOW.
(last-position position)
- (draggable t)
posn-window growth dragged)
;; Decide on whether we are allowed to track at all and whose
;; window's edge we drag.
@@ -732,7 +741,7 @@ must be one of the symbols `header', `mode', or `vertical'."
(setq dragged t)
(adjust-window-trailing-edge window growth t t))
(setq last-position position))
- (draggable
+ (t
;; Drag bottom edge of `window'.
(setq start (event-start event))
;; Set `posn-window' to the window where `event' was recorded.
@@ -1573,8 +1582,7 @@ The region will be defined with mark and point."
(mouse-minibuffer-check start-event)
(setq mouse-selection-click-count-buffer (current-buffer))
(deactivate-mark)
- (let* ((scroll-margin 0) ; Avoid margin scrolling (Bug#9541).
- (start-posn (event-start start-event))
+ (let* ((start-posn (event-start start-event))
(start-point (posn-point start-posn))
(start-window (posn-window start-posn))
(_ (with-current-buffer (window-buffer start-window)
@@ -1596,76 +1604,88 @@ The region will be defined with mark and point."
;; Don't count the mode line.
(1- (nth 3 bounds))))
(click-count (1- (event-click-count start-event)))
- ;; Suppress automatic hscrolling, because that is a nuisance
- ;; when setting point near the right fringe (but see below).
+ ;; Save original automatic scrolling behavior (see below).
(auto-hscroll-mode-saved auto-hscroll-mode)
- (old-track-mouse track-mouse))
+ (scroll-margin-saved scroll-margin)
+ (old-track-mouse track-mouse)
+ (cleanup (lambda ()
+ (setq track-mouse old-track-mouse)
+ (setq auto-hscroll-mode auto-hscroll-mode-saved)
+ (setq scroll-margin scroll-margin-saved))))
+ (condition-case err
+ (progn
+ (setq mouse-selection-click-count click-count)
+
+ ;; Suppress automatic scrolling near the edges while tracking
+ ;; movement, as it interferes with the natural dragging behavior
+ ;; (point will unexpectedly be moved beneath the pointer, making
+ ;; selections in auto-scrolling margins impossible).
+ (setq auto-hscroll-mode nil)
+ (setq scroll-margin 0)
+
+ ;; In case the down click is in the middle of some intangible text,
+ ;; use the end of that text, and put it in START-POINT.
+ (if (< (point) start-point)
+ (goto-char start-point))
+ (setq start-point (point))
+
+ ;; Activate the region, using `mouse-start-end' to determine where
+ ;; to put point and mark (e.g., double-click will select a word).
+ (setq-local transient-mark-mode
+ (if (eq transient-mark-mode 'lambda)
+ '(only)
+ (cons 'only transient-mark-mode)))
+ (let ((range (mouse-start-end start-point start-point click-count)))
+ (push-mark (nth 0 range) t t)
+ (goto-char (nth 1 range)))
- (setq mouse-selection-click-count click-count)
- ;; In case the down click is in the middle of some intangible text,
- ;; use the end of that text, and put it in START-POINT.
- (if (< (point) start-point)
- (goto-char start-point))
- (setq start-point (point))
+ (setf (terminal-parameter nil 'mouse-drag-start) start-event)
+ ;; Set 'track-mouse' to something neither nil nor t, so that mouse
+ ;; events are not reported to have happened on the tool bar or the
+ ;; tab bar, as that breaks drag events that originate on the window
+ ;; body below these bars; see make_lispy_position and bug#51794.
+ (setq track-mouse 'drag-tracking)
- ;; Activate the region, using `mouse-start-end' to determine where
- ;; to put point and mark (e.g., double-click will select a word).
- (setq-local transient-mark-mode
- (if (eq transient-mark-mode 'lambda)
- '(only)
- (cons 'only transient-mark-mode)))
- (let ((range (mouse-start-end start-point start-point click-count)))
- (push-mark (nth 0 range) t t)
- (goto-char (nth 1 range)))
-
- (setf (terminal-parameter nil 'mouse-drag-start) start-event)
- ;; Set 'track-mouse' to something neither nil nor t, so that mouse
- ;; events are not reported to have happened on the tool bar or the
- ;; tab bar, as that breaks drag events that originate on the window
- ;; body below these bars; see make_lispy_position and bug#51794.
- (setq track-mouse 'drag-tracking)
- (setq auto-hscroll-mode nil)
-
- (set-transient-map
- (let ((map (make-sparse-keymap)))
- (define-key map [switch-frame] #'ignore)
- (define-key map [select-window] #'ignore)
- (define-key map [mouse-movement]
- (lambda (event) (interactive "e")
- (let* ((end (event-end event))
- (end-point (posn-point end)))
- (unless (eq end-point start-point)
- ;; As soon as the user moves, we can re-enable auto-hscroll.
- (setq auto-hscroll-mode auto-hscroll-mode-saved)
- ;; And remember that we have moved, so mouse-set-region can know
- ;; its event is really a drag event.
- (setcar start-event 'mouse-movement))
- (if (and (eq (posn-window end) start-window)
- (integer-or-marker-p end-point))
- (mouse--drag-set-mark-and-point start-point
- end-point click-count)
- (let ((mouse-row (cdr (cdr (mouse-position)))))
- (cond
- ((null mouse-row))
- ((< mouse-row top)
- (mouse-scroll-subr start-window (- mouse-row top)
- nil start-point))
- ((>= mouse-row bottom)
- (mouse-scroll-subr start-window (1+ (- mouse-row bottom))
- nil start-point))))))))
- map)
- t (lambda ()
- (setq track-mouse old-track-mouse)
- (setq auto-hscroll-mode auto-hscroll-mode-saved)
- ;; 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.
- (unless (and context-menu-mode
- (eq (car-safe (aref (this-command-keys-vector) 0))
- 'down-mouse-3))
- (deactivate-mark)
- (pop-mark))))))
+ (set-transient-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [switch-frame] #'ignore)
+ (define-key map [select-window] #'ignore)
+ (define-key map [mouse-movement]
+ (lambda (event) (interactive "e")
+ (let* ((end (event-end event))
+ (end-point (posn-point end)))
+ (unless (eq end-point start-point)
+ ;; And remember that we have moved, so mouse-set-region can know
+ ;; its event is really a drag event.
+ (setcar start-event 'mouse-movement))
+ (if (and (eq (posn-window end) start-window)
+ (integer-or-marker-p end-point))
+ (mouse--drag-set-mark-and-point start-point
+ end-point click-count)
+ (let ((mouse-row (cdr (cdr (mouse-position)))))
+ (cond
+ ((null mouse-row))
+ ((< mouse-row top)
+ (mouse-scroll-subr start-window (- mouse-row top)
+ nil start-point))
+ ((>= mouse-row bottom)
+ (mouse-scroll-subr start-window (1+ (- mouse-row bottom))
+ nil start-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.
+ (unless (and context-menu-mode
+ (eq (car-safe (aref (this-command-keys-vector) 0))
+ 'down-mouse-3))
+ (deactivate-mark)
+ (pop-mark)))))
+ ;; Cleanup on errors
+ (error (funcall cleanup)
+ (signal (car err) (cdr err))))))
(defun mouse--drag-set-mark-and-point (start click click-count)
(let* ((range (mouse-start-end start click click-count))
@@ -1821,7 +1841,7 @@ If MODE is 2 then do the same for lines."
event)))
(setcar last new)
(if (and (not (equal modifiers old-modifiers))
- (key-binding (apply 'vector events)))
+ (key-binding (apply #'vector events)))
t
(setcar last event)
nil)))
@@ -1875,12 +1895,12 @@ regardless of where you click."
(setq mouse-selection-click-count 0)
(yank arg))
-(defun mouse-yank-primary (click)
- "Insert the primary selection at the position clicked on.
+(defun mouse-yank-primary (&optional event)
+ "Insert the primary selection,
Move point to the end of the inserted text, and set mark at
beginning. If `mouse-yank-at-point' is non-nil, insert at point
-regardless of where you click."
- (interactive "e")
+otherwise insert it at the position of EVENT."
+ (interactive (list last-nonmenu-event))
;; Give temporary modes such as isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook)
;; Without this, confusing things happen upon e.g. inserting into
@@ -1888,7 +1908,7 @@ regardless of where you click."
(when select-active-regions
(let (select-active-regions)
(deactivate-mark)))
- (or mouse-yank-at-point (mouse-set-point click))
+ (or mouse-yank-at-point (mouse-set-point event))
(let ((primary (gui-get-primary-selection)))
(push-mark)
(insert-for-yank primary)))
@@ -2028,11 +2048,11 @@ if `mouse-drag-copy-region' is non-nil)."
(setq mouse-save-then-kill-posn click-pt)))))
-(global-set-key [M-mouse-1] 'mouse-start-secondary)
-(global-set-key [M-drag-mouse-1] 'mouse-set-secondary)
-(global-set-key [M-down-mouse-1] 'mouse-drag-secondary)
-(global-set-key [M-mouse-3] 'mouse-secondary-save-then-kill)
-(global-set-key [M-mouse-2] 'mouse-yank-secondary)
+(global-set-key [M-mouse-1] #'mouse-start-secondary)
+(global-set-key [M-drag-mouse-1] #'mouse-set-secondary)
+(global-set-key [M-down-mouse-1] #'mouse-drag-secondary)
+(global-set-key [M-mouse-3] #'mouse-secondary-save-then-kill)
+(global-set-key [M-mouse-2] #'mouse-yank-secondary)
(defconst mouse-secondary-overlay
(let ((ol (make-overlay (point-min) (point-min))))
@@ -3192,78 +3212,78 @@ is copied instead of being cut."
;;; Bindings for mouse commands.
-(global-set-key [down-mouse-1] 'mouse-drag-region)
-(global-set-key [mouse-1] 'mouse-set-point)
-(global-set-key [drag-mouse-1] 'mouse-set-region)
+(global-set-key [down-mouse-1] #'mouse-drag-region)
+(global-set-key [mouse-1] #'mouse-set-point)
+(global-set-key [drag-mouse-1] #'mouse-set-region)
(defun mouse--strip-first-event (_prompt)
(substring (this-single-command-raw-keys) 1))
-(define-key function-key-map [left-fringe mouse-1] 'mouse--strip-first-event)
-(define-key function-key-map [right-fringe mouse-1] 'mouse--strip-first-event)
+(define-key function-key-map [left-fringe mouse-1] #'mouse--strip-first-event)
+(define-key function-key-map [right-fringe mouse-1] #'mouse--strip-first-event)
-(global-set-key [mouse-2] 'mouse-yank-primary)
+(global-set-key [mouse-2] #'mouse-yank-primary)
;; Allow yanking also when the corresponding cursor is "in the fringe".
-(define-key function-key-map [right-fringe mouse-2] 'mouse--strip-first-event)
-(define-key function-key-map [left-fringe mouse-2] 'mouse--strip-first-event)
-(global-set-key [mouse-3] 'mouse-save-then-kill)
-(define-key function-key-map [right-fringe mouse-3] 'mouse--strip-first-event)
-(define-key function-key-map [left-fringe mouse-3] 'mouse--strip-first-event)
+(define-key function-key-map [right-fringe mouse-2] #'mouse--strip-first-event)
+(define-key function-key-map [left-fringe mouse-2] #'mouse--strip-first-event)
+(global-set-key [mouse-3] #'mouse-save-then-kill)
+(define-key function-key-map [right-fringe mouse-3] #'mouse--strip-first-event)
+(define-key function-key-map [left-fringe mouse-3] #'mouse--strip-first-event)
;; By binding these to down-going events, we let the user use the up-going
;; event to make the selection, saving a click.
-(global-set-key [C-down-mouse-1] 'mouse-buffer-menu)
+(global-set-key [C-down-mouse-1] #'mouse-buffer-menu)
(if (not (eq system-type 'ms-dos))
- (global-set-key [S-down-mouse-1] 'mouse-appearance-menu))
+ (global-set-key [S-down-mouse-1] #'mouse-appearance-menu))
;; C-down-mouse-2 is bound in facemenu.el.
(global-set-key [C-down-mouse-3]
`(menu-item ,(purecopy "Menu Bar") ignore
- :filter (lambda (_)
- (if (zerop (or (frame-parameter nil 'menu-bar-lines) 0))
- (mouse-menu-bar-map)
- (mouse-menu-major-mode-map)))))
+ :filter ,(lambda (_)
+ (if (zerop (or (frame-parameter nil 'menu-bar-lines) 0))
+ (mouse-menu-bar-map)
+ (mouse-menu-major-mode-map)))))
;; Binding mouse-1 to mouse-select-window when on mode-, header-, or
;; vertical-line prevents Emacs from signaling an error when the mouse
;; button is released after dragging these lines, on non-toolkit
;; versions.
-(global-set-key [header-line down-mouse-1] 'mouse-drag-header-line)
-(global-set-key [header-line mouse-1] 'mouse-select-window)
-(global-set-key [tab-line down-mouse-1] 'mouse-drag-tab-line)
-(global-set-key [tab-line mouse-1] 'mouse-select-window)
+(global-set-key [header-line down-mouse-1] #'mouse-drag-header-line)
+(global-set-key [header-line mouse-1] #'mouse-select-window)
+(global-set-key [tab-line down-mouse-1] #'mouse-drag-tab-line)
+(global-set-key [tab-line mouse-1] #'mouse-select-window)
;; (global-set-key [mode-line drag-mouse-1] 'mouse-select-window)
-(global-set-key [mode-line down-mouse-1] 'mouse-drag-mode-line)
-(global-set-key [mode-line mouse-1] 'mouse-select-window)
-(global-set-key [mode-line mouse-2] 'mouse-delete-other-windows)
-(global-set-key [mode-line mouse-3] 'mouse-delete-window)
-(global-set-key [mode-line C-mouse-2] 'mouse-split-window-horizontally)
-(global-set-key [vertical-scroll-bar C-mouse-2] 'mouse-split-window-vertically)
-(global-set-key [horizontal-scroll-bar C-mouse-2] 'mouse-split-window-horizontally)
-(global-set-key [vertical-line down-mouse-1] 'mouse-drag-vertical-line)
-(global-set-key [vertical-line mouse-1] 'mouse-select-window)
-(global-set-key [vertical-line C-mouse-2] 'mouse-split-window-vertically)
-(global-set-key [right-divider down-mouse-1] 'mouse-drag-vertical-line)
-(global-set-key [right-divider mouse-1] 'ignore)
-(global-set-key [right-divider C-mouse-2] 'mouse-split-window-vertically)
-(global-set-key [bottom-divider down-mouse-1] 'mouse-drag-mode-line)
-(global-set-key [bottom-divider mouse-1] 'ignore)
-(global-set-key [bottom-divider C-mouse-2] 'mouse-split-window-horizontally)
-(global-set-key [left-edge down-mouse-1] 'mouse-drag-left-edge)
-(global-set-key [left-edge mouse-1] 'ignore)
-(global-set-key [top-left-corner down-mouse-1] 'mouse-drag-top-left-corner)
-(global-set-key [top-left-corner mouse-1] 'ignore)
-(global-set-key [top-edge down-mouse-1] 'mouse-drag-top-edge)
-(global-set-key [top-edge mouse-1] 'ignore)
-(global-set-key [top-right-corner down-mouse-1] 'mouse-drag-top-right-corner)
-(global-set-key [top-right-corner mouse-1] 'ignore)
-(global-set-key [right-edge down-mouse-1] 'mouse-drag-right-edge)
-(global-set-key [right-edge mouse-1] 'ignore)
-(global-set-key [bottom-right-corner down-mouse-1] 'mouse-drag-bottom-right-corner)
-(global-set-key [bottom-right-corner mouse-1] 'ignore)
-(global-set-key [bottom-edge down-mouse-1] 'mouse-drag-bottom-edge)
-(global-set-key [bottom-edge mouse-1] 'ignore)
-(global-set-key [bottom-left-corner down-mouse-1] 'mouse-drag-bottom-left-corner)
-(global-set-key [bottom-left-corner mouse-1] 'ignore)
+(global-set-key [mode-line down-mouse-1] #'mouse-drag-mode-line)
+(global-set-key [mode-line mouse-1] #'mouse-select-window)
+(global-set-key [mode-line mouse-2] #'mouse-delete-other-windows)
+(global-set-key [mode-line mouse-3] #'mouse-delete-window)
+(global-set-key [mode-line C-mouse-2] #'mouse-split-window-horizontally)
+(global-set-key [vertical-scroll-bar C-mouse-2] #'mouse-split-window-vertically)
+(global-set-key [horizontal-scroll-bar C-mouse-2] #'mouse-split-window-horizontally)
+(global-set-key [vertical-line down-mouse-1] #'mouse-drag-vertical-line)
+(global-set-key [vertical-line mouse-1] #'mouse-select-window)
+(global-set-key [vertical-line C-mouse-2] #'mouse-split-window-vertically)
+(global-set-key [right-divider down-mouse-1] #'mouse-drag-vertical-line)
+(global-set-key [right-divider mouse-1] #'ignore)
+(global-set-key [right-divider C-mouse-2] #'mouse-split-window-vertically)
+(global-set-key [bottom-divider down-mouse-1] #'mouse-drag-mode-line)
+(global-set-key [bottom-divider mouse-1] #'ignore)
+(global-set-key [bottom-divider C-mouse-2] #'mouse-split-window-horizontally)
+(global-set-key [left-edge down-mouse-1] #'mouse-drag-left-edge)
+(global-set-key [left-edge mouse-1] #'ignore)
+(global-set-key [top-left-corner down-mouse-1] #'mouse-drag-top-left-corner)
+(global-set-key [top-left-corner mouse-1] #'ignore)
+(global-set-key [top-edge down-mouse-1] #'mouse-drag-top-edge)
+(global-set-key [top-edge mouse-1] #'ignore)
+(global-set-key [top-right-corner down-mouse-1] #'mouse-drag-top-right-corner)
+(global-set-key [top-right-corner mouse-1] #'ignore)
+(global-set-key [right-edge down-mouse-1] #'mouse-drag-right-edge)
+(global-set-key [right-edge mouse-1] #'ignore)
+(global-set-key [bottom-right-corner down-mouse-1] #'mouse-drag-bottom-right-corner)
+(global-set-key [bottom-right-corner mouse-1] #'ignore)
+(global-set-key [bottom-edge down-mouse-1] #'mouse-drag-bottom-edge)
+(global-set-key [bottom-edge mouse-1] #'ignore)
+(global-set-key [bottom-left-corner down-mouse-1] #'mouse-drag-bottom-left-corner)
+(global-set-key [bottom-left-corner mouse-1] #'ignore)
(provide 'mouse)
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 51410e3ef4c..fbe8daa77f8 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -55,7 +55,8 @@
(mouse-wheel-mode 1)))
(defcustom mouse-wheel-down-event
- (if (or (featurep 'w32-win) (featurep 'ns-win))
+ (if (or (featurep 'w32-win) (featurep 'ns-win)
+ (featurep 'haiku-win) (featurep 'pgtk-win))
'wheel-up
'mouse-4)
"Event used for scrolling down."
@@ -63,8 +64,20 @@
: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."
+ :group 'mouse
+ :type 'symbol
+ :version "29.1"
+ :set 'mouse-wheel-change-button)
+
(defcustom mouse-wheel-up-event
- (if (or (featurep 'w32-win) (featurep 'ns-win))
+ (if (or (featurep 'w32-win) (featurep 'ns-win)
+ (featurep 'haiku-win) (featurep 'pgtk-win))
'wheel-down
'mouse-5)
"Event used for scrolling up."
@@ -72,6 +85,17 @@
: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)
+
(defcustom mouse-wheel-click-event 'mouse-2
"Event that should be temporarily inhibited after mouse scrolling.
The mouse wheel is typically on the mouse-2 button, so it may easily
@@ -221,17 +245,33 @@ 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))
+ (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.")
+
(defvar mouse-wheel-right-event
- (if (or (featurep 'w32-win) (featurep 'ns-win))
+ (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.")
+
(defun mouse-wheel--get-scroll-window (event)
"Return window for mouse wheel event EVENT.
If `mouse-wheel-follow-mouse' is non-nil, return the window that
@@ -296,14 +336,16 @@ value of ARG, and the command uses it in subsequent scrolls."
(condition-case nil
(unwind-protect
(let ((button (mwheel-event-button event)))
- (cond ((and (eq amt 'hscroll) (eq button mouse-wheel-down-event))
+ (cond ((and (eq amt 'hscroll) (memq button (list mouse-wheel-down-event
+ mouse-wheel-down-alternate-event)))
(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))
- ((eq button mouse-wheel-down-event)
+ ((memq button (list mouse-wheel-down-event
+ mouse-wheel-down-alternate-event))
(condition-case nil (funcall mwheel-scroll-down-function amt)
;; Make sure we do indeed scroll to the beginning of
;; the buffer.
@@ -318,23 +360,27 @@ 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) (eq button mouse-wheel-up-event))
+ ((and (eq amt 'hscroll) (memq button (list mouse-wheel-up-event
+ mouse-wheel-up-alternate-event)))
(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))
- ((eq button mouse-wheel-up-event)
+ ((memq button (list mouse-wheel-up-event
+ mouse-wheel-up-alternate-event))
(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)))))
- ((eq button mouse-wheel-left-event) ; for tilt scroll
+ ((memq button (list mouse-wheel-left-event
+ mouse-wheel-left-alternate-event)) ; for tilt scroll
(when mouse-wheel-tilt-scroll
(funcall (if mouse-wheel-flip-direction
mwheel-scroll-right-function
mwheel-scroll-left-function) amt)))
- ((eq button mouse-wheel-right-event) ; for tilt scroll
+ ((memq button (list mouse-wheel-right-event
+ mouse-wheel-right-alternate-event)) ; for tilt scroll
(when mouse-wheel-tilt-scroll
(funcall (if mouse-wheel-flip-direction
mwheel-scroll-left-function
@@ -378,9 +424,11 @@ value of ARG, and the command uses it in subsequent scrolls."
(button (mwheel-event-button event)))
(select-window scroll-window 'mark-for-redisplay)
(unwind-protect
- (cond ((eq button mouse-wheel-down-event)
+ (cond ((memq button (list mouse-wheel-down-event
+ mouse-wheel-down-alternate-event))
(text-scale-increase 1))
- ((eq button mouse-wheel-up-event)
+ ((memq button (list mouse-wheel-up-event
+ mouse-wheel-up-alternate-event))
(text-scale-decrease 1)))
(select-window selected-window))))
@@ -432,15 +480,23 @@ an event used for scrolling, such as `mouse-wheel-down-event'."
(cond
;; 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--add-binding `[,(list (caar binding) event)]
- 'mouse-wheel-text-scale)))
+ (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
+ mouse-wheel-down-alternate-event
+ mouse-wheel-up-alternate-event))
+ (when event
+ (mouse-wheel--add-binding `[,(list (caar binding) event)]
+ 'mouse-wheel-text-scale))))
;; Bindings for scrolling.
(t
(dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
- mouse-wheel-left-event mouse-wheel-right-event))
- (dolist (key (mouse-wheel--create-scroll-keys binding event))
- (mouse-wheel--add-binding key 'mwheel-scroll)))))))
+ 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))
+ (when event
+ (dolist (key (mouse-wheel--create-scroll-keys binding event))
+ (mouse-wheel--add-binding key 'mwheel-scroll))))))))
(when mouse-wheel-mode
(mouse-wheel--setup-bindings))
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el
index 2585833e1d4..a6c256eeba8 100644
--- a/lisp/net/ange-ftp.el
+++ b/lisp/net/ange-ftp.el
@@ -1230,8 +1230,9 @@ only return the directory part of FILE."
;; found another machine with the same user.
;; Try that account.
(read-passwd
- (format "passwd for %s@%s (default same as %s@%s): "
- user host user other)
+ (format-prompt "passwd for %s@%s"
+ (format "same as %s@%s" user other)
+ user host)
nil
(ange-ftp-lookup-passwd other user))
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index 4ae56864c55..b7840f05890 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -39,6 +39,7 @@
;; browse-url-chrome Chrome 47.0.2526.111
;; browse-url-chromium Chromium 3.0
;; browse-url-epiphany GNOME Web (Epiphany) Don't know
+;; browse-url-webpositive WebPositive 1.2-alpha (Haiku R1/beta3)
;; browse-url-w3 w3 0
;; browse-url-text-* Any text browser 0
;; browse-url-generic arbitrary
@@ -156,6 +157,7 @@
(function-item :tag "Google Chrome" :value browse-url-chrome)
(function-item :tag "Chromium" :value browse-url-chromium)
(function-item :tag "GNOME Web (Epiphany)" :value browse-url-epiphany)
+ (function-item :tag "WebPositive" :value browse-url-webpositive)
(function-item :tag "Text browser in an xterm window"
:value browse-url-text-xterm)
(function-item :tag "Text browser in an Emacs window"
@@ -219,7 +221,7 @@ be used instead."
(defcustom browse-url-button-regexp
(concat
- "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|"
+ "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|gemini\\|"
"nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)"
"\\(//[-a-z0-9_.]+:[0-9]*\\)?"
(let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]")
@@ -238,33 +240,6 @@ be used instead."
:version "27.1"
:type 'regexp)
-(defcustom browse-url-netscape-program "netscape"
- ;; Info about netscape-remote from Karl Berry.
- "The name by which to invoke Netscape.
-
-The free program `netscape-remote' from
-<URL:http://home.netscape.com/newsref/std/remote.c> is said to start
-up very much quicker than `netscape'. Reported to compile on a GNU
-system, given vroot.h from the same directory, with cc flags
- -DSTANDALONE -L/usr/X11R6/lib -lXmu -lX11."
- :type 'string)
-
-(make-obsolete-variable 'browse-url-netscape-program nil "25.1")
-
-(defcustom browse-url-netscape-arguments nil
- "A list of strings to pass to Netscape as arguments."
- :type '(repeat (string :tag "Argument")))
-
-(make-obsolete-variable 'browse-url-netscape-arguments nil "25.1")
-
-(defcustom browse-url-netscape-startup-arguments browse-url-netscape-arguments
- "A list of strings to pass to Netscape when it starts up.
-Defaults to the value of `browse-url-netscape-arguments' at the time
-`browse-url' is loaded."
- :type '(repeat (string :tag "Argument")))
-
-(make-obsolete-variable 'browse-url-netscape-startup-arguments nil "25.1")
-
(defcustom browse-url-browser-display nil
"The X display for running the browser, if not same as Emacs's."
:type '(choice string (const :tag "Default" nil)))
@@ -283,11 +258,13 @@ Defaults to the value of `browse-url-mozilla-arguments' at the time
`browse-url' is loaded."
:type '(repeat (string :tag "Argument")))
+(defun browse-url--find-executable (candidates default)
+ (while (and candidates (not (executable-find (car candidates))))
+ (setq candidates (cdr candidates)))
+ (or (car candidates) default))
+
(defcustom browse-url-firefox-program
- (let ((candidates '("icecat" "iceweasel" "firefox")))
- (while (and candidates (not (executable-find (car candidates))))
- (setq candidates (cdr candidates)))
- (or (car candidates) "firefox"))
+ (browse-url--find-executable '("icecat" "iceweasel") "firefox")
"The name by which to invoke Firefox or a variant of it."
:type 'string)
@@ -305,10 +282,8 @@ Defaults to the value of `browse-url-firefox-arguments' at the time
"it no longer has any effect." "24.5")
(defcustom browse-url-chrome-program
- (let ((candidates '("google-chrome-stable" "google-chrome")))
- (while (and candidates (not (executable-find (car candidates))))
- (setq candidates (cdr candidates)))
- (or (car candidates) "chromium"))
+ (browse-url--find-executable '("google-chrome-stable" "google-chrome")
+ "chromium")
"The name by which to invoke the Chrome browser."
:type 'string
:version "25.1")
@@ -319,10 +294,7 @@ Defaults to the value of `browse-url-firefox-arguments' at the time
:version "25.1")
(defcustom browse-url-chromium-program
- (let ((candidates '("chromium" "chromium-browser")))
- (while (and candidates (not (executable-find (car candidates))))
- (setq candidates (cdr candidates)))
- (or (car candidates) "chromium"))
+ (browse-url--find-executable '("chromium" "chromium-browser") "chromium")
"The name by which to invoke Chromium."
:type 'string
:version "24.1")
@@ -332,26 +304,6 @@ Defaults to the value of `browse-url-firefox-arguments' at the time
:type '(repeat (string :tag "Argument"))
:version "24.1")
-(defcustom browse-url-galeon-program "galeon"
- "The name by which to invoke Galeon."
- :type 'string)
-
-(make-obsolete-variable 'browse-url-galeon-program nil "25.1")
-
-(defcustom browse-url-galeon-arguments nil
- "A list of strings to pass to Galeon as arguments."
- :type '(repeat (string :tag "Argument")))
-
-(make-obsolete-variable 'browse-url-galeon-arguments nil "25.1")
-
-(defcustom browse-url-galeon-startup-arguments browse-url-galeon-arguments
- "A list of strings to pass to Galeon when it starts up.
-Defaults to the value of `browse-url-galeon-arguments' at the time
-`browse-url' is loaded."
- :type '(repeat (string :tag "Argument")))
-
-(make-obsolete-variable 'browse-url-galeon-startup-arguments nil "25.1")
-
(defcustom browse-url-epiphany-program "epiphany"
"The name by which to invoke GNOME Web (Epiphany)."
:type 'string)
@@ -366,7 +318,12 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time
`browse-url' is loaded."
:type '(repeat (string :tag "Argument")))
-;; GNOME means of invoking either Mozilla or Netscape.
+(defcustom browse-url-webpositive-program "WebPositive"
+ "The name by which to invoke WebPositive."
+ :type 'string
+ :version "29.1")
+
+;; GNOME means of invoking Mozilla.
(defvar browse-url-gnome-moz-program "gnome-moz-remote")
(make-obsolete-variable 'browse-url-gnome-moz-program nil "25.1")
@@ -399,29 +356,12 @@ If non-nil, then open the URL in a new buffer rather than a new window if
(make-obsolete-variable 'browse-url-conkeror-new-window-is-buffer nil "28.1")
-(defcustom browse-url-galeon-new-window-is-tab nil
- "Whether to open up new windows in a tab or a new window.
-If non-nil, then open the URL in a new tab rather than a new window if
-`browse-url-galeon' is asked to open it in a new window."
- :type 'boolean)
-
-(make-obsolete-variable 'browse-url-galeon-new-window-is-tab nil "25.1")
-
(defcustom browse-url-epiphany-new-window-is-tab nil
"Whether to open up new windows in a tab or a new window.
If non-nil, then open the URL in a new tab rather than a new window if
`browse-url-epiphany' is asked to open it in a new window."
:type 'boolean)
-(defcustom browse-url-netscape-new-window-is-tab nil
- "Whether to open up new windows in a tab or a new window.
-If non-nil, then open the URL in a new tab rather than a new
-window if `browse-url-netscape' is asked to open it in a new
-window."
- :type 'boolean)
-
-(make-obsolete-variable 'browse-url-netscape-new-window-is-tab nil "25.1")
-
(defcustom browse-url-new-window-flag nil
"Non-nil means always open a new browser window with appropriate browsers.
Passing an interactive argument to \\[browse-url], or specific browser
@@ -518,14 +458,6 @@ You might want to set this to somewhere with restricted read permissions
for privacy's sake."
:type 'string)
-(defcustom browse-url-netscape-version 3
- "The version of Netscape you are using.
-This affects how URL reloading is done; the mechanism changed
-incompatibly at version 4."
- :type 'number)
-
-(make-obsolete-variable 'browse-url-netscape-version nil "25.1")
-
(defcustom browse-url-text-browser "lynx"
"The name of the text browser to invoke."
:type 'string
@@ -730,8 +662,7 @@ position clicked before acting.
This function returns a list (URL NEW-WINDOW-FLAG)
for use in `interactive'."
(let ((event (elt (this-command-keys) 0)))
- (when (mouse-event-p event)
- (mouse-set-point event)))
+ (mouse-set-point event))
(list (read-string prompt (or (and transient-mark-mode mark-active
;; rfc2396 Appendix E.
(replace-regexp-in-string
@@ -856,6 +787,8 @@ See `browse-url' for details."
;; A generic command to call the current browse-url-browser-function
+(declare-function pgtk-backend-display-class "pgtkfns.c" (&optional terminal))
+
;;;###autoload
(defun browse-url (url &rest args)
"Open URL using a configurable method.
@@ -893,8 +826,17 @@ If ARGS are omitted, the default is to pass
;; When connected to various displays, be careful to use the display of
;; the currently selected frame, rather than the original start display,
;; which may not even exist any more.
- (if (stringp (frame-parameter nil 'display))
- (setenv "DISPLAY" (frame-parameter nil 'display)))
+ (let ((dpy (frame-parameter nil 'display))
+ classname)
+ (if (stringp dpy)
+ (cond
+ ((featurep 'pgtk)
+ (setq classname (pgtk-backend-display-class))
+ (if (equal classname "GdkWaylandDisplay")
+ (setenv "WAYLAND_DISPLAY" dpy)
+ (setenv "DISPLAY" dpy)))
+ (t
+ (setenv "DISPLAY" dpy)))))
(if (functionp function)
(apply function url args)
(error "No suitable browser for URL %s" url))))
@@ -1003,8 +945,6 @@ The optional NEW-WINDOW argument is not used."
(function-put 'browse-url-default-macosx-browser 'browse-url-browser-kind
'external)
-;; --- Netscape ---
-
(defun browse-url-process-environment ()
"Set DISPLAY in the environment to the X display the browser will use.
This is either the value of variable `browse-url-browser-display' if
@@ -1047,10 +987,9 @@ instead of `browse-url-new-window-flag'."
((executable-find browse-url-mozilla-program) 'browse-url-mozilla)
((executable-find browse-url-firefox-program) 'browse-url-firefox)
((executable-find browse-url-chromium-program) 'browse-url-chromium)
-;;; ((executable-find browse-url-galeon-program) 'browse-url-galeon)
((executable-find browse-url-kde-program) 'browse-url-kde)
-;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape)
((executable-find browse-url-chrome-program) 'browse-url-chrome)
+ ((executable-find browse-url-webpositive-program) 'browse-url-webpositive)
((executable-find browse-url-xterm-program) 'browse-url-text-xterm)
((locate-library "w3") 'browse-url-w3)
(t
@@ -1083,82 +1022,6 @@ The optional argument IGNORED is not used."
(function-put 'browse-url-xdg-open 'browse-url-browser-kind 'external)
;;;###autoload
-(defun browse-url-netscape (url &optional new-window)
- "Ask the Netscape WWW browser to load URL.
-Default to the URL around or before point. The strings in variable
-`browse-url-netscape-arguments' are also passed to Netscape.
-
-When called interactively, if variable `browse-url-new-window-flag' is
-non-nil, load the document in a new Netscape window, otherwise use a
-random existing one. A non-nil interactive prefix argument reverses
-the effect of `browse-url-new-window-flag'.
-
-If `browse-url-netscape-new-window-is-tab' is non-nil, then
-whenever a document would otherwise be loaded in a new window, it
-is loaded in a new tab in an existing window instead.
-
-When called non-interactively, optional second argument NEW-WINDOW is
-used instead of `browse-url-new-window-flag'."
- (declare (obsolete nil "25.1"))
- (interactive (browse-url-interactive-arg "URL: "))
- (setq url (browse-url-encode-url url))
- (let* ((process-environment (browse-url-process-environment))
- (process
- (apply #'start-process
- (concat "netscape " url) nil
- browse-url-netscape-program
- (append
- browse-url-netscape-arguments
- (if (eq window-system 'w32)
- (list url)
- (append
- (if new-window '("-noraise"))
- (list "-remote"
- (concat "openURL(" url
- (if (browse-url-maybe-new-window
- new-window)
- (if browse-url-netscape-new-window-is-tab
- ",new-tab"
- ",new-window"))
- ")"))))))))
- (set-process-sentinel process
- (lambda (process _change)
- (browse-url-netscape-sentinel process url)))))
-
-(function-put 'browse-url-netscape 'browse-url-browser-kind 'external)
-
-(defun browse-url-netscape-sentinel (process url)
- "Handle a change to the process communicating with Netscape."
- (declare (obsolete nil "25.1"))
- (or (eq (process-exit-status process) 0)
- (let* ((process-environment (browse-url-process-environment)))
- ;; Netscape not running - start it
- (message "Starting %s..." browse-url-netscape-program)
- (apply #'start-process (concat "netscape" url) nil
- browse-url-netscape-program
- (append browse-url-netscape-startup-arguments (list url))))))
-
-(defun browse-url-netscape-reload ()
- "Ask Netscape to reload its current document.
-How depends on `browse-url-netscape-version'."
- (declare (obsolete nil "25.1"))
- (interactive)
- ;; Backwards incompatibility reported by
- ;; <peter.kruse@psychologie.uni-regensburg.de>.
- (browse-url-netscape-send (if (>= browse-url-netscape-version 4)
- "xfeDoCommand(reload)"
- "reload")))
-
-(defun browse-url-netscape-send (command)
- "Send a remote control command to Netscape."
- (declare (obsolete nil "25.1"))
- (let* ((process-environment (browse-url-process-environment)))
- (apply #'start-process "netscape" nil
- browse-url-netscape-program
- (append browse-url-netscape-arguments
- (list "-remote" command)))))
-
-;;;###autoload
(defun browse-url-mozilla (url &optional new-window)
"Ask the Mozilla WWW browser to load URL.
Default to the URL around or before point. The strings in variable
@@ -1278,56 +1141,6 @@ The optional argument NEW-WINDOW is not used."
(function-put 'browse-url-chrome 'browse-url-browser-kind 'external)
-;;;###autoload
-(defun browse-url-galeon (url &optional new-window)
- "Ask the Galeon WWW browser to load URL.
-Default to the URL around or before point. The strings in variable
-`browse-url-galeon-arguments' are also passed to Galeon.
-
-When called interactively, if variable `browse-url-new-window-flag' is
-non-nil, load the document in a new Galeon window, otherwise use a
-random existing one. A non-nil interactive prefix argument reverses
-the effect of `browse-url-new-window-flag'.
-
-If `browse-url-galeon-new-window-is-tab' is non-nil, then whenever a
-document would otherwise be loaded in a new window, it is loaded in a
-new tab in an existing window instead.
-
-When called non-interactively, optional second argument NEW-WINDOW is
-used instead of `browse-url-new-window-flag'."
- (declare (obsolete nil "25.1"))
- (interactive (browse-url-interactive-arg "URL: "))
- (setq url (browse-url-encode-url url))
- (let* ((process-environment (browse-url-process-environment))
- (process (apply #'start-process
- (concat "galeon " url)
- nil
- browse-url-galeon-program
- (append
- browse-url-galeon-arguments
- (if (browse-url-maybe-new-window new-window)
- (if browse-url-galeon-new-window-is-tab
- '("--new-tab")
- '("--new-window" "--noraise"))
- '("--existing"))
- (list url)))))
- (set-process-sentinel process
- (lambda (process _change)
- (browse-url-galeon-sentinel process url)))))
-
-(function-put 'browse-url-galeon 'browse-url-browser-kind 'external)
-
-(defun browse-url-galeon-sentinel (process url)
- "Handle a change to the process communicating with Galeon."
- (declare (obsolete nil "25.1"))
- (or (eq (process-exit-status process) 0)
- (let* ((process-environment (browse-url-process-environment)))
- ;; Galeon is not running - start it
- (message "Starting %s..." browse-url-galeon-program)
- (apply #'start-process (concat "galeon " url) nil
- browse-url-galeon-program
- (append browse-url-galeon-startup-arguments (list url))))))
-
(defun browse-url-epiphany (url &optional new-window)
"Ask the GNOME Web (Epiphany) WWW browser to load URL.
Default to the URL around or before point. The strings in variable
@@ -1378,6 +1191,18 @@ used instead of `browse-url-new-window-flag'."
(defvar url-handler-regexp)
;;;###autoload
+(defun browse-url-webpositive (url &optional _new-window)
+ "Ask the WebPositive WWW browser to load URL.
+Default to the URL around or before point.
+The optional argument NEW-WINDOW is not used."
+ (interactive (browse-url-interactive-arg "URL: "))
+ (setq url (browse-url-encode-url url))
+ (let* ((process-environment (browse-url-process-environment)))
+ (start-process (concat "WebPositive " url) nil "WebPositive" url)))
+
+(function-put 'browse-url-webpositive '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.
Optional argument SAME-WINDOW non-nil means show the URL in the
@@ -1399,7 +1224,7 @@ currently selected window instead."
;;;###autoload
(defun browse-url-gnome-moz (url &optional new-window)
- "Ask Mozilla/Netscape to load URL via the GNOME program `gnome-moz-remote'.
+ "Ask Mozilla to load URL via the GNOME program `gnome-moz-remote'.
Default to the URL around or before point. The strings in variable
`browse-url-gnome-moz-arguments' are also passed.
diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index 560ece67517..411249767f5 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -2102,7 +2102,7 @@ has been handled by this function."
(interface (dbus-event-interface-name event))
(member (dbus-event-member-name event))
(arguments (dbus-event-arguments event))
- (time (time-to-seconds (current-time))))
+ (time (float-time)))
(save-excursion
;; Check for matching method-call.
(goto-char (point-max))
@@ -2252,15 +2252,19 @@ keywords `:system-private' or `:session-private', respectively."
bus nil dbus-path-local dbus-interface-local
"Disconnected" #'dbus-handle-bus-disconnect)))
-
-;; Initialize `:system' and `:session' buses. This adds their file
-;; descriptors to input_wait_mask, in order to detect incoming
-;; messages immediately.
-(when (featurep 'dbusbind)
- (dbus-ignore-errors
- (dbus-init-bus :system))
- (dbus-ignore-errors
- (dbus-init-bus :session)))
+
+(defun dbus--init ()
+ ;; Initialize `:system' and `:session' buses. This adds their file
+ ;; descriptors to input_wait_mask, in order to detect incoming
+ ;; messages immediately.
+ (when (featurep 'dbusbind)
+ (dbus-ignore-errors
+ (dbus-init-bus :system))
+ (dbus-ignore-errors
+ (dbus-init-bus :session))))
+
+(add-hook 'after-pdump-load-hook #'dbus--init)
+(dbus--init)
(provide 'dbus)
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el
index 14e5c28b2dc..62c2913b50a 100644
--- a/lisp/net/eudc.el
+++ b/lisp/net/eudc.el
@@ -46,16 +46,9 @@
;;; Code:
(require 'wid-edit)
-
(require 'cl-lib)
-
-(unless (fboundp 'custom-menu-create)
- (autoload 'custom-menu-create "cus-edit"))
-
(require 'eudc-vars)
-
-
;;{{{ Internal cooking
;;{{{ Internal variables and compatibility tricks
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 238900db0c3..8930eb427d2 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -178,6 +178,40 @@ the tab bar is enabled."
:group 'eww
:type 'hook)
+(defcustom eww-auto-rename-buffer nil
+ "Automatically rename EWW buffers once the page is rendered.
+
+When nil, do not rename the buffer. With a non-nil value
+determine the renaming scheme, as follows:
+
+- `title': Use the web page's title.
+- `url': Use the web page's URL.
+- a function's symbol: Run a user-defined function that returns a
+ string with which to rename the buffer. Sample of a
+ user-defined function:
+
+ (defun my-eww-rename-buffer ()
+ (when (eq major-mode 'eww-mode)
+ (when-let ((string (or (plist-get eww-data :title)
+ (plist-get eww-data :url))))
+ (format \"*%s*\" string))))
+
+The string of `title' and `url' is always truncated to the value
+of `eww-buffer-name-length'."
+ :version "29.1"
+ :type '(choice
+ (const :tag "Do not rename buffers (default)" nil)
+ (const :tag "Rename buffer to web page title" title)
+ (const :tag "Rename buffer to web page URL" url)
+ (function :tag "A user-defined function to rename the buffer"))
+ :group 'eww)
+
+(defcustom eww-buffer-name-length 40
+ "Length of renamed buffer name, per `eww-auto-rename-buffer'."
+ :type 'natnum
+ :version "29.1"
+ :group 'eww)
+
(defcustom eww-form-checkbox-selected-symbol "[X]"
"Symbol used to represent a selected checkbox.
See also `eww-form-checkbox-symbol'."
@@ -197,8 +231,15 @@ See also `eww-form-checkbox-selected-symbol'."
(const "☐") ; Unicode BALLOT BOX
string))
+(defcustom eww-url-transformers '(eww-remove-tracking)
+ "This is a list of transforming functions applied to an URL before usage.
+The functions will be called with the URL as the single
+parameter, and should return the (possibly) transformed URL."
+ :type '(repeat function)
+ :version "29.1")
+
(defface eww-form-submit
- '((((type x w32 ns) (class color)) ; Like default mode line
+ '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "#808080" :foreground "black"))
"Face for eww buffer buttons."
@@ -206,7 +247,7 @@ See also `eww-form-checkbox-selected-symbol'."
:group 'eww)
(defface eww-form-file
- '((((type x w32 ns) (class color)) ; Like default mode line
+ '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "#808080" :foreground "black"))
"Face for eww buffer buttons."
@@ -214,7 +255,7 @@ See also `eww-form-checkbox-selected-symbol'."
:group 'eww)
(defface eww-form-checkbox
- '((((type x w32 ns) (class color)) ; Like default mode line
+ '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "lightgrey" :foreground "black"))
"Face for eww buffer buttons."
@@ -222,7 +263,7 @@ See also `eww-form-checkbox-selected-symbol'."
:group 'eww)
(defface eww-form-select
- '((((type x w32 ns) (class color)) ; Like default mode line
+ '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "lightgrey" :foreground "black"))
"Face for eww buffer buttons."
@@ -271,15 +312,13 @@ See also `eww-form-checkbox-selected-symbol'."
"text/html, text/plain, text/sgml, text/css, application/xhtml+xml, */*;q=0.01"
"Value used for the HTTP 'Accept' header.")
-(defvar eww-link-keymap
- (let ((map (copy-keymap shr-map)))
- (define-key map "\r" 'eww-follow-link)
- map))
+(defvar-keymap eww-link-keymap
+ :parent shr-map
+ "RET" #'eww-follow-link)
-(defvar eww-image-link-keymap
- (let ((map (copy-keymap shr-image-map)))
- (define-key map "\r" 'eww-follow-link)
- map))
+(defvar-keymap eww-image-link-keymap
+ :parent shr-map
+ "RET" #'eww-follow-link)
(defun eww-suggested-uris nil
"Return the list of URIs to suggest at the `eww' prompt.
@@ -313,13 +352,13 @@ will start Emacs and browse the GNU web site."
;;;###autoload
-(defun eww (url &optional arg buffer)
+(defun eww (url &optional new-buffer buffer)
"Fetch URL and render the page.
If the input doesn't look like an URL or a domain name, the
word(s) will be searched for via `eww-search-prefix'.
-If called with a prefix ARG, use a new buffer instead of reusing
-the default EWW buffer.
+If NEW-BUFFER is non-nil (interactively, the prefix arg), use a
+new buffer instead of reusing the default EWW buffer.
If BUFFER, the data to be rendered is in that buffer. In that
case, this function doesn't actually fetch URL. BUFFER will be
@@ -329,11 +368,11 @@ killed after rendering."
(list (read-string (format-prompt "Enter URL or keywords"
(and uris (car uris)))
nil 'eww-prompt-history uris)
- (prefix-numeric-value current-prefix-arg))))
+ current-prefix-arg)))
(setq url (eww--dwim-expand-url url))
(pop-to-buffer-same-window
(cond
- ((eq arg 4)
+ (new-buffer
(generate-new-buffer "*eww*"))
((eq major-mode 'eww-mode)
(current-buffer))
@@ -353,9 +392,10 @@ killed after rendering."
(while (string-match "\\`/[.][.]/" (url-filename parsed))
(setf (url-filename parsed) (substring (url-filename parsed) 3))))
(setq url (url-recreate-url parsed)))
+ (setq url (eww--transform-url url))
(plist-put eww-data :url url)
(plist-put eww-data :title "")
- (eww-update-header-line-format)
+ (eww--after-page-change)
(let ((inhibit-read-only t))
(insert (format "Loading %s..." url))
(goto-char (point-min)))
@@ -504,6 +544,30 @@ Currently this means either text/html or application/xhtml+xml."
(member content-type '("text/html"
"application/xhtml+xml")))
+(defun eww--rename-buffer ()
+ "Rename the current EWW buffer.
+The renaming scheme is performed in accordance with
+`eww-auto-rename-buffer'."
+ (let ((rename-string)
+ (formatter
+ (lambda (string)
+ (format "*%s # eww*" (truncate-string-to-width
+ string eww-buffer-name-length))))
+ (site-title (plist-get eww-data :title))
+ (site-url (plist-get eww-data :url)))
+ (cond ((null eww-auto-rename-buffer))
+ ((eq eww-auto-rename-buffer 'url)
+ (setq rename-string (funcall formatter site-url)))
+ ((functionp eww-auto-rename-buffer)
+ (setq rename-string (funcall eww-auto-rename-buffer)))
+ (t (setq rename-string
+ (funcall formatter (if (or (equal site-title "")
+ (null site-title))
+ "Untitled"
+ site-title)))))
+ (when rename-string
+ (rename-buffer rename-string t))))
+
(defun eww-render (status url &optional point buffer encode)
(let* ((headers (eww-parse-headers))
(content-type
@@ -554,7 +618,7 @@ Currently this means either text/html or application/xhtml+xml."
(eww-display-raw buffer (or encode charset 'utf-8))))
(with-current-buffer buffer
(plist-put eww-data :url url)
- (eww-update-header-line-format)
+ (eww--after-page-change)
(setq eww-history-position 0)
(and last-coding-system-used
(set-buffer-file-coding-system last-coding-system-used))
@@ -638,14 +702,15 @@ Currently this means either text/html or application/xhtml+xml."
(meta . eww-tag-meta)
(a . eww-tag-a)))))
(erase-buffer)
- (shr-insert-document document)
+ (with-delayed-message (2 "Rendering HTML...")
+ (shr-insert-document document))
(cond
(point
(goto-char point))
(shr-target-id
(goto-char (point-min))
(let ((match (text-property-search-forward
- 'shr-target-id shr-target-id t)))
+ 'shr-target-id shr-target-id #'member)))
(when match
(goto-char (prop-match-beginning match)))))
(t
@@ -798,12 +863,16 @@ Currently this means either text/html or application/xhtml+xml."
`((?u . ,(or url ""))
(?t . ,title))))))))
+(defun eww--after-page-change ()
+ (eww-update-header-line-format)
+ (eww--rename-buffer))
+
(defun eww-tag-title (dom)
(plist-put eww-data :title
(replace-regexp-in-string
"^ \\| $" ""
(replace-regexp-in-string "[ \t\r\n]+" " " (dom-text dom))))
- (eww-update-header-line-format))
+ (eww--after-page-change))
(defun eww-display-raw (buffer &optional encode)
(let ((data (buffer-substring (point) (point-max))))
@@ -931,7 +1000,7 @@ the like."
nil (current-buffer))
(dolist (elem '(:source :url :title :next :previous :up))
(plist-put eww-data elem (plist-get old-data elem)))
- (eww-update-header-line-format)))
+ (eww--after-page-change)))
(defun eww-score-readability (node)
(let ((score -1))
@@ -973,67 +1042,67 @@ the like."
(setq result highest))))
result))
-(defvar eww-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "g" 'eww-reload) ;FIXME: revert-buffer-function instead!
- (define-key map "G" 'eww)
- (define-key map [?\M-\r] 'eww-open-in-new-buffer)
- (define-key map [?\t] 'shr-next-link)
- (define-key map [?\M-\t] 'shr-previous-link)
- (define-key map [backtab] 'shr-previous-link)
- (define-key map [delete] 'scroll-down-command)
- (define-key map "l" 'eww-back-url)
- (define-key map "r" 'eww-forward-url)
- (define-key map "n" 'eww-next-url)
- (define-key map "p" 'eww-previous-url)
- (define-key map "u" 'eww-up-url)
- (define-key map "t" 'eww-top-url)
- (define-key map "&" 'eww-browse-with-external-browser)
- (define-key map "d" 'eww-download)
- (define-key map "w" 'eww-copy-page-url)
- (define-key map "C" 'url-cookie-list)
- (define-key map "v" 'eww-view-source)
- (define-key map "R" 'eww-readable)
- (define-key map "H" 'eww-list-histories)
- (define-key map "E" 'eww-set-character-encoding)
- (define-key map "s" 'eww-switch-to-buffer)
- (define-key map "S" 'eww-list-buffers)
- (define-key map "F" 'eww-toggle-fonts)
- (define-key map "D" 'eww-toggle-paragraph-direction)
- (define-key map [(meta C)] 'eww-toggle-colors)
- (define-key map [(meta I)] 'eww-toggle-images)
-
- (define-key map "b" 'eww-add-bookmark)
- (define-key map "B" 'eww-list-bookmarks)
- (define-key map [(meta n)] 'eww-next-bookmark)
- (define-key map [(meta p)] 'eww-previous-bookmark)
-
- (easy-menu-define nil map ""
- '("Eww"
- ["Exit" quit-window t]
- ["Close browser" quit-window t]
- ["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)))]
- ["Forward to next page" eww-forward-url
- :active (not (zerop eww-history-position))]
- ["Browse with external browser" eww-browse-with-external-browser t]
- ["Download" eww-download t]
- ["View page source" eww-view-source]
- ["Copy page URL" eww-copy-page-url t]
- ["List histories" eww-list-histories t]
- ["Switch to buffer" eww-switch-to-buffer t]
- ["List buffers" eww-list-buffers t]
- ["Add bookmark" eww-add-bookmark t]
- ["List bookmarks" eww-list-bookmarks t]
- ["List cookies" url-cookie-list t]
- ["Toggle fonts" eww-toggle-fonts t]
- ["Toggle colors" eww-toggle-colors t]
- ["Toggle images" eww-toggle-images t]
- ["Character Encoding" eww-set-character-encoding]
- ["Toggle Paragraph Direction" eww-toggle-paragraph-direction]))
- map))
+(defvar-keymap eww-mode-map
+ "g" #'eww-reload ;FIXME: revert-buffer-function instead!
+ "G" #'eww
+ "M-RET" #'eww-open-in-new-buffer
+ "TAB" #'shr-next-link
+ "C-M-i" #'shr-previous-link
+ "<backtab>" #'shr-previous-link
+ "<delete>" #'scroll-down-command
+ "l" #'eww-back-url
+ "r" #'eww-forward-url
+ "n" #'eww-next-url
+ "p" #'eww-previous-url
+ "u" #'eww-up-url
+ "t" #'eww-top-url
+ "&" #'eww-browse-with-external-browser
+ "d" #'eww-download
+ "w" #'eww-copy-page-url
+ "C" #'url-cookie-list
+ "v" #'eww-view-source
+ "R" #'eww-readable
+ "H" #'eww-list-histories
+ "E" #'eww-set-character-encoding
+ "s" #'eww-switch-to-buffer
+ "S" #'eww-list-buffers
+ "F" #'eww-toggle-fonts
+ "D" #'eww-toggle-paragraph-direction
+ "M-C" #'eww-toggle-colors
+ "M-I" #'eww-toggle-images
+
+ "b" #'eww-add-bookmark
+ "B" #'eww-list-bookmarks
+ "M-n" #'eww-next-bookmark
+ "M-p" #'eww-previous-bookmark
+
+ "<mouse-8>" #'eww-back-url
+ "<mouse-9>" #'eww-forward-url
+
+ :menu '("Eww"
+ ["Exit" quit-window t]
+ ["Close browser" quit-window t]
+ ["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)))]
+ ["Forward to next page" eww-forward-url
+ :active (not (zerop eww-history-position))]
+ ["Browse with external browser" eww-browse-with-external-browser t]
+ ["Download" eww-download t]
+ ["View page source" eww-view-source]
+ ["Copy page URL" eww-copy-page-url t]
+ ["List histories" eww-list-histories t]
+ ["Switch to buffer" eww-switch-to-buffer t]
+ ["List buffers" eww-list-buffers t]
+ ["Add bookmark" eww-add-bookmark t]
+ ["List bookmarks" eww-list-bookmarks t]
+ ["List cookies" url-cookie-list t]
+ ["Toggle fonts" eww-toggle-fonts t]
+ ["Toggle colors" eww-toggle-colors t]
+ ["Toggle images" eww-toggle-images t]
+ ["Character Encoding" eww-set-character-encoding]
+ ["Toggle Paragraph Direction" eww-toggle-paragraph-direction]))
(defun eww-context-menu (menu click)
"Populate MENU with eww commands at CLICK."
@@ -1166,7 +1235,7 @@ instead of `browse-url-new-window-flag'."
(goto-char (plist-get elem :point))
;; Make buffer listings more informative.
(setq list-buffers-directory (plist-get elem :url))
- (eww-update-header-line-format))))
+ (eww--after-page-change))))
(defun eww-next-url ()
"Go to the page marked `next'.
@@ -1230,54 +1299,43 @@ just re-display the HTML already fetched."
(defvar eww-form nil)
-(defvar eww-submit-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\r" 'eww-submit)
- (define-key map [(control c) (control c)] 'eww-submit)
- map))
-
-(defvar eww-submit-file
- (let ((map (make-sparse-keymap)))
- (define-key map "\r" 'eww-select-file)
- (define-key map [(control c) (control c)] 'eww-submit)
- map))
-
-(defvar eww-checkbox-map
- (let ((map (make-sparse-keymap)))
- (define-key map " " 'eww-toggle-checkbox)
- (define-key map "\r" 'eww-toggle-checkbox)
- (define-key map [(control c) (control c)] 'eww-submit)
- map))
-
-(defvar eww-text-map
- (let ((map (make-keymap)))
- (set-keymap-parent map text-mode-map)
- (define-key map "\r" 'eww-submit)
- (define-key map [(control a)] 'eww-beginning-of-text)
- (define-key map [(control c) (control c)] 'eww-submit)
- (define-key map [(control e)] 'eww-end-of-text)
- (define-key map [?\t] 'shr-next-link)
- (define-key map [?\M-\t] 'shr-previous-link)
- (define-key map [backtab] 'shr-previous-link)
- map))
-
-(defvar eww-textarea-map
- (let ((map (make-keymap)))
- (set-keymap-parent map text-mode-map)
- (define-key map "\r" 'forward-line)
- (define-key map [(control c) (control c)] 'eww-submit)
- (define-key map [?\t] 'shr-next-link)
- (define-key map [?\M-\t] 'shr-previous-link)
- (define-key map [backtab] 'shr-previous-link)
- map))
-
-(defvar eww-select-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\r" 'eww-change-select)
- (define-key map [follow-link] 'mouse-face)
- (define-key map [mouse-2] 'eww-change-select)
- (define-key map [(control c) (control c)] 'eww-submit)
- map))
+(defvar-keymap eww-submit-map
+ "RET" #'eww-submit
+ "C-c C-c" #'eww-submit)
+
+(defvar-keymap eww-submit-file
+ "RET" #'eww-select-file
+ "C-c C-c" #'eww-submit)
+
+(defvar-keymap eww-checkbox-map
+ "SPC" #'eww-toggle-checkbox
+ "RET" #'eww-toggle-checkbox
+ "C-c C-c" #'eww-submit)
+
+(defvar-keymap eww-text-map
+ :full t :parent text-mode-map
+ "RET" #'eww-submit
+ "C-a" #'eww-beginning-of-text
+ "C-c C-c" #'eww-submit
+ "C-e" #'eww-end-of-text
+ "TAB" #'shr-next-link
+ "M-TAB" #'shr-previous-link
+ "<backtab>" #'shr-previous-link)
+
+(defvar-keymap eww-textarea-map
+ :full t :parent text-mode-map
+ "RET" #'forward-line
+ "C-c C-c" #'eww-submit
+ "TAB" #'shr-next-link
+ "M-TAB" #'shr-previous-link
+ "<backtab>" #'shr-previous-link)
+
+(defvar-keymap eww-select-map
+ :doc "Map for select buttons"
+ "RET" #'eww-change-select
+ "<follow-link>" 'mouse-face
+ "<mouse-2>" #'eww-change-select
+ "C-c C-c" #'eww-submit)
(defun eww-beginning-of-text ()
"Move to the start of the input field."
@@ -1784,6 +1842,17 @@ The browser to used is specified by the
(funcall browse-url-secondary-browser-function
(or url (plist-get eww-data :url))))
+(defun eww-remove-tracking (url)
+ "Remove the commong utm_ tracking cookies from URLs."
+ (replace-regexp-in-string ".utm_.*" "" url))
+
+(defun eww--transform-url (url)
+ "Appy `eww-url-transformers'."
+ (when url
+ (dolist (func eww-url-transformers)
+ (setq url (funcall func url)))
+ url))
+
(defun eww-follow-link (&optional external mouse-event)
"Browse the URL under point.
If EXTERNAL is single prefix, browse the URL using
@@ -1794,7 +1863,8 @@ If EXTERNAL is double prefix, browse in new buffer."
(list current-prefix-arg last-nonmenu-event)
eww-mode)
(mouse-set-point mouse-event)
- (let ((url (get-text-property (point) 'shr-url)))
+ (let* ((orig-url (get-text-property (point) 'shr-url))
+ (url (eww--transform-url orig-url)))
(cond
((not url)
(message "No link under point"))
@@ -1813,7 +1883,7 @@ If EXTERNAL is double prefix, browse in new buffer."
(plist-put eww-data :url url)
(eww-display-html 'utf-8 url dom nil (current-buffer))))
(t
- (eww-browse-url url external)))))
+ (eww-browse-url orig-url external)))))
(defun eww-same-page-p (url1 url2)
"Return non-nil if URL1 and URL2 represent the same page.
@@ -2100,23 +2170,18 @@ If ERROR-OUT, signal user-error if there are no bookmarks."
'eww-bookmark)))
(eww-browse-url (plist-get bookmark :url))))
-(defvar eww-bookmark-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [(control k)] 'eww-bookmark-kill)
- (define-key map [(control y)] 'eww-bookmark-yank)
- (define-key map "\r" 'eww-bookmark-browse)
-
- (easy-menu-define nil map
- "Menu for `eww-bookmark-mode-map'."
- '("Eww Bookmark"
- ["Exit" quit-window t]
- ["Browse" eww-bookmark-browse
- :active (get-text-property (line-beginning-position) 'eww-bookmark)]
- ["Kill" eww-bookmark-kill
- :active (get-text-property (line-beginning-position) 'eww-bookmark)]
- ["Yank" eww-bookmark-yank
- :active eww-bookmark-kill-ring]))
- map))
+(defvar-keymap eww-bookmark-mode-map
+ "C-k" #'eww-bookmark-kill
+ "C-y" #'eww-bookmark-yank
+ "RET" #'eww-bookmark-browse
+ :menu '("Eww Bookmark"
+ ["Exit" quit-window t]
+ ["Browse" eww-bookmark-browse
+ :active (get-text-property (line-beginning-position) 'eww-bookmark)]
+ ["Kill" eww-bookmark-kill
+ :active (get-text-property (line-beginning-position) 'eww-bookmark)]
+ ["Yank" eww-bookmark-yank
+ :active eww-bookmark-kill-ring]))
(define-derived-mode eww-bookmark-mode special-mode "eww bookmarks"
"Mode for listing bookmarks.
@@ -2181,19 +2246,15 @@ If ERROR-OUT, signal user-error if there are no bookmarks."
(pop-to-buffer-same-window buffer)))
(eww-restore-history history)))
-(defvar eww-history-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\r" 'eww-history-browse)
- (define-key map "n" 'next-line)
- (define-key map "p" 'previous-line)
-
- (easy-menu-define nil map
- "Menu for `eww-history-mode-map'."
- '("Eww History"
- ["Exit" quit-window t]
- ["Browse" eww-history-browse
- :active (get-text-property (line-beginning-position) 'eww-history)]))
- map))
+(defvar-keymap eww-history-mode-map
+ "RET" #'eww-history-browse
+ "n" #'next-line
+ "p" #'previous-line
+ :menu '("Eww History"
+ ["Exit" quit-window t]
+ ["Browse" eww-history-browse
+ :active (get-text-property (line-beginning-position)
+ 'eww-history)]))
(define-derived-mode eww-history-mode special-mode "eww history"
"Mode for listing eww-histories.
@@ -2304,22 +2365,18 @@ If ERROR-OUT, signal user-error if there are no bookmarks."
(forward-line -1))
(eww-buffer-show))
-(defvar eww-buffers-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [(control k)] 'eww-buffer-kill)
- (define-key map "\r" 'eww-buffer-select)
- (define-key map "n" 'eww-buffer-show-next)
- (define-key map "p" 'eww-buffer-show-previous)
-
- (easy-menu-define nil map
- "Menu for `eww-buffers-mode-map'."
- '("Eww Buffers"
- ["Exit" quit-window t]
- ["Select" eww-buffer-select
- :active (get-text-property (line-beginning-position) 'eww-buffer)]
- ["Kill" eww-buffer-kill
- :active (get-text-property (line-beginning-position) 'eww-buffer)]))
- map))
+(defvar-keymap eww-buffers-mode-map
+ "C-k" #'eww-buffer-kill
+ "RET" #'eww-buffer-select
+ "n" #'eww-buffer-show-next
+ "p" #'eww-buffer-show-previous
+ :menu '("Eww Buffers"
+ ["Exit" quit-window t]
+ ["Select" eww-buffer-select
+ :active (get-text-property (line-beginning-position) 'eww-buffer)]
+ ["Kill" eww-buffer-kill
+ :active (get-text-property (line-beginning-position)
+ 'eww-buffer)]))
(define-derived-mode eww-buffers-mode special-mode "eww buffers"
"Mode for listing buffers.
diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el
index 5af6d4324ae..5778857ff80 100644
--- a/lisp/net/hmac-def.el
+++ b/lisp/net/hmac-def.el
@@ -37,6 +37,7 @@ a string and return a digest of it (in binary form).
B is a byte length of a block size of H. (B=64 for both SHA1 and MD5.)
L is a byte length of hash outputs. (L=16 for MD5, L=20 for SHA1.)
If BIT is non-nil, truncate output to specified bits."
+ (declare (indent defun))
`(defun ,name (text key)
,(concat "Compute "
(upcase (symbol-name name))
diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el
index 83d0eeef9f1..14d49251f55 100644
--- a/lisp/net/mailcap.el
+++ b/lisp/net/mailcap.el
@@ -55,7 +55,7 @@ you have an entry for \"image/*\" in your ~/.mailcap file."
"A syntax table for parsing SGML attributes.")
(defvar mailcap-print-command
- (mapconcat 'identity
+ (mapconcat #'identity
(cons (if (boundp 'lpr-command)
lpr-command
"lpr")
@@ -116,8 +116,7 @@ is consulted."
(regexp :tag "MIME Type")
(sexp :tag "Test (optional)")))
:get #'mailcap--get-user-mime-data
- :set #'mailcap--set-user-mime-data
- :group 'mailcap)
+ :set #'mailcap--set-user-mime-data)
;; Postpone using defcustom for this as it's so big and we essentially
;; have to have two copies of the data around then. Perhaps just
@@ -344,8 +343,7 @@ Same format as `mailcap-mime-data'.")
"Directory to which `mailcap-save-binary-file' downloads files by default.
nil means your home directory."
:type '(choice (const :tag "Home directory" nil)
- directory)
- :group 'mailcap)
+ directory))
(defvar mailcap-poor-system-types
'(ms-dos windows-nt)
@@ -423,14 +421,6 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus
(interactive (list nil t))
(when (or (not mailcap-parsed-p)
force)
- ;; Clear out all old data.
- (setq mailcap--computed-mime-data nil)
- ;; Add the Emacs-distributed defaults (which will be used as
- ;; fallbacks). Do it this way instead of just copying the list,
- ;; since entries are destructively modified.
- (cl-loop for (major . minors) in mailcap-mime-data
- do (cl-loop for (minor . entry) in minors
- do (mailcap-add-mailcap-entry major minor entry)))
(cond
(path nil)
((getenv "MAILCAPS")
@@ -447,18 +437,26 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus
("/etc/mailcap" system)
("/usr/etc/mailcap" system)
("/usr/local/etc/mailcap" system)))))
- ;; The ~/.mailcap entries will end up first in the resulting data.
- (dolist (spec (reverse
- (if (stringp path)
- (split-string path path-separator t)
- path)))
- (let ((source (and (consp spec) (cadr spec)))
- (file-name (if (stringp spec)
- spec
- (car spec))))
- (when (and (file-readable-p file-name)
- (file-regular-p file-name))
- (mailcap-parse-mailcap file-name source))))
+ (when (stringp path)
+ (setq path (mapcar #'list (split-string path path-separator t))))
+ (when (seq-some (lambda (f)
+ (file-has-changed-p (car f) 'mail-parse-mailcaps))
+ path)
+ ;; Clear out all old data.
+ (setq mailcap--computed-mime-data nil)
+ ;; Add the Emacs-distributed defaults (which will be used as
+ ;; fallbacks). Do it this way instead of just copying the list,
+ ;; since entries are destructively modified.
+ (cl-loop for (major . minors) in mailcap-mime-data
+ do (cl-loop for (minor . entry) in minors
+ do (mailcap-add-mailcap-entry major minor entry)))
+ ;; The ~/.mailcap entries will end up first in the resulting data.
+ (dolist (spec (reverse path))
+ (let ((source (cadr spec))
+ (file-name (car spec)))
+ (when (and (file-readable-p file-name)
+ (file-regular-p file-name))
+ (mailcap-parse-mailcap file-name source)))))
(setq mailcap-parsed-p t)))
(defun mailcap-parse-mailcap (fname &optional source)
@@ -636,7 +634,7 @@ the test clause will be unchanged."
((and (listp test) (symbolp (car test))) test)
((or (stringp test)
(and (listp test) (stringp (car test))
- (setq test (mapconcat 'identity test " "))))
+ (setq test (mapconcat #'identity test " "))))
(with-temp-buffer
(insert test)
(goto-char (point-min))
@@ -707,12 +705,12 @@ to supply to the test."
(symbol-value test))
((and (listp test) ; List to be eval'd
(symbolp (car test)))
- (eval test))
+ (eval test t))
(t
(setq test (mailcap-unescape-mime-test test type-info)
test (list shell-file-name nil nil nil
shell-command-switch test)
- status (apply 'call-process test))
+ status (apply #'call-process test))
(eq 0 status))))
(push (list otest result) mailcap-viewer-test-cache)
result))))
@@ -837,7 +835,7 @@ If NO-DECODE is non-nil, don't decode STRING."
(dolist (entry viewers)
(when (mailcap-viewer-passes-test entry info)
(push entry passed)))
- (setq passed (sort (nreverse passed) 'mailcap-viewer-lessp))
+ (setq passed (sort (nreverse passed) #'mailcap-viewer-lessp))
;; When we want to prefer entries from the user's
;; ~/.mailcap file, then we filter out the system entries
;; and see whether we have anything left.
@@ -1065,12 +1063,21 @@ For instance, \"foo.png\" will result in \"image/png\"."
(match-string 1 file-name)
"")))
+;;;###autoload
+(defun mailcap-mime-type-to-extension (mime-type)
+ "Return a file name extension based on a MIME-TYPE.
+For instance, `image/png' will result in `png'."
+ (intern (cadr (split-string (if (symbolp mime-type)
+ (symbol-name mime-type)
+ mime-type)
+ "/"))))
+
(defun mailcap-mime-types ()
"Return a list of MIME media types."
(mailcap-parse-mimetypes)
(delete-dups
(nconc
- (mapcar 'cdr mailcap-mime-extensions)
+ (mapcar #'cdr mailcap-mime-extensions)
(let (res type)
(dolist (data mailcap--computed-mime-data)
(dolist (info (cdr data))
diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el
index 03a297ca41f..d51f8c0189f 100644
--- a/lisp/net/newst-backend.el
+++ b/lisp/net/newst-backend.el
@@ -402,13 +402,6 @@ headline after it has been retrieved for the first time."
"Miscellaneous newsticker settings."
:group 'newsticker)
-(defcustom newsticker-cache-filename
- "~/.newsticker-cache"
- "Name of the newsticker cache file."
- :type 'string
- :group 'newsticker-miscellaneous)
-(make-obsolete-variable 'newsticker-cache-filename 'newsticker-dir "23.1")
-
(defcustom newsticker-dir
(locate-user-emacs-file "newsticker/" ".newsticker/")
"Directory where newsticker saves data."
@@ -2114,28 +2107,6 @@ well."
(throw 'result t)))))
(< (or (newsticker--pos item1) 0) (or (newsticker--pos item2) 0))))
-(defun newsticker--cache-save-version1 ()
- "Update and save newsticker cache file."
- (interactive)
- (newsticker--cache-update t))
-
-(defun newsticker--cache-update (&optional save)
- "Update newsticker cache file.
-If optional argument SAVE is not nil the cache file is saved to disk."
- (save-excursion
- (unless (file-directory-p newsticker-dir)
- (make-directory newsticker-dir t))
- (let ((coding-system-for-write 'utf-8)
- (buf (find-file-noselect newsticker-cache-filename)))
- (when buf
- (set-buffer buf)
- (setq buffer-undo-list t)
- (erase-buffer)
- (insert ";; -*- coding: utf-8 -*-\n")
- (insert (prin1-to-string newsticker--cache))
- (when save
- (save-buffer))))))
-
(defun newsticker--cache-get-feed (feed)
"Return the cached data for the feed FEED.
FEED is a symbol!"
@@ -2162,30 +2133,11 @@ FEED is a symbol!"
(insert ";; -*- coding: utf-8 -*-\n")
(insert (prin1-to-string (cdr feed)))))))
-(defun newsticker--cache-read-version1 ()
- "Read version1 cache data."
- (let ((coding-system-for-read 'utf-8))
- (when (file-exists-p newsticker-cache-filename)
- (with-temp-buffer
- (insert-file-contents newsticker-cache-filename)
- (goto-char (point-min))
- (condition-case nil
- (setq newsticker--cache (read (current-buffer)))
- (error
- (message "Error while reading newsticker cache file!")
- (setq newsticker--cache nil)))))))
-
(defun newsticker--cache-read ()
"Read cache data."
(setq newsticker--cache nil)
- (if (file-exists-p newsticker-cache-filename)
- (progn
- (when (y-or-n-p "Old newsticker cache file exists. Read it? ")
- (newsticker--cache-read-version1))
- (when (y-or-n-p "Delete old newsticker cache file? ")
- (delete-file newsticker-cache-filename)))
- (dolist (f (append newsticker-url-list-defaults newsticker-url-list))
- (newsticker--cache-read-feed (car f)))))
+ (dolist (f (append newsticker-url-list-defaults newsticker-url-list))
+ (newsticker--cache-read-feed (car f))))
(defun newsticker--cache-read-feed (feed-name)
"Read cache data for feed named FEED-NAME."
diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el
index 420cf82e4d8..82977b000b6 100644
--- a/lisp/net/newst-plainview.el
+++ b/lisp/net/newst-plainview.el
@@ -589,7 +589,7 @@ calls `w3m-toggle-inline-image'. It works only if
(defun newsticker-close-buffer ()
"Close the newsticker buffer."
(interactive)
- (newsticker--cache-update t)
+ (newsticker--cache-save)
(bury-buffer))
(defun newsticker-next-new-item (&optional do-not-wrap-at-eob)
@@ -748,7 +748,7 @@ Return new buffer position."
(newsticker--cache-replace-age newsticker--cache feed 'new 'old)
(newsticker--cache-replace-age newsticker--cache feed 'obsolete
'old)
- (newsticker--cache-update)
+ (newsticker--cache-save)
(newsticker--buffer-set-uptodate nil)
(newsticker--ticker-text-setup)
(newsticker-buffer-update)
@@ -879,7 +879,7 @@ not get changed."
(newsticker--cache-replace-age newsticker--cache 'any 'new 'old)
(newsticker--buffer-set-uptodate nil)
(newsticker--ticker-text-setup)
- (newsticker--cache-update)
+ (newsticker--cache-save)
(newsticker-buffer-update)))
(defun newsticker-hide-extra ()
diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el
index 2ac1df1d58a..b067b23f8ff 100644
--- a/lisp/net/nsm.el
+++ b/lisp/net/nsm.el
@@ -79,8 +79,7 @@ option."
(const :tag "Off" nil)
(function :tag "Custom function")))
-(defcustom nsm-settings-file (expand-file-name "network-security.data"
- user-emacs-directory)
+(defcustom nsm-settings-file (locate-user-emacs-file "network-security.data")
"The file the security manager settings will be stored in."
:version "25.1"
:type 'file)
diff --git a/lisp/net/puny.el b/lisp/net/puny.el
index 42a7e796798..c1833ffdb0b 100644
--- a/lisp/net/puny.el
+++ b/lisp/net/puny.el
@@ -43,6 +43,7 @@ For instance, \"fśf.org\" => \"xn--ff-2sa.org\"."
"Encode STRING according to the IDNA/punycode algorithm.
This is used to encode non-ASCII domain names.
For instance, \"bücher\" => \"xn--bcher-kva\"."
+ (setq string (downcase (string-glyph-compose string)))
(let ((ascii (seq-filter (lambda (char)
(< char 128))
string)))
diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el
index 5c92c60eda2..2375b14cca2 100644
--- a/lisp/net/rcirc.el
+++ b/lisp/net/rcirc.el
@@ -262,6 +262,7 @@ The ARGUMENTS for each METHOD symbol are:
`bitlbee': NICK PASSWORD
`quakenet': ACCOUNT PASSWORD
`sasl': NICK PASSWORD
+ `certfp': KEY CERT
Examples:
((\"Libera.Chat\" nickserv \"bob\" \"p455w0rd\")
@@ -291,7 +292,11 @@ Examples:
(list :tag "SASL"
(const sasl)
(string :tag "Nick")
- (string :tag "Password")))))
+ (string :tag "Password"))
+ (list :tag "CertFP"
+ (const certfp)
+ (string :tag "Key")
+ (string :tag "Certificate")))))
(defcustom rcirc-auto-authenticate-flag t
"Non-nil means automatically send authentication string to server.
@@ -547,6 +552,9 @@ If ARG is non-nil, instead prompt for connection parameters."
(password (plist-get (cdr c) :password))
(encryption (plist-get (cdr c) :encryption))
(server-alias (plist-get (cdr c) :server-alias))
+ (client-cert (when (eq (rcirc-get-server-method (car c))
+ 'certfp)
+ (rcirc-get-server-cert (car c))))
contact)
(when-let (((not password))
(auth (auth-source-search :host server
@@ -563,7 +571,7 @@ If ARG is non-nil, instead prompt for connection parameters."
(condition-case nil
(let ((process (rcirc-connect server port nick user-name
full-name channels password encryption
- server-alias)))
+ client-cert server-alias)))
(when rcirc-display-server-buffer
(pop-to-buffer-same-window (process-buffer process))))
(quit (message "Quit connecting to %s"
@@ -646,29 +654,23 @@ See `rcirc-connect' for more details on these variables.")
(defun rcirc-get-server-method (server)
"Return authentication method for SERVER."
- (catch 'method
- (dolist (i rcirc-authinfo)
- (let ((server-i (car i))
- (method (cadr i)))
- (when (string-match server-i server)
- (throw 'method method))))))
+ (cadr (assoc server rcirc-authinfo #'string-match)))
(defun rcirc-get-server-password (server)
"Return password for SERVER."
- (catch 'pass
- (dolist (i rcirc-authinfo)
- (let ((server-i (car i))
- (args (cdddr i)))
- (when (string-match server-i server)
- (throw 'pass (car args)))))))
+ (cadddr (assoc server rcirc-authinfo #'string-match)))
+
+(defun rcirc-get-server-cert (server)
+ "Return a list of key and certificate for SERVER."
+ (cddr (assoc server rcirc-authinfo #'string-match)))
;;;###autoload
(defun rcirc-connect (server &optional port nick user-name
full-name startup-channels password encryption
- server-alias)
+ certfp server-alias)
"Connect to SERVER.
The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD,
-ENCRYPTION, SERVER-ALIAS are interpreted as in
+ENCRYPTION, CERTFP, SERVER-ALIAS are interpreted as in
`rcirc-server-alist'. STARTUP-CHANNELS is a list of channels
that are joined after authentication."
(save-excursion
@@ -695,6 +697,7 @@ that are joined after authentication."
(setq process (open-network-stream
(or server-alias server) nil server port-number
:type (or encryption 'plain)
+ :client-certificate certfp
:nowait t))
(set-process-coding-system process 'raw-text 'raw-text)
(with-current-buffer (get-buffer-create (rcirc-generate-new-buffer-name process nil))
@@ -713,8 +716,8 @@ that are joined after authentication."
(setq rcirc-nick-table (make-hash-table :test 'equal))
(setq rcirc-nick nick)
(setq rcirc-startup-channels startup-channels)
- (setq rcirc-last-server-message-time (current-time))
(setq rcirc-last-connect-time (current-time))
+ (setq rcirc-last-server-message-time rcirc-last-connect-time)
;; Check if the immediate process state
(sit-for .1)
diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el
index b7f814f7237..0a3ecf9f534 100644
--- a/lisp/net/sasl.el
+++ b/lisp/net/sasl.el
@@ -174,21 +174,24 @@ It contain at least 64 bits of entropy."
;; stolen (and renamed) from message.el
(defun sasl-unique-id-function ()
- ;; Don't use microseconds from (current-time), they may be unsupported.
+ ;; Don't use fractional seconds from timestamp; they may be unsupported.
;; Instead we use this randomly inited counter.
(setq sasl-unique-id-char
- (% (1+ (or sasl-unique-id-char (logand (random) (1- (ash 1 20)))))
- ;; (current-time) returns 16-bit ints,
- ;; and 2^16*25 just fits into 4 digits i base 36.
- (* 25 25)))
- (let ((tm (current-time)))
+ ;; 2^16 * 25 just fits into 4 digits i base 36.
+ (let ((base (* 25 25)))
+ (if sasl-unique-id-char
+ (% (1+ sasl-unique-id-char) base)
+ (random base))))
+ (let ((tm (time-convert nil 'integer)))
(concat
(sasl-unique-id-number-base36
- (+ (car tm)
- (ash (% sasl-unique-id-char 25) 16)) 4)
+ (+ (ash tm -16)
+ (ash (% sasl-unique-id-char 25) 16))
+ 4)
(sasl-unique-id-number-base36
- (+ (nth 1 tm)
- (ash (/ sasl-unique-id-char 25) 16)) 4))))
+ (+ (logand tm #xffff)
+ (ash (/ sasl-unique-id-char 25) 16))
+ 4))))
(defun sasl-unique-id-number-base36 (num len)
(if (if (< len 0)
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 48590fd675a..44fb5ec6e9a 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -40,6 +40,7 @@
(require 'image)
(require 'puny)
(require 'url-cookie)
+(require 'pixel-fill)
(require 'text-property-search)
(defgroup shr nil
@@ -56,8 +57,15 @@ fit these criteria."
:version "24.1"
:type 'float)
+(defcustom shr-allowed-images nil
+ "If non-nil, only images that match this regexp are displayed.
+If nil, all URLs are allowed. Also see `shr-blocked-images'."
+ :version "29.1"
+ :type '(choice (const nil) regexp))
+
(defcustom shr-blocked-images nil
- "Images that have URLs matching this regexp will be blocked."
+ "Images that have URLs matching this regexp will be blocked.
+If nil, no images are blocked. Also see `shr-allowed-images'."
:version "24.1"
:type '(choice (const nil) regexp))
@@ -162,6 +170,10 @@ cid: URL as the argument.")
(defvar shr-put-image-function #'shr-put-image
"Function called to put image and alt string.")
+(defface shr-text '((t :inherit variable-pitch-text))
+ "Face used for rendering text."
+ :version "29.1")
+
(defface shr-strike-through '((t :strike-through t))
"Face for <s> elements."
:version "24.1")
@@ -183,6 +195,11 @@ temporarily blinks with this face."
"Face for <abbr> elements."
:version "27.1")
+(defface shr-sup
+ '((t :height 0.8))
+ "Face for <sup> and <sub> elements."
+ :version "29.1")
+
(defface shr-h1
'((t :height 1.3 :weight bold))
"Face for <h1> elements."
@@ -231,7 +248,6 @@ and other things:
(defvar shr-internal-width nil)
(defvar shr-list-mode nil)
(defvar shr-content-cache nil)
-(defvar shr-kinsoku-shorten nil)
(defvar shr-table-depth 0)
(defvar shr-stylesheet nil)
(defvar shr-base nil)
@@ -246,24 +262,23 @@ and other things:
(defvar shr-target-id nil
"Target fragment identifier anchor.")
-
-(defvar shr-map
- (let ((map (make-sparse-keymap)))
- (define-key map "a" #'shr-show-alt-text)
- (define-key map "i" #'shr-browse-image)
- (define-key map "z" #'shr-zoom-image)
- (define-key map [?\t] #'shr-next-link)
- (define-key map [?\M-\t] #'shr-previous-link)
- (define-key map [follow-link] 'mouse-face)
- (define-key map [mouse-2] #'shr-browse-url)
- (define-key map [C-down-mouse-1] #'shr-mouse-browse-url-new-window)
- (define-key map "I" #'shr-insert-image)
- (define-key map "w" #'shr-maybe-probe-and-copy-url)
- (define-key map "u" #'shr-maybe-probe-and-copy-url)
- (define-key map "v" #'shr-browse-url)
- (define-key map "O" #'shr-save-contents)
- (define-key map "\r" #'shr-browse-url)
- map))
+(defvar shr--link-targets nil)
+
+(defvar-keymap shr-map
+ "a" #'shr-show-alt-text
+ "i" #'shr-browse-image
+ "z" #'shr-zoom-image
+ "TAB" #'shr-next-link
+ "C-M-i" #'shr-previous-link
+ "<follow-link>" 'mouse-face
+ "<mouse-2>" #'shr-browse-url
+ "C-<down-mouse-1>" #'shr-mouse-browse-url-new-window
+ "I" #'shr-insert-image
+ "w" #'shr-maybe-probe-and-copy-url
+ "u" #'shr-maybe-probe-and-copy-url
+ "v" #'shr-browse-url
+ "O" #'shr-save-contents
+ "RET" #'shr-browse-url)
(defvar shr-image-map
(let ((map (copy-keymap shr-map)))
@@ -305,6 +320,18 @@ and other things:
(or (not (zerop (fringe-columns 'right)))
(not (zerop (fringe-columns 'left))))))
+(defun shr--window-width ()
+ ;; Compute the width based on the window width. We need to
+ ;; adjust the available width for when the user disables
+ ;; the fringes, which will cause the display engine usurp
+ ;; one column for the continuation glyph.
+ (if (not shr-use-fonts)
+ (- (window-body-width) 1
+ (if (shr--have-one-fringe-p)
+ 1
+ 0))
+ (pixel-fill-width)))
+
;;;###autoload
(defun shr-insert-document (dom)
"Render the parsed document DOM into the current buffer.
@@ -326,22 +353,9 @@ DOM should be a parse tree as generated by
(if (not shr-use-fonts)
shr-width
(* shr-width (frame-char-width)))
- ;; Compute the width based on the window width. We need to
- ;; adjust the available width for when the user disables
- ;; the fringes, which will cause the display engine usurp
- ;; one column for the continuation glyph.
- (if (not shr-use-fonts)
- (- (window-body-width) 1
- (if (shr--have-one-fringe-p)
- 1
- 0))
- (- (window-body-width nil t)
- (* 2 (frame-char-width))
- (if (shr--have-one-fringe-p)
- 0
- (* (frame-char-width) 2))
- 1))))
+ (shr--window-width)))
(max-specpdl-size max-specpdl-size)
+ (shr--link-targets nil)
;; `bidi-display-reordering' is supposed to be only used for
;; debugging purposes, but Shr's naïve filling algorithm
;; cannot cope with the complexity of RTL text in an LTR
@@ -365,9 +379,22 @@ DOM should be a parse tree as generated by
(shr-descend dom)
(shr-fill-lines start (point))
(shr--remove-blank-lines-at-the-end start (point))
+ (shr--set-target-ids shr--link-targets)
(when shr-warning
(message "%s" shr-warning))))
+(defun shr--set-target-ids (ids)
+ ;; If the buffer is empty, there's no point in setting targets.
+ (unless (zerop (buffer-size))
+ ;; We may have several targets in the same place (if you have
+ ;; several <span id='foo'> things after one another). So group
+ ;; them by position.
+ (dolist (group (seq-group-by #'cdr ids))
+ (let ((point (min (1- (point-max)) (car group))))
+ (put-text-property point (1+ point)
+ 'shr-target-id
+ (mapcar #'car (cdr group)))))))
+
(defun shr--remove-blank-lines-at-the-end (start end)
(save-restriction
(save-excursion
@@ -547,6 +574,12 @@ size, and full-buffer size."
(shr-insert sub)
(shr-descend sub))))
+(defun shr-image-blocked-p (url)
+ (or (and shr-blocked-images
+ (string-match shr-blocked-images url))
+ (and shr-allowed-images
+ (not (string-match shr-allowed-images url)))))
+
(defun shr-indirect-call (tag-name dom &rest args)
(let ((function (intern (concat "shr-tag-" (symbol-name tag-name)) obarray))
;; Allow other packages to override (or provide) rendering
@@ -577,7 +610,7 @@ size, and full-buffer size."
(setq shr-warning
"Not rendering the complete page because of too-deep nesting")
(when style
- (if (string-match "color\\|display\\|border-collapse" style)
+ (if (string-match-p "color\\|display\\|border-collapse" style)
(setq shr-stylesheet (nconc (shr-parse-style style)
shr-stylesheet))
(setq style nil)))
@@ -596,16 +629,8 @@ size, and full-buffer size."
(funcall function dom))
(t
(shr-generic dom)))
- (when-let* ((id (dom-attr dom 'id)))
- ;; If the element was empty, we don't have anything to put the
- ;; anchor on. So just insert a dummy character.
- (when (= start (point))
- (if (not (bolp))
- (insert ? )
- (insert ? )
- (shr-mark-fill start))
- (put-text-property (1- (point)) (point) 'display ""))
- (put-text-property (1- (point)) (point) 'shr-target-id id))
+ (when-let ((id (dom-attr dom 'id)))
+ (push (cons id (point)) shr--link-targets))
;; If style is set, then this node has set the color.
(when style
(shr-colorize-region
@@ -619,43 +644,11 @@ size, and full-buffer size."
(with-temp-buffer
(let ((shr-indentation 0)
(shr-start nil)
- (shr-internal-width (- (window-body-width nil t)
- (* 2 (frame-char-width))
- ;; Adjust the window width for when
- ;; the user disables the fringes,
- ;; which causes the display engine
- ;; to usurp one column for the
- ;; continuation glyph.
- (if (and (null shr-width)
- (not (shr--have-one-fringe-p)))
- (* (frame-char-width) 2)
- 0))))
+ (shr-internal-width (shr--window-width)))
(shr-insert text)
(shr-fill-lines (point-min) (point-max))
(buffer-string)))))
-(define-inline shr-char-breakable-p (char)
- "Return non-nil if a line can be broken before and after CHAR."
- (inline-quote (aref fill-find-break-point-function-table ,char)))
-(define-inline shr-char-nospace-p (char)
- "Return non-nil if no space is required before and after CHAR."
- (inline-quote (aref fill-nospace-between-words-table ,char)))
-
-;; KINSOKU is a Japanese word meaning a rule that should not be violated.
-;; In Emacs, it is a term used for characters, e.g. punctuation marks,
-;; parentheses, and so on, that should not be placed in the beginning
-;; of a line or the end of a line.
-(define-inline shr-char-kinsoku-bol-p (char)
- "Return non-nil if a line ought not to begin with CHAR."
- (inline-letevals (char)
- (inline-quote (and (not (eq ,char ?'))
- (aref (char-category-set ,char) ?>)))))
-(define-inline shr-char-kinsoku-eol-p (char)
- "Return non-nil if a line ought not to end with CHAR."
- (inline-quote (aref (char-category-set ,char) ?<)))
-(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
- (load "kinsoku" nil t))
-
(defun shr-pixel-column ()
(if (not shr-use-fonts)
(current-column)
@@ -669,6 +662,7 @@ size, and full-buffer size."
(car (window-text-pixel-size nil (line-beginning-position) (point))))))
(defun shr-pixel-region ()
+ (declare (obsolete nil "29.1"))
(- (shr-pixel-column)
(save-excursion
(goto-char (mark))
@@ -711,7 +705,7 @@ size, and full-buffer size."
(goto-char (point-max)))))
(t
(let ((font-start (point)))
- (when (and (string-match "\\`[ \t\n\r]" text)
+ (when (and (string-match-p "\\`[ \t\n\r]" text)
(not (bolp))
(not (eq (char-after (1- (point))) ? )))
(insert " "))
@@ -739,7 +733,7 @@ size, and full-buffer size."
(when shr-use-fonts
(put-text-property font-start (point)
'face
- (or shr-current-font 'variable-pitch)))))))))
+ (or shr-current-font 'shr-text)))))))))
(defun shr-fill-lines (start end)
(if (<= shr-internal-width 0)
@@ -788,7 +782,7 @@ size, and full-buffer size."
(while (not (eolp))
;; We have to do some folding. First find the first
;; previous point suitable for folding.
- (if (or (not (shr-find-fill-point (line-beginning-position)))
+ (if (or (not (pixel-fill-find-fill-point (line-beginning-position)))
(= (point) start))
;; We had unbreakable text (for this width), so just go to
;; the first space and carry on.
@@ -829,84 +823,6 @@ size, and full-buffer size."
(when (looking-at " $")
(delete-region (point) (line-end-position)))))))
-(defun shr-find-fill-point (start)
- (let ((bp (point))
- (end (point))
- failed)
- (while (not (or (setq failed (<= (point) start))
- (eq (preceding-char) ? )
- (eq (following-char) ? )
- (shr-char-breakable-p (preceding-char))
- (shr-char-breakable-p (following-char))
- (and (shr-char-kinsoku-bol-p (preceding-char))
- (shr-char-breakable-p (following-char))
- (not (shr-char-kinsoku-bol-p (following-char))))
- (shr-char-kinsoku-eol-p (following-char))
- (bolp)))
- (backward-char 1))
- (if failed
- ;; There's no breakable point, so we give it up.
- (let (found)
- (goto-char bp)
- ;; Don't overflow the window edge, even if
- ;; shr-kinsoku-shorten is nil.
- (unless (or shr-kinsoku-shorten (null shr-width))
- (while (setq found (re-search-forward
- "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
- (line-end-position) 'move)))
- (if (and found
- (not (match-beginning 1)))
- (goto-char (match-beginning 0)))))
- (or
- (eolp)
- ;; Don't put kinsoku-bol characters at the beginning of a line,
- ;; or kinsoku-eol characters at the end of a line.
- (cond
- ;; Don't overflow the window edge, even if shr-kinsoku-shorten
- ;; is nil.
- ((or shr-kinsoku-shorten (null shr-width))
- (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
- (or (shr-char-kinsoku-eol-p (preceding-char))
- (shr-char-kinsoku-bol-p (following-char))))
- (backward-char 1))
- (when (setq failed (<= (point) start))
- ;; There's no breakable point that doesn't violate kinsoku,
- ;; so we look for the second best position.
- (while (and (progn
- (forward-char 1)
- (<= (point) end))
- (progn
- (setq bp (point))
- (shr-char-kinsoku-eol-p (following-char)))))
- (goto-char bp)))
- ((shr-char-kinsoku-eol-p (preceding-char))
- ;; Find backward the point where kinsoku-eol characters begin.
- (let ((count 4))
- (while
- (progn
- (backward-char 1)
- (and (> (setq count (1- count)) 0)
- (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
- (or (shr-char-kinsoku-eol-p (preceding-char))
- (shr-char-kinsoku-bol-p (following-char)))))))
- (when (setq failed (<= (point) start))
- ;; There's no breakable point that doesn't violate kinsoku,
- ;; so we go to the second best position.
- (if (looking-at "\\(\\c<+\\)\\c<")
- (goto-char (match-end 1))
- (forward-char 1))))
- ((shr-char-kinsoku-bol-p (following-char))
- ;; Find forward the point where kinsoku-bol characters end.
- (let ((count 4))
- (while (progn
- (forward-char 1)
- (and (>= (setq count (1- count)) 0)
- (shr-char-kinsoku-bol-p (following-char))
- (shr-char-breakable-p (following-char))))))))
- (when (eq (following-char) ? )
- (forward-char 1))))
- (not failed)))
-
(defun shr-parse-base (url)
;; Always chop off anchors.
(when (string-match "#.*" url)
@@ -947,7 +863,7 @@ size, and full-buffer size."
(cond ((zerop (length url))
(nth 3 base))
((or (not base)
- (string-match "\\`[a-z]*:" url))
+ (string-match-p "\\`[a-z]*:" url))
;; Absolute or empty URI
url)
((eq (aref url 0) ?/)
@@ -984,22 +900,6 @@ size, and full-buffer size."
(looking-at " *$")))
;; We're already at a new paragraph; do nothing.
)
- ((and (not (bolp))
- (save-excursion
- (beginning-of-line)
- (looking-at " *$"))
- (save-excursion
- (forward-line -1)
- (looking-at " *$"))
- ;; Check all chars on the current line and see whether
- ;; they're all placeholders.
- (cl-loop for pos from (line-beginning-position) upto (1- (point))
- unless (get-text-property pos 'shr-target-id)
- return nil
- finally return t))
- ;; We have some invisible markers from <div id="foo"></div>;
- ;; do nothing.
- )
((and prefix
(= prefix (- (point) (line-beginning-position))))
;; Do nothing; we're at the start of a <li>.
@@ -1132,14 +1032,14 @@ the mouse click event."
(let ((param (match-string 4 data))
(payload (url-unhex-string (match-string 5 data))))
(when (and param
- (string-match "^.*\\(;[ \t]*base64\\)$" param))
+ (string-match-p "^.*\\(;[ \t]*base64\\)$" param))
(setq payload (ignore-errors
(base64-decode-string payload))))
payload)))
;; Behind display-graphic-p test.
(declare-function image-size "image.c" (spec &optional pixels frame))
-(declare-function image-animate "image" (image &optional index limit))
+(declare-function image-animate "image" (image &optional index limit position))
(defun shr-put-image (spec alt &optional flags)
"Insert image SPEC with a string ALT. Return image.
@@ -1176,13 +1076,14 @@ element is the data blob and the second element is the content-type."
(when (and (> (current-column) 0)
(> (car (image-size image t)) 400))
(insert "\n"))
- (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)))
+ (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))))
image)
(insert (or alt ""))))
@@ -1268,7 +1169,7 @@ Return a string with image data."
;; SVG images may contain references to further images that we may
;; want to block. So special-case these by parsing the XML data
;; and remove anything that looks like a blocked bit.
- (when (and shr-blocked-images
+ (when (and (or shr-allowed-images shr-blocked-images)
(eq content-type 'image/svg+xml))
(setq data
;; Note that libxml2 doesn't parse everything perfectly,
@@ -1447,8 +1348,7 @@ ones, in case fg and bg are nil."
((or (not (eq (dom-tag elem) 'image))
;; Filter out blocked elements inside the SVG image.
(not (setq url (dom-attr elem ':xlink:href)))
- (not shr-blocked-images)
- (not (string-match shr-blocked-images url)))
+ (not (shr-image-blocked-p url)))
(insert " ")
(shr-dom-print elem)))))
(insert (format "</%s>" (dom-tag dom))))
@@ -1465,12 +1365,14 @@ ones, in case fg and bg are nil."
(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 0.2))
+ (add-face-text-property start (point) 'shr-sup)))
(defun shr-tag-sub (dom)
(let ((start (point)))
(shr-generic dom)
- (put-text-property start (point) 'display '(raise -0.2))))
+ (put-text-property start (point) 'display '(raise -0.2))
+ (add-face-text-property start (point) 'shr-sup)))
(defun shr-tag-p (dom)
(shr-ensure-paragraph)
@@ -1532,9 +1434,7 @@ ones, in case fg and bg are nil."
(defun shr-parse-style (style)
(when style
- (save-match-data
- (when (string-match "\n" style)
- (setq style (replace-match " " t t style))))
+ (setq style (replace-regexp-in-string "\n" " " style))
(let ((plist nil))
(dolist (elem (split-string style ";"))
(when elem
@@ -1563,13 +1463,9 @@ ones, in case fg and bg are nil."
(start (point))
shr-start)
(shr-generic dom)
- (when-let* ((id (unless (dom-attr dom 'id) ; Handled by `shr-descend'.
- (dom-attr dom 'name)))) ; Obsolete since HTML5.
- ;; We have an empty element, so just insert... something.
- (when (= start (point))
- (insert ?\s)
- (put-text-property (1- (point)) (point) 'display ""))
- (put-text-property start (1+ start) 'shr-target-id id))
+ (when-let* ((id (and (not (dom-attr dom 'id)) ; Handled by `shr-descend'.
+ (dom-attr dom 'name)))) ; Obsolete since HTML5.
+ (push (cons id (point)) shr--link-targets))
(when url
(shr-urlify (or shr-start start) (shr-expand-url url) title))))
@@ -1592,7 +1488,7 @@ ones, in case fg and bg are nil."
(let ((start (point))
url multimedia image)
(when-let* ((type (dom-attr dom 'type)))
- (when (string-match "\\`image/svg" type)
+ (when (string-match-p "\\`image/svg" type)
(setq url (dom-attr dom 'data)
image t)))
(dolist (child (dom-non-text-children dom))
@@ -1628,6 +1524,14 @@ url if no type is specified. The value should be a float in the range 0.0 to
:version "24.4"
:type '(alist :key-type regexp :value-type float))
+(defcustom shr-use-xwidgets-for-media nil
+ "If non-nil, use xwidgets to display video and audio elements.
+This also depends on Emacs being built with xwidgets capability.
+Note that this is experimental, and may lead to instability on
+some platforms."
+ :type 'boolean
+ :version "29.1")
+
(defun shr--get-media-pref (elem)
"Determine the preference for ELEM.
The preference is a float determined from `shr-prefer-media-type'."
@@ -1664,16 +1568,39 @@ The preference is a float determined from `shr-prefer-media-type'."
pref (cdr ret)))))))))
(cons url pref))
+(declare-function xwidget-webkit-execute-script "xwidget.c"
+ (xwidget script &optional callback))
+
(defun shr-tag-video (dom)
(let ((image (dom-attr dom 'poster))
(url (dom-attr dom 'src))
(start (point)))
(unless url
(setq url (car (shr--extract-best-source dom))))
- (if (> (length image) 0)
- (shr-indirect-call 'img nil image)
- (shr-insert " [video] "))
- (shr-urlify start (shr-expand-url url))))
+ (if (and shr-use-xwidgets-for-media
+ (fboundp 'make-xwidget))
+ ;; Play the video.
+ (progn
+ (require 'xwidget)
+ (let ((widget (make-xwidget
+ 'webkit
+ "Video"
+ (truncate (* (window-pixel-width) 0.8))
+ (truncate (* (window-pixel-width) 0.8 0.75)))))
+ (insert
+ (propertize
+ " [video] "
+ 'display (list 'xwidget :xwidget widget)))
+ (xwidget-webkit-execute-script
+ widget (format "document.body.innerHTML = %S;"
+ (format
+ "<style>body { margin: 0px; }</style><div style='background: black; height: 100%%; display: flex; align-items: center; justify-content: center;'><video autoplay loop muted controls style='max-width: 100%%; max-height: 100%%;'><source src=%S type='video/mp4'></source></video></div>"
+ url)))))
+ ;; No xwidgets.
+ (if (> (length image) 0)
+ (shr-indirect-call 'img nil image)
+ (shr-insert " [video] "))
+ (shr-urlify start (shr-expand-url url)))))
(defun shr-tag-audio (dom)
(let ((url (dom-attr dom 'src))
@@ -1723,8 +1650,7 @@ The preference is a float determined from `shr-prefer-media-type'."
(funcall shr-put-image-function image alt
(list :width width :height height)))))
((or shr-inhibit-images
- (and shr-blocked-images
- (string-match shr-blocked-images url)))
+ (shr-image-blocked-p url))
(setq shr-start (point))
(shr-insert alt))
((and (not shr-ignore-cache)
@@ -2036,7 +1962,8 @@ BASE is the URL of the HTML being rendered."
(setq dom (or (dom-child-by-tag dom 'tbody) dom))
(let* ((shr-inhibit-images t)
(shr-table-depth (1+ shr-table-depth))
- (shr-kinsoku-shorten t)
+ ;; Fill hard in CJK languages.
+ (pixel-fill-respect-kinsoku nil)
;; Find all suggested widths.
(columns (shr-column-specs dom))
;; Compute how many pixels wide each TD should be.
@@ -2530,9 +2457,10 @@ flags that control whether to collect or render objects."
(style (dom-attr dom 'style))
(shr-stylesheet shr-stylesheet)
(max-width 0)
+ (shr--link-targets nil)
natural-width)
(when style
- (setq style (and (string-match "color" style)
+ (setq style (and (string-search "color" style)
(shr-parse-style style))))
(when bgcolor
(setq style (nconc (list (cons 'background-color bgcolor))
@@ -2571,6 +2499,7 @@ flags that control whether to collect or render objects."
(end-of-line)
(point)))
(goto-char (point-min))
+ (shr--set-target-ids shr--link-targets)
(list max-width
natural-width
(count-lines (point-min) (point-max))
diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el
index b4aed279819..6f915e97452 100644
--- a/lisp/net/soap-client.el
+++ b/lisp/net/soap-client.el
@@ -718,10 +718,9 @@ representing leap seconds."
second)
minute hour day month year second-fraction datatype time-zone)
(let ((time
- (apply
- #'encode-time (list
- (if new-decode-time new-decode-time-second second)
- minute hour day month year nil nil time-zone))))
+ (encode-time (list
+ (if new-decode-time new-decode-time-second second)
+ minute hour day month year nil nil time-zone))))
(if new-decode-time
(with-no-warnings (decode-time time nil t))
(decode-time time))))))
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index 362a258f43d..b662e0bf6cf 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -107,7 +107,8 @@ It is used for TCP/IP devices."
;;;###tramp-autoload
(defconst tramp-adb-file-name-handler-alist
- '((access-file . tramp-handle-access-file)
+ '(;; `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)
@@ -191,11 +192,10 @@ It is used for TCP/IP devices."
;; 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-adb-file-name-p (filename)
- "Check if it's a FILENAME for ADB."
- (and (tramp-tramp-file-p filename)
- (string= (tramp-file-name-method (tramp-dissect-file-name filename))
- tramp-adb-method)))
+(defsubst tramp-adb-file-name-p (vec-or-filename)
+ "Check if it's a VEC-OR-FILENAME for ADB."
+ (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)))
+ (string= (tramp-file-name-method vec) tramp-adb-method)))
;;;###tramp-autoload
(defun tramp-adb-file-name-handler (operation &rest args)
@@ -306,7 +306,7 @@ arguments to pass to the OPERATION."
(directory &optional full match nosort id-format count)
"Like `directory-files-and-attributes' for Tramp files."
(unless (file-exists-p directory)
- (tramp-compat-file-missing (tramp-dissect-file-name directory) directory))
+ (tramp-error (tramp-dissect-file-name directory) 'file-missing directory))
(when (file-directory-p directory)
(with-parsed-tramp-file-name (expand-file-name directory) nil
(copy-tree
@@ -415,6 +415,8 @@ 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))))
(string-match tramp-adb-ls-date-regexp b)
@@ -499,7 +501,7 @@ Emacs dired can't find files."
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name filename nil
(unless (file-exists-p (file-truename filename))
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
(let ((tmpfile (tramp-compat-make-temp-file filename)))
(with-tramp-progress-reporter
v 3 (format "Fetching %s to tmp file %s" filename tmpfile)
@@ -591,8 +593,7 @@ Emacs dired can't find files."
;; Set file modification time.
(when (or (eq visit t) (stringp visit))
(set-visited-file-modtime
- (or (tramp-compat-file-attribute-modification-time
- (file-attributes filename))
+ (or (file-attribute-modification-time (file-attributes filename))
(current-time))))
;; Unlock file.
@@ -660,7 +661,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(jka-compr-inhibit t))
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
@@ -720,8 +721,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(when keep-date
(tramp-compat-set-file-times
newname
- (tramp-compat-file-attribute-modification-time
- (file-attributes filename))
+ (file-attribute-modification-time (file-attributes filename))
(unless ok-if-already-exists 'nofollow)))))
(defun tramp-adb-handle-rename-file
@@ -742,7 +742,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(jka-compr-inhibit t))
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
@@ -1349,22 +1349,18 @@ connection if a previous connection has died for some reason."
;; Mark it as connected.
(tramp-set-connection-property p "connected" t)))))))
-;;; Default connection-local variables for Tramp:
-;; `connection-local-set-profile-variables' and
-;; `connection-local-set-profiles' exists since Emacs 26.1.
+;;; Default connection-local variables for Tramp.
(defconst tramp-adb-connection-local-default-shell-variables
'((shell-file-name . "/system/bin/sh")
(shell-command-switch . "-c"))
"Default connection-local shell variables for remote adb connections.")
-(tramp-compat-funcall
- 'connection-local-set-profile-variables
+(connection-local-set-profile-variables
'tramp-adb-connection-local-default-shell-profile
tramp-adb-connection-local-default-shell-variables)
(with-eval-after-load 'shell
- (tramp-compat-funcall
- 'connection-local-set-profiles
+ (connection-local-set-profiles
`(:application tramp :protocol ,tramp-adb-method)
'tramp-adb-connection-local-default-shell-profile))
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index bd0f82cbad6..b44a4e86aad 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -54,6 +54,7 @@
;; * ".ar" - UNIX archiver formats
;; * ".cab", ".CAB" - Microsoft Windows cabinets
;; * ".cpio" - CPIO archives
+;; * ".crate" - Cargo (Rust) packages
;; * ".deb" - Debian packages
;; * ".depot" - HP-UX SD depots
;; * ".exe" - Self extracting Microsoft Windows EXE files
@@ -141,6 +142,7 @@
"ar" ;; UNIX archiver formats.
"cab" "CAB" ;; Microsoft Windows cabinets.
"cpio" ;; CPIO archives.
+ "crate" ;; Cargo (Rust) packages. Not in libarchive testsuite.
"deb" ;; Debian packages. Not in libarchive testsuite.
"depot" ;; HP-UX SD depot. Not in libarchive testsuite.
"exe" ;; Self extracting Microsoft Windows EXE files.
@@ -211,7 +213,8 @@ It must be supported by libarchive(3).")
;; New handlers should be added here.
;;;###tramp-autoload
(defconst tramp-archive-file-name-handler-alist
- '((access-file . tramp-archive-handle-access-file)
+ '(;; `abbreviate-file-name' performed by default handler.
+ (access-file . tramp-archive-handle-access-file)
(add-name-to-file . tramp-archive-handle-not-implemented)
;; `byte-compiler-base-file-name' performed by default handler.
;; `copy-directory' performed by default handler.
@@ -618,7 +621,7 @@ offered."
(defun tramp-archive-handle-file-system-info (filename)
"Like `file-system-info' for file archives."
(with-parsed-tramp-archive-file-name filename nil
- (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0)))
+ (list (file-attribute-size (file-attributes archive)) 0 0)))
(defun tramp-archive-handle-file-truename (filename)
"Like `file-truename' for file archives."
@@ -658,7 +661,7 @@ offered."
;; mounted directory, it is returned as it. Not what we want.
(with-parsed-tramp-archive-file-name default-directory nil
(let ((default-directory (file-name-directory archive)))
- (tramp-compat-temporary-file-directory-function))))
+ (temporary-file-directory))))
(defun tramp-archive-handle-not-implemented (operation &rest args)
"Generic handler for operations not implemented for file archives."
diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el
index f1c656ec209..b909c5706d6 100644
--- a/lisp/net/tramp-cache.el
+++ b/lisp/net/tramp-cache.el
@@ -49,8 +49,6 @@
;; an open connection. Examples: "scripts" keeps shell script
;; definitions already sent to the remote shell, "last-cmd-time" is
;; the time stamp a command has been sent to the remote process.
-;; "lock-pid" is the timestamp a (network) process is created, it is
-;; used instead of the pid in file locks.
;;
;; - The key is nil. These are temporary properties related to the
;; local machine. Examples: "parse-passwd" and "parse-group" keep
@@ -101,8 +99,7 @@ details see the info pages."
(choice :tag " Value" sexp))))
;;;###tramp-autoload
-(defcustom tramp-persistency-file-name
- (expand-file-name (locate-user-emacs-file "tramp"))
+(defcustom tramp-persistency-file-name (locate-user-emacs-file "tramp")
"File which keeps connection history for Tramp connections."
:group 'tramp
:type 'file)
@@ -225,7 +222,9 @@ Return VALUE."
(defun tramp-flush-file-upper-properties (key file)
"Remove some properties of FILE's upper directory."
(when (file-name-absolute-p file)
- (let ((file (directory-file-name (file-name-directory file))))
+ ;; `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 file (tramp-compat-file-name-unquote file)
key (copy-tramp-file-name key))
diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el
index 63eab1b31a1..2eaebebed9f 100644
--- a/lisp/net/tramp-cmds.el
+++ b/lisp/net/tramp-cmds.el
@@ -67,7 +67,7 @@ SYNTAX can be one of the symbols `default' (default),
nil
(mapcar
(lambda (x)
- (with-current-buffer x (when (tramp-tramp-file-p default-directory) x)))
+ (when (tramp-tramp-file-p (tramp-get-default-directory x)) x))
(buffer-list))))
;;;###tramp-autoload
@@ -593,9 +593,8 @@ buffer in your bug report.
(defun tramp-reporter-dump-variable (varsym mailbuf)
"Pretty-print the value of the variable in symbol VARSYM."
- (let* ((reporter-eval-buffer (symbol-value 'reporter-eval-buffer))
- (val (with-current-buffer reporter-eval-buffer
- (symbol-value varsym))))
+ (when-let ((reporter-eval-buffer reporter-eval-buffer)
+ (val (buffer-local-value varsym reporter-eval-buffer)))
(if (hash-table-p val)
;; Pretty print the cache.
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index fbc3d684ce8..627ff1edaec 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -23,17 +23,12 @@
;;; Commentary:
-;; Tramp's main Emacs version for development is Emacs 28. This
-;; package provides compatibility functions for Emacs 25, Emacs 26 and
-;; Emacs 27.
+;; Tramp's main Emacs version for development is Emacs 29. This
+;; package provides compatibility functions for Emacs 26, Emacs 27 and
+;; Emacs 28.
;;; Code:
-;; In Emacs 25, `tramp-unload-file-name-handlers' is not autoloaded.
-;; So we declare it here in order to avoid recursive load. This will
-;; be overwritten in tramp.el.
-(defun tramp-unload-file-name-handlers () ".")
-
(require 'auth-source)
(require 'format-spec)
(require 'ls-lisp) ;; Due to `tramp-handle-insert-directory'.
@@ -42,8 +37,6 @@
(require 'subr-x)
(declare-function tramp-error "tramp")
-;; `temporary-file-directory' as function is introduced with Emacs 26.1.
-(declare-function tramp-handle-temporary-file-directory "tramp")
(declare-function tramp-tramp-file-p "tramp")
(defvar tramp-temp-name-prefix)
@@ -83,133 +76,19 @@ Add the extension of F, if existing."
tramp-temp-name-prefix tramp-compat-temporary-file-directory)
dir-flag (file-name-extension f t)))
-;; `temporary-file-directory' as function is introduced with Emacs 26.1.
-(defalias 'tramp-compat-temporary-file-directory-function
- (if (fboundp 'temporary-file-directory)
- #'temporary-file-directory
- #'tramp-handle-temporary-file-directory))
-
-;; `file-attribute-*' are introduced in Emacs 26.1.
-
-(defalias 'tramp-compat-file-attribute-type
- (if (fboundp 'file-attribute-type)
- #'file-attribute-type
- (lambda (attributes)
- "The type field in ATTRIBUTES returned by `file-attributes'.
-The value is either t for directory, string (name linked to) for
-symbolic link, or nil."
- (nth 0 attributes))))
-
-(defalias 'tramp-compat-file-attribute-link-number
- (if (fboundp 'file-attribute-link-number)
- #'file-attribute-link-number
- (lambda (attributes)
- "Return the number of links in ATTRIBUTES returned by `file-attributes'."
- (nth 1 attributes))))
-
-(defalias 'tramp-compat-file-attribute-user-id
- (if (fboundp 'file-attribute-user-id)
- #'file-attribute-user-id
- (lambda (attributes)
- "The UID field in ATTRIBUTES returned by `file-attributes'.
-This is either a string or a number. If a string value cannot be
-looked up, a numeric value, either an integer or a float, is
-returned."
- (nth 2 attributes))))
-
-(defalias 'tramp-compat-file-attribute-group-id
- (if (fboundp 'file-attribute-group-id)
- #'file-attribute-group-id
- (lambda (attributes)
- "The GID field in ATTRIBUTES returned by `file-attributes'.
-This is either a string or a number. If a string value cannot be
-looked up, a numeric value, either an integer or a float, is
-returned."
- (nth 3 attributes))))
-
-(defalias 'tramp-compat-file-attribute-access-time
- (if (fboundp 'file-attribute-access-time)
- #'file-attribute-access-time
- (lambda (attributes)
- "The last access time in ATTRIBUTES returned by `file-attributes'.
-This a Lisp timestamp in the style of `current-time'."
- (nth 4 attributes))))
-
-(defalias 'tramp-compat-file-attribute-modification-time
- (if (fboundp 'file-attribute-modification-time)
- #'file-attribute-modification-time
- (lambda (attributes)
- "The modification time in ATTRIBUTES returned by `file-attributes'.
-This is the time of the last change to the file's contents, and
-is a Lisp timestamp in the style of `current-time'."
- (nth 5 attributes))))
-
-(defalias 'tramp-compat-file-attribute-status-change-time
- (if (fboundp 'file-attribute-status-change-time)
- #'file-attribute-status-change-time
- (lambda (attributes)
- "The status modification time in ATTRIBUTES returned by `file-attributes'.
-This is the time of last change to the file's attributes: owner
-and group, access mode bits, etc., and is a Lisp timestamp in the
-style of `current-time'."
- (nth 6 attributes))))
-
-(defalias 'tramp-compat-file-attribute-size
- (if (fboundp 'file-attribute-size)
- #'file-attribute-size
- (lambda (attributes)
- "The size (in bytes) in ATTRIBUTES returned by `file-attributes'.
-If the size is too large for a fixnum, this is a bignum in Emacs 27
-and later, and is a float in Emacs 26 and earlier."
- (nth 7 attributes))))
-
-(defalias 'tramp-compat-file-attribute-modes
- (if (fboundp 'file-attribute-modes)
- #'file-attribute-modes
- (lambda (attributes)
- "The file modes in ATTRIBUTES returned by `file-attributes'.
-This is a string of ten letters or dashes as in ls -l."
- (nth 8 attributes))))
-
-;; `file-missing' is introduced in Emacs 26.1.
-(defconst tramp-file-missing
- (if (get 'file-missing 'error-conditions) 'file-missing 'file-error)
- "The error symbol for the `file-missing' error.")
-
-(defsubst tramp-compat-file-missing (vec file)
- "Emit the `file-missing' error."
- (if (get 'file-missing 'error-conditions)
- (tramp-error vec tramp-file-missing file)
- (tramp-error vec tramp-file-missing "No such file or directory: %s" file)))
-
-;; `file-local-name', `file-name-quoted-p', `file-name-quote' and
-;; `file-name-unquote' are introduced in Emacs 26.1.
-(defalias 'tramp-compat-file-local-name
- (if (fboundp 'file-local-name)
- #'file-local-name
- (lambda (name)
- "Return the local name component of NAME.
-It returns a file name which can be used directly as argument of
-`process-file', `start-file-process', or `shell-command'."
- (or (file-remote-p name 'localname) name))))
-
;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' got
;; a second argument in Emacs 27.1.
(defalias 'tramp-compat-file-name-quoted-p
- (if (and
- (fboundp 'file-name-quoted-p)
- (equal (tramp-compat-funcall 'func-arity #'file-name-quoted-p) '(1 . 2)))
+ (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 "/:" (tramp-compat-file-local-name name))))))
+ (string-prefix-p "/:" (file-local-name name))))))
(defalias 'tramp-compat-file-name-quote
- (if (and
- (fboundp 'file-name-quote)
- (equal (tramp-compat-funcall 'func-arity #'file-name-quote) '(1 . 2)))
+ (if (equal (func-arity #'file-name-quote) '(1 . 2))
#'file-name-quote
(lambda (name &optional top)
"Add the quotation prefix \"/:\" to file NAME.
@@ -217,20 +96,17 @@ 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) "/:" (tramp-compat-file-local-name name)))))))
+ (concat (file-remote-p name) "/:" (file-local-name name)))))))
(defalias 'tramp-compat-file-name-unquote
- (if (and
- (fboundp 'file-name-unquote)
- (equal (tramp-compat-funcall 'func-arity #'file-name-unquote) '(1 . 2)))
+ (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 (tramp-compat-file-local-name name)))
+ (localname (file-local-name name)))
(when (tramp-compat-file-name-quoted-p localname top)
(setq
localname (if (= (length localname) 2) "/" (substring localname 2))))
@@ -288,8 +164,7 @@ A nil value for either argument stands for the current time."
;; `progress-reporter-update' got argument SUFFIX in Emacs 27.1.
(defalias 'tramp-compat-progress-reporter-update
- (if (equal (tramp-compat-funcall 'func-arity #'progress-reporter-update)
- '(1 . 3))
+ (if (equal (func-arity #'progress-reporter-update) '(1 . 3))
#'progress-reporter-update
(lambda (reporter &optional value _suffix)
(progress-reporter-update reporter value))))
@@ -306,19 +181,19 @@ CONDITION can also be a list of error conditions."
;; `file-modes', `set-file-modes' and `set-file-times' got argument
;; FLAG in Emacs 28.1.
(defalias 'tramp-compat-file-modes
- (if (equal (tramp-compat-funcall 'func-arity #'file-modes) '(1 . 2))
+ (if (equal (func-arity #'file-modes) '(1 . 2))
#'file-modes
(lambda (filename &optional _flag)
(file-modes filename))))
(defalias 'tramp-compat-set-file-modes
- (if (equal (tramp-compat-funcall 'func-arity #'set-file-modes) '(2 . 3))
+ (if (equal (func-arity #'set-file-modes) '(2 . 3))
#'set-file-modes
(lambda (filename mode &optional _flag)
(set-file-modes filename mode))))
(defalias 'tramp-compat-set-file-times
- (if (equal (tramp-compat-funcall 'func-arity #'set-file-times) '(1 . 3))
+ (if (equal (func-arity #'set-file-times) '(1 . 3))
#'set-file-times
(lambda (filename &optional timestamp _flag)
(set-file-times filename timestamp))))
@@ -326,14 +201,13 @@ CONDITION can also be a list of error conditions."
;; `directory-files' and `directory-files-and-attributes' got argument
;; COUNT in Emacs 28.1.
(defalias 'tramp-compat-directory-files
- (if (equal (tramp-compat-funcall 'func-arity #'directory-files) '(1 . 5))
+ (if (equal (func-arity #'directory-files) '(1 . 5))
#'directory-files
(lambda (directory &optional full match nosort _count)
(directory-files directory full match nosort))))
(defalias 'tramp-compat-directory-files-and-attributes
- (if (equal (tramp-compat-funcall 'func-arity #'directory-files-and-attributes)
- '(1 . 6))
+ (if (equal (func-arity #'directory-files-and-attributes) '(1 . 6))
#'directory-files-and-attributes
(lambda (directory &optional full match nosort id-format _count)
(directory-files-and-attributes directory full match nosort id-format))))
@@ -410,8 +284,6 @@ CONDITION can also be a list of error conditions."
;;; TODO:
;;
-;; * `func-arity' exists since Emacs 26.1.
-;;
;; * Starting with Emacs 27.1, there's no need to escape open
;; parentheses with a backslash in docstrings anymore.
;;
diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el
index 5def3a4137c..4ff8e6bbf12 100644
--- a/lisp/net/tramp-crypt.el
+++ b/lisp/net/tramp-crypt.el
@@ -157,7 +157,8 @@ If NAME doesn't belong to a crypted remote directory, retun nil."
;; New handlers should be added here.
;;;###tramp-autoload
(defconst tramp-crypt-file-name-handler-alist
- '((access-file . tramp-crypt-handle-access-file)
+ '(;; `abbreviate-file-name' performed by default handler.
+ (access-file . tramp-crypt-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)
@@ -294,8 +295,8 @@ arguments to pass to the OPERATION."
(defun tramp-crypt-config-file-name (vec)
"Return the encfs config file name for VEC."
(expand-file-name
- (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config)
- user-emacs-directory))
+ (locate-user-emacs-file
+ (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config))))
(defun tramp-crypt-maybe-open-connection (vec)
"Maybe open a connection VEC.
@@ -485,6 +486,7 @@ See `tramp-crypt-do-encrypt-or-decrypt-file'."
Files in that directory and all subdirectories will be encrypted
before copying to, and decrypted after copying from that
directory. File names will be also encrypted."
+ ;; (declare (completion tramp-crypt-command-completion-p))
(interactive "DRemote directory name: ")
(unless tramp-crypt-enabled
(tramp-user-error nil "Feature is not enabled."))
@@ -596,7 +598,7 @@ absolute file names."
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
@@ -698,7 +700,7 @@ absolute file names."
(directory &optional full match nosort count)
"Like `directory-files' for Tramp files."
(unless (file-exists-p directory)
- (tramp-compat-file-missing (tramp-dissect-file-name directory) directory))
+ (tramp-error (tramp-dissect-file-name directory) 'file-missing directory))
(when (file-directory-p directory)
(setq directory (file-name-as-directory (expand-file-name directory)))
(let* (tramp-crypt-enabled
diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el
index 11ccdc8a4c9..f78c08ec415 100644
--- a/lisp/net/tramp-ftp.el
+++ b/lisp/net/tramp-ftp.el
@@ -175,11 +175,10 @@ pass to the OPERATION."
;; 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-ftp-file-name-p (filename)
- "Check if it's a FILENAME that should be forwarded to Ange-FTP."
- (and (tramp-tramp-file-p filename)
- (string= (tramp-file-name-method (tramp-dissect-file-name filename))
- tramp-ftp-method)))
+(defsubst tramp-ftp-file-name-p (vec-or-filename)
+ "Check if it's a VEC-OR-FILENAME that should be forwarded to Ange-FTP."
+ (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)))
+ (string= (tramp-file-name-method vec) tramp-ftp-method)))
;;;###tramp-autoload
(tramp--with-startup
diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el
index c359082dc1e..cb270be68fb 100644
--- a/lisp/net/tramp-fuse.el
+++ b/lisp/net/tramp-fuse.el
@@ -48,7 +48,7 @@
(directory &optional full match nosort count)
"Like `directory-files' for Tramp files."
(unless (file-exists-p directory)
- (tramp-compat-file-missing (tramp-dissect-file-name directory) directory))
+ (tramp-error (tramp-dissect-file-name directory) 'file-missing directory))
(when (file-directory-p directory)
(setq directory (file-name-as-directory (expand-file-name directory)))
(with-parsed-tramp-file-name directory nil
@@ -107,12 +107,6 @@
(unless (string-match-p elt item) (throw 'match nil)))
(setq result (cons (concat item "/") result))))))))))
-(defun tramp-fuse-handle-file-readable-p (filename)
- "Like `file-readable-p' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (with-tramp-file-property v localname "file-readable-p"
- (file-readable-p (tramp-fuse-local-file-name filename)))))
-
;; This function isn't used.
(defun tramp-fuse-handle-insert-directory
(filename switches &optional wildcard full-directory-p)
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index cab912bd93a..6b0299aa097 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -122,10 +122,7 @@
(autoload 'zeroconf-init "zeroconf")
(tramp-compat-funcall 'dbus-get-unique-name :system)
(tramp-compat-funcall 'dbus-get-unique-name :session)
- (or ;; Until Emacs 25, `process-attributes' could crash Emacs
- ;; for some processes. Better we don't check.
- (<= emacs-major-version 25)
- (tramp-process-running-p "gvfs-fuse-daemon")
+ (or (tramp-process-running-p "gvfs-fuse-daemon")
(tramp-process-running-p "gvfsd-fuse"))))
"Non-nil when GVFS is available.")
@@ -471,8 +468,7 @@ It has been changed in GVFS 1.14.")
;; </method>
;; </interface>
-;; The basic structure for GNOME Online Accounts. We use a list :type,
-;; in order to be compatible with Emacs 25.
+;; The basic structure for GNOME Online Accounts.
(cl-defstruct (tramp-goa-account (:type list) :named) method user host port)
;;;###tramp-autoload
@@ -672,8 +668,7 @@ It has been changed in GVFS 1.14.")
;; STRING key (always-call-mount, is-removable, ...)
;; VARIANT value (boolean?)
-;; The basic structure for media devices. We use a list :type, in
-;; order to be compatible with Emacs 25.
+;; The basic structure for media devices.
(cl-defstruct (tramp-media-device (:type list) :named) method host port)
;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We
@@ -749,7 +744,8 @@ It has been changed in GVFS 1.14.")
;; New handlers should be added here.
;;;###tramp-autoload
(defconst tramp-gvfs-file-name-handler-alist
- '((access-file . tramp-handle-access-file)
+ '((abbreviate-file-name . tramp-handle-abbreviate-file-name)
+ (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)
@@ -834,12 +830,11 @@ Operations not mentioned here will be handled by the default Emacs primitives.")
;; 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-gvfs-file-name-p (filename)
- "Check if it's a FILENAME handled by the GVFS daemon."
- (and (tramp-tramp-file-p filename)
- (let ((method
- (tramp-file-name-method (tramp-dissect-file-name filename))))
- (and (stringp method) (member method tramp-gvfs-methods)))))
+(defsubst tramp-gvfs-file-name-p (vec-or-filename)
+ "Check if it's a VEC-OR-FILENAME handled by the GVFS daemon."
+ (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)))
+ (let ((method (tramp-file-name-method vec)))
+ (and (stringp method) (member method tramp-gvfs-methods)))))
;;;###tramp-autoload
(defun tramp-gvfs-file-name-handler (operation &rest args)
@@ -1002,7 +997,7 @@ file names."
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
@@ -1102,8 +1097,7 @@ file names."
(tramp-skeleton-delete-directory directory recursive trash
(if (and recursive (not (file-symlink-p directory)))
(mapc (lambda (file)
- (if (eq t (tramp-compat-file-attribute-type
- (file-attributes file)))
+ (if (eq t (file-attribute-type (file-attributes file)))
(delete-directory file recursive)
(delete-file file)))
(directory-files
@@ -1155,15 +1149,12 @@ file names."
(make-tramp-file-name
:method method :user user :domain domain
:host host :port port :localname "/" :hop hop)))
- (setq localname
- (replace-match
- (tramp-get-connection-property v "default-location" "~")
- nil t localname 1)))
- ;; Tilde expansion is not possible.
- (when (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
- (tramp-error
- v 'file-error
- "Cannot expand tilde in file `%s'" name))
+ (unless (string-empty-p
+ (tramp-get-connection-property v "default-location" ""))
+ (setq localname
+ (replace-match
+ (tramp-get-connection-property v "default-location" "~")
+ nil t localname 1))))
(unless (tramp-run-real-handler #'file-name-absolute-p (list localname))
(setq localname (concat "/" localname)))
;; We do not pass "/..".
@@ -1178,10 +1169,12 @@ file names."
;; Do not keep "/..".
(when (string-match-p "^/\\.\\.?$" localname)
(setq localname "/"))
- ;; No tilde characters in file name, do normal
- ;; `expand-file-name' (this does "/./" and "/../").
+ ;; Do normal `expand-file-name' (this does "/./" and "/../"),
+ ;; unless there are tilde characters in file name.
(tramp-make-tramp-file-name
- v (tramp-run-real-handler #'expand-file-name (list localname))))))
+ v (if (string-match-p "\\`~" localname)
+ localname
+ (tramp-run-real-handler #'expand-file-name (list localname)))))))
(defun tramp-gvfs-get-directory-attributes (directory)
"Return GVFS attributes association list of all files in DIRECTORY."
@@ -1463,7 +1456,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
`file-notify' events."
(let* ((events (process-get proc 'events))
(rest-string (process-get proc 'rest-string))
- (dd (with-current-buffer (process-buffer proc) default-directory))
+ (dd (tramp-get-default-directory (process-buffer proc)))
(ddu (regexp-quote (tramp-gvfs-url-file-name dd))))
(when rest-string
(tramp-message proc 10 "Previous string:\n%s" rest-string))
@@ -1528,11 +1521,11 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(size (cdr (assoc "filesystem::size" attr)))
(used (cdr (assoc "filesystem::used" attr)))
(free (cdr (assoc "filesystem::free" attr))))
- (when (or size used free)
- (list (string-to-number (or size "0"))
- (string-to-number (or free "0"))
- (- (string-to-number (or size "0"))
- (string-to-number (or used "0"))))))))
+ (when (or size free)
+ (list (and size (string-to-number size))
+ (and free (string-to-number free))
+ (and size used
+ (- (string-to-number size) (string-to-number used))))))))
(defun tramp-gvfs-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
@@ -1602,7 +1595,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
"%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))
- (current-time)
+ nil
time)))))
(defun tramp-gvfs-handle-get-remote-uid (vec id-format)
@@ -1614,9 +1607,8 @@ ID-FORMAT valid values are `string' and `integer'."
(tramp-get-connection-property
(tramp-get-process vec) "share"
(tramp-get-connection-property vec "default-location" nil))))
- (tramp-compat-file-attribute-user-id
- (file-attributes
- (tramp-make-tramp-file-name vec localname) id-format)))))
+ (file-attribute-user-id
+ (file-attributes (tramp-make-tramp-file-name vec localname) id-format)))))
(defun tramp-gvfs-handle-get-remote-gid (vec id-format)
"The gid of the remote connection VEC, in ID-FORMAT.
@@ -1625,9 +1617,8 @@ ID-FORMAT valid values are `string' and `integer'."
(tramp-get-connection-property
(tramp-get-process vec) "share"
(tramp-get-connection-property vec "default-location" nil))))
- (tramp-compat-file-attribute-group-id
- (file-attributes
- (tramp-make-tramp-file-name vec localname) id-format))))
+ (file-attribute-group-id
+ (file-attributes (tramp-make-tramp-file-name vec localname) id-format))))
(defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid)
"Like `tramp-set-file-uid-gid' for Tramp files."
@@ -1865,9 +1856,9 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and
host (tramp-file-name-host v)
port (tramp-file-name-port v)))))
(when (member method tramp-gvfs-methods)
- (let ((v (make-tramp-file-name
- :method method :user user :domain domain
- :host host :port port)))
+ (let ((v (make-tramp-file-name
+ :method method :user user :domain domain
+ :host host :port port)))
(tramp-message
v 6 "%s %s"
signal-name (tramp-gvfs-stringify-dbus-message mount-info))
@@ -2134,9 +2125,6 @@ connection if a previous connection has died for some reason."
(process-put p 'vector vec)
(set-process-query-on-exit-flag p nil)
- ;; Mark process for filelock.
- (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds)))
-
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)))
diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el
index 17264193fd6..238abd34230 100644
--- a/lisp/net/tramp-integration.el
+++ b/lisp/net/tramp-integration.el
@@ -85,13 +85,6 @@ special handling of `substitute-in-file-name'."
"An overlay covering the shadowed part of the filename."
(format "[^%s/~]*\\(/\\|~\\)" tramp-postfix-host-format))
-;; Package rfn-eshadow is preloaded in Emacs, but for some reason,
-;; it only did (defvar rfn-eshadow-overlay) without giving it a global
-;; value, so it was only declared as dynamically-scoped within the
-;; rfn-eshadow.el file. This is now fixed in Emacs>26.1 but we still need
-;; this defvar here for older releases.
-(defvar rfn-eshadow-overlay)
-
(defun tramp-rfn-eshadow-update-overlay ()
"Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input.
This is intended to be used as a minibuffer `post-command-hook' for
@@ -281,22 +274,18 @@ NAME must be equal to `tramp-current-connection'."
(remove-hook 'compilation-start-hook
#'tramp-compile-disable-ssh-controlmaster-options))))
-;;; Default connection-local variables for Tramp:
-;; `connection-local-set-profile-variables' and
-;; `connection-local-set-profiles' exists since Emacs 26.1.
+;;; Default connection-local variables for Tramp.
(defconst tramp-connection-local-default-system-variables
'((path-separator . ":")
(null-device . "/dev/null"))
"Default connection-local system variables for remote connections.")
-(tramp-compat-funcall
- 'connection-local-set-profile-variables
+(connection-local-set-profile-variables
'tramp-connection-local-default-system-profile
tramp-connection-local-default-system-variables)
-(tramp-compat-funcall
- 'connection-local-set-profiles
+(connection-local-set-profiles
'(:application tramp)
'tramp-connection-local-default-system-profile)
@@ -305,14 +294,12 @@ NAME must be equal to `tramp-current-connection'."
(shell-command-switch . "-c"))
"Default connection-local shell variables for remote connections.")
-(tramp-compat-funcall
- 'connection-local-set-profile-variables
+(connection-local-set-profile-variables
'tramp-connection-local-default-shell-profile
tramp-connection-local-default-shell-variables)
(with-eval-after-load 'shell
- (tramp-compat-funcall
- 'connection-local-set-profiles
+ (connection-local-set-profiles
'(:application tramp)
'tramp-connection-local-default-shell-profile))
diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el
index 812e06f3f11..71ec2607a30 100644
--- a/lisp/net/tramp-rclone.el
+++ b/lisp/net/tramp-rclone.el
@@ -71,7 +71,8 @@
;; New handlers should be added here.
;;;###tramp-autoload
(defconst tramp-rclone-file-name-handler-alist
- '((access-file . tramp-handle-access-file)
+ '(;; `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)
@@ -110,7 +111,7 @@
(file-notify-rm-watch . ignore)
(file-notify-valid-p . ignore)
(file-ownership-preserved-p . ignore)
- (file-readable-p . tramp-fuse-handle-file-readable-p)
+ (file-readable-p . tramp-rclone-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)
@@ -156,11 +157,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.")
;; 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-rclone-file-name-p (filename)
- "Check if it's a FILENAME for rclone."
- (and (tramp-tramp-file-p filename)
- (string= (tramp-file-name-method (tramp-dissect-file-name filename))
- tramp-rclone-method)))
+(defsubst tramp-rclone-file-name-p (vec-or-filename)
+ "Check if it's a VEC-OR-FILENAME for rclone."
+ (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)))
+ (string= (tramp-file-name-method vec) tramp-rclone-method)))
;;;###tramp-autoload
(defun tramp-rclone-file-name-handler (operation &rest args)
@@ -223,7 +223,7 @@ file names."
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
@@ -280,6 +280,12 @@ file names."
(list filename newname ok-if-already-exists keep-date
preserve-uid-gid preserve-extended-attributes))))
+(defun tramp-rclone-handle-file-readable-p (filename)
+ "Like `file-readable-p' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (with-tramp-file-property v localname "file-readable-p"
+ (file-readable-p (tramp-fuse-local-file-name filename)))))
+
(defun tramp-rclone-handle-file-system-info (filename)
"Like `file-system-info' for Tramp files."
(ignore-errors
@@ -362,10 +368,6 @@ connection if a previous connection has died for some reason."
(process-put p 'vector vec)
(set-process-query-on-exit-flag p nil)
- ;; Mark process for filelock.
- (tramp-set-connection-property
- p "lock-pid" (truncate (time-to-seconds)))
-
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)))
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 21217381f14..72eb63d3929 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -34,6 +34,8 @@
(eval-when-compile (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 process-file-return-signal-string)
@@ -940,7 +942,8 @@ Format specifiers \"%s\" are replaced before the script is used.")
;; New handlers should be added here.
;;;###tramp-autoload
(defconst tramp-sh-file-name-handler-alist
- '((access-file . tramp-handle-access-file)
+ '((abbreviate-file-name . tramp-handle-abbreviate-file-name)
+ (access-file . tramp-handle-access-file)
(add-name-to-file . tramp-sh-handle-add-name-to-file)
;; `byte-compiler-base-file-name' performed by default handler.
(copy-directory . tramp-sh-handle-copy-directory)
@@ -952,6 +955,8 @@ Format specifiers \"%s\" are replaced before the script is used.")
(directory-files . tramp-handle-directory-files)
(directory-files-and-attributes
. tramp-sh-handle-directory-files-and-attributes)
+ ;; Starting with Emacs 29.1, `dired-compress-file' performed by
+ ;; default handler.
(dired-compress-file . tramp-sh-handle-dired-compress-file)
(dired-uncache . tramp-handle-dired-uncache)
(exec-path . tramp-sh-handle-exec-path)
@@ -1334,7 +1339,7 @@ component is used as the target of the symlink."
(with-parsed-tramp-file-name f nil
(let* ((remote-file-name-inhibit-cache t)
(attr (file-attributes f))
- (modtime (or (tramp-compat-file-attribute-modification-time attr)
+ (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))
@@ -1372,7 +1377,7 @@ of."
(with-parsed-tramp-file-name f nil
(let* ((remote-file-name-inhibit-cache t)
(attr (file-attributes f))
- (modtime (tramp-compat-file-attribute-modification-time attr))
+ (modtime (file-attribute-modification-time attr))
(mt (visited-file-modtime)))
(cond
@@ -1424,7 +1429,7 @@ of."
(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)
+ nil
time)))
(tramp-send-command-and-check
v (format
@@ -1620,14 +1625,14 @@ ID-FORMAT valid values are `string' and `integer'."
;; information would be lost by an (attempted) delete and create.
(or (null attributes)
(and
- (= (tramp-compat-file-attribute-user-id attributes)
+ (= (file-attribute-user-id attributes)
(tramp-get-remote-uid v 'integer))
(or (not group)
;; On BSD-derived systems files always inherit the
;; parent directory's group, so skip the group-gid
;; test.
(tramp-check-remote-uname v "BSD\\|DragonFly\\|Darwin")
- (= (tramp-compat-file-attribute-group-id attributes)
+ (= (file-attribute-group-id attributes)
(tramp-get-remote-gid v 'integer)))))))))
;; Directory listings.
@@ -1637,8 +1642,7 @@ ID-FORMAT valid values are `string' and `integer'."
"Like `directory-files-and-attributes' for Tramp files."
(unless id-format (setq id-format 'integer))
(unless (file-exists-p directory)
- (tramp-compat-file-missing
- (tramp-dissect-file-name directory) directory))
+ (tramp-error (tramp-dissect-file-name directory) 'file-missing directory))
(when (file-directory-p directory)
(setq directory (expand-file-name directory))
(let* ((temp
@@ -1858,7 +1862,7 @@ ID-FORMAT valid values are `string' and `integer'."
target)
(with-parsed-tramp-file-name (if t1 dirname newname) nil
(unless (file-exists-p dirname)
- (tramp-compat-file-missing v dirname))
+ (tramp-error v 'file-missing dirname))
;; `copy-directory-create-symlink' exists since Emacs 28.1.
(if (and (bound-and-true-p copy-directory-create-symlink)
@@ -1952,7 +1956,7 @@ file names."
(let ((t1 (tramp-tramp-file-p filename))
(t2 (tramp-tramp-file-p newname))
- (length (tramp-compat-file-attribute-size
+ (length (file-attribute-size
(file-attributes (file-truename filename))))
(attributes (and preserve-extended-attributes
(file-extended-attributes filename)))
@@ -1960,7 +1964,7 @@ file names."
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
@@ -2052,7 +2056,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME."
;; Check, whether file is too large. Emacs checks in `insert-file-1'
;; and `find-file-noselect', but that's not called here.
(abort-if-file-too-large
- (tramp-compat-file-attribute-size (file-attributes (file-truename filename)))
+ (file-attribute-size (file-attributes (file-truename filename)))
(symbol-name op) filename)
;; We must disable multibyte, because binary data shall not be
;; converted. We don't want the target file to be compressed, so we
@@ -2074,8 +2078,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME."
(when keep-date
(tramp-compat-set-file-times
newname
- (tramp-compat-file-attribute-modification-time
- (file-attributes filename))
+ (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))
@@ -2094,7 +2097,7 @@ as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
the uid and gid from FILENAME."
(let ((t1 (tramp-tramp-file-p filename))
(t2 (tramp-tramp-file-p newname))
- (file-times (tramp-compat-file-attribute-modification-time
+ (file-times (file-attribute-modification-time
(file-attributes filename)))
(file-modes (tramp-default-file-modes filename)))
(with-parsed-tramp-file-name (if t1 filename newname) nil
@@ -2419,8 +2422,7 @@ The method used must be an out-of-band method."
(when (and keep-date (not copy-keep-date))
(tramp-compat-set-file-times
newname
- (tramp-compat-file-attribute-modification-time
- (file-attributes filename))
+ (file-attribute-modification-time (file-attributes filename))
(unless ok-if-already-exists 'nofollow)))
;; Set the mode.
@@ -2476,42 +2478,58 @@ The method used must be an out-of-band method."
(defun tramp-sh-handle-dired-compress-file (file)
"Like `dired-compress-file' for Tramp files."
- ;; Code stolen mainly from dired-aux.el.
- (with-parsed-tramp-file-name file nil
- (tramp-flush-file-properties v localname)
- (let ((suffixes dired-compress-file-suffixes)
- suffix)
- ;; See if any suffix rule matches this file name.
- (while suffixes
- (let (case-fold-search)
- (if (string-match-p (car (car suffixes)) localname)
- (setq suffix (car suffixes) suffixes nil))
- (setq suffixes (cdr suffixes))))
-
- (cond ((file-symlink-p file) nil)
- ((and suffix (nth 2 suffix))
- ;; We found an uncompression rule.
- (with-tramp-progress-reporter
- v 0 (format "Uncompressing %s" file)
- (when (tramp-send-command-and-check
- v (concat (nth 2 suffix) " "
- (tramp-shell-quote-argument localname)))
- (dired-remove-file file)
- (string-match (car suffix) file)
- (concat (substring file 0 (match-beginning 0))))))
- (t
- ;; We don't recognize the file as compressed, so compress it.
- ;; Try gzip.
- (with-tramp-progress-reporter v 0 (format "Compressing %s" file)
- (when (tramp-send-command-and-check
- v (concat "gzip -f "
- (tramp-shell-quote-argument localname)))
- (dired-remove-file file)
- (cond ((file-exists-p (concat file ".gz"))
- (concat file ".gz"))
- ((file-exists-p (concat file ".z"))
- (concat file ".z"))
- (t nil)))))))))
+ ;; Starting with Emacs 29.1, `dired-compress-file' is performed by
+ ;; default handler.
+ (if (>= emacs-major-version 29)
+ (tramp-run-real-handler #'dired-compress-file (list file))
+ ;; Code stolen mainly from dired-aux.el.
+ (with-parsed-tramp-file-name file nil
+ (tramp-flush-file-properties v localname)
+ (let ((suffixes dired-compress-file-suffixes)
+ suffix)
+ ;; See if any suffix rule matches this file name.
+ (while suffixes
+ (let (case-fold-search)
+ (if (string-match-p (car (car suffixes)) localname)
+ (setq suffix (car suffixes) suffixes nil))
+ (setq suffixes (cdr suffixes))))
+
+ (cond ((file-symlink-p file) nil)
+ ((and suffix (nth 2 suffix))
+ ;; We found an uncompression rule.
+ (with-tramp-progress-reporter
+ v 0 (format "Uncompressing %s" file)
+ (when (tramp-send-command-and-check
+ v (if (string-match-p "%[io]" (nth 2 suffix))
+ (replace-regexp-in-string
+ "%i" (tramp-shell-quote-argument localname)
+ (nth 2 suffix))
+ (concat (nth 2 suffix) " "
+ (tramp-shell-quote-argument localname))))
+ (unless (string-match-p "\\.tar\\.gz" file)
+ (dired-remove-file file))
+ (string-match (car suffix) file)
+ (concat (substring file 0 (match-beginning 0))))))
+ (t
+ ;; We don't recognize the file as compressed, so
+ ;; compress it. Try gzip.
+ (with-tramp-progress-reporter v 0 (format "Compressing %s" file)
+ (when (tramp-send-command-and-check
+ v (if (file-directory-p file)
+ (format "tar -cf - %s | gzip -c9 > %s.tar.gz"
+ (tramp-shell-quote-argument
+ (file-name-nondirectory localname))
+ (tramp-shell-quote-argument localname))
+ (concat "gzip -f "
+ (tramp-shell-quote-argument localname))))
+ (unless (file-directory-p file)
+ (dired-remove-file file))
+ (catch 'found nil
+ (dolist (target (mapcar (lambda (suffix)
+ (concat file suffix))
+ '(".tar.gz" ".gz" ".z")))
+ (when (file-exists-p target)
+ (throw 'found target))))))))))))
(defun tramp-sh-handle-insert-directory
(filename switches &optional wildcard full-directory-p)
@@ -2583,7 +2601,7 @@ The method used must be an out-of-band method."
;; We cannot use `insert-buffer-substring' because the Tramp
;; buffer changes its contents before insertion due to calling
;; `expand-file-name' and alike.
- (insert (with-current-buffer (tramp-get-buffer v) (buffer-string)))
+ (insert (tramp-get-buffer-string (tramp-get-buffer v)))
;; We must enable unibyte strings, because the "--dired"
;; output counts in bytes.
@@ -2693,11 +2711,11 @@ the result will be a local, non-Tramp, file name."
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
(setq name (tramp-compat-file-name-concat dir name)))
- ;; If connection is not established yet, run the real handler.
- (if (not (tramp-connectable-p name))
- (tramp-run-real-handler #'expand-file-name (list name nil))
- ;; Dissect NAME.
- (with-parsed-tramp-file-name name nil
+ ;; Dissect NAME.
+ (with-parsed-tramp-file-name name nil
+ ;; If connection is not established yet, run the real handler.
+ (if (not (tramp-connectable-p v))
+ (tramp-run-real-handler #'expand-file-name (list name nil))
(unless (tramp-run-real-handler #'file-name-absolute-p (list localname))
(setq localname (concat "~/" localname)))
;; Tilde expansion if necessary. This needs a shell which
@@ -3142,8 +3160,7 @@ implementation will be used."
(when outbuf
(with-current-buffer outbuf
(insert
- (with-current-buffer (tramp-get-connection-buffer v)
- (buffer-string))))
+ (tramp-get-buffer-string (tramp-get-connection-buffer v))))
(when (and display (get-buffer-window outbuf t)) (redisplay))))
;; When the user did interrupt, we should do it also. We use
;; return code -1 as marker.
@@ -3187,9 +3204,9 @@ implementation will be used."
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name filename nil
(unless (file-exists-p (file-truename filename))
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
- (let* ((size (tramp-compat-file-attribute-size
+ (let* ((size (file-attribute-size
(file-attributes (file-truename filename))))
(rem-enc (tramp-get-inline-coding v "remote-encoding" size))
(loc-dec (tramp-get-inline-coding v "local-decoding" size))
@@ -3276,11 +3293,9 @@ implementation will be used."
(tramp-error v 'file-already-exists filename))
(let ((file-locked (eq (file-locked-p lockname) t))
- (uid (or (tramp-compat-file-attribute-user-id
- (file-attributes filename 'integer))
+ (uid (or (file-attribute-user-id (file-attributes filename 'integer))
(tramp-get-remote-uid v 'integer)))
- (gid (or (tramp-compat-file-attribute-group-id
- (file-attributes filename 'integer))
+ (gid (or (file-attribute-group-id (file-attributes filename 'integer))
(tramp-get-remote-gid v 'integer))))
;; Lock file.
@@ -3359,8 +3374,7 @@ implementation will be used."
;; specified. However, if the method _also_ specifies an
;; encoding function, then that is used for encoding the
;; contents of the tmp file.
- (let* ((size (tramp-compat-file-attribute-size
- (file-attributes tmpfile)))
+ (let* ((size (file-attribute-size (file-attributes tmpfile)))
(rem-dec (tramp-get-inline-coding v "remote-decoding" size))
(loc-enc (tramp-get-inline-coding v "local-encoding" size)))
(cond
@@ -3460,8 +3474,7 @@ implementation will be used."
(not
(string-equal
(buffer-string)
- (with-current-buffer (tramp-get-buffer v)
- (buffer-string))))
+ (tramp-get-buffer-string (tramp-get-buffer v))))
(tramp-error
v 'file-error
(concat "Couldn't write region to `%s',"
@@ -3495,10 +3508,10 @@ implementation will be used."
;; We must pass modtime explicitly, because FILENAME can
;; be different from (buffer-file-name), f.e. if
;; `file-precious-flag' is set.
- (or (tramp-compat-file-attribute-modification-time file-attr)
+ (or (file-attribute-modification-time file-attr)
(current-time)))
- (when (and (= (tramp-compat-file-attribute-user-id file-attr) uid)
- (= (tramp-compat-file-attribute-group-id file-attr) gid))
+ (when (and (= (file-attribute-user-id file-attr) uid)
+ (= (file-attribute-group-id file-attr) gid))
(setq need-chown nil))))
;; Set the ownership.
@@ -3755,8 +3768,7 @@ Fall back to normal file name handler if no Tramp handler exists."
"Read output from \"gio monitor\" and add corresponding `file-notify' events."
(let ((events (process-get proc 'events))
(remote-prefix
- (with-current-buffer (process-buffer proc)
- (file-remote-p default-directory)))
+ (file-remote-p (tramp-get-default-directory (process-buffer proc))))
(rest-string (process-get proc 'rest-string))
pos)
(when rest-string
@@ -6011,5 +6023,8 @@ function cell is returned to be applied on a buffer."
;; be to stipulate, as a directory or connection-local variable, an
;; additional rc file on the remote machine that is sourced every
;; time Tramp connects. <https://emacs.stackexchange.com/questions/62306>
+;;
+;; * Support hostname canonicalization in ~/.ssh/config.
+;; <https://stackoverflow.com/questions/70205232/>
;;; tramp-sh.el ends here
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 49f049d3f34..34203076b24 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -222,7 +222,8 @@ See `tramp-actions-before-shell' for more info.")
;; New handlers should be added here.
;;;###tramp-autoload
(defconst tramp-smb-file-name-handler-alist
- '((access-file . tramp-handle-access-file)
+ '((abbreviate-file-name . tramp-handle-abbreviate-file-name)
+ (access-file . tramp-handle-access-file)
(add-name-to-file . tramp-smb-handle-add-name-to-file)
;; `byte-compiler-base-file-name' performed by default handler.
(copy-directory . tramp-smb-handle-copy-directory)
@@ -330,11 +331,10 @@ This can be used to disable echo etc."
;; 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-smb-file-name-p (filename)
- "Check if it's a FILENAME for SMB servers."
- (and (tramp-tramp-file-p filename)
- (string= (tramp-file-name-method (tramp-dissect-file-name filename))
- tramp-smb-method)))
+(defsubst tramp-smb-file-name-p (vec-or-filename)
+ "Check if it's a VEC-OR-FILENAME for SMB servers."
+ (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)))
+ (string= (tramp-file-name-method vec) tramp-smb-method)))
;;;###tramp-autoload
(defun tramp-smb-file-name-handler (operation &rest args)
@@ -419,7 +419,7 @@ arguments to pass to the OPERATION."
target)
(with-parsed-tramp-file-name (if t1 dirname newname) nil
(unless (file-exists-p dirname)
- (tramp-compat-file-missing v dirname))
+ (tramp-error v 'file-missing dirname))
;; `copy-directory-create-symlink' exists since Emacs 28.1.
(if (and (bound-and-true-p copy-directory-create-symlink)
@@ -442,7 +442,7 @@ arguments to pass to the OPERATION."
(with-tramp-progress-reporter
v 0 (format "Copying %s to %s" dirname newname)
(unless (file-exists-p dirname)
- (tramp-compat-file-missing v dirname))
+ (tramp-error v 'file-missing dirname))
(when (and (file-directory-p newname)
(not (directory-name-p newname)))
(tramp-error v 'file-already-exists newname))
@@ -567,8 +567,7 @@ arguments to pass to the OPERATION."
(when keep-date
(tramp-compat-set-file-times
newname
- (tramp-compat-file-attribute-modification-time
- (file-attributes dirname))
+ (file-attribute-modification-time (file-attributes dirname))
(unless ok-if-already-exists 'nofollow)))
;; Set the mode.
@@ -602,10 +601,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(copy-directory filename newname keep-date 'parents 'copy-contents)
(unless (file-exists-p filename)
- (tramp-compat-file-missing
+ (tramp-error
(tramp-dissect-file-name
(if (tramp-tramp-file-p filename) filename newname))
- filename))
+ 'file-missing filename))
(if-let ((tmpfile (file-local-copy filename)))
;; Remote filename.
@@ -645,8 +644,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(when keep-date
(tramp-compat-set-file-times
newname
- (tramp-compat-file-attribute-modification-time
- (file-attributes filename))
+ (file-attribute-modification-time (file-attributes filename))
(unless ok-if-already-exists 'nofollow)))))
(defun tramp-smb-handle-delete-directory (directory &optional recursive trash)
@@ -706,7 +704,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(directory &optional full match nosort count)
"Like `directory-files' for Tramp files."
(unless (file-exists-p directory)
- (tramp-compat-file-missing (tramp-dissect-file-name directory) directory))
+ (tramp-error (tramp-dissect-file-name directory) 'file-missing directory))
(let ((result (mapcar #'directory-file-name
(file-name-all-completions "" directory))))
;; Discriminate with regexp.
@@ -976,7 +974,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name (file-truename filename) nil
(unless (file-exists-p (file-truename filename))
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
(let ((tmpfile (tramp-compat-make-temp-file filename)))
(with-tramp-progress-reporter
v 3 (format "Fetching %s to tmp file %s" filename tmpfile)
@@ -1041,8 +1039,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
"Like `file-writable-p' for Tramp files."
(if (file-exists-p filename)
(tramp-compat-string-search
- "w"
- (or (tramp-compat-file-attribute-modes (file-attributes filename)) ""))
+ "w" (or (file-attribute-modes (file-attributes filename)) ""))
(let ((dir (file-name-directory filename)))
(and (file-exists-p dir)
(file-writable-p dir)))))
@@ -1145,11 +1142,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(insert
(format
"%10s %3d %-8s %-8s %8s %s "
- (or (tramp-compat-file-attribute-modes attr) (nth 1 x))
- (or (tramp-compat-file-attribute-link-number attr) 1)
- (or (tramp-compat-file-attribute-user-id attr) "nobody")
- (or (tramp-compat-file-attribute-group-id attr) "nogroup")
- (or (tramp-compat-file-attribute-size attr) (nth 2 x))
+ (or (file-attribute-modes attr) (nth 1 x))
+ (or (file-attribute-link-number attr) 1)
+ (or (file-attribute-user-id attr) "nobody")
+ (or (file-attribute-group-id attr) "nogroup")
+ (or (file-attribute-size attr) (nth 2 x))
(format-time-string
(if (time-less-p
;; Half a year.
@@ -1171,8 +1168,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; Insert symlink.
(when (and (tramp-compat-string-search "l" switches)
- (stringp (tramp-compat-file-attribute-type attr)))
- (insert " -> " (tramp-compat-file-attribute-type attr))))
+ (stringp (file-attribute-type attr)))
+ (insert " -> " (file-attribute-type attr))))
(insert "\n")
(beginning-of-line)))
@@ -1394,7 +1391,7 @@ component is used as the target of the symlink."
(with-parsed-tramp-file-name
(if (tramp-tramp-file-p filename) filename newname) nil
(unless (file-exists-p filename)
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
@@ -1439,9 +1436,9 @@ component is used as the target of the symlink."
(unless (process-live-p proc)
;; Accept pending output.
(while (tramp-accept-process-output proc))
- (with-current-buffer (tramp-get-connection-buffer vec)
- (tramp-message vec 10 "\n%s" (buffer-string))
- (throw 'tramp-action 'ok))))
+ (tramp-message
+ vec 10 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec)))
+ (throw 'tramp-action 'ok)))
(defun tramp-smb-handle-set-file-acl (filename acl-string)
"Like `set-file-acl' for Tramp files."
@@ -1647,8 +1644,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows."
;; Set file modification time.
(when (or (eq visit t) (stringp visit))
(set-visited-file-modtime
- (or (tramp-compat-file-attribute-modification-time
- (file-attributes filename))
+ (or (file-attribute-modification-time (file-attributes filename))
(current-time))))
;; Unlock file.
diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el
index 1886031dec7..ef1f302546a 100644
--- a/lisp/net/tramp-sshfs.el
+++ b/lisp/net/tramp-sshfs.el
@@ -71,7 +71,8 @@
;; New handlers should be added here.
;;;###tramp-autoload
(defconst tramp-sshfs-file-name-handler-alist
- '((access-file . tramp-handle-access-file)
+ '(;; `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)
@@ -156,11 +157,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.")
;; 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-sshfs-file-name-p (filename)
- "Check if it's a FILENAME for sshfs."
- (and (tramp-tramp-file-p filename)
- (string= (tramp-file-name-method (tramp-dissect-file-name filename))
- tramp-sshfs-method)))
+(defsubst tramp-sshfs-file-name-p (vec-or-filename)
+ "Check if it's a VEC-OR-FILENAME for sshfs."
+ (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)))
+ (string= (tramp-file-name-method vec) tramp-sshfs-method)))
;;;###tramp-autoload
(defun tramp-sshfs-file-name-handler (operation &rest args)
@@ -345,9 +345,6 @@ connection if a previous connection has died for some reason."
(process-put p 'vector vec)
(set-process-query-on-exit-flag p nil)
- ;; Mark process for filelock.
- (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds)))
-
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)))
diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el
index 845f31d09b1..88e8c43534b 100644
--- a/lisp/net/tramp-sudoedit.el
+++ b/lisp/net/tramp-sudoedit.el
@@ -63,7 +63,8 @@ See `tramp-actions-before-shell' for more info.")
;;;###tramp-autoload
(defconst tramp-sudoedit-file-name-handler-alist
- '((access-file . tramp-handle-access-file)
+ '((abbreviate-file-name . tramp-handle-abbreviate-file-name)
+ (access-file . tramp-handle-access-file)
(add-name-to-file . tramp-sudoedit-handle-add-name-to-file)
(byte-compiler-base-file-name . ignore)
(copy-directory . tramp-handle-copy-directory)
@@ -148,11 +149,10 @@ See `tramp-actions-before-shell' for more info.")
;; 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-sudoedit-file-name-p (filename)
- "Check if it's a FILENAME for SUDOEDIT."
- (and (tramp-tramp-file-p filename)
- (string= (tramp-file-name-method (tramp-dissect-file-name filename))
- tramp-sudoedit-method)))
+(defsubst tramp-sudoedit-file-name-p (vec-or-filename)
+ "Check if it's a VEC-OR-FILENAME for SUDOEDIT."
+ (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)))
+ (string= (tramp-file-name-method vec) tramp-sudoedit-method)))
;;;###tramp-autoload
(defun tramp-sudoedit-file-name-handler (operation &rest args)
@@ -233,7 +233,7 @@ absolute file names."
(let ((t1 (tramp-sudoedit-file-name-p filename))
(t2 (tramp-sudoedit-file-name-p newname))
- (file-times (tramp-compat-file-attribute-modification-time
+ (file-times (file-attribute-modification-time
(file-attributes filename)))
(file-modes (tramp-default-file-modes filename))
(attributes (and preserve-extended-attributes
@@ -247,7 +247,7 @@ absolute file names."
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
@@ -336,7 +336,7 @@ absolute file names."
(if (and delete-by-moving-to-trash trash)
(move-file-to-trash filename)
(unless (tramp-sudoedit-send-command
- v "rm" (tramp-compat-file-name-unquote localname))
+ v "rm" "-f" (tramp-compat-file-name-unquote localname))
;; Propagate the error.
(with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
@@ -453,12 +453,13 @@ the result will be a local, non-Tramp, file name."
(if (file-directory-p (expand-file-name f directory))
(file-name-as-directory f)
f))
- (with-current-buffer (tramp-get-connection-buffer v)
- (delq
- nil
- (mapcar
- (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l))
- (split-string (buffer-string) "\n" 'omit)))))))))
+ (delq
+ nil
+ (mapcar
+ (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l))
+ (split-string
+ (tramp-get-buffer-string (tramp-get-connection-buffer v))
+ "\n" 'omit))))))))
(defun tramp-sudoedit-handle-file-readable-p (filename)
"Like `file-readable-p' for Tramp files."
@@ -534,7 +535,7 @@ the result will be a local, non-Tramp, file name."
(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)
+ nil
time)))
(tramp-sudoedit-send-command
v "env" "TZ=UTC" "touch" "-t"
@@ -721,11 +722,9 @@ ID-FORMAT valid values are `string' and `integer'."
"Like `write-region' for Tramp files."
(setq filename (expand-file-name filename))
(with-parsed-tramp-file-name filename nil
- (let* ((uid (or (tramp-compat-file-attribute-user-id
- (file-attributes filename 'integer))
+ (let* ((uid (or (file-attribute-user-id (file-attributes filename 'integer))
(tramp-get-remote-uid v 'integer)))
- (gid (or (tramp-compat-file-attribute-group-id
- (file-attributes filename 'integer))
+ (gid (or (file-attribute-group-id (file-attributes filename 'integer))
(tramp-get-remote-gid v 'integer)))
(flag (and (eq mustbenew 'excl) 'nofollow))
(modes (tramp-default-file-modes filename flag))
@@ -736,10 +735,10 @@ ID-FORMAT valid values are `string' and `integer'."
;; Set the ownership, modes and extended attributes. This is
;; not performed in `tramp-handle-write-region'.
- (unless (and (= (tramp-compat-file-attribute-user-id
+ (unless (and (= (file-attribute-user-id
(file-attributes filename 'integer))
uid)
- (= (tramp-compat-file-attribute-group-id
+ (= (file-attribute-group-id
(file-attributes filename 'integer))
gid))
(tramp-set-file-uid-gid filename uid gid))
@@ -789,9 +788,6 @@ connection if a previous connection has died for some reason."
(process-put p 'vector vec)
(set-process-query-on-exit-flag p nil)
- ;; Mark process for filelock.
- (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds)))
-
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 740cb23ebee..940e25e04f9 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -751,11 +751,11 @@ The answer will be provided by `tramp-action-process-alive',
(defconst tramp-temp-name-prefix "tramp."
"Prefix to use for temporary files.
-If this is a relative file name (such as \"tramp.\"), it is considered
-relative to the directory name returned by the function
-`tramp-compat-temporary-file-directory' (which see). It may also be an
-absolute file name; don't forget to include a prefix for the filename
-part, though.")
+If this is a relative file name (such as \"tramp.\"), it is
+considered relative to the directory name returned by the
+function `temporary-file-directory' (which see). It may also be
+an absolute file name; don't forget to include a prefix for the
+filename part, though.")
(defconst tramp-temp-buffer-name " *tramp temp*"
"Buffer name for a temporary buffer.
@@ -822,11 +822,10 @@ to be set, depending on VALUE."
(tramp-register-file-name-handlers))
;; Initialize the Tramp syntax variables. We want to override initial
-;; value of `tramp-file-name-regexp'. Other Tramp syntax variables
-;; must be initialized as well to proper values. We do not call
+;; value of `tramp-file-name-regexp'. We do not call
;; `custom-set-variable', this would load Tramp via custom.el.
(tramp--with-startup
- (tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax)))
+ (tramp-set-syntax 'tramp-syntax tramp-syntax))
(defun tramp-syntax-values ()
"Return possible values of `tramp-syntax', a list."
@@ -836,9 +835,9 @@ to be set, depending on VALUE."
values))
(defun tramp-lookup-syntax (alist)
- "Look up a syntax string in ALIST according to `tramp-compat-tramp-syntax'.
-Raise an error if `tramp-syntax' is invalid."
- (or (cdr (assq (tramp-compat-tramp-syntax) alist))
+ "Look up a syntax string in ALIST according to `tramp-syntax'.
+Raise an error if it is invalid."
+ (or (cdr (assq tramp-syntax alist))
(error "Wrong `tramp-syntax' %s" tramp-syntax)))
(defconst tramp-prefix-format-alist
@@ -1409,8 +1408,7 @@ calling HANDLER.")
;; internal data structure. Convenience functions for internal
;; data structure.
-;; The basic structure for remote file names. We use a list :type,
-;; in order to be compatible with Emacs 25.
+;; The basic structure for remote file names.
(cl-defstruct (tramp-file-name (:type list) :named)
method user domain host port localname hop)
@@ -1522,7 +1520,7 @@ of `process-file', `start-file-process', or `shell-command'."
(or (and (tramp-tramp-file-p name)
(string-match (nth 0 tramp-file-name-structure) name)
(match-string (nth 4 tramp-file-name-structure) name))
- (tramp-compat-file-local-name name)))
+ (file-local-name name)))
;; The localname can be quoted with "/:". Extract this.
(defun tramp-unquote-file-local-name (name)
@@ -1669,6 +1667,18 @@ default values are used."
(put #'tramp-dissect-file-name 'tramp-suppress-trace t)
+(defun tramp-ensure-dissected-file-name (vec-or-filename)
+ "Return a `tramp-file-name' structure for VEC-OR-FILENAME.
+
+VEC-OR-FILENAME may be either a string or a `tramp-file-name'.
+If it's not a Tramp filename, return nil."
+ (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)
+
(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."
@@ -1839,9 +1849,7 @@ from the default one."
If connection-local variables are not supported by this Emacs
version, the function does nothing."
(with-current-buffer (tramp-get-connection-buffer vec)
- ;; `hack-connection-local-variables-apply' exists since Emacs 26.1.
- (tramp-compat-funcall
- 'hack-connection-local-variables-apply
+ (hack-connection-local-variables-apply
`(:application tramp
:protocol ,(tramp-file-name-method vec)
:user ,(tramp-file-name-user-domain vec)
@@ -1852,14 +1860,27 @@ version, the function does nothing."
If connection-local variables are not supported by this Emacs
version, the function does nothing."
(when (tramp-tramp-file-p default-directory)
- ;; `hack-connection-local-variables-apply' exists since Emacs 26.1.
- (tramp-compat-funcall
- 'hack-connection-local-variables-apply
+ (hack-connection-local-variables-apply
`(:application tramp
:protocol ,(file-remote-p default-directory 'method)
:user ,(file-remote-p default-directory 'user)
:machine ,(file-remote-p default-directory 'host)))))
+(defsubst tramp-get-default-directory (buffer)
+ "Return `default-directory' of BUFFER."
+ (buffer-local-value 'default-directory buffer))
+
+(put #'tramp-get-default-directory 'tramp-suppress-trace t)
+
+(defsubst tramp-get-buffer-string (&optional buffer)
+ "Return contents of BUFFER.
+If BUFFER is not a buffer or a buffer name, return the contents
+of `current-buffer'."
+ (with-current-buffer (or buffer (current-buffer))
+ (substring-no-properties (buffer-string))))
+
+(put #'tramp-get-buffer-string 'tramp-suppress-trace t)
+
(defun tramp-debug-buffer-name (vec)
"A name for the debug buffer for VEC."
(let ((method (tramp-file-name-method vec))
@@ -1898,29 +1919,55 @@ The outline level is equal to the verbosity of the Tramp message."
(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 1 10) ";; 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)
+ ;; 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)
- (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))
+ (tramp-setup-debug-buffer))
(current-buffer)))
(put #'tramp-get-debug-buffer 'tramp-suppress-trace t)
@@ -1982,9 +2029,7 @@ ARGUMENTS to actually emit the message (if applicable)."
(unless (bolp)
(insert "\n"))
;; Timestamp.
- (let ((now (current-time)))
- (insert (format-time-string "%T." now))
- (insert (format "%06d " (nth 2 now))))
+ (insert (format-time-string "%T.%6N "))
;; Calling Tramp function. We suppress compat and trace
;; functions from being displayed.
(let ((btn 1) btf fn)
@@ -2054,12 +2099,15 @@ applicable)."
;; Append connection buffer for error messages, if exists.
(when (= level 1)
(ignore-errors
- (with-current-buffer
- (if (processp vec-or-proc)
- (process-buffer vec-or-proc)
- (tramp-get-connection-buffer vec-or-proc 'dont-create))
- (setq fmt-string (concat fmt-string "\n%s")
- arguments (append arguments (list (buffer-string)))))))
+ (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 'vector))))
@@ -2121,8 +2169,8 @@ an input event arrives. The other arguments are passed to `tramp-error'."
(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 (with-current-buffer buf
- (tramp-dissect-file-name default-directory))))))
+ (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.
@@ -2186,10 +2234,14 @@ the resulting error message."
(defun tramp-test-message (fmt-string &rest arguments)
"Emit a Tramp message according `default-directory'."
- (if (tramp-tramp-file-p default-directory)
- (apply #'tramp-message
- (tramp-dissect-file-name default-directory) 0 fmt-string arguments)
- (apply #'message fmt-string arguments)))
+ (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)
@@ -2476,19 +2528,17 @@ Must be handled by the callers."
file-accessible-directory-p file-attributes
file-directory-p file-executable-p file-exists-p
file-local-copy file-modes file-name-as-directory
- file-name-directory 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
+ file-name-case-insensitive-p file-name-directory
+ 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 make-directory-internal set-file-acl
set-file-modes set-file-selinux-context set-file-times
substitute-in-file-name unhandled-file-name-directory
vc-registered
- ;; Emacs 26+ only.
- file-name-case-insensitive-p
;; Emacs 27+ only.
file-system-info
;; Emacs 28+ only.
@@ -2501,8 +2551,6 @@ Must be handled by the callers."
(nth 0 args)
default-directory))
;; STRING FILE.
- ;; Starting with Emacs 26.1, just the 2nd argument of
- ;; `make-symbolic-link' matters.
((eq operation 'make-symbolic-link) (nth 1 args))
;; FILE DIRECTORY resp FILE1 FILE2.
((member operation
@@ -2533,17 +2581,15 @@ Must be handled by the callers."
(if (bufferp (nth 0 args)) (nth 0 args) (current-buffer))))
;; COMMAND.
((member operation
- '(process-file shell-command start-file-process
- ;; Emacs 26+ only.
- make-nearby-temp-file temporary-file-directory
+ '(make-nearby-temp-file process-file shell-command
+ start-file-process temporary-file-directory
;; Emacs 27+ only.
exec-path make-process))
default-directory)
;; PROC.
((member operation '(file-notify-rm-watch file-notify-valid-p))
(when (processp (nth 0 args))
- (with-current-buffer (process-buffer (nth 0 args))
- default-directory)))
+ (tramp-get-default-directory (process-buffer (nth 0 args)))))
;; VEC.
((member operation '(tramp-get-remote-gid tramp-get-remote-uid))
(tramp-make-tramp-file-name (nth 0 args)))
@@ -2554,11 +2600,21 @@ Must be handled by the callers."
"Return foreign file name handler if exists."
(when (tramp-tramp-file-p filename)
(let ((handler tramp-foreign-file-name-handler-alist)
- elt res)
+ (vec (tramp-dissect-file-name filename))
+ elt func res)
(while handler
(setq elt (car handler)
handler (cdr handler))
- (when (funcall (car elt) filename)
+ ;; Previously, this function was called with FILENAME, but now
+ ;; it's called with the VEC.
+ (when (condition-case nil
+ (funcall (setq func (car elt)) vec)
+ (error
+ (setcar elt #'ignore)
+ (unless (member 'remote-file-error debug-ignored-errors)
+ (tramp-error
+ vec 'remote-file-error
+ "Not a valid Tramp file name function `%s'" func))))
(setq handler nil
res (cdr elt))))
res)))
@@ -2757,8 +2813,9 @@ remote file names."
(defun tramp-register-foreign-file-name-handler
(func handler &optional append)
"Register (FUNC . HANDLER) in `tramp-foreign-file-name-handler-alist'.
-FUNC is the function, which determines whether HANDLER is to be called.
-Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'."
+FUNC is the function, which takes a dissected filename and determines
+whether HANDLER is to be called. Add operations defined in
+`HANDLER-alist' to `tramp-file-name-handler'."
(add-to-list
'tramp-foreign-file-name-handler-alist `(,func . ,handler) append)
;; Mark `operations' the handler is responsible for.
@@ -2809,18 +2866,14 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'."
(defun tramp-command-completion-p (_symbol buffer)
"A predicate for Tramp interactive commands.
They are completed by \"M-x TAB\" only if the current buffer is remote."
- (with-current-buffer buffer (tramp-tramp-file-p default-directory)))
+ (tramp-tramp-file-p (tramp-get-default-directory buffer)))
(defun tramp-connectable-p (vec-or-filename)
"Check, whether it is possible to connect the remote host w/o side-effects.
This is true, if either the remote host is already connected, or if we are
not in completion mode."
(let ((tramp-verbose 0)
- (vec
- (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)))))
+ (vec (tramp-ensure-dissected-file-name vec-or-filename)))
(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.
@@ -3278,6 +3331,28 @@ User is always nil."
(defvar tramp-handle-write-region-hook nil
"Normal hook to be run at the end of `tramp-*-handle-write-region'.")
+;; `directory-abbrev-apply' and `directory-abbrev-make-regexp' exists
+;; since Emacs 29.1. Since this handler isn't called for older
+;; Emacsen, it is save to invoke them via `tramp-compat-funcall'.
+(defun tramp-handle-abbreviate-file-name (filename)
+ "Like `abbreviate-file-name' for Tramp files."
+ (let* ((case-fold-search (file-name-case-insensitive-p filename))
+ (vec (tramp-dissect-file-name filename))
+ (home-dir
+ (with-tramp-connection-property vec "home-directory"
+ (tramp-compat-funcall
+ 'directory-abbrev-apply
+ (expand-file-name (tramp-make-tramp-file-name vec "~"))))))
+ ;; If any elt of `directory-abbrev-alist' matches this name,
+ ;; abbreviate accordingly.
+ (setq filename (tramp-compat-funcall 'directory-abbrev-apply filename))
+ ;; Abbreviate home directory.
+ (if (string-match
+ (tramp-compat-funcall 'directory-abbrev-make-regexp home-dir) filename)
+ (tramp-make-tramp-file-name
+ vec (concat "~" (substring filename (match-beginning 1))))
+ filename)))
+
(defun tramp-handle-access-file (filename string)
"Like `access-file' for Tramp files."
(setq filename (file-truename filename))
@@ -3290,8 +3365,9 @@ User is always nil."
filename)
(tramp-error
v 'file-error (format "%s: Permission denied, %s" string filename)))
- (tramp-compat-file-missing
- v (format "%s: No such file or directory, %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)
@@ -3325,7 +3401,7 @@ User is always nil."
;; `copy-directory' creates NEWNAME before running this check. So
;; we do it ourselves.
(unless (file-exists-p directory)
- (tramp-compat-file-missing (tramp-dissect-file-name directory) directory))
+ (tramp-error (tramp-dissect-file-name directory) 'file-missing directory))
;; We must do it file-wise.
(tramp-run-real-handler
#'copy-directory
@@ -3346,7 +3422,7 @@ User is always nil."
(defun tramp-handle-directory-files (directory &optional full match nosort count)
"Like `directory-files' for Tramp files."
(unless (file-exists-p directory)
- (tramp-compat-file-missing (tramp-dissect-file-name directory) directory))
+ (tramp-error (tramp-dissect-file-name directory) 'file-missing directory))
(when (file-directory-p directory)
(setq directory (file-name-as-directory (expand-file-name directory)))
(let ((temp (nreverse (file-name-all-completions "" directory)))
@@ -3397,13 +3473,16 @@ User is always nil."
;; Do not keep "/..".
(when (string-match-p "^/\\.\\.?$" localname)
(setq localname "/"))
- ;; Do normal `expand-file-name' (this does "/./" and "/../").
+ ;; Do normal `expand-file-name' (this does "/./" and "/../"),
+ ;; unless there are tilde characters in file name.
;; `default-directory' is bound, because on Windows there would
;; be problems with UNC shares or Cygwin mounts.
(let ((default-directory tramp-compat-temporary-file-directory))
(tramp-make-tramp-file-name
- v (tramp-drop-volume-letter
- (tramp-run-real-handler #'expand-file-name (list localname))))))))
+ v (if (string-match-p "\\`~" localname)
+ localname
+ (tramp-drop-volume-letter
+ (tramp-run-real-handler #'expand-file-name (list localname)))))))))
(defun tramp-handle-file-accessible-directory-p (filename)
"Like `file-accessible-directory-p' for Tramp files."
@@ -3412,9 +3491,7 @@ User is always nil."
(defun tramp-handle-file-directory-p (filename)
"Like `file-directory-p' for Tramp files."
- (eq (tramp-compat-file-attribute-type
- (file-attributes (file-truename filename)))
- t))
+ (eq (file-attribute-type (file-attributes (file-truename filename))) t))
(defun tramp-handle-file-equal-p (filename1 filename2)
"Like `file-equalp-p' for Tramp files."
@@ -3446,7 +3523,7 @@ User is always nil."
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name filename nil
(unless (file-exists-p filename)
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
(let ((tmpfile (tramp-compat-make-temp-file filename)))
(copy-file filename tmpfile 'ok-if-already-exists 'keep-time)
tmpfile)))
@@ -3454,7 +3531,7 @@ User is always nil."
(defun tramp-handle-file-modes (filename &optional flag)
"Like `file-modes' for Tramp files."
(when-let ((attrs (file-attributes filename))
- (mode-string (tramp-compat-file-attribute-modes attrs)))
+ (mode-string (file-attribute-modes attrs)))
(if (and (not (eq flag 'nofollow)) (eq ?l (aref mode-string 0)))
(file-modes (file-truename filename))
(tramp-mode-string-to-int mode-string))))
@@ -3486,7 +3563,7 @@ User is always nil."
(tramp-get-method-parameter v 'tramp-case-insensitive)
;; There isn't. So we must check, in case there's a connection already.
- (and (file-remote-p filename nil 'connected)
+ (and (let ((non-essential t)) (tramp-connectable-p v))
(with-tramp-connection-property v "case-insensitive"
(ignore-errors
(with-tramp-progress-reporter v 5 "Checking case-insensitive"
@@ -3507,16 +3584,13 @@ User is always nil."
(directory-file-name
(file-name-directory candidate))))
;; Nothing found, so we must use a temporary file
- ;; for comparison. `make-nearby-temp-file' is added
- ;; to Emacs 26+ like `file-name-case-insensitive-p',
- ;; so there is no compatibility problem calling it.
+ ;; for comparison.
(unless (string-match-p
"[[:lower:]]" (tramp-file-local-name candidate))
(setq tmpfile
(let ((default-directory
- (file-name-directory filename)))
- (tramp-compat-funcall
- 'make-nearby-temp-file "tramp."))
+ (file-name-directory filename)))
+ (make-nearby-temp-file "tramp."))
candidate tmpfile))
;; Check for the existence of the same file with
;; upper case letters.
@@ -3577,9 +3651,8 @@ User is always nil."
((not (file-exists-p file1)) nil)
((not (file-exists-p file2)) t)
(t (time-less-p
- (tramp-compat-file-attribute-modification-time (file-attributes file2))
- (tramp-compat-file-attribute-modification-time
- (file-attributes file1))))))
+ (file-attribute-modification-time (file-attributes file2))
+ (file-attribute-modification-time (file-attributes file1))))))
(defun tramp-handle-file-readable-p (filename)
"Like `file-readable-p' for Tramp files."
@@ -3598,7 +3671,7 @@ User is always nil."
;; Sometimes, `file-attributes' does not return a proper value
;; even if `file-exists-p' does.
(when-let ((attr (file-attributes filename)))
- (eq ?- (aref (tramp-compat-file-attribute-modes attr) 0)))))
+ (eq ?- (aref (file-attribute-modes attr) 0)))))
(defun tramp-handle-file-remote-p (filename &optional identification connected)
"Like `file-remote-p' for Tramp files."
@@ -3630,7 +3703,7 @@ User is always nil."
(defun tramp-handle-file-symlink-p (filename)
"Like `file-symlink-p' for Tramp files."
- (let ((x (tramp-compat-file-attribute-type (file-attributes filename))))
+ (let ((x (file-attribute-type (file-attributes filename))))
(and (stringp x) x)))
(defun tramp-handle-file-truename (filename)
@@ -3719,7 +3792,7 @@ User is always nil."
(when (and (not tramp-allow-unsafe-temporary-files)
(not backup-inhibited)
(file-in-directory-p (car result) temporary-file-directory)
- (zerop (or (tramp-compat-file-attribute-user-id
+ (zerop (or (file-attribute-user-id
(file-attributes filename 'integer))
tramp-unknown-id-integer))
(not (with-tramp-connection-property
@@ -3776,7 +3849,7 @@ User is always nil."
(unwind-protect
(if (not (file-exists-p filename))
(let ((tramp-verbose (if visit 0 tramp-verbose)))
- (tramp-compat-file-missing v filename))
+ (tramp-error v 'file-missing filename))
(with-tramp-progress-reporter
v 3 (format-message "Inserting `%s'" filename)
@@ -3890,16 +3963,19 @@ Return nil when there is no lockfile."
(insert-file-contents-literally lockname)
(buffer-string))))))
+(defvar tramp-lock-pid nil
+ "A random nunber local for every connection.
+Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.")
+
(defun tramp-get-lock-pid (file)
"Determine pid for lockfile of FILE."
- ;; Some Tramp methods do not offer a connection process, but just a
- ;; network process as a place holder. Those processes use the
- ;; "lock-pid" connection property as fake pid, in fact it is the
- ;; time stamp the process is created.
- (let ((p (tramp-get-process (tramp-dissect-file-name file))))
- (number-to-string
- (or (process-id p)
- (tramp-get-connection-property p "lock-pid" (emacs-pid))))))
+ ;; Not all Tramp methods use an own process. So we use a random
+ ;; number, which is as good as a process id.
+ (with-current-buffer
+ (tramp-get-connection-buffer (tramp-dissect-file-name file))
+ (or tramp-lock-pid
+ (setq-local
+ tramp-lock-pid (number-to-string (random most-positive-fixnum))))))
(defconst tramp-lock-file-info-regexp
;; USER@HOST.PID[:BOOT_TIME]
@@ -3910,9 +3986,11 @@ Return nil when there is no lockfile."
"Like `file-locked-p' for Tramp files."
(when-let ((info (tramp-get-lock-file file))
(match (string-match tramp-lock-file-info-regexp info)))
- (or (and (string-equal (match-string 1 info) (user-login-name))
+ (or ; Locked by me.
+ (and (string-equal (match-string 1 info) (user-login-name))
(string-equal (match-string 2 info) (system-name))
(string-equal (match-string 3 info) (tramp-get-lock-pid file)))
+ ; User name.
(match-string 1 info))))
(defun tramp-handle-lock-file (file)
@@ -3941,7 +4019,7 @@ Return nil when there is no lockfile."
(when (and (not tramp-allow-unsafe-temporary-files)
create-lockfiles
(file-in-directory-p lockname temporary-file-directory)
- (zerop (or (tramp-compat-file-attribute-user-id
+ (zerop (or (file-attribute-user-id
(file-attributes file 'integer))
tramp-unknown-id-integer))
(not (with-tramp-connection-property
@@ -3993,7 +4071,7 @@ Return nil when there is no lockfile."
v 'file-error
"File `%s' does not include a `.el' or `.elc' suffix" file)))
(unless (or noerror (file-exists-p file))
- (tramp-compat-file-missing v file))
+ (tramp-error v 'file-missing file))
(if (not (file-exists-p file))
nil
(let ((signal-hook-function (unless noerror signal-hook-function))
@@ -4255,18 +4333,13 @@ substitution. SPEC-LIST is a list of char/value pairs used for
p))))))
(defun tramp-handle-make-symbolic-link
- (target linkname &optional ok-if-already-exists)
+ (_target linkname &optional _ok-if-already-exists)
"Like `make-symbolic-link' for Tramp files.
This is the fallback implementation for backends which do not
support symbolic links."
- (if (tramp-tramp-file-p (expand-file-name linkname))
- (tramp-error
- (tramp-dissect-file-name (expand-file-name linkname)) 'file-error
- "make-symbolic-link not supported")
- ;; This is needed prior Emacs 26.1, where TARGET has also be
- ;; checked for a file name handler.
- (tramp-run-real-handler
- #'make-symbolic-link (list target linkname ok-if-already-exists))))
+ (tramp-error
+ (tramp-dissect-file-name (expand-file-name linkname)) 'file-error
+ "make-symbolic-link not supported"))
(defun tramp-handle-shell-command (command &optional output-buffer error-buffer)
"Like `shell-command' for Tramp files."
@@ -4484,7 +4557,7 @@ BUFFER might be a list, in this case STDERR is separated."
(unless time-list
(let ((remote-file-name-inhibit-cache t))
(setq time-list
- (or (tramp-compat-file-attribute-modification-time
+ (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)
@@ -4508,7 +4581,7 @@ of."
t
(let* ((remote-file-name-inhibit-cache t)
(attr (file-attributes f))
- (modtime (tramp-compat-file-attribute-modification-time attr))
+ (modtime (file-attribute-modification-time attr))
(mt (visited-file-modtime)))
(cond
@@ -4539,11 +4612,9 @@ of."
(tmpfile (tramp-compat-make-temp-file filename))
(modes (tramp-default-file-modes
filename (and (eq mustbenew 'excl) 'nofollow)))
- (uid (or (tramp-compat-file-attribute-user-id
- (file-attributes filename 'integer))
+ (uid (or (file-attribute-user-id (file-attributes filename 'integer))
(tramp-get-remote-uid v 'integer)))
- (gid (or (tramp-compat-file-attribute-group-id
- (file-attributes filename 'integer))
+ (gid (or (file-attribute-group-id (file-attributes filename 'integer))
(tramp-get-remote-gid v 'integer))))
;; Lock file.
@@ -4579,8 +4650,7 @@ of."
;; Set file modification time.
(when (or (eq visit t) (stringp visit))
(set-visited-file-modtime
- (or (tramp-compat-file-attribute-modification-time
- (file-attributes filename))
+ (or (file-attribute-modification-time (file-attributes filename))
(current-time))))
;; Set the ownership.
@@ -4661,8 +4731,8 @@ of."
(save-window-excursion
(pop-to-buffer (tramp-get-connection-buffer vec))
(read-string (match-string 0)))))))
- (with-current-buffer (tramp-get-connection-buffer vec)
- (tramp-message vec 6 "\n%s" (buffer-string)))
+ (tramp-message
+ vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec)))
(tramp-message vec 3 "Sending login name `%s'" user)
(tramp-send-string vec (concat user tramp-local-end-of-line)))
t)
@@ -4705,8 +4775,8 @@ See also `tramp-action-yn'."
(unless (yes-or-no-p (match-string 0))
(kill-process proc)
(throw 'tramp-action 'permission-denied))
- (with-current-buffer (tramp-get-connection-buffer vec)
- (tramp-message vec 6 "\n%s" (buffer-string)))
+ (tramp-message
+ vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec)))
(tramp-send-string vec (concat "yes" tramp-local-end-of-line)))
t)
@@ -4719,8 +4789,8 @@ See also `tramp-action-yesno'."
(unless (y-or-n-p (match-string 0))
(kill-process proc)
(throw 'tramp-action 'permission-denied))
- (with-current-buffer (tramp-get-connection-buffer vec)
- (tramp-message vec 6 "\n%s" (buffer-string)))
+ (tramp-message
+ vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec)))
(tramp-send-string vec (concat "y" tramp-local-end-of-line)))
t)
@@ -4728,15 +4798,15 @@ See also `tramp-action-yesno'."
"Tell the remote host which terminal type to use.
The terminal type can be configured with `tramp-terminal-type'."
(tramp-message vec 5 "Setting `%s' as terminal type." tramp-terminal-type)
- (with-current-buffer (tramp-get-connection-buffer vec)
- (tramp-message vec 6 "\n%s" (buffer-string)))
+ (tramp-message
+ vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec)))
(tramp-send-string vec (concat tramp-terminal-type tramp-local-end-of-line))
t)
(defun tramp-action-confirm-message (_proc vec)
"Return RET in order to confirm the message."
- (with-current-buffer (tramp-get-connection-buffer vec)
- (tramp-message vec 6 "\n%s" (buffer-string)))
+ (tramp-message
+ vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec)))
(tramp-send-string vec tramp-local-end-of-line)
t)
@@ -5024,8 +5094,8 @@ nil."
;; 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
- (with-current-buffer (process-buffer proc)
- (tramp-message proc 6 "\n%s" (buffer-string))))
+ (tramp-message
+ proc 6 "\n%s" (tramp-get-buffer-string (process-buffer proc))))
(unless found
(if timeout
(tramp-error
@@ -5247,7 +5317,7 @@ If FILENAME is remote, a file name handler is called."
(let* ((dir (file-name-directory filename))
(modes (file-modes dir)))
(when (and modes (not (zerop (logand modes #o2000))))
- (setq gid (tramp-compat-file-attribute-group-id (file-attributes dir)))))
+ (setq gid (file-attribute-group-id (file-attributes dir)))))
(if-let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid)))
(funcall handler #'tramp-set-file-uid-gid filename uid gid)
@@ -5276,8 +5346,7 @@ ID-FORMAT valid values are `string' and `integer'."
;; `group-name' has been introduced with Emacs 27.1.
((and (fboundp 'group-name) (equal id-format 'string))
(tramp-compat-funcall 'group-name (group-gid)))
- ((tramp-compat-file-attribute-group-id
- (file-attributes "~/" id-format))))))
+ ((file-attribute-group-id (file-attributes "~/" id-format))))))
(defun tramp-get-local-locale (&optional vec)
"Determine locale, supporting UTF8 if possible.
@@ -5332,31 +5401,22 @@ be granted."
file-attr
(or
;; Not a symlink.
- (eq t (tramp-compat-file-attribute-type file-attr))
- (null (tramp-compat-file-attribute-type file-attr)))
+ (eq t (file-attribute-type file-attr))
+ (null (file-attribute-type file-attr)))
(or
;; World accessible.
- (eq access
- (aref (tramp-compat-file-attribute-modes file-attr)
- (+ offset 6)))
+ (eq access (aref (file-attribute-modes file-attr) (+ offset 6)))
;; User accessible and owned by user.
(and
- (eq access
- (aref (tramp-compat-file-attribute-modes file-attr) offset))
- (or (equal remote-uid
- (tramp-compat-file-attribute-user-id file-attr))
- (equal unknown-id
- (tramp-compat-file-attribute-user-id file-attr))))
+ (eq access (aref (file-attribute-modes file-attr) offset))
+ (or (equal remote-uid (file-attribute-user-id file-attr))
+ (equal unknown-id (file-attribute-user-id file-attr))))
;; Group accessible and owned by user's principal group.
(and
(eq access
- (aref (tramp-compat-file-attribute-modes file-attr)
- (+ offset 3)))
- (or (equal remote-gid
- (tramp-compat-file-attribute-group-id file-attr))
- (equal unknown-id
- (tramp-compat-file-attribute-group-id
- file-attr))))))))))))
+ (aref (file-attribute-modes file-attr) (+ offset 3)))
+ (or (equal remote-gid (file-attribute-group-id file-attr))
+ (equal unknown-id (file-attribute-group-id file-attr))))))))))))
(defun tramp-get-remote-uid (vec id-format)
"The uid of the remote connection VEC, in ID-FORMAT.
@@ -5497,7 +5557,7 @@ this file, if that variable is non-nil."
(when (and (not tramp-allow-unsafe-temporary-files)
auto-save-default
(file-in-directory-p result temporary-file-directory)
- (zerop (or (tramp-compat-file-attribute-user-id
+ (zerop (or (file-attribute-user-id
(file-attributes filename 'integer))
tramp-unknown-id-integer))
(not (with-tramp-connection-property
@@ -5533,8 +5593,7 @@ ALIST is of the form ((FROM . TO) ...)."
(defun tramp-handle-make-nearby-temp-file (prefix &optional dir-flag suffix)
"Like `make-nearby-temp-file' for Tramp files."
- (let ((temporary-file-directory
- (tramp-compat-temporary-file-directory-function)))
+ (let ((temporary-file-directory (temporary-file-directory)))
(make-temp-file prefix dir-flag suffix)))
;;; Compatibility functions section:
@@ -5557,14 +5616,12 @@ are written with verbosity of 6."
(with-temp-buffer
(setq result
(apply
- #'call-process program infile (or destination t) display args))
+ #'call-process program infile (or destination t) display args)
+ output (tramp-get-buffer-string destination))
;; `result' could also be an error string.
(when (stringp result)
(setq error result
- result 1))
- (with-current-buffer
- (if (bufferp destination) destination (current-buffer))
- (setq output (buffer-string))))
+ result 1)))
(error
(setq error (error-message-string err)
result 1)))
@@ -5595,10 +5652,10 @@ are written with verbosity of 6."
;; `result' could also be an error string.
(when (stringp result)
(signal 'file-error (list result)))
- (with-current-buffer (if (bufferp buffer) buffer (current-buffer))
- (if (zerop result)
- (tramp-message vec 6 "%d" result)
- (tramp-message vec 6 "%d\n%s" result (buffer-string)))))
+ (if (zerop result)
+ (tramp-message vec 6 "%d" result)
+ (tramp-message
+ vec 6 "%d\n%s" result (tramp-get-buffer-string buffer))))
(error
(setq result 1)
(tramp-message vec 6 "%d\n%s" result (error-message-string err))))
@@ -5663,7 +5720,7 @@ Invokes `password-read' if available, `read-passwd' else."
(format "%s for %s " (capitalize (match-string 1)) key))))
(auth-source-creation-prompts `((secret . ,pw-prompt)))
;; Use connection-local value.
- (auth-sources (with-current-buffer (process-buffer proc) auth-sources))
+ (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)
@@ -5704,15 +5761,12 @@ Invokes `password-read' if available, `read-passwd' else."
(setq auth-passwd (funcall auth-passwd)))
auth-passwd)
- ;; Try the password cache. Exists since Emacs 26.1.
+ ;; Try the password cache.
(progn
(setq auth-passwd (password-read pw-prompt key)
tramp-password-save-function
(lambda () (password-cache-add key auth-passwd)))
- auth-passwd)
-
- ;; Else, get the password interactively w/o cache.
- (read-passwd pw-prompt))
+ auth-passwd))
;; Workaround. Prior Emacs 28.1, auth-source has saved
;; empty passwords. See discussion in Bug#50399.
@@ -5824,13 +5878,11 @@ name of a process or buffer, or nil to default to the current buffer."
(while (tramp-accept-process-output proc 0))
(not (process-live-p proc))))))
-;; `interrupt-process-functions' exists since Emacs 26.1.
-(when (boundp 'interrupt-process-functions)
- (add-hook 'interrupt-process-functions #'tramp-interrupt-process)
- (add-hook
- 'tramp-unload-hook
- (lambda ()
- (remove-hook 'interrupt-process-functions #'tramp-interrupt-process))))
+(add-hook 'interrupt-process-functions #'tramp-interrupt-process)
+(add-hook
+ 'tramp-unload-hook
+ (lambda ()
+ (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))
(defun tramp-get-remote-null-device (vec)
"Return null device on the remote host identified by VEC.
@@ -5894,5 +5946,11 @@ BODY is the backend specific code."
;; and friends, for most of the handlers this is the major
;; difference between the different backends. Other handlers but
;; *-process-file would profit from this as well.
+;;
+;; * Implement file name abbreviation for a different user. That is,
+;; (abbreviate-file-name "/ssh:user1@host:/home/user2") =>
+;; "/ssh:user1@host:~user2".
+;;
+;; * Implement file name abbreviation for user and host names.
;;; tramp.el ends here
diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el
index 680bcf09318..6dc5da229c1 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.5.2.28.1
-;; Package-Requires: ((emacs "25.1"))
+;; Version: 2.6.0-pre
+;; Package-Requires: ((emacs "26.1"))
;; Package-Type: multi
;; URL: https://www.gnu.org/software/tramp/
@@ -40,7 +40,7 @@
;; ./configure" to change them.
;;;###tramp-autoload
-(defconst tramp-version "2.5.2.28.1"
+(defconst tramp-version "2.6.0-pre"
"This version of Tramp.")
;;;###tramp-autoload
@@ -74,9 +74,9 @@
"The repository revision of the Tramp sources.")
;; Check for Emacs version.
-(let ((x (if (not (string-lessp emacs-version "25.1"))
+(let ((x (if (not (string-version-lessp emacs-version "26.1"))
"ok"
- (format "Tramp 2.5.2.28.1 is not fit for %s"
+ (format "Tramp 2.6.0-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/nxml/rng-cmpct.el b/lisp/nxml/rng-cmpct.el
index dd3000773fd..1476aa0e5a3 100644
--- a/lisp/nxml/rng-cmpct.el
+++ b/lisp/nxml/rng-cmpct.el
@@ -369,7 +369,7 @@ OVERRIDE is either nil, require or t."
(while (re-search-forward "\\\\x+{\\([[:xdigit:]]+\\)}"
(point-max)
t)
- (let* ((ch (decode-char 'ucs (string-to-number (match-string 1) 16))))
+ (let* ((ch (string-to-number (match-string 1) 16)))
(if (and ch (> ch 0))
(let ((begin (match-beginning 0))
(end (match-end 0)))
diff --git a/lisp/nxml/xmltok.el b/lisp/nxml/xmltok.el
index 6159e00c511..ecad501a644 100644
--- a/lisp/nxml/xmltok.el
+++ b/lisp/nxml/xmltok.el
@@ -943,7 +943,6 @@ and VALUE-END, otherwise a STRING giving the value."
(let ((n (string-to-number (buffer-substring-no-properties start end)
base)))
(cond ((and (integerp n) (xmltok-valid-char-p n))
- (setq n (xmltok-unicode-to-char n))
(and n (string n)))
(t
(xmltok-add-error "Invalid character code" start end)
@@ -971,11 +970,6 @@ and VALUE-END, otherwise a STRING giving the value."
(t (and (> n #xFFFF)
(< n #x110000)))))
-(defun xmltok-unicode-to-char (n)
- "Return the character corresponding to Unicode scalar value N.
-Return nil if unsupported in Emacs."
- (decode-char 'ucs n))
-
;;; Prolog parsing
(defvar xmltok-contains-doctype nil)
@@ -1766,6 +1760,10 @@ and `xmltok-namespace-attributes'."
xmltok-type))
(message "Scanned end of file")))
+;;; Obsolete
+
+(define-obsolete-function-alias 'xmltok-unicode-to-char #'identity "29.1")
+
(provide 'xmltok)
;;; xmltok.el ends here
diff --git a/lisp/nxml/xsd-regexp.el b/lisp/nxml/xsd-regexp.el
index f07ca6657ed..d6eaf7cc4bc 100644
--- a/lisp/nxml/xsd-regexp.el
+++ b/lisp/nxml/xsd-regexp.el
@@ -52,9 +52,6 @@
;; or a character translatable to such a character (i.e a character
;; for which `encode-char' will return non-nil).
;;
-;; Using unify-8859-on-decoding-mode is probably a good idea here
-;; (and generally with XML and other Unicode-oriented formats).
-;;
;; Unfortunately, this means that this package is currently useless
;; for CJK characters, since there's no mule-unicode charset for the
;; CJK ranges of Unicode. We should devise a workaround for this
@@ -290,7 +287,7 @@ and whose tail is ACCUM."
(defun xsdre-compile-single-char (ch)
(if (memq ch '(?. ?* ?+ ?? ?\[ ?\] ?^ ?$ ?\\))
(string ?\\ ch)
- (string (decode-char 'ucs ch))))
+ (string ch)))
(defun xsdre-char-class-to-range-list (cc)
"Return a range-list for a symbolic char-class CC."
@@ -407,10 +404,6 @@ consisting of a single char alternative delimited with []."
(cons last chars)
(cons last (cons ?- chars))))))
(setq range-list (cdr range-list)))
- (setq chars
- (mapcar (lambda (c)
- (decode-char 'ucs c))
- chars))
(when caret
(setq chars (cons ?^ chars)))
(when hyphen
diff --git a/lisp/obsolete/cl-compat.el b/lisp/obsolete/cl-compat.el
index 619bc06122b..0dba366192e 100644
--- a/lisp/obsolete/cl-compat.el
+++ b/lisp/obsolete/cl-compat.el
@@ -52,6 +52,7 @@
;;; Keyword routines not supported by new package.
(defmacro defkeyword (x &optional doc)
+ (declare (indent defun))
(cl-list* 'defconst x (list 'quote x) (and doc (list doc))))
(defun keyword-of (sym)
diff --git a/lisp/obsolete/cl.el b/lisp/obsolete/cl.el
index 9df62318572..a892ed7c76b 100644
--- a/lisp/obsolete/cl.el
+++ b/lisp/obsolete/cl.el
@@ -513,7 +513,8 @@ a temporary-variables list, a value-forms list, a store-variables list
See `gv-define-expander', and `gv-define-setter' for better and
simpler ways to define setf-methods."
(declare (debug
- (&define name cl-lambda-list cl-declarations-or-string def-body)))
+ (&define name cl-lambda-list cl-declarations-or-string def-body))
+ (indent defun))
`(progn
,@(if (stringp (car body))
(list `(put ',name 'setf-documentation ,(pop body))))
@@ -554,7 +555,8 @@ You can replace this form with `gv-define-setter'.
(&define name
[&or [symbolp &optional stringp]
[cl-lambda-list (symbolp)]]
- cl-declarations-or-string def-body)))
+ cl-declarations-or-string def-body))
+ (indent defun))
(if (and (listp arg1) (consp args))
;; Like `gv-define-setter' but with `cl-function'.
`(gv-define-expander ,name
@@ -615,7 +617,8 @@ arguments from ARGLIST using FUNC. For example:
You can replace this macro with `gv-letplace'."
(declare (debug
(&define name cl-lambda-list ;; should exclude &key
- symbolp &optional stringp)))
+ symbolp &optional stringp))
+ (indent defun))
(if (memq '&key arglist)
(error "&key not allowed in define-modify-macro"))
(require 'cl-macs) ;For cl--arglist-args.
diff --git a/lisp/obsolete/crisp.el b/lisp/obsolete/crisp.el
index 69bf3ed12bc..ccf9aaa2b6a 100644
--- a/lisp/obsolete/crisp.el
+++ b/lisp/obsolete/crisp.el
@@ -231,27 +231,13 @@ does not load the scroll-all package."
;; The cut and paste routines are different between XEmacs and Emacs
;; so we need to set up aliases for the functions.
-
-(defalias 'crisp-set-clipboard
- (if (fboundp 'clipboard-kill-ring-save)
- 'clipboard-kill-ring-save
- 'copy-primary-selection))
-
-(defalias 'crisp-kill-region
- (if (fboundp 'clipboard-kill-region)
- 'clipboard-kill-region
- 'kill-primary-selection))
-
-(defalias 'crisp-yank-clipboard
- (if (fboundp 'clipboard-yank)
- 'clipboard-yank
- 'yank-clipboard-selection))
+(defalias 'crisp-set-clipboard 'clipboard-kill-ring-save)
+(defalias 'crisp-kill-region 'clipboard-kill-region)
+(defalias 'crisp-yank-clipboard 'clipboard-yank)
(defun crisp-region-active ()
"Compatibility function to test for an active region."
- (if (featurep 'xemacs)
- zmacs-region-active-p
- mark-active))
+ mark-active)
(defun crisp-version (&optional arg)
"Version number of the CRiSP emulator package.
diff --git a/lisp/obsolete/eieio-compat.el b/lisp/obsolete/eieio-compat.el
new file mode 100644
index 00000000000..60b0638c63f
--- /dev/null
+++ b/lisp/obsolete/eieio-compat.el
@@ -0,0 +1,277 @@
+;;; eieio-compat.el --- Compatibility with Older EIEIO versions -*- lexical-binding:t -*-
+
+;; Copyright (C) 1995-1996, 1998-2021 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Keywords: OO, lisp
+;; Package: eieio
+
+;; 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:
+
+;; Backward compatibility definition of old EIEIO functions in
+;; terms of newer equivalent.
+
+;; The main elements are the old EIEIO `defmethod' and `defgeneric' which are
+;; now implemented on top of cl-generic. The differences we have to
+;; accommodate are:
+;; - EIEIO's :static methods (turned into a new `eieio--static' specializer).
+;; - EIEIO's support for `call-next-method' and `next-method-p' instead of
+;; `cl-next-method-p' and `cl-call-next-method' (simple matter of renaming).
+;; - Different errors are signaled.
+;; - EIEIO's defgeneric does not reset the function.
+;; - EIEIO's no-next-method and no-applicable-method can't be aliases of
+;; cl-generic's namesakes since they have different calling conventions,
+;; which means that packages that (defmethod no-next-method ..) don't work.
+;; - EIEIO's `call-next-method' and `next-method-p' had dynamic scope whereas
+;; cl-generic's `cl-next-method-p' and `cl-call-next-method' are lexically
+;; scoped.
+
+;;; Code:
+
+(require 'eieio-core)
+(require 'cl-generic)
+
+(put 'eieio--defalias 'byte-hunk-handler
+ #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
+;;;###autoload
+(defun eieio--defalias (name body)
+ "Like `defalias', but with less side-effects.
+More specifically, it has no side-effects at all when the new function
+definition is the same (`eq') as the old one."
+ (cl-assert (not (symbolp body)))
+ (while (and (fboundp name) (symbolp (symbol-function name)))
+ ;; Follow aliases, so methods applied to obsolete aliases still work.
+ (setq name (symbol-function name)))
+ (unless (and (fboundp name)
+ (eq (symbol-function name) body))
+ (defalias name body)))
+
+;;;###autoload
+(defmacro defgeneric (method args &optional doc-string)
+ "Create a generic function METHOD.
+DOC-STRING is the base documentation for this class. A generic
+function has no body, as its purpose is to decide which method body
+is appropriate to use. Uses `defmethod' to create methods, and calls
+`defgeneric' for you. With this implementation the ARGS are
+currently ignored. You can use `defgeneric' to apply specialized
+top level documentation to a method."
+ (declare (doc-string 3) (obsolete cl-defgeneric "25.1")
+ (indent defun))
+ `(eieio--defalias ',method
+ (eieio--defgeneric-init-form
+ ',method
+ ,(if doc-string (help-add-fundoc-usage doc-string args)))))
+
+;;;###autoload
+(defmacro defmethod (method &rest args)
+ "Create a new METHOD through `defgeneric' with ARGS.
+
+The optional second argument KEY is a specifier that
+modifies how the method is called, including:
+ :before - Method will be called before the :primary
+ :primary - The default if not specified
+ :after - Method will be called after the :primary
+ :static - First arg could be an object or class
+The next argument is the ARGLIST. The ARGLIST specifies the arguments
+to the method as with `defun'. The first argument can have a type
+specifier, such as:
+ ((VARNAME CLASS) ARG2 ...)
+where VARNAME is the name of the local variable for the method being
+created. The CLASS is a class symbol for a class made with `defclass'.
+A DOCSTRING comes after the ARGLIST, and is optional.
+All the rest of the args are the BODY of the method. A method will
+return the value of the last form in the BODY.
+
+Summary:
+
+ (defmethod mymethod [:before | :primary | :after | :static]
+ ((typearg class-name) arg2 &optional opt &rest rest)
+ \"doc-string\"
+ body)"
+ (declare (doc-string 3) (obsolete cl-defmethod "25.1")
+ (indent defun)
+ (debug
+ (&define ; this means we are defining something
+ [&name sexp] ;Allow (setf ...) additionally to symbols.
+ ;; ^^ This is the methods symbol
+ [ &optional symbolp ] ; this is key :before etc
+ cl-generic-method-args ; arguments
+ [ &optional stringp ] ; documentation string
+ def-body ; part to be debugged
+ )))
+ (let* ((key (if (keywordp (car args)) (pop args)))
+ (params (car args))
+ (arg1 (car params))
+ (fargs (if (consp arg1)
+ (cons (car arg1) (cdr params))
+ params))
+ (class (if (consp arg1) (nth 1 arg1)))
+ (code `(lambda ,fargs ,@(cdr args))))
+ `(progn
+ ;; Make sure there is a generic and the byte-compiler sees it.
+ (defgeneric ,method ,args)
+ (eieio--defmethod ',method ',key ',class #',code))))
+
+(defun eieio--generic-static-symbol-specializers (tag &rest _)
+ (cl-assert (or (null tag) (eieio--class-p tag)))
+ (when (eieio--class-p tag)
+ (let ((superclasses (eieio--generic-subclass-specializers tag))
+ (specializers ()))
+ (dolist (superclass superclasses)
+ (push superclass specializers)
+ (push `(eieio--static ,(cadr superclass)) specializers))
+ (nreverse specializers))))
+
+(cl-generic-define-generalizer eieio--generic-static-symbol-generalizer
+ ;; Give it a slightly higher priority than `subclass' so that the
+ ;; interleaved list comes before subclass's non-interleaved list.
+ 61 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name)))
+ #'eieio--generic-static-symbol-specializers)
+(cl-generic-define-generalizer eieio--generic-static-object-generalizer
+ ;; Give it a slightly higher priority than `class' so that the
+ ;; interleaved list comes before the class's non-interleaved list.
+ 51 #'cl--generic-struct-tag
+ (lambda (tag &rest _)
+ (and (symbolp tag) (setq tag (cl--find-class tag))
+ (eieio--class-p tag)
+ (let ((superclasses (eieio--class-precedence-list tag))
+ (specializers ()))
+ (dolist (superclass superclasses)
+ (setq superclass (eieio--class-name superclass))
+ (push superclass specializers)
+ (push `(eieio--static ,superclass) specializers))
+ (nreverse specializers)))))
+
+(cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static)))
+ (list eieio--generic-static-symbol-generalizer
+ eieio--generic-static-object-generalizer))
+
+;;;###autoload
+(defun eieio--defgeneric-init-form (method doc-string)
+ (if doc-string (put method 'function-documentation doc-string))
+ (if (memq method '(no-next-method no-applicable-method))
+ (symbol-function method)
+ (let ((generic (cl-generic-ensure-function method)))
+ (or (symbol-function (cl--generic-name generic))
+ (cl--generic-make-function generic)))))
+
+;;;###autoload
+(defun eieio--defmethod (method kind argclass code)
+ (setq kind (intern (downcase (symbol-name kind))))
+ (let* ((specializer (if (not (eq kind :static))
+ (or argclass t)
+ (setq kind nil)
+ `(eieio--static ,argclass)))
+ (uses-cnm (not (memq kind '(:before :after))))
+ (specializers `((arg ,specializer)))
+ (code
+ ;; Backward compatibility for `no-next-method' and
+ ;; `no-applicable-method', which have slightly different calling
+ ;; convention than their cl-generic counterpart.
+ (pcase method
+ ('no-next-method
+ (setq method 'cl-no-next-method)
+ (setq specializers `(generic method ,@specializers))
+ (lambda (_generic _method &rest args) (apply code args)))
+ ('no-applicable-method
+ (setq method 'cl-no-applicable-method)
+ (setq specializers `(generic ,@specializers))
+ (lambda (generic arg &rest args)
+ (apply code arg (cl--generic-name generic) (cons arg args))))
+ (_ code))))
+ (cl-generic-define-method
+ method (unless (memq kind '(nil :primary)) (list kind))
+ specializers uses-cnm
+ (if uses-cnm
+ (let* ((docstring (documentation code 'raw))
+ (args (help-function-arglist code 'preserve-names))
+ (doc-only (if docstring
+ (let ((split (help-split-fundoc docstring nil)))
+ (if split (cdr split) docstring)))))
+ (lambda (cnm &rest args)
+ (:documentation
+ (help-add-fundoc-usage doc-only (cons 'cl-cnm args)))
+ (cl-letf (((symbol-function 'call-next-method) cnm)
+ ((symbol-function 'next-method-p)
+ (lambda () (cl--generic-isnot-nnm-p cnm))))
+ (apply code args))))
+ code))
+ ;; The old EIEIO code did not signal an error when there are methods
+ ;; applicable but only of the before/after kind. So if we add a :before
+ ;; or :after, make sure there's a matching dummy primary.
+ (when (and (memq kind '(:before :after))
+ ;; FIXME: Use `cl-find-method'?
+ (not (cl-find-method method ()
+ (mapcar (lambda (arg)
+ (if (consp arg) (nth 1 arg) t))
+ specializers))))
+ (cl-generic-define-method method () specializers t
+ (lambda (cnm &rest args)
+ (if (cl--generic-isnot-nnm-p cnm)
+ (apply cnm args)))))
+ method))
+
+;; Compatibility with code which tries to catch `no-method-definition' errors.
+(push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions))
+
+(defun generic-p (fname) (not (null (cl--generic fname))))
+
+(defun no-next-method (&rest args)
+ (declare (obsolete cl-no-next-method "25.1"))
+ (apply #'cl-no-next-method 'unknown nil args))
+
+(defun no-applicable-method (object method &rest args)
+ (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")
+(defun next-method-p ()
+ (declare (obsolete cl-next-method-p "25.1"))
+ ;; EIEIO's `next-method-p' just returned nil when called in an
+ ;; invalid context.
+ (message "next-method-p called outside of a primary or around method")
+ nil)
+
+;;;###autoload
+(defun eieio-defmethod (method args)
+ "Obsolete work part of an old version of the `defmethod' macro."
+ (declare (obsolete cl-defmethod "24.1"))
+ (eval `(defmethod ,method ,@args))
+ method)
+
+;;;###autoload
+(defun eieio-defgeneric (method doc-string)
+ "Obsolete work part of an old version of the `defgeneric' macro."
+ (declare (obsolete cl-defgeneric "24.1"))
+ (eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string))))
+ ;; Return the method
+ 'method)
+
+;;;###autoload
+(defun eieio-defclass (cname superclasses slots options)
+ (declare (obsolete eieio-defclass-internal "25.1"))
+ (eval `(defclass ,cname ,superclasses ,slots ,@options)))
+
+
+;; Local Variables:
+;; generated-autoload-file: "eieio-loaddefs.el"
+;; End:
+
+(provide 'eieio-compat)
+
+;;; eieio-compat.el ends here
diff --git a/lisp/obsolete/eudcb-ph.el b/lisp/obsolete/eudcb-ph.el
index 187879ce2f7..51a6780d903 100644
--- a/lisp/obsolete/eudcb-ph.el
+++ b/lisp/obsolete/eudcb-ph.el
@@ -176,9 +176,7 @@ SERVER is either a string naming the server or a list (NAME PORT)."
(setq eudc-ph-process-buffer (get-buffer-create (format " *PH-%s*" host)))
(with-current-buffer eudc-ph-process-buffer
(erase-buffer)
- (setq eudc-ph-read-point (point))
- (and (featurep 'xemacs) (featurep 'mule)
- (set-buffer-file-coding-system 'binary t)))
+ (setq eudc-ph-read-point (point)))
(setq process (open-network-stream "ph" eudc-ph-process-buffer host port))
(if (null process)
(throw 'done nil))
diff --git a/lisp/obsolete/fast-lock.el b/lisp/obsolete/fast-lock.el
index 960233d5627..1dee7120c0e 100644
--- a/lisp/obsolete/fast-lock.el
+++ b/lisp/obsolete/fast-lock.el
@@ -283,10 +283,7 @@ If a number, only buffers greater than this size have processing messages."
(other :tag "always" t)
(integer :tag "size")))
-(defvar fast-lock-save-faces
- (when (featurep 'xemacs)
- ;; XEmacs uses extents for everything, so we have to pick the right ones.
- font-lock-face-list)
+(defvar fast-lock-save-faces nil
"Faces that will be saved in a Font Lock cache file.
If nil, means information for all faces will be saved.")
@@ -707,35 +704,7 @@ See `fast-lock-get-face-properties'."
(while regions
(add-text-properties (nth 0 regions) (nth 1 regions) plist)
(setq regions (nthcdr 2 regions))))))))
-
-;; Functions for XEmacs:
-
-(unless (boundp 'font-lock-syntactic-keywords)
- (defvar font-lock-syntactic-keywords nil))
-
-(unless (boundp 'font-lock-inhibit-thing-lock)
- (defvar font-lock-inhibit-thing-lock nil))
-
-(unless (fboundp 'font-lock-compile-keywords)
- (defalias 'font-lock-compile-keywords #'identity))
-
-(unless (fboundp 'font-lock-eval-keywords)
- (defun font-lock-eval-keywords (keywords)
- (if (symbolp keywords)
- (font-lock-eval-keywords (if (fboundp keywords)
- (funcall keywords)
- (eval keywords t)))
- keywords)))
-
-(unless (fboundp 'font-lock-value-in-major-mode)
- (defun font-lock-value-in-major-mode (alist)
- (if (consp alist)
- (cdr (or (assq major-mode alist) (assq t alist)))
- alist)))
-
-(unless (fboundp 'current-message)
- (defun current-message ()
- ""))
+
;; Install ourselves:
diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el
index a630baf3543..f1e4414e93f 100644
--- a/lisp/obsolete/iswitchb.el
+++ b/lisp/obsolete/iswitchb.el
@@ -467,9 +467,7 @@ interfere with other minibuffer usage.")
(switch-to-buffer-other-window . iswitchb-buffer-other-window)
(switch-to-buffer-other-frame . iswitchb-buffer-other-frame)
(display-buffer . iswitchb-display-buffer)))
- (if (fboundp 'command-remapping)
- (define-key map (vector 'remap (car b)) (cdr b))
- (substitute-key-definition (car b) (cdr b) map global-map)))
+ (define-key map (vector 'remap (car b)) (cdr b)))
map)
"Global keymap for `iswitchb-mode'.")
@@ -977,17 +975,7 @@ Return the modified list with the last element prepended to it."
(set-buffer buf))
(with-output-to-temp-buffer temp-buf
- (if (featurep 'xemacs)
-
- ;; XEmacs extents are put on by default, doesn't seem to be
- ;; any way of switching them off.
- (display-completion-list (or iswitchb-matches iswitchb-buflist)
- :help-string "iswitchb "
- :activate-callback
- (lambda (_x _y _z)
- (message "doesn't work yet, sorry!")))
- ;; else running Emacs
- (display-completion-list (or iswitchb-matches iswitchb-buflist))))
+ (display-completion-list (or iswitchb-matches iswitchb-buflist)))
(setq iswitchb-common-match-inserted nil))))
;;; KILL CURRENT BUFFER
@@ -1326,9 +1314,7 @@ This is an example function which can be hooked on to
"Return non-nil if we should ignore case when matching.
See the variable `iswitchb-case' for details."
(if iswitchb-case
- (if (featurep 'xemacs)
- (isearch-no-upper-case-p iswitchb-text)
- (isearch-no-upper-case-p iswitchb-text t))))
+ (isearch-no-upper-case-p iswitchb-text t)))
;;;###autoload
(define-minor-mode iswitchb-mode
diff --git a/lisp/obsolete/otodo-mode.el b/lisp/obsolete/otodo-mode.el
index 47f5089452f..a71d2b82e4c 100644
--- a/lisp/obsolete/otodo-mode.el
+++ b/lisp/obsolete/otodo-mode.el
@@ -908,8 +908,7 @@ If INCLUDE-SEP is non-nil, return point after the separator."
;;;###autoload
(define-derived-mode todo-mode nil "TODO"
"Major mode for editing TODO lists."
- (when (featurep 'xemacs)
- (easy-menu-add todo-menu)))
+ nil)
(with-suppressed-warnings ((lexical date entry))
(defvar date)
diff --git a/lisp/obsolete/pgg-parse.el b/lisp/obsolete/pgg-parse.el
index 2c76365a415..3e4c216abef 100644
--- a/lisp/obsolete/pgg-parse.el
+++ b/lisp/obsolete/pgg-parse.el
@@ -496,8 +496,7 @@
(defun pgg-parse-armor (string)
(with-temp-buffer
(buffer-disable-undo)
- (unless (featurep 'xemacs)
- (set-buffer-multibyte nil))
+ (set-buffer-multibyte nil)
(insert string)
(pgg-decode-armor-region (point-min)(point))))
diff --git a/lisp/obsolete/pgg.el b/lisp/obsolete/pgg.el
index 5ed59933f23..127e1dc15c0 100644
--- a/lisp/obsolete/pgg.el
+++ b/lisp/obsolete/pgg.el
@@ -376,8 +376,7 @@ signer's public key from `pgg-default-keyserver-address'."
(if (null signature) nil
(with-temp-buffer
(buffer-disable-undo)
- (unless (featurep 'xemacs)
- (set-buffer-multibyte nil))
+ (set-buffer-multibyte nil)
(insert-file-contents signature)
(cdr (assq 2 (pgg-decode-armor-region
(point-min)(point-max)))))))
diff --git a/lisp/obsolete/tpu-edt.el b/lisp/obsolete/tpu-edt.el
index e0e89c390ea..b59fb8c868c 100644
--- a/lisp/obsolete/tpu-edt.el
+++ b/lisp/obsolete/tpu-edt.el
@@ -650,12 +650,8 @@ GOLD is the ASCII 7-bit escape sequence <ESC>OP.")
(setq tpu-mark-flag (if transient-mark-mode "" (if (tpu-mark) " @" " ")))
(force-mode-line-update))
-(cond ((featurep 'xemacs)
- (add-hook 'zmacs-deactivate-region-hook 'tpu-update-mode-line)
- (add-hook 'zmacs-activate-region-hook 'tpu-update-mode-line))
- (t
- (add-hook 'activate-mark-hook 'tpu-update-mode-line)
- (add-hook 'deactivate-mark-hook 'tpu-update-mode-line)))
+(add-hook 'activate-mark-hook 'tpu-update-mode-line)
+(add-hook 'deactivate-mark-hook 'tpu-update-mode-line)
;;;
@@ -727,15 +723,13 @@ Otherwise sets the tpu-match markers to nil and returns nil."
"TPU-edt version of the mark function.
Return the appropriate value of the mark for the current
version of Emacs."
- (cond ((featurep 'xemacs) (mark (not zmacs-regions)))
- (t (and mark-active (mark (not transient-mark-mode))))))
+ (and mark-active (mark (not transient-mark-mode))))
(defun tpu-set-mark (pos)
"TPU-edt version of the `set-mark' function.
Sets the mark at POS and activates the region according to the
current version of Emacs."
- (set-mark pos)
- (when (featurep 'xemacs) (when pos (zmacs-activate-region))))
+ (set-mark pos))
(defun tpu-string-prompt (prompt history-symbol)
"Read a string with PROMPT."
@@ -2306,17 +2300,14 @@ Accepts a prefix argument for the number of tpu-pan-columns to scroll."
;;;
(defun tpu-load-xkeys (file)
"Load the TPU-edt X-windows key definitions FILE.
-If FILE is nil, try to load a default file. The default file names are
-`~/.tpu-lucid-keys' for XEmacs, and `~/.tpu-keys' for Emacs."
+If FILE is nil, try to load a default file. The default file name is
+`~/.tpu-keys'."
(interactive "fX key definition file: ")
(cond (file
(setq file (expand-file-name file)))
(tpu-xkeys-file
(setq file (expand-file-name tpu-xkeys-file)))
- ((featurep 'xemacs)
- (setq file (convert-standard-filename
- (expand-file-name "~/.tpu-lucid-keys"))))
- (t
+ (t
(setq file (convert-standard-filename
(expand-file-name "~/.tpu-keys")))
(and (not (file-exists-p file))
diff --git a/lisp/obsolete/tpu-mapper.el b/lisp/obsolete/tpu-mapper.el
index 5ae0a6558d5..02ba3632504 100644
--- a/lisp/obsolete/tpu-mapper.el
+++ b/lisp/obsolete/tpu-mapper.el
@@ -46,24 +46,14 @@
;;;
(defun tpu-map-key (ident descrip func gold-func)
(interactive)
- (if (featurep 'xemacs)
- (progn
- (setq tpu-key-seq (read-key-sequence
- (format "Press %s%s: " ident descrip))
- tpu-key (format "[%s]" (event-key (aref tpu-key-seq 0))))
- (unless (equal tpu-key tpu-return)
- (set-buffer "Keys")
- (insert (format"(global-set-key %s %s)\n" tpu-key func))
- (set-buffer "Gold-Keys")
- (insert (format "(define-key tpu-gold-map %s %s)\n" tpu-key gold-func))))
- (message "Press %s%s: " ident descrip)
- (setq tpu-key-seq (read-event)
- tpu-key (format "[%s]" tpu-key-seq))
- (unless (equal tpu-key tpu-return)
- (set-buffer "Keys")
- (insert (format"(define-key tpu-global-map %s %s)\n" tpu-key func))
- (set-buffer "Gold-Keys")
- (insert (format "(define-key tpu-gold-map %s %s)\n" tpu-key gold-func))))
+ (message "Press %s%s: " ident descrip)
+ (setq tpu-key-seq (read-event)
+ tpu-key (format "[%s]" tpu-key-seq))
+ (unless (equal tpu-key tpu-return)
+ (set-buffer "Keys")
+ (insert (format"(define-key tpu-global-map %s %s)\n" tpu-key func))
+ (set-buffer "Gold-Keys")
+ (insert (format "(define-key tpu-gold-map %s %s)\n" tpu-key gold-func)))
(set-buffer "Directions")
tpu-key)
@@ -103,8 +93,7 @@ your local X guru can try to figure out why the key is being ignored."
;; Make sure the window is big enough to display the instructions
- (if (featurep 'xemacs) (set-screen-size (selected-screen) 80 36)
- (set-frame-size (selected-frame) 80 36))
+ (set-frame-size (selected-frame) 80 36)
;; Create buffers - Directions, Keys, Gold-Keys
@@ -162,14 +151,9 @@ your local X guru can try to figure out why the key is being ignored."
;; Save <CR> for future reference
- (cond
- ((featurep 'xemacs)
- (setq tpu-return-seq (read-key-sequence "Hit carriage-return <CR> to continue "))
- (setq tpu-return (concat "[" (format "%s" (event-key (aref tpu-return-seq 0))) "]")))
- (t
- (message "Hit carriage-return <CR> to continue ")
- (setq tpu-return-seq (read-event))
- (setq tpu-return (concat "[" (format "%s" tpu-return-seq) "]"))))
+ (message "Hit carriage-return <CR> to continue ")
+ (setq tpu-return-seq (read-event))
+ (setq tpu-return (concat "[" (format "%s" tpu-return-seq) "]"))
;; Build the keymap file
@@ -308,24 +292,14 @@ your local X guru can try to figure out why the key is being ignored."
;;
")
- (cond ((featurep 'xemacs)
- (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter-seq))
- (insert (format "(setq tpu-help-return \"%s\")\n" tpu-return-seq))
- (insert "(setq tpu-help-N \"[#<keypress-event N>]\")\n")
- (insert "(setq tpu-help-n \"[#<keypress-event n>]\")\n")
- (insert "(setq tpu-help-P \"[#<keypress-event P>]\")\n")
- (insert "(setq tpu-help-p \"[#<keypress-event p>]\")\n"))
- (t
- (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter))))
+ (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter))
(append-to-buffer "Keys" 1 (point))
(set-buffer "Keys")
;; Save the key mapping program
- (let ((file
- (convert-standard-filename
- (if (featurep 'xemacs) "~/.tpu-lucid-keys" "~/.tpu-keys"))))
+ (let ((file (convert-standard-filename "~/.tpu-keys")))
(set-visited-file-name
(read-file-name (format "Save key mapping to file (default %s): " file) "" file)))
(save-buffer)
diff --git a/lisp/obsolete/vc-arch.el b/lisp/obsolete/vc-arch.el
index fbbd2d4ecfe..1dffd36f0ea 100644
--- a/lisp/obsolete/vc-arch.el
+++ b/lisp/obsolete/vc-arch.el
@@ -83,8 +83,6 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(repeat :tag "Argument List" :value ("") string))
:version "23.1")
-(define-obsolete-variable-alias 'vc-arch-command 'vc-arch-program "23.1")
-
(defcustom vc-arch-program
(let ((candidates '("tla" "baz")))
(while (and candidates (not (executable-find (car candidates))))
diff --git a/lisp/org/ol.el b/lisp/org/ol.el
index aa1849715c3..b70f1996d54 100644
--- a/lisp/org/ol.el
+++ b/lisp/org/ol.el
@@ -1575,7 +1575,7 @@ non-nil."
(setq link
(format-time-string
(car org-time-stamp-formats)
- (apply 'encode-time
+ (encode-time
(list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd)
nil nil nil))))
(org-link-store-props :type "calendar" :date cd)))
diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el
index a9350c58d52..1756b34fc5b 100644
--- a/lisp/org/org-capture.el
+++ b/lisp/org/org-capture.el
@@ -1815,10 +1815,13 @@ by their respective `org-store-link-plist' properties if present."
;; Load history list for current prompt.
(setq org-capture--prompt-history
(gethash prompt org-capture--prompt-history-table))
- (push (org-completing-read
- (concat (or prompt "Enter string")
- (and default (format " [%s]" default))
- ": ")
+ (push (org-completing-read
+ ;; `format-prompt' is new in Emacs 28.1.
+ (if (fboundp 'format-prompt)
+ (format-prompt (or prompt "Enter string") default)
+ (concat (or prompt "Enter string")
+ (and default (format " [%s]" default))
+ ": "))
completions
nil nil nil 'org-capture--prompt-history default)
strings)
diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el
index 143ed4f123a..2526ca793aa 100644
--- a/lisp/org/org-clock.el
+++ b/lisp/org/org-clock.el
@@ -219,8 +219,7 @@ Emacs initialization file."
(const :tag "Clock and history" t)
(const :tag "No persistence" nil)))
-(defcustom org-clock-persist-file (convert-standard-filename
- (concat user-emacs-directory "org-clock-save.el"))
+(defcustom org-clock-persist-file (locate-user-emacs-file "org-clock-save.el")
"File to save clock data to."
:group 'org-clock
:type 'string)
@@ -1905,11 +1904,11 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes."
((match-end 2)
;; Two time stamps.
(let* ((ts (float-time
- (apply #'encode-time
+ (encode-time
(save-match-data
(org-parse-time-string (match-string 2))))))
(te (float-time
- (apply #'encode-time
+ (encode-time
(org-parse-time-string (match-string 3)))))
(dt (- (if tend (min te tend) te)
(if tstart (max ts tstart) ts))))
@@ -2838,7 +2837,7 @@ a number of clock tables."
(pcase (if range (car range) (plist-get params :tstart))
((and (pred numberp) n)
(pcase-let ((`(,m ,d ,y) (calendar-gregorian-from-absolute n)))
- (apply #'encode-time (list 0 0 org-extend-today-until d m y))))
+ (encode-time 0 0 org-extend-today-until d m y)))
(timestamp
(seconds-to-time
(org-matcher-time (or timestamp
@@ -2848,7 +2847,7 @@ a number of clock tables."
(pcase (if range (nth 1 range) (plist-get params :tend))
((and (pred numberp) n)
(pcase-let ((`(,m ,d ,y) (calendar-gregorian-from-absolute n)))
- (apply #'encode-time (list 0 0 org-extend-today-until d m y))))
+ (encode-time 0 0 org-extend-today-until d m y)))
(timestamp (seconds-to-time (org-matcher-time timestamp))))))
(while (time-less-p start end)
(unless (bolp) (insert "\n"))
@@ -3043,9 +3042,9 @@ Otherwise, return nil."
(setq ts (match-string 1)
te (match-string 3))
(setq s (- (float-time
- (apply #'encode-time (org-parse-time-string te)))
+ (encode-time (org-parse-time-string te)))
(float-time
- (apply #'encode-time (org-parse-time-string ts))))
+ (encode-time (org-parse-time-string ts))))
neg (< s 0)
s (abs s)
h (floor (/ s 3600))
diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el
index 9794382d8a4..f93e948bdcd 100644
--- a/lisp/org/org-colview.el
+++ b/lisp/org/org-colview.el
@@ -782,7 +782,7 @@ around it."
(setq time-after (copy-sequence time))
(setf (nth 3 time-before) (1- (nth 3 time)))
(setf (nth 3 time-after) (1+ (nth 3 time)))
- (mapcar (lambda (x) (format-time-string fmt (apply #'encode-time x)))
+ (mapcar (lambda (x) (format-time-string fmt (encode-time x)))
(list time-before time time-after)))))
(defun org-columns-open-link (&optional arg)
diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el
index d230ee2b11f..b140df76223 100644
--- a/lisp/org/org-compat.el
+++ b/lisp/org/org-compat.el
@@ -170,8 +170,7 @@ extension beyond end of line was not controllable."
(defsubst file-attribute-modification-time (attributes)
"The modification time in ATTRIBUTES returned by `file-attributes'.
This is the time of the last change to the file's contents, and
-is a list of integers (HIGH LOW USEC PSEC) in the same style
-as (current-time)."
+is a Lisp timestamp in the same style as `current-time'."
(nth 5 attributes)))
(unless (fboundp 'file-attribute-size)
diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el
index 56783d10833..bd7e73905f3 100644
--- a/lisp/org/org-id.el
+++ b/lisp/org/org-id.el
@@ -196,8 +196,7 @@ the link."
:group 'org-id
:type 'boolean)
-(defcustom org-id-locations-file (convert-standard-filename
- (concat user-emacs-directory ".org-id-locations"))
+(defcustom org-id-locations-file (locate-user-emacs-file ".org-id-locations")
"The file for remembering in which file an ID was defined.
This variable is only relevant when `org-id-track-globally' is set."
:group 'org-id
diff --git a/lisp/org/org-macro.el b/lisp/org/org-macro.el
index c0287a25a55..83c35faea41 100644
--- a/lisp/org/org-macro.el
+++ b/lisp/org/org-macro.el
@@ -378,7 +378,7 @@ Return value as a string."
(buffer-substring
(point) (line-end-position)))))
(when (cl-some #'identity time)
- (setq date (apply #'encode-time time))))))))
+ (setq date (encode-time time))))))))
(let ((proc (get-buffer-process buf)))
(while (and proc (accept-process-output proc .5 nil t)))))
(kill-buffer buf))
diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el
index 0779c3a82c8..044056b7a04 100644
--- a/lisp/org/org-macs.el
+++ b/lisp/org/org-macs.el
@@ -1185,7 +1185,7 @@ nil, just return 0."
((numberp s) s)
((stringp s)
(condition-case nil
- (float-time (apply #'encode-time (org-parse-time-string s)))
+ (float-time (encode-time (org-parse-time-string s)))
(error 0)))
(t 0)))
@@ -1252,7 +1252,7 @@ following special strings: \"<now>\", \"<today>\",
\"<tomorrow>\", and \"<yesterday>\".
Return 0. if S is not recognized as a valid value."
- (let ((today (float-time (apply #'encode-time
+ (let ((today (float-time (encode-time
(append '(0 0 0) (nthcdr 3 (decode-time)))))))
(save-match-data
(cond
diff --git a/lisp/org/org-refile.el b/lisp/org/org-refile.el
index 678759e10db..73eaad6bf52 100644
--- a/lisp/org/org-refile.el
+++ b/lisp/org/org-refile.el
@@ -640,11 +640,13 @@ this function appends the default value from
org-refile-target-table))
(completion-ignore-case t)
cdef
- (prompt (concat prompt
- (or (and (car org-refile-history)
- (concat " (default " (car org-refile-history) ")"))
- (and (assoc cbnex tbl) (setq cdef cbnex)
- (concat " (default " cbnex ")"))) ": "))
+ (prompt (let ((default (or (car org-refile-history)
+ (and (assoc cbnex tbl) (setq cdef cbnex)
+ cbnex))))
+ ;; `format-prompt' is new in Emacs 28.1.
+ (if (fboundp 'format-prompt)
+ (format-prompt prompt default)
+ (concat prompt " (default " default ": "))))
pa answ parent-target child parent old-hist)
(setq old-hist org-refile-history)
(setq answ (funcall cfunc prompt tbl nil (not new-nodes)
diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el
index e34872fb491..a6dd8bff20f 100644
--- a/lisp/org/org-table.el
+++ b/lisp/org/org-table.el
@@ -2606,7 +2606,7 @@ location of point."
(format-time-string
(org-time-stamp-format
(string-match-p "[0-9]\\{1,2\\}:[0-9]\\{2\\}" ts))
- (apply #'encode-time
+ (encode-time
(save-match-data (org-parse-time-string ts))))))
form t t))
diff --git a/lisp/org/org.el b/lisp/org/org.el
index f784369f95f..bddc319bf6a 100644
--- a/lisp/org/org.el
+++ b/lisp/org/org.el
@@ -13987,7 +13987,7 @@ user."
(when (< (nth 2 org-defdecode) org-extend-today-until)
(setf (nth 2 org-defdecode) -1)
(setf (nth 1 org-defdecode) 59)
- (setq org-def (apply #'encode-time org-defdecode))
+ (setq org-def (encode-time org-defdecode))
(setq org-defdecode (decode-time org-def)))
(let* ((timestr (format-time-string
(if org-with-time "%Y-%m-%d %H:%M" "%Y-%m-%d")
@@ -14471,7 +14471,7 @@ The command returns the inserted time stamp."
time (org-fix-decoded-time t1)
str (org-add-props
(format-time-string
- (substring tf 1 -1) (apply 'encode-time time))
+ (substring tf 1 -1) (encode-time time))
nil 'mouse-face 'highlight))
(put-text-property beg end 'display str)))
@@ -14726,7 +14726,7 @@ days in order to avoid rounding problems."
(defun org-time-string-to-time (s)
"Convert timestamp string S into internal time."
- (apply #'encode-time (org-parse-time-string s)))
+ (encode-time (org-parse-time-string s)))
(defun org-time-string-to-seconds (s)
"Convert a timestamp string S into a number of seconds."
@@ -15156,7 +15156,7 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like
(setcar time0 (or (car time0) 0))
(setcar (nthcdr 1 time0) (or (nth 1 time0) 0))
(setcar (nthcdr 2 time0) (or (nth 2 time0) 0))
- (setq time (apply 'encode-time time0))))
+ (setq time (encode-time time0))))
;; Insert the new time-stamp, and ensure point stays in the same
;; category as before (i.e. not after the last position in that
;; category).
diff --git a/lisp/org/ox-icalendar.el b/lisp/org/ox-icalendar.el
index 16c3dc9a029..211d0f716b8 100644
--- a/lisp/org/ox-icalendar.el
+++ b/lisp/org/ox-icalendar.el
@@ -824,8 +824,7 @@ as a communication channel."
(if (not (plist-get info :with-author)) ""
(org-export-data (plist-get info :author) info))
;; Timezone.
- (if (org-string-nw-p org-icalendar-timezone) org-icalendar-timezone
- (cadr (current-time-zone)))
+ (or (org-string-nw-p org-icalendar-timezone) (format-time-string "%Z"))
;; Description.
(org-export-data (plist-get info :title) info)
contents))
@@ -972,7 +971,7 @@ This function assumes major mode for current buffer is
(org-icalendar--vcalendar
org-icalendar-combined-name
user-full-name
- (or (org-string-nw-p org-icalendar-timezone) (cadr (current-time-zone)))
+ (or (org-string-nw-p org-icalendar-timezone) (format-time-string "%Z"))
org-icalendar-combined-description
contents)))
(run-hook-with-args 'org-icalendar-after-save-hook file)))
@@ -995,7 +994,7 @@ FILES is a list of files to build the calendar from."
user-full-name
;; Timezone.
(or (org-string-nw-p org-icalendar-timezone)
- (cadr (current-time-zone)))
+ (format-time-string "Z"))
;; Description.
org-icalendar-combined-description
;; Contents.
diff --git a/lisp/outline.el b/lisp/outline.el
index 52a94b4d9f4..5e3d4e0e002 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -35,6 +35,8 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
+
(defgroup outlines nil
"Support for hierarchical outlining."
:prefix "outline-"
@@ -219,7 +221,7 @@ in the file it applies to.")
(defvar outline-font-lock-keywords
'(
;; Highlight headings according to the level.
- (eval . (list (concat "^\\(?:" outline-regexp "\\).+")
+ (eval . (list (concat "^\\(?:" outline-regexp "\\).*")
0 '(if outline-minor-mode
(if outline-minor-mode-cycle
(if outline-minor-mode-highlight
@@ -272,6 +274,25 @@ in the file it applies to.")
(defvar outline-font-lock-faces
[outline-1 outline-2 outline-3 outline-4
outline-5 outline-6 outline-7 outline-8])
+
+(defcustom outline-minor-mode-use-buttons nil
+ "If non-nil, use clickable buttons on the headings.
+Note that this feature is not meant to be used in editing
+buffers (yet) -- that will be amended in a future version.
+
+The `outline-minor-mode-buttons' variable specifies how the
+buttons should look."
+ :type 'boolean
+ :safe #'booleanp
+ :version "29.1")
+
+(defcustom outline-minor-mode-buttons
+ '(("▶️" "🔽" outline--valid-emoji-p)
+ ("▶" "▼" outline--valid-char-p))
+ "List of close/open pairs to use if using buttons."
+ :type 'sexp
+ :version "29.1")
+
(defvar outline-level #'outline-level
"Function of no args to compute a header's nesting level in an outline.
@@ -356,8 +377,8 @@ When point is on a heading line, then typing `TAB' cycles between `hide all',
a heading line cycles the whole buffer (`outline-cycle-buffer').
Typing these keys anywhere outside heading lines uses their default bindings."
:type 'boolean
+ :safe #'booleanp
:version "28.1")
-;;;###autoload(put 'outline-minor-mode-cycle 'safe-local-variable 'booleanp)
(defcustom outline-minor-mode-highlight nil
"Highlight headings in `outline-minor-mode' using font-lock keywords.
@@ -371,8 +392,8 @@ faces to major mode's faces."
(const :tag "Overwrite major mode faces" override)
(const :tag "Append outline faces to major mode faces" append)
(const :tag "Highlight separately from major mode faces" t))
+ :safe #'symbolp
:version "28.1")
-;;;###autoload(put 'outline-minor-mode-highlight 'safe-local-variable 'symbolp)
(defun outline-minor-mode-highlight-buffer ()
;; Fallback to overlays when font-lock is unsupported.
@@ -388,6 +409,8 @@ faces to major mode's faces."
(goto-char (match-beginning 0))
(not (get-text-property (point) 'face))))
(overlay-put overlay 'face (outline-font-lock-face)))
+ (when outline-minor-mode-use-buttons
+ (outline--insert-open-button))
(when outline-minor-mode-cycle
(overlay-put overlay 'keymap outline-minor-mode-cycle-map)))
(goto-char (match-end 0))))))
@@ -807,6 +830,7 @@ If FLAG is nil then text is shown, while if FLAG is t the text is hidden."
(overlay-put o 'isearch-open-invisible
(or outline-isearch-open-invisible-function
#'outline-isearch-open-invisible))))
+ (outline--fix-up-all-buttons from to)
;; Seems only used by lazy-lock. I.e. obsolete.
(run-hooks 'outline-view-change-hook))
@@ -923,11 +947,82 @@ Note that this does not hide the lines preceding the first heading line."
(define-obsolete-function-alias 'show-all #'outline-show-all "25.1")
-(defun outline-hide-subtree ()
- "Hide everything after this heading at deeper levels."
- (interactive)
+(defun outline-hide-subtree (&optional event)
+ "Hide everything after this heading at deeper levels.
+If non-nil, EVENT should be a mouse event."
+ (interactive (list last-nonmenu-event))
+ (when (mouse-event-p event)
+ (mouse-set-point event))
+ (when (and outline-minor-mode-use-buttons outline-minor-mode)
+ (outline--insert-close-button))
(outline-flag-subtree t))
+(defun outline--make-button (type)
+ (cl-loop for (close open test) in outline-minor-mode-buttons
+ when (and (funcall test close) (funcall test open))
+ return (concat (if (eq type 'close)
+ close
+ open)
+ " " (buffer-substring (point) (1+ (point))))))
+
+(defun outline--valid-emoji-p (string)
+ (when-let ((font (and (display-multi-font-p)
+ (car (internal-char-font nil ?😀)))))
+ (font-has-char-p font (aref string 0))))
+
+(defun outline--valid-char-p (string)
+ (char-displayable-p (aref string 0)))
+
+(defun outline--make-button-overlay (type)
+ (let ((o (seq-find (lambda (o)
+ (overlay-get o 'outline-button))
+ (overlays-at (point)))))
+ (unless o
+ (setq o (make-overlay (point) (1+ (point))))
+ (overlay-put o 'follow-link 'mouse-face)
+ (overlay-put o 'mouse-face 'highlight)
+ (overlay-put o 'outline-button t))
+ (overlay-put o 'display (outline--make-button type))
+ o))
+
+(defun outline--insert-open-button ()
+ (save-excursion
+ (beginning-of-line)
+ (let ((o (outline--make-button-overlay 'open)))
+ (overlay-put o 'help-echo "Click to hide")
+ (overlay-put o 'keymap
+ (define-keymap
+ :parent outline-minor-mode-cycle-map
+ "RET" #'outline-hide-subtree
+ "<mouse-2>" #'outline-hide-subtree)))))
+
+(defun outline--insert-close-button ()
+ (save-excursion
+ (beginning-of-line)
+ (let ((o (outline--make-button-overlay 'close)))
+ (overlay-put o 'help-echo "Click to show")
+ (overlay-put o 'keymap
+ (define-keymap
+ :parent outline-minor-mode-cycle-map
+ "RET" #'outline-show-subtree
+ "<mouse-2>" #'outline-show-subtree)))))
+
+(defun outline--fix-up-all-buttons (&optional from to)
+ (when from
+ (save-excursion
+ (goto-char from)
+ (setq from (line-beginning-position))))
+ (when outline-minor-mode-use-buttons
+ (outline-map-region
+ (lambda ()
+ ;; `outline--cycle-state' will fail if we're in a totally
+ ;; collapsed buffer -- but in that case, we're not in a
+ ;; `show-all' situation.
+ (if (eq (ignore-errors (outline--cycle-state)) 'show-all)
+ (outline--insert-open-button)
+ (outline--insert-close-button)))
+ (or from (point-min)) (or to (point-max)))))
+
(define-obsolete-function-alias 'hide-subtree #'outline-hide-subtree "25.1")
(defun outline-hide-leaves ()
@@ -943,9 +1038,13 @@ Note that this does not hide the lines preceding the first heading line."
(define-obsolete-function-alias 'hide-leaves #'outline-hide-leaves "25.1")
-(defun outline-show-subtree ()
+(defun outline-show-subtree (&optional event)
"Show everything after this heading at deeper levels."
- (interactive)
+ (interactive (list last-nonmenu-event))
+ (when (mouse-event-p event)
+ (mouse-set-point event))
+ (when (and outline-minor-mode-use-buttons outline-minor-mode)
+ (outline--insert-open-button))
(outline-flag-subtree nil))
(define-obsolete-function-alias 'show-subtree #'outline-show-subtree "25.1")
@@ -1295,7 +1394,8 @@ Return either 'hide-all, 'headings-only, or 'show-all."
(t
(outline-show-all)
(setq outline--cycle-buffer-state 'show-all)
- (message "Show all")))))
+ (message "Show all")))
+ (outline--fix-up-all-buttons)))
(defvar outline-navigation-repeat-map
(let ((map (make-sparse-keymap)))
diff --git a/lisp/paren.el b/lisp/paren.el
index ce6aa9ae13b..7e7cf6c262a 100644
--- a/lisp/paren.el
+++ b/lisp/paren.el
@@ -88,6 +88,14 @@ is not highlighted, the cursor being regarded as adequate to mark
its position."
:type 'boolean)
+(defcustom show-paren-context-when-offscreen nil
+ "If non-nil, show context in the echo area when the openparen is offscreen.
+The context is usually the line that contains the openparen,
+except if the openparen is on its own line, in which case the
+context includes the previous nonblank line."
+ :type 'boolean
+ :version "29.1")
+
(defvar show-paren--idle-timer nil)
(defvar show-paren--overlay
(let ((ol (make-overlay (point) (point) nil t))) (delete-overlay ol) ol)
@@ -312,6 +320,19 @@ It is the default value of `show-paren-data-function'."
(current-buffer))
(move-overlay show-paren--overlay
there-beg there-end (current-buffer)))
+ ;; If `show-paren-open-line-when-offscreen' is t and point
+ ;; is at a close paren, show the line that contains the
+ ;; openparen in the echo area.
+ (let ((openparen (min here-beg there-beg)))
+ (if (and show-paren-context-when-offscreen
+ (< there-beg here-beg)
+ (not (pos-visible-in-window-p openparen)))
+ (let ((open-paren-line-string
+ (blink-paren-open-paren-line-string openparen))
+ (message-log-max nil))
+ (minibuffer-message
+ "Matches %s"
+ (substring-no-properties open-paren-line-string)))))
;; Always set the overlay face, since it varies.
(overlay-put show-paren--overlay 'priority show-paren-priority)
(overlay-put show-paren--overlay 'face face))))))
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index 64acc416c23..1636e218821 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -680,8 +680,8 @@ user actually typed in."
(match-string which arg)
(throw 'pcompleted nil))))
-(defalias 'pcomplete-match-beginning 'match-beginning)
-(defalias 'pcomplete-match-end 'match-end)
+(define-obsolete-function-alias 'pcomplete-match-beginning #'match-beginning "29.1")
+(define-obsolete-function-alias 'pcomplete-match-end #'match-end "29.1")
(defsubst pcomplete--test (pred arg)
"Perform a programmable completion predicate match."
@@ -1006,7 +1006,7 @@ Arguments NO-GANGING and ARGS-FOLLOW are currently ignored."
((eq arg-char ?*) (pcomplete-executables))
((eq arg-char ??) nil)
((eq arg-char ?.) (pcomplete-entries))
- ((eq arg-char ?\() (eval result))))))
+ ((eq arg-char ?\() (eval result t))))))
(setq index (1+ index))))))))
(defun pcomplete--here (&optional form stub paring form-only)
@@ -1040,7 +1040,7 @@ See the documentation for `pcomplete-here'."
(funcall form)
;; Old calling convention, might still be used by files
;; byte-compiled with the older code.
- (eval form)))))
+ (eval form t)))))
(defmacro pcomplete-here* (&optional form stub form-only)
@@ -1062,9 +1062,9 @@ See the documentation for `pcomplete-here'."
pcomplete-window-restore-timer nil))
(define-obsolete-function-alias 'pcomplete-event-matches-key-specifier-p
- 'eq "27.1")
+ #'eq "27.1")
-(define-obsolete-function-alias 'pcomplete-read-event 'read-event "27.1")
+(define-obsolete-function-alias 'pcomplete-read-event #'read-event "27.1")
(defun pcomplete-show-completions (completions)
"List in help buffer sorted COMPLETIONS.
@@ -1244,7 +1244,7 @@ If specific documentation can't be given, be generic."
(fboundp 'Info-goto-node))
(listp pcomplete-help)))
(if (listp pcomplete-help)
- (message "%s" (eval pcomplete-help))
+ (message "%s" (eval pcomplete-help t))
(save-window-excursion (info))
(declare-function Info-goto-node
"info" (nodename &optional fork strict-case))
diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el
index 249484cf581..fa0185b16e9 100644
--- a/lisp/pixel-scroll.el
+++ b/lisp/pixel-scroll.el
@@ -67,6 +67,8 @@
;;; Code:
(require 'mwheel)
+(require 'subr-x)
+(require 'ring)
(defvar pixel-wait 0
"Idle time on each step of pixel scroll specified in second.
@@ -90,6 +92,73 @@ is always with pixel resolution.")
(defvar pixel-last-scroll-time 0
"Time when the last scrolling was made, in second since the epoch.")
+(defvar mwheel-coalesce-scroll-events)
+
+(defvar pixel-scroll-precision-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [wheel-down] #'pixel-scroll-precision)
+ (define-key map [wheel-up] #'pixel-scroll-precision)
+ (define-key map [touch-end] #'pixel-scroll-start-momentum)
+ map)
+ "The key map used by `pixel-scroll-precision-mode'.")
+
+(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.25
+ "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 4.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")
+
(defun pixel-scroll-in-rush-p ()
"Return non-nil if next scroll should be non-smooth.
When scrolling request is delivered soon after the previous one,
@@ -323,28 +392,44 @@ returns nil."
(setq pos-list (cdr pos-list))))
visible-pos))
-(defun pixel-point-at-unseen-line ()
- "Return the character position of line above the selected window.
-The returned value is the position of the first character on the
-unseen line just above the scope of current window."
- (let* ((pos0 (window-start))
+(defun pixel-point-and-height-at-unseen-line ()
+ "Return the position and pixel height of line above the selected window.
+The returned value is a cons of the position of the first
+character on the unseen line just above the scope of current
+window, and the pixel height of that line."
+ (let* ((pos0 (save-excursion
+ (goto-char (window-start))
+ (unless (bobp)
+ (beginning-of-visual-line))
+ (point)))
(vscroll0 (window-vscroll nil t))
+ (line-height nil)
(pos
(save-excursion
(goto-char pos0)
(if (bobp)
(point-min)
- ;; When there's an overlay string at window-start,
- ;; (beginning-of-visual-line 0) stays put.
- (let ((ppos (point))
- (tem (beginning-of-visual-line 0)))
- (if (eq tem ppos)
- (vertical-motion -1))
- (point))))))
+ (vertical-motion -1)
+ (setq line-height
+ (cdr (window-text-pixel-size nil (point) pos0)))
+ (point)))))
;; restore initial position
(set-window-start nil pos0 t)
(set-window-vscroll nil vscroll0 t)
- pos))
+ (when (and line-height
+ (> (car (posn-x-y (posn-at-point pos0)))
+ (line-number-display-width t)))
+ (setq line-height (- line-height
+ (save-excursion
+ (goto-char pos0)
+ (line-pixel-height)))))
+ (cons pos line-height)))
+
+(defun pixel-point-at-unseen-line ()
+ "Return the character position of line above the selected window.
+The returned value is the position of the first character on the
+unseen line just above the scope of current window."
+ (car (pixel-point-and-height-at-unseen-line)))
(defun pixel-scroll-down-and-set-window-vscroll (vscroll)
"Scroll down a line and set VSCROLL in pixels.
@@ -354,5 +439,299 @@ Otherwise, redisplay will reset the window's vscroll."
(set-window-start nil (pixel-point-at-unseen-line) t)
(set-window-vscroll nil vscroll t))
+(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
+the height of the current window."
+ (let* ((desired-pos (posn-at-x-y 0 (+ delta
+ (window-tab-line-height)
+ (window-header-line-height))))
+ (desired-start (posn-point desired-pos))
+ (current-vs (window-vscroll nil t))
+ (start-posn (unless (eq desired-start (window-start))
+ (posn-at-point desired-start)))
+ (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)))
+ (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)))
+
+(defun pixel-scroll-precision-scroll-down (delta)
+ "Scroll the current window down by DELTA pixels."
+ (let ((max-height (- (window-text-height nil t)
+ (frame-char-height))))
+ (while (> delta max-height)
+ (pixel-scroll-precision-scroll-down-page max-height)
+ (setq delta (- delta max-height)))
+ (pixel-scroll-precision-scroll-down-page delta)))
+
+(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
+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 (save-excursion
+ (goto-char point)
+ (vertical-motion (- (1+ scroll-margin)))
+ (point))))
+ (when (> (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)))
+ (if (<= delta current-vscroll)
+ (set-window-vscroll nil (- current-vscroll delta) t)
+ (setq delta (- delta current-vscroll))
+ (set-window-vscroll nil 0 t)
+ (while (> delta 0)
+ (let ((position (pixel-point-and-height-at-unseen-line)))
+ (unless (cdr position)
+ (signal 'beginning-of-buffer nil))
+ (set-window-start nil (car 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 (> (cdr position) usable-height)
+ (goto-char (car position)))
+ (setq delta (- delta (cdr position)))))
+ (when (< delta 0)
+ (set-window-vscroll nil (- delta) t))))))
+
+(defun pixel-scroll-precision-interpolate (delta)
+ "Interpolate a scroll of DELTA pixels.
+This results in the window being scrolled by DELTA pixels with an
+animation."
+ (let ((percentage 0)
+ (total-time pixel-scroll-precision-interpolation-total-time)
+ (factor pixel-scroll-precision-interpolation-factor)
+ (last-time (float-time))
+ (time-elapsed 0.0)
+ (between-scroll pixel-scroll-precision-interpolation-between-scroll)
+ (rem (window-parameter nil 'interpolated-scroll-remainder))
+ (time (window-parameter nil 'interpolated-scroll-remainder-time)))
+ (when (and rem time
+ (< (- (float-time) time) 1.0)
+ (eq (< delta 0) (< rem 0)))
+ (setq delta (+ delta rem)))
+ (if (or (null rem)
+ (eq (< delta 0) (< rem 0)))
+ (while-no-input
+ (unwind-protect
+ (while (< percentage 1)
+ (redisplay t)
+ (sleep-for between-scroll)
+ (setq time-elapsed (+ time-elapsed
+ (- (float-time) last-time))
+ percentage (/ time-elapsed total-time))
+ (let ((throw-on-input nil))
+ (if (< delta 0)
+ (pixel-scroll-precision-scroll-down
+ (ceiling (abs (* (* delta factor)
+ (/ between-scroll total-time)))))
+ (pixel-scroll-precision-scroll-up
+ (ceiling (* (* delta factor)
+ (/ between-scroll total-time))))))
+ (setq last-time (float-time)))
+ (if (< percentage 1)
+ (progn
+ (set-window-parameter nil 'interpolated-scroll-remainder
+ (* delta (- 1 percentage)))
+ (set-window-parameter nil 'interpolated-scroll-remainder-time
+ (float-time)))
+ (set-window-parameter nil
+ 'interpolated-scroll-remainder
+ nil)
+ (set-window-parameter nil
+ 'interpolated-scroll-remainder-time
+ nil))))
+ (set-window-parameter nil
+ 'interpolated-scroll-remainder
+ nil)
+ (set-window-parameter nil
+ 'interpolated-scroll-remainder-time
+ nil))))
+
+(defun pixel-scroll-precision-scroll-up (delta)
+ "Scroll the current window up by DELTA pixels."
+ (let ((max-height (- (window-text-height nil t)
+ (frame-char-height))))
+ (while (> delta max-height)
+ (pixel-scroll-precision-scroll-up-page max-height)
+ (setq delta (- delta max-height)))
+ (pixel-scroll-precision-scroll-up-page delta)))
+
+;; FIXME: This doesn't _always_ work when there's an image above the
+;; current line that is taller than the window, and scrolling can
+;; sometimes be jumpy in that case.
+(defun pixel-scroll-precision (event)
+ "Scroll the display vertically by pixels according to EVENT.
+Move the display up or down by the pixel deltas in EVENT to
+scroll the display according to the user's turning the mouse
+wheel."
+ (interactive "e")
+ (let ((window (mwheel-event-window event)))
+ (if (and (nth 4 event))
+ (let ((delta (round (cdr (nth 4 event)))))
+ (unless (zerop delta)
+ (if (> (abs delta) (window-text-height window t))
+ (mwheel-scroll event nil)
+ (with-selected-window window
+ (if (and pixel-scroll-precision-large-scroll-height
+ (> (abs delta)
+ pixel-scroll-precision-large-scroll-height)
+ (let* ((kin-state (pixel-scroll-kinetic-state))
+ (ring (aref kin-state 0))
+ (time (aref kin-state 1)))
+ (or (null time)
+ (> (- (float-time) time) 1.0)
+ (and (consp ring)
+ (ring-empty-p ring)))))
+ (progn
+ (let ((kin-state (pixel-scroll-kinetic-state)))
+ (aset kin-state 0 (make-ring 10))
+ (aset kin-state 1 nil))
+ (pixel-scroll-precision-interpolate delta))
+ (condition-case nil
+ (progn
+ (if (< delta 0)
+ (pixel-scroll-precision-scroll-down (- delta))
+ (pixel-scroll-precision-scroll-up delta))
+ (pixel-scroll-accumulate-velocity delta))
+ ;; Do not ding at buffer limits. Show a message instead.
+ (beginning-of-buffer
+ (message (error-message-string '(beginning-of-buffer))))
+ (end-of-buffer
+ (message (error-message-string '(end-of-buffer))))))))))
+ (mwheel-scroll event nil))))
+
+(defun pixel-scroll-kinetic-state ()
+ "Return the kinetic scroll state of the current window.
+It is a vector of the form [ VELOCITY TIME ]."
+ (or (window-parameter nil 'kinetic-state)
+ (set-window-parameter nil 'kinetic-state
+ (vector (make-ring 10) nil))))
+
+(defun pixel-scroll-accumulate-velocity (delta)
+ "Accumulate DELTA into the current window's kinetic scroll state."
+ (let* ((state (pixel-scroll-kinetic-state))
+ (ring (aref state 0))
+ (time (aref state 1)))
+ (when (or (and time (> (- (float-time) time) 0.5))
+ (and (not (ring-empty-p ring))
+ (not (eq (< delta 0)
+ (< (cdr (ring-ref ring 0))
+ 0)))))
+ (aset state 0 (make-ring 10)))
+ (ring-insert (aref state 0)
+ (cons (aset state 1 (float-time))
+ delta))))
+
+(defun pixel-scroll-calculate-velocity (state)
+ "Calculate velocity from the kinetic state vector STATE."
+ (let* ((ring (aref state 0))
+ (elts (ring-elements ring))
+ (total 0))
+ (dolist (tem elts)
+ (setq total (+ total (cdr tem))))
+ (/ total (* (- (float-time) (caar elts))
+ 100))))
+
+(defun pixel-scroll-start-momentum (event)
+ "Start kinetic scrolling for the touch event EVENT."
+ (interactive "e")
+ (when pixel-scroll-precision-use-momentum
+ (let ((window (mwheel-event-window event))
+ (state nil))
+ (with-selected-window window
+ (setq state (pixel-scroll-kinetic-state))
+ (when (and (aref state 1)
+ (listp (aref state 0)))
+ (while-no-input
+ (unwind-protect (progn
+ (aset state 0 (pixel-scroll-calculate-velocity state))
+ (when (> (abs (aref state 0))
+ pixel-scroll-precision-momentum-min-velocity)
+ (let* ((velocity (* (aref state 0)
+ pixel-scroll-precision-initial-velocity-factor))
+ (original-velocity velocity)
+ (time-spent 0))
+ (if (> velocity 0)
+ (while (and (> velocity 0)
+ (<= time-spent
+ pixel-scroll-precision-momentum-seconds))
+ (when (> (round velocity) 0)
+ (pixel-scroll-precision-scroll-up (round velocity)))
+ (setq velocity (- velocity
+ (/ original-velocity
+ (/ pixel-scroll-precision-momentum-seconds
+ pixel-scroll-precision-momentum-tick))))
+ (redisplay t)
+ (sit-for pixel-scroll-precision-momentum-tick)
+ (setq time-spent (+ time-spent
+ pixel-scroll-precision-momentum-tick))))
+ (while (and (< velocity 0)
+ (<= time-spent
+ pixel-scroll-precision-momentum-seconds))
+ (when (> (round (abs velocity)) 0)
+ (pixel-scroll-precision-scroll-down (round
+ (abs velocity))))
+ (setq velocity (+ velocity
+ (/ (abs original-velocity)
+ (/ pixel-scroll-precision-momentum-seconds
+ pixel-scroll-precision-momentum-tick))))
+ (redisplay t)
+ (sit-for pixel-scroll-precision-momentum-tick)
+ (setq time-spent (+ time-spent
+ pixel-scroll-precision-momentum-tick))))))
+ (aset state 0 (make-ring 10))
+ (aset state 1 nil))))))))
+
+;;;###autoload
+(define-minor-mode pixel-scroll-precision-mode
+ "Toggle pixel scrolling.
+When enabled, this minor mode allows 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)))
+
(provide 'pixel-scroll)
;;; pixel-scroll.el ends here
diff --git a/lisp/play/animate.el b/lisp/play/animate.el
index 7eb1b277179..54ee9dc84eb 100644
--- a/lisp/play/animate.el
+++ b/lisp/play/animate.el
@@ -93,9 +93,17 @@
(unless (eolp) (delete-char 1))
(insert-char char 1))
-(defcustom animate-n-steps 10
+(defcustom animate-n-steps 20
"Number of steps `animate-string' will place a char before its last position."
- :type 'integer)
+ :type 'natnum
+ :version "29.1")
+
+(defcustom animate-total-added-delay 0.5
+ "Total number of seconds to wait in between steps.
+This is added to the total time it takes to run `animate-string'
+to ensure that the animation is not too fast to be seen."
+ :type 'float
+ :version "29.1")
(defvar animation-buffer-name nil
"String naming the default buffer for animations.
@@ -130,7 +138,7 @@ in the current window."
;; Make sure buffer is displayed starting at the beginning.
(set-window-start nil 1)
;; Display it, and wait just a little while.
- (sit-for .05)
+ (sit-for (/ (float animate-total-added-delay) (max animate-n-steps 1)))
;; Now undo the changes we made in the buffer.
(setq list-to-undo buffer-undo-list)
(while list-to-undo
diff --git a/lisp/play/snake.el b/lisp/play/snake.el
index 29effa23460..dbdecde973d 100644
--- a/lisp/play/snake.el
+++ b/lisp/play/snake.el
@@ -160,31 +160,28 @@ and then start moving it leftwards.")
;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar snake-mode-map
- (let ((map (make-sparse-keymap 'snake-mode-map)))
-
- (define-key map "n" 'snake-start-game)
- (define-key map "q" 'snake-end-game)
- (define-key map "p" 'snake-pause-game)
-
- (define-key map [left] 'snake-move-left)
- (define-key map [right] 'snake-move-right)
- (define-key map [up] 'snake-move-up)
- (define-key map [down] 'snake-move-down)
-
- (define-key map "\C-b" 'snake-move-left)
- (define-key map "\C-f" 'snake-move-right)
- (define-key map "\C-p" 'snake-move-up)
- (define-key map "\C-n" 'snake-move-down)
- map)
- "Keymap for Snake games.")
-
-(defvar snake-null-map
- (let ((map (make-sparse-keymap 'snake-null-map)))
- (define-key map "n" 'snake-start-game)
- (define-key map "q" 'quit-window)
- map)
- "Keymap for finished Snake games.")
+(defvar-keymap snake-mode-map
+ :doc "Keymap for Snake games."
+ :name 'snake-mode-map
+ "n" #'snake-start-game
+ "q" #'snake-end-game
+ "p" #'snake-pause-game
+
+ "<left>" #'snake-move-left
+ "<right>" #'snake-move-right
+ "<up>" #'snake-move-up
+ "<down>" #'snake-move-down
+
+ "C-b" #'snake-move-left
+ "C-f" #'snake-move-right
+ "C-p" #'snake-move-up
+ "C-n" #'snake-move-down)
+
+(defvar-keymap snake-null-map
+ :doc "Keymap for finished Snake games."
+ :name 'snake-null-map
+ "n" #'snake-start-game
+ "q" #'quit-window)
(defconst snake--menu-def
'("Snake"
diff --git a/lisp/play/tetris.el b/lisp/play/tetris.el
index 3d6ddd5307f..693bfe49354 100644
--- a/lisp/play/tetris.el
+++ b/lisp/play/tetris.el
@@ -236,26 +236,24 @@ each one of its four blocks.")
;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar tetris-mode-map
- (let ((map (make-sparse-keymap 'tetris-mode-map)))
- (define-key map "n" 'tetris-start-game)
- (define-key map "q" 'tetris-end-game)
- (define-key map "p" 'tetris-pause-game)
-
- (define-key map " " 'tetris-move-bottom)
- (define-key map [left] 'tetris-move-left)
- (define-key map [right] 'tetris-move-right)
- (define-key map [up] 'tetris-rotate-prev)
- (define-key map [down] 'tetris-move-down)
- map)
- "Keymap for Tetris games.")
-
-(defvar tetris-null-map
- (let ((map (make-sparse-keymap 'tetris-null-map)))
- (define-key map "n" 'tetris-start-game)
- (define-key map "q" 'quit-window)
- map)
- "Keymap for finished Tetris games.")
+(defvar-keymap tetris-mode-map
+ :doc "Keymap for Tetris games."
+ :name 'tetris-mode-map
+ "n" #'tetris-start-game
+ "q" #'tetris-end-game
+ "p" #'tetris-pause-game
+
+ "SPC" #'tetris-move-bottom
+ "<left>" #'tetris-move-left
+ "<right>" #'tetris-move-right
+ "<up>" #'tetris-rotate-prev
+ "<down>" #'tetris-move-down)
+
+(defvar-keymap tetris-null-map
+ :doc "Keymap for finished Tetris games."
+ :name 'tetris-null-map
+ "n" #'tetris-start-game
+ "q" #'quit-window)
(defconst tetris--menu-def
'("Tetris"
diff --git a/lisp/proced.el b/lisp/proced.el
index 3b754c24c5f..9e9793abece 100644
--- a/lisp/proced.el
+++ b/lisp/proced.el
@@ -658,6 +658,7 @@ After displaying or updating a Proced buffer, Proced runs the normal hook
`proced-post-display-hook'.
\\{proced-mode-map}"
+ :interactive nil
(abbrev-mode 0)
(auto-fill-mode 0)
(setq buffer-read-only t
@@ -721,7 +722,7 @@ Proced buffers."
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'."
- (interactive (list (or current-prefix-arg 'toggle)))
+ (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))
@@ -733,19 +734,19 @@ The time interval for updates is specified via `proced-auto-update-interval'."
(defun proced-mark (&optional count)
"Mark the current (or next COUNT) processes."
- (interactive "p")
+ (interactive "p" proced-mode)
(proced-do-mark t count))
(defun proced-unmark (&optional count)
"Unmark the current (or next COUNT) processes."
- (interactive "p")
+ (interactive "p" proced-mode)
(proced-do-mark nil count))
(defun proced-unmark-backward (&optional count)
"Unmark the previous (or COUNT previous) processes."
;; Analogous to `dired-unmark-backward',
;; but `ibuffer-unmark-backward' behaves different.
- (interactive "p")
+ (interactive "p" proced-mode)
(proced-do-mark nil (- (or count 1))))
(defun proced-do-mark (mark &optional count)
@@ -762,7 +763,7 @@ The time interval for updates is specified via `proced-auto-update-interval'."
(defun proced-toggle-marks ()
"Toggle marks: marked processes become unmarked, and vice versa."
- (interactive)
+ (interactive nil proced-mode)
(let ((mark-re (proced-marker-regexp))
buffer-read-only)
(save-excursion
@@ -788,14 +789,14 @@ Otherwise move one line forward after inserting the mark."
"Mark all processes.
If `transient-mark-mode' is turned on and the region is active,
mark the region."
- (interactive)
+ (interactive nil proced-mode)
(proced-do-mark-all t))
(defun proced-unmark-all ()
"Unmark all processes.
If `transient-mark-mode' is turned on and the region is active,
unmark the region."
- (interactive)
+ (interactive nil proced-mode)
(proced-do-mark-all nil))
(defun proced-do-mark-all (mark)
@@ -830,14 +831,14 @@ mark the region."
(defun proced-mark-children (ppid &optional omit-ppid)
"Mark child processes of process PPID.
Also mark process PPID unless prefix OMIT-PPID is non-nil."
- (interactive (list (proced-pid-at-point) current-prefix-arg))
+ (interactive (list (proced-pid-at-point) current-prefix-arg) proced-mode)
(proced-mark-process-alist
(proced-filter-children proced-process-alist ppid omit-ppid)))
(defun proced-mark-parents (cpid &optional omit-cpid)
"Mark parent processes of process CPID.
Also mark CPID unless prefix OMIT-CPID is non-nil."
- (interactive (list (proced-pid-at-point) current-prefix-arg))
+ (interactive (list (proced-pid-at-point) current-prefix-arg) proced-mode)
(proced-mark-process-alist
(proced-filter-parents proced-process-alist cpid omit-cpid)))
@@ -870,7 +871,7 @@ If `transient-mark-mode' is turned on and the region is active,
omit the processes in region.
If QUIET is non-nil suppress status message.
Returns count of omitted lines."
- (interactive "P")
+ (interactive "P" proced-mode)
(let ((mark-re (proced-marker-regexp))
(count 0)
buffer-read-only)
@@ -947,7 +948,8 @@ Set variable `proced-filter' to SCHEME. Revert listing."
(interactive
(let ((scheme (completing-read "Filter: "
proced-filter-alist nil t)))
- (list (if (string= "" scheme) nil (intern scheme)))))
+ (list (if (string= "" scheme) nil (intern scheme))))
+ proced-mode)
;; only update if necessary
(unless (eq proced-filter scheme)
(setq proced-filter scheme)
@@ -1057,7 +1059,7 @@ Each parent process is followed by its child processes.
The process tree inherits the chosen sorting order of the process listing,
that is, child processes of the same parent process are sorted using
the selected sorting order."
- (interactive (list (or current-prefix-arg 'toggle)))
+ (interactive (list (or current-prefix-arg 'toggle)) proced-mode)
(setq proced-tree-flag
(cond ((eq arg 'toggle) (not proced-tree-flag))
(arg (> (prefix-numeric-value arg) 0))
@@ -1140,7 +1142,7 @@ This command refines an already existing process listing generated initially
based on the value of the variable `proced-filter'. It does not change
this variable. It does not revert the listing. If you frequently need
a certain refinement, consider defining a new filter in `proced-filter-alist'."
- (interactive (list last-input-event))
+ (interactive (list last-input-event) proced-mode)
(if event (posn-set-point (event-end event)))
(let ((key (get-text-property (point) 'proced-key))
(pid (get-text-property (point) 'proced-pid)))
@@ -1269,7 +1271,8 @@ in the mode line, using \"+\" or \"-\" for ascending or descending order."
nil t)))
(list (if (string= "" scheme) nil (intern scheme))
;; like 'toggle in `define-derived-mode'
- (or current-prefix-arg 'no-arg))))
+ (or current-prefix-arg 'no-arg)))
+ proced-mode)
(setq proced-descend
;; If `proced-sort-interactive' is called repeatedly for the same
@@ -1290,37 +1293,37 @@ in the mode line, using \"+\" or \"-\" for ascending or descending order."
(defun proced-sort-pcpu (&optional arg)
"Sort Proced buffer by percentage CPU time (%CPU).
Prefix ARG controls sort order, see `proced-sort-interactive'."
- (interactive (list (or current-prefix-arg 'no-arg)))
+ (interactive (list (or current-prefix-arg 'no-arg)) proced-mode)
(proced-sort-interactive 'pcpu arg))
(defun proced-sort-pmem (&optional arg)
"Sort Proced buffer by percentage memory usage (%MEM).
Prefix ARG controls sort order, see `proced-sort-interactive'."
- (interactive (list (or current-prefix-arg 'no-arg)))
+ (interactive (list (or current-prefix-arg 'no-arg)) proced-mode)
(proced-sort-interactive 'pmem arg))
(defun proced-sort-pid (&optional arg)
"Sort Proced buffer by PID.
Prefix ARG controls sort order, see `proced-sort-interactive'."
- (interactive (list (or current-prefix-arg 'no-arg)))
+ (interactive (list (or current-prefix-arg 'no-arg)) proced-mode)
(proced-sort-interactive 'pid arg))
(defun proced-sort-start (&optional arg)
"Sort Proced buffer by time the command started (START).
Prefix ARG controls sort order, see `proced-sort-interactive'."
- (interactive (list (or current-prefix-arg 'no-arg)))
+ (interactive (list (or current-prefix-arg 'no-arg)) proced-mode)
(proced-sort-interactive 'start arg))
(defun proced-sort-time (&optional arg)
"Sort Proced buffer by CPU time (TIME).
Prefix ARG controls sort order, see `proced-sort-interactive'."
- (interactive (list (or current-prefix-arg 'no-arg)))
+ (interactive (list (or current-prefix-arg 'no-arg)) proced-mode)
(proced-sort-interactive 'time arg))
(defun proced-sort-user (&optional arg)
"Sort Proced buffer by USER.
Prefix ARG controls sort order, see `proced-sort-interactive'."
- (interactive (list (or current-prefix-arg 'no-arg)))
+ (interactive (list (or current-prefix-arg 'no-arg)) proced-mode)
(proced-sort-interactive 'user arg))
(defun proced-sort-header (event &optional arg)
@@ -1329,7 +1332,7 @@ EVENT is a mouse event with starting position in the header line.
It is converted to the corresponding attribute key.
This command updates the variable `proced-sort'.
Prefix ARG controls sort order, see `proced-sort-interactive'."
- (interactive (list last-input-event (or last-prefix-arg 'no-arg)))
+ (interactive (list last-input-event (or last-prefix-arg 'no-arg)) proced-mode)
(let* ((start (event-start event))
(obj (posn-object start))
col key)
@@ -1535,7 +1538,8 @@ With prefix REVERT non-nil revert listing."
(let ((scheme (completing-read "Format: "
proced-format-alist nil t)))
(list (if (string= "" scheme) nil (intern scheme))
- current-prefix-arg)))
+ current-prefix-arg))
+ proced-mode)
;; only update if necessary
(when (or (not (eq proced-format scheme)) revert)
(setq proced-format scheme)
@@ -1567,7 +1571,7 @@ Suppress status information if QUIET is nil.
After updating a displayed Proced buffer run the normal hook
`proced-post-display-hook'."
;; This is the main function that generates and updates the process listing.
- (interactive "P")
+ (interactive "P" proced-mode)
(setq revert (or revert (not proced-process-alist)))
(or quiet (message (if revert "Updating process information..."
"Updating process display...")))
@@ -1773,11 +1777,12 @@ supported but discouraged. It will be removed in a future version of Emacs."
`(:annotation-function
,(lambda (s) (cdr (assoc s proced-signal-list))))))
(proced-with-processes-buffer process-alist
- (list (completing-read (concat "Send signal [" pnum
- "] (default TERM): ")
+ (list (completing-read (format-prompt "Send signal [%s]"
+ "TERM" pnum)
proced-signal-list
nil nil nil nil "TERM")
- process-alist))))
+ process-alist)))
+ proced-mode)
(unless (and signal process-alist)
;; Discouraged usage (supported for backward compatibility):
@@ -1798,8 +1803,8 @@ supported but discouraged. It will be removed in a future version of Emacs."
`(:annotation-function
,(lambda (s) (cdr (assoc s proced-signal-list))))))
(proced-with-processes-buffer process-alist
- (setq signal (completing-read (concat "Send signal [" pnum
- "] (default TERM): ")
+ (setq signal (completing-read (format-prompt "Send signal [%s]"
+ "TERM" pnum)
proced-signal-list
nil nil nil nil "TERM"))))))
@@ -1862,7 +1867,8 @@ the normal hook `proced-after-send-signal-hook'."
(let ((process-alist (proced-marked-processes)))
(proced-with-processes-buffer process-alist
(list (read-number "New priority: ")
- process-alist))))
+ process-alist)))
+ proced-mode)
(if (numberp priority)
(setq priority (number-to-string priority)))
(let (failures)
@@ -1894,7 +1900,7 @@ the normal hook `proced-after-send-signal-hook'."
"Pop up a buffer with error log output from Proced.
A group of errors from a single command ends with a formfeed.
Thus, use \\[backward-page] to find the beginning of a group of errors."
- (interactive)
+ (interactive nil proced-mode)
(if (get-buffer proced-log-buffer)
(save-selected-window
;; move `proced-log-buffer' to the front of the buffer list
@@ -1946,7 +1952,7 @@ STRING is an overall summary of the failures."
(defun proced-help ()
"Provide help for the Proced user."
- (interactive)
+ (interactive nil proced-mode)
(proced-why)
(if (eq last-command 'proced-help)
(describe-mode)
@@ -1956,7 +1962,7 @@ STRING is an overall summary of the failures."
"Undo in a Proced buffer.
This doesn't recover killed processes, it just undoes changes in the Proced
buffer. You can use it to recover marks."
- (interactive)
+ (interactive nil proced-mode)
(let (buffer-read-only)
(undo))
(message "Change in Proced buffer undone.
diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index d7b12db2211..d7092a37d44 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -269,9 +269,9 @@ via the internet it might also be http.")
;; pull/17 page if 17 is a PR. Explicit user/project#17 links to
;; possibly different projects are also supported.
(cl-defmethod bug-reference--build-forge-setup-entry
- (host-domain (_forge-type (eql github)) protocol)
+ (host-domain (_forge-type (eql 'github)) protocol)
`(,(concat "[/@]" (regexp-quote host-domain)
- "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git")
+ "[/:]\\([.A-Za-z0-9_/-]+?\\)\\(?:\\.git\\)?/?\\'")
"\\(\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>"
,(lambda (groups)
(let ((ns-project (nth 1 groups)))
@@ -285,9 +285,9 @@ via the internet it might also be http.")
;; namespace/project#18 or namespace/project!17 references to possibly
;; different projects are also supported.
(cl-defmethod bug-reference--build-forge-setup-entry
- (host-domain (_forge-type (eql gitlab)) protocol)
+ (host-domain (_forge-type (eql 'gitlab)) protocol)
`(,(concat "[/@]" (regexp-quote host-domain)
- "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git")
+ "[/:]\\([.A-Za-z0-9_/-]+?\\)\\(?:\\.git\\)?/?\\'")
"\\(\\([.A-Za-z0-9_/-]+\\)?\\([#!]\\)\\([0-9]+\\)\\)\\>"
,(lambda (groups)
(let ((ns-project (nth 1 groups)))
@@ -302,9 +302,9 @@ via the internet it might also be http.")
;; Gitea: The systematics is exactly as for Github projects.
(cl-defmethod bug-reference--build-forge-setup-entry
- (host-domain (_forge-type (eql gitea)) protocol)
+ (host-domain (_forge-type (eql 'gitea)) protocol)
`(,(concat "[/@]" (regexp-quote host-domain)
- "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git")
+ "[/:]\\([.A-Za-z0-9_/-]+?\\)\\(?:\\.git\\)?/?\\'")
"\\(\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>"
,(lambda (groups)
(let ((ns-project (nth 1 groups)))
@@ -323,7 +323,7 @@ via the internet it might also be http.")
;; repo without tracker, or a repo with a tracker using a different
;; name, etc. So we can only try to make a good guess.
(cl-defmethod bug-reference--build-forge-setup-entry
- (host-domain (_forge-type (eql sourcehut)) protocol)
+ (host-domain (_forge-type (eql 'sourcehut)) protocol)
`(,(concat "[/@]\\(?:git\\|hg\\)." (regexp-quote host-domain)
"[/:]\\(~[.A-Za-z0-9_/-]+\\)")
"\\(\\(~[.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>"
diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el
index a9a52636b78..50249728048 100644
--- a/lisp/progmodes/cc-cmds.el
+++ b/lisp/progmodes/cc-cmds.el
@@ -1896,16 +1896,18 @@ defun."
(if (< arg 0)
(c-while-widening-to-decl-block
(< (setq arg (- (c-forward-to-nth-EOF-\;-or-} (- arg) where))) 0)))
- ;; Move forward to the next opening brace....
- (when (and (= arg 0)
- (progn
- (c-while-widening-to-decl-block
- (not (c-syntactic-re-search-forward "{" nil 'eob)))
- (eq (char-before) ?{)))
- (backward-char)
- ;; ... and backward to the function header.
- (c-beginning-of-decl-1)
- t))
+ (prog1
+ ;; Move forward to the next opening brace....
+ (when (and (= arg 0)
+ (progn
+ (c-while-widening-to-decl-block
+ (not (c-syntactic-re-search-forward "{" nil 'eob)))
+ (eq (char-before) ?{)))
+ (backward-char)
+ ;; ... and backward to the function header.
+ (c-beginning-of-decl-1)
+ t)
+ (c-keep-region-active)))
;; Move backward to the opening brace of a function, making successively
;; larger portions of the buffer visible as necessary.
@@ -3413,7 +3415,8 @@ to call `c-scan-conditionals' directly instead."
(interactive "p")
(let ((new-point (c-scan-conditionals count target-depth with-else)))
(push-mark)
- (goto-char new-point)))
+ (goto-char new-point))
+ (c-keep-region-active))
(defun c-scan-conditionals (count &optional target-depth with-else)
"Scan forward across COUNT preprocessor conditionals.
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el
index db1f46621da..d37a50997ad 100644
--- a/lisp/progmodes/cc-engine.el
+++ b/lisp/progmodes/cc-engine.el
@@ -165,12 +165,16 @@
(defvar c-doc-line-join-end-ch)
(defvar c-syntactic-context)
(defvar c-syntactic-element)
+(defvar c-new-id-start)
+(defvar c-new-id-end)
+(defvar c-new-id-is-type)
(cc-bytecomp-defvar c-min-syn-tab-mkr)
(cc-bytecomp-defvar c-max-syn-tab-mkr)
(cc-bytecomp-defun c-clear-syn-tab)
(cc-bytecomp-defun c-clear-string-fences)
(cc-bytecomp-defun c-restore-string-fences)
(cc-bytecomp-defun c-remove-string-fences)
+(cc-bytecomp-defun c-fontify-new-found-type)
;; Make declarations for all the `c-lang-defvar' variables in cc-langs.
@@ -6808,26 +6812,47 @@ comment at the start of cc-engine.el for more info."
(defvar c-found-types nil)
(make-variable-buffer-local 'c-found-types)
+;; Dynamically bound variable that instructs `c-forward-type' to
+;; record the ranges of types that only are found. Behaves otherwise
+;; like `c-record-type-identifiers'. Also when this variable is non-nil,
+;; `c-fontify-new-found-type' doesn't get called (yet) for the purported
+;; type.
+(defvar c-record-found-types nil)
+
(defsubst c-clear-found-types ()
;; Clears `c-found-types'.
(setq c-found-types
(make-hash-table :test #'equal :weakness nil)))
-(defun c-add-type (from to)
- ;; Add the given region as a type in `c-found-types'. If the region
- ;; doesn't match an existing type but there is a type which is equal
- ;; to the given one except that the last character is missing, then
- ;; the shorter type is removed. That's done to avoid adding all
- ;; prefixes of a type as it's being entered and font locked. This
- ;; doesn't cover cases like when characters are removed from a type
- ;; or added in the middle. We'd need the position of point when the
- ;; font locking is invoked to solve this well.
+(defun c-add-type-1 (from to)
+ ;; Add the given region as a type in `c-found-types'. Prepare occurrences
+ ;; of this new type for fontification throughout the buffer.
;;
;; This function might do hidden buffer changes.
(let ((type (c-syntactic-content from to c-recognize-<>-arglists)))
(unless (gethash type c-found-types)
- (remhash (substring type 0 -1) c-found-types)
- (puthash type t c-found-types))))
+ (puthash type t c-found-types)
+ (when (and (not c-record-found-types) ; Only call `c-fontify-new-fount-type'
+ ; when we haven't "bound" c-found-types
+ ; to itself in c-forward-<>-arglist.
+ (eq (string-match c-symbol-key type) 0)
+ (eq (match-end 0) (length type)))
+ (c-fontify-new-found-type type)))))
+
+(defun c-add-type (from to)
+ ;; Add the given region as a type in `c-found-types'. Also perform the
+ ;; actions of `c-add-type-1'. If the region is or overlaps an identifier
+ ;; which might be being typed in, don't record it. This is tested by
+ ;; checking `c-new-id-start' and `c-new-id-end'. That's done to avoid
+ ;; adding all prefixes of a type as it's being entered and font locked.
+ ;; This is a bit rough and ready, but now covers adding characters into the
+ ;; middle of an identifer.
+ ;;
+ ;; This function might do hidden buffer changes.
+ (if (and c-new-id-start c-new-id-end
+ (<= from c-new-id-end) (>= to c-new-id-start))
+ (setq c-new-id-is-type t)
+ (c-add-type-1 from to)))
(defun c-unfind-type (name)
;; Remove the "NAME" from c-found-types, if present.
@@ -8210,11 +8235,6 @@ multi-line strings (but not C++, for example)."
(setq c-record-ref-identifiers
(cons range c-record-ref-identifiers))))))
-;; Dynamically bound variable that instructs `c-forward-type' to
-;; record the ranges of types that only are found. Behaves otherwise
-;; like `c-record-type-identifiers'.
-(defvar c-record-found-types nil)
-
(defmacro c-forward-keyword-prefixed-id (type)
;; Used internally in `c-forward-keyword-clause' to move forward
;; over a type (if TYPE is 'type) or a name (otherwise) which
@@ -8444,6 +8464,11 @@ multi-line strings (but not C++, for example)."
(c-forward-<>-arglist-recur all-types)))
(progn
(when (consp c-record-found-types)
+ (let ((cur c-record-found-types))
+ (while (consp (car-safe cur))
+ (c-fontify-new-found-type
+ (buffer-substring-no-properties (caar cur) (cdar cur)))
+ (setq cur (cdr cur))))
(setq c-record-type-identifiers
;; `nconc' doesn't mind that the tail of
;; `c-record-found-types' is t.
@@ -9169,6 +9194,12 @@ multi-line strings (but not C++, for example)."
(when (and (eq res t)
(consp c-record-found-types))
+ ;; Cause the confirmed types to get fontified.
+ (let ((cur c-record-found-types))
+ (while (consp (car-safe cur))
+ (c-fontify-new-found-type
+ (buffer-substring-no-properties (caar cur) (cdar cur)))
+ (setq cur (cdr cur))))
;; Merge in the ranges of any types found by the second
;; `c-forward-type'.
(setq c-record-type-identifiers
@@ -12092,7 +12123,10 @@ comment at the start of cc-engine.el for more info."
(and (c-major-mode-is 'pike-mode)
c-decl-block-key)))
(while (eq braceassignp 'dontknow)
- (cond ((eq (char-after) ?\;)
+ (cond ((or (eq (char-after) ?\;)
+ (save-excursion
+ (progn (c-backward-syntactic-ws)
+ (c-at-vsemi-p))))
(setq braceassignp nil))
((and class-key
(looking-at class-key))
@@ -14016,7 +14050,8 @@ 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))
- (memq (char-before) '(?, ?= ?<)))
+ (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>"
diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el
index bc0ae6cc95a..846c25f45a6 100644
--- a/lisp/progmodes/cc-fonts.el
+++ b/lisp/progmodes/cc-fonts.el
@@ -97,6 +97,7 @@
(cc-bytecomp-defun c-font-lock-declarators)
(cc-bytecomp-defun c-font-lock-objc-method)
(cc-bytecomp-defun c-font-lock-invalid-string)
+(cc-bytecomp-defun c-font-lock-fontify-region)
;; Note that font-lock in XEmacs doesn't expand face names as
@@ -919,13 +920,6 @@ casts and declarations are fontified. Used on level 2 and higher."
;; This function does hidden buffer changes.
;;(message "c-font-lock-complex-decl-prepare %s %s" (point) limit)
-
- ;; Clear the list of found types if we start from the start of the
- ;; buffer, to make it easier to get rid of misspelled types and
- ;; variables that have gotten recognized as types in malformed code.
- (when (bobp)
- (c-clear-found-types))
-
(c-skip-comments-and-strings limit)
(when (< (point) limit)
@@ -2255,6 +2249,47 @@ higher."
;; defvar will install its default value later on.
(makunbound def-var)))
+;; `c-re-redisplay-timer' is a timer which, when triggered, causes a
+;; redisplay.
+(defvar c-re-redisplay-timer nil)
+
+(defun c-force-redisplay (start end)
+ ;; Force redisplay immediately. This assumes `font-lock-support-mode' is
+ ;; 'jit-lock-mode. Set the variable `c-re-redisplay-timer' to nil.
+ (save-excursion (c-font-lock-fontify-region start end))
+ (jit-lock-force-redisplay (copy-marker start) (copy-marker end))
+ (setq c-re-redisplay-timer nil))
+
+(defun c-fontify-new-found-type (type)
+ ;; Cause the fontification of TYPE, a string, wherever it occurs in the
+ ;; buffer. If TYPE is currently displayed in a window, cause redisplay to
+ ;; happen "instantaneously". These actions are done only when jit-lock-mode
+ ;; is active.
+ (when (and font-lock-mode
+ (boundp 'font-lock-support-mode)
+ (eq font-lock-support-mode 'jit-lock-mode))
+ (c-save-buffer-state
+ ((window-boundaries
+ (mapcar (lambda (win)
+ (cons (window-start win)
+ (window-end win)))
+ (get-buffer-window-list (current-buffer) 'no-mini t)))
+ (target-re (concat "\\_<" type "\\_>")))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (re-search-forward target-re nil t)
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'fontified nil)
+ (dolist (win-boundary window-boundaries)
+ (when (and (< (match-beginning 0) (cdr win-boundary))
+ (> (match-end 0) (car win-boundary))
+ (not c-re-redisplay-timer))
+ (setq c-re-redisplay-timer
+ (run-with-timer 0 nil #'c-force-redisplay
+ (match-beginning 0) (match-end 0)))))))))))
+
;;; C.
diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el
index c9b7a95df60..ae2ca397661 100644
--- a/lisp/progmodes/cc-mode.el
+++ b/lisp/progmodes/cc-mode.el
@@ -179,6 +179,15 @@
(when c-buffer-is-cc-mode
(save-restriction
(widen)
+ (let ((lst (buffer-list)))
+ (catch 'found
+ (dolist (b lst)
+ (if (and (not (eq b (current-buffer)))
+ (with-current-buffer b
+ c-buffer-is-cc-mode))
+ (throw 'found nil)))
+ (remove-hook 'post-command-hook 'c-post-command)
+ (remove-hook 'post-gc-hook 'c-post-gc-hook)))
(c-save-buffer-state ()
(c-clear-char-properties (point-min) (point-max) 'category)
(c-clear-char-properties (point-min) (point-max) 'syntax-table)
@@ -745,6 +754,8 @@ that requires a literal mode spec at compile time."
;; would do since font-lock uses a(n implicit) depth of 0) so we don't need
;; c-after-font-lock-init.
(add-hook 'after-change-functions 'c-after-change nil t)
+ (add-hook 'post-command-hook 'c-post-command)
+
(when (boundp 'font-lock-extend-after-change-region-function)
(set (make-local-variable 'font-lock-extend-after-change-region-function)
'c-extend-after-change-region))) ; Currently (2009-05) used by all
@@ -1950,6 +1961,43 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
;; confused by already processed single quotes.
(narrow-to-region (point) (point-max))))))
+;; The next two variables record the bounds of an identifier currently being
+;; typed in. These are used to prevent such a partial identifier being
+;; recorded as a found type by c-add-type.
+(defvar c-new-id-start nil)
+(make-variable-buffer-local 'c-new-id-start)
+(defvar c-new-id-end nil)
+(make-variable-buffer-local 'c-new-id-end)
+;; The next variable, when non-nil, records that the previous two variables
+;; define a type.
+(defvar c-new-id-is-type nil)
+(make-variable-buffer-local 'c-new-id-is-type)
+
+(defun c-update-new-id (end)
+ ;; Note the bounds of any identifier that END is in or just after, in
+ ;; `c-new-id-start' and `c-new-id-end'. Otherwise set these variables to
+ ;; nil.
+ (save-excursion
+ (goto-char end)
+ (let ((id-beg (c-on-identifier)))
+ (setq c-new-id-start id-beg
+ c-new-id-end (and id-beg
+ (progn (c-end-of-current-token) (point)))))))
+
+
+(defun c-post-command ()
+ ;; If point was inside of a new identifier and no longer is, record that
+ ;; fact.
+ (when (and c-buffer-is-cc-mode
+ c-new-id-start c-new-id-end
+ (or (> (point) c-new-id-end)
+ (< (point) c-new-id-start)))
+ (when c-new-id-is-type
+ (c-add-type-1 c-new-id-start c-new-id-end))
+ (setq c-new-id-start nil
+ c-new-id-end nil
+ c-new-id-is-type nil)))
+
(defun c-before-change (beg end)
;; Function to be put on `before-change-functions'. Primarily, this calls
;; the language dependent `c-get-state-before-change-functions'. It is
@@ -1969,11 +2017,16 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
(unless (c-called-from-text-property-change-p)
(save-restriction
(widen)
+ ;; Clear the list of found types if we make a change at the start of the
+ ;; buffer, to make it easier to get rid of misspelled types and
+ ;; variables that have gotten recognized as types in malformed code.
+ (when (eq beg (point-min))
+ (c-clear-found-types))
(if c-just-done-before-change
- ;; We have two consecutive calls to `before-change-functions' without
- ;; an intervening `after-change-functions'. An example of this is bug
- ;; #38691. To protect CC Mode, assume that the entire buffer has
- ;; changed.
+ ;; We have two consecutive calls to `before-change-functions'
+ ;; without an intervening `after-change-functions'. An example of
+ ;; this is bug #38691. To protect CC Mode, assume that the entire
+ ;; buffer has changed.
(setq beg (point-min)
end (point-max)
c-just-done-before-change 'whole-buffer)
@@ -2151,6 +2204,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
c->-as-paren-syntax)
(c-clear-char-property-with-value beg end 'syntax-table nil)))
+ (c-update-new-id end)
(c-trim-found-types beg end old-len) ; maybe we don't
; need all of these.
(c-invalidate-sws-region-after beg end old-len)
@@ -2549,17 +2603,24 @@ This function is called from `c-common-init', once per mode initialization."
At the time of call, point is just after the newly inserted CHAR.
-When CHAR is \", t will be returned unless the \" is marked with
-a string fence syntax-table text property. For other characters,
-the default value of `electric-pair-inhibit-predicate' is called
-and its value returned.
+When CHAR is \" and not within a comment, t will be returned if
+the quotes on the current line are already balanced (i.e. if the
+last \" is not marked with a string fence syntax-table text
+property). For other cases, the default value of
+`electric-pair-inhibit-predicate' is called and its value
+returned.
This function is the appropriate value of
`electric-pair-inhibit-predicate' for CC Mode modes, which mark
invalid strings with such a syntax table text property on the
opening \" and the next unescaped end of line."
- (if (eq char ?\")
- (not (equal (get-text-property (1- (point)) 'c-fl-syn-tab) '(15)))
+ (if (and (eq char ?\")
+ (not (memq (cadr (c-semi-pp-to-literal (1- (point)))) '(c c++))))
+ (let ((last-quote (save-match-data
+ (save-excursion
+ (goto-char (c-point 'eoll))
+ (search-backward "\"")))))
+ (not (equal (c-get-char-property last-quote 'c-fl-syn-tab) '(15))))
(funcall (default-value 'electric-pair-inhibit-predicate) char)))
diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el
index c6b6be5b399..4d518838d11 100644
--- a/lisp/progmodes/cc-styles.el
+++ b/lisp/progmodes/cc-styles.el
@@ -444,17 +444,19 @@ STYLE using `c-set-style' if the optional SET-P flag is non-nil."
defstr))
(prompt (concat symname " offset " defstr))
(keymap (make-sparse-keymap))
- (minibuffer-completion-table obarray)
- (minibuffer-completion-predicate 'fboundp)
offset input)
;; In principle completing-read is used here, but SPC is unbound
;; to make it less annoying to enter lists.
(set-keymap-parent keymap minibuffer-local-completion-map)
(define-key keymap " " 'self-insert-command)
(while (not offset)
- (setq input (read-from-minibuffer prompt nil keymap t
- 'c-read-offset-history
- (format "%s" oldoff)))
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (setq-local minibuffer-completion-table obarray)
+ (setq-local minibuffer-completion-predicate 'fboundp))
+ (setq input (read-from-minibuffer prompt nil keymap t
+ 'c-read-offset-history
+ (format "%s" oldoff))))
(if (c-valid-offset input)
(setq offset input)
;; error, but don't signal one, keep trying
diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el
index d843c783ed0..83fd3da7c1d 100644
--- a/lisp/progmodes/cc-vars.el
+++ b/lisp/progmodes/cc-vars.el
@@ -179,7 +179,7 @@ STYLE stands for the choice where the value is taken from some
style setting. PREAMBLE is optionally prepended to FOO; that is,
if FOO contains :tag or :value, the respective two-element list
component is ignored."
- (declare (debug (symbolp form stringp &rest)))
+ (declare (debug (symbolp form stringp &rest)) (indent defun))
(let* ((expanded-doc (concat doc "
This is a style variable. Apart from the valid values described
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index ac26f5e9341..6e3589df7ad 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -346,12 +346,9 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
;; PROGRAM:SOURCE-FILE-NAME:LINENO: MESSAGE
;; which is used for non-interactive programs other than
;; compilers (e.g. the "jade:" entry in compilation.txt).
- (? (| (regexp "[[:alpha:]][-[:alnum:].]+: ?")
- ;; FIXME: This pattern was added for handling messages
- ;; from Ruby, but it is unclear whether it is actually
- ;; used since the gcc-include rule above seems to cover
- ;; it.
- (regexp "[ \t]+\\(?:in \\|from\\)")))
+ (? (| (: alpha (+ (in ?. ?- alnum)) ":" (? " "))
+ ;; Skip indentation generated by GCC's -fanalyzer.
+ (: (+ " ") "|")))
;; File name group.
(group-n 1
@@ -2228,6 +2225,7 @@ The parent is always `compilation-mode' and the customizable `compilation-...'
variables are also set from the name of the mode you have chosen,
by replacing the first word, e.g., `compilation-scroll-output' from
`grep-scroll-output' if that variable exists."
+ (declare (indent defun))
(let ((mode-name (replace-regexp-in-string "-mode\\'" "" (symbol-name mode))))
`(define-derived-mode ,mode compilation-mode ,name
,doc
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 1afeb60ac5f..fe9612a09a9 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -1019,15 +1019,9 @@ Unless KEEP, removes the old indentation."
(define-key map [(control ?c) (control ?h) ?v]
;;(concat (char-to-string help-char) "v") ; does not work
'cperl-get-help))
- (substitute-key-definition
- 'indent-sexp 'cperl-indent-exp
- map global-map)
- (substitute-key-definition
- 'indent-region 'cperl-indent-region
- map global-map)
- (substitute-key-definition
- 'indent-for-comment 'cperl-indent-for-comment
- map global-map)
+ (define-key map [remap indent-sexp] #'cperl-indent-exp)
+ (define-key map [remap indent-region] #'cperl-indent-region)
+ (define-key map [remap indent-for-comment] #'cperl-indent-for-comment)
map)
"Keymap used in CPerl mode.")
@@ -5951,7 +5945,7 @@ default function."
(eval cperl--basic-identifier-rx)))
(0+ blank) "(")
;; '("\\<for\\(each\\)?\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("
- 4 font-lock-variable-name-face)
+ 1 font-lock-variable-name-face)
;; Avoid $!, and s!!, qq!! etc. when not fontifying syntactically
'("\\(?:^\\|[^smywqrx$]\\)\\(!\\)" 1 font-lock-negation-char-face)
'("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend)))
diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el
index d800365e66d..baee72b332d 100644
--- a/lisp/progmodes/cpp.el
+++ b/lisp/progmodes/cpp.el
@@ -702,11 +702,8 @@ BRANCH should be either nil (false branch), t (true branch) or `both'."
(x-popup-menu cpp-button-event
(list prompt (cons prompt cpp-face-default-list)))
(let ((name (car (rassq default cpp-face-default-list))))
- (cdr (assoc (completing-read (if name
- (concat prompt
- " (default " name "): ")
- (concat prompt ": "))
- cpp-face-default-list nil t)
+ (cdr (assoc (completing-read (format-prompt "%s" name prompt)
+ cpp-face-default-list nil t)
cpp-face-all-list))))
default))
diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el
index ab0329d7eec..0713370da3c 100644
--- a/lisp/progmodes/ebrowse.el
+++ b/lisp/progmodes/ebrowse.el
@@ -1330,9 +1330,9 @@ Pop to member buffer if no prefix ARG, to tree buffer otherwise."
"Set the indentation width of the tree display."
(interactive)
(let ((width (string-to-number (read-string
- (concat "Indentation (default "
- (int-to-string ebrowse--indentation)
- "): ")
+ (format-prompt
+ "Indentation"
+ (int-to-string ebrowse--indentation))
nil nil ebrowse--indentation))))
(when (cl-plusp width)
(setq-local ebrowse--indentation width)
@@ -4045,23 +4045,27 @@ NUMBER-OF-STATIC-VARIABLES:"
(defvar ebrowse-global-map nil
"Keymap for Ebrowse commands.")
-
(defvar ebrowse-global-prefix-key "\C-c\C-m"
"Prefix key for Ebrowse commands.")
-
-(defvar ebrowse-global-submap-4 nil
- "Keymap used for `ebrowse-global-prefix' followed by `4'.")
-
-
-(defvar ebrowse-global-submap-5 nil
- "Keymap used for `ebrowse-global-prefix' followed by `5'.")
-
+(defvar-keymap ebrowse-global-submap-4
+ :doc "Keymap used for `ebrowse-global-prefix' followed by `4'."
+ "." #'ebrowse-tags-find-definition-other-window
+ "f" #'ebrowse-tags-find-definition-other-window
+ "v" #'ebrowse-tags-find-declaration-other-window
+ "F" #'ebrowse-tags-view-definition-other-window
+ "V" #'ebrowse-tags-view-declaration-other-window)
+
+(defvar-keymap ebrowse-global-submap-5
+ :doc "Keymap used for `ebrowse-global-prefix' followed by `5'."
+ "." #'ebrowse-tags-find-definition-other-frame
+ "f" #'ebrowse-tags-find-definition-other-frame
+ "v" #'ebrowse-tags-find-declaration-other-frame
+ "F" #'ebrowse-tags-view-definition-other-frame
+ "V" #'ebrowse-tags-view-declaration-other-frame)
(unless ebrowse-global-map
(setq ebrowse-global-map (make-sparse-keymap))
- (setq ebrowse-global-submap-4 (make-sparse-keymap))
- (setq ebrowse-global-submap-5 (make-sparse-keymap))
(define-key ebrowse-global-map "a" 'ebrowse-tags-apropos)
(define-key ebrowse-global-map "b" 'ebrowse-pop-to-browser-buffer)
(define-key ebrowse-global-map "-" 'ebrowse-back-in-position-stack)
@@ -4082,17 +4086,7 @@ NUMBER-OF-STATIC-VARIABLES:"
(define-key ebrowse-global-map " " 'ebrowse-electric-buffer-list)
(define-key ebrowse-global-map "\t" 'ebrowse-tags-complete-symbol)
(define-key ebrowse-global-map "4" ebrowse-global-submap-4)
- (define-key ebrowse-global-submap-4 "." 'ebrowse-tags-find-definition-other-window)
- (define-key ebrowse-global-submap-4 "f" 'ebrowse-tags-find-definition-other-window)
- (define-key ebrowse-global-submap-4 "v" 'ebrowse-tags-find-declaration-other-window)
- (define-key ebrowse-global-submap-4 "F" 'ebrowse-tags-view-definition-other-window)
- (define-key ebrowse-global-submap-4 "V" 'ebrowse-tags-view-declaration-other-window)
(define-key ebrowse-global-map "5" ebrowse-global-submap-5)
- (define-key ebrowse-global-submap-5 "." 'ebrowse-tags-find-definition-other-frame)
- (define-key ebrowse-global-submap-5 "f" 'ebrowse-tags-find-definition-other-frame)
- (define-key ebrowse-global-submap-5 "v" 'ebrowse-tags-find-declaration-other-frame)
- (define-key ebrowse-global-submap-5 "F" 'ebrowse-tags-view-definition-other-frame)
- (define-key ebrowse-global-submap-5 "V" 'ebrowse-tags-view-declaration-other-frame)
(define-key global-map ebrowse-global-prefix-key ebrowse-global-map))
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index 9522055670d..efb5df8ebfb 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -45,15 +45,13 @@ It has `lisp-mode-abbrev-table' as its parent."
table)
"Syntax table used in `emacs-lisp-mode'.")
-(defvar emacs-lisp-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map lisp-mode-shared-map)
- (define-key map "\e\t" 'completion-at-point)
- (define-key map "\e\C-x" 'eval-defun)
- (define-key map "\e\C-q" 'indent-pp-sexp)
- map)
- "Keymap for Emacs Lisp mode.
-All commands in `lisp-mode-shared-map' are inherited by this map.")
+(defvar-keymap emacs-lisp-mode-map
+ :doc "Keymap for Emacs Lisp mode.
+All commands in `lisp-mode-shared-map' are inherited by this map."
+ :parent lisp-mode-shared-map
+ "M-TAB" #'completion-at-point
+ "C-M-x" #'eval-defun
+ "C-M-q" #'indent-pp-sexp)
(easy-menu-define emacs-lisp-mode-menu emacs-lisp-mode-map
"Menu for Emacs Lisp mode."
@@ -270,10 +268,8 @@ Comments in the form will be lost."
(setq-local lexical-binding t)
(add-file-local-variable-prop-line 'lexical-binding t interactive))))
-(defvar elisp--dynlex-modeline-map
- (let ((map (make-sparse-keymap)))
- (define-key map [mode-line mouse-1] 'elisp-enable-lexical-binding)
- map))
+(defvar-keymap elisp--dynlex-modeline-map
+ "<mode-line> <mouse-1>" #'elisp-enable-lexical-binding)
;;;###autoload
(define-derived-mode emacs-lisp-mode lisp-data-mode
@@ -636,7 +632,8 @@ functions are annotated with \"<f>\" via the
:company-kind #'elisp--company-kind
:company-doc-buffer #'elisp--company-doc-buffer
:company-docsig #'elisp--company-doc-string
- :company-location #'elisp--company-location))
+ :company-location #'elisp--company-location
+ :company-deprecated #'elisp--company-deprecated))
(quoted
(list nil (elisp--completion-local-symbols)
;; Don't include all symbols (bug#16646).
@@ -652,7 +649,8 @@ functions are annotated with \"<f>\" via the
:company-kind #'elisp--company-kind
:company-doc-buffer #'elisp--company-doc-buffer
:company-docsig #'elisp--company-doc-string
- :company-location #'elisp--company-location))
+ :company-location #'elisp--company-location
+ :company-deprecated #'elisp--company-deprecated))
(t
(list nil (completion-table-merge
elisp--local-variables-completion-table
@@ -667,7 +665,8 @@ functions are annotated with \"<f>\" via the
'variable))
:company-doc-buffer #'elisp--company-doc-buffer
:company-docsig #'elisp--company-doc-string
- :company-location #'elisp--company-location)))
+ :company-location #'elisp--company-location
+ :company-deprecated #'elisp--company-deprecated)))
;; Looks like a funcall position. Let's double check.
(save-excursion
(goto-char (1- beg))
@@ -714,13 +713,15 @@ functions are annotated with \"<f>\" via the
:company-kind (lambda (_) 'variable)
:company-doc-buffer #'elisp--company-doc-buffer
:company-docsig #'elisp--company-doc-string
- :company-location #'elisp--company-location))
+ :company-location #'elisp--company-location
+ :company-deprecated #'elisp--company-deprecated))
(_ (list nil (elisp--completion-local-symbols)
:predicate #'elisp--shorthand-aware-fboundp
:company-kind #'elisp--company-kind
:company-doc-buffer #'elisp--company-doc-buffer
:company-docsig #'elisp--company-doc-string
:company-location #'elisp--company-location
+ :company-deprecated #'elisp--company-deprecated
))))))))
(nconc (list beg end)
(if (null (car table-etc))
@@ -743,6 +744,11 @@ functions are annotated with \"<f>\" via the
((facep sym) 'color)
(t 'text))))
+(defun elisp--company-deprecated (str)
+ (let ((sym (intern-soft str)))
+ (or (get sym 'byte-obsolete-variable)
+ (get sym 'byte-obsolete-info))))
+
(defun lisp-completion-at-point (&optional _predicate)
(declare (obsolete elisp-completion-at-point "25.1"))
(elisp-completion-at-point))
@@ -1190,16 +1196,14 @@ namespace but with lower confidence."
;;; Elisp Interaction mode
-(defvar lisp-interaction-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map lisp-mode-shared-map)
- (define-key map "\e\C-x" 'eval-defun)
- (define-key map "\e\C-q" 'indent-pp-sexp)
- (define-key map "\e\t" 'completion-at-point)
- (define-key map "\n" 'eval-print-last-sexp)
- map)
- "Keymap for Lisp Interaction mode.
-All commands in `lisp-mode-shared-map' are inherited by this map.")
+(defvar-keymap lisp-interaction-mode-map
+ :doc "Keymap for Lisp Interaction mode.
+All commands in `lisp-mode-shared-map' are inherited by this map."
+ :parent lisp-mode-shared-map
+ "C-M-x" #'eval-defun
+ "C-M-q" #'indent-pp-sexp
+ "M-TAB" #'completion-at-point
+ "C-j" #'eval-print-last-sexp)
(easy-menu-define lisp-interaction-mode-menu lisp-interaction-mode-map
"Menu for Lisp Interaction mode."
diff --git a/lisp/progmodes/erts-mode.el b/lisp/progmodes/erts-mode.el
new file mode 100644
index 00000000000..a12c964c250
--- /dev/null
+++ b/lisp/progmodes/erts-mode.el
@@ -0,0 +1,225 @@
+;;; erts-mode.el --- major mode to edit erts files -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Keywords: tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+(require 'ert)
+
+(defgroup erts-mode nil
+ "Major mode for editing Emacs test files."
+ :group 'lisp)
+
+(defface erts-mode-specification-name
+ '((((class color)
+ (background dark))
+ :foreground "green")
+ (((class color)
+ (background light))
+ :foreground "cornflower blue")
+ (t
+ :bold t))
+ "Face used for displaying specification names."
+ :group 'erts-mode)
+
+(defface erts-mode-specification-value
+ '((((class color)
+ (background dark))
+ :foreground "DeepSkyBlue1")
+ (((class color)
+ (background light))
+ :foreground "blue")
+ (t
+ :bold t))
+ "Face used for displaying specificaton values."
+ :group 'erts-mode)
+
+(defface erts-mode-start-test
+ '((t :inherit font-lock-keyword-face))
+ "Face used for displaying specificaton test start markers."
+ :group 'erts-mode)
+
+(defface erts-mode-end-test
+ '((t :inherit font-lock-comment-face))
+ "Face used for displaying specificaton test start markers."
+ :group 'erts-mode)
+
+(defvar erts-mode-map
+ (let ((map (make-keymap)))
+ (set-keymap-parent map prog-mode-map)
+ (define-key map "\C-c\C-r" 'erts-tag-region)
+ (define-key map "\C-c\C-c" 'erts-run-test)
+ map))
+
+(defvar erts-mode-font-lock-keywords
+ ;; Specifications.
+ `((erts-mode--match-not-in-test
+ ("^\\([^ \t\n:]+:\\)[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?"
+ (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+ (1 'erts-mode-specification-name)
+ (2 'erts-mode-specification-value)))
+ ("^=-=$" 0 'erts-mode-start-test)
+ ("^=-=-=$" 0 'erts-mode-end-test)))
+
+(defun erts-mode--match-not-in-test (_limit)
+ (when (erts-mode--in-test-p (point))
+ (erts-mode--end-of-test))
+ (let ((start (point)))
+ (goto-char
+ (if (re-search-forward "^=-=$" nil t)
+ (match-beginning 0)
+ (point-max)))
+ (if (< (point) start)
+ nil
+ ;; Here we disregard LIMIT so that we may extend the area again.
+ (set-match-data (list start (point)))
+ (point))))
+
+(defun erts-mode--end-of-test ()
+ (search-forward "^=-=-=\n" nil t))
+
+(defun erts-mode--in-test-p (point)
+ "Say whether POINT is in a test."
+ (save-excursion
+ (goto-char point)
+ (beginning-of-line)
+ (if (looking-at "=-=\\(-=\\)?$")
+ t
+ (let ((test-start (save-excursion
+ (re-search-backward "^=-=\n" nil t))))
+ ;; Before the first test.
+ (and test-start
+ (let ((test-end (re-search-backward "^=-=-=\n" nil t)))
+ (or (null test-end)
+ ;; Between tests.
+ (> test-start test-end))))))))
+
+;;;###autoload
+(define-derived-mode erts-mode prog-mode "erts"
+ "Major mode for editing erts (Emacs testing) files.
+This mode mainly provides some font locking.
+
+\\{erts-mode-map}"
+ (setq-local font-lock-defaults '(erts-mode-font-lock-keywords t)))
+
+(defun erts-tag-region (start end name)
+ "Tag the region between START and END as a test.
+Interactively, this is the region.
+
+NAME should be a string appropriate for output by ert if the test fails.
+If NAME is nil or the empty string, a name will be auto-generated."
+ (interactive "r\nsTest name: " erts-mode)
+ ;; Automatically make a name.
+ (when (zerop (length name))
+ (save-excursion
+ (goto-char (point-min))
+ (let ((names nil))
+ (while (re-search-forward "^Name:[ \t]*\\(.*\\)" nil t)
+ (let ((name (match-string 1)))
+ (unless (erts-mode--in-test-p (point))
+ (push name names))))
+ (setq name
+ (cl-loop with base = (file-name-sans-extension (buffer-name))
+ for i from 1
+ for name = (format "%s%d" base i)
+ unless (member name names)
+ return name)))))
+ (save-excursion
+ (goto-char end)
+ (unless (bolp)
+ (insert "\n"))
+ (insert "=-=-=\n")
+ (goto-char start)
+ (insert "Name: " name "\n\n")
+ (insert "=-=\n")))
+
+(defun erts-mode--preceding-spec (name)
+ (save-excursion
+ ;; Find the name, but skip if it's in a test.
+ (while (and (re-search-backward (format "^%s:" name) nil t)
+ (erts-mode--in-test-p (point))))
+ (and (not (erts-mode--in-test-p (point)))
+ (re-search-forward "^=-=$" nil t)
+ (progn
+ (goto-char (match-beginning 0))
+ (cdr (assq (intern (downcase name))
+ (ert--erts-specifications (point))))))))
+
+(defun erts-run-test (test-function &optional verbose)
+ "Run the current test.
+If the current erts file doesn't define a test function, the user
+will be prompted for one.
+
+If VERBOSE (interactively, the prefix), display a diff of the
+expected results and the actual results in a separate buffer."
+ (interactive
+ (list (or (erts-mode--preceding-spec "Code")
+ (read-string "Transformation function: "))
+ current-prefix-arg)
+ erts-mode)
+ (save-excursion
+ (erts-mode--goto-start-of-test)
+ (condition-case arg
+ (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")))
+ (buffer-file-name))
+ (:success (message "Test successful"))
+ (ert-test-failed
+ (if (not verbose)
+ (message "Test failure; result: \n%s"
+ (substring-no-properties (cadr (cadr arg))))
+ (message "Test failure")
+ (let (expected got)
+ (unwind-protect
+ (progn
+ (with-current-buffer
+ (setq expected (generate-new-buffer "erts expected"))
+ (insert (nth 1 (cadr arg))))
+ (with-current-buffer
+ (setq got (generate-new-buffer "erts results"))
+ (insert (nth 2 (cadr arg))))
+ (diff-buffers expected got))
+ (kill-buffer expected)
+ (kill-buffer got))))))))
+
+(defun erts-mode--goto-start-of-test ()
+ (if (not (erts-mode--in-test-p (point)))
+ (re-search-forward "^=-=\n" nil t)
+ (re-search-backward "^=-=\n" nil t)
+ (let ((potential-start (match-end 0)))
+ ;; See if we're in a two-clause ("before" and "after") test or not.
+ (if-let ((start (and (save-excursion (re-search-backward "^=-=\n" nil t))
+ (match-end 0))))
+ (let ((end (save-excursion (re-search-backward "^=-=-=\n" nil t))))
+ (if (or (not end)
+ (> start end))
+ ;; We are, so go to the real start.
+ (goto-char start)
+ (goto-char potential-start)))
+ (goto-char potential-start)))))
+
+(provide 'erts-mode)
+
+;;; erts-mode.el ends here
diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el
index f53b09d9e8c..d7dbaa06505 100644
--- a/lisp/progmodes/etags.el
+++ b/lisp/progmodes/etags.el
@@ -145,7 +145,9 @@ Otherwise, `find-tag-default' is used."
:type '(choice (const nil) function))
(define-obsolete-variable-alias 'find-tag-marker-ring-length
- 'xref-marker-ring-length "25.1")
+ 'tags-location-ring-length "25.1")
+
+(defvar tags-location-ring-length 16)
(defcustom tags-tag-face 'default
"Face for tags in the output of `tags-apropos'."
@@ -180,10 +182,11 @@ Example value:
(sexp :tag "Tags to search")))
:version "21.1")
-(defvaralias 'find-tag-marker-ring 'xref--marker-ring)
+;; Obsolete variable kept for compatibility. We don't use it in any way.
+(defvar find-tag-marker-ring (make-ring 16))
(make-obsolete-variable
'find-tag-marker-ring
- "use `xref-push-marker-stack' or `xref-pop-marker-stack' instead."
+ "use `xref-push-marker-stack' or `xref-go-back' instead."
"25.1")
(defvar default-tags-table-function nil
@@ -191,7 +194,7 @@ Example value:
This function receives no arguments and should return the default
tags table file to use for the current buffer.")
-(defvar tags-location-ring (make-ring xref-marker-ring-length)
+(defvar tags-location-ring (make-ring tags-location-ring-length)
"Ring of markers which are locations visited by \\[find-tag].
Pop back to the last location with \\[negative-argument] \\[find-tag].")
@@ -292,7 +295,7 @@ file the tag was in."
(or (locate-dominating-file default-directory "TAGS")
default-directory)))
(list (read-file-name
- "Visit tags table (default TAGS): "
+ (format-prompt "Visit tags table" "TAGS")
;; default to TAGS from default-directory up to root.
default-tag-dir
(expand-file-name "TAGS" default-tag-dir)
@@ -625,7 +628,7 @@ Returns t if it visits a tags table, or nil if there are no more in the list."
(car list))
;; Finally, prompt the user for a file name.
(expand-file-name
- (read-file-name "Visit tags table (default TAGS): "
+ (read-file-name (format-prompt "Visit tags table" "TAGS")
default-directory
"TAGS"
t))))))
@@ -731,13 +734,13 @@ Returns t if it visits a tags table, or nil if there are no more in the list."
(interactive)
;; Clear out the markers we are throwing away.
(let ((i 0))
- (while (< i xref-marker-ring-length)
+ (while (< i tags-location-ring-length)
(if (aref (cddr tags-location-ring) i)
(set-marker (aref (cddr tags-location-ring) i) nil))
(setq i (1+ i))))
(xref-clear-marker-stack)
(setq tags-file-name nil
- tags-location-ring (make-ring xref-marker-ring-length)
+ tags-location-ring (make-ring tags-location-ring-length)
tags-table-list nil
tags-table-computed-list nil
tags-table-computed-list-for nil
@@ -1068,7 +1071,7 @@ See documentation of variable `tags-file-name'."
regexp next-p t))
;;;###autoload
-(defalias 'pop-tag-mark 'xref-pop-marker-stack)
+(defalias 'pop-tag-mark 'xref-go-back)
(defvar tag-lines-already-matched nil
@@ -1989,7 +1992,8 @@ see the doc of that variable if you want to add names to the list."
(setq set-list (delete (car set-list) set-list)))
(goto-char (point-min))
(insert-before-markers
- "Type `t' to select a tags table or set of tags tables:\n\n")
+ (substitute-command-keys
+ "Type \\`t' to select a tags table or set of tags tables:\n\n"))
(if desired-point
(goto-char desired-point))
(set-window-start (selected-window) 1 t))
diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el
index f9e6101e7ab..eb6da20ff7f 100644
--- a/lisp/progmodes/f90.el
+++ b/lisp/progmodes/f90.el
@@ -345,6 +345,7 @@ The options are `downcase-word', `upcase-word', `capitalize-word' and nil."
;; there are spaces.
"contiguous" "submodule" "concurrent" "codimension"
"sync all" "sync memory" "critical" "image_index" "error stop"
+ "impure"
))
"\\_>")
"Regexp used by the function `f90-change-keywords'.")
@@ -646,7 +647,7 @@ do\\([ \t]*while\\)?\\|select[ \t]*\\(?:case\\|type\\)\\|where\\|\
forall\\|block\\|critical\\)\\)\\_>"
(2 font-lock-constant-face nil t) (3 font-lock-keyword-face))
;; Implicit declaration.
- '("\\_<\\(implicit\\)[ \t]*\\(real\\|integer\\|c\\(haracter\\|omplex\\)\
+ '("\\_<\\(implicit\\)[ \t]+\\(real\\|integer\\|c\\(haracter\\|omplex\\)\
\\|enumerator\\|procedure\\|\
logical\\|double[ \t]*precision\\|type[ \t]*(\\(?:\\sw\\|\\s_\\)+)\\|none\\)[ \t]*"
(1 font-lock-keyword-face) (2 font-lock-type-face))
@@ -656,8 +657,10 @@ logical\\|double[ \t]*precision\\|type[ \t]*(\\(?:\\sw\\|\\s_\\)+)\\|none\\)[ \t
'("\\(&\\)[ \t]*\\(!\\|$\\)" (1 font-lock-keyword-face))
"\\_<\\(then\\|continue\\|format\\|include\\|\\(?:error[ \t]+\\)?stop\\|\
return\\)\\_>"
- '("\\_<\\(exit\\|cycle\\)[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)?\\_>"
+ '("\\_<\\(exit\\|cycle\\)[ \t]+\\(\\(?:\\sw\\|\\s_\\)+\\)?\\_>"
(1 font-lock-keyword-face) (2 font-lock-constant-face nil t))
+ '("\\_<\\(exit\\|cycle\\)\\_>"
+ (1 font-lock-keyword-face))
'("\\_<\\(case\\)[ \t]*\\(default\\|(\\)" . 1)
;; F2003 "class default".
'("\\_<\\(class\\)[ \t]*default" . 1)
diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el
index 66adc4e9ef8..409ff940d96 100644
--- a/lisp/progmodes/gdb-mi.el
+++ b/lisp/progmodes/gdb-mi.el
@@ -1266,7 +1266,7 @@ Used by Speedbar."
:version "22.1")
(define-key gud-minor-mode-map "\C-c\C-w" 'gud-watch)
-(define-key global-map (vconcat gud-key-prefix "\C-w") 'gud-watch)
+(keymap-set gud-global-map "C-w" 'gud-watch)
(declare-function tooltip-identifier-from-point "tooltip" (point))
@@ -1612,6 +1612,7 @@ this trigger is subscribed to `gdb-buf-publisher' and called with
;; Used to display windows with thread-bound buffers
(defmacro def-gdb-preempt-display-buffer (name buffer &optional doc
split-horizontal)
+ (declare (indent defun))
`(defun ,name (&optional thread)
,(when doc doc)
(message "%s" thread)
@@ -3012,6 +3013,7 @@ calling `gdb-current-context-command').
Triggers defined by this command are meant to be used as a
trigger argument when describing buffer types with
`gdb-set-buffer-rules'."
+ (declare (indent defun))
`(defun ,trigger-name (&optional signal)
(when
(or (not ,signal-list)
@@ -3032,6 +3034,7 @@ Erase current buffer and evaluate CUSTOM-DEFUN.
Then call `gdb-update-buffer-name'.
If NOPRESERVE is non-nil, window point is not restored after CUSTOM-DEFUN."
+ (declare (indent defun))
`(defun ,handler-name ()
(let* ((inhibit-read-only t)
,@(unless nopreserve
@@ -3055,6 +3058,7 @@ See `def-gdb-auto-update-trigger'.
HANDLER-NAME handler uses customization of CUSTOM-DEFUN.
See `def-gdb-auto-update-handler'."
+ (declare (indent defun))
`(progn
(def-gdb-auto-update-trigger ,trigger-name
,gdb-command
@@ -3473,6 +3477,7 @@ corresponding to the mode line clicked."
CUSTOM-DEFUN may use locally bound `thread' variable, which will
be the value of `gdb-thread' property of the current line.
If `gdb-thread' is nil, error is signaled."
+ (declare (indent defun))
`(defun ,name (&optional event)
,(when doc doc)
(interactive (list last-input-event))
@@ -3488,6 +3493,7 @@ If `gdb-thread' is nil, error is signaled."
&optional doc)
"Define a NAME which will call BUFFER-COMMAND with id of thread
on the current line."
+ (declare (indent defun))
`(def-gdb-thread-buffer-command ,name
(,buffer-command (gdb-mi--field thread 'id))
,doc))
@@ -3543,6 +3549,7 @@ on the current line."
"Define a NAME which will execute GUD-COMMAND with
`gdb-thread-number' locally bound to id of thread on the current
line."
+ (declare (indent defun))
`(def-gdb-thread-buffer-command ,name
(if gdb-non-stop
(let ((gdb-thread-number (gdb-mi--field thread 'id))
@@ -3711,6 +3718,7 @@ in `gdb-memory-format'."
(defmacro def-gdb-set-positive-number (name variable echo-string &optional doc)
"Define a function NAME which reads new VAR value from minibuffer."
+ (declare (indent defun))
`(defun ,name (event)
,(when doc doc)
(interactive "e")
@@ -3739,6 +3747,7 @@ in `gdb-memory-format'."
"Define a function NAME to switch memory buffer to use FORMAT.
DOC is an optional documentation string."
+ (declare (indent defun))
`(defun ,name () ,(when doc doc)
(interactive)
(customize-set-variable 'gdb-memory-format ,format)
@@ -3808,6 +3817,7 @@ DOC is an optional documentation string."
"Define a function NAME to switch memory unit size to UNIT-SIZE.
DOC is an optional documentation string."
+ (declare (indent defun))
`(defun ,name () ,(when doc doc)
(interactive)
(customize-set-variable 'gdb-memory-unit ,unit-size)
@@ -3832,6 +3842,7 @@ The defined function switches Memory buffer to show address
stored in ADDRESS-VAR variable.
DOC is an optional documentation string."
+ (declare (indent defun))
`(defun ,name
,(when doc doc)
(interactive)
diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el
index 9be3af79f9d..70c55c01dd7 100644
--- a/lisp/progmodes/grep.el
+++ b/lisp/progmodes/grep.el
@@ -1057,11 +1057,9 @@ REGEXP is used as a string in the prompt."
default-extension
(car grep-files-history)
(car (car grep-files-aliases))))
- (files (completing-read
- (concat "Search for \"" regexp
- "\" in files matching wildcard"
- (if default (concat " (default " default ")"))
- ": ")
+ (files (completing-read
+ (format-prompt "Search for \"%s\" in files matching wildcard"
+ default regexp)
#'read-file-name-internal
nil nil nil 'grep-files-history
(delete-dups
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index 2061d414802..d5bd2655174 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -90,8 +90,10 @@ pdb (Python), and jdb."
"Prefix of all GUD commands valid in C buffers."
:type 'key-sequence)
-(global-set-key (vconcat gud-key-prefix "\C-l") #'gud-refresh)
-;; (define-key ctl-x-map " " 'gud-break); backward compatibility hack
+(defvar-keymap gud-global-map
+ "C-l" #'gud-refresh)
+
+(global-set-key gud-key-prefix gud-global-map)
(defvar gud-marker-filter nil)
(put 'gud-marker-filter 'permanent-local t)
@@ -433,7 +435,7 @@ we're in the GUD buffer)."
;; Unused lexical warning if cmd does not use "arg".
cmd))))
,(if key `(local-set-key ,(concat "\C-c" key) #',func))
- ,(if key `(global-set-key (vconcat gud-key-prefix ,key) #',func))))
+ ,(if key `(define-key gud-global-map ,key #',func))))
;; Where gud-display-frame should put the debugging arrow; a cons of
;; (filename . line-number). This is set by the marker-filter, which scans
@@ -3539,8 +3541,8 @@ Treats actions as defuns."
#'gdb-script-end-of-defun)
(setq-local font-lock-defaults
'(gdb-script-font-lock-keywords nil nil ((?_ . "w")) nil
- (font-lock-syntactic-face-function
- . gdb-script-font-lock-syntactic-face)))
+ (font-lock-syntactic-face-function
+ . gdb-script-font-lock-syntactic-face)))
;; Recognize docstrings.
(setq-local syntax-propertize-function
gdb-script-syntax-propertize-function)
diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el
index a18a67249ae..538ec4df804 100644
--- a/lisp/progmodes/hideif.el
+++ b/lisp/progmodes/hideif.el
@@ -181,30 +181,24 @@ Effective only if `hide-ifdef-expand-reinclusion-guard' is t."
:type 'regexp
:version "25.1")
-(defvar hide-ifdef-mode-submap
+(defvar-keymap hide-ifdef-mode-submap
+ :doc "Keymap used by `hide-ifdef-mode' under `hide-ifdef-mode-prefix-key'."
;; Set up the submap that goes after the prefix key.
- (let ((map (make-sparse-keymap)))
- (define-key map "d" 'hide-ifdef-define)
- (define-key map "u" 'hide-ifdef-undef)
- (define-key map "D" 'hide-ifdef-set-define-alist)
- (define-key map "U" 'hide-ifdef-use-define-alist)
-
- (define-key map "h" 'hide-ifdefs)
- (define-key map "s" 'show-ifdefs)
- (define-key map "\C-d" 'hide-ifdef-block)
- (define-key map "\C-s" 'show-ifdef-block)
- (define-key map "e" 'hif-evaluate-macro)
- (define-key map "C" 'hif-clear-all-ifdef-defined)
-
- (define-key map "\C-q" 'hide-ifdef-toggle-read-only)
- (define-key map "\C-w" 'hide-ifdef-toggle-shadowing)
- (substitute-key-definition
- 'read-only-mode 'hide-ifdef-toggle-outside-read-only map)
- ;; `toggle-read-only' is obsoleted by `read-only-mode'.
- (substitute-key-definition
- 'toggle-read-only 'hide-ifdef-toggle-outside-read-only map)
- map)
- "Keymap used by `hide-ifdef-mode' under `hide-ifdef-mode-prefix-key'.")
+ "d" #'hide-ifdef-define
+ "u" #'hide-ifdef-undef
+ "D" #'hide-ifdef-set-define-alist
+ "U" #'hide-ifdef-use-define-alist
+ "h" #'hide-ifdefs
+ "s" #'show-ifdefs
+ "C-d" #'hide-ifdef-block
+ "C-s" #'show-ifdef-block
+ "e" #'hif-evaluate-macro
+ "C" #'hif-clear-all-ifdef-defined
+ "C-q" #'hide-ifdef-toggle-read-only
+ "C-w" #'hide-ifdef-toggle-shadowing
+ "<remap> <read-only-mode>" #'hide-ifdef-toggle-outside-read-only
+ ;; `toggle-read-only' is obsoleted by `read-only-mode'.
+ "<remap> <toggle-read-only>" #'hide-ifdef-toggle-outside-read-only)
(defcustom hide-ifdef-mode-prefix-key "\C-c@"
"Prefix key for all Hide-Ifdef mode commands."
@@ -2456,7 +2450,7 @@ This allows #ifdef VAR to be hidden."
(t
nil))))
(var (read-minibuffer "Define what? " default))
- (val (read-from-minibuffer (format "Set %s to? (default 1): " var)
+ (val (read-from-minibuffer (format-prompt "Set %s to?" "1" var)
nil nil t nil "1")))
(list var val)))
(hif-set-var var (or val 1))
diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el
index 5a31ad35087..ded3a9c463c 100644
--- a/lisp/progmodes/idlw-shell.el
+++ b/lisp/progmodes/idlw-shell.el
@@ -817,7 +817,7 @@ IDL has currently stepped.")
Command history, searching of previous commands, command line
editing are available via the comint-mode key bindings, by default
- mostly on the key `C-c'. Command history is also available with
+ mostly on the key \\`C-c'. Command history is also available with
the arrow keys UP and DOWN.
2. Completion
@@ -1327,7 +1327,7 @@ See also the variable `idlwave-shell-input-mode-spells'."
Characters are sent one by one, without newlines. The loop is blocking
and intercepts all input events to Emacs. You can use this command
to interact with the IDL command GET_KBRD.
-The loop can be aborted by typing `C-g'. The loop also exits automatically
+The loop can be aborted by typing \\[keyboard-quit]. The loop also exits automatically
when the IDL prompt gets displayed again after the current IDL command."
(interactive)
@@ -1342,7 +1342,8 @@ when the IDL prompt gets displayed again after the current IDL command."
(funcall errf "No IDL program seems to be waiting for input"))
;; OK, start the loop
- (message "Character mode on: Sending single chars (`C-g' to exit)")
+ (message (substitute-command-keys
+ "Character mode on: Sending single chars (\\[keyboard-quit] to exit)"))
(message
(catch 'exit
(while t
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index 845ca8609d7..9303f1ecb91 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -33,7 +33,7 @@
;; The main features of this JavaScript mode are syntactic
;; highlighting (enabled with `font-lock-mode' or
;; `global-font-lock-mode'), automatic indentation and filling of
-;; comments, C preprocessor fontification, and MozRepl integration.
+;; comments, and C preprocessor fontification.
;;
;; General Remarks:
;;
@@ -51,7 +51,6 @@
(require 'cc-fonts))
(require 'newcomment)
(require 'imenu)
-(require 'moz nil t)
(require 'json)
(require 'prog-mode)
@@ -59,12 +58,9 @@
(require 'cl-lib)
(require 'ido))
-(defvar inferior-moz-buffer)
-(defvar moz-repl-name)
(defvar ido-cur-list)
(defvar electric-layout-rules)
(declare-function ido-mode "ido" (&optional arg))
-(declare-function inferior-moz-process "ext:mozrepl" ())
;;; Constants
@@ -95,7 +91,7 @@ name.")
(defconst js--plain-method-re
(concat "^\\s-*?\\(" js--dotted-name-re "\\)\\.prototype"
- "\\.\\(" js--name-re "\\)\\s-*?=\\s-*?\\(function\\)\\_>")
+ "\\.\\(" js--name-re "\\)\\s-*?=\\s-*?\\(\\(:?async[ \t\n]+\\)function\\)\\_>")
"Regexp matching an explicit JavaScript prototype \"method\" declaration.
Group 1 is a (possibly-dotted) class name, group 2 is a method name,
and group 3 is the `function' keyword.")
@@ -485,25 +481,22 @@ seldom use, either globally or on a per-buffer basis."
(list 'const x))
js--available-frameworks)))
-(defcustom js-js-switch-tabs
- (and (memq system-type '(darwin)) t)
+(defvar js-js-switch-tabs (and (memq system-type '(darwin)) t)
"Whether `js-mode' should display tabs while selecting them.
This is useful only if the windowing system has a good mechanism
-for preventing Firefox from stealing the keyboard focus."
- :type 'boolean)
+for preventing Firefox from stealing the keyboard focus.")
+(make-obsolete-variable 'js-js-switch-tabs "MozRepl no longer exists" "28.1")
-(defcustom js-js-tmpdir
- (locate-user-emacs-file "js/js")
+(defvar js-js-tmpdir (locate-user-emacs-file "js/js")
"Temporary directory used by `js-mode' to communicate with Mozilla.
-This directory must be readable and writable by both Mozilla and Emacs."
- :type 'directory
- :version "28.1")
+This directory must be readable and writable by both Mozilla and Emacs.")
+(make-obsolete-variable 'js-js-tmpdir "MozRepl no longer exists" "28.1")
-(defcustom js-js-timeout 5
+(defvar js-js-timeout 5
"Reply timeout for executing commands in Mozilla via `js-mode'.
The value is given in seconds. Increase this value if you are
-getting timeout messages."
- :type 'integer)
+getting timeout messages.")
+(make-obsolete-variable 'js-js-timeout "MozRepl no longer exists" "28.1")
(defcustom js-indent-first-init nil
"Non-nil means specially indent the first variable declaration's initializer.
@@ -671,18 +664,7 @@ This variable is like `sgml-attribute-offset'."
(defvar js-mode-map
(let ((keymap (make-sparse-keymap)))
- (define-key keymap [(control ?c) (meta ?:)] #'js-eval)
- (define-key keymap [(control ?c) (control ?j)] #'js-set-js-context)
- (define-key keymap [(control meta ?x)] #'js-eval-defun)
(define-key keymap [(meta ?.)] #'js-find-symbol)
- (easy-menu-define nil keymap "JavaScript Menu"
- '("JavaScript"
- ["Select New Mozilla Context..." js-set-js-context
- (fboundp #'inferior-moz-process)]
- ["Evaluate Expression in Mozilla Context..." js-eval
- (fboundp #'inferior-moz-process)]
- ["Send Current Function to Mozilla..." js-eval-defun
- (fboundp #'inferior-moz-process)]))
keymap)
"Keymap for `js-mode'.")
@@ -932,9 +914,10 @@ This puts point at the `function' keyword.
If this is a syntactically-correct non-expression function,
return the name of the function, or t if the name could not be
determined. Otherwise, return nil."
- (cl-assert (looking-at "\\_<function\\_>"))
+ (unless (looking-at "\\(\\_<async\\_>[ \t\n]+\\)?\\_<function\\_>")
+ (error "Invalid position"))
(let ((name t))
- (forward-word-strictly)
+ (goto-char (match-end 0))
(forward-comment most-positive-fixnum)
(when (eq (char-after) ?*)
(forward-char)
@@ -970,14 +953,17 @@ If POS is not in a function prologue, return nil."
(goto-char (match-end 0))))
(skip-syntax-backward "w_")
- (and (or (looking-at "\\_<function\\_>")
- (js--re-search-backward "\\_<function\\_>" nil t))
-
- (save-match-data (goto-char (match-beginning 0))
- (js--forward-function-decl))
-
- (<= pos (point))
- (or prologue-begin (match-beginning 0))))))
+ (let ((start nil))
+ (and (or (looking-at "\\_<function\\_>")
+ (js--re-search-backward "\\_<function\\_>" nil t))
+ (progn
+ (setq start (match-beginning 0))
+ (goto-char start)
+ (when (looking-back "\\_<async\\_>[ \t\n]+" (- (point) 30))
+ (setq start (match-beginning 0)))
+ (js--forward-function-decl))
+ (<= pos (point))
+ (or prologue-begin start))))))
(defun js--beginning-of-defun-raw ()
"Helper function for `js-beginning-of-defun'.
@@ -1247,7 +1233,6 @@ LIMIT defaults to point."
;; Regular function declaration
((and (looking-at "\\_<function\\_>")
(setq name (js--forward-function-decl)))
-
(when (eq name t)
(setq name (js--guess-function-name orig-match-end))
(if name
@@ -1259,6 +1244,11 @@ LIMIT defaults to point."
(cl-assert (eq (char-after) ?{))
(forward-char)
+ (save-excursion
+ (goto-char orig-match-start)
+ (when (looking-back "\\_<async\\_>[ \t\n]+"
+ (- (point) 30))
+ (setq orig-match-start (match-beginning 0))))
(make-js--pitem
:paren-depth orig-depth
:h-begin orig-match-start
@@ -3308,10 +3298,7 @@ marker."
(setf (car bounds) (point))))
(buffer-substring (car bounds) (cdr bounds)))))
-(defvar find-tag-marker-ring) ; etags
-
-;; etags loads ring.
-(declare-function ring-insert "ring" (ring item))
+(declare-function xref-push-marker-stack "xref" (&optional m))
(defun js-find-symbol (&optional arg)
"Read a JavaScript symbol and jump to it.
@@ -3319,7 +3306,7 @@ With a prefix argument, restrict symbols to those from the
current buffer. Pushes a mark onto the tag ring just like
`find-tag'."
(interactive "P")
- (require 'etags)
+ (require 'xref)
(let (symbols marker)
(if (not arg)
(setq symbols (js--get-all-known-symbols))
@@ -3331,1111 +3318,11 @@ current buffer. Pushes a mark onto the tag ring just like
symbols "Jump to: "
(js--guess-symbol-at-point))))
- (ring-insert find-tag-marker-ring (point-marker))
+ (xref-push-marker-stack)
(switch-to-buffer (marker-buffer marker))
(push-mark)
(goto-char marker)))
-;;; MozRepl integration
-
-(define-error 'js-moz-bad-rpc "Mozilla RPC Error") ;; '(timeout error))
-(define-error 'js-js-error "JavaScript Error") ;; '(js-error error))
-
-(defun js--wait-for-matching-output
- (process regexp timeout &optional start)
- "Wait TIMEOUT seconds for PROCESS to output a match for REGEXP.
-On timeout, return nil. On success, return t with match data
-set. If START is non-nil, look for output starting from START.
-Otherwise, use the current value of `process-mark'."
- (with-current-buffer (process-buffer process)
- (cl-loop with start-pos = (or start
- (marker-position (process-mark process)))
- with end-time = (time-add nil timeout)
- for time-left = (float-time (time-subtract end-time nil))
- do (goto-char (point-max))
- if (looking-back regexp start-pos) return t
- while (> time-left 0)
- do (accept-process-output process time-left nil t)
- do (goto-char (process-mark process))
- finally do (signal
- 'js-moz-bad-rpc
- (list (format "Timed out waiting for output matching %S" regexp))))))
-
-(cl-defstruct js--js-handle
- ;; Integer, mirrors the value we see in JS
- (id nil :read-only t)
-
- ;; Process to which this thing belongs
- (process nil :read-only t))
-
-(defun js--js-handle-expired-p (x)
- (not (eq (js--js-handle-process x)
- (inferior-moz-process))))
-
-(defvar js--js-references nil
- "Maps Elisp JavaScript proxy objects to their JavaScript IDs.")
-
-(defvar js--js-process nil
- "The most recent MozRepl process object.")
-
-(defvar js--js-gc-idle-timer nil
- "Idle timer for cleaning up JS object references.")
-
-(defvar js--js-last-gcs-done nil)
-
-(defconst js--moz-interactor
- (replace-regexp-in-string
- "[ \n]+" " "
- ; */" Make Emacs happy
-"(function(repl) {
- repl.defineInteractor('js', {
- onStart: function onStart(repl) {
- if(!repl._jsObjects) {
- repl._jsObjects = {};
- repl._jsLastID = 0;
- repl._jsGC = this._jsGC;
- }
- this._input = '';
- },
-
- _jsGC: function _jsGC(ids_in_use) {
- var objects = this._jsObjects;
- var keys = [];
- var num_freed = 0;
-
- for(var pn in objects) {
- keys.push(Number(pn));
- }
-
- keys.sort(function(x, y) x - y);
- ids_in_use.sort(function(x, y) x - y);
- var i = 0;
- var j = 0;
-
- while(i < ids_in_use.length && j < keys.length) {
- var id = ids_in_use[i++];
- while(j < keys.length && keys[j] !== id) {
- var k_id = keys[j++];
- delete objects[k_id];
- ++num_freed;
- }
- ++j;
- }
-
- while(j < keys.length) {
- var k_id = keys[j++];
- delete objects[k_id];
- ++num_freed;
- }
-
- return num_freed;
- },
-
- _mkArray: function _mkArray() {
- var result = [];
- for(var i = 0; i < arguments.length; ++i) {
- result.push(arguments[i]);
- }
- return result;
- },
-
- _parsePropDescriptor: function _parsePropDescriptor(parts) {
- if(typeof parts === 'string') {
- parts = [ parts ];
- }
-
- var obj = parts[0];
- var start = 1;
-
- if(typeof obj === 'string') {
- obj = window;
- start = 0;
- } else if(parts.length < 2) {
- throw new Error('expected at least 2 arguments');
- }
-
- for(var i = start; i < parts.length - 1; ++i) {
- obj = obj[parts[i]];
- }
-
- return [obj, parts[parts.length - 1]];
- },
-
- _getProp: function _getProp(/*...*/) {
- if(arguments.length === 0) {
- throw new Error('no arguments supplied to getprop');
- }
-
- if(arguments.length === 1 &&
- (typeof arguments[0]) !== 'string')
- {
- return arguments[0];
- }
-
- var [obj, propname] = this._parsePropDescriptor(arguments);
- return obj[propname];
- },
-
- _putProp: function _putProp(properties, value) {
- var [obj, propname] = this._parsePropDescriptor(properties);
- obj[propname] = value;
- },
-
- _delProp: function _delProp(propname) {
- var [obj, propname] = this._parsePropDescriptor(arguments);
- delete obj[propname];
- },
-
- _typeOf: function _typeOf(thing) {
- return typeof thing;
- },
-
- _callNew: function(constructor) {
- if(typeof constructor === 'string')
- {
- constructor = window[constructor];
- } else if(constructor.length === 1 &&
- typeof constructor[0] !== 'string')
- {
- constructor = constructor[0];
- } else {
- var [obj,propname] = this._parsePropDescriptor(constructor);
- constructor = obj[propname];
- }
-
- /* Hacky, but should be robust */
- var s = 'new constructor(';
- for(var i = 1; i < arguments.length; ++i) {
- if(i != 1) {
- s += ',';
- }
-
- s += 'arguments[' + i + ']';
- }
-
- s += ')';
- return eval(s);
- },
-
- _callEval: function(thisobj, js) {
- return eval.call(thisobj, js);
- },
-
- getPrompt: function getPrompt(repl) {
- return 'EVAL>'
- },
-
- _lookupObject: function _lookupObject(repl, id) {
- if(typeof id === 'string') {
- switch(id) {
- case 'global':
- return window;
- case 'nil':
- return null;
- case 't':
- return true;
- case 'false':
- return false;
- case 'undefined':
- return undefined;
- case 'repl':
- return repl;
- case 'interactor':
- return this;
- case 'NaN':
- return NaN;
- case 'Infinity':
- return Infinity;
- case '-Infinity':
- return -Infinity;
- default:
- throw new Error('No object with special id:' + id);
- }
- }
-
- var ret = repl._jsObjects[id];
- if(ret === undefined) {
- throw new Error('No object with id:' + id + '(' + typeof id + ')');
- }
- return ret;
- },
-
- _findOrAllocateObject: function _findOrAllocateObject(repl, value) {
- if(typeof value !== 'object' && typeof value !== 'function') {
- throw new Error('_findOrAllocateObject called on non-object('
- + typeof(value) + '): '
- + value)
- }
-
- for(var id in repl._jsObjects) {
- id = Number(id);
- var obj = repl._jsObjects[id];
- if(obj === value) {
- return id;
- }
- }
-
- var id = ++repl._jsLastID;
- repl._jsObjects[id] = value;
- return id;
- },
-
- _fixupList: function _fixupList(repl, list) {
- for(var i = 0; i < list.length; ++i) {
- if(list[i] instanceof Array) {
- this._fixupList(repl, list[i]);
- } else if(typeof list[i] === 'object') {
- var obj = list[i];
- if(obj.funcall) {
- var parts = obj.funcall;
- this._fixupList(repl, parts);
- var [thisobj, func] = this._parseFunc(parts[0]);
- list[i] = func.apply(thisobj, parts.slice(1));
- } else if(obj.objid) {
- list[i] = this._lookupObject(repl, obj.objid);
- } else {
- throw new Error('Unknown object type: ' + obj.toSource());
- }
- }
- }
- },
-
- _parseFunc: function(func) {
- var thisobj = null;
-
- if(typeof func === 'string') {
- func = window[func];
- } else if(func instanceof Array) {
- if(func.length === 1 && typeof func[0] !== 'string') {
- func = func[0];
- } else {
- [thisobj, func] = this._parsePropDescriptor(func);
- func = thisobj[func];
- }
- }
-
- return [thisobj,func];
- },
-
- _encodeReturn: function(value, array_as_mv) {
- var ret;
-
- if(value === null) {
- ret = ['special', 'null'];
- } else if(value === true) {
- ret = ['special', 'true'];
- } else if(value === false) {
- ret = ['special', 'false'];
- } else if(value === undefined) {
- ret = ['special', 'undefined'];
- } else if(typeof value === 'number') {
- if(isNaN(value)) {
- ret = ['special', 'NaN'];
- } else if(value === Infinity) {
- ret = ['special', 'Infinity'];
- } else if(value === -Infinity) {
- ret = ['special', '-Infinity'];
- } else {
- ret = ['atom', value];
- }
- } else if(typeof value === 'string') {
- ret = ['atom', value];
- } else if(array_as_mv && value instanceof Array) {
- ret = ['array', value.map(this._encodeReturn, this)];
- } else {
- ret = ['objid', this._findOrAllocateObject(repl, value)];
- }
-
- return ret;
- },
-
- _handleInputLine: function _handleInputLine(repl, line) {
- var ret;
- var array_as_mv = false;
-
- try {
- if(line[0] === '*') {
- array_as_mv = true;
- line = line.substring(1);
- }
- var parts = eval(line);
- this._fixupList(repl, parts);
- var [thisobj, func] = this._parseFunc(parts[0]);
- ret = this._encodeReturn(
- func.apply(thisobj, parts.slice(1)),
- array_as_mv);
- } catch(x) {
- ret = ['error', x.toString() ];
- }
-
- var JSON = Components.classes['@mozilla.org/dom/json;1'].createInstance(Components.interfaces.nsIJSON);
- repl.print(JSON.encode(ret));
- repl._prompt();
- },
-
- handleInput: function handleInput(repl, chunk) {
- this._input += chunk;
- var match, line;
- while(match = this._input.match(/.*\\n/)) {
- line = match[0];
-
- if(line === 'EXIT\\n') {
- repl.popInteractor();
- repl._prompt();
- return;
- }
-
- this._input = this._input.substring(line.length);
- this._handleInputLine(repl, line);
- }
- }
- });
-})
-")
-
- "String to set MozRepl up into a simple-minded evaluation mode.")
-
-(defun js--js-encode-value (x)
- "Marshall the given value for JS.
-Strings and numbers are JSON-encoded. Lists (including nil) are
-made into JavaScript array literals and their contents encoded
-with `js--js-encode-value'."
- (cond ((or (stringp x) (numberp x)) (json-encode x))
- ((symbolp x) (format "{objid:%S}" (symbol-name x)))
- ((js--js-handle-p x)
-
- (when (js--js-handle-expired-p x)
- (error "Stale JS handle"))
-
- (format "{objid:%s}" (js--js-handle-id x)))
-
- ((sequencep x)
- (if (eq (car-safe x) 'js--funcall)
- (format "{funcall:[%s]}"
- (mapconcat #'js--js-encode-value (cdr x) ","))
- (concat
- "[" (mapconcat #'js--js-encode-value x ",") "]")))
- (t
- (error "Unrecognized item: %S" x))))
-
-(defconst js--js-prompt-regexp "\\(repl[0-9]*\\)> $")
-(defconst js--js-repl-prompt-regexp "^EVAL>$")
-(defvar js--js-repl-depth 0)
-
-(defun js--js-wait-for-eval-prompt ()
- (js--wait-for-matching-output
- (inferior-moz-process)
- js--js-repl-prompt-regexp js-js-timeout
-
- ;; start matching against the beginning of the line in
- ;; order to catch a prompt that's only partially arrived
- (save-excursion (forward-line 0) (point))))
-
-;; Presumably "inferior-moz-process" loads comint.
-(declare-function comint-send-string "comint" (process string))
-(declare-function comint-send-input "comint"
- (&optional no-newline artificial))
-
-(defun js--js-enter-repl ()
- (inferior-moz-process) ; called for side-effect
- (with-current-buffer inferior-moz-buffer
- (goto-char (point-max))
-
- ;; Do some initialization the first time we see a process
- (unless (eq (inferior-moz-process) js--js-process)
- (setq js--js-process (inferior-moz-process))
- (setq js--js-references (make-hash-table :test 'eq :weakness t))
- (setq js--js-repl-depth 0)
-
- ;; Send interactor definition
- (comint-send-string js--js-process js--moz-interactor)
- (comint-send-string js--js-process
- (concat "(" moz-repl-name ")\n"))
- (js--wait-for-matching-output
- (inferior-moz-process) js--js-prompt-regexp
- js-js-timeout))
-
- ;; Sanity check
- (when (looking-back js--js-prompt-regexp
- (save-excursion (forward-line 0) (point)))
- (setq js--js-repl-depth 0))
-
- (if (> js--js-repl-depth 0)
- ;; If js--js-repl-depth > 0, we *should* be seeing an
- ;; EVAL> prompt. If we don't, give Mozilla a chance to catch
- ;; up with us.
- (js--js-wait-for-eval-prompt)
-
- ;; Otherwise, tell Mozilla to enter the interactor mode
- (insert (match-string-no-properties 1)
- ".pushInteractor('js')")
- (comint-send-input nil t)
- (js--wait-for-matching-output
- (inferior-moz-process) js--js-repl-prompt-regexp
- js-js-timeout))
-
- (cl-incf js--js-repl-depth)))
-
-(defun js--js-leave-repl ()
- (cl-assert (> js--js-repl-depth 0))
- (when (= 0 (cl-decf js--js-repl-depth))
- (with-current-buffer inferior-moz-buffer
- (goto-char (point-max))
- (js--js-wait-for-eval-prompt)
- (insert "EXIT")
- (comint-send-input nil t)
- (js--wait-for-matching-output
- (inferior-moz-process) js--js-prompt-regexp
- js-js-timeout))))
-
-(defsubst js--js-not (value)
- (memq value '(nil null false undefined)))
-
-(defsubst js--js-true (value)
- (not (js--js-not value)))
-
-(eval-and-compile
- (defun js--optimize-arglist (arglist)
- "Convert immediate js< and js! references to deferred ones."
- (cl-loop for item in arglist
- if (eq (car-safe item) 'js<)
- collect (append (list 'list ''js--funcall
- '(list 'interactor "_getProp"))
- (js--optimize-arglist (cdr item)))
- else if (eq (car-safe item) 'js>)
- collect (append (list 'list ''js--funcall
- '(list 'interactor "_putProp"))
-
- (if (atom (cadr item))
- (list (cadr item))
- (list
- (append
- (list 'list ''js--funcall
- '(list 'interactor "_mkArray"))
- (js--optimize-arglist (cadr item)))))
- (js--optimize-arglist (cddr item)))
- else if (eq (car-safe item) 'js!)
- collect (pcase-let ((`(,_ ,function . ,body) item))
- (append (list 'list ''js--funcall
- (if (consp function)
- (cons 'list
- (js--optimize-arglist function))
- function))
- (js--optimize-arglist body)))
- else
- collect item)))
-
-(defmacro js--js-get-service (class-name interface-name)
- `(js! ("Components" "classes" ,class-name "getService")
- (js< "Components" "interfaces" ,interface-name)))
-
-(defmacro js--js-create-instance (class-name interface-name)
- `(js! ("Components" "classes" ,class-name "createInstance")
- (js< "Components" "interfaces" ,interface-name)))
-
-(defmacro js--js-qi (object interface-name)
- `(js! (,object "QueryInterface")
- (js< "Components" "interfaces" ,interface-name)))
-
-(defmacro with-js (&rest forms)
- "Run FORMS with the Mozilla repl set up for js commands.
-Inside the lexical scope of `with-js', `js?', `js!',
-`js-new', `js-eval', `js-list', `js<', `js>', `js-get-service',
-`js-create-instance', and `js-qi' are defined."
- (declare (indent 0) (debug t))
- `(progn
- (js--js-enter-repl)
- (unwind-protect
- (cl-macrolet ((js? (&rest body) `(js--js-true ,@body))
- (js! (function &rest body)
- `(js--js-funcall
- ,(if (consp function)
- (cons 'list
- (js--optimize-arglist function))
- function)
- ,@(js--optimize-arglist body)))
-
- (js-new (function &rest body)
- `(js--js-new
- ,(if (consp function)
- (cons 'list
- (js--optimize-arglist function))
- function)
- ,@body))
-
- (js-eval (thisobj js)
- `(js--js-eval
- ,@(js--optimize-arglist
- (list thisobj js))))
-
- (js-list (&rest args)
- `(js--js-list
- ,@(js--optimize-arglist args)))
-
- (js-get-service (&rest args)
- `(js--js-get-service
- ,@(js--optimize-arglist args)))
-
- (js-create-instance (&rest args)
- `(js--js-create-instance
- ,@(js--optimize-arglist args)))
-
- (js-qi (&rest args)
- `(js--js-qi
- ,@(js--optimize-arglist args)))
-
- (js< (&rest body) `(js--js-get
- ,@(js--optimize-arglist body)))
- (js> (props value)
- `(js--js-funcall
- '(interactor "_putProp")
- ,(if (consp props)
- (cons 'list
- (js--optimize-arglist props))
- props)
- ,@(js--optimize-arglist (list value))
- ))
- (js-handle? (arg) `(js--js-handle-p ,arg)))
- ,@forms)
- (js--js-leave-repl))))
-
-(defvar js--js-array-as-list nil
- "Whether to listify any Array returned by a Mozilla function.
-If nil, the whole Array is treated as a JS symbol.")
-
-(defun js--js-decode-retval (result)
- (pcase (intern (cl-first result))
- ('atom (cl-second result))
- ('special (intern (cl-second result)))
- ('array
- (mapcar #'js--js-decode-retval (cl-second result)))
- ('objid
- (or (gethash (cl-second result)
- js--js-references)
- (puthash (cl-second result)
- (make-js--js-handle
- :id (cl-second result)
- :process (inferior-moz-process))
- js--js-references)))
-
- ('error (signal 'js-js-error (list (cl-second result))))
- (x (error "Unmatched case in js--js-decode-retval: %S" x))))
-
-(defvar comint-last-input-end)
-
-(defun js--js-funcall (function &rest arguments)
- "Call the Mozilla function FUNCTION with arguments ARGUMENTS.
-If function is a string, look it up as a property on the global
-object and use the global object for `this'.
-If FUNCTION is a list with one element, use that element as the
-function with the global object for `this', except that if that
-single element is a string, look it up on the global object.
-If FUNCTION is a list with more than one argument, use the list
-up to the last value as a property descriptor and the last
-argument as a function."
-
- (with-js
- (let ((argstr (js--js-encode-value
- (cons function arguments))))
-
- (with-current-buffer inferior-moz-buffer
- ;; Actual funcall
- (when js--js-array-as-list
- (insert "*"))
- (insert argstr)
- (comint-send-input nil t)
- (js--wait-for-matching-output
- (inferior-moz-process) "EVAL>"
- js-js-timeout)
- (goto-char comint-last-input-end)
-
- ;; Read the result
- (let* ((json-array-type 'list)
- (result (prog1 (json-read)
- (goto-char (point-max)))))
- (js--js-decode-retval result))))))
-
-(defun js--js-new (constructor &rest arguments)
- "Call CONSTRUCTOR as a constructor, with arguments ARGUMENTS.
-CONSTRUCTOR is a JS handle, a string, or a list of these things."
- (apply #'js--js-funcall
- '(interactor "_callNew")
- constructor arguments))
-
-(defun js--js-eval (thisobj js)
- (js--js-funcall '(interactor "_callEval") thisobj js))
-
-(defun js--js-list (&rest arguments)
- "Return a Lisp array resulting from evaluating each of ARGUMENTS."
- (let ((js--js-array-as-list t))
- (apply #'js--js-funcall '(interactor "_mkArray")
- arguments)))
-
-(defun js--js-get (&rest props)
- (apply #'js--js-funcall '(interactor "_getProp") props))
-
-(defun js--js-put (props value)
- (js--js-funcall '(interactor "_putProp") props value))
-
-(defun js-gc (&optional force)
- "Tell the repl about any objects we don't reference anymore.
-With argument, run even if no intervening GC has happened."
- (interactive)
-
- (when force
- (setq js--js-last-gcs-done nil))
-
- (let ((this-gcs-done gcs-done) keys num)
- (when (and js--js-references
- (boundp 'inferior-moz-buffer)
- (buffer-live-p inferior-moz-buffer)
-
- ;; Don't bother running unless we've had an intervening
- ;; garbage collection; without a gc, nothing is deleted
- ;; from the weak hash table, so it's pointless telling
- ;; MozRepl about that references we still hold
- (not (eq js--js-last-gcs-done this-gcs-done))
-
- ;; Are we looking at a normal prompt? Make sure not to
- ;; interrupt the user if he's doing something
- (with-current-buffer inferior-moz-buffer
- (save-excursion
- (goto-char (point-max))
- (looking-back js--js-prompt-regexp
- (save-excursion (forward-line 0) (point))))))
-
- (setq keys (cl-loop for x being the hash-keys
- of js--js-references
- collect x))
- (setq num (js--js-funcall '(repl "_jsGC") (or keys [])))
-
- (setq js--js-last-gcs-done this-gcs-done)
- (when (called-interactively-p 'interactive)
- (message "Cleaned %s entries" num))
-
- num)))
-
-(run-with-idle-timer 30 t #'js-gc)
-
-(defun js-eval (js)
- "Evaluate the JavaScript in JS and return JSON-decoded result."
- (interactive "MJavaScript to evaluate: ")
- (with-js
- (let* ((content-window (js--js-content-window
- (js--get-js-context)))
- (result (js-eval content-window js)))
- (when (called-interactively-p 'interactive)
- (message "%s" (js! "String" result)))
- result)))
-
-(defun js--get-tabs ()
- "Enumerate all JavaScript contexts available.
-Each context is a list:
- (TITLE URL BROWSER TAB TABBROWSER) for content documents
- (TITLE URL WINDOW) for windows
-
-All tabs of a given window are grouped together. The most recent
-window is first. Within each window, the tabs are returned
-left-to-right."
- (with-js
- (let (windows)
-
- (cl-loop with window-mediator = (js! ("Components" "classes"
- "@mozilla.org/appshell/window-mediator;1"
- "getService")
- (js< "Components" "interfaces"
- "nsIWindowMediator"))
- with enumerator = (js! (window-mediator "getEnumerator") nil)
-
- while (js? (js! (enumerator "hasMoreElements")))
- for window = (js! (enumerator "getNext"))
- for window-info = (js-list window
- (js< window "document" "title")
- (js! (window "location" "toString"))
- (js< window "closed")
- (js< window "windowState"))
-
- unless (or (js? (cl-fourth window-info))
- (eq (cl-fifth window-info) 2))
- do (push window-info windows))
-
- (cl-loop for (window title location) in windows
- collect (list title location window)
-
- for gbrowser = (js< window "gBrowser")
- if (js-handle? gbrowser)
- nconc (cl-loop
- for x below (js< gbrowser "browsers" "length")
- collect (js-list (js< gbrowser
- "browsers"
- x
- "contentDocument"
- "title")
-
- (js! (gbrowser
- "browsers"
- x
- "contentWindow"
- "location"
- "toString"))
- (js< gbrowser
- "browsers"
- x)
-
- (js! (gbrowser
- "tabContainer"
- "childNodes"
- "item")
- x)
-
- gbrowser))))))
-
-(defvar js-read-tab-history nil)
-
-(declare-function ido-chop "ido" (items elem))
-
-(defun js--read-tab (prompt)
- "Read a Mozilla tab with prompt PROMPT.
-Return a cons of (TYPE . OBJECT). TYPE is either `window' or
-`tab', and OBJECT is a JavaScript handle to a ChromeWindow or a
-browser, respectively."
-
- ;; Prime IDO
- (unless ido-mode
- (ido-mode 1)
- (ido-mode -1))
-
- (with-js
- (let ((tabs (js--get-tabs)) selected-tab-cname
- selected-tab prev-hitab)
-
- ;; Disambiguate names
- (setq tabs
- (cl-loop with tab-names = (make-hash-table :test 'equal)
- for tab in tabs
- for cname = (format "%s (%s)"
- (cl-second tab) (cl-first tab))
- for num = (cl-incf (gethash cname tab-names -1))
- if (> num 0)
- do (setq cname (format "%s <%d>" cname num))
- collect (cons cname tab)))
-
- (cl-labels
- ((find-tab-by-cname
- (cname)
- (cl-loop for tab in tabs
- if (equal (car tab) cname)
- return (cdr tab)))
-
- (mogrify-highlighting
- (hitab unhitab)
-
- ;; Hack to reduce the number of
- ;; round-trips to mozilla
- (let (cmds)
- (cond
- ;; Highlighting tab
- ((cl-fourth hitab)
- (push '(js! ((cl-fourth hitab) "setAttribute")
- "style"
- "color: red; font-weight: bold")
- cmds)
-
- ;; Highlight window proper
- (push '(js! ((cl-third hitab)
- "setAttribute")
- "style"
- "border: 8px solid red")
- cmds)
-
- ;; Select tab, when appropriate
- (when js-js-switch-tabs
- (push
- '(js> ((cl-fifth hitab) "selectedTab") (cl-fourth hitab))
- cmds)))
-
- ;; Highlighting whole window
- ((cl-third hitab)
- (push '(js! ((cl-third hitab) "document"
- "documentElement" "setAttribute")
- "style"
- (concat "-moz-appearance: none;"
- "border: 8px solid red;"))
- cmds)))
-
- (cond
- ;; Unhighlighting tab
- ((cl-fourth unhitab)
- (push '(js! ((cl-fourth unhitab) "setAttribute") "style" "")
- cmds)
- (push '(js! ((cl-third unhitab) "setAttribute") "style" "")
- cmds))
-
- ;; Unhighlighting window
- ((cl-third unhitab)
- (push '(js! ((cl-third unhitab) "document"
- "documentElement" "setAttribute")
- "style" "")
- cmds)))
-
- (eval `(with-js
- (js-list ,@(nreverse cmds)))
- t)))
-
- (command-hook
- ()
- (let* ((tab (find-tab-by-cname (car ido-matches))))
- (mogrify-highlighting tab prev-hitab)
- (setq prev-hitab tab)))
-
- (setup-hook
- ()
- ;; Fiddle with the match list a bit: if our first match
- ;; is a tabbrowser window, rotate the match list until
- ;; the active tab comes up
- (let ((matched-tab (find-tab-by-cname (car ido-matches))))
- (when (and matched-tab
- (null (cl-fourth matched-tab))
- (equal "navigator:browser"
- (js! ((cl-third matched-tab)
- "document"
- "documentElement"
- "getAttribute")
- "windowtype")))
-
- (cl-loop with tab-to-match = (js< (cl-third matched-tab)
- "gBrowser"
- "selectedTab")
-
- for match in ido-matches
- for candidate-tab = (find-tab-by-cname match)
- if (eq (cl-fourth candidate-tab) tab-to-match)
- do (setq ido-cur-list
- (ido-chop ido-cur-list match))
- and return t)))
-
- (add-hook 'post-command-hook #'command-hook t t)))
-
-
- (unwind-protect
- ;; FIXME: Don't impose IDO on the user.
- (setq selected-tab-cname
- (let ((ido-minibuffer-setup-hook
- (cons #'setup-hook ido-minibuffer-setup-hook)))
- (ido-completing-read
- prompt
- (mapcar #'car tabs)
- nil t nil
- 'js-read-tab-history)))
-
- (when prev-hitab
- (mogrify-highlighting nil prev-hitab)
- (setq prev-hitab nil)))
-
- (add-to-history 'js-read-tab-history selected-tab-cname)
-
- (setq selected-tab (cl-loop for tab in tabs
- if (equal (car tab) selected-tab-cname)
- return (cdr tab)))
-
- (cons (if (cl-fourth selected-tab) 'browser 'window)
- (cl-third selected-tab))))))
-
-(defun js--guess-eval-defun-info (pstate)
- "Helper function for `js-eval-defun'.
-Return a list (NAME . CLASSPARTS), where CLASSPARTS is a list of
-strings making up the class name and NAME is the name of the
-function part."
- (cond ((and (= (length pstate) 3)
- (eq (js--pitem-type (cl-first pstate)) 'function)
- (= (length (js--pitem-name (cl-first pstate))) 1)
- (consp (js--pitem-type (cl-second pstate))))
-
- (append (js--pitem-name (cl-second pstate))
- (list (cl-first (js--pitem-name (cl-first pstate))))))
-
- ((and (= (length pstate) 2)
- (eq (js--pitem-type (cl-first pstate)) 'function))
-
- (append
- (butlast (js--pitem-name (cl-first pstate)))
- (list (car (last (js--pitem-name (cl-first pstate)))))))
-
- (t (error "Function not a toplevel defun or class member"))))
-
-(defvar js--js-context nil
- "The current JavaScript context.
-This is a cons like the one returned from `js--read-tab'.
-Change with `js-set-js-context'.")
-
-(defconst js--js-inserter
- "(function(func_info,func) {
- func_info.unshift('window');
- var obj = window;
- for(var i = 1; i < func_info.length - 1; ++i) {
- var next = obj[func_info[i]];
- if(typeof next !== 'object' && typeof next !== 'function') {
- next = obj.prototype && obj.prototype[func_info[i]];
- if(typeof next !== 'object' && typeof next !== 'function') {
- alert('Could not find ' + func_info.slice(0, i+1).join('.') +
- ' or ' + func_info.slice(0, i+1).join('.') + '.prototype');
- return;
- }
-
- func_info.splice(i+1, 0, 'prototype');
- ++i;
- }
- }
-
- obj[func_info[i]] = func;
- alert('Successfully updated '+func_info.join('.'));
- })")
-
-(defun js-set-js-context (context)
- "Set the JavaScript context to CONTEXT.
-When called interactively, prompt for CONTEXT."
- (interactive (list (js--read-tab "JavaScript Context: ")))
- (setq js--js-context context))
-
-(defun js--get-js-context ()
- "Return a valid JavaScript context.
-If one hasn't been set, or if it's stale, prompt for a new one."
- (with-js
- (when (or (null js--js-context)
- (js--js-handle-expired-p (cdr js--js-context))
- (pcase (car js--js-context)
- ('window (js? (js< (cdr js--js-context) "closed")))
- ('browser (not (js? (js< (cdr js--js-context)
- "contentDocument"))))
- (x (error "Unmatched case in js--get-js-context: %S" x))))
- (setq js--js-context (js--read-tab "JavaScript Context: ")))
- js--js-context))
-
-(defun js--js-content-window (context)
- (with-js
- (pcase (car context)
- ('window (cdr context))
- ('browser (js< (cdr context)
- "contentWindow" "wrappedJSObject"))
- (x (error "Unmatched case in js--js-content-window: %S" x)))))
-
-(defun js--make-nsilocalfile (path)
- (with-js
- (let ((file (js-create-instance "@mozilla.org/file/local;1"
- "nsILocalFile")))
- (js! (file "initWithPath") path)
- file)))
-
-(defun js--js-add-resource-alias (alias path)
- (with-js
- (let* ((io-service (js-get-service "@mozilla.org/network/io-service;1"
- "nsIIOService"))
- (res-prot (js! (io-service "getProtocolHandler") "resource"))
- (res-prot (js-qi res-prot "nsIResProtocolHandler"))
- (path-file (js--make-nsilocalfile path))
- (path-uri (js! (io-service "newFileURI") path-file)))
- (js! (res-prot "setSubstitution") alias path-uri))))
-
-(cl-defun js-eval-defun ()
- "Update a Mozilla tab using the JavaScript defun at point."
- (interactive)
-
- ;; This function works by generating a temporary file that contains
- ;; the function we'd like to insert. We then use the elisp-js bridge
- ;; to command mozilla to load this file by inserting a script tag
- ;; into the document we set. This way, debuggers and such will have
- ;; a way to find the source of the just-inserted function.
- ;;
- ;; We delete the temporary file if there's an error, but otherwise
- ;; we add an unload event listener on the Mozilla side to delete the
- ;; file.
-
- (save-excursion
- (let (begin end pstate defun-info temp-name defun-body)
- (js-end-of-defun)
- (setq end (point))
- (js--ensure-cache)
- (js-beginning-of-defun)
- (re-search-forward "\\_<function\\_>")
- (setq begin (match-beginning 0))
- (setq pstate (js--forward-pstate))
-
- (when (or (null pstate)
- (> (point) end))
- (error "Could not locate function definition"))
-
- (setq defun-info (js--guess-eval-defun-info pstate))
-
- (let ((overlay (make-overlay begin end)))
- (overlay-put overlay 'face 'highlight)
- (unwind-protect
- (unless (y-or-n-p (format "Send %s to Mozilla? "
- (mapconcat #'identity defun-info ".")))
- (message "") ; question message lingers until next command
- (cl-return-from js-eval-defun))
- (delete-overlay overlay)))
-
- (setq defun-body (buffer-substring-no-properties begin end))
-
- (make-directory js-js-tmpdir t)
-
- ;; (Re)register a Mozilla resource URL to point to the
- ;; temporary directory
- (js--js-add-resource-alias "js" js-js-tmpdir)
-
- (setq temp-name (make-temp-file (concat js-js-tmpdir
- "/js-")
- nil ".js"))
- (unwind-protect
- (with-js
- (with-temp-buffer
- (insert js--js-inserter)
- (insert "(")
- (let ((standard-output (current-buffer)))
- (json--print-list defun-info))
- (insert ",\n")
- (insert defun-body)
- (insert "\n)")
- (write-region (point-min) (point-max) temp-name
- nil 1))
-
- ;; Give Mozilla responsibility for deleting this file
- (let* ((content-window (js--js-content-window
- (js--get-js-context)))
- (content-document (js< content-window "document"))
- (head (if (js? (js< content-document "body"))
- ;; Regular content
- (js< (js! (content-document "getElementsByTagName")
- "head")
- 0)
- ;; Chrome
- (js< content-document "documentElement")))
- (elem (js! (content-document "createElementNS")
- "http://www.w3.org/1999/xhtml" "script")))
-
- (js! (elem "setAttribute") "type" "text/javascript")
- (js! (elem "setAttribute") "src"
- (format "resource://js/%s"
- (file-name-nondirectory temp-name)))
-
- (js! (head "appendChild") elem)
-
- (js! (content-window "addEventListener") "unload"
- (js! ((js-new
- "Function" "file"
- "return function() { file.remove(false) }"))
- (js--make-nsilocalfile temp-name))
- 'false)
- (setq temp-name nil)
-
-
-
- ))
-
- ;; temp-name is set to nil on success
- (when temp-name
- (delete-file temp-name))))))
-
;;; Syntax extensions
(defvar js-syntactic-mode-name t
diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el
index 6bf070cf9e5..79530f81673 100644
--- a/lisp/progmodes/octave.el
+++ b/lisp/progmodes/octave.el
@@ -1814,18 +1814,18 @@ If the environment variable OCTAVE_SRCDIR is set, it is searched first."
(user-error "Aborted")))
(_ name)))
-(defvar find-tag-marker-ring)
+(declare-function xref-push-marker-stack "xref" (&optional m))
(defun octave-find-definition (fn)
"Find the definition of FN.
Functions implemented in C++ can be found if
variable `octave-source-directories' is set correctly."
(interactive (list (octave-completing-read)))
- (require 'etags)
+ (require 'xref)
(let ((orig (point)))
(if (and (derived-mode-p 'octave-mode)
(octave-goto-function-definition fn))
- (ring-insert find-tag-marker-ring (copy-marker orig))
+ (xref-push-marker-stack (copy-marker orig))
(inferior-octave-send-list-and-digest
;; help NAME is more verbose
(list (format "\
@@ -1840,7 +1840,7 @@ if iskeyword('%s') disp('`%s'' is a keyword') else which('%s') endif\n"
(setq file (match-string 1 line))))
(if (not file)
(user-error "%s" (or line (format-message "`%s' not found" fn)))
- (ring-insert find-tag-marker-ring (point-marker))
+ (xref-push-marker-stack)
(setq file (funcall octave-find-definition-filename-function file))
(when file
(find-file file)
diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el
index e6e6e40aa19..5938da542ac 100644
--- a/lisp/progmodes/pascal.el
+++ b/lisp/progmodes/pascal.el
@@ -1357,9 +1357,7 @@ The default is a name found in the buffer around point."
default ""))
(label
;; Do completion with default.
- (completing-read (if (not (string= default ""))
- (concat "Label (default " default "): ")
- "Label: ")
+ (completing-read (format-prompt "Label" default)
;; Complete with the defuns found in the
;; current-buffer.
(let ((buf (current-buffer)))
diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el
index e43f2ff90b5..496b0810183 100644
--- a/lisp/progmodes/prog-mode.el
+++ b/lisp/progmodes/prog-mode.el
@@ -49,9 +49,15 @@
(define-key-after menu [prog-separator] menu-bar-separator
'middle-separator)
+ (unless (xref-forward-history-empty-p)
+ (define-key-after menu [xref-forward]
+ '(menu-item "Go Forward" xref-go-forward
+ :help "Forward to the position gone Back from")
+ 'prog-separator))
+
(unless (xref-marker-stack-empty-p)
(define-key-after menu [xref-pop]
- '(menu-item "Go Back" xref-pop-marker-stack
+ '(menu-item "Go Back" xref-go-back
:help "Back to the position of the last search")
'prog-separator))
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index da7435cddf3..3b634471ace 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -322,7 +322,15 @@ to find the list of ignores for each directory."
(process-file-shell-command command nil t))
(pt (point-min)))
(unless (zerop status)
- (error "File listing failed: %s" (buffer-string)))
+ (goto-char (point-min))
+ (if (and
+ (not (eql status 127))
+ (search-forward "Permission denied\n" nil t))
+ (let ((end (1- (point))))
+ (re-search-backward "\\`\\|\0")
+ (error "File listing failed: %s"
+ (buffer-substring (1+ (point)) end)))
+ (error "File listing failed: %s" (buffer-string))))
(goto-char pt)
(while (search-forward "\0" nil t)
(push (buffer-substring-no-properties (1+ pt) (1- (point)))
@@ -840,28 +848,36 @@ pattern to search for."
project-regexp-history-variable)))
;;;###autoload
-(defun project-find-file ()
+(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\"."
- (interactive)
+is available as part of \"future history\".
+
+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")
(let* ((pr (project-current t))
(dirs (list (project-root pr))))
- (project-find-file-in (thing-at-point 'filename) dirs pr)))
+ (project-find-file-in (thing-at-point 'filename) dirs pr include-all)))
;;;###autoload
-(defun project-or-external-find-file ()
+(defun project-or-external-find-file (&optional include-all)
"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\"."
- (interactive)
+is available as part of \"future history\".
+
+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")
(let* ((pr (project-current t))
(dirs (cons
(project-root pr)
(project-external-roots pr))))
- (project-find-file-in (thing-at-point 'filename) dirs pr)))
+ (project-find-file-in (thing-at-point 'filename) 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.
@@ -914,12 +930,25 @@ by the user at will."
predicate
hist mb-default))
-(defun project-find-file-in (suggested-filename dirs project)
+(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
-is used as part of \"future history\"."
- (let* ((all-files (project-files project dirs))
+is used as part of \"future history\".
+
+If INCLUDE-ALL is non-nil, or with prefix argument when called
+interactively, include all files from DIRS, except for VCS
+directories listed in `vc-directory-exclusion-list'."
+ (let* ((vc-dirs-ignores (mapcar
+ (lambda (dir)
+ (concat dir "/"))
+ vc-directory-exclusion-list))
+ (all-files
+ (if include-all
+ (mapcan
+ (lambda (dir) (project--files-in-directory dir vc-dirs-ignores))
+ 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 nil
@@ -1144,7 +1173,10 @@ displayed."
(not (major-mode . help-mode)))
(derived-mode . compilation-mode)
(derived-mode . dired-mode)
- (derived-mode . diff-mode))
+ (derived-mode . diff-mode)
+ (derived-mode . comint-mode)
+ (derived-mode . eshell-mode)
+ (derived-mode . change-log-mode))
"List of conditions to kill buffers related to a project.
This list is used by `project-kill-buffers'.
Each condition is either:
@@ -1177,9 +1209,18 @@ current project, it will be killed."
(const and) sexp)
(cons :tag "Disjunction"
(const or) sexp)))
- :version "28.1"
+ :version "29.1"
:group 'project
- :package-version '(project . "0.6.0"))
+ :package-version '(project . "0.8.2"))
+
+(defcustom project-kill-buffers-display-buffer-list nil
+ "Non-nil to display list of buffers to kill before killing project buffers.
+Used by `project-kill-buffers'."
+ :type 'boolean
+ :version "29.1"
+ :group 'project
+ :package-version '(project . "0.8.2")
+ :safe #'booleanp)
(defun project--buffer-list (pr)
"Return the list of all buffers in project PR."
@@ -1247,14 +1288,35 @@ NO-CONFIRM is always nil when the command is invoked
interactively."
(interactive)
(let* ((pr (project-current t))
- (bufs (project--buffers-to-kill pr)))
+ (bufs (project--buffers-to-kill pr))
+ (query-user (lambda ()
+ (yes-or-no-p
+ (format "Kill %d buffers in %s? "
+ (length bufs)
+ (project-root pr))))))
(cond (no-confirm
(mapc #'kill-buffer bufs))
((null bufs)
(message "No buffers to kill"))
- ((yes-or-no-p (format "Kill %d buffers in %s? "
- (length bufs)
- (project-root pr)))
+ (project-kill-buffers-display-buffer-list
+ (when
+ (with-current-buffer-window
+ (get-buffer-create "*Buffer List*")
+ `(display-buffer--maybe-at-bottom
+ (dedicated . t)
+ (window-height . (fit-window-to-buffer))
+ (preserve-size . (nil . t))
+ (body-function
+ . ,#'(lambda (_window)
+ (list-buffers-noselect nil bufs))))
+ #'(lambda (window _value)
+ (with-selected-window window
+ (unwind-protect
+ (funcall query-user)
+ (when (window-live-p window)
+ (quit-restore-window window 'kill))))))
+ (mapc #'kill-buffer bufs)))
+ ((funcall query-user)
(mapc #'kill-buffer bufs)))))
diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el
index 59004e413eb..c36082bb6d0 100644
--- a/lisp/progmodes/prolog.el
+++ b/lisp/progmodes/prolog.el
@@ -2484,11 +2484,8 @@ Interaction supports completion."
(if (eq (try-completion default prolog-info-alist) nil)
(setq default nil))
;; Read the PredSpec from the user
- (completing-read
- (if (zerop (length default))
- "Help on predicate: "
- (concat "Help on predicate (default " default "): "))
- prolog-info-alist nil t nil nil default)))
+ (completing-read (format-prompt "Help on predicate" default)
+ prolog-info-alist nil t nil nil default)))
(defun prolog-build-info-alist (&optional verbose)
"Build an alist of all builtins and library predicates.
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index 6357c4f2d3e..b403de8b7a6 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -5,7 +5,7 @@
;; Author: Fabián E. Gallina <fgallina@gnu.org>
;; URL: https://github.com/fgallina/python.el
;; Version: 0.28
-;; Package-Requires: ((emacs "24.2") (cl-lib "1.0"))
+;; Package-Requires: ((emacs "24.4") (cl-lib "1.0"))
;; Maintainer: emacs-devel@gnu.org
;; Created: Jul 2010
;; Keywords: languages
@@ -1427,6 +1427,13 @@ marks the next defun after the ones already marked."
;;; Navigation
+(defcustom python-forward-sexp-function #'python-nav-forward-sexp
+ "Function to use when navigating between expressions."
+ :version "28.1"
+ :type '(choice (const :tag "Python blocks" python-nav-forward-sexp)
+ (const :tag "CC-mode like" nil)
+ function))
+
(defvar python-nav-beginning-of-defun-regexp
(python-rx line-start (* space) defun (+ space) (group symbol-name))
"Regexp matching class or function definition.
@@ -1518,7 +1525,10 @@ Returns nil if point is not in a def or class."
(python-util-forward-comment -1)
(forward-line 1)
;; Ensure point moves forward.
- (and (> beg-pos (point)) (goto-char beg-pos)))))
+ (and (> beg-pos (point)) (goto-char beg-pos))
+ ;; Return non-nil if we did something (because then we were in a
+ ;; def/class).
+ (/= beg-pos (point)))))
(defun python-nav--syntactically (fn poscompfn &optional contextfn)
"Move point using FN avoiding places with specific context.
@@ -2724,20 +2734,12 @@ goes wrong and syntax highlighting in the shell gets messed up."
(deactivate-mark nil)
(start-pos prompt-end)
(buffer-undo-list t)
- (font-lock-buffer-pos nil)
(replacement
(python-shell-font-lock-with-font-lock-buffer
- (delete-region (line-beginning-position)
- (point-max))
- (setq font-lock-buffer-pos (point))
+ (delete-region (point-min) (point-max))
(insert input)
- ;; Ensure buffer is fontified, keeping it
- ;; compatible with Emacs < 24.4.
- (if (fboundp 'font-lock-ensure)
- (funcall 'font-lock-ensure)
- (font-lock-default-fontify-buffer))
- (buffer-substring font-lock-buffer-pos
- (point-max))))
+ (font-lock-ensure)
+ (buffer-string)))
(replacement-length (length replacement))
(i 0))
;; Inject text properties to get input fontified.
@@ -3763,7 +3765,8 @@ With argument MSG show activation/deactivation message."
(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. "))
+ "list. Native completions have been disabled locally. "
+ "Consider installing the python package \"readline\". "))
(python-shell-completion-native-turn-off msg))))))
(defun python-shell-completion-native-turn-on-maybe-with-msg ()
@@ -3810,7 +3813,7 @@ With argument MSG show activation/deactivation message."
(comint-redirect-perform-sanity-check nil)
(comint-redirect-insert-matching-regexp t)
(comint-redirect-finished-regexp
- "1__dummy_completion__[[:space:]]*\n")
+ "1__dummy_completion__.*\n")
(comint-redirect-output-buffer redirect-buffer))
;; Compatibility with Emacs 24.x. Comint changed and
;; now `comint-redirect-filter' gets 3 args. This
@@ -4670,7 +4673,10 @@ See `python-check-command' for the default."
target = obj
objtype = 'def'
if target:
- args = inspect.formatargspec(*argspec_function(target))
+ if hasattr(inspect, 'signature'):
+ args = str(inspect.signature(target))
+ else:
+ args = inspect.formatargspec(*argspec_function(target))
name = obj.__name__
doc = '{objtype} {name}{args}'.format(
objtype=objtype, name=name, args=args
@@ -4769,10 +4775,14 @@ Interactively, prompt for symbol."
(interactive
(let ((symbol (python-eldoc--get-symbol-at-point))
(enable-recursive-minibuffers t))
- (list (read-string (if symbol
- (format "Describe symbol (default %s): " symbol)
- "Describe symbol: ")
- nil nil symbol))))
+ (list (read-string
+ ;; `format-prompt' is new in Emacs 28.1.
+ (if (fboundp 'format-prompt)
+ (format-prompt "Describe symbol" symbol)
+ (if symbol
+ (format "Describe symbol (default %s): " symbol)
+ "Describe symbol: "))
+ nil nil symbol))))
(message (python-eldoc--get-doc-at-point symbol)))
(defun python-describe-at-point (symbol process)
@@ -5569,13 +5579,6 @@ By default messages are considered errors."
:type '(alist :key-type (regexp)
:value-type (symbol)))
-(defcustom python-forward-sexp-function #'python-nav-forward-sexp
- "Function to use when navigating between expressions."
- :version "28.1"
- :type '(choice (const :tag "Python blocks" python-nav-forward-sexp)
- (const :tag "CC-mode like" nil)
- function))
-
(defvar-local python--flymake-proc nil)
(defun python--flymake-parse-output (source proc report-fn)
diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el
index 57351a7308d..abcdcb3349e 100644
--- a/lisp/progmodes/scheme.el
+++ b/lisp/progmodes/scheme.el
@@ -143,7 +143,6 @@
(setq-local comment-start-skip ";+[ \t]*")
(setq-local comment-use-syntax t)
(setq-local comment-column 40)
- (setq-local parse-sexp-ignore-comments t)
(setq-local lisp-indent-function 'scheme-indent-function)
(setq mode-line-process '("" scheme-mode-line-process))
(setq-local imenu-case-fold-search t)
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index 0dd9f2b4fa2..92326d0dcfa 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -402,45 +402,42 @@ This is buffer-local in every such buffer.")
(rpm . (,sh-mode-syntax-table ?\' ".")))
"Syntax-table used in Shell-Script mode. See `sh-feature'.")
-(defvar sh-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\C-c(" 'sh-function)
- (define-key map "\C-c\C-w" 'sh-while)
- (define-key map "\C-c\C-u" 'sh-until)
- (define-key map "\C-c\C-t" 'sh-tmp-file)
- (define-key map "\C-c\C-s" 'sh-select)
- (define-key map "\C-c\C-r" 'sh-repeat)
- (define-key map "\C-c\C-o" 'sh-while-getopts)
- (define-key map "\C-c\C-l" 'sh-indexed-loop)
- (define-key map "\C-c\C-i" 'sh-if)
- (define-key map "\C-c\C-f" 'sh-for)
- (define-key map "\C-c\C-c" 'sh-case)
- (define-key map "\C-c?" #'smie-config-show-indent)
- (define-key map "\C-c=" #'smie-config-set-indent)
- (define-key map "\C-c<" #'smie-config-set-indent)
- (define-key map "\C-c>" #'smie-config-guess)
- (define-key map "\C-c\C-\\" 'sh-backslash-region)
-
- (define-key map "\C-c+" 'sh-add)
- (define-key map "\C-\M-x" 'sh-execute-region)
- (define-key map "\C-c\C-x" 'executable-interpret)
- (define-key map "\C-c\C-n" 'sh-send-line-or-region-and-step)
- (define-key map "\C-c\C-d" 'sh-cd-here)
- (define-key map "\C-c\C-z" 'sh-show-shell)
-
- (define-key map [remap delete-backward-char]
- 'backward-delete-char-untabify)
- (define-key map "\C-c:" 'sh-set-shell)
- (define-key map [remap backward-sentence] 'sh-beginning-of-command)
- (define-key map [remap forward-sentence] 'sh-end-of-command)
- map)
- "Keymap used in Shell-Script mode.")
+(defvar-keymap sh-mode-map
+ :doc "Keymap used in Shell-Script mode."
+ "C-c (" #'sh-function
+ "C-c C-w" #'sh-while
+ "C-c C-u" #'sh-until
+ "C-c C-t" #'sh-tmp-file
+ "C-c C-s" #'sh-select
+ "C-c C-r" #'sh-repeat
+ "C-c C-o" #'sh-while-getopts
+ "C-c C-l" #'sh-indexed-loop
+ "C-c C-i" #'sh-if
+ "C-c C-f" #'sh-for
+ "C-c C-c" #'sh-case
+ "C-c ?" #'smie-config-show-indent
+ "C-c =" #'smie-config-set-indent
+ "C-c <" #'smie-config-set-indent
+ "C-c >" #'smie-config-guess
+ "C-c C-\\" #'sh-backslash-region
+
+ "C-c +" #'sh-add
+ "C-M-x" #'sh-execute-region
+ "C-c C-x" #'executable-interpret
+ "C-c C-n" #'sh-send-line-or-region-and-step
+ "C-c C-d" #'sh-cd-here
+ "C-c C-z" #'sh-show-shell
+ "C-c :" #'sh-set-shell
+
+ "<remap> <delete-backward-char>" #'backward-delete-char-untabify
+ "<remap> <backward-sentence>" #'sh-beginning-of-command
+ "<remap> <forward-sentence>" #'sh-end-of-command)
(easy-menu-define sh-mode-menu sh-mode-map
"Menu for Shell-Script mode."
'("Sh-Script"
["Backslash region" sh-backslash-region
- :help "Insert, align, or delete end-of-line backslashes on the lines in the region."]
+ :help "Insert, align, or delete end-of-line backslashes on the lines in the region"]
["Set shell type..." sh-set-shell
:help "Set this buffer's shell to SHELL (a string)"]
["Execute script..." executable-interpret
@@ -458,7 +455,7 @@ This is buffer-local in every such buffer.")
["Select Statement" sh-select
:help "Insert a select statement "]
["Indexed Loop" sh-indexed-loop
- :help "Insert an indexed loop from 1 to n."]
+ :help "Insert an indexed loop from 1 to n"]
["Options Loop" sh-while-getopts
:help "Insert a while getopts loop."]
["While Loop" sh-while
@@ -482,7 +479,7 @@ This is buffer-local in every such buffer.")
["Show indentation" smie-config-show-indent
:help "Show the how the current line would be indented"]
["Learn buffer indentation" smie-config-guess
- :help "Learn how to indent the buffer the way it currently is."]))
+ :help "Learn how to indent the buffer the way it currently is"]))
(defvar sh-skeleton-pair-default-alist '((?\( _ ?\)) (?\))
(?\[ ?\s _ ?\s ?\]) (?\])
@@ -628,7 +625,8 @@ removed when closing the here document."
(wksh sh-append ksh88)
(zsh sh-append ksh88
- "autoload" "bindkey" "builtin" "chdir" "compctl" "declare" "dirs"
+ "autoload" "always"
+ "bindkey" "builtin" "chdir" "compctl" "declare" "dirs"
"disable" "disown" "echotc" "enable" "functions" "getln" "hash"
"history" "integer" "limit" "local" "log" "popd" "pushd" "r"
"readonly" "rehash" "sched" "setopt" "source" "suspend" "true"
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index 5dfbf87e452..9e40fbd6efc 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -481,9 +481,9 @@ file. Since that is a plaintext file, this could be dangerous."
:list-all ("\\d+" . "\\dS+")
:list-table ("\\d+ %s" . "\\dS+ %s")
:completion-object sql-postgres-completion-object
- :prompt-regexp "^[[:alnum:]_]*=[#>] "
+ :prompt-regexp "^[-[:alnum:]_]*[-=][#>] "
:prompt-length 5
- :prompt-cont-regexp "^[[:alnum:]_]*[-(][#>] "
+ :prompt-cont-regexp "^[-[:alnum:]_]*[-'(][#>] "
:statement sql-postgres-statement-starters
:input-filter sql-remove-tabs-filter
:terminator ("\\(^\\s-*\\\\g\\|;\\)" . "\\g"))
@@ -700,8 +700,17 @@ making new SQLi sessions."
(sexp :tag "Value Expression")))))
:version "24.1")
-(defvaralias 'sql-dialect 'sql-product)
+(defun sql-add-connection (connection params)
+ "Add a new connection to `sql-connection-alist'.
+If CONNECTION already exists, it is replaced with PARAMS."
+ (setq sql-connection-alist
+ (assoc-delete-all connection sql-connection-alist))
+ (push
+ (cons connection params)
+ sql-connection-alist))
+
+(defvaralias 'sql-dialect 'sql-product)
(defcustom sql-product 'ansi
"Select the SQL database product used.
This allows highlighting buffers properly when you open them."
@@ -963,12 +972,7 @@ If set to \"\\n\", each line in the history file will be interpreted as
one command. Multi-line commands are split into several commands when
the input ring is initialized from a history file.
-This variable used to initialize `comint-input-ring-separator'.
-`comint-input-ring-separator' is part of Emacs 21; if your Emacs
-does not have it, setting `sql-input-ring-separator' will have no
-effect. In that case multiline commands will be split into several
-commands when the input history is read, as if you had set
-`sql-input-ring-separator' to \"\\n\"."
+This variable used to initialize `comint-input-ring-separator'."
:type 'string)
;; The usual hooks
@@ -1357,8 +1361,6 @@ specified, it's `sql-product' or `sql-connection' must match."
(defvar sql-interactive-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map comint-mode-map)
- (if (fboundp 'set-keymap-name)
- (set-keymap-name map 'sql-interactive-mode-map)); XEmacs
(define-key map (kbd "C-j") 'sql-accumulate-and-indent)
(define-key map (kbd "C-c C-w") 'sql-copy-column)
(define-key map (kbd "O") 'sql-magic-go)
@@ -2832,16 +2834,6 @@ configured."
(font-lock-mode-internal nil)
(font-lock-mode-internal t))
- (add-hook 'font-lock-mode-hook
- (lambda ()
- ;; Provide defaults for new font-lock faces.
- (defvar font-lock-builtin-face
- (if (boundp 'font-lock-preprocessor-face)
- font-lock-preprocessor-face
- font-lock-keyword-face))
- (defvar font-lock-doc-face font-lock-string-face))
- nil t)
-
;; Setup imenu; it needs the same syntax-alist.
(when imenu
(setq imenu-syntax-alist syntax-alist))))
@@ -3219,14 +3211,7 @@ For both `:file' and `:completion', there can also be a
symbol
(let* ((default (plist-get plist :default))
(last-value (sql-default-value symbol))
- (prompt-def
- (if default
- (if (string-match "\\(\\):[ \t]*\\'" prompt)
- (replace-match (format " (default \"%s\")" default) t t prompt 1)
- (replace-regexp-in-string "[ \t]*\\'"
- (format " (default \"%s\") " default)
- prompt t t))
- prompt))
+ (prompt-def (format-prompt prompt default))
(use-dialog-box nil))
(cond
((plist-member plist :file)
@@ -3311,7 +3296,7 @@ function like this: (sql-get-login \\='user \\='password \\='database)."
(let ((plist (cdr-safe w)))
(pcase (or (car-safe w) w)
('user
- (sql-get-login-ext 'sql-user "User: " 'sql-user-history plist))
+ (sql-get-login-ext 'sql-user "User" 'sql-user-history plist))
('password
(setq-default sql-password
@@ -3330,14 +3315,14 @@ function like this: (sql-get-login \\='user \\='password \\='database)."
(read-passwd "Password: " nil (sql-default-value 'sql-password)))))
('server
- (sql-get-login-ext 'sql-server "Server: " 'sql-server-history plist))
+ (sql-get-login-ext 'sql-server "Server" 'sql-server-history plist))
('database
(sql-get-login-ext 'sql-database "Database: "
'sql-database-history plist))
('port
- (sql-get-login-ext 'sql-port "Port: "
+ (sql-get-login-ext 'sql-port "Port"
nil (append '(:number t) plist)))))))
(defun sql-find-sqli-buffer (&optional product connection)
@@ -4182,10 +4167,6 @@ must tell Emacs. Here's how to do that in your init file:
(modify-syntax-entry ?\\\\ \"\\\\\" sql-mode-syntax-table)))"
:abbrev-table sql-mode-abbrev-table
- (when (and (featurep 'xemacs)
- sql-mode-menu)
- (easy-menu-add sql-mode-menu))
-
;; (smie-setup sql-smie-grammar #'sql-smie-rules)
(setq-local comment-start "--")
;; Make each buffer in sql-mode remember the "current" SQLi buffer.
@@ -4308,9 +4289,6 @@ you entered, right above the output it created.
(setq mode-name
(concat "SQLi[" (or (sql-get-product-feature sql-product :name)
(symbol-name sql-product)) "]"))
- (when (and (featurep 'xemacs)
- sql-interactive-mode-menu)
- (easy-menu-add sql-interactive-mode-menu))
;; Note that making KEYWORDS-ONLY nil will cause havoc if you try
;; SELECT 'x' FROM DUAL with SQL*Plus, because the title of the column
@@ -4681,6 +4659,14 @@ the call to \\[sql-product-interactive] with
(get-buffer new-sqli-buffer)))))
(user-error "No default SQL product defined: set `sql-product'")))
+(defun sql-comint-automatic-password (_)
+ "Intercept password prompts when we know the password.
+This must also do the job of detecting password prompts."
+ (when (and
+ sql-password
+ (not (string= "" sql-password)))
+ sql-password))
+
(defun sql-comint (product params &optional buf-name)
"Set up a comint buffer to run the SQL processor.
@@ -4705,6 +4691,13 @@ buffer. If nil, a name is chosen for it."
(setq buf-name (sql-generate-unique-sqli-buffer-name product nil)))
(set-text-properties 0 (length buf-name) nil buf-name)
+ ;; Create the buffer first, because we want to set it up before
+ ;; comint starts to run.
+ (set-buffer (get-buffer-create buf-name))
+ ;; Set up the automatic population of passwords, if supported.
+ (when (sql-get-product-feature product :password-in-comint)
+ (setq comint-password-function #'sql-comint-automatic-password))
+
;; Start the command interpreter in the buffer
;; PROC-NAME is BUF-NAME without enclosing asterisks
(let ((proc-name (replace-regexp-in-string "\\`[*]\\(.*\\)[*]\\'" "\\1" buf-name)))
diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el
index 52c34d9fbc6..14f252b42d4 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.09.23.089128420
+;; Version: 2021.10.14.127365406
;; 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-09-23-54ffde4-vpo-GNU"
+(defconst verilog-mode-version "2021-10-14-797711e-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.")
@@ -1264,7 +1264,9 @@ 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.
+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.
See also `verilog-auto-arg-sort'."
:version "24.1" ; rev688
@@ -5478,8 +5480,11 @@ becomes:
(let* ((pop-up-windows t))
(let ((name (expand-file-name
(read-file-name
- (format "Find this error in: (default %s) "
- file)
+ ;; `format-prompt' is new in Emacs 28.1.
+ (if (fboundp 'format-prompt)
+ (format-prompt "Find this error in" file)
+ (format "Find this error in (default %s): "
+ file))
nil ;; dir
file t))))
(setq buffer
@@ -6598,7 +6603,8 @@ 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-*{" (buffer-substring p (point)))))))))
+ (not (string-match "^{\\s-*[()0-9a-zA-Z_\\]*\\s-*{"
+ (buffer-substring p (point)))))))))
(progn
(let ( (pt (point)) (pass 0))
(verilog-backward-ws&directives)
@@ -7863,14 +7869,14 @@ If search fails, other files are checked based on
(let* ((default (verilog-get-default-symbol))
;; The following variable is used in verilog-comp-function
(verilog-buffer-to-use (current-buffer))
- (label (if (not (string= default ""))
- ;; Do completion with default
- (completing-read (concat "Goto-Label: (default "
- default ") ")
- #'verilog-comp-defun nil nil "")
- ;; There is no default value. Complete without it
- (completing-read "Goto-Label: "
- #'verilog-comp-defun nil nil "")))
+ (label
+ (completing-read (cond ((fboundp 'format-prompt)
+ ;; `format-prompt' is new in Emacs 28.1.
+ (format-prompt "Goto-Label" default))
+ ((not (string= default ""))
+ (concat "Goto-Label (default " default "): "))
+ (t "Goto-Label: "))
+ #'verilog-comp-defun nil nil ""))
pt)
;; Make sure library paths are correct, in case need to resolve module
(verilog-auto-reeval-locals)
diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el
index 3a9185b334f..f3a7d96c63b 100644
--- a/lisp/progmodes/vhdl-mode.el
+++ b/lisp/progmodes/vhdl-mode.el
@@ -10683,8 +10683,9 @@ Include a library specification, if not already there."
(replace-match "" t t)
(vhdl-template-insert-date))
(goto-char beg)
- (while (search-forward "<year>" end t)
- (replace-match (format-time-string "%Y" nil) t t))
+ (let ((year (format-time-string "%Y")))
+ (while (search-forward "<year>" end t)
+ (replace-match year t t)))
(goto-char beg)
(when file-title
(while (search-forward "<title string>" end t)
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 492be9a104d..ca3594d253b 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -1,7 +1,7 @@
;;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*-
;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
-;; Version: 1.3.0
+;; Version: 1.3.2
;; Package-Requires: ((emacs "26.1"))
;; This is a GNU ELPA :core package. Avoid functionality that is not
@@ -75,7 +75,7 @@
(require 'project)
(eval-and-compile
- (when (version< emacs-version "28")
+ (when (version< emacs-version "28.0.60")
;; etags.el in Emacs 26 and 27 uses EIEIO, and its location type
;; inherits from `xref-location'.
(require 'eieio)
@@ -195,16 +195,23 @@ is not known."
;;; Cross-reference
-(cl-defstruct (xref-item
- (:constructor xref-make (summary location))
- (:noinline t))
+(defmacro xref--defstruct (name &rest fields)
+ (declare (indent 1))
+ `(cl-defstruct ,(if (>= emacs-major-version 27)
+ name
+ (remq (assq :noinline name) name))
+ ,@fields))
+
+(xref--defstruct (xref-item
+ (:constructor xref-make (summary location))
+ (:noinline t))
"An xref item describes a reference to a location somewhere."
summary location)
-(cl-defstruct (xref-match-item
- (:include xref-item)
- (:constructor xref-make-match (summary location length))
- (:noinline t))
+(xref--defstruct (xref-match-item
+ (:include xref-item)
+ (:constructor xref-make-match (summary location length))
+ (:noinline t))
"A match xref item describes a search result."
length)
@@ -334,15 +341,9 @@ backward."
(t (goto-char start) nil))))
-;;; Marker stack (M-. pushes, M-, pops)
-
-(defcustom xref-marker-ring-length 16
- "Length of the xref marker ring.
-If this variable is not set through Customize, you must call
-`xref-set-marker-ring-length' for changes to take effect."
- :type 'integer
- :initialize #'custom-initialize-default
- :set #'xref-set-marker-ring-length)
+;; Dummy variable retained for compatibility.
+(defvar xref-marker-ring-length 16)
+(make-obsolete-variable 'xref-marker-ring-length nil "29.1")
(defcustom xref-prompt-for-identifier '(not xref-find-definitions
xref-find-definitions-other-window
@@ -413,29 +414,59 @@ or earlier: it can break `dired-do-find-regexp-and-replace'."
:version "28.1"
:package-version '(xref . "1.2.0"))
-(defvar xref--marker-ring (make-ring xref-marker-ring-length)
- "Ring of markers to implement the marker stack.")
+(make-obsolete-variable 'xref-marker-ring nil "29.1")
+
+(defun xref-set-marker-ring-length (_var _val)
+ (declare (obsolete nil "29.1"))
+ nil)
+
+(defvar xref--history (cons nil nil)
+ "(BACKWARD-STACK . FORWARD-STACK) of markers to visited Xref locations.")
-(defun xref-set-marker-ring-length (var val)
- "Set `xref-marker-ring-length'.
-VAR is the symbol `xref-marker-ring-length' and VAL is the new
-value."
- (set-default var val)
- (if (ring-p xref--marker-ring)
- (ring-resize xref--marker-ring val)))
+(defun xref--push-backward (m)
+ "Push marker M onto the backward history stack."
+ (unless (equal m (caar xref--history))
+ (push m (car xref--history))))
+
+(defun xref--push-forward (m)
+ "Push marker M onto the forward history stack."
+ (unless (equal m (cadr xref--history))
+ (push m (cdr xref--history))))
(defun xref-push-marker-stack (&optional m)
- "Add point M (defaults to `point-marker') to the marker stack."
- (ring-insert xref--marker-ring (or m (point-marker))))
+ "Add point M (defaults to `point-marker') to the marker stack.
+The future stack is erased."
+ (xref--push-backward (or m (point-marker)))
+ (dolist (mk (cdr xref--history))
+ (set-marker mk nil nil))
+ (setcdr xref--history nil))
+
+;;;###autoload
+(define-obsolete-function-alias 'xref-pop-marker-stack #'xref-go-back "29.1")
+
+;;;###autoload
+(defun xref-go-back ()
+ "Go back to the previous position in xref history.
+To undo, use \\[xref-go-forward]."
+ (interactive)
+ (if (null (car xref--history))
+ (user-error "At start of xref history")
+ (let ((marker (pop (car xref--history))))
+ (xref--push-forward (point-marker))
+ (switch-to-buffer (or (marker-buffer marker)
+ (user-error "The marked buffer has been deleted")))
+ (goto-char (marker-position marker))
+ (set-marker marker nil nil)
+ (run-hooks 'xref-after-return-hook))))
;;;###autoload
-(defun xref-pop-marker-stack ()
- "Pop back to where \\[xref-find-definitions] was last invoked."
+(defun xref-go-forward ()
+ "Got to the point where a previous \\[xref-go-back] was invoked."
(interactive)
- (let ((ring xref--marker-ring))
- (when (ring-empty-p ring)
- (user-error "Marker stack is empty"))
- (let ((marker (ring-remove ring 0)))
+ (if (null (cdr xref--history))
+ (user-error "At end of xref history")
+ (let ((marker (pop (cdr xref--history))))
+ (xref--push-backward (point-marker))
(switch-to-buffer (or (marker-buffer marker)
(user-error "The marked buffer has been deleted")))
(goto-char (marker-position marker))
@@ -458,17 +489,23 @@ value."
;; etags.el needs this
(defun xref-clear-marker-stack ()
- "Discard all markers from the marker stack."
- (let ((ring xref--marker-ring))
- (while (not (ring-empty-p ring))
- (let ((marker (ring-remove ring)))
- (set-marker marker nil nil)))))
+ "Discard all markers from the xref history."
+ (dolist (l (list (car xref--history) (cdr xref--history)))
+ (dolist (m l)
+ (set-marker m nil nil)))
+ (setq xref--history (cons nil nil))
+ nil)
;;;###autoload
(defun xref-marker-stack-empty-p ()
- "Return t if the marker stack is empty; nil otherwise."
- (ring-empty-p xref--marker-ring))
+ "Whether the xref back-history is empty."
+ (null (car xref--history)))
+;; FIXME: rename this to `xref-back-history-empty-p'.
+;;;###autoload
+(defun xref-forward-history-empty-p ()
+ "Whether the xref forward-history is empty."
+ (null (cdr xref--history)))
(defun xref--goto-char (pos)
@@ -683,7 +720,7 @@ quit the *xref* buffer."
"Quit *xref* buffer, then pop the xref marker stack."
(interactive)
(quit-window)
- (xref-pop-marker-stack))
+ (xref-go-back))
(defun xref-query-replace-in-results (from to)
"Perform interactive replacement of FROM with TO in all displayed xrefs.
@@ -1322,12 +1359,17 @@ definitions."
(xref--prompt-p this-command))
(let ((id
(completing-read
- (if def
- (format "%s (default %s): "
- (substring prompt 0 (string-match
- "[ :]+\\'" prompt))
- def)
- prompt)
+ ;; `format-prompt' is new in Emacs 28.1
+ (if (fboundp 'format-prompt)
+ (format-prompt (substring prompt 0 (string-match
+ "[ :]+\\'" prompt))
+ def)
+ (if def
+ (format "%s (default %s): "
+ (substring prompt 0 (string-match
+ "[ :]+\\'" prompt))
+ def)
+ prompt))
(xref-backend-identifier-completion-table backend)
nil nil nil
'xref--read-identifier-history def)))
@@ -1388,7 +1430,7 @@ definition for IDENTIFIER, display it in the selected window.
Otherwise, display the list of the possible definitions in a
buffer where the user can select from the list.
-Use \\[xref-pop-marker-stack] to return back to where you invoked this command."
+Use \\[xref-go-back] to return back to where you invoked this command."
(interactive (list (xref--read-identifier "Find definitions of: ")))
(xref--find-definitions identifier nil))
@@ -1479,7 +1521,8 @@ output of this command when the backend is etags."
;;; Key bindings
;;;###autoload (define-key esc-map "." #'xref-find-definitions)
-;;;###autoload (define-key esc-map "," #'xref-pop-marker-stack)
+;;;###autoload (define-key esc-map "," #'xref-go-back)
+;;;###autoload (define-key esc-map [?\C-,] #'xref-go-forward)
;;;###autoload (define-key esc-map "?" #'xref-find-references)
;;;###autoload (define-key esc-map [?\C-.] #'xref-find-apropos)
;;;###autoload (define-key ctl-x-4-map "." #'xref-find-definitions-other-window)
diff --git a/lisp/progmodes/xscheme.el b/lisp/progmodes/xscheme.el
index 26ffe33b83e..e7667ebf51f 100644
--- a/lisp/progmodes/xscheme.el
+++ b/lisp/progmodes/xscheme.el
@@ -574,9 +574,8 @@ See also the commands \\[xscheme-yank-pop] and \\[xscheme-yank-push]."
(if (consp arg)
(exchange-point-and-mark)))
-;; Old name, to avoid errors in users' init files.
-(fset 'xscheme-yank-previous-send
- 'xscheme-yank)
+(define-obsolete-function-alias 'xscheme-yank-previous-send
+ #'xscheme-yank "29.1")
(defun xscheme-yank-pop (arg)
"Insert or replace a just-yanked expression with an older expression.
diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el
index ab8af40628a..2d1dcd2b686 100644
--- a/lisp/ps-mule.el
+++ b/lisp/ps-mule.el
@@ -1209,8 +1209,8 @@ V%s 0 /%s-latin1 /%s Latin1Encoding put\n"
(ps-output-prologue (format "ETOP%d %d %d put\n" i (car font) index))
(setq index (1+ index))))
(ps-output-prologue (format "/VTOP%d [%s] def\n" i
- (mapconcat #'(lambda (x)
- (format "F%02X" (cdr x)))
+ (mapconcat (lambda (x)
+ (format "F%02X" (cdr x)))
font-list " ")))))
;; Redefine fonts f0, f1, f2, f3, h0, h1, H0.
diff --git a/lisp/ps-print.el b/lisp/ps-print.el
index b1d03fda1d4..0fc95546794 100644
--- a/lisp/ps-print.el
+++ b/lisp/ps-print.el
@@ -3855,7 +3855,7 @@ It can be retrieved with `(ps-get ALIST-SYM KEY)'."
(defun ps-color-scale (color)
;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
- (mapcar #'(lambda (value) (/ value ps-print-color-scale))
+ (mapcar (lambda (value) (/ value ps-print-color-scale))
(color-values color)))
@@ -4747,11 +4747,11 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th
(defun ps-background-pages (page-list func)
(if page-list
(mapcar
- #'(lambda (pages)
- (let ((start (if (consp pages) (car pages) pages))
- (end (if (consp pages) (cdr pages) pages)))
- (and (integerp start) (integerp end) (<= start end)
- (add-to-list 'ps-background-pages (vector start end func)))))
+ (lambda (pages)
+ (let ((start (if (consp pages) (car pages) pages))
+ (end (if (consp pages) (cdr pages) pages)))
+ (and (integerp start) (integerp end) (<= start end)
+ (add-to-list 'ps-background-pages (vector start end func)))))
page-list)
(setq ps-background-all-pages (cons func ps-background-all-pages))))
@@ -4789,76 +4789,76 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th
(defun ps-background-text ()
(mapcar
- #'(lambda (text)
- (setq ps-background-text-count (1+ ps-background-text-count))
- (ps-output (format "/ShowBackText-%d{\n" ps-background-text-count))
- (ps-output-string (nth 0 text)) ; text
- (ps-output
- "\n"
- (ps-float-format (nth 4 text) 200.0) ; font size
- (format "/%s " (or (nth 3 text) "Times-Roman")) ; font name
- (ps-float-format (nth 6 text)
- "PrintHeight PrintPageWidth atan") ; rotation
- (ps-float-format (nth 5 text) 0.85) ; gray
- (ps-float-format (nth 1 text) "0") ; x position
- (ps-float-format (nth 2 text) "0") ; y position
- "\nShowBackText}def\n")
- (ps-background-pages (nthcdr 7 text) ; page list
- (format "ShowBackText-%d\n"
- ps-background-text-count)))
+ (lambda (text)
+ (setq ps-background-text-count (1+ ps-background-text-count))
+ (ps-output (format "/ShowBackText-%d{\n" ps-background-text-count))
+ (ps-output-string (nth 0 text)) ; text
+ (ps-output
+ "\n"
+ (ps-float-format (nth 4 text) 200.0) ; font size
+ (format "/%s " (or (nth 3 text) "Times-Roman")) ; font name
+ (ps-float-format (nth 6 text)
+ "PrintHeight PrintPageWidth atan") ; rotation
+ (ps-float-format (nth 5 text) 0.85) ; gray
+ (ps-float-format (nth 1 text) "0") ; x position
+ (ps-float-format (nth 2 text) "0") ; y position
+ "\nShowBackText}def\n")
+ (ps-background-pages (nthcdr 7 text) ; page list
+ (format "ShowBackText-%d\n"
+ ps-background-text-count)))
ps-print-background-text))
(defun ps-background-image ()
(mapcar
- #'(lambda (image)
- (let ((image-file (expand-file-name (nth 0 image))))
- (when (file-readable-p image-file)
- (setq ps-background-image-count (1+ ps-background-image-count))
- (ps-output
- (format "/ShowBackImage-%d{\n--back-- "
- ps-background-image-count)
- (ps-float-format (nth 5 image) 0.0) ; rotation
- (ps-float-format (nth 3 image) 1.0) ; x scale
- (ps-float-format (nth 4 image) 1.0) ; y scale
- (ps-float-format (nth 1 image) ; x position
- "PrintPageWidth 2 div")
- (ps-float-format (nth 2 image) ; y position
- "PrintHeight 2 div BottomMargin add")
- "\nBeginBackImage\n")
- (ps-insert-file image-file)
- ;; coordinate adjustment to center image
- ;; around x and y position
- (let ((box (ps-get-boundingbox)))
- (with-current-buffer ps-spool-buffer
- (save-excursion
- (if (re-search-backward "^--back--" nil t)
- (replace-match
- (format "%s %s"
- (ps-float-format
- (- (+ (/ (- (aref box 2) (aref box 0)) 2.0)
- (aref box 0))))
- (ps-float-format
- (- (+ (/ (- (aref box 3) (aref box 1)) 2.0)
- (aref box 1)))))
- t)))))
- (ps-output "\nEndBackImage}def\n")
- (ps-background-pages (nthcdr 6 image) ; page list
- (format "ShowBackImage-%d\n"
- ps-background-image-count)))))
+ (lambda (image)
+ (let ((image-file (expand-file-name (nth 0 image))))
+ (when (file-readable-p image-file)
+ (setq ps-background-image-count (1+ ps-background-image-count))
+ (ps-output
+ (format "/ShowBackImage-%d{\n--back-- "
+ ps-background-image-count)
+ (ps-float-format (nth 5 image) 0.0) ; rotation
+ (ps-float-format (nth 3 image) 1.0) ; x scale
+ (ps-float-format (nth 4 image) 1.0) ; y scale
+ (ps-float-format (nth 1 image) ; x position
+ "PrintPageWidth 2 div")
+ (ps-float-format (nth 2 image) ; y position
+ "PrintHeight 2 div BottomMargin add")
+ "\nBeginBackImage\n")
+ (ps-insert-file image-file)
+ ;; coordinate adjustment to center image
+ ;; around x and y position
+ (let ((box (ps-get-boundingbox)))
+ (with-current-buffer ps-spool-buffer
+ (save-excursion
+ (if (re-search-backward "^--back--" nil t)
+ (replace-match
+ (format "%s %s"
+ (ps-float-format
+ (- (+ (/ (- (aref box 2) (aref box 0)) 2.0)
+ (aref box 0))))
+ (ps-float-format
+ (- (+ (/ (- (aref box 3) (aref box 1)) 2.0)
+ (aref box 1)))))
+ t)))))
+ (ps-output "\nEndBackImage}def\n")
+ (ps-background-pages (nthcdr 6 image) ; page list
+ (format "ShowBackImage-%d\n"
+ ps-background-image-count)))))
ps-print-background-image))
(defun ps-background (page-number)
(let (has-local-background)
- (mapc #'(lambda (range)
- (and (<= (aref range 0) page-number)
- (<= page-number (aref range 1))
- (if has-local-background
- (ps-output (aref range 2))
- (setq has-local-background t)
- (ps-output "/printLocalBackground{\n"
- (aref range 2)))))
+ (mapc (lambda (range)
+ (and (<= (aref range 0) page-number)
+ (<= page-number (aref range 1))
+ (if has-local-background
+ (ps-output (aref range 2))
+ (setq has-local-background t)
+ (ps-output "/printLocalBackground{\n"
+ (aref range 2)))))
ps-background-pages)
(and has-local-background (ps-output "}def\n"))))
@@ -5697,8 +5697,8 @@ XSTART YSTART are the relative position for the first page in a sheet.")
(> (car page) 0)
(<= (car page) (cdr page))
(setq new (cons page new))))))
- (setq ps-selected-pages (sort new #'(lambda (one other)
- (< (car one) (car other))))
+ (setq ps-selected-pages (sort new (lambda (one other)
+ (< (car one) (car other))))
ps-last-selected-pages ps-selected-pages
ps-first-page nil
ps-last-page nil))
@@ -5782,8 +5782,8 @@ XSTART YSTART are the relative position for the first page in a sheet.")
"unspecified-fg"
0.0)
ps-foreground-list (mapcar
- #'(lambda (arg)
- (ps-rgb-color arg "unspecified-fg" 0.0))
+ (lambda (arg)
+ (ps-rgb-color arg "unspecified-fg" 0.0))
(append (and (not (member ps-print-color-p
'(nil black-white)))
ps-fg-list)
@@ -6012,9 +6012,9 @@ XSTART YSTART are the relative position for the first page in a sheet.")
(if (and (boundp 'ucs-mule-8859-to-mule-unicode)
(char-table-p ucs-mule-8859-to-mule-unicode))
(map-char-table
- #'(lambda (k v)
- (if (and v (eq (char-charset v) 'latin-iso8859-1) (/= k v))
- (aset tbl k v)))
+ (lambda (k v)
+ (if (and v (eq (char-charset v) 'latin-iso8859-1) (/= k v))
+ (aset tbl k v)))
ucs-mule-8859-to-mule-unicode))
tbl)
"Translation table for PostScript printing.
diff --git a/lisp/recentf.el b/lisp/recentf.el
index 57cbaf0debb..6b5a47c66fd 100644
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -674,55 +674,55 @@ Return nil if file NAME is not one of the ten more recent."
"Sort the list of menu elements L in ascending order.
The MENU-ITEM part of each menu element is compared."
(sort (copy-sequence l)
- #'(lambda (e1 e2)
- (recentf-string-lessp
- (recentf-menu-element-item e1)
- (recentf-menu-element-item e2)))))
+ (lambda (e1 e2)
+ (recentf-string-lessp
+ (recentf-menu-element-item e1)
+ (recentf-menu-element-item e2)))))
(defsubst recentf-sort-descending (l)
"Sort the list of menu elements L in descending order.
The MENU-ITEM part of each menu element is compared."
(sort (copy-sequence l)
- #'(lambda (e1 e2)
- (recentf-string-lessp
- (recentf-menu-element-item e2)
- (recentf-menu-element-item e1)))))
+ (lambda (e1 e2)
+ (recentf-string-lessp
+ (recentf-menu-element-item e2)
+ (recentf-menu-element-item e1)))))
(defsubst recentf-sort-basenames-ascending (l)
"Sort the list of menu elements L in ascending order.
Only filenames sans directory are compared."
(sort (copy-sequence l)
- #'(lambda (e1 e2)
- (recentf-string-lessp
- (file-name-nondirectory (recentf-menu-element-value e1))
- (file-name-nondirectory (recentf-menu-element-value e2))))))
+ (lambda (e1 e2)
+ (recentf-string-lessp
+ (file-name-nondirectory (recentf-menu-element-value e1))
+ (file-name-nondirectory (recentf-menu-element-value e2))))))
(defsubst recentf-sort-basenames-descending (l)
"Sort the list of menu elements L in descending order.
Only filenames sans directory are compared."
(sort (copy-sequence l)
- #'(lambda (e1 e2)
- (recentf-string-lessp
- (file-name-nondirectory (recentf-menu-element-value e2))
- (file-name-nondirectory (recentf-menu-element-value e1))))))
+ (lambda (e1 e2)
+ (recentf-string-lessp
+ (file-name-nondirectory (recentf-menu-element-value e2))
+ (file-name-nondirectory (recentf-menu-element-value e1))))))
(defsubst recentf-sort-directories-ascending (l)
"Sort the list of menu elements L in ascending order.
Compares directories then filenames to order the list."
(sort (copy-sequence l)
- #'(lambda (e1 e2)
- (recentf-directory-compare
- (recentf-menu-element-value e1)
- (recentf-menu-element-value e2)))))
+ (lambda (e1 e2)
+ (recentf-directory-compare
+ (recentf-menu-element-value e1)
+ (recentf-menu-element-value e2)))))
(defsubst recentf-sort-directories-descending (l)
"Sort the list of menu elements L in descending order.
Compares directories then filenames to order the list."
(sort (copy-sequence l)
- #'(lambda (e1 e2)
- (recentf-directory-compare
- (recentf-menu-element-value e2)
- (recentf-menu-element-value e1)))))
+ (lambda (e1 e2)
+ (recentf-directory-compare
+ (recentf-menu-element-value e2)
+ (recentf-menu-element-value e1)))))
(defun recentf-show-basenames (l &optional no-dir)
"Filter the list of menu elements L to show filenames sans directory.
@@ -1382,5 +1382,5 @@ buffers you switch to a lot, you can say something like the following:
(provide 'recentf)
(run-hooks 'recentf-load-hook)
-
+
;;; recentf.el ends here
diff --git a/lisp/register.el b/lisp/register.el
index e48a09f1574..38ee87cd775 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -279,6 +279,8 @@ ARG is the value of the prefix argument or nil."
(goto-char (cadr val)))
((eq (car val) 'file)
(find-file (cdr val)))
+ ((eq (car val) 'buffer)
+ (switch-to-buffer (cdr val)))
((eq (car val) 'file-query)
(or (find-buffer-visiting (nth 1 val))
(y-or-n-p (format "Visit file %s again? " (nth 1 val)))
@@ -417,6 +419,11 @@ Interactively, reads the register using `register-read-with-preview'."
(prin1 (cdr val))
(princ "."))
+ ((eq (car val) 'buffer)
+ (princ "the buffer ")
+ (prin1 (cdr val))
+ (princ "."))
+
((eq (car val) 'file-query)
(princ "a file-query reference:\n file ")
(prin1 (car (cdr val)))
diff --git a/lisp/repeat.el b/lisp/repeat.el
index 308ba46a265..ea6da5d7f9b 100644
--- a/lisp/repeat.el
+++ b/lisp/repeat.el
@@ -546,31 +546,32 @@ See `describe-repeat-maps' for a list of all repeatable commands."
Used in `repeat-mode'."
(interactive)
(require 'help-fns)
- (help-setup-xref (list #'describe-repeat-maps)
- (called-interactively-p 'interactive))
- (let ((keymaps nil))
- (all-completions
- "" obarray (lambda (s)
- (and (commandp s)
- (get s 'repeat-map)
- (push s (alist-get (get s 'repeat-map) keymaps)))))
- (with-help-window (help-buffer)
- (with-current-buffer standard-output
- (princ "A list of keymaps used by commands with the symbol property `repeat-map'.\n\n")
-
- (dolist (keymap (sort keymaps (lambda (a b) (string-lessp (car a) (car b)))))
- (princ (format-message "`%s' keymap is repeatable by these commands:\n"
- (car keymap)))
- (dolist (command (sort (cdr keymap) 'string-lessp))
- (let* ((info (help-fns--analyze-function command))
- (map (list (symbol-value (car keymap))))
- (desc (mapconcat (lambda (key)
- (format-message "`%s'" (key-description key)))
- (or (where-is-internal command map)
- (where-is-internal (nth 3 info) map))
- ", ")))
- (princ (format-message " `%s' (bound to %s)\n" command desc))))
- (princ "\n"))))))
+ (let ((help-buffer-under-preparation t))
+ (help-setup-xref (list #'describe-repeat-maps)
+ (called-interactively-p 'interactive))
+ (let ((keymaps nil))
+ (all-completions
+ "" obarray (lambda (s)
+ (and (commandp s)
+ (get s 'repeat-map)
+ (push s (alist-get (get s 'repeat-map) keymaps)))))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (princ "A list of keymaps used by commands with the symbol property `repeat-map'.\n\n")
+
+ (dolist (keymap (sort keymaps (lambda (a b) (string-lessp (car a) (car b)))))
+ (princ (format-message "`%s' keymap is repeatable by these commands:\n"
+ (car keymap)))
+ (dolist (command (sort (cdr keymap) 'string-lessp))
+ (let* ((info (help-fns--analyze-function command))
+ (map (list (symbol-value (car keymap))))
+ (desc (mapconcat (lambda (key)
+ (format-message "`%s'" (key-description key)))
+ (or (where-is-internal command map)
+ (where-is-internal (nth 3 info) map))
+ ", ")))
+ (princ (format-message " `%s' (bound to %s)\n" command desc))))
+ (princ "\n")))))))
(provide 'repeat)
diff --git a/lisp/replace.el b/lisp/replace.el
index 84ec042f455..0e81b15a097 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -2263,11 +2263,11 @@ See also `multi-occur'."
(defun occur-engine-add-prefix (lines &optional prefix-face)
(mapcar
- #'(lambda (line)
- (concat (if prefix-face
- (propertize " :" 'font-lock-face prefix-face)
- " :")
- line "\n"))
+ (lambda (line)
+ (concat (if prefix-face
+ (propertize " :" 'font-lock-face prefix-face)
+ " :")
+ line "\n"))
lines))
(defun occur-accumulate-lines (count &optional keep-props pt)
@@ -2402,20 +2402,20 @@ To be added to `context-menu-functions'."
;; It would be nice to use \\[...], but there is no reasonable way
;; to make that display both SPC and Y.
(defconst query-replace-help
- "Type Space or `y' to replace one match, Delete or `n' to skip to next,
-RET or `q' to exit, Period to replace one match and exit,
-Comma to replace but not move point immediately,
-C-r to enter recursive edit (\\[exit-recursive-edit] to get out again),
-C-w to delete match and recursive edit,
-C-l to clear the screen, redisplay, and offer same replacement again,
-! to replace all remaining matches in this buffer with no more questions,
-^ to move point back to previous match,
-u to undo previous replacement,
-U to undo all replacements,
-E to edit the replacement string.
-In multi-buffer replacements type `Y' to replace all remaining
+ "Type \\`SPC' or \\`y' to replace one match, Delete or \\`n' to skip to next,
+\\`RET' or \\`q' to exit, Period to replace one match and exit,
+\\`,' to replace but not move point immediately,
+\\`C-r' to enter recursive edit (\\[exit-recursive-edit] to get out again),
+\\`C-w' to delete match and recursive edit,
+\\`C-l' to clear the screen, redisplay, and offer same replacement again,
+\\`!' to replace all remaining matches in this buffer with no more questions,
+\\`^' to move point back to previous match,
+\\`u' to undo previous replacement,
+\\`U' to undo all replacements,
+\\`E' to edit the replacement string.
+In multi-buffer replacements type \\`Y' to replace all remaining
matches in all remaining buffers with no more questions,
-`N' to skip to the next buffer without replacing remaining matches
+\\`N' to skip to the next buffer without replacing remaining matches
in the current buffer."
"Help message while in `query-replace'.")
diff --git a/lisp/rot13.el b/lisp/rot13.el
index 4e4e60fea3f..e509b22529f 100644
--- a/lisp/rot13.el
+++ b/lisp/rot13.el
@@ -46,29 +46,23 @@
;;; Code:
-(defvar rot13-display-table
- (let ((table (make-display-table))
- (i 0))
- (while (< i 26)
+(defconst rot13-display-table
+ (let ((table (make-display-table)))
+ (dotimes (i 26)
(aset table (+ i ?a) (vector (+ (% (+ i 13) 26) ?a)))
- (aset table (+ i ?A) (vector (+ (% (+ i 13) 26) ?A)))
- (setq i (1+ i)))
+ (aset table (+ i ?A) (vector (+ (% (+ i 13) 26) ?A))))
table)
"Char table for ROT13 display.")
-(defvar rot13-translate-table
- (let ((str (make-string 127 0))
- (i 0))
- (while (< i 127)
- (aset str i i)
- (setq i (1+ i)))
- (setq i 0)
- (while (< i 26)
- (aset str (+ i ?a) (+ (% (+ i 13) 26) ?a))
- (aset str (+ i ?A) (+ (% (+ i 13) 26) ?A))
- (setq i (1+ i)))
- str)
- "String table for ROT13 translation.")
+(put 'plain-char-table 'char-table-extra-slots 0)
+
+(defconst rot13-translate-table
+ (let ((table (make-char-table 'translation-table)))
+ (dotimes (i 26)
+ (aset table (+ i ?a) (+ (% (+ i 13) 26) ?a))
+ (aset table (+ i ?A) (+ (% (+ i 13) 26) ?A)))
+ table)
+ "Char table for ROT13 translation.")
;;;###autoload
(defun rot13 (object &optional start end)
diff --git a/lisp/saveplace.el b/lisp/saveplace.el
index 4191a3fa62e..3eff816fa07 100644
--- a/lisp/saveplace.el
+++ b/lisp/saveplace.el
@@ -328,11 +328,18 @@ may have changed) back to `save-place-alist'."
(with-current-buffer (car buf-list)
;; save-place checks buffer-file-name too, but we can avoid
;; overhead of function call by checking here too.
- (and (or buffer-file-name (and (derived-mode-p 'dired-mode)
- (boundp 'dired-subdir-alist)
- dired-subdir-alist
- (dired-current-directory)))
- (save-place-to-alist))
+ (when (and (or buffer-file-name
+ (and (derived-mode-p 'dired-mode)
+ (boundp 'dired-subdir-alist)
+ dired-subdir-alist
+ (dired-current-directory)))
+ ;; Don't save place in literally-visited file
+ ;; because this will commonly differ from the place
+ ;; when visiting literally (and
+ ;; `find-file-literally' always places point at the
+ ;; start of the buffer).
+ (not find-file-literally))
+ (save-place-to-alist))
(setq buf-list (cdr buf-list))))))
(defun save-place-find-file-hook ()
diff --git a/lisp/select.el b/lisp/select.el
index 15e171c13f9..5e7f4a696a3 100644
--- a/lisp/select.el
+++ b/lisp/select.el
@@ -140,24 +140,27 @@ MS-Windows does not have a \"primary\" selection."
(defcustom x-select-request-type nil
"Data type request for X selection.
The value is one of the following data types, a list of them, or nil:
- `COMPOUND_TEXT', `UTF8_STRING', `STRING', `TEXT'
+ `COMPOUND_TEXT', `UTF8_STRING', `STRING', `TEXT', `text/plain\\;charset=utf-8'
If the value is one of the above symbols, try only the specified type.
If the value is a list of them, try each of them in the specified
order until succeed.
-The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING)."
+The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING
+text/plain\\;charset=utf-8)."
:type '(choice (const :tag "Default" nil)
(const COMPOUND_TEXT)
(const UTF8_STRING)
(const STRING)
(const TEXT)
+ (const text/plain\;charset=utf-8)
(set :tag "List of values"
(const COMPOUND_TEXT)
(const UTF8_STRING)
(const STRING)
- (const TEXT)))
+ (const TEXT)
+ (const text/plain\;charset=utf-8)))
:group 'killing)
(defun gui--selection-value-internal (type)
@@ -165,9 +168,9 @@ The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING)."
Call `gui-get-selection' with an appropriate DATA-TYPE argument
decided by `x-select-request-type'. The return value is already
decoded. If `gui-get-selection' signals an error, return nil."
- (let ((request-type (if (eq window-system 'x)
+ (let ((request-type (if (memq window-system '(x pgtk))
(or x-select-request-type
- '(UTF8_STRING COMPOUND_TEXT STRING))
+ '(UTF8_STRING COMPOUND_TEXT STRING text/plain\;charset=utf-8))
'STRING))
text)
(with-demoted-errors "gui-get-selection: %S"
@@ -304,22 +307,33 @@ the formats available in the clipboard if TYPE is `CLIPBOARD'."
(let ((data (gui-backend-get-selection (or type 'PRIMARY)
(or data-type 'STRING))))
(when (and (stringp data)
- (setq data-type (get-text-property 0 'foreign-selection data)))
+ ;; If this text property is set, then the data needs to
+ ;; be decoded -- otherwise it has already been decoded
+ ;; by the lower level functions.
+ (get-text-property 0 'foreign-selection data))
(let ((coding (or next-selection-coding-system
selection-coding-system
(pcase data-type
('UTF8_STRING 'utf-8)
+ ('text/plain\;charset=utf-8 'utf-8)
('COMPOUND_TEXT 'compound-text-with-extensions)
('C_STRING nil)
- ('STRING 'iso-8859-1)
- (_ (error "Unknown selection data type: %S"
- type))))))
- (setq data (if coding (decode-coding-string data coding)
- ;; This is for C_STRING case.
+ ('STRING 'iso-8859-1)))))
+ (setq data
+ (cond (coding (decode-coding-string data coding))
;; We want to convert each non-ASCII byte to the
;; corresponding eight-bit character, which has
;; a codepoint >= #x3FFF00.
- (string-to-multibyte data))))
+ ((eq data-type 'C_STRING)
+ (string-to-multibyte data))
+ ;; Guess at the charset for types like text/html
+ ;; -- it can be anything, and different
+ ;; applications use different encodings.
+ ((string-match-p "\\`text/" (symbol-name data-type))
+ (decode-coding-string
+ data (car (detect-coding-string data))))
+ ;; Do nothing.
+ (t data))))
(setq next-selection-coding-system nil)
(put-text-property 0 (length data) 'foreign-selection data-type data))
data))
@@ -440,13 +454,13 @@ two markers or an overlay. Otherwise, it is nil."
(setq type 'C_STRING))
(t
(let (non-latin-1 non-unicode eight-bit)
- (mapc #'(lambda (x)
- (if (>= x #x100)
- (if (< x #x110000)
- (setq non-latin-1 t)
- (if (< x #x3FFF80)
- (setq non-unicode t)
- (setq eight-bit t)))))
+ (mapc (lambda (x)
+ (if (>= x #x100)
+ (if (< x #x110000)
+ (setq non-latin-1 t)
+ (if (< x #x3FFF80)
+ (setq non-unicode t)
+ (setq eight-bit t)))))
str)
(setq type (if (or non-unicode
(and
diff --git a/lisp/server.el b/lisp/server.el
index 6359a761994..d510df1208a 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -90,12 +90,12 @@
(defcustom server-use-tcp nil
"If non-nil, use TCP sockets instead of local sockets."
- :set #'(lambda (sym val)
- (unless (featurep 'make-network-process '(:family local))
- (setq val t)
- (unless load-in-progress
- (message "Local sockets unsupported, using TCP sockets")))
- (set-default sym val))
+ :set (lambda (sym val)
+ (unless (featurep 'make-network-process '(:family local))
+ (setq val t)
+ (unless load-in-progress
+ (message "Local sockets unsupported, using TCP sockets")))
+ (set-default sym val))
:type 'boolean
:version "22.1")
@@ -485,11 +485,11 @@ If CLIENT is non-nil, add a description of it to the logged message."
(when (and (frame-live-p frame)
proc
;; See if this is the last frame for this client.
- (>= 1 (let ((frame-num 0))
- (dolist (f (frame-list))
- (when (eq proc (frame-parameter f 'client))
- (setq frame-num (1+ frame-num))))
- frame-num)))
+ (not (seq-some
+ (lambda (f)
+ (and (not (eq frame f))
+ (eq proc (frame-parameter f 'client))))
+ (frame-list))))
(server-log (format "server-handle-delete-frame, frame %s" frame) proc)
(server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later.
@@ -900,12 +900,17 @@ This handles splitting the command if it would be bigger than
)
(cond (w
- (server--create-frame
- nowait proc
- `((display . ,display)
- ,@(if parent-id
- `((parent-id . ,(string-to-number parent-id))))
- ,@parameters)))
+ (condition-case nil
+ (server--create-frame
+ nowait proc
+ `((display . ,display)
+ ,@(if parent-id
+ `((parent-id . ,(string-to-number parent-id))))
+ ,@parameters))
+ (error
+ (server-log "Window system unsupported" proc)
+ (server-send-string proc "-window-system-unsupported \n")
+ nil)))
(t
(server-log "Window system unsupported" proc)
@@ -1580,13 +1585,13 @@ specifically for the clients and did not exist before their request for it."
(server-buffer-done (current-buffer))))
(defun server-kill-emacs-query-function ()
- "Ask before exiting Emacs if it has live clients."
- (or (not (let (live-client)
- (dolist (proc server-clients)
- (when (memq t (mapcar #'buffer-live-p
- (process-get proc 'buffers)))
- (setq live-client t)))
- live-client))
+ "Ask before exiting Emacs if it has live clients.
+A \"live client\" is a client with at least one live buffer
+associated with it."
+ (or (not (seq-some (lambda (proc)
+ (seq-some #'buffer-live-p
+ (process-get proc 'buffers)))
+ server-clients))
(yes-or-no-p "This Emacs session has clients; exit anyway? ")))
(defun server-kill-buffer ()
@@ -1716,6 +1721,9 @@ 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.
@@ -1724,27 +1732,103 @@ 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)))
- (cond ((eq proc 'nowait)
- ;; Nowait frames have no client buffer list.
- (if (cdr (frame-list))
- (progn (save-some-buffers arg)
- (delete-frame))
- ;; If we're the last frame standing, kill Emacs.
- (save-buffers-kill-emacs arg)))
- ((processp proc)
- (let ((buffers (process-get proc 'buffers)))
- (save-some-buffers
- arg (if buffers
- ;; Only files from emacsclient file list.
- (lambda () (memq (current-buffer) buffers))
- ;; No emacsclient file list: don't override
- ;; `save-some-buffers-default-predicate' (unless
- ;; ARG is non-nil), since we're not killing
- ;; Emacs (unlike `save-buffers-kill-emacs').
- (and arg t)))
- (server-delete-client proc)))
- (t (error "Invalid client frame")))))
+ (if server-stop-automatically
+ (server-stop-automatically--handle-delete-frame (selected-frame))
+ (let ((proc (frame-parameter nil 'client)))
+ (cond ((eq proc 'nowait)
+ ;; Nowait frames have no client buffer list.
+ (if (cdr (frame-list))
+ (progn (save-some-buffers arg)
+ (delete-frame))
+ ;; If we're the last frame standing, kill Emacs.
+ (save-buffers-kill-emacs arg)))
+ ((processp proc)
+ (let ((buffers (process-get proc 'buffers)))
+ (save-some-buffers
+ arg (if buffers
+ ;; Only files from emacsclient file list.
+ (lambda () (memq (current-buffer) buffers))
+ ;; No emacsclient file list: don't override
+ ;; `save-some-buffers-default-predicate' (unless
+ ;; ARG is non-nil), since we're not killing
+ ;; Emacs (unlike `save-buffers-kill-emacs').
+ (and arg t)))
+ (server-delete-client proc)))
+ (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--maybe-kill-emacs ()
+ "Handle closing of Emacs daemon when `server-stop-automatically' is used."
+ (unless (cdr (frame-list))
+ (when (and
+ (not (memq t (mapcar (lambda (b)
+ (and (buffer-file-name b)
+ (buffer-modified-p b)))
+ (buffer-list))))
+ (not (memq t (mapcar (lambda (p)
+ (and (memq (process-status p)
+ '(run stop open listen))
+ (process-query-on-exit-flag p)))
+ (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
+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."
+ (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")))))
(define-key ctl-x-map "#" 'server-edit)
diff --git a/lisp/ses.el b/lisp/ses.el
index ea966295b18..8496aeec8e8 100644
--- a/lisp/ses.el
+++ b/lisp/ses.el
@@ -227,12 +227,6 @@ Used for listing local printers or renamed cells.")
"w" ses-set-column-width
"x" ses-export-keymap
"\M-p" ses-read-column-printer))
- (repl '(;;We'll replace these wherever they appear in the keymap
- clipboard-kill-region ses-kill-override
- end-of-line ses-end-of-line
- kill-line ses-delete-row
- kill-region ses-kill-override
- open-line ses-insert-row))
(numeric "0123456789.-")
(newmap (make-keymap)))
;;Get rid of printables
@@ -240,13 +234,11 @@ Used for listing local printers or renamed cells.")
;;These keys insert themselves as the beginning of a numeric value
(dotimes (x (length numeric))
(define-key newmap (substring numeric x (1+ x)) 'ses-read-cell))
- ;;Override these global functions wherever they're bound
- (while repl
- (substitute-key-definition (car repl) (cadr repl) newmap
- (current-global-map))
- (setq repl (cddr repl)))
- ;;Apparently substitute-key-definition doesn't catch this?
- (define-key newmap [(menu-bar) edit cut] 'ses-kill-override)
+ (define-key newmap [remap clipboard-kill-region] #'ses-kill-override)
+ (define-key newmap [remap end-of-line] #'ses-end-of-line)
+ (define-key newmap [remap kill-line] #'ses-delete-row)
+ (define-key newmap [remap kill-region] #'ses-kill-override)
+ (define-key newmap [remap open-line] #'ses-insert-row)
;;Define our other local keys
(while keys
(define-key newmap (car keys) (cadr keys))
@@ -3554,7 +3546,7 @@ With prefix, sorts in REVERSE order."
(push (cons (buffer-substring-no-properties (point) end)
(+ minrow x))
keys))
- (setq keys (sort keys #'(lambda (x y) (string< (car x) (car y)))))
+ (setq keys (sort keys (lambda (x y) (string< (car x) (car y)))))
;;Extract the lines in reverse sorted order
(or reverse
(setq keys (nreverse keys)))
@@ -3774,7 +3766,9 @@ function is redefined."
(setq name (intern name))
(let* ((cur-printer (gethash name ses--local-printer-hashmap))
(default (and cur-printer (ses--locprn-def cur-printer))))
- (setq def (ses-read-printer (format "Enter definition of printer %S" name)
+ (setq def (ses-read-printer (format-prompt
+ "Enter definition of printer %S"
+ default name)
default)))
(list name def)))
diff --git a/lisp/shell.el b/lisp/shell.el
index cb4afe6dea8..370532ea46f 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -785,7 +785,8 @@ Make the shell buffer the current buffer, and return it.
(startfile (concat "~/.emacs_" name))
(xargs-name (intern-soft (concat "explicit-" name "-args"))))
(unless (file-exists-p startfile)
- (setq startfile (concat user-emacs-directory "init_" name ".sh")))
+ (setq startfile (locate-user-emacs-file
+ (concat "init_" name ".sh"))))
(setq-local shell--start-prog (file-name-nondirectory prog))
(apply #'make-comint-in-buffer "shell" buffer prog
(if (file-exists-p startfile) startfile)
diff --git a/lisp/simple.el b/lisp/simple.el
index 94a459b7795..b217aeb49ce 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -527,21 +527,28 @@ Other major modes are defined by comparison with this one."
(kill-all-local-variables)
(run-mode-hooks))
+(define-derived-mode clean-mode fundamental-mode "Clean"
+ "A mode that removes all overlays and text properties."
+ (kill-all-local-variables t)
+ (let ((inhibit-read-only t))
+ (dolist (overlay (overlays-in (point-min) (point-max)))
+ (delete-overlay overlay))
+ (set-text-properties (point-min) (point-max) nil)
+ (setq-local yank-excluded-properties t)))
+
;; Special major modes to view specially formatted data rather than files.
-(defvar special-mode-map
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "q" 'quit-window)
- (define-key map " " 'scroll-up-command)
- (define-key map [?\S-\ ] 'scroll-down-command)
- (define-key map "\C-?" 'scroll-down-command)
- (define-key map "?" 'describe-mode)
- (define-key map "h" 'describe-mode)
- (define-key map ">" 'end-of-buffer)
- (define-key map "<" 'beginning-of-buffer)
- (define-key map "g" 'revert-buffer)
- map))
+(defvar-keymap special-mode-map
+ :suppress t
+ "q" #'quit-window
+ "SPC" #'scroll-up-command
+ "S-SPC" #'scroll-down-command
+ "DEL" #'scroll-down-command
+ "?" #'describe-mode
+ "h" #'describe-mode
+ ">" #'end-of-buffer
+ "<" #'beginning-of-buffer
+ "g" #'revert-buffer)
(put 'special-mode 'mode-class 'special)
(define-derived-mode special-mode nil "Special"
@@ -703,9 +710,10 @@ When called from Lisp code, ARG may be a prefix string to copy."
:height 0.1 :background "#505050")
(((type graphic) (background light))
:height 0.1 :background "#a0a0a0")
- (t :foreground "ForestGreen"))
+ (t
+ :foreground "ForestGreen" :underline t))
"Face for separator lines."
- :version "28.1"
+ :version "29.1"
:group 'text)
(defun make-separator-line (&optional length)
@@ -713,11 +721,13 @@ When called from Lisp code, ARG may be a prefix string to copy."
This uses the `separator-line' face.
If LENGTH is nil, use the window width."
- (if (display-graphic-p)
+ (if (or (display-graphic-p)
+ (display-supports-face-attributes-p '(:underline t)))
(if length
(concat (propertize (make-string length ?\s) 'face 'separator-line)
"\n")
(propertize "\n" 'face '(:inherit separator-line :extend t)))
+ ;; In terminals (that don't support underline), use a line of dashes.
(concat (propertize (make-string (or length (1- (window-width))) ?-)
'face 'separator-line)
"\n")))
@@ -3104,7 +3114,7 @@ Interactively, ARG is the prefix numeric argument and defaults to 1."
(let ((undo-in-progress t))
(while (and (consp ul) (eq (car ul) nil))
(setq ul (cdr ul)))
- (primitive-undo arg ul)))
+ (primitive-undo (or arg 1) ul)))
(new-pul (undo--last-change-was-undo-p new-ul)))
(message "Redo%s" (if undo-in-region " in region" ""))
(setq this-command 'undo)
@@ -5069,10 +5079,11 @@ interact nicely with `interprogram-cut-function' and
interaction; you may want to use them instead of manipulating the kill
ring directly.")
-(defcustom kill-ring-max 60
+(defcustom kill-ring-max 120
"Maximum length of kill ring before oldest elements are thrown away."
:type 'integer
- :group 'killing)
+ :group 'killing
+ :version "29.1")
(defvar kill-ring-yank-pointer nil
"The tail of the kill ring whose car is the last thing yanked.")
@@ -8573,40 +8584,43 @@ The function should return non-nil if the two tokens do not match.")
(current-buffer))
(sit-for blink-matching-delay))
(delete-overlay blink-matching--overlay)))))
- (t
- (let ((open-paren-line-string
- (save-excursion
- (goto-char blinkpos)
- ;; Show what precedes the open in its line, if anything.
- (cond
- ((save-excursion (skip-chars-backward " \t") (not (bolp)))
- (buffer-substring (line-beginning-position)
- (1+ blinkpos)))
- ;; Show what follows the open in its line, if anything.
- ((save-excursion
- (forward-char 1)
- (skip-chars-forward " \t")
- (not (eolp)))
- (buffer-substring blinkpos
- (line-end-position)))
- ;; Otherwise show the previous nonblank line,
- ;; if there is one.
- ((save-excursion (skip-chars-backward "\n \t") (not (bobp)))
- (concat
- (buffer-substring (progn
- (skip-chars-backward "\n \t")
- (line-beginning-position))
- (progn (end-of-line)
- (skip-chars-backward " \t")
- (point)))
- ;; Replace the newline and other whitespace with `...'.
- "..."
- (buffer-substring blinkpos (1+ blinkpos))))
- ;; There is nothing to show except the char itself.
- (t (buffer-substring blinkpos (1+ blinkpos)))))))
- (minibuffer-message
- "Matches %s"
- (substring-no-properties open-paren-line-string))))))))
+ ((not show-paren-context-when-offscreen)
+ (minibuffer-message
+ "Matches %s"
+ (substring-no-properties
+ (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."
+ (save-excursion
+ (goto-char pos)
+ ;; Show what precedes the open in its line, if anything.
+ (cond
+ ((save-excursion (skip-chars-backward " \t") (not (bolp)))
+ (buffer-substring (line-beginning-position)
+ (1+ pos)))
+ ;; Show what follows the open in its line, if anything.
+ ((save-excursion
+ (forward-char 1)
+ (skip-chars-forward " \t")
+ (not (eolp)))
+ (buffer-substring pos
+ (line-end-position)))
+ ;; Otherwise show the previous nonblank line,
+ ;; if there is one.
+ ((save-excursion (skip-chars-backward "\n \t") (not (bobp)))
+ (concat
+ (buffer-substring (progn
+ (skip-chars-backward "\n \t")
+ (line-beginning-position))
+ (progn (end-of-line)
+ (skip-chars-backward " \t")
+ (point)))
+ ;; Replace the newline and other whitespace with `...'.
+ "..."
+ (buffer-substring pos (1+ pos))))
+ ;; There is nothing to show except the char itself.
+ (t (buffer-substring pos (1+ pos))))))
(defvar blink-paren-function 'blink-matching-open
"Function called, if non-nil, whenever a close parenthesis is inserted.
@@ -8898,7 +8912,7 @@ With a prefix argument, set VARIABLE to VALUE buffer-locally.
When called interactively, the user is prompted for VARIABLE and
then VALUE. The current value of VARIABLE will be put in the
-minibuffer history so that it can be accessed with `M-n', which
+minibuffer history so that it can be accessed with \\`M-n', which
makes it easier to edit it."
(interactive
(let* ((default-var (variable-at-point))
@@ -9602,7 +9616,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))
+ (memq window-system '(w32 ns pgtk))
(and (eq window-system 'x)
(fboundp 'x-backspace-delete-keys-p)
(x-backspace-delete-keys-p))
@@ -9776,24 +9790,7 @@ If it does not exist, create it and switch it to `messages-buffer-mode'."
;; versions together with bad values. This is therefore not as
;; flexible as it could be. See the thread:
;; https://lists.gnu.org/r/emacs-devel/2007-08/msg00300.html
-(defconst bad-packages-alist
- ;; Not sure exactly which semantic versions have problems.
- ;; Definitely 2.0pre3, probably all 2.0pre's before this.
- '((semantic semantic-version "\\`2\\.0pre[1-3]\\'"
- "The version of `semantic' loaded does not work in Emacs 22.
-It can cause constant high CPU load.
-Upgrade to at least Semantic 2.0pre4 (distributed with CEDET 1.0pre4).")
- ;; CUA-mode does not work with GNU Emacs version 22.1 and newer.
- ;; Except for version 1.2, all of the 1.x and 2.x version of cua-mode
- ;; provided the `CUA-mode' feature. Since this is no longer true,
- ;; we can warn the user if the `CUA-mode' feature is ever provided.
- (CUA-mode t nil
-"CUA-mode is now part of the standard GNU Emacs distribution,
-so you can now enable CUA via the Options menu or by customizing `cua-mode'.
-
-You have loaded an older version of CUA-mode which does not work
-correctly with this version of Emacs. You should remove the old
-version and use the one distributed with Emacs."))
+(defconst bad-packages-alist nil
"Alist of packages known to cause problems in this version of Emacs.
Each element has the form (PACKAGE SYMBOL REGEXP STRING).
PACKAGE is either a regular expression to match file names, or a
@@ -9801,9 +9798,11 @@ symbol (a feature name), like for `with-eval-after-load'.
SYMBOL is either the name of a string variable, or t. Upon
loading PACKAGE, if SYMBOL is t or matches REGEXP, display a
warning using STRING as the message.")
+(make-obsolete-variable 'bad-packages-alist nil "29.1")
(defun bad-package-check (package)
"Run a check using the element from `bad-packages-alist' matching PACKAGE."
+ (declare (obsolete nil "29.1"))
(condition-case nil
(let* ((list (assoc package bad-packages-alist))
(symbol (nth 1 list)))
@@ -9815,11 +9814,6 @@ warning using STRING as the message.")
(display-warning package (nth 3 list) :warning)))
(error nil)))
-(dolist (elem bad-packages-alist)
- (let ((pkg (car elem)))
- (with-eval-after-load pkg
- (bad-package-check pkg))))
-
;;; Generic dispatcher commands
@@ -9856,6 +9850,7 @@ does not have any effect until this variable is set.
CUSTOMIZATIONS, if non-nil, should be composed of alternating
`defcustom' keywords and values to add to the declaration of
`COMMAND-alternatives' (typically :group and :version)."
+ (declare (indent defun))
(let* ((command-name (symbol-name command))
(varalt-name (concat command-name "-alternatives"))
(varalt-sym (intern varalt-name))
diff --git a/lisp/skeleton.el b/lisp/skeleton.el
index c363fb2c489..2b183996d83 100644
--- a/lisp/skeleton.el
+++ b/lisp/skeleton.el
@@ -113,7 +113,8 @@ are integer buffer positions in the reverse order of the insertion order.")
"Define a user-configurable COMMAND that enters a statement skeleton.
DOCUMENTATION is that of the command.
SKELETON is as defined under `skeleton-insert'."
- (declare (doc-string 2) (debug (&define name stringp skeleton-edebug-spec)))
+ (declare (doc-string 2) (debug (&define name stringp skeleton-edebug-spec))
+ (indent defun))
(if skeleton-debug
(set command skeleton))
`(progn
diff --git a/lisp/sort.el b/lisp/sort.el
index d6767ed5098..09259805415 100644
--- a/lisp/sort.el
+++ b/lisp/sort.el
@@ -540,8 +540,8 @@ Use \\[untabify] to convert tabs to spaces before sorting."
(narrow-to-region beg1 end1)
(goto-char beg1)
(sort-subr reverse 'forward-line 'end-of-line
- #'(lambda () (move-to-column col-start) nil)
- #'(lambda () (move-to-column col-end) nil))))))))
+ (lambda () (move-to-column col-start) nil)
+ (lambda () (move-to-column col-end) nil))))))))
;;;###autoload
(defun reverse-region (beg end)
diff --git a/lisp/speedbar.el b/lisp/speedbar.el
index 3cc3e276067..cfa96608bff 100644
--- a/lisp/speedbar.el
+++ b/lisp/speedbar.el
@@ -3694,27 +3694,21 @@ regular expression EXPR."
;;; BUFFER DISPLAY mode.
;;
-(defvar speedbar-buffers-key-map nil
+(defvar speedbar-buffers-key-map
+ (let ((map (speedbar-make-specialized-keymap)))
+ ;; Basic tree features
+ (define-key map "e" #'speedbar-edit-line)
+ (define-key map "\C-m" #'speedbar-edit-line)
+ (define-key map "+" #'speedbar-expand-line)
+ (define-key map "=" #'speedbar-expand-line)
+ (define-key map "-" #'speedbar-contract-line)
+ (define-key map " " #'speedbar-toggle-line-expansion)
+ ;; Buffer specific keybindings
+ (define-key map "k" #'speedbar-buffer-kill-buffer)
+ (define-key map "r" #'speedbar-buffer-revert-buffer)
+ map)
"Keymap used when in the buffers display mode.")
-(if speedbar-buffers-key-map
- nil
- (setq speedbar-buffers-key-map (speedbar-make-specialized-keymap))
-
- ;; Basic tree features
- (define-key speedbar-buffers-key-map "e" 'speedbar-edit-line)
- (define-key speedbar-buffers-key-map "\C-m" 'speedbar-edit-line)
- (define-key speedbar-buffers-key-map "+" 'speedbar-expand-line)
- (define-key speedbar-buffers-key-map "=" 'speedbar-expand-line)
- (define-key speedbar-buffers-key-map "-" 'speedbar-contract-line)
- (define-key speedbar-buffers-key-map " " 'speedbar-toggle-line-expansion)
-
- ;; Buffer specific keybindings
- (define-key speedbar-buffers-key-map "k" 'speedbar-buffer-kill-buffer)
- (define-key speedbar-buffers-key-map "r" 'speedbar-buffer-revert-buffer)
-
- )
-
(defvar speedbar-buffer-easymenu-definition
'(["Jump to buffer" speedbar-edit-line t]
["Expand File Tags" speedbar-expand-line
diff --git a/lisp/sqlite-mode.el b/lisp/sqlite-mode.el
new file mode 100644
index 00000000000..082eb8276e8
--- /dev/null
+++ b/lisp/sqlite-mode.el
@@ -0,0 +1,216 @@
+;;; sqlite-mode.el --- Mode for examining sqlite3 database files -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 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 'cl-lib)
+
+(declare-function sqlite-execute "sqlite.c")
+(declare-function sqlite-more-p "sqlite.c")
+(declare-function sqlite-next "sqlite.c")
+(declare-function sqlite-columns "sqlite.c")
+(declare-function sqlite-finalize "sqlite.c")
+(declare-function sqlite-select "sqlite.c")
+(declare-function sqlite-open "sqlite.c")
+
+(defvar-keymap sqlite-mode-map
+ "g" #'sqlite-mode-list-tables
+ "c" #'sqlite-mode-list-columns
+ "RET" #'sqlite-mode-list-data
+ "DEL" #'sqlite-mode-delete)
+
+(define-derived-mode sqlite-mode special-mode "Sqlite"
+ "This mode lists the contents of an .sqlite3 file"
+ :interactive nil
+ (buffer-disable-undo)
+ (setq-local buffer-read-only t
+ truncate-lines t))
+
+(defvar sqlite--db nil)
+
+;;;###autoload
+(defun sqlite-mode-open-file (file)
+ "Browse the contents of an sqlite file."
+ (interactive "fSQLite file name: ")
+ (unless (sqlite-available-p)
+ (error "This Emacs doesn't have SQLite support, so it can't view SQLite files"))
+ (pop-to-buffer (get-buffer-create
+ (format "*SQLite %s*" (file-name-nondirectory file))))
+ (sqlite-mode)
+ (setq-local sqlite--db (sqlite-open file))
+ (sqlite-mode-list-tables))
+
+(defun sqlite-mode-list-tables ()
+ "Re-list the tables from the currently selected database."
+ (interactive nil sqlite-mode)
+ (let ((inhibit-read-only t)
+ (db sqlite--db)
+ (entries nil))
+ (erase-buffer)
+ (dolist (table (sqlite-select db "select name from sqlite_master where type = 'table' and name not like 'sqlite_%' order by name"))
+ (push (list (car table)
+ (caar (sqlite-select db (format "select count(*) from %s"
+ (car table)))))
+ entries))
+ (sqlite-mode--tablify '("Table Name" "Number of Rows")
+ (nreverse entries)
+ 'table)
+ (goto-char (point-min))))
+
+(defun sqlite-mode--tablify (columns rows type &optional prefix)
+ (let ((widths
+ (mapcar
+ (lambda (i)
+ (1+ (seq-max (mapcar (lambda (row)
+ (length (format "%s" (nth i row))))
+ (cons columns rows)))))
+ (number-sequence 0 (1- (length columns))))))
+ (when prefix
+ (insert prefix))
+ (dotimes (i (length widths))
+ (insert (propertize (format (format "%%-%ds " (nth i widths))
+ (nth i columns))
+ 'face 'header-line)))
+ (insert "\n")
+ (dolist (row rows)
+ (let ((start (point)))
+ (when prefix
+ (insert prefix))
+ (dotimes (i (length widths))
+ (let ((elem (nth i row)))
+ (insert (format (format "%%%s%ds "
+ (if (numberp elem)
+ "" "-")
+ (nth i widths))
+ (if (numberp elem)
+ (nth i row)
+ (string-replace "\n" " " (or elem "")))))))
+ (put-text-property start (point) 'sqlite--row row)
+ (put-text-property start (point) 'sqlite--type type)
+ (insert "\n")))))
+
+(defun sqlite-mode-list-columns ()
+ "List the columns of the table under point."
+ (interactive nil sqlite-mode)
+ (let ((row (get-text-property (point) 'sqlite--row)))
+ (unless row
+ (user-error "No table under point"))
+ (let ((columns (sqlite-mode--column-names (car row)))
+ (inhibit-read-only t))
+ (save-excursion
+ (forward-line 1)
+ (if (looking-at " ")
+ ;; Delete the info.
+ (delete-region (point) (if (re-search-forward "^[^ ]" nil t)
+ (match-beginning 0)
+ (point-max)))
+ ;; Insert the info.
+ (dolist (column columns)
+ (insert (format " %s\n" column))))))))
+
+(defun sqlite-mode--column-names (table)
+ (let ((sql
+ (caar
+ (sqlite-select
+ sqlite--db
+ "select sql from sqlite_master where tbl_name = ? AND type = 'table'"
+ (list table)))))
+ (mapcar
+ #'string-trim
+ (split-string (replace-regexp-in-string "^.*(\\|)$" "" sql) ","))))
+
+(defun sqlite-mode-list-data ()
+ "List the data from the table under point."
+ (interactive nil sqlite-mode)
+ (let ((row (and (eq (get-text-property (point) 'sqlite--type) 'table)
+ (get-text-property (point) 'sqlite--row))))
+ (unless row
+ (user-error "No table under point"))
+ (let ((inhibit-read-only t))
+ (save-excursion
+ (forward-line 1)
+ (if (looking-at " ")
+ ;; Delete the info.
+ (delete-region (point) (if (re-search-forward "^[^ ]" nil t)
+ (match-beginning 0)
+ (point-max)))
+ (sqlite--mode--list-data (list (car row) 0)))))))
+
+(defun sqlite-mode--more-data (stmt)
+ (let ((inhibit-read-only t))
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (sqlite--mode--list-data stmt)))
+
+(defun sqlite--mode--list-data (data)
+ (let* ((table (car data))
+ (rowid (cadr data))
+ stmt)
+ (unwind-protect
+ (progn
+ (setq stmt
+ (sqlite-select
+ sqlite--db
+ (format "select rowid, * from %s where rowid >= ?" table)
+ (list rowid)
+ 'set))
+ (sqlite-mode--tablify (sqlite-columns stmt)
+ (cl-loop for i from 0 upto 1000
+ for row = (sqlite-next stmt)
+ while row
+ do (setq rowid (car row))
+ collect row)
+ (cons 'row table)
+ " ")
+ (when (sqlite-more-p stmt)
+ (insert (buttonize " More data...\n" #'sqlite-mode--more-data
+ (list table rowid)))))
+ (when stmt
+ (sqlite-finalize stmt)))))
+
+(defun sqlite-mode-delete ()
+ "Delete the row under point."
+ (interactive nil sqlite-mode)
+ (let ((table (get-text-property (point) 'sqlite--type))
+ (row (get-text-property (point) 'sqlite--row))
+ (inhibit-read-only t))
+ (when (or (not (consp table))
+ (not (eq (car table) 'row)))
+ (user-error "No row under point"))
+ (unless (yes-or-no-p "Really delete the row under point? ")
+ (user-error "Not deleting"))
+ (sqlite-execute
+ sqlite--db
+ (format "delete from %s where %s"
+ (cdr table)
+ (string-join
+ (mapcar (lambda (column)
+ (format "%s = ?" (car (split-string column " "))))
+ (cons "rowid" (sqlite-mode--column-names (cdr table))))
+ " and "))
+ row)
+ (delete-region (line-beginning-position) (progn (forward-line 1) (point)))))
+
+(provide 'sqlite-mode)
+
+;;; sqlite-mode.el ends here
diff --git a/lisp/sqlite.el b/lisp/sqlite.el
new file mode 100644
index 00000000000..6d32a0468f3
--- /dev/null
+++ b/lisp/sqlite.el
@@ -0,0 +1,43 @@
+;;; sqlite.el --- Functions for interacting with sqlite3 databases -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 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:
+
+(defmacro with-sqlite-transaction (db &rest body)
+ "Execute BODY while holding a transaction for DB."
+ (declare (indent 1) (debug (form body)))
+ (let ((db-var (gensym))
+ (func-var (gensym)))
+ `(let ((,db-var ,db)
+ (,func-var (lambda () ,@body)))
+ (if (sqlite-available-p)
+ (unwind-protect
+ (progn
+ (sqlite-transaction ,db-var)
+ (funcall ,func-var))
+ (sqlite-commit ,db-var))
+ (funcall ,func-var)))))
+
+(provide 'sqlite)
+
+;;; sqlite.el ends here
diff --git a/lisp/startup.el b/lisp/startup.el
index 505d7b83f48..b79467339b2 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -519,6 +519,19 @@ DIRS are relative."
xdg-dir)
(t emacs-d-dir))))
+(defvar comp--delayed-sources)
+(defvar comp--loadable)
+(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)
+ (require 'comp)
+ (setq comp--loadable t)
+ (native--compile-async comp--delayed-sources nil 'late)
+ (setq comp--delayed-sources nil)))
+
(defvar native-comp-eln-load-path)
(defun normal-top-level ()
"Emacs calls this function when it first starts up.
@@ -785,7 +798,8 @@ It is the default value of the variable `top-level'."
(if (string-match "\\`DISPLAY=" varval)
(setq display varval))))
(when display
- (delete display process-environment)))))
+ (delete display process-environment))))
+ (startup--honor-delayed-native-compilations))
;; Precompute the keyboard equivalents in the menu bar items.
;; Command-line options supported by tty's:
@@ -1556,17 +1570,22 @@ If this is nil, no message will be displayed."
`((:face (variable-pitch font-lock-comment-face)
"Welcome to "
:link ("GNU Emacs"
- ,(lambda (_button) (browse-url "https://www.gnu.org/software/emacs/"))
+ ,(lambda (_button)
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/software/emacs/")))
"Browse https://www.gnu.org/software/emacs/")
", one component of the "
:link
,(lambda ()
(if (eq system-type 'gnu/linux)
`("GNU/Linux"
- ,(lambda (_button) (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html"))
+ ,(lambda (_button)
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html")))
"Browse https://www.gnu.org/gnu/linux-and-gnu.html")
`("GNU" ,(lambda (_button)
- (browse-url "https://www.gnu.org/gnu/thegnuproject.html"))
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/gnu/thegnuproject.html")))
"Browse https://www.gnu.org/gnu/thegnuproject.html")))
" operating system.\n\n"
:face variable-pitch
@@ -1599,7 +1618,8 @@ If this is nil, no message will be displayed."
"\n"
:link ("Emacs Guided Tour"
,(lambda (_button)
- (browse-url "https://www.gnu.org/software/emacs/tour/"))
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/software/emacs/tour/")))
"Browse https://www.gnu.org/software/emacs/tour/")
"\tOverview of Emacs features at gnu.org\n"
:link ("View Emacs Manual" ,(lambda (_button) (info-emacs-manual)))
@@ -1622,22 +1642,31 @@ Each element in the list should be a list of strings or pairs
`((:face (variable-pitch font-lock-comment-face)
"This is "
:link ("GNU Emacs"
- ,(lambda (_button) (browse-url "https://www.gnu.org/software/emacs/"))
+ ,(lambda (_button)
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/software/emacs/")))
"Browse https://www.gnu.org/software/emacs/")
- ", one component of the "
+ ", a text editor and more.\nIt's a component of the "
:link
,(lambda ()
(if (eq system-type 'gnu/linux)
`("GNU/Linux"
,(lambda (_button)
- (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html"))
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html")))
"Browse https://www.gnu.org/gnu/linux-and-gnu.html")
- `("GNU" ,(lambda (_button) (describe-gnu-project))
+ `("GNU" ,(lambda (_button)
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (describe-gnu-project)))
"Display info on the GNU project.")))
" operating system.\n"
:face (variable-pitch font-lock-builtin-face)
"\n"
- ,(lambda () (emacs-version))
+ ,(lambda ()
+ (with-temp-buffer
+ (insert (emacs-version))
+ (fill-region (point-min) (point-max))
+ (buffer-string)))
"\n"
:face (variable-pitch (:height 0.8))
,(lambda () emacs-copyright)
@@ -1652,7 +1681,9 @@ Each element in the list should be a list of strings or pairs
,(lambda (_button) (info "(emacs)Contributing")))
"\tHow to report bugs and contribute improvements to Emacs\n"
"\n"
- :link ("GNU and Freedom" ,(lambda (_button) (describe-gnu-project)))
+ :link ("GNU and Freedom" ,(lambda (_button)
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (describe-gnu-project))))
"\tWhy we developed GNU Emacs, and the GNU operating system\n"
:link ("Absence of Warranty" ,(lambda (_button) (describe-no-warranty)))
"\tGNU Emacs comes with "
@@ -1690,7 +1721,8 @@ Each element in the list should be a list of strings or pairs
"\n"
:link ("Emacs Guided Tour"
,(lambda (_button)
- (browse-url "https://www.gnu.org/software/emacs/tour/"))
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/software/emacs/tour/")))
"Browse https://www.gnu.org/software/emacs/tour/")
"\tSee an overview of Emacs features at gnu.org\n"
:link ("Emacs Manual" ,(lambda (_button) (info-emacs-manual)))
@@ -1812,7 +1844,9 @@ a face or button specification."
(make-button (prog1 (point) (insert-image img)) (point)
'face 'default
'help-echo "mouse-2, RET: Browse https://www.gnu.org/"
- 'action (lambda (_button) (browse-url "https://www.gnu.org/"))
+ 'action (lambda (_button)
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/")))
'follow-link t)
(insert "\n\n")))))
@@ -1821,28 +1855,35 @@ a face or button specification."
(unless concise
(fancy-splash-insert
:face 'variable-pitch
- "\nTo start... "
+ "\nTo start...\t"
:link `("Open a File"
,(lambda (_button) (call-interactively 'find-file))
"Specify a new file's name, to edit the file")
- " "
+ "\t\t"
:link `("Open Home Directory"
,(lambda (_button) (dired "~"))
"Open your home directory, to operate on its files")
- " "
+ "\n\t"
:link `("Customize Startup"
,(lambda (_button) (customize-group 'initialization))
"Change initialization settings including this screen")
+ "\t"
+ :link `("Explore Packages"
+ ,(lambda (_button) (call-interactively 'package-list-packages))
+ "Explore, install and remove Emacs packages (requires Internet connection)")
"\n"))
(fancy-splash-insert
:face 'variable-pitch "To quit a partially entered command, type "
:face 'default "Control-g"
:face 'variable-pitch ".\n")
- (fancy-splash-insert :face '(variable-pitch font-lock-builtin-face)
- "\nThis is "
- (emacs-version)
- "\n"
- :face '(variable-pitch (:height 0.8))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (fancy-splash-insert :face '(variable-pitch font-lock-builtin-face)
+ "\nThis is "
+ (emacs-version)
+ "\n")
+ (fill-region (point-min) (point-max)))
+ (fancy-splash-insert :face '(variable-pitch (:height 0.8))
emacs-copyright
"\n")
(when auto-save-list-file-prefix
@@ -1926,7 +1967,6 @@ splash screen in another window."
(insert "\n")
(fancy-startup-tail concise))
(use-local-map splash-screen-keymap)
- (setq-local browse-url-browser-function 'eww-browse-url)
(setq tab-width 22
buffer-read-only t)
(set-buffer-modified-p nil)
@@ -1964,11 +2004,11 @@ splash screen in another window."
(goto-char (point-min))
(force-mode-line-update))
(use-local-map splash-screen-keymap)
- (setq-local browse-url-browser-function 'eww-browse-url)
(setq tab-width 22)
(setq buffer-read-only t)
+ ;; Place point somewhere it doesn't cover a character.
(goto-char (point-min))
- (forward-line 3))))
+ (re-search-forward "\n$" nil nil 2))))
(defun fancy-splash-frame ()
"Return the frame to use for the fancy splash screen.
@@ -1980,6 +2020,8 @@ we put it on this frame."
;; frame visible.
(if (eq (window-system) 'w32)
(sit-for 0 t))
+ (if (eq (window-system) 'pgtk)
+ (sit-for 0.1 t))
(dolist (frame (append (frame-list) (list (selected-frame))))
(if (and (frame-visible-p frame)
(not (window-minibuffer-p (frame-selected-window frame))))
@@ -2121,8 +2163,11 @@ To quit a partially entered command, type Control-g.\n")
'follow-link t)
(insert "\tChange initialization settings including this screen\n")
- (insert "\n" (emacs-version)
- "\n" emacs-copyright))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (insert "\n" (emacs-version) "\n")
+ (fill-region (point-min) (point-max)))
+ (insert emacs-copyright))
(defun normal-no-mouse-startup-screen ()
"Show a splash screen suitable for displays without mouse support."
@@ -2202,7 +2247,11 @@ If you have no Meta key, you may instead type ESC followed by the character.)"))
(startup--get-buffer-create-scratch)))
'follow-link t)
(insert "\n")
- (insert "\n" (emacs-version) "\n" emacs-copyright "\n")
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (insert "\n" (emacs-version) "\n")
+ (fill-region (point-min) (point-max)))
+ (insert emacs-copyright "\n")
(insert (substitute-command-keys
"
GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for "))
@@ -2242,7 +2291,9 @@ Type \\[describe-distribution] for information on "))
(insert "\tHow to report bugs and contribute improvements to Emacs\n\n")
(insert-button "GNU and Freedom"
- 'action (lambda (_button) (describe-gnu-project))
+ 'action (lambda (_button)
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (describe-gnu-project)))
'follow-link t)
(insert "\t\tWhy we developed GNU Emacs and the GNU system\n")
@@ -2383,6 +2434,7 @@ A fancy display is used on graphic displays, normal otherwise."
;; and long versions of what's on command-switch-alist.
(longopts
(append '("--funcall" "--load" "--insert" "--kill"
+ "--dump-file" "--seccomp"
"--directory" "--eval" "--execute" "--no-splash"
"--find-file" "--visit" "--file" "--no-desktop")
(mapcar (lambda (elt) (concat "-" (car elt)))
@@ -2526,7 +2578,15 @@ nil default-directory" name)
(let* ((file (command-line-normalize-file-name
(or argval (pop command-line-args-left))))
;; Take file from default dir.
- (file-ex (file-truename (expand-file-name file))))
+ (file-ex (expand-file-name file))
+ (truename (file-truename file-ex)))
+ ;; We want to use the truename here if we can,
+ ;; because that makes `eval-after-load' work
+ ;; more reliably. But if the file is, for
+ ;; instance, /dev/stdin, the truename doesn't
+ ;; actually exist on some systems.
+ (when (file-exists-p truename)
+ (setq file-ex truename))
(load file-ex nil t t)))
((equal argi "-insert")
@@ -2536,6 +2596,11 @@ nil default-directory" name)
(error "File name omitted from `-insert' option"))
(insert-file-contents (command-line-normalize-file-name tem)))
+ ((or (equal argi "-dump-file")
+ (equal argi "-seccomp"))
+ ;; This was processed in C.
+ (or argval (pop command-line-args-left)))
+
((equal argi "-kill")
(kill-emacs t))
diff --git a/lisp/strokes.el b/lisp/strokes.el
index 91ddefd3738..db0eb83a3e6 100644
--- a/lisp/strokes.el
+++ b/lisp/strokes.el
@@ -1395,14 +1395,19 @@ Encode/decode your strokes with \\[strokes-encode-buffer],
(strokes-load-user-strokes))
(add-hook 'kill-emacs-query-functions
#'strokes-prompt-user-save-strokes)
- (add-hook 'select-frame-hook
- #'strokes-update-window-configuration)
+ ;; FIXME: Should this be something like `focus-in-hook'?
+ ;; That variable is obsolete, but `select-frame-hook' has
+ ;; never existed in Emacs.
+ ;;(add-hook 'select-frame-hook
+ ;; #'strokes-update-window-configuration)
(strokes-update-window-configuration))
(t ; turn off strokes
(if (get-buffer strokes-buffer-name)
- (kill-buffer (get-buffer strokes-buffer-name)))
- (remove-hook 'select-frame-hook
- #'strokes-update-window-configuration))))
+ (kill-buffer (get-buffer strokes-buffer-name)))
+ ;; FIXME: Same as above.
+ ;;(remove-hook 'select-frame-hook
+ ;; #'strokes-update-window-configuration)
+ )))
;;;; strokes-xpm stuff (later may be separate)...
diff --git a/lisp/subr.el b/lisp/subr.el
index 8ff403e1139..9c07606100b 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -61,7 +61,8 @@ must be the first non-whitespace on a line.
For more information, see Info node `(elisp)Declaring Functions'."
(declare (advertised-calling-convention
(fn file &optional arglist fileonly) nil))
- ;; Does nothing - byte-compile-declare-function does the work.
+ ;; Does nothing - `byte-compile-macroexpand-declare-function' does
+ ;; the work.
nil)
@@ -193,7 +194,7 @@ set earlier in the `setq-local'. The return value of the
"Define VAR as a buffer-local variable with default value VAL.
Like `defvar' but additionally marks the variable as being automatically
buffer-local wherever it is set."
- (declare (debug defvar) (doc-string 3))
+ (declare (debug defvar) (doc-string 3) (indent 2))
;; Can't use backquote here, it's too early in the bootstrap.
(list 'progn (list 'defvar var val docstring)
(list 'make-variable-buffer-local (list 'quote var))))
@@ -929,15 +930,29 @@ side-effects, and the argument LIST is not modified."
"Convert KEYS to the internal Emacs key representation.
KEYS should be a string in the format returned by commands such
as `C-h k' (`describe-key').
+
This is the same format used for saving keyboard macros (see
`edmacro-mode').
+Here's some example key sequences:
+
+ \"f\"
+ \"C-c C-c\"
+ \"H-<left>\"
+ \"M-RET\"
+ \"C-M-<return>\"
+
For an approximate inverse of this, see `key-description'."
- ;; Don't use a defalias, since the `pure' property is true only for
- ;; the calling convention of `kbd'.
(declare (pure t) (side-effect-free t))
- ;; A pure function is expected to preserve the match data.
- (save-match-data (read-kbd-macro keys)))
+ (let ((res (key-parse keys)))
+ (if (not (memq nil (mapcar (lambda (ch)
+ (and (numberp ch)
+ (<= 0 ch 127)))
+ res)))
+ ;; Return a string.
+ (concat (mapcar #'identity res))
+ ;; Return a vector.
+ res)))
(defun undefined ()
"Beep to tell the user this binding is undefined."
@@ -988,6 +1003,9 @@ PARENT if non-nil should be a keymap."
(defun define-key-after (keymap key definition &optional after)
"Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
+This is a legacy function; see `keymap-set-after' for the
+recommended function to use instead.
+
This is like `define-key' except that the binding for KEY is placed
just after the binding for the event AFTER, instead of at the beginning
of the map. Note that AFTER must be an event type (like KEY), NOT a command
@@ -1000,6 +1018,7 @@ Bindings are always added before any inherited map.
The order of bindings in a keymap matters only when it is used as
a menu, so this function is not useful for non-menu keymaps."
+ (declare (indent defun))
(unless after (setq after t))
(or (keymapp keymap)
(signal 'wrong-type-argument (list 'keymapp keymap)))
@@ -1157,6 +1176,9 @@ Subkeymaps may be modified but are not canonicalized."
(defun keyboard-translate (from to)
"Translate character FROM to TO on the current terminal.
+This is a legacy function; see `keymap-translate' for the
+recommended function to use instead.
+
This function creates a `keyboard-translate-table' if necessary
and then modifies one entry in it."
(or (char-table-p keyboard-translate-table)
@@ -1168,6 +1190,9 @@ and then modifies one entry in it."
(defun global-set-key (key command)
"Give KEY a global binding as COMMAND.
+This is a legacy function; see `keymap-global-set' for the
+recommended function to use instead.
+
COMMAND is the command definition to use; usually it is
a symbol naming an interactively-callable function.
KEY is a key sequence; noninteractively, it is a string or vector
@@ -1189,6 +1214,9 @@ that you make with this function."
(defun local-set-key (key command)
"Give KEY a local binding as COMMAND.
+This is a legacy function; see `keymap-local-set' for the
+recommended function to use instead.
+
COMMAND is the command definition to use; usually it is
a symbol naming an interactively-callable function.
KEY is a key sequence; noninteractively, it is a string or vector
@@ -1207,12 +1235,18 @@ cases is shared with all other buffers in the same major mode."
(defun global-unset-key (key)
"Remove global binding of KEY.
+This is a legacy function; see `keymap-global-unset' for the
+recommended function to use instead.
+
KEY is a string or vector representing a sequence of keystrokes."
(interactive "kUnset key globally: ")
(global-set-key key nil))
(defun local-unset-key (key)
"Remove local binding of KEY.
+This is a legacy function; see `keymap-local-unset' for the
+recommended function to use instead.
+
KEY is a string or vector representing a sequence of keystrokes."
(interactive "kUnset key locally: ")
(if (current-local-map)
@@ -1221,6 +1255,9 @@ KEY is a string or vector representing a sequence of keystrokes."
(defun local-key-binding (keys &optional accept-default)
"Return the binding for command KEYS in current local keymap only.
+This is a legacy function; see `keymap-local-binding' for the
+recommended function to use instead.
+
KEYS is a string or vector, a sequence of keystrokes.
The binding is probably a symbol with a function definition.
@@ -1232,6 +1269,9 @@ about this."
(defun global-key-binding (keys &optional accept-default)
"Return the binding for command KEYS in current global keymap only.
+This is a legacy function; see `keymap-global-binding' for the
+recommended function to use instead.
+
KEYS is a string or vector, a sequence of keystrokes.
The binding is probably a symbol with a function definition.
This function's return values are the same as those of `lookup-key'
@@ -1250,6 +1290,9 @@ about this."
(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
"Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
+This is a legacy function; see `keymap-substitute' for the
+recommended function to use instead.
+
In other words, OLDDEF is replaced with NEWDEF wherever it appears.
Alternatively, if optional fourth argument OLDMAP is specified, we redefine
in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP.
@@ -1511,22 +1554,22 @@ nil or (STRING . POSITION)'.
`posn-timestamp': The time the event occurred, in milliseconds.
For more information, see Info node `(elisp)Click Events'."
- (if (consp event) (nth 1 event)
- ;; Use `window-point' for the case when the current buffer
- ;; is temporarily switched to some other buffer (bug#50256)
- (or (posn-at-point (window-point))
- (list (selected-window) (window-point) '(0 . 0) 0))))
+ (or (and (consp event) (nth 1 event))
+ ;; Use `window-point' for the case when the current buffer
+ ;; is temporarily switched to some other buffer (bug#50256)
+ (posn-at-point (window-point))
+ (list (selected-window) (window-point) '(0 . 0) 0)))
(defun event-end (event)
"Return the ending position of EVENT.
EVENT should be a click, drag, or key press event.
See `event-start' for a description of the value returned."
- (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event)
- ;; Use `window-point' for the case when the current buffer
- ;; is temporarily switched to some other buffer (bug#50256)
- (or (posn-at-point (window-point))
- (list (selected-window) (window-point) '(0 . 0) 0))))
+ (or (and (consp event) (nth (if (consp (nth 2 event)) 2 1) event))
+ ;; Use `window-point' for the case when the current buffer
+ ;; is temporarily switched to some other buffer (bug#50256)
+ (posn-at-point (window-point))
+ (list (selected-window) (window-point) '(0 . 0) 0)))
(defsubst event-click-count (event)
"Return the multi-click count of EVENT, a click or drag event.
@@ -1752,6 +1795,7 @@ be a list of the form returned by `event-start' and `event-end'."
(make-obsolete 'window-redisplay-end-trigger nil "23.1")
(make-obsolete 'set-window-redisplay-end-trigger nil "23.1")
(make-obsolete-variable 'operating-system-release nil "28.1")
+(make-obsolete-variable 'inhibit-changing-match-data 'save-match-data "29.1")
(make-obsolete 'run-window-configuration-change-hook nil "27.1")
@@ -1868,7 +1912,7 @@ performance impact when running `add-hook' and `remove-hook'."
(when (or (get hook 'hook--depth-alist) (not (zerop depth)))
;; Note: The main purpose of the above `when' test is to avoid running
;; this `setf' before `gv' is loaded during bootstrap.
- (push (cons function depth) (get hook 'hook--depth-alist)))
+ (setf (alist-get function (get hook 'hook--depth-alist) 0) depth))
(setq hook-value
(if (< 0 depth)
(append hook-value (list function))
@@ -3077,7 +3121,7 @@ Optional argument CHARS, if non-nil, should be a list of characters;
the function will ignore any input that is not one of CHARS.
Optional argument HISTORY, if non-nil, should be a symbol that
specifies the history list variable to use for navigating in input
-history using `M-p' and `M-n', with `RET' to select a character from
+history using \\`M-p' and \\`M-n', with \\`RET' to select a character from
history.
If you bind the variable `help-form' to a non-nil value
while calling this function, then pressing `help-char'
@@ -3368,6 +3412,29 @@ user can undo the change normally."
(accept-change-group ,handle)
(cancel-change-group ,handle))))))
+(defmacro with-undo-amalgamate (&rest body)
+ "Like `progn' but perform BODY with amalgamated undo barriers.
+
+This allows multiple operations to be undone in a single step.
+When undo is disabled this behaves like `progn'."
+ (declare (indent 0) (debug t))
+ (let ((handle (make-symbol "--change-group-handle--")))
+ `(let ((,handle (prepare-change-group))
+ ;; Don't truncate any undo data in the middle of this,
+ ;; otherwise Emacs might truncate part of the resulting
+ ;; undo step: we want to mimic the behavior we'd get if the
+ ;; undo-boundaries were never added in the first place.
+ (undo-outer-limit nil)
+ (undo-limit most-positive-fixnum)
+ (undo-strong-limit most-positive-fixnum))
+ (unwind-protect
+ (progn
+ (activate-change-group ,handle)
+ ,@body)
+ (progn
+ (accept-change-group ,handle)
+ (undo-amalgamate-change-group ,handle))))))
+
(defun prepare-change-group (&optional buffer)
"Return a handle for the current buffer's state, for a change group.
If you specify BUFFER, make a handle for BUFFER's state instead.
@@ -3567,6 +3634,9 @@ If either NAME or VAL are specified, both should be specified."
(defvar suspend-resume-hook nil
"Normal hook run by `suspend-emacs', after Emacs is continued.")
+(defvar after-pdump-load-hook nil
+ "Normal hook run after loading the .pdmp file.")
+
(defvar temp-buffer-show-hook nil
"Normal hook run by `with-output-to-temp-buffer' after displaying the buffer.
When the hook runs, the temporary buffer is current, and the window it
@@ -3987,7 +4057,7 @@ BUFFER is the buffer (or buffer name) to associate with the process.
Process output goes at end of that buffer, unless you specify
an output stream or filter function to handle the output.
BUFFER may be also nil, meaning that this process is not associated
- with any buffer
+ with any buffer.
COMMAND is the shell command to run."
;; We used to use `exec' to replace the shell with the command,
;; but that failed to handle (...) and semicolon, etc.
@@ -4386,11 +4456,6 @@ is allowed once again. (Immediately, if `inhibit-quit' is nil.)"
;; that intends to handle the quit signal next time.
(eval '(ignore nil)))))
-;; Don't throw `throw-on-input' on those events by default.
-(setq while-no-input-ignore-events
- '(focus-in focus-out help-echo iconify-frame
- make-frame-visible selection-request))
-
(defmacro while-no-input (&rest body)
"Execute BODY only as long as there's no pending input.
If input arrives, that ends the execution of BODY,
@@ -4763,14 +4828,12 @@ wherever possible, since it is slow."
(defsubst looking-at-p (regexp)
"\
Same as `looking-at' except this function does not change the match data."
- (let ((inhibit-changing-match-data t))
- (looking-at regexp)))
+ (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."
- (let ((inhibit-changing-match-data t))
- (string-match regexp string start)))
+ (string-match regexp string start t))
(defun subregexp-context-p (regexp pos &optional start)
"Return non-nil if POS is in a normal subregexp context in REGEXP.
@@ -5575,6 +5638,7 @@ If HOOKVAR is nil, `mail-send-hook' is used.
The properties used on SYMBOL are `composefunc', `sendfunc',
`abortfunc', and `hookvar'."
+ (declare (indent defun))
(put symbol 'composefunc composefunc)
(put symbol 'sendfunc sendfunc)
(put symbol 'abortfunc (or abortfunc #'kill-buffer))
@@ -6462,4 +6526,145 @@ not a list, return a one-element list containing OBJECT."
object
(list object)))
+(defun define-keymap--compile (form &rest args)
+ ;; This compiler macro is only there for compile-time
+ ;; error-checking; it does not change the call in any way.
+ (while (and args
+ (keywordp (car args))
+ (not (eq (car args) :menu)))
+ (unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix))
+ (byte-compile-warn "Invalid keyword: %s" (car args)))
+ (setq args (cdr args))
+ (when (null args)
+ (byte-compile-warn "Uneven number of keywords in %S" form))
+ (setq args (cdr args)))
+ ;; Bindings.
+ (while args
+ (let ((key (pop args)))
+ (when (and (stringp key) (not (key-valid-p key)))
+ (byte-compile-warn "Invalid `kbd' syntax: %S" key)))
+ (when (null args)
+ (byte-compile-warn "Uneven number of key bindings in %S" form))
+ (setq args (cdr args)))
+ form)
+
+(defun define-keymap (&rest definitions)
+ "Create a new keymap and define KEY/DEFEFINITION pairs as key sequences.
+The new keymap is returned.
+
+Options can be given as keywords before the KEY/DEFEFINITION
+pairs. Available keywords are:
+
+:full If non-nil, create a chartable alist (see `make-keymap').
+ If nil (i.e., the default), create a sparse keymap (see
+ `make-sparse-keymap').
+
+:suppress If non-nil, the keymap will be suppressed (see `suppress-keymap').
+ If `nodigits', treat digits like other chars.
+
+:parent If non-nil, this should be a keymap to use as the parent
+ (see `set-keymap-parent').
+
+:keymap If non-nil, instead of creating a new keymap, the given keymap
+ will be destructively modified instead.
+
+:name If non-nil, this should be a string to use as the menu for
+ the keymap in case you use it as a menu with `x-popup-menu'.
+
+:prefix If non-nil, this should be a symbol to be used as a prefix
+ command (see `define-prefix-command'). If this is the case,
+ this symbol is returned instead of the map itself.
+
+KEY/DEFINITION pairs are as KEY and DEF in `keymap-set'. KEY can
+also be the special symbol `:menu', in which case DEFINITION
+should be a MENU form as accepted by `easy-menu-define'.
+
+\(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)"
+ (declare (indent defun)
+ (compiler-macro define-keymap--compile))
+ (let (full suppress parent name prefix keymap)
+ ;; Handle keywords.
+ (while (and definitions
+ (keywordp (car definitions))
+ (not (eq (car definitions) :menu)))
+ (let ((keyword (pop definitions)))
+ (unless definitions
+ (error "Missing keyword value for %s" keyword))
+ (let ((value (pop definitions)))
+ (pcase keyword
+ (:full (setq full value))
+ (:keymap (setq keymap value))
+ (:parent (setq parent value))
+ (:suppress (setq suppress value))
+ (:name (setq name value))
+ (:prefix (setq prefix value))
+ (_ (error "Invalid keyword: %s" keyword))))))
+
+ (when (and prefix
+ (or full parent suppress keymap))
+ (error "A prefix keymap can't be defined with :full/:parent/:suppress/:keymap keywords"))
+
+ (when (and keymap full)
+ (error "Invalid combination: :keymap with :full"))
+
+ (let ((keymap (cond
+ (keymap keymap)
+ (prefix (define-prefix-command prefix nil name))
+ (full (make-keymap name))
+ (t (make-sparse-keymap name)))))
+ (when suppress
+ (suppress-keymap keymap (eq suppress 'nodigits)))
+ (when parent
+ (set-keymap-parent keymap parent))
+
+ ;; Do the bindings.
+ (while definitions
+ (let ((key (pop definitions)))
+ (unless definitions
+ (error "Uneven number of key/definition pairs"))
+ (let ((def (pop definitions)))
+ (if (eq key :menu)
+ (easy-menu-define nil keymap "" def)
+ (keymap-set keymap key def)))))
+ keymap)))
+
+(defmacro defvar-keymap (variable-name &rest defs)
+ "Define VARIABLE-NAME as a variable with a keymap definition.
+See `define-keymap' for an explanation of the keywords and KEY/DEFINITION.
+
+In addition to the keywords accepted by `define-keymap', this
+macro also accepts a `:doc' keyword, which (if present) is used
+as the variable documentation string.
+
+\(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)"
+ (declare (indent 1))
+ (let ((opts nil)
+ doc)
+ (while (and defs
+ (keywordp (car defs))
+ (not (eq (car defs) :menu)))
+ (let ((keyword (pop defs)))
+ (unless defs
+ (error "Uneven number of keywords"))
+ (if (eq keyword :doc)
+ (setq doc (pop defs))
+ (push keyword opts)
+ (push (pop defs) opts))))
+ (unless (zerop (% (length defs) 2))
+ (error "Uneven number of key/definition pairs: %s" defs))
+ `(defvar ,variable-name
+ (define-keymap ,@(nreverse opts) ,@defs)
+ ,@(and doc (list doc)))))
+
+(defmacro with-delayed-message (args &rest body)
+ "Like `progn', but display MESSAGE if BODY takes longer than TIMEOUT seconds.
+The MESSAGE form will be evaluated immediately, but the resulting
+string will be displayed only if BODY takes longer than TIMEOUT seconds.
+
+\(fn (timeout message) &rest body)"
+ (declare (indent 1))
+ `(funcall-with-delayed-message ,(car args) ,(cadr args)
+ (lambda ()
+ ,@body)))
+
;;; subr.el ends here
diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el
index 68d28306dd9..07aa0f2d569 100644
--- a/lisp/tab-bar.el
+++ b/lisp/tab-bar.el
@@ -982,10 +982,11 @@ on the tab bar instead."
(wc-point . ,(point-marker))
(wc-bl . ,bl)
(wc-bbl . ,bbl)
- (wc-history-back . ,(gethash (or frame (selected-frame))
- tab-bar-history-back))
- (wc-history-forward . ,(gethash (or frame (selected-frame))
- tab-bar-history-forward))
+ ,@(when tab-bar-history-mode
+ `((wc-history-back . ,(gethash (or frame (selected-frame))
+ tab-bar-history-back))
+ (wc-history-forward . ,(gethash (or frame (selected-frame))
+ tab-bar-history-forward))))
;; Copy other possible parameters
,@(mapcan (lambda (param)
(unless (memq (car param)
@@ -1126,19 +1127,21 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar."
(when wc-bl (set-frame-parameter nil 'buffer-list wc-bl))
(when wc-bbl (set-frame-parameter nil 'buried-buffer-list wc-bbl))
- (puthash (selected-frame)
- (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)))
- wc-history-forward)
- tab-bar-history-forward)))
+ (when tab-bar-history-mode
+ (puthash (selected-frame)
+ (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)))
+ wc-history-forward)
+ tab-bar-history-forward))))
(ws
(window-state-put ws nil 'safe)))
- (setq tab-bar-history-omit t)
+ (when tab-bar-history-mode
+ (setq tab-bar-history-omit t))
(when from-index
(setf (nth from-index tabs) from-tab))
@@ -1193,7 +1196,9 @@ Interactively, ARG is the prefix numeric argument and defaults to 1."
Default values are tab names sorted by recency, so you can use \
\\<minibuffer-local-map>\\[next-history-element]
to get the name of the most recently visited tab, the second
-most recent, and so on."
+most recent, and so on.
+When the tab with that NAME doesn't exist, create a new tab
+and rename it to NAME."
(interactive
(let* ((recent-tabs (mapcar (lambda (tab)
(alist-get 'name tab))
@@ -1201,7 +1206,11 @@ most recent, and so on."
(list (completing-read (format-prompt "Switch to tab by name"
(car recent-tabs))
recent-tabs nil nil nil nil recent-tabs))))
- (tab-bar-select-tab (1+ (or (tab-bar--tab-index-by-name name) 0))))
+ (let ((tab-index (tab-bar--tab-index-by-name name)))
+ (if tab-index
+ (tab-bar-select-tab (1+ tab-index))
+ (tab-bar-new-tab)
+ (tab-bar-rename-tab name))))
(defalias 'tab-bar-select-tab-by-name 'tab-bar-switch-to-tab)
@@ -1388,6 +1397,11 @@ After the tab is created, the hooks in
;; `pushnew' handles the head of tabs but not frame-parameter
(tab-bar-tabs-set tabs))
+ (when tab-bar-history-mode
+ (puthash (selected-frame) nil tab-bar-history-back)
+ (puthash (selected-frame) nil tab-bar-history-forward)
+ (setq tab-bar-history-omit t))
+
(run-hook-with-args 'tab-bar-tab-post-open-functions
(nth to-index tabs)))
@@ -1803,30 +1817,34 @@ Interactively, prompt for GROUP-NAME."
(defvar tab-bar-history-old nil
"Window configuration before the current command.")
-(defvar tab-bar-history-old-minibuffer-depth 0
- "Minibuffer depth before the current command.")
+(defvar tab-bar-history-pre-command nil
+ "Command set to `this-command' by `pre-command-hook'.")
+
+(defvar tab-bar-history-done-command nil
+ "Command handled by `window-configuration-change-hook'.")
(defun tab-bar--history-pre-change ()
- (setq tab-bar-history-old-minibuffer-depth (minibuffer-depth))
- ;; Store window-configuration before possibly entering the minibuffer.
- (when (zerop tab-bar-history-old-minibuffer-depth)
+ ;; Reset before the command could set it
+ (setq tab-bar-history-omit nil)
+ (setq tab-bar-history-pre-command this-command)
+ (when (zerop (minibuffer-depth))
(setq tab-bar-history-old
`((wc . ,(current-window-configuration))
(wc-point . ,(point-marker))))))
(defun tab-bar--history-change ()
- (when (and (not tab-bar-history-omit)
- tab-bar-history-old
- ;; Store window-configuration before possibly entering
- ;; the minibuffer.
- (zerop tab-bar-history-old-minibuffer-depth))
+ (when (and (not tab-bar-history-omit) tab-bar-history-old
+ ;; Don't register changes performed by the same command
+ ;; repeated in sequence, such as incremental window resizing.
+ (not (eq tab-bar-history-done-command tab-bar-history-pre-command))
+ (zerop (minibuffer-depth)))
(puthash (selected-frame)
(seq-take (cons tab-bar-history-old
(gethash (selected-frame) tab-bar-history-back))
tab-bar-history-limit)
- tab-bar-history-back))
- (when tab-bar-history-omit
- (setq tab-bar-history-omit nil)))
+ tab-bar-history-back)
+ (setq tab-bar-history-old nil))
+ (setq tab-bar-history-done-command tab-bar-history-pre-command))
(defun tab-bar-history-back ()
"Restore a previous window configuration used in the current tab.
diff --git a/lisp/tab-line.el b/lisp/tab-line.el
index 5affae79138..af0647acf7c 100644
--- a/lisp/tab-line.el
+++ b/lisp/tab-line.el
@@ -792,7 +792,9 @@ Its effect is the same as using the `previous-buffer' command
(if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers)
(switch-to-prev-buffer window)
(with-selected-window (or window (selected-window))
- (let* ((tabs (funcall tab-line-tabs-function))
+ (let* ((tabs (seq-filter
+ (lambda (tab) (or (bufferp tab) (assq 'buffer tab)))
+ (funcall tab-line-tabs-function)))
(pos (seq-position
tabs (current-buffer)
(lambda (tab buffer)
@@ -816,7 +818,9 @@ Its effect is the same as using the `next-buffer' command
(if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers)
(switch-to-next-buffer window)
(with-selected-window (or window (selected-window))
- (let* ((tabs (funcall tab-line-tabs-function))
+ (let* ((tabs (seq-filter
+ (lambda (tab) (or (bufferp tab) (assq 'buffer tab)))
+ (funcall tab-line-tabs-function)))
(pos (seq-position
tabs (current-buffer)
(lambda (tab buffer)
@@ -893,7 +897,14 @@ sight of the tab line."
(define-minor-mode tab-line-mode
"Toggle display of tab line in the windows displaying the current buffer."
:lighter nil
- (setq tab-line-format (when tab-line-mode '(:eval (tab-line-format)))))
+ (let ((default-value '(:eval (tab-line-format))))
+ (if tab-line-mode
+ ;; Preserve the existing tab-line set outside of this mode
+ (unless tab-line-format
+ (setq tab-line-format default-value))
+ ;; Reset only values set by this mode
+ (when (equal tab-line-format default-value)
+ (setq tab-line-format nil)))))
(defcustom tab-line-exclude-modes
'(completion-list-mode)
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el
index db655619bed..0ca26f770c4 100644
--- a/lisp/tar-mode.el
+++ b/lisp/tar-mode.el
@@ -467,8 +467,8 @@ checksum before doing the check."
(defun tar-clip-time-string (time)
(declare (obsolete format-time-string "27.1"))
- (let ((str (current-time-string time)))
- (concat " " (substring str 4 16) (format-time-string " %Y" time))))
+ (let ((system-time-locale "C"))
+ (format-time-string " %b %e %H:%M %Y" time)))
(defun tar-grind-file-mode (mode)
"Construct a `rw-r--r--' string indicating MODE.
diff --git a/lisp/term.el b/lisp/term.el
index e76eb77647f..698bef08b2d 100644
--- a/lisp/term.el
+++ b/lisp/term.el
@@ -303,6 +303,7 @@
(require 'ange-ftp)
(require 'cl-lib))
(require 'comint) ; Password regexp.
+(require 'ansi-color)
(require 'ehelp)
(require 'ring)
(require 'shell)
@@ -710,13 +711,20 @@ Buffer local variable.")
(defvar term-ansi-at-save-pwd nil)
(defvar term-ansi-at-save-anon nil)
(defvar term-ansi-current-bold nil)
+(defvar term-ansi-current-faint nil)
+(defvar term-ansi-current-italic nil)
+(defvar term-ansi-current-underline nil)
+(defvar term-ansi-current-slow-blink nil)
+(defvar term-ansi-current-fast-blink nil)
(defvar term-ansi-current-color 0)
(defvar term-ansi-face-already-done nil)
(defvar term-ansi-current-bg-color 0)
-(defvar term-ansi-current-underline nil)
(defvar term-ansi-current-reverse nil)
(defvar term-ansi-current-invisible nil)
+(make-obsolete-variable 'term-ansi-face-already-done
+ "it doesn't have any effect." "29.1")
+
;;; Faces
(defvar ansi-term-color-vector
[term
@@ -765,12 +773,36 @@ Buffer local variable.")
:group 'term
:version "28.1")
+(defface term-faint
+ '((t :inherit ansi-color-faint))
+ "Default face to use for faint text."
+ :group 'term
+ :version "29.1")
+
+(defface term-italic
+ '((t :inherit ansi-color-italic))
+ "Default face to use for italic text."
+ :group 'term
+ :version "29.1")
+
(defface term-underline
'((t :inherit ansi-color-underline))
"Default face to use for underlined text."
:group 'term
:version "28.1")
+(defface term-slow-blink
+ '((t :inherit ansi-color-slow-blink))
+ "Default face to use for slowly blinking text."
+ :group 'term
+ :version "29.1")
+
+(defface term-fast-blink
+ '((t :inherit ansi-color-fast-blink))
+ "Default face to use for rapidly blinking text."
+ :group 'term
+ :version "29.1")
+
(defface term-color-black
'((t :inherit ansi-color-black))
"Face used to render black color code."
@@ -1034,15 +1066,15 @@ is buffer-local."
(defun term-ansi-reset ()
(setq term-current-face 'term)
- (setq term-ansi-current-underline nil)
(setq term-ansi-current-bold nil)
+ (setq term-ansi-current-faint nil)
+ (setq term-ansi-current-italic nil)
+ (setq term-ansi-current-underline nil)
+ (setq term-ansi-current-slow-blink nil)
+ (setq term-ansi-current-fast-blink nil)
(setq term-ansi-current-reverse nil)
(setq term-ansi-current-color 0)
(setq term-ansi-current-invisible nil)
- ;; Stefan thought this should be t, but could not remember why.
- ;; Setting it to t seems to cause bug#11785. Setting it to nil
- ;; again to see if there are other consequences...
- (setq term-ansi-face-already-done nil)
(setq term-ansi-current-bg-color 0))
(define-derived-mode term-mode fundamental-mode "Term"
@@ -1499,7 +1531,6 @@ commands to use in that buffer.
(getenv "ESHELL")
shell-file-name))))
(set-buffer (make-term "terminal" program))
- (term-mode)
(term-char-mode)
(switch-to-buffer "*terminal*"))
@@ -1581,10 +1612,12 @@ Using \"emacs\" loses, because bash disables editing if $TERM == emacs.")
:nd=\\E[C:up=\\E[A:ce=\\E[K:ho=\\E[H:pt\
:al=\\E[L:dl=\\E[M:DL=\\E[%%dM:AL=\\E[%%dL:cs=\\E[%%i%%d;%%dr:sf=^J\
:dc=\\E[P:DC=\\E[%%dP:IC=\\E[%%d@:im=\\E[4h:ei=\\E[4l:mi:\
+:mb=\\E[5m:mh=\\E[2m:ZR=\\E[23m:ZH=\\E[3m\
:so=\\E[7m:se=\\E[m:us=\\E[4m:ue=\\E[m:md=\\E[1m:mr=\\E[7m:me=\\E[m\
:UP=\\E[%%dA:DO=\\E[%%dB:LE=\\E[%%dD:RI=\\E[%%dC\
:kl=\\EOD:kd=\\EOB:kr=\\EOC:ku=\\EOA:kN=\\E[6~:kP=\\E[5~:@7=\\E[4~:kh=\\E[1~\
-:mk=\\E[8m:cb=\\E[1K:op=\\E[39;49m:Co#8:pa#64:AB=\\E[4%%dm:AF=\\E[3%%dm:cr=^M\
+:mk=\\E[8m:cb=\\E[1K:op=\\E[39;49m:Co#256:pa#32767\
+:AB=\\E[48;5;%%dm:AF=\\E[38;5;%%dm:cr=^M\
:bl=^G:do=^J:le=^H:ta=^I:se=\\E[27m:ue=\\E[24m\
:kb=^?:kD=^[[3~:sc=\\E7:rc=\\E8:r1=\\Ec:"
;; : -undefine ic
@@ -2375,7 +2408,14 @@ Checks if STRING contains a password prompt as defined by
(when (term-in-line-mode)
(when (let ((case-fold-search t))
(string-match comint-password-prompt-regexp string))
- (term-send-invisible (read-passwd string)))))
+ ;; Use `run-at-time' in order not to pause execution of the
+ ;; process filter with a minibuffer
+ (run-at-time
+ 0 nil
+ (lambda (current-buf)
+ (with-current-buffer current-buf
+ (term-send-invisible (read-passwd string))))
+ (current-buffer)))))
;;; Low-level process communication
@@ -3104,30 +3144,34 @@ See `term-prompt-regexp'."
(term-horizontal-column)
term-ansi-current-bg-color
term-ansi-current-bold
+ term-ansi-current-faint
+ term-ansi-current-italic
+ term-ansi-current-underline
+ term-ansi-current-slow-blink
+ term-ansi-current-fast-blink
term-ansi-current-color
term-ansi-current-invisible
term-ansi-current-reverse
- term-ansi-current-underline
term-current-face)))
(?8 ;; Restore cursor (terminfo: rc, [ctlseqs]
;; "DECRC").
(when term-saved-cursor
(term-goto (nth 0 term-saved-cursor)
(nth 1 term-saved-cursor))
- (setq term-ansi-current-bg-color
- (nth 2 term-saved-cursor)
- term-ansi-current-bold
- (nth 3 term-saved-cursor)
- term-ansi-current-color
- (nth 4 term-saved-cursor)
- term-ansi-current-invisible
- (nth 5 term-saved-cursor)
- term-ansi-current-reverse
- (nth 6 term-saved-cursor)
- term-ansi-current-underline
- (nth 7 term-saved-cursor)
- term-current-face
- (nth 8 term-saved-cursor))))
+ (pcase-setq
+ `( ,_ ,_
+ ,term-ansi-current-bg-color
+ ,term-ansi-current-bold
+ ,term-ansi-current-faint
+ ,term-ansi-current-italic
+ ,term-ansi-current-underline
+ ,term-ansi-current-slow-blink
+ ,term-ansi-current-fast-blink
+ ,term-ansi-current-color
+ ,term-ansi-current-invisible
+ ,term-ansi-current-reverse
+ ,term-current-face)
+ term-saved-cursor)))
(?c ;; \Ec - Reset (terminfo: rs1, [ctlseqs] "RIS").
;; This is used by the "clear" program.
(term-reset-terminal))
@@ -3285,133 +3329,141 @@ option is enabled. See `term-set-goto-process-mark'."
(setq term-current-row 0)
(setq term-current-column 1)
(term--reset-scroll-region)
- (setq term-insert-mode nil)
- ;; FIXME: No idea why this is here, it looks wrong. --Stef
- (setq term-ansi-face-already-done nil))
-
-(defun term--maybe-brighten-color (color bold)
- "Possibly convert COLOR to its bright variant.
-COLOR is an index into `ansi-term-color-vector'. If BOLD and
-`ansi-color-bold-is-bright' are non-nil and COLOR is a regular color,
-return the bright version of COLOR; otherwise, return COLOR."
- (if (and ansi-color-bold-is-bright bold (<= 1 color 8))
- (+ color 8)
- color))
+ (setq term-insert-mode nil))
+
+(defun term--color-as-hex (for-foreground)
+ "Return the current ANSI color as a hexadecimal color string.
+Use the current background color if FOR-FOREGROUND is nil,
+otherwise use the current foreground color."
+ (let ((color (if for-foreground term-ansi-current-color
+ term-ansi-current-bg-color)))
+ (or (ansi-color--code-as-hex (1- color))
+ (progn
+ (and ansi-color-bold-is-bright term-ansi-current-bold
+ (<= 1 color 8)
+ (setq color (+ color 8)))
+ (if for-foreground
+ (face-foreground (elt ansi-term-color-vector color)
+ nil 'default)
+ (face-background (elt ansi-term-color-vector color)
+ nil 'default))))))
;; New function to deal with ansi colorized output, as you can see you can
;; have any bold/underline/fg/bg/reverse combination. -mm
(defun term-handle-colors-array (parameter)
- (cond
-
- ;; Bold (terminfo: bold)
- ((eq parameter 1)
- (setq term-ansi-current-bold t))
-
- ;; Underline
- ((eq parameter 4)
- (setq term-ansi-current-underline t))
-
- ;; Blink (unsupported by Emacs), will be translated to bold.
- ;; This may change in the future though.
- ((eq parameter 5)
- (setq term-ansi-current-bold t))
-
- ;; Reverse (terminfo: smso)
- ((eq parameter 7)
- (setq term-ansi-current-reverse t))
-
- ;; Invisible
- ((eq parameter 8)
- (setq term-ansi-current-invisible t))
-
- ;; Reset underline (terminfo: rmul)
- ((eq parameter 24)
- (setq term-ansi-current-underline nil))
-
- ;; Reset reverse (terminfo: rmso)
- ((eq parameter 27)
- (setq term-ansi-current-reverse nil))
-
- ;; Foreground
- ((and (>= parameter 30) (<= parameter 37))
- (setq term-ansi-current-color (- parameter 29)))
-
- ;; Bright foreground
- ((and (>= parameter 90) (<= parameter 97))
- (setq term-ansi-current-color (- parameter 81)))
-
- ;; Reset foreground
- ((eq parameter 39)
- (setq term-ansi-current-color 0))
-
- ;; Background
- ((and (>= parameter 40) (<= parameter 47))
- (setq term-ansi-current-bg-color (- parameter 39)))
-
- ;; Bright foreground
- ((and (>= parameter 100) (<= parameter 107))
- (setq term-ansi-current-bg-color (- parameter 91)))
-
- ;; Reset background
- ((eq parameter 49)
- (setq term-ansi-current-bg-color 0))
-
- ;; 0 (Reset) or unknown (reset anyway)
- (t
- (term-ansi-reset)))
-
- ;; (message "Debug: U-%d R-%d B-%d I-%d D-%d F-%d B-%d"
- ;; term-ansi-current-underline
- ;; term-ansi-current-reverse
- ;; term-ansi-current-bold
- ;; term-ansi-current-invisible
- ;; term-ansi-face-already-done
- ;; term-ansi-current-color
- ;; term-ansi-current-bg-color)
-
- (unless term-ansi-face-already-done
- (let ((current-color (term--maybe-brighten-color
- term-ansi-current-color
- term-ansi-current-bold))
- (current-bg-color (term--maybe-brighten-color
- term-ansi-current-bg-color
- term-ansi-current-bold)))
- (if term-ansi-current-invisible
- (let ((color
- (if term-ansi-current-reverse
- (face-foreground
- (elt ansi-term-color-vector current-color)
- nil 'default)
- (face-background
- (elt ansi-term-color-vector current-bg-color)
- nil 'default))))
- (setq term-current-face
- (list :background color
- :foreground color))
- ) ;; No need to bother with anything else if it's invisible.
- (setq term-current-face
- (list :foreground
- (face-foreground
- (elt ansi-term-color-vector current-color)
- nil 'default)
- :background
- (face-background
- (elt ansi-term-color-vector current-bg-color)
- nil 'default)
- :inverse-video term-ansi-current-reverse))
-
- (when term-ansi-current-bold
- (setq term-current-face
- `(,term-current-face :inherit term-bold)))
-
- (when term-ansi-current-underline
- (setq term-current-face
- `(,term-current-face :inherit term-underline))))))
-
- ;; (message "Debug %S" term-current-face)
- ;; FIXME: shouldn't we set term-ansi-face-already-done to t here? --Stef
- (setq term-ansi-face-already-done nil))
+ (declare (obsolete term--handle-colors-list "29.1"))
+ (term--handle-colors-list (list parameter)))
+
+(defun term--handle-colors-list (parameters)
+ (while parameters
+ (pcase (pop parameters)
+ (1 (setq term-ansi-current-bold t)) ; (terminfo: bold)
+ (2 (setq term-ansi-current-faint t)) ; (terminfo: dim)
+ (3 (setq term-ansi-current-italic t)) ; (terminfo: sitm)
+ (4 (setq term-ansi-current-underline t)) ; (terminfo: smul)
+ (5 (setq term-ansi-current-slow-blink t)) ; (terminfo: blink)
+ (6 (setq term-ansi-current-fast-blink t))
+ (7 (setq term-ansi-current-reverse t)) ; (terminfo: smso, rev)
+ (8 (setq term-ansi-current-invisible t)) ; (terminfo: invis)
+ (21 (setq term-ansi-current-bold nil))
+ (22 (setq term-ansi-current-bold nil)
+ (setq term-ansi-current-faint nil))
+ (23 (setq term-ansi-current-italic nil)) ; (terminfo: ritm)
+ (24 (setq term-ansi-current-underline nil)) ; (terminfo: rmul)
+ (25 (setq term-ansi-current-slow-blink nil)
+ (setq term-ansi-current-fast-blink nil))
+ (27 (setq term-ansi-current-reverse nil)) ; (terminfo: rmso)
+
+ ;; Foreground (terminfo: setaf)
+ ((and param (guard (<= 30 param 37)))
+ (setq term-ansi-current-color (- param 29)))
+
+ ;; Bright foreground (terminfo: setaf)
+ ((and param (guard (<= 90 param 97)))
+ (setq term-ansi-current-color (- param 81)))
+
+ ;; Extended foreground (terminfo: setaf)
+ (38
+ (pcase (pop parameters)
+ ;; 256 color
+ (5 (if (setq term-ansi-current-color (pop parameters))
+ (cl-incf term-ansi-current-color)
+ (term-ansi-reset)))
+ ;; Full 24-bit color
+ (2 (cl-loop with color = (1+ 256) ; Base
+ for i from 16 downto 0 by 8
+ if (pop parameters)
+ do (setq color (+ color (ash it i)))
+ else return (term-ansi-reset)
+ finally
+ (if (> color (+ 1 256 #xFFFFFF))
+ (term-ansi-reset)
+ (setq term-ansi-current-color color))))
+ (_ (term-ansi-reset))))
+
+ ;; Reset foreground (terminfo: op)
+ (39 (setq term-ansi-current-color 0))
+
+ ;; Background (terminfo: setab)
+ ((and param (guard (<= 40 param 47)))
+ (setq term-ansi-current-bg-color (- param 39)))
+
+ ;; Bright background (terminfo: setab)
+ ((and param (guard (<= 100 param 107)))
+ (setq term-ansi-current-bg-color (- param 91)))
+
+ ;; Extended background (terminfo: setab)
+ (48
+ (pcase (pop parameters)
+ ;; 256 color
+ (5 (if (setq term-ansi-current-bg-color (pop parameters))
+ (cl-incf term-ansi-current-bg-color)
+ (term-ansi-reset)))
+ ;; Full 24-bit color
+ (2 (cl-loop with color = (1+ 256) ; Base
+ for i from 16 downto 0 by 8
+ if (pop parameters)
+ do (setq color (+ color (ash it i)))
+ else return (term-ansi-reset)
+ finally
+ (if (> color (+ 1 256 #xFFFFFF))
+ (term-ansi-reset)
+ (setq term-ansi-current-bg-color color))))
+ (_ (term-ansi-reset))))
+
+ ;; Reset background (terminfo: op)
+ (49 (setq term-ansi-current-bg-color 0))
+
+ ;; 0 (Reset) (terminfo: sgr0) or unknown (reset anyway)
+ (_ (term-ansi-reset))))
+
+ (let (fg bg)
+ (if term-ansi-current-invisible
+ (setq bg (term--color-as-hex term-ansi-current-reverse)
+ fg bg)
+ (setq fg (term--color-as-hex t)
+ bg (term--color-as-hex nil)))
+ (setq term-current-face
+ `( :foreground ,fg
+ :background ,bg
+ ,@(unless term-ansi-current-invisible
+ (list :inverse-video term-ansi-current-reverse)))))
+
+ (setq term-current-face
+ `(,term-current-face
+ ,@(when term-ansi-current-bold
+ '(term-bold))
+ ,@(when term-ansi-current-faint
+ '(term-faint))
+ ,@(when term-ansi-current-italic
+ '(term-italic))
+ ,@(when term-ansi-current-underline
+ '(term-underline))
+ ,@(when term-ansi-current-slow-blink
+ '(term-slow-blink))
+ ,@(when term-ansi-current-fast-blink
+ '(term-fast-blink)))))
;; Handle a character assuming (eq terminal-state 2) -
@@ -3497,9 +3549,9 @@ return the bright version of COLOR; otherwise, return COLOR."
;; Modified to allow ansi coloring -mm
;; \E[m - Set/reset modes, set bg/fg
- ;;(terminfo: smso,rmso,smul,rmul,rev,bold,sgr0,invis,op,setab,setaf)
+ ;;(terminfo: smso,rmso,smul,rmul,rev,bold,dim,sitm,ritm,blink,sgr0,invis,op,setab,setaf)
((eq char ?m)
- (mapc #'term-handle-colors-array params))
+ (term--handle-colors-list params))
;; \E[6n - Report cursor position (terminfo: u7)
((eq char ?n)
diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el
new file mode 100644
index 00000000000..3c4d00f7f99
--- /dev/null
+++ b/lisp/term/haiku-win.el
@@ -0,0 +1,139 @@
+;;; haiku-win.el --- set up windowing on Haiku -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021 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:
+
+;; Support for using Haiku's BeOS derived windowing system.
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+(unless (featurep 'haiku)
+ (error "%s: Loading haiku-win without having Haiku"
+ invocation-name))
+
+;; Documentation-purposes only: actually loaded in loadup.el.
+(require 'frame)
+(require 'mouse)
+(require 'scroll-bar)
+(require 'menu-bar)
+(require 'fontset)
+(require 'dnd)
+
+(add-to-list 'display-format-alist '(".*" . haiku-win))
+
+;;;; Command line argument handling.
+
+(defvar x-invocation-args)
+(defvar x-command-line-resources)
+
+(defvar haiku-initialized)
+
+(declare-function x-open-connection "haikufns.c")
+(declare-function x-handle-args "common-win")
+(declare-function haiku-selection-data "haikuselect.c")
+(declare-function haiku-selection-put "haikuselect.c")
+(declare-function haiku-selection-targets "haikuselect.c")
+(declare-function haiku-put-resource "haikufns.c")
+
+(defun haiku--handle-x-command-line-resources (command-line-resources)
+ "Handle command line X resources specified with the option `-xrm'.
+The resources should be a list of strings in COMMAND-LINE-RESOURCES."
+ (dolist (s command-line-resources)
+ (let ((components (split-string s ":")))
+ (when (car components)
+ (haiku-put-resource (car components)
+ (string-trim-left
+ (mapconcat #'identity (cdr components) ":")))))))
+
+(cl-defmethod window-system-initialization (&context (window-system haiku)
+ &optional display)
+ "Set up the window system. WINDOW-SYSTEM must be HAIKU.
+DISPLAY may be set to the name of a display that will be initialized."
+ (cl-assert (not haiku-initialized))
+
+ (create-default-fontset)
+ (when x-command-line-resources
+ (haiku--handle-x-command-line-resources
+ (split-string x-command-line-resources "\n")))
+ (x-open-connection (or display "be") x-command-line-resources t)
+ (setq haiku-initialized t))
+
+(cl-defmethod frame-creation-function (params &context (window-system haiku))
+ (x-create-frame-with-faces params))
+
+(cl-defmethod handle-args-function (args &context (window-system haiku))
+ (x-handle-args args))
+
+(defun haiku--selection-type-to-mime (type)
+ "Convert symbolic selection type TYPE to its MIME equivalent.
+If TYPE is nil, return \"text/plain\"."
+ (cond
+ ((memq type '(TEXT COMPOUND_TEXT STRING UTF8_STRING)) "text/plain")
+ ((stringp type) type)
+ ((symbolp type) (symbol-name type))
+ (t "text/plain")))
+
+(cl-defmethod gui-backend-get-selection (type data-type
+ &context (window-system haiku))
+ (if (eq data-type 'TARGETS)
+ (apply #'vector (mapcar #'intern
+ (haiku-selection-targets type)))
+ (haiku-selection-data type (haiku--selection-type-to-mime data-type))))
+
+(cl-defmethod gui-backend-set-selection (type value
+ &context (window-system haiku))
+ (haiku-selection-put type "text/plain" value t))
+
+(cl-defmethod gui-backend-selection-exists-p (selection
+ &context (window-system haiku))
+ (haiku-selection-data selection "text/plain"))
+
+(cl-defmethod gui-backend-selection-owner-p (_
+ &context (window-system haiku))
+ t)
+
+(declare-function haiku-read-file-name "haikufns.c")
+
+(defun x-file-dialog (prompt dir default_filename mustmatch only_dir_p)
+ "SKIP: real doc in xfns.c."
+ (if (eq (framep-on-display (selected-frame)) 'haiku)
+ (haiku-read-file-name prompt (selected-frame)
+ (or dir (and default_filename
+ (file-name-directory default_filename)))
+ mustmatch only_dir_p
+ (file-name-nondirectory default_filename))
+ (error "x-file-dialog on a tty frame")))
+
+(defun haiku-dnd-handle-drag-n-drop-event (event)
+ "Handle specified drag-n-drop EVENT."
+ (interactive "e")
+ (let* ((string (caddr event))
+ (window (posn-window (event-start event))))
+ (with-selected-window window
+ (raise-frame)
+ (dnd-handle-one-url window 'private (concat "file:" string)))))
+
+(define-key special-event-map [drag-n-drop]
+ 'haiku-dnd-handle-drag-n-drop-event)
+
+(provide 'haiku-win)
+(provide 'term/haiku-win)
+
+;;; haiku-win.el ends here
diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el
index 1a3811a37c2..67a417c1161 100644
--- a/lisp/term/ns-win.el
+++ b/lisp/term/ns-win.el
@@ -867,10 +867,10 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
;; For Darwin nothing except UTF-8 makes sense.
(when (eq system-type 'darwin)
(add-hook 'before-init-hook
- #'(lambda ()
- (setq locale-coding-system 'utf-8-unix)
- (setq default-process-coding-system
- '(utf-8-unix . utf-8-unix)))))
+ (lambda ()
+ (setq locale-coding-system 'utf-8-unix)
+ (setq default-process-coding-system
+ '(utf-8-unix . utf-8-unix)))))
;; Mac OS X Lion introduces PressAndHold, which is unsupported by this port.
;; See this thread for more details:
diff --git a/lisp/term/pgtk-win.el b/lisp/term/pgtk-win.el
new file mode 100644
index 00000000000..bd925a01299
--- /dev/null
+++ b/lisp/term/pgtk-win.el
@@ -0,0 +1,516 @@
+;;; xterm.el --- define function key sequences and standard colors for xterm -*- lexical-binding: t -*-
+
+;; Copyright (C) 1995, 2001-2020 Free Software Foundation, Inc.
+
+;; Author: FSF
+;; Keywords: terminals
+
+;; 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:
+(eval-when-compile (require 'cl-lib))
+(or (featurep 'pgtk)
+ (error "%s: Loading pgtk-win.el but not compiled for pure Gtk+-3."
+ invocation-name))
+
+;; Documentation-purposes only: actually loaded in loadup.el.
+(require 'term/common-win)
+(require 'frame)
+(require 'mouse)
+(require 'scroll-bar)
+(require 'faces)
+(require 'menu-bar)
+(require 'fontset)
+(require 'dnd)
+
+(defgroup pgtk nil
+ "Pure-GTK specific features."
+ :group 'environment)
+
+;;;; Command line argument handling.
+
+(defvar x-invocation-args)
+;; Set in term/common-win.el; currently unused by Gtk's x-open-connection.
+(defvar x-command-line-resources)
+
+;; pgtkterm.c.
+(defvar pgtk-input-file)
+
+(declare-function pgtk-use-im-context "pgtkim.c")
+(defvar pgtk-use-im-context-on-new-connection)
+
+(defun pgtk-handle-nxopen (_switch &optional temp)
+ (setq unread-command-events (append unread-command-events
+ (if temp '(pgtk-open-temp-file)
+ '(pgtk-open-file)))
+ pgtk-input-file (append pgtk-input-file (list (pop x-invocation-args)))))
+
+(defun pgtk-handle-nxopentemp (switch)
+ (pgtk-handle-nxopen switch t))
+
+(defun pgtk-ignore-1-arg (_switch)
+ (setq x-invocation-args (cdr x-invocation-args)))
+
+;;;; File handling.
+
+(declare-function pgtk-hide-emacs "pgtkfns.c" (on))
+
+
+(defun pgtk-drag-n-drop (event &optional new-frame force-text)
+ "Edit the files listed in the drag-n-drop EVENT.
+Switch to a buffer editing the last file dropped."
+ (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)
+(global-set-key [C-drag-n-drop] 'pgtk-drag-n-drop-other-frame)
+(global-set-key [M-drag-n-drop] 'pgtk-drag-n-drop-as-text)
+(global-set-key [C-M-drag-n-drop] 'pgtk-drag-n-drop-as-text-other-frame)
+
+;;;; Frame-related functions.
+
+;; pgtkterm.c
+(defvar pgtk-alternate-modifier)
+(defvar pgtk-right-alternate-modifier)
+(defvar pgtk-right-command-modifier)
+(defvar pgtk-right-control-modifier)
+
+;; You say tomAYto, I say tomAHto..
+(with-no-warnings
+ (defvaralias 'pgtk-option-modifier 'pgtk-alternate-modifier)
+ (defvaralias 'pgtk-right-option-modifier 'pgtk-right-alternate-modifier))
+
+(defun pgtk-do-hide-emacs ()
+ (interactive)
+ (pgtk-hide-emacs t))
+
+(declare-function pgtk-hide-others "pgtkfns.c" ())
+
+(defun pgtk-do-hide-others ()
+ (interactive)
+ (pgtk-hide-others))
+
+(declare-function pgtk-emacs-info-panel "pgtkfns.c" ())
+
+(defun pgtk-do-emacs-info-panel ()
+ (interactive)
+ (pgtk-emacs-info-panel))
+
+(defun pgtk-next-frame ()
+ "Switch to next visible frame."
+ (interactive)
+ (other-frame 1))
+
+(defun pgtk-prev-frame ()
+ "Switch to previous visible frame."
+ (interactive)
+ (other-frame -1))
+
+;; Frame will be focused anyway, so select it
+;; (if this is not done, mode line is dimmed until first interaction)
+;; FIXME: Sounds like we're working around a bug in the underlying code.
+(add-hook 'after-make-frame-functions 'select-frame)
+
+(defvar tool-bar-mode)
+(declare-function tool-bar-mode "tool-bar" (&optional arg))
+
+;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ;
+;; see https://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html .
+(defun pgtk-toggle-toolbar (&optional frame)
+ "Switches the tool bar on and off in frame FRAME.
+ If FRAME is nil, the change applies to the selected frame."
+ (interactive)
+ (modify-frame-parameters
+ frame (list (cons 'tool-bar-lines
+ (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0)
+ 0 1)) ))
+ (if (not tool-bar-mode) (tool-bar-mode t)))
+
+
+;;;; Dialog-related functions.
+
+;; Ask user for confirm before printing. Due to Kevin Rodgers.
+(defun pgtk-print-buffer ()
+ "Interactive front-end to `print-buffer': asks for user confirmation first."
+ (interactive)
+ (if (and (called-interactively-p 'interactive)
+ (or (listp last-nonmenu-event)
+ (and (char-or-string-p (event-basic-type last-command-event))
+ (memq 'super (event-modifiers last-command-event)))))
+ (let ((last-nonmenu-event (if (listp last-nonmenu-event)
+ last-nonmenu-event
+ ;; Fake it:
+ `(mouse-1 POSITION 1))))
+ (if (y-or-n-p (format "Print buffer %s? " (buffer-name)))
+ (print-buffer)
+ (error "Canceled")))
+ (print-buffer)))
+
+;;;; Font support.
+
+;; Needed for font listing functions under both backend and normal
+(setq scalable-fonts-allowed t)
+
+;; Default fontset. This is mainly here to show how a fontset
+;; can be set up manually. Ordinarily, fontsets are auto-created whenever
+;; a font is chosen by
+(defvar pgtk-standard-fontset-spec
+ ;; Only some code supports this so far, so use uglier XLFD version
+ ;; "-pgtk-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai"
+ (mapconcat 'identity
+ '("-*-Monospace-*-*-*-*-10-*-*-*-*-*-fontset-standard"
+ "latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1")
+ ",")
+ "String of fontset spec of the standard fontset.
+This defines a fontset consisting of the Courier and other fonts.
+See the documentation of `create-fontset-from-fontset-spec' for the format.")
+
+
+;;;; Pasteboard support.
+
+(define-obsolete-function-alias 'pgtk-store-cut-buffer-internal
+ 'gui-set-selection "24.1")
+
+
+(defun pgtk-copy-including-secondary ()
+ (interactive)
+ (call-interactively 'kill-ring-save)
+ (gui-set-selection 'SECONDARY (buffer-substring (point) (mark t))))
+
+(defun pgtk-paste-secondary ()
+ (interactive)
+ (insert (gui-get-selection 'SECONDARY)))
+
+
+(defun pgtk-suspend-error ()
+ ;; Don't allow suspending if any of the frames are PGTK frames.
+ (if (memq 'pgtk (mapcar 'window-system (frame-list)))
+ (error "Cannot suspend Emacs while a PGTK GUI frame exists")))
+
+
+
+(defvar pgtk-initialized nil
+ "Non-nil if pure-GTK windowing has been initialized.")
+
+(declare-function x-handle-args "common-win" (args))
+(declare-function x-open-connection "pgtkfns.c"
+ (display &optional xrm-string must-succeed))
+(declare-function pgtk-set-resource "pgtkfns.c" (owner name value))
+
+;; Do the actual pure-GTK Windows setup here; the above code just
+;; defines functions and variables that we use now.
+(cl-defmethod window-system-initialization (&context (window-system pgtk)
+ &optional display)
+ "Initialize Emacs for pure-GTK windowing."
+ (cl-assert (not pgtk-initialized))
+
+ ;; PENDING: not needed?
+ (setq command-line-args (x-handle-args command-line-args))
+
+ ;; Make sure we have a valid resource name.
+ (or (stringp x-resource-name)
+ (let (i)
+ (setq x-resource-name (copy-sequence invocation-name))
+
+ ;; Change any . or * characters in x-resource-name to hyphens,
+ ;; so as not to choke when we use it in X resource queries.
+ (while (setq i (string-match "[.*]" x-resource-name))
+ (aset x-resource-name i ?-))))
+
+ ;; Setup the default fontset.
+ (create-default-fontset)
+ ;; Create the standard fontset.
+ (condition-case err
+ (create-fontset-from-fontset-spec pgtk-standard-fontset-spec t)
+ (error (display-warning
+ 'initialization
+ (format "Creation of the standard fontset failed: %s" err)
+ :error)))
+
+ (x-open-connection (or display
+ x-display-name)
+ x-command-line-resources
+ ;; Exit Emacs with fatal error if this fails and we
+ ;; are the initial display.
+ (= (length (frame-list)) 0))
+
+ (x-apply-session-resources)
+
+ ;; Don't let Emacs suspend under PGTK.
+ (add-hook 'suspend-hook 'pgtk-suspend-error)
+
+ (setq pgtk-initialized t))
+
+;; Any display name is OK.
+(add-to-list 'display-format-alist '(".*" . pgtk))
+(cl-defmethod handle-args-function (args &context (window-system pgtk))
+ (x-handle-args args))
+
+(cl-defmethod frame-creation-function (params &context (window-system pgtk))
+ (x-create-frame-with-faces params))
+
+(declare-function pgtk-own-selection-internal "pgtkselect.c" (selection value &optional frame))
+(declare-function pgtk-disown-selection-internal "pgtkselect.c" (selection &optional time_object terminal))
+(declare-function pgtk-selection-owner-p "pgtkselect.c" (&optional selection terminal))
+(declare-function pgtk-selection-exists-p "pgtkselect.c" (&optional selection terminal))
+(declare-function pgtk-get-selection-internal "pgtkselect.c" (selection-symbol target-type &optional time_stamp terminal))
+
+(cl-defmethod gui-backend-set-selection (selection value
+ &context (window-system pgtk))
+ (if value (pgtk-own-selection-internal selection value)
+ (pgtk-disown-selection-internal selection)))
+
+(cl-defmethod gui-backend-selection-owner-p (selection
+ &context (window-system pgtk))
+ (pgtk-selection-owner-p selection))
+
+(cl-defmethod gui-backend-selection-exists-p (selection
+ &context (window-system pgtk))
+ (pgtk-selection-exists-p selection))
+
+(cl-defmethod gui-backend-get-selection (selection-symbol target-type
+ &context (window-system pgtk))
+ (pgtk-get-selection-internal selection-symbol target-type))
+
+
+(defvar pgtk-preedit-overlay nil)
+
+(defun pgtk-preedit-text (event)
+ "An internal function to display preedit text from input method.
+
+EVENT is an event of PGTK_PREEDIT_TEXT_EVENT.
+It contains colors and texts."
+ (interactive "e")
+ (when pgtk-preedit-overlay
+ (delete-overlay pgtk-preedit-overlay))
+ (setq pgtk-preedit-overlay nil)
+
+ (let ((ovstr "")
+ (idx 0)
+ atts ov str color face-name)
+ (dolist (part (nth 1 event))
+ (setq str (car part))
+ (setq face-name (intern (format "pgtk-im-%d" idx)))
+ (eval
+ `(defface ,face-name nil "face of input method preedit"))
+ (setq atts nil)
+ (when (setq color (cdr-safe (assq 'fg (cdr part))))
+ (setq atts (append atts `(:foreground ,color))))
+ (when (setq color (cdr-safe (assq 'bg (cdr part))))
+ (setq atts (append atts `(:background ,color))))
+ (when (setq color (cdr-safe (assq 'ul (cdr part))))
+ (setq atts (append atts `(:underline ,color))))
+ (face-spec-set face-name `((t . ,atts)))
+ (add-text-properties 0 (length str) `(face ,face-name) str)
+ (setq ovstr (concat ovstr str))
+ (setq idx (1+ idx)))
+
+ (setq ov (make-overlay (point) (point)))
+ (overlay-put ov 'before-string ovstr)
+ (setq pgtk-preedit-overlay ov)))
+
+
+(add-hook 'after-init-hook
+ (function
+ (lambda ()
+ (when (eq window-system 'pgtk)
+ (pgtk-use-im-context pgtk-use-im-context-on-new-connection)))))
+
+
+;;;
+
+(defcustom x-gtk-stock-map
+ (mapcar (lambda (arg)
+ (cons (purecopy (car arg)) (purecopy (cdr arg))))
+ '(
+ ("etc/images/new" . ("document-new" "gtk-new"))
+ ("etc/images/open" . ("document-open" "gtk-open"))
+ ("etc/images/diropen" . "n:system-file-manager")
+ ("etc/images/close" . ("window-close" "gtk-close"))
+ ("etc/images/save" . ("document-save" "gtk-save"))
+ ("etc/images/saveas" . ("document-save-as" "gtk-save-as"))
+ ("etc/images/undo" . ("edit-undo" "gtk-undo"))
+ ("etc/images/cut" . ("edit-cut" "gtk-cut"))
+ ("etc/images/copy" . ("edit-copy" "gtk-copy"))
+ ("etc/images/paste" . ("edit-paste" "gtk-paste"))
+ ("etc/images/search" . ("edit-find" "gtk-find"))
+ ("etc/images/print" . ("document-print" "gtk-print"))
+ ("etc/images/preferences" . ("preferences-system" "gtk-preferences"))
+ ("etc/images/help" . ("help-browser" "gtk-help"))
+ ("etc/images/left-arrow" . ("go-previous" "gtk-go-back"))
+ ("etc/images/right-arrow" . ("go-next" "gtk-go-forward"))
+ ("etc/images/home" . ("go-home" "gtk-home"))
+ ("etc/images/jump-to" . ("go-jump" "gtk-jump-to"))
+ ("etc/images/index" . ("gtk-search" "gtk-index"))
+ ("etc/images/exit" . ("application-exit" "gtk-quit"))
+ ("etc/images/cancel" . "gtk-cancel")
+ ("etc/images/info" . ("dialog-information" "gtk-info"))
+ ("etc/images/bookmark_add" . "n:bookmark_add")
+ ;; Used in Gnus and/or MH-E:
+ ("etc/images/attach" . ("mail-attachment" "gtk-attach"))
+ ("etc/images/connect" . "gtk-connect")
+ ("etc/images/contact" . "gtk-contact")
+ ("etc/images/delete" . ("edit-delete" "gtk-delete"))
+ ("etc/images/describe" . ("document-properties" "gtk-properties"))
+ ("etc/images/disconnect" . "gtk-disconnect")
+ ;; ("etc/images/exit" . "gtk-exit")
+ ("etc/images/lock-broken" . "gtk-lock_broken")
+ ("etc/images/lock-ok" . "gtk-lock_ok")
+ ("etc/images/lock" . "gtk-lock")
+ ("etc/images/next-page" . "gtk-next-page")
+ ("etc/images/refresh" . ("view-refresh" "gtk-refresh"))
+ ("etc/images/search-replace" . "edit-find-replace")
+ ("etc/images/sort-ascending" . ("view-sort-ascending" "gtk-sort-ascending"))
+ ("etc/images/sort-column-ascending" . "gtk-sort-column-ascending")
+ ("etc/images/sort-criteria" . "gtk-sort-criteria")
+ ("etc/images/sort-descending" . ("view-sort-descending"
+ "gtk-sort-descending"))
+ ("etc/images/sort-row-ascending" . "gtk-sort-row-ascending")
+ ("etc/images/spell" . ("tools-check-spelling" "gtk-spell-check"))
+ ("images/gnus/toggle-subscription" . "gtk-task-recurring")
+ ("images/mail/compose" . ("mail-message-new" "gtk-mail-compose"))
+ ("images/mail/copy" . "gtk-mail-copy")
+ ("images/mail/forward" . "gtk-mail-forward")
+ ("images/mail/inbox" . "gtk-inbox")
+ ("images/mail/move" . "gtk-mail-move")
+ ("images/mail/not-spam" . "gtk-not-spam")
+ ("images/mail/outbox" . "gtk-outbox")
+ ("images/mail/reply-all" . "gtk-mail-reply-to-all")
+ ("images/mail/reply" . "gtk-mail-reply")
+ ("images/mail/save-draft" . "gtk-mail-handling")
+ ("images/mail/send" . ("mail-send" "gtk-mail-send"))
+ ("images/mail/spam" . "gtk-spam")
+ ;; Used for GDB Graphical Interface
+ ("images/gud/break" . "gtk-no")
+ ("images/gud/recstart" . ("media-record" "gtk-media-record"))
+ ("images/gud/recstop" . ("media-playback-stop" "gtk-media-stop"))
+ ;; No themed versions available:
+ ;; mail/preview (combining stock_mail and stock_zoom)
+ ;; mail/save (combining stock_mail, stock_save and stock_convert)
+ ))
+ "How icons for tool bars are mapped to Gtk+ stock items.
+Emacs must be compiled with the Gtk+ toolkit for this to have any effect.
+A value that begins with n: denotes a named icon instead of a stock icon."
+ :version "22.2"
+ :type '(choice (repeat
+ (choice symbol
+ (cons (string :tag "Emacs icon")
+ (choice (group (string :tag "Named")
+ (string :tag "Stock"))
+ (string :tag "Stock/named"))))))
+ :group 'pgtk)
+
+(defcustom icon-map-list '(x-gtk-stock-map)
+ "A list of alists that map icon file names to stock/named icons.
+The alists are searched in the order they appear. The first match is used.
+The keys in the alists are file names without extension and with two directory
+components. For example, to map /usr/share/emacs/22.1.1/etc/images/open.xpm
+to stock item gtk-open, use:
+
+ (\"etc/images/open\" . \"gtk-open\")
+
+Themes also have named icons. To map to one of those, use n: before the name:
+
+ (\"etc/images/diropen\" . \"n:system-file-manager\")
+
+The list elements are either the symbol name for the alist or the
+alist itself.
+
+If you don't want stock icons, set the variable to nil."
+ :version "22.2"
+ :type '(choice (const :tag "Don't use stock icons" nil)
+ (repeat (choice symbol
+ (cons (string :tag "Emacs icon")
+ (string :tag "Stock/named")))))
+ :group 'pgtk)
+
+(defconst x-gtk-stock-cache (make-hash-table :weakness t :test 'equal))
+
+(defun x-gtk-map-stock (file)
+ "Map icon with file name FILE to a Gtk+ stock name.
+This uses `icon-map-list' to map icon file names to stock icon names."
+ (when (stringp file)
+ (or (gethash file x-gtk-stock-cache)
+ (puthash
+ file
+ (save-match-data
+ (let* ((file-sans (file-name-sans-extension file))
+ (key (and (string-match "/\\([^/]+/[^/]+/[^/]+$\\)"
+ file-sans)
+ (match-string 1 file-sans)))
+ (icon-map icon-map-list)
+ elem value)
+ (while (and (null value) icon-map)
+ (setq elem (car icon-map)
+ value (assoc-string (or key file-sans)
+ (if (symbolp elem)
+ (symbol-value elem)
+ elem))
+ icon-map (cdr icon-map)))
+ (and value (cdr value))))
+ x-gtk-stock-cache))))
+
+(declare-function accelerate-menu "pgtkmenu.c" (&optional frame) t)
+
+(defun pgtk-menu-bar-open (&optional frame)
+ "Open the menu bar if it is shown.
+`popup-menu' is used if it is off."
+ (interactive "i")
+ (cond
+ ((and (not (zerop (or (frame-parameter nil 'menu-bar-lines) 0)))
+ (fboundp 'accelerate-menu))
+ (accelerate-menu frame))
+ (t
+ (popup-menu (mouse-menu-bar-map) last-nonmenu-event))))
+
+(provide 'pgtk-win)
+(provide 'term/pgtk-win)
+
+;;; pgtk-win.el ends here
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el
index 5d1dc606676..0ee010b6c87 100644
--- a/lisp/term/w32-win.el
+++ b/lisp/term/w32-win.el
@@ -274,6 +274,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
'(gif "libgif-6.dll" "giflib5.dll" "gif.dll")
'(gif "libgif-5.dll" "giflib4.dll" "libungif4.dll" "libungif.dll")))
'(svg "librsvg-2-2.dll")
+ '(webp "libwebp-7.dll" "libwebp.dll")
+ '(sqlite3 "libsqlite3-0.dll")
'(gdk-pixbuf "libgdk_pixbuf-2.0-0.dll")
'(glib "libglib-2.0-0.dll")
'(gio "libgio-2.0-0.dll")
diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el
index c42286e5bc3..25f0c35aa5d 100644
--- a/lisp/textmodes/artist.el
+++ b/lisp/textmodes/artist.el
@@ -2840,9 +2840,8 @@ Returns a list of strings."
(if (memq system-type '(windows-nt ms-dos))
(artist-figlet-get-font-list-windows)
(artist-figlet-get-font-list)))
- (font (completing-read (concat "Select font (default "
- artist-figlet-default-font
- "): ")
+ (font (completing-read (format-prompt "Select font"
+ artist-figlet-default-font)
(mapcar
(lambda (font) (cons font font))
avail-fonts))))
diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el
index 237a1d99353..2dd4e8e7af0 100644
--- a/lisp/textmodes/bibtex.el
+++ b/lisp/textmodes/bibtex.el
@@ -839,6 +839,24 @@ for a new entry."
("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
("url") ("urldate")))
+ ("PhdThesis" "PhD Thesis"
+ (("author")
+ ("title" "Title of the PhD thesis")
+ ("school" "School where the PhD thesis was written")
+ ("year"))
+ nil
+ (("type" "Type of the PhD thesis")
+ ("address" "Address of the school (if not part of field \"school\") or country")
+ ("month") ("note")))
+ ("TechReport" "Technical Report"
+ (("author")
+ ("title" "Title of the technical report (BibTeX converts it to lowercase)")
+ ("institution" "Sponsoring institution of the report")
+ ("year"))
+ nil
+ (("type" "Type of the report (if other than \"technical report\")")
+ ("number" "Number of the technical report")
+ ("address") ("month") ("note")))
("Unpublished" "Unpublished"
(("author") ("title") ("date" nil nil 1) ("year" nil nil -1))
nil
@@ -4317,8 +4335,6 @@ for a crossref key, t otherwise."
(eqb (goto-char pos))
(t (set-buffer buffer) (goto-char pos)))
pos))
-;; backward compatibility
-(defalias 'bibtex-find-crossref 'bibtex-search-crossref)
(defun bibtex-dist (pos beg end)
"Return distance between POS and region delimited by BEG and END."
@@ -4381,8 +4397,6 @@ A prefix arg negates the value of `bibtex-search-entry-globally'."
(if display (bibtex-reposition-window)))
(display (message "Key `%s' not found" key)))
pnt)))
-;; backward compatibility
-(defalias 'bibtex-find-entry 'bibtex-search-entry)
(defun bibtex-prepare-new-entry (index)
"Prepare a new BibTeX entry with index INDEX.
@@ -5608,5 +5622,8 @@ If APPEND is non-nil, append ENTRIES to those already displayed."
(setq buffer-read-only t)
(goto-char (point-min)))
+(define-obsolete-function-alias 'bibtex-find-crossref #'bibtex-search-crossref "29.1")
+(define-obsolete-function-alias 'bibtex-find-entry #'bibtex-search-entry "29.1")
+
(provide 'bibtex)
;;; bibtex.el ends here
diff --git a/lisp/textmodes/etc-authors-mode.el b/lisp/textmodes/etc-authors-mode.el
index 8b5fefd3b7d..a79a1ecf4bb 100644
--- a/lisp/textmodes/etc-authors-mode.el
+++ b/lisp/textmodes/etc-authors-mode.el
@@ -115,12 +115,10 @@ With a prefix arg ARG, move point that many authors backward."
(interactive "p" etc-authors-mode)
(etc-authors-next-author (- arg)))
-(defvar etc-authors-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "n" #'etc-authors-next-author)
- (define-key map "p" #'etc-authors-prev-author)
- map)
- "Keymap for `etc-authors-mode'.")
+(defvar-keymap etc-authors-mode-map
+ :doc "Keymap for `etc-authors-mode'."
+ "n" #'etc-authors-next-author
+ "p" #'etc-authors-prev-author)
;;;###autoload
(define-derived-mode etc-authors-mode special-mode "Authors View"
diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el
index decce88573b..4e161099cd6 100644
--- a/lisp/textmodes/fill.el
+++ b/lisp/textmodes/fill.el
@@ -396,12 +396,8 @@ and `fill-nobreak-invisible'."
(save-excursion
(skip-chars-backward " ")
(and (eq (preceding-char) ?.)
- (looking-at " \\([^ ]\\|$\\)"))))
- ;; Another approach to the same problem.
- (save-excursion
- (skip-chars-backward " ")
- (and (eq (preceding-char) ?.)
- (not (progn (forward-char -1) (looking-at (sentence-end))))))
+ ;; There's something more after the space.
+ (looking-at " [^ \n]"))))
;; Don't split a line if the rest would look like a new paragraph.
(unless use-hard-newlines
(save-excursion
@@ -709,7 +705,10 @@ space does not end a sentence, so don't break a line there."
(goto-char from-plus-indent))
(if (not (> to (point)))
- nil ;; There is no paragraph, only whitespace: exit now.
+ ;; There is no paragraph, only whitespace: exit now.
+ (progn
+ (set-marker to nil)
+ nil)
(or justify (setq justify (current-justification)))
@@ -795,6 +794,7 @@ space does not end a sentence, so don't break a line there."
;; Leave point after final newline.
(goto-char to)
(unless (eobp) (forward-char 1))
+ (set-marker to nil)
;; Return the fill-prefix we used
fill-prefix)))
diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el
index 258e5fde674..2a9cae29f79 100644
--- a/lisp/textmodes/flyspell.el
+++ b/lisp/textmodes/flyspell.el
@@ -2270,17 +2270,8 @@ If OPOINT is non-nil, restore point there after adjusting it for replacement."
;;*---------------------------------------------------------------------*/
(defun flyspell-emacs-popup (event poss word)
"The Emacs popup menu."
- (if (and (not event)
- (display-mouse-p))
- (let* ((mouse-pos (mouse-position))
- (mouse-pos (if (nth 1 mouse-pos)
- mouse-pos
- (set-mouse-position (car mouse-pos)
- (/ (frame-width) 2) 2)
- (mouse-position))))
- (setq event (list (list (car (cdr mouse-pos))
- (1+ (cdr (cdr mouse-pos))))
- (car mouse-pos)))))
+ (unless event
+ (setq event (popup-menu-normalize-position (point))))
(let* ((corrects (flyspell-sort (car (cdr (cdr poss))) word))
(cor-menu (if (consp corrects)
(mapcar (lambda (correct)
diff --git a/lisp/textmodes/glyphless-mode.el b/lisp/textmodes/glyphless-mode.el
new file mode 100644
index 00000000000..177ba42c9c8
--- /dev/null
+++ b/lisp/textmodes/glyphless-mode.el
@@ -0,0 +1,68 @@
+;;; glyphless-mode.el --- minor mode for displaying glyphless characters -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Maintainer: emacs-devel@gnu.org
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(defcustom glyphless-mode-types '(all)
+ "Which glyphless characters to display.
+The value can be any of the groups supported by
+`glyphless-char-display-control' (which see), and in addition
+`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)
+ (const :tag "Bidirectional Control" bidi-control)
+ (const :tag "Variation Selectors" variation-selectors)
+ (const :tag "No Font" no-font)))
+ :group 'display)
+
+;;;###autoload
+(define-minor-mode glyphless-display-mode
+ "Minor mode for displaying glyphless characters in the current buffer.
+If enabled, all glyphless characters will be displayed as boxes
+that display their acronyms."
+ :lighter " Glyphless"
+ (if glyphless-display-mode
+ (progn
+ (setq-local glyphless-char-display
+ (let ((table (make-display-table)))
+ (set-char-table-parent table glyphless-char-display)
+ table))
+ (glyphless-mode--setup))
+ (kill-local-variable 'glyphless-char-display)))
+
+(defun glyphless-mode--setup ()
+ (let ((types (if (memq 'all glyphless-mode-types)
+ '(c0-control c1-control format-control
+ variation-selectors no-font)
+ glyphless-mode-types)))
+ (when types
+ (update-glyphless-char-display
+ nil (mapcar (lambda (e) (cons e 'acronym)) types)))))
+
+(provide 'glyphless-mode)
+
+;;; glyphless-mode.el ends here
diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el
index 0a3a49d868a..754ecb3a1d7 100644
--- a/lisp/textmodes/ispell.el
+++ b/lisp/textmodes/ispell.el
@@ -2398,24 +2398,24 @@ Global `ispell-quit' set to start location to continue spell session."
Selections are:
-DIGIT: Replace the word with a digit offered in the *Choices* buffer.
-SPC: Accept word this time.
-`i': Accept word and insert into private dictionary.
-`a': Accept word for this session.
-`A': Accept word and place in `buffer-local dictionary'.
-`r': Replace word with typed-in value. Rechecked.
-`R': Replace word with typed-in value. Query-replaced in buffer. Rechecked.
-`?': Show these commands.
-`x': Exit spelling buffer. Move cursor to original point.
-`X': Exit spelling buffer. Leaves cursor at the current point, and permits
+\\`0'..\\`9' Replace the word with a digit offered in the *Choices* buffer.
+\\`SPC' Accept word this time.
+\\`i' Accept word and insert into private dictionary.
+\\`a' Accept word for this session.
+\\`A' Accept word and place in `buffer-local dictionary'.
+\\`r' Replace word with typed-in value. Rechecked.
+\\`R' Replace word with typed-in value. Query-replaced in buffer. Rechecked.
+\\`?' Show these commands.
+\\`x' Exit spelling buffer. Move cursor to original point.
+\\`X' Exit spelling buffer. Leaves cursor at the current point, and permits
the aborted check to be completed later.
-`q': Quit spelling session (Kills ispell process).
-`l': Look up typed-in replacement in alternate dictionary. Wildcards okay.
-`u': Like `i', but the word is lower-cased first.
-`m': Place typed-in value in personal dictionary, then recheck current word.
-`C-l': Redraw screen.
-`C-r': Recursive edit.
-`C-z': Suspend Emacs or iconify frame."
+\\`q' Quit spelling session (Kills ispell process).
+\\`l' Look up typed-in replacement in alternate dictionary. Wildcards okay.
+\\`u' Like \\`i', but the word is lower-cased first.
+\\`m' Place typed-in value in personal dictionary, then recheck current word.
+\\`C-l' Redraw screen.
+\\`C-r' Recursive edit.
+\\`C-z' Suspend Emacs or iconify frame."
(if (equal ispell-help-in-bufferp 'electric)
(progn
@@ -2428,26 +2428,28 @@ SPC: Accept word this time.
;;(if (< (window-height) 15)
;; (enlarge-window
;; (- 15 (ispell-adjusted-window-height))))
- (princ "Selections are:
-
-DIGIT: Replace the word with a digit offered in the *Choices* buffer.
-SPC: Accept word this time.
-`i': Accept word and insert into private dictionary.
-`a': Accept word for this session.
-`A': Accept word and place in `buffer-local dictionary'.
-`r': Replace word with typed-in value. Rechecked.
-`R': Replace word with typed-in value. Query-replaced in buffer. Rechecked.
-`?': Show these commands.
-`x': Exit spelling buffer. Move cursor to original point.
-`X': Exit spelling buffer. Leaves cursor at the current point, and permits
- the aborted check to be completed later.
-`q': Quit spelling session (Kills ispell process).
-`l': Look up typed-in replacement in alternate dictionary. Wildcards okay.
-`u': Like `i', but the word is lower-cased first.
-`m': Place typed-in value in personal dictionary, then recheck current word.
-`C-l': Redraw screen.
-`C-r': Recursive edit.
-`C-z': Suspend Emacs or iconify frame.")
+ (princ
+ (substitute-command-keys
+ "Selections are:
+
+\\`0'..\\`9' Replace the word with a digit offered in the *Choices* buffer.
+\\`SPC' Accept word this time.
+\\`i' Accept word and insert into private dictionary.
+\\`a' Accept word for this session.
+\\`A' Accept word and place in `buffer-local dictionary'.
+\\`r' Replace word with typed-in value. Rechecked.
+\\`R' Replace word with typed-in value. Query-replaced in buffer. Rechecked.
+\\`?' Show these commands.
+\\`x' Exit spelling buffer. Move cursor to original point.
+\\`X' Exit spelling buffer. Leaves cursor at the current point, and permits
+ the aborted check to be completed later.
+\\`q' Quit spelling session (Kills ispell process).
+\\`l' Look up typed-in replacement in alternate dictionary. Wildcards okay.
+\\`u' Like \\`i', but the word is lower-cased first.
+\\`m' Place typed-in value in personal dictionary, then recheck current word.
+\\`C-l' Redraw screen.
+\\`C-r' Recursive edit.
+\\`C-z' Suspend Emacs or iconify frame."))
nil)))
@@ -3883,8 +3885,8 @@ Don't check spelling of message headers except the Subject field.
Don't check included messages.
To abort spell checking of a message region and send the message anyway,
-use the `x' command. (Any subsequent regions will be checked.)
-The `X' command aborts sending the message so that you can edit the buffer.
+use the \\`x' command. (Any subsequent regions will be checked.)
+The \\`X' command aborts sending the message so that you can edit the buffer.
To spell-check whenever a message is sent, include the appropriate lines
in your init file:
@@ -3975,7 +3977,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to
(if (re-search-forward "^Subject: *" end-of-headers t)
(progn
(goto-char (match-end 0))
- (if (and (not (looking-at ".*Re\\>"))
+ (if (and (not (looking-at ".*\\<Re\\>"))
(not (looking-at "\\[")))
(progn
(setq case-fold-search old-case-fold-search)
diff --git a/lisp/textmodes/pixel-fill.el b/lisp/textmodes/pixel-fill.el
new file mode 100644
index 00000000000..0a0f0eb8b66
--- /dev/null
+++ b/lisp/textmodes/pixel-fill.el
@@ -0,0 +1,240 @@
+;;; pixel-fill.el --- variable pitch filling functions -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Maintainer: emacs-devel@gnu.org
+;; Keywords: filling
+
+;; 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 main entry point is `pixel-fill-region', but
+;; `pixel-fill-find-fill-point' can also be useful by itself.
+
+;;; Code:
+
+(require 'kinsoku)
+
+(defgroup pixel-fill nil
+ "Filling based on pixel widths."
+ :group 'fill
+ :version "29.1")
+
+(defcustom pixel-fill-respect-kinsoku t
+ "If nil, fill even if we can't find a good kinsoku point.
+Kinsoku is a Japanese word meaning a rule that should not be violated.
+In Emacs, it is a term used for characters, e.g. punctuation marks,
+parentheses, and so on, that should not be placed in the beginning
+of a line or the end of a line."
+ :type 'boolean
+ :version "29.1")
+
+(defun pixel-fill-width (&optional columns window)
+ "Return the pixel width corresponding to COLUMNS in WINDOW.
+If COLUMNS in nil, use the enture window width.
+
+If WINDOW is nil, this defaults to the current window."
+ (unless window
+ (setq window (selected-window)))
+ (let ((frame (window-frame window)))
+ (if columns
+ (* (frame-char-width frame) columns)
+ (- (window-body-width nil t)
+ (* 2 (frame-char-width frame))
+ ;; We need to adjust the available width for when the user
+ ;; disables the fringes, which will cause the display
+ ;; engine usurp one column for the continuation glyph.
+ (if (and (fboundp 'fringe-columns)
+ (or (not (zerop (fringe-columns 'right)))
+ (not (zerop (fringe-columns 'left)))))
+ 0
+ (* (frame-char-width frame) 2))
+ 1))))
+
+(defun pixel-fill-region (start end pixel-width)
+ "Fill the region between START and END.
+This will attempt to reformat the text in the region to have no
+lines that are visually wider than PIXEL-WIDTH.
+
+If START isn't at the start of a line, the horizontal position of
+START, converted to pixel units, will be used as the indentation
+prefix on subsequent lines."
+ (save-excursion
+ (goto-char start)
+ (let ((indentation
+ (car (window-text-pixel-size nil (line-beginning-position)
+ (point))))
+ (newline-end nil))
+ (when (> indentation pixel-width)
+ (error "The indentation (%s) is wider than the fill width (%s)"
+ indentation pixel-width))
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-max))
+ (when (looking-back "\n[ \t]*" (point-min))
+ (setq newline-end t))
+ (goto-char (point-min))
+ ;; First replace all whitespace with space.
+ (while (re-search-forward "[ \t\n]+" nil t)
+ (cond
+ ((or (= (match-beginning 0) start)
+ (= (match-end 0) end))
+ (delete-region (match-beginning 0) (match-end 0)))
+ ;; If there's just a single space here, don't replace.
+ ((not (and (= (- (match-end 0) (match-beginning 0)) 1)
+ (= (char-after (match-beginning 0)) ?\s)))
+ (replace-match
+ ;; We need to use a space that has an appropriate width.
+ (propertize " " 'face
+ (get-text-property (match-beginning 0) 'face))))))
+ (goto-char start)
+ (pixel-fill--fill-line pixel-width indentation)
+ (goto-char (point-max))
+ (when newline-end
+ (insert "\n"))))))
+
+(defun pixel-fill--goto-pixel (width)
+ (vertical-motion (cons (/ width (frame-char-width)) 0)))
+
+(defun pixel-fill--fill-line (width &optional indentation)
+ (let ((start (point)))
+ (pixel-fill--goto-pixel width)
+ (while (not (eolp))
+ ;; We have to do some folding. First find the first previous
+ ;; point suitable for folding.
+ (when (or (not (pixel-fill-find-fill-point (line-beginning-position)))
+ (= (point) start))
+ ;; We had unbreakable text (for this width), so just go to
+ ;; the first space and carry on.
+ (beginning-of-line)
+ (skip-chars-forward " ")
+ (search-forward " " (line-end-position) 'move))
+ (when (= (preceding-char) ?\s)
+ (delete-char -1))
+ (unless (eobp)
+ (insert ?\n)
+ (when (> indentation 0)
+ (insert (propertize " " 'display
+ (list 'space :align-to (list indentation))))))
+ (setq start (point))
+ (unless (eobp)
+ (pixel-fill--goto-pixel width)))))
+
+(define-inline pixel-fill--char-breakable-p (char)
+ "Return non-nil if a line can be broken before and after CHAR."
+ (inline-quote (aref fill-find-break-point-function-table ,char)))
+
+(define-inline pixel-fill--char-nospace-p (char)
+ "Return non-nil if no space is required before and after CHAR."
+ (inline-quote (aref fill-nospace-between-words-table ,char)))
+
+(define-inline pixel-fill--char-kinsoku-bol-p (char)
+ "Return non-nil if a line ought not to begin with CHAR."
+ (inline-letevals (char)
+ (inline-quote (and (not (eq ,char ?'))
+ (aref (char-category-set ,char) ?>)))))
+
+(define-inline pixel-fill--char-kinsoku-eol-p (char)
+ "Return non-nil if a line ought not to end with CHAR."
+ (inline-quote (aref (char-category-set ,char) ?<)))
+
+(defun pixel-fill-find-fill-point (start)
+ "Find a place suitable for breaking the current line.
+START should be the earliest buffer position that should be considered
+(typically the start of the line), and this function will search
+backward in the current buffer from the current position."
+ (let ((bp (point))
+ (end (point))
+ failed)
+ (while (not
+ (or (setq failed (<= (point) start))
+ (eq (preceding-char) ?\s)
+ (eq (following-char) ?\s)
+ (pixel-fill--char-breakable-p (preceding-char))
+ (pixel-fill--char-breakable-p (following-char))
+ (and (pixel-fill--char-kinsoku-bol-p (preceding-char))
+ (pixel-fill--char-breakable-p (following-char))
+ (not (pixel-fill--char-kinsoku-bol-p (following-char))))
+ (pixel-fill--char-kinsoku-eol-p (following-char))
+ (bolp)))
+ (backward-char 1))
+ (if failed
+ ;; There's no breakable point, so we give it up.
+ (let (found)
+ (goto-char bp)
+ ;; Don't overflow the window edge, even if
+ ;; `pixel-fill-respect-kinsoku' is t.
+ (when pixel-fill-respect-kinsoku
+ (while (setq found (re-search-forward
+ "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
+ (line-end-position) 'move)))
+ (if (and found
+ (not (match-beginning 1)))
+ (goto-char (match-beginning 0)))))
+ (or
+ (eolp)
+ ;; Don't put kinsoku-bol characters at the beginning of a line,
+ ;; or kinsoku-eol characters at the end of a line.
+ (cond
+ ;; Don't overflow the window edge, even if `pixel-fill-respect-kinsoku'
+ ;; is t.
+ ((not pixel-fill-respect-kinsoku)
+ (while (and (not (eq (preceding-char) ?\s))
+ (or (pixel-fill--char-kinsoku-eol-p (preceding-char))
+ (pixel-fill--char-kinsoku-bol-p (following-char))))
+ (backward-char 1))
+ (when (setq failed (<= (point) start))
+ ;; There's no breakable point that doesn't violate kinsoku,
+ ;; so we look for the second best position.
+ (while (and (progn
+ (forward-char 1)
+ (<= (point) end))
+ (progn
+ (setq bp (point))
+ (pixel-fill--char-kinsoku-eol-p (following-char)))))
+ (goto-char bp)))
+ ((pixel-fill--char-kinsoku-eol-p (preceding-char))
+ ;; Find backward the point where kinsoku-eol characters begin.
+ (let ((count 4))
+ (while
+ (progn
+ (backward-char 1)
+ (and (> (setq count (1- count)) 0)
+ (not (eq (preceding-char) ?\s))
+ (or (pixel-fill--char-kinsoku-eol-p (preceding-char))
+ (pixel-fill--char-kinsoku-bol-p (following-char)))))))
+ (when (setq failed (<= (point) start))
+ ;; There's no breakable point that doesn't violate kinsoku,
+ ;; so we go to the second best position.
+ (if (looking-at "\\(\\c<+\\)\\c<")
+ (goto-char (match-end 1))
+ (forward-char 1))))
+ ((pixel-fill--char-kinsoku-bol-p (following-char))
+ ;; Find forward the point where kinsoku-bol characters end.
+ (let ((count 4))
+ (while (progn
+ (forward-char 1)
+ (and (>= (setq count (1- count)) 0)
+ (pixel-fill--char-kinsoku-bol-p (following-char))
+ (pixel-fill--char-breakable-p (following-char))))))))
+ (when (eq (following-char) ?\s)
+ (forward-char 1))))
+ (not failed)))
+
+(provide 'pixel-fill)
+
+;;; pixel-fill.el ends here
diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el
index b90c21339cc..f787f5f3e56 100644
--- a/lisp/textmodes/reftex-global.el
+++ b/lisp/textmodes/reftex-global.el
@@ -148,8 +148,10 @@ No active TAGS table is required."
(erase-buffer)
(insert " MULTIPLE LABELS IN CURRENT DOCUMENT:\n")
(insert
- " Move point to label and type `r' to run a query-replace on the label\n"
- " and its references. Type `q' to exit this buffer.\n\n")
+ (substitute-command-keys
+ " Move point to label and type \\`r' to run a query-replace on the label\n")
+ (substitute-command-keys
+ " and its references. Type \\`q' to exit this buffer.\n\n"))
(insert " LABEL FILE\n")
(insert " -------------------------------------------------------------\n")
(use-local-map (make-sparse-keymap))
diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el
index 9d9eab4d7b5..357f7da2f9d 100644
--- a/lisp/textmodes/reftex-index.el
+++ b/lisp/textmodes/reftex-index.el
@@ -29,9 +29,7 @@
(require 'reftex)
-;; START remove for XEmacs release
(defvar TeX-master)
-;; END remove for XEmacs release
;;;###autoload
(defun reftex-index-selection-or-word (&optional arg phrase)
diff --git a/lisp/textmodes/reftex-parse.el b/lisp/textmodes/reftex-parse.el
index c521a07f192..b8c75cb21b6 100644
--- a/lisp/textmodes/reftex-parse.el
+++ b/lisp/textmodes/reftex-parse.el
@@ -345,7 +345,17 @@ of master file."
;; Find external document specifications
(goto-char 1)
- (while (re-search-forward "[\n\r][ \t]*\\\\externaldocument\\(\\[\\([^]]*\\)\\]\\)?{\\([^}]+\\)}" nil t)
+ (while (re-search-forward
+ (concat "[\n\r][ \t]*"
+ ;; Support \externalcitedocument macro
+ "\\\\external\\(?:cite\\)?document"
+ ;; The optional prefix
+ "\\(\\[\\([^]]*\\)\\]\\)?"
+ ;; The 2nd opt. arg can only be nocite
+ "\\(?:\\[nocite\\]\\)?"
+ ;; Mandatory file argument
+ "{\\([^}]+\\)}")
+ nil t)
(push (list 'xr-doc (reftex-match-string 2)
(reftex-match-string 3))
docstruct))
diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el
index d57a7678553..dedd74607ae 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -70,12 +70,16 @@
("tabwindow" ?f nil nil 1)))
(rotating "Sidewaysfigure and table"
- (("sidewaysfigure" ?f nil nil caption)
- ("sidewaystable" ?t nil nil caption)))
+ (("sidewaysfigure" ?f nil nil caption)
+ ("sidewaysfigure*" ?f nil nil caption)
+ ("sidewaystable" ?t nil nil caption)
+ ("sidewaystable*" ?t nil nil caption)))
- (sidecap "CSfigure and SCtable"
- (("SCfigure" ?f nil nil caption)
- ("SCtable" ?t nil nil caption)))
+ (sidecap "SCfigure and SCtable"
+ (("SCfigure" ?f nil nil caption)
+ ("SCfigure*" ?f nil nil caption)
+ ("SCtable" ?t nil nil caption)
+ ("SCtable*" ?t nil nil caption)))
(subfigure "Subfigure environments/macro"
(("subfigure" ?f nil nil caption)
@@ -392,19 +396,19 @@ that the *toc* window fills half the frame."
(defcustom reftex-toc-include-file-boundaries nil
"Non-nil means, include file boundaries in *toc* buffer.
-This flag can be toggled from within the *toc* buffer with the `F' key."
+This flag can be toggled from within the *toc* buffer with the \\`F' key."
:group 'reftex-table-of-contents-browser
:type 'boolean)
(defcustom reftex-toc-include-labels nil
"Non-nil means, include labels in *toc* buffer.
-This flag can be toggled from within the *toc* buffer with the `l' key."
+This flag can be toggled from within the *toc* buffer with the \\`l' key."
:group 'reftex-table-of-contents-browser
:type 'boolean)
(defcustom reftex-toc-include-index-entries nil
"Non-nil means, include index entries in *toc* buffer.
-This flag can be toggled from within the *toc* buffer with the `i' key."
+This flag can be toggled from within the *toc* buffer with the \\`i' key."
:group 'reftex-table-of-contents-browser
:type 'boolean)
@@ -422,14 +426,14 @@ changed."
(defcustom reftex-toc-include-context nil
"Non-nil means, include context with labels in the *toc* buffer.
Context will only be shown when labels are visible as well.
-This flag can be toggled from within the *toc* buffer with the `c' key."
+This flag can be toggled from within the *toc* buffer with the \\`c' key."
:group 'reftex-table-of-contents-browser
:type 'boolean)
(defcustom reftex-toc-follow-mode nil
"Non-nil means, point in *toc* buffer will cause other window to follow.
The other window will show the corresponding part of the document.
-This flag can be toggled from within the *toc* buffer with the `f' key."
+This flag can be toggled from within the *toc* buffer with the \\`f' key."
:group 'reftex-table-of-contents-browser
:type 'boolean)
@@ -1627,14 +1631,14 @@ to that section."
(defcustom reftex-index-include-context nil
"Non-nil means, display the index definition context in the index buffer.
-This flag may also be toggled from the index buffer with the `c' key."
+This flag may also be toggled from the index buffer with the \\`c' key."
:group 'reftex-index-support
:type 'boolean)
(defcustom reftex-index-follow-mode nil
"Non-nil means, point in *Index* buffer will cause other window to follow.
The other window will show the corresponding part of the document.
-This flag can be toggled from within the *Index* buffer with the `f' key."
+This flag can be toggled from within the *Index* buffer with the \\`f' key."
:group 'reftex-table-of-contents-browser
:type 'boolean)
@@ -1863,10 +1867,11 @@ of the regular expressions in this list, that file is not parsed by RefTeX."
(defcustom reftex-enable-partial-scans nil
"Non-nil means, re-parse only 1 file when asked to re-parse.
Re-parsing is normally requested with a \\[universal-argument] prefix to many RefTeX commands,
-or with the `r' key in menus. When this option is t in a multifile document,
+or with the \\`r' key in menus. When this option is t in a multifile document,
we will only parse the current buffer, or the file associated with the label
or section heading near point in a menu. Requesting re-parsing of an entire
-multifile document then requires a \\[universal-argument] \\[universal-argument] prefix or the capital `R' key
+multifile document then requires a \\[universal-argument] \
+\\[universal-argument] prefix or the capital \\`R' key
in menus."
:group 'reftex-optimizations-for-large-documents
:type 'boolean)
@@ -1912,7 +1917,7 @@ when new labels in its category are added. See the variable
When a new label is defined with `reftex-label', all selection buffers
associated with that label category are emptied, in order to force an
update upon next use. When nil, the buffers are left alone and have to be
-updated by hand, with the `g' key from the label selection process.
+updated by hand, with the \\`g' key from the label selection process.
The value of this variable will only have any effect when
`reftex-use-multiple-selection-buffers' is non-nil."
:group 'reftex-optimizations-for-large-documents
@@ -1964,7 +1969,7 @@ instead or as well. The variable may have one of these values:
both Both cursor and mouse trigger highlighting.
Changing this variable requires rebuilding the selection and *toc* buffers
-to become effective (keys `g' or `r')."
+to become effective (keys \\`g' or \\`r')."
:group 'reftex-fontification-configurations
:type '(choice
(const :tag "Never" nil)
diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el
index 7ef8161ab5c..dedc3882199 100644
--- a/lisp/textmodes/sgml-mode.el
+++ b/lisp/textmodes/sgml-mode.el
@@ -440,7 +440,8 @@ These have to be run via `sgml-syntax-propertize'"))
;; internal
(defvar sgml-face-tag-alist ()
- "Alist of face and tag name for facemenu.")
+ "Alist of face and tag name for facemenu.
+The tag name can be a string or a list of strings.")
(defvar sgml-tag-face-alist ()
"Tag names and face or list of faces to fontify with when invisible.
@@ -528,11 +529,13 @@ an optional alist of possible values."
(comment-indent-new-line soft)))
(defun sgml-mode-facemenu-add-face-function (face _end)
- (let ((tag-face (cdr (assq face sgml-face-tag-alist))))
+ "Add \"face\" tags with `facemenu-keymap' commands."
+ (let ((tag-face (ensure-list (cdr (assq face sgml-face-tag-alist)))))
(cond (tag-face
(setq tag-face (funcall skeleton-transformation-function tag-face))
- (setq facemenu-end-add-face (concat "</" tag-face ">"))
- (concat "<" tag-face ">"))
+ (setq facemenu-end-add-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))
@@ -1868,6 +1871,7 @@ This takes effect when first loading the library.")
(defvar html-face-tag-alist
'((bold . "strong")
(italic . "em")
+ (bold-italic . ("strong" "em"))
(underline . "u")
(mode-line . "rev"))
"Value of `sgml-face-tag-alist' for HTML mode.")
@@ -2411,6 +2415,8 @@ To work around that, do:
(setq-local css-id-list-function #'html-current-buffer-ids))
(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)
(setq-local sgml-empty-tags
;; From HTML-4.01's loose.dtd, parsed with
@@ -2426,6 +2432,30 @@ To work around that, do:
;; (setq imenu-sort-function nil) ; sorting the menu defeats the purpose
)
+(defun html-mode--html-yank-handler (_type html)
+ (save-restriction
+ (insert html)
+ (ignore-errors
+ (sgml-pretty-print (point-min) (point-max)))))
+
+(defun html-mode--image-yank-handler (type image)
+ (let ((file (read-file-name (format "Save %s image to: " type))))
+ (when (file-directory-p file)
+ (user-error "%s is a directory"))
+ (when (and (file-exists-p file)
+ (not (yes-or-no-p (format "%s exists; overwrite?" file))))
+ (user-error "%s exists"))
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert image)
+ (write-region (point-min) (point-max) file))
+ (insert (format "<img src=%S>\n" (file-relative-name file)))
+ (insert-image
+ (create-image file (mailcap-mime-type-to-extension type) nil
+ :max-width 200
+ :max-height 200)
+ " ")))
+
(defvar html-imenu-regexp
"\\s-*<h\\([1-9]\\)[^\n<>]*>\\(<[^\n<>]*>\\)*\\s-*\\([^\n<>]*\\)"
"A regular expression matching a head line to be added to the menu.
diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el
index fef5ad2c7ac..ca99d562e40 100644
--- a/lisp/textmodes/table.el
+++ b/lisp/textmodes/table.el
@@ -1195,6 +1195,21 @@ executing body forms.")
(easy-menu-add-item (current-global-map)
'("menu-bar" "tools") table-global-menu-map)
+;;;###autoload
+(define-minor-mode table-fixed-width-mode
+ "Cell width is fixed when this is non-nil.
+Normally it should be nil for allowing automatic cell width expansion
+that widens a cell when it is necessary. When non-nil, typing in a
+cell does not automatically expand the cell width. A word that is too
+long to fit in a cell is chopped into multiple lines. The chopped
+location is indicated by `table-word-continuation-char'. This
+variable's value can be toggled by \\[table-fixed-width-mode] at
+run-time."
+ :tag "Fix Cell Width"
+ :group 'table
+ (table--finish-delayed-tasks)
+ (table--update-cell-face))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Macros
@@ -1219,43 +1234,49 @@ original buffer's point is moved to the location that corresponds to
the last cache point coordinate."
(declare (debug (body)) (indent 0))
(let ((height-expansion (make-symbol "height-expansion-var-symbol"))
- (width-expansion (make-symbol "width-expansion-var-symbol")))
- `(let (,height-expansion ,width-expansion)
+ (width-expansion (make-symbol "width-expansion-var-symbol"))
+ (fixed-width (make-symbol "fixed-width")))
+ `(let ((,fixed-width table-fixed-width-mode)
+ ,height-expansion ,width-expansion)
;; make sure cache has valid data unless it is explicitly inhibited.
(unless table-inhibit-update
(table-recognize-cell))
(with-current-buffer (get-buffer-create table-cache-buffer-name)
- ;; goto the cell coordinate based on `table-cell-cache-point-coordinate'.
- (set-mark (table--goto-coordinate table-cell-cache-mark-coordinate))
- (table--goto-coordinate table-cell-cache-point-coordinate)
- (table--untabify-line)
- ;; always reset before executing body forms because auto-fill behavior is the default.
- (setq table-inhibit-auto-fill-paragraph nil)
- ;; do the body
- ,@body
- ;; fill paragraph unless the body does not want to by setting `table-inhibit-auto-fill-paragraph'.
- (unless table-inhibit-auto-fill-paragraph
- (if (and table-cell-info-justify
- (not (eq table-cell-info-justify 'left)))
- (table--fill-region (point-min) (point-max))
- (table--fill-region
- (save-excursion (forward-paragraph -1) (point))
- (save-excursion (forward-paragraph 1) (point)))))
- ;; keep the updated cell coordinate.
- (setq table-cell-cache-point-coordinate (table--get-coordinate))
- ;; determine the cell width expansion.
- (setq ,width-expansion (table--measure-max-width))
- (if (<= ,width-expansion table-cell-info-width) nil
- (table--fill-region (point-min) (point-max) ,width-expansion)
- ;; keep the updated cell coordinate.
- (setq table-cell-cache-point-coordinate (table--get-coordinate)))
- (setq ,width-expansion (- ,width-expansion table-cell-info-width))
- ;; determine the cell height expansion.
- (if (looking-at "\\s *\\'") nil
- (goto-char (point-min))
- (if (re-search-forward "\\(\\s *\\)\\'" nil t)
- (goto-char (match-beginning 1))))
- (setq ,height-expansion (- (cdr (table--get-coordinate)) (1- table-cell-info-height))))
+ (let ((table-fixed-width-mode ,fixed-width))
+ ;; Go to the cell coordinate based on
+ ;; `table-cell-cache-point-coordinate'.
+ (set-mark (table--goto-coordinate table-cell-cache-mark-coordinate))
+ (table--goto-coordinate table-cell-cache-point-coordinate)
+ (table--untabify-line)
+ ;; Always reset before executing body forms because
+ ;; auto-fill behavior is the default.
+ (setq table-inhibit-auto-fill-paragraph nil)
+ ;; Do the body
+ ,@body
+ ;; Fill paragraph unless the body does not want to by
+ ;; setting `table-inhibit-auto-fill-paragraph'.
+ (unless table-inhibit-auto-fill-paragraph
+ (if (and table-cell-info-justify
+ (not (eq table-cell-info-justify 'left)))
+ (table--fill-region (point-min) (point-max))
+ (table--fill-region
+ (save-excursion (forward-paragraph -1) (point))
+ (save-excursion (forward-paragraph 1) (point)))))
+ ;; Keep the updated cell coordinate.
+ (setq table-cell-cache-point-coordinate (table--get-coordinate))
+ ;; Determine the cell width expansion.
+ (setq ,width-expansion (table--measure-max-width))
+ (if (<= ,width-expansion table-cell-info-width) nil
+ (table--fill-region (point-min) (point-max) ,width-expansion)
+ ;; Keep the updated cell coordinate.
+ (setq table-cell-cache-point-coordinate (table--get-coordinate)))
+ (setq ,width-expansion (- ,width-expansion table-cell-info-width))
+ ;; Determine the cell height expansion.
+ (if (looking-at "\\s *\\'") nil
+ (goto-char (point-min))
+ (if (re-search-forward "\\(\\s *\\)\\'" nil t)
+ (goto-char (match-beginning 1))))
+ (setq ,height-expansion (- (cdr (table--get-coordinate)) (1- table-cell-info-height)))))
;; now back to the table buffer.
;; expand the cell width in the table buffer if necessary.
(if (> ,width-expansion 0)
@@ -2823,21 +2844,6 @@ or `top', `middle', `bottom' or `none' for vertical."
(table--justify-cell-contents justify))))))
;;;###autoload
-(define-minor-mode table-fixed-width-mode
- "Cell width is fixed when this is non-nil.
-Normally it should be nil for allowing automatic cell width expansion
-that widens a cell when it is necessary. When non-nil, typing in a
-cell does not automatically expand the cell width. A word that is too
-long to fit in a cell is chopped into multiple lines. The chopped
-location is indicated by `table-word-continuation-char'. This
-variable's value can be toggled by \\[table-fixed-width-mode] at
-run-time."
- :tag "Fix Cell Width"
- :group 'table
- (table--finish-delayed-tasks)
- (table--update-cell-face))
-
-;;;###autoload
(defun table-query-dimension (&optional where)
"Return the dimension of the current cell and the current table.
The result is a list (cw ch tw th c r cells) where cw is the cell
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 6fd66b2502f..5fba93c76eb 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -2457,7 +2457,7 @@ Only applies the FSPEC to the args part of FORMAT."
(default (tex-compile-default fspec)))
(list default-directory
(completing-read
- (format "Command [%s]: " (tex-summarize-command default))
+ (format-prompt "Command" (tex-summarize-command default))
(mapcar (lambda (x)
(list (tex-format-cmd (eval (car x) t) fspec)))
tex-compile-commands)
diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el
index 7876a87a281..dbf30dabe59 100644
--- a/lisp/textmodes/texinfo.el
+++ b/lisp/textmodes/texinfo.el
@@ -4,7 +4,6 @@
;; Foundation, Inc.
;; Author: Robert J. Chassell
-;; Date: [See date below for texinfo-version]
;; Maintainer: emacs-devel@gnu.org
;; Keywords: maint, tex, docs
@@ -411,13 +410,13 @@ value of `texinfo-mode-hook'."
"\\)\\>"))
(setq-local require-final-newline mode-require-final-newline)
(setq-local indent-tabs-mode nil)
- (setq-local paragraph-separate
- (concat "@[a-zA-Z]*[ \n]\\|"
- paragraph-separate))
(setq-local paragraph-start (concat "@[a-zA-Z]*[ \n]\\|"
paragraph-start))
+ (setq-local fill-paragraph-function 'texinfo--fill-paragraph)
(setq-local sentence-end-base "\\(@\\(end\\)?dots{}\\|[.?!]\\)[]\"'”)}]*")
(setq-local fill-column 70)
+ (setq-local beginning-of-defun-function #'texinfo--beginning-of-defun)
+ (setq-local end-of-defun-function #'texinfo--end-of-defun)
(setq-local comment-start "@c ")
(setq-local comment-start-skip "@c +\\|@comment +")
(setq-local words-include-escapes t)
@@ -457,6 +456,58 @@ value of `texinfo-mode-hook'."
prevent-filling
(concat auto-fill-inhibit-regexp "\\|" prevent-filling)))))
+(defvar texinfo-fillable-commands '("@noindent")
+ "A list of commands that can be filled.")
+
+(defun texinfo--fill-paragraph (justify)
+ "Function to fill a paragraph in `texinfo-mode'."
+ (let ((command-re "\\(@[a-zA-Z]+\\)[ \t\n]"))
+ (catch 'no-fill
+ (save-restriction
+ ;; First check whether we're on a command line that can be
+ ;; filled by itself.
+ (or
+ (save-excursion
+ (beginning-of-line)
+ (when (looking-at command-re)
+ (let ((command (match-string 1)))
+ (if (member command texinfo-fillable-commands)
+ (progn
+ (narrow-to-region (point) (progn (forward-line 1) (point)))
+ t)
+ (throw 'no-fill nil)))))
+ ;; We're not on such a line, so fill the region.
+ (save-excursion
+ (let ((regexp (concat command-re "\\|^[ \t]*$\\|\f")))
+ (narrow-to-region
+ (if (re-search-backward regexp nil t)
+ (progn
+ (forward-line 1)
+ (point))
+ (point-min))
+ (if (re-search-forward regexp nil t)
+ (match-beginning 0)
+ (point-max)))
+ (goto-char (point-min)))))
+ ;; We've now narrowed to the region we want to fill.
+ (let ((fill-paragraph-function nil)
+ (adaptive-fill-mode nil))
+ (fill-paragraph justify))))
+ t))
+
+(defun texinfo--beginning-of-defun (&optional arg)
+ "Go to the previous @node line."
+ (while (and (> arg 0)
+ (re-search-backward "^@node " nil t))
+ (setq arg (1- arg))))
+
+(defun texinfo--end-of-defun ()
+ "Go to the start of the next @node line."
+ (when (looking-at-p "@node")
+ (forward-line))
+ (if (re-search-forward "^@node " nil t)
+ (goto-char (match-beginning 0))
+ (goto-char (point-max))))
;;; Insert string commands
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index 32e66184d70..2d1bf2013e1 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -106,8 +106,17 @@ valid THING.
Return a cons cell (START . END) giving the start and end
positions of the thing found."
- (if (get thing 'bounds-of-thing-at-point)
- (funcall (get thing 'bounds-of-thing-at-point))
+ (cond
+ ((get thing 'bounds-of-thing-at-point)
+ (funcall (get thing 'bounds-of-thing-at-point)))
+ ;; If the buffer is totally empty, give up.
+ ((and (not (eq thing 'whitespace))
+ (save-excursion
+ (goto-char (point-min))
+ (not (re-search-forward "[^\t\n ]" nil t))))
+ nil)
+ ;; Find the thing.
+ (t
(let ((orig (point)))
(ignore-errors
(save-excursion
@@ -149,7 +158,7 @@ positions of the thing found."
(lambda () (forward-thing thing -1))))
(point))))
(if (and (<= real-beg orig) (<= orig end) (< real-beg end))
- (cons real-beg end))))))))))
+ (cons real-beg end)))))))))))
;;;###autoload
(defun thing-at-point (thing &optional no-properties)
diff --git a/lisp/thumbs.el b/lisp/thumbs.el
index 4c863883ba4..001b2c8e770 100644
--- a/lisp/thumbs.el
+++ b/lisp/thumbs.el
@@ -91,7 +91,7 @@ When it reaches that size (in bytes), a warning is sent."
(defcustom thumbs-conversion-program
(if (eq system-type 'windows-nt)
;; FIXME is this necessary, or can a sane PATHEXE be assumed?
- ;; Eg find-program does not do this.
+ ;; E.g. find-program does not do this.
"convert.exe"
"convert")
"Name of conversion program for thumbnails generation.
@@ -292,22 +292,11 @@ smaller according to whether INCREMENT is 1 or -1."
(thumbs-call-convert fn tn "sample" thumbs-geometry))
tn))
-(defun thumbs-image-type (img)
- "Return image type from filename IMG."
- (cond ((string-match ".*\\.jpe?g\\'" img) 'jpeg)
- ((string-match ".*\\.xpm\\'" img) 'xpm)
- ((string-match ".*\\.xbm\\'" img) 'xbm)
- ((string-match ".*\\.pbm\\'" img) 'pbm)
- ((string-match ".*\\.gif\\'" img) 'gif)
- ((string-match ".*\\.bmp\\'" img) 'bmp)
- ((string-match ".*\\.png\\'" img) 'png)
- ((string-match ".*\\.tiff?\\'" img) 'tiff)))
-
(declare-function image-size "image.c" (spec &optional pixels frame))
(defun thumbs-file-size (img)
(let ((i (image-size
- (find-image `((:type ,(thumbs-image-type img) :file ,img))) t)))
+ (find-image `((:type ,(image-type-from-file-name img) :file ,img))) t)))
(concat (number-to-string (round (car i))) "x"
(number-to-string (round (cdr i))))))
@@ -410,7 +399,7 @@ and SAME-WINDOW to show thumbs in the same window."
thumbs-image-num (or num 0))
(delete-region (point-min)(point-max))
(save-excursion
- (thumbs-insert-image img (thumbs-image-type img) 0)))))
+ (thumbs-insert-image img (image-type-from-file-name img) 0)))))
(defun thumbs-find-image-at-point (&optional img otherwin)
"Display image IMG for thumbnail at point.
@@ -544,7 +533,7 @@ Open another window."
" - " (number-to-string num)))
(let ((inhibit-read-only t))
(erase-buffer)
- (thumbs-insert-image img (thumbs-image-type img) 0)
+ (thumbs-insert-image img (image-type-from-file-name img) 0)
(goto-char (point-min))))
(setq thumbs-image-num num
thumbs-current-image-filename img))))
@@ -775,6 +764,9 @@ ACTION and ARG should be a valid convert command."
(define-key dired-mode-map "\C-tm" 'thumbs-dired-show-marked)
(define-key dired-mode-map "\C-tw" 'thumbs-dired-setroot)
+(define-obsolete-function-alias 'thumbs-image-type
+ #'image-type-from-file-name "29.1")
+
(provide 'thumbs)
;;; thumbs.el ends here
diff --git a/lisp/time.el b/lisp/time.el
index 8496adec228..b67315cf630 100644
--- a/lisp/time.el
+++ b/lisp/time.el
@@ -343,7 +343,7 @@ Switches from the 1 to 5 to 15 minute load average, and then back to 1."
"Update the `display-time' info for the mode line.
However, don't redisplay right now.
-This is used for things like Rmail `g' that want to force an
+This is used for things like Rmail \\`g' that want to force an
update which can wait for the next redisplay."
(let* ((now (current-time))
(time (current-time-string now))
@@ -355,7 +355,7 @@ update which can wait for the next redisplay."
(am-pm (if (>= hour 12) "pm" "am"))
(minutes (substring time 14 16))
(seconds (substring time 17 19))
- (time-zone (car (cdr (current-time-zone now))))
+ (time-zone (format-time-string "%Z" now))
(day (substring time 8 10))
(year (format-time-string "%Y" now))
(monthname (substring time 4 7))
@@ -526,11 +526,9 @@ If the value is t instead of an alist, use the value of
'((t :inherit font-lock-variable-name-face))
"Face for time zone label in `world-clock' buffer.")
-(defvar world-clock-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "n" #'next-line)
- (define-key map "p" #'previous-line)
- map))
+(defvar-keymap world-clock-mode-map
+ "n" #'next-line
+ "p" #'previous-line)
(define-derived-mode world-clock-mode special-mode "World clock"
"Major mode for buffer that displays times in various time zones.
diff --git a/lisp/timezone.el b/lisp/timezone.el
index 2c96343a74b..7a461c4e22d 100644
--- a/lisp/timezone.el
+++ b/lisp/timezone.el
@@ -95,10 +95,7 @@ if nil, the local time zone is assumed."
Optional argument TIMEZONE specifies a time zone."
(let ((zone
(if (listp timezone)
- (let* ((m (timezone-zone-to-minute timezone))
- (absm (if (< m 0) (- m) m)))
- (format "%c%02d%02d"
- (if (< m 0) ?- ?+) (/ absm 60) (% absm 60)))
+ (format-time-string "%z" 0 (or timezone 0))
timezone)))
(format "%02d %s %04d %s %s"
day
@@ -302,11 +299,10 @@ Return a list in the same format as `current-time-zone's result,
or nil if the local time zone could not be computed.
DATE is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
- (and (fboundp 'current-time-zone)
- (let ((utc-time (timezone-time-from-absolute date seconds)))
- (and utc-time
- (let ((zone (current-time-zone utc-time)))
- (and (car zone) zone))))))
+ (let ((utc-time (timezone-time-from-absolute date seconds)))
+ (and utc-time
+ (let ((zone (current-time-zone utc-time)))
+ (and (car zone) zone)))))
(defun timezone-fix-time (date local timezone)
"Convert DATE (default timezone LOCAL) to YYYY-MM-DD-HH-MM-SS-ZONE vector.
diff --git a/lisp/tooltip.el b/lisp/tooltip.el
index 23b67ee2cab..6cc482d012a 100644
--- a/lisp/tooltip.el
+++ b/lisp/tooltip.el
@@ -368,10 +368,15 @@ It is also called if Tooltip mode is on, for text-only displays."
((equal-including-properties tooltip-help-message (current-message))
(message nil)))))
+(declare-function menu-or-popup-active-p "xmenu.c" ())
+
(defun tooltip-show-help (msg)
"Function installed as `show-help-function'.
MSG is either a help string to display, or nil to cancel the display."
- (if (display-graphic-p)
+ (if (and (display-graphic-p)
+ (or (not (eq window-system 'haiku)) ;; On Haiku, there isn't a reliable way to show tooltips
+ ;; above menus.
+ (not (menu-or-popup-active-p))))
(let ((previous-help tooltip-help-message))
(setq tooltip-help-message msg)
(cond ((null msg)
diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el
index d40a628b994..8691f03f86d 100644
--- a/lisp/tree-widget.el
+++ b/lisp/tree-widget.el
@@ -214,8 +214,8 @@ Give the image the specified properties PROPS."
See also the option `widget-image-conversion'."
(delq nil
(mapcar
- #'(lambda (fmt)
- (and (image-type-available-p (car fmt)) fmt))
+ (lambda (fmt)
+ (and (image-type-available-p (car fmt)) fmt))
widget-image-conversion)))
;; Buffer local cache of theme data.
diff --git a/lisp/tutorial.el b/lisp/tutorial.el
index 186bf35fe7e..bf985280d80 100644
--- a/lisp/tutorial.el
+++ b/lisp/tutorial.el
@@ -423,11 +423,9 @@ where
;; Handle prefix definitions specially
;; so that a mode that rebinds some subcommands
;; won't make it appear that the whole prefix is gone.
- (key-fun (if (eq def-fun 'ESC-prefix)
- (lookup-key global-map [27])
- (if (eq def-fun 'Control-X-prefix)
- (lookup-key global-map [24])
- (key-binding key))))
+ (key-fun (if (keymapp def-fun)
+ (lookup-key global-map key)
+ (key-binding key)))
(where (where-is-internal (if rem-fun rem-fun def-fun)))
cwhere)
diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el
index 58ae6efbfc1..ebba87ebbb5 100644
--- a/lisp/url/url-privacy.el
+++ b/lisp/url/url-privacy.el
@@ -48,6 +48,7 @@
(pcase (or window-system 'tty)
('x "X11")
('ns "OpenStep")
+ ('pgtk "PureGTK")
('tty "TTY")
(_ nil)))))
diff --git a/lisp/userlock.el b/lisp/userlock.el
index 348ccc6f8ec..9a2d45a8468 100644
--- a/lisp/userlock.el
+++ b/lisp/userlock.el
@@ -39,10 +39,6 @@
(define-error 'file-locked "File is locked" 'file-error)
-(defun userlock--fontify-key (key)
- "Add the `help-key-binding' face to string KEY."
- (propertize key 'face 'help-key-binding))
-
;;;###autoload
(defun ask-user-about-lock (file opponent)
"Ask user what to do when he wants to edit FILE but it is locked by OPPONENT.
@@ -68,12 +64,9 @@ in any way you like."
(match-string 0 opponent)))
opponent))
(while (null answer)
- (message "%s locked by %s: (%s, %s, %s, %s)? "
- short-file short-opponent
- (userlock--fontify-key "s")
- (userlock--fontify-key "q")
- (userlock--fontify-key "p")
- (userlock--fontify-key "?"))
+ (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))
@@ -88,12 +81,9 @@ in any way you like."
(?? . help))))
(cond ((null answer)
(beep)
- (message "Please type %s, %s, or %s; or %s for help"
- (userlock--fontify-key "q")
- (userlock--fontify-key "s")
- (userlock--fontify-key "p")
- ;; FIXME: Why do we use "?" here and "C-h" below?
- (userlock--fontify-key "?"))
+ ;; FIXME: Why do we use "?" here and "C-h" below?
+ (message (substitute-command-keys
+ "Please type \\`q', \\`s', or \\`p'; or \\`?' for help"))
(sit-for 3))
((eq (cdr answer) 'help)
(ask-user-about-lock-help)
@@ -106,17 +96,14 @@ in any way you like."
(with-output-to-temp-buffer "*Help*"
(with-current-buffer standard-output
(insert
- (format
+ (substitute-command-keys
"It has been detected that you want to modify a file that someone else has
already started modifying in Emacs.
-You can <%s>teal the file; the other user becomes the
+You can <\\`s'>teal the file; the other user becomes the
intruder if (s)he ever unmodifies the file and then changes it again.
-You can <%s>roceed; you edit at your own (and the other user's) risk.
-You can <%s>uit; don't modify this file."
- (userlock--fontify-key "s")
- (userlock--fontify-key "p")
- (userlock--fontify-key "q")))
+You can <\\`p'>roceed; you edit at your own (and the other user's) risk.
+You can <\\`q'>uit; don't modify this file."))
(help-mode))))
(define-error 'file-supersession nil 'file-error)
@@ -169,14 +156,11 @@ The buffer in question is current when this function is called."
(discard-input)
(save-window-excursion
(let ((prompt
- (format "%s changed on disk; \
-really edit the buffer? (%s, %s, %s or %s) "
- (file-name-nondirectory filename)
- (userlock--fontify-key "y")
- (userlock--fontify-key "n")
- (userlock--fontify-key "r")
- ;; FIXME: Why do we use "C-h" here and "?" above?
- (userlock--fontify-key "C-h")))
+ ;; FIXME: Why do we use "C-h" here and "?" above?
+ (format (substitute-command-keys
+ "%s changed on disk; \
+really edit the buffer? (\\`y', \\`n', \\`r' or \\`C-h') ")
+ (file-name-nondirectory filename)))
(choices '(?y ?n ?r ?? ?\C-h))
answer)
(when noninteractive
@@ -205,22 +189,18 @@ really edit the buffer? (%s, %s, %s or %s) "
(with-output-to-temp-buffer "*Help*"
(with-current-buffer standard-output
(insert
- (format
+ (substitute-command-keys
"You want to modify a buffer whose disk file has changed
since you last read it in or saved it with this buffer.
-If you say %s to go ahead and modify this buffer,
+If you say \\`y' to go ahead and modify this buffer,
you risk ruining the work of whoever rewrote the file.
-If you say %s to revert, the contents of the buffer are refreshed
+If you say \\`r' to revert, the contents of the buffer are refreshed
from the file on disk.
-If you say %s, the change you started to make will be aborted.
-
-Usually, you should type %s to get the latest version of the
-file, then make the change again."
- (userlock--fontify-key "y")
- (userlock--fontify-key "r")
- (userlock--fontify-key "n")
- (userlock--fontify-key "r")))
+If you say \\`n', the change you started to make will be aborted.
+
+Usually, you should type \\`r' to get the latest version of the
+file, then make the change again."))
(help-mode))))
;;;###autoload
diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el
index 63b886362ba..7886cc1eae2 100644
--- a/lisp/vc/cvs-status.el
+++ b/lisp/vc/cvs-status.el
@@ -29,23 +29,22 @@
;;; Code:
(require 'cl-lib)
-(require 'pcvs-util)
+(require 'pcvs)
+(require 'easy-mmode)
;;;
-(easy-mmode-defmap cvs-status-mode-map
- '(("n" . next-line)
- ("p" . previous-line)
- ("N" . cvs-status-next)
- ("P" . cvs-status-prev)
- ("\M-n" . cvs-status-next)
- ("\M-p" . cvs-status-prev)
- ("t" . cvs-status-cvstrees)
- ("T" . cvs-status-trees)
- (">" . cvs-mode-checkout))
- "CVS-Status' keymap."
- :group 'cvs-status
- :inherit 'cvs-mode-map)
+(defvar-keymap cvs-status-mode-map
+ :parent 'cvs-mode-map
+ "n" #'next-line
+ "p" #'previous-line
+ "N" #'cvs-status-next
+ "P" #'cvs-status-prev
+ "M-n" #'cvs-status-next
+ "M-p" #'cvs-status-prev
+ "t" #'cvs-status-cvstrees
+ "T" #'cvs-status-trees
+ ">" #'cvs-mode-checkout)
;;(easy-menu-define cvs-status-menu cvs-status-mode-map
;; "Menu for `cvs-status-mode'."
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index 057ffcd06e3..8f83aa580e4 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -55,6 +55,7 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
(eval-when-compile (require 'subr-x))
+(require 'easy-mmode)
(autoload 'vc-find-revision "vc")
(autoload 'vc-find-revision-no-save "vc")
@@ -162,57 +163,55 @@ and hunk-based syntax highlighting otherwise as a fallback."
;;;; keymap, menu, ...
;;;;
-(easy-mmode-defmap diff-mode-shared-map
- '(("n" . diff-hunk-next)
- ("N" . diff-file-next)
- ("p" . diff-hunk-prev)
- ("P" . diff-file-prev)
- ("\t" . diff-hunk-next)
- ([backtab] . diff-hunk-prev)
- ("k" . diff-hunk-kill)
- ("K" . diff-file-kill)
- ("}" . diff-file-next) ; From compilation-minor-mode.
- ("{" . diff-file-prev)
- ("\C-m" . diff-goto-source)
- ([mouse-2] . diff-goto-source)
- ("W" . widen)
- ("o" . diff-goto-source) ; other-window
- ("A" . diff-ediff-patch)
- ("r" . diff-restrict-view)
- ("R" . diff-reverse-direction)
- ([remap undo] . diff-undo))
- "Basic keymap for `diff-mode', bound to various prefix keys."
- :inherit special-mode-map)
-
-(easy-mmode-defmap diff-mode-map
- `(("\e" . ,(let ((map (make-sparse-keymap)))
- ;; We want to inherit most bindings from diff-mode-shared-map,
- ;; but not all since they may hide useful M-<foo> global
- ;; bindings when editing.
- (set-keymap-parent map diff-mode-shared-map)
- (dolist (key '("A" "r" "R" "g" "q" "W" "z"))
- (define-key map key nil))
- map))
- ;; From compilation-minor-mode.
- ("\C-c\C-c" . diff-goto-source)
- ;; By analogy with the global C-x 4 a binding.
- ("\C-x4A" . diff-add-change-log-entries-other-window)
- ;; Misc operations.
- ("\C-c\C-a" . diff-apply-hunk)
- ("\C-c\C-e" . diff-ediff-patch)
- ("\C-c\C-n" . diff-restrict-view)
- ("\C-c\C-s" . diff-split-hunk)
- ("\C-c\C-t" . diff-test-hunk)
- ("\C-c\C-r" . diff-reverse-direction)
- ("\C-c\C-u" . diff-context->unified)
- ;; `d' because it duplicates the context :-( --Stef
- ("\C-c\C-d" . diff-unified->context)
- ("\C-c\C-w" . diff-ignore-whitespace-hunk)
- ;; `l' because it "refreshes" the hunk like C-l refreshes the screen
- ("\C-c\C-l" . diff-refresh-hunk)
- ("\C-c\C-b" . diff-refine-hunk) ;No reason for `b' :-(
- ("\C-c\C-f" . next-error-follow-minor-mode))
- "Keymap for `diff-mode'. See also `diff-mode-shared-map'.")
+(defvar-keymap diff-mode-shared-map
+ :parent special-mode-map
+ "n" #'diff-hunk-next
+ "N" #'diff-file-next
+ "p" #'diff-hunk-prev
+ "P" #'diff-file-prev
+ "TAB" #'diff-hunk-next
+ "<backtab>" #'diff-hunk-prev
+ "k" #'diff-hunk-kill
+ "K" #'diff-file-kill
+ "}" #'diff-file-next ; From compilation-minor-mode.
+ "{" #'diff-file-prev
+ "RET" #'diff-goto-source
+ "<mouse-2>" #'diff-goto-source
+ "W" #'widen
+ "o" #'diff-goto-source ; other-window
+ "A" #'diff-ediff-patch
+ "r" #'diff-restrict-view
+ "R" #'diff-reverse-direction
+ "<remap> <undo>" #'diff-undo)
+
+(defvar-keymap diff-mode-map
+ :doc "Keymap for `diff-mode'. See also `diff-mode-shared-map'."
+ "ESC" (let ((map (define-keymap :parent diff-mode-shared-map)))
+ ;; We want to inherit most bindings from
+ ;; `diff-mode-shared-map', but not all since they may hide
+ ;; useful `M-<foo>' global bindings when editing.
+ (dolist (key '("A" "r" "R" "g" "q" "W" "z"))
+ (keymap-set map key nil))
+ map)
+ ;; From compilation-minor-mode.
+ "C-c C-c" #'diff-goto-source
+ ;; By analogy with the global C-x 4 a binding.
+ "C-x 4 A" #'diff-add-change-log-entries-other-window
+ ;; Misc operations.
+ "C-c C-a" #'diff-apply-hunk
+ "C-c C-e" #'diff-ediff-patch
+ "C-c C-n" #'diff-restrict-view
+ "C-c C-s" #'diff-split-hunk
+ "C-c C-t" #'diff-test-hunk
+ "C-c C-r" #'diff-reverse-direction
+ "C-c C-u" #'diff-context->unified
+ ;; `d' because it duplicates the context :-( --Stef
+ "C-c C-d" #'diff-unified->context
+ "C-c C-w" #'diff-ignore-whitespace-hunk
+ ;; `l' because it "refreshes" the hunk like C-l refreshes the screen
+ "C-c C-l" #'diff-refresh-hunk
+ "C-c C-b" #'diff-refine-hunk ;No reason for `b' :-(
+ "C-c C-f" #'next-error-follow-minor-mode)
(easy-menu-define diff-mode-menu diff-mode-map
"Menu for `diff-mode'."
@@ -267,11 +266,12 @@ and hunk-based syntax highlighting otherwise as a fallback."
(defcustom diff-minor-mode-prefix "\C-c="
"Prefix key for `diff-minor-mode' commands."
- :type '(choice (string "\e") (string "C-c=") string))
+ :type '(choice (string "ESC")
+ (string "\C-c=") string))
-(easy-mmode-defmap diff-minor-mode-map
- `((,diff-minor-mode-prefix . ,diff-mode-shared-map))
- "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'.")
+(defvar-keymap diff-minor-mode-map
+ :doc "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'."
+ (key-description diff-minor-mode-prefix) diff-mode-shared-map)
(define-minor-mode diff-auto-refine-mode
"Toggle automatic diff hunk finer highlighting (Diff Auto Refine mode).
@@ -894,6 +894,9 @@ data such as \"Index: ...\" and such."
;; Fix the original hunk-header.
(diff-fixup-modifs start pos))))
+(defun diff--outline-level ()
+ (if (string-match-p diff-hunk-header-re (match-string 0))
+ 2 1))
;;;;
;;;; jump to other buffers
@@ -1494,7 +1497,6 @@ a diff with \\[diff-reverse-direction].
(setq-local font-lock-defaults diff-font-lock-defaults)
(add-hook 'font-lock-mode-hook #'diff--font-lock-cleanup nil 'local)
- (setq-local outline-regexp diff-outline-regexp)
(setq-local imenu-generic-expression
diff-imenu-generic-expression)
;; These are not perfect. They would be better done separately for
@@ -1539,11 +1541,7 @@ a diff with \\[diff-reverse-direction].
#'diff--filter-substring)
(unless buffer-file-name
(hack-dir-local-variables-non-file-buffer))
- (save-excursion
- (setq-local diff-buffer-type
- (if (re-search-forward "^diff --git" nil t)
- 'git
- nil))))
+ (diff-setup-buffer-type))
;;;###autoload
(define-minor-mode diff-minor-mode
@@ -1579,6 +1577,21 @@ modified lines of the diff."
"^[-+!] .*?\\([\t ]+\\)$"
"^[-+!<>].*?\\([\t ]+\\)$"))))
+(defun diff-setup-buffer-type ()
+ "Try to guess the `diff-buffer-type' from content of current Diff mode buffer.
+`outline-regexp' is updated accordingly."
+ (save-excursion
+ (goto-char (point-min))
+ (setq-local diff-buffer-type
+ (if (re-search-forward "^diff --git" nil t)
+ 'git
+ nil)))
+ (when (eq diff-buffer-type 'git)
+ (setq diff-outline-regexp
+ (concat "\\(^diff --git.*\n\\|" diff-hunk-header-re "\\)"))
+ (setq-local outline-level #'diff--outline-level))
+ (setq-local outline-regexp diff-outline-regexp))
+
(defun diff-delete-if-empty ()
;; An empty diff file means there's no more diffs to integrate, so we
;; can just remove the file altogether. Very handy for .rej files if we
@@ -2603,13 +2616,15 @@ fixed, visit it in a buffer."
(or (match-beginning 2) (match-beginning 1))
'display (propertize
(cond
- ((null (match-beginning 1)) "new file ")
- ((null (match-beginning 2)) "deleted ")
- (t "modified "))
+ ((null (match-beginning 1))
+ (concat "new file " (match-string 2)))
+ ((null (match-beginning 2))
+ (concat "deleted " (match-string 1)))
+ (t
+ (concat "modified " (match-string 1))))
'face '(diff-file-header diff-header)))
- (unless (match-beginning 2)
- (put-text-property (match-end 1) (1- (match-end 0))
- 'display "")))))
+ (put-text-property (match-end 1) (1- (match-end 0))
+ 'display ""))))
nil)
;;; Syntax highlighting from font-lock
diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el
index 352fa693ffb..4061fedd578 100644
--- a/lisp/vc/diff.el
+++ b/lisp/vc/diff.el
@@ -96,15 +96,15 @@ Non-interactively, OLD and NEW may each be a file or a buffer."
(interactive
(let* ((newf (if (and buffer-file-name (file-exists-p buffer-file-name))
(read-file-name
- (concat "Diff new file (default "
- (file-name-nondirectory buffer-file-name) "): ")
+ (format-prompt "Diff new file"
+ (file-name-nondirectory buffer-file-name))
nil buffer-file-name t)
(read-file-name "Diff new file: " nil nil t)))
(oldf (file-newest-backup newf)))
(setq oldf (if (and oldf (file-exists-p oldf))
(read-file-name
- (concat "Diff original file (default "
- (file-name-nondirectory oldf) "): ")
+ (format-prompt "Diff original file"
+ (file-name-nondirectory oldf))
(file-name-directory oldf) oldf t)
(read-file-name "Diff original file: "
(file-name-directory newf) nil t)))
diff --git a/lisp/vc/ediff-help.el b/lisp/vc/ediff-help.el
index 0450cd7f23b..48e1f15f05c 100644
--- a/lisp/vc/ediff-help.el
+++ b/lisp/vc/ediff-help.el
@@ -227,7 +227,9 @@ the value of this variable and the variables `ediff-help-message-*' in
((string= cmd "s") (re-search-forward "^['`‘]s['’]"))
((string= cmd "+") (re-search-forward "^['`‘]\\+['’]"))
((string= cmd "=") (re-search-forward "^['`‘]=['’]"))
- (t (user-error "Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer")))
+ (t (user-error (substitute-command-keys
+ "Undocumented command! Type \\`G' in Ediff Control \
+Panel to drop a note to the Ediff maintainer"))))
) ; let case-fold-search
))
diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el
index eaccb7a98c7..4b352bd34fc 100644
--- a/lisp/vc/ediff-init.el
+++ b/lisp/vc/ediff-init.el
@@ -615,8 +615,8 @@ Actually, Ediff restores the scope of visibility that existed at startup.")
(defcustom ediff-keep-variants t
"Nil means prompt to remove unmodified buffers A/B/C at session end.
-Supplying a prefix argument to the quit command `q' temporarily reverses the
-meaning of this variable."
+Supplying a prefix argument to the quit command \\`q' temporarily
+reverses the meaning of this variable."
:type 'boolean
:group 'ediff)
diff --git a/lisp/vc/ediff-ptch.el b/lisp/vc/ediff-ptch.el
index 4135e8b4702..a03c6a5ed7e 100644
--- a/lisp/vc/ediff-ptch.el
+++ b/lisp/vc/ediff-ptch.el
@@ -415,7 +415,9 @@ other files, enter `/dev/null'.
(with-output-to-temp-buffer ediff-msg-buffer
(ediff-with-current-buffer standard-output
(fundamental-mode))
- (princ (format-message "
+ (with-current-buffer standard-output
+ (insert (format-message
+ (substitute-command-keys "
Ediff has inferred that
%s
%s
@@ -423,10 +425,10 @@ are two possible targets for applying the patch.
Both files seem to be plausible alternatives.
Please advise:
- Type `y' to use %s as the target;
- Type `n' to use %s as the target.
-"
- file1 file2 file1 file2)))
+ Type \\`y' to use %s as the target;
+ Type \\`n' to use %s as the target.
+")
+ file1 file2 file1 file2))))
(setcar session-file-object
(if (y-or-n-p (format "Use %s ? " file1))
(progn
@@ -503,15 +505,11 @@ are two possible targets for this %spatch. However, these files do not exist."
patch-file-name)
(setq patch-file-name
(read-file-name
- (format "Patch is in file%s: "
- (cond ((and buffer-file-name
- (equal (expand-file-name dir)
- (file-name-directory buffer-file-name)))
- (concat
- " (default "
- (file-name-nondirectory buffer-file-name)
- ")"))
- (t "")))
+ (format-prompt "Patch is in file"
+ (and buffer-file-name
+ (equal (expand-file-name dir)
+ (file-name-directory buffer-file-name))
+ (file-name-nondirectory buffer-file-name)))
dir buffer-file-name 'must-match))
(if (file-directory-p patch-file-name)
(error "Patch file cannot be a directory: %s" patch-file-name)
@@ -827,7 +825,8 @@ you can still examine the changes via M-x ediff-files"
ediff-patch-diagnostics patch-diagnostics))
(bury-buffer patch-diagnostics)
- (message "Type `P', if you need to see patch diagnostics")
+ (message (substitute-command-keys
+ "Type \\`P', if you need to see patch diagnostics"))
ctl-buf))
(defun ediff-multi-patch-internal (patch-buf &optional startup-hooks)
diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el
index c12de02e49f..c2b08bd31af 100644
--- a/lisp/vc/ediff-util.el
+++ b/lisp/vc/ediff-util.el
@@ -3121,11 +3121,7 @@ Hit \\[ediff-recenter] to reset the windows afterward."
(lambda () (when defaults
(setq minibuffer-default defaults)))
(read-file-name
- (format "%s%s "
- prompt
- (cond (default-file
- (concat " (default " default-file "):"))
- (t (concat " (default " default-dir "):"))))
+ (format-prompt prompt (or default-file default-dir))
default-dir
(or default-file default-dir)
t ; must match, no-confirm
diff --git a/lisp/vc/ediff.el b/lisp/vc/ediff.el
index 97c84ae5a18..cb4c8d93052 100644
--- a/lisp/vc/ediff.el
+++ b/lisp/vc/ediff.el
@@ -1558,7 +1558,9 @@ With optional NODE, goes to that node."
(info "ediff")
(if node
(Info-goto-node node)
- (message "Type `i' to search for a specific topic"))
+ (message (substitute-command-keys
+ (concat "Type \\<Info-mode-map>\\[Info-index] to"
+ " search for a specific topic"))))
(raise-frame))
(error (beep 1)
(with-output-to-temp-buffer ediff-msg-buffer
diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el
index 4d151d555cc..6e3f302263b 100644
--- a/lisp/vc/log-edit.el
+++ b/lisp/vc/log-edit.el
@@ -54,21 +54,19 @@
(define-obsolete-variable-alias 'vc-log-mode-map 'log-edit-mode-map "28.1")
(define-obsolete-variable-alias 'vc-log-entry-mode 'log-edit-mode-map "28.1")
-(easy-mmode-defmap log-edit-mode-map
- '(("\C-c\C-c" . log-edit-done)
- ("\C-c\C-a" . log-edit-insert-changelog)
- ("\C-c\C-w" . log-edit-generate-changelog-from-diff)
- ("\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))
- "Keymap for the `log-edit-mode' (to edit version control log messages)."
- :group 'log-edit)
+(defvar-keymap log-edit-mode-map
+ "C-c C-c" #'log-edit-done
+ "C-c C-a" #'log-edit-insert-changelog
+ "C-c C-w" #'log-edit-generate-changelog-from-diff
+ "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)
(easy-menu-define log-edit-menu log-edit-mode-map
"Menu used for `log-edit-mode'."
diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el
index c2f008fc47d..d45c1696a2f 100644
--- a/lisp/vc/log-view.el
+++ b/lisp/vc/log-view.el
@@ -110,6 +110,7 @@
;;; Code:
(require 'pcvs-util)
+(require 'easy-mmode)
(autoload 'vc-find-revision "vc")
(autoload 'vc-diff-internal "vc")
@@ -121,39 +122,23 @@
:group 'pcl-cvs
:prefix "log-view-")
-(easy-mmode-defmap log-view-mode-map
- '(
- ("-" . negative-argument)
- ("0" . digit-argument)
- ("1" . digit-argument)
- ("2" . digit-argument)
- ("3" . digit-argument)
- ("4" . digit-argument)
- ("5" . digit-argument)
- ("6" . digit-argument)
- ("7" . digit-argument)
- ("8" . digit-argument)
- ("9" . digit-argument)
-
- ("\C-m" . log-view-toggle-entry-display)
- ("m" . log-view-toggle-mark-entry)
- ("e" . log-view-modify-change-comment)
- ("d" . log-view-diff)
- ("=" . log-view-diff)
- ("D" . log-view-diff-changeset)
- ("a" . log-view-annotate-version)
- ("f" . log-view-find-revision)
- ("n" . log-view-msg-next)
- ("p" . log-view-msg-prev)
- ("\t" . log-view-msg-next)
- ([backtab] . log-view-msg-prev)
- ("N" . log-view-file-next)
- ("P" . log-view-file-prev)
- ("\M-n" . log-view-file-next)
- ("\M-p" . log-view-file-prev))
- "Log-View's keymap."
- :inherit special-mode-map
- :group 'log-view)
+(defvar-keymap log-view-mode-map
+ "RET" #'log-view-toggle-entry-display
+ "m" #'log-view-toggle-mark-entry
+ "e" #'log-view-modify-change-comment
+ "d" #'log-view-diff
+ "=" #'log-view-diff
+ "D" #'log-view-diff-changeset
+ "a" #'log-view-annotate-version
+ "f" #'log-view-find-revision
+ "n" #'log-view-msg-next
+ "p" #'log-view-msg-prev
+ "TAB" #'log-view-msg-next
+ "<backtab>" #'log-view-msg-prev
+ "N" #'log-view-file-next
+ "P" #'log-view-file-prev
+ "M-n" #'log-view-file-next
+ "M-p" #'log-view-file-prev)
(easy-menu-define log-view-mode-menu log-view-mode-map
"Log-View Display Menu."
diff --git a/lisp/vc/pcvs-defs.el b/lisp/vc/pcvs-defs.el
index 54ef06960f9..c3109f7e85b 100644
--- a/lisp/vc/pcvs-defs.el
+++ b/lisp/vc/pcvs-defs.el
@@ -264,160 +264,6 @@ This variable is buffer local and only used in the *cvs* buffer.")
(defconst cvs-vendor-branch "1.1.1"
"The default branch used by CVS for vendor code.")
-(easy-mmode-defmap cvs-mode-diff-map
- '(("E" "imerge" . cvs-mode-imerge)
- ("=" . cvs-mode-diff)
- ("e" "idiff" . cvs-mode-idiff)
- ("2" "other" . cvs-mode-idiff-other)
- ("d" "diff" . cvs-mode-diff)
- ("b" "backup" . cvs-mode-diff-backup)
- ("h" "head" . cvs-mode-diff-head)
- ("r" "repository" . cvs-mode-diff-repository)
- ("y" "yesterday" . cvs-mode-diff-yesterday)
- ("v" "vendor" . cvs-mode-diff-vendor))
- "Keymap for diff-related operations in `cvs-mode'."
- :name "Diff")
-;; This is necessary to allow correct handling of \\[cvs-mode-diff-map]
-;; in substitute-command-keys.
-(fset 'cvs-mode-diff-map cvs-mode-diff-map)
-
-(easy-mmode-defmap cvs-mode-map
- ;;(define-prefix-command 'cvs-mode-map-diff-prefix)
- ;;(define-prefix-command 'cvs-mode-map-control-c-prefix)
- '(;; various
- ;; (undo . cvs-mode-undo)
- ("?" . cvs-help)
- ("h" . cvs-help)
- ("q" . cvs-bury-buffer)
- ("z" . kill-this-buffer)
- ("F" . cvs-mode-set-flags)
- ;; ("\M-f" . cvs-mode-force-command)
- ("!" . cvs-mode-force-command)
- ("\C-c\C-c" . cvs-mode-kill-process)
- ;; marking
- ("m" . cvs-mode-mark)
- ("M" . cvs-mode-mark-all-files)
- ("S" . cvs-mode-mark-on-state)
- ("u" . cvs-mode-unmark)
- ("\C-?". cvs-mode-unmark-up)
- ("%" . cvs-mode-mark-matching-files)
- ("T" . cvs-mode-toggle-marks)
- ("\M-\C-?" . cvs-mode-unmark-all-files)
- ;; navigation keys
- (" " . cvs-mode-next-line)
- ("n" . cvs-mode-next-line)
- ("p" . cvs-mode-previous-line)
- ("\t" . cvs-mode-next-line)
- ([backtab] . cvs-mode-previous-line)
- ;; M- keys are usually those that operate on modules
- ;;("\M-C". cvs-mode-rcs2log) ; i.e. "Create a ChangeLog"
- ;;("\M-t". cvs-rtag)
- ;;("\M-l". cvs-rlog)
- ("\M-c". cvs-checkout)
- ("\M-e". cvs-examine)
- ("g" . cvs-mode-revert-buffer)
- ("\M-u". cvs-update)
- ("\M-s". cvs-status)
- ;; diff commands
- ("=" . cvs-mode-diff)
- ("d" . cvs-mode-diff-map)
- ;; keys that operate on individual files
- ("\C-k" . cvs-mode-acknowledge)
- ("A" . cvs-mode-add-change-log-entry-other-window)
- ;;("B" . cvs-mode-byte-compile-files)
- ("C" . cvs-mode-commit-setup)
- ("O" . cvs-mode-update)
- ("U" . cvs-mode-undo)
- ("I" . cvs-mode-insert)
- ("a" . cvs-mode-add)
- ("b" . cvs-set-branch-prefix)
- ("B" . cvs-set-secondary-branch-prefix)
- ("c" . cvs-mode-commit)
- ("e" . cvs-mode-examine)
- ("f" . cvs-mode-find-file)
- ("\C-m" . cvs-mode-find-file)
- ("i" . cvs-mode-ignore)
- ("l" . cvs-mode-log)
- ("o" . cvs-mode-find-file-other-window)
- ("r" . cvs-mode-remove)
- ("s" . cvs-mode-status)
- ("t" . cvs-mode-tag)
- ("v" . cvs-mode-view-file)
- ("x" . cvs-mode-remove-handled)
- ;; cvstree bindings
- ("+" . cvs-mode-tree)
- ;; mouse bindings
- ([mouse-2] . cvs-mode-find-file)
- ([follow-link] . (lambda (pos)
- (if (eq (get-char-property pos 'face) 'cvs-filename) t)))
- ([(down-mouse-3)] . cvs-menu)
- ;; dired-like bindings
- ("\C-o" . cvs-mode-display-file)
- ;; Emacs-21 toolbar
- ;;([tool-bar item1] . (menu-item "Examine" cvs-examine :image (image :file "/usr/share/icons/xpaint.xpm" :type xpm)))
- ;;([tool-bar item2] . (menu-item "Update" cvs-update :image (image :file "/usr/share/icons/mail1.xpm" :type xpm)))
- )
- "Keymap for `cvs-mode'."
- :dense t
- :suppress t)
-
-(fset 'cvs-mode-map cvs-mode-map)
-
-(easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'."
- '("CVS"
- ["Open file" cvs-mode-find-file t]
- ["Open in other window" cvs-mode-find-file-other-window t]
- ["Display in other window" cvs-mode-display-file t]
- ["Interactive merge" cvs-mode-imerge t]
- ("View diff"
- ["Interactive diff" cvs-mode-idiff t]
- ["Current diff" cvs-mode-diff t]
- ["Diff with head" cvs-mode-diff-head t]
- ["Diff with vendor" cvs-mode-diff-vendor t]
- ["Diff against yesterday" cvs-mode-diff-yesterday t]
- ["Diff with backup" cvs-mode-diff-backup t])
- ["View log" cvs-mode-log t]
- ["View status" cvs-mode-status t]
- ["View tag tree" cvs-mode-tree t]
- "----"
- ["Insert" cvs-mode-insert]
- ["Update" cvs-mode-update (cvs-enabledp 'update)]
- ["Re-examine" cvs-mode-examine t]
- ["Commit" cvs-mode-commit-setup (cvs-enabledp 'commit)]
- ["Tag" cvs-mode-tag (cvs-enabledp (when cvs-force-dir-tag 'tag))]
- ["Undo changes" cvs-mode-undo (cvs-enabledp 'undo)]
- ["Add" cvs-mode-add (cvs-enabledp 'add)]
- ["Remove" cvs-mode-remove (cvs-enabledp 'remove)]
- ["Ignore" cvs-mode-ignore (cvs-enabledp 'ignore)]
- ["Add ChangeLog" cvs-mode-add-change-log-entry-other-window t]
- "----"
- ["Mark" cvs-mode-mark t]
- ["Mark all" cvs-mode-mark-all-files t]
- ["Mark by regexp..." cvs-mode-mark-matching-files t]
- ["Mark by state..." cvs-mode-mark-on-state t]
- ["Unmark" cvs-mode-unmark t]
- ["Unmark all" cvs-mode-unmark-all-files t]
- ["Hide handled" cvs-mode-remove-handled t]
- "----"
- ["PCL-CVS Manual" (lambda () (interactive)
- (info "(pcl-cvs)Top")) t]
- "----"
- ["Quit" cvs-mode-quit t]))
-
-;;;;
-;;;; CVS-Minor mode
-;;;;
-
-(defcustom cvs-minor-mode-prefix "\C-xc"
- "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'."
- :type 'string)
-
-(easy-mmode-defmap cvs-minor-mode-map
- `((,cvs-minor-mode-prefix . cvs-mode-map)
- ("e" . (menu-item nil cvs-mode-edit-log
- :filter (lambda (x) (if (derived-mode-p 'log-view-mode) x)))))
- "Keymap for `cvs-minor-mode', used in buffers related to PCL-CVS.")
-
(defvar cvs-buffer nil
"(Buffer local) The *cvs* buffer associated with this buffer.")
(put 'cvs-buffer 'permanent-local t)
diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el
index bbc81ef195d..2d7b8cb2ef7 100644
--- a/lisp/vc/pcvs.el
+++ b/lisp/vc/pcvs.el
@@ -117,11 +117,11 @@
(require 'cl-lib)
(require 'ewoc) ;Ewoc was once cookie
-(require 'pcvs-defs)
(require 'pcvs-util)
(require 'pcvs-parse)
(require 'pcvs-info)
(require 'vc-cvs)
+(require 'easy-mmode)
;;;;
@@ -138,6 +138,147 @@
(defvar cvs-from-vc nil "Bound to t inside VC advice.")
+(defvar-keymap cvs-mode-diff-map
+ :name "Diff"
+ "E" (cons "imerge" #'cvs-mode-imerge)
+ "=" #'cvs-mode-diff
+ "e" (cons "idiff" #'cvs-mode-idiff)
+ "2" (cons "other" #'cvs-mode-idiff-other)
+ "d" (cons "diff" #'cvs-mode-diff)
+ "b" (cons "backup" #'cvs-mode-diff-backup)
+ "h" (cons "head" #'cvs-mode-diff-head)
+ "r" (cons "repository" #'cvs-mode-diff-repository)
+ "y" (cons "yesterday" #'cvs-mode-diff-yesterday)
+ "v" (cons "vendor" #'cvs-mode-diff-vendor))
+;; This is necessary to allow correct handling of \\[cvs-mode-diff-map]
+;; in substitute-command-keys.
+(fset 'cvs-mode-diff-map cvs-mode-diff-map)
+
+(defvar-keymap cvs-mode-map
+ :full t
+ :suppress t
+ ;; various
+ "?" #'cvs-help
+ "h" #'cvs-help
+ "q" #'cvs-bury-buffer
+ "z" #'kill-this-buffer
+ "F" #'cvs-mode-set-flags
+ "!" #'cvs-mode-force-command
+ "C-c C-c" #'cvs-mode-kill-process
+ ;; marking
+ "m" #'cvs-mode-mark
+ "M" #'cvs-mode-mark-all-files
+ "S" #'cvs-mode-mark-on-state
+ "u" #'cvs-mode-unmark
+ "DEL" #'cvs-mode-unmark-up
+ "%" #'cvs-mode-mark-matching-files
+ "T" #'cvs-mode-toggle-marks
+ "M-DEL" #'cvs-mode-unmark-all-files
+ ;; navigation keys
+ "SPC" #'cvs-mode-next-line
+ "n" #'cvs-mode-next-line
+ "p" #'cvs-mode-previous-line
+ "TAB" #'cvs-mode-next-line
+ "<backtab>" #'cvs-mode-previous-line
+ ;; M- keys are usually those that operate on modules
+ "M-c" #'cvs-checkout
+ "M-e" #'cvs-examine
+ "g" #'cvs-mode-revert-buffer
+ "M-u" #'cvs-update
+ "M-s" #'cvs-status
+ ;; diff commands
+ "=" #'cvs-mode-diff
+ "d" cvs-mode-diff-map
+ ;; keys that operate on individual files
+ "C-k" #'cvs-mode-acknowledge
+ "A" #'cvs-mode-add-change-log-entry-other-window
+ "C" #'cvs-mode-commit-setup
+ "O" #'cvs-mode-update
+ "U" #'cvs-mode-undo
+ "I" #'cvs-mode-insert
+ "a" #'cvs-mode-add
+ "b" #'cvs-set-branch-prefix
+ "B" #'cvs-set-secondary-branch-prefix
+ "c" #'cvs-mode-commit
+ "e" #'cvs-mode-examine
+ "f" #'cvs-mode-find-file
+ "RET" #'cvs-mode-find-file
+ "i" #'cvs-mode-ignore
+ "l" #'cvs-mode-log
+ "o" #'cvs-mode-find-file-other-window
+ "r" #'cvs-mode-remove
+ "s" #'cvs-mode-status
+ "t" #'cvs-mode-tag
+ "v" #'cvs-mode-view-file
+ "x" #'cvs-mode-remove-handled
+ ;; cvstree bindings
+ "+" #'cvs-mode-tree
+ ;; mouse bindings
+ "<mouse-2>" #'cvs-mode-find-file
+ "<follow-link>" (lambda (pos)
+ (eq (get-char-property pos 'face) 'cvs-filename))
+ "<down-mouse-3>" #'cvs-menu
+ ;; dired-like bindings
+ "C-o" #'cvs-mode-display-file)
+
+(easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'."
+ '("CVS"
+ ["Open file" cvs-mode-find-file t]
+ ["Open in other window" cvs-mode-find-file-other-window t]
+ ["Display in other window" cvs-mode-display-file t]
+ ["Interactive merge" cvs-mode-imerge t]
+ ("View diff"
+ ["Interactive diff" cvs-mode-idiff t]
+ ["Current diff" cvs-mode-diff t]
+ ["Diff with head" cvs-mode-diff-head t]
+ ["Diff with vendor" cvs-mode-diff-vendor t]
+ ["Diff against yesterday" cvs-mode-diff-yesterday t]
+ ["Diff with backup" cvs-mode-diff-backup t])
+ ["View log" cvs-mode-log t]
+ ["View status" cvs-mode-status t]
+ ["View tag tree" cvs-mode-tree t]
+ "----"
+ ["Insert" cvs-mode-insert]
+ ["Update" cvs-mode-update (cvs-enabledp 'update)]
+ ["Re-examine" cvs-mode-examine t]
+ ["Commit" cvs-mode-commit-setup (cvs-enabledp 'commit)]
+ ["Tag" cvs-mode-tag (cvs-enabledp (when cvs-force-dir-tag 'tag))]
+ ["Undo changes" cvs-mode-undo (cvs-enabledp 'undo)]
+ ["Add" cvs-mode-add (cvs-enabledp 'add)]
+ ["Remove" cvs-mode-remove (cvs-enabledp 'remove)]
+ ["Ignore" cvs-mode-ignore (cvs-enabledp 'ignore)]
+ ["Add ChangeLog" cvs-mode-add-change-log-entry-other-window t]
+ "----"
+ ["Mark" cvs-mode-mark t]
+ ["Mark all" cvs-mode-mark-all-files t]
+ ["Mark by regexp..." cvs-mode-mark-matching-files t]
+ ["Mark by state..." cvs-mode-mark-on-state t]
+ ["Unmark" cvs-mode-unmark t]
+ ["Unmark all" cvs-mode-unmark-all-files t]
+ ["Hide handled" cvs-mode-remove-handled t]
+ "----"
+ ["PCL-CVS Manual" (lambda () (interactive)
+ (info "(pcl-cvs)Top")) t]
+ "----"
+ ["Quit" cvs-mode-quit t]))
+
+;;;;
+;;;; CVS-Minor mode
+;;;;
+
+(defcustom cvs-minor-mode-prefix "\C-xc"
+ "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'."
+ :type 'string
+ :group 'pcl-cvs)
+
+(defvar-keymap cvs-minor-mode-map
+ (key-description cvs-minor-mode-prefix) 'cvs-mode-map
+ "e" '(menu-item nil cvs-mode-edit-log
+ :filter (lambda (x)
+ (and (derived-mode-p 'log-view-mode) x))))
+
+(require 'pcvs-defs)
+
;;;;
;;;; flags variables
;;;;
@@ -758,6 +899,7 @@ clear what alternative to use.
- `DOUBLE' is the generic case."
(declare (debug (&define sexp lambda-list stringp
("interactive" interactive) def-body))
+ (indent defun)
(doc-string 3))
(let ((style (cvs-cdr fun))
(fun (cvs-car fun)))
@@ -1284,8 +1426,7 @@ marked instead. A directory can never be marked."
(intern
(upcase
(completing-read
- (concat
- "Mark files in state" (if default (concat " [" default "]")) ": ")
+ (format-prompt "Mark files in state" default)
(mapcar (lambda (x)
(list (downcase (symbol-name (car x)))))
cvs-states)
diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el
index b2a875c81ff..6c1b8cc95b3 100644
--- a/lisp/vc/smerge-mode.el
+++ b/lisp/vc/smerge-mode.el
@@ -47,6 +47,7 @@
(require 'diff) ;For diff-check-labels.
(require 'diff-mode) ;For diff-refine.
(require 'newcomment)
+(require 'easy-mmode)
;;; The real definition comes later.
(defvar smerge-mode)
@@ -142,36 +143,34 @@ Used in `smerge-diff-base-upper' and related functions."
"Face used for added characters shown by `smerge-refine'."
:version "24.3")
-(easy-mmode-defmap smerge-basic-map
- `(("n" . smerge-next)
- ("p" . smerge-prev)
- ("r" . smerge-resolve)
- ("a" . smerge-keep-all)
- ("b" . smerge-keep-base)
- ("o" . smerge-keep-lower) ; for the obsolete keep-other
- ("l" . smerge-keep-lower)
- ("m" . smerge-keep-upper) ; for the obsolete keep-mine
- ("u" . smerge-keep-upper)
- ("E" . smerge-ediff)
- ("C" . smerge-combine-with-next)
- ("R" . smerge-refine)
- ("\C-m" . smerge-keep-current)
- ("=" . ,(make-sparse-keymap "Diff"))
- ("=<" "base-upper" . smerge-diff-base-upper)
- ("=>" "base-lower" . smerge-diff-base-lower)
- ("==" "upper-lower" . smerge-diff-upper-lower))
- "The base keymap for `smerge-mode'.")
+(defvar-keymap smerge-basic-map
+ "n" #'smerge-next
+ "p" #'smerge-prev
+ "r" #'smerge-resolve
+ "a" #'smerge-keep-all
+ "b" #'smerge-keep-base
+ "o" #'smerge-keep-lower ; for the obsolete keep-other
+ "l" #'smerge-keep-lower
+ "m" #'smerge-keep-upper ; for the obsolete keep-mine
+ "u" #'smerge-keep-upper
+ "E" #'smerge-ediff
+ "C" #'smerge-combine-with-next
+ "R" #'smerge-refine
+ "C-m" #'smerge-keep-current
+ "=" (define-keymap :name "Diff"
+ "<" (cons "base-upper" #'smerge-diff-base-upper)
+ ">" (cons "base-lower" #'smerge-diff-base-lower)
+ "=" (cons "upper-lower" #'smerge-diff-upper-lower)))
(defcustom smerge-command-prefix "\C-c^"
"Prefix for `smerge-mode' commands."
:type '(choice (const :tag "ESC" "\e")
- (const :tag "C-c ^" "\C-c^" )
+ (const :tag "C-c ^" "\C-c^")
(const :tag "none" "")
string))
-(easy-mmode-defmap smerge-mode-map
- `((,smerge-command-prefix . ,smerge-basic-map))
- "Keymap for `smerge-mode'.")
+(defvar-keymap smerge-mode-map
+ (key-description smerge-command-prefix) smerge-basic-map)
(defvar-local smerge-check-cache nil)
(defun smerge-check (n)
diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el
index 6f921ac2a04..c8954472245 100644
--- a/lisp/vc/vc-cvs.el
+++ b/lisp/vc/vc-cvs.el
@@ -309,10 +309,11 @@ to the CVS command."
(defun vc-cvs-responsible-p (file)
"Return non-nil if CVS thinks it is responsible for FILE."
- (file-directory-p (expand-file-name "CVS"
- (if (file-directory-p file)
- file
- (file-name-directory file)))))
+ (let ((dir (if (file-directory-p file)
+ file
+ (file-name-directory file))))
+ (and (file-directory-p (expand-file-name "CVS" dir))
+ (file-name-directory (expand-file-name "CVS" dir)))))
(defun vc-cvs-could-register (file)
"Return non-nil if FILE could be registered in CVS.
diff --git a/lisp/vc/vc-dav.el b/lisp/vc/vc-dav.el
index fe631ee09a7..49a8af10e78 100644
--- a/lisp/vc/vc-dav.el
+++ b/lisp/vc/vc-dav.el
@@ -136,10 +136,10 @@ It should return a status of either 0 (no differences found), or
"Find the version control state of all files in DIR in a fast way."
)
-(defun vc-dav-responsible-p (_url)
+(defun vc-dav-responsible-p (url)
"Return non-nil if DAV considers itself `responsible' for URL."
;; Check for DAV support on the web server.
- t)
+ (and t url))
;;; Unimplemented functions
;;
diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el
index 8165d5e09f1..32e492171d3 100644
--- a/lisp/vc/vc-dir.el
+++ b/lisp/vc/vc-dir.el
@@ -1427,7 +1427,12 @@ These are the commands available for use in the file status buffer:
(vc-dir-refresh)
;; FIXME: find a better way to pass the backend to `vc-dir-mode'.
(let ((use-vc-backend backend))
- (vc-dir-mode))))
+ (vc-dir-mode)
+ ;; Activate the backend-specific minor mode, if any.
+ (when-let ((minor-mode
+ (intern-soft (format "vc-dir-%s-mode"
+ (downcase (symbol-name backend))))))
+ (funcall minor-mode 1)))))
(defun vc-default-dir-extra-headers (_backend _dir)
;; Be loud by default to remind people to add code to display
diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el
index 346974bdba8..53cdb5eba84 100644
--- a/lisp/vc/vc-dispatcher.el
+++ b/lisp/vc/vc-dispatcher.el
@@ -127,8 +127,12 @@ preserve the setting."
:group 'vc)
(defcustom vc-command-messages nil
- "If non-nil, display run messages from back-end commands."
- :type 'boolean
+ "If non-nil, display and log messages about running back-end commands.
+If the value is `log', messages about running VC back-end commands are
+logged in the *Messages* buffer, but not displayed."
+ :type '(choice (const :tag "No messages" nil)
+ (const :tag "Display and log messages" t)
+ (const :tag "Log messages, but don't display" log))
:group 'vc)
(defcustom vc-suppress-confirm nil
@@ -311,7 +315,10 @@ case, and the process object in the asynchronous case."
(substring command 0 -1)
command)
" " (vc-delistify flags)
- " " (vc-delistify files))))
+ " " (vc-delistify files)))
+ (vc-inhibit-message
+ (or (eq vc-command-messages 'log)
+ (eq (selected-window) (active-minibuffer-window)))))
(save-current-buffer
(unless (or (eq buffer t)
(and (stringp buffer)
@@ -335,7 +342,7 @@ case, and the process object in the asynchronous case."
(apply #'start-file-process command (current-buffer)
command squeezed))))
(when vc-command-messages
- (let ((inhibit-message (eq (selected-window) (active-minibuffer-window))))
+ (let ((inhibit-message vc-inhibit-message))
(message "Running in background: %s" full-command)))
;; Get rid of the default message insertion, in case we don't
;; set a sentinel explicitly.
@@ -345,11 +352,11 @@ case, and the process object in the asynchronous case."
(when vc-command-messages
(vc-run-delayed
(let ((message-truncate-lines t)
- (inhibit-message (eq (selected-window) (active-minibuffer-window))))
+ (inhibit-message vc-inhibit-message))
(message "Done in background: %s" full-command)))))
;; Run synchronously
(when vc-command-messages
- (let ((inhibit-message (eq (selected-window) (active-minibuffer-window))))
+ (let ((inhibit-message vc-inhibit-message))
(message "Running in foreground: %s" full-command)))
(let ((buffer-undo-list t))
(setq status (apply #'process-file command nil t nil squeezed)))
@@ -364,7 +371,7 @@ case, and the process object in the asynchronous case."
(if (integerp status) (format "status %d" status) status)
full-command))
(when vc-command-messages
- (let ((inhibit-message (eq (selected-window) (active-minibuffer-window))))
+ (let ((inhibit-message vc-inhibit-message))
(message "Done (status=%d): %s" status full-command)))))
(vc-run-delayed
(run-hook-with-args 'vc-post-command-functions
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 2d35061b269..5c6a39aec96 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -298,12 +298,14 @@ included in the completions."
(vc-git--run-command-string nil "version")))
(setq vc-git--program-version
(if (and version-string
- ;; Git for Windows appends ".windows.N" to the
- ;; numerical version reported by Git.
- (string-match
- "git version \\([0-9.]+\\)\\(\\.windows\\.[0-9]+\\)?$"
- version-string))
- (match-string 1 version-string)
+ ;; Some Git versions append additional strings
+ ;; to the numerical version string. E.g., Git
+ ;; for Windows appends ".windows.N", while Git
+ ;; for Mac appends " (Apple Git-N)". Capture
+ ;; numerical version and ignore the rest.
+ (string-match "git version \\([0-9][0-9.]+\\)"
+ version-string))
+ (string-trim-right (match-string 1 version-string) "\\.")
"0")))))
(defun vc-git--git-status-to-vc-state (code-list)
@@ -1688,7 +1690,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]."
(let ((stash (completing-read
prompt
(split-string
- (or (vc-git--run-command-string nil "stash" "list") "") "\n")
+ (or (vc-git--run-command-string nil "stash" "list") "") "\n" t)
nil :require-match nil 'vc-git-stash-read-history)))
(if (string-equal stash "")
(user-error "Not a stash")
@@ -1733,12 +1735,11 @@ This command shares argument histories with \\[rgrep] and \\[grep]."
(defun vc-git-stash-list ()
(when-let ((out (vc-git--run-command-string nil "stash" "list")))
- (delete
- ""
- (split-string
- (replace-regexp-in-string
- "^stash@" " " out)
- "\n"))))
+ (split-string
+ (replace-regexp-in-string
+ "^stash@" " " out)
+ "\n"
+ t)))
(defun vc-git-stash-get-at-point (point)
(save-excursion
@@ -1871,6 +1872,17 @@ Returns nil if not possible."
(1- (point-max)))))))
(and name (not (string= name "undefined")) name))))
+(defvar-keymap vc-dir-git-mode-map
+ "z c" #'vc-git-stash
+ "z s" #'vc-git-stash-snapshot
+ "z p" #'vc-git-stash-pop)
+
+(define-minor-mode vc-dir-git-mode
+ "A minor mode for git-specific commands in `vc-dir-mode' buffers.
+Also note that there are git stash commands available in the
+\"Stash\" section at the head of the buffer."
+ :lighter " Git")
+
(provide 'vc-git)
;;; vc-git.el ends here
diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el
index 0ed9f7c31fe..6bec9edbf35 100644
--- a/lisp/vc/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -672,7 +672,6 @@ Return the byte's value as an integer."
(let* ((result nil)
(flen (length fname))
(case-fold-search nil)
- (inhibit-changing-match-data t)
;; Find a conservative bound for the loop below by using
;; Boyer-Moore on the raw dirstate without parsing it; we
;; know we can't possibly find fname _after_ the last place
@@ -976,10 +975,9 @@ REPO must be the directory name of an hg repository."
"Test whether the ignore pattern set HGIP says to ignore FILENAME.
FILENAME must be the file's true absolute name."
(let ((patterns (vc-hg--ignore-patterns-ignore-patterns hgip))
- (inhibit-changing-match-data t)
(ignored nil))
(while (and patterns (not ignored))
- (setf ignored (string-match (pop patterns) filename)))
+ (setf ignored (string-match-p (pop patterns) filename)))
ignored))
(defvar vc-hg--cached-ignore-patterns nil
@@ -1043,7 +1041,8 @@ Avoids the need to repeatedly scan dirstate on repeated calls to
(equal size (pop cache))
(equal ascii-fname (pop cache)))
(pop cache)
- (let ((result (vc-hg--raw-dirstate-search dirstate ascii-fname)))
+ (let ((result (save-match-data
+ (vc-hg--raw-dirstate-search dirstate ascii-fname))))
(setf vc-hg--dirstate-scan-cache
(list dirstate mtime size ascii-fname result))
result))))
diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el
index b7760e3bba5..cd5b11d840b 100644
--- a/lisp/vc/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -864,7 +864,8 @@ In the latter case, VC mode is deactivated for this buffer."
(defvar vc-prefix-map
(let ((map (make-sparse-keymap)))
(define-key map "a" #'vc-update-change-log)
- (define-key map "b" #'vc-switch-backend)
+ (with-suppressed-warnings ((obsolete vc-switch-backend))
+ (define-key map "b" #'vc-switch-backend))
(define-key map "d" #'vc-dir)
(define-key map "g" #'vc-annotate)
(define-key map "G" #'vc-ignore)
diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el
index e38469ba9f0..2422e99d3da 100644
--- a/lisp/vc/vc-rcs.el
+++ b/lisp/vc/vc-rcs.el
@@ -290,10 +290,11 @@ to the RCS command."
(defun vc-rcs-responsible-p (file)
"Return non-nil if RCS thinks it would be responsible for registering FILE."
;; TODO: check for all the patterns in vc-rcs-master-templates
- (file-directory-p (expand-file-name "RCS"
- (if (file-directory-p file)
- file
- (file-name-directory file)))))
+ (let ((dir (if (file-directory-p file)
+ file
+ (file-name-directory file))))
+ (and (file-directory-p (expand-file-name "RCS" dir))
+ (file-name-directory (expand-file-name "RCS" dir)))))
(defun vc-rcs-receive-file (file rev)
"Implementation of receive-file for RCS."
diff --git a/lisp/vc/vc-sccs.el b/lisp/vc/vc-sccs.el
index bcbb87eba8e..4b56fbf28ef 100644
--- a/lisp/vc/vc-sccs.el
+++ b/lisp/vc/vc-sccs.el
@@ -214,9 +214,13 @@ to the SCCS command."
(defun vc-sccs-responsible-p (file)
"Return non-nil if SCCS thinks it would be responsible for registering FILE."
;; TODO: check for all the patterns in vc-sccs-master-templates
- (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file)))
- (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "")
- (file-name-nondirectory file)))))
+ (or (and (file-directory-p
+ (expand-file-name "SCCS" (file-name-directory file)))
+ (file-name-directory file))
+ (let ((dir (vc-sccs-search-project-dir (or (file-name-directory file) "")
+ (file-name-nondirectory file))))
+ (and (stringp dir)
+ dir))))
(defun vc-sccs-checkin (files comment &optional rev)
"SCCS-specific version of `vc-backend-checkin'."
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 67003c83926..64f752f248d 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -739,6 +739,7 @@
(require 'cl-lib)
(declare-function diff-setup-whitespace "diff-mode" ())
+(declare-function diff-setup-buffer-type "diff-mode" ())
(eval-when-compile
(require 'dired))
@@ -937,11 +938,20 @@ repository, prompting for the directory and the VC backend to
use."
(catch 'found
;; First try: find a responsible backend, it must be a backend
- ;; under which FILE is not yet registered.
- (dolist (backend vc-handled-backends)
- (and (not (vc-call-backend backend 'registered file))
- (vc-call-backend backend 'responsible-p file)
- (throw 'found backend)))
+ ;; under which FILE is not yet registered and with the most
+ ;; specific path to FILE.
+ (let ((max 0)
+ bk)
+ (dolist (backend vc-handled-backends)
+ (when (not (vc-call-backend backend 'registered file))
+ (let* ((dir-name (vc-call-backend backend 'responsible-p file))
+ (len (and dir-name
+ (length (file-name-split
+ (expand-file-name dir-name))))))
+ (when (and len (> len max))
+ (setq max len bk backend)))))
+ (when bk
+ (throw 'found bk)))
;; no responsible backend
(let* ((possible-backends
(let (pos)
@@ -969,7 +979,7 @@ use."
(message "arg %s" arg)
(and (file-directory-p arg)
(string-prefix-p (expand-file-name arg) def-dir)))))))
- (let ((default-directory repo-dir))
+ (let ((default-directory repo-dir))
(vc-call-backend bk 'create-repo))
(throw 'found bk))))
@@ -1188,7 +1198,11 @@ For old-style locking-based version control systems, like RCS:
*vc-log* buffer to check in the changes. Leave a
read-only copy of each changed file after checking in.
If every file is locked by you and unchanged, unlock them.
- If every file is locked by someone else, offer to steal the lock."
+ If every file is locked by someone else, offer to steal the lock.
+
+When using this command to register a new file (or files), it
+will automatically deduce which VC repository to register it
+with, using the most specific one."
(interactive "P")
(let* ((vc-fileset (vc-deduce-fileset nil t 'state-model-only-files))
(backend (car vc-fileset))
@@ -1728,6 +1742,7 @@ to override the value of `vc-diff-switches' and `diff-switches'."
(insert (cdr messages) ".\n")
(message "%s" (cdr messages))))
(diff-setup-whitespace)
+ (diff-setup-buffer-type)
(goto-char (point-min))
(when window
(shrink-window-if-larger-than-buffer window)))
@@ -1863,13 +1878,10 @@ Return t if the buffer had changes, nil otherwise."
(vc-working-revision first))))
(when (string= rev1-default "") (setq rev1-default nil))))
;; construct argument list
- (let* ((rev1-prompt (if rev1-default
- (concat "Older revision (default "
- rev1-default "): ")
- "Older revision: "))
- (rev2-prompt (concat "Newer revision (default "
- ;; (or rev2-default
- "current source): "))
+ (let* ((rev1-prompt (format-prompt "Older revision" rev1-default))
+ (rev2-prompt (format-prompt "Newer revision"
+ ;; (or rev2-default
+ "current source"))
(rev1 (vc-read-revision rev1-prompt files backend rev1-default))
(rev2 (vc-read-revision rev2-prompt files backend nil))) ;; rev2-default
(when (string= rev1 "") (setq rev1 nil))
@@ -2082,7 +2094,7 @@ If `F.~REV~' already exists, use it instead of checking it out again."
(with-current-buffer (or (buffer-base-buffer) (current-buffer))
(vc-ensure-vc-buffer)
(list
- (vc-read-revision "Revision to visit (default is working revision): "
+ (vc-read-revision (format-prompt "Revision to visit" "working revision")
(list buffer-file-name)))))
(set-buffer (or (buffer-base-buffer) (current-buffer)))
(vc-ensure-vc-buffer)
@@ -2378,7 +2390,7 @@ This function runs the hook `vc-retrieve-tag-hook' when finished."
(read-directory-name "Directory: " default-directory nil t))))
(list
dir
- (vc-read-revision "Tag name to retrieve (default latest revisions): "
+ (vc-read-revision (format-prompt "Tag name to retrieve" "latest revisions")
(list dir)
(vc-responsible-backend dir)))))
(let* ((backend (vc-responsible-backend dir))
diff --git a/lisp/vcursor.el b/lisp/vcursor.el
index e219dc2d1a5..df65db39e38 100644
--- a/lisp/vcursor.el
+++ b/lisp/vcursor.el
@@ -788,9 +788,9 @@ out how much to copy."
(vcursor-check)
(with-current-buffer (overlay-buffer vcursor-overlay)
- (let ((start (goto-char (overlay-start vcursor-overlay))))
- (- (progn (apply func args) (point)) start)))
- )
+ (save-excursion
+ (let ((start (goto-char (overlay-start vcursor-overlay))))
+ (- (progn (apply func args) (point)) start)))))
;; Make sure the virtual cursor is active. Unless arg is non-nil,
;; report an error if it is not.
diff --git a/lisp/version.el b/lisp/version.el
index 3a3093fdd4a..5d0a1ae37dc 100644
--- a/lisp/version.el
+++ b/lisp/version.el
@@ -53,6 +53,8 @@ developing Emacs.")
(defvar ns-version-string)
(defvar cairo-version-string)
+(declare-function haiku-get-version-string "haikufns.c")
+
(defun emacs-version (&optional here)
"Return string describing the version of Emacs that is running.
If optional argument HERE is non-nil, insert string at point.
@@ -71,6 +73,8 @@ to the system configuration; look at `system-configuration' instead."
((featurep 'x-toolkit) ", X toolkit")
((featurep 'ns)
(format ", NS %s" ns-version-string))
+ ((featurep 'haiku)
+ (format ", Haiku %s" (haiku-get-version-string)))
(t ""))
(if (featurep 'cairo)
(format ", cairo version %s" cairo-version-string)
diff --git a/lisp/view.el b/lisp/view.el
index 3476ced3f79..321bc5f5660 100644
--- a/lisp/view.el
+++ b/lisp/view.el
@@ -36,8 +36,8 @@
;;; Suggested key bindings:
;;
-;; (define-key ctl-x-4-map "v" #'view-file-other-window) ; ^x4v
-;; (define-key ctl-x-5-map "v" #'view-file-other-frame) ; ^x5v
+;; (keymap-set ctl-x-4-map "v" #'view-file-other-window) ; C-x 4 v
+;; (keymap-set ctl-x-5-map "v" #'view-file-other-frame) ; C-x 5 v
;;
;; You could also bind `view-file', `view-buffer', `view-buffer-other-window' and
;; `view-buffer-other-frame' to keys.
@@ -142,68 +142,68 @@ that use View mode automatically.")
(defvar-local view-overlay nil
"Overlay used to display where a search operation found its match.
This is local in each buffer, once it is used.")
+
-;; Define keymap inside defvar to make it easier to load changes.
;; Some redundant "less"-like key bindings below have been commented out.
-(defvar view-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "C" #'View-kill-and-leave)
- (define-key map "c" #'View-leave)
- (define-key map "Q" #'View-quit-all)
- (define-key map "E" #'View-exit-and-edit)
- ;; (define-key map "v" #'View-exit)
- (define-key map "e" #'View-exit)
- (define-key map "q" #'View-quit)
- ;; (define-key map "N" #'View-search-last-regexp-backward)
- (define-key map "p" #'View-search-last-regexp-backward)
- (define-key map "n" #'View-search-last-regexp-forward)
- ;; (define-key map "?" #'View-search-regexp-backward) ; Less does this.
- (define-key map "\\" #'View-search-regexp-backward)
- (define-key map "/" #'View-search-regexp-forward)
- (define-key map "r" #'isearch-backward)
- (define-key map "s" #'isearch-forward)
- (define-key map "m" #'point-to-register)
- (define-key map "'" #'register-to-point)
- (define-key map "x" #'exchange-point-and-mark)
- (define-key map "@" #'View-back-to-mark)
- (define-key map "." #'set-mark-command)
- (define-key map "%" #'View-goto-percent)
- ;; (define-key map "G" #'View-goto-line-last)
- (define-key map "g" #'View-goto-line)
- (define-key map "=" #'what-line)
- (define-key map "F" #'View-revert-buffer-scroll-page-forward)
- ;; (define-key map "k" #'View-scroll-line-backward)
- (define-key map "y" #'View-scroll-line-backward)
- ;; (define-key map "j" #'View-scroll-line-forward)
- (define-key map "\n" #'View-scroll-line-forward)
- (define-key map "\r" #'View-scroll-line-forward)
- (define-key map "u" #'View-scroll-half-page-backward)
- (define-key map "d" #'View-scroll-half-page-forward)
- (define-key map "z" #'View-scroll-page-forward-set-page-size)
- (define-key map "w" #'View-scroll-page-backward-set-page-size)
- ;; (define-key map "b" #'View-scroll-page-backward)
- (define-key map "\C-?" #'View-scroll-page-backward)
- ;; (define-key map "f" #'View-scroll-page-forward)
- (define-key map " " #'View-scroll-page-forward)
- (define-key map [?\S-\ ] #'View-scroll-page-backward)
- (define-key map "o" #'View-scroll-to-buffer-end)
- (define-key map ">" #'end-of-buffer)
- (define-key map "<" #'beginning-of-buffer)
- (define-key map "-" #'negative-argument)
- (define-key map "9" #'digit-argument)
- (define-key map "8" #'digit-argument)
- (define-key map "7" #'digit-argument)
- (define-key map "6" #'digit-argument)
- (define-key map "5" #'digit-argument)
- (define-key map "4" #'digit-argument)
- (define-key map "3" #'digit-argument)
- (define-key map "2" #'digit-argument)
- (define-key map "1" #'digit-argument)
- (define-key map "0" #'digit-argument)
- (define-key map "H" #'describe-mode)
- (define-key map "?" #'describe-mode) ; Maybe do as less instead? See above.
- (define-key map "h" #'describe-mode)
- map))
+(defvar-keymap view-mode-map
+ :doc "Keymap for ‘view-mode’."
+ "C" #'View-kill-and-leave
+ "c" #'View-leave
+ "Q" #'View-quit-all
+ "E" #'View-exit-and-edit
+ ;; "v" #'View-exit
+ "e" #'View-exit
+ "q" #'View-quit
+ ;; "N" #'View-search-last-regexp-backward
+ "p" #'View-search-last-regexp-backward
+ "n" #'View-search-last-regexp-forward
+ ;; "?" #'View-search-regexp-backward ; Less does this.
+ "\\" #'View-search-regexp-backward
+ "/" #'View-search-regexp-forward
+ "r" #'isearch-backward
+ "s" #'isearch-forward
+ "m" #'point-to-register
+ "'" #'register-to-point
+ "x" #'exchange-point-and-mark
+ "@" #'View-back-to-mark
+ "." #'set-mark-command
+ "%" #'View-goto-percent
+ ;; "G" #'View-goto-line-last
+ "g" #'View-goto-line
+ "=" #'what-line
+ "F" #'View-revert-buffer-scroll-page-forward
+ ;; "k" #'View-scroll-line-backward
+ "y" #'View-scroll-line-backward
+ ;; "j" #'View-scroll-line-forward
+ "C-j" #'View-scroll-line-forward
+ "RET" #'View-scroll-line-forward
+ "u" #'View-scroll-half-page-backward
+ "d" #'View-scroll-half-page-forward
+ "z" #'View-scroll-page-forward-set-page-size
+ "w" #'View-scroll-page-backward-set-page-size
+ ;; "b" #'View-scroll-page-backward
+ "DEL" #'View-scroll-page-backward
+ ;; "f" #'View-scroll-page-forward
+ "SPC" #'View-scroll-page-forward
+ "S-SPC" #'View-scroll-page-backward
+ "o" #'View-scroll-to-buffer-end
+ ">" #'end-of-buffer
+ "<" #'beginning-of-buffer
+ "-" #'negative-argument
+ "9" #'digit-argument
+ "8" #'digit-argument
+ "7" #'digit-argument
+ "6" #'digit-argument
+ "5" #'digit-argument
+ "4" #'digit-argument
+ "3" #'digit-argument
+ "2" #'digit-argument
+ "1" #'digit-argument
+ "0" #'digit-argument
+ "H" #'describe-mode
+ "?" #'describe-mode ; Maybe do as less instead? See above.
+ "h" #'describe-mode)
+
;;; Commands that enter or exit view mode.
diff --git a/lisp/whitespace.el b/lisp/whitespace.el
index 017409d6a42..5a482c5253a 100644
--- a/lisp/whitespace.el
+++ b/lisp/whitespace.el
@@ -1687,32 +1687,32 @@ cleaning up these problems."
(or whitespace-active-style whitespace-style)))
(bogus-list
(mapcar
- #'(lambda (option)
- (when force
- (push (car option) style))
- (goto-char rstart)
- (let ((regexp
- (cond
- ((eq (car option) 'indentation)
- (whitespace-indentation-regexp))
- ((eq (car option) 'indentation::tab)
- (whitespace-indentation-regexp 'tab))
- ((eq (car option) 'indentation::space)
- (whitespace-indentation-regexp 'space))
- ((eq (car option) 'space-after-tab)
- (whitespace-space-after-tab-regexp))
- ((eq (car option) 'space-after-tab::tab)
- (whitespace-space-after-tab-regexp 'tab))
- ((eq (car option) 'space-after-tab::space)
- (whitespace-space-after-tab-regexp 'space))
- ((eq (car option) 'missing-newline-at-eof)
- "[^\n]\\'")
- (t
- (cdr option)))))
- (when (re-search-forward regexp rend t)
- (unless has-bogus
- (setq has-bogus (memq (car option) style)))
- t)))
+ (lambda (option)
+ (when force
+ (push (car option) style))
+ (goto-char rstart)
+ (let ((regexp
+ (cond
+ ((eq (car option) 'indentation)
+ (whitespace-indentation-regexp))
+ ((eq (car option) 'indentation::tab)
+ (whitespace-indentation-regexp 'tab))
+ ((eq (car option) 'indentation::space)
+ (whitespace-indentation-regexp 'space))
+ ((eq (car option) 'space-after-tab)
+ (whitespace-space-after-tab-regexp))
+ ((eq (car option) 'space-after-tab::tab)
+ (whitespace-space-after-tab-regexp 'tab))
+ ((eq (car option) 'space-after-tab::space)
+ (whitespace-space-after-tab-regexp 'space))
+ ((eq (car option) 'missing-newline-at-eof)
+ "[^\n]\\'")
+ (t
+ (cdr option)))))
+ (when (re-search-forward regexp rend t)
+ (unless has-bogus
+ (setq has-bogus (memq (car option) style)))
+ t)))
whitespace-report-list)))
(when (pcase report-if-bogus ('nil t) ('never nil) (_ has-bogus))
(whitespace-kill-buffer whitespace-report-buffer-name)
@@ -2463,5 +2463,4 @@ It should be added buffer-locally to `write-file-functions'."
"use `with-eval-after-load' instead." "28.1")
(run-hooks 'whitespace-load-hook)
-
;;; whitespace.el ends here
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index a2e9bf41ade..a53add7d084 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -131,16 +131,21 @@ This exists as a variable so it can be set locally in certain buffers.")
(((class grayscale color)
(background light))
:background "gray85"
+ ;; We use negative thickness of the horizontal box border line to
+ ;; avoid making lines taller when fields become visible.
+ :box (:line-width (1 . -1) :color "gray80")
:extend t)
(((class grayscale color)
(background dark))
:background "dim gray"
+ :box (:line-width (1 . -1) :color "gray46")
:extend t)
(t
:slant italic
:extend t))
"Face used for editable fields."
- :group 'widget-faces)
+ :group 'widget-faces
+ :version "28.1")
(defface widget-single-line-field '((((type tty))
:background "green3"
@@ -2963,7 +2968,8 @@ Save CHILD into the :last-deleted list, so it can be inserted later."
"A widget which groups other widgets inside."
:convert-widget 'widget-types-convert-widget
:copy 'widget-types-copy
- :format ":\n%v"
+ :format (concat (propertize ":" 'display "")
+ "\n%v")
:value-create 'widget-group-value-create
:value-get 'widget-editable-list-value-get
:default-get 'widget-group-default-get
@@ -3320,7 +3326,7 @@ It reads a file name from an editable text field."
;;; (file (file-name-nondirectory value))
;;; (menu-tag (widget-apply widget :menu-tag-get))
;;; (must-match (widget-get widget :must-match))
-;;; (answer (read-file-name (concat menu-tag " (default " value "): ")
+;;; (answer (read-file-name (format-prompt menu-tag value)
;;; dir nil must-match file)))
;;; (widget-value-set widget (abbreviate-file-name answer))
;;; (widget-setup)
diff --git a/lisp/widget.el b/lisp/widget.el
index 393fe6c21b3..0232f6cf93f 100644
--- a/lisp/widget.el
+++ b/lisp/widget.el
@@ -44,7 +44,7 @@
;; (list 'or (list 'boundp (list 'car 'keywords))
;; (list 'set (list 'car 'keywords) (list 'car 'keywords)))
;; (list 'setq 'keywords (list 'cdr 'keywords)))))
- (declare (obsolete nil "27.1"))
+ (declare (obsolete nil "27.1") (indent defun))
nil)
;;(define-widget-keywords :documentation-indent
@@ -83,7 +83,7 @@ create identical widgets:
* (apply #\\='widget-create CLASS ARGS)
The third argument DOC is a documentation string for the widget."
- (declare (doc-string 3))
+ (declare (doc-string 3) (indent defun))
;;
(unless (or (null doc) (stringp doc))
(error "Widget documentation must be nil or a string"))
diff --git a/lisp/windmove.el b/lisp/windmove.el
index 658e59af198..8904f5cbf70 100644
--- a/lisp/windmove.el
+++ b/lisp/windmove.el
@@ -700,7 +700,7 @@ where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or
a single modifier.
If PREFIX is `none', no prefix is used. If MODIFIERS is `none',
the keybindings are directly bound to the arrow keys.
-Default value of PREFIX is `C-x' and MODIFIERS is `shift'."
+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))
diff --git a/lisp/window.el b/lisp/window.el
index d12232641e3..0f17bb28b4c 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -108,11 +108,14 @@ Return the buffer."
;; Return the buffer.
buffer)))
+;; Defined in help.el.
+(defvar resize-temp-buffer-window-inhibit)
+
(defun temp-buffer-window-show (buffer &optional action)
"Show temporary buffer BUFFER in a window.
Return the window showing BUFFER. Pass ACTION as action argument
to `display-buffer'."
- (let (window frame)
+ (let (resize-temp-buffer-window-inhibit window)
(with-current-buffer buffer
(set-buffer-modified-p nil)
(setq buffer-read-only t)
@@ -130,9 +133,9 @@ to `display-buffer'."
t
window-combination-limit)))
(setq window (display-buffer buffer action)))
- (setq frame (window-frame window))
- (unless (eq frame (selected-frame))
- (raise-frame frame))
+ ;; We used to raise the window's frame here. Do not do that
+ ;; since it would override an `inhibit-switch-frame' entry
+ ;; specified for the action alist used by `display-buffer'.
(setq minibuffer-scroll-window window)
(set-window-hscroll window 0)
(with-selected-window window
@@ -1514,21 +1517,11 @@ Emacs won't change the size of any window displaying that buffer,
unless it has no other choice (like when deleting a neighboring
window).")
-(defun window--preservable-size (window &optional horizontal)
- "Return height of WINDOW as `window-preserve-size' would preserve it.
-Optional argument HORIZONTAL non-nil means to return the width of
-WINDOW as `window-preserve-size' would preserve it."
- (if horizontal
- (window-body-width window t)
- (+ (window-body-height window t)
- (window-header-line-height window)
- (window-mode-line-height window))))
-
(defun window-preserve-size (&optional window horizontal preserve)
- "Preserve height of window WINDOW.
+ "Preserve height of specified WINDOW's body.
WINDOW must be a live window and defaults to the selected one.
-Optional argument HORIZONTAL non-nil means preserve the width of
-WINDOW.
+Optional argument HORIZONTAL non-nil means to preserve the width
+of WINDOW's body.
PRESERVE t means to preserve the current height/width of WINDOW's
body in frame and window resizing operations whenever possible.
@@ -1545,21 +1538,15 @@ WINDOW as argument also removes the respective restraint.
Other values of PRESERVE are reserved for future use."
(setq window (window-normalize-window window t))
(let* ((parameter (window-parameter window 'window-preserved-size))
- (width (nth 1 parameter))
- (height (nth 2 parameter)))
- (if horizontal
- (set-window-parameter
- window 'window-preserved-size
- (list
- (window-buffer window)
- (and preserve (window--preservable-size window t))
- height))
- (set-window-parameter
- window 'window-preserved-size
- (list
- (window-buffer window)
- width
- (and preserve (window--preservable-size window)))))))
+ (width (if horizontal
+ (and preserve (window-body-width window t))
+ (nth 1 parameter)))
+ (height (if horizontal
+ (nth 2 parameter)
+ (and preserve (window-body-height window t)))))
+ (set-window-parameter
+ window 'window-preserved-size
+ (list (window-buffer window) width height))))
(defun window-preserved-size (&optional window horizontal)
"Return preserved height of window WINDOW.
@@ -1567,12 +1554,9 @@ WINDOW must be a live window and defaults to the selected one.
Optional argument HORIZONTAL non-nil means to return preserved
width of WINDOW."
(setq window (window-normalize-window window t))
- (let* ((parameter (window-parameter window 'window-preserved-size))
- (buffer (nth 0 parameter))
- (width (nth 1 parameter))
- (height (nth 2 parameter)))
- (when (eq buffer (window-buffer window))
- (if horizontal width height))))
+ (let ((parameter (window-parameter window 'window-preserved-size)))
+ (when (eq (nth 0 parameter) (window-buffer window))
+ (nth (if horizontal 1 2) parameter))))
(defun window--preserve-size (window horizontal)
"Return non-nil when the height of WINDOW shall be preserved.
@@ -1580,7 +1564,7 @@ Optional argument HORIZONTAL non-nil means to return non-nil when
the width of WINDOW shall be preserved."
(let ((size (window-preserved-size window horizontal)))
(and (numberp size)
- (= size (window--preservable-size window horizontal)))))
+ (= size (window-body-size window horizontal t)))))
(defun window-safe-min-size (&optional window horizontal pixelwise)
"Return safe minimum size of WINDOW.
@@ -7250,11 +7234,15 @@ Return WINDOW if BUFFER and WINDOW are live."
(inhibit-modification-hooks t))
(funcall (cdr (assq 'body-function alist)) window)))
- (let ((quit-restore (window-parameter window 'quit-restore))
- (height (cdr (assq 'window-height alist)))
- (width (cdr (assq 'window-width alist)))
- (size (cdr (assq 'window-size alist)))
- (preserve-size (cdr (assq 'preserve-size alist))))
+ (let* ((frame (window-frame window))
+ (quit-restore (window-parameter window 'quit-restore))
+ (window-height (assq 'window-height alist))
+ (height (cdr window-height))
+ (window-width (assq 'window-width alist))
+ (width (cdr window-width))
+ (window-size (assq 'window-size alist))
+ (size (cdr window-size))
+ (preserve-size (cdr (assq 'preserve-size alist))))
(cond
((or (eq type 'frame)
(and (eq (car quit-restore) 'same)
@@ -7265,29 +7253,43 @@ Return WINDOW if BUFFER and WINDOW are live."
;; Adjust size of frame if asked for. We probably should do
;; that only for a single window frame.
(cond
- ((not size))
+ ((not size)
+ (when window-size
+ (setq resize-temp-buffer-window-inhibit t)))
((consp size)
- (let ((width (car size))
- (height (cdr size))
- (frame (window-frame window)))
- (when (and (numberp width) (numberp height))
- (set-frame-height
- frame (+ (frame-height frame)
- (- height (window-total-height window))))
- (set-frame-width
- frame (+ (frame-width frame)
- (- width (window-total-width window)))))))
- ((functionp size)
- (ignore-errors (funcall size window)))))
+ ;; Modifying the parameters of a newly created frame might
+ ;; not work everywhere, but then `temp-buffer-resize-mode'
+ ;; will certainly fail in a similar fashion.
+ (if (eq (car size) 'body-chars)
+ (let ((width (+ (frame-text-width frame)
+ (* (frame-char-width frame) (cadr size))
+ (- (window-body-width window t))))
+ (height (+ (frame-text-height frame)
+ (* (frame-char-height frame) (cddr size))
+ (- (window-body-height window t)))))
+ (modify-frame-parameters
+ frame `((height . (text-pixels . ,height))
+ (width . (text-pixels . ,width)))))
+ (let ((width (- (+ (frame-width frame) (car size))
+ (window-total-width window)))
+ (height (- (+ (frame-height frame) (cdr size))
+ (window-total-height window))))
+ (modify-frame-parameters
+ frame `((height . ,height) (width . ,width)))))
+ (setq resize-temp-buffer-window-inhibit t))
+ ((functionp size)
+ (ignore-errors (funcall size window))
+ (setq resize-temp-buffer-window-inhibit t))))
((or (eq type 'window)
(and (eq (car quit-restore) 'same)
(eq (nth 1 quit-restore) 'window)))
;; A window that never showed another buffer but BUFFER ever
- ;; since it was created on an existing frame.
- ;;
- ;; Adjust width and/or height of window if asked for.
+ ;; since it was created on an existing frame. Adjust its width
+ ;; and/or height if asked for.
(cond
- ((not height))
+ ((not height)
+ (when window-height
+ (setq resize-temp-buffer-window-inhibit 'vertical)))
((numberp height)
(let* ((new-height
(if (integerp height)
@@ -7298,12 +7300,23 @@ Return WINDOW if BUFFER and WINDOW are live."
(delta (- new-height (window-total-height window))))
(when (and (window--resizable-p window delta nil 'safe)
(window-combined-p window))
- (window-resize window delta nil 'safe))))
- ((functionp height)
- (ignore-errors (funcall height window))))
+ (window-resize window delta nil 'safe)))
+ (setq resize-temp-buffer-window-inhibit 'vertical))
+ ((and (consp height) (eq (car height) 'body-lines))
+ (let* ((delta (- (* (frame-char-height frame) (cdr height))
+ (window-body-height window t))))
+ (and (window--resizable-p window delta nil 'safe nil nil nil t)
+ (window-combined-p window)
+ (window-resize window delta nil 'safe t)))
+ (setq resize-temp-buffer-window-inhibit 'vertical))
+ ((functionp height)
+ (ignore-errors (funcall height window))
+ (setq resize-temp-buffer-window-inhibit 'vertical)))
;; Adjust width of window if asked for.
(cond
- ((not width))
+ ((not width)
+ (when window-width
+ (setq resize-temp-buffer-window-inhibit 'horizontal)))
((numberp width)
(let* ((new-width
(if (integerp width)
@@ -7314,13 +7327,24 @@ Return WINDOW if BUFFER and WINDOW are live."
(delta (- new-width (window-total-width window))))
(when (and (window--resizable-p window delta t 'safe)
(window-combined-p window t))
- (window-resize window delta t 'safe))))
+ (window-resize window delta t 'safe)))
+ (setq resize-temp-buffer-window-inhibit 'horizontal))
+ ((and (consp width) (eq (car width) 'body-columns))
+ (let* ((delta (- (* (frame-char-width frame) (cdr width))
+ (window-body-width window t))))
+ (and (window--resizable-p window delta t 'safe nil nil nil t)
+ (window-combined-p window t)
+ (window-resize window delta t 'safe t)))
+ (setq resize-temp-buffer-window-inhibit 'horizontal))
((functionp width)
- (ignore-errors (funcall width window))))
+ (ignore-errors (funcall width window))
+ (setq resize-temp-buffer-window-inhibit 'horizontal)))
+
;; Preserve window size if asked for.
(when (consp preserve-size)
(window-preserve-size window t (car preserve-size))
(window-preserve-size window nil (cdr preserve-size)))))
+
;; Assign any window parameters specified.
(let ((parameters (cdr (assq 'window-parameters alist))))
(dolist (parameter parameters)
@@ -7563,6 +7587,9 @@ Action alist entries are:
window from being used for display.
`inhibit-switch-frame' -- A non-nil value prevents any frame
used for showing the buffer from being raised or selected.
+ Note that a window manager may still raise a new frame and
+ give it focus, effectively overriding the value specified
+ here.
`reusable-frames' -- The value specifies the set of frames to
search for a window that already displays the buffer.
Possible values are nil (the selected frame), t (any live
@@ -7572,20 +7599,33 @@ Action alist entries are:
frame parameters to give a new frame, if one is created.
`window-height' -- The value specifies the desired height of the
window chosen and is either an integer (the total height of
- the window), a floating point number (the fraction of its
- total height with respect to the total height of the frame's
- root window) or a function to be called with one argument -
- the chosen window. The function is supposed to adjust the
- height of the window; its return value is ignored. Suitable
- functions are `shrink-window-if-larger-than-buffer' and
- `fit-window-to-buffer'.
+ the window specified in frame lines), a floating point
+ number (the fraction of its total height with respect to the
+ total height of the frame's root window), a cons cell whose
+ car is 'body-lines' and whose cdr is an integer that
+ specifies the height of the window's body in frame lines, or
+ a function to be called with one argument - the chosen
+ window. That function is supposed to adjust the height of
+ the window. Suitable functions are `fit-window-to-buffer'
+ and `shrink-window-if-larger-than-buffer'.
`window-width' -- The value specifies the desired width of the
window chosen and is either an integer (the total width of
- the window), a floating point number (the fraction of its
- total width with respect to the width of the frame's root
- window) or a function to be called with one argument - the
- chosen window. The function is supposed to adjust the width
- of the window; its return value is ignored.
+ the window specified in frame lines), a floating point
+ number (the fraction of its total width with respect to the
+ width of the frame's root window), a cons cell whose car is
+ 'body-columns' and whose cdr is an integer that specifies the
+ width of the window's body in frame columns, or a function to
+ be called with one argument - the chosen window. That
+ function is supposed to adjust the width of the window.
+ `window-size' -- This entry is only useful for windows appearing
+ alone on their frame and specifies the desired size of that
+ window either as a cons of integers (the total width and
+ height of the window on that frame), a cons cell whose car is
+ 'body-chars' and whose cdr is a cons of integers (the desired
+ width and height of the window's body in columns and lines of
+ its frame), or a function to be called with one argument -
+ the chosen window. That function is supposed to adjust the
+ size of the frame.
`preserve-size' -- The value should be either (t . nil) to
preserve the width of the chosen window, (nil . t) to
preserve its height or (t . t) to preserve its height and
@@ -7601,9 +7641,9 @@ Action alist entries are:
to fill the window body with some contents that might depend
on dimensions of the displayed window.
-The entries `window-height', `window-width' and `preserve-size'
-are applied only when the window used for displaying the buffer
-never showed another buffer before.
+The entries `window-height', `window-width', `window-size' and
+`preserve-size' are applied only when the window used for
+displaying the buffer never showed another buffer before.
The ACTION argument can also have a non-nil and non-list value.
This means to display the buffer in a window other than the
@@ -8534,7 +8574,7 @@ from the list of completions and default values."
(let ((rbts-completion-table (internal-complete-buffer-except)))
(minibuffer-with-setup-hook
(lambda ()
- (setq minibuffer-completion-table rbts-completion-table)
+ (setq-local minibuffer-completion-table rbts-completion-table)
;; Since rbts-completion-table is built dynamically, we
;; can't just add it to the default value of
;; icomplete-with-completion-tables, so we add it
diff --git a/lisp/xdg.el b/lisp/xdg.el
index ee5d292ce65..60558982146 100644
--- a/lisp/xdg.el
+++ b/lisp/xdg.el
@@ -41,13 +41,11 @@
;; XDG Base Directory Specification
;; https://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
-(defmacro xdg--dir-home (environ default-path)
- (declare (debug (stringp stringp)))
- (let ((env (make-symbol "env")))
- `(let ((,env (getenv ,environ)))
- (if (or (null ,env) (not (file-name-absolute-p ,env)))
- (expand-file-name ,default-path)
- ,env))))
+(defun xdg--dir-home (environ default-path)
+ (let ((env (getenv environ)))
+ (if (or (null env) (not (file-name-absolute-p env)))
+ (expand-file-name default-path)
+ env)))
(defun xdg-config-home ()
"Return the base directory for user specific configuration files.
@@ -85,6 +83,23 @@ According to the XDG Base Directory Specification version
should be used.\""
(xdg--dir-home "XDG_DATA_HOME" "~/.local/share"))
+(defun xdg-state-home ()
+ "Return the base directory for user-specific state data.
+
+According to the XDG Base Directory Specification version
+0.8 (8th May 2021):
+
+ \"The $XDG_STATE_HOME 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. It may contain:
+
+ * actions history (logs, history, recently used files, …)
+
+ * current state of the application that can be reused on a
+ restart (view, layout, open files, undo history, …)\""
+ (xdg--dir-home "XDG_STATE_HOME" "~/.local/state"))
+
(defun xdg-runtime-dir ()
"Return the value of $XDG_RUNTIME_DIR.
diff --git a/lisp/xml.el b/lisp/xml.el
index 0282e3741c0..e2ba02e1952 100644
--- a/lisp/xml.el
+++ b/lisp/xml.el
@@ -612,8 +612,8 @@ references."
(if (setq ref (match-string 2))
(progn ; Numeric char reference
(setq val (save-match-data
- (decode-char 'ucs (string-to-number
- ref (if (match-string 1) 16)))))
+ (string-to-number
+ ref (if (match-string 1) 16))))
(and (null val)
xml-validating-parser
(error "XML: (Validity) Invalid character reference `%s'"
@@ -898,11 +898,11 @@ references and parameter-entity references."
ref val)
(cond ((setq ref (match-string 1 string))
;; Decimal character reference
- (setq val (decode-char 'ucs (string-to-number ref)))
+ (setq val (string-to-number ref))
(if val (push (string val) children)))
;; Hexadecimal character reference
((setq ref (match-string 2 string))
- (setq val (decode-char 'ucs (string-to-number ref 16)))
+ (setq val (string-to-number ref 16))
(if val (push (string val) children)))
;; Parameter entity reference
((setq ref (match-string 3 string))
@@ -962,7 +962,7 @@ STRING is assumed to occur in an XML attribute value."
(if ref
;; [4.6] Character references are included as
;; character data.
- (let ((val (decode-char 'ucs (string-to-number ref (if is-hex 16)))))
+ (let ((val (string-to-number ref (if is-hex 16))))
(push (cond (val (string val))
(xml-validating-parser
(error "XML: (Validity) Undefined character `x%s'" ref))
diff --git a/lisp/xwidget.el b/lisp/xwidget.el
index 8c593abea88..ce9839ebd34 100644
--- a/lisp/xwidget.el
+++ b/lisp/xwidget.el
@@ -33,10 +33,12 @@
(require 'cl-lib)
(require 'bookmark)
+(require 'format-spec)
(declare-function make-xwidget "xwidget.c"
- (type title width height arguments &optional buffer))
+ (type title width height arguments &optional buffer related))
(declare-function xwidget-buffer "xwidget.c" (xwidget))
+(declare-function set-xwidget-buffer "xwidget.c" (xwidget buffer))
(declare-function xwidget-size-request "xwidget.c" (xwidget))
(declare-function xwidget-resize "xwidget.c" (xwidget new-width new-height))
(declare-function xwidget-webkit-execute-script "xwidget.c"
@@ -53,31 +55,33 @@
(declare-function delete-xwidget-view "xwidget.c" (xwidget-view))
(declare-function get-buffer-xwidgets "xwidget.c" (buffer))
(declare-function xwidget-query-on-exit-flag "xwidget.c" (xwidget))
+(declare-function xwidget-webkit-back-forward-list "xwidget.c" (xwidget &optional limit))
+(declare-function xwidget-webkit-estimated-load-progress "xwidget.c" (xwidget))
+(declare-function xwidget-webkit-set-cookie-storage-file "xwidget.c" (xwidget file))
+(declare-function xwidget-live-p "xwidget.c" (xwidget))
+(declare-function xwidget-webkit-stop-loading "xwidget.c" (xwidget))
(defgroup xwidget nil
"Displaying native widgets in Emacs buffers."
:group 'widgets)
-(defun xwidget-insert (pos type title width height &optional args)
+(defun xwidget-insert (pos type title width height &optional args related)
"Insert an xwidget at position POS.
-Supply the xwidget's TYPE, TITLE, WIDTH, and HEIGHT.
+Supply the xwidget's TYPE, TITLE, WIDTH, HEIGHT, and RELATED.
See `make-xwidget' for the possible TYPE values.
The usage of optional argument ARGS depends on the xwidget.
This returns the result of `make-xwidget'."
(goto-char pos)
- (let ((id (make-xwidget type title width height args)))
+ (let ((id (make-xwidget type title width height args nil related)))
(put-text-property (point) (+ 1 (point))
'display (list 'xwidget ':xwidget id))
id))
(defun xwidget-at (pos)
"Return xwidget at POS."
- ;; TODO this function is a bit tedious because the C layer isn't well
- ;; protected yet and xwidgetp apparently doesn't work yet.
(let* ((disp (get-text-property pos 'display))
- (xw (car (cdr (cdr disp)))))
- ;;(if (xwidgetp xw) xw nil)
- (if (equal 'xwidget (car disp)) xw)))
+ (xw (car (cdr (cdr disp)))))
+ (when (xwidget-live-p xw) xw)))
@@ -88,6 +92,29 @@ This returns the result of `make-xwidget'."
(require 'seq)
(require 'url-handlers)
+(defgroup xwidget-webkit nil
+ "Displaying webkit xwidgets in Emacs buffers."
+ :version "29.1"
+ :group 'web
+ :prefix "xwidget-webkit-")
+
+(defcustom xwidget-webkit-buffer-name-format "*xwidget-webkit: %T*"
+ "Template for naming `xwidget-webkit' buffers.
+It can use the following special constructs:
+
+ %T -- the title of the Web page loaded by the xwidget.
+ %U -- the URI of the Web page loaded by the xwidget."
+ :type 'string
+ :version "29.1")
+
+(defcustom xwidget-webkit-cookie-file nil
+ "The name of the file where `xwidget-webkit-browse-url' will store cookies.
+They will be stored as plain text in Mozilla \"cookies.txt\"
+format. If nil, do not store cookies. You must kill all xwidget-webkit
+buffers for this setting to take effect after setting it to nil."
+ :type '(choice (const :tag "Do not store cookies" nil) file)
+ :version "29.1")
+
;;;###autoload
(defun xwidget-webkit-browse-url (url &optional new-session)
"Ask xwidget-webkit to browse URL.
@@ -124,6 +151,45 @@ in `split-window-right' with a new xwidget webkit session."
(with-selected-window (split-window-right)
(xwidget-webkit-new-session url))))
+(declare-function xwidget-perform-lispy-event "xwidget.c")
+
+(defvar xwidget-webkit--input-method-events nil
+ "Internal variable used to store input method events.")
+
+(defvar-local xwidget-webkit--loading-p nil
+ "Whether or not a page is being loaded.")
+
+(defvar-local xwidget-webkit--progress-update-timer nil
+ "Timer that updates the display of page load progress in the header line.")
+
+(defun xwidget-webkit-pass-command-event-with-input-method ()
+ "Handle a `with-input-method' event."
+ (interactive)
+ (let ((key (pop unread-command-events)))
+ (setq xwidget-webkit--input-method-events
+ (funcall input-method-function key))
+ (exit-minibuffer)))
+
+(defun xwidget-webkit-pass-command-event ()
+ "Pass `last-command-event' to the current buffer's WebKit widget.
+If `current-input-method' is non-nil, consult `input-method-function'
+for the actual events that will be sent."
+ (interactive)
+ (if (and current-input-method
+ (characterp last-command-event))
+ (let ((xwidget-webkit--input-method-events nil)
+ (minibuffer-local-map (make-keymap)))
+ (define-key minibuffer-local-map [with-input-method]
+ 'xwidget-webkit-pass-command-event-with-input-method)
+ (push last-command-event unread-command-events)
+ (push 'with-input-method unread-command-events)
+ (read-from-minibuffer "" nil nil nil nil nil t)
+ (dolist (event xwidget-webkit--input-method-events)
+ (xwidget-perform-lispy-event (xwidget-webkit-current-session)
+ event)))
+ (xwidget-perform-lispy-event (xwidget-webkit-current-session)
+ last-command-event)))
+
;;todo.
;; - check that the webkit support is compiled in
(defvar xwidget-webkit-mode-map
@@ -133,11 +199,14 @@ in `split-window-right' with a new xwidget webkit session."
(define-key map "b" 'xwidget-webkit-back)
(define-key map "f" 'xwidget-webkit-forward)
(define-key map "r" 'xwidget-webkit-reload)
- (define-key map "t" (lambda () (interactive) (message "o"))) ;FIXME: ?!?
(define-key map "\C-m" 'xwidget-webkit-insert-string)
(define-key map "w" 'xwidget-webkit-current-url)
(define-key map "+" 'xwidget-webkit-zoom-in)
(define-key map "-" 'xwidget-webkit-zoom-out)
+ (define-key map "e" 'xwidget-webkit-edit-mode)
+ (define-key map "\C-r" 'xwidget-webkit-isearch-mode)
+ (define-key map "\C-s" 'xwidget-webkit-isearch-mode)
+ (define-key map "H" 'xwidget-webkit-browse-history)
;;similar to image mode bindings
(define-key map (kbd "SPC") 'xwidget-webkit-scroll-up)
@@ -164,6 +233,70 @@ in `split-window-right' with a new xwidget webkit session."
map)
"Keymap for `xwidget-webkit-mode'.")
+(easy-menu-define nil xwidget-webkit-mode-map "Xwidget WebKit menu."
+ (list "Xwidget WebKit"
+ ["Browse URL" xwidget-webkit-browse-url
+ :active t
+ :help "Prompt for a URL, then instruct WebKit to browse it"]
+ ["Back" xwidget-webkit-back t]
+ ["Forward" xwidget-webkit-forward t]
+ ["Reload" xwidget-webkit-reload t]
+ ["History" xwidget-webkit-browse-history t]
+ ["Insert String" xwidget-webkit-insert-string
+ :active t
+ :help "Insert a string into the currently active field"]
+ ["Zoom In" xwidget-webkit-zoom-in t]
+ ["Zoom Out" xwidget-webkit-zoom-out t]
+ ["Edit Mode" xwidget-webkit-edit-mode
+ :active t
+ :style toggle
+ :selected xwidget-webkit-edit-mode
+ :help "Send self inserting characters to the WebKit widget"]
+ ["Save Selection" xwidget-webkit-copy-selection-as-kill
+ :active t
+ :help "Save the browser's selection in the kill ring"]
+ ["Incremental Search" xwidget-webkit-isearch-mode
+ :active (not xwidget-webkit-isearch-mode)
+ :help "Perform incremental search inside the WebKit widget"]
+ ["Stop Loading" xwidget-webkit-stop
+ :active xwidget-webkit--loading-p]))
+
+(defvar xwidget-webkit-tool-bar-map
+ (let ((map (make-sparse-keymap)))
+ (prog1 map
+ (tool-bar-local-item-from-menu 'xwidget-webkit-stop
+ "cancel"
+ map
+ xwidget-webkit-mode-map)
+ (tool-bar-local-item-from-menu 'xwidget-webkit-back
+ "left-arrow"
+ map
+ xwidget-webkit-mode-map)
+ (tool-bar-local-item-from-menu 'xwidget-webkit-forward
+ "right-arrow"
+ map
+ xwidget-webkit-mode-map)
+ (tool-bar-local-item-from-menu 'xwidget-webkit-reload
+ "refresh"
+ map
+ xwidget-webkit-mode-map)
+ (tool-bar-local-item-from-menu 'xwidget-webkit-zoom-in
+ "zoom-in"
+ map
+ xwidget-webkit-mode-map)
+ (tool-bar-local-item-from-menu 'xwidget-webkit-zoom-out
+ "zoom-out"
+ map
+ xwidget-webkit-mode-map)
+ (tool-bar-local-item-from-menu 'xwidget-webkit-browse-url
+ "connect-to-url"
+ map
+ xwidget-webkit-mode-map)
+ (tool-bar-local-item-from-menu 'xwidget-webkit-isearch-mode
+ "search"
+ map
+ xwidget-webkit-mode-map))))
+
(defun xwidget-webkit-zoom-in ()
"Increase webkit view zoom factor."
(interactive nil xwidget-webkit-mode)
@@ -246,10 +379,13 @@ If N is omitted or nil, scroll backwards by one char."
(xwidget-webkit-current-session)
"window.scrollTo(pageXOffset, window.document.body.scrollHeight);"))
-;; The xwidget event needs to go into a higher level handler
-;; since the xwidget can generate an event even if it's offscreen.
-;; TODO this needs to use callbacks and consider different xwidget event types.
-(define-key (current-global-map) [xwidget-event] #'xwidget-event-handler)
+;; The xwidget event needs to go in the special map. To receive
+;; xwidget events, you should place a callback in the property list of
+;; the xwidget, instead of handling these events manually.
+;;
+;; See `xwidget-webkit-new-session' for an example of how to do this.
+(define-key special-event-map [xwidget-event] #'xwidget-event-handler)
+
(defun xwidget-log (&rest msg)
"Log MSG to a buffer."
(let ((buf (get-buffer-create " *xwidget-log*")))
@@ -265,7 +401,18 @@ If N is omitted or nil, scroll backwards by one char."
((xwidget-event-type (nth 1 last-input-event))
(xwidget (nth 2 last-input-event))
(xwidget-callback (xwidget-get xwidget 'callback)))
- (funcall xwidget-callback xwidget xwidget-event-type)))
+ (when xwidget-callback
+ (funcall xwidget-callback xwidget xwidget-event-type))))
+
+(defun xwidget-webkit--update-progress-timer-function (xwidget)
+ "Force an update of the header line of XWIDGET's buffer."
+ (with-current-buffer (xwidget-buffer xwidget)
+ (force-mode-line-update)))
+
+(defun xwidget-webkit-buffer-kill ()
+ "Clean up an xwidget-webkit buffer before it is killed."
+ (when (timerp xwidget-webkit--progress-update-timer)
+ (cancel-timer xwidget-webkit--progress-update-timer)))
(defun xwidget-webkit-callback (xwidget xwidget-event-type)
"Callback for xwidgets.
@@ -273,30 +420,58 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget."
(if (not (buffer-live-p (xwidget-buffer xwidget)))
(xwidget-log
"error: callback called for xwidget with dead buffer")
- (with-current-buffer (xwidget-buffer xwidget)
- (cond ((eq xwidget-event-type 'load-changed)
- (let ((title (xwidget-webkit-title xwidget)))
- (xwidget-log "webkit finished loading: %s" title)
- ;; Do not adjust webkit size to window here, the selected window
- ;; can be the mini-buffer window unwantedly.
- (rename-buffer (format "*xwidget webkit: %s *" title) t)))
- ((eq xwidget-event-type 'decide-policy)
- (let ((strarg (nth 3 last-input-event)))
- (if (string-match ".*#\\(.*\\)" strarg)
- (xwidget-webkit-show-id-or-named-element
- xwidget
- (match-string 1 strarg)))))
- ;; TODO: Response handling other than download.
- ((eq xwidget-event-type 'download-callback)
- (let ((url (nth 3 last-input-event))
- (mime-type (nth 4 last-input-event))
- (file-name (nth 5 last-input-event)))
- (xwidget-webkit-save-as-file url mime-type file-name)))
- ((eq xwidget-event-type 'javascript-callback)
- (let ((proc (nth 3 last-input-event))
- (arg (nth 4 last-input-event)))
- (funcall proc arg)))
- (t (xwidget-log "unhandled event:%s" xwidget-event-type))))))
+ (cond ((eq xwidget-event-type 'load-changed)
+ (let ((title (xwidget-webkit-title xwidget))
+ (uri (xwidget-webkit-uri xwidget)))
+ (when-let ((buffer (get-buffer "*Xwidget WebKit History*")))
+ (with-current-buffer buffer
+ (revert-buffer)))
+ (with-current-buffer (xwidget-buffer xwidget)
+ (if (string-equal (nth 3 last-input-event)
+ "load-finished")
+ (progn
+ (setq xwidget-webkit--loading-p nil)
+ (cancel-timer xwidget-webkit--progress-update-timer))
+ (unless xwidget-webkit--loading-p
+ (setq xwidget-webkit--loading-p t
+ xwidget-webkit--progress-update-timer
+ (run-at-time 0.5 0.5 #'xwidget-webkit--update-progress-timer-function
+ xwidget)))))
+ ;; This funciton will be called multi times, so only
+ ;; change buffer name when the load actually completes
+ ;; this can limit buffer-name flicker in mode-line.
+ (when (or (string-equal (nth 3 last-input-event)
+ "load-finished")
+ (> (length title) 0))
+ (with-current-buffer (xwidget-buffer xwidget)
+ (force-mode-line-update)
+ (xwidget-log "webkit finished loading: %s" title)
+ ;; Do not adjust webkit size to window here, the
+ ;; selected window can be the mini-buffer window
+ ;; unwantedly.
+ (rename-buffer
+ (format-spec
+ xwidget-webkit-buffer-name-format
+ `((?T . ,title)
+ (?U . ,uri)))
+ t)))))
+ ((eq xwidget-event-type 'decide-policy)
+ (let ((strarg (nth 3 last-input-event)))
+ (if (string-match ".*#\\(.*\\)" strarg)
+ (xwidget-webkit-show-id-or-named-element
+ xwidget
+ (match-string 1 strarg)))))
+ ;; TODO: Response handling other than download.
+ ((eq xwidget-event-type 'download-callback)
+ (let ((url (nth 3 last-input-event))
+ (mime-type (nth 4 last-input-event))
+ (file-name (nth 5 last-input-event)))
+ (xwidget-webkit-save-as-file url mime-type file-name)))
+ ((eq xwidget-event-type 'javascript-callback)
+ (let ((proc (nth 3 last-input-event))
+ (arg (nth 4 last-input-event)))
+ (funcall proc arg)))
+ (t (xwidget-log "unhandled event:%s" xwidget-event-type)))))
(defvar bookmark-make-record-function)
(when (memq window-system '(mac ns))
@@ -309,8 +484,21 @@ If non-nil, plugins are enabled. Otherwise, disabled."
(define-derived-mode xwidget-webkit-mode special-mode "xwidget-webkit"
"Xwidget webkit view mode."
(setq buffer-read-only t)
+ (add-hook 'kill-buffer-hook #'xwidget-webkit-buffer-kill)
+ (setq-local tool-bar-map xwidget-webkit-tool-bar-map)
(setq-local bookmark-make-record-function
#'xwidget-webkit-bookmark-make-record)
+ (setq-local header-line-format
+ (list "WebKit: "
+ '(:eval
+ (xwidget-webkit-title (xwidget-webkit-current-session)))
+ '(:eval
+ (when xwidget-webkit--loading-p
+ (let ((session (xwidget-webkit-current-session)))
+ (format " [%d%%%%]"
+ (* 100
+ (xwidget-webkit-estimated-load-progress
+ session))))))))
;; Keep track of [vh]scroll when switching buffers
(image-mode-setup-winprops))
@@ -386,6 +574,10 @@ The latter might be nil."
(let ((size (xwidget-size-request xw)))
(xwidget-resize xw (car size) (cadr size))))
+(defun xwidget-webkit-stop ()
+ "Stop trying to load the current page."
+ (interactive)
+ (xwidget-webkit-stop-loading (xwidget-webkit-current-session)))
(defvar xwidget-webkit-activeelement-js"
function findactiveelement(doc){
@@ -606,10 +798,15 @@ For example, use this to display an anchor."
(defun xwidget-webkit-new-session (url &optional callback)
"Create a new webkit session buffer with URL."
- (let*
- ((bufname (generate-new-buffer-name "*xwidget-webkit*"))
- (callback (or callback #'xwidget-webkit-callback))
- xw)
+ (let* ((bufname
+ ;; Generate a temp-name based on current buffer name. it
+ ;; will be renamed by `xwidget-webkit-callback' in the
+ ;; future. This approach can limit flicker of buffer-name in
+ ;; mode-line.
+ (generate-new-buffer-name (buffer-name)))
+ (callback (or callback #'xwidget-webkit-callback))
+ (current-session (xwidget-webkit-current-session))
+ xw)
(setq xwidget-webkit-last-session-buffer (switch-to-buffer
(get-buffer-create bufname)))
;; The xwidget id is stored in a text property, so we need to have
@@ -621,17 +818,62 @@ For example, use this to display an anchor."
(setq xw (xwidget-insert
start 'webkit bufname
(xwidget-window-inside-pixel-width (selected-window))
- (xwidget-window-inside-pixel-height (selected-window)))))
+ (xwidget-window-inside-pixel-height (selected-window))
+ nil current-session)))
+ (when xwidget-webkit-cookie-file
+ (xwidget-webkit-set-cookie-storage-file
+ xw (expand-file-name xwidget-webkit-cookie-file)))
(xwidget-put xw 'callback callback)
+ (xwidget-put xw 'display-callback #'xwidget-webkit-display-callback)
(xwidget-webkit-mode)
(xwidget-webkit-goto-uri (xwidget-webkit-last-session) url)))
+(defun xwidget-webkit-import-widget (xwidget)
+ "Create a new webkit session buffer from XWIDGET, an existing xwidget.
+Return the buffer."
+ (let* ((bufname
+ ;; Generate a temp-name based on current buffer name. it
+ ;; will be renamed by `xwidget-webkit-callback' in the
+ ;; future. This approach can limit flicker of buffer-name in
+ ;; mode-line.
+ (generate-new-buffer-name (buffer-name)))
+ (callback #'xwidget-webkit-callback)
+ (buffer (get-buffer-create bufname)))
+ (with-current-buffer buffer
+ (setq xwidget-webkit-last-session-buffer buffer)
+ (save-excursion
+ (erase-buffer)
+ (insert ".")
+ (put-text-property (point-min) (point-max)
+ 'display (list 'xwidget :xwidget xwidget)))
+ (xwidget-put xwidget 'callback callback)
+ (xwidget-put xwidget 'display-callback
+ #'xwidget-webkit-display-callback)
+ (set-xwidget-buffer xwidget buffer)
+ (xwidget-webkit-mode))
+ buffer))
+
+(defun xwidget-webkit-display-event (event)
+ "Trigger display callback for EVENT."
+ (interactive "e")
+ (let ((xwidget (cadr event))
+ (source (caddr event)))
+ (when (xwidget-get source 'display-callback)
+ (funcall (xwidget-get source 'display-callback)
+ xwidget source))))
+
+(defun xwidget-webkit-display-callback (xwidget _source)
+ "Import XWIDGET and display it."
+ (display-buffer (xwidget-webkit-import-widget xwidget)))
+
+(define-key special-event-map [xwidget-display-event] 'xwidget-webkit-display-event)
(defun xwidget-webkit-goto-url (url)
"Goto URL with xwidget webkit."
(if (xwidget-webkit-current-session)
(progn
- (xwidget-webkit-goto-uri (xwidget-webkit-current-session) url))
+ (xwidget-webkit-goto-uri (xwidget-webkit-current-session) url)
+ (switch-to-buffer (xwidget-buffer (xwidget-webkit-current-session))))
(xwidget-webkit-new-session url)))
(defun xwidget-webkit-back ()
@@ -655,6 +897,15 @@ For example, use this to display an anchor."
(let ((url (xwidget-webkit-uri (xwidget-webkit-current-session))))
(message "URL: %s" (kill-new (or url "")))))
+(defun xwidget-webkit-browse-history ()
+ "Display a buffer containing the history of page loads."
+ (interactive)
+ (setq xwidget-webkit-last-session-buffer (current-buffer))
+ (let ((buffer (get-buffer-create "*Xwidget WebKit History*")))
+ (with-current-buffer buffer
+ (xwidget-webkit-history-mode))
+ (display-buffer buffer)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun xwidget-webkit-get-selection (proc)
"Get the webkit selection and pass it to PROC."
@@ -684,7 +935,275 @@ You can retrieve the value with `xwidget-get'."
(set-xwidget-plist xwidget
(plist-put (xwidget-plist xwidget) propname value)))
+(defvar xwidget-webkit-edit-mode-map (make-keymap))
+
+(define-key xwidget-webkit-edit-mode-map [backspace] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [tab] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [left] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [right] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [up] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [down] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [return] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [C-left] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [C-right] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [C-up] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [C-down] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [C-return] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [S-left] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [S-right] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [S-up] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [S-down] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [S-return] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [M-left] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [M-right] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [M-up] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [M-down] 'xwidget-webkit-pass-command-event)
+(define-key xwidget-webkit-edit-mode-map [M-return] 'xwidget-webkit-pass-command-event)
+
+(define-minor-mode xwidget-webkit-edit-mode
+ "Minor mode for editing the content of WebKit buffers.
+
+This defines most self-inserting characters and some common
+keyboard shortcuts to `xwidget-webkit-pass-command-event', which
+will pass the key events corresponding to these characters to the
+WebKit widget."
+ :keymap xwidget-webkit-edit-mode-map)
+
+(substitute-key-definition 'self-insert-command
+ 'xwidget-webkit-pass-command-event
+ xwidget-webkit-edit-mode-map
+ global-map)
+
+(declare-function xwidget-webkit-search "xwidget.c")
+(declare-function xwidget-webkit-next-result "xwidget.c")
+(declare-function xwidget-webkit-previous-result "xwidget.c")
+(declare-function xwidget-webkit-finish-search "xwidget.c")
+
+(defvar-local xwidget-webkit-isearch--string ""
+ "The current search query.")
+(defvar-local xwidget-webkit-isearch--is-reverse nil
+ "Whether or not the current isearch should be reverse.")
+(defvar xwidget-webkit-isearch--read-string-buffer nil
+ "The buffer we are reading input method text for, if any.")
+
+(defun xwidget-webkit-isearch--update (&optional only-message)
+ "Update the current buffer's WebKit widget's search query.
+If ONLY-MESSAGE is non-nil, the query will not be sent to the
+WebKit widget. The query will be set to the contents of
+`xwidget-webkit-isearch--string'."
+ (unless only-message
+ (xwidget-webkit-search xwidget-webkit-isearch--string
+ (xwidget-webkit-current-session)
+ t xwidget-webkit-isearch--is-reverse t))
+ (let ((message-log-max nil))
+ (message "%s" (concat (propertize "Search contents: " 'face 'minibuffer-prompt)
+ xwidget-webkit-isearch--string))))
+
+(defun xwidget-webkit-isearch-erasing-char (count)
+ "Erase the last COUNT characters of the current query."
+ (interactive (list (prefix-numeric-value current-prefix-arg)))
+ (when (> (length xwidget-webkit-isearch--string) 0)
+ (setq xwidget-webkit-isearch--string
+ (substring xwidget-webkit-isearch--string 0
+ (- (length xwidget-webkit-isearch--string) count))))
+ (xwidget-webkit-isearch--update))
+
+(defun xwidget-webkit-isearch-with-input-method ()
+ "Handle a request to use the input method to modify the search query."
+ (interactive)
+ (let ((key (car unread-command-events))
+ events)
+ (setq unread-command-events (cdr unread-command-events)
+ events (funcall input-method-function key))
+ (dolist (k events)
+ (with-current-buffer xwidget-webkit-isearch--read-string-buffer
+ (setq xwidget-webkit-isearch--string
+ (concat xwidget-webkit-isearch--string
+ (char-to-string k)))))
+ (exit-minibuffer)))
+
+(defun xwidget-webkit-isearch-printing-char-with-input-method (char)
+ "Handle printing char CHAR with the current input method."
+ (let ((minibuffer-local-map (make-keymap))
+ (xwidget-webkit-isearch--read-string-buffer (current-buffer)))
+ (define-key minibuffer-local-map [with-input-method]
+ 'xwidget-webkit-isearch-with-input-method)
+ (setq unread-command-events
+ (cons 'with-input-method
+ (cons char unread-command-events)))
+ (read-string "Search contents: "
+ xwidget-webkit-isearch--string
+ 'junk-hist nil t)
+ (xwidget-webkit-isearch--update)))
+
+(defun xwidget-webkit-isearch-printing-char (char &optional count)
+ "Add ordinary character CHAR to the search string and search.
+With argument, add COUNT copies of CHAR."
+ (interactive (list last-command-event
+ (prefix-numeric-value current-prefix-arg)))
+ (if current-input-method
+ (xwidget-webkit-isearch-printing-char-with-input-method char)
+ (setq xwidget-webkit-isearch--string (concat xwidget-webkit-isearch--string
+ (make-string (or count 1) char))))
+ (xwidget-webkit-isearch--update))
+
+(defun xwidget-webkit-isearch-forward (count)
+ "Move to the next search result COUNT times."
+ (interactive (list (prefix-numeric-value current-prefix-arg)))
+ (let ((was-reverse xwidget-webkit-isearch--is-reverse))
+ (setq xwidget-webkit-isearch--is-reverse nil)
+ (when was-reverse
+ (xwidget-webkit-isearch--update)
+ (setq count (1- count))))
+ (let ((i 0))
+ (while (< i count)
+ (xwidget-webkit-next-result (xwidget-webkit-current-session))
+ (cl-incf i)))
+ (xwidget-webkit-isearch--update t))
+
+(defun xwidget-webkit-isearch-backward (count)
+ "Move to the previous search result COUNT times."
+ (interactive (list (prefix-numeric-value current-prefix-arg)))
+ (let ((was-reverse xwidget-webkit-isearch--is-reverse))
+ (setq xwidget-webkit-isearch--is-reverse t)
+ (unless was-reverse
+ (xwidget-webkit-isearch--update)
+ (setq count (1- count))))
+ (let ((i 0))
+ (while (< i count)
+ (xwidget-webkit-previous-result (xwidget-webkit-current-session))
+ (cl-incf i)))
+ (xwidget-webkit-isearch--update t))
+
+(defun xwidget-webkit-isearch-exit ()
+ "Exit incremental search of a WebKit buffer."
+ (interactive)
+ (xwidget-webkit-isearch-mode 0))
+
+(defvar xwidget-webkit-isearch-mode-map (make-keymap)
+ "The keymap used inside xwidget-webkit-isearch-mode.")
+
+(set-char-table-range (nth 1 xwidget-webkit-isearch-mode-map)
+ (cons 0 (max-char))
+ 'xwidget-webkit-isearch-exit)
+
+(substitute-key-definition 'self-insert-command
+ 'xwidget-webkit-isearch-printing-char
+ xwidget-webkit-isearch-mode-map
+ global-map)
+
+(define-key xwidget-webkit-isearch-mode-map (kbd "DEL")
+ 'xwidget-webkit-isearch-erasing-char)
+(define-key xwidget-webkit-isearch-mode-map [backspace] 'xwidget-webkit-isearch-erasing-char)
+(define-key xwidget-webkit-isearch-mode-map [return] 'xwidget-webkit-isearch-exit)
+(define-key xwidget-webkit-isearch-mode-map "\r" 'xwidget-webkit-isearch-exit)
+(define-key xwidget-webkit-isearch-mode-map "\C-g" 'xwidget-webkit-isearch-exit)
+(define-key xwidget-webkit-isearch-mode-map "\C-r" 'xwidget-webkit-isearch-backward)
+(define-key xwidget-webkit-isearch-mode-map "\C-s" 'xwidget-webkit-isearch-forward)
+(define-key xwidget-webkit-isearch-mode-map "\C-y" 'xwidget-webkit-isearch-yank-kill)
+(define-key xwidget-webkit-isearch-mode-map "\C-\\" 'toggle-input-method)
+(define-key xwidget-webkit-isearch-mode-map "\t" 'xwidget-webkit-isearch-printing-char)
+
+(let ((meta-map (make-keymap)))
+ (set-char-table-range (nth 1 meta-map)
+ (cons 0 (max-char))
+ 'xwidget-webkit-isearch-exit)
+ (define-key xwidget-webkit-isearch-mode-map (char-to-string meta-prefix-char) meta-map))
+
+(define-minor-mode xwidget-webkit-isearch-mode
+ "Minor mode for performing incremental search inside WebKit buffers.
+
+This resembles the regular incremental search, but it does not
+support recursive edits.
+
+If this mode is activated with `\\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-backward]', then the search will by default
+start in the reverse direction.
+
+To navigate around the search results, type
+\\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-forward] to move forward, and
+\\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-backward] to move backward.
+
+To insert the string at the front of the kill ring into the
+search query, type \\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-yank-kill].
+
+Press \\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-exit] to exit incremental search."
+ :keymap xwidget-webkit-isearch-mode-map
+ (if xwidget-webkit-isearch-mode
+ (progn
+ (setq xwidget-webkit-isearch--string "")
+ (setq xwidget-webkit-isearch--is-reverse (eq last-command-event ?\C-r))
+ (xwidget-webkit-isearch--update))
+ (xwidget-webkit-finish-search (xwidget-webkit-current-session))))
+(defun xwidget-webkit-isearch-yank-kill ()
+ "Append the most recent kill from `kill-ring' to the current query."
+ (interactive)
+ (unless xwidget-webkit-isearch-mode
+ (xwidget-webkit-isearch-mode t))
+ (setq xwidget-webkit-isearch--string
+ (concat xwidget-webkit-isearch--string
+ (current-kill 0)))
+ (xwidget-webkit-isearch--update))
+
+(defvar-local xwidget-webkit-history--session nil
+ "The xwidget this history buffer controls.")
+
+(define-button-type 'xwidget-webkit-history 'action #'xwidget-webkit-history-select-item)
+
+(defun xwidget-webkit-history--insert-item (item)
+ "Insert specified ITEM into the current buffer."
+ (let ((idx (car item))
+ (title (cadr item))
+ (uri (caddr item)))
+ (push (list idx (vector (list (number-to-string idx)
+ :type 'xwidget-webkit-history)
+ (list title :type 'xwidget-webkit-history)
+ (list uri :type 'xwidget-webkit-history)))
+ tabulated-list-entries)))
+
+(defun xwidget-webkit-history-select-item (pos)
+ "Navigate to the history item underneath POS."
+ (interactive "P")
+ (let ((id (tabulated-list-get-id pos)))
+ (xwidget-webkit-goto-history xwidget-webkit-history--session id))
+ (xwidget-webkit-history-reload))
+
+(defun xwidget-webkit-history-reload (&rest ignored)
+ "Reload the current history buffer."
+ (interactive)
+ (setq tabulated-list-entries nil)
+ (let* ((back-forward-list
+ (xwidget-webkit-back-forward-list xwidget-webkit-history--session))
+ (back-list (car back-forward-list))
+ (here (cadr back-forward-list))
+ (forward-list (caddr back-forward-list)))
+ (mapc #'xwidget-webkit-history--insert-item (nreverse forward-list))
+ (xwidget-webkit-history--insert-item here)
+ (mapc #'xwidget-webkit-history--insert-item back-list)
+ (tabulated-list-print t nil)
+ (goto-char (point-min))
+ (let ((position (line-beginning-position (1+ (length back-list)))))
+ (goto-char position)
+ (setq-local overlay-arrow-position (make-marker))
+ (set-marker overlay-arrow-position position))))
+
+(define-derived-mode xwidget-webkit-history-mode tabulated-list-mode
+ "Xwidget Webkit History"
+ "Major mode for browsing the history of an Xwidget Webkit buffer.
+Each line describes an entry in history."
+ (setq truncate-lines t)
+ (setq buffer-read-only t)
+ (setq tabulated-list-format [("Index" 10 nil)
+ ("Title" 50 nil)
+ ("URL" 100 nil)])
+ (setq tabulated-list-entries nil)
+ (setq xwidget-webkit-history--session (xwidget-webkit-current-session))
+ (xwidget-webkit-history-reload)
+ (setq-local revert-buffer-function #'xwidget-webkit-history-reload)
+ (tabulated-list-init-header))
+
+(define-key xwidget-webkit-history-mode-map (kbd "RET")
+ #'xwidget-webkit-history-select-item)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar xwidget-view-list) ; xwidget.c
diff --git a/lisp/yank-media.el b/lisp/yank-media.el
new file mode 100644
index 00000000000..decab3b3625
--- /dev/null
+++ b/lisp/yank-media.el
@@ -0,0 +1,194 @@
+;;; yank-media.el --- Yanking images and HTML -*- lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: Lars Ingebrigtsen <larsi@gnus.org>
+;; Keywords: utility
+
+;; 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 'cl-lib)
+(require 'seq)
+
+(defvar yank-media--registered-handlers nil)
+
+;;;###autoload
+(defun yank-media ()
+ "Yank media (images, HTML and the like) from the clipboard.
+This command depends on the current major mode having support for
+accepting the media type. The mode has to register itself using
+the `yank-media-handler' mechanism.
+
+Also see `yank-media-types' for a command that lets you explore
+all the different selection types."
+ (interactive)
+ (unless yank-media--registered-handlers
+ (user-error "The `%s' mode hasn't registered any handlers" major-mode))
+ (let ((all-types nil))
+ (pcase-dolist (`(,handled-type . ,handler)
+ yank-media--registered-handlers)
+ (dolist (type (yank-media--find-matching-media handled-type))
+ (push (cons type handler) all-types)))
+ (unless all-types
+ (user-error
+ "No handler in the current buffer for anything on the clipboard"))
+ ;; We have a handler in the current buffer; if there's just
+ ;; matching type, just call the handler.
+ (if (length= all-types 1)
+ (funcall (cdar all-types) (caar all-types)
+ (yank-media--get-selection (caar all-types)))
+ ;; More than one type the user for what type to insert.
+ (let ((type
+ (intern
+ (completing-read "Several types available, choose one: "
+ (mapcar #'car all-types) nil t))))
+ (funcall (alist-get type all-types)
+ type (yank-media--get-selection type))))))
+
+(defun yank-media--find-matching-media (handled-type)
+ (seq-filter
+ (lambda (type)
+ (pcase-let ((`(,major ,minor) (split-string (symbol-name type) "/")))
+ (if (and (equal major "image")
+ (not (image-type-available-p (intern minor))))
+ ;; Just filter out all the image types that Emacs doesn't
+ ;; support, because the clipboard is full of things like
+ ;; `image/x-win-bitmap'.
+ nil
+ ;; Check that the handler wants this type.
+ (and (if (symbolp handled-type)
+ (eq handled-type type)
+ (string-match-p handled-type (symbol-name type)))
+ ;; An element may be in TARGETS but be empty.
+ (yank-media--get-selection type)))))
+ (gui-get-selection 'CLIPBOARD 'TARGETS)))
+
+(defun yank-media--get-selection (data-type)
+ (when-let ((data (gui-backend-get-selection 'CLIPBOARD data-type)))
+ (if (string-match-p "\\`text/" (symbol-name data-type))
+ (yank-media-types--format data-type data)
+ data)))
+
+;;;###autoload
+(defun yank-media-handler (types handler)
+ "Register HANDLER for dealing with `yank-media' actions for TYPES.
+TYPES should be a MIME media type symbol, a regexp, or a list
+that can contain both symbols and regexps.
+
+HANDLER is a function that will be called with two arguments: The
+MIME type (a symbol on the form `image/png') and the selection
+data (a string)."
+ (make-local-variable 'yank-media--registered-handlers)
+ (dolist (type (ensure-list types))
+ (setf (alist-get type yank-media--registered-handlers nil nil #'equal)
+ handler)))
+
+(defun yank-media-types (&optional all)
+ "Yank any element present in the primary selection or the clipboard.
+This is primarily meant as a debugging tool -- many of the
+elements (like images) will be inserted as raw data into the
+current buffer. See `yank-media' instead for a command that
+inserts images as images.
+
+By default, data types that aren't supported by
+`gui-get-selection' (i.e., that returns nothing if you actually
+try to look at the selection) are not included by this command.
+If ALL (interactively, the prefix), also include these
+non-supported selection data types."
+ (interactive "P")
+ (let ((elements nil))
+ ;; First gather all the data.
+ (dolist (type '(PRIMARY CLIPBOARD))
+ (when-let ((data-types (gui-get-selection type 'TARGETS)))
+ (when (vectorp data-types)
+ (seq-do (lambda (data-type)
+ (unless (memq data-type '( TARGETS MULTIPLE
+ DELETE SAVE_TARGETS))
+ (let ((data (gui-get-selection type data-type)))
+ (when (or data all)
+ ;; Remove duplicates -- the data in PRIMARY and
+ ;; CLIPBOARD are sometimes (mostly) identical,
+ ;; and sometimes not.
+ (let ((old (assq data-type elements)))
+ (when (or (not old)
+ (not (equal (nth 2 old) data)))
+ (push (list data-type type data)
+ elements)))))))
+ data-types))))
+ ;; Then query the user.
+ (unless elements
+ (user-error "No elements in the primary selection or the clipboard"))
+ (let ((spec
+ (completing-read
+ "Yank type: "
+ (mapcar (lambda (e)
+ (format "%s:%s" (downcase (symbol-name (cadr e)))
+ (car e)))
+ elements)
+ nil t)))
+ (dolist (elem elements)
+ (when (equal (format "%s:%s" (downcase (symbol-name (cadr elem)))
+ (car elem))
+ spec)
+ (insert (yank-media-types--format (car elem) (nth 2 elem))))))))
+
+(defun yank-media-types--format (data-type data)
+ (cond
+ ((not (stringp data))
+ (format "%s" data))
+ ((string-match-p "\\`text/" (symbol-name data-type))
+ ;; We may have utf-16, which Emacs won't detect automatically.
+ (let ((coding-system
+ (and (zerop (mod (length data) 2))
+ (let ((stats (vector 0 0)))
+ (dotimes (i (length data))
+ (when (zerop (elt data i))
+ (setf (aref stats (mod i 2))
+ (1+ (aref stats (mod i 2))))))
+ ;; If we have more than 90% every-other nul, then it's
+ ;; pretty likely to be utf-16.
+ (cond
+ ((> (if (zerop (elt stats 1))
+ 1
+ (/ (float (elt stats 0))
+ (float (elt stats 1))))
+ 0.9)
+ ;; Big endian.
+ 'utf-16-be)
+ ((> (if (zerop (elt stats 0))
+ 1
+ (/ (float (elt stats 1))
+ (float (elt stats 0))))
+ 0.9)
+ ;; Little endian.
+ 'utf-16-le))))))
+ (if coding-system
+ (decode-coding-string data coding-system)
+ ;; Some programs add a nul character at the end of text/*
+ ;; selections. Remove that.
+ (if (zerop (elt data (1- (length data))))
+ (substring data 0 (1- (length data)))
+ data))))
+ (t
+ data)))
+
+(provide 'yank-media)
+
+;;; yank-media.el ends here
diff --git a/lwlib/xlwmenu.c b/lwlib/xlwmenu.c
index cc73d9aa498..a0a10d13db5 100644
--- a/lwlib/xlwmenu.c
+++ b/lwlib/xlwmenu.c
@@ -157,6 +157,9 @@ xlwMenuResources[] =
offset(menu.cursor_shape), XtRString, (XtPointer)"right_ptr"},
{XtNhorizontal, XtCHorizontal, XtRInt, sizeof(int),
offset(menu.horizontal), XtRImmediate, (XtPointer)True},
+ {XtNborderThickness, XtCBorderThickness, XtRDimension,
+ sizeof (Dimension), offset (menu.border_thickness),
+ XtRImmediate, (XtPointer)1}
};
#undef offset
@@ -635,9 +638,24 @@ draw_shadow_rectangle (XlwMenuWidget mw,
Display *dpy = XtDisplay (mw);
GC top_gc = !erase_p ? mw->menu.shadow_top_gc : mw->menu.background_gc;
GC bottom_gc = !erase_p ? mw->menu.shadow_bottom_gc : mw->menu.background_gc;
- int thickness = mw->menu.shadow_thickness;
+ int thickness = !x && !y ? mw->menu.border_thickness : mw->menu.shadow_thickness;
XPoint points [4];
+ if (!erase_p && width == height && width == toggle_button_width (mw))
+ {
+ points [0].x = x;
+ points [0].y = y;
+ points [1].x = x + width;
+ points [1].y = y;
+ points [2].x = x + width;
+ points [2].y = y + height;
+ points [3].x = x;
+ points [3].y = y + height;
+ XFillPolygon (dpy, window,
+ down_p ? mw->menu.button_gc : mw->menu.inactive_button_gc,
+ points, 4, Convex, CoordModeOrigin);
+ }
+
if (!erase_p && down_p)
{
GC temp;
@@ -701,6 +719,21 @@ draw_shadow_rhombus (XlwMenuWidget mw,
int thickness = mw->menu.shadow_thickness;
XPoint points [4];
+ if (!erase_p && width == height && width == radio_button_width (mw))
+ {
+ points [0].x = x;
+ points [0].y = y + width / 2;
+ points [1].x = x + height / 2;
+ points [1].y = y + width;
+ points [2].x = x + height;
+ points [2].y = y + width / 2;
+ points [3].x = x + height / 2;
+ points [3].y = y;
+ XFillPolygon (dpy, window,
+ down_p ? mw->menu.button_gc : mw->menu.inactive_button_gc,
+ points, 4, Convex, CoordModeOrigin);
+ }
+
if (!erase_p && down_p)
{
GC temp;
@@ -1624,7 +1657,6 @@ make_drawing_gcs (XlwMenuWidget mw)
#define BRIGHTNESS(color) (((color) & 0xff) + (((color) >> 8) & 0xff) + (((color) >> 16) & 0xff))
/* Allocate color for disabled menu-items. */
- mw->menu.disabled_foreground = mw->menu.foreground;
if (BRIGHTNESS(mw->menu.foreground) < BRIGHTNESS(mw->core.background_pixel))
scale = 2.3;
else
diff --git a/lwlib/xlwmenu.h b/lwlib/xlwmenu.h
index 9143edba9a2..89e548bc8da 100644
--- a/lwlib/xlwmenu.h
+++ b/lwlib/xlwmenu.h
@@ -56,6 +56,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#define XtCResizeToPreferred "ResizeToPreferred"
#define XtNallowResize "allowResize"
#define XtCAllowResize "AllowResize"
+#define XtNborderThickness "borderThickness"
+#define XtCBorderThickness "BorderThickness"
/* Motif-compatible resource names */
#define XmNshadowThickness "shadowThickness"
diff --git a/lwlib/xlwmenuP.h b/lwlib/xlwmenuP.h
index fc77ec4bfd1..bb37b0dee2f 100644
--- a/lwlib/xlwmenuP.h
+++ b/lwlib/xlwmenuP.h
@@ -75,6 +75,7 @@ typedef struct _XlwMenu_part
Dimension vertical_spacing;
Dimension arrow_spacing;
Dimension shadow_thickness;
+ Dimension border_thickness;
Pixel top_shadow_color;
Pixel bottom_shadow_color;
Pixmap top_shadow_pixmap;
diff --git a/m4/alloca.m4 b/m4/alloca.m4
index ba2f679d8e0..7e474aa681b 100644
--- a/m4/alloca.m4
+++ b/m4/alloca.m4
@@ -1,4 +1,4 @@
-# alloca.m4 serial 20
+# alloca.m4 serial 21
dnl Copyright (C) 2002-2004, 2006-2007, 2009-2021 Free Software Foundation,
dnl Inc.
dnl This file is free software; the Free Software Foundation
@@ -26,17 +26,15 @@ AC_DEFUN([gl_FUNC_ALLOCA],
AC_DEFINE([HAVE_ALLOCA], [1],
[Define to 1 if you have 'alloca' after including <alloca.h>,
a header that may be supplied by this distribution.])
- ALLOCA_H=alloca.h
+ GL_GENERATE_ALLOCA_H=true
else
dnl alloca exists as a library function, i.e. it is slow and probably
dnl a memory leak. Don't define HAVE_ALLOCA in this case.
- ALLOCA_H=
+ GL_GENERATE_ALLOCA_H=false
fi
else
- ALLOCA_H=alloca.h
+ GL_GENERATE_ALLOCA_H=true
fi
- AC_SUBST([ALLOCA_H])
- AM_CONDITIONAL([GL_GENERATE_ALLOCA_H], [test -n "$ALLOCA_H"])
if test $ac_cv_working_alloca_h = yes; then
HAVE_ALLOCA_H=1
diff --git a/m4/byteswap.m4 b/m4/byteswap.m4
index 1083b4c9e24..db35b527a69 100644
--- a/m4/byteswap.m4
+++ b/m4/byteswap.m4
@@ -1,4 +1,4 @@
-# byteswap.m4 serial 4
+# byteswap.m4 serial 5
dnl Copyright (C) 2005, 2007, 2009-2021 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -10,10 +10,8 @@ AC_DEFUN([gl_BYTESWAP],
[
dnl Prerequisites of lib/byteswap.in.h.
AC_CHECK_HEADERS([byteswap.h], [
- BYTESWAP_H=''
+ GL_GENERATE_BYTESWAP_H=false
], [
- BYTESWAP_H='byteswap.h'
+ GL_GENERATE_BYTESWAP_H=true
])
- AC_SUBST([BYTESWAP_H])
- AM_CONDITIONAL([GL_GENERATE_BYTESWAP_H], [test -n "$BYTESWAP_H"])
])
diff --git a/m4/errno_h.m4 b/m4/errno_h.m4
index 51dfe92938d..7f5feabb2b8 100644
--- a/m4/errno_h.m4
+++ b/m4/errno_h.m4
@@ -1,4 +1,4 @@
-# errno_h.m4 serial 13
+# errno_h.m4 serial 14
dnl Copyright (C) 2004, 2006, 2008-2021 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -68,13 +68,11 @@ booboo
[gl_cv_header_errno_h_complete=yes])
])
if test $gl_cv_header_errno_h_complete = yes; then
- ERRNO_H=''
+ GL_GENERATE_ERRNO_H=false
else
gl_NEXT_HEADERS([errno.h])
- ERRNO_H='errno.h'
+ GL_GENERATE_ERRNO_H=true
fi
- AC_SUBST([ERRNO_H])
- AM_CONDITIONAL([GL_GENERATE_ERRNO_H], [test -n "$ERRNO_H"])
gl_REPLACE_ERRNO_VALUE([EMULTIHOP])
gl_REPLACE_ERRNO_VALUE([ENOLINK])
gl_REPLACE_ERRNO_VALUE([EOVERFLOW])
@@ -88,7 +86,7 @@ booboo
# Set the variables EOVERFLOW_HIDDEN and EOVERFLOW_VALUE.
AC_DEFUN([gl_REPLACE_ERRNO_VALUE],
[
- if test -n "$ERRNO_H"; then
+ if $GL_GENERATE_ERRNO_H; then
AC_CACHE_CHECK([for ]$1[ value], [gl_cv_header_errno_h_]$1, [
AC_EGREP_CPP([yes],[
#include <errno.h>
diff --git a/m4/execinfo.m4 b/m4/execinfo.m4
index 75ab44beeea..581b173a23a 100644
--- a/m4/execinfo.m4
+++ b/m4/execinfo.m4
@@ -10,7 +10,7 @@ AC_DEFUN([gl_EXECINFO_H],
AC_CHECK_HEADERS_ONCE([execinfo.h])
LIB_EXECINFO=''
- EXECINFO_H='execinfo.h'
+ GL_GENERATE_EXECINFO_H=true
if test $ac_cv_header_execinfo_h = yes; then
gl_saved_libs=$LIBS
@@ -18,14 +18,10 @@ AC_DEFUN([gl_EXECINFO_H],
[test "$ac_cv_search_backtrace_symbols_fd" = "none required" ||
LIB_EXECINFO=$ac_cv_search_backtrace_symbols_fd])
LIBS=$gl_saved_libs
- test "$ac_cv_search_backtrace_symbols_fd" = no || EXECINFO_H=''
+ if test "$ac_cv_search_backtrace_symbols_fd" != no; then
+ GL_GENERATE_EXECINFO_H=false
+ fi
fi
- if test -n "$EXECINFO_H"; then
- AC_LIBOBJ([execinfo])
- fi
-
- AC_SUBST([EXECINFO_H])
AC_SUBST([LIB_EXECINFO])
- AM_CONDITIONAL([GL_GENERATE_EXECINFO_H], [test -n "$EXECINFO_H"])
])
diff --git a/m4/getopt.m4 b/m4/getopt.m4
index bb95c5ea28e..9b71159bc57 100644
--- a/m4/getopt.m4
+++ b/m4/getopt.m4
@@ -1,4 +1,4 @@
-# getopt.m4 serial 47
+# getopt.m4 serial 48
dnl Copyright (C) 2002-2006, 2008-2021 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,6 +21,8 @@ AC_DEFUN([gl_FUNC_GETOPT_POSIX],
REPLACE_GETOPT=1
fi
])
+ GL_GENERATE_GETOPT_H=false
+ GL_GENERATE_GETOPT_CDEFS_H=false
if test $REPLACE_GETOPT = 1; then
dnl Arrange for getopt.h to be created.
gl_GETOPT_SUBSTITUTE_HEADER
@@ -374,8 +376,6 @@ AC_DEFUN([gl_GETOPT_SUBSTITUTE_HEADER],
AC_DEFINE([__GETOPT_PREFIX], [[rpl_]],
[Define to rpl_ if the getopt replacement functions and variables
should be used.])
- GETOPT_H=getopt.h
- GETOPT_CDEFS_H=getopt-cdefs.h
- AC_SUBST([GETOPT_H])
- AC_SUBST([GETOPT_CDEFS_H])
+ GL_GENERATE_GETOPT_H=true
+ GL_GENERATE_GETOPT_CDEFS_H=true
])
diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4
index 12b19dbcb44..f70ef4ea968 100644
--- a/m4/gnulib-common.m4
+++ b/m4/gnulib-common.m4
@@ -1,4 +1,4 @@
-# gnulib-common.m4 serial 67
+# gnulib-common.m4 serial 69
dnl Copyright (C) 2007-2021 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -879,6 +879,36 @@ AC_DEFUN([gl_CXX_ALLOW_WARNINGS],
AC_SUBST([GL_CXXFLAG_ALLOW_WARNINGS])
])
+dnl gl_CONDITIONAL_HEADER([foo.h])
+dnl takes a shell variable GL_GENERATE_FOO_H (with value true or false) as input
+dnl and produces
+dnl - an AC_SUBSTed variable FOO_H that is either a file name or empty, based
+dnl on whether GL_GENERATE_FOO_H is true or false,
+dnl - an Automake conditional GL_GENERATE_FOO_H that evaluates to the value of
+dnl the shell variable GL_GENERATE_FOO_H.
+AC_DEFUN([gl_CONDITIONAL_HEADER],
+[
+ m4_pushdef([gl_header_name], AS_TR_SH(m4_toupper($1)))
+ m4_pushdef([gl_generate_var], [GL_GENERATE_]AS_TR_SH(m4_toupper($1)))
+ m4_pushdef([gl_generate_cond], [GL_GENERATE_]AS_TR_SH(m4_toupper($1)))
+ case "$gl_generate_var" in
+ false) gl_header_name='' ;;
+ true)
+ dnl It is OK to use a .h file in lib/ from within tests/, but not vice
+ dnl versa.
+ if test -z "$gl_header_name"; then
+ gl_header_name="${gl_source_base_prefix}$1"
+ fi
+ ;;
+ *) echo "*** gl_generate_var is not set correctly" 1>&2; exit 1 ;;
+ esac
+ AC_SUBST(gl_header_name)
+ AM_CONDITIONAL(gl_generate_cond, [$gl_generate_var])
+ m4_popdef([gl_generate_cond])
+ m4_popdef([gl_generate_var])
+ m4_popdef([gl_header_name])
+])
+
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 e314edcfb53..a6810523ec9 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -224,10 +224,15 @@ AC_DEFUN([gl_INIT],
m4_pushdef([GL_MODULE_INDICATOR_PREFIX], [GL])
gl_COMMON
gl_source_base='lib'
+ gl_source_base_prefix=
gl_FUNC_ACL
gl_FUNC_ALLOCA
+ gl_CONDITIONAL_HEADER([alloca.h])
+ AC_PROG_MKDIR_P
gl___BUILTIN_EXPECT
gl_BYTESWAP
+ gl_CONDITIONAL_HEADER([byteswap.h])
+ AC_PROG_MKDIR_P
gl_CANONICALIZE_LGPL
if test $HAVE_CANONICALIZE_FILE_NAME = 0 || test $REPLACE_CANONICALIZE_FILE_NAME = 1; then
AC_LIBOBJ([canonicalize-lgpl])
@@ -255,6 +260,7 @@ AC_DEFUN([gl_INIT],
gl_CHECK_TYPE_STRUCT_DIRENT_D_TYPE
gl_DIRENT_H
gl_DIRENT_H_REQUIRE_DEFAULTS
+ AC_PROG_MKDIR_P
gl_DOUBLE_SLASH_ROOT
gl_FUNC_DUP2
if test $REPLACE_DUP2 = 1; then
@@ -265,7 +271,14 @@ AC_DEFUN([gl_INIT],
gl_ENVIRON
gl_UNISTD_MODULE_INDICATOR([environ])
gl_HEADER_ERRNO_H
+ gl_CONDITIONAL_HEADER([errno.h])
+ AC_PROG_MKDIR_P
gl_EXECINFO_H
+ gl_CONDITIONAL_HEADER([execinfo.h])
+ AC_PROG_MKDIR_P
+ if $GL_GENERATE_EXECINFO_H; then
+ AC_LIBOBJ([execinfo])
+ fi
gl_FUNC_EXPLICIT_BZERO
if test $HAVE_EXPLICIT_BZERO = 0; then
AC_LIBOBJ([explicit_bzero])
@@ -293,6 +306,7 @@ AC_DEFUN([gl_INIT],
gl_FCNTL_MODULE_INDICATOR([fcntl])
gl_FCNTL_H
gl_FCNTL_H_REQUIRE_DEFAULTS
+ AC_PROG_MKDIR_P
gl_FUNC_FDOPENDIR
if test $HAVE_FDOPENDIR = 0 || test $REPLACE_FDOPENDIR = 1; then
AC_LIBOBJ([fdopendir])
@@ -345,6 +359,9 @@ AC_DEFUN([gl_INIT],
dnl mechanism), there is no need to do any AC_LIBOBJ or AC_SUBST here; they are
dnl done in the getopt-posix module.
gl_FUNC_GETOPT_POSIX
+ gl_CONDITIONAL_HEADER([getopt.h])
+ gl_CONDITIONAL_HEADER([getopt-cdefs.h])
+ AC_PROG_MKDIR_P
if test $REPLACE_GETOPT = 1; then
AC_LIBOBJ([getopt])
AC_LIBOBJ([getopt1])
@@ -367,15 +384,22 @@ AC_DEFUN([gl_INIT],
fi
gl_SYS_TIME_MODULE_INDICATOR([gettimeofday])
gl_IEEE754_H
+ gl_CONDITIONAL_HEADER([ieee754.h])
+ AC_PROG_MKDIR_P
gl_INTTYPES_INCOMPLETE
gl_INTTYPES_H_REQUIRE_DEFAULTS
+ AC_PROG_MKDIR_P
AC_REQUIRE([gl_LARGEFILE])
gl___INLINE
gl_LIBGMP
+ gl_CONDITIONAL_HEADER([gmp.h])
+ AC_PROG_MKDIR_P
if test $HAVE_LIBGMP != yes; then
AC_LIBOBJ([mini-gmp-gnulib])
fi
gl_LIMITS_H
+ gl_CONDITIONAL_HEADER([limits.h])
+ AC_PROG_MKDIR_P
gl_FUNC_LSTAT
if test $REPLACE_LSTAT = 1; then
AC_LIBOBJ([lstat])
@@ -458,16 +482,26 @@ AC_DEFUN([gl_INIT],
gl_STRING_MODULE_INDICATOR([sigdescr_np])
gl_SIGNAL_H
gl_SIGNAL_H_REQUIRE_DEFAULTS
+ AC_PROG_MKDIR_P
gl_TYPE_SOCKLEN_T
gt_TYPE_SSIZE_T
gl_STAT_TIME
gl_STAT_BIRTHTIME
gl_STDALIGN_H
+ gl_CONDITIONAL_HEADER([stdalign.h])
+ AC_PROG_MKDIR_P
gl_STDDEF_H
gl_STDDEF_H_REQUIRE_DEFAULTS
+ gl_CONDITIONAL_HEADER([stddef.h])
+ AC_PROG_MKDIR_P
gl_STDINT_H
+ gl_CONDITIONAL_HEADER([stdint.h])
+ dnl Because of gl_REPLACE_LIMITS_H:
+ gl_CONDITIONAL_HEADER([limits.h])
+ AC_PROG_MKDIR_P
gl_STDIO_H
gl_STDIO_H_REQUIRE_DEFAULTS
+ AC_PROG_MKDIR_P
dnl No need to create extra modules for these functions. Everyone who uses
dnl <stdio.h> likely needs them.
gl_STDIO_MODULE_INDICATOR([fscanf])
@@ -493,6 +527,7 @@ AC_DEFUN([gl_INIT],
gl_STDIO_MODULE_INDICATOR([fwrite])
gl_STDLIB_H
gl_STDLIB_H_REQUIRE_DEFAULTS
+ AC_PROG_MKDIR_P
gl_FUNC_STPCPY
if test $HAVE_STPCPY = 0; then
AC_LIBOBJ([stpcpy])
@@ -501,6 +536,7 @@ AC_DEFUN([gl_INIT],
gl_STRING_MODULE_INDICATOR([stpcpy])
gl_STRING_H
gl_STRING_H_REQUIRE_DEFAULTS
+ AC_PROG_MKDIR_P
gl_FUNC_STRNLEN
if test $HAVE_DECL_STRNLEN = 0 || test $REPLACE_STRNLEN = 1; then
AC_LIBOBJ([strnlen])
@@ -537,6 +573,7 @@ AC_DEFUN([gl_INIT],
gl_MODULE_INDICATOR([tempname])
gl_TIME_H
gl_TIME_H_REQUIRE_DEFAULTS
+ AC_PROG_MKDIR_P
gl_TIME_R
if test $HAVE_LOCALTIME_R = 0 || test $REPLACE_LOCALTIME_R = 1; then
AC_LIBOBJ([time_r])
@@ -558,6 +595,7 @@ AC_DEFUN([gl_INIT],
gl_TIMESPEC
gl_UNISTD_H
gl_UNISTD_H_REQUIRE_DEFAULTS
+ AC_PROG_MKDIR_P
AC_DEFINE([GNULIB_STDIO_SINGLE_THREAD], [1],
[Define to 1 if you want the FILE stream functions getc, putc, etc.
to use unlocked I/O if available, throughout the package.
@@ -993,6 +1031,7 @@ AC_DEFUN([gl_INIT],
m4_pushdef([GL_MODULE_INDICATOR_PREFIX], [GL])
gl_COMMON
gl_source_base='tests'
+ gl_source_base_prefix=
changequote(,)dnl
gltests_WITNESS=IN_`echo "${PACKAGE-$PACKAGE_TARNAME}" | LC_ALL=C tr abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ | LC_ALL=C sed -e 's/[^A-Z0-9_]/_/g'`_GNULIB_TESTS
changequote([, ])dnl
diff --git a/m4/gsettings.m4 b/m4/gsettings.m4
new file mode 100644
index 00000000000..882e6a83e76
--- /dev/null
+++ b/m4/gsettings.m4
@@ -0,0 +1,88 @@
+# Increment this whenever this file is changed.
+#serial 2
+
+dnl GLIB_GSETTINGS
+dnl Defines GSETTINGS_SCHEMAS_INSTALL which controls whether
+dnl the schema should be compiled
+dnl
+
+AC_DEFUN([GLIB_GSETTINGS],
+[
+ dnl We can't use PKG_PREREQ because that needs 0.29.
+ m4_ifndef([PKG_PROG_PKG_CONFIG],
+ [pkg.m4 version 0.28 or later is required])
+
+ m4_pattern_allow([AM_V_GEN])
+ AC_ARG_ENABLE(schemas-compile,
+ AS_HELP_STRING([--disable-schemas-compile],
+ [Disable regeneration of gschemas.compiled on install]),
+ [case ${enableval} in
+ yes) GSETTINGS_DISABLE_SCHEMAS_COMPILE="" ;;
+ no) GSETTINGS_DISABLE_SCHEMAS_COMPILE="1" ;;
+ *) AC_MSG_ERROR([bad value ${enableval} for --enable-schemas-compile]) ;;
+ esac])
+ AC_SUBST([GSETTINGS_DISABLE_SCHEMAS_COMPILE])
+ PKG_PROG_PKG_CONFIG([0.16])
+ AC_SUBST(gsettingsschemadir, [${datadir}/glib-2.0/schemas])
+ AS_IF([test x$cross_compiling != xyes],
+ [PKG_CHECK_VAR([GLIB_COMPILE_SCHEMAS], [gio-2.0], [glib_compile_schemas])],
+ [AC_PATH_PROG([GLIB_COMPILE_SCHEMAS], [glib-compile-schemas])])
+ AC_SUBST(GLIB_COMPILE_SCHEMAS)
+ if test "x$GLIB_COMPILE_SCHEMAS" = "x"; then
+ ifelse([$2],,[AC_MSG_ERROR([glib-compile-schemas not found.])],[$2])
+ else
+ ifelse([$1],,[:],[$1])
+ fi
+
+ GSETTINGS_RULES='
+.PHONY : uninstall-gsettings-schemas install-gsettings-schemas clean-gsettings-schemas
+
+mostlyclean-am: clean-gsettings-schemas
+
+gsettings__enum_file = $(addsuffix .enums.xml,$(gsettings_ENUM_NAMESPACE))
+
+%.gschema.valid: %.gschema.xml $(gsettings__enum_file)
+ $(AM_V_GEN) $(GLIB_COMPILE_SCHEMAS) --strict --dry-run $(addprefix --schema-file=,$(gsettings__enum_file)) --schema-file=$< && mkdir -p [$](@D) && touch [$]@
+
+all-am: $(gsettings_SCHEMAS:.xml=.valid)
+uninstall-am: uninstall-gsettings-schemas
+install-data-am: install-gsettings-schemas
+
+.SECONDARY: $(gsettings_SCHEMAS)
+
+install-gsettings-schemas: $(gsettings_SCHEMAS) $(gsettings__enum_file)
+ @$(NORMAL_INSTALL)
+ if test -n "$^"; then \
+ test -z "$(gsettingsschemadir)" || $(MKDIR_P) "$(DESTDIR)$(gsettingsschemadir)"; \
+ $(INSTALL_DATA) $^ "$(DESTDIR)$(gsettingsschemadir)"; \
+ test -n "$(GSETTINGS_DISABLE_SCHEMAS_COMPILE)$(DESTDIR)" || $(GLIB_COMPILE_SCHEMAS) $(gsettingsschemadir); \
+ fi
+
+uninstall-gsettings-schemas:
+ @$(NORMAL_UNINSTALL)
+ @list='\''$(gsettings_SCHEMAS) $(gsettings__enum_file)'\''; test -n "$(gsettingsschemadir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e '\''s|^.*/||'\''`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '\''$(DESTDIR)$(gsettingsschemadir)'\'' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(gsettingsschemadir)" && rm -f $$files
+ test -n "$(GSETTINGS_DISABLE_SCHEMAS_COMPILE)$(DESTDIR)" || $(GLIB_COMPILE_SCHEMAS) $(gsettingsschemadir)
+
+clean-gsettings-schemas:
+ rm -f $(gsettings_SCHEMAS:.xml=.valid) $(gsettings__enum_file)
+
+ifdef gsettings_ENUM_NAMESPACE
+$(gsettings__enum_file): $(gsettings_ENUM_FILES)
+ $(AM_V_GEN) glib-mkenums --comments '\''<!-- @comment@ -->'\'' --fhead "<schemalist>" --vhead " <@type@ id='\''$(gsettings_ENUM_NAMESPACE).@EnumName@'\''>" --vprod " <value nick='\''@valuenick@'\'' value='\''@valuenum@'\''/>" --vtail " </@type@>" --ftail "</schemalist>" [$]^ > [$]@.tmp && mv [$]@.tmp [$]@
+endif
+'
+ _GSETTINGS_SUBST(GSETTINGS_RULES)
+])
+
+dnl _GSETTINGS_SUBST(VARIABLE)
+dnl Abstract macro to do either _AM_SUBST_NOTMAKE or AC_SUBST
+AC_DEFUN([_GSETTINGS_SUBST],
+[
+AC_SUBST([$1])
+m4_ifdef([_AM_SUBST_NOTMAKE], [_AM_SUBST_NOTMAKE([$1])])
+]
+)
diff --git a/m4/ieee754-h.m4 b/m4/ieee754-h.m4
index 68af3bd7ebe..0712613b6f2 100644
--- a/m4/ieee754-h.m4
+++ b/m4/ieee754-h.m4
@@ -10,12 +10,10 @@ AC_DEFUN([gl_IEEE754_H],
AC_REQUIRE([AC_C_BIGENDIAN])
AC_CHECK_HEADERS_ONCE([ieee754.h])
if test $ac_cv_header_ieee754_h = yes; then
- IEEE754_H=
+ GL_GENERATE_IEEE754_H=false
else
- IEEE754_H=ieee754.h
+ GL_GENERATE_IEEE754_H=true
AC_DEFINE([_GL_REPLACE_IEEE754_H], 1,
[Define to 1 if <ieee754.h> is missing.])
fi
- AC_SUBST([IEEE754_H])
- AM_CONDITIONAL([GL_GENERATE_IEEE754_H], [test -n "$IEEE754_H"])
])
diff --git a/m4/include_next.m4 b/m4/include_next.m4
index bdd542bc64d..7dcd1cef0b3 100644
--- a/m4/include_next.m4
+++ b/m4/include_next.m4
@@ -193,9 +193,9 @@ AC_DEFUN([gl_NEXT_HEADERS_INTERNAL],
if test AS_VAR_GET([gl_header_exists]) = yes; then
AS_VAR_POPDEF([gl_header_exists])
])
- gl_ABSOLUTE_HEADER_ONE(gl_HEADER_NAME)
- AS_VAR_COPY([gl_header], [gl_cv_absolute_]AS_TR_SH(gl_HEADER_NAME))
- AS_VAR_SET([gl_next_header], ['"'$gl_header'"'])
+ gl_ABSOLUTE_HEADER_ONE(gl_HEADER_NAME)
+ AS_VAR_COPY([gl_header], [gl_cv_absolute_]AS_TR_SH(gl_HEADER_NAME))
+ AS_VAR_SET([gl_next_header], ['"'$gl_header'"'])
m4_if([$2], [check],
[else
AS_VAR_SET([gl_next_header], ['<'gl_HEADER_NAME'>'])
diff --git a/m4/inttypes.m4 b/m4/inttypes.m4
index 64b1de5c42a..c446aa82773 100644
--- a/m4/inttypes.m4
+++ b/m4/inttypes.m4
@@ -1,4 +1,4 @@
-# inttypes.m4 serial 35
+# inttypes.m4 serial 36
dnl Copyright (C) 2006-2021 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -36,7 +36,7 @@ AC_DEFUN_ONCE([gl_INTTYPES_INCOMPLETE],
AC_DEFUN([gl_INTTYPES_PRI_SCN],
[
PRIPTR_PREFIX=
- if test -n "$STDINT_H"; then
+ if $GL_GENERATE_STDINT_H; then
dnl Using the gnulib <stdint.h>. It defines intptr_t to 'long' or
dnl 'long long', depending on _WIN64.
AC_COMPILE_IFELSE(
diff --git a/m4/libgmp.m4 b/m4/libgmp.m4
index c630a19e640..a2103dde88d 100644
--- a/m4/libgmp.m4
+++ b/m4/libgmp.m4
@@ -1,4 +1,4 @@
-# libgmp.m4 serial 5
+# libgmp.m4 serial 6
# Configure the GMP library or a replacement.
dnl Copyright 2020-2021 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
@@ -59,11 +59,10 @@ AC_DEFUN([gl_LIBGMP],
[ Try specifying --with-libgmp-prefix=DIR.])])
fi])
if test $HAVE_LIBGMP = yes && test "$ac_cv_header_gmp_h" = yes; then
- GMP_H=
+ GL_GENERATE_GMP_H=false
else
- GMP_H=gmp.h
+ GL_GENERATE_GMP_H=true
fi
- AC_SUBST([GMP_H])
AM_CONDITIONAL([GL_GENERATE_MINI_GMP_H],
[test $HAVE_LIBGMP != yes])
AM_CONDITIONAL([GL_GENERATE_GMP_GMP_H],
diff --git a/m4/limits-h.m4 b/m4/limits-h.m4
index 00c9fe9e50a..c82f6c67813 100644
--- a/m4/limits-h.m4
+++ b/m4/limits-h.m4
@@ -27,18 +27,15 @@ AC_DEFUN_ONCE([gl_LIMITS_H],
[gl_cv_header_limits_width=yes],
[gl_cv_header_limits_width=no])])
if test "$gl_cv_header_limits_width" = yes; then
- LIMITS_H=
+ GL_GENERATE_LIMITS_H=false
else
- LIMITS_H=limits.h
+ GL_GENERATE_LIMITS_H=true
fi
- AC_SUBST([LIMITS_H])
- AM_CONDITIONAL([GL_GENERATE_LIMITS_H], [test -n "$LIMITS_H"])
])
dnl Unconditionally enables the replacement of <limits.h>.
AC_DEFUN([gl_REPLACE_LIMITS_H],
[
AC_REQUIRE([gl_LIMITS_H])
- LIMITS_H='limits.h'
- AM_CONDITIONAL([GL_GENERATE_LIMITS_H], [test -n "$LIMITS_H"])
+ GL_GENERATE_LIMITS_H=true
])
diff --git a/m4/stdalign.m4 b/m4/stdalign.m4
index e22d7f78c06..fd57cdd47f2 100644
--- a/m4/stdalign.m4
+++ b/m4/stdalign.m4
@@ -49,11 +49,8 @@ AC_DEFUN([gl_STDALIGN_H],
[gl_cv_header_working_stdalign_h=no])])
if test $gl_cv_header_working_stdalign_h = yes; then
- STDALIGN_H=''
+ GL_GENERATE_STDALIGN_H=false
else
- STDALIGN_H='stdalign.h'
+ GL_GENERATE_STDALIGN_H=true
fi
-
- AC_SUBST([STDALIGN_H])
- AM_CONDITIONAL([GL_GENERATE_STDALIGN_H], [test -n "$STDALIGN_H"])
])
diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4
index 1303d2e06c7..0b160cde08b 100644
--- a/m4/stddef_h.m4
+++ b/m4/stddef_h.m4
@@ -1,4 +1,4 @@
-# stddef_h.m4 serial 11
+# stddef_h.m4 serial 12
dnl Copyright (C) 2009-2021 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -14,7 +14,7 @@ AC_DEFUN_ONCE([gl_STDDEF_H],
dnl Persuade OpenBSD <stddef.h> to declare max_align_t.
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
- STDDEF_H=
+ GL_GENERATE_STDDEF_H=false
dnl Test whether the type max_align_t exists and whether its alignment
dnl "is as great as is supported by the implementation in all contexts".
@@ -41,12 +41,12 @@ AC_DEFUN_ONCE([gl_STDDEF_H],
])
if test $gl_cv_type_max_align_t = no; then
HAVE_MAX_ALIGN_T=0
- STDDEF_H=stddef.h
+ GL_GENERATE_STDDEF_H=true
fi
if test $gt_cv_c_wchar_t = no; then
HAVE_WCHAR_T=0
- STDDEF_H=stddef.h
+ GL_GENERATE_STDDEF_H=true
fi
AC_CACHE_CHECK([whether NULL can be used in arbitrary expressions],
@@ -58,12 +58,10 @@ AC_DEFUN_ONCE([gl_STDDEF_H],
[gl_cv_decl_null_works=no])])
if test $gl_cv_decl_null_works = no; then
REPLACE_NULL=1
- STDDEF_H=stddef.h
+ GL_GENERATE_STDDEF_H=true
fi
- AC_SUBST([STDDEF_H])
- AM_CONDITIONAL([GL_GENERATE_STDDEF_H], [test -n "$STDDEF_H"])
- if test -n "$STDDEF_H"; then
+ if $GL_GENERATE_STDDEF_H; then
gl_NEXT_HEADERS([stddef.h])
fi
])
diff --git a/m4/stdint.m4 b/m4/stdint.m4
index 2eb1652d8e2..61fb8ca696f 100644
--- a/m4/stdint.m4
+++ b/m4/stdint.m4
@@ -1,4 +1,4 @@
-# stdint.m4 serial 60
+# stdint.m4 serial 61
dnl Copyright (C) 2001-2021 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -296,7 +296,7 @@ static const char *macro_values[] =
HAVE_C99_STDINT_H=0
HAVE_SYS_BITYPES_H=0
HAVE_SYS_INTTYPES_H=0
- STDINT_H=stdint.h
+ GL_GENERATE_STDINT_H=true
case "$gl_cv_header_working_stdint_h" in
*yes)
HAVE_C99_STDINT_H=1
@@ -341,7 +341,7 @@ int32_t i32 = INT32_C (0x7fffffff);
]])],
[gl_cv_header_stdint_width=yes])])
if test "$gl_cv_header_stdint_width" = yes; then
- STDINT_H=
+ GL_GENERATE_STDINT_H=false
fi
;;
*)
@@ -364,8 +364,6 @@ int32_t i32 = INT32_C (0x7fffffff);
AC_SUBST([HAVE_C99_STDINT_H])
AC_SUBST([HAVE_SYS_BITYPES_H])
AC_SUBST([HAVE_SYS_INTTYPES_H])
- AC_SUBST([STDINT_H])
- AM_CONDITIONAL([GL_GENERATE_STDINT_H], [test -n "$STDINT_H"])
])
dnl gl_STDINT_BITSIZEOF(TYPES, INCLUDES)
diff --git a/m4/sys_socket_h.m4 b/m4/sys_socket_h.m4
index 5676a0d2170..1f9a06f09cb 100644
--- a/m4/sys_socket_h.m4
+++ b/m4/sys_socket_h.m4
@@ -1,4 +1,4 @@
-# sys_socket_h.m4 serial 28
+# sys_socket_h.m4 serial 29
dnl Copyright (C) 2005-2021 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,6 +22,7 @@ AC_DEFUN_ONCE([gl_SYS_SOCKET_H],
;;
esac
+ GL_GENERATE_SYS_SOCKET_H=false
AC_CACHE_CHECK([whether <sys/socket.h> is self-contained],
[gl_cv_header_sys_socket_h_selfcontained],
[
@@ -44,7 +45,7 @@ AC_DEFUN_ONCE([gl_SYS_SOCKET_H],
[gl_cv_header_sys_socket_h_shut=no])
])
if test $gl_cv_header_sys_socket_h_shut = no; then
- SYS_SOCKET_H='sys/socket.h'
+ GL_GENERATE_SYS_SOCKET_H=true
fi
fi
fi
@@ -83,7 +84,7 @@ AC_DEFUN_ONCE([gl_SYS_SOCKET_H],
fi
if test $HAVE_STRUCT_SOCKADDR_STORAGE = 0 || test $HAVE_SA_FAMILY_T = 0 \
|| test $HAVE_STRUCT_SOCKADDR_STORAGE_SS_FAMILY = 0; then
- SYS_SOCKET_H='sys/socket.h'
+ GL_GENERATE_SYS_SOCKET_H=true
fi
gl_PREREQ_SYS_H_WINSOCK2
diff --git a/msdos/sed2v2.inp b/msdos/sed2v2.inp
index ae5d46fe860..52fbd4e9cbc 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 "28.0.90"/
+/^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION "29.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/nextstep/templates/Info.plist.in b/nextstep/templates/Info.plist.in
index 66cde9f4eeb..f9f0ec08571 100644
--- a/nextstep/templates/Info.plist.in
+++ b/nextstep/templates/Info.plist.in
@@ -555,7 +555,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
<key>UTTypeIdentifier</key>
<string>org.orgmode.org</string>
<key>UTTypeReferenceURL</key>
- <string>http://orgmode.org</string>
+ <string>https://orgmode.org</string>
<key>UTTypeTagSpecification</key>
<dict>
<key>public.filename-extension</key>
diff --git a/nt/INSTALL b/nt/INSTALL
index 9f543151a94..c324fb4ae7d 100644
--- a/nt/INSTALL
+++ b/nt/INSTALL
@@ -488,6 +488,7 @@ build will run on Windows 9X and newer systems).
Does Emacs use a gif library? yes
Does Emacs use a png library? yes
Does Emacs use -lrsvg-2? yes
+ Does Emacs use -lwebp? yes
Does Emacs use cairo? no
Does Emacs use -llcms2? yes
Does Emacs use imagemagick? no
@@ -597,8 +598,8 @@ build will run on Windows 9X and newer systems).
* Optional image library support
In addition to its "native" image formats (pbm and xbm), Emacs can
- handle other image types: xpm, tiff, gif, png, jpeg and experimental
- support for svg.
+ handle other image types: xpm, tiff, gif, png, jpeg, webp and
+ experimental support for svg.
To build Emacs with support for them, the corresponding headers must
be in the include path and libraries should be where the linker
@@ -736,6 +737,18 @@ build will run on Windows 9X and newer systems).
without it by specifying the --without-rsvg switch to the configure
script.
+ For WebP images you will need libwebp. You can find it here:
+
+ http://sourceforge.net/projects/ezwinports/files/
+
+ Note: the MS-Windows binary distribution on the Google site:
+
+ https://developers.google.com/speed/webp/
+
+ was compiled by MSVC, and includes only static libraries, no DLLs.
+ So you cannot use that to build Emacs with WebP support on
+ MS-Windows, as that needs libwebp as a DLL.
+
Binaries for the other image libraries can be found on the
ezwinports site or at the GnuWin32 project (the latter are generally
very old, so not recommended). Note specifically that, due to some
diff --git a/nt/INSTALL.W64 b/nt/INSTALL.W64
index 8f0d0c9528f..c3845d5b177 100644
--- a/nt/INSTALL.W64
+++ b/nt/INSTALL.W64
@@ -51,6 +51,7 @@ packages (you can copy and paste it into the shell with Shift + Insert):
mingw-w64-x86_64-libpng \
mingw-w64-x86_64-libjpeg-turbo \
mingw-w64-x86_64-librsvg \
+ mingw-w64-x86_64-libwebp \
mingw-w64-x86_64-lcms2 \
mingw-w64-x86_64-jansson \
mingw-w64-x86_64-libxml2 \
diff --git a/nt/Makefile.in b/nt/Makefile.in
index 3274ff924f9..811680da851 100644
--- a/nt/Makefile.in
+++ b/nt/Makefile.in
@@ -144,6 +144,7 @@ LIBS_ADDPM = -lole32 -luuid
## Compilation and linking flags
BASE_CFLAGS = $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) \
$(WARN_CFLAGS) $(WERROR_CFLAGS) \
+ -I../src -I${srcdir}/../src -I../lib -I${srcdir}/../lib \
-I. -I${srcdir}
ALL_CFLAGS = ${BASE_CFLAGS} ${PROFILING_CFLAGS} ${LDFLAGS} ${CPPFLAGS} ${CFLAGS}
diff --git a/nt/README.W32 b/nt/README.W32
index 7a7c1920ddc..495af0baede 100644
--- a/nt/README.W32
+++ b/nt/README.W32
@@ -1,7 +1,7 @@
Copyright (C) 2001-2021 Free Software Foundation, Inc.
See the end of the file for license conditions.
- Emacs version 28.0.90 for MS-Windows
+ Emacs version 29.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/addpm.c b/nt/addpm.c
index f54a6ea9f7c..4fbcf6c05ea 100644
--- a/nt/addpm.c
+++ b/nt/addpm.c
@@ -34,6 +34,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
installed, then the DDE fallback for creating icons the Windows 3.1
progman way will be used instead, but that is prone to lockups
caused by other applications not servicing their message queues. */
+
+#define DEFER_MS_W32_H
+#include <config.h>
+
#include <stdlib.h>
#include <stdio.h>
#include <malloc.h>
diff --git a/nt/cmdproxy.c b/nt/cmdproxy.c
index 224f68b1e85..f5a0550aa9d 100644
--- a/nt/cmdproxy.c
+++ b/nt/cmdproxy.c
@@ -27,6 +27,9 @@ 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 DEFER_MS_W32_H
+#include <config.h>
+
#include <windows.h>
#include <stdarg.h> /* va_args */
diff --git a/nt/ddeclient.c b/nt/ddeclient.c
index c577bfcfa93..0a44cbfd770 100644
--- a/nt/ddeclient.c
+++ b/nt/ddeclient.c
@@ -16,6 +16,9 @@ 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 DEFER_MS_W32_H
+#include <config.h>
+
#include <windows.h>
#include <ddeml.h>
#include <stdlib.h>
diff --git a/nt/preprep.c b/nt/preprep.c
index 78ed1c32381..8b054b19a71 100644
--- a/nt/preprep.c
+++ b/nt/preprep.c
@@ -21,6 +21,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
based on code from addsection.c
*/
+#define DEFER_MS_W32_H
+#include <config.h>
+
#include <stdlib.h>
#include <stdio.h>
#include <fcntl.h>
diff --git a/nt/runemacs.c b/nt/runemacs.c
index 308e856be2a..b4ed9fb1564 100644
--- a/nt/runemacs.c
+++ b/nt/runemacs.c
@@ -40,6 +40,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
/* #define CHOOSE_NEWEST_EXE */
+#define DEFER_MS_W32_H
+#include <config.h>
+
#include <windows.h>
#include <string.h>
#include <malloc.h>
diff --git a/src/.gdbinit b/src/.gdbinit
index f74e295f7ea..68db1ff3ea4 100644
--- a/src/.gdbinit
+++ b/src/.gdbinit
@@ -41,6 +41,11 @@ handle SIGUSR2 noprint pass
# debugging.
handle SIGALRM ignore
+# On selection send failed.
+if defined_HAVE_PGTK
+ handle SIGPIPE nostop noprint
+end
+
# Use $bugfix so that the value isn't a constant.
# Using a constant runs into GDB bugs sometimes.
define xgetptr
@@ -1224,6 +1229,9 @@ set print pretty on
set print sevenbit-strings
show environment DISPLAY
+if defined_HAVE_PGTK
+ show environment WAYLAND_DISPLAY
+end
show environment TERM
# When debugging, it is handy to be able to "return" from
diff --git a/src/Makefile.in b/src/Makefile.in
index 954d5482162..ee9a22469ea 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -34,6 +34,7 @@ top_builddir = @top_builddir@
abs_top_srcdir=@abs_top_srcdir@
VPATH = $(srcdir)
CC = @CC@
+CXX = @CXX@
CFLAGS = @CFLAGS@
CPPFLAGS = @CPPFLAGS@
LDFLAGS = @LDFLAGS@
@@ -124,7 +125,7 @@ LIB_MATH=@LIB_MATH@
## -lpthread, or empty.
LIB_PTHREAD=@LIB_PTHREAD@
-LIBIMAGE=@LIBTIFF@ @LIBJPEG@ @LIBPNG@ @LIBGIF@ @LIBXPM@
+LIBIMAGE=@LIBTIFF@ @LIBJPEG@ @LIBPNG@ @LIBGIF@ @LIBXPM@ @WEBP_LIBS@
XCB_LIBS=@XCB_LIBS@
XFT_LIBS=@XFT_LIBS@
@@ -223,6 +224,8 @@ CFLAGS_SOUND= @CFLAGS_SOUND@
RSVG_LIBS= @RSVG_LIBS@
RSVG_CFLAGS= @RSVG_CFLAGS@
+WEBP_CFLAGS= @WEBP_CFLAGS@
+
WEBKIT_LIBS= @WEBKIT_LIBS@
WEBKIT_CFLAGS= @WEBKIT_CFLAGS@
@@ -235,6 +238,8 @@ IMAGEMAGICK_CFLAGS= @IMAGEMAGICK_CFLAGS@
LIBXML2_LIBS = @LIBXML2_LIBS@
LIBXML2_CFLAGS = @LIBXML2_CFLAGS@
+SQLITE3_LIBS = @SQLITE3_LIBS@
+
GETADDRINFO_A_LIBS = @GETADDRINFO_A_LIBS@
LCMS2_LIBS = @LCMS2_LIBS@
@@ -256,6 +261,9 @@ XINERAMA_CFLAGS = @XINERAMA_CFLAGS@
XFIXES_LIBS = @XFIXES_LIBS@
XFIXES_CFLAGS = @XFIXES_CFLAGS@
+XINPUT_LIBS = @XINPUT_LIBS@
+XINPUT_CFLAGS = @XINPUT_CFLAGS@
+
XDBE_LIBS = @XDBE_LIBS@
XDBE_CFLAGS = @XDBE_CFLAGS@
@@ -289,6 +297,9 @@ W32_OBJ=@W32_OBJ@
## -lkernel32 if CYGWIN but not HAVE_W32, else empty.
W32_LIBS=@W32_LIBS@
+PGTK_OBJ=@PGTK_OBJ@
+PGTK_LIBS=@PGTK_LIBS@
+
## emacs.res if HAVE_W32
EMACSRES = @EMACSRES@
## If HAVE_W32, compiler arguments for including
@@ -341,10 +352,17 @@ BUILD_DETAILS = @BUILD_DETAILS@
UNEXEC_OBJ = @UNEXEC_OBJ@
+HAIKU_OBJ = @HAIKU_OBJ@
+HAIKU_CXX_OBJ = @HAIKU_CXX_OBJ@
+HAIKU_LIBS = @HAIKU_LIBS@
+HAIKU_CFLAGS = @HAIKU_CFLAGS@
+
DUMPING=@DUMPING@
CHECK_STRUCTS = @CHECK_STRUCTS@
HAVE_PDUMPER = @HAVE_PDUMPER@
+HAVE_BE_APP = @HAVE_BE_APP@
+
## ARM Macs require that all code have a valid signature. Since pdump
## invalidates the signature, we must re-sign to fix it.
DO_CODESIGN=$(patsubst aarch64-apple-darwin%,yes,@configuration@)
@@ -362,6 +380,9 @@ endif
# Flags that might be in WARN_CFLAGS but are not valid for Objective C.
NON_OBJC_CFLAGS = -Wignored-attributes -Wignored-qualifiers -Wopenmp-simd
+# Ditto, but for C++.
+NON_CXX_CFLAGS = -Wmissing-prototypes -Wnested-externs -Wold-style-definition \
+ -Wstrict-prototypes -Wno-override-init
# -Demacs makes some files produce the correct version for use in Emacs.
# MYCPPFLAGS is for by-hand Emacs-specific overrides, e.g.,
@@ -372,22 +393,26 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \
$(GNUSTEP_CFLAGS) $(CFLAGS_SOUND) $(RSVG_CFLAGS) $(IMAGEMAGICK_CFLAGS) \
$(PNG_CFLAGS) $(LIBXML2_CFLAGS) $(LIBGCCJIT_CFLAGS) $(DBUS_CFLAGS) \
$(XRANDR_CFLAGS) $(XINERAMA_CFLAGS) $(XFIXES_CFLAGS) $(XDBE_CFLAGS) \
- $(WEBKIT_CFLAGS) $(LCMS2_CFLAGS) \
+ $(XINPUT_CFLAGS) $(WEBP_CFLAGS) $(WEBKIT_CFLAGS) $(LCMS2_CFLAGS) \
$(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \
$(HARFBUZZ_CFLAGS) $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \
$(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \
$(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \
- $(WERROR_CFLAGS)
+ $(WERROR_CFLAGS) $(HAIKU_CFLAGS)
ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS)
ALL_OBJC_CFLAGS = $(EMACS_CFLAGS) \
$(filter-out $(NON_OBJC_CFLAGS),$(WARN_CFLAGS)) $(CFLAGS) \
$(GNU_OBJC_CFLAGS)
+ALL_CXX_CFLAGS = $(EMACS_CFLAGS) \
+ $(filter-out $(NON_CXX_CFLAGS),$(WARN_CFLAGS)) $(CXXFLAGS)
-.SUFFIXES: .m
+.SUFFIXES: .m .cc
.c.o:
$(AM_V_CC)$(CC) -c $(CPPFLAGS) $(ALL_CFLAGS) $(PROFILING_CFLAGS) $<
.m.o:
$(AM_V_CC)$(CC) -c $(CPPFLAGS) $(ALL_OBJC_CFLAGS) $(PROFILING_CFLAGS) $<
+.cc.o:
+ $(AM_V_CXX)$(CXX) -c $(CPPFLAGS) $(ALL_CXX_CFLAGS) $(PROFILING_CFLAGS) $<
## lastfile must follow all files whose initialized data areas should
## be dumped as pure by dump-emacs.
@@ -406,11 +431,13 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \
$(XWIDGETS_OBJ) \
profiler.o decompress.o \
- thread.o systhread.o \
+ thread.o systhread.o sqlite.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)
-obj = $(base_obj) $(NS_OBJC_OBJ)
+ $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) \
+ $(HAIKU_OBJ) $(PGTK_OBJ)
+doc_obj = $(base_obj) $(NS_OBJC_OBJ)
+obj = $(doc_obj) $(HAIKU_CXX_OBJ)
## Object files used on some machine or other.
## These go in the DOC file on all machines in case they are needed.
@@ -424,7 +451,8 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \
w32.o w32console.o w32cygwinx.o w32fns.o w32heap.o w32inevt.o w32notify.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
+ xsettings.o xgselect.o termcap.o hbfont.o \
+ haikuterm.o haikufns.o haikumenu.o haikufont.o
## gmalloc.o if !SYSTEM_MALLOC && !DOUG_LEA_MALLOC, else empty.
GMALLOC_OBJ=@GMALLOC_OBJ@
@@ -450,7 +478,11 @@ FIRSTFILE_OBJ=@FIRSTFILE_OBJ@
ALLOBJS = $(FIRSTFILE_OBJ) $(VMLIMIT_OBJ) $(obj) $(otherobj)
# Must be first, before dep inclusion!
+ifneq ($(HAVE_BE_APP),yes)
all: emacs$(EXEEXT) $(pdmp) $(OTHER_FILES)
+else
+all: Emacs Emacs.pdmp $(OTHER_FILES)
+endif
ifeq ($(HAVE_NATIVE_COMP):$(NATIVE_DISABLED),yes:)
all: ../native-lisp
endif
@@ -510,7 +542,7 @@ export LISP_PRELOADED = ${shortlisp}
lisp = $(addprefix ${lispsource}/,${shortlisp})
## Construct full set of libraries to be linked.
-LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \
+LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(PGTK_LIBS) $(LIBX_BASE) $(LIBIMAGE) \
$(LIBX_OTHER) $(LIBSOUND) \
$(RSVG_LIBS) $(IMAGEMAGICK_LIBS) $(LIB_ACL) $(LIB_CLOCK_GETTIME) \
$(WEBKIT_LIBS) \
@@ -522,7 +554,8 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \
$(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \
$(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \
$(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \
- $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS)
+ $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) $(XINPUT_LIBS) $(HAIKU_LIBS) \
+ $(SQLITE3_LIBS)
## FORCE it so that admin/unidata can decide whether this file is
## up-to-date. Although since charprop depends on bootstrap-emacs,
@@ -579,6 +612,18 @@ else
rm -f $@ && cp -f temacs$(EXEEXT) $@
endif
+## On Haiku, also produce a binary named Emacs with the appropriate
+## icon set.
+
+ifeq ($(HAVE_BE_APP),yes)
+Emacs: emacs$(EXEEXT)
+ cp -f emacs$(EXEEXT) $@
+ $(AM_V_GEN) $(libsrc)/be-resources \
+ $(etc)/images/icons/hicolor/32x32/apps/emacs.png $@
+Emacs.pdmp: $(pdmp)
+ $(AM_V_GEN) cp -f $(pdmp) $@
+endif
+
ifeq ($(DUMPING),pdumper)
$(pdmp): emacs$(EXEEXT)
LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump \
@@ -597,11 +642,11 @@ endif
## for the first time, this prevents any variation between configurations
## in the contents of the DOC file.
##
-$(etc)/DOC: lisp.mk $(libsrc)/make-docfile$(EXEEXT) $(obj) $(lisp)
+$(etc)/DOC: lisp.mk $(libsrc)/make-docfile$(EXEEXT) $(doc_obj) $(lisp)
$(AM_V_GEN)$(MKDIR_P) $(etc)
$(AM_V_at)rm -f $(etc)/DOC
$(AM_V_at)$(libsrc)/make-docfile -d $(srcdir) \
- $(SOME_MACHINE_OBJECTS) $(obj) > $(etc)/DOC
+ $(SOME_MACHINE_OBJECTS) $(doc_obj) > $(etc)/DOC
$(AM_V_at)$(libsrc)/make-docfile -a $(etc)/DOC -d $(lispsource) \
$(shortlisp)
@@ -619,7 +664,7 @@ buildobj.h: Makefile
GLOBAL_SOURCES = $(base_obj:.o=.c) $(NS_OBJC_OBJ:.o=.m)
gl-stamp: $(libsrc)/make-docfile$(EXEEXT) $(GLOBAL_SOURCES)
- $(AM_V_GLOBALS)$(libsrc)/make-docfile -d $(srcdir) -g $(obj) > globals.tmp
+ $(AM_V_GLOBALS)$(libsrc)/make-docfile -d $(srcdir) -g $(doc_obj) > globals.tmp
$(AM_V_at)$(top_srcdir)/build-aux/move-if-change globals.tmp globals.h
$(AM_V_at)echo timestamp > $@
@@ -644,9 +689,15 @@ endif
## to start if Vinstallation_directory has the wrong value.
temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \
$(charsets) $(charscript) ${emoji-zwj} $(MAKE_PDUMPER_FINGERPRINT)
- $(AM_V_CCLD)$(CC) -o $@.tmp \
+ifeq ($(HAVE_BE_APP),yes)
+ $(AM_V_CXXLD)$(CXX) -o $@.tmp \
$(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \
+ $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) -lstdc++
+else
+ $(AM_V_CCLD)$(CC) -o $@.tmp \
+ $(ALL_CFLAGS) $(CXXFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \
$(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES)
+endif
ifeq ($(HAVE_PDUMPER),yes)
$(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@.tmp
ifeq ($(DO_CODESIGN),yes)
@@ -731,6 +782,7 @@ ${ETAGS}: FORCE
# to be built before we can get TAGS.
ctagsfiles1 = $(filter-out ${srcdir}/macuvs.h, $(wildcard ${srcdir}/*.[hc]))
ctagsfiles2 = $(wildcard ${srcdir}/*.m)
+ctagsfiles3 = $(wildcard ${srcdir}/*.cc)
## In out-of-tree builds, TAGS are generated in the build dir, like
## other non-bootstrap build products (see Bug#31744).
@@ -745,7 +797,8 @@ TAGS: ${ETAGS} $(ctagsfiles1) $(ctagsfiles2)
$(ctagsfiles1) \
--regex='{objc}/[ ]*DEFVAR_[A-Z_ (]+"\([^"]+\)"/\1/' \
--regex='{objc}/[ ]*DEFVAR_[A-Z_ (]+"[^"]+",[ ]\([A-Za-z0-9_]+\)/\1/' \
- $(ctagsfiles2)
+ $(ctagsfiles2) \
+ $(ctagsfiles3)
## Arrange to make tags tables for ../lisp and ../lwlib,
## which the above TAGS file for the C files includes by reference.
@@ -796,16 +849,6 @@ elnlisp := \
international/charscript.eln \
emacs-lisp/comp.eln \
emacs-lisp/comp-cstr.eln \
- emacs-lisp/cl-macs.eln \
- emacs-lisp/rx.eln \
- emacs-lisp/cl-seq.eln \
- help-mode.eln \
- emacs-lisp/cl-extra.eln \
- emacs-lisp/gv.eln \
- emacs-lisp/seq.eln \
- emacs-lisp/cl-lib.eln \
- emacs-lisp/warnings.eln \
- emacs-lisp/subr-x.eln \
international/emoji-zwj.eln
elnlisp := $(addprefix ${lispsource}/,${elnlisp}) $(lisp:.elc=.eln)
@@ -860,6 +903,9 @@ ifeq ($(DUMPING),unexec)
else
@: In the pdumper case, make compile-first after the dump
cp -f temacs$(EXEEXT) bootstrap-emacs$(EXEEXT)
+ifeq ($(DO_CODESIGN),yes)
+ codesign -s - -f bootstrap-emacs$(EXEEXT)
+endif
endif
ifeq ($(DUMPING),pdumper)
diff --git a/src/alloc.c b/src/alloc.c
index e2184d7ba86..16f9076b03c 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -125,6 +125,7 @@ union emacs_align_type
struct Lisp_Overlay Lisp_Overlay;
struct Lisp_Sub_Char_Table Lisp_Sub_Char_Table;
struct Lisp_Subr Lisp_Subr;
+ struct Lisp_Sqlite Lisp_Sqlite;
struct Lisp_User_Ptr Lisp_User_Ptr;
struct Lisp_Vector Lisp_Vector;
struct terminal terminal;
@@ -765,7 +766,7 @@ xmalloc (size_t size)
val = lmalloc (size, false);
MALLOC_UNBLOCK_INPUT;
- if (!val && size)
+ if (!val)
memory_full (size);
MALLOC_PROBE (size);
return val;
@@ -782,7 +783,7 @@ xzalloc (size_t size)
val = lmalloc (size, true);
MALLOC_UNBLOCK_INPUT;
- if (!val && size)
+ if (!val)
memory_full (size);
MALLOC_PROBE (size);
return val;
@@ -796,15 +797,15 @@ xrealloc (void *block, size_t size)
void *val;
MALLOC_BLOCK_INPUT;
- /* We must call malloc explicitly when BLOCK is 0, since some
- reallocs don't do this. */
+ /* Call lmalloc when BLOCK is null, for the benefit of long-obsolete
+ platforms lacking support for realloc (NULL, size). */
if (! block)
val = lmalloc (size, false);
else
val = lrealloc (block, size);
MALLOC_UNBLOCK_INPUT;
- if (!val && size)
+ if (!val)
memory_full (size);
MALLOC_PROBE (size);
return val;
@@ -988,8 +989,7 @@ record_xmalloc (size_t size)
/* Like malloc but used for allocating Lisp data. NBYTES is the
number of bytes to allocate, TYPE describes the intended use of the
- allocated memory block (for strings, for conses, ...).
- NBYTES must be positive. */
+ allocated memory block (for strings, for conses, ...). */
#if ! USE_LSB_TAG
void *lisp_malloc_loser EXTERNALLY_VISIBLE;
@@ -1330,16 +1330,20 @@ laligned (void *p, size_t size)
|| size % LISP_ALIGNMENT != 0);
}
-/* Like malloc and realloc except that if SIZE is Lisp-aligned, make
- sure the result is too, if necessary by reallocating (typically
- with larger and larger sizes) until the allocator returns a
- Lisp-aligned pointer. Code that needs to allocate C heap memory
+/* Like malloc and realloc except return null only on failure,
+ the result is Lisp-aligned if SIZE is, and lrealloc's pointer
+ argument must be nonnull. Code allocating C heap memory
for a Lisp object should use one of these functions to obtain a
pointer P; that way, if T is an enum Lisp_Type value and L ==
make_lisp_ptr (P, T), then XPNTR (L) == P and XTYPE (L) == T.
+ If CLEARIT, arrange for the allocated memory to be cleared.
+ This might use calloc, as calloc can be faster than malloc+memset.
+
On typical modern platforms these functions' loops do not iterate.
- On now-rare (and perhaps nonexistent) platforms, the loops in
+ On now-rare (and perhaps nonexistent) platforms, the code can loop,
+ reallocating (typically with larger and larger sizes) until the
+ allocator returns a Lisp-aligned pointer. This loop in
theory could repeat forever. If an infinite loop is possible on a
platform, a build would surely loop and the builder can then send
us a bug report. Adding a counter to try to detect any such loop
@@ -1353,8 +1357,13 @@ lmalloc (size_t size, bool clearit)
if (! MALLOC_IS_LISP_ALIGNED && size % LISP_ALIGNMENT == 0)
{
void *p = aligned_alloc (LISP_ALIGNMENT, size);
- if (clearit && p)
- memclear (p, size);
+ if (p)
+ {
+ if (clearit)
+ memclear (p, size);
+ }
+ else if (! (MALLOC_0_IS_NONNULL || size))
+ return aligned_alloc (LISP_ALIGNMENT, LISP_ALIGNMENT);
return p;
}
#endif
@@ -1362,7 +1371,7 @@ lmalloc (size_t size, bool clearit)
while (true)
{
void *p = clearit ? calloc (1, size) : malloc (size);
- if (laligned (p, size))
+ if (laligned (p, size) && (MALLOC_0_IS_NONNULL || size || p))
return p;
free (p);
size_t bigger = size + LISP_ALIGNMENT;
@@ -1377,7 +1386,7 @@ lrealloc (void *p, size_t size)
while (true)
{
p = realloc (p, size);
- if (laligned (p, size))
+ if (laligned (p, size) && (size || p))
return p;
size_t bigger = size + LISP_ALIGNMENT;
if (size < bigger)
@@ -6136,11 +6145,18 @@ garbage_collect (void)
mark_terminals ();
mark_kboards ();
mark_threads ();
+#ifdef HAVE_PGTK
+ mark_pgtkterm ();
+#endif
#ifdef USE_GTK
xg_mark_data ();
#endif
+#ifdef HAVE_HAIKU
+ mark_haiku_display ();
+#endif
+
#ifdef HAVE_WINDOW_SYSTEM
mark_fringe_data ();
#endif
@@ -7708,6 +7724,12 @@ enum defined_HAVE_X_WINDOWS { defined_HAVE_X_WINDOWS = true };
enum defined_HAVE_X_WINDOWS { defined_HAVE_X_WINDOWS = false };
#endif
+#ifdef HAVE_PGTK
+enum defined_HAVE_PGTK { defined_HAVE_PGTK = true };
+#else
+enum defined_HAVE_PGTK { defined_HAVE_PGTK = false };
+#endif
+
/* When compiled with GCC, GDB might say "No enum type named
pvec_type" if we don't have at least one symbol with that type, and
then xbacktrace could fail. Similarly for the other enums and
@@ -7727,5 +7749,6 @@ union
enum More_Lisp_Bits More_Lisp_Bits;
enum pvec_type pvec_type;
enum defined_HAVE_X_WINDOWS defined_HAVE_X_WINDOWS;
+ enum defined_HAVE_PGTK defined_HAVE_PGTK;
} const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0};
#endif /* __GNUC__ */
diff --git a/src/atimer.c b/src/atimer.c
index 9b198675ab4..df35603f324 100644
--- a/src/atimer.c
+++ b/src/atimer.c
@@ -305,18 +305,34 @@ set_alarm (void)
#ifdef HAVE_ITIMERSPEC
if (0 <= timerfd || alarm_timer_ok)
{
+ bool exit = false;
struct itimerspec ispec;
ispec.it_value = atimers->expiration;
ispec.it_interval.tv_sec = ispec.it_interval.tv_nsec = 0;
+ if (alarm_timer_ok
+ && timer_settime (alarm_timer, TIMER_ABSTIME, &ispec, 0) == 0)
+ exit = true;
+
+ /* Don't start both timerfd and POSIX timers on Cygwin; this
+ causes a slowdown (bug#51734). Prefer POSIX timers
+ because the timerfd notifications aren't delivered while
+ Emacs is busy, which prevents things like the hourglass
+ pointer from being displayed reliably (bug#19776). */
+# ifdef CYGWIN
+ if (exit)
+ return;
+# endif
+
# ifdef HAVE_TIMERFD
- if (timerfd_settime (timerfd, TFD_TIMER_ABSTIME, &ispec, 0) == 0)
+ if (0 <= timerfd
+ && timerfd_settime (timerfd, TFD_TIMER_ABSTIME, &ispec, 0) == 0)
{
add_timer_wait_descriptor (timerfd);
- return;
+ exit = true;
}
# endif
- if (alarm_timer_ok
- && timer_settime (alarm_timer, TIMER_ABSTIME, &ispec, 0) == 0)
+
+ if (exit)
return;
}
#endif
@@ -333,9 +349,8 @@ set_alarm (void)
memset (&it, 0, sizeof it);
it.it_value = make_timeval (interval);
setitimer (ITIMER_REAL, &it, 0);
-#else /* not HAVE_SETITIMER */
- alarm (max (interval.tv_sec, 1));
#endif /* not HAVE_SETITIMER */
+ alarm (max (interval.tv_sec, 1));
}
}
@@ -583,15 +598,17 @@ init_atimer (void)
timerfd = (egetenv ("EMACS_IGNORE_TIMERFD") || have_buggy_timerfd () ? -1 :
timerfd_create (CLOCK_REALTIME, TFD_NONBLOCK | TFD_CLOEXEC));
# endif
- if (timerfd < 0)
- {
- struct sigevent sigev;
- sigev.sigev_notify = SIGEV_SIGNAL;
- sigev.sigev_signo = SIGALRM;
- sigev.sigev_value.sival_ptr = &alarm_timer;
- alarm_timer_ok
- = timer_create (CLOCK_REALTIME, &sigev, &alarm_timer) == 0;
- }
+ /* We're starting the alarms even if we have timerfd, because
+ timerfd events do not fire while Emacs Lisp is busy and doesn't
+ call thread_select. This might or might not mean that the
+ timerfd code doesn't really give us anything and should be
+ removed, see discussion in bug#19776. */
+ struct sigevent sigev;
+ sigev.sigev_notify = SIGEV_SIGNAL;
+ sigev.sigev_signo = SIGALRM;
+ sigev.sigev_value.sival_ptr = &alarm_timer;
+ alarm_timer_ok
+ = timer_create (CLOCK_REALTIME, &sigev, &alarm_timer) == 0;
#endif
free_atimers = stopped_atimers = atimers = NULL;
diff --git a/src/bidi.c b/src/bidi.c
index 1413ba6b888..890a60acc43 100644
--- a/src/bidi.c
+++ b/src/bidi.c
@@ -3564,11 +3564,19 @@ bidi_move_to_visually_next (struct bidi_it *bidi_it)
}
/* Utility function for looking for strong directional characters
- whose bidi type was overridden by a directional override. */
+ whose bidi type was overridden by directional override or embedding
+ or isolate control characters. */
ptrdiff_t
bidi_find_first_overridden (struct bidi_it *bidi_it)
{
ptrdiff_t found_pos = ZV;
+ /* Maximum bidi levels we allow for L2R and R2L characters. Note
+ that these are levels after resolving explicit embeddings,
+ overrides, and isolates, i.e. before resolving implicit levels. */
+ int max_l2r = bidi_it->paragraph_dir == L2R ? 0 : 2;
+ int max_r2l = 1;
+ /* Same for WEAK and NEUTRAL_ON types. */
+ int max_weak = bidi_it->paragraph_dir == L2R ? 1 : 2;
do
{
@@ -3576,11 +3584,28 @@ bidi_find_first_overridden (struct bidi_it *bidi_it)
because the directional overrides are applied by the
former. */
bidi_type_t type = bidi_resolve_weak (bidi_it);
+ unsigned level = bidi_it->level_stack[bidi_it->stack_idx].level;
+ bidi_category_t category = bidi_get_category (bidi_it->orig_type);
+ /* Detect strong L or R types that have been overridden by
+ explicit overrides. */
if ((type == STRONG_R && bidi_it->orig_type == STRONG_L)
|| (type == STRONG_L
&& (bidi_it->orig_type == STRONG_R
- || bidi_it->orig_type == STRONG_AL)))
+ || bidi_it->orig_type == STRONG_AL))
+ /* Detect strong L or R types or WEAK_EN types that were
+ pushed into higher embedding levels (and will thus
+ reorder) by explicit embeddings and isolates. */
+ || ((bidi_it->orig_type == STRONG_L
+ || bidi_it->orig_type == WEAK_EN)
+ && level > max_l2r)
+ || ((bidi_it->orig_type == STRONG_R
+ || bidi_it->orig_type == STRONG_AL)
+ && level > max_r2l)
+ /* Detect other weak or neutral types whose level was
+ tweaked by explicit embeddings and isolates. */
+ || ((category == WEAK || bidi_it->orig_type == NEUTRAL_ON)
+ && level > max_weak))
found_pos = bidi_it->charpos;
} while (found_pos == ZV
&& bidi_it->charpos < ZV
diff --git a/src/bignum.c b/src/bignum.c
index 1ac75c19e24..5c587fc6dba 100644
--- a/src/bignum.c
+++ b/src/bignum.c
@@ -53,6 +53,15 @@ init_bignum (void)
{
eassert (mp_bits_per_limb == GMP_NUMB_BITS);
integer_width = 1 << 16;
+
+ /* FIXME: The Info node `(gmp) Custom Allocation' states: "No error
+ return is allowed from any of these functions, if they return
+ then they must have performed the specified operation. [...]
+ There's currently no defined way for the allocation functions to
+ recover from an error such as out of memory, they must terminate
+ program execution. A 'longjmp' or throwing a C++ exception will
+ have undefined results." But xmalloc and xrealloc do call
+ 'longjmp'. */
mp_set_memory_functions (xmalloc, xrealloc_for_gmp, xfree_for_gmp);
for (int i = 0; i < ARRAYELTS (mpz); i++)
diff --git a/src/buffer.c b/src/buffer.c
index eca2843e2bc..9d8892a797a 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -2805,7 +2805,7 @@ current buffer is cleared. */)
}
DEFUN ("kill-all-local-variables", Fkill_all_local_variables,
- Skill_all_local_variables, 0, 0, 0,
+ Skill_all_local_variables, 0, 1, 0,
doc: /* Switch to Fundamental mode by killing current buffer's local variables.
Most local variable bindings are eliminated so that the default values
become effective once more. Also, the syntax table is set from
@@ -2816,18 +2816,20 @@ This function also forces redisplay of the mode line.
Every function to select a new major mode starts by
calling this function.
-As a special exception, local variables whose names have
-a non-nil `permanent-local' property are not eliminated by this function.
+As a special exception, local variables whose names have a non-nil
+`permanent-local' property are not eliminated by this function. If
+the optional KILL-PERMANENT argument is non-nil, clear out these local
+variables, too.
The first thing this function does is run
the normal hook `change-major-mode-hook'. */)
- (void)
+ (Lisp_Object kill_permanent)
{
run_hook (Qchange_major_mode_hook);
/* Actually eliminate all local bindings of this buffer. */
- reset_buffer_local_variables (current_buffer, 0);
+ reset_buffer_local_variables (current_buffer, !NILP (kill_permanent));
/* Force mode-line redisplay. Useful here because all major mode
commands call this function. */
diff --git a/src/callproc.c b/src/callproc.c
index f7c55d04863..c89628bb0ec 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -34,8 +34,7 @@ extern char **environ;
/* In order to be able to use `posix_spawn', it needs to support some
variant of `chdir' as well as `setsid'. */
-#if defined DARWIN_OS \
- && defined HAVE_SPAWN_H && defined HAVE_POSIX_SPAWN \
+#if defined HAVE_SPAWN_H && defined HAVE_POSIX_SPAWN \
&& defined HAVE_POSIX_SPAWNATTR_SETFLAGS \
&& (defined HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR \
|| defined HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP) \
diff --git a/src/casefiddle.c b/src/casefiddle.c
index a7a25414909..81e9ed153fb 100644
--- a/src/casefiddle.c
+++ b/src/casefiddle.c
@@ -54,6 +54,9 @@ struct casing_context
/* Whether the context is within a word. */
bool inword;
+
+ /* What the last operation was. */
+ bool downcase_last;
};
/* Initialize CTX structure for casing characters. */
@@ -143,10 +146,14 @@ case_character_impl (struct casing_str_buf *buf,
/* Handle simple, one-to-one case. */
if (flag == CASE_DOWN)
- cased = downcase (ch);
+ {
+ cased = downcase (ch);
+ ctx->downcase_last = true;
+ }
else
{
bool cased_is_set = false;
+ ctx->downcase_last = false;
if (!NILP (ctx->titlecase_char_table))
{
prop = CHAR_TABLE_REF (ctx->titlecase_char_table, ch);
@@ -297,6 +304,16 @@ do_casify_multibyte_string (struct casing_context *ctx, Lisp_Object obj)
return obj;
}
+static int
+ascii_casify_character (bool downcase, int c)
+{
+ Lisp_Object cased = CHAR_TABLE_REF (downcase?
+ uniprop_table (Qlowercase) :
+ uniprop_table (Quppercase),
+ c);
+ return FIXNATP (cased) ? XFIXNAT (cased) : c;
+}
+
static Lisp_Object
do_casify_unibyte_string (struct casing_context *ctx, Lisp_Object obj)
{
@@ -310,11 +327,12 @@ do_casify_unibyte_string (struct casing_context *ctx, Lisp_Object obj)
cased = case_single_character (ctx, ch);
if (ch == cased)
continue;
- cased = make_char_unibyte (cased);
- /* If the char can't be converted to a valid byte, just don't
- change it. */
- if (SINGLE_BYTE_CHAR_P (cased))
- SSET (obj, i, cased);
+ /* If down/upcasing changed an ASCII character into a non-ASCII
+ character (this can happen in some locales, like the Turkish
+ "I"), downcase using the ASCII char table. */
+ if (ASCII_CHAR_P (ch) && !SINGLE_BYTE_CHAR_P (cased))
+ cased = ascii_casify_character (ctx->downcase_last, ch);
+ SSET (obj, i, make_char_unibyte (cased));
}
return obj;
}
@@ -339,10 +357,13 @@ casify_object (enum case_action flag, Lisp_Object obj)
DEFUN ("upcase", Fupcase, Supcase, 1, 1, 0,
doc: /* Convert argument to upper case and return that.
-The argument may be a character or string. The result has the same type.
+The argument may be a character or string. The result has the same
+type. (See `downcase' for further details about the type.)
+
The argument object is not altered--the value is a copy. If argument
is a character, characters which map to multiple code points when
cased, e.g. fi, are returned unchanged.
+
See also `capitalize', `downcase' and `upcase-initials'. */)
(Lisp_Object obj)
{
@@ -351,7 +372,15 @@ See also `capitalize', `downcase' and `upcase-initials'. */)
DEFUN ("downcase", Fdowncase, Sdowncase, 1, 1, 0,
doc: /* Convert argument to lower case and return that.
-The argument may be a character or string. The result has the same type.
+The argument may be a character or string. The result has the same type,
+including the multibyteness of the string.
+
+This means that if this function is called with a unibyte string
+argument, and downcasing it would turn it into a multibyte string
+(according to the current locale), the downcasing is done using ASCII
+\"C\" rules instead. To accurately downcase according to the current
+locale, the string must be converted into multibyte first.
+
The argument object is not altered--the value is a copy. */)
(Lisp_Object obj)
{
@@ -362,7 +391,10 @@ DEFUN ("capitalize", Fcapitalize, Scapitalize, 1, 1, 0,
doc: /* Convert argument to capitalized form and return that.
This means that each word's first character is converted to either
title case or upper case, and the rest to lower case.
-The argument may be a character or string. The result has the same type.
+
+The argument may be a character or string. The result has the same
+type. (See `downcase' for further details about the type.)
+
The argument object is not altered--the value is a copy. If argument
is a character, characters which map to multiple code points when
cased, e.g. fi, are returned unchanged. */)
@@ -377,7 +409,10 @@ DEFUN ("upcase-initials", Fupcase_initials, Supcase_initials, 1, 1, 0,
doc: /* Convert the initial of each word in the argument to upper case.
This means that each word's first character is converted to either
title case or upper case, and the rest are left unchanged.
-The argument may be a character or string. The result has the same type.
+
+The argument may be a character or string. The result has the same
+type. (See `downcase' for further details about the type.)
+
The argument object is not altered--the value is a copy. If argument
is a character, characters which map to multiple code points when
cased, e.g. fi, are returned unchanged. */)
@@ -651,6 +686,8 @@ syms_of_casefiddle (void)
DEFSYM (Qbounds, "bounds");
DEFSYM (Qidentity, "identity");
DEFSYM (Qtitlecase, "titlecase");
+ DEFSYM (Qlowercase, "lowercase");
+ DEFSYM (Quppercase, "uppercase");
DEFSYM (Qspecial_uppercase, "special-uppercase");
DEFSYM (Qspecial_lowercase, "special-lowercase");
DEFSYM (Qspecial_titlecase, "special-titlecase");
diff --git a/src/comp.c b/src/comp.c
index 43feac64903..1fb384840cf 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -4123,7 +4123,7 @@ one for the file name and another for its contents, followed by .eln. */)
FOR_EACH_TAIL (lds_re_tail)
{
Lisp_Object match_idx =
- Fstring_match (XCAR (lds_re_tail), filename, Qnil);
+ Fstring_match (XCAR (lds_re_tail), filename, Qnil, Qnil);
if (EQ (match_idx, make_fixnum (0)))
{
filename =
@@ -4786,10 +4786,6 @@ register_native_comp_unit (Lisp_Object comp_u)
/* Deferred compilation mechanism. */
/***********************************/
-/* List of sources we'll compile and load after having conventionally
- loaded the compiler and its dependencies. */
-static Lisp_Object delayed_sources;
-
/* Queue an asynchronous compilation for the source file defining
FUNCTION_NAME and perform a late load.
@@ -4846,30 +4842,16 @@ maybe_defer_native_compilation (Lisp_Object function_name,
/* This is so deferred compilation is able to compile comp
dependencies breaking circularity. */
- if (!NILP (Ffeaturep (Qcomp, Qnil)))
+ if (comp__loadable)
{
- /* Comp already loaded. */
- if (!NILP (delayed_sources))
- {
- CALLN (Ffuncall, intern_c_string ("native--compile-async"),
- delayed_sources, Qnil, Qlate);
- delayed_sources = Qnil;
- }
+ /* Startup is done, comp is usable. */
+ Frequire (Qcomp, Qnil, Qnil);
Fputhash (function_name, definition, Vcomp_deferred_pending_h);
CALLN (Ffuncall, intern_c_string ("native--compile-async"),
src, Qnil, Qlate);
}
else
- {
- delayed_sources = Fcons (src, delayed_sources);
- /* Require comp only once. */
- static bool comp_required = false;
- if (!comp_required)
- {
- comp_required = true;
- Frequire (Qcomp, Qnil, Qnil);
- }
- }
+ Vcomp__delayed_sources = Fcons (src, Vcomp__delayed_sources);
}
@@ -5268,7 +5250,8 @@ file_in_eln_sys_dir (Lisp_Object filename)
eln_sys_dir = XCAR (tmp);
return !NILP (Fstring_match (Fregexp_quote (Fexpand_file_name (eln_sys_dir,
Qnil)),
- Fexpand_file_name (filename, Qnil), Qnil));
+ Fexpand_file_name (filename, Qnil),
+ Qnil, Qnil));
}
/* Load related routines. */
@@ -5295,16 +5278,16 @@ LATE_LOAD has to be non-nil when loading for deferred compilation. */)
Fmake_temp_file_internal (filename, Qnil, build_string (".eln.tmp"),
Qnil);
if (NILP (Ffile_writable_p (tmp_filename)))
- comp_u->handle = dynlib_open (SSDATA (encoded_filename));
+ comp_u->handle = dynlib_open_for_eln (SSDATA (encoded_filename));
else
{
Frename_file (filename, tmp_filename, Qt);
- comp_u->handle = dynlib_open (SSDATA (ENCODE_FILE (tmp_filename)));
+ comp_u->handle = dynlib_open_for_eln (SSDATA (ENCODE_FILE (tmp_filename)));
Frename_file (tmp_filename, filename, Qnil);
}
}
else
- comp_u->handle = dynlib_open (SSDATA (encoded_filename));
+ comp_u->handle = dynlib_open_for_eln (SSDATA (encoded_filename));
if (!comp_u->handle)
xsignal2 (Qnative_lisp_load_failed, filename,
@@ -5335,6 +5318,13 @@ 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--loadable",
+ comp__loadable,
+ doc: /* Non-nil when comp.el can be loaded.
+For internal use. */);
/* Compiler control customizes. */
DEFVAR_BOOL ("native-comp-deferred-compilation",
native_comp_deferred_compilation,
@@ -5475,8 +5465,6 @@ compiled one. */);
staticpro (&comp.func_blocks_h);
staticpro (&comp.emitter_dispatcher);
comp.emitter_dispatcher = Qnil;
- staticpro (&delayed_sources);
- delayed_sources = Qnil;
staticpro (&loadsearch_re_list);
loadsearch_re_list = Qnil;
diff --git a/src/data.c b/src/data.c
index b2c395831ae..f07667b0003 100644
--- a/src/data.c
+++ b/src/data.c
@@ -259,6 +259,8 @@ for example, (type-of 1) returns `integer'. */)
return Qxwidget;
case PVEC_XWIDGET_VIEW:
return Qxwidget_view;
+ case PVEC_SQLITE:
+ return Qsqlite;
/* "Impossible" cases. */
case PVEC_MISC_PTR:
case PVEC_OTHER:
diff --git a/src/dispextern.h b/src/dispextern.h
index 08dac5d4557..0f316a2eaf9 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -134,6 +134,21 @@ typedef Emacs_Pixmap Emacs_Pix_Context;
#define FACE_COLOR_TO_PIXEL(face_color, frame) face_color
#endif
+#ifdef HAVE_PGTK
+#include "pgtkgui.h"
+/* Following typedef needed to accommodate the MSDOS port, believe it or not. */
+typedef struct pgtk_display_info Display_Info;
+typedef Emacs_Pixmap XImagePtr;
+typedef XImagePtr XImagePtr_or_DC;
+#endif /* HAVE_PGTK */
+
+#ifdef HAVE_HAIKU
+#include "haikugui.h"
+typedef struct haiku_display_info Display_Info;
+typedef Emacs_Pixmap Emacs_Pix_Container;
+typedef Emacs_Pixmap Emacs_Pix_Context;
+#endif
+
#ifdef HAVE_WINDOW_SYSTEM
# include <time.h>
# include "fontset.h"
@@ -536,8 +551,8 @@ struct glyph
int img_id;
#ifdef HAVE_XWIDGETS
- /* Xwidget reference (type == XWIDGET_GLYPH). */
- struct xwidget *xwidget;
+ /* Xwidget ID. */
+ uint32_t xwidget;
#endif
/* Sub-structure for type == STRETCH_GLYPH. */
@@ -1393,6 +1408,9 @@ struct glyph_string
Emacs_GC *gc;
HDC hdc;
#endif
+#if defined (HAVE_PGTK)
+ Emacs_GC xgcv;
+#endif
/* A pointer to the first glyph in the string. This glyph
corresponds to char2b[0]. Needed to draw rectangles if
@@ -1470,21 +1488,23 @@ struct glyph_string
compared against minibuf_window (if SELW doesn't match), and SCRW
which is compared against minibuf_selected_window (if MBW matches). */
-#define CURRENT_MODE_LINE_FACE_ID_3(SELW, MBW, SCRW) \
+#define CURRENT_MODE_LINE_ACTIVE_FACE_ID_3(SELW, MBW, SCRW) \
((!mode_line_in_non_selected_windows \
|| (SELW) == XWINDOW (selected_window) \
|| (minibuf_level > 0 \
&& !NILP (minibuf_selected_window) \
&& (MBW) == XWINDOW (minibuf_window) \
&& (SCRW) == XWINDOW (minibuf_selected_window))) \
- ? MODE_LINE_FACE_ID \
+ ? MODE_LINE_ACTIVE_FACE_ID \
: MODE_LINE_INACTIVE_FACE_ID)
/* Return the desired face id for the mode line of window W. */
-#define CURRENT_MODE_LINE_FACE_ID(W) \
- (CURRENT_MODE_LINE_FACE_ID_3((W), XWINDOW (selected_window), (W)))
+#define CURRENT_MODE_LINE_ACTIVE_FACE_ID(W) \
+ (CURRENT_MODE_LINE_ACTIVE_FACE_ID_3((W), \
+ XWINDOW (selected_window), \
+ (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
@@ -1497,7 +1517,7 @@ struct glyph_string
= (MATRIX_MODE_LINE_HEIGHT ((W)->current_matrix) \
? MATRIX_MODE_LINE_HEIGHT ((W)->current_matrix) \
: estimate_mode_line_height \
- (XFRAME ((W)->frame), CURRENT_MODE_LINE_FACE_ID (W)))))
+ (XFRAME ((W)->frame), CURRENT_MODE_LINE_ACTIVE_FACE_ID (W)))))
/* Return the current height of the header line of window W. If not known
from W->header_line_height, look at W's current glyph matrix, or return
@@ -1811,7 +1831,7 @@ face_tty_specified_color (unsigned long color)
enum face_id
{
DEFAULT_FACE_ID,
- MODE_LINE_FACE_ID,
+ MODE_LINE_ACTIVE_FACE_ID,
MODE_LINE_INACTIVE_FACE_ID,
TOOL_BAR_FACE_ID,
FRINGE_FACE_ID,
@@ -1829,6 +1849,7 @@ enum face_id
CHILD_FRAME_BORDER_FACE_ID,
TAB_BAR_FACE_ID,
TAB_LINE_FACE_ID,
+ MODE_LINE_FACE_ID,
BASIC_FACE_ID_SENTINEL
};
@@ -2538,7 +2559,8 @@ struct it
enum line_wrap_method line_wrap;
/* The ID of the default face to use. One of DEFAULT_FACE_ID,
- MODE_LINE_FACE_ID, etc, depending on what we are displaying. */
+ MODE_LINE_ACTIVE_FACE_ID, etc, depending on what we are
+ displaying. */
int base_face_id;
/* If `what' == IT_CHARACTER, the character and the length in bytes
@@ -2739,6 +2761,12 @@ struct it
/* For iterating over bidirectional text. */
struct bidi_it bidi_it;
bidi_dir_t paragraph_embedding;
+
+ /* For handling the :min-width property. The object is the text
+ property we're testing the `eq' of (nil if none), and the integer
+ is the x position of the start of the run of glyphs. */
+ Lisp_Object min_width_property;
+ int min_width_start;
};
@@ -3011,7 +3039,7 @@ struct redisplay_interface
#ifdef HAVE_WINDOW_SYSTEM
# if (defined USE_CAIRO || defined HAVE_XRENDER \
- || defined HAVE_NS || defined HAVE_NTGUI)
+ || defined HAVE_NS || defined HAVE_NTGUI || defined HAVE_HAIKU)
# define HAVE_NATIVE_TRANSFORMS
# endif
@@ -3050,6 +3078,14 @@ struct image
#ifdef HAVE_NTGUI
XFORM xform;
#endif
+#ifdef HAVE_HAIKU
+ /* Non-zero if the image has not yet been transformed for display. */
+ int have_be_transforms_p;
+
+ double be_rotate;
+ double be_scale_x;
+ double be_scale_y;
+#endif
/* Colors allocated for this image, if any. Allocated via xmalloc. */
unsigned long *colors;
@@ -3162,7 +3198,7 @@ struct image_cache
/* Size of bucket vector of image caches. Should be prime. */
-#define IMAGE_CACHE_BUCKETS_SIZE 1001
+#define IMAGE_CACHE_BUCKETS_SIZE 1009
#endif /* HAVE_WINDOW_SYSTEM */
@@ -3489,7 +3525,8 @@ bool valid_image_p (Lisp_Object);
void prepare_image_for_display (struct frame *, struct image *);
ptrdiff_t lookup_image (struct frame *, Lisp_Object, int);
-#if defined HAVE_X_WINDOWS || defined USE_CAIRO || defined HAVE_NS
+#if defined HAVE_X_WINDOWS || defined USE_CAIRO || defined HAVE_NS \
+ || defined HAVE_HAIKU
#define RGB_PIXEL_COLOR unsigned long
#endif
@@ -3722,10 +3759,8 @@ extern Lisp_Object gui_default_parameter (struct frame *, Lisp_Object,
const char *, const char *,
enum resource_types);
-#ifndef HAVE_NS /* These both used on W32 and X only. */
extern bool gui_mouse_grabbed (Display_Info *);
extern void gui_redo_mouse_highlight (Display_Info *);
-#endif /* HAVE_NS */
#endif /* HAVE_WINDOW_SYSTEM */
diff --git a/src/dispnew.c b/src/dispnew.c
index 4a9f2bae44b..4faa7a7777b 100644
--- a/src/dispnew.c
+++ b/src/dispnew.c
@@ -3850,6 +3850,9 @@ gui_update_window_end (struct window *w, bool cursor_on_p,
w->output_cursor.hpos, w->output_cursor.vpos,
w->output_cursor.x, w->output_cursor.y);
+ if (cursor_in_mouse_face_p (w) && cursor_on_p)
+ mouse_face_overwritten_p = 1;
+
if (draw_window_fringes (w, true))
{
if (WINDOW_RIGHT_DIVIDER_WIDTH (w))
@@ -4446,16 +4449,6 @@ scrolling_window (struct window *w, int tab_line_p)
break;
}
-#ifdef HAVE_XWIDGETS
- /* Currently this seems needed to detect xwidget movement reliably.
- This is most probably because an xwidget glyph is represented in
- struct glyph's 'union u' by a pointer to a struct, which takes 8
- bytes in 64-bit builds, and thus the comparison of u.val values
- done by GLYPH_EQUAL_P doesn't work reliably, since it assumes the
- size of the union is 4 bytes. FIXME. */
- return 0;
-#endif
-
/* Can't scroll the display of w32 GUI frames when position of point
is indicated by the system caret, because scrolling the display
will then "copy" the pixels used by the caret. */
@@ -6153,7 +6146,7 @@ sit_for (Lisp_Object timeout, bool reading, int display_option)
wrong_type_argument (Qnumberp, timeout);
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
gobble_input ();
#endif
@@ -6460,6 +6453,24 @@ init_display_interactive (void)
}
#endif
+#ifdef HAVE_PGTK
+ if (!inhibit_window_system && !will_dump_p ())
+ {
+ Vinitial_window_system = Qpgtk;
+ Vwindow_system_version = make_fixnum (3);
+ return;
+ }
+#endif
+
+#ifdef HAVE_HAIKU
+ if (!inhibit_window_system && !will_dump_p ())
+ {
+ Vinitial_window_system = Qhaiku;
+ Vwindow_system_version = make_fixnum (1);
+ return;
+ }
+#endif
+
/* If no window system has been specified, try to use the terminal. */
if (! isatty (STDIN_FILENO))
fatal ("standard input is not a tty");
diff --git a/src/dynlib.c b/src/dynlib.c
index a8c88439615..e9a775f2d3c 100644
--- a/src/dynlib.c
+++ b/src/dynlib.c
@@ -104,6 +104,12 @@ dynlib_open (const char *dll_fname)
return (dynlib_handle_ptr) hdll;
}
+dynlib_handle_ptr
+dynlib_open_for_eln (const char *dll_fname)
+{
+ return dynlib_open (dll_fname);
+}
+
void *
dynlib_sym (dynlib_handle_ptr h, const char *sym)
{
@@ -270,6 +276,12 @@ dynlib_close (dynlib_handle_ptr h)
dynlib_handle_ptr
dynlib_open (const char *path)
{
+ return dlopen (path, RTLD_LAZY | RTLD_GLOBAL);
+}
+
+dynlib_handle_ptr
+dynlib_open_for_eln (const char *path)
+{
return dlopen (path, RTLD_LAZY);
}
diff --git a/src/dynlib.h b/src/dynlib.h
index e20d8891a23..05ba7981226 100644
--- a/src/dynlib.h
+++ b/src/dynlib.h
@@ -24,6 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
typedef void *dynlib_handle_ptr;
dynlib_handle_ptr dynlib_open (const char *path);
+dynlib_handle_ptr dynlib_open_for_eln (const char *path);
int dynlib_close (dynlib_handle_ptr h);
const char *dynlib_error (void);
diff --git a/src/emacs-module.h.in b/src/emacs-module.h.in
index fe52587c1a5..a56e4dd12ae 100644
--- a/src/emacs-module.h.in
+++ b/src/emacs-module.h.in
@@ -169,6 +169,19 @@ struct emacs_env_28
@module_env_snippet_28@
};
+struct emacs_env_29
+{
+@module_env_snippet_25@
+
+@module_env_snippet_26@
+
+@module_env_snippet_27@
+
+@module_env_snippet_28@
+
+@module_env_snippet_29@
+};
+
/* 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 c99b007ea78..6048d126781 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -109,6 +109,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "getpagesize.h"
#include "gnutls.h"
+#ifdef HAVE_HAIKU
+#include <kernel/OS.h>
+#endif
+
#ifdef PROFILING
# include <sys/gmon.h>
extern void moncontrol (int mode);
@@ -133,6 +137,7 @@ extern char etext;
#endif
#include "pdumper.h"
+#include "fingerprint.h"
#include "epaths.h"
static const char emacs_version[] = PACKAGE_VERSION;
@@ -255,11 +260,12 @@ Initialization options:\n\
#ifdef HAVE_PDUMPER
"\
--dump-file FILE read dumped state from FILE\n\
+--fingerprint output fingerprint and exit\n\
",
#endif
#if SECCOMP_USABLE
"\
---sandbox=FILE read Seccomp BPF filter from FILE\n\
+--seccomp=FILE read Seccomp BPF filter from FILE\n\
"
#endif
"\
@@ -830,6 +836,8 @@ load_pdump (int argc, char **argv)
const char *const suffix = ".pdmp";
int result;
char *emacs_executable = argv[0];
+ ptrdiff_t hexbuf_size;
+ char *hexbuf;
const char *strip_suffix =
#if defined DOS_NT || defined CYGWIN
".exe"
@@ -924,12 +932,18 @@ load_pdump (int argc, char **argv)
path_exec = ns_relocate (path_exec);
#endif
- /* Look for "emacs.pdmp" in PATH_EXEC. We hardcode "emacs" in
- "emacs.pdmp" so that the Emacs binary still works if the user
- copies and renames it. */
+ /* Look for "emacs-FINGERPRINT.pdmp" in PATH_EXEC. We hardcode
+ "emacs" in "emacs-FINGERPRINT.pdmp" so that the Emacs binary
+ still works if the user copies and renames it. */
+ hexbuf_size = 2 * sizeof fingerprint;
+ hexbuf = xmalloc (hexbuf_size + 1);
+ hexbuf_digest (hexbuf, (char *) fingerprint, sizeof fingerprint);
+ hexbuf[hexbuf_size] = '\0';
needed = (strlen (path_exec)
+ 1
+ strlen (argv0_base)
+ + 1
+ + strlen (hexbuf)
+ strlen (suffix)
+ 1);
if (bufsize < needed)
@@ -937,8 +951,8 @@ load_pdump (int argc, char **argv)
xfree (dump_file);
dump_file = xpalloc (NULL, &bufsize, needed - bufsize, -1, 1);
}
- sprintf (dump_file, "%s%c%s%s",
- path_exec, DIRECTORY_SEP, argv0_base, suffix);
+ sprintf (dump_file, "%s%c%s-%s%s",
+ path_exec, DIRECTORY_SEP, argv0_base, hexbuf, suffix);
#if !defined (NS_SELF_CONTAINED)
/* Assume the Emacs binary lives in a sibling directory as set up by
the default installation configuration. */
@@ -1420,6 +1434,24 @@ main (int argc, char **argv)
exit (0);
}
+#ifdef HAVE_PDUMPER
+ if (argmatch (argv, argc, "-fingerprint", "--fingerprint", 4,
+ NULL, &skip_args))
+ {
+ if (initialized)
+ {
+ dump_fingerprint (stdout, "",
+ (unsigned char *) fingerprint);
+ exit (0);
+ }
+ else
+ {
+ fputs ("Not initialized\n", stderr);
+ exit (1);
+ }
+ }
+#endif
+
emacs_wd = emacs_get_current_dir_name ();
#ifdef HAVE_PDUMPER
if (dumped_with_pdumper_p ())
@@ -1877,7 +1909,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
init_bignum ();
init_threads ();
init_eval ();
- init_atimer ();
+#ifdef HAVE_PGTK
+ init_pgtkterm (); /* before init_atimer(). */
+#endif
running_asynch_code = 0;
init_random ();
@@ -2039,6 +2073,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
if (!will_dump_p ())
set_initial_environment ();
+ /* Has to run after the environment is set up. */
+ init_atimer ();
+
#ifdef WINDOWSNT
globals_of_w32 ();
#ifdef HAVE_W32NOTIFY
@@ -2149,6 +2186,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
#endif
syms_of_window ();
syms_of_xdisp ();
+ syms_of_sqlite ();
syms_of_font ();
#ifdef HAVE_WINDOW_SYSTEM
syms_of_fringe ();
@@ -2210,6 +2248,27 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
syms_of_fontset ();
#endif /* HAVE_NS */
+#ifdef HAVE_PGTK
+ syms_of_pgtkterm ();
+ syms_of_pgtkfns ();
+ syms_of_pgtkselect ();
+ syms_of_pgtkmenu ();
+ syms_of_pgtkim ();
+ syms_of_fontset ();
+ syms_of_xsettings ();
+#endif /* HAVE_PGTK */
+#ifdef HAVE_HAIKU
+ syms_of_haikuterm ();
+ syms_of_haikufns ();
+ syms_of_haikumenu ();
+ syms_of_haikufont ();
+ syms_of_haikuselect ();
+#ifdef HAVE_NATIVE_IMAGE_API
+ syms_of_haikuimage ();
+#endif
+ syms_of_fontset ();
+#endif /* HAVE_HAIKU */
+
syms_of_gnutls ();
#ifdef HAVE_INOTIFY
@@ -2264,6 +2323,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
#if defined WINDOWSNT || defined HAVE_NTGUI
globals_of_w32select ();
#endif
+
+#ifdef HAVE_HAIKU
+ init_haiku_select ();
+#endif
}
init_charset ();
@@ -2277,7 +2340,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
#ifdef HAVE_DBUS
init_dbusbind ();
#endif
-#ifdef USE_GTK
+#if defined(USE_GTK) && !defined(HAVE_PGTK)
init_xterm ();
#endif
@@ -2349,6 +2412,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
if (dump_mode)
Vdump_mode = build_string (dump_mode);
+#ifdef HAVE_PDUMPER
+ /* Allow code to be run (mostly useful after redumping). */
+ safe_run_hooks (Qafter_pdump_load_hook);
+#endif
+
/* Enter editor command loop. This never returns. */
set_initial_minibuffer_mode ();
Frecursive_edit ();
@@ -2371,6 +2439,9 @@ struct standard_args
static const struct standard_args standard_args[] =
{
{ "-version", "--version", 150, 0 },
+#ifdef HAVE_PDUMPER
+ { "-fingerprint", "--fingerprint", 140, 0 },
+#endif
{ "-chdir", "--chdir", 130, 1 },
{ "-t", "--terminal", 120, 1 },
{ "-nw", "--no-window-system", 110, 0 },
@@ -2734,6 +2805,9 @@ shut_down_emacs (int sig, Lisp_Object stuff)
/* Don't update display from now on. */
Vinhibit_redisplay = Qt;
+#ifdef HAVE_HAIKU
+ be_app_quit ();
+#endif
/* If we are controlling the terminal, reset terminal modes. */
#ifndef DOS_NT
pid_t tpgrp = tcgetpgrp (STDIN_FILENO);
@@ -2743,6 +2817,10 @@ shut_down_emacs (int sig, Lisp_Object stuff)
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"
+ INT_STRLEN_BOUND (int) + 1),
min (PIPE_BUF, MAX_ALLOCA))];
@@ -3235,6 +3313,7 @@ Special values:
`ms-dos' compiled as an MS-DOS application.
`windows-nt' compiled as a native W32 application.
`cygwin' compiled using the Cygwin library.
+ `haiku' compiled for a Haiku system.
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.c b/src/emacsgtkfixed.c
index 996ded2acaa..78c952f8054 100644
--- a/src/emacsgtkfixed.c
+++ b/src/emacsgtkfixed.c
@@ -22,7 +22,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "frame.h"
+#ifdef HAVE_PGTK
+#include "pgtkterm.h"
+#else
#include "xterm.h"
+#endif
#include "xwidget.h"
#include "emacsgtkfixed.h"
@@ -47,7 +51,9 @@ static void emacs_fixed_get_preferred_width (GtkWidget *widget,
static void emacs_fixed_get_preferred_height (GtkWidget *widget,
gint *minimum,
gint *natural);
+#ifndef HAVE_PGTK
static GType emacs_fixed_get_type (void);
+#endif
G_DEFINE_TYPE (EmacsFixed, emacs_fixed, GTK_TYPE_FIXED)
static EmacsFixed *
@@ -57,92 +63,6 @@ EMACS_FIXED (GtkWidget *widget)
EmacsFixed);
}
-#ifdef HAVE_XWIDGETS
-
-static EmacsFixedClass *
-EMACS_FIXED_GET_CLASS (GtkWidget *widget)
-{
- return G_TYPE_INSTANCE_GET_CLASS (widget, emacs_fixed_get_type (),
- EmacsFixedClass);
-}
-
-struct GtkFixedPrivateL
-{
- GList *children;
-};
-
-static void
-emacs_fixed_gtk_widget_size_allocate (GtkWidget *widget,
- GtkAllocation *allocation)
-{
- /* For xwidgets.
-
- This basically re-implements the base class method and adds an
- additional case for an xwidget view.
-
- It would be nicer if the bse class method could be called first,
- and the xview modification only would remain here. It wasn't
- possible to solve it that way yet. */
- EmacsFixedClass *klass;
- GtkWidgetClass *parent_class;
- struct GtkFixedPrivateL *priv;
-
- klass = EMACS_FIXED_GET_CLASS (widget);
- parent_class = g_type_class_peek_parent (klass);
- parent_class->size_allocate (widget, allocation);
-
- priv = G_TYPE_INSTANCE_GET_PRIVATE (widget, GTK_TYPE_FIXED,
- struct GtkFixedPrivateL);
-
- gtk_widget_set_allocation (widget, allocation);
-
- if (gtk_widget_get_has_window (widget))
- {
- if (gtk_widget_get_realized (widget))
- gdk_window_move_resize (gtk_widget_get_window (widget),
- allocation->x,
- allocation->y,
- allocation->width,
- allocation->height);
- }
-
- for (GList *children = priv->children; children; children = children->next)
- {
- GtkFixedChild *child = children->data;
-
- if (!gtk_widget_get_visible (child->widget))
- continue;
-
- GtkRequisition child_requisition;
- gtk_widget_get_preferred_size (child->widget, &child_requisition, NULL);
-
- GtkAllocation child_allocation;
- child_allocation.x = child->x;
- child_allocation.y = child->y;
-
- if (!gtk_widget_get_has_window (widget))
- {
- child_allocation.x += allocation->x;
- child_allocation.y += allocation->y;
- }
-
- child_allocation.width = child_requisition.width;
- child_allocation.height = child_requisition.height;
-
- struct xwidget_view *xv
- = g_object_get_data (G_OBJECT (child->widget), XG_XWIDGET_VIEW);
- if (xv)
- {
- child_allocation.width = xv->clip_right;
- child_allocation.height = xv->clip_bottom - xv->clip_top;
- }
-
- gtk_widget_size_allocate (child->widget, &child_allocation);
- }
-}
-
-#endif /* HAVE_XWIDGETS */
-
static void
emacs_fixed_class_init (EmacsFixedClass *klass)
{
@@ -152,9 +72,6 @@ emacs_fixed_class_init (EmacsFixedClass *klass)
widget_class->get_preferred_width = emacs_fixed_get_preferred_width;
widget_class->get_preferred_height = emacs_fixed_get_preferred_height;
-#ifdef HAVE_XWIDGETS
- widget_class->size_allocate = emacs_fixed_gtk_widget_size_allocate;
-#endif
g_type_class_add_private (klass, sizeof (EmacsFixedPrivate));
}
@@ -182,9 +99,15 @@ emacs_fixed_get_preferred_width (GtkWidget *widget,
{
EmacsFixed *fixed = EMACS_FIXED (widget);
EmacsFixedPrivate *priv = fixed->priv;
+#ifdef HAVE_PGTK
+ int w = priv->f->output_data.pgtk->size_hints.min_width;
+ if (minimum) *minimum = w;
+ if (natural) *natural = priv->f->output_data.pgtk->preferred_width;
+#else
int w = priv->f->output_data.x->size_hints.min_width;
if (minimum) *minimum = w;
if (natural) *natural = w;
+#endif
}
static void
@@ -194,12 +117,20 @@ emacs_fixed_get_preferred_height (GtkWidget *widget,
{
EmacsFixed *fixed = EMACS_FIXED (widget);
EmacsFixedPrivate *priv = fixed->priv;
+#ifdef HAVE_PGTK
+ int h = priv->f->output_data.pgtk->size_hints.min_height;
+ if (minimum) *minimum = h;
+ if (natural) *natural = priv->f->output_data.pgtk->preferred_height;
+#else
int h = priv->f->output_data.x->size_hints.min_height;
if (minimum) *minimum = h;
if (natural) *natural = h;
+#endif
}
+#ifndef HAVE_PGTK
+
/* Override the X function so we can intercept Gtk+ 3 calls.
Use our values for min_width/height so that KDE don't freak out
(Bug#8919), and so users can resize our frames as they wish. */
@@ -234,8 +165,13 @@ XSetWMSizeHints (Display *d,
if ((hints->flags & PMinSize) && f)
{
+#ifdef HAVE_PGTK
+ int w = f->output_data.pgtk->size_hints.min_width;
+ int h = f->output_data.pgtk->size_hints.min_height;
+#else
int w = f->output_data.x->size_hints.min_width;
int h = f->output_data.x->size_hints.min_height;
+#endif
data[5] = w;
data[6] = h;
}
@@ -253,3 +189,5 @@ XSetWMNormalHints (Display *d, Window w, XSizeHints *hints)
{
XSetWMSizeHints (d, w, hints, XA_WM_NORMAL_HINTS);
}
+
+#endif
diff --git a/src/emacsgtkfixed.h b/src/emacsgtkfixed.h
index 78879764d86..4f7a4eb3f71 100644
--- a/src/emacsgtkfixed.h
+++ b/src/emacsgtkfixed.h
@@ -27,6 +27,11 @@ 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))
+#endif
+
struct frame;
typedef struct _EmacsFixedPrivate EmacsFixedPrivate;
@@ -44,6 +49,10 @@ struct _EmacsFixedClass
GtkFixedClass parent_class;
};
+#ifdef HAVE_PGTK
+extern GType emacs_fixed_get_type (void);
+#endif
+
extern GtkWidget *emacs_fixed_new (struct frame *f);
G_END_DECLS
diff --git a/src/eval.c b/src/eval.c
index 3ac1afc17bd..fe29564aa2d 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -29,6 +29,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "dispextern.h"
#include "buffer.h"
#include "pdumper.h"
+#include "atimer.h"
/* CACHEABLE is ordinarily nothing, except it is 'volatile' if
necessary to cajole GCC into not warning incorrectly that a
@@ -1075,6 +1076,47 @@ usage: (while TEST BODY...) */)
return Qnil;
}
+static void
+with_delayed_message_display (struct atimer *timer)
+{
+ message3 (build_string (timer->client_data));
+}
+
+static void
+with_delayed_message_cancel (void *timer)
+{
+ xfree (((struct atimer *) timer)->client_data);
+ cancel_atimer (timer);
+}
+
+DEFUN ("funcall-with-delayed-message",
+ Ffuncall_with_delayed_message, Sfuncall_with_delayed_message,
+ 3, 3, 0,
+ doc: /* Like `funcall', but display MESSAGE if FUNCTION takes longer than TIMEOUT.
+TIMEOUT is a number of seconds, and can be an integer or a floating
+point number.
+
+If FUNCTION takes less time to execute than TIMEOUT seconds, MESSAGE
+is not displayed. */)
+ (Lisp_Object timeout, Lisp_Object message, Lisp_Object function)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ CHECK_NUMBER (timeout);
+ CHECK_STRING (message);
+
+ /* Set up the atimer. */
+ struct timespec interval = dtotimespec (XFLOATINT (timeout));
+ struct atimer *timer = start_atimer (ATIMER_RELATIVE, interval,
+ with_delayed_message_display,
+ xstrdup (SSDATA (message)));
+ record_unwind_protect_ptr (with_delayed_message_cancel, timer);
+
+ Lisp_Object result = CALLN (Ffuncall, function);
+
+ return unbind_to (count, result);
+}
+
DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
doc: /* Return result of expanding macros at top level of FORM.
If FORM is not a macro call, it is returned unchanged.
@@ -4510,6 +4552,7 @@ alist of active lexical bindings. */);
defsubr (&Slet);
defsubr (&SletX);
defsubr (&Swhile);
+ defsubr (&Sfuncall_with_delayed_message);
defsubr (&Smacroexpand);
defsubr (&Scatch);
defsubr (&Sthrow);
diff --git a/src/fileio.c b/src/fileio.c
index b1f464cf988..f802e4e4184 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -195,7 +195,11 @@ get_file_errno_data (char const *string, Lisp_Object name, int errorno)
if (errorno == EEXIST)
return Fcons (Qfile_already_exists, errdata);
else
- return Fcons (errorno == ENOENT ? Qfile_missing : Qfile_error,
+ return Fcons (errorno == ENOENT
+ ? Qfile_missing
+ : (errorno == EACCES
+ ? Qpermission_denied
+ : Qfile_error),
Fcons (build_string (string), errdata));
}
@@ -3833,7 +3837,7 @@ restore_window_points (Lisp_Object window_markers, ptrdiff_t inserted,
Lisp_Object oldpos = XCDR (car);
if (MARKERP (marker) && FIXNUMP (oldpos)
&& XFIXNUM (oldpos) > same_at_start
- && XFIXNUM (oldpos) < same_at_end)
+ && XFIXNUM (oldpos) <= same_at_end)
{
ptrdiff_t oldsize = same_at_end - same_at_start;
ptrdiff_t newsize = inserted;
@@ -6194,7 +6198,7 @@ before any other event (mouse or keypress) is handled. */)
(void)
{
#if (defined USE_GTK || defined USE_MOTIF \
- || defined HAVE_NS || defined HAVE_NTGUI)
+ || defined HAVE_NS || defined HAVE_NTGUI || defined HAVE_HAIKU)
if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
&& use_dialog_box
&& use_file_dialog
@@ -6380,6 +6384,7 @@ syms_of_fileio (void)
DEFSYM (Qfile_already_exists, "file-already-exists");
DEFSYM (Qfile_date_error, "file-date-error");
DEFSYM (Qfile_missing, "file-missing");
+ DEFSYM (Qpermission_denied, "permission-denied");
DEFSYM (Qfile_notify_error, "file-notify-error");
DEFSYM (Qremote_file_error, "remote-file-error");
DEFSYM (Qexcl, "excl");
@@ -6438,6 +6443,11 @@ behaves as if file names were encoded in `utf-8'. */);
Fput (Qfile_missing, Qerror_message,
build_pure_c_string ("File is missing"));
+ Fput (Qpermission_denied, Qerror_conditions,
+ Fpurecopy (list3 (Qpermission_denied, Qfile_error, Qerror)));
+ Fput (Qpermission_denied, Qerror_message,
+ build_pure_c_string ("Cannot access file or directory"));
+
Fput (Qfile_notify_error, Qerror_conditions,
Fpurecopy (list3 (Qfile_notify_error, Qfile_error, Qerror)));
Fput (Qfile_notify_error, Qerror_message,
diff --git a/src/filelock.c b/src/filelock.c
index cc185d96cdf..c12776246bd 100644
--- a/src/filelock.c
+++ b/src/filelock.c
@@ -65,7 +65,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#define BOOT_TIME_FILE "/var/run/random-seed"
#endif
-#if !defined WTMP_FILE && !defined WINDOWSNT
+#if !defined WTMP_FILE && !defined WINDOWSNT && defined BOOT_TIME
#define WTMP_FILE "/var/log/wtmp"
#endif
diff --git a/src/floatfns.c b/src/floatfns.c
index aadae4fd9d6..f52dae47193 100644
--- a/src/floatfns.c
+++ b/src/floatfns.c
@@ -347,6 +347,21 @@ int
double_integer_scale (double d)
{
int exponent = ilogb (d);
+#ifdef HAIKU
+ /* On Haiku, the values returned by ilogb are nonsensical when
+ confronted with tiny numbers, inf, or NaN, which breaks the trick
+ used by code on other platforms, so we have to test for each case
+ manually, and return the appropriate value. */
+ if (exponent == FP_ILOGB0)
+ {
+ if (isnan (d))
+ return (DBL_MANT_DIG - DBL_MIN_EXP) + 2;
+ if (isinf (d))
+ return (DBL_MANT_DIG - DBL_MIN_EXP) + 1;
+
+ return (DBL_MANT_DIG - DBL_MIN_EXP);
+ }
+#endif
return (DBL_MIN_EXP - 1 <= exponent && exponent < INT_MAX
? DBL_MANT_DIG - 1 - exponent
: (DBL_MANT_DIG - DBL_MIN_EXP
diff --git a/src/fns.c b/src/fns.c
index 6f358dd1ba4..76c76c92ba9 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -2855,12 +2855,16 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
return leni;
}
-DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
+DEFUN ("mapconcat", Fmapconcat, Smapconcat, 2, 3, 0,
doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
In between each pair of results, stick in SEPARATOR. Thus, " " as
SEPARATOR results in spaces between the values returned by FUNCTION.
+
SEQUENCE may be a list, a vector, a bool-vector, or a string.
-SEPARATOR must be a string, a vector, or a list of characters.
+
+Optional argument SEPARATOR must be a string, a vector, or a list of
+characters; nil stands for the empty string.
+
FUNCTION must be a function of one argument, and must return a value
that is a sequence of characters: either a string, or a vector or
list of numbers that are valid character codepoints. */)
diff --git a/src/font.c b/src/font.c
index c0050a99cfe..f2fd64e76ee 100644
--- a/src/font.c
+++ b/src/font.c
@@ -57,24 +57,28 @@ struct table_entry
int numeric;
/* The first one is a valid name as a face attribute.
The second one (if any) is a typical name in XLFD field. */
- const char *names[5];
+ const char *names[6];
};
+/* The following tables should be in sync with 'custom-face-attributes'. */
+
/* Table of weight numeric values and their names. This table must be
- sorted by numeric values in ascending order. */
+ sorted by numeric values in ascending order and the numeric values
+ must approximately match the weights in the font files. */
static const struct table_entry weight_table[] =
{
{ 0, { "thin" }},
- { 20, { "ultra-light", "ultralight" }},
- { 40, { "extra-light", "extralight" }},
+ { 40, { "ultra-light", "ultralight", "extra-light", "extralight" }},
{ 50, { "light" }},
- { 75, { "semi-light", "semilight", "demilight", "book" }},
- { 100, { "normal", "medium", "regular", "unspecified" }},
- { 180, { "semi-bold", "semibold", "demibold", "demi" }},
+ { 55, { "semi-light", "semilight", "demilight" }},
+ { 80, { "regular", "normal", "unspecified", "book" }},
+ { 100, { "medium" }},
+ { 180, { "semi-bold", "semibold", "demibold", "demi-bold", "demi" }},
{ 200, { "bold" }},
- { 205, { "extra-bold", "extrabold" }},
- { 210, { "ultra-bold", "ultrabold", "black" }}
+ { 205, { "extra-bold", "extrabold", "ultra-bold", "ultrabold" }},
+ { 210, { "black", "heavy" }},
+ { 250, { "ultra-heavy", "ultraheavy" }}
};
/* Table of slant numeric values and their names. This table must be
@@ -1484,11 +1488,20 @@ font_parse_fcname (char *name, ptrdiff_t len, Lisp_Object font)
#define PROP_MATCH(STR) (word_len == strlen (STR) \
&& memcmp (p, STR, strlen (STR)) == 0)
- if (PROP_MATCH ("light")
+ if (PROP_MATCH ("thin")
+ || PROP_MATCH ("ultra-light")
+ || PROP_MATCH ("light")
+ || PROP_MATCH ("semi-light")
+ || PROP_MATCH ("book")
|| PROP_MATCH ("medium")
+ || PROP_MATCH ("normal")
+ || PROP_MATCH ("semibold")
|| PROP_MATCH ("demibold")
|| PROP_MATCH ("bold")
- || PROP_MATCH ("black"))
+ || PROP_MATCH ("ultra-bold")
+ || PROP_MATCH ("black")
+ || PROP_MATCH ("heavy")
+ || PROP_MATCH ("ultra-heavy"))
FONT_SET_STYLE (font, FONT_WEIGHT_INDEX, val);
else if (PROP_MATCH ("roman")
|| PROP_MATCH ("italic")
@@ -2748,10 +2761,34 @@ font_delete_unmatched (Lisp_Object vec, Lisp_Object spec, int size)
continue;
}
for (prop = FONT_WEIGHT_INDEX; prop < FONT_SIZE_INDEX; prop++)
- if (FIXNUMP (AREF (spec, prop))
- && ((XFIXNUM (AREF (spec, prop)) >> 8)
- != (XFIXNUM (AREF (entity, prop)) >> 8)))
- prop = FONT_SPEC_MAX;
+ {
+ if (FIXNUMP (AREF (spec, prop)))
+ {
+ int required = XFIXNUM (AREF (spec, prop)) >> 8;
+ int candidate = XFIXNUM (AREF (entity, prop)) >> 8;
+
+ if (candidate != required
+ /* A kludge for w32 font search, where listing a
+ family returns only 4 standard weights: regular,
+ italic, bold, bold-italic. For other values one
+ must specify the font, not just the family in the
+ :family attribute of the face. But specifying
+ :family in the face attributes looks for regular
+ weight, so if we require exact match, the
+ non-regular font will be rejected. So we relax
+ the accuracy of the match here, and let
+ font_sort_entities find the best match.
+
+ Similar things happen on Posix platforms, when
+ people use font families that don't have the
+ regular weight, only the medium weight: these
+ families get rejected if we require an exact match. */
+ && (prop != FONT_WEIGHT_INDEX
+ || eabs (candidate - required) > 100)
+ )
+ prop = FONT_SPEC_MAX;
+ }
+ }
if (prop < FONT_SPEC_MAX
&& size
&& XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) > 0)
@@ -4985,6 +5022,33 @@ If the font is not OpenType font, CAPABILITY is nil. */)
: Qnil));
}
+DEFUN ("font-has-char-p", Ffont_has_char_p, Sfont_has_char_p, 2, 3, 0,
+ doc:
+ /* Return non-nil if FONT on FRAME has a glyph for character CH.
+FONT can be either a font-entity or a font-object. If it is
+a font-entity and the result is nil, it means the font needs to be
+opened (with `open-font') to check.
+FRAME defaults to the selected frame if it is nil or omitted. */)
+ (Lisp_Object font, Lisp_Object ch, Lisp_Object frame)
+{
+ struct frame *f;
+ CHECK_FONT (font);
+ CHECK_CHARACTER (ch);
+
+ if (NILP (frame))
+ f = XFRAME (selected_frame);
+ else
+ {
+ CHECK_FRAME (frame);
+ f = XFRAME (frame);
+ }
+
+ if (font_has_char (f, font, XFIXNAT (ch)) <= 0)
+ return Qnil;
+ else
+ return Qt;
+}
+
DEFUN ("font-get-glyphs", Ffont_get_glyphs, Sfont_get_glyphs, 3, 4, 0,
doc:
/* Return a vector of FONT-OBJECT's glyphs for the specified characters.
@@ -5003,8 +5067,13 @@ where
CODE is the glyph-code of C in FONT-OBJECT.
WIDTH thru DESCENT are the metrics (in pixels) of the glyph.
ADJUSTMENT is always nil.
-If FONT-OBJECT doesn't have a glyph for a character,
-the corresponding element is nil. */)
+
+If FONT-OBJECT doesn't have a glyph for a character, the corresponding
+element is nil.
+
+Also see `font-has-char-p', which is more efficient than this function
+if you just want to check whether FONT-OBJECT has a glyph for a
+character. */)
(Lisp_Object font_object, Lisp_Object from, Lisp_Object to,
Lisp_Object object)
{
@@ -5556,6 +5625,7 @@ syms_of_font (void)
defsubr (&Sclose_font);
defsubr (&Squery_font);
defsubr (&Sfont_get_glyphs);
+ defsubr (&Sfont_has_char_p);
defsubr (&Sfont_match_p);
defsubr (&Sfont_at);
#if 0
@@ -5674,7 +5744,11 @@ match. */);
syms_of_xftfont ();
#endif /* HAVE_XFT */
#endif /* not USE_CAIRO */
-#endif /* HAVE_X_WINDOWS */
+#else /* not HAVE_X_WINDOWS */
+#ifdef USE_CAIRO
+ syms_of_ftcrfont ();
+#endif
+#endif /* not HAVE_X_WINDOWS */
#else /* not HAVE_FREETYPE */
#ifdef HAVE_X_WINDOWS
syms_of_xfont ();
@@ -5686,6 +5760,9 @@ match. */);
#ifdef HAVE_NTGUI
syms_of_w32font ();
#endif /* HAVE_NTGUI */
+#ifdef USE_BE_CAIRO
+ syms_of_ftcrfont ();
+#endif
#endif /* HAVE_WINDOW_SYSTEM */
}
diff --git a/src/font.h b/src/font.h
index 6694164e09b..2da5ec45047 100644
--- a/src/font.h
+++ b/src/font.h
@@ -965,7 +965,7 @@ extern struct font_driver const nsfont_driver;
extern void syms_of_nsfont (void);
extern void syms_of_macfont (void);
#endif /* HAVE_NS */
-#ifdef USE_CAIRO
+#if defined (USE_CAIRO) || defined (USE_BE_CAIRO)
extern struct font_driver const ftcrfont_driver;
#ifdef HAVE_HARFBUZZ
extern struct font_driver ftcrhbfont_driver;
@@ -999,7 +999,7 @@ extern void font_deferred_log (const char *, Lisp_Object, Lisp_Object);
INLINE bool
font_data_structures_may_be_ill_formed (void)
{
-#ifdef USE_CAIRO
+#if defined USE_CAIRO || defined USE_BE_CAIRO
/* Although this works around Bug#20890, it is probably not the
right thing to do. */
return gc_in_progress;
diff --git a/src/frame.c b/src/frame.c
index 2b1cb452efd..2b06bc821d0 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -225,7 +225,9 @@ Value is:
`x' for an Emacs frame that is really an X window,
`w32' for an Emacs frame that is a window on MS-Windows display,
`ns' for an Emacs frame on a GNUstep or Macintosh Cocoa display,
- `pc' for a direct-write MS-DOS frame.
+ `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.
See also `frame-live-p'. */)
(Lisp_Object object)
{
@@ -244,6 +246,10 @@ See also `frame-live-p'. */)
return Qpc;
case output_ns:
return Qns;
+ case output_pgtk:
+ return Qpgtk;
+ case output_haiku:
+ return Qhaiku;
default:
emacs_abort ();
}
@@ -2212,7 +2218,8 @@ delete_frame (Lisp_Object frame, Lisp_Object force)
/* Since a similar behavior was observed on the Lucid and Motif
builds (see Bug#5802, Bug#21509, Bug#23499, Bug#27816), we now
don't delete the terminal for these builds either. */
- if (terminal->reference_count == 0 && terminal->type == output_x_window)
+ if (terminal->reference_count == 0 &&
+ (terminal->type == output_x_window || terminal->type == output_pgtk))
terminal->reference_count = 1;
#endif /* USE_X_TOOLKIT || USE_GTK */
if (terminal->reference_count == 0)
@@ -5028,8 +5035,6 @@ gui_set_no_special_glyphs (struct frame *f, Lisp_Object new_value, Lisp_Object o
}
-#ifndef HAVE_NS
-
/* Non-zero if mouse is grabbed on DPYINFO
and we know the frame where it is. */
@@ -5054,8 +5059,6 @@ gui_redo_mouse_highlight (Display_Info *dpyinfo)
dpyinfo->last_mouse_motion_y);
}
-#endif /* HAVE_NS */
-
/* Subroutines of creating an X frame. */
/* Make sure that Vx_resource_name is set to a reasonable value.
@@ -5897,7 +5900,7 @@ This function is for internal use only. */)
#ifdef HAVE_WINDOW_SYSTEM
-# if (defined USE_GTK || defined HAVE_NS || defined HAVE_XINERAMA \
+# if (defined USE_GTK || defined HAVE_PGTK || defined HAVE_NS || defined HAVE_XINERAMA \
|| defined HAVE_XRANDR)
void
free_monitors (struct MonitorInfo *monitors, int n_monitors)
@@ -5935,6 +5938,10 @@ make_monitor_attribute_list (struct MonitorInfo *monitors,
attributes);
attributes = Fcons (Fcons (Qframes, AREF (monitor_frames, i)),
attributes);
+#ifdef HAVE_PGTK
+ attributes = Fcons (Fcons (Qscale_factor, make_float (mi->scale_factor)),
+ attributes);
+#endif
attributes = Fcons (Fcons (Qmm_size,
list2i (mi->mm_width, mi->mm_height)),
attributes);
@@ -6024,6 +6031,8 @@ syms_of_frame (void)
DEFSYM (Qw32, "w32");
DEFSYM (Qpc, "pc");
DEFSYM (Qns, "ns");
+ DEFSYM (Qpgtk, "pgtk");
+ DEFSYM (Qhaiku, "haiku");
DEFSYM (Qvisible, "visible");
DEFSYM (Qbuffer_predicate, "buffer-predicate");
DEFSYM (Qbuffer_list, "buffer-list");
@@ -6046,6 +6055,9 @@ syms_of_frame (void)
DEFSYM (Qworkarea, "workarea");
DEFSYM (Qmm_size, "mm-size");
+#ifdef HAVE_PGTK
+ DEFSYM (Qscale_factor, "scale-factor");
+#endif
DEFSYM (Qframes, "frames");
DEFSYM (Qsource, "source");
diff --git a/src/frame.h b/src/frame.h
index 3dd76805dd2..4060ee65c42 100644
--- a/src/frame.h
+++ b/src/frame.h
@@ -585,6 +585,8 @@ struct frame
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. */
}
output_data;
@@ -852,6 +854,16 @@ default_pixels_per_inch_y (void)
#else
#define FRAME_NS_P(f) ((f)->output_method == output_ns)
#endif
+#ifndef HAVE_PGTK
+#define FRAME_PGTK_P(f) false
+#else
+#define FRAME_PGTK_P(f) ((f)->output_method == output_pgtk)
+#endif
+#ifndef HAVE_HAIKU
+#define FRAME_HAIKU_P(f) false
+#else
+#define FRAME_HAIKU_P(f) ((f)->output_method == output_haiku)
+#endif
/* FRAME_WINDOW_P tests whether the frame is a graphical window system
frame. */
@@ -864,6 +876,12 @@ default_pixels_per_inch_y (void)
#ifdef HAVE_NS
#define FRAME_WINDOW_P(f) FRAME_NS_P(f)
#endif
+#ifdef HAVE_PGTK
+#define FRAME_WINDOW_P(f) FRAME_PGTK_P(f)
+#endif
+#ifdef HAVE_HAIKU
+#define FRAME_WINDOW_P(f) FRAME_HAIKU_P (f)
+#endif
#ifndef FRAME_WINDOW_P
#define FRAME_WINDOW_P(f) ((void) (f), false)
#endif
@@ -916,6 +934,8 @@ default_pixels_per_inch_y (void)
/* Scale factor of frame F. */
#if defined HAVE_NS
# define FRAME_SCALE_FACTOR(f) (FRAME_NS_P (f) ? ns_frame_scale_factor (f) : 1)
+#elif defined HAVE_PGTK
+# define FRAME_SCALE_FACTOR(f) (FRAME_PGTK_P (f) ? pgtk_frame_scale_factor (f) : 1)
#else
# define FRAME_SCALE_FACTOR(f) 1
#endif
@@ -1673,7 +1693,7 @@ extern const char *x_get_resource_string (const char *, const char *);
extern void x_sync (struct frame *);
#endif /* HAVE_X_WINDOWS */
-#ifndef HAVE_NS
+#if !defined (HAVE_NS) && !defined (HAVE_PGTK)
/* Set F's bitmap icon, if specified among F's parameters. */
@@ -1709,6 +1729,9 @@ struct MonitorInfo {
Emacs_Rectangle geom, work;
int mm_width, mm_height;
char *name;
+#ifdef HAVE_PGTK
+ double scale_factor;
+#endif
};
extern void free_monitors (struct MonitorInfo *monitors, int n_monitors);
diff --git a/src/fringe.c b/src/fringe.c
index b651a4eb0d9..441146d135d 100644
--- a/src/fringe.c
+++ b/src/fringe.c
@@ -30,6 +30,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "termhooks.h"
#include "pdumper.h"
+#include "pgtkterm.h"
+
/* Fringe bitmaps are represented in three different ways:
Logical bitmaps are used internally to denote things like
@@ -1408,7 +1410,7 @@ If BITMAP overrides a standard fringe bitmap, the original bitmap is restored.
On W32 and MAC (little endian), there's no need to do this.
*/
-#if defined (HAVE_X_WINDOWS)
+#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 */
@@ -1471,6 +1473,25 @@ init_fringe_bitmap (int which, struct fringe_bitmap *fb, int once_p)
#endif /* not USE_CAIRO */
#endif /* HAVE_X_WINDOWS */
+#if !defined(HAVE_X_WINDOWS) && defined (HAVE_PGTK)
+ unsigned short *bits = fb->bits;
+ int j;
+
+ for (j = 0; j < fb->height; j++)
+ {
+ unsigned short b = *bits;
+#ifdef WORDS_BIGENDIAN
+ *bits++ = (b << (16 - fb->width));
+#else
+ b = (unsigned short)((swap_nibble[b & 0xf] << 12)
+ | (swap_nibble[(b>>4) & 0xf] << 8)
+ | (swap_nibble[(b>>8) & 0xf] << 4)
+ | (swap_nibble[(b>>12) & 0xf]));
+ *bits++ = (b >> (16 - fb->width));
+#endif
+ }
+#endif /* !HAVE_X_WINDOWS && HAVE_PGTK */
+
#ifdef HAVE_NTGUI
unsigned short *bits = fb->bits;
int j;
diff --git a/src/ftcrfont.c b/src/ftcrfont.c
index db417b3e77d..49b179b0efc 100644
--- a/src/ftcrfont.c
+++ b/src/ftcrfont.c
@@ -22,7 +22,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <cairo-ft.h>
#include "lisp.h"
+#ifdef HAVE_X_WINDOWS
#include "xterm.h"
+#elif HAVE_HAIKU
+#include "haikuterm.h"
+#include "haiku_support.h"
+#include "termchar.h"
+#else
+#include "pgtkterm.h"
+#endif
#include "blockinput.h"
#include "charset.h"
#include "composite.h"
@@ -30,6 +38,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "ftfont.h"
#include "pdumper.h"
+#ifdef USE_BE_CAIRO
+#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff)
+#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff)
+#define BLUE_FROM_ULONG(color) ((color) & 0xff)
+#endif
+
#define METRICS_NCOLS_PER_ROW (128)
enum metrics_status
@@ -513,11 +527,52 @@ ftcrfont_draw (struct glyph_string *s,
block_input ();
+#ifndef USE_BE_CAIRO
+#ifdef HAVE_X_WINDOWS
cr = x_begin_cr_clip (f, s->gc);
+#else
+ cr = pgtk_begin_cr_clip (f);
+#endif
+#else
+ BView_draw_lock (FRAME_HAIKU_VIEW (f));
+ EmacsWindow_begin_cr_critical_section (FRAME_HAIKU_WINDOW (f));
+ cr = haiku_begin_cr_clip (f, s);
+ if (!cr)
+ {
+ BView_draw_unlock (FRAME_HAIKU_VIEW (f));
+ EmacsWindow_end_cr_critical_section (FRAME_HAIKU_WINDOW (f));
+ unblock_input ();
+ return 0;
+ }
+ BView_cr_dump_clipping (FRAME_HAIKU_VIEW (f), cr);
+
+ if (s->left_overhang && s->clip_head && !s->for_overlaps)
+ {
+ cairo_rectangle (cr, s->clip_head->x, 0,
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f));
+ cairo_clip (cr);
+ }
+#endif
if (with_background)
{
+#ifndef USE_BE_CAIRO
+#ifdef HAVE_X_WINDOWS
x_set_cr_source_with_gc_background (f, s->gc);
+#else
+ pgtk_set_cr_source_with_color (f, s->xgcv.background);
+#endif
+#else
+ struct face *face = s->face;
+
+ uint32_t col = s->hl == DRAW_CURSOR ?
+ FRAME_CURSOR_COLOR (s->f).pixel : face->background;
+
+ cairo_set_source_rgb (cr, RED_FROM_ULONG (col) / 255.0,
+ GREEN_FROM_ULONG (col) / 255.0,
+ BLUE_FROM_ULONG (col) / 255.0);
+#endif
+ s->background_filled_p = 1;
cairo_rectangle (cr, x, y - FONT_BASE (face->font),
s->width, FONT_HEIGHT (face->font));
cairo_fill (cr);
@@ -533,13 +588,33 @@ ftcrfont_draw (struct glyph_string *s,
glyphs[i].index,
NULL));
}
-
+#ifndef USE_BE_CAIRO
+#ifdef HAVE_X_WINDOWS
x_set_cr_source_with_gc_foreground (f, s->gc);
+#else
+ pgtk_set_cr_source_with_color (f, s->xgcv.foreground);
+#endif
+#else
+ uint32_t col = s->hl == DRAW_CURSOR ?
+ FRAME_OUTPUT_DATA (s->f)->cursor_fg : face->foreground;
+
+ cairo_set_source_rgb (cr, RED_FROM_ULONG (col) / 255.0,
+ GREEN_FROM_ULONG (col) / 255.0,
+ BLUE_FROM_ULONG (col) / 255.0);
+#endif
cairo_set_scaled_font (cr, ftcrfont_info->cr_scaled_font);
cairo_show_glyphs (cr, glyphs, len);
-
+#ifndef USE_BE_CAIRO
+#ifdef HAVE_X_WINDOWS
x_end_cr_clip (f);
-
+#else
+ pgtk_end_cr_clip (f);
+#endif
+#else
+ haiku_end_cr_clip (cr);
+ EmacsWindow_end_cr_critical_section (FRAME_HAIKU_WINDOW (f));
+ BView_draw_unlock (FRAME_HAIKU_VIEW (f));
+#endif
unblock_input ();
return len;
diff --git a/src/ftfont.c b/src/ftfont.c
index 12d0d72d276..cf592759ab6 100644
--- a/src/ftfont.c
+++ b/src/ftfont.c
@@ -225,8 +225,6 @@ ftfont_pattern_entity (FcPattern *p, Lisp_Object extra)
}
if (FcPatternGetInteger (p, FC_WEIGHT, 0, &numeric) == FcResultMatch)
{
- if (numeric >= FC_WEIGHT_REGULAR && numeric < FC_WEIGHT_MEDIUM)
- numeric = FC_WEIGHT_MEDIUM;
FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX, make_fixnum (numeric));
}
if (FcPatternGetInteger (p, FC_SLANT, 0, &numeric) == FcResultMatch)
@@ -3110,6 +3108,10 @@ syms_of_ftfont (void)
Fput (Qfreetype, Qfont_driver_superseded_by, Qfreetypehb);
#endif /* HAVE_HARFBUZZ */
+#ifdef HAVE_HAIKU
+ DEFSYM (Qmono, "mono");
+#endif
+
/* Fontconfig's generic families and their aliases. */
DEFSYM (Qmonospace, "monospace");
DEFSYM (Qsans_serif, "sans-serif");
diff --git a/src/ftfont.h b/src/ftfont.h
index f771dc159b0..cfab8d3154f 100644
--- a/src/ftfont.h
+++ b/src/ftfont.h
@@ -25,10 +25,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <ft2build.h>
#include FT_FREETYPE_H
#include FT_SIZES_H
+#include FT_TRUETYPE_TABLES_H
#ifdef FT_BDF_H
# include FT_BDF_H
#endif
+#ifdef USE_BE_CAIRO
+#include <cairo.h>
+#endif
+
#ifdef HAVE_HARFBUZZ
#include <hb.h>
#include <hb-ft.h>
@@ -62,7 +67,7 @@ struct font_info
hb_font_t *hb_font;
#endif /* HAVE_HARFBUZZ */
-#ifdef USE_CAIRO
+#if defined (USE_CAIRO) || defined (USE_BE_CAIRO)
cairo_scaled_font_t *cr_scaled_font;
/* Scale factor from the bitmap strike metrics in 1/64 pixels, used
as the hb_position_t value in HarfBuzz, to those in (scaled)
diff --git a/src/gtkutil.c b/src/gtkutil.c
index e87845caf70..62a9c05a977 100644
--- a/src/gtkutil.c
+++ b/src/gtkutil.c
@@ -17,13 +17,6 @@ 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/>. */
-/* FIXME: This code is problematic; it misuses GTK, so the GTK
- developers don't think they should fix the resulting problems in GTK
- itself. The right way to fix this is by rewriting the code in Emacs
- to use GTK3 properly. As of 2020, there is a project to do this.
- Talk with Yuuki Harano <masm+emacs@masm11.me> if you are interested
- in doing substantial work on this. */
-
#include <config.h>
#ifdef USE_GTK
@@ -37,7 +30,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "dispextern.h"
#include "frame.h"
#include "systime.h"
+#ifndef HAVE_PGTK
#include "xterm.h"
+#define xp x
+typedef struct x_output xp_output;
+#else
+#define xp pgtk
+typedef struct pgtk_output xp_output;
+#endif
#include "blockinput.h"
#include "window.h"
#include "gtkutil.h"
@@ -47,12 +47,18 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <gdk/gdkkeysyms.h>
+#ifdef HAVE_XINPUT2
+#include <X11/extensions/XInput2.h>
+#endif
+
#ifdef HAVE_XFT
#include <X11/Xft/Xft.h>
#endif
#ifdef HAVE_GTK3
+#ifndef HAVE_PGTK
#include <gtk/gtkx.h>
+#endif
#include "emacsgtkfixed.h"
#endif
@@ -127,6 +133,7 @@ static GdkDisplay *gdpy_def;
static void
xg_set_screen (GtkWidget *w, struct frame *f)
{
+#ifndef HAVE_PGTK
if (FRAME_X_DISPLAY (f) != DEFAULT_GDK_DISPLAY ())
{
GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f));
@@ -137,6 +144,17 @@ xg_set_screen (GtkWidget *w, struct frame *f)
else
gtk_window_set_screen (GTK_WINDOW (w), gscreen);
}
+#else
+ if (FRAME_X_DISPLAY (f) != DEFAULT_GDK_DISPLAY ())
+ {
+ GdkScreen *gscreen = gdk_display_get_default_screen (FRAME_X_DISPLAY (f));
+
+ if (GTK_IS_MENU (w))
+ gtk_menu_set_screen (GTK_MENU (w), gscreen);
+ else
+ gtk_window_set_screen (GTK_WINDOW (w), gscreen);
+ }
+#endif
}
@@ -148,12 +166,20 @@ xg_set_screen (GtkWidget *w, struct frame *f)
multiple displays. */
void
+#ifndef HAVE_PGTK
xg_display_open (char *display_name, Display **dpy)
+#else
+xg_display_open (char *display_name, GdkDisplay **dpy)
+#endif
{
GdkDisplay *gdpy;
unrequest_sigio (); /* See comment in x_display_ok, xterm.c. */
+#ifndef HAVE_PGTK
gdpy = gdk_display_open (display_name);
+#else
+ gdpy = gdk_display_open (strlen (display_name) == 0 ? NULL : display_name);
+#endif
request_sigio ();
if (!gdpy_def && gdpy)
{
@@ -162,7 +188,11 @@ xg_display_open (char *display_name, Display **dpy)
gdpy);
}
+#ifndef HAVE_PGTK
*dpy = gdpy ? GDK_DISPLAY_XDISPLAY (gdpy) : NULL;
+#else
+ *dpy = gdpy;
+#endif
}
/* Scaling/HiDPI functions. */
@@ -184,6 +214,9 @@ xg_get_gdk_scale (void)
int
xg_get_scale (struct frame *f)
{
+#ifdef HAVE_PGTK
+ return 1;
+#endif
#ifdef HAVE_GTK3
if (FRAME_GTK_WIDGET (f))
return gtk_widget_get_scale_factor (FRAME_GTK_WIDGET (f));
@@ -194,8 +227,13 @@ xg_get_scale (struct frame *f)
/* Close display DPY. */
void
+#ifndef HAVE_PGTK
xg_display_close (Display *dpy)
+#else
+xg_display_close (GdkDisplay *gdpy)
+#endif
{
+#ifndef HAVE_PGTK
GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (dpy);
/* If this is the default display, try to change it before closing.
@@ -219,6 +257,31 @@ xg_display_close (Display *dpy)
}
gdk_display_close (gdpy);
+
+#else
+
+ /* If this is the default display, try to change it before closing.
+ If there is no other display to use, gdpy_def is set to NULL, and
+ the next call to xg_display_open resets the default display. */
+ if (gdk_display_get_default () == gdpy)
+ {
+ struct pgtk_display_info *dpyinfo;
+ GdkDisplay *gdpy_new = NULL;
+
+ /* Find another display. */
+ for (dpyinfo = x_display_list; dpyinfo; dpyinfo = dpyinfo->next)
+ if (dpyinfo->gdpy != gdpy)
+ {
+ gdpy_new = dpyinfo->gdpy;
+ gdk_display_manager_set_default_display (gdk_display_manager_get (),
+ gdpy_new);
+ break;
+ }
+ gdpy_def = gdpy_new;
+ }
+
+ gdk_display_close (gdpy);
+#endif
}
@@ -230,12 +293,19 @@ xg_display_close (Display *dpy)
scroll bars on display DPY. */
GdkCursor *
+#ifndef HAVE_PGTK
xg_create_default_cursor (Display *dpy)
+#else
+xg_create_default_cursor (GdkDisplay *gdpy)
+#endif
{
+#ifndef HAVE_PGTK
GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (dpy);
+#endif
return gdk_cursor_new_for_display (gdpy, GDK_LEFT_PTR);
}
+#ifndef HAVE_PGTK
/* Apply GMASK to GPIX and return a GdkPixbuf with an alpha channel. */
static GdkPixbuf *
@@ -335,6 +405,8 @@ xg_get_pixbuf_from_surface (cairo_surface_t *surface)
}
#endif /* USE_CAIRO && !HAVE_GTK3 */
+#endif /* !HAVE_PGTK */
+
static Lisp_Object
file_for_image (Lisp_Object image)
{
@@ -605,8 +677,13 @@ xg_check_special_colors (struct frame *f,
block_input ();
{
#ifdef HAVE_GTK3
+#ifndef HAVE_PGTK
GtkStyleContext *gsty
= gtk_widget_get_style_context (FRAME_GTK_OUTER_WIDGET (f));
+#else
+ GtkStyleContext *gsty
+ = gtk_widget_get_style_context (FRAME_WIDGET (f));
+#endif
GdkRGBA col;
char buf[sizeof "rgb://rrrr/gggg/bbbb"];
int state = GTK_STATE_FLAG_SELECTED|GTK_STATE_FLAG_FOCUSED;
@@ -630,9 +707,14 @@ xg_check_special_colors (struct frame *f,
r = col.red * 65535,
g = col.green * 65535,
b = col.blue * 65535;
+#ifndef HAVE_PGTK
sprintf (buf, "rgb:%04x/%04x/%04x", r, g, b);
success_p = x_parse_color (f, buf, color) != 0;
#else
+ sprintf (buf, "#%04x%04x%04x", r, g, b);
+ success_p = pgtk_parse_color (f, buf, color) != 0;
+#endif
+#else
GtkStyle *gsty = gtk_widget_get_style (FRAME_GTK_WIDGET (f));
GdkColor *grgb = get_bg
? &gsty->bg[GTK_STATE_SELECTED]
@@ -655,6 +737,9 @@ xg_check_special_colors (struct frame *f,
/***********************************************************************
Tooltips
***********************************************************************/
+
+#ifndef HAVE_PGTK
+
/* Gtk+ calls this callback when the parent of our tooltip dummy changes.
We use that to pop down the tooltip. This happens if Gtk+ for some
reason wants to change or hide the tooltip. */
@@ -665,7 +750,7 @@ hierarchy_ch_cb (GtkWidget *widget,
gpointer user_data)
{
struct frame *f = user_data;
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
GtkWidget *top = gtk_widget_get_toplevel (x->ttip_lbl);
if (! top || ! GTK_IS_WINDOW (top))
@@ -687,7 +772,7 @@ qttip_cb (GtkWidget *widget,
gpointer user_data)
{
struct frame *f = user_data;
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
if (x->ttip_widget == NULL)
{
GtkWidget *p;
@@ -734,7 +819,7 @@ xg_prepare_tooltip (struct frame *f,
int *width,
int *height)
{
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
GtkWidget *widget;
GdkWindow *gwin;
GdkScreen *screen;
@@ -785,13 +870,19 @@ xg_prepare_tooltip (struct frame *f,
void
xg_show_tooltip (struct frame *f, int root_x, int root_y)
{
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
if (x->ttip_window)
{
block_input ();
+#ifndef HAVE_PGTK
gtk_window_move (x->ttip_window, root_x / xg_get_scale (f),
root_y / xg_get_scale (f));
gtk_widget_show (GTK_WIDGET (x->ttip_window));
+#else
+ gtk_widget_show (GTK_WIDGET (x->ttip_window));
+ gtk_window_move (x->ttip_window, root_x / xg_get_scale (f),
+ root_y / xg_get_scale (f));
+#endif
unblock_input ();
}
}
@@ -803,10 +894,9 @@ xg_show_tooltip (struct frame *f, int root_x, int root_y)
bool
xg_hide_tooltip (struct frame *f)
{
- if (f->output_data.x->ttip_window)
+ if (f->output_data.xp->ttip_window)
{
- GtkWindow *win = f->output_data.x->ttip_window;
-
+ GtkWindow *win = f->output_data.xp->ttip_window;
block_input ();
gtk_widget_hide (GTK_WIDGET (win));
@@ -824,6 +914,30 @@ xg_hide_tooltip (struct frame *f)
return FALSE;
}
+#else /* HAVE_PGTK */
+
+void
+xg_show_tooltip (struct frame *f,
+ Lisp_Object string)
+{
+ Lisp_Object encoded_string = ENCODE_UTF_8 (string);
+ gtk_widget_set_tooltip_text (FRAME_GTK_OUTER_WIDGET (f)
+ ? FRAME_GTK_OUTER_WIDGET (f)
+ : FRAME_GTK_WIDGET (f),
+ SSDATA (encoded_string));
+}
+
+bool
+xg_hide_tooltip (struct frame *f)
+{
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ gtk_widget_set_tooltip_text (FRAME_GTK_OUTER_WIDGET (f), NULL);
+ gtk_widget_set_tooltip_text (FRAME_GTK_WIDGET (f), NULL);
+ return TRUE;
+}
+
+#endif /* HAVE_PGTK */
+
/***********************************************************************
General functions for creating widgets, resizing, events, e.t.c.
@@ -839,6 +953,27 @@ my_log_handler (const gchar *log_domain, GLogLevelFlags log_level,
}
#endif
+#if defined HAVE_GTK3 && defined HAVE_XINPUT2
+bool
+xg_is_menu_window (Display *dpy, Window wdesc)
+{
+ GtkWidget *gwdesc = xg_win_to_widget (dpy, wdesc);
+
+ if (GTK_IS_WINDOW (gwdesc))
+ {
+ GtkWidget *fw = gtk_bin_get_child (GTK_BIN (gwdesc));
+ if (GTK_IS_MENU (fw))
+ {
+ GtkWidget *parent
+ = gtk_menu_shell_get_parent_shell (GTK_MENU_SHELL (fw));
+ return GTK_IS_MENU_BAR (parent);
+ }
+ }
+
+ return false;
+}
+#endif
+
/* Make a geometry string and pass that to GTK. It seems this is the
only way to get geometry position right if the user explicitly
asked for a position when starting Emacs.
@@ -954,8 +1089,23 @@ xg_frame_set_char_size (struct frame *f, int width, int height)
bool was_visible = false;
bool hide_child_frame;
+#ifndef HAVE_PGTK
gtk_window_get_size (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
&gwidth, &gheight);
+#else
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ gtk_window_get_size (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ &gwidth, &gheight);
+ }
+ else
+ {
+ GtkAllocation alloc;
+ gtk_widget_get_allocation (FRAME_GTK_WIDGET (f), &alloc);
+ gwidth = alloc.width;
+ gheight = alloc.height;
+ }
+#endif
/* Do this before resize, as we don't know yet if we will be resized. */
FRAME_RIF (f)->clear_under_internal_border (f);
@@ -975,11 +1125,37 @@ xg_frame_set_char_size (struct frame *f, int width, int height)
remain unchanged but giving the frame back its normal size will
be broken ... */
if (EQ (fullscreen, Qfullwidth) && width == FRAME_PIXEL_WIDTH (f))
+#ifndef HAVE_PGTK
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
gwidth, outer_height);
+#else
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ gwidth, outer_height);
+ }
+ else
+ {
+ gtk_widget_set_size_request (FRAME_GTK_WIDGET (f),
+ gwidth, outer_height);
+ }
+#endif
else if (EQ (fullscreen, Qfullheight) && height == FRAME_PIXEL_HEIGHT (f))
+#ifndef HAVE_PGTK
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
outer_width, gheight);
+#else
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ outer_width, gheight);
+ }
+ else
+ {
+ gtk_widget_set_size_request (FRAME_GTK_WIDGET (f),
+ outer_width, gheight);
+ }
+#endif
else if (FRAME_PARENT_FRAME (f) && FRAME_VISIBLE_P (f))
{
was_visible = true;
@@ -990,17 +1166,38 @@ xg_frame_set_char_size (struct frame *f, int width, int height)
if (hide_child_frame)
{
block_input ();
+#ifndef HAVE_PGTK
gtk_widget_hide (FRAME_GTK_OUTER_WIDGET (f));
+#else
+ gtk_widget_hide (FRAME_WIDGET (f));
+#endif
unblock_input ();
}
+#ifndef HAVE_PGTK
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
outer_width, outer_height);
+#else
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ outer_width, outer_height);
+ }
+ else
+ {
+ gtk_widget_set_size_request (FRAME_GTK_WIDGET (f),
+ outer_width, outer_height);
+ }
+#endif
if (hide_child_frame)
{
block_input ();
+#ifndef HAVE_PGTK
gtk_widget_show_all (FRAME_GTK_OUTER_WIDGET (f));
+#else
+ gtk_widget_show_all (FRAME_WIDGET (f));
+#endif
unblock_input ();
}
@@ -1009,8 +1206,21 @@ xg_frame_set_char_size (struct frame *f, int width, int height)
}
else
{
+#ifndef HAVE_PGTK
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
outer_width, outer_height);
+#else
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ outer_width, outer_height);
+ }
+ else
+ {
+ gtk_widget_set_size_request (FRAME_GTK_WIDGET (f),
+ outer_width, outer_height);
+ }
+#endif
fullscreen = Qnil;
}
@@ -1035,7 +1245,9 @@ xg_frame_set_char_size (struct frame *f, int width, int height)
/* Must call this to flush out events */
(void)gtk_events_pending ();
gdk_flush ();
+#ifndef HAVE_PGTK
x_wait_for_event (f, ConfigureNotify);
+#endif
if (!NILP (fullscreen))
/* Try to restore fullscreen state. */
@@ -1068,11 +1280,12 @@ xg_height_or_width_changed (struct frame *f)
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
FRAME_TOTAL_PIXEL_WIDTH (f),
FRAME_TOTAL_PIXEL_HEIGHT (f));
- f->output_data.x->hint_flags = 0;
+ f->output_data.xp->hint_flags = 0;
x_wm_set_size_hint (f, 0, 0);
}
#endif
+#ifndef HAVE_PGTK
/* Convert an X Window WSESC on display DPY to its corresponding GtkWidget.
Must be done like this, because GtkWidget:s can have "hidden"
X Window that aren't accessible.
@@ -1100,6 +1313,7 @@ xg_win_to_widget (Display *dpy, Window wdesc)
unblock_input ();
return gwdesc;
}
+#endif
/* Set the background of widget W to PIXEL. */
@@ -1107,9 +1321,18 @@ static void
xg_set_widget_bg (struct frame *f, GtkWidget *w, unsigned long pixel)
{
#ifdef HAVE_GTK3
- XColor xbg;
+ Emacs_Color xbg;
xbg.pixel = pixel;
+#ifndef HAVE_PGTK
if (XQueryColor (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), &xbg))
+#else
+ xbg.red = (pixel >> 16) & 0xff;
+ xbg.green = (pixel >> 8) & 0xff;
+ xbg.blue = (pixel >> 0) & 0xff;
+ xbg.red |= xbg.red << 8;
+ xbg.green |= xbg.green << 8;
+ xbg.blue |= xbg.blue << 8;
+#endif
{
const char format[] = "* { background-color: #%02x%02x%02x; }";
/* The format is always longer than the resulting string. */
@@ -1144,7 +1367,16 @@ style_changed_cb (GObject *go,
struct input_event event;
GdkDisplay *gdpy = user_data;
const char *display_name = gdk_display_get_name (gdpy);
+#ifndef HAVE_PGTK
Display *dpy = GDK_DISPLAY_XDISPLAY (gdpy);
+#else
+ GdkDisplay *dpy = gdpy;
+#endif
+
+#ifndef HAVE_PGTK
+ if (display_name == NULL)
+ display_name = "";
+#endif
EVENT_INIT (event);
event.kind = CONFIG_CHANGED_EVENT;
@@ -1165,7 +1397,11 @@ style_changed_cb (GObject *go,
{
struct frame *f = XFRAME (frame);
if (FRAME_LIVE_P (f)
+#ifndef HAVE_PGTK
&& FRAME_X_P (f)
+#else
+ && FRAME_PGTK_P (f)
+#endif
&& FRAME_X_DISPLAY (f) == dpy)
{
FRAME_TERMINAL (f)->set_scroll_bar_default_width_hook (f);
@@ -1179,6 +1415,7 @@ style_changed_cb (GObject *go,
/* Called when a delete-event occurs on WIDGET. */
+#ifndef HAVE_PGTK
static gboolean
delete_cb (GtkWidget *widget,
GdkEvent *event,
@@ -1186,6 +1423,7 @@ delete_cb (GtkWidget *widget,
{
return TRUE;
}
+#endif
/* Create and set up the GTK widgets for frame F.
Return true if creation succeeded. */
@@ -1199,17 +1437,27 @@ xg_create_frame_widgets (struct frame *f)
#ifndef HAVE_GTK3
GtkRcStyle *style;
#endif
+ GtkWindowType type = GTK_WINDOW_TOPLEVEL;
char *title = 0;
block_input ();
+#ifndef HAVE_PGTK /* gtk_plug not found. */
if (FRAME_X_EMBEDDED_P (f))
{
GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f));
- wtop = gtk_plug_new_for_display (gdpy, f->output_data.x->parent_desc);
+ wtop = gtk_plug_new_for_display (gdpy, f->output_data.xp->parent_desc);
}
else
- wtop = gtk_window_new (GTK_WINDOW_TOPLEVEL);
+ wtop = gtk_window_new (type);
+#else
+ if (f->tooltip)
+ {
+ type = GTK_WINDOW_POPUP;
+ }
+ wtop = gtk_window_new (type);
+ gtk_widget_add_events (wtop, GDK_ALL_EVENTS_MASK);
+#endif
/* gtk_window_set_has_resize_grip is a Gtk+ 3.0 function but Ubuntu
has backported it to Gtk+ 2.0 and they add the resize grip for
@@ -1266,8 +1514,8 @@ xg_create_frame_widgets (struct frame *f)
FRAME_GTK_OUTER_WIDGET (f) = wtop;
FRAME_GTK_WIDGET (f) = wfixed;
- f->output_data.x->vbox_widget = wvbox;
- f->output_data.x->hbox_widget = whbox;
+ f->output_data.xp->vbox_widget = wvbox;
+ f->output_data.xp->hbox_widget = whbox;
gtk_widget_set_has_window (wfixed, TRUE);
@@ -1286,7 +1534,10 @@ xg_create_frame_widgets (struct frame *f)
FIXME: gtk_widget_set_double_buffered is deprecated and might stop
working in the future. We need to migrate away from combining
X and GTK+ drawing to a pure GTK+ build. */
+
+#ifndef HAVE_PGTK
gtk_widget_set_double_buffered (wfixed, FALSE);
+#endif
#if ! GTK_CHECK_VERSION (3, 22, 0)
gtk_window_set_wmclass (GTK_WINDOW (wtop),
@@ -1294,10 +1545,12 @@ xg_create_frame_widgets (struct frame *f)
SSDATA (Vx_resource_class));
#endif
+#ifndef HAVE_PGTK
/* Add callback to do nothing on WM_DELETE_WINDOW. The default in
GTK is to destroy the widget. We want Emacs to do that instead. */
g_signal_connect (G_OBJECT (wtop), "delete-event",
G_CALLBACK (delete_cb), f);
+#endif
/* Convert our geometry parameters into a geometry string
and specify it.
@@ -1308,7 +1561,9 @@ xg_create_frame_widgets (struct frame *f)
gtk_widget_add_events (wfixed,
GDK_POINTER_MOTION_MASK
+#ifndef HAVE_PGTK
| GDK_EXPOSURE_MASK
+#endif
| GDK_BUTTON_PRESS_MASK
| GDK_BUTTON_RELEASE_MASK
| GDK_KEY_PRESS_MASK
@@ -1316,13 +1571,19 @@ xg_create_frame_widgets (struct frame *f)
| GDK_LEAVE_NOTIFY_MASK
| GDK_FOCUS_CHANGE_MASK
| GDK_STRUCTURE_MASK
+#ifdef HAVE_PGTK
+ | GDK_SCROLL_MASK
+ | GDK_SMOOTH_SCROLL_MASK
+#endif
| GDK_VISIBILITY_NOTIFY_MASK);
+#ifndef HAVE_PGTK
/* Must realize the windows so the X window gets created. It is used
by callers of this function. */
gtk_widget_realize (wfixed);
FRAME_X_WINDOW (f) = GTK_WIDGET_TO_X_WIN (wfixed);
initial_set_up_x_back_buffer (f);
+#endif
/* Since GTK clears its window by filling with the background color,
we must keep X and GTK background in sync. */
@@ -1339,6 +1600,9 @@ xg_create_frame_widgets (struct frame *f)
gtk_widget_modify_style (wfixed, style);
#else
gtk_widget_set_can_focus (wfixed, TRUE);
+#ifdef HAVE_PGTK
+ gtk_widget_grab_focus (wfixed);
+#endif
gtk_window_set_resizable (GTK_WINDOW (wtop), TRUE);
#endif
@@ -1351,11 +1615,13 @@ xg_create_frame_widgets (struct frame *f)
}
/* Steal a tool tip window we can move ourselves. */
- f->output_data.x->ttip_widget = 0;
- f->output_data.x->ttip_lbl = 0;
- f->output_data.x->ttip_window = 0;
+ f->output_data.xp->ttip_widget = 0;
+ f->output_data.xp->ttip_lbl = 0;
+ f->output_data.xp->ttip_window = 0;
+#ifndef HAVE_PGTK
gtk_widget_set_tooltip_text (wtop, "Dummy text");
g_signal_connect (wtop, "query-tooltip", G_CALLBACK (qttip_cb), f);
+#endif
{
GdkScreen *screen = gtk_widget_get_screen (wtop);
@@ -1378,12 +1644,114 @@ xg_create_frame_widgets (struct frame *f)
return 1;
}
+#ifdef HAVE_PGTK
+void
+xg_create_frame_outer_widgets (struct frame *f)
+{
+ GtkWidget *wtop;
+ GtkWidget *wvbox, *whbox;
+ GtkWindowType type = GTK_WINDOW_TOPLEVEL;
+ char *title = 0;
+
+ block_input ();
+
+ wtop = gtk_window_new (type);
+ gtk_widget_add_events (wtop, GDK_ALL_EVENTS_MASK);
+
+ xg_set_screen (wtop, f);
+
+ wvbox = gtk_box_new (GTK_ORIENTATION_VERTICAL, 0);
+ whbox = gtk_box_new (GTK_ORIENTATION_HORIZONTAL, 0);
+ gtk_box_set_homogeneous (GTK_BOX (wvbox), FALSE);
+ gtk_box_set_homogeneous (GTK_BOX (whbox), FALSE);
+
+ /* Use same names as the Xt port does. I.e. Emacs.pane.emacs by default */
+ gtk_widget_set_name (wtop, EMACS_CLASS);
+ gtk_widget_set_name (wvbox, "pane");
+
+ /* If this frame has a title or name, set it in the title bar. */
+ if (! NILP (f->title))
+ title = SSDATA (ENCODE_UTF_8 (f->title));
+ else if (! NILP (f->name))
+ title = SSDATA (ENCODE_UTF_8 (f->name));
+
+ if (title)
+ gtk_window_set_title (GTK_WINDOW (wtop), title);
+
+ if (FRAME_UNDECORATED (f))
+ {
+ gtk_window_set_decorated (GTK_WINDOW (wtop), FALSE);
+ store_frame_param (f, Qundecorated, Qt);
+ }
+
+ FRAME_GTK_OUTER_WIDGET (f) = wtop;
+ f->output_data.xp->vbox_widget = wvbox;
+ f->output_data.xp->hbox_widget = whbox;
+
+ gtk_container_add (GTK_CONTAINER (wtop), wvbox);
+ gtk_box_pack_start (GTK_BOX (wvbox), whbox, TRUE, TRUE, 0);
+
+ if (FRAME_EXTERNAL_TOOL_BAR (f))
+ update_frame_tool_bar (f);
+
+#if ! GTK_CHECK_VERSION (3, 22, 0)
+ gtk_window_set_wmclass (GTK_WINDOW (wtop),
+ SSDATA (Vx_resource_name),
+ SSDATA (Vx_resource_class));
+#endif
+
+ /* Convert our geometry parameters into a geometry string
+ and specify it.
+ GTK will itself handle calculating the real position this way. */
+ xg_set_geometry (f);
+ f->win_gravity
+ = gtk_window_get_gravity (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)));
+
+ gtk_window_set_resizable (GTK_WINDOW (wtop), TRUE);
+
+ if (FRAME_OVERRIDE_REDIRECT (f))
+ {
+ GdkWindow *gwin = gtk_widget_get_window (wtop);
+
+ if (gwin)
+ gdk_window_set_override_redirect (gwin, TRUE);
+ }
+
+ /* Steal a tool tip window we can move ourselves. */
+ f->output_data.xp->ttip_widget = 0;
+ f->output_data.xp->ttip_lbl = 0;
+ f->output_data.xp->ttip_window = 0;
+#ifndef HAVE_PGTK
+ gtk_widget_set_tooltip_text (wtop, "Dummy text");
+ g_signal_connect (wtop, "query-tooltip", G_CALLBACK (qttip_cb), f);
+#endif
+
+ {
+ GdkScreen *screen = gtk_widget_get_screen (wtop);
+ GtkSettings *gs = gtk_settings_get_for_screen (screen);
+ /* Only connect this signal once per screen. */
+ if (! g_signal_handler_find (G_OBJECT (gs),
+ G_SIGNAL_MATCH_FUNC,
+ 0, 0, 0,
+ (gpointer) G_CALLBACK (style_changed_cb),
+ 0))
+ {
+ g_signal_connect (G_OBJECT (gs), "notify::gtk-theme-name",
+ G_CALLBACK (style_changed_cb),
+ gdk_screen_get_display (screen));
+ }
+ }
+
+ unblock_input ();
+}
+#endif
+
void
xg_free_frame_widgets (struct frame *f)
{
if (FRAME_GTK_OUTER_WIDGET (f))
{
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
struct xg_frame_tb_info *tbinfo
= g_object_get_data (G_OBJECT (FRAME_GTK_OUTER_WIDGET (f)),
TB_INFO_KEY);
@@ -1391,10 +1759,14 @@ xg_free_frame_widgets (struct frame *f)
xfree (tbinfo);
/* x_free_frame_resources should have taken care of it */
+#ifndef HAVE_PGTK
eassert (!FRAME_X_DOUBLE_BUFFERED_P (f));
+#endif
gtk_widget_destroy (FRAME_GTK_OUTER_WIDGET (f));
FRAME_X_WINDOW (f) = 0; /* Set to avoid XDestroyWindow in xterm.c */
+#ifndef HAVE_PGTK
FRAME_X_RAW_DRAWABLE (f) = 0;
+#endif
FRAME_GTK_OUTER_WIDGET (f) = 0;
if (x->ttip_widget)
{
@@ -1436,9 +1808,12 @@ x_wm_set_size_hint (struct frame *f, long int flags, bool user_position)
XSETFRAME (frame, f);
fs_state = Fframe_parameter (frame, Qfullscreen);
- if ((EQ (fs_state, Qmaximized) || EQ (fs_state, Qfullboth)) &&
- (x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_wm_state) ||
- x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_wm_state_fullscreen)))
+ if ((EQ (fs_state, Qmaximized) || EQ (fs_state, Qfullboth))
+#ifndef HAVE_PGTK
+ && (x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_wm_state) ||
+ x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_wm_state_fullscreen))
+#endif
+ )
{
/* Don't set hints when maximized or fullscreen. Apparently KWin and
Gtk3 don't get along and the frame shrinks (!).
@@ -1449,14 +1824,14 @@ x_wm_set_size_hint (struct frame *f, long int flags, bool user_position)
if (flags)
{
memset (&size_hints, 0, sizeof (size_hints));
- f->output_data.x->size_hints = size_hints;
- f->output_data.x->hint_flags = hint_flags;
+ f->output_data.xp->size_hints = size_hints;
+ f->output_data.xp->hint_flags = hint_flags;
}
else
flags = f->size_hint_flags;
- size_hints = f->output_data.x->size_hints;
- hint_flags = f->output_data.x->hint_flags;
+ size_hints = f->output_data.xp->size_hints;
+ hint_flags = f->output_data.xp->hint_flags;
hint_flags |= GDK_HINT_RESIZE_INC | GDK_HINT_MIN_SIZE;
size_hints.width_inc = frame_resize_pixelwise ? 1 : FRAME_COLUMN_WIDTH (f);
@@ -1518,16 +1893,16 @@ x_wm_set_size_hint (struct frame *f, long int flags, bool user_position)
size_hints.width_inc /= scale;
size_hints.height_inc /= scale;
- if (hint_flags != f->output_data.x->hint_flags
+ if (hint_flags != f->output_data.xp->hint_flags
|| memcmp (&size_hints,
- &f->output_data.x->size_hints,
+ &f->output_data.xp->size_hints,
sizeof (size_hints)) != 0)
{
block_input ();
gtk_window_set_geometry_hints (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
NULL, &size_hints, hint_flags);
- f->output_data.x->size_hints = size_hints;
- f->output_data.x->hint_flags = hint_flags;
+ f->output_data.xp->size_hints = size_hints;
+ f->output_data.xp->hint_flags = hint_flags;
unblock_input ();
}
}
@@ -1567,6 +1942,10 @@ xg_set_background_color (struct frame *f, unsigned long bg)
void
xg_set_undecorated (struct frame *f, Lisp_Object undecorated)
{
+#ifdef HAVE_PGTK
+ if (!FRAME_GTK_OUTER_WIDGET (f))
+ return;
+#endif
if (FRAME_GTK_WIDGET (f))
{
block_input ();
@@ -1593,7 +1972,11 @@ xg_frame_restack (struct frame *f1, struct frame *f2, bool above_flag)
XSETFRAME (frame2, f2);
gdk_window_restack (gwin1, gwin2, above_flag);
+#ifndef HAVE_PGTK
x_sync (f1);
+#else
+ gdk_flush ();
+#endif
}
unblock_input ();
}
@@ -1604,10 +1987,17 @@ void
xg_set_skip_taskbar (struct frame *f, Lisp_Object skip_taskbar)
{
block_input ();
+#ifndef HAVE_PGTK
if (FRAME_GTK_WIDGET (f))
gdk_window_set_skip_taskbar_hint
(gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (f)),
NILP (skip_taskbar) ? FALSE : TRUE);
+#else
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ gdk_window_set_skip_taskbar_hint
+ (gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (f)),
+ NILP (skip_taskbar) ? FALSE : TRUE);
+#endif
unblock_input ();
}
@@ -1616,6 +2006,10 @@ xg_set_skip_taskbar (struct frame *f, Lisp_Object skip_taskbar)
void
xg_set_no_focus_on_map (struct frame *f, Lisp_Object no_focus_on_map)
{
+#ifdef HAVE_PGTK
+ if (!FRAME_GTK_OUTER_WIDGET (f))
+ return;
+#endif
block_input ();
if (FRAME_GTK_WIDGET (f))
{
@@ -1631,12 +2025,19 @@ xg_set_no_focus_on_map (struct frame *f, Lisp_Object no_focus_on_map)
void
xg_set_no_accept_focus (struct frame *f, Lisp_Object no_accept_focus)
{
+ gboolean g_no_accept_focus = NILP (no_accept_focus) ? TRUE : FALSE;
+#ifdef HAVE_PGTK
+ if (!FRAME_GTK_OUTER_WIDGET (f))
+ {
+ if (FRAME_WIDGET (f))
+ gtk_widget_set_can_focus (FRAME_WIDGET (f), g_no_accept_focus);
+ return;
+ }
+#endif
block_input ();
if (FRAME_GTK_WIDGET (f))
{
GtkWindow *gwin = GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f));
- gboolean g_no_accept_focus = NILP (no_accept_focus) ? TRUE : FALSE;
-
gtk_window_set_accept_focus (gwin, g_no_accept_focus);
}
unblock_input ();
@@ -1657,18 +2058,24 @@ xg_set_override_redirect (struct frame *f, Lisp_Object override_redirect)
unblock_input ();
}
+#ifndef HAVE_PGTK
/* Set the frame icon to ICON_PIXMAP/MASK. This must be done with GTK
functions so GTK does not overwrite the icon. */
void
xg_set_frame_icon (struct frame *f, Pixmap icon_pixmap, Pixmap icon_mask)
{
+#ifdef HAVE_PGTK
+ if (!FRAME_GTK_OUTER_WIDGET (f))
+ return;
+#endif
GdkPixbuf *gp = xg_get_pixbuf_from_pix_and_mask (f,
icon_pixmap,
icon_mask);
if (gp)
gtk_window_set_icon (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), gp);
}
+#endif
@@ -2205,6 +2612,11 @@ xg_get_file_name (struct frame *f,
int filesel_done = 0;
xg_get_file_func func;
+#ifdef HAVE_PGTK
+ if (!FRAME_GTK_OUTER_WIDGET (f))
+ error ("Can't open dialog from child frames");
+#endif
+
#ifdef HAVE_GTK_FILE_SELECTION_NEW
if (xg_uses_old_file_dialog ())
@@ -2237,20 +2649,34 @@ xg_get_file_name (struct frame *f,
#ifdef HAVE_GTK3
-#define XG_WEIGHT_TO_SYMBOL(w) \
- (w <= PANGO_WEIGHT_THIN ? Qextra_light \
- : w <= PANGO_WEIGHT_ULTRALIGHT ? Qlight \
- : w <= PANGO_WEIGHT_LIGHT ? Qsemi_light \
- : w < PANGO_WEIGHT_MEDIUM ? Qnormal \
- : w <= PANGO_WEIGHT_SEMIBOLD ? Qsemi_bold \
- : w <= PANGO_WEIGHT_BOLD ? Qbold \
- : w <= PANGO_WEIGHT_HEAVY ? Qextra_bold \
- : Qultra_bold)
-
-#define XG_STYLE_TO_SYMBOL(s) \
- (s == PANGO_STYLE_OBLIQUE ? Qoblique \
- : s == PANGO_STYLE_ITALIC ? Qitalic \
- : Qnormal)
+static
+Lisp_Object xg_weight_to_symbol (PangoWeight w)
+{
+ return
+ (w <= PANGO_WEIGHT_THIN ? Qthin /* 100 */
+ : w <= PANGO_WEIGHT_ULTRALIGHT ? Qultra_light /* 200 */
+ : w <= PANGO_WEIGHT_LIGHT ? Qlight /* 300 */
+#if PANGO_VERSION_CHECK(1, 36, 7)
+ : w <= PANGO_WEIGHT_SEMILIGHT ? Qsemi_light /* 350 */
+#endif
+ : w <= PANGO_WEIGHT_BOOK ? Qbook /* 380 */
+ : w <= PANGO_WEIGHT_NORMAL ? Qnormal /* 400 */
+ : w <= PANGO_WEIGHT_MEDIUM ? Qmedium /* 500 */
+ : w <= PANGO_WEIGHT_SEMIBOLD ? Qsemi_bold /* 600 */
+ : w <= PANGO_WEIGHT_BOLD ? Qbold /* 700 */
+ : w <= PANGO_WEIGHT_ULTRABOLD ? Qultra_bold /* 800 */
+ : w <= PANGO_WEIGHT_HEAVY ? Qblack /* 900 */
+ : Qultra_heavy); /* 1000 */
+}
+
+static
+Lisp_Object xg_style_to_symbol (PangoStyle s)
+{
+ return
+ (s == PANGO_STYLE_OBLIQUE ? Qoblique
+ : s == PANGO_STYLE_ITALIC ? Qitalic
+ : Qnormal);
+}
#endif /* HAVE_GTK3 */
@@ -2288,6 +2714,11 @@ xg_get_font (struct frame *f, const char *default_name)
int done = 0;
Lisp_Object font = Qnil;
+#ifdef HAVE_PGTK
+ if (!FRAME_GTK_OUTER_WIDGET (f))
+ error ("Can't open dialog from child frames");
+#endif
+
w = gtk_font_chooser_dialog_new
("Pick a font", GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)));
@@ -2341,8 +2772,8 @@ xg_get_font (struct frame *f, const char *default_name)
font = CALLN (Ffont_spec,
QCfamily, build_string (family),
QCsize, make_float (pango_units_to_double (size)),
- QCweight, XG_WEIGHT_TO_SYMBOL (weight),
- QCslant, XG_STYLE_TO_SYMBOL (style));
+ QCweight, xg_weight_to_symbol (weight),
+ QCslant, xg_style_to_symbol (style));
char *font_desc_str = pango_font_description_to_string (desc);
dupstring (&x_last_font_name, font_desc_str);
@@ -2485,7 +2916,7 @@ xg_mark_data (void)
{
struct frame *f = XFRAME (frame);
- if (FRAME_X_P (f) && FRAME_GTK_OUTER_WIDGET (f))
+ if ((FRAME_X_P (f) || FRAME_PGTK_P (f)) && FRAME_GTK_OUTER_WIDGET (f))
{
struct xg_frame_tb_info *tbinfo
= g_object_get_data (G_OBJECT (FRAME_GTK_OUTER_WIDGET (f)),
@@ -2649,6 +3080,11 @@ make_menu_item (const char *utf8_label,
if (wtoadd) gtk_container_add (GTK_CONTAINER (w), wtoadd);
if (! item->enabled) gtk_widget_set_sensitive (w, FALSE);
+#ifdef HAVE_PGTK
+ if (!NILP (item->help))
+ gtk_widget_set_tooltip_text (w, SSDATA (item->help));
+#endif
+
return w;
}
@@ -2715,6 +3151,20 @@ xg_create_one_menuitem (widget_value *item,
return w;
}
+#ifdef HAVE_PGTK
+static gboolean
+menu_bar_button_pressed_cb (GtkWidget *widget, GdkEvent *event,
+ gpointer user_data)
+{
+ struct frame *f = user_data;
+
+ if (event->button.button < 4)
+ set_frame_menubar (f, true);
+
+ return false;
+}
+#endif
+
/* Create a full menu tree specified by DATA.
F is the frame the created menu belongs to.
SELECT_CB is the callback to use when a menu item is selected.
@@ -2772,6 +3222,10 @@ create_menus (widget_value *data,
else
{
wmenu = gtk_menu_bar_new ();
+#ifdef HAVE_PGTK
+ g_signal_connect (G_OBJECT (wmenu), "button-press-event",
+ G_CALLBACK (menu_bar_button_pressed_cb), f);
+#endif
/* Set width of menu bar to a small value so it doesn't enlarge
a small initial frame size. The width will be set to the
width of the frame later on when it is added to a container.
@@ -2788,9 +3242,15 @@ create_menus (widget_value *data,
if (name)
gtk_widget_set_name (wmenu, name);
+#ifndef HAVE_PGTK
if (deactivate_cb)
g_signal_connect (G_OBJECT (wmenu),
"selection-done", deactivate_cb, 0);
+#else
+ if (deactivate_cb)
+ g_signal_connect (G_OBJECT (wmenu),
+ "deactivate", deactivate_cb, 0);
+#endif
}
for (item = data; item; item = item->next)
@@ -3512,7 +3972,7 @@ menubar_map_cb (GtkWidget *w, gpointer user_data)
void
xg_update_frame_menubar (struct frame *f)
{
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
GtkRequisition req;
if (!x->menubar_widget || gtk_widget_get_mapped (x->menubar_widget))
@@ -3545,7 +4005,7 @@ xg_update_frame_menubar (struct frame *f)
void
free_frame_menubar (struct frame *f)
{
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
if (x->menubar_widget)
{
@@ -3561,6 +4021,7 @@ free_frame_menubar (struct frame *f)
}
}
+#ifndef HAVE_PGTK
bool
xg_event_is_for_menubar (struct frame *f, const XEvent *event)
{
@@ -3575,6 +4036,18 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event)
if (! x->menubar_widget) return 0;
+#ifdef HAVE_XINPUT2
+ XIDeviceEvent *xev = (XIDeviceEvent *) event->xcookie.data;
+ if (event->type == GenericEvent) /* XI_ButtonPress or XI_ButtonRelease */
+ {
+ if (! (xev->event_x >= 0
+ && xev->event_x < FRAME_PIXEL_WIDTH (f)
+ && xev->event_y >= 0
+ && xev->event_y < FRAME_MENUBAR_HEIGHT (f)))
+ return 0;
+ }
+ else
+#endif
if (! (event->xbutton.x >= 0
&& event->xbutton.x < FRAME_PIXEL_WIDTH (f)
&& event->xbutton.y >= 0
@@ -3583,7 +4056,12 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event)
return 0;
gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f));
- gw = gdk_x11_window_lookup_for_display (gdpy, event->xbutton.window);
+#ifdef HAVE_XINPUT2
+ if (event->type == GenericEvent)
+ gw = gdk_x11_window_lookup_for_display (gdpy, xev->event);
+ else
+#endif
+ gw = gdk_x11_window_lookup_for_display (gdpy, event->xbutton.window);
if (! gw) return 0;
gevent.any.window = gw;
gevent.any.type = GDK_NOTHING;
@@ -3611,6 +4089,7 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event)
g_list_free (list);
return iter != 0;
}
+#endif
@@ -3766,6 +4245,7 @@ xg_get_default_scrollbar_height (struct frame *f)
return scroll_bar_width_for_theme * xg_get_scale (f);
}
+#ifndef HAVE_PGTK
/* Return the scrollbar id for X Window WID on display DPY.
Return -1 if WID not in id_to_widget. */
@@ -3786,6 +4266,7 @@ xg_get_scroll_id_for_window (Display *dpy, Window wid)
return -1;
}
+#endif
/* Callback invoked when scroll bar WIDGET is destroyed.
DATA is the index into id_to_widget for WIDGET.
@@ -3835,7 +4316,7 @@ xg_finish_scroll_bar_creation (struct frame *f,
also, which causes flicker. Put an event box between the edit widget
and the scroll bar, so the scroll bar instead draws itself on the
event box window. */
- gtk_fixed_put (GTK_FIXED (f->output_data.x->edit_widget), webox, -1, -1);
+ gtk_fixed_put (GTK_FIXED (f->output_data.xp->edit_widget), webox, -1, -1);
gtk_container_add (GTK_CONTAINER (webox), wscroll);
xg_set_widget_bg (f, webox, FRAME_BACKGROUND_PIXEL (f));
@@ -3845,11 +4326,28 @@ xg_finish_scroll_bar_creation (struct frame *f,
real X window, it and its scroll-bar child try to draw on the
Emacs main window, which we draw over using Xlib. */
gtk_widget_realize (webox);
+#ifdef HAVE_PGTK
+ gtk_widget_show_all (webox);
+#endif
+#ifndef HAVE_PGTK
GTK_WIDGET_TO_X_WIN (webox);
+#endif
/* Set the cursor to an arrow. */
xg_set_cursor (webox, FRAME_DISPLAY_INFO (f)->xg_cursor);
+#ifdef HAVE_PGTK
+ GtkStyleContext *ctxt = gtk_widget_get_style_context (wscroll);
+ gtk_style_context_add_provider (ctxt,
+ GTK_STYLE_PROVIDER (FRAME_OUTPUT_DATA (f)->
+ scrollbar_foreground_css_provider),
+ GTK_STYLE_PROVIDER_PRIORITY_USER);
+ gtk_style_context_add_provider (ctxt,
+ GTK_STYLE_PROVIDER (FRAME_OUTPUT_DATA (f)->
+ scrollbar_background_css_provider),
+ GTK_STYLE_PROVIDER_PRIORITY_USER);
+#endif
+
bar->x_window = scroll_id;
}
@@ -3950,7 +4448,7 @@ xg_update_scrollbar_pos (struct frame *f,
GtkWidget *wscroll = xg_get_widget_from_map (scrollbar_id);
if (wscroll)
{
- GtkWidget *wfixed = f->output_data.x->edit_widget;
+ GtkWidget *wfixed = f->output_data.xp->edit_widget;
GtkWidget *wparent = gtk_widget_get_parent (wscroll);
gint msl;
int scale = xg_get_scale (f);
@@ -3990,7 +4488,11 @@ xg_update_scrollbar_pos (struct frame *f,
/* Clear under old scroll bar position. */
oldw += (scale - 1) * oldw;
oldx -= (scale - 1) * oldw;
+#ifndef HAVE_PGTK
x_clear_area (f, oldx, oldy, oldw, oldh);
+#else
+ pgtk_clear_area (f, oldx, oldy, oldw, oldh);
+#endif
}
if (!hidden)
@@ -3998,15 +4500,23 @@ xg_update_scrollbar_pos (struct frame *f,
GtkWidget *scrollbar = xg_get_widget_from_map (scrollbar_id);
GtkWidget *webox = gtk_widget_get_parent (scrollbar);
+#ifndef HAVE_PGTK
/* Don't obscure any child frames. */
XLowerWindow (FRAME_X_DISPLAY (f), GTK_WIDGET_TO_X_WIN (webox));
+#else
+ gdk_window_lower (gtk_widget_get_window (webox));
+#endif
}
/* GTK does not redraw until the main loop is entered again, but
if there are no X events pending we will not enter it. So we sync
here to get some events. */
+#ifndef HAVE_PGTK
x_sync (f);
+#else
+ gdk_flush ();
+#endif
SET_FRAME_GARBAGED (f);
cancel_mouse_face (f);
}
@@ -4031,7 +4541,7 @@ xg_update_horizontal_scrollbar_pos (struct frame *f,
if (wscroll)
{
- GtkWidget *wfixed = f->output_data.x->edit_widget;
+ GtkWidget *wfixed = f->output_data.xp->edit_widget;
GtkWidget *wparent = gtk_widget_get_parent (wscroll);
gint msl;
int scale = xg_get_scale (f);
@@ -4067,7 +4577,11 @@ xg_update_horizontal_scrollbar_pos (struct frame *f,
}
if (oldx != -1 && oldw > 0 && oldh > 0)
/* Clear under old scroll bar position. */
+#ifndef HAVE_PGTK
x_clear_area (f, oldx, oldy, oldw, oldh);
+#else
+ pgtk_clear_area (f, oldx, oldy, oldw, oldh);
+#endif
/* GTK does not redraw until the main loop is entered again, but
if there are no X events pending we will not enter it. So we sync
@@ -4078,11 +4592,19 @@ xg_update_horizontal_scrollbar_pos (struct frame *f,
xg_get_widget_from_map (scrollbar_id);
GtkWidget *webox = gtk_widget_get_parent (scrollbar);
+#ifndef HAVE_PGTK
/* Don't obscure any child frames. */
XLowerWindow (FRAME_X_DISPLAY (f), GTK_WIDGET_TO_X_WIN (webox));
+#else
+ gdk_window_lower (gtk_widget_get_window (webox));
+#endif
}
+#ifndef HAVE_PGTK
x_sync (f);
+#else
+ gdk_flush ();
+#endif
SET_FRAME_GARBAGED (f);
cancel_mouse_face (f);
}
@@ -4226,14 +4748,37 @@ xg_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar,
frame. This function does additional checks. */
bool
-xg_event_is_for_scrollbar (struct frame *f, const XEvent *event)
+xg_event_is_for_scrollbar (struct frame *f, const EVENT *event)
{
bool retval = 0;
- if (f && event->type == ButtonPress && event->xbutton.button < 4)
+#ifdef HAVE_XINPUT2
+ XIDeviceEvent *xev = (XIDeviceEvent *) event->xcookie.data;
+ if (f && ((FRAME_DISPLAY_INFO (f)->supports_xi2
+ && event->type == GenericEvent
+ && (event->xgeneric.extension
+ == FRAME_DISPLAY_INFO (f)->xi2_opcode)
+ && ((event->xgeneric.evtype == XI_ButtonPress
+ && xev->detail < 4)
+ || (event->xgeneric.evtype == XI_Motion)))
+ || (event->type == ButtonPress
+ && event->xbutton.button < 4)))
+#else
+ if (f
+#ifndef HAVE_PGTK
+ && event->type == ButtonPress && event->xbutton.button < 4
+#else
+ && event->type == GDK_BUTTON_PRESS && event->button.button < 4
+#endif
+ )
+#endif /* HAVE_XINPUT2 */
{
/* Check if press occurred outside the edit widget. */
+#ifndef HAVE_PGTK
GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f));
+#else
+ GdkDisplay *gdpy = FRAME_X_DISPLAY (f);
+#endif
GdkWindow *gwin;
#ifdef HAVE_GTK3
#if GTK_CHECK_VERSION (3, 20, 0)
@@ -4247,11 +4792,36 @@ xg_event_is_for_scrollbar (struct frame *f, const XEvent *event)
#else
gwin = gdk_display_get_window_at_pointer (gdpy, NULL, NULL);
#endif
- retval = gwin != gtk_widget_get_window (f->output_data.x->edit_widget);
+ retval = gwin != gtk_widget_get_window (f->output_data.xp->edit_widget);
+#ifdef HAVE_XINPUT2
+ GtkWidget *grab = gtk_grab_get_current ();
+ if (event->type == GenericEvent
+ && event->xgeneric.evtype == XI_Motion)
+ retval = retval || (grab && GTK_IS_SCROLLBAR (grab));
+#endif
}
+#ifdef HAVE_XINPUT2
+ else if (f && ((FRAME_DISPLAY_INFO (f)->supports_xi2
+ && event->type == GenericEvent
+ && (event->xgeneric.extension
+ == FRAME_DISPLAY_INFO (f)->xi2_opcode)
+ && ((event->xgeneric.evtype == XI_ButtonRelease
+ && xev->detail < 4)
+ || (event->xgeneric.evtype == XI_Motion)))
+ || ((event->type == ButtonRelease
+ && event->xbutton.button < 4)
+ || event->type == MotionNotify)))
+#else
else if (f
+#ifndef HAVE_PGTK
&& ((event->type == ButtonRelease && event->xbutton.button < 4)
- || event->type == MotionNotify))
+ || event->type == MotionNotify)
+#else
+ && ((event->type == GDK_BUTTON_RELEASE && event->button.button < 4)
+ || event->type == GDK_MOTION_NOTIFY)
+#endif
+ )
+#endif /* HAVE_XINPUT2 */
{
/* If we are releasing or moving the scroll bar, it has the grab. */
GtkWidget *w = gtk_grab_get_current ();
@@ -4329,7 +4899,11 @@ draw_page (GtkPrintOperation *operation, GtkPrintContext *context,
struct frame *f = XFRAME (Fnth (make_fixnum (page_nr), frames));
cairo_t *cr = gtk_print_context_get_cairo_context (context);
+#ifndef HAVE_PGTK
x_cr_draw_frame (cr, f);
+#else
+ pgtk_cr_draw_frame (cr, f);
+#endif
}
void
@@ -4430,7 +5004,11 @@ xg_tool_bar_callback (GtkWidget *w, gpointer client_data)
/* Convert between the modifier bits GDK uses and the modifier bits
Emacs uses. This assumes GDK and X masks are the same, which they are when
this is written. */
+#ifndef HAVE_PGTK
event.modifiers = x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), mod);
+#else
+ event.modifiers = pgtk_gtk_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), mod);
+#endif
kbd_buffer_store_event (&event);
/* Return focus to the frame after we have clicked on a detached
@@ -4527,7 +5105,7 @@ xg_tool_bar_item_expose_callback (GtkWidget *w,
static void
xg_pack_tool_bar (struct frame *f, Lisp_Object pos)
{
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
bool into_hbox = EQ (pos, Qleft) || EQ (pos, Qright);
GtkWidget *top_widget = x->toolbar_widget;
@@ -4583,7 +5161,7 @@ tb_size_cb (GtkWidget *widget,
static void
xg_create_tool_bar (struct frame *f)
{
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
#ifdef HAVE_GTK3
GtkStyleContext *gsty;
#endif
@@ -4822,7 +5400,7 @@ xg_tool_item_stale_p (GtkWidget *wbutton, const char *stock_name,
static bool
xg_update_tool_bar_sizes (struct frame *f)
{
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
GtkRequisition req;
int nl = 0, nr = 0, nt = 0, nb = 0;
GtkWidget *top_widget = x->toolbar_widget;
@@ -4908,7 +5486,7 @@ void
update_frame_tool_bar (struct frame *f)
{
int i, j;
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
int hmargin = 0, vmargin = 0;
GtkToolbar *wtoolbar;
GtkToolItem *ti;
@@ -4923,6 +5501,11 @@ update_frame_tool_bar (struct frame *f)
if (! FRAME_GTK_WIDGET (f))
return;
+#ifdef HAVE_PGTK
+ if (! FRAME_GTK_OUTER_WIDGET (f))
+ return;
+#endif
+
block_input ();
if (RANGED_FIXNUMP (1, Vtool_bar_button_margin, INT_MAX))
@@ -5218,7 +5801,7 @@ update_frame_tool_bar (struct frame *f)
void
free_frame_tool_bar (struct frame *f)
{
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
if (x->toolbar_widget)
{
@@ -5263,7 +5846,7 @@ free_frame_tool_bar (struct frame *f)
void
xg_change_toolbar_position (struct frame *f, Lisp_Object pos)
{
- struct x_output *x = f->output_data.x;
+ xp_output *x = f->output_data.xp;
GtkWidget *top_widget = x->toolbar_widget;
if (! x->toolbar_widget || ! top_widget)
diff --git a/src/gtkutil.h b/src/gtkutil.h
index 31a12cd5d3c..9c6160dd772 100644
--- a/src/gtkutil.h
+++ b/src/gtkutil.h
@@ -25,7 +25,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <gtk/gtk.h>
#include "../lwlib/lwlib-widget.h"
+#ifdef HAVE_PGTK
+#include "pgtkterm.h"
+#define EVENT GdkEvent
+#else
#include "xterm.h"
+#define EVENT XEvent
+#endif
/* Minimum and maximum values used for GTK scroll bars */
@@ -105,7 +111,7 @@ extern void xg_modify_menubar_widgets (GtkWidget *menubar,
extern void xg_update_frame_menubar (struct frame *f);
-extern bool xg_event_is_for_menubar (struct frame *, const XEvent *);
+extern bool xg_event_is_for_menubar (struct frame *, const EVENT *);
extern ptrdiff_t xg_get_scroll_id_for_window (Display *dpy, Window wid);
@@ -142,7 +148,7 @@ extern void xg_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar,
int portion,
int position,
int whole);
-extern bool xg_event_is_for_scrollbar (struct frame *, const XEvent *);
+extern bool xg_event_is_for_scrollbar (struct frame *, const EVENT *);
extern int xg_get_default_scrollbar_width (struct frame *f);
extern int xg_get_default_scrollbar_height (struct frame *f);
@@ -157,9 +163,15 @@ extern void xg_frame_set_char_size (struct frame *f, int width, int height);
extern GtkWidget * xg_win_to_widget (Display *dpy, Window wdesc);
extern int xg_get_scale (struct frame *f);
+#ifndef HAVE_PGTK
extern void xg_display_open (char *display_name, Display **dpy);
extern void xg_display_close (Display *dpy);
extern GdkCursor * xg_create_default_cursor (Display *dpy);
+#else
+extern void xg_display_open (char *display_name, GdkDisplay **dpy);
+extern void xg_display_close (GdkDisplay *gdpy);
+extern GdkCursor * xg_create_default_cursor (GdkDisplay *gdpy);
+#endif
extern bool xg_create_frame_widgets (struct frame *f);
extern void xg_free_frame_widgets (struct frame *f);
@@ -167,10 +179,15 @@ extern void xg_set_background_color (struct frame *f, unsigned long bg);
extern bool xg_check_special_colors (struct frame *f,
const char *color_name,
Emacs_Color *color);
+#ifdef HAVE_PGTK
+extern void xg_create_frame_outer_widgets (struct frame *f);
+#endif
+#ifndef HAVE_PGTK
extern void xg_set_frame_icon (struct frame *f,
Pixmap icon_pixmap,
Pixmap icon_mask);
+#endif
extern void xg_set_undecorated (struct frame *f, Lisp_Object undecorated);
extern void xg_frame_restack (struct frame *f1, struct frame *f2, bool above);
@@ -183,7 +200,11 @@ extern bool xg_prepare_tooltip (struct frame *f,
Lisp_Object string,
int *width,
int *height);
+#ifndef HAVE_PGTK
extern void xg_show_tooltip (struct frame *f, int root_x, int root_y);
+#else
+extern void xg_show_tooltip (struct frame *f, Lisp_Object string);
+#endif
extern bool xg_hide_tooltip (struct frame *f);
#ifdef USE_CAIRO
@@ -192,6 +213,10 @@ extern Lisp_Object xg_get_page_setup (void);
extern void xg_print_frames_dialog (Lisp_Object);
#endif
+#if defined HAVE_GTK3 && defined HAVE_XINPUT2
+extern bool xg_is_menu_window (Display *dpy, Window);
+#endif
+
/* Mark all callback data that are Lisp_object:s during GC. */
extern void xg_mark_data (void);
diff --git a/src/haiku.c b/src/haiku.c
new file mode 100644
index 00000000000..485d86983c2
--- /dev/null
+++ b/src/haiku.c
@@ -0,0 +1,286 @@
+/* Haiku subroutines that are general to the Haiku operating system.
+ Copyright (C) 2021 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 "process.h"
+#include "coding.h"
+
+#include <kernel/OS.h>
+
+#include <pwd.h>
+#include <stdlib.h>
+
+Lisp_Object
+list_system_processes (void)
+{
+ team_info info;
+ int32 cookie = 0;
+ Lisp_Object lval = Qnil;
+
+ while (get_next_team_info (&cookie, &info) == B_OK)
+ lval = Fcons (make_fixnum (info.team), lval);
+
+ return lval;
+}
+
+Lisp_Object
+system_process_attributes (Lisp_Object pid)
+{
+ CHECK_FIXNUM (pid);
+
+ team_info info;
+ Lisp_Object lval = Qnil;
+ thread_info inf;
+ area_info area;
+ team_id id = (team_id) XFIXNUM (pid);
+ struct passwd *g;
+ size_t mem = 0;
+
+ if (get_team_info (id, &info) != B_OK)
+ return Qnil;
+
+ bigtime_t everything = 0, vsample = 0;
+ bigtime_t cpu_eaten = 0, esample = 0;
+
+ lval = Fcons (Fcons (Qeuid, make_fixnum (info.uid)), lval);
+ lval = Fcons (Fcons (Qegid, make_fixnum (info.gid)), lval);
+ lval = Fcons (Fcons (Qthcount, make_fixnum (info.thread_count)), lval);
+ lval = Fcons (Fcons (Qcomm, build_string_from_utf8 (info.args)), lval);
+
+ g = getpwuid (info.uid);
+
+ if (g && g->pw_name)
+ lval = Fcons (Fcons (Quser, build_string (g->pw_name)), lval);
+
+ /* FIXME: Calculating this makes Emacs show up as using 100% CPU! */
+
+ for (int32 team_cookie = 0;
+ get_next_team_info (&team_cookie, &info) == B_OK;)
+ for (int32 thread_cookie = 0;
+ get_next_thread_info (info.team, &thread_cookie, &inf) == B_OK;)
+ {
+ if (inf.team == id && strncmp (inf.name, "idle thread ", 12))
+ cpu_eaten += inf.user_time + inf.kernel_time;
+ everything += inf.user_time + inf.kernel_time;
+ }
+
+ sleep (0.05);
+
+ for (int32 team_cookie = 0;
+ get_next_team_info (&team_cookie, &info) == B_OK;)
+ for (int32 thread_cookie = 0;
+ get_next_thread_info (info.team, &thread_cookie, &inf) == B_OK;)
+ {
+ if (inf.team == id && strncmp (inf.name, "idle thread ", 12))
+ esample += inf.user_time + inf.kernel_time;
+ vsample += inf.user_time + inf.kernel_time;
+ }
+
+ cpu_eaten = esample - cpu_eaten;
+ everything = vsample - everything;
+
+ if (everything)
+ lval = Fcons (Fcons (Qpcpu, make_float (((double) (cpu_eaten) /
+ (double) (everything)) * 100)),
+ lval);
+ else
+ lval = Fcons (Fcons (Qpcpu, make_float (0.0)), lval);
+
+ for (ssize_t area_cookie = 0;
+ get_next_area_info (id, &area_cookie, &area) == B_OK;)
+ mem += area.ram_size;
+
+ system_info sinfo;
+ get_system_info (&sinfo);
+ int64 max = (int64) sinfo.max_pages * B_PAGE_SIZE;
+
+ lval = Fcons (Fcons (Qpmem, make_float (((double) mem /
+ (double) max) * 100)),
+ lval);
+ lval = Fcons (Fcons (Qrss, make_fixnum (mem / 1024)), lval);
+
+ return lval;
+}
+
+
+/* Borrowed from w32 implementation. */
+
+struct load_sample
+{
+ time_t sample_time;
+ bigtime_t idle;
+ bigtime_t kernel;
+ bigtime_t user;
+};
+
+/* We maintain 1-sec samples for the last 16 minutes in a circular buffer. */
+static struct load_sample samples[16*60];
+static int first_idx = -1, last_idx = -1;
+static int max_idx = ARRAYELTS (samples);
+static unsigned num_of_processors = 0;
+
+static int
+buf_next (int from)
+{
+ int next_idx = from + 1;
+
+ if (next_idx >= max_idx)
+ next_idx = 0;
+
+ return next_idx;
+}
+
+static int
+buf_prev (int from)
+{
+ int prev_idx = from - 1;
+
+ if (prev_idx < 0)
+ prev_idx = max_idx - 1;
+
+ return prev_idx;
+}
+
+static double
+getavg (int which)
+{
+ double retval = -1.0;
+ double tdiff;
+ int idx;
+ double span = (which == 0 ? 1.0 : (which == 1 ? 5.0 : 15.0)) * 60;
+ time_t now = samples[last_idx].sample_time;
+
+ if (first_idx != last_idx)
+ {
+ for (idx = buf_prev (last_idx); ; idx = buf_prev (idx))
+ {
+ tdiff = difftime (now, samples[idx].sample_time);
+ if (tdiff >= span - 2 * DBL_EPSILON * now)
+ {
+ long double sys =
+ (samples[last_idx].kernel + samples[last_idx].user) -
+ (samples[idx].kernel + samples[idx].user);
+ long double idl = samples[last_idx].idle - samples[idx].idle;
+
+ retval = (idl / (sys + idl)) * num_of_processors;
+ break;
+ }
+ if (idx == first_idx)
+ break;
+ }
+ }
+
+ return retval;
+}
+
+static void
+sample_sys_load (bigtime_t *idle, bigtime_t *system, bigtime_t *user)
+{
+ bigtime_t i = 0, s = 0, u = 0;
+ team_info info;
+ thread_info inf;
+
+ for (int32 team_cookie = 0;
+ get_next_team_info (&team_cookie, &info) == B_OK;)
+ for (int32 thread_cookie = 0;
+ get_next_thread_info (info.team, &thread_cookie, &inf) == B_OK;)
+ {
+ if (!strncmp (inf.name, "idle thread ", 12))
+ i += inf.user_time + inf.kernel_time;
+ else
+ s += inf.kernel_time, u += inf.user_time;
+ }
+
+ *idle = i;
+ *system = s;
+ *user = u;
+}
+
+int
+getloadavg (double loadavg[], int nelem)
+{
+ int elem;
+ bigtime_t idle, kernel, user;
+ time_t now = time (NULL);
+
+ if (num_of_processors <= 0)
+ {
+ system_info i;
+ if (get_system_info (&i) == B_OK)
+ num_of_processors = i.cpu_count;
+ }
+
+ /* If system time jumped back for some reason, delete all samples
+ whose time is later than the current wall-clock time. This
+ prevents load average figures from becoming frozen for prolonged
+ periods of time, when system time is reset backwards. */
+ if (last_idx >= 0)
+ {
+ while (difftime (now, samples[last_idx].sample_time) < -1.0)
+ {
+ if (last_idx == first_idx)
+ {
+ first_idx = last_idx = -1;
+ break;
+ }
+ last_idx = buf_prev (last_idx);
+ }
+ }
+
+ /* Store another sample. We ignore samples that are less than 1 sec
+ apart. */
+ if (last_idx < 0
+ || (difftime (now, samples[last_idx].sample_time)
+ >= 1.0 - 2 * DBL_EPSILON * now))
+ {
+ sample_sys_load (&idle, &kernel, &user);
+ last_idx = buf_next (last_idx);
+ samples[last_idx].sample_time = now;
+ samples[last_idx].idle = idle;
+ samples[last_idx].kernel = kernel;
+ samples[last_idx].user = user;
+ /* If the buffer has more that 15 min worth of samples, discard
+ the old ones. */
+ if (first_idx == -1)
+ first_idx = last_idx;
+ while (first_idx != last_idx
+ && (difftime (now, samples[first_idx].sample_time)
+ >= 15.0 * 60 + 2 * DBL_EPSILON * now))
+ first_idx = buf_next (first_idx);
+ }
+
+ for (elem = 0; elem < nelem; elem++)
+ {
+ double avg = getavg (elem);
+
+ if (avg < 0)
+ break;
+ loadavg[elem] = avg;
+ }
+
+ /* Always return at least one element, otherwise load-average
+ returns nil, and Lisp programs might decide we cannot measure
+ system load. For example, jit-lock-stealth-load's defcustom
+ might decide that feature is "unsupported". */
+ if (elem == 0)
+ loadavg[elem++] = 0.09; /* < display-time-load-average-threshold */
+
+ return elem;
+}
diff --git a/src/haiku_draw_support.cc b/src/haiku_draw_support.cc
new file mode 100644
index 00000000000..5b1eccfbe6e
--- /dev/null
+++ b/src/haiku_draw_support.cc
@@ -0,0 +1,488 @@
+/* Haiku window system support. Hey, Emacs, this is -*- C++ -*-
+ Copyright (C) 2021 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 <View.h>
+#include <Region.h>
+#include <Font.h>
+#include <Window.h>
+#include <Bitmap.h>
+
+#include <cmath>
+
+#include "haiku_support.h"
+
+#define RGB_TO_UINT32(r, g, b) ((255 << 24) | ((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 RGB_COLOR_UINT32(r) RGB_TO_UINT32 ((r).red, (r).green, (r).blue)
+
+static void
+rgb32_to_rgb_color (uint32_t rgb, rgb_color *color)
+{
+ color->red = RED_FROM_ULONG (rgb);
+ color->green = GREEN_FROM_ULONG (rgb);
+ color->blue = BLUE_FROM_ULONG (rgb);
+ color->alpha = 255;
+}
+
+static BView *
+get_view (void *vw)
+{
+ BView *view = (BView *) find_appropriate_view_for_draw (vw);
+ return view;
+}
+
+void
+BView_StartClip (void *view)
+{
+ BView *vw = get_view (view);
+ vw->PushState ();
+}
+
+void
+BView_EndClip (void *view)
+{
+ BView *vw = get_view (view);
+ vw->PopState ();
+}
+
+void
+BView_SetHighColor (void *view, uint32_t color)
+{
+ BView *vw = get_view (view);
+ rgb_color col;
+ rgb32_to_rgb_color (color, &col);
+
+ vw->SetHighColor (col);
+}
+
+void
+BView_SetLowColor (void *view, uint32_t color)
+{
+ BView *vw = get_view (view);
+ rgb_color col;
+ rgb32_to_rgb_color (color, &col);
+
+ vw->SetLowColor (col);
+}
+
+void
+BView_SetPenSize (void *view, int u)
+{
+ BView *vw = get_view (view);
+ vw->SetPenSize (u);
+}
+
+void
+BView_FillRectangle (void *view, int x, int y, int width, int height)
+{
+ BView *vw = get_view (view);
+ BRect rect = BRect (x, y, x + width - 1, y + height - 1);
+
+ vw->FillRect (rect);
+}
+
+void
+BView_FillRectangleAbs (void *view, int x, int y, int x1, int y1)
+{
+ BView *vw = get_view (view);
+ BRect rect = BRect (x, y, x1, y1);
+
+ vw->FillRect (rect);
+}
+
+void
+BView_StrokeRectangle (void *view, int x, int y, int width, int height)
+{
+ BView *vw = get_view (view);
+ BRect rect = BRect (x, y, x + width - 1, y + height - 1);
+
+ vw->StrokeRect (rect);
+}
+
+void
+BView_SetViewColor (void *view, uint32_t color)
+{
+ BView *vw = get_view (view);
+ rgb_color col;
+ rgb32_to_rgb_color (color, &col);
+
+#ifndef USE_BE_CAIRO
+ vw->SetViewColor (col);
+#else
+ vw->SetViewColor (B_TRANSPARENT_32_BIT);
+#endif
+}
+
+void
+BView_ClipToRect (void *view, int x, int y, int width, int height)
+{
+ BView *vw = get_view (view);
+ BRect rect = BRect (x, y, x + width - 1, y + height - 1);
+
+ vw->ClipToRect (rect);
+}
+
+void
+BView_ClipToInverseRect (void *view, int x, int y, int width, int height)
+{
+ BView *vw = get_view (view);
+ BRect rect = BRect (x, y, x + width - 1, y + height - 1);
+
+ vw->ClipToInverseRect (rect);
+}
+
+void
+BView_StrokeLine (void *view, int sx, int sy, int tx, int ty)
+{
+ BView *vw = get_view (view);
+ BPoint from = BPoint (sx, sy);
+ BPoint to = BPoint (tx, ty);
+
+ vw->StrokeLine (from, to);
+}
+
+void
+BView_SetFont (void *view, void *font)
+{
+ BView *vw = get_view (view);
+
+ vw->SetFont ((BFont *) font);
+}
+
+void
+BView_MovePenTo (void *view, int x, int y)
+{
+ BView *vw = get_view (view);
+ BPoint pt = BPoint (x, y);
+
+ vw->MovePenTo (pt);
+}
+
+void
+BView_DrawString (void *view, const char *chr, ptrdiff_t len)
+{
+ BView *vw = get_view (view);
+
+ vw->DrawString (chr, len);
+}
+
+void
+BView_DrawChar (void *view, char chr)
+{
+ BView *vw = get_view (view);
+
+ vw->DrawChar (chr);
+}
+
+void
+BView_CopyBits (void *view, int x, int y, int width, int height,
+ int tox, int toy, int towidth, int toheight)
+{
+ BView *vw = get_view (view);
+
+ vw->CopyBits (BRect (x, y, x + width - 1, y + height - 1),
+ BRect (tox, toy, tox + towidth - 1, toy + toheight - 1));
+ vw->Sync ();
+}
+
+/* Convert RGB32 color color from RGB color space to its
+ HSL components pointed to by H, S and L. */
+void
+rgb_color_hsl (uint32_t rgb, double *h, double *s, double *l)
+{
+ rgb_color col;
+ rgb32_to_rgb_color (rgb, &col);
+
+ double red = col.red / 255.0;
+ double green = col.green / 255.0;
+ double blue = col.blue / 255.0;
+
+ double max = std::fmax (std::fmax (red, blue), green);
+ double min = std::fmin (std::fmin (red, blue), green);
+ double delta = max - min;
+ *l = (max + min) / 2.0;
+
+ if (!delta)
+ {
+ *h = 0;
+ *s = 0;
+ return;
+ }
+
+ *s = (*l < 0.5) ? delta / (max + min) :
+ delta / (20 - max - min);
+ double rc = (max - red) / delta;
+ double gc = (max - green) / delta;
+ double bc = (max - blue) / delta;
+
+ if (red == max)
+ *h = bc - gc;
+ else if (green == max)
+ *h = 2.0 + rc + -bc;
+ else
+ *h = 4.0 + gc + -rc;
+ *h = std::fmod (*h / 6, 1.0);
+}
+
+static double
+hue_to_rgb (double v1, double v2, double h)
+{
+ if (h < 1 / 6)
+ return v1 + (v2 - v1) * h * 6.0;
+ else if (h < 0.5)
+ return v2;
+ else if (h < 2.0 / 3)
+ return v1 + (v2 - v1) * (2.0 / 3 - h) * 6.0;
+ return v1;
+}
+
+void
+hsl_color_rgb (double h, double s, double l, uint32_t *rgb)
+{
+ if (!s)
+ *rgb = RGB_TO_UINT32 (std::lrint (l * 255),
+ std::lrint (l * 255),
+ std::lrint (l * 255));
+ else
+ {
+ double m2 = l <= 0.5 ? l * (1 + s) : l + s - l * s;
+ double m1 = 2.0 * l - m2;
+
+ *rgb = RGB_TO_UINT32
+ (std::lrint (hue_to_rgb (m1, m2,
+ std::fmod (h + 1 / 3.0, 1)) * 255),
+ std::lrint (hue_to_rgb (m1, m2, h) * 255),
+ std::lrint (hue_to_rgb (m1, m2,
+ std::fmod (h - 1 / 3.0, 1)) * 255));
+ }
+}
+
+void
+BView_DrawBitmap (void *view, void *bitmap, int x, int y,
+ int width, int height, int vx, int vy, int vwidth,
+ int vheight)
+{
+ BView *vw = get_view (view);
+ BBitmap *bm = (BBitmap *) bitmap;
+
+ vw->PushState ();
+ vw->SetDrawingMode (B_OP_OVER);
+ vw->DrawBitmap (bm, BRect (x, y, x + width - 1, y + height - 1),
+ BRect (vx, vy, vx + vwidth - 1, vy + vheight - 1));
+ vw->PopState ();
+}
+
+void
+BView_DrawBitmapWithEraseOp (void *view, void *bitmap, int x,
+ int y, int width, int height)
+{
+ BView *vw = get_view (view);
+ BBitmap *bm = (BBitmap *) bitmap;
+ BBitmap bc (bm->Bounds (), B_RGBA32);
+ BRect rect (x, y, x + width - 1, y + height - 1);
+
+ if (bc.InitCheck () != B_OK || bc.ImportBits (bm) != B_OK)
+ return;
+
+ uint32_t *bits = (uint32_t *) bc.Bits ();
+ size_t stride = bc.BytesPerRow ();
+
+ if (bm->ColorSpace () == B_GRAY1)
+ {
+ rgb_color low_color = vw->LowColor ();
+ for (int y = 0; y <= bc.Bounds ().Height (); ++y)
+ {
+ for (int x = 0; x <= bc.Bounds ().Width (); ++x)
+ {
+ if (bits[y * (stride / 4) + x] == 0xFF000000)
+ bits[y * (stride / 4) + x] = RGB_COLOR_UINT32 (low_color);
+ else
+ bits[y * (stride / 4) + x] = 0;
+ }
+ }
+ }
+
+ vw->PushState ();
+ vw->SetDrawingMode (bm->ColorSpace () == B_GRAY1 ? B_OP_OVER : B_OP_ERASE);
+ vw->DrawBitmap (&bc, rect);
+ vw->PopState ();
+}
+
+void
+BView_DrawMask (void *src, void *view,
+ int x, int y, int width, int height,
+ int vx, int vy, int vwidth, int vheight,
+ uint32_t color)
+{
+ BBitmap *source = (BBitmap *) src;
+ BBitmap bm (source->Bounds (), B_RGBA32);
+ if (bm.InitCheck () != B_OK)
+ return;
+ for (int y = 0; y <= bm.Bounds ().Height (); ++y)
+ {
+ for (int x = 0; x <= bm.Bounds ().Width (); ++x)
+ {
+ int bit = haiku_get_pixel ((void *) source, x, y);
+
+ if (!bit)
+ haiku_put_pixel ((void *) &bm, x, y, ((uint32_t) 255 << 24) | color);
+ else
+ haiku_put_pixel ((void *) &bm, x, y, 0);
+ }
+ }
+ BView *vw = get_view (view);
+ vw->SetDrawingMode (B_OP_OVER);
+ vw->DrawBitmap (&bm, BRect (x, y, x + width - 1, y + height - 1),
+ BRect (vx, vy, vx + vwidth - 1, vy + vheight - 1));
+}
+
+static BBitmap *
+rotate_bitmap_270 (BBitmap *bmp)
+{
+ BRect r = bmp->Bounds ();
+ BBitmap *bm = new BBitmap (BRect (r.top, r.left, r.bottom, r.right),
+ bmp->ColorSpace (), true);
+ if (bm->InitCheck () != B_OK)
+ gui_abort ("Failed to init bitmap for rotate");
+ int w = bmp->Bounds ().Width () + 1;
+ int h = bmp->Bounds ().Height () + 1;
+
+ for (int y = 0; y < h; ++y)
+ for (int x = 0; x < w; ++x)
+ haiku_put_pixel ((void *) bm, y, w - x - 1,
+ haiku_get_pixel ((void *) bmp, x, y));
+
+ return bm;
+}
+
+static BBitmap *
+rotate_bitmap_90 (BBitmap *bmp)
+{
+ BRect r = bmp->Bounds ();
+ BBitmap *bm = new BBitmap (BRect (r.top, r.left, r.bottom, r.right),
+ bmp->ColorSpace (), true);
+ if (bm->InitCheck () != B_OK)
+ gui_abort ("Failed to init bitmap for rotate");
+ int w = bmp->Bounds ().Width () + 1;
+ int h = bmp->Bounds ().Height () + 1;
+
+ for (int y = 0; y < h; ++y)
+ for (int x = 0; x < w; ++x)
+ haiku_put_pixel ((void *) bm, h - y - 1, x,
+ haiku_get_pixel ((void *) bmp, x, y));
+
+ return bm;
+}
+
+void *
+BBitmap_transform_bitmap (void *bitmap, void *mask, uint32_t m_color,
+ double rot, int desw, int desh)
+{
+ BBitmap *bm = (BBitmap *) bitmap;
+ BBitmap *mk = (BBitmap *) mask;
+ int copied_p = 0;
+
+ if (rot == 90)
+ {
+ copied_p = 1;
+ bm = rotate_bitmap_90 (bm);
+ if (mk)
+ mk = rotate_bitmap_90 (mk);
+ }
+
+ if (rot == 270)
+ {
+ copied_p = 1;
+ bm = rotate_bitmap_270 (bm);
+ if (mk)
+ mk = rotate_bitmap_270 (mk);
+ }
+
+ BRect r = bm->Bounds ();
+ if (r.Width () != desw || r.Height () != desh)
+ {
+ BRect n = BRect (0, 0, desw - 1, desh - 1);
+ BView vw (n, NULL, B_FOLLOW_NONE, 0);
+ BBitmap *dst = new BBitmap (n, bm->ColorSpace (), true);
+ if (dst->InitCheck () != B_OK)
+ if (bm->InitCheck () != B_OK)
+ gui_abort ("Failed to init bitmap for scale");
+ dst->AddChild (&vw);
+
+ if (!vw.LockLooper ())
+ gui_abort ("Failed to lock offscreen view for scale");
+
+ if (rot != 90 && rot != 270)
+ {
+ BAffineTransform tr;
+ tr.RotateBy (BPoint (desw / 2, desh / 2), rot * M_PI / 180.0);
+ vw.SetTransform (tr);
+ }
+
+ vw.MovePenTo (0, 0);
+ vw.DrawBitmap (bm, n);
+ if (mk)
+ BView_DrawMask ((void *) mk, (void *) &vw,
+ 0, 0, mk->Bounds ().Width (),
+ mk->Bounds ().Height (),
+ 0, 0, desw, desh, m_color);
+ vw.Sync ();
+ vw.RemoveSelf ();
+
+ if (copied_p)
+ delete bm;
+ if (copied_p && mk)
+ delete mk;
+ return dst;
+ }
+
+ return bm;
+}
+
+void
+BView_FillTriangle (void *view, int x1, int y1,
+ int x2, int y2, int x3, int y3)
+{
+ BView *vw = get_view (view);
+ vw->FillTriangle (BPoint (x1, y1), BPoint (x2, y2),
+ BPoint (x3, y3));
+}
+
+void
+BView_SetHighColorForVisibleBell (void *view, uint32_t color)
+{
+ BView *vw = (BView *) view;
+ rgb_color col;
+ rgb32_to_rgb_color (color, &col);
+
+ vw->SetHighColor (col);
+}
+
+void
+BView_FillRectangleForVisibleBell (void *view, int x, int y, int width, int height)
+{
+ BView *vw = (BView *) view;
+ BRect rect = BRect (x, y, x + width - 1, y + height - 1);
+
+ vw->FillRect (rect);
+}
diff --git a/src/haiku_font_support.cc b/src/haiku_font_support.cc
new file mode 100644
index 00000000000..9ac0400969b
--- /dev/null
+++ b/src/haiku_font_support.cc
@@ -0,0 +1,596 @@
+/* Haiku window system support. Hey, Emacs, this is -*- C++ -*-
+ Copyright (C) 2021 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 <Font.h>
+#include <Rect.h>
+#include <AffineTransform.h>
+
+#include <cstring>
+#include <cmath>
+
+#include "haiku_support.h"
+
+/* Haiku doesn't expose font language data in BFont objects. Thus, we
+ select a few representative characters for each supported `:lang'
+ (currently Chinese, Korean and Japanese,) and test for those
+ instead. */
+
+static uint32_t language_code_points[MAX_LANGUAGE][4] =
+ {{20154, 20754, 22996, 0}, /* Chinese. */
+ {51312, 49440, 44544, 0}, /* Korean. */
+ {26085, 26412, 12371, 0}, /* Japanese. */};
+
+static void
+estimate_font_ascii (BFont *font, int *max_width,
+ int *min_width, int *avg_width)
+{
+ char ch[2];
+ bool tems[1];
+ int total = 0;
+ int count = 0;
+ int min = 0;
+ int max = 0;
+
+ std::memset (ch, 0, sizeof ch);
+ for (ch[0] = 32; ch[0] < 127; ++ch[0])
+ {
+ tems[0] = false;
+ font->GetHasGlyphs (ch, 1, tems);
+ if (tems[0])
+ {
+ int w = font->StringWidth (ch);
+ ++count;
+ total += w;
+
+ if (!min || min > w)
+ min = w;
+ if (max < w)
+ max = w;
+ }
+ }
+
+ *min_width = min;
+ *max_width = max;
+ *avg_width = total / count;
+}
+
+void
+BFont_close (void *font)
+{
+ if (font != (void *) be_fixed_font &&
+ font != (void *) be_plain_font &&
+ font != (void *) be_bold_font)
+ delete (BFont *) font;
+}
+
+void
+BFont_dat (void *font, int *px_size, int *min_width, int *max_width,
+ int *avg_width, int *height, int *space_width, int *ascent,
+ int *descent, int *underline_position, int *underline_thickness)
+{
+ BFont *ft = (BFont *) font;
+ struct font_height fheight;
+ bool have_space_p;
+
+ char atem[1];
+ bool otem[1];
+
+ ft->GetHeight (&fheight);
+ atem[0] = ' ';
+ otem[0] = false;
+ ft->GetHasGlyphs (atem, 1, otem);
+ have_space_p = otem[0];
+
+ estimate_font_ascii (ft, max_width, min_width, avg_width);
+ *ascent = std::lrint (fheight.ascent);
+ *descent = std::lrint (fheight.descent);
+ *height = *ascent + *descent;
+
+ *space_width = have_space_p ? ft->StringWidth (" ") : 0;
+
+ *px_size = std::lrint (ft->Size ());
+ *underline_position = 0;
+ *underline_thickness = 0;
+}
+
+/* Return non-null if FONT contains CHR, a Unicode code-point. */
+int
+BFont_have_char_p (void *font, int32_t chr)
+{
+ BFont *ft = (BFont *) font;
+ return ft->IncludesBlock (chr, chr);
+}
+
+/* Return non-null if font contains a block from BEG to END. */
+int
+BFont_have_char_block (void *font, int32_t beg, int32_t end)
+{
+ BFont *ft = (BFont *) font;
+ return ft->IncludesBlock (beg, end);
+}
+
+/* Compute bounds for MB_STR, a character in multibyte encoding,
+ used with font. The width (in pixels) is returned in ADVANCE,
+ the left bearing in LB, and the right bearing in RB. */
+void
+BFont_char_bounds (void *font, const char *mb_str, int *advance,
+ int *lb, int *rb)
+{
+ BFont *ft = (BFont *) font;
+ edge_info edge_info;
+ float size, escapement;
+ size = ft->Size ();
+
+ ft->GetEdges (mb_str, 1, &edge_info);
+ ft->GetEscapements (mb_str, 1, &escapement);
+ *advance = std::lrint (escapement * size);
+ *lb = std::lrint (edge_info.left * size);
+ *rb = *advance + std::lrint (edge_info.right * size);
+}
+
+/* The same, but for a variable amount of chars. */
+void
+BFont_nchar_bounds (void *font, const char *mb_str, int *advance,
+ int *lb, int *rb, int32_t n)
+{
+ BFont *ft = (BFont *) font;
+ edge_info edge_info[n];
+ float size;
+ float escapement[n];
+
+ size = ft->Size ();
+
+ ft->GetEdges (mb_str, n, edge_info);
+ ft->GetEscapements (mb_str, n, (float *) escapement);
+
+ for (int32_t i = 0; i < n; ++i)
+ {
+ advance[i] = std::lrint (escapement[i] * size);
+ lb[i] = advance[i] - std::lrint (edge_info[i].left * size);
+ rb[i] = advance[i] + std::lrint (edge_info[i].right * size);
+ }
+}
+
+static void
+font_style_to_flags (char *st, struct haiku_font_pattern *pattern)
+{
+ char *style = strdup (st);
+ char *token;
+ pattern->weight = -1;
+ pattern->width = NO_WIDTH;
+ pattern->slant = NO_SLANT;
+ int tok = 0;
+
+ while ((token = std::strtok (!tok ? style : NULL, " ")) && tok < 3)
+ {
+ if (token && !strcmp (token, "Thin"))
+ pattern->weight = HAIKU_THIN;
+ else if (token && !strcmp (token, "UltraLight"))
+ pattern->weight = HAIKU_ULTRALIGHT;
+ else if (token && !strcmp (token, "ExtraLight"))
+ pattern->weight = HAIKU_EXTRALIGHT;
+ else if (token && !strcmp (token, "Light"))
+ pattern->weight = HAIKU_LIGHT;
+ else if (token && !strcmp (token, "SemiLight"))
+ pattern->weight = HAIKU_SEMI_LIGHT;
+ else if (token && !strcmp (token, "Regular"))
+ {
+ if (pattern->slant == NO_SLANT)
+ pattern->slant = SLANT_REGULAR;
+
+ if (pattern->width == NO_WIDTH)
+ pattern->width = NORMAL_WIDTH;
+
+ if (pattern->weight == -1)
+ pattern->weight = HAIKU_REGULAR;
+ }
+ else if (token && !strcmp (token, "SemiBold"))
+ pattern->weight = HAIKU_SEMI_BOLD;
+ else if (token && !strcmp (token, "Bold"))
+ pattern->weight = HAIKU_BOLD;
+ else if (token && (!strcmp (token, "ExtraBold") ||
+ /* This has actually been seen in the wild. */
+ !strcmp (token, "Extrabold")))
+ pattern->weight = HAIKU_EXTRA_BOLD;
+ else if (token && !strcmp (token, "UltraBold"))
+ pattern->weight = HAIKU_ULTRA_BOLD;
+ else if (token && !strcmp (token, "Book"))
+ pattern->weight = HAIKU_BOOK;
+ else if (token && !strcmp (token, "Heavy"))
+ pattern->weight = HAIKU_HEAVY;
+ else if (token && !strcmp (token, "UltraHeavy"))
+ pattern->weight = HAIKU_ULTRA_HEAVY;
+ else if (token && !strcmp (token, "Black"))
+ pattern->weight = HAIKU_BLACK;
+ else if (token && !strcmp (token, "Medium"))
+ pattern->weight = HAIKU_MEDIUM;
+ else if (token && !strcmp (token, "Oblique"))
+ pattern->slant = SLANT_OBLIQUE;
+ else if (token && !strcmp (token, "Italic"))
+ pattern->slant = SLANT_ITALIC;
+ else if (token && !strcmp (token, "UltraCondensed"))
+ pattern->width = ULTRA_CONDENSED;
+ else if (token && !strcmp (token, "ExtraCondensed"))
+ pattern->width = EXTRA_CONDENSED;
+ else if (token && !strcmp (token, "Condensed"))
+ pattern->width = CONDENSED;
+ else if (token && !strcmp (token, "SemiCondensed"))
+ pattern->width = SEMI_CONDENSED;
+ else if (token && !strcmp (token, "SemiExpanded"))
+ pattern->width = SEMI_EXPANDED;
+ else if (token && !strcmp (token, "Expanded"))
+ pattern->width = EXPANDED;
+ else if (token && !strcmp (token, "ExtraExpanded"))
+ pattern->width = EXTRA_EXPANDED;
+ else if (token && !strcmp (token, "UltraExpanded"))
+ pattern->width = ULTRA_EXPANDED;
+ else
+ {
+ tok = 1000;
+ break;
+ }
+ tok++;
+ }
+
+ if (pattern->weight != -1)
+ pattern->specified |= FSPEC_WEIGHT;
+ if (pattern->slant != NO_SLANT)
+ pattern->specified |= FSPEC_SLANT;
+ if (pattern->width != NO_WIDTH)
+ pattern->specified |= FSPEC_WIDTH;
+
+ if (tok > 3)
+ {
+ pattern->specified &= ~FSPEC_SLANT;
+ pattern->specified &= ~FSPEC_WEIGHT;
+ pattern->specified &= ~FSPEC_WIDTH;
+ pattern->specified |= FSPEC_STYLE;
+ std::strncpy ((char *) &pattern->style, st,
+ sizeof pattern->style - 1);
+ }
+
+ free (style);
+}
+
+static bool
+font_check_wanted_chars (struct haiku_font_pattern *pattern, font_family family,
+ char *style)
+{
+ BFont ft;
+
+ if (ft.SetFamilyAndStyle (family, style) != B_OK)
+ return false;
+
+ for (int i = 0; i < pattern->want_chars_len; ++i)
+ if (!ft.IncludesBlock (pattern->wanted_chars[i],
+ pattern->wanted_chars[i]))
+ return false;
+
+ return true;
+}
+
+static bool
+font_check_one_of (struct haiku_font_pattern *pattern, font_family family,
+ char *style)
+{
+ BFont ft;
+
+ if (ft.SetFamilyAndStyle (family, style) != B_OK)
+ return false;
+
+ for (int i = 0; i < pattern->need_one_of_len; ++i)
+ if (ft.IncludesBlock (pattern->need_one_of[i],
+ pattern->need_one_of[i]))
+ return true;
+
+ return false;
+}
+
+static bool
+font_check_language (struct haiku_font_pattern *pattern, font_family family,
+ char *style)
+{
+ BFont ft;
+
+ if (ft.SetFamilyAndStyle (family, style) != B_OK)
+ return false;
+
+ if (pattern->language == MAX_LANGUAGE)
+ return false;
+
+ for (uint32_t *ch = (uint32_t *)
+ &language_code_points[pattern->language]; *ch; ch++)
+ if (!ft.IncludesBlock (*ch, *ch))
+ return false;
+
+ return true;
+}
+
+static bool
+font_family_style_matches_p (font_family family, char *style, uint32_t flags,
+ struct haiku_font_pattern *pattern,
+ int ignore_flags_p = 0)
+{
+ struct haiku_font_pattern m;
+ m.specified = 0;
+
+ if (style)
+ font_style_to_flags (style, &m);
+
+ if ((pattern->specified & FSPEC_FAMILY) &&
+ strcmp ((char *) &pattern->family, family))
+ return false;
+
+ if (!ignore_flags_p && (pattern->specified & FSPEC_SPACING) &&
+ !(pattern->mono_spacing_p) != !(flags & B_IS_FIXED))
+ return false;
+
+ if (pattern->specified & FSPEC_STYLE)
+ return style && !strcmp (style, pattern->style);
+
+ if ((pattern->specified & FSPEC_WEIGHT)
+ && (pattern->weight
+ != ((m.specified & FSPEC_WEIGHT) ? m.weight : HAIKU_REGULAR)))
+ return false;
+
+ if ((pattern->specified & FSPEC_SLANT)
+ && (pattern->slant
+ != ((m.specified & FSPEC_SLANT) ? m.slant : SLANT_REGULAR)))
+ return false;
+
+ if ((pattern->specified & FSPEC_WANTED)
+ && !font_check_wanted_chars (pattern, family, style))
+ return false;
+
+ if ((pattern->specified & FSPEC_WIDTH)
+ && (pattern->width !=
+ ((m.specified & FSPEC_WIDTH) ? m.width : NORMAL_WIDTH)))
+ return false;
+
+ if ((pattern->specified & FSPEC_NEED_ONE_OF)
+ && !font_check_one_of (pattern, family, style))
+ return false;
+
+ if ((pattern->specified & FSPEC_LANGUAGE)
+ && !font_check_language (pattern, family, style))
+ return false;
+
+ return true;
+}
+
+static void
+haiku_font_fill_pattern (struct haiku_font_pattern *pattern,
+ font_family family, char *style,
+ uint32_t flags)
+{
+ if (style)
+ font_style_to_flags (style, pattern);
+
+ pattern->specified |= FSPEC_FAMILY;
+ std::strncpy (pattern->family, family,
+ sizeof pattern->family - 1);
+ pattern->specified |= FSPEC_SPACING;
+ pattern->mono_spacing_p = flags & B_IS_FIXED;
+}
+
+/* Delete every element of the font pattern PT. */
+void
+haiku_font_pattern_free (struct haiku_font_pattern *pt)
+{
+ struct haiku_font_pattern *tem = pt;
+ while (tem)
+ {
+ struct haiku_font_pattern *t = tem;
+ tem = t->next;
+ delete t;
+ }
+}
+
+/* Find all fonts matching the font pattern PT. */
+struct haiku_font_pattern *
+BFont_find (struct haiku_font_pattern *pt)
+{
+ struct haiku_font_pattern *r = NULL;
+ font_family name;
+ font_style sname;
+ uint32 flags;
+ int sty_count;
+ int fam_count = count_font_families ();
+
+ for (int fi = 0; fi < fam_count; ++fi)
+ {
+ if (get_font_family (fi, &name, &flags) == B_OK)
+ {
+ sty_count = count_font_styles (name);
+ if (!sty_count &&
+ font_family_style_matches_p (name, NULL, flags, pt))
+ {
+ struct haiku_font_pattern *p = new struct haiku_font_pattern;
+ p->specified = 0;
+ p->oblique_seen_p = 1;
+ haiku_font_fill_pattern (p, name, NULL, flags);
+ p->next = r;
+ if (p->next)
+ p->next->last = p;
+ p->last = NULL;
+ p->next_family = r;
+ r = p;
+ }
+ else if (sty_count)
+ {
+ for (int si = 0; si < sty_count; ++si)
+ {
+ int oblique_seen_p = 0;
+ struct haiku_font_pattern *head = r;
+ struct haiku_font_pattern *p = NULL;
+
+ if (get_font_style (name, si, &sname, &flags) == B_OK)
+ {
+ if (font_family_style_matches_p (name, (char *) &sname, flags, pt))
+ {
+ p = new struct haiku_font_pattern;
+ p->specified = 0;
+ haiku_font_fill_pattern (p, name, (char *) &sname, flags);
+ if (p->specified & FSPEC_SLANT &&
+ ((p->slant == SLANT_OBLIQUE) || (p->slant == SLANT_ITALIC)))
+ oblique_seen_p = 1;
+
+ p->next = r;
+ if (p->next)
+ p->next->last = p;
+ r = p;
+ p->next_family = head;
+ }
+ }
+
+ if (p)
+ p->last = NULL;
+
+ for (; head; head = head->last)
+ {
+ head->oblique_seen_p = oblique_seen_p;
+ }
+ }
+ }
+ }
+ }
+
+ /* There's a very good chance that this result will get cached if no
+ slant is specified. Thus, we look through each font that hasn't
+ seen an oblique style, and add one. */
+
+ if (!(pt->specified & FSPEC_SLANT))
+ {
+ /* r->last is invalid from here onwards. */
+ for (struct haiku_font_pattern *p = r; p;)
+ {
+ if (!p->oblique_seen_p)
+ {
+ struct haiku_font_pattern *n = new haiku_font_pattern;
+ *n = *p;
+ n->slant = SLANT_OBLIQUE;
+ p->next = n;
+ p = p->next_family;
+ }
+ else
+ p = p->next_family;
+ }
+ }
+
+ return r;
+}
+
+/* Find and open a font matching the pattern PAT, which must have its
+ family set. */
+int
+BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size)
+{
+ int sty_count;
+ font_family name;
+ font_style sname;
+ uint32 flags = 0;
+ if (!(pat->specified & FSPEC_FAMILY))
+ return 1;
+ strncpy (name, pat->family, sizeof name - 1);
+ sty_count = count_font_styles (name);
+
+ if (!sty_count &&
+ font_family_style_matches_p (name, NULL, flags, pat, 1))
+ {
+ BFont *ft = new BFont;
+ if (ft->SetFamilyAndStyle (name, NULL) != B_OK)
+ {
+ delete ft;
+ return 1;
+ }
+ ft->SetSize (size);
+ ft->SetEncoding (B_UNICODE_UTF8);
+ ft->SetSpacing (B_BITMAP_SPACING);
+ *font = (void *) ft;
+ return 0;
+ }
+ else if (sty_count)
+ {
+ for (int si = 0; si < sty_count; ++si)
+ {
+ if (get_font_style (name, si, &sname, &flags) == B_OK &&
+ font_family_style_matches_p (name, (char *) &sname, flags, pat))
+ {
+ BFont *ft = new BFont;
+ if (ft->SetFamilyAndStyle (name, sname) != B_OK)
+ {
+ delete ft;
+ return 1;
+ }
+ ft->SetSize (size);
+ ft->SetEncoding (B_UNICODE_UTF8);
+ ft->SetSpacing (B_BITMAP_SPACING);
+ *font = (void *) ft;
+ return 0;
+ }
+ }
+ }
+
+ if (pat->specified & FSPEC_SLANT && pat->slant == SLANT_OBLIQUE)
+ {
+ struct haiku_font_pattern copy = *pat;
+ copy.slant = SLANT_REGULAR;
+ int code = BFont_open_pattern (&copy, font, size);
+ if (code)
+ return code;
+ BFont *ft = (BFont *) *font;
+ /* XXX Font measurements don't respect shear. Haiku bug?
+ This apparently worked in BeOS.
+ ft->SetShear (100.0); */
+ ft->SetFace (B_ITALIC_FACE);
+ return 0;
+ }
+
+ return 1;
+}
+
+/* Query the family of the default fixed font. */
+void
+BFont_populate_fixed_family (struct haiku_font_pattern *ptn)
+{
+ font_family f;
+ font_style s;
+ be_fixed_font->GetFamilyAndStyle (&f, &s);
+
+ ptn->specified |= FSPEC_FAMILY;
+ strncpy (ptn->family, f, sizeof ptn->family - 1);
+}
+
+void
+BFont_populate_plain_family (struct haiku_font_pattern *ptn)
+{
+ font_family f;
+ font_style s;
+ be_plain_font->GetFamilyAndStyle (&f, &s);
+
+ ptn->specified |= FSPEC_FAMILY;
+ strncpy (ptn->family, f, sizeof ptn->family - 1);
+}
+
+int
+BFont_string_width (void *font, const char *utf8)
+{
+ return ((BFont *) font)->StringWidth (utf8);
+}
diff --git a/src/haiku_io.c b/src/haiku_io.c
new file mode 100644
index 00000000000..c152d9b086a
--- /dev/null
+++ b/src/haiku_io.c
@@ -0,0 +1,207 @@
+/* Haiku window system support.
+ Copyright (C) 2021 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 <pthread.h>
+#include <unistd.h>
+
+#include <OS.h>
+
+#include "haiku_support.h"
+#include "lisp.h"
+#include "haikuterm.h"
+#include "blockinput.h"
+
+#define PORT_CAP 1200
+
+/* The port used to send messages from the application thread to
+ Emacs. */
+port_id port_application_to_emacs;
+
+void
+haiku_io_init (void)
+{
+ port_application_to_emacs = create_port (PORT_CAP, "application emacs port");
+}
+
+static ssize_t
+haiku_len (enum haiku_event_type type)
+{
+ switch (type)
+ {
+ case QUIT_REQUESTED:
+ return sizeof (struct haiku_quit_requested_event);
+ case FRAME_RESIZED:
+ return sizeof (struct haiku_resize_event);
+ case FRAME_EXPOSED:
+ return sizeof (struct haiku_expose_event);
+ case KEY_DOWN:
+ case KEY_UP:
+ return sizeof (struct haiku_key_event);
+ case ACTIVATION:
+ return sizeof (struct haiku_activation_event);
+ case MOUSE_MOTION:
+ return sizeof (struct haiku_mouse_motion_event);
+ case BUTTON_DOWN:
+ case BUTTON_UP:
+ return sizeof (struct haiku_button_event);
+ case ICONIFICATION:
+ return sizeof (struct haiku_iconification_event);
+ case MOVE_EVENT:
+ return sizeof (struct haiku_move_event);
+ case SCROLL_BAR_VALUE_EVENT:
+ return sizeof (struct haiku_scroll_bar_value_event);
+ case SCROLL_BAR_DRAG_EVENT:
+ return sizeof (struct haiku_scroll_bar_drag_event);
+ case WHEEL_MOVE_EVENT:
+ return sizeof (struct haiku_wheel_move_event);
+ case MENU_BAR_RESIZE:
+ return sizeof (struct haiku_menu_bar_resize_event);
+ case MENU_BAR_OPEN:
+ case MENU_BAR_CLOSE:
+ return sizeof (struct haiku_menu_bar_state_event);
+ case MENU_BAR_SELECT_EVENT:
+ return sizeof (struct haiku_menu_bar_select_event);
+ case FILE_PANEL_EVENT:
+ return sizeof (struct haiku_file_panel_event);
+ case MENU_BAR_HELP_EVENT:
+ return sizeof (struct haiku_menu_bar_help_event);
+ case ZOOM_EVENT:
+ return sizeof (struct haiku_zoom_event);
+ case REFS_EVENT:
+ return sizeof (struct haiku_refs_event);
+ case APP_QUIT_REQUESTED_EVENT:
+ return sizeof (struct haiku_app_quit_requested_event);
+ }
+
+ emacs_abort ();
+}
+
+/* Read the size of the next message into len, returning -1 if the
+ query fails or there is no next message. */
+void
+haiku_read_size (ssize_t *len)
+{
+ port_id from = port_application_to_emacs;
+ ssize_t size;
+
+ size = port_buffer_size_etc (from, B_TIMEOUT, 0);
+
+ if (size < B_OK)
+ *len = -1;
+ else
+ *len = size;
+}
+
+/* Read the next message into BUF, putting its type into TYPE,
+ assuming the message is at most LEN long. Return 0 if successful
+ and -1 if the read fails. */
+int
+haiku_read (enum haiku_event_type *type, void *buf, ssize_t len)
+{
+ int32 typ;
+ port_id from = port_application_to_emacs;
+
+ if (read_port (from, &typ, buf, len) < B_OK)
+ return -1;
+
+ *type = (enum haiku_event_type) typ;
+ eassert (len >= haiku_len (typ));
+ return 0;
+}
+
+/* The same as haiku_read, but time out after TIMEOUT microseconds.
+ Input is blocked when an attempt to read is in progress. */
+int
+haiku_read_with_timeout (enum haiku_event_type *type, void *buf, ssize_t len,
+ time_t timeout)
+{
+ int32 typ;
+ port_id from = port_application_to_emacs;
+
+ block_input ();
+ if (read_port_etc (from, &typ, buf, len,
+ B_TIMEOUT, (bigtime_t) timeout) < B_OK)
+ {
+ unblock_input ();
+ return -1;
+ }
+ unblock_input ();
+ *type = (enum haiku_event_type) typ;
+ eassert (len >= haiku_len (typ));
+ return 0;
+}
+
+/* Write a message with type TYPE into BUF. */
+int
+haiku_write (enum haiku_event_type type, void *buf)
+{
+ port_id to = port_application_to_emacs;
+
+ if (write_port (to, (int32_t) type, buf, haiku_len (type)) < B_OK)
+ return -1;
+
+ kill (getpid (), SIGPOLL);
+
+ return 0;
+}
+
+int
+haiku_write_without_signal (enum haiku_event_type type, void *buf)
+{
+ port_id to = port_application_to_emacs;
+
+ if (write_port (to, (int32_t) type, buf, haiku_len (type)) < B_OK)
+ return -1;
+
+ return 0;
+}
+
+void
+haiku_io_init_in_app_thread (void)
+{
+ sigset_t set;
+ sigfillset (&set);
+
+ if (pthread_sigmask (SIG_BLOCK, &set, NULL))
+ perror ("pthread_sigmask");
+}
+
+/* Record an unwind protect from C++ code. */
+void
+record_c_unwind_protect_from_cxx (void (*fn) (void *), void *r)
+{
+ record_unwind_protect_ptr (fn, r);
+}
+
+/* SPECPDL_IDX that is safe from C++ code. */
+ptrdiff_t
+c_specpdl_idx_from_cxx (void)
+{
+ return SPECPDL_INDEX ();
+}
+
+/* unbind_to (IDX, Qnil), but safe from C++ code. */
+void
+c_unbind_to_nil_from_cxx (ptrdiff_t idx)
+{
+ unbind_to (idx, Qnil);
+}
diff --git a/src/haiku_select.cc b/src/haiku_select.cc
new file mode 100644
index 00000000000..6cd6ee879e5
--- /dev/null
+++ b/src/haiku_select.cc
@@ -0,0 +1,229 @@
+/* Haiku window system selection support. Hey Emacs, this is -*- C++ -*-
+ Copyright (C) 2021 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 <Clipboard.h>
+
+#include <cstdlib>
+#include <cstring>
+
+#include "haikuselect.h"
+
+
+static BClipboard *primary = NULL;
+static BClipboard *secondary = NULL;
+static BClipboard *system_clipboard = NULL;
+
+int selection_state_flag;
+
+static char *
+BClipboard_find_data (BClipboard *cb, const char *type, ssize_t *len)
+{
+ if (!cb->Lock ())
+ return 0;
+
+ BMessage *dat = cb->Data ();
+ if (!dat)
+ {
+ cb->Unlock ();
+ return 0;
+ }
+
+ const char *ptr;
+ ssize_t bt;
+ dat->FindData (type, B_MIME_TYPE, (const void **) &ptr, &bt);
+
+ if (!ptr)
+ {
+ cb->Unlock ();
+ return NULL;
+ }
+
+ if (len)
+ *len = bt;
+
+ cb->Unlock ();
+
+ return strndup (ptr, bt);
+}
+
+static void
+BClipboard_get_targets (BClipboard *cb, char **buf, int buf_size)
+{
+ BMessage *data;
+ char *name;
+ int32 count_found;
+ type_code type;
+ int32 i;
+ int index;
+
+ if (!cb->Lock ())
+ {
+ buf[0] = NULL;
+ return;
+ }
+
+ data = cb->Data ();
+ index = 0;
+
+ if (!data)
+ {
+ buf[0] = NULL;
+ cb->Unlock ();
+ return;
+ }
+
+ for (i = 0; (data->GetInfo (B_ANY_TYPE, i, &name,
+ &type, &count_found)
+ == B_OK); ++i)
+ {
+ if (type == B_MIME_TYPE)
+ {
+ if (index < (buf_size - 1))
+ {
+ buf[index++] = strdup (name);
+
+ if (!buf[index - 1])
+ break;
+ }
+ }
+ }
+
+ buf[index] = NULL;
+
+ cb->Unlock ();
+}
+
+static void
+BClipboard_set_data (BClipboard *cb, const char *type, const char *dat,
+ ssize_t len, bool clear)
+{
+ if (!cb->Lock ())
+ return;
+
+ if (clear)
+ cb->Clear ();
+
+ BMessage *mdat = cb->Data ();
+ if (!mdat)
+ {
+ cb->Unlock ();
+ return;
+ }
+
+ if (dat)
+ {
+ if (mdat->ReplaceData (type, B_MIME_TYPE, dat, len)
+ == B_NAME_NOT_FOUND)
+ mdat->AddData (type, B_MIME_TYPE, dat, len);
+ }
+ else
+ mdat->RemoveName (type);
+ cb->Commit ();
+ cb->Unlock ();
+}
+
+char *
+BClipboard_find_system_data (const char *type, ssize_t *len)
+{
+ if (!system_clipboard)
+ return 0;
+
+ return BClipboard_find_data (system_clipboard, type, len);
+}
+
+char *
+BClipboard_find_primary_selection_data (const char *type, ssize_t *len)
+{
+ if (!primary)
+ return 0;
+
+ return BClipboard_find_data (primary, type, len);
+}
+
+char *
+BClipboard_find_secondary_selection_data (const char *type, ssize_t *len)
+{
+ if (!secondary)
+ return 0;
+
+ return BClipboard_find_data (secondary, type, len);
+}
+
+void
+BClipboard_set_system_data (const char *type, const char *data,
+ ssize_t len, bool clear)
+{
+ if (!system_clipboard)
+ return;
+
+ BClipboard_set_data (system_clipboard, type, data, len, clear);
+}
+
+void
+BClipboard_set_primary_selection_data (const char *type, const char *data,
+ ssize_t len, bool clear)
+{
+ if (!primary)
+ return;
+
+ BClipboard_set_data (primary, type, data, len, clear);
+}
+
+void
+BClipboard_set_secondary_selection_data (const char *type, const char *data,
+ ssize_t len, bool clear)
+{
+ if (!secondary)
+ return;
+
+ BClipboard_set_data (secondary, type, data, len, clear);
+}
+
+void
+BClipboard_free_data (void *ptr)
+{
+ std::free (ptr);
+}
+
+void
+BClipboard_system_targets (char **buf, int len)
+{
+ BClipboard_get_targets (system_clipboard, buf, len);
+}
+
+void
+BClipboard_primary_targets (char **buf, int len)
+{
+ BClipboard_get_targets (primary, buf, len);
+}
+
+void
+BClipboard_secondary_targets (char **buf, int len)
+{
+ BClipboard_get_targets (secondary, buf, len);
+}
+
+void
+init_haiku_select (void)
+{
+ system_clipboard = new BClipboard ("system");
+ primary = new BClipboard ("primary");
+ secondary = new BClipboard ("secondary");
+}
diff --git a/src/haiku_support.cc b/src/haiku_support.cc
new file mode 100644
index 00000000000..b8f6e84d2c3
--- /dev/null
+++ b/src/haiku_support.cc
@@ -0,0 +1,2928 @@
+/* Haiku window system support. Hey, Emacs, this is -*- C++ -*-
+ Copyright (C) 2021 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 <app/Application.h>
+#include <app/Cursor.h>
+#include <app/Messenger.h>
+
+#include <interface/GraphicsDefs.h>
+#include <interface/InterfaceDefs.h>
+#include <interface/Bitmap.h>
+#include <interface/Window.h>
+#include <interface/View.h>
+#include <interface/Screen.h>
+#include <interface/ScrollBar.h>
+#include <interface/Region.h>
+#include <interface/Menu.h>
+#include <interface/MenuItem.h>
+#include <interface/PopUpMenu.h>
+#include <interface/MenuBar.h>
+#include <interface/Alert.h>
+#include <interface/Button.h>
+
+#include <locale/UnicodeChar.h>
+
+#include <game/WindowScreen.h>
+#include <game/DirectWindow.h>
+
+#include <storage/Entry.h>
+#include <storage/Path.h>
+#include <storage/FilePanel.h>
+#include <storage/AppFileInfo.h>
+#include <storage/Path.h>
+#include <storage/PathFinder.h>
+
+#include <support/Beep.h>
+#include <support/DataIO.h>
+#include <support/Locker.h>
+
+#include <translation/TranslatorRoster.h>
+#include <translation/TranslationDefs.h>
+#include <translation/TranslationUtils.h>
+
+#include <kernel/OS.h>
+#include <kernel/fs_attr.h>
+#include <kernel/scheduler.h>
+
+#include <private/interface/ToolTip.h>
+
+#include <cmath>
+#include <cstring>
+#include <cstdint>
+#include <cstdio>
+#include <csignal>
+#include <cfloat>
+
+#include <pthread.h>
+
+#ifdef USE_BE_CAIRO
+#include <cairo.h>
+#endif
+
+#include "haiku_support.h"
+
+#define SCROLL_BAR_UPDATE 3000
+
+static color_space dpy_color_space = B_NO_COLOR_SPACE;
+static key_map *key_map = NULL;
+static char *key_chars = NULL;
+static BLocker key_map_lock;
+
+extern "C"
+{
+ extern _Noreturn void emacs_abort (void);
+ /* Also defined in haikuterm.h. */
+ extern void be_app_quit (void);
+}
+
+static thread_id app_thread;
+
+_Noreturn void
+gui_abort (const char *msg)
+{
+ fprintf (stderr, "Abort in GUI code: %s\n", msg);
+ fprintf (stderr, "Under Haiku, Emacs cannot recover from errors in GUI code\n");
+ fprintf (stderr, "App Server disconnects usually manifest as bitmap "
+ "initialization failures or lock failures.");
+ emacs_abort ();
+}
+
+#ifdef USE_BE_CAIRO
+static cairo_format_t
+cairo_format_from_color_space (color_space space)
+{
+ switch (space)
+ {
+ case B_RGBA32:
+ return CAIRO_FORMAT_ARGB32;
+ case B_RGB32:
+ return CAIRO_FORMAT_RGB24;
+ case B_RGB16:
+ return CAIRO_FORMAT_RGB16_565;
+ case B_GRAY8:
+ return CAIRO_FORMAT_A8;
+ case B_GRAY1:
+ return CAIRO_FORMAT_A1;
+ default:
+ gui_abort ("Unsupported color space");
+ }
+}
+#endif
+
+static void
+map_key (char *chars, int32 offset, uint32_t *c)
+{
+ int size = chars[offset++];
+ switch (size)
+ {
+ case 0:
+ break;
+
+ case 1:
+ *c = chars[offset];
+ break;
+
+ default:
+ {
+ char str[5];
+ int i = (size <= 4) ? size : 4;
+ strncpy (str, &(chars[offset]), i);
+ str[i] = '0';
+ *c = BUnicodeChar::FromUTF8 ((char *) &str);
+ break;
+ }
+ }
+}
+
+static void
+map_shift (uint32_t kc, uint32_t *ch)
+{
+ if (!key_map_lock.Lock ())
+ gui_abort ("Failed to lock keymap");
+ if (!key_map)
+ get_key_map (&key_map, &key_chars);
+ if (!key_map)
+ return;
+ if (kc >= 128)
+ return;
+
+ int32_t m = key_map->shift_map[kc];
+ map_key (key_chars, m, ch);
+ key_map_lock.Unlock ();
+}
+
+static void
+map_normal (uint32_t kc, uint32_t *ch)
+{
+ if (!key_map_lock.Lock ())
+ gui_abort ("Failed to lock keymap");
+ if (!key_map)
+ get_key_map (&key_map, &key_chars);
+ if (!key_map)
+ return;
+ if (kc >= 128)
+ return;
+
+ int32_t m = key_map->normal_map[kc];
+ map_key (key_chars, m, ch);
+ key_map_lock.Unlock ();
+}
+
+class Emacs : public BApplication
+{
+public:
+ Emacs () : BApplication ("application/x-vnd.GNU-emacs")
+ {
+ }
+
+ void
+ AboutRequested (void)
+ {
+ BAlert *about = new BAlert (PACKAGE_NAME,
+ PACKAGE_STRING
+ "\nThe extensible, self-documenting, real-time display editor.",
+ "Close");
+ about->Go ();
+ }
+
+ bool
+ QuitRequested (void)
+ {
+ struct haiku_app_quit_requested_event rq;
+ haiku_write (APP_QUIT_REQUESTED_EVENT, &rq);
+ return 0;
+ }
+
+ void
+ RefsReceived (BMessage *msg)
+ {
+ struct haiku_refs_event rq;
+ entry_ref ref;
+ BEntry entry;
+ BPath path;
+ int32 cookie = 0;
+ int32 x, y;
+ void *window;
+
+ if ((msg->FindPointer ("window", 0, &window) != B_OK)
+ || (msg->FindInt32 ("x", 0, &x) != B_OK)
+ || (msg->FindInt32 ("y", 0, &y) != B_OK))
+ return;
+
+ rq.window = window;
+ rq.x = x;
+ rq.y = y;
+
+ while (msg->FindRef ("refs", cookie++, &ref) == B_OK)
+ {
+ if (entry.SetTo (&ref, 0) == B_OK
+ && entry.GetPath (&path) == B_OK)
+ {
+ rq.ref = strdup (path.Path ());
+ haiku_write (REFS_EVENT, &rq);
+ }
+ }
+ }
+};
+
+class EmacsWindow : public BDirectWindow
+{
+public:
+ struct child_frame
+ {
+ struct child_frame *next;
+ int xoff, yoff;
+ EmacsWindow *window;
+ } *subset_windows = NULL;
+
+ EmacsWindow *parent = NULL;
+ BRect pre_fullscreen_rect;
+ BRect pre_zoom_rect;
+ int x_before_zoom = INT_MIN;
+ int y_before_zoom = INT_MIN;
+ int fullscreen_p = 0;
+ int zoomed_p = 0;
+ int shown_flag = 0;
+
+#ifdef USE_BE_CAIRO
+ BLocker surface_lock;
+ cairo_surface_t *cr_surface = NULL;
+#endif
+
+ EmacsWindow () : BDirectWindow (BRect (0, 0, 0, 0), "", B_TITLED_WINDOW_LOOK,
+ B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS)
+ {
+
+ }
+
+ ~EmacsWindow ()
+ {
+ struct child_frame *next;
+ for (struct child_frame *f = subset_windows; f; f = next)
+ {
+ f->window->Unparent ();
+ next = f->next;
+ delete f;
+ }
+
+ if (this->parent)
+ UnparentAndUnlink ();
+
+#ifdef USE_BE_CAIRO
+ if (!surface_lock.Lock ())
+ gui_abort ("Failed to lock cairo surface");
+ if (cr_surface)
+ {
+ cairo_surface_destroy (cr_surface);
+ cr_surface = NULL;
+ }
+ surface_lock.Unlock ();
+#endif
+ }
+
+ void
+ UpwardsSubset (EmacsWindow *w)
+ {
+ for (; w; w = w->parent)
+ AddToSubset (w);
+ }
+
+ void
+ UpwardsSubsetChildren (EmacsWindow *w)
+ {
+ UpwardsSubset (w);
+ for (struct child_frame *f = subset_windows; f;
+ f = f->next)
+ f->window->UpwardsSubsetChildren (w);
+ }
+
+ void
+ UpwardsUnSubset (EmacsWindow *w)
+ {
+ for (; w; w = w->parent)
+ RemoveFromSubset (w);
+ }
+
+ void
+ UpwardsUnSubsetChildren (EmacsWindow *w)
+ {
+ UpwardsUnSubset (w);
+ for (struct child_frame *f = subset_windows; f;
+ f = f->next)
+ f->window->UpwardsUnSubsetChildren (w);
+ }
+
+ void
+ Unparent (void)
+ {
+ this->SetFeel (B_NORMAL_WINDOW_FEEL);
+ UpwardsUnSubsetChildren (parent);
+ this->RemoveFromSubset (this);
+ this->parent = NULL;
+ if (fullscreen_p)
+ {
+ fullscreen_p = 0;
+ MakeFullscreen (1);
+ }
+ }
+
+ void
+ UnparentAndUnlink (void)
+ {
+ this->parent->UnlinkChild (this);
+ this->Unparent ();
+ }
+
+ void
+ UnlinkChild (EmacsWindow *window)
+ {
+ struct child_frame *last = NULL;
+ struct child_frame *tem = subset_windows;
+
+ for (; tem; last = tem, tem = tem->next)
+ {
+ if (tem->window == window)
+ {
+ if (last)
+ last->next = tem->next;
+ if (tem == subset_windows)
+ subset_windows = NULL;
+ delete tem;
+ return;
+ }
+ }
+
+ gui_abort ("Failed to unlink child frame");
+ }
+
+ void
+ ParentTo (EmacsWindow *window)
+ {
+ if (this->parent)
+ UnparentAndUnlink ();
+
+ this->parent = window;
+ this->SetFeel (B_FLOATING_SUBSET_WINDOW_FEEL);
+ this->AddToSubset (this);
+ if (!IsHidden () && this->parent)
+ UpwardsSubsetChildren (parent);
+ if (fullscreen_p)
+ {
+ fullscreen_p = 0;
+ MakeFullscreen (1);
+ }
+ this->Sync ();
+ window->LinkChild (this);
+ }
+
+ void
+ LinkChild (EmacsWindow *window)
+ {
+ struct child_frame *f = new struct child_frame;
+
+ for (struct child_frame *f = subset_windows; f;
+ f = f->next)
+ {
+ if (window == f->window)
+ gui_abort ("Trying to link a child frame that is already present");
+ }
+
+ f->window = window;
+ f->next = subset_windows;
+ f->xoff = -1;
+ f->yoff = -1;
+
+ subset_windows = f;
+ }
+
+ void
+ DoMove (struct child_frame *f)
+ {
+ BRect frame = this->Frame ();
+ f->window->MoveTo (frame.left + f->xoff,
+ frame.top + f->yoff);
+ this->Sync ();
+ }
+
+ void
+ DoUpdateWorkspace (struct child_frame *f)
+ {
+ f->window->SetWorkspaces (this->Workspaces ());
+ }
+
+ void
+ MoveChild (EmacsWindow *window, int xoff, int yoff,
+ int weak_p)
+ {
+ for (struct child_frame *f = subset_windows; f;
+ f = f->next)
+ {
+ if (window == f->window)
+ {
+ f->xoff = xoff;
+ f->yoff = yoff;
+ if (!weak_p)
+ DoMove (f);
+ return;
+ }
+ }
+
+ gui_abort ("Trying to move a child frame that doesn't exist");
+ }
+
+ void
+ WindowActivated (bool activated)
+ {
+ struct haiku_activation_event rq;
+ rq.window = this;
+ rq.activated_p = activated;
+
+ haiku_write (ACTIVATION, &rq);
+ }
+
+ void
+ DirectConnected (direct_buffer_info *info)
+ {
+#ifdef USE_BE_CAIRO
+ if (!surface_lock.Lock ())
+ gui_abort ("Failed to lock window direct cr surface");
+ if (cr_surface)
+ {
+ cairo_surface_destroy (cr_surface);
+ cr_surface = NULL;
+ }
+
+ if (info->buffer_state != B_DIRECT_STOP)
+ {
+ int left, top, right, bottom;
+ left = info->clip_bounds.left;
+ top = info->clip_bounds.top;
+ right = info->clip_bounds.right;
+ bottom = info->clip_bounds.bottom;
+
+ unsigned char *bits = (unsigned char *) info->bits;
+ if ((info->bits_per_pixel % 8) == 0)
+ {
+ bits += info->bytes_per_row * top;
+ bits += (left * info->bits_per_pixel / 8);
+ cr_surface = cairo_image_surface_create_for_data
+ (bits,
+ cairo_format_from_color_space (info->pixel_format),
+ right - left + 1,
+ bottom - top + 1,
+ info->bytes_per_row);
+ }
+ }
+ surface_lock.Unlock ();
+#endif
+ }
+
+ void
+ MessageReceived (BMessage *msg)
+ {
+ int32 old_what = 0;
+
+ if (msg->WasDropped ())
+ {
+ entry_ref ref;
+ BPoint whereto;
+
+ if (msg->FindRef ("refs", &ref) == B_OK)
+ {
+ msg->what = B_REFS_RECEIVED;
+ msg->AddPointer ("window", this);
+ if (msg->FindPoint ("_drop_point_", &whereto) == B_OK)
+ {
+ this->ConvertFromScreen (&whereto);
+ msg->AddInt32 ("x", whereto.x);
+ msg->AddInt32 ("y", whereto.y);
+ }
+ be_app->PostMessage (msg);
+ msg->SendReply (B_OK);
+ }
+ }
+ else if (msg->GetPointer ("menuptr"))
+ {
+ struct haiku_menu_bar_select_event rq;
+ rq.window = this;
+ rq.ptr = (void *) msg->GetPointer ("menuptr");
+ haiku_write (MENU_BAR_SELECT_EVENT, &rq);
+ }
+ else if (msg->what == 'FPSE'
+ || ((msg->FindInt32 ("old_what", &old_what) == B_OK
+ && old_what == 'FPSE')))
+ {
+ struct haiku_file_panel_event rq;
+ BEntry entry;
+ BPath path;
+ entry_ref ref;
+
+ rq.ptr = NULL;
+
+ if (msg->FindRef ("refs", &ref) == B_OK &&
+ entry.SetTo (&ref, 0) == B_OK &&
+ entry.GetPath (&path) == B_OK)
+ {
+ const char *str_path = path.Path ();
+ if (str_path)
+ rq.ptr = strdup (str_path);
+ }
+
+ if (msg->FindRef ("directory", &ref),
+ entry.SetTo (&ref, 0) == B_OK &&
+ entry.GetPath (&path) == B_OK)
+ {
+ const char *name = msg->GetString ("name");
+ const char *str_path = path.Path ();
+
+ if (name)
+ {
+ char str_buf[std::strlen (str_path)
+ + std::strlen (name) + 2];
+ snprintf ((char *) &str_buf,
+ std::strlen (str_path)
+ + std::strlen (name) + 2, "%s/%s",
+ str_path, name);
+ rq.ptr = strdup (str_buf);
+ }
+ }
+
+ haiku_write (FILE_PANEL_EVENT, &rq);
+ }
+ else
+ BDirectWindow::MessageReceived (msg);
+ }
+
+ void
+ DispatchMessage (BMessage *msg, BHandler *handler)
+ {
+ if (msg->what == B_KEY_DOWN || msg->what == B_KEY_UP)
+ {
+ struct haiku_key_event rq;
+ rq.window = this;
+
+ int32_t code = msg->GetInt32 ("raw_char", 0);
+
+ rq.modifiers = 0;
+ uint32_t mods = modifiers ();
+
+ if (mods & B_SHIFT_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_SHIFT;
+
+ if (mods & B_CONTROL_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_CTRL;
+
+ if (mods & B_COMMAND_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_ALT;
+
+ if (mods & B_OPTION_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_SUPER;
+
+ rq.mb_char = code;
+ rq.kc = msg->GetInt32 ("key", -1);
+ rq.unraw_mb_char =
+ BUnicodeChar::FromUTF8 (msg->GetString ("bytes"));
+
+ if ((mods & B_SHIFT_KEY) && rq.kc >= 0)
+ map_shift (rq.kc, &rq.unraw_mb_char);
+ else if (rq.kc >= 0)
+ map_normal (rq.kc, &rq.unraw_mb_char);
+
+ haiku_write (msg->what == B_KEY_DOWN ? KEY_DOWN : KEY_UP, &rq);
+ }
+ else if (msg->what == B_MOUSE_WHEEL_CHANGED)
+ {
+ struct haiku_wheel_move_event rq;
+ rq.window = this;
+ rq.modifiers = 0;
+
+ uint32_t mods = modifiers ();
+
+ if (mods & B_SHIFT_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_SHIFT;
+
+ if (mods & B_CONTROL_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_CTRL;
+
+ if (mods & B_COMMAND_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_ALT;
+
+ if (mods & B_OPTION_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_SUPER;
+
+ float dx, dy;
+ if (msg->FindFloat ("be:wheel_delta_x", &dx) == B_OK &&
+ msg->FindFloat ("be:wheel_delta_y", &dy) == B_OK)
+ {
+ rq.delta_x = dx;
+ rq.delta_y = dy;
+
+ haiku_write (WHEEL_MOVE_EVENT, &rq);
+ };
+ }
+ else
+ BDirectWindow::DispatchMessage (msg, handler);
+ }
+
+ void
+ MenusBeginning ()
+ {
+ struct haiku_menu_bar_state_event rq;
+ rq.window = this;
+
+ haiku_write (MENU_BAR_OPEN, &rq);
+ }
+
+ void
+ MenusEnded ()
+ {
+ struct haiku_menu_bar_state_event rq;
+ rq.window = this;
+
+ haiku_write (MENU_BAR_CLOSE, &rq);
+ }
+
+ void
+ FrameResized (float newWidth, float newHeight)
+ {
+ struct haiku_resize_event rq;
+ rq.window = this;
+ rq.px_heightf = newHeight + 1.0f;
+ rq.px_widthf = newWidth + 1.0f;
+
+ haiku_write (FRAME_RESIZED, &rq);
+ BDirectWindow::FrameResized (newWidth, newHeight);
+ }
+
+ void
+ FrameMoved (BPoint newPosition)
+ {
+ struct haiku_move_event rq;
+ rq.window = this;
+ rq.x = std::lrint (newPosition.x);
+ rq.y = std::lrint (newPosition.y);
+
+ haiku_write (MOVE_EVENT, &rq);
+
+ for (struct child_frame *f = subset_windows;
+ f; f = f->next)
+ DoMove (f);
+ BDirectWindow::FrameMoved (newPosition);
+ }
+
+ void
+ WorkspacesChanged (uint32_t old, uint32_t n)
+ {
+ for (struct child_frame *f = subset_windows;
+ f; f = f->next)
+ DoUpdateWorkspace (f);
+ }
+
+ void
+ EmacsMoveTo (int x, int y)
+ {
+ if (!this->parent)
+ this->MoveTo (x, y);
+ else
+ this->parent->MoveChild (this, x, y, 0);
+ }
+
+ bool
+ QuitRequested ()
+ {
+ struct haiku_quit_requested_event rq;
+ rq.window = this;
+ haiku_write (QUIT_REQUESTED, &rq);
+ return false;
+ }
+
+ void
+ Minimize (bool minimized_p)
+ {
+ BDirectWindow::Minimize (minimized_p);
+ struct haiku_iconification_event rq;
+ rq.window = this;
+ rq.iconified_p = !parent && minimized_p;
+
+ haiku_write (ICONIFICATION, &rq);
+ }
+
+ void
+ EmacsHide (void)
+ {
+ if (this->IsHidden ())
+ return;
+ Hide ();
+ if (this->parent)
+ UpwardsUnSubsetChildren (this->parent);
+ }
+
+ void
+ EmacsShow (void)
+ {
+ if (!this->IsHidden ())
+ return;
+ if (this->parent)
+ shown_flag = 1;
+ Show ();
+ if (this->parent)
+ UpwardsSubsetChildren (this->parent);
+ }
+
+ void
+ Zoom (BPoint o, float w, float h)
+ {
+ struct haiku_zoom_event rq;
+ rq.window = this;
+
+ rq.x = o.x;
+ rq.y = o.y;
+
+ rq.width = w + 1;
+ rq.height = h + 1;
+
+ if (fullscreen_p)
+ MakeFullscreen (0);
+
+ if (o.x != x_before_zoom ||
+ o.y != y_before_zoom)
+ {
+ x_before_zoom = Frame ().left;
+ y_before_zoom = Frame ().top;
+ pre_zoom_rect = Frame ();
+ zoomed_p = 1;
+ haiku_write (ZOOM_EVENT, &rq);
+ }
+ else
+ {
+ zoomed_p = 0;
+ x_before_zoom = y_before_zoom = INT_MIN;
+ }
+
+ BDirectWindow::Zoom (o, w, h);
+ }
+
+ void
+ UnZoom (void)
+ {
+ if (!zoomed_p)
+ return;
+ zoomed_p = 0;
+
+ EmacsMoveTo (pre_zoom_rect.left, pre_zoom_rect.top);
+ ResizeTo (pre_zoom_rect.Width (),
+ pre_zoom_rect.Height ());
+ }
+
+ void
+ GetParentWidthHeight (int *width, int *height)
+ {
+ if (parent)
+ {
+ *width = parent->Frame ().Width ();
+ *height = parent->Frame ().Height ();
+ }
+ else
+ {
+ BScreen s (this);
+ *width = s.Frame ().Width ();
+ *height = s.Frame ().Height ();
+ }
+ }
+
+ void
+ OffsetChildRect (BRect *r, EmacsWindow *c)
+ {
+ for (struct child_frame *f; f; f = f->next)
+ if (f->window == c)
+ {
+ r->top -= f->yoff;
+ r->bottom -= f->yoff;
+ r->left -= f->xoff;
+ r->right -= f->xoff;
+ return;
+ }
+
+ gui_abort ("Trying to calculate offsets for a child frame that doesn't exist");
+ }
+
+ void
+ MakeFullscreen (int make_fullscreen_p)
+ {
+ BScreen screen (this);
+
+ if (!screen.IsValid ())
+ gui_abort ("Trying to make a window fullscreen without a screen");
+
+ if (make_fullscreen_p == fullscreen_p)
+ return;
+
+ fullscreen_p = make_fullscreen_p;
+ uint32 flags = Flags ();
+ if (fullscreen_p)
+ {
+ if (zoomed_p)
+ UnZoom ();
+
+ flags |= B_NOT_MOVABLE | B_NOT_ZOOMABLE;
+ pre_fullscreen_rect = Frame ();
+ if (parent)
+ parent->OffsetChildRect (&pre_fullscreen_rect, this);
+
+ int w, h;
+ EmacsMoveTo (0, 0);
+ GetParentWidthHeight (&w, &h);
+ ResizeTo (w, h);
+ }
+ else
+ {
+ flags &= ~(B_NOT_MOVABLE | B_NOT_ZOOMABLE);
+ EmacsMoveTo (pre_fullscreen_rect.left,
+ pre_fullscreen_rect.top);
+ ResizeTo (pre_fullscreen_rect.Width (),
+ pre_fullscreen_rect.Height ());
+ }
+ SetFlags (flags);
+ }
+};
+
+class EmacsMenuBar : public BMenuBar
+{
+public:
+ EmacsMenuBar () : BMenuBar (BRect (0, 0, 0, 0), NULL)
+ {
+ }
+
+ void
+ FrameResized (float newWidth, float newHeight)
+ {
+ struct haiku_menu_bar_resize_event rq;
+ rq.window = this->Window ();
+ rq.height = std::lrint (newHeight);
+ rq.width = std::lrint (newWidth);
+
+ haiku_write (MENU_BAR_RESIZE, &rq);
+ BMenuBar::FrameResized (newWidth, newHeight);
+ }
+};
+
+class EmacsView : public BView
+{
+public:
+ uint32_t visible_bell_color = 0;
+ uint32_t previous_buttons = 0;
+ int looper_locked_count = 0;
+ BRegion sb_region;
+
+ BView *offscreen_draw_view = NULL;
+ BBitmap *offscreen_draw_bitmap_1 = NULL;
+ BBitmap *copy_bitmap = NULL;
+
+#ifdef USE_BE_CAIRO
+ cairo_surface_t *cr_surface = NULL;
+ BLocker cr_surface_lock;
+#endif
+
+ BPoint tt_absl_pos;
+
+ color_space cspace;
+
+ EmacsView () : BView (BRect (0, 0, 0, 0), "Emacs", B_FOLLOW_NONE, B_WILL_DRAW)
+ {
+
+ }
+
+ ~EmacsView ()
+ {
+ TearDownDoubleBuffering ();
+ }
+
+ void
+ AttachedToWindow (void)
+ {
+ cspace = B_RGBA32;
+ }
+
+#ifdef USE_BE_CAIRO
+ void
+ DetachCairoSurface (void)
+ {
+ if (!cr_surface_lock.Lock ())
+ gui_abort ("Could not lock cr surface during detachment");
+ if (!cr_surface)
+ gui_abort ("Trying to detach window cr surface when none exists");
+ cairo_surface_destroy (cr_surface);
+ cr_surface = NULL;
+ cr_surface_lock.Unlock ();
+ }
+
+ void
+ AttachCairoSurface (void)
+ {
+ if (!cr_surface_lock.Lock ())
+ gui_abort ("Could not lock cr surface during attachment");
+ if (cr_surface)
+ gui_abort ("Trying to attach cr surface when one already exists");
+ cr_surface = cairo_image_surface_create_for_data
+ ((unsigned char *) offscreen_draw_bitmap_1->Bits (),
+ CAIRO_FORMAT_ARGB32, offscreen_draw_bitmap_1->Bounds ().Width (),
+ offscreen_draw_bitmap_1->Bounds ().Height (),
+ offscreen_draw_bitmap_1->BytesPerRow ());
+ if (!cr_surface)
+ gui_abort ("Cr surface allocation failed for double-buffered view");
+ cr_surface_lock.Unlock ();
+ }
+#endif
+
+ void
+ TearDownDoubleBuffering (void)
+ {
+ if (offscreen_draw_view)
+ {
+ if (Window ())
+ ClearViewBitmap ();
+ if (copy_bitmap)
+ {
+ delete copy_bitmap;
+ copy_bitmap = NULL;
+ }
+ if (!looper_locked_count)
+ if (!offscreen_draw_view->LockLooper ())
+ gui_abort ("Failed to lock offscreen draw view");
+#ifdef USE_BE_CAIRO
+ if (cr_surface)
+ DetachCairoSurface ();
+#endif
+ offscreen_draw_view->RemoveSelf ();
+ delete offscreen_draw_view;
+ offscreen_draw_view = NULL;
+ delete offscreen_draw_bitmap_1;
+ offscreen_draw_bitmap_1 = NULL;
+ }
+ }
+
+ void
+ AfterResize (void)
+ {
+ if (offscreen_draw_view)
+ {
+ if (!LockLooper ())
+ gui_abort ("Failed to lock looper after resize");
+
+ if (!offscreen_draw_view->LockLooper ())
+ gui_abort ("Failed to lock offscreen draw view after resize");
+#ifdef USE_BE_CAIRO
+ DetachCairoSurface ();
+#endif
+ offscreen_draw_view->RemoveSelf ();
+ delete offscreen_draw_bitmap_1;
+ offscreen_draw_bitmap_1 = new BBitmap (Frame (), cspace, 1);
+ if (offscreen_draw_bitmap_1->InitCheck () != B_OK)
+ gui_abort ("Offscreen draw bitmap initialization failed");
+
+ offscreen_draw_view->MoveTo (Frame ().left, Frame ().top);
+ offscreen_draw_view->ResizeTo (Frame ().Width (), Frame ().Height ());
+ offscreen_draw_bitmap_1->AddChild (offscreen_draw_view);
+#ifdef USE_BE_CAIRO
+ AttachCairoSurface ();
+#endif
+
+ if (looper_locked_count)
+ {
+ offscreen_draw_bitmap_1->Lock ();
+ }
+
+ UnlockLooper ();
+ }
+ }
+
+ void
+ Pulse (void)
+ {
+ visible_bell_color = 0;
+ SetFlags (Flags () & ~B_PULSE_NEEDED);
+ Window ()->SetPulseRate (0);
+ Invalidate ();
+ }
+
+ void
+ Draw (BRect expose_bounds)
+ {
+ struct haiku_expose_event rq;
+ EmacsWindow *w = (EmacsWindow *) Window ();
+
+ if (visible_bell_color > 0)
+ {
+ PushState ();
+ BView_SetHighColorForVisibleBell (this, visible_bell_color);
+ FillRect (Frame ());
+ PopState ();
+ return;
+ }
+
+ if (w->shown_flag)
+ {
+ PushState ();
+ SetDrawingMode (B_OP_ERASE);
+ FillRect (Frame ());
+ PopState ();
+ return;
+ }
+
+ if (!offscreen_draw_view)
+ {
+ if (sb_region.Contains (std::lrint (expose_bounds.left),
+ std::lrint (expose_bounds.top)) &&
+ sb_region.Contains (std::lrint (expose_bounds.right),
+ std::lrint (expose_bounds.top)) &&
+ sb_region.Contains (std::lrint (expose_bounds.left),
+ std::lrint (expose_bounds.bottom)) &&
+ sb_region.Contains (std::lrint (expose_bounds.right),
+ std::lrint (expose_bounds.bottom)))
+ return;
+
+ rq.x = std::floor (expose_bounds.left);
+ rq.y = std::floor (expose_bounds.top);
+ rq.width = std::ceil (expose_bounds.right - expose_bounds.left + 1);
+ rq.height = std::ceil (expose_bounds.bottom - expose_bounds.top + 1);
+ if (!rq.width)
+ rq.width = 1;
+ if (!rq.height)
+ rq.height = 1;
+ rq.window = this->Window ();
+
+ haiku_write (FRAME_EXPOSED, &rq);
+ }
+ }
+
+ void
+ DoVisibleBell (uint32_t color)
+ {
+ if (!LockLooper ())
+ gui_abort ("Failed to lock looper during visible bell");
+ visible_bell_color = color | (255 << 24);
+ SetFlags (Flags () | B_PULSE_NEEDED);
+ Window ()->SetPulseRate (100 * 1000);
+ Invalidate ();
+ UnlockLooper ();
+ }
+
+ void
+ FlipBuffers (void)
+ {
+ if (!LockLooper ())
+ gui_abort ("Failed to lock looper during buffer flip");
+ if (!offscreen_draw_view)
+ gui_abort ("Failed to lock offscreen view during buffer flip");
+
+ offscreen_draw_view->Flush ();
+ offscreen_draw_view->Sync ();
+
+ EmacsWindow *w = (EmacsWindow *) Window ();
+ w->shown_flag = 0;
+
+ if (copy_bitmap &&
+ copy_bitmap->Bounds () != offscreen_draw_bitmap_1->Bounds ())
+ {
+ delete copy_bitmap;
+ copy_bitmap = NULL;
+ }
+ if (!copy_bitmap)
+ copy_bitmap = new BBitmap (offscreen_draw_bitmap_1);
+ else
+ copy_bitmap->ImportBits (offscreen_draw_bitmap_1);
+
+ if (copy_bitmap->InitCheck () != B_OK)
+ gui_abort ("Failed to init copy bitmap during buffer flip");
+
+ SetViewBitmap (copy_bitmap,
+ Frame (), Frame (), B_FOLLOW_NONE, 0);
+
+ Invalidate ();
+ UnlockLooper ();
+ return;
+ }
+
+ void
+ SetUpDoubleBuffering (void)
+ {
+ if (!LockLooper ())
+ gui_abort ("Failed to lock self setting up double buffering");
+ if (offscreen_draw_view)
+ gui_abort ("Failed to lock offscreen view setting up double buffering");
+
+ offscreen_draw_bitmap_1 = new BBitmap (Frame (), cspace, 1);
+ if (offscreen_draw_bitmap_1->InitCheck () != B_OK)
+ gui_abort ("Failed to init offscreen bitmap");
+#ifdef USE_BE_CAIRO
+ AttachCairoSurface ();
+#endif
+ offscreen_draw_view = new BView (Frame (), NULL, B_FOLLOW_NONE, B_WILL_DRAW);
+ offscreen_draw_bitmap_1->AddChild (offscreen_draw_view);
+
+ if (looper_locked_count)
+ {
+ if (!offscreen_draw_bitmap_1->Lock ())
+ gui_abort ("Failed to lock bitmap after double buffering was set up.");
+ }
+
+ UnlockLooper ();
+ Invalidate ();
+ }
+
+ void
+ MouseMoved (BPoint point, uint32 transit, const BMessage *msg)
+ {
+ struct haiku_mouse_motion_event rq;
+
+ rq.just_exited_p = transit == B_EXITED_VIEW;
+ rq.x = point.x;
+ rq.y = point.y;
+ rq.be_code = transit;
+ rq.window = this->Window ();
+
+ if (ToolTip ())
+ ToolTip ()->SetMouseRelativeLocation (BPoint (-(point.x - tt_absl_pos.x),
+ -(point.y - tt_absl_pos.y)));
+
+ haiku_write (MOUSE_MOTION, &rq);
+ }
+
+ void
+ MouseDown (BPoint point)
+ {
+ struct haiku_button_event rq;
+ uint32 buttons;
+
+ this->GetMouse (&point, &buttons, false);
+
+ rq.window = this->Window ();
+ rq.btn_no = 0;
+
+ if (!(previous_buttons & B_PRIMARY_MOUSE_BUTTON) &&
+ (buttons & B_PRIMARY_MOUSE_BUTTON))
+ rq.btn_no = 0;
+ else if (!(previous_buttons & B_SECONDARY_MOUSE_BUTTON) &&
+ (buttons & B_SECONDARY_MOUSE_BUTTON))
+ rq.btn_no = 2;
+ else if (!(previous_buttons & B_TERTIARY_MOUSE_BUTTON) &&
+ (buttons & B_TERTIARY_MOUSE_BUTTON))
+ rq.btn_no = 1;
+ previous_buttons = buttons;
+
+ rq.x = point.x;
+ rq.y = point.y;
+
+ uint32_t mods = modifiers ();
+
+ rq.modifiers = 0;
+ if (mods & B_SHIFT_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_SHIFT;
+
+ if (mods & B_CONTROL_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_CTRL;
+
+ if (mods & B_COMMAND_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_ALT;
+
+ if (mods & B_OPTION_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_SUPER;
+
+ SetMouseEventMask (B_POINTER_EVENTS, B_LOCK_WINDOW_FOCUS);
+
+ haiku_write (BUTTON_DOWN, &rq);
+ }
+
+ void
+ MouseUp (BPoint point)
+ {
+ struct haiku_button_event rq;
+ uint32 buttons;
+
+ this->GetMouse (&point, &buttons, false);
+
+ rq.window = this->Window ();
+ rq.btn_no = 0;
+
+ if ((previous_buttons & B_PRIMARY_MOUSE_BUTTON)
+ && !(buttons & B_PRIMARY_MOUSE_BUTTON))
+ rq.btn_no = 0;
+ else if ((previous_buttons & B_SECONDARY_MOUSE_BUTTON)
+ && !(buttons & B_SECONDARY_MOUSE_BUTTON))
+ rq.btn_no = 2;
+ else if ((previous_buttons & B_TERTIARY_MOUSE_BUTTON)
+ && !(buttons & B_TERTIARY_MOUSE_BUTTON))
+ rq.btn_no = 1;
+ previous_buttons = buttons;
+
+ rq.x = point.x;
+ rq.y = point.y;
+
+ uint32_t mods = modifiers ();
+
+ rq.modifiers = 0;
+ if (mods & B_SHIFT_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_SHIFT;
+
+ if (mods & B_CONTROL_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_CTRL;
+
+ if (mods & B_COMMAND_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_ALT;
+
+ if (mods & B_OPTION_KEY)
+ rq.modifiers |= HAIKU_MODIFIER_SUPER;
+
+ if (!buttons)
+ SetMouseEventMask (0, 0);
+
+ haiku_write (BUTTON_UP, &rq);
+ }
+};
+
+class EmacsScrollBar : public BScrollBar
+{
+public:
+ void *scroll_bar;
+
+ EmacsScrollBar (int x, int y, int x1, int y1, bool horizontal_p) :
+ BScrollBar (BRect (x, y, x1, y1), NULL, NULL, 0, 0, horizontal_p ?
+ B_HORIZONTAL : B_VERTICAL)
+ {
+ BView *vw = (BView *) this;
+ vw->SetResizingMode (B_FOLLOW_NONE);
+ }
+
+ void
+ MessageReceived (BMessage *msg)
+ {
+ if (msg->what == SCROLL_BAR_UPDATE)
+ {
+ this->SetRange (0, msg->GetInt32 ("emacs:range", 0));
+ this->SetValue (msg->GetInt32 ("emacs:units", 0));
+ }
+
+ BScrollBar::MessageReceived (msg);
+ }
+
+ void
+ ValueChanged (float new_value)
+ {
+ struct haiku_scroll_bar_value_event rq;
+ rq.scroll_bar = scroll_bar;
+ rq.position = new_value;
+
+ haiku_write (SCROLL_BAR_VALUE_EVENT, &rq);
+ }
+
+ void
+ MouseDown (BPoint pt)
+ {
+ struct haiku_scroll_bar_drag_event rq;
+ rq.dragging_p = 1;
+ rq.scroll_bar = scroll_bar;
+
+ haiku_write (SCROLL_BAR_DRAG_EVENT, &rq);
+ BScrollBar::MouseDown (pt);
+ }
+
+ void
+ MouseUp (BPoint pt)
+ {
+ struct haiku_scroll_bar_drag_event rq;
+ rq.dragging_p = 0;
+ rq.scroll_bar = scroll_bar;
+
+ haiku_write (SCROLL_BAR_DRAG_EVENT, &rq);
+ BScrollBar::MouseUp (pt);
+ }
+};
+
+class EmacsTitleMenuItem : public BMenuItem
+{
+public:
+ EmacsTitleMenuItem (const char *str) : BMenuItem (str, NULL)
+ {
+ SetEnabled (0);
+ }
+
+ void
+ DrawContent (void)
+ {
+ BMenu *menu = Menu ();
+
+ menu->PushState ();
+ menu->SetFont (be_bold_font);
+ BView_SetHighColorForVisibleBell (menu, 0);
+ BMenuItem::DrawContent ();
+ menu->PopState ();
+ }
+};
+
+class EmacsMenuItem : public BMenuItem
+{
+public:
+ int menu_bar_id = -1;
+ void *wind_ptr = NULL;
+ char *key = NULL;
+ char *help = NULL;
+
+ EmacsMenuItem (const char *ky,
+ const char *str,
+ const char *help,
+ BMessage *message = NULL) : BMenuItem (str, message)
+ {
+ if (ky)
+ {
+ key = strdup (ky);
+ if (!key)
+ gui_abort ("strdup failed");
+ }
+
+ if (help)
+ {
+ this->help = strdup (help);
+ if (!this->help)
+ gui_abort ("strdup failed");
+ }
+ }
+
+ ~EmacsMenuItem ()
+ {
+ if (key)
+ free (key);
+ if (help)
+ free (help);
+ }
+
+ void
+ DrawContent (void)
+ {
+ BMenu *menu = Menu ();
+
+ BMenuItem::DrawContent ();
+
+ if (key)
+ {
+ BRect r = menu->Frame ();
+ int w = menu->StringWidth (key);
+ menu->MovePenTo (BPoint (r.Width () - w - 4,
+ menu->PenLocation ().y));
+ menu->DrawString (key);
+ }
+ }
+
+ void
+ GetContentSize (float *w, float *h)
+ {
+ BMenuItem::GetContentSize (w, h);
+ if (Menu () && key)
+ *w += 4 + Menu ()->StringWidth (key);
+ }
+
+ void
+ Highlight (bool highlight_p)
+ {
+ struct haiku_menu_bar_help_event rq;
+
+ if (menu_bar_id >= 0)
+ {
+ rq.window = wind_ptr;
+ rq.mb_idx = highlight_p ? menu_bar_id : -1;
+
+ haiku_write (MENU_BAR_HELP_EVENT, &rq);
+ }
+ else if (help)
+ {
+ Menu ()->SetToolTip (highlight_p ? help : NULL);
+ }
+
+ BMenuItem::Highlight (highlight_p);
+ }
+};
+
+class EmacsPopUpMenu : public BPopUpMenu
+{
+public:
+ EmacsPopUpMenu (const char *name) : BPopUpMenu (name, 0)
+ {
+
+ }
+
+ void
+ FrameResized (float w, float h)
+ {
+ Invalidate ();
+ BPopUpMenu::FrameResized (w, h);
+ }
+};
+
+static int32
+start_running_application (void *data)
+{
+ haiku_io_init_in_app_thread ();
+
+ if (!((Emacs *) data)->Lock ())
+ gui_abort ("Failed to lock application");
+
+ ((Emacs *) data)->Run ();
+ ((Emacs *) data)->Unlock ();
+ return 0;
+}
+
+/* Take BITMAP, a reference to a BBitmap, and return a pointer to its
+ data. */
+void *
+BBitmap_data (void *bitmap)
+{
+ return ((BBitmap *) bitmap)->Bits ();
+}
+
+/* Convert bitmap if required, placing the new bitmap in NEW_BITMAP,
+ and return non-null if bitmap was successfully converted. Bitmaps
+ should be freed with `BBitmap_free'. */
+int
+BBitmap_convert (void *_bitmap, void **new_bitmap)
+{
+ BBitmap *bitmap = (BBitmap *) _bitmap;
+ if (bitmap->ColorSpace () == B_RGBA32)
+ return -1;
+ BRect bounds = bitmap->Bounds ();
+ BBitmap *bmp = new (std::nothrow) BBitmap (bounds, B_RGBA32);
+ if (!bmp || bmp->InitCheck () != B_OK)
+ {
+ if (bmp)
+ delete bmp;
+ return 0;
+ }
+ if (bmp->ImportBits (bitmap) != B_OK)
+ {
+ delete bmp;
+ return 0;
+ }
+ *(BBitmap **) new_bitmap = bmp;
+ return 1;
+}
+
+void
+BBitmap_free (void *bitmap)
+{
+ delete (BBitmap *) bitmap;
+}
+
+/* Create new bitmap in RGB32 format, or in GRAY1 if MONO_P is
+ non-zero. */
+void *
+BBitmap_new (int width, int height, int mono_p)
+{
+ BBitmap *bn = new (std::nothrow) BBitmap (BRect (0, 0, width - 1, height - 1),
+ mono_p ? B_GRAY1 : B_RGB32);
+
+ return bn->InitCheck () == B_OK ? (void *) bn : (void *) (delete bn, NULL);
+}
+
+void
+BBitmap_dimensions (void *bitmap, int *left, int *top,
+ int *right, int *bottom,
+ int32_t *bytes_per_row, int *mono_p)
+{
+ BRect rect = ((BBitmap *) bitmap)->Bounds ();
+ *left = rect.left;
+ *top = rect.top;
+ *right = rect.right;
+ *bottom = rect.bottom;
+
+ *bytes_per_row = ((BBitmap *) bitmap)->BytesPerRow ();
+ *mono_p = (((BBitmap *) bitmap)->ColorSpace () == B_GRAY1);
+}
+
+/* Set up an application and return it. If starting the application
+ thread fails, abort Emacs. */
+void *
+BApplication_setup (void)
+{
+ if (be_app)
+ return be_app;
+ thread_id id;
+ Emacs *app;
+
+ app = new Emacs;
+ app->Unlock ();
+ if ((id = spawn_thread (start_running_application, "Emacs app thread",
+ B_DEFAULT_MEDIA_PRIORITY, app)) < 0)
+ gui_abort ("spawn_thread failed");
+
+ resume_thread (id);
+
+ app_thread = id;
+ return app;
+}
+
+/* Set up and return a window with its view put in VIEW. */
+void *
+BWindow_new (void *_view)
+{
+ BWindow *window = new (std::nothrow) EmacsWindow;
+ BView **v = (BView **) _view;
+ if (!window)
+ {
+ *v = NULL;
+ return window;
+ }
+
+ BView *vw = new (std::nothrow) EmacsView;
+ if (!vw)
+ {
+ *v = NULL;
+ window->Lock ();
+ window->Quit ();
+ return NULL;
+ }
+ window->AddChild (vw);
+ *v = vw;
+ return window;
+}
+
+void
+BWindow_quit (void *window)
+{
+ ((BWindow *) window)->Lock ();
+ ((BWindow *) window)->Quit ();
+}
+
+/* Set WINDOW's offset to X, Y. */
+void
+BWindow_set_offset (void *window, int x, int y)
+{
+ BWindow *wn = (BWindow *) window;
+ EmacsWindow *w = dynamic_cast<EmacsWindow *> (wn);
+ if (w)
+ {
+ if (!w->LockLooper ())
+ gui_abort ("Failed to lock window looper setting offset");
+ w->EmacsMoveTo (x, y);
+ w->UnlockLooper ();
+ }
+ else
+ wn->MoveTo (x, y);
+}
+
+/* Iconify WINDOW. */
+void
+BWindow_iconify (void *window)
+{
+ if (((BWindow *) window)->IsHidden ())
+ BWindow_set_visible (window, true);
+ ((BWindow *) window)->Minimize (true);
+}
+
+/* Show or hide WINDOW. */
+void
+BWindow_set_visible (void *window, int visible_p)
+{
+ EmacsWindow *win = (EmacsWindow *) window;
+ if (visible_p)
+ {
+ if (win->IsMinimized ())
+ win->Minimize (false);
+ win->EmacsShow ();
+ }
+ else if (!win->IsHidden ())
+ {
+ if (win->IsMinimized ())
+ win->Minimize (false);
+ win->EmacsHide ();
+ }
+ win->Sync ();
+}
+
+/* Change the title of WINDOW to the multibyte string TITLE. */
+void
+BWindow_retitle (void *window, const char *title)
+{
+ ((BWindow *) window)->SetTitle (title);
+}
+
+/* Resize WINDOW to WIDTH by HEIGHT. */
+void
+BWindow_resize (void *window, int width, int height)
+{
+ ((BWindow *) window)->ResizeTo (width, height);
+}
+
+/* Activate WINDOW, making it the subject of keyboard focus and
+ bringing it to the front of the screen. */
+void
+BWindow_activate (void *window)
+{
+ ((BWindow *) window)->Activate ();
+}
+
+/* Return the pixel dimensions of the main screen in WIDTH and
+ HEIGHT. */
+void
+BScreen_px_dim (int *width, int *height)
+{
+ BScreen screen;
+ if (!screen.IsValid ())
+ gui_abort ("Invalid screen");
+ BRect frame = screen.Frame ();
+
+ *width = frame.right - frame.left;
+ *height = frame.bottom - frame.top;
+}
+
+/* Resize VIEW to WIDTH, HEIGHT. */
+void
+BView_resize_to (void *view, int width, int height)
+{
+ EmacsView *vw = (EmacsView *) view;
+ if (!vw->LockLooper ())
+ gui_abort ("Failed to lock view for resize");
+ vw->ResizeTo (width, height);
+ vw->AfterResize ();
+ vw->UnlockLooper ();
+}
+
+void *
+BCursor_create_default (void)
+{
+ return new BCursor (B_CURSOR_ID_SYSTEM_DEFAULT);
+}
+
+void *
+BCursor_create_modeline (void)
+{
+ return new BCursor (B_CURSOR_ID_CONTEXT_MENU);
+}
+
+void *
+BCursor_from_id (enum haiku_cursor cursor)
+{
+ return new BCursor ((enum BCursorID) cursor);
+}
+
+void *
+BCursor_create_i_beam (void)
+{
+ return new BCursor (B_CURSOR_ID_I_BEAM);
+}
+
+void *
+BCursor_create_progress_cursor (void)
+{
+ return new BCursor (B_CURSOR_ID_PROGRESS);
+}
+
+void *
+BCursor_create_grab (void)
+{
+ return new BCursor (B_CURSOR_ID_GRAB);
+}
+
+void
+BCursor_delete (void *cursor)
+{
+ delete (BCursor *) cursor;
+}
+
+void
+BView_set_view_cursor (void *view, void *cursor)
+{
+ if (!((BView *) view)->LockLooper ())
+ gui_abort ("Failed to lock view setting cursor");
+ ((BView *) view)->SetViewCursor ((BCursor *) cursor);
+ ((BView *) view)->UnlockLooper ();
+}
+
+void
+BWindow_Flush (void *window)
+{
+ ((BWindow *) window)->Flush ();
+}
+
+/* Map the keycode KC, storing the result in CODE and 1 in
+ NON_ASCII_P if it should be used. */
+void
+BMapKey (uint32_t kc, int *non_ascii_p, unsigned *code)
+{
+ if (*code == 10 && kc != 0x42)
+ {
+ *code = XK_Return;
+ *non_ascii_p = 1;
+ return;
+ }
+
+ switch (kc)
+ {
+ default:
+ *non_ascii_p = 0;
+ if (kc < 0xe && kc > 0x1)
+ {
+ *code = XK_F1 + kc - 2;
+ *non_ascii_p = 1;
+ }
+ return;
+ case 0x1e:
+ *code = XK_BackSpace;
+ break;
+ case 0x61:
+ *code = XK_Left;
+ break;
+ case 0x63:
+ *code = XK_Right;
+ break;
+ case 0x57:
+ *code = XK_Up;
+ break;
+ case 0x62:
+ *code = XK_Down;
+ break;
+ case 0x64:
+ *code = XK_Insert;
+ break;
+ case 0x65:
+ *code = XK_Delete;
+ break;
+ case 0x37:
+ *code = XK_Home;
+ break;
+ case 0x58:
+ *code = XK_End;
+ break;
+ case 0x39:
+ *code = XK_Page_Up;
+ break;
+ case 0x5a:
+ *code = XK_Page_Down;
+ break;
+ case 0x1:
+ *code = XK_Escape;
+ break;
+ case 0x68:
+ *code = XK_Menu;
+ break;
+ }
+ *non_ascii_p = 1;
+}
+
+/* Make a scrollbar, attach it to VIEW's window, and return it. */
+void *
+BScrollBar_make_for_view (void *view, int horizontal_p,
+ int x, int y, int x1, int y1,
+ void *scroll_bar_ptr)
+{
+ EmacsScrollBar *sb = new EmacsScrollBar (x, y, x1, y1, horizontal_p);
+ sb->scroll_bar = scroll_bar_ptr;
+
+ BView *vw = (BView *) view;
+ BView *sv = (BView *) sb;
+ if (!vw->LockLooper ())
+ gui_abort ("Failed to lock scrollbar owner");
+ vw->AddChild ((BView *) sb);
+ sv->WindowActivated (vw->Window ()->IsActive ());
+ vw->UnlockLooper ();
+ return sb;
+}
+
+void
+BScrollBar_delete (void *sb)
+{
+ BView *view = (BView *) sb;
+ BView *pr = view->Parent ();
+
+ if (!pr->LockLooper ())
+ gui_abort ("Failed to lock scrollbar parent");
+ pr->RemoveChild (view);
+ pr->UnlockLooper ();
+
+ delete (EmacsScrollBar *) sb;
+}
+
+void
+BView_move_frame (void *view, int x, int y, int x1, int y1)
+{
+ BView *vw = (BView *) view;
+
+ if (!vw->LockLooper ())
+ gui_abort ("Failed to lock view moving frame");
+ vw->MoveTo (x, y);
+ vw->ResizeTo (x1 - x, y1 - y);
+ vw->Flush ();
+ vw->Sync ();
+ vw->UnlockLooper ();
+}
+
+void
+BView_scroll_bar_update (void *sb, int portion, int whole, int position)
+{
+ BScrollBar *bar = (BScrollBar *) sb;
+ BMessage msg = BMessage (SCROLL_BAR_UPDATE);
+ BMessenger mr = BMessenger (bar);
+ msg.AddInt32 ("emacs:range", whole);
+ msg.AddInt32 ("emacs:units", position);
+
+ mr.SendMessage (&msg);
+}
+
+/* Return the default scrollbar size. */
+int
+BScrollBar_default_size (int horizontal_p)
+{
+ return horizontal_p ? B_H_SCROLL_BAR_HEIGHT : B_V_SCROLL_BAR_WIDTH;
+}
+
+/* Invalidate VIEW, causing it to be drawn again. */
+void
+BView_invalidate (void *view)
+{
+ BView *vw = (BView *) view;
+ if (!vw->LockLooper ())
+ gui_abort ("Couldn't lock view while invalidating it");
+ vw->Invalidate ();
+ vw->UnlockLooper ();
+}
+
+/* Lock VIEW in preparation for drawing operations. This should be
+ called before any attempt to draw onto VIEW or to lock it for Cairo
+ drawing. `BView_draw_unlock' should be called afterwards. */
+void
+BView_draw_lock (void *view)
+{
+ EmacsView *vw = (EmacsView *) view;
+ if (vw->looper_locked_count)
+ {
+ vw->looper_locked_count++;
+ return;
+ }
+ BView *v = (BView *) find_appropriate_view_for_draw (vw);
+ if (v != vw)
+ {
+ if (!vw->offscreen_draw_bitmap_1->Lock ())
+ gui_abort ("Failed to lock offscreen bitmap while acquiring draw lock");
+ }
+ else if (!v->LockLooper ())
+ gui_abort ("Failed to lock draw view while acquiring draw lock");
+
+ if (v != vw && !vw->LockLooper ())
+ gui_abort ("Failed to lock view while acquiring draw lock");
+ vw->looper_locked_count++;
+}
+
+void
+BView_draw_unlock (void *view)
+{
+ EmacsView *vw = (EmacsView *) view;
+ if (--vw->looper_locked_count)
+ return;
+
+ BView *v = (BView *) find_appropriate_view_for_draw (view);
+ if (v == vw)
+ vw->UnlockLooper ();
+ else
+ {
+ vw->offscreen_draw_bitmap_1->Unlock ();
+ vw->UnlockLooper ();
+ }
+}
+
+void
+BWindow_center_on_screen (void *window)
+{
+ BWindow *w = (BWindow *) window;
+ w->CenterOnScreen ();
+}
+
+/* Tell VIEW it has been clicked at X by Y. */
+void
+BView_mouse_down (void *view, int x, int y)
+{
+ BView *vw = (BView *) view;
+ if (vw->LockLooper ())
+ {
+ vw->MouseDown (BPoint (x, y));
+ vw->UnlockLooper ();
+ }
+}
+
+/* Tell VIEW the mouse has been released at X by Y. */
+void
+BView_mouse_up (void *view, int x, int y)
+{
+ BView *vw = (BView *) view;
+ if (vw->LockLooper ())
+ {
+ vw->MouseUp (BPoint (x, y));
+ vw->UnlockLooper ();
+ }
+}
+
+/* Tell VIEW that the mouse has moved to Y by Y. */
+void
+BView_mouse_moved (void *view, int x, int y, uint32_t transit)
+{
+ BView *vw = (BView *) view;
+ if (vw->LockLooper ())
+ {
+ vw->MouseMoved (BPoint (x, y), transit, NULL);
+ vw->UnlockLooper ();
+ }
+}
+
+/* Import BITS into BITMAP using the B_GRAY1 colorspace. */
+void
+BBitmap_import_mono_bits (void *bitmap, void *bits, int wd, int h)
+{
+ BBitmap *bmp = (BBitmap *) bitmap;
+ unsigned char *data = (unsigned char *) bmp->Bits ();
+ unsigned short *bts = (unsigned short *) bits;
+
+ for (int i = 0; i < (h * (wd / 8)); i++)
+ {
+ *((unsigned short *) data) = bts[i];
+ data += bmp->BytesPerRow ();
+ }
+}
+
+/* Make a scrollbar at X, Y known to the view VIEW. */
+void
+BView_publish_scroll_bar (void *view, int x, int y, int width, int height)
+{
+ EmacsView *vw = (EmacsView *) view;
+ if (vw->LockLooper ())
+ {
+ vw->sb_region.Include (BRect (x, y, x - 1 + width,
+ y - 1 + height));
+ vw->UnlockLooper ();
+ }
+}
+
+void
+BView_forget_scroll_bar (void *view, int x, int y, int width, int height)
+{
+ EmacsView *vw = (EmacsView *) view;
+ if (vw->LockLooper ())
+ {
+ vw->sb_region.Exclude (BRect (x, y, x - 1 + width,
+ y - 1 + height));
+ vw->UnlockLooper ();
+ }
+}
+
+void
+BView_get_mouse (void *view, int *x, int *y)
+{
+ BPoint l;
+ BView *vw = (BView *) view;
+ if (!vw->LockLooper ())
+ gui_abort ("Failed to lock view in BView_get_mouse");
+ vw->GetMouse (&l, NULL, 1);
+ vw->UnlockLooper ();
+
+ *x = std::lrint (l.x);
+ *y = std::lrint (l.y);
+}
+
+/* Perform an in-place conversion of X and Y from VIEW's coordinate
+ system to its screen's coordinate system. */
+void
+BView_convert_to_screen (void *view, int *x, int *y)
+{
+ BPoint l = BPoint (*x, *y);
+ BView *vw = (BView *) view;
+ if (!vw->LockLooper ())
+ gui_abort ("Failed to lock view in convert_to_screen");
+ vw->ConvertToScreen (&l);
+ vw->UnlockLooper ();
+
+ *x = std::lrint (l.x);
+ *y = std::lrint (l.y);
+}
+
+void
+BView_convert_from_screen (void *view, int *x, int *y)
+{
+ BPoint l = BPoint (*x, *y);
+ BView *vw = (BView *) view;
+ if (!vw->LockLooper ())
+ gui_abort ("Failed to lock view in convert_from_screen");
+ vw->ConvertFromScreen (&l);
+ vw->UnlockLooper ();
+
+ *x = std::lrint (l.x);
+ *y = std::lrint (l.y);
+}
+
+/* Decorate or undecorate WINDOW depending on DECORATE_P. */
+void
+BWindow_change_decoration (void *window, int decorate_p)
+{
+ BWindow *w = (BWindow *) window;
+ if (!w->LockLooper ())
+ gui_abort ("Failed to lock window while changing its decorations");
+ if (decorate_p)
+ w->SetLook (B_TITLED_WINDOW_LOOK);
+ else
+ w->SetLook (B_NO_BORDER_WINDOW_LOOK);
+ w->UnlockLooper ();
+}
+
+/* Decorate WINDOW appropriately for use as a tooltip. */
+void
+BWindow_set_tooltip_decoration (void *window)
+{
+ BWindow *w = (BWindow *) window;
+ if (!w->LockLooper ())
+ gui_abort ("Failed to lock window while setting ttip decoration");
+ w->SetLook (B_BORDERED_WINDOW_LOOK);
+ w->SetFeel (B_FLOATING_APP_WINDOW_FEEL);
+ w->UnlockLooper ();
+}
+
+/* Set B_AVOID_FOCUS on WINDOW if AVOID_FOCUS_P is non-nil, or clear
+ it otherwise. */
+void
+BWindow_set_avoid_focus (void *window, int avoid_focus_p)
+{
+ BWindow *w = (BWindow *) window;
+ if (!w->LockLooper ())
+ gui_abort ("Failed to lock window while setting avoid focus");
+
+ if (!avoid_focus_p)
+ w->SetFlags (w->Flags () & ~B_AVOID_FOCUS);
+ else
+ w->SetFlags (w->Flags () | B_AVOID_FOCUS);
+ w->Sync ();
+ w->UnlockLooper ();
+}
+
+void
+BView_emacs_delete (void *view)
+{
+ EmacsView *vw = (EmacsView *) view;
+ if (!vw->LockLooper ())
+ gui_abort ("Failed to lock view while deleting it");
+ vw->RemoveSelf ();
+ delete vw;
+}
+
+/* Return the current workspace. */
+uint32_t
+haiku_current_workspace (void)
+{
+ return current_workspace ();
+}
+
+/* Return a bitmask consisting of workspaces WINDOW is on. */
+uint32_t
+BWindow_workspaces (void *window)
+{
+ return ((BWindow *) window)->Workspaces ();
+}
+
+/* Create a popup menu. */
+void *
+BPopUpMenu_new (const char *name)
+{
+ BPopUpMenu *menu = new EmacsPopUpMenu (name);
+ menu->SetRadioMode (0);
+ return menu;
+}
+
+/* Add a title item to MENU. These items cannot be highlighted or
+ triggered, and their labels will display as bold text. */
+void
+BMenu_add_title (void *menu, const char *text)
+{
+ EmacsTitleMenuItem *it = new EmacsTitleMenuItem (text);
+ BMenu *mn = (BMenu *) menu;
+ mn->AddItem (it);
+}
+
+/* Add an item to the menu MENU. */
+void
+BMenu_add_item (void *menu, const char *label, void *ptr, bool enabled_p,
+ bool marked_p, bool mbar_p, void *mbw_ptr, const char *key,
+ const char *help)
+{
+ BMenu *m = (BMenu *) menu;
+ BMessage *msg;
+ if (ptr)
+ msg = new BMessage ();
+ EmacsMenuItem *it = new EmacsMenuItem (key, label, help, ptr ? msg : NULL);
+ it->SetTarget (m->Window ());
+ it->SetEnabled (enabled_p);
+ it->SetMarked (marked_p);
+ if (mbar_p)
+ {
+ it->menu_bar_id = (intptr_t) ptr;
+ it->wind_ptr = mbw_ptr;
+ }
+ if (ptr)
+ msg->AddPointer ("menuptr", ptr);
+ m->AddItem (it);
+}
+
+/* Add a separator to the menu MENU. */
+void
+BMenu_add_separator (void *menu)
+{
+ BMenu *m = (BMenu *) menu;
+
+ m->AddSeparatorItem ();
+}
+
+/* Create a submenu and attach it to MENU. */
+void *
+BMenu_new_submenu (void *menu, const char *label, bool enabled_p)
+{
+ BMenu *m = (BMenu *) menu;
+ BMenu *mn = new BMenu (label, B_ITEMS_IN_COLUMN);
+ mn->SetRadioMode (0);
+ BMenuItem *i = new BMenuItem (mn);
+ i->SetEnabled (enabled_p);
+ m->AddItem (i);
+ return mn;
+}
+
+/* Create a submenu that notifies Emacs upon opening. */
+void *
+BMenu_new_menu_bar_submenu (void *menu, const char *label)
+{
+ BMenu *m = (BMenu *) menu;
+ BMenu *mn = new BMenu (label, B_ITEMS_IN_COLUMN);
+ mn->SetRadioMode (0);
+ BMenuItem *i = new BMenuItem (mn);
+ i->SetEnabled (1);
+ m->AddItem (i);
+ return mn;
+}
+
+/* Run MENU, waiting for it to close, and return a pointer to the
+ data of the selected item (if one exists), or NULL. X, Y should
+ be in the screen coordinate system. */
+void *
+BMenu_run (void *menu, int x, int y)
+{
+ BPopUpMenu *mn = (BPopUpMenu *) menu;
+ mn->SetRadioMode (0);
+ BMenuItem *it = mn->Go (BPoint (x, y));
+ if (it)
+ {
+ BMessage *mg = it->Message ();
+ if (mg)
+ return (void *) mg->GetPointer ("menuptr");
+ else
+ return NULL;
+ }
+ return NULL;
+}
+
+/* Delete the entire menu hierarchy of MENU, and then delete MENU
+ itself. */
+void
+BPopUpMenu_delete (void *menu)
+{
+ delete (BPopUpMenu *) menu;
+}
+
+/* Create a menubar, attach it to VIEW, and return it. */
+void *
+BMenuBar_new (void *view)
+{
+ BView *vw = (BView *) view;
+ EmacsMenuBar *bar = new EmacsMenuBar ();
+
+ if (!vw->LockLooper ())
+ gui_abort ("Failed to lock menu bar parent");
+ vw->AddChild ((BView *) bar);
+ vw->UnlockLooper ();
+
+ return bar;
+}
+
+/* Delete MENUBAR along with all subitems. */
+void
+BMenuBar_delete (void *menubar)
+{
+ BView *vw = (BView *) menubar;
+ BView *p = vw->Parent ();
+ if (!p->LockLooper ())
+ gui_abort ("Failed to lock menu bar parent while removing menubar");
+ vw->RemoveSelf ();
+ p->UnlockLooper ();
+ delete vw;
+}
+
+/* Delete all items from MENU. */
+void
+BMenu_delete_all (void *menu)
+{
+ BMenu *mn = (BMenu *) menu;
+ mn->RemoveItems (0, mn->CountItems (), true);
+}
+
+/* Delete COUNT items from MENU starting from START. */
+void
+BMenu_delete_from (void *menu, int start, int count)
+{
+ BMenu *mn = (BMenu *) menu;
+ mn->RemoveItems (start, count, true);
+}
+
+/* Count items in menu MENU. */
+int
+BMenu_count_items (void *menu)
+{
+ return ((BMenu *) menu)->CountItems ();
+}
+
+/* Find the item in MENU at IDX. */
+void *
+BMenu_item_at (void *menu, int idx)
+{
+ return ((BMenu *) menu)->ItemAt (idx);
+}
+
+/* Set ITEM's label to LABEL. */
+void
+BMenu_item_set_label (void *item, const char *label)
+{
+ ((BMenuItem *) item)->SetLabel (label);
+}
+
+/* Get ITEM's menu. */
+void *
+BMenu_item_get_menu (void *item)
+{
+ return ((BMenuItem *) item)->Submenu ();
+}
+
+/* Emit a beep noise. */
+void
+haiku_ring_bell (void)
+{
+ beep ();
+}
+
+/* Create a BAlert with TEXT. */
+void *
+BAlert_new (const char *text, enum haiku_alert_type type)
+{
+ return new BAlert (NULL, text, NULL, NULL, NULL, B_WIDTH_AS_USUAL,
+ (enum alert_type) type);
+}
+
+/* Add a button to ALERT and return the button. */
+void *
+BAlert_add_button (void *alert, const char *text)
+{
+ BAlert *al = (BAlert *) alert;
+ al->AddButton (text);
+ return al->ButtonAt (al->CountButtons () - 1);
+}
+
+/* Run ALERT, returning the number of the button that was selected,
+ or -1 if no button was selected before the alert was closed. */
+int32_t
+BAlert_go (void *alert)
+{
+ return ((BAlert *) alert)->Go ();
+}
+
+/* Enable or disable BUTTON depending on ENABLED_P. */
+void
+BButton_set_enabled (void *button, int enabled_p)
+{
+ ((BButton *) button)->SetEnabled (enabled_p);
+}
+
+/* Set VIEW's tooltip to TOOLTIP. */
+void
+BView_set_tooltip (void *view, const char *tooltip)
+{
+ ((BView *) view)->SetToolTip (tooltip);
+}
+
+/* Set VIEW's tooltip to a sticky tooltip at X by Y. */
+void
+BView_set_and_show_sticky_tooltip (void *view, const char *tooltip,
+ int x, int y)
+{
+ BToolTip *tip;
+ BView *vw = (BView *) view;
+ if (!vw->LockLooper ())
+ gui_abort ("Failed to lock view while showing sticky tooltip");
+ vw->SetToolTip (tooltip);
+ tip = vw->ToolTip ();
+ BPoint pt;
+ EmacsView *ev = dynamic_cast<EmacsView *> (vw);
+ if (ev)
+ ev->tt_absl_pos = BPoint (x, y);
+
+ vw->GetMouse (&pt, NULL, 1);
+ pt.x -= x;
+ pt.y -= y;
+
+ pt.x = -pt.x;
+ pt.y = -pt.y;
+
+ tip->SetMouseRelativeLocation (pt);
+ tip->SetSticky (1);
+ vw->ShowToolTip (tip);
+ vw->UnlockLooper ();
+}
+
+/* Delete ALERT. */
+void
+BAlert_delete (void *alert)
+{
+ delete (BAlert *) alert;
+}
+
+/* Place the resolution of the monitor in DPI in RSSX and RSSY. */
+void
+BScreen_res (double *rrsx, double *rrsy)
+{
+ BScreen s (B_MAIN_SCREEN_ID);
+ if (!s.IsValid ())
+ gui_abort ("Invalid screen for resolution checks");
+ monitor_info i;
+
+ if (s.GetMonitorInfo (&i) == B_OK)
+ {
+ *rrsx = (double) i.width / (double) 2.54;
+ *rrsy = (double) i.height / (double) 2.54;
+ }
+ else
+ {
+ *rrsx = 72.27;
+ *rrsy = 72.27;
+ }
+}
+
+/* Add WINDOW to OTHER_WINDOW's subset and parent it to
+ OTHER_WINDOW. */
+void
+EmacsWindow_parent_to (void *window, void *other_window)
+{
+ EmacsWindow *w = (EmacsWindow *) window;
+ if (!w->LockLooper ())
+ gui_abort ("Failed to lock window while parenting");
+ w->ParentTo ((EmacsWindow *) other_window);
+ w->UnlockLooper ();
+}
+
+void
+EmacsWindow_unparent (void *window)
+{
+ EmacsWindow *w = (EmacsWindow *) window;
+ if (!w->LockLooper ())
+ gui_abort ("Failed to lock window while unparenting");
+ w->UnparentAndUnlink ();
+ w->UnlockLooper ();
+}
+
+/* Place text describing the current version of Haiku in VERSION,
+ which should be a buffer LEN bytes wide. */
+void
+be_get_version_string (char *version, int len)
+{
+ std::strncpy (version, "Unknown Haiku release", len - 1);
+ BPath path;
+ if (find_directory (B_BEOS_LIB_DIRECTORY, &path) == B_OK)
+ {
+ path.Append ("libbe.so");
+
+ BAppFileInfo appFileInfo;
+ version_info versionInfo;
+ BFile file;
+ if (file.SetTo (path.Path (), B_READ_ONLY) == B_OK
+ && appFileInfo.SetTo (&file) == B_OK
+ && appFileInfo.GetVersionInfo (&versionInfo,
+ B_APP_VERSION_KIND) == B_OK
+ && versionInfo.short_info[0] != '\0')
+ std::strncpy (version, versionInfo.short_info, len - 1);
+ }
+}
+
+/* Return the amount of color planes in the current display. */
+int
+be_get_display_planes (void)
+{
+ color_space space = dpy_color_space;
+ if (space == B_NO_COLOR_SPACE)
+ {
+ BScreen screen; /* This is actually a very slow operation. */
+ if (!screen.IsValid ())
+ gui_abort ("Invalid screen");
+ space = dpy_color_space = screen.ColorSpace ();
+ }
+
+ if (space == B_RGB32 || space == B_RGB24)
+ return 24;
+ if (space == B_RGB16)
+ return 16;
+ if (space == B_RGB15)
+ return 15;
+ if (space == B_CMAP8)
+ return 8;
+
+ gui_abort ("Bad colorspace for screen");
+ /* https://www.haiku-os.org/docs/api/classBScreen.html
+ says a valid screen can't be anything else. */
+ return -1;
+}
+
+/* Return the amount of colors the display can handle. */
+int
+be_get_display_color_cells (void)
+{
+ color_space space = dpy_color_space;
+ if (space == B_NO_COLOR_SPACE)
+ {
+ BScreen screen;
+ if (!screen.IsValid ())
+ gui_abort ("Invalid screen");
+ space = dpy_color_space = screen.ColorSpace ();
+ }
+
+ if (space == B_RGB32 || space == B_RGB24)
+ return 1677216;
+ if (space == B_RGB16)
+ return 65536;
+ if (space == B_RGB15)
+ return 32768;
+ if (space == B_CMAP8)
+ return 256;
+
+ gui_abort ("Bad colorspace for screen");
+ return -1;
+}
+
+/* Warp the pointer to X by Y. */
+void
+be_warp_pointer (int x, int y)
+{
+ /* We're not supposed to use the following function without a
+ BWindowScreen object, but in Haiku nothing actually prevents us
+ from doing so. */
+
+ set_mouse_position (x, y);
+}
+
+/* Update the position of CHILD in WINDOW without actually moving
+ it. */
+void
+EmacsWindow_move_weak_child (void *window, void *child, int xoff, int yoff)
+{
+ EmacsWindow *w = (EmacsWindow *) window;
+ EmacsWindow *c = (EmacsWindow *) child;
+
+ if (!w->LockLooper ())
+ gui_abort ("Couldn't lock window for weak move");
+ w->MoveChild (c, xoff, yoff, 1);
+ w->UnlockLooper ();
+}
+
+/* Find an appropriate view to draw onto. If VW is double-buffered,
+ this will be the view used for double buffering instead of VW
+ itself. */
+void *
+find_appropriate_view_for_draw (void *vw)
+{
+ BView *v = (BView *) vw;
+ EmacsView *ev = dynamic_cast<EmacsView *>(v);
+ if (!ev)
+ return v;
+
+ return ev->offscreen_draw_view ? ev->offscreen_draw_view : vw;
+}
+
+/* Set up double buffering for VW. */
+void
+EmacsView_set_up_double_buffering (void *vw)
+{
+ EmacsView *view = (EmacsView *) vw;
+ if (!view->LockLooper ())
+ gui_abort ("Couldn't lock view while setting up double buffering");
+ if (view->offscreen_draw_view)
+ {
+ view->UnlockLooper ();
+ return;
+ }
+ view->SetUpDoubleBuffering ();
+ view->UnlockLooper ();
+}
+
+/* Flip and invalidate the view VW. */
+void
+EmacsView_flip_and_blit (void *vw)
+{
+ EmacsView *view = (EmacsView *) vw;
+ if (!view->offscreen_draw_view)
+ return;
+ if (!view->LockLooper ())
+ gui_abort ("Couldn't lock view in flip_and_blit");
+ view->FlipBuffers ();
+ view->UnlockLooper ();
+}
+
+/* Disable double buffering for VW. */
+void
+EmacsView_disable_double_buffering (void *vw)
+{
+ EmacsView *view = (EmacsView *) vw;
+ if (!view->LockLooper ())
+ gui_abort ("Couldn't lock view tearing down double buffering");
+ view->TearDownDoubleBuffering ();
+ view->UnlockLooper ();
+}
+
+/* Return non-0 if VW is double-buffered. */
+int
+EmacsView_double_buffered_p (void *vw)
+{
+ EmacsView *view = (EmacsView *) vw;
+ if (!view->LockLooper ())
+ gui_abort ("Couldn't lock view testing double buffering status");
+ int db_p = !!view->offscreen_draw_view;
+ view->UnlockLooper ();
+ return db_p;
+}
+
+struct popup_file_dialog_data
+{
+ BMessage *msg;
+ BFilePanel *panel;
+ BEntry *entry;
+};
+
+static void
+unwind_popup_file_dialog (void *ptr)
+{
+ struct popup_file_dialog_data *data =
+ (struct popup_file_dialog_data *) ptr;
+ BFilePanel *panel = data->panel;
+ delete panel;
+ delete data->entry;
+ delete data->msg;
+}
+
+static void
+be_popup_file_dialog_safe_set_target (BFilePanel *dialog, BWindow *window)
+{
+ dialog->SetTarget (BMessenger (window));
+}
+
+/* Popup a file dialog. */
+char *
+be_popup_file_dialog (int open_p, const char *default_dir, int must_match_p, int dir_only_p,
+ void *window, const char *save_text, const char *prompt,
+ void (*block_input_function) (void),
+ void (*unblock_input_function) (void))
+{
+ ptrdiff_t idx = c_specpdl_idx_from_cxx ();
+ /* setjmp/longjmp is UB with automatic objects. */
+ block_input_function ();
+ BWindow *w = (BWindow *) window;
+ uint32_t mode = dir_only_p ? B_DIRECTORY_NODE : B_FILE_NODE | B_DIRECTORY_NODE;
+ BEntry *path = new BEntry;
+ BMessage *msg = new BMessage ('FPSE');
+ BFilePanel *panel = new BFilePanel (open_p ? B_OPEN_PANEL : B_SAVE_PANEL,
+ NULL, NULL, mode);
+ unblock_input_function ();
+
+ struct popup_file_dialog_data dat;
+ dat.entry = path;
+ dat.msg = msg;
+ dat.panel = panel;
+
+ record_c_unwind_protect_from_cxx (unwind_popup_file_dialog, &dat);
+ if (default_dir)
+ {
+ if (path->SetTo (default_dir, 0) != B_OK)
+ default_dir = NULL;
+ }
+
+ panel->SetMessage (msg);
+ if (default_dir)
+ panel->SetPanelDirectory (path);
+ if (save_text)
+ panel->SetSaveText (save_text);
+ panel->SetHideWhenDone (0);
+ panel->Window ()->SetTitle (prompt);
+ be_popup_file_dialog_safe_set_target (panel, w);
+
+ panel->Show ();
+ panel->Window ()->Show ();
+
+ void *buf = alloca (200);
+ while (1)
+ {
+ enum haiku_event_type type;
+ char *ptr = NULL;
+
+ if (!haiku_read_with_timeout (&type, buf, 200, 100000))
+ {
+ if (type != FILE_PANEL_EVENT)
+ haiku_write (type, buf);
+ else if (!ptr)
+ ptr = (char *) ((struct haiku_file_panel_event *) buf)->ptr;
+ }
+
+ ssize_t b_s;
+ haiku_read_size (&b_s);
+ if (!b_s || b_s == -1 || ptr || panel->Window ()->IsHidden ())
+ {
+ c_unbind_to_nil_from_cxx (idx);
+ return ptr;
+ }
+ }
+}
+
+void
+be_app_quit (void)
+{
+ if (be_app)
+ {
+ while (!be_app->Lock ());
+ be_app->Quit ();
+ }
+}
+
+/* Temporarily fill VIEW with COLOR. */
+void
+EmacsView_do_visible_bell (void *view, uint32_t color)
+{
+ EmacsView *vw = (EmacsView *) view;
+ vw->DoVisibleBell (color);
+}
+
+/* Zoom WINDOW. */
+void
+BWindow_zoom (void *window)
+{
+ BWindow *w = (BWindow *) window;
+ w->Zoom ();
+}
+
+/* Make WINDOW fullscreen if FULLSCREEN_P. */
+void
+EmacsWindow_make_fullscreen (void *window, int fullscreen_p)
+{
+ EmacsWindow *w = (EmacsWindow *) window;
+ w->MakeFullscreen (fullscreen_p);
+}
+
+/* Unzoom (maximize) WINDOW. */
+void
+EmacsWindow_unzoom (void *window)
+{
+ EmacsWindow *w = (EmacsWindow *) window;
+ w->UnZoom ();
+}
+
+/* Move the pointer into MBAR and start tracking. */
+void
+BMenuBar_start_tracking (void *mbar)
+{
+ EmacsMenuBar *mb = (EmacsMenuBar *) mbar;
+ if (!mb->LockLooper ())
+ gui_abort ("Couldn't lock menubar");
+ BRect frame = mb->Frame ();
+ BPoint pt = frame.LeftTop ();
+ BPoint l = pt;
+ mb->Parent ()->ConvertToScreen (&pt);
+ set_mouse_position (pt.x, pt.y);
+ mb->MouseDown (l);
+ mb->UnlockLooper ();
+}
+
+#ifdef HAVE_NATIVE_IMAGE_API
+int
+be_can_translate_type_to_bitmap_p (const char *mime)
+{
+ BTranslatorRoster *r = BTranslatorRoster::Default ();
+ translator_id *ids;
+ int32 id_len;
+
+ if (r->GetAllTranslators (&ids, &id_len) != B_OK)
+ return 0;
+
+ int found_in = 0;
+ int found_out = 0;
+
+ for (int i = 0; i < id_len; ++i)
+ {
+ found_in = 0;
+ found_out = 0;
+ const translation_format *i_fmts;
+ const translation_format *o_fmts;
+
+ int32 i_count, o_count;
+
+ if (r->GetInputFormats (ids[i], &i_fmts, &i_count) != B_OK)
+ continue;
+
+ if (r->GetOutputFormats (ids[i], &o_fmts, &o_count) != B_OK)
+ continue;
+
+ for (int x = 0; x < i_count; ++x)
+ {
+ if (!strcmp (i_fmts[x].MIME, mime))
+ {
+ found_in = 1;
+ break;
+ }
+ }
+
+ for (int x = 0; x < i_count; ++x)
+ {
+ if (!strcmp (o_fmts[x].MIME, "image/x-be-bitmap") ||
+ !strcmp (o_fmts[x].MIME, "image/x-vnd.Be-bitmap"))
+ {
+ found_out = 1;
+ break;
+ }
+ }
+
+ if (found_in && found_out)
+ break;
+ }
+
+ delete [] ids;
+
+ return found_in && found_out;
+}
+
+void *
+be_translate_bitmap_from_file_name (const char *filename)
+{
+ BBitmap *bm = BTranslationUtils::GetBitmap (filename);
+ return bm;
+}
+
+void *
+be_translate_bitmap_from_memory (const void *buf, size_t bytes)
+{
+ BMemoryIO io (buf, bytes);
+ BBitmap *bm = BTranslationUtils::GetBitmap (&io);
+ return bm;
+}
+#endif
+
+/* Return the size of BITMAP's data, in bytes. */
+size_t
+BBitmap_bytes_length (void *bitmap)
+{
+ BBitmap *bm = (BBitmap *) bitmap;
+ return bm->BitsLength ();
+}
+
+/* Show VIEW's tooltip. */
+void
+BView_show_tooltip (void *view)
+{
+ BView *vw = (BView *) view;
+ if (vw->LockLooper ())
+ {
+ vw->ShowToolTip (vw->ToolTip ());
+ vw->UnlockLooper ();
+ }
+}
+
+
+#ifdef USE_BE_CAIRO
+/* Return VIEW's cairo surface. */
+cairo_surface_t *
+EmacsView_cairo_surface (void *view)
+{
+ EmacsView *vw = (EmacsView *) view;
+ EmacsWindow *wn = (EmacsWindow *) vw->Window ();
+ return vw->cr_surface ? vw->cr_surface : wn->cr_surface;
+}
+
+/* Transfer each clip rectangle in VIEW to the cairo context
+ CTX. */
+void
+BView_cr_dump_clipping (void *view, cairo_t *ctx)
+{
+ BView *vw = (BView *) find_appropriate_view_for_draw (view);
+ BRegion cr;
+ vw->GetClippingRegion (&cr);
+
+ for (int i = 0; i < cr.CountRects (); ++i)
+ {
+ BRect r = cr.RectAt (i);
+ cairo_rectangle (ctx, r.left, r.top, r.Width () + 1,
+ r.Height () + 1);
+ }
+
+ cairo_clip (ctx);
+}
+
+/* Lock WINDOW in preparation for drawing using Cairo. */
+void
+EmacsWindow_begin_cr_critical_section (void *window)
+{
+ EmacsWindow *w = (EmacsWindow *) window;
+ if (!w->surface_lock.Lock ())
+ gui_abort ("Couldn't lock cairo surface");
+
+ BView *vw = (BView *) w->FindView ("Emacs");
+ EmacsView *ev = dynamic_cast <EmacsView *> (vw);
+ if (ev && !ev->cr_surface_lock.Lock ())
+ gui_abort ("Couldn't lock view cairo surface");
+}
+
+/* Unlock WINDOW in preparation for drawing using Cairo. */
+void
+EmacsWindow_end_cr_critical_section (void *window)
+{
+ EmacsWindow *w = (EmacsWindow *) window;
+ w->surface_lock.Unlock ();
+ BView *vw = (BView *) w->FindView ("Emacs");
+ EmacsView *ev = dynamic_cast <EmacsView *> (vw);
+ if (ev)
+ ev->cr_surface_lock.Unlock ();
+}
+#endif
+
+/* Get the width of STR in the plain font. */
+int
+be_string_width_with_plain_font (const char *str)
+{
+ return be_plain_font->StringWidth (str);
+}
+
+/* Get the ascent + descent of the plain font. */
+int
+be_plain_font_height (void)
+{
+ struct font_height fheight;
+ be_plain_font->GetHeight (&fheight);
+
+ return fheight.ascent + fheight.descent;
+}
+
+/* Return the number of physical displays connected. */
+int
+be_get_display_screens (void)
+{
+ int count = 1;
+ BScreen scr;
+
+ if (!scr.IsValid ())
+ gui_abort ("Main screen vanished!");
+ while (scr.SetToNext () == B_OK && scr.IsValid ())
+ ++count;
+
+ return count;
+}
+
+/* Set the minimum width the user can resize WINDOW to. */
+void
+BWindow_set_min_size (void *window, int width, int height)
+{
+ BWindow *w = (BWindow *) window;
+
+ if (!w->LockLooper ())
+ gui_abort ("Failed to lock window looper setting min size");
+ w->SetSizeLimits (width, -1, height, -1);
+ w->UnlockLooper ();
+}
+
+/* Set the alignment of WINDOW's dimensions. */
+void
+BWindow_set_size_alignment (void *window, int align_width, int align_height)
+{
+ BWindow *w = (BWindow *) window;
+
+ if (!w->LockLooper ())
+ gui_abort ("Failed to lock window looper setting alignment");
+#if 0 /* Haiku does not currently implement SetWindowAlignment. */
+ if (w->SetWindowAlignment (B_PIXEL_ALIGNMENT, -1, -1, align_width,
+ align_width, -1, -1, align_height,
+ align_height) != B_NO_ERROR)
+ gui_abort ("Invalid pixel alignment");
+#endif
+ w->UnlockLooper ();
+}
diff --git a/src/haiku_support.h b/src/haiku_support.h
new file mode 100644
index 00000000000..9f5f3c77e3d
--- /dev/null
+++ b/src/haiku_support.h
@@ -0,0 +1,869 @@
+/* Haiku window system support. Hey Emacs, this is -*- C++ -*-
+ Copyright (C) 2021 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 _HAIKU_SUPPORT_H
+#define _HAIKU_SUPPORT_H
+
+#include <stdint.h>
+
+#ifdef HAVE_FREETYPE
+#include <ft2build.h>
+#include <fontconfig/fontconfig.h>
+#include FT_FREETYPE_H
+#include FT_SIZES_H
+#endif
+
+#ifdef USE_BE_CAIRO
+#include <cairo.h>
+#endif
+
+enum haiku_cursor
+ {
+ CURSOR_ID_NO_CURSOR = 12,
+ CURSOR_ID_RESIZE_NORTH = 15,
+ CURSOR_ID_RESIZE_EAST = 16,
+ CURSOR_ID_RESIZE_SOUTH = 17,
+ CURSOR_ID_RESIZE_WEST = 18,
+ CURSOR_ID_RESIZE_NORTH_EAST = 19,
+ CURSOR_ID_RESIZE_NORTH_WEST = 20,
+ CURSOR_ID_RESIZE_SOUTH_EAST = 21,
+ CURSOR_ID_RESIZE_SOUTH_WEST = 22,
+ CURSOR_ID_RESIZE_NORTH_SOUTH = 23,
+ CURSOR_ID_RESIZE_EAST_WEST = 24,
+ CURSOR_ID_RESIZE_NORTH_EAST_SOUTH_WEST = 25,
+ CURSOR_ID_RESIZE_NORTH_WEST_SOUTH_EAST = 26
+ };
+
+enum haiku_alert_type
+ {
+ HAIKU_EMPTY_ALERT = 0,
+ HAIKU_INFO_ALERT,
+ HAIKU_IDEA_ALERT,
+ HAIKU_WARNING_ALERT,
+ HAIKU_STOP_ALERT
+ };
+
+enum haiku_event_type
+ {
+ QUIT_REQUESTED,
+ FRAME_RESIZED,
+ FRAME_EXPOSED,
+ KEY_DOWN,
+ KEY_UP,
+ ACTIVATION,
+ MOUSE_MOTION,
+ BUTTON_DOWN,
+ BUTTON_UP,
+ ICONIFICATION,
+ MOVE_EVENT,
+ SCROLL_BAR_VALUE_EVENT,
+ SCROLL_BAR_DRAG_EVENT,
+ WHEEL_MOVE_EVENT,
+ MENU_BAR_RESIZE,
+ MENU_BAR_OPEN,
+ MENU_BAR_SELECT_EVENT,
+ MENU_BAR_CLOSE,
+ FILE_PANEL_EVENT,
+ MENU_BAR_HELP_EVENT,
+ ZOOM_EVENT,
+ REFS_EVENT,
+ APP_QUIT_REQUESTED_EVENT
+ };
+
+struct haiku_quit_requested_event
+{
+ void *window;
+};
+
+struct haiku_resize_event
+{
+ void *window;
+ float px_heightf;
+ float px_widthf;
+};
+
+struct haiku_expose_event
+{
+ void *window;
+ int x;
+ int y;
+ int width;
+ int height;
+};
+
+struct haiku_refs_event
+{
+ void *window;
+ int x, y;
+ /* Free this with free! */
+ char *ref;
+};
+
+struct haiku_app_quit_requested_event
+{
+ char dummy;
+};
+
+#define HAIKU_MODIFIER_ALT (1)
+#define HAIKU_MODIFIER_CTRL (1 << 1)
+#define HAIKU_MODIFIER_SHIFT (1 << 2)
+#define HAIKU_MODIFIER_SUPER (1 << 3)
+
+struct haiku_key_event
+{
+ void *window;
+ int modifiers;
+ uint32_t mb_char;
+ uint32_t unraw_mb_char;
+ short kc;
+};
+
+struct haiku_activation_event
+{
+ void *window;
+ int activated_p;
+};
+
+struct haiku_mouse_motion_event
+{
+ void *window;
+ bool just_exited_p;
+ int x;
+ int y;
+ uint32_t be_code;
+};
+
+struct haiku_button_event
+{
+ void *window;
+ int btn_no;
+ int modifiers;
+ int x;
+ int y;
+};
+
+struct haiku_iconification_event
+{
+ void *window;
+ int iconified_p;
+};
+
+struct haiku_move_event
+{
+ void *window;
+ int x;
+ int y;
+};
+
+struct haiku_wheel_move_event
+{
+ void *window;
+ int modifiers;
+ float delta_x;
+ float delta_y;
+};
+
+struct haiku_menu_bar_select_event
+{
+ void *window;
+ void *ptr;
+};
+
+struct haiku_file_panel_event
+{
+ void *ptr;
+};
+
+struct haiku_menu_bar_help_event
+{
+ void *window;
+ int mb_idx;
+};
+
+struct haiku_zoom_event
+{
+ void *window;
+ int x;
+ int y;
+ int width;
+ int height;
+};
+
+#define FSPEC_FAMILY 1
+#define FSPEC_STYLE (1 << 1)
+#define FSPEC_SLANT (1 << 2)
+#define FSPEC_WEIGHT (1 << 3)
+#define FSPEC_SPACING (1 << 4)
+#define FSPEC_WANTED (1 << 5)
+#define FSPEC_NEED_ONE_OF (1 << 6)
+#define FSPEC_WIDTH (1 << 7)
+#define FSPEC_LANGUAGE (1 << 8)
+
+typedef char haiku_font_family_or_style[64];
+
+enum haiku_font_slant
+ {
+ NO_SLANT = -1,
+ SLANT_OBLIQUE,
+ SLANT_REGULAR,
+ SLANT_ITALIC
+ };
+
+enum haiku_font_width
+ {
+ NO_WIDTH = -1,
+ ULTRA_CONDENSED,
+ EXTRA_CONDENSED,
+ CONDENSED,
+ SEMI_CONDENSED,
+ NORMAL_WIDTH,
+ SEMI_EXPANDED,
+ EXPANDED,
+ EXTRA_EXPANDED,
+ ULTRA_EXPANDED
+ };
+
+enum haiku_font_language
+ {
+ LANGUAGE_CN,
+ LANGUAGE_KO,
+ LANGUAGE_JP,
+ MAX_LANGUAGE /* This isn't a language. */
+ };
+
+struct haiku_font_pattern
+{
+ int specified;
+ struct haiku_font_pattern *next;
+ /* The next two fields are only temporarily used during the font
+ discovery process! Do not rely on them being correct outside
+ BFont_find. */
+ struct haiku_font_pattern *last;
+ struct haiku_font_pattern *next_family;
+ haiku_font_family_or_style family;
+ haiku_font_family_or_style style;
+ int weight;
+ int mono_spacing_p;
+ int want_chars_len;
+ int need_one_of_len;
+ enum haiku_font_slant slant;
+ enum haiku_font_width width;
+ enum haiku_font_language language;
+ uint32_t *wanted_chars;
+ uint32_t *need_one_of;
+
+ int oblique_seen_p;
+};
+
+struct haiku_scroll_bar_value_event
+{
+ void *scroll_bar;
+ int position;
+};
+
+struct haiku_scroll_bar_drag_event
+{
+ void *scroll_bar;
+ int dragging_p;
+};
+
+struct haiku_menu_bar_resize_event
+{
+ void *window;
+ int width;
+ int height;
+};
+
+struct haiku_menu_bar_state_event
+{
+ void *window;
+};
+
+#define HAIKU_THIN 0
+#define HAIKU_ULTRALIGHT 20
+#define HAIKU_EXTRALIGHT 40
+#define HAIKU_LIGHT 50
+#define HAIKU_SEMI_LIGHT 75
+#define HAIKU_REGULAR 100
+#define HAIKU_SEMI_BOLD 180
+#define HAIKU_BOLD 200
+#define HAIKU_EXTRA_BOLD 205
+#define HAIKU_ULTRA_BOLD 210
+#define HAIKU_BOOK 400
+#define HAIKU_HEAVY 800
+#define HAIKU_ULTRA_HEAVY 900
+#define HAIKU_BLACK 1000
+#define HAIKU_MEDIUM 2000
+
+#ifdef __cplusplus
+extern "C"
+{
+#endif
+#include <pthread.h>
+#include <OS.h>
+
+#ifdef __cplusplus
+ typedef void *haiku;
+
+ extern void
+ haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel);
+
+ extern unsigned long
+ haiku_get_pixel (haiku bitmap, int x, int y);
+#endif
+
+ extern port_id port_application_to_emacs;
+
+ extern void haiku_io_init (void);
+ extern void haiku_io_init_in_app_thread (void);
+
+ extern void
+ haiku_read_size (ssize_t *len);
+
+ extern int
+ haiku_read (enum haiku_event_type *type, void *buf, ssize_t len);
+
+ extern int
+ haiku_read_with_timeout (enum haiku_event_type *type, void *buf, ssize_t len,
+ time_t timeout);
+
+ extern int
+ haiku_write (enum haiku_event_type type, void *buf);
+
+ extern int
+ haiku_write_without_signal (enum haiku_event_type type, void *buf);
+
+ extern void
+ rgb_color_hsl (uint32_t rgb, double *h, double *s, double *l);
+
+ extern void
+ hsl_color_rgb (double h, double s, double l, uint32_t *rgb);
+
+ extern void *
+ BBitmap_new (int width, int height, int mono_p);
+
+ extern void *
+ BBitmap_data (void *bitmap);
+
+ extern int
+ BBitmap_convert (void *bitmap, void **new_bitmap);
+
+ extern void
+ BBitmap_free (void *bitmap);
+
+ extern void
+ BBitmap_dimensions (void *bitmap, int *left, int *top,
+ int *right, int *bottom, int32_t *bytes_per_row,
+ int *mono_p);
+
+ extern void *
+ BApplication_setup (void);
+
+ extern void *
+ BWindow_new (void *view);
+
+ extern void
+ BWindow_quit (void *window);
+
+ extern void
+ BWindow_set_offset (void *window, int x, int y);
+
+ extern void
+ BWindow_iconify (void *window);
+
+ extern void
+ BWindow_set_visible (void *window, int visible_p);
+
+ extern void
+ BFont_close (void *font);
+
+ extern void
+ BFont_dat (void *font, int *px_size, int *min_width, int *max_width,
+ int *avg_width, int *height, int *space_width, int *ascent,
+ int *descent, int *underline_position, int *underline_thickness);
+
+ extern int
+ BFont_have_char_p (void *font, int32_t chr);
+
+ extern int
+ BFont_have_char_block (void *font, int32_t beg, int32_t end);
+
+ extern void
+ BFont_char_bounds (void *font, const char *mb_str, int *advance,
+ int *lb, int *rb);
+
+ extern void
+ BFont_nchar_bounds (void *font, const char *mb_str, int *advance,
+ int *lb, int *rb, int32_t n);
+
+ extern void
+ BWindow_retitle (void *window, const char *title);
+
+ extern void
+ BWindow_resize (void *window, int width, int height);
+
+ extern void
+ BWindow_activate (void *window);
+
+ extern void
+ BView_StartClip (void *view);
+
+ extern void
+ BView_EndClip (void *view);
+
+ extern void
+ BView_SetHighColor (void *view, uint32_t color);
+
+ extern void
+ BView_SetHighColorForVisibleBell (void *view, uint32_t color);
+
+ extern void
+ BView_FillRectangleForVisibleBell (void *view, int x, int y, int width,
+ int height);
+
+ extern void
+ BView_SetLowColor (void *view, uint32_t color);
+
+ extern void
+ BView_SetPenSize (void *view, int u);
+
+ extern void
+ BView_SetFont (void *view, void *font);
+
+ extern void
+ BView_MovePenTo (void *view, int x, int y);
+
+ extern void
+ BView_DrawString (void *view, const char *chr, ptrdiff_t len);
+
+ extern void
+ BView_DrawChar (void *view, char chr);
+
+ extern void
+ BView_FillRectangle (void *view, int x, int y, int width, int height);
+
+ extern void
+ BView_FillRectangleAbs (void *view, int x, int y, int x1, int y1);
+
+ extern void
+ BView_FillTriangle (void *view, int x1, int y1,
+ int x2, int y2, int x3, int y3);
+
+ extern void
+ BView_StrokeRectangle (void *view, int x, int y, int width, int height);
+
+ extern void
+ BView_SetViewColor (void *view, uint32_t color);
+
+ extern void
+ BView_ClipToRect (void *view, int x, int y, int width, int height);
+
+ extern void
+ BView_ClipToInverseRect (void *view, int x, int y, int width, int height);
+
+ extern void
+ BView_StrokeLine (void *view, int sx, int sy, int tx, int ty);
+
+ extern void
+ BView_CopyBits (void *view, int x, int y, int width, int height,
+ int tox, int toy, int towidth, int toheight);
+
+ extern void
+ BView_DrawBitmap (void *view, void *bitmap, int x, int y,
+ int width, int height, int vx, int vy, int vwidth,
+ int vheight);
+
+ extern void
+ BView_DrawBitmapWithEraseOp (void *view, void *bitmap, int x,
+ int y, int width, int height);
+
+ extern void
+ BView_DrawMask (void *src, void *view,
+ int x, int y, int width, int height,
+ int vx, int vy, int vwidth, int vheight,
+ uint32_t color);
+
+ extern void *
+ BBitmap_transform_bitmap (void *bitmap, void *mask, uint32_t m_color,
+ double rot, int desw, int desh);
+
+ extern void
+ BScreen_px_dim (int *width, int *height);
+
+ extern void
+ BView_resize_to (void *view, int width, int height);
+
+ /* Functions for creating and freeing cursors. */
+ extern void *
+ BCursor_create_default (void);
+
+ extern void *
+ BCursor_from_id (enum haiku_cursor cursor);
+
+ extern void *
+ BCursor_create_modeline (void);
+
+ extern void *
+ BCursor_create_i_beam (void);
+
+ extern void *
+ BCursor_create_progress_cursor (void);
+
+ extern void *
+ BCursor_create_grab (void);
+
+ extern void
+ BCursor_delete (void *cursor);
+
+ extern void
+ BView_set_view_cursor (void *view, void *cursor);
+
+ extern void
+ BWindow_Flush (void *window);
+
+ extern void
+ BMapKey (uint32_t kc, int *non_ascii_p, unsigned *code);
+
+ extern void *
+ BScrollBar_make_for_view (void *view, int horizontal_p,
+ int x, int y, int x1, int y1,
+ void *scroll_bar_ptr);
+
+ extern void
+ BScrollBar_delete (void *sb);
+
+ extern void
+ BView_move_frame (void *view, int x, int y, int x1, int y1);
+
+ extern void
+ BView_scroll_bar_update (void *sb, int portion, int whole, int position);
+
+ extern int
+ BScrollBar_default_size (int horizontal_p);
+
+ extern void
+ BView_invalidate (void *view);
+
+ extern void
+ BView_draw_lock (void *view);
+
+ extern void
+ BView_draw_unlock (void *view);
+
+ extern void
+ BWindow_center_on_screen (void *window);
+
+ extern void
+ BView_mouse_moved (void *view, int x, int y, uint32_t transit);
+
+ extern void
+ BView_mouse_down (void *view, int x, int y);
+
+ extern void
+ BView_mouse_up (void *view, int x, int y);
+
+ extern void
+ BBitmap_import_mono_bits (void *bitmap, void *bits, int wd, int h);
+
+ extern void
+ haiku_font_pattern_free (struct haiku_font_pattern *pt);
+
+ extern struct haiku_font_pattern *
+ BFont_find (struct haiku_font_pattern *pt);
+
+ extern int
+ BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size);
+
+ extern void
+ BFont_populate_fixed_family (struct haiku_font_pattern *ptn);
+
+ extern void
+ BFont_populate_plain_family (struct haiku_font_pattern *ptn);
+
+ extern void
+ BView_publish_scroll_bar (void *view, int x, int y, int width, int height);
+
+ extern void
+ BView_forget_scroll_bar (void *view, int x, int y, int width, int height);
+
+ extern void
+ BView_get_mouse (void *view, int *x, int *y);
+
+ extern void
+ BView_convert_to_screen (void *view, int *x, int *y);
+
+ extern void
+ BView_convert_from_screen (void *view, int *x, int *y);
+
+ extern void
+ BWindow_change_decoration (void *window, int decorate_p);
+
+ extern void
+ BWindow_set_tooltip_decoration (void *window);
+
+ extern void
+ BWindow_set_avoid_focus (void *window, int avoid_focus_p);
+
+ extern void
+ BView_emacs_delete (void *view);
+
+ extern uint32_t
+ haiku_current_workspace (void);
+
+ extern uint32_t
+ BWindow_workspaces (void *window);
+
+ extern void *
+ BPopUpMenu_new (const char *name);
+
+ extern void
+ BMenu_add_item (void *menu, const char *label, void *ptr, bool enabled_p,
+ bool marked_p, bool mbar_p, void *mbw_ptr, const char *key,
+ const char *help);
+
+ extern void
+ BMenu_add_separator (void *menu);
+
+ extern void *
+ BMenu_new_submenu (void *menu, const char *label, bool enabled_p);
+
+ extern void *
+ BMenu_new_menu_bar_submenu (void *menu, const char *label);
+
+ extern int
+ BMenu_count_items (void *menu);
+
+ extern void *
+ BMenu_item_at (void *menu, int idx);
+
+ extern void *
+ BMenu_run (void *menu, int x, int y);
+
+ extern void
+ BPopUpMenu_delete (void *menu);
+
+ extern void *
+ BMenuBar_new (void *view);
+
+ extern void
+ BMenu_delete_all (void *menu);
+
+ extern void
+ BMenuBar_delete (void *menubar);
+
+ extern void
+ BMenu_item_set_label (void *item, const char *label);
+
+ extern void *
+ BMenu_item_get_menu (void *item);
+
+ extern void
+ BMenu_delete_from (void *menu, int start, int count);
+
+ extern void
+ haiku_ring_bell (void);
+
+ extern void *
+ BAlert_new (const char *text, enum haiku_alert_type type);
+
+ extern void *
+ BAlert_add_button (void *alert, const char *text);
+
+ extern int32_t
+ BAlert_go (void *alert);
+
+ extern void
+ BButton_set_enabled (void *button, int enabled_p);
+
+ extern void
+ BView_set_tooltip (void *view, const char *tooltip);
+
+ extern void
+ BAlert_delete (void *alert);
+
+ extern void
+ BScreen_res (double *rrsx, double *rrsy);
+
+ extern void
+ EmacsWindow_parent_to (void *window, void *other_window);
+
+ extern void
+ EmacsWindow_unparent (void *window);
+
+ extern int
+ BFont_string_width (void *font, const char *utf8);
+
+ extern void
+ be_get_version_string (char *version, int len);
+
+ extern int
+ be_get_display_planes (void);
+
+ extern int
+ be_get_display_color_cells (void);
+
+ extern void
+ be_warp_pointer (int x, int y);
+
+ extern void
+ EmacsWindow_move_weak_child (void *window, void *child, int xoff, int yoff);
+
+ extern void
+ EmacsView_set_up_double_buffering (void *vw);
+
+ extern void
+ EmacsView_disable_double_buffering (void *vw);
+
+ extern void
+ EmacsView_flip_and_blit (void *vw);
+
+ extern int
+ EmacsView_double_buffered_p (void *vw);
+
+ extern char *
+ be_popup_file_dialog (int open_p, const char *default_dir, int must_match_p,
+ int dir_only_p, void *window, const char *save_text,
+ const char *prompt,
+ void (*block_input_function) (void),
+ void (*unblock_input_function) (void));
+
+ extern void
+ record_c_unwind_protect_from_cxx (void (*) (void *), void *);
+
+ extern ptrdiff_t
+ c_specpdl_idx_from_cxx (void);
+
+ extern void
+ c_unbind_to_nil_from_cxx (ptrdiff_t idx);
+
+ extern void
+ EmacsView_do_visible_bell (void *view, uint32_t color);
+
+ extern void
+ BWindow_zoom (void *window);
+
+ extern void
+ EmacsWindow_make_fullscreen (void *window, int fullscreen_p);
+
+ extern void
+ EmacsWindow_unzoom (void *window);
+
+#ifdef HAVE_NATIVE_IMAGE_API
+ extern int
+ be_can_translate_type_to_bitmap_p (const char *mime);
+
+ extern void *
+ be_translate_bitmap_from_file_name (const char *filename);
+
+ extern void *
+ be_translate_bitmap_from_memory (const void *buf, size_t bytes);
+#endif
+
+ extern void
+ BMenuBar_start_tracking (void *mbar);
+
+ extern size_t
+ BBitmap_bytes_length (void *bitmap);
+
+ extern void
+ BView_show_tooltip (void *view);
+
+#ifdef USE_BE_CAIRO
+ extern cairo_surface_t *
+ EmacsView_cairo_surface (void *view);
+
+ extern void
+ BView_cr_dump_clipping (void *view, cairo_t *ctx);
+
+ extern void
+ EmacsWindow_begin_cr_critical_section (void *window);
+
+ extern void
+ EmacsWindow_end_cr_critical_section (void *window);
+#endif
+
+ extern void
+ BView_set_and_show_sticky_tooltip (void *view, const char *tooltip,
+ int x, int y);
+
+ extern void
+ BMenu_add_title (void *menu, const char *text);
+
+ extern int
+ be_plain_font_height (void);
+
+ extern int
+ be_string_width_with_plain_font (const char *str);
+
+ extern int
+ be_get_display_screens (void);
+
+ extern void
+ BWindow_set_min_size (void *window, int width, int height);
+
+ extern void
+ BWindow_set_size_alignment (void *window, int align_width, int align_height);
+
+#ifdef __cplusplus
+ extern void *
+ find_appropriate_view_for_draw (void *vw);
+}
+
+extern _Noreturn void
+gui_abort (const char *msg);
+#endif /* _cplusplus */
+
+/* Borrowed from X.Org keysymdef.h */
+#define XK_BackSpace 0xff08 /* Back space, back char */
+#define XK_Tab 0xff09
+#define XK_Linefeed 0xff0a /* Linefeed, LF */
+#define XK_Clear 0xff0b
+#define XK_Return 0xff0d /* Return, enter */
+#define XK_Pause 0xff13 /* Pause, hold */
+#define XK_Scroll_Lock 0xff14
+#define XK_Sys_Req 0xff15
+#define XK_Escape 0xff1b
+#define XK_Delete 0xffff /* Delete, rubout */
+#define XK_Home 0xff50
+#define XK_Left 0xff51 /* Move left, left arrow */
+#define XK_Up 0xff52 /* Move up, up arrow */
+#define XK_Right 0xff53 /* Move right, right arrow */
+#define XK_Down 0xff54 /* Move down, down arrow */
+#define XK_Prior 0xff55 /* Prior, previous */
+#define XK_Page_Up 0xff55
+#define XK_Next 0xff56 /* Next */
+#define XK_Page_Down 0xff56
+#define XK_End 0xff57 /* EOL */
+#define XK_Begin 0xff58 /* BOL */
+#define XK_Select 0xff60 /* Select, mark */
+#define XK_Print 0xff61
+#define XK_Execute 0xff62 /* Execute, run, do */
+#define XK_Insert 0xff63 /* Insert, insert here */
+#define XK_Undo 0xff65
+#define XK_Redo 0xff66 /* Redo, again */
+#define XK_Menu 0xff67
+#define XK_Find 0xff68 /* Find, search */
+#define XK_Cancel 0xff69 /* Cancel, stop, abort, exit */
+#define XK_Help 0xff6a /* Help */
+#define XK_Break 0xff6b
+#define XK_Mode_switch 0xff7e /* Character set switch */
+#define XK_script_switch 0xff7e /* Alias for mode_switch */
+#define XK_Num_Lock 0xff7f
+#define XK_F1 0xffbe
+
+#endif /* _HAIKU_SUPPORT_H_ */
diff --git a/src/haikufns.c b/src/haikufns.c
new file mode 100644
index 00000000000..737b0338994
--- /dev/null
+++ b/src/haikufns.c
@@ -0,0 +1,2449 @@
+/* Haiku window system support
+ Copyright (C) 2021 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 "frame.h"
+#include "blockinput.h"
+#include "termchar.h"
+#include "font.h"
+#include "keyboard.h"
+#include "buffer.h"
+#include "dispextern.h"
+
+#include "haikugui.h"
+#include "haikuterm.h"
+#include "haiku_support.h"
+#include "termhooks.h"
+
+#include <stdlib.h>
+
+#include <kernel/OS.h>
+
+#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)
+
+/* The frame of the currently visible tooltip. */
+static Lisp_Object tip_frame;
+
+/* The window-system window corresponding to the frame of the
+ currently visible tooltip. */
+static Window tip_window;
+
+/* 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;
+
+static void
+haiku_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval);
+static void
+haiku_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name);
+
+static ptrdiff_t image_cache_refcount;
+
+static Lisp_Object
+get_geometry_from_preferences (struct haiku_display_info *dpyinfo,
+ Lisp_Object parms)
+{
+ struct {
+ const char *val;
+ const char *cls;
+ Lisp_Object tem;
+ } r[] = {
+ { "width", "Width", Qwidth },
+ { "height", "Height", Qheight },
+ { "left", "Left", Qleft },
+ { "top", "Top", Qtop },
+ };
+
+ int i;
+ for (i = 0; i < ARRAYELTS (r); ++i)
+ {
+ if (NILP (Fassq (r[i].tem, parms)))
+ {
+ Lisp_Object value
+ = gui_display_get_arg (dpyinfo, parms, r[i].tem, r[i].val, r[i].cls,
+ RES_TYPE_NUMBER);
+ if (! EQ (value, Qunbound))
+ parms = Fcons (Fcons (r[i].tem, value), parms);
+ }
+ }
+
+ return parms;
+}
+
+void
+haiku_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_HAIKU_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);
+
+ if (FRAME_HAIKU_WINDOW (f))
+ haiku_clear_under_internal_border (f);
+}
+
+void
+haiku_change_tab_bar_height (struct frame *f, int height)
+{
+ int unit = FRAME_LINE_HEIGHT (f);
+ int old_height = FRAME_TAB_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);
+
+ /* 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_HAIKU_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);
+ if (FRAME_HAIKU_WINDOW (f))
+ haiku_clear_under_internal_border (f);
+}
+
+static void
+haiku_set_no_focus_on_map (struct frame *f, Lisp_Object value,
+ Lisp_Object oldval)
+{
+ if (!EQ (value, oldval))
+ FRAME_NO_FOCUS_ON_MAP (f) = !NILP (value);
+}
+
+static void
+haiku_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
+{
+ if (FRAME_TOOLTIP_P (f))
+ return;
+ 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;
+
+ haiku_change_tool_bar_height (f, nlines * FRAME_LINE_HEIGHT (f));
+}
+
+static void
+haiku_set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
+{
+ if (FRAME_TOOLTIP_P (f))
+ return;
+ int olines = FRAME_TAB_BAR_LINES (f);
+ int nlines;
+
+ /* 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))
+ haiku_change_tab_bar_height (f, nlines * FRAME_LINE_HEIGHT (f));
+}
+
+
+int
+haiku_get_color (const char *name, Emacs_Color *color)
+{
+ unsigned short r16, g16, b16;
+ Lisp_Object tem;
+
+ if (parse_color_spec (name, &r16, &g16, &b16))
+ {
+ color->pixel = RGB_TO_ULONG (r16 / 256, g16 / 256, b16 / 256);
+ color->red = r16;
+ color->green = g16;
+ color->blue = b16;
+ return 0;
+ }
+ else
+ {
+ block_input ();
+ eassert (x_display_list && !NILP (x_display_list->color_map));
+ tem = x_display_list->color_map;
+ for (; CONSP (tem); tem = XCDR (tem))
+ {
+ Lisp_Object col = XCAR (tem);
+ if (CONSP (col) && !xstrcasecmp (SSDATA (XCAR (col)), name))
+ {
+ int32_t clr = XFIXNUM (XCDR (col));
+ color->pixel = clr;
+ color->red = RED_FROM_ULONG (clr) * 257;
+ color->green = GREEN_FROM_ULONG (clr) * 257;
+ color->blue = BLUE_FROM_ULONG (clr) * 257;
+ unblock_input ();
+ return 0;
+ }
+ }
+
+ unblock_input ();
+ }
+
+ return 1;
+}
+
+static struct haiku_display_info *
+haiku_display_info_for_name (Lisp_Object name)
+{
+ CHECK_STRING (name);
+
+ if (!NILP (Fstring_equal (name, build_string ("be"))))
+ {
+ if (!x_display_list)
+ return x_display_list;
+
+ error ("Be windowing not initialized");
+ }
+
+ error ("Be displays can only be named \"be\"");
+}
+
+static struct haiku_display_info *
+check_haiku_display_info (Lisp_Object object)
+{
+ struct haiku_display_info *dpyinfo = NULL;
+
+ if (NILP (object))
+ {
+ struct frame *sf = XFRAME (selected_frame);
+
+ if (FRAME_HAIKU_P (sf) && FRAME_LIVE_P (sf))
+ dpyinfo = FRAME_DISPLAY_INFO (sf);
+ else if (x_display_list)
+ dpyinfo = x_display_list;
+ else
+ error ("Be windowing not present");
+ }
+ else if (TERMINALP (object))
+ {
+ struct terminal *t = decode_live_terminal (object);
+
+ if (t->type != output_haiku)
+ error ("Terminal %d is not a Be display", t->id);
+
+ dpyinfo = t->display_info.haiku;
+ }
+ else if (STRINGP (object))
+ dpyinfo = haiku_display_info_for_name (object);
+ else
+ {
+ struct frame *f = decode_window_system_frame (object);
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+ }
+
+ return dpyinfo;
+}
+
+static void
+haiku_set_title_bar_text (struct frame *f, Lisp_Object text)
+{
+ if (FRAME_HAIKU_WINDOW (f))
+ {
+ block_input ();
+ BWindow_retitle (FRAME_HAIKU_WINDOW (f), SSDATA (ENCODE_UTF_8 (text)));
+ unblock_input ();
+ }
+}
+
+static void
+haiku_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 = 26;
+
+ fset_title (f, name);
+
+ if (NILP (name))
+ name = f->name;
+
+ haiku_set_title_bar_text (f, name);
+}
+
+static void
+haiku_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_HAIKU_WINDOW (f))
+ adjust_frame_size (f, -1, -1, 3, 0, Qchild_frame_border_width);
+
+ SET_FRAME_GARBAGED (f);
+ }
+}
+
+static void
+haiku_set_parent_frame (struct frame *f,
+ Lisp_Object new_value, Lisp_Object old_value)
+{
+ struct frame *p = NULL;
+ block_input ();
+ if (!NILP (new_value)
+ && (!FRAMEP (new_value)
+ || !FRAME_LIVE_P (p = XFRAME (new_value))
+ || !FRAME_HAIKU_P (p)))
+ {
+ store_frame_param (f, Qparent_frame, old_value);
+ unblock_input ();
+ error ("Invalid specification of `parent-frame'");
+ }
+
+ if (EQ (new_value, old_value))
+ {
+ unblock_input ();
+ return;
+ }
+
+ if (!NILP (old_value))
+ EmacsWindow_unparent (FRAME_HAIKU_WINDOW (f));
+ if (!NILP (new_value))
+ {
+ EmacsWindow_parent_to (FRAME_HAIKU_WINDOW (f),
+ FRAME_HAIKU_WINDOW (p));
+ BWindow_set_offset (FRAME_HAIKU_WINDOW (f),
+ f->left_pos, f->top_pos);
+ }
+ fset_parent_frame (f, new_value);
+ unblock_input ();
+}
+
+static void
+haiku_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ haiku_set_name (f, arg, 1);
+}
+
+static void
+haiku_set_no_accept_focus (struct frame *f, Lisp_Object new_value, Lisp_Object old_value)
+{
+ block_input ();
+ if (!EQ (new_value, old_value))
+ FRAME_NO_ACCEPT_FOCUS (f) = !NILP (new_value);
+
+ if (FRAME_HAIKU_WINDOW (f))
+ {
+ BWindow_set_avoid_focus (FRAME_HAIKU_WINDOW (f),
+ FRAME_NO_ACCEPT_FOCUS (f));
+ }
+ unblock_input ();
+}
+
+static void
+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 x_create_frame removes the unwind protect. */
+ if (!FRAME_LIVE_P (f))
+ return;
+
+ /* If frame is ``official'', nothing to do. */
+ if (NILP (Fmemq (frame, Vframe_list)))
+ {
+#if defined GLYPH_DEBUG && defined ENABLE_CHECKING
+ struct haiku_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+#endif
+
+ /* 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 free_frame_resources later,
+ 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++;
+
+ haiku_free_frame_resources (f);
+ free_glyphs (f);
+
+#if defined GLYPH_DEBUG && defined ENABLE_CHECKING
+ /* Check that reference counts are indeed correct. */
+ if (dpyinfo->terminal->image_cache)
+ eassert (dpyinfo->terminal->image_cache->refcount == image_cache_refcount);
+#endif
+ }
+}
+
+static void
+unwind_create_tip_frame (Lisp_Object frame)
+{
+ unwind_create_frame (frame);
+ tip_window = NULL;
+ tip_frame = Qnil;
+}
+
+static void
+haiku_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ struct haiku_output *output = FRAME_OUTPUT_DATA (f);
+ unsigned long old_fg;
+
+ Emacs_Color color;
+
+ if (haiku_get_color (SSDATA (arg), &color))
+ {
+ store_frame_param (f, Qforeground_color, oldval);
+ unblock_input ();
+ error ("Bad color");
+ }
+
+ old_fg = FRAME_FOREGROUND_PIXEL (f);
+ FRAME_FOREGROUND_PIXEL (f) = color.pixel;
+
+ if (FRAME_HAIKU_WINDOW (f))
+ {
+
+ block_input ();
+ if (output->cursor_color.pixel == old_fg)
+ {
+ output->cursor_color.pixel = old_fg;
+ output->cursor_color.red = RED_FROM_ULONG (old_fg);
+ output->cursor_color.green = GREEN_FROM_ULONG (old_fg);
+ output->cursor_color.blue = BLUE_FROM_ULONG (old_fg);
+ }
+
+ unblock_input ();
+
+ update_face_from_frame_parameter (f, Qforeground_color, arg);
+
+ if (FRAME_VISIBLE_P (f))
+ redraw_frame (f);
+ }
+}
+
+static void
+unwind_popup (void)
+{
+ if (!popup_activated_p)
+ emacs_abort ();
+ --popup_activated_p;
+}
+
+static Lisp_Object
+haiku_create_frame (Lisp_Object parms, int ttip_p)
+{
+ struct frame *f;
+ Lisp_Object frame, tem;
+ Lisp_Object name;
+ bool minibuffer_only = false;
+ bool face_change_before = face_change;
+ long window_prompting = 0;
+ ptrdiff_t count = SPECPDL_INDEX ();
+ Lisp_Object display;
+ struct haiku_display_info *dpyinfo = NULL;
+ struct kboard *kb;
+
+ parms = Fcopy_alist (parms);
+
+ Vx_resource_name = Vinvocation_name;
+
+ display = gui_display_get_arg (dpyinfo, parms, Qterminal, 0, 0,
+ RES_TYPE_STRING);
+ if (EQ (display, Qunbound))
+ display = Qnil;
+ dpyinfo = check_haiku_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, 0, 0,
+ RES_TYPE_STRING);
+ if (!STRINGP (name)
+ && ! EQ (name, Qunbound)
+ && ! NILP (name))
+ error ("Invalid frame name--not a string or nil");
+
+ if (STRINGP (name))
+ Vx_resource_name = name;
+
+ block_input ();
+
+ /* make_frame_without_minibuffer can run Lisp code and garbage collect. */
+ /* No need to protect DISPLAY because that's not used after passing
+ it to make_frame_without_minibuffer. */
+ frame = Qnil;
+ tem = gui_display_get_arg (dpyinfo, parms, Qminibuffer,
+ "minibuffer", "Minibuffer",
+ RES_TYPE_SYMBOL);
+ if (ttip_p)
+ f = make_frame (0);
+ else 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 = 1;
+ }
+ else if (WINDOWP (tem))
+ f = make_frame_without_minibuffer (tem, kb, display);
+ else
+ f = make_frame (1);
+ XSETFRAME (frame, f);
+
+ f->terminal = dpyinfo->terminal;
+
+ f->output_method = output_haiku;
+ f->output_data.haiku = xzalloc (sizeof *f->output_data.haiku);
+
+ f->output_data.haiku->pending_zoom_x = INT_MIN;
+ f->output_data.haiku->pending_zoom_y = INT_MIN;
+ f->output_data.haiku->pending_zoom_width = INT_MIN;
+ f->output_data.haiku->pending_zoom_height = INT_MIN;
+
+ if (ttip_p)
+ f->wants_modeline = false;
+
+ fset_icon_name (f, gui_display_get_arg (dpyinfo, parms, Qicon_name,
+ "iconName", "Title",
+ RES_TYPE_STRING));
+ if (! STRINGP (f->icon_name) || ttip_p)
+ fset_icon_name (f, Qnil);
+
+ FRAME_DISPLAY_INFO (f) = dpyinfo;
+
+ /* With FRAME_DISPLAY_INFO set up, this unwind-protect is safe. */
+ if (!ttip_p)
+ record_unwind_protect (unwind_create_frame, frame);
+ else
+ record_unwind_protect (unwind_create_tip_frame, frame);
+
+ FRAME_OUTPUT_DATA (f)->parent_desc = NULL;
+ FRAME_OUTPUT_DATA (f)->explicit_parent = 0;
+
+ /* Set the name; the functions to which we pass f expect the name to
+ be set. */
+ if (EQ (name, Qunbound) || NILP (name) || ! STRINGP (name))
+ {
+ fset_name (f, Vinvocation_name);
+ f->explicit_name = 0;
+ }
+ else
+ {
+ fset_name (f, name);
+ f->explicit_name = 1;
+ specbind (Qx_resource_name, name);
+ }
+
+#ifdef USE_BE_CAIRO
+ register_font_driver (&ftcrfont_driver, f);
+#ifdef HAVE_HARFBUZZ
+ register_font_driver (&ftcrhbfont_driver, f);
+#endif
+#endif
+ register_font_driver (&haikufont_driver, f);
+
+ f->tooltip = ttip_p;
+
+ 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);
+
+ FRAME_RIF (f)->default_font_parameter (f, parms);
+
+ unblock_input ();
+
+ gui_default_parameter (f, parms, Qborder_width, make_fixnum (0),
+ "borderwidth", "BorderWidth", RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qinternal_border_width, make_fixnum (ttip_p ? 1 : 2),
+ "internalBorderWidth", "InternalBorderWidth",
+ RES_TYPE_NUMBER);
+ 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);
+ gui_default_parameter (f, parms, Qvertical_scroll_bars, !ttip_p ? Qt : Qnil,
+ "verticalScrollBars", "VerticalScrollBars",
+ RES_TYPE_SYMBOL);
+ gui_default_parameter (f, parms, Qhorizontal_scroll_bars, Qnil,
+ "horizontalScrollBars", "HorizontalScrollBars",
+ RES_TYPE_SYMBOL);
+ 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, 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, ttip_p ? Qnil : Qt,
+ NULL, NULL, RES_TYPE_BOOLEAN);
+
+ init_frame_faces (f);
+
+ /* Read comment about this code in corresponding place in xfns.c. */
+ 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, 1,
+ Qx_create_frame_1);
+
+ if (!ttip_p)
+ {
+ gui_default_parameter (f, parms, Qz_group, Qnil, NULL, NULL, RES_TYPE_SYMBOL);
+ gui_default_parameter (f, parms, Qno_focus_on_map, Qnil,
+ NULL, NULL, RES_TYPE_BOOLEAN);
+ gui_default_parameter (f, parms, Qno_accept_focus, Qnil,
+ NULL, NULL, RES_TYPE_BOOLEAN);
+
+ /* The resources controlling the menu-bar, tool-bar, and tab-bar are
+ processed specially at startup, and reflected in the mode
+ variables; ignore them here. */
+ 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);
+ }
+
+ parms = get_geometry_from_preferences (dpyinfo, parms);
+ window_prompting = gui_figure_window_size (f, parms, false, true);
+
+ if (ttip_p)
+ {
+ /* No fringes on tip frame. */
+ f->fringe_cols = 0;
+ f->left_fringe_width = 0;
+ f->right_fringe_width = 0;
+ /* No dividers on tip frame. */
+ f->right_divider_width = 0;
+ f->bottom_divider_width = 0;
+ }
+
+ tem = gui_display_get_arg (dpyinfo, parms, Qunsplittable, 0, 0,
+ RES_TYPE_BOOLEAN);
+ f->no_split = minibuffer_only || (!EQ (tem, Qunbound) && !NILP (tem));
+
+ /* Add `tooltip' frame parameter's default value. */
+ if (NILP (Fframe_parameter (frame, Qtooltip)) && ttip_p)
+ Fmodify_frame_parameters (frame, Fcons (Fcons (Qtooltip, Qt), Qnil));
+
+#define ASSIGN_CURSOR(cursor, be_cursor) \
+ (FRAME_OUTPUT_DATA (f)->cursor = be_cursor)
+
+ ASSIGN_CURSOR (text_cursor, BCursor_create_i_beam ());
+ ASSIGN_CURSOR (nontext_cursor, BCursor_create_default ());
+ ASSIGN_CURSOR (modeline_cursor, BCursor_create_modeline ());
+ ASSIGN_CURSOR (hand_cursor, BCursor_create_grab ());
+ ASSIGN_CURSOR (hourglass_cursor, BCursor_create_progress_cursor ());
+ ASSIGN_CURSOR (horizontal_drag_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_EAST_WEST));
+ ASSIGN_CURSOR (vertical_drag_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_NORTH_SOUTH));
+ ASSIGN_CURSOR (left_edge_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_WEST));
+ ASSIGN_CURSOR (top_left_corner_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_NORTH_WEST));
+ ASSIGN_CURSOR (top_edge_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_NORTH));
+ ASSIGN_CURSOR (top_right_corner_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_NORTH_EAST));
+ ASSIGN_CURSOR (right_edge_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_EAST));
+ ASSIGN_CURSOR (bottom_right_corner_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_EAST));
+ ASSIGN_CURSOR (bottom_edge_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_SOUTH));
+ ASSIGN_CURSOR (bottom_left_corner_cursor,
+ BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_WEST));
+ ASSIGN_CURSOR (no_cursor,
+ BCursor_from_id (CURSOR_ID_NO_CURSOR));
+
+ ASSIGN_CURSOR (current_cursor, FRAME_OUTPUT_DATA (f)->text_cursor);
+#undef ASSIGN_CURSOR
+
+
+ if (ttip_p)
+ f->no_split = true;
+ f->terminal->reference_count++;
+
+ FRAME_OUTPUT_DATA (f)->window = BWindow_new (&FRAME_OUTPUT_DATA (f)->view);
+ if (!FRAME_OUTPUT_DATA (f)->window)
+ xsignal1 (Qerror, build_unibyte_string ("Could not create window"));
+
+ if (!minibuffer_only && !ttip_p && FRAME_EXTERNAL_MENU_BAR (f))
+ initialize_frame_menubar (f);
+
+ FRAME_OUTPUT_DATA (f)->window_desc = FRAME_OUTPUT_DATA (f)->window;
+
+ Vframe_list = Fcons (frame, Vframe_list);
+
+ Lisp_Object parent_frame = gui_display_get_arg (dpyinfo, parms, Qparent_frame, NULL, NULL,
+ RES_TYPE_SYMBOL);
+
+ if (EQ (parent_frame, Qunbound)
+ || NILP (parent_frame)
+ || !FRAMEP (parent_frame)
+ || !FRAME_LIVE_P (XFRAME (parent_frame)))
+ parent_frame = Qnil;
+
+ fset_parent_frame (f, parent_frame);
+ store_frame_param (f, Qparent_frame, parent_frame);
+
+ if (!NILP (parent_frame))
+ haiku_set_parent_frame (f, parent_frame, Qnil);
+
+ gui_default_parameter (f, parms, Qundecorated, Qnil, NULL, NULL, RES_TYPE_BOOLEAN);
+
+ gui_default_parameter (f, parms, Qicon_type, Qnil,
+ "bitmapIcon", "BitmapIcon", RES_TYPE_SYMBOL);
+ if (ttip_p)
+ {
+ gui_default_parameter (f, parms, Qundecorated, Qt, NULL, NULL, RES_TYPE_BOOLEAN);
+ gui_default_parameter (f, parms, Qno_accept_focus, Qt, NULL, NULL,
+ RES_TYPE_BOOLEAN);
+ }
+ else
+ {
+ gui_default_parameter (f, parms, Qauto_raise, Qnil,
+ "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN);
+ gui_default_parameter (f, parms, Qauto_lower, Qnil,
+ "autoLower", "AutoLower", RES_TYPE_BOOLEAN);
+ gui_default_parameter (f, parms, Qcursor_type, Qbox,
+ "cursorType", "CursorType", RES_TYPE_SYMBOL);
+ 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, Qfullscreen, Qnil,
+ "fullscreen", "Fullscreen", RES_TYPE_SYMBOL);
+ }
+
+ gui_default_parameter (f, parms, Qinhibit_double_buffering, Qnil,
+ "inhibitDoubleBuffering", "InhibitDoubleBuffering",
+ RES_TYPE_BOOLEAN);
+
+ if (ttip_p)
+ {
+ 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);
+ }
+ }
+
+ if (ttip_p)
+ face_change = face_change_before;
+
+ f->can_set_window_size = true;
+
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 0, true, ttip_p ? Qtip_frame : Qx_create_frame_2);
+
+ if (!FRAME_OUTPUT_DATA (f)->explicit_parent && !ttip_p)
+ {
+ Lisp_Object visibility;
+
+ visibility = gui_display_get_arg (dpyinfo, parms, Qvisibility, 0, 0,
+ RES_TYPE_SYMBOL);
+ if (EQ (visibility, Qunbound))
+ visibility = Qt;
+ if (EQ (visibility, Qicon))
+ haiku_iconify_frame (f);
+ else if (!NILP (visibility))
+ haiku_visualize_frame (f);
+ else /* Qnil */
+ {
+ f->was_invisible = true;
+ }
+ }
+
+ if (!ttip_p)
+ {
+ 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);
+ }
+
+ 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));
+
+ if (window_prompting & (USPosition | PPosition))
+ haiku_set_offset (f, f->left_pos, f->top_pos, 1);
+ else
+ BWindow_center_on_screen (FRAME_HAIKU_WINDOW (f));
+
+ /* Make sure windows on this frame appear in calls to next-window
+ and similar functions. */
+ Vwindow_list = Qnil;
+
+ if (ttip_p)
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 0, true, Qtip_frame);
+
+ return unbind_to (count, frame);
+}
+
+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 = 0, min_y = 0, max_x = 0, max_y = 0;
+
+ /* User-specified position? */
+ left = Fcdr (Fassq (Qleft, parms));
+ top = Fcdr (Fassq (Qtop, parms));
+ right = Fcdr (Fassq (Qright, parms));
+ bottom = Fcdr (Fassq (Qbottom, parms));
+
+ /* Move the tooltip window where the mouse pointer is. Resize and
+ show it. */
+ if ((!FIXNUMP (left) && !FIXNUMP (right))
+ || (!FIXNUMP (top) && !FIXNUMP (bottom)))
+ {
+ int x, y;
+
+ /* Default min and max values. */
+ min_x = 0;
+ min_y = 0;
+ BScreen_px_dim (&max_x, &max_y);
+
+ block_input ();
+ BView_get_mouse (FRAME_HAIKU_VIEW (f), &x, &y);
+ BView_convert_to_screen (FRAME_HAIKU_VIEW (f), &x, &y);
+ *root_x = x;
+ *root_y = y;
+ unblock_input ();
+ }
+
+ 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;
+}
+
+static Lisp_Object
+haiku_hide_tip (bool delete)
+{
+ if (!NILP (tip_timer))
+ {
+ call1 (Qcancel_timer, tip_timer);
+ tip_timer = Qnil;
+ }
+
+ Lisp_Object it, frame;
+ FOR_EACH_FRAME (it, frame)
+ if (FRAME_WINDOW_P (XFRAME (frame)) &&
+ FRAME_HAIKU_VIEW (XFRAME (frame)))
+ BView_set_tooltip (FRAME_HAIKU_VIEW (XFRAME (frame)), NULL);
+
+ if (NILP (tip_frame)
+ || (!delete && !NILP (tip_frame)
+ && !FRAME_VISIBLE_P (XFRAME (tip_frame))))
+ return Qnil;
+ else
+ {
+ ptrdiff_t count;
+ Lisp_Object was_open = Qnil;
+
+ count = SPECPDL_INDEX ();
+ specbind (Qinhibit_redisplay, Qt);
+ specbind (Qinhibit_quit, Qt);
+
+ if (!NILP (tip_frame))
+ {
+ if (FRAME_LIVE_P (XFRAME (tip_frame)))
+ {
+ if (delete)
+ {
+ delete_frame (tip_frame, Qnil);
+ tip_frame = Qnil;
+ }
+ else
+ haiku_unvisualize_frame (XFRAME (tip_frame));
+
+ was_open = Qt;
+ }
+ else
+ tip_frame = Qnil;
+ }
+ else
+ tip_frame = Qnil;
+
+ return unbind_to (count, was_open);
+ }
+}
+
+static void
+haiku_set_undecorated (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ if (EQ (new_value, old_value))
+ return;
+
+ block_input ();
+ FRAME_UNDECORATED (f) = !NILP (new_value);
+ BWindow_change_decoration (FRAME_HAIKU_WINDOW (f), NILP (new_value));
+ unblock_input ();
+}
+
+static void
+haiku_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
+{
+ if (FRAME_TOOLTIP_P (f))
+ return;
+ int nlines;
+ if (TYPE_RANGED_FIXNUMP (int, value))
+ nlines = XFIXNUM (value);
+ else
+ nlines = 0;
+
+ fset_redisplay (f);
+
+ FRAME_MENU_BAR_LINES (f) = 0;
+ FRAME_MENU_BAR_HEIGHT (f) = 0;
+
+ if (nlines)
+ {
+ FRAME_EXTERNAL_MENU_BAR (f) = 1;
+ if (FRAME_HAIKU_P (f) && !FRAME_HAIKU_MENU_BAR (f))
+ XWINDOW (FRAME_SELECTED_WINDOW (f))->update_mode_line = 1;
+ }
+ else
+ {
+ if (FRAME_EXTERNAL_MENU_BAR (f))
+ free_frame_menubar (f);
+ FRAME_EXTERNAL_MENU_BAR (f) = 0;
+ if (FRAME_HAIKU_P (f))
+ FRAME_HAIKU_MENU_BAR (f) = 0;
+ }
+
+ adjust_frame_glyphs (f);
+}
+
+/* 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
+ Fx_frame_geometry. */
+static Lisp_Object
+frame_geometry (Lisp_Object frame, Lisp_Object attribute)
+{
+ struct frame *f = decode_live_frame (frame);
+ check_window_system (f);
+
+ if (EQ (attribute, Qouter_edges))
+ return list4i (f->left_pos, f->top_pos,
+ f->left_pos, f->top_pos);
+ else if (EQ (attribute, Qnative_edges))
+ return list4i (f->left_pos, f->top_pos,
+ f->left_pos + FRAME_PIXEL_WIDTH (f),
+ f->top_pos + FRAME_PIXEL_HEIGHT (f));
+ else if (EQ (attribute, Qinner_edges))
+ return list4i (f->left_pos + FRAME_INTERNAL_BORDER_WIDTH (f),
+ f->top_pos + FRAME_INTERNAL_BORDER_WIDTH (f) +
+ FRAME_MENU_BAR_HEIGHT (f) + FRAME_TOOL_BAR_HEIGHT (f),
+ f->left_pos - FRAME_INTERNAL_BORDER_WIDTH (f) +
+ FRAME_PIXEL_WIDTH (f),
+ f->top_pos + FRAME_PIXEL_HEIGHT (f) -
+ FRAME_INTERNAL_BORDER_WIDTH (f));
+
+ else
+ return
+ list (Fcons (Qouter_position,
+ Fcons (make_fixnum (f->left_pos),
+ make_fixnum (f->top_pos))),
+ Fcons (Qouter_size,
+ Fcons (make_fixnum (FRAME_PIXEL_WIDTH (f)),
+ make_fixnum (FRAME_PIXEL_HEIGHT (f)))),
+ Fcons (Qexternal_border_size,
+ Fcons (make_fixnum (0), make_fixnum (0))),
+ Fcons (Qtitle_bar_size,
+ Fcons (make_fixnum (0), make_fixnum (0))),
+ Fcons (Qmenu_bar_external, Qnil),
+ Fcons (Qmenu_bar_size, Fcons (make_fixnum (FRAME_PIXEL_WIDTH (f) -
+ (FRAME_INTERNAL_BORDER_WIDTH (f) * 2)),
+ make_fixnum (FRAME_MENU_BAR_HEIGHT (f)))),
+ Fcons (Qtool_bar_external, Qnil),
+ Fcons (Qtool_bar_position, Qtop),
+ Fcons (Qtool_bar_size, Fcons (make_fixnum (FRAME_PIXEL_WIDTH (f) -
+ (FRAME_INTERNAL_BORDER_WIDTH (f) * 2)),
+ make_fixnum (FRAME_TOOL_BAR_HEIGHT (f)))),
+ Fcons (Qinternal_border_width, make_fixnum (FRAME_INTERNAL_BORDER_WIDTH (f))));
+}
+
+void
+haiku_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ CHECK_STRING (arg);
+
+ block_input ();
+ Emacs_Color color;
+
+ if (haiku_get_color (SSDATA (arg), &color))
+ {
+ store_frame_param (f, Qbackground_color, oldval);
+ unblock_input ();
+ error ("Bad color");
+ }
+
+ FRAME_OUTPUT_DATA (f)->cursor_fg = color.pixel;
+ FRAME_BACKGROUND_PIXEL (f) = color.pixel;
+
+ if (FRAME_HAIKU_VIEW (f))
+ {
+ struct face *defface;
+
+ BView_draw_lock (FRAME_HAIKU_VIEW (f));
+ BView_SetViewColor (FRAME_HAIKU_VIEW (f), color.pixel);
+ BView_draw_unlock (FRAME_HAIKU_VIEW (f));
+
+ defface = FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID);
+ if (defface)
+ {
+ defface->background = color.pixel;
+ update_face_from_frame_parameter (f, Qbackground_color, arg);
+ clear_frame (f);
+ }
+ }
+
+ if (FRAME_VISIBLE_P (f))
+ SET_FRAME_GARBAGED (f);
+ unblock_input ();
+}
+
+void
+haiku_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ CHECK_STRING (arg);
+
+ block_input ();
+ Emacs_Color color;
+
+ if (haiku_get_color (SSDATA (arg), &color))
+ {
+ store_frame_param (f, Qcursor_color, oldval);
+ unblock_input ();
+ error ("Bad color");
+ }
+
+ FRAME_CURSOR_COLOR (f) = color;
+ if (FRAME_VISIBLE_P (f))
+ {
+ gui_update_cursor (f, 0);
+ gui_update_cursor (f, 1);
+ }
+ update_face_from_frame_parameter (f, Qcursor_color, arg);
+ unblock_input ();
+}
+
+void
+haiku_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ set_frame_cursor_types (f, arg);
+}
+
+unsigned long
+haiku_get_pixel (haiku bitmap, int x, int y)
+{
+ unsigned char *data;
+ int32_t bytes_per_row;
+ int mono_p;
+ int left;
+ int right;
+ int top;
+ int bottom;
+
+ data = BBitmap_data (bitmap);
+ BBitmap_dimensions (bitmap, &left, &top, &right, &bottom,
+ &bytes_per_row, &mono_p);
+
+ if (x < left || x > right || y < top || y > bottom)
+ emacs_abort ();
+
+ if (!mono_p)
+ return ((uint32_t *) (data + (bytes_per_row * y)))[x];
+
+ int byte = y * bytes_per_row + x / 8;
+ return data[byte] & (1 << (x % 8));
+}
+
+void
+haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel)
+{
+ unsigned char *data;
+ int32_t bytes_per_row;
+ int mono_p;
+ int left;
+ int right;
+ int top;
+ int bottom;
+
+ data = BBitmap_data (bitmap);
+ BBitmap_dimensions (bitmap, &left, &top, &right, &bottom,
+ &bytes_per_row, &mono_p);
+
+ if (x < left || x > right || y < top || y > bottom)
+ emacs_abort ();
+
+ if (mono_p)
+ {
+ ptrdiff_t off = y * bytes_per_row;
+ ptrdiff_t bit = x % 8;
+ ptrdiff_t xoff = x / 8;
+
+ unsigned char *byte = data + off + xoff;
+ if (!pixel)
+ *byte &= ~(1 << bit);
+ else
+ *byte |= 1 << bit;
+ }
+ else
+ ((uint32_t *) (data + (bytes_per_row * y)))[x] = pixel;
+}
+
+void
+haiku_free_frame_resources (struct frame *f)
+{
+ haiku window, drawable, mbar;
+ Mouse_HLInfo *hlinfo;
+ struct haiku_display_info *dpyinfo;
+ Lisp_Object bar;
+ struct scroll_bar *b;
+
+ block_input ();
+ check_window_system (f);
+
+ hlinfo = MOUSE_HL_INFO (f);
+ window = FRAME_HAIKU_WINDOW (f);
+ drawable = FRAME_HAIKU_VIEW (f);
+ mbar = FRAME_HAIKU_MENU_BAR (f);
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+
+ free_frame_faces (f);
+
+ /* Free scroll bars */
+ for (bar = FRAME_SCROLL_BARS (f); !NILP (bar); bar = b->next)
+ {
+ b = XSCROLL_BAR (bar);
+ haiku_scroll_bar_remove (b);
+ }
+
+ if (f == dpyinfo->highlight_frame)
+ dpyinfo->highlight_frame = 0;
+ if (f == dpyinfo->focused_frame)
+ dpyinfo->focused_frame = 0;
+ if (f == dpyinfo->last_mouse_motion_frame)
+ dpyinfo->last_mouse_motion_frame = NULL;
+ if (f == dpyinfo->last_mouse_frame)
+ dpyinfo->last_mouse_frame = NULL;
+ if (f == dpyinfo->focus_event_frame)
+ dpyinfo->focus_event_frame = NULL;
+
+ if (f == hlinfo->mouse_face_mouse_frame)
+ reset_mouse_highlight (hlinfo);
+
+ if (mbar)
+ {
+ BMenuBar_delete (mbar);
+ if (f->output_data.haiku->menu_bar_open_p)
+ {
+ --popup_activated_p;
+ f->output_data.haiku->menu_bar_open_p = 0;
+ }
+ }
+
+ if (drawable)
+ BView_emacs_delete (drawable);
+
+ if (window)
+ BWindow_quit (window);
+
+ /* Free cursors */
+
+ BCursor_delete (f->output_data.haiku->text_cursor);
+ BCursor_delete (f->output_data.haiku->nontext_cursor);
+ BCursor_delete (f->output_data.haiku->modeline_cursor);
+ BCursor_delete (f->output_data.haiku->hand_cursor);
+ BCursor_delete (f->output_data.haiku->hourglass_cursor);
+ BCursor_delete (f->output_data.haiku->horizontal_drag_cursor);
+ BCursor_delete (f->output_data.haiku->vertical_drag_cursor);
+ BCursor_delete (f->output_data.haiku->left_edge_cursor);
+ BCursor_delete (f->output_data.haiku->top_left_corner_cursor);
+ BCursor_delete (f->output_data.haiku->top_edge_cursor);
+ BCursor_delete (f->output_data.haiku->top_right_corner_cursor);
+ BCursor_delete (f->output_data.haiku->right_edge_cursor);
+ BCursor_delete (f->output_data.haiku->bottom_right_corner_cursor);
+ BCursor_delete (f->output_data.haiku->bottom_edge_cursor);
+ BCursor_delete (f->output_data.haiku->bottom_left_corner_cursor);
+ BCursor_delete (f->output_data.haiku->no_cursor);
+
+ xfree (FRAME_OUTPUT_DATA (f));
+ FRAME_OUTPUT_DATA (f) = NULL;
+
+ unblock_input ();
+}
+
+void
+haiku_iconify_frame (struct frame *frame)
+{
+ if (FRAME_ICONIFIED_P (frame))
+ return;
+
+ block_input ();
+
+ SET_FRAME_VISIBLE (frame, false);
+ SET_FRAME_ICONIFIED (frame, true);
+
+ BWindow_iconify (FRAME_HAIKU_WINDOW (frame));
+
+ unblock_input ();
+}
+
+void
+haiku_visualize_frame (struct frame *f)
+{
+ block_input ();
+
+ if (!FRAME_VISIBLE_P (f))
+ {
+ if (FRAME_NO_FOCUS_ON_MAP (f))
+ BWindow_set_avoid_focus (FRAME_HAIKU_WINDOW (f), 1);
+ BWindow_set_visible (FRAME_HAIKU_WINDOW (f), 1);
+ if (FRAME_NO_FOCUS_ON_MAP (f) &&
+ !FRAME_NO_ACCEPT_FOCUS (f))
+ BWindow_set_avoid_focus (FRAME_HAIKU_WINDOW (f), 0);
+
+ haiku_set_offset (f, f->left_pos, f->top_pos, 0);
+
+ SET_FRAME_VISIBLE (f, 1);
+ SET_FRAME_ICONIFIED (f, 0);
+ }
+
+ unblock_input ();
+}
+
+void
+haiku_unvisualize_frame (struct frame *f)
+{
+ block_input ();
+
+ BWindow_set_visible (FRAME_HAIKU_WINDOW (f), 0);
+ SET_FRAME_VISIBLE (f, 0);
+ SET_FRAME_ICONIFIED (f, 0);
+
+ unblock_input ();
+}
+
+void
+haiku_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ int old_width = FRAME_INTERNAL_BORDER_WIDTH (f);
+ int new_width = check_int_nonnegative (arg);
+
+ if (new_width == old_width)
+ return;
+ f->internal_border_width = new_width;
+
+ if (FRAME_HAIKU_WINDOW (f))
+ {
+ adjust_frame_size (f, -1, -1, 3, 0, Qinternal_border_width);
+ haiku_clear_under_internal_border (f);
+ }
+
+ SET_FRAME_GARBAGED (f);
+}
+
+void
+haiku_set_frame_visible_invisible (struct frame *f, bool visible_p)
+{
+ if (visible_p)
+ haiku_visualize_frame (f);
+ else
+ haiku_unvisualize_frame (f);
+}
+
+void
+frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y)
+{
+ block_input ();
+
+ BView_convert_to_screen (FRAME_HAIKU_VIEW (f), &pix_x, &pix_y);
+ be_warp_pointer (pix_x, pix_y);
+
+ unblock_input ();
+}
+
+void
+haiku_query_color (uint32_t col, Emacs_Color *color_def)
+{
+ color_def->red = RED_FROM_ULONG (col) * 257;
+ color_def->green = GREEN_FROM_ULONG (col) * 257;
+ color_def->blue = BLUE_FROM_ULONG (col) * 257;
+
+ color_def->pixel = col;
+}
+
+Display_Info *
+check_x_display_info (Lisp_Object object)
+{
+ return check_haiku_display_info (object);
+}
+
+/* Rename frame F to NAME. If NAME is nil, set F's name to "GNU
+ Emacs". If EXPLICIT_P is non-zero, that indicates Lisp code is
+ setting the name, not redisplay; in that case, set F's name to NAME
+ and set F->explicit_name; if NAME is nil, clear F->explicit_name.
+
+ If EXPLICIT_P is zero, it means redisplay is setting the name; the
+ name provided will be ignored if explicit_name is set. */
+void
+haiku_set_name (struct frame *f, Lisp_Object name, bool explicit_p)
+{
+ if (explicit_p)
+ {
+ if (f->explicit_name && NILP (name))
+ update_mode_lines = 24;
+
+ f->explicit_name = !NILP (name);
+ }
+ else if (f->explicit_name)
+ return;
+
+ if (NILP (name))
+ name = build_unibyte_string ("GNU Emacs");
+
+ if (!NILP (Fstring_equal (name, f->name)))
+ return;
+
+ fset_name (f, name);
+
+ if (!NILP (f->title))
+ name = f->title;
+
+ haiku_set_title_bar_text (f, name);
+}
+
+static void
+haiku_set_inhibit_double_buffering (struct frame *f,
+ Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ block_input ();
+ if (FRAME_HAIKU_WINDOW (f))
+ {
+ if (NILP (new_value))
+ {
+ EmacsView_set_up_double_buffering (FRAME_HAIKU_VIEW (f));
+ if (!NILP (old_value))
+ {
+ SET_FRAME_GARBAGED (f);
+ expose_frame (f, 0, 0, 0, 0);
+ }
+ }
+ else
+ EmacsView_disable_double_buffering (FRAME_HAIKU_VIEW (f));
+ }
+ unblock_input ();
+}
+
+
+
+DEFUN ("haiku-set-mouse-absolute-pixel-position",
+ Fhaiku_set_mouse_absolute_pixel_position,
+ Shaiku_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. */)
+ (Lisp_Object x, Lisp_Object y)
+{
+ int xval = check_integer_range (x, INT_MIN, INT_MAX);
+ int yval = check_integer_range (y, INT_MIN, INT_MAX);
+
+ if (!x_display_list)
+ error ("Window system not initialized");
+
+ block_input ();
+ be_warp_pointer (xval, yval);
+ unblock_input ();
+ return Qnil;
+}
+
+DEFUN ("haiku-mouse-absolute-pixel-position", Fhaiku_mouse_absolute_pixel_position,
+ Shaiku_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. */)
+ (void)
+{
+ if (!x_display_list)
+ return Qnil;
+
+ struct frame *f = SELECTED_FRAME ();
+
+ if (FRAME_INITIAL_P (f) || !FRAME_HAIKU_P (f)
+ || !FRAME_HAIKU_VIEW (f))
+ return Qnil;
+
+ block_input ();
+ void *view = FRAME_HAIKU_VIEW (f);
+
+ int x, y;
+ BView_get_mouse (view, &x, &y);
+ BView_convert_to_screen (view, &x, &y);
+ unblock_input ();
+
+ return Fcons (make_fixnum (x), make_fixnum (y));
+}
+
+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 ("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)
+{
+ Emacs_Color col;
+ CHECK_STRING (color);
+ decode_window_system_frame (frame);
+
+ return haiku_get_color (SSDATA (color), &col) ? Qnil : Qt;
+}
+
+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)
+{
+ Emacs_Color col;
+ CHECK_STRING (color);
+ decode_window_system_frame (frame);
+
+ block_input ();
+ if (haiku_get_color (SSDATA (color), &col))
+ {
+ unblock_input ();
+ return Qnil;
+ }
+ unblock_input ();
+ return list3i (lrint (col.red), lrint (col.green), lrint (col.blue));
+}
+
+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-open-connection", Fx_open_connection, Sx_open_connection,
+ 1, 3, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object display, Lisp_Object resource_string, Lisp_Object must_succeed)
+{
+ struct haiku_display_info *dpy_info;
+ CHECK_STRING (display);
+
+ if (NILP (Fstring_equal (display, build_string ("be"))))
+ !NILP (must_succeed) ? fatal ("Bad display") : error ("Bad display");
+ dpy_info = haiku_term_init ();
+
+ if (!dpy_info)
+ !NILP (must_succeed) ? fatal ("Display not responding") :
+ error ("Display not responding");
+
+ 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)
+
+{
+ check_haiku_display_info (terminal);
+
+ int width, height;
+ BScreen_px_dim (&width, &height);
+ return make_fixnum (width);
+}
+
+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)
+
+{
+ check_haiku_display_info (terminal);
+
+ int width, height;
+ BScreen_px_dim (&width, &height);
+ return make_fixnum (width);
+}
+
+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)
+{
+ struct haiku_display_info *dpyinfo = check_haiku_display_info (terminal);
+
+ int width, height;
+ BScreen_px_dim (&width, &height);
+
+ return make_fixnum (height / (dpyinfo->resy / 25.4));
+}
+
+
+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)
+{
+ struct haiku_display_info *dpyinfo = check_haiku_display_info (terminal);
+
+ int width, height;
+ BScreen_px_dim (&width, &height);
+
+ return make_fixnum (height / (dpyinfo->resy / 25.4));
+}
+
+DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
+ 1, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object parms)
+{
+ return haiku_create_frame (parms, 0);
+}
+
+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_haiku_display_info (terminal);
+
+ int planes = be_get_display_planes ();
+
+ if (planes == 8)
+ return intern ("static-color");
+ else if (planes == 16 || planes == 15)
+ return intern ("pseudo-color");
+
+ return intern ("direct-color");
+}
+
+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)
+{
+ struct frame *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;
+ ptrdiff_t count = SPECPDL_INDEX ();
+ ptrdiff_t count_1;
+ Lisp_Object window, size, tip_buf;
+
+ AUTO_STRING (tip, " *tip*");
+
+ specbind (Qinhibit_redisplay, Qt);
+
+ CHECK_STRING (string);
+
+ if (NILP (frame))
+ frame = selected_frame;
+ decode_window_system_frame (frame);
+
+ if (NILP (timeout))
+ timeout = make_fixnum (5);
+ else
+ 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);
+
+ if (haiku_use_system_tooltips)
+ {
+ int root_x, root_y;
+ CHECK_STRING (string);
+ if (STRING_MULTIBYTE (string))
+ string = ENCODE_UTF_8 (string);
+
+ if (NILP (frame))
+ frame = selected_frame;
+
+ struct frame *f = decode_window_system_frame (frame);
+ block_input ();
+
+ char *str = xstrdup (SSDATA (string));
+ int height = be_plain_font_height ();
+ int width;
+ char *tok = strtok (str, "\n");
+ width = be_string_width_with_plain_font (tok);
+
+ while ((tok = strtok (NULL, "\n")))
+ {
+ height = be_plain_font_height ();
+ int w = be_string_width_with_plain_font (tok);
+ if (w > width)
+ w = width;
+ }
+ free (str);
+
+ height += 16; /* Default margin. */
+ width += 16; /* Ditto. Unfortunately there isn't a more
+ reliable way to get it. */
+ compute_tip_xy (f, parms, dx, dy, width, height, &root_x, &root_y);
+ BView_convert_from_screen (FRAME_HAIKU_VIEW (f), &root_x, &root_y);
+ BView_set_and_show_sticky_tooltip (FRAME_HAIKU_VIEW (f), SSDATA (string),
+ root_x, root_y);
+ unblock_input ();
+ goto start_timer;
+ }
+
+ if (!NILP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame)))
+ {
+ if (FRAME_VISIBLE_P (XFRAME (tip_frame))
+ && EQ (frame, tip_last_frame)
+ && !NILP (Fequal_including_properties (string, tip_last_string))
+ && !NILP (Fequal (parms, tip_last_parms)))
+ {
+ /* Only DX and DY have changed. */
+ tip_f = XFRAME (tip_frame);
+ if (!NILP (tip_timer))
+ {
+ Lisp_Object timer = tip_timer;
+
+ tip_timer = Qnil;
+ call1 (Qcancel_timer, timer);
+ }
+
+ block_input ();
+ compute_tip_xy (tip_f, parms, dx, dy, FRAME_PIXEL_WIDTH (tip_f),
+ FRAME_PIXEL_HEIGHT (tip_f), &root_x, &root_y);
+ haiku_set_offset (tip_f, root_x, root_y, 1);
+ haiku_visualize_frame (tip_f);
+ unblock_input ();
+
+ goto start_timer;
+ }
+ else if (tooltip_reuse_hidden_frame && 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 = Fcar (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 (Fcdr (elt), Fcdr (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 there's a parameter left in tip_last_parms with a
+ non-nil value. */
+ for (tail = tip_last_parms; CONSP (tail); tail = XCDR (tail))
+ {
+ elt = XCAR (tail);
+ parm = Fcar (elt);
+ if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright)
+ && !EQ (parm, Qbottom) && !NILP (Fcdr (elt)))
+ {
+ /* We lost, delete the old tooltip. */
+ delete = true;
+ break;
+ }
+ }
+
+ haiku_hide_tip (delete);
+ }
+ else
+ haiku_hide_tip (true);
+ }
+ else
+ haiku_hide_tip (true);
+
+ tip_last_frame = frame;
+ tip_last_string = string;
+ tip_last_parms = parms;
+
+ /* Block input until the tip has been fully drawn, to avoid crashes
+ when drawing tips in menus. */
+ block_input ();
+
+ 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 = haiku_create_frame (parms, 1)))
+ {
+ /* Creating the tip frame failed. */
+ unblock_input ();
+ 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) = WINDOW_TOTAL_COLS (w);
+ adjust_frame_glyphs (tip_f);
+
+ /* Insert STRING into the root window's buffer and fit the frame to
+ the buffer. */
+ 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);
+ try_window (window, pos, TRY_WINDOW_IGNORE_FONTS_CHANGE);
+ /* 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 (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
+ height = XFIXNUM (Fcdr (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);
+ BWindow_resize (FRAME_HAIKU_WINDOW (tip_f), width, height);
+ haiku_set_offset (tip_f, root_x, root_y, 1);
+ BWindow_set_tooltip_decoration (FRAME_HAIKU_WINDOW (tip_f));
+ BView_set_view_cursor (FRAME_HAIKU_VIEW (tip_f),
+ FRAME_OUTPUT_DATA (XFRAME (frame))->current_cursor);
+ SET_FRAME_VISIBLE (tip_f, 1);
+ BWindow_set_visible (FRAME_HAIKU_WINDOW (tip_f), 1);
+
+ w->must_be_updated_p = true;
+ flush_frame (tip_f);
+ update_single_window (w);
+ set_buffer_internal_1 (old_buffer);
+ unbind_to (count_1, Qnil);
+ unblock_input ();
+ windows_or_buffers_changed = old_windows_or_buffers_changed;
+
+ start_timer:
+ /* Let the tip disappear after timeout seconds. */
+ tip_timer = call3 (intern ("run-at-time"), timeout, Qnil,
+ intern ("x-hide-tip"));
+
+ return unbind_to (count, Qnil);
+}
+
+DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (void)
+{
+ return haiku_hide_tip (!tooltip_reuse_hidden_frame);
+}
+
+DEFUN ("x-close-connection", Fx_close_connection, Sx_close_connection, 1, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */
+ attributes: noreturn)
+ (Lisp_Object terminal)
+{
+ check_haiku_display_info (terminal);
+
+ error ("Cannot close Haiku displays");
+}
+
+DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (void)
+{
+ if (!x_display_list)
+ return Qnil;
+
+ return list1 (XCAR (x_display_list->name_list_element));
+}
+
+DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+ check_haiku_display_info (terminal);
+ return build_string ("Haiku, Inc.");
+}
+
+DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+ check_haiku_display_info (terminal);
+ return list3i (5, 1, 1);
+}
+
+DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+ check_haiku_display_info (terminal);
+ return make_fixnum (be_get_display_screens ());
+}
+
+DEFUN ("haiku-get-version-string", Fhaiku_get_version_string,
+ Shaiku_get_version_string, 0, 0, 0,
+ doc: /* Return a string describing the current Haiku version. */)
+ (void)
+{
+ char buf[1024];
+
+ be_get_version_string ((char *) &buf, sizeof buf);
+ return build_string (buf);
+}
+
+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)
+{
+ check_haiku_display_info (terminal);
+
+ return make_fixnum (be_get_display_color_cells ());
+}
+
+DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes,
+ 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+ check_haiku_display_info (terminal);
+
+ return make_fixnum (be_get_display_planes ());
+}
+
+DEFUN ("x-double-buffered-p", Fx_double_buffered_p, Sx_double_buffered_p,
+ 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object frame)
+{
+ struct frame *f = decode_live_frame (frame);
+ check_window_system (f);
+
+ return EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f)) ? Qt : Qnil;
+}
+
+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)
+{
+ if (FRAMEP (terminal))
+ {
+ CHECK_LIVE_FRAME (terminal);
+ struct frame *f = decode_window_system_frame (terminal);
+
+ if (FRAME_HAIKU_VIEW (f) &&
+ EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f)))
+ return FRAME_PARENT_FRAME (f) ? Qwhen_mapped : Qalways;
+ else
+ return Qnot_useful;
+ }
+ else
+ {
+ check_haiku_display_info (terminal);
+ return Qnot_useful;
+ }
+}
+
+DEFUN ("haiku-frame-geometry", Fhaiku_frame_geometry, Shaiku_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)
+{
+ return frame_geometry (frame, Qnil);
+}
+
+DEFUN ("haiku-frame-edges", Fhaiku_frame_edges, Shaiku_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)
+{
+ return frame_geometry (frame, ((EQ (type, Qouter_edges)
+ || EQ (type, Qinner_edges))
+ ? type
+ : Qnative_edges));
+}
+
+DEFUN ("haiku-read-file-name", Fhaiku_read_file_name, Shaiku_read_file_name, 1, 6, 0,
+ doc: /* Use a graphical panel to read a file name, using prompt PROMPT.
+Optional arg FRAME specifies a frame on which to display the file panel.
+If it is nil, the current frame is used instead.
+The frame being used will be brought to the front of
+the display after the file panel is closed.
+Optional arg DIR, if non-nil, supplies a default directory.
+Optional arg MUSTMATCH, if non-nil, means the returned file or
+directory must exist.
+Optional arg DIR_ONLY_P, if non-nil, means choose only directories.
+Optional arg SAVE_TEXT, if non-nil, specifies some text to show in the entry field. */)
+ (Lisp_Object prompt, Lisp_Object frame,
+ Lisp_Object dir, Lisp_Object mustmatch,
+ Lisp_Object dir_only_p, Lisp_Object save_text)
+{
+ ptrdiff_t idx;
+ if (!x_display_list)
+ error ("Be windowing not initialized");
+
+ if (!NILP (dir))
+ CHECK_STRING (dir);
+
+ if (!NILP (save_text))
+ CHECK_STRING (save_text);
+
+ if (NILP (frame))
+ frame = selected_frame;
+
+ CHECK_STRING (prompt);
+
+ CHECK_LIVE_FRAME (frame);
+ check_window_system (XFRAME (frame));
+
+ idx = SPECPDL_INDEX ();
+ record_unwind_protect_void (unwind_popup);
+
+ struct frame *f = XFRAME (frame);
+
+ FRAME_DISPLAY_INFO (f)->focus_event_frame = f;
+
+ ++popup_activated_p;
+ char *fn = be_popup_file_dialog (!NILP (mustmatch) || !NILP (dir_only_p),
+ !NILP (dir) ? SSDATA (ENCODE_UTF_8 (dir)) : NULL,
+ !NILP (mustmatch), !NILP (dir_only_p),
+ FRAME_HAIKU_WINDOW (f),
+ !NILP (save_text) ? SSDATA (ENCODE_UTF_8 (save_text)) : NULL,
+ SSDATA (ENCODE_UTF_8 (prompt)),
+ block_input, unblock_input);
+
+ unbind_to (idx, Qnil);
+
+ block_input ();
+ BWindow_activate (FRAME_HAIKU_WINDOW (f));
+ unblock_input ();
+
+ if (!fn)
+ return Qnil;
+
+ Lisp_Object p = build_string_from_utf8 (fn);
+ free (fn);
+ return p;
+}
+
+DEFUN ("haiku-put-resource", Fhaiku_put_resource, Shaiku_put_resource,
+ 2, 2, 0, doc: /* Place STRING by the key RESOURCE in the resource database.
+It can later be retrieved with `x-get-resource'. */)
+ (Lisp_Object resource, Lisp_Object string)
+{
+ CHECK_STRING (resource);
+ if (!NILP (string))
+ CHECK_STRING (string);
+
+ put_xrm_resource (resource, string);
+ return Qnil;
+}
+
+DEFUN ("haiku-frame-list-z-order", Fhaiku_frame_list_z_order,
+ Shaiku_frame_list_z_order, 0, 1, 0,
+ doc: /* Return list of Emacs' frames, in Z (stacking) order.
+If TERMINAL is non-nil and specifies a live frame, return the child
+frames of that frame in Z (stacking) order.
+
+As it is impossible to reliably determine the frame stacking order on
+Haiku, the selected frame is always the first element of the returned
+list, while the rest are not guaranteed to be in any particular order.
+
+Frames are listed from topmost (first) to bottommost (last). */)
+ (Lisp_Object terminal)
+{
+ Lisp_Object frames = Qnil;
+ Lisp_Object head, tail;
+ Lisp_Object sel = Qnil;
+
+ FOR_EACH_FRAME (head, tail)
+ {
+ struct frame *f = XFRAME (tail);
+ if (!FRAME_HAIKU_P (f) ||
+ (FRAMEP (terminal) &&
+ FRAME_LIVE_P (XFRAME (terminal)) &&
+ !EQ (terminal, get_frame_param (f, Qparent_frame))))
+ continue;
+
+ if (EQ (tail, selected_frame))
+ sel = tail;
+ else
+ frames = Fcons (tail, frames);
+ }
+
+ if (NILP (sel))
+ return frames;
+ return Fcons (sel, frames);
+}
+
+DEFUN ("x-display-save-under", Fx_display_save_under,
+ Sx_display_save_under, 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+ check_haiku_display_info (terminal);
+
+ if (FRAMEP (terminal))
+ {
+ struct frame *f = decode_window_system_frame (terminal);
+ return FRAME_HAIKU_VIEW (f) && EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f)) ?
+ Qt : Qnil;
+ }
+
+ return Qnil;
+}
+
+frame_parm_handler haiku_frame_parm_handlers[] =
+ {
+ gui_set_autoraise,
+ gui_set_autolower,
+ haiku_set_background_color,
+ NULL, /* x_set_border_color */
+ gui_set_border_width,
+ haiku_set_cursor_color,
+ haiku_set_cursor_type,
+ gui_set_font,
+ haiku_set_foreground_color,
+ NULL, /* set icon name */
+ NULL, /* set icon type */
+ haiku_set_child_frame_border_width,
+ haiku_set_internal_border_width,
+ gui_set_right_divider_width,
+ gui_set_bottom_divider_width,
+ haiku_set_menu_bar_lines,
+ NULL, /* set mouse color */
+ haiku_explicitly_set_name,
+ gui_set_scroll_bar_width,
+ gui_set_scroll_bar_height,
+ haiku_set_title,
+ gui_set_unsplittable,
+ gui_set_vertical_scroll_bars,
+ gui_set_horizontal_scroll_bars,
+ gui_set_visibility,
+ haiku_set_tab_bar_lines,
+ haiku_set_tool_bar_lines,
+ NULL, /* set scroll bar fg */
+ NULL, /* set scroll bar bkg */
+ gui_set_screen_gamma,
+ gui_set_line_spacing,
+ gui_set_left_fringe,
+ gui_set_right_fringe,
+ NULL, /* x wait for wm */
+ gui_set_fullscreen,
+ gui_set_font_backend,
+ gui_set_alpha,
+ NULL, /* set sticky */
+ NULL, /* set tool bar pos */
+ haiku_set_inhibit_double_buffering,
+ haiku_set_undecorated,
+ haiku_set_parent_frame,
+ NULL, /* set skip taskbar */
+ haiku_set_no_focus_on_map,
+ haiku_set_no_accept_focus,
+ NULL, /* set z group */
+ NULL, /* set override redir */
+ gui_set_no_special_glyphs
+ };
+
+void
+syms_of_haikufns (void)
+{
+ DEFSYM (Qfont_parameter, "font-parameter");
+ DEFSYM (Qcancel_timer, "cancel-timer");
+ DEFSYM (Qassq_delete_all, "assq-delete-all");
+
+ DEFSYM (Qalways, "always");
+ DEFSYM (Qnot_useful, "not-useful");
+ DEFSYM (Qwhen_mapped, "when-mapped");
+
+ defsubr (&Sx_hide_tip);
+ defsubr (&Sxw_display_color_p);
+ defsubr (&Sx_display_grayscale_p);
+ defsubr (&Sx_open_connection);
+ defsubr (&Sx_create_frame);
+ defsubr (&Sx_display_pixel_width);
+ defsubr (&Sx_display_pixel_height);
+ defsubr (&Sxw_color_values);
+ defsubr (&Sxw_color_defined_p);
+ defsubr (&Sx_display_visual_class);
+ defsubr (&Sx_show_tip);
+ defsubr (&Sx_display_mm_height);
+ defsubr (&Sx_display_mm_width);
+ defsubr (&Sx_close_connection);
+ defsubr (&Sx_display_list);
+ defsubr (&Sx_server_vendor);
+ defsubr (&Sx_server_version);
+ defsubr (&Sx_display_screens);
+ defsubr (&Shaiku_get_version_string);
+ defsubr (&Sx_display_color_cells);
+ defsubr (&Sx_display_planes);
+ defsubr (&Shaiku_set_mouse_absolute_pixel_position);
+ defsubr (&Shaiku_mouse_absolute_pixel_position);
+ defsubr (&Shaiku_frame_geometry);
+ defsubr (&Shaiku_frame_edges);
+ defsubr (&Sx_double_buffered_p);
+ defsubr (&Sx_display_backing_store);
+ defsubr (&Shaiku_read_file_name);
+ defsubr (&Shaiku_put_resource);
+ defsubr (&Shaiku_frame_list_z_order);
+ defsubr (&Sx_display_save_under);
+
+ 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);
+
+ DEFVAR_LISP ("x-max-tooltip-size", Vx_max_tooltip_size,
+ doc: /* SKIP: real doc in xfns.c. */);
+ Vx_max_tooltip_size = Fcons (make_fixnum (80), make_fixnum (40));
+
+ DEFVAR_BOOL ("haiku-use-system-tooltips", haiku_use_system_tooltips,
+ doc: /* When non-nil, Emacs will display tooltips using the App Kit.
+This can avoid a great deal of consing that does not play
+well with the Haiku memory allocator, but comes with the
+disadvantage of not being able to use special display properties
+within tooltips. */);
+ haiku_use_system_tooltips = 1;
+
+#ifdef USE_BE_CAIRO
+ DEFVAR_LISP ("cairo-version-string", Vcairo_version_string,
+ doc: /* Version info for cairo. */);
+ {
+ char cairo_version[sizeof ".." + 3 * INT_STRLEN_BOUND (int)];
+ int len = sprintf (cairo_version, "%d.%d.%d",
+ CAIRO_VERSION_MAJOR, CAIRO_VERSION_MINOR,
+ CAIRO_VERSION_MICRO);
+ Vcairo_version_string = make_pure_string (cairo_version, len, len, false);
+ }
+#endif
+
+ return;
+}
diff --git a/src/haikufont.c b/src/haikufont.c
new file mode 100644
index 00000000000..811fa62a848
--- /dev/null
+++ b/src/haikufont.c
@@ -0,0 +1,1072 @@
+/* Font support for Haiku windowing
+
+Copyright (C) 2021 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 "dispextern.h"
+#include "composite.h"
+#include "blockinput.h"
+#include "charset.h"
+#include "frame.h"
+#include "window.h"
+#include "fontset.h"
+#include "haikuterm.h"
+#include "character.h"
+#include "font.h"
+#include "termchar.h"
+#include "pdumper.h"
+#include "haiku_support.h"
+
+#include <math.h>
+#include <stdlib.h>
+
+static Lisp_Object font_cache;
+
+#define METRICS_NCOLS_PER_ROW (128)
+
+enum metrics_status
+ {
+ METRICS_INVALID = -1, /* metrics entry is invalid */
+ };
+
+#define METRICS_STATUS(metrics) ((metrics)->ascent + (metrics)->descent)
+#define METRICS_SET_STATUS(metrics, status) \
+ ((metrics)->ascent = 0, (metrics)->descent = (status))
+
+static struct
+{
+ /* registry name */
+ const char *name;
+ /* characters to distinguish the charset from the others */
+ int uniquifier[6];
+ /* additional constraint by language */
+ const char *lang;
+} em_charset_table[] =
+ { { "iso8859-1", { 0x00A0, 0x00A1, 0x00B4, 0x00BC, 0x00D0 } },
+ { "iso8859-2", { 0x00A0, 0x010E }},
+ { "iso8859-3", { 0x00A0, 0x0108 }},
+ { "iso8859-4", { 0x00A0, 0x00AF, 0x0128, 0x0156, 0x02C7 }},
+ { "iso8859-5", { 0x00A0, 0x0401 }},
+ { "iso8859-6", { 0x00A0, 0x060C }},
+ { "iso8859-7", { 0x00A0, 0x0384 }},
+ { "iso8859-8", { 0x00A0, 0x05D0 }},
+ { "iso8859-9", { 0x00A0, 0x00A1, 0x00BC, 0x011E }},
+ { "iso8859-10", { 0x00A0, 0x00D0, 0x0128, 0x2015 }},
+ { "iso8859-11", { 0x00A0, 0x0E01 }},
+ { "iso8859-13", { 0x00A0, 0x201C }},
+ { "iso8859-14", { 0x00A0, 0x0174 }},
+ { "iso8859-15", { 0x00A0, 0x00A1, 0x00D0, 0x0152 }},
+ { "iso8859-16", { 0x00A0, 0x0218}},
+ { "gb2312.1980-0", { 0x4E13 }, "zh-cn"},
+ { "big5-0", { 0x9C21 }, "zh-tw" },
+ { "jisx0208.1983-0", { 0x4E55 }, "ja"},
+ { "ksc5601.1985-0", { 0xAC00 }, "ko"},
+ { "cns11643.1992-1", { 0xFE32 }, "zh-tw"},
+ { "cns11643.1992-2", { 0x4E33, 0x7934 }},
+ { "cns11643.1992-3", { 0x201A9 }},
+ { "cns11643.1992-4", { 0x20057 }},
+ { "cns11643.1992-5", { 0x20000 }},
+ { "cns11643.1992-6", { 0x20003 }},
+ { "cns11643.1992-7", { 0x20055 }},
+ { "gbk-0", { 0x4E06 }, "zh-cn"},
+ { "jisx0212.1990-0", { 0x4E44 }},
+ { "jisx0213.2000-1", { 0xFA10 }, "ja"},
+ { "jisx0213.2000-2", { 0xFA49 }},
+ { "jisx0213.2004-1", { 0x20B9F }},
+ { "viscii1.1-1", { 0x1EA0, 0x1EAE, 0x1ED2 }, "vi"},
+ { "tis620.2529-1", { 0x0E01 }, "th"},
+ { "microsoft-cp1251", { 0x0401, 0x0490 }, "ru"},
+ { "koi8-r", { 0x0401, 0x2219 }, "ru"},
+ { "mulelao-1", { 0x0E81 }, "lo"},
+ { "unicode-sip", { 0x20000 }},
+ { "mulearabic-0", { 0x628 }},
+ { "mulearabic-1", { 0x628 }},
+ { "mulearabic-2", { 0x628 }},
+ { NULL }
+ };
+
+static void
+haikufont_apply_registry (struct haiku_font_pattern *pattern,
+ Lisp_Object registry)
+{
+ char *str = SSDATA (SYMBOL_NAME (registry));
+ USE_SAFE_ALLOCA;
+ char *re = SAFE_ALLOCA (SBYTES (SYMBOL_NAME (registry)) * 2 + 1);
+ int i, j;
+
+ for (i = j = 0; i < SBYTES (SYMBOL_NAME (registry)); i++, j++)
+ {
+ if (str[i] == '.')
+ re[j++] = '\\';
+ else if (str[i] == '*')
+ re[j++] = '.';
+ re[j] = str[i];
+ if (re[j] == '?')
+ re[j] = '.';
+ }
+ re[j] = '\0';
+ AUTO_STRING_WITH_LEN (regexp, re, j);
+ for (i = 0; em_charset_table[i].name; i++)
+ if (fast_c_string_match_ignore_case
+ (regexp, em_charset_table[i].name,
+ strlen (em_charset_table[i].name)) >= 0)
+ break;
+ SAFE_FREE ();
+ if (!em_charset_table[i].name)
+ return;
+ int *uniquifier = em_charset_table[i].uniquifier;
+ int l;
+
+ for (l = 0; uniquifier[l]; ++l);
+
+ uint32_t *a = xmalloc (l * sizeof *a);
+ for (l = 0; uniquifier[l]; ++l)
+ a[l] = uniquifier[l];
+
+ if (pattern->specified & FSPEC_WANTED)
+ {
+ int old_l = l;
+ l += pattern->want_chars_len;
+ a = xrealloc (a, l * sizeof *a);
+ memcpy (&a[old_l], pattern->wanted_chars, (l - old_l) * sizeof *a);
+ xfree (pattern->wanted_chars);
+ }
+ pattern->specified |= FSPEC_WANTED;
+ pattern->want_chars_len = l;
+ pattern->wanted_chars = a;
+
+ if (em_charset_table[i].lang)
+ {
+ if (!strncmp (em_charset_table[i].lang, "zh", 2))
+ {
+ pattern->specified |= FSPEC_LANGUAGE;
+ pattern->language = LANGUAGE_CN;
+ }
+ else if (!strncmp (em_charset_table[i].lang, "ko", 2))
+ {
+ pattern->specified |= FSPEC_LANGUAGE;
+ pattern->language = LANGUAGE_KO;
+ }
+ else if (!strncmp (em_charset_table[i].lang, "ja", 2))
+ {
+ pattern->specified |= FSPEC_LANGUAGE;
+ pattern->language = LANGUAGE_JP;
+ }
+ }
+
+ return;
+}
+
+static Lisp_Object
+haikufont_get_fallback_entity (void)
+{
+ Lisp_Object ent = font_make_entity ();
+ ASET (ent, FONT_TYPE_INDEX, Qhaiku);
+ ASET (ent, FONT_FOUNDRY_INDEX, Qhaiku);
+ ASET (ent, FONT_FAMILY_INDEX, Qnil);
+ ASET (ent, FONT_ADSTYLE_INDEX, Qnil);
+ ASET (ent, FONT_REGISTRY_INDEX, Qutf_8);
+ ASET (ent, FONT_SIZE_INDEX, make_fixnum (0));
+ ASET (ent, FONT_AVGWIDTH_INDEX, make_fixnum (0));
+ ASET (ent, FONT_SPACING_INDEX, make_fixnum (FONT_SPACING_MONO));
+ FONT_SET_STYLE (ent, FONT_WIDTH_INDEX, Qnil);
+ FONT_SET_STYLE (ent, FONT_WEIGHT_INDEX, Qnil);
+ FONT_SET_STYLE (ent, FONT_SLANT_INDEX, Qnil);
+
+ return ent;
+}
+
+static Lisp_Object
+haikufont_get_cache (struct frame *frame)
+{
+ return font_cache;
+}
+
+static Lisp_Object
+haikufont_weight_to_lisp (int weight)
+{
+ switch (weight)
+ {
+ case HAIKU_THIN:
+ return Qthin;
+ case HAIKU_ULTRALIGHT:
+ return Qultra_light;
+ case HAIKU_EXTRALIGHT:
+ return Qextra_light;
+ case HAIKU_LIGHT:
+ return Qlight;
+ case HAIKU_SEMI_LIGHT:
+ return Qsemi_light;
+ case HAIKU_REGULAR:
+ return Qnormal;
+ case HAIKU_SEMI_BOLD:
+ return Qsemi_bold;
+ case HAIKU_BOLD:
+ return Qbold;
+ case HAIKU_EXTRA_BOLD:
+ return Qextra_bold;
+ case HAIKU_ULTRA_BOLD:
+ return Qultra_bold;
+ case HAIKU_BOOK:
+ return Qbook;
+ case HAIKU_HEAVY:
+ return Qheavy;
+ case HAIKU_ULTRA_HEAVY:
+ return Qultra_heavy;
+ case HAIKU_BLACK:
+ return Qblack;
+ case HAIKU_MEDIUM:
+ return Qmedium;
+ }
+ emacs_abort ();
+}
+
+static int
+haikufont_lisp_to_weight (Lisp_Object weight)
+{
+ if (EQ (weight, Qthin))
+ return HAIKU_THIN;
+ if (EQ (weight, Qultra_light))
+ return HAIKU_ULTRALIGHT;
+ if (EQ (weight, Qextra_light))
+ return HAIKU_EXTRALIGHT;
+ if (EQ (weight, Qlight))
+ return HAIKU_LIGHT;
+ if (EQ (weight, Qsemi_light))
+ return HAIKU_SEMI_LIGHT;
+ if (EQ (weight, Qnormal))
+ return HAIKU_REGULAR;
+ if (EQ (weight, Qsemi_bold))
+ return HAIKU_SEMI_BOLD;
+ if (EQ (weight, Qbold))
+ return HAIKU_BOLD;
+ if (EQ (weight, Qextra_bold))
+ return HAIKU_EXTRA_BOLD;
+ if (EQ (weight, Qultra_bold))
+ return HAIKU_ULTRA_BOLD;
+ if (EQ (weight, Qbook))
+ return HAIKU_BOOK;
+ if (EQ (weight, Qheavy))
+ return HAIKU_HEAVY;
+ if (EQ (weight, Qultra_heavy))
+ return HAIKU_ULTRA_HEAVY;
+ if (EQ (weight, Qblack))
+ return HAIKU_BLACK;
+ if (EQ (weight, Qmedium))
+ return HAIKU_MEDIUM;
+
+ emacs_abort ();
+}
+
+static Lisp_Object
+haikufont_slant_to_lisp (enum haiku_font_slant slant)
+{
+ switch (slant)
+ {
+ case NO_SLANT:
+ emacs_abort ();
+ case SLANT_ITALIC:
+ return Qitalic;
+ case SLANT_REGULAR:
+ return Qnormal;
+ case SLANT_OBLIQUE:
+ return Qoblique;
+ }
+ emacs_abort ();
+}
+
+static enum haiku_font_slant
+haikufont_lisp_to_slant (Lisp_Object slant)
+{
+ if (EQ (slant, Qitalic) ||
+ EQ (slant, Qreverse_italic))
+ return SLANT_ITALIC;
+ if (EQ (slant, Qoblique) ||
+ EQ (slant, Qreverse_oblique))
+ return SLANT_OBLIQUE;
+ if (EQ (slant, Qnormal))
+ return SLANT_REGULAR;
+ emacs_abort ();
+}
+
+static Lisp_Object
+haikufont_width_to_lisp (enum haiku_font_width width)
+{
+ switch (width)
+ {
+ case NO_WIDTH:
+ emacs_abort ();
+ case ULTRA_CONDENSED:
+ return Qultra_condensed;
+ case EXTRA_CONDENSED:
+ return Qextra_condensed;
+ case CONDENSED:
+ return Qcondensed;
+ case SEMI_CONDENSED:
+ return Qsemi_condensed;
+ case NORMAL_WIDTH:
+ return Qnormal;
+ case SEMI_EXPANDED:
+ return Qsemi_expanded;
+ case EXPANDED:
+ return Qexpanded;
+ case EXTRA_EXPANDED:
+ return Qextra_expanded;
+ case ULTRA_EXPANDED:
+ return Qultra_expanded;
+ }
+
+ emacs_abort ();
+}
+
+static enum haiku_font_width
+haikufont_lisp_to_width (Lisp_Object lisp)
+{
+ if (EQ (lisp, Qultra_condensed))
+ return ULTRA_CONDENSED;
+ if (EQ (lisp, Qextra_condensed))
+ return EXTRA_CONDENSED;
+ if (EQ (lisp, Qcondensed))
+ return CONDENSED;
+ if (EQ (lisp, Qsemi_condensed))
+ return SEMI_CONDENSED;
+ if (EQ (lisp, Qnormal))
+ return NORMAL_WIDTH;
+ if (EQ (lisp, Qexpanded))
+ return EXPANDED;
+ if (EQ (lisp, Qextra_expanded))
+ return EXTRA_EXPANDED;
+ if (EQ (lisp, Qultra_expanded))
+ return ULTRA_EXPANDED;
+ emacs_abort ();
+}
+
+static int
+haikufont_maybe_handle_special_family (Lisp_Object family,
+ struct haiku_font_pattern *ptn)
+{
+ CHECK_SYMBOL (family);
+
+ if (EQ (family, Qmonospace) || EQ (family, Qfixed) ||
+ EQ (family, Qdefault))
+ {
+ BFont_populate_fixed_family (ptn);
+ return 1;
+ }
+ else if (EQ (family, intern ("Sans Serif")))
+ {
+ BFont_populate_plain_family (ptn);
+ return 1;
+ }
+ return 0;
+}
+
+static Lisp_Object
+haikufont_pattern_to_entity (struct haiku_font_pattern *ptn)
+{
+ Lisp_Object ent = font_make_entity ();
+ ASET (ent, FONT_TYPE_INDEX, Qhaiku);
+ ASET (ent, FONT_FOUNDRY_INDEX, Qhaiku);
+ ASET (ent, FONT_FAMILY_INDEX, Qdefault);
+ ASET (ent, FONT_ADSTYLE_INDEX, Qnil);
+ ASET (ent, FONT_REGISTRY_INDEX, Qutf_8);
+ ASET (ent, FONT_SIZE_INDEX, make_fixnum (0));
+ ASET (ent, FONT_AVGWIDTH_INDEX, make_fixnum (0));
+ ASET (ent, FONT_SPACING_INDEX, make_fixnum (FONT_SPACING_MONO));
+ FONT_SET_STYLE (ent, FONT_WIDTH_INDEX, Qnormal);
+ FONT_SET_STYLE (ent, FONT_WEIGHT_INDEX, Qnormal);
+ FONT_SET_STYLE (ent, FONT_SLANT_INDEX, Qnormal);
+
+ if (ptn->specified & FSPEC_FAMILY)
+ ASET (ent, FONT_FAMILY_INDEX, intern (ptn->family));
+ else
+ ASET (ent, FONT_FAMILY_INDEX, Qdefault);
+
+ if (ptn->specified & FSPEC_STYLE)
+ ASET (ent, FONT_ADSTYLE_INDEX, intern (ptn->style));
+ else
+ {
+ if (ptn->specified & FSPEC_WEIGHT)
+ FONT_SET_STYLE (ent, FONT_WEIGHT_INDEX,
+ haikufont_weight_to_lisp (ptn->weight));
+ if (ptn->specified & FSPEC_SLANT)
+ FONT_SET_STYLE (ent, FONT_SLANT_INDEX,
+ haikufont_slant_to_lisp (ptn->slant));
+ if (ptn->specified & FSPEC_WIDTH)
+ FONT_SET_STYLE (ent, FONT_WIDTH_INDEX,
+ haikufont_width_to_lisp (ptn->width));
+ }
+
+ if (ptn->specified & FSPEC_SPACING)
+ ASET (ent, FONT_SPACING_INDEX,
+ make_fixnum (ptn->mono_spacing_p ?
+ FONT_SPACING_MONO : FONT_SPACING_PROPORTIONAL));
+ return ent;
+}
+
+static void
+haikufont_spec_or_entity_to_pattern (Lisp_Object ent,
+ int list_p,
+ struct haiku_font_pattern *ptn)
+{
+ Lisp_Object tem;
+ ptn->specified = 0;
+
+ tem = AREF (ent, FONT_ADSTYLE_INDEX);
+ if (!NILP (tem))
+ {
+ ptn->specified |= FSPEC_STYLE;
+ strncpy ((char *) &ptn->style,
+ SSDATA (SYMBOL_NAME (tem)),
+ sizeof ptn->style - 1);
+ }
+
+ tem = FONT_SLANT_SYMBOLIC (ent);
+ if (!NILP (tem))
+ {
+ ptn->specified |= FSPEC_SLANT;
+ ptn->slant = haikufont_lisp_to_slant (tem);
+ }
+
+ tem = FONT_WEIGHT_SYMBOLIC (ent);
+ if (!NILP (tem))
+ {
+ ptn->specified |= FSPEC_WEIGHT;
+ ptn->weight = haikufont_lisp_to_weight (tem);
+ }
+
+ tem = FONT_WIDTH_SYMBOLIC (ent);
+ if (!NILP (tem))
+ {
+ ptn->specified |= FSPEC_WIDTH;
+ ptn->width = haikufont_lisp_to_width (tem);
+ }
+
+ tem = AREF (ent, FONT_SPACING_INDEX);
+ if (FIXNUMP (tem))
+ {
+ ptn->specified |= FSPEC_SPACING;
+ ptn->mono_spacing_p = XFIXNUM (tem) != FONT_SPACING_PROPORTIONAL;
+ }
+
+ tem = AREF (ent, FONT_FAMILY_INDEX);
+ if (!NILP (tem) &&
+ (list_p && !haikufont_maybe_handle_special_family (tem, ptn)))
+ {
+ ptn->specified |= FSPEC_FAMILY;
+ strncpy ((char *) &ptn->family,
+ SSDATA (SYMBOL_NAME (tem)),
+ sizeof ptn->family - 1);
+ }
+
+ tem = assq_no_quit (QCscript, AREF (ent, FONT_EXTRA_INDEX));
+ if (!NILP (tem))
+ {
+ tem = assq_no_quit (XCDR (tem), Vscript_representative_chars);
+
+ if (CONSP (tem) && VECTORP (XCDR (tem)))
+ {
+ tem = XCDR (tem);
+
+ int count = 0;
+
+ for (int j = 0; j < ASIZE (tem); ++j)
+ if (TYPE_RANGED_FIXNUMP (uint32_t, AREF (tem, j)))
+ ++count;
+
+ if (count)
+ {
+ ptn->specified |= FSPEC_NEED_ONE_OF;
+ ptn->need_one_of_len = count;
+ ptn->need_one_of = xmalloc (count * sizeof *ptn->need_one_of);
+ count = 0;
+ for (int j = 0; j < ASIZE (tem); ++j)
+ if (TYPE_RANGED_FIXNUMP (uint32_t, AREF (tem, j)))
+ {
+ ptn->need_one_of[j] = XFIXNAT (AREF (tem, j));
+ ++count;
+ }
+ }
+ }
+ else if (CONSP (tem) && CONSP (XCDR (tem)))
+ {
+ int count = 0;
+
+ for (Lisp_Object it = XCDR (tem); CONSP (it); it = XCDR (it))
+ if (TYPE_RANGED_FIXNUMP (uint32_t, XCAR (it)))
+ ++count;
+
+ if (count)
+ {
+ ptn->specified |= FSPEC_WANTED;
+ ptn->want_chars_len = count;
+ ptn->wanted_chars = xmalloc (count * sizeof *ptn->wanted_chars);
+ count = 0;
+
+ for (tem = XCDR (tem); CONSP (tem); tem = XCDR (tem))
+ if (TYPE_RANGED_FIXNUMP (uint32_t, XCAR (tem)))
+ {
+ ptn->wanted_chars[count] = XFIXNAT (XCAR (tem));
+ ++count;
+ }
+ }
+ }
+ }
+
+ tem = assq_no_quit (QClang, AREF (ent, FONT_EXTRA_INDEX));
+ if (CONSP (tem))
+ {
+ tem = XCDR (tem);
+ if (EQ (tem, Qzh))
+ {
+ ptn->specified |= FSPEC_LANGUAGE;
+ ptn->language = LANGUAGE_CN;
+ }
+ else if (EQ (tem, Qko))
+ {
+ ptn->specified |= FSPEC_LANGUAGE;
+ ptn->language = LANGUAGE_KO;
+ }
+ else if (EQ (tem, Qjp))
+ {
+ ptn->specified |= FSPEC_LANGUAGE;
+ ptn->language = LANGUAGE_JP;
+ }
+ }
+
+ tem = AREF (ent, FONT_REGISTRY_INDEX);
+ if (SYMBOLP (tem))
+ haikufont_apply_registry (ptn, tem);
+}
+
+static void
+haikufont_done_with_query_pattern (struct haiku_font_pattern *ptn)
+{
+ if (ptn->specified & FSPEC_WANTED)
+ xfree (ptn->wanted_chars);
+
+ if (ptn->specified & FSPEC_NEED_ONE_OF)
+ xfree (ptn->need_one_of);
+}
+
+static Lisp_Object
+haikufont_match (struct frame *f, Lisp_Object font_spec)
+{
+ block_input ();
+ Lisp_Object tem = Qnil;
+ struct haiku_font_pattern ptn;
+ haikufont_spec_or_entity_to_pattern (font_spec, 0, &ptn);
+ ptn.specified &= ~FSPEC_FAMILY;
+ struct haiku_font_pattern *found = BFont_find (&ptn);
+ haikufont_done_with_query_pattern (&ptn);
+ if (found)
+ {
+ tem = haikufont_pattern_to_entity (found);
+ haiku_font_pattern_free (found);
+ }
+ unblock_input ();
+ return !NILP (tem) ? tem : haikufont_get_fallback_entity ();
+}
+
+static Lisp_Object
+haikufont_list (struct frame *f, Lisp_Object font_spec)
+{
+ block_input ();
+ Lisp_Object lst = Qnil;
+
+ /* Returning irrelevant results on receiving an OTF form will cause
+ fontset.c to loop over and over, making displaying some
+ characters very slow. */
+ Lisp_Object tem = assq_no_quit (QCotf, AREF (font_spec, FONT_EXTRA_INDEX));
+ if (CONSP (tem) && !NILP (XCDR (tem)))
+ {
+ unblock_input ();
+ return Qnil;
+ }
+
+ struct haiku_font_pattern ptn;
+ haikufont_spec_or_entity_to_pattern (font_spec, 1, &ptn);
+ struct haiku_font_pattern *found = BFont_find (&ptn);
+ haikufont_done_with_query_pattern (&ptn);
+ if (found)
+ {
+ for (struct haiku_font_pattern *pt = found;
+ pt; pt = pt->next)
+ lst = Fcons (haikufont_pattern_to_entity (pt), lst);
+ haiku_font_pattern_free (found);
+ }
+ unblock_input ();
+ return lst;
+}
+
+static void
+haiku_bulk_encode (struct haikufont_info *font_info, int block)
+{
+ unsigned short *unichars = xmalloc (0x101 * sizeof (*unichars));
+ unsigned int i, idx;
+
+ block_input ();
+
+ font_info->glyphs[block] = unichars;
+ if (!unichars)
+ emacs_abort ();
+
+ for (idx = block << 8, i = 0; i < 0x100; idx++, i++)
+ unichars[i] = idx;
+ unichars[0x100] = 0;
+
+
+ /* If the font contains the entire block, just store it. */
+ if (!BFont_have_char_block (font_info->be_font,
+ unichars[0], unichars[0xff]))
+ {
+ for (int i = 0; i < 0x100; ++i)
+ if (!BFont_have_char_p (font_info->be_font, unichars[i]))
+ unichars[i] = 0xFFFF;
+ }
+
+ unblock_input ();
+}
+
+static unsigned int
+haikufont_encode_char (struct font *font, int c)
+{
+ struct haikufont_info *font_info = (struct haikufont_info *) font;
+ unsigned char high = (c & 0xff00) >> 8, low = c & 0x00ff;
+ unsigned short g;
+
+ if (c > 0xFFFF)
+ return FONT_INVALID_CODE;
+
+ if (!font_info->glyphs[high])
+ haiku_bulk_encode (font_info, high);
+ g = font_info->glyphs[high][low];
+ return g == 0xFFFF ? FONT_INVALID_CODE : g;
+}
+
+static Lisp_Object
+haikufont_open (struct frame *f, Lisp_Object font_entity, int x)
+{
+ struct haikufont_info *font_info;
+ struct haiku_font_pattern ptn;
+ struct font *font;
+ void *be_font;
+ Lisp_Object font_object;
+ Lisp_Object tem;
+
+ block_input ();
+ if (x <= 0)
+ {
+ /* Get pixel size from frame instead. */
+ tem = get_frame_param (f, Qfontsize);
+ x = NILP (tem) ? 0 : XFIXNAT (tem);
+ }
+
+ haikufont_spec_or_entity_to_pattern (font_entity, 1, &ptn);
+
+ if (BFont_open_pattern (&ptn, &be_font, x))
+ {
+ haikufont_done_with_query_pattern (&ptn);
+ unblock_input ();
+ return Qnil;
+ }
+
+ haikufont_done_with_query_pattern (&ptn);
+
+ font_object = font_make_object (VECSIZE (struct haikufont_info),
+ font_entity, x);
+
+ ASET (font_object, FONT_TYPE_INDEX, Qhaiku);
+ font_info = (struct haikufont_info *) XFONT_OBJECT (font_object);
+ font = (struct font *) font_info;
+
+ if (!font)
+ {
+ unblock_input ();
+ return Qnil;
+ }
+
+ font_info->be_font = be_font;
+ font_info->glyphs = xzalloc (0x100 * sizeof *font_info->glyphs);
+
+ font->pixel_size = 0;
+ font->driver = &haikufont_driver;
+ font->encoding_charset = -1;
+ font->repertory_charset = -1;
+ font->default_ascent = 0;
+ font->vertical_centering = 0;
+ font->baseline_offset = 0;
+ font->relative_compose = 0;
+
+ font_info->metrics = NULL;
+ font_info->metrics_nrows = 0;
+
+ int px_size, min_width, max_width,
+ avg_width, height, space_width, ascent,
+ descent, underline_pos, underline_thickness;
+
+ BFont_dat (be_font, &px_size, &min_width,
+ &max_width, &avg_width, &height,
+ &space_width, &ascent, &descent,
+ &underline_pos, &underline_thickness);
+
+ font->pixel_size = px_size;
+ font->min_width = min_width;
+ font->max_width = max_width;
+ font->average_width = avg_width;
+ font->height = height;
+ font->space_width = space_width;
+ font->ascent = ascent;
+ font->descent = descent;
+ font->default_ascent = ascent;
+ font->underline_position = underline_pos;
+ font->underline_thickness = underline_thickness;
+
+ font->vertical_centering = 0;
+ font->baseline_offset = 0;
+ font->relative_compose = 0;
+
+ font->props[FONT_NAME_INDEX] = Ffont_xlfd_name (font_object, Qnil);
+
+ unblock_input ();
+ return font_object;
+}
+
+static void
+haikufont_close (struct font *font)
+{
+ if (font_data_structures_may_be_ill_formed ())
+ return;
+ struct haikufont_info *info = (struct haikufont_info *) font;
+
+ block_input ();
+ if (info && info->be_font)
+ BFont_close (info->be_font);
+
+ for (int i = 0; i < info->metrics_nrows; i++)
+ if (info->metrics[i])
+ xfree (info->metrics[i]);
+ if (info->metrics)
+ xfree (info->metrics);
+ for (int i = 0; i < 0x100; ++i)
+ if (info->glyphs[i])
+ xfree (info->glyphs[i]);
+ xfree (info->glyphs);
+ unblock_input ();
+}
+
+static void
+haikufont_prepare_face (struct frame *f, struct face *face)
+{
+
+}
+
+static void
+haikufont_glyph_extents (struct font *font, unsigned code,
+ struct font_metrics *metrics)
+{
+ struct haikufont_info *info = (struct haikufont_info *) font;
+
+ struct font_metrics *cache;
+ int row, col;
+
+ row = code / METRICS_NCOLS_PER_ROW;
+ col = code % METRICS_NCOLS_PER_ROW;
+ if (row >= info->metrics_nrows)
+ {
+ info->metrics =
+ xrealloc (info->metrics,
+ sizeof (struct font_metrics *) * (row + 1));
+ memset (info->metrics + info->metrics_nrows, 0,
+ (sizeof (struct font_metrics *)
+ * (row + 1 - info->metrics_nrows)));
+ info->metrics_nrows = row + 1;
+ }
+
+ if (info->metrics[row] == NULL)
+ {
+ struct font_metrics *new;
+ int i;
+
+ new = xmalloc (sizeof (struct font_metrics) * METRICS_NCOLS_PER_ROW);
+ for (i = 0; i < METRICS_NCOLS_PER_ROW; i++)
+ METRICS_SET_STATUS (new + i, METRICS_INVALID);
+ info->metrics[row] = new;
+ }
+ cache = info->metrics[row] + col;
+
+ if (METRICS_STATUS (cache) == METRICS_INVALID)
+ {
+ unsigned char utf8[MAX_MULTIBYTE_LENGTH];
+ memset (utf8, 0, MAX_MULTIBYTE_LENGTH);
+ CHAR_STRING (code, utf8);
+ int advance, lb, rb;
+ BFont_char_bounds (info->be_font, (const char *) utf8, &advance, &lb, &rb);
+
+ cache->lbearing = lb;
+ cache->rbearing = rb;
+ cache->width = advance;
+ cache->ascent = font->ascent;
+ cache->descent = font->descent;
+ }
+
+ if (metrics)
+ *metrics = *cache;
+}
+
+static void
+haikufont_text_extents (struct font *font, const unsigned int *code,
+ int nglyphs, struct font_metrics *metrics)
+{
+ int totalwidth = 0;
+ memset (metrics, 0, sizeof (struct font_metrics));
+
+ block_input ();
+ for (int i = 0; i < nglyphs; i++)
+ {
+ struct font_metrics m;
+ haikufont_glyph_extents (font, code[i], &m);
+ if (metrics)
+ {
+ if (totalwidth + m.lbearing < metrics->lbearing)
+ metrics->lbearing = totalwidth + m.lbearing;
+ if (totalwidth + m.rbearing > metrics->rbearing)
+ metrics->rbearing = totalwidth + m.rbearing;
+ if (m.ascent > metrics->ascent)
+ metrics->ascent = m.ascent;
+ if (m.descent > metrics->descent)
+ metrics->descent = m.descent;
+ }
+ totalwidth += m.width;
+ }
+
+ unblock_input ();
+
+ if (metrics)
+ metrics->width = totalwidth;
+}
+
+static Lisp_Object
+haikufont_shape (Lisp_Object lgstring, Lisp_Object direction)
+{
+ struct haikufont_info *font =
+ (struct haikufont_info *) CHECK_FONT_GET_OBJECT (LGSTRING_FONT (lgstring));
+ int *advance, *lb, *rb;
+ ptrdiff_t glyph_len, len, i, b_len;
+ Lisp_Object tem;
+ char *b;
+ uint32_t *mb_buf;
+
+ glyph_len = LGSTRING_GLYPH_LEN (lgstring);
+ for (i = 0; i < glyph_len; ++i)
+ {
+ tem = LGSTRING_GLYPH (lgstring, i);
+
+ if (NILP (tem))
+ break;
+ }
+
+ len = i;
+
+ if (INT_MAX / 2 < len)
+ memory_full (SIZE_MAX);
+
+ block_input ();
+
+ b_len = 0;
+ b = xmalloc (b_len);
+ mb_buf = alloca (len * sizeof *mb_buf);
+
+ for (i = b_len; i < len; ++i)
+ {
+ uint32_t c = LGLYPH_CHAR (LGSTRING_GLYPH (lgstring, i));
+ mb_buf[i] = c;
+ unsigned char mb[MAX_MULTIBYTE_LENGTH];
+ int slen = CHAR_STRING (c, mb);
+
+ b = xrealloc (b, b_len = (b_len + slen));
+ if (len == 1)
+ b[b_len - slen] = mb[0];
+ else
+ memcpy (b + b_len - slen, mb, slen);
+ }
+
+ advance = alloca (len * sizeof *advance);
+ lb = alloca (len * sizeof *lb);
+ rb = alloca (len * sizeof *rb);
+
+ eassert (font->be_font);
+ BFont_nchar_bounds (font->be_font, b, advance, lb, rb, len);
+ xfree (b);
+
+ for (i = 0; i < len; ++i)
+ {
+ tem = LGSTRING_GLYPH (lgstring, i);
+ if (NILP (tem))
+ {
+ tem = LGLYPH_NEW ();
+ LGSTRING_SET_GLYPH (lgstring, i, tem);
+ }
+
+ LGLYPH_SET_FROM (tem, i);
+ LGLYPH_SET_TO (tem, i);
+ LGLYPH_SET_CHAR (tem, mb_buf[i]);
+ LGLYPH_SET_CODE (tem, mb_buf[i]);
+
+ LGLYPH_SET_WIDTH (tem, advance[i]);
+ LGLYPH_SET_LBEARING (tem, lb[i]);
+ LGLYPH_SET_RBEARING (tem, rb[i]);
+ LGLYPH_SET_ASCENT (tem, font->font.ascent);
+ LGLYPH_SET_DESCENT (tem, font->font.descent);
+ }
+
+ unblock_input ();
+
+ return make_fixnum (len);
+}
+
+static int
+haikufont_draw (struct glyph_string *s, int from, int to,
+ int x, int y, bool with_background)
+{
+ struct frame *f = s->f;
+ struct face *face = s->face;
+ struct font_info *info = (struct font_info *) s->font;
+ unsigned char mb[MAX_MULTIBYTE_LENGTH];
+ void *view = FRAME_HAIKU_VIEW (f);
+
+ block_input ();
+ prepare_face_for_display (s->f, face);
+
+ BView_draw_lock (view);
+ BView_StartClip (view);
+ if (with_background)
+ {
+ int height = FONT_HEIGHT (s->font), ascent = FONT_BASE (s->font);
+
+ /* Font's global height and ascent values might be
+ preposterously large for some fonts. We fix here the case
+ when those fonts are used for display of glyphless
+ characters, because drawing background with font dimensions
+ in those cases makes the display illegible. There's only one
+ more call to the draw method with with_background set to
+ true, and that's in x_draw_glyph_string_foreground, when
+ drawing the cursor, where we have no such heuristics
+ available. FIXME. */
+ if (s->first_glyph->type == GLYPHLESS_GLYPH
+ && (s->first_glyph->u.glyphless.method == GLYPHLESS_DISPLAY_HEX_CODE
+ || s->first_glyph->u.glyphless.method == GLYPHLESS_DISPLAY_ACRONYM))
+ height = ascent =
+ s->first_glyph->slice.glyphless.lower_yoff
+ - s->first_glyph->slice.glyphless.upper_yoff;
+
+ BView_SetHighColor (view, s->hl == DRAW_CURSOR ?
+ FRAME_CURSOR_COLOR (s->f).pixel : face->background);
+
+ BView_FillRectangle (view, x, y - ascent, s->width, height);
+ s->background_filled_p = 1;
+ }
+
+ if (s->left_overhang && s->clip_head && !s->for_overlaps)
+ {
+ /* XXX: Why is this neccessary? */
+ BView_ClipToRect (view, s->clip_head->x, 0,
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f));
+ }
+
+ if (s->hl == DRAW_CURSOR)
+ BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg);
+ else
+ BView_SetHighColor (view, face->foreground);
+
+ BView_MovePenTo (view, x, y);
+ BView_SetFont (view, ((struct haikufont_info *) info)->be_font);
+
+ if (from == to)
+ {
+ int len = CHAR_STRING (s->char2b[from], mb);
+ BView_DrawString (view, (char *) mb, len);
+ }
+ else
+ {
+ ptrdiff_t b_len = 0;
+ char *b = xmalloc (b_len);
+
+ for (int idx = from; idx < to; ++idx)
+ {
+ int len = CHAR_STRING (s->char2b[idx], mb);
+ b = xrealloc (b, b_len = (b_len + len));
+ if (len == 1)
+ b[b_len - len] = mb[0];
+ else
+ memcpy (b + b_len - len, mb, len);
+ }
+
+ BView_DrawString (view, b, b_len);
+ xfree (b);
+ }
+ BView_EndClip (view);
+ BView_draw_unlock (view);
+ unblock_input ();
+ return 1;
+}
+
+struct font_driver const haikufont_driver =
+ {
+ .type = LISPSYM_INITIALLY (Qhaiku),
+ .case_sensitive = true,
+ .get_cache = haikufont_get_cache,
+ .list = haikufont_list,
+ .match = haikufont_match,
+ .draw = haikufont_draw,
+ .open_font = haikufont_open,
+ .close_font = haikufont_close,
+ .prepare_face = haikufont_prepare_face,
+ .encode_char = haikufont_encode_char,
+ .text_extents = haikufont_text_extents,
+ .shape = haikufont_shape
+ };
+
+void
+syms_of_haikufont (void)
+{
+ DEFSYM (Qfontsize, "fontsize");
+ DEFSYM (Qfixed, "fixed");
+ DEFSYM (Qplain, "plain");
+ DEFSYM (Qultra_light, "ultra-light");
+ DEFSYM (Qthin, "thin");
+ DEFSYM (Qreverse_italic, "reverse-italic");
+ DEFSYM (Qreverse_oblique, "reverse-oblique");
+ DEFSYM (Qmonospace, "monospace");
+ DEFSYM (Qultra_condensed, "ultra-condensed");
+ DEFSYM (Qextra_condensed, "extra-condensed");
+ DEFSYM (Qcondensed, "condensed");
+ DEFSYM (Qsemi_condensed, "semi-condensed");
+ DEFSYM (Qsemi_expanded, "semi-expanded");
+ DEFSYM (Qexpanded, "expanded");
+ DEFSYM (Qextra_expanded, "extra-expanded");
+ DEFSYM (Qultra_expanded, "ultra-expanded");
+ DEFSYM (Qzh, "zh");
+ DEFSYM (Qko, "ko");
+ DEFSYM (Qjp, "jp");
+
+ font_cache = list (Qnil);
+ staticpro (&font_cache);
+}
diff --git a/src/haikugui.h b/src/haikugui.h
new file mode 100644
index 00000000000..cfc693fb552
--- /dev/null
+++ b/src/haikugui.h
@@ -0,0 +1,106 @@
+/* Haiku window system support
+ Copyright (C) 2021 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 _HAIKU_GUI_H_
+#define _HAIKU_GUI_H_
+
+#ifdef _cplusplus
+extern "C"
+{
+#endif
+
+typedef struct haiku_char_struct
+{
+ int rbearing;
+ int lbearing;
+ int width;
+ int ascent;
+ int descent;
+} XCharStruct;
+
+struct haiku_rect
+{
+ int x, y;
+ int width, height;
+};
+
+typedef void *haiku;
+
+typedef haiku Emacs_Pixmap;
+typedef haiku Emacs_Window;
+typedef haiku Emacs_Cursor;
+typedef haiku Drawable;
+
+#define NativeRectangle struct haiku_rect
+#define CONVERT_TO_EMACS_RECT(xr, nr) \
+ ((xr).x = (nr).x, \
+ (xr).y = (nr).y, \
+ (xr).width = (nr).width, \
+ (xr).height = (nr).height)
+
+#define CONVERT_FROM_EMACS_RECT(xr, nr) \
+ ((nr).x = (xr).x, \
+ (nr).y = (xr).y, \
+ (nr).width = (xr).width, \
+ (nr).height = (xr).height)
+
+#define STORE_NATIVE_RECT(nr, px, py, pwidth, pheight) \
+ ((nr).x = (px), \
+ (nr).y = (py), \
+ (nr).width = (pwidth), \
+ (nr).height = (pheight))
+
+#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 */
+
+typedef haiku Window;
+typedef int Display;
+
+#ifdef _cplusplus
+};
+#endif
+#endif /* _HAIKU_GUI_H_ */
diff --git a/src/haikuimage.c b/src/haikuimage.c
new file mode 100644
index 00000000000..138e5b84e6a
--- /dev/null
+++ b/src/haikuimage.c
@@ -0,0 +1,109 @@
+/* Haiku window system support.
+ Copyright (C) 2021 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 "dispextern.h"
+#include "haikuterm.h"
+#include "coding.h"
+
+#include "haiku_support.h"
+
+bool
+haiku_can_use_native_image_api (Lisp_Object type)
+{
+ const char *mime_type = NULL;
+
+ if (EQ (type, Qnative_image))
+ return 1;
+
+#ifdef HAVE_RSVG
+ if (EQ (type, Qsvg))
+ return 0;
+#endif
+
+ if (EQ (type, Qjpeg))
+ mime_type = "image/jpeg";
+ else if (EQ (type, Qpng))
+ mime_type = "image/png";
+ else if (EQ (type, Qgif))
+ mime_type = "image/gif";
+ else if (EQ (type, Qtiff))
+ mime_type = "image/tiff";
+ else if (EQ (type, Qbmp))
+ mime_type = "image/bmp";
+ else if (EQ (type, Qsvg))
+ mime_type = "image/svg";
+ else if (EQ (type, Qpbm))
+ mime_type = "image/pbm";
+
+ if (!mime_type)
+ return 0;
+
+ return be_can_translate_type_to_bitmap_p (mime_type);
+}
+
+extern int
+haiku_load_image (struct frame *f, struct image *img,
+ Lisp_Object spec_file, Lisp_Object spec_data)
+{
+ eassert (valid_image_p (img->spec));
+
+ void *pixmap = NULL;
+
+ if (STRINGP (spec_file))
+ {
+ pixmap = be_translate_bitmap_from_file_name
+ (SSDATA (ENCODE_UTF_8 (spec_file)));
+ }
+ else if (STRINGP (spec_data))
+ {
+ pixmap = be_translate_bitmap_from_memory
+ (SSDATA (spec_data), SBYTES (spec_data));
+ }
+
+ void *conv = NULL;
+
+ if (!pixmap || !BBitmap_convert (pixmap, &conv))
+ {
+ add_to_log ("Unable to load image %s", img->spec);
+ return 0;
+ }
+
+ if (conv)
+ {
+ BBitmap_free (pixmap);
+ pixmap = conv;
+ }
+
+ int left, top, right, bottom, stride, mono_p;
+ BBitmap_dimensions (pixmap, &left, &top, &right, &bottom, &stride, &mono_p);
+
+ img->width = (1 + right - left);
+ img->height = (1 + bottom - top);
+ img->pixmap = pixmap;
+
+ return 1;
+}
+
+void
+syms_of_haikuimage (void)
+{
+ DEFSYM (Qbmp, "bmp");
+}
diff --git a/src/haikumenu.c b/src/haikumenu.c
new file mode 100644
index 00000000000..698da9d639c
--- /dev/null
+++ b/src/haikumenu.c
@@ -0,0 +1,656 @@
+/* Haiku window system support
+ Copyright (C) 2021 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 "frame.h"
+#include "keyboard.h"
+#include "menu.h"
+#include "buffer.h"
+#include "blockinput.h"
+
+#include "haikuterm.h"
+#include "haiku_support.h"
+
+static Lisp_Object *volatile menu_item_selection;
+
+int popup_activated_p = 0;
+
+struct submenu_stack_cell
+{
+ void *parent_menu;
+ void *pane;
+};
+
+static void
+digest_menu_items (void *first_menu, int start, int menu_items_used,
+ int mbar_p)
+{
+ void **menus, **panes;
+ ssize_t menu_len = (menu_items_used + 1 - start) * sizeof *menus;
+ ssize_t pane_len = (menu_items_used + 1 - start) * sizeof *panes;
+
+ menus = alloca (menu_len);
+ panes = alloca (pane_len);
+
+ int i = start, menu_depth = 0;
+
+ memset (menus, 0, menu_len);
+ memset (panes, 0, pane_len);
+
+ void *menu = first_menu;
+
+ menus[0] = first_menu;
+
+ void *window = NULL;
+ if (FRAMEP (Vmenu_updating_frame) &&
+ FRAME_LIVE_P (XFRAME (Vmenu_updating_frame)) &&
+ FRAME_HAIKU_P (XFRAME (Vmenu_updating_frame)))
+ window = FRAME_HAIKU_WINDOW (XFRAME (Vmenu_updating_frame));
+
+ while (i < menu_items_used)
+ {
+ if (NILP (AREF (menu_items, i)))
+ {
+ menus[++menu_depth] = menu;
+ i++;
+ }
+ else if (EQ (AREF (menu_items, i), Qlambda))
+ {
+ panes[menu_depth] = NULL;
+ menu = panes[--menu_depth] ? panes[menu_depth] : menus[menu_depth];
+ i++;
+ }
+ else if (EQ (AREF (menu_items, i), Qquote))
+ i += 1;
+ else if (EQ (AREF (menu_items, i), Qt))
+ {
+ Lisp_Object pane_name, prefix;
+ const char *pane_string;
+
+ if (menu_items_n_panes == 1)
+ {
+ i += MENU_ITEMS_PANE_LENGTH;
+ continue;
+ }
+
+ pane_name = AREF (menu_items, i + MENU_ITEMS_PANE_NAME);
+ prefix = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX);
+
+ if (STRINGP (pane_name) && STRING_MULTIBYTE (pane_name))
+ {
+ pane_name = ENCODE_UTF_8 (pane_name);
+ ASET (menu_items, i + MENU_ITEMS_PANE_NAME, pane_name);
+ }
+
+ pane_string = (NILP (pane_name)
+ ? "" : SSDATA (pane_name));
+ if (!NILP (prefix))
+ pane_string++;
+
+ if (strcmp (pane_string, ""))
+ {
+ panes[menu_depth] =
+ menu = BMenu_new_submenu (menus[menu_depth], pane_string, 1);
+ }
+
+ i += MENU_ITEMS_PANE_LENGTH;
+ }
+ else
+ {
+ Lisp_Object item_name, enable, descrip, def, selected, help;
+ item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME);
+ enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE);
+ descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY);
+ def = AREF (menu_items, i + MENU_ITEMS_ITEM_DEFINITION);
+ selected = AREF (menu_items, i + MENU_ITEMS_ITEM_SELECTED);
+ help = AREF (menu_items, i + MENU_ITEMS_ITEM_HELP);
+
+ if (STRINGP (item_name) && STRING_MULTIBYTE (item_name))
+ {
+ item_name = ENCODE_UTF_8 (item_name);
+ ASET (menu_items, i + MENU_ITEMS_ITEM_NAME, item_name);
+ }
+
+ if (STRINGP (descrip) && STRING_MULTIBYTE (descrip))
+ {
+ descrip = ENCODE_UTF_8 (descrip);
+ ASET (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY, descrip);
+ }
+
+ if (STRINGP (help) && STRING_MULTIBYTE (help))
+ {
+ help = ENCODE_UTF_8 (help);
+ ASET (menu_items, i + MENU_ITEMS_ITEM_HELP, help);
+ }
+
+ if (i + MENU_ITEMS_ITEM_LENGTH < menu_items_used &&
+ NILP (AREF (menu_items, i + MENU_ITEMS_ITEM_LENGTH)))
+ menu = BMenu_new_submenu (menu, SSDATA (item_name), !NILP (enable));
+ else if (NILP (def) && menu_separator_name_p (SSDATA (item_name)))
+ BMenu_add_separator (menu);
+ else if (!mbar_p)
+ BMenu_add_item (menu, SSDATA (item_name),
+ !NILP (def) ? aref_addr (menu_items, i) : NULL,
+ !NILP (enable), !NILP (selected), 0, window,
+ !NILP (descrip) ? SSDATA (descrip) : NULL,
+ STRINGP (help) ? SSDATA (help) : NULL);
+ else
+ BMenu_add_item (menu, SSDATA (item_name),
+ !NILP (def) ? (void *) (intptr_t) i : NULL,
+ !NILP (enable), !NILP (selected), 1, window,
+ !NILP (descrip) ? SSDATA (descrip) : NULL,
+ STRINGP (help) ? SSDATA (help) : NULL);
+
+ i += MENU_ITEMS_ITEM_LENGTH;
+ }
+ }
+}
+
+static Lisp_Object
+haiku_dialog_show (struct frame *f, Lisp_Object title,
+ Lisp_Object header, const char **error_name)
+{
+ int i, nb_buttons = 0;
+
+ *error_name = NULL;
+
+ if (menu_items_n_panes > 1)
+ {
+ *error_name = "Multiple panes in dialog box";
+ return Qnil;
+ }
+
+ Lisp_Object pane_name = AREF (menu_items, MENU_ITEMS_PANE_NAME);
+ i = MENU_ITEMS_PANE_LENGTH;
+
+ if (STRING_MULTIBYTE (pane_name))
+ pane_name = ENCODE_UTF_8 (pane_name);
+
+ block_input ();
+ void *alert = BAlert_new (SSDATA (pane_name), NILP (header) ? HAIKU_INFO_ALERT :
+ HAIKU_IDEA_ALERT);
+
+ Lisp_Object vals[10];
+
+ while (i < menu_items_used)
+ {
+ Lisp_Object item_name, enable, descrip, value;
+ item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME);
+ enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE);
+ descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY);
+ value = AREF (menu_items, i + MENU_ITEMS_ITEM_VALUE);
+
+ if (NILP (item_name))
+ {
+ BAlert_delete (alert);
+ *error_name = "Submenu in dialog items";
+ unblock_input ();
+ return Qnil;
+ }
+
+ if (EQ (item_name, Qquote))
+ {
+ i++;
+ }
+
+ if (nb_buttons >= 9)
+ {
+ BAlert_delete (alert);
+ *error_name = "Too many dialog items";
+ unblock_input ();
+ return Qnil;
+ }
+
+ if (STRING_MULTIBYTE (item_name))
+ item_name = ENCODE_UTF_8 (item_name);
+ if (!NILP (descrip) && STRING_MULTIBYTE (descrip))
+ descrip = ENCODE_UTF_8 (descrip);
+
+ void *button = BAlert_add_button (alert, SSDATA (item_name));
+
+ BButton_set_enabled (button, !NILP (enable));
+ if (!NILP (descrip))
+ BView_set_tooltip (button, SSDATA (descrip));
+
+ vals[nb_buttons] = value;
+ ++nb_buttons;
+ i += MENU_ITEMS_ITEM_LENGTH;
+ }
+
+ int32_t val = BAlert_go (alert);
+ unblock_input ();
+
+ if (val < 0)
+ quit ();
+ else
+ return vals[val];
+
+ return Qnil;
+}
+
+Lisp_Object
+haiku_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents)
+{
+ Lisp_Object title;
+ const char *error_name = NULL;
+ Lisp_Object selection;
+ ptrdiff_t 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. Also, the lesstif/motif version crashes if there are
+ no buttons. */
+ contents = list2 (title, Fcons (build_string ("Ok"), Qt));
+
+ list_of_panes (list1 (contents));
+
+ /* Display them in a dialog box. */
+ block_input ();
+ selection = haiku_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;
+}
+
+Lisp_Object
+haiku_menu_show (struct frame *f, int x, int y, int menuflags,
+ Lisp_Object title, const char **error_name)
+{
+ int i = 0, submenu_depth = 0;
+ void *view = FRAME_HAIKU_VIEW (f);
+ void *menu;
+
+ Lisp_Object *subprefix_stack =
+ alloca (menu_items_used * sizeof (Lisp_Object));
+
+ eassert (FRAME_HAIKU_P (f));
+
+ *error_name = NULL;
+
+ if (menu_items_used <= MENU_ITEMS_PANE_LENGTH)
+ {
+ *error_name = "Empty menu";
+ return Qnil;
+ }
+
+ block_input ();
+ if (STRINGP (title) && STRING_MULTIBYTE (title))
+ title = ENCODE_UTF_8 (title);
+
+ menu = BPopUpMenu_new (STRINGP (title) ? SSDATA (title) : NULL);
+ if (STRINGP (title))
+ {
+ BMenu_add_title (menu, SSDATA (title));
+ BMenu_add_separator (menu);
+ }
+ digest_menu_items (menu, 0, menu_items_used, 0);
+ BView_convert_to_screen (view, &x, &y);
+ unblock_input ();
+
+ menu_item_selection = BMenu_run (menu, x, y);
+
+ FRAME_DISPLAY_INFO (f)->grabbed = 0;
+
+ if (menu_item_selection)
+ {
+ Lisp_Object prefix, entry;
+
+ prefix = entry = Qnil;
+ i = 0;
+ while (i < menu_items_used)
+ {
+ if (NILP (AREF (menu_items, i)))
+ {
+ subprefix_stack[submenu_depth++] = prefix;
+ prefix = entry;
+ i++;
+ }
+ else if (EQ (AREF (menu_items, i), Qlambda))
+ {
+ prefix = subprefix_stack[--submenu_depth];
+ 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 (menu_item_selection == aref_addr (menu_items, i))
+ {
+ if (menuflags & MENU_KEYMAPS)
+ {
+ int j;
+
+ entry = list1 (entry);
+ if (!NILP (prefix))
+ entry = Fcons (prefix, entry);
+ for (j = submenu_depth - 1; j >= 0; j--)
+ if (!NILP (subprefix_stack[j]))
+ entry = Fcons (subprefix_stack[j], entry);
+ }
+ BPopUpMenu_delete (menu);
+ return entry;
+ }
+ i += MENU_ITEMS_ITEM_LENGTH;
+ }
+ }
+ }
+ else if (!(menuflags & MENU_FOR_CLICK))
+ {
+ BPopUpMenu_delete (menu);
+ quit ();
+ }
+ BPopUpMenu_delete (menu);
+ return Qnil;
+}
+
+void
+free_frame_menubar (struct frame *f)
+{
+ FRAME_MENU_BAR_LINES (f) = 0;
+ FRAME_MENU_BAR_HEIGHT (f) = 0;
+ FRAME_EXTERNAL_MENU_BAR (f) = 0;
+
+ block_input ();
+ void *mbar = FRAME_HAIKU_MENU_BAR (f);
+ if (mbar)
+ BMenuBar_delete (mbar);
+ if (FRAME_OUTPUT_DATA (f)->menu_bar_open_p)
+ --popup_activated_p;
+ FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 0;
+ unblock_input ();
+
+ adjust_frame_size (f, -1, -1, 2, false, Qmenu_bar_lines);
+}
+
+void
+initialize_frame_menubar (struct frame *f)
+{
+ /* This function is called before the first chance to redisplay
+ the frame. It has to be, so the frame will have the right size. */
+ fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f)));
+ set_frame_menubar (f, true);
+}
+
+void
+set_frame_menubar (struct frame *f, bool deep_p)
+{
+ void *mbar = FRAME_HAIKU_MENU_BAR (f);
+ void *view = FRAME_HAIKU_VIEW (f);
+
+ int first_time_p = 0;
+
+ if (!mbar)
+ {
+ mbar = FRAME_HAIKU_MENU_BAR (f) = BMenuBar_new (view);
+ first_time_p = 1;
+ }
+
+ Lisp_Object items;
+ struct buffer *prev = current_buffer;
+ Lisp_Object buffer;
+ ptrdiff_t specpdl_count = SPECPDL_INDEX ();
+ int previous_menu_items_used = f->menu_bar_items_used;
+ Lisp_Object *previous_items
+ = alloca (previous_menu_items_used * sizeof *previous_items);
+
+ XSETFRAME (Vmenu_updating_frame, f);
+
+ if (!deep_p)
+ {
+ FRAME_OUTPUT_DATA (f)->menu_up_to_date_p = 0;
+ items = FRAME_MENU_BAR_ITEMS (f);
+ Lisp_Object string;
+
+ block_input ();
+ int count = BMenu_count_items (mbar);
+
+ int i;
+ for (i = 0; i < ASIZE (items); i += 4)
+ {
+ string = AREF (items, i + 1);
+
+ if (!STRINGP (string))
+ break;
+
+ if (STRING_MULTIBYTE (string))
+ string = ENCODE_UTF_8 (string);
+
+ if (i / 4 < count)
+ {
+ void *it = BMenu_item_at (mbar, i / 4);
+ BMenu_item_set_label (it, SSDATA (string));
+ }
+ else
+ BMenu_new_menu_bar_submenu (mbar, SSDATA (string));
+ }
+
+ if (i / 4 < count)
+ BMenu_delete_from (mbar, i / 4, count - i / 4 + 1);
+ unblock_input ();
+
+ f->menu_bar_items_used = 0;
+ }
+ else
+ {
+ /* If we are making a new widget, its contents are empty,
+ do always reinitialize them. */
+ if (first_time_p)
+ previous_menu_items_used = 0;
+ buffer = XWINDOW (FRAME_SELECTED_WINDOW (f))->contents;
+ specbind (Qinhibit_quit, Qt);
+ /* Don't let the debugger step into this code
+ because it is not reentrant. */
+ specbind (Qdebug_on_next_call, Qnil);
+
+ record_unwind_save_match_data ();
+ if (NILP (Voverriding_local_map_menu_flag))
+ {
+ specbind (Qoverriding_terminal_local_map, Qnil);
+ specbind (Qoverriding_local_map, Qnil);
+ }
+
+ set_buffer_internal_1 (XBUFFER (buffer));
+
+ /* Run the Lucid hook. */
+ safe_run_hooks (Qactivate_menubar_hook);
+
+ /* If it has changed current-menubar from previous value,
+ really recompute the menubar from the value. */
+ if (! NILP (Vlucid_menu_bar_dirty_flag))
+ call0 (Qrecompute_lucid_menubar);
+ safe_run_hooks (Qmenu_bar_update_hook);
+ fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f)));
+
+ items = FRAME_MENU_BAR_ITEMS (f);
+
+ /* Save the frame's previous menu bar contents data. */
+ if (previous_menu_items_used)
+ memcpy (previous_items, xvector_contents (f->menu_bar_vector),
+ previous_menu_items_used * word_size);
+
+ /* Fill in menu_items with the current menu bar contents.
+ This can evaluate Lisp code. */
+ save_menu_items ();
+ menu_items = f->menu_bar_vector;
+ menu_items_allocated = VECTORP (menu_items) ? ASIZE (menu_items) : 0;
+ init_menu_items ();
+ int i;
+ int count = BMenu_count_items (mbar);
+ int subitems = ASIZE (items) / 4;
+
+ int *submenu_start, *submenu_end, *submenu_n_panes;
+ Lisp_Object *submenu_names;
+
+ submenu_start = alloca ((subitems + 1) * sizeof *submenu_start);
+ submenu_end = alloca (subitems * sizeof *submenu_end);
+ submenu_n_panes = alloca (subitems * sizeof *submenu_n_panes);
+ submenu_names = alloca (subitems * sizeof (Lisp_Object));
+
+ for (i = 0; i < subitems; ++i)
+ {
+ Lisp_Object key, string, maps;
+
+ key = AREF (items, i * 4);
+ string = AREF (items, i * 4 + 1);
+ maps = AREF (items, i * 4 + 2);
+
+ if (NILP (string))
+ break;
+
+ if (STRINGP (string) && STRING_MULTIBYTE (string))
+ string = ENCODE_UTF_8 (string);
+
+ submenu_start[i] = menu_items_used;
+ menu_items_n_panes = 0;
+ parse_single_submenu (key, string, maps);
+ submenu_n_panes[i] = menu_items_n_panes;
+ submenu_end[i] = menu_items_used;
+ submenu_names[i] = string;
+ }
+ finish_menu_items ();
+ submenu_start[i] = -1;
+
+ block_input ();
+ for (i = 0; submenu_start[i] >= 0; ++i)
+ {
+ void *mn = NULL;
+ if (i < count)
+ mn = BMenu_item_get_menu (BMenu_item_at (mbar, i));
+ if (mn)
+ BMenu_delete_all (mn);
+ else
+ mn = BMenu_new_menu_bar_submenu (mbar, SSDATA (submenu_names[i]));
+
+ menu_items_n_panes = submenu_n_panes[i];
+ digest_menu_items (mn, submenu_start[i], submenu_end[i], 1);
+ }
+ unblock_input ();
+
+ set_buffer_internal_1 (prev);
+
+ FRAME_OUTPUT_DATA (f)->menu_up_to_date_p = 1;
+ fset_menu_bar_vector (f, menu_items);
+ f->menu_bar_items_used = menu_items_used;
+ }
+ unbind_to (specpdl_count, Qnil);
+}
+
+void
+run_menu_bar_help_event (struct frame *f, int mb_idx)
+{
+ Lisp_Object frame;
+ Lisp_Object vec;
+ Lisp_Object help;
+
+ block_input ();
+ if (!FRAME_OUTPUT_DATA (f)->menu_up_to_date_p)
+ {
+ unblock_input ();
+ return;
+ }
+
+ XSETFRAME (frame, f);
+
+ if (mb_idx < 0)
+ {
+ kbd_buffer_store_help_event (frame, Qnil);
+ unblock_input ();
+ return;
+ }
+
+ vec = f->menu_bar_vector;
+ if (mb_idx >= ASIZE (vec))
+ emacs_abort ();
+
+ help = AREF (vec, mb_idx + MENU_ITEMS_ITEM_HELP);
+ if (STRINGP (help) || NILP (help))
+ kbd_buffer_store_help_event (frame, help);
+ unblock_input ();
+}
+
+DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p, Smenu_or_popup_active_p,
+ 0, 0, 0, doc: /* SKIP: real doc in xmenu.c. */)
+ (void)
+{
+ return popup_activated_p ? Qt : Qnil;
+}
+
+DEFUN ("haiku-menu-bar-open", Fhaiku_menu_bar_open, Shaiku_menu_bar_open, 0, 1, "i",
+ doc: /* Show the menu bar in FRAME.
+
+Move the mouse pointer onto the first element of FRAME's menu bar, and
+cause it to be opened. If FRAME is nil or not given, use the selected
+frame. If FRAME has no menu bar, a pop-up is displayed at the position
+of the last non-menu event instead. */)
+ (Lisp_Object frame)
+{
+ struct frame *f = decode_window_system_frame (frame);
+
+ if (FRAME_EXTERNAL_MENU_BAR (f))
+ {
+ if (!FRAME_OUTPUT_DATA (f)->menu_up_to_date_p)
+ set_frame_menubar (f, 1);
+ }
+ else
+ {
+ return call2 (Qpopup_menu, call0 (Qmouse_menu_bar_map),
+ last_nonmenu_event);
+ }
+
+ block_input ();
+ BMenuBar_start_tracking (FRAME_HAIKU_MENU_BAR (f));
+ unblock_input ();
+
+ return Qnil;
+}
+
+void
+syms_of_haikumenu (void)
+{
+ DEFSYM (Qdebug_on_next_call, "debug-on-next-call");
+ DEFSYM (Qpopup_menu, "popup-menu");
+ DEFSYM (Qmouse_menu_bar_map, "mouse-menu-bar-map");
+
+ defsubr (&Smenu_or_popup_active_p);
+ defsubr (&Shaiku_menu_bar_open);
+ return;
+}
diff --git a/src/haikuselect.c b/src/haikuselect.c
new file mode 100644
index 00000000000..38cceb1de74
--- /dev/null
+++ b/src/haikuselect.c
@@ -0,0 +1,180 @@
+/* Haiku window system selection support.
+ Copyright (C) 2021 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 "blockinput.h"
+#include "coding.h"
+#include "haikuselect.h"
+#include "haikuterm.h"
+
+static Lisp_Object
+haiku_selection_data_1 (Lisp_Object clipboard)
+{
+ Lisp_Object result = Qnil;
+ char *targets[256];
+
+ block_input ();
+ if (EQ (clipboard, QPRIMARY))
+ BClipboard_primary_targets ((char **) &targets, 256);
+ else if (EQ (clipboard, QSECONDARY))
+ BClipboard_secondary_targets ((char **) &targets, 256);
+ else if (EQ (clipboard, QCLIPBOARD))
+ BClipboard_system_targets ((char **) &targets, 256);
+ else
+ {
+ unblock_input ();
+ signal_error ("Bad clipboard", clipboard);
+ }
+
+ for (int i = 0; targets[i]; ++i)
+ {
+ result = Fcons (build_unibyte_string (targets[i]),
+ result);
+ free (targets[i]);
+ }
+ unblock_input ();
+
+ return result;
+}
+
+DEFUN ("haiku-selection-targets", Fhaiku_selection_targets,
+ Shaiku_selection_targets, 1, 1, 0,
+ doc: /* Find the types of data available from CLIPBOARD.
+CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'.
+Return the available types as a list of strings. */)
+ (Lisp_Object clipboard)
+{
+ return haiku_selection_data_1 (clipboard);
+}
+
+DEFUN ("haiku-selection-data", Fhaiku_selection_data, Shaiku_selection_data,
+ 2, 2, 0,
+ doc: /* Retrieve content typed as NAME from the clipboard
+CLIPBOARD. CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or
+`CLIPBOARD'. NAME is a MIME type denoting the type of the data to
+fetch. */)
+ (Lisp_Object clipboard, Lisp_Object name)
+{
+ CHECK_SYMBOL (clipboard);
+ CHECK_STRING (name);
+ char *dat;
+ ssize_t len;
+
+ block_input ();
+ if (EQ (clipboard, QPRIMARY))
+ dat = BClipboard_find_primary_selection_data (SSDATA (name), &len);
+ else if (EQ (clipboard, QSECONDARY))
+ dat = BClipboard_find_secondary_selection_data (SSDATA (name), &len);
+ else if (EQ (clipboard, QCLIPBOARD))
+ dat = BClipboard_find_system_data (SSDATA (name), &len);
+ else
+ {
+ unblock_input ();
+ signal_error ("Bad clipboard", clipboard);
+ }
+ unblock_input ();
+
+ if (!dat)
+ return Qnil;
+
+ Lisp_Object str = make_unibyte_string (dat, len);
+ Lisp_Object lispy_type = Qnil;
+
+ if (!strcmp (SSDATA (name), "text/utf-8") ||
+ !strcmp (SSDATA (name), "text/plain"))
+ {
+ if (string_ascii_p (str))
+ lispy_type = QSTRING;
+ else
+ lispy_type = QUTF8_STRING;
+ }
+
+ if (!NILP (lispy_type))
+ Fput_text_property (make_fixnum (0), make_fixnum (len),
+ Qforeign_selection, lispy_type, str);
+
+ block_input ();
+ BClipboard_free_data (dat);
+ unblock_input ();
+
+ return str;
+}
+
+DEFUN ("haiku-selection-put", Fhaiku_selection_put, Shaiku_selection_put,
+ 3, 4, 0,
+ doc: /* Add or remove content from the clipboard CLIPBOARD.
+CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. NAME
+is a MIME type denoting the type of the data to add. DATA is the
+string that will be placed in the clipboard, or nil if the content is
+to be removed. If NAME is the string "text/utf-8" or the string
+"text/plain", encode it as UTF-8 before storing it into the clipboard.
+CLEAR, if non-nil, means to erase all the previous contents of the
+clipboard. */)
+ (Lisp_Object clipboard, Lisp_Object name, Lisp_Object data,
+ Lisp_Object clear)
+{
+ CHECK_SYMBOL (clipboard);
+ CHECK_STRING (name);
+ if (!NILP (data))
+ CHECK_STRING (data);
+
+ block_input ();
+ /* It seems that Haiku applications counter-intuitively expect
+ UTF-8 data in both text/utf-8 and text/plain. */
+ if (!NILP (data) && STRING_MULTIBYTE (data) &&
+ (!strcmp (SSDATA (name), "text/utf-8") ||
+ !strcmp (SSDATA (name), "text/plain")))
+ data = ENCODE_UTF_8 (data);
+
+ char *dat = !NILP (data) ? SSDATA (data) : NULL;
+ ptrdiff_t len = !NILP (data) ? SBYTES (data) : 0;
+
+ if (EQ (clipboard, QPRIMARY))
+ BClipboard_set_primary_selection_data (SSDATA (name), dat, len,
+ !NILP (clear));
+ else if (EQ (clipboard, QSECONDARY))
+ BClipboard_set_secondary_selection_data (SSDATA (name), dat, len,
+ !NILP (clear));
+ else if (EQ (clipboard, QCLIPBOARD))
+ BClipboard_set_system_data (SSDATA (name), dat, len, !NILP (clear));
+ else
+ {
+ unblock_input ();
+ signal_error ("Bad clipboard", clipboard);
+ }
+ unblock_input ();
+
+ return Qnil;
+}
+
+void
+syms_of_haikuselect (void)
+{
+ DEFSYM (QSECONDARY, "SECONDARY");
+ DEFSYM (QCLIPBOARD, "CLIPBOARD");
+ DEFSYM (QSTRING, "STRING");
+ DEFSYM (QUTF8_STRING, "UTF8_STRING");
+ DEFSYM (Qforeign_selection, "foreign-selection");
+ DEFSYM (QTARGETS, "TARGETS");
+
+ defsubr (&Shaiku_selection_data);
+ defsubr (&Shaiku_selection_put);
+ defsubr (&Shaiku_selection_targets);
+}
diff --git a/src/haikuselect.h b/src/haikuselect.h
new file mode 100644
index 00000000000..1a3a945f98d
--- /dev/null
+++ b/src/haikuselect.h
@@ -0,0 +1,74 @@
+/* Haiku window system selection support. Hey Emacs, this is -*- C++ -*-
+ Copyright (C) 2021 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 _HAIKU_SELECT_H_
+#define _HAIKU_SELECT_H_
+
+#ifdef __cplusplus
+#include <cstdio>
+#endif
+
+#ifdef __cplusplus
+#include <stdio.h>
+extern "C"
+{
+ extern void init_haiku_select (void);
+#endif
+
+ /* Whether or not the selection was recently changed. */
+ extern int selection_state_flag;
+
+ /* Find a string with the MIME type TYPE in the system clipboard. */
+ extern char *
+ BClipboard_find_system_data (const char *type, ssize_t *len);
+
+ /* Ditto, but for the primary selection and not clipboard. */
+ extern char *
+ BClipboard_find_primary_selection_data (const char *type, ssize_t *len);
+
+ /* Ditto, this time for the secondary selection. */
+ extern char *
+ BClipboard_find_secondary_selection_data (const char *type, ssize_t *len);
+
+ extern void
+ BClipboard_set_system_data (const char *type, const char *data, ssize_t len,
+ bool clear);
+
+ extern void
+ BClipboard_set_primary_selection_data (const char *type, const char *data,
+ ssize_t len, bool clear);
+
+ extern void
+ BClipboard_set_secondary_selection_data (const char *type, const char *data,
+ ssize_t len, bool clear);
+
+ extern void
+ BClipboard_system_targets (char **buf, int len);
+
+ extern void
+ BClipboard_primary_targets (char **buf, int len);
+
+ extern void
+ BClipboard_secondary_targets (char **buf, int len);
+
+ /* Free the returned data. */
+ extern void BClipboard_free_data (void *ptr);
+#ifdef __cplusplus
+};
+#endif
+#endif /* _HAIKU_SELECT_H_ */
diff --git a/src/haikuterm.c b/src/haikuterm.c
new file mode 100644
index 00000000000..24fa44b01d0
--- /dev/null
+++ b/src/haikuterm.c
@@ -0,0 +1,3647 @@
+/* Haiku window system support
+ Copyright (C) 2021 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 "dispextern.h"
+#include "frame.h"
+#include "lisp.h"
+#include "haikugui.h"
+#include "keyboard.h"
+#include "haikuterm.h"
+#include "blockinput.h"
+#include "termchar.h"
+#include "termhooks.h"
+#include "menu.h"
+#include "buffer.h"
+#include "haiku_support.h"
+#include "thread.h"
+#include "window.h"
+
+#include <math.h>
+#include <stdlib.h>
+
+#ifdef USE_BE_CAIRO
+#include <cairo.h>
+#endif
+
+struct haiku_display_info *x_display_list = NULL;
+extern frame_parm_handler haiku_frame_parm_handlers[];
+
+static void **fringe_bmps;
+static int fringe_bitmap_fillptr = 0;
+
+static Lisp_Object rdb;
+
+struct unhandled_event
+{
+ struct unhandled_event *next;
+ enum haiku_event_type type;
+ uint8_t buffer[200];
+};
+
+char *
+get_keysym_name (int keysym)
+{
+ static char value[16];
+ sprintf (value, "%d", keysym);
+ return value;
+}
+
+static struct frame *
+haiku_window_to_frame (void *window)
+{
+ Lisp_Object tail, tem;
+ struct frame *f;
+
+ FOR_EACH_FRAME (tail, tem)
+ {
+ f = XFRAME (tem);
+ if (!FRAME_HAIKU_P (f))
+ continue;
+
+ eassert (FRAME_DISPLAY_INFO (f) == x_display_list);
+
+ if (FRAME_HAIKU_WINDOW (f) == window)
+ return f;
+ }
+
+ return 0;
+}
+
+static void
+haiku_coords_from_parent (struct frame *f, int *x, int *y)
+{
+ struct frame *p = FRAME_PARENT_FRAME (f);
+ eassert (p);
+
+ for (struct frame *parent = p; parent;
+ parent = FRAME_PARENT_FRAME (parent))
+ {
+ *x -= parent->left_pos;
+ *y -= parent->top_pos;
+ }
+}
+
+static void
+haiku_delete_terminal (struct terminal *terminal)
+{
+ emacs_abort ();
+}
+
+static const char *
+get_string_resource (void *ignored, const char *name, const char *class)
+{
+ if (!name)
+ return NULL;
+
+ Lisp_Object lval = assoc_no_quit (build_string (name), rdb);
+
+ if (!NILP (lval))
+ return SSDATA (XCDR (lval));
+
+ return NULL;
+}
+
+static void
+haiku_update_size_hints (struct frame *f)
+{
+ int base_width, base_height;
+ eassert (FRAME_HAIKU_P (f) && FRAME_HAIKU_WINDOW (f));
+
+ base_width = FRAME_TEXT_COLS_TO_PIXEL_WIDTH (f, 0);
+ base_height = FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (f, 0);
+
+ block_input ();
+ BWindow_set_size_alignment (FRAME_HAIKU_WINDOW (f),
+ frame_resize_pixelwise ? 1 : FRAME_COLUMN_WIDTH (f),
+ frame_resize_pixelwise ? 1 : FRAME_LINE_HEIGHT (f));
+ BWindow_set_min_size (FRAME_HAIKU_WINDOW (f), base_width,
+ base_height
+ + FRAME_TOOL_BAR_HEIGHT (f)
+ + FRAME_MENU_BAR_HEIGHT (f));
+ unblock_input ();
+}
+
+static void
+haiku_clip_to_string (struct glyph_string *s)
+{
+ struct haiku_rect r[2];
+ int n = get_glyph_string_clip_rects (s, (struct haiku_rect *) &r, 2);
+
+ if (n)
+ BView_ClipToRect (FRAME_HAIKU_VIEW (s->f), r[0].x, r[0].y,
+ r[0].width, r[0].height);
+ if (n > 1)
+ {
+ BView_ClipToRect (FRAME_HAIKU_VIEW (s->f), r[1].x, r[1].y,
+ r[1].width, r[1].height);
+ }
+
+ s->num_clips = n;
+}
+
+static void
+haiku_clip_to_string_exactly (struct glyph_string *s, struct glyph_string *dst)
+{
+ BView_ClipToRect (FRAME_HAIKU_VIEW (s->f), s->x, s->y,
+ s->width, s->height);
+ dst->num_clips = 1;
+}
+
+static void
+haiku_flip_buffers (struct frame *f)
+{
+ void *view = FRAME_OUTPUT_DATA (f)->view;
+ block_input ();
+
+ BView_draw_lock (view);
+ FRAME_DIRTY_P (f) = 0;
+ EmacsView_flip_and_blit (view);
+ BView_draw_unlock (view);
+
+ unblock_input ();
+}
+
+static void
+haiku_frame_up_to_date (struct frame *f)
+{
+ block_input ();
+ FRAME_MOUSE_UPDATE (f);
+ if (FRAME_DIRTY_P (f) && !buffer_flipping_blocked_p ())
+ haiku_flip_buffers (f);
+ unblock_input ();
+}
+
+static void
+haiku_buffer_flipping_unblocked_hook (struct frame *f)
+{
+ if (FRAME_DIRTY_P (f))
+ haiku_flip_buffers (f);
+}
+
+static void
+haiku_clear_frame_area (struct frame *f, int x, int y,
+ int width, int height)
+{
+ void *vw = FRAME_HAIKU_VIEW (f);
+ block_input ();
+ BView_draw_lock (vw);
+ BView_StartClip (vw);
+ BView_ClipToRect (vw, x, y, width, height);
+ BView_SetHighColor (vw, FRAME_BACKGROUND_PIXEL (f));
+ BView_FillRectangle (vw, x, y, width, height);
+ BView_EndClip (vw);
+ BView_draw_unlock (vw);
+ unblock_input ();
+}
+
+static void
+haiku_clear_frame (struct frame *f)
+{
+ void *view = FRAME_HAIKU_VIEW (f);
+ block_input ();
+ BView_draw_lock (view);
+ BView_StartClip (view);
+ BView_ClipToRect (view, 0, 0, FRAME_PIXEL_WIDTH (f) + 1,
+ FRAME_PIXEL_HEIGHT (f) + 1);
+ BView_SetHighColor (view, FRAME_BACKGROUND_PIXEL (f));
+ BView_FillRectangle (view, 0, 0, FRAME_PIXEL_WIDTH (f) + 1,
+ FRAME_PIXEL_HEIGHT (f) + 1);
+ BView_EndClip (view);
+ BView_draw_unlock (view);
+ unblock_input ();
+}
+
+/* Give frame F the font FONT-OBJECT as its default font. The return
+ value is FONT-OBJECT. FONTSET is an ID of the fontset for the
+ frame. If it is negative, generate a new fontset from
+ FONT-OBJECT. */
+
+static Lisp_Object
+haiku_new_font (struct frame *f, Lisp_Object font_object, int fontset)
+{
+ struct font *font = XFONT_OBJECT (font_object);
+ if (fontset < 0)
+ fontset = fontset_from_font (font_object);
+
+ FRAME_FONTSET (f) = fontset;
+ if (FRAME_FONT (f) == font)
+ return font_object;
+
+ FRAME_FONT (f) = font;
+ FRAME_BASELINE_OFFSET (f) = font->baseline_offset;
+ FRAME_COLUMN_WIDTH (f) = font->average_width;
+
+ int ascent, descent;
+ get_font_ascent_descent (font, &ascent, &descent);
+ FRAME_LINE_HEIGHT (f) = ascent + descent;
+ FRAME_TAB_BAR_HEIGHT (f) = FRAME_TAB_BAR_LINES (f) * FRAME_LINE_HEIGHT (f);
+
+ int 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;
+
+ if (FRAME_HAIKU_WINDOW (f))
+ {
+ adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
+ FRAME_LINES (f) * FRAME_LINE_HEIGHT (f),
+ 3, false, Qfont);
+
+ haiku_clear_under_internal_border (f);
+ }
+ return font_object;
+}
+
+static int
+haiku_valid_modifier_p (Lisp_Object sym)
+{
+ return EQ (sym, Qcommand) || EQ (sym, Qshift)
+ || EQ (sym, Qcontrol) || EQ (sym, Qoption);
+}
+
+#define MODIFIER_OR(obj, def) (haiku_valid_modifier_p (obj) ? obj : def)
+
+static void
+haiku_add_modifier (int modifier, int toput, Lisp_Object qtem, int *modifiers)
+{
+ if ((modifier & HAIKU_MODIFIER_ALT && EQ (qtem, Qcommand))
+ || (modifier & HAIKU_MODIFIER_SHIFT && EQ (qtem, Qshift))
+ || (modifier & HAIKU_MODIFIER_CTRL && EQ (qtem, Qcontrol))
+ || (modifier & HAIKU_MODIFIER_SUPER && EQ (qtem, Qoption)))
+ *modifiers |= toput;
+}
+
+static int
+haiku_modifiers_to_emacs (int haiku_key)
+{
+ int modifiers = 0;
+ haiku_add_modifier (haiku_key, shift_modifier,
+ MODIFIER_OR (Vhaiku_shift_keysym, Qshift), &modifiers);
+ haiku_add_modifier (haiku_key, super_modifier,
+ MODIFIER_OR (Vhaiku_super_keysym, Qoption), &modifiers);
+ haiku_add_modifier (haiku_key, meta_modifier,
+ MODIFIER_OR (Vhaiku_meta_keysym, Qcommand), &modifiers);
+ haiku_add_modifier (haiku_key, ctrl_modifier,
+ MODIFIER_OR (Vhaiku_control_keysym, Qcontrol), &modifiers);
+ return modifiers;
+}
+
+#undef MODIFIER_OR
+
+static void
+haiku_rehighlight (void)
+{
+ eassert (x_display_list && !x_display_list->next);
+
+ block_input ();
+
+ struct frame *old_hl = x_display_list->highlight_frame;
+
+ if (x_display_list->focused_frame)
+ {
+ x_display_list->highlight_frame
+ = ((FRAMEP (FRAME_FOCUS_FRAME (x_display_list->focused_frame)))
+ ? XFRAME (FRAME_FOCUS_FRAME (x_display_list->focused_frame))
+ : x_display_list->focused_frame);
+ if (!FRAME_LIVE_P (x_display_list->highlight_frame))
+ {
+ fset_focus_frame (x_display_list->focused_frame, Qnil);
+ x_display_list->highlight_frame = x_display_list->focused_frame;
+ }
+ }
+ else
+ x_display_list->highlight_frame = 0;
+
+ if (old_hl)
+ gui_update_cursor (old_hl, true);
+
+ if (x_display_list->highlight_frame)
+ gui_update_cursor (x_display_list->highlight_frame, true);
+ unblock_input ();
+}
+
+static void
+haiku_frame_raise_lower (struct frame *f, bool raise_p)
+{
+ if (raise_p)
+ {
+ block_input ();
+ BWindow_activate (FRAME_HAIKU_WINDOW (f));
+ flush_frame (f);
+ unblock_input ();
+ }
+}
+
+/* Unfortunately, NOACTIVATE is not implementable on Haiku. */
+static void
+haiku_focus_frame (struct frame *frame, bool noactivate)
+{
+ if (x_display_list->focused_frame != frame)
+ haiku_frame_raise_lower (frame, 1);
+}
+
+static void
+haiku_new_focus_frame (struct frame *frame)
+{
+ eassert (x_display_list && !x_display_list->next);
+
+ block_input ();
+ if (frame != x_display_list->focused_frame)
+ {
+ if (x_display_list->focused_frame &&
+ x_display_list->focused_frame->auto_lower)
+ haiku_frame_raise_lower (x_display_list->focused_frame, 0);
+
+ x_display_list->focused_frame = frame;
+
+ if (frame && frame->auto_raise)
+ haiku_frame_raise_lower (frame, 1);
+ }
+ unblock_input ();
+
+ haiku_rehighlight ();
+}
+
+static void
+haiku_implicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ haiku_set_name (f, arg, 0);
+}
+
+static void
+haiku_query_frame_background_color (struct frame *f, Emacs_Color *bgcolor)
+{
+ haiku_query_color (FRAME_BACKGROUND_PIXEL (f), bgcolor);
+}
+
+static bool
+haiku_defined_color (struct frame *f,
+ const char *name,
+ Emacs_Color *color,
+ bool alloc,
+ bool make_index)
+{
+ return !haiku_get_color (name, color);
+}
+
+/* Adapted from xterm `x_draw_box_rect'. */
+static void
+haiku_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 haiku_rect *clip_rect)
+{
+ void *view = FRAME_HAIKU_VIEW (s->f);
+ struct face *face = s->face;
+
+ BView_StartClip (view);
+ BView_SetHighColor (view, face->box_color);
+ if (clip_rect)
+ BView_ClipToRect (view, clip_rect->x, clip_rect->y, clip_rect->width,
+ clip_rect->height);
+ BView_FillRectangle (view, left_x, top_y, right_x - left_x + 1, hwidth);
+ if (left_p)
+ BView_FillRectangle (view, left_x, top_y, vwidth, bottom_y - top_y + 1);
+
+ BView_FillRectangle (view, left_x, bottom_y - hwidth + 1,
+ right_x - left_x + 1, hwidth);
+ if (right_p)
+ BView_FillRectangle (view, right_x - vwidth + 1,
+ top_y, vwidth, bottom_y - top_y + 1);
+ BView_EndClip (view);
+}
+
+static void
+haiku_calculate_relief_colors (struct glyph_string *s,
+ uint32_t *rgbout_w, uint32_t *rgbout_b,
+ uint32_t *rgbout_c)
+{
+ struct face *face = s->face;
+
+ prepare_face_for_display (s->f, s->face);
+
+ uint32_t rgbin = face->use_box_color_for_shadows_p
+ ? face->box_color : face->background;
+
+ if (s->hl == DRAW_CURSOR)
+ rgbin = FRAME_CURSOR_COLOR (s->f).pixel;
+
+ double h, cs, l;
+ rgb_color_hsl (rgbin, &h, &cs, &l);
+
+ hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 0.6), rgbout_b);
+ hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 1.2), rgbout_w);
+ hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 1.8), rgbout_c);
+}
+
+static void
+haiku_draw_relief_rect (struct glyph_string *s,
+ int left_x, int top_y, int right_x, int bottom_y,
+ int hwidth, int vwidth, bool raised_p, bool top_p, bool bot_p,
+ bool left_p, bool right_p,
+ struct haiku_rect *clip_rect, bool fancy_p)
+{
+ uint32_t color_white;
+ uint32_t color_black;
+ uint32_t color_corner;
+
+ haiku_calculate_relief_colors (s, &color_white, &color_black,
+ &color_corner);
+
+ void *view = FRAME_HAIKU_VIEW (s->f);
+ BView_StartClip (view);
+
+ BView_SetHighColor (view, raised_p ? color_white : color_black);
+ if (clip_rect)
+ BView_ClipToRect (view, clip_rect->x, clip_rect->y, clip_rect->width,
+ clip_rect->height);
+ if (top_p)
+ BView_FillRectangle (view, left_x, top_y, right_x - left_x + 1, hwidth);
+ if (left_p)
+ BView_FillRectangle (view, left_x, top_y, vwidth, bottom_y - top_y + 1);
+ BView_SetHighColor (view, !raised_p ? color_white : color_black);
+
+ if (bot_p)
+ BView_FillRectangle (view, left_x, bottom_y - hwidth + 1,
+ right_x - left_x + 1, hwidth);
+ if (right_p)
+ BView_FillRectangle (view, right_x - vwidth + 1, top_y,
+ vwidth, bottom_y - top_y + 1);
+
+ /* Draw the triangle for the bottom-left corner. */
+ if (bot_p && left_p)
+ {
+ BView_SetHighColor (view, raised_p ? color_white : color_black);
+ BView_FillTriangle (view, left_x, bottom_y - hwidth, left_x + vwidth,
+ bottom_y - hwidth, left_x, bottom_y);
+ }
+
+ /* Now draw the triangle for the top-right corner. */
+ if (top_p && right_p)
+ {
+ BView_SetHighColor (view, raised_p ? color_white : color_black);
+ BView_FillTriangle (view, right_x - vwidth, top_y,
+ right_x, top_y,
+ right_x - vwidth, top_y + hwidth);
+ }
+
+ /* If (h/v)width is > 1, we draw the outer-most line on each side in the
+ black relief color. */
+
+ BView_SetHighColor (view, color_black);
+
+ if (hwidth > 1 && top_p)
+ BView_StrokeLine (view, left_x, top_y, right_x, top_y);
+ if (hwidth > 1 && bot_p)
+ BView_StrokeLine (view, left_x, bottom_y, right_x, bottom_y);
+ if (vwidth > 1 && left_p)
+ BView_StrokeLine (view, left_x, top_y, left_x, bottom_y);
+ if (vwidth > 1 && right_p)
+ BView_StrokeLine (view, right_x, top_y, right_x, bottom_y);
+
+ BView_SetHighColor (view, color_corner);
+
+ /* Omit corner pixels. */
+ if (hwidth > 1 || vwidth > 1)
+ {
+ if (left_p && top_p)
+ BView_FillRectangle (view, left_x, top_y, 1, 1);
+ if (left_p && bot_p)
+ BView_FillRectangle (view, left_x, bottom_y, 1, 1);
+ if (right_p && top_p)
+ BView_FillRectangle (view, right_x, top_y, 1, 1);
+ if (right_p && bot_p)
+ BView_FillRectangle (view, right_x, bottom_y, 1, 1);
+ }
+
+ BView_EndClip (view);
+}
+
+static void
+haiku_draw_underwave (struct glyph_string *s, int width, int x)
+{
+ int wave_height = 3, wave_length = 2;
+ int y, dx, dy, odd, xmax;
+ dx = wave_length;
+ dy = wave_height - 1;
+ y = s->ybase - wave_height + 3;
+
+ float ax, ay, bx, by;
+ xmax = x + width;
+
+ void *view = FRAME_HAIKU_VIEW (s->f);
+
+ BView_StartClip (view);
+ BView_ClipToRect (view, x, y, width, wave_height);
+ ax = x - ((int) (x) % dx) + (float) 0.5;
+ bx = ax + dx;
+ odd = (int) (ax / dx) % 2;
+ ay = by = y + 0.5;
+
+ if (odd)
+ ay += dy;
+ else
+ by += dy;
+
+ while (ax <= xmax)
+ {
+ BView_StrokeLine (view, ax, ay, bx, by);
+ ax = bx, ay = by;
+ bx += dx, by = y + 0.5 + odd * dy;
+ odd = !odd;
+ }
+ BView_EndClip (view);
+}
+
+static void
+haiku_draw_text_decoration (struct glyph_string *s, struct face *face,
+ uint8_t dcol, int width, int x)
+{
+ if (s->for_overlaps)
+ return;
+
+ void *view = FRAME_HAIKU_VIEW (s->f);
+ BView_draw_lock (view);
+ BView_StartClip (view);
+
+ if (face->underline)
+ {
+ if (s->hl == DRAW_CURSOR)
+ BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg);
+ else if (!face->underline_defaulted_p)
+ BView_SetHighColor (view, face->underline_color);
+ else
+ BView_SetHighColor (view, dcol);
+
+ if (face->underline == FACE_UNDER_WAVE)
+ haiku_draw_underwave (s, width, x);
+ else if (face->underline == FACE_UNDER_LINE)
+ {
+ unsigned long thickness, position;
+ int y;
+
+ if (s->prev && s->prev && s->prev->hl == DRAW_MOUSE_FACE)
+ {
+ struct face *prev_face = s->prev->face;
+
+ if (prev_face && prev_face->underline == FACE_UNDER_LINE)
+ {
+ /* We use the same underline style as the previous one. */
+ thickness = s->prev->underline_thickness;
+ position = s->prev->underline_position;
+ }
+ else
+ goto calculate_underline_metrics;
+ }
+ else
+ {
+ calculate_underline_metrics:;
+ 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) || EQ (val, Qunbound));
+
+ val = (WINDOW_BUFFER_LOCAL_VALUE
+ (Qx_use_underline_position_properties, s->w));
+ use_underline_position_properties
+ = !(NILP (val) || 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);
+ 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;
+ }
+ 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;
+
+ BView_FillRectangle (view, s->x, y, s->width, thickness);
+ }
+ }
+
+ if (face->overline_p)
+ {
+ unsigned long dy = 0, h = 1;
+ if (s->hl == DRAW_CURSOR)
+ BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg);
+ else if (!face->overline_color_defaulted_p)
+ BView_SetHighColor (view, face->overline_color);
+ else
+ BView_SetHighColor (view, dcol);
+
+ BView_FillRectangle (view, s->x, s->y + dy, s->width, h);
+ }
+
+ if (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->hl == DRAW_CURSOR)
+ BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg);
+ else if (!face->strike_through_color_defaulted_p)
+ BView_SetHighColor (view, face->strike_through_color);
+ else
+ BView_SetHighColor (view, dcol);
+
+ BView_FillRectangle (view, s->x, glyph_y + dy, s->width, h);
+ }
+
+ BView_EndClip (view);
+ BView_draw_unlock (view);
+}
+
+static void
+haiku_draw_string_box (struct glyph_string *s, int clip_p)
+{
+ 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 haiku_rect clip_rect;
+
+ struct face *face = s->face;
+
+ 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 (face->box_vertical_line_width);
+ hwidth = eabs (face->box_horizontal_line_width);
+ raised_p = 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 (face->box == FACE_SIMPLE_BOX)
+ haiku_draw_box_rect (s, left_x, top_y, right_x, bottom_y, hwidth,
+ vwidth, left_p, right_p, &clip_rect);
+ else
+ haiku_draw_relief_rect (s, left_x, top_y, right_x, bottom_y, hwidth,
+ vwidth, raised_p, true, true, left_p, right_p,
+ &clip_rect, 1);
+
+ if (clip_p)
+ {
+ void *view = FRAME_HAIKU_VIEW (s->f);
+
+ haiku_draw_text_decoration (s, face, face->foreground, s->width, s->x);
+ BView_ClipToInverseRect (view, left_x, top_y, right_x - left_x + 1, hwidth);
+ if (left_p)
+ BView_ClipToInverseRect (view, left_x, top_y, vwidth, bottom_y - top_y + 1);
+ BView_ClipToInverseRect (view, left_x, bottom_y - hwidth + 1,
+ right_x - left_x + 1, hwidth);
+ if (right_p)
+ BView_ClipToInverseRect (view, right_x - vwidth + 1,
+ top_y, vwidth, bottom_y - top_y + 1);
+ }
+}
+
+static void
+haiku_draw_plain_background (struct glyph_string *s, struct face *face,
+ int box_line_hwidth, int box_line_vwidth)
+{
+ void *view = FRAME_HAIKU_VIEW (s->f);
+ BView_StartClip (view);
+ if (s->hl == DRAW_CURSOR)
+ BView_SetHighColor (view, FRAME_CURSOR_COLOR (s->f).pixel);
+ else
+ BView_SetHighColor (view, face->background_defaulted_p ?
+ FRAME_BACKGROUND_PIXEL (s->f) :
+ face->background);
+
+ BView_FillRectangle (view, s->x,
+ s->y + box_line_hwidth,
+ s->background_width,
+ s->height - 2 * box_line_hwidth);
+ BView_EndClip (view);
+}
+
+static void
+haiku_draw_stipple_background (struct glyph_string *s, struct face *face,
+ int box_line_hwidth, int box_line_vwidth)
+{
+}
+
+static void
+haiku_maybe_draw_background (struct glyph_string *s, int force_p)
+{
+ if ((s->first_glyph->type != IMAGE_GLYPH) && !s->background_filled_p)
+ {
+ struct face *face = s->face;
+ int box_line_width = max (face->box_horizontal_line_width, 0);
+ int box_vline_width = max (face->box_vertical_line_width, 0);
+
+ if (FONT_HEIGHT (s->font) < s->height - 2 * box_vline_width
+ || FONT_TOO_HIGH (s->font)
+ || s->font_not_found_p || s->extends_to_end_of_line_p || force_p)
+ {
+ if (!face->stipple)
+ haiku_draw_plain_background (s, face, box_line_width,
+ box_vline_width);
+ else
+ haiku_draw_stipple_background (s, face, box_line_width,
+ box_vline_width);
+ s->background_filled_p = 1;
+ }
+ }
+}
+
+static void
+haiku_mouse_face_colors (struct glyph_string *s, uint32_t *fg,
+ uint32_t *bg)
+{
+ int face_id;
+ struct face *face;
+
+ /* What face has to be used last for the mouse face? */
+ face_id = MOUSE_HL_INFO (s->f)->mouse_face_face_id;
+ face = FACE_FROM_ID_OR_NULL (s->f, face_id);
+ if (face == NULL)
+ face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
+
+ if (s->first_glyph->type == CHAR_GLYPH)
+ face_id = FACE_FOR_CHAR (s->f, face, s->first_glyph->u.ch, -1, Qnil);
+ else
+ face_id = FACE_FOR_CHAR (s->f, face, 0, -1, Qnil);
+
+ face = FACE_FROM_ID (s->f, face_id);
+ prepare_face_for_display (s->f, s->face);
+
+ if (fg)
+ *fg = face->foreground;
+ if (bg)
+ *bg = face->background;
+}
+
+static void
+haiku_draw_glyph_string_foreground (struct glyph_string *s)
+{
+ struct face *face = s->face;
+
+ int i, x;
+ if (face->box != FACE_NO_BOX
+ && s->first_glyph->left_box_line_p)
+ x = s->x + max (face->box_vertical_line_width, 0);
+ else
+ x = s->x;
+
+ void *view = FRAME_HAIKU_VIEW (s->f);
+
+ if (s->font_not_found_p)
+ {
+ BView_StartClip (view);
+ if (s->hl == DRAW_CURSOR)
+ BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg);
+ else
+ BView_SetHighColor (view, face->foreground);
+ for (i = 0; i < s->nchars; ++i)
+ {
+ struct glyph *g = s->first_glyph + i;
+ BView_StrokeRectangle (view, x, s->y, g->pixel_width,
+ s->height);
+ x += g->pixel_width;
+ }
+ BView_EndClip (view);
+ }
+ else
+ {
+ struct font *ft = s->font;
+ int off = ft->baseline_offset;
+ int y;
+
+ if (ft->vertical_centering)
+ off = VCENTER_BASELINE_OFFSET (ft, s->f) - off;
+ y = s->ybase - off;
+ if (s->for_overlaps || (s->background_filled_p && s->hl != DRAW_CURSOR))
+ ft->driver->draw (s, 0, s->nchars, x, y, false);
+ else
+ ft->driver->draw (s, 0, s->nchars, x, y, true);
+
+ if (face->overstrike)
+ ft->driver->draw (s, 0, s->nchars, x + 1, y, false);
+ }
+}
+
+static void
+haiku_draw_glyphless_glyph_string_foreground (struct glyph_string *s)
+{
+ struct glyph *glyph = s->first_glyph;
+ unsigned char2b[8];
+ int x, i, j;
+ struct face *face = s->face;
+
+ /* If first glyph of S has a left box line, start drawing the text
+ of S to the right of that box line. */
+ if (face && face->box != FACE_NO_BOX
+ && s->first_glyph->left_box_line_p)
+ x = s->x + max (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 (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);
+ }
+ BView_StartClip (FRAME_HAIKU_VIEW (s->f));
+ if (glyph->u.glyphless.method != GLYPHLESS_DISPLAY_THIN_SPACE)
+ BView_FillRectangle (FRAME_HAIKU_VIEW (s->f),
+ x, s->ybase - glyph->ascent,
+ glyph->pixel_width - 1,
+ glyph->ascent + glyph->descent - 1);
+ BView_EndClip (FRAME_HAIKU_VIEW (s->f));
+ x += glyph->pixel_width;
+ }
+}
+
+static void
+haiku_draw_stretch_glyph_string (struct glyph_string *s)
+{
+ eassert (s->first_glyph->type == STRETCH_GLYPH);
+
+ struct face *face = s->face;
+
+ if (s->hl == DRAW_CURSOR && !x_stretch_cursor_p)
+ {
+ 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;
+
+ void *view = FRAME_HAIKU_VIEW (s->f);
+ BView_StartClip (view);
+ BView_SetHighColor (view, FRAME_CURSOR_COLOR (s->f).pixel);
+ BView_FillRectangle (view, x, s->y, width, s->height);
+ BView_EndClip (view);
+
+ if (width < background_width)
+ {
+ if (!s->row->reversed_p)
+ x += width;
+ else
+ x = s->x;
+
+ int y = s->y;
+ int w = background_width - width, h = s->height;
+
+ if (!face->stipple)
+ {
+ uint32_t bkg;
+ if (s->hl == DRAW_MOUSE_FACE || (s->hl == DRAW_CURSOR
+ && s->row->mouse_face_p
+ && cursor_in_mouse_face_p (s->w)))
+ haiku_mouse_face_colors (s, NULL, &bkg);
+ else
+ bkg = face->background;
+
+ BView_StartClip (view);
+ BView_SetHighColor (view, bkg);
+ BView_FillRectangle (view, x, y, w, h);
+ BView_EndClip (view);
+ }
+ }
+ }
+ 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 (background_width > 0)
+ {
+ void *view = FRAME_HAIKU_VIEW (s->f);
+ BView_StartClip (view);
+ uint32_t bkg;
+ if (s->hl == DRAW_MOUSE_FACE)
+ haiku_mouse_face_colors (s, NULL, &bkg);
+ else if (s->hl == DRAW_CURSOR)
+ bkg = FRAME_CURSOR_COLOR (s->f).pixel;
+ else
+ bkg = s->face->background;
+
+ BView_SetHighColor (view, bkg);
+ BView_FillRectangle (view, x, s->y, background_width, s->height);
+ BView_EndClip (view);
+ }
+ }
+ s->background_filled_p = 1;
+}
+
+static void
+haiku_start_clip (struct glyph_string *s)
+{
+ void *view = FRAME_HAIKU_VIEW (s->f);
+ BView_draw_lock (view);
+ BView_StartClip (view);
+}
+
+static void
+haiku_end_clip (struct glyph_string *s)
+{
+ void *view = FRAME_HAIKU_VIEW (s->f);
+ BView_EndClip (view);
+ BView_draw_unlock (view);
+}
+
+static void
+haiku_clip_to_row (struct window *w, struct glyph_row *row,
+ enum glyph_row_area area)
+{
+ struct frame *f = WINDOW_XFRAME (w);
+ int window_x, window_y, window_width;
+ int x, y, width, height;
+
+ window_box (w, area, &window_x, &window_y, &window_width, 0);
+
+ x = window_x;
+ y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, row->y));
+ y = max (y, window_y);
+ width = window_width;
+ height = row->visible_height;
+
+ BView_ClipToRect (FRAME_HAIKU_VIEW (f), x, y, width, height);
+}
+
+static void
+haiku_update_begin (struct frame *f)
+{
+}
+
+static void
+haiku_update_end (struct frame *f)
+{
+ MOUSE_HL_INFO (f)->mouse_face_defer = false;
+ flush_frame (f);
+}
+
+static void
+haiku_draw_composite_glyph_string_foreground (struct glyph_string *s)
+{
+ int i, j, x;
+ struct font *font = s->font;
+ void *view = FRAME_HAIKU_VIEW (s->f);
+ struct face *face = s->face;
+
+ /* If first glyph of S has a left box line, start drawing the text
+ of S to the right of that box line. */
+ if (face && face->box != FACE_NO_BOX
+ && s->first_glyph->left_box_line_p)
+ x = s->x + max (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 && !s->cmp_from)
+ {
+ BView_StartClip (view);
+ if (s->hl == DRAW_CURSOR)
+ BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg);
+ else
+ BView_SetHighColor (view, s->face->foreground);
+ BView_StrokeRectangle (view, s->x, s->y, s->width - 1, s->height - 1);
+ BView_EndClip (view);
+ }
+ 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 (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 (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 (face->overstrike)
+ font->driver->draw (s, j, i, x + 1, y, false);
+ }
+ }
+}
+
+static void
+haiku_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 haiku_rect r;
+ int x = s->x;
+ int y = s->ybase - image_ascent (s->img, s->face, &s->slice);
+
+ struct face *face = s->face;
+
+ /* If first glyph of S has a left box line, start drawing it to the
+ right of that line. */
+ if (face->box != FACE_NO_BOX
+ && s->first_glyph->left_box_line_p
+ && s->slice.x == 0)
+ x += max (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 = 0;
+
+ if (s->slice.x == 0)
+ x -= thick + extra_x, left_p = 1;
+ if (s->slice.y == 0)
+ y -= thick + extra_y, top_p = 1;
+ if (s->slice.x + s->slice.width == s->img->width)
+ x1 += thick + extra_x, right_p = 1;
+ if (s->slice.y + s->slice.height == s->img->height)
+ y1 += thick + extra_y, bot_p = 1;
+
+ get_glyph_string_clip_rect (s, &r);
+ haiku_draw_relief_rect (s, x, y, x1, y1, thick, thick, raised_p,
+ top_p, bot_p, left_p, right_p, &r, 0);
+}
+
+static void
+haiku_draw_image_glyph_string (struct glyph_string *s)
+{
+ struct face *face = s->face;
+
+ int box_line_hwidth = max (face->box_vertical_line_width, 0);
+ int box_line_vwidth = max (face->box_horizontal_line_width, 0);
+
+ int x, y;
+ int height, width;
+
+ 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;
+
+ width = s->background_width;
+ x = s->x;
+ if (s->first_glyph->left_box_line_p
+ && s->slice.x == 0)
+ {
+ x += box_line_hwidth;
+ width -= box_line_hwidth;
+ }
+
+ y = s->y;
+ if (s->slice.y == 0)
+ y += box_line_vwidth;
+
+ void *view = FRAME_HAIKU_VIEW (s->f);
+ void *bitmap = s->img->pixmap;
+
+ s->stippled_p = face->stipple != 0;
+
+ BView_draw_lock (view);
+ BView_StartClip (view);
+ BView_SetHighColor (view, face->background);
+ BView_FillRectangle (view, x, y, width, height);
+ BView_EndClip (view);
+ BView_draw_unlock (view);
+
+ if (bitmap)
+ {
+ struct haiku_rect nr;
+ Emacs_Rectangle cr, ir, r;
+
+ get_glyph_string_clip_rect (s, &nr);
+ CONVERT_TO_EMACS_RECT (cr, nr);
+ x = s->x;
+ y = s->ybase - image_ascent (s->img, face, &s->slice);
+
+ if (s->slice.x == 0)
+ x += s->img->hmargin;
+ if (s->slice.y == 0)
+ y += s->img->vmargin;
+
+ if (face->box != FACE_NO_BOX
+ && s->first_glyph->left_box_line_p
+ && s->slice.x == 0)
+ x += max (face->box_vertical_line_width, 0);
+
+ ir.x = x;
+ ir.y = y;
+ ir.width = s->slice.width;
+ ir.height = s->slice.height;
+ r = ir;
+
+ void *mask = s->img->mask;
+
+ if (gui_intersect_rectangles (&cr, &ir, &r))
+ {
+ BView_draw_lock (view);
+ BView_StartClip (view);
+
+ haiku_clip_to_string (s);
+ if (s->img->have_be_transforms_p)
+ {
+ bitmap = BBitmap_transform_bitmap (bitmap,
+ s->img->mask,
+ face->background,
+ s->img->be_rotate,
+ s->img->width,
+ s->img->height);
+ mask = NULL;
+ }
+
+ BView_DrawBitmap (view, bitmap,
+ s->slice.x + r.x - x,
+ s->slice.y + r.y - y,
+ r.width, r.height,
+ r.x, r.y, r.width, r.height);
+ if (mask)
+ {
+ BView_DrawMask (mask, view,
+ s->slice.x + r.x - x,
+ s->slice.y + r.y - y,
+ r.width, r.height,
+ r.x, r.y, r.width, r.height,
+ face->background);
+ }
+
+ if (s->img->have_be_transforms_p)
+ BBitmap_free (bitmap);
+ BView_EndClip (view);
+ BView_draw_unlock (view);
+ }
+
+ if (s->hl == DRAW_CURSOR)
+ {
+ BView_draw_lock (view);
+ BView_StartClip (view);
+ BView_SetPenSize (view, 1);
+ BView_SetHighColor (view, FRAME_CURSOR_COLOR (s->f).pixel);
+ BView_StrokeRectangle (view, r.x, r.y, r.width, r.height);
+ BView_EndClip (view);
+ BView_draw_unlock (view);
+ }
+ }
+
+ if (s->img->relief
+ || s->hl == DRAW_IMAGE_RAISED
+ || s->hl == DRAW_IMAGE_SUNKEN)
+ haiku_draw_image_relief (s);
+}
+
+static void
+haiku_draw_glyph_string (struct glyph_string *s)
+{
+ block_input ();
+ prepare_face_for_display (s->f, s->face);
+
+ struct face *face = s->face;
+ if (face != s->face)
+ prepare_face_for_display (s->f, face);
+
+ 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)
+ {
+ prepare_face_for_display (s->f, s->next->face);
+ haiku_start_clip (s->next);
+ haiku_clip_to_string (s->next);
+ if (next->first_glyph->type != STRETCH_GLYPH)
+ haiku_maybe_draw_background (s->next, 1);
+ else
+ haiku_draw_stretch_glyph_string (s->next);
+ next->num_clips = 0;
+ haiku_end_clip (s);
+ }
+ }
+
+ haiku_start_clip (s);
+
+ int box_filled_p = 0;
+
+ if (!s->for_overlaps && face->box != FACE_NO_BOX
+ && (s->first_glyph->type == CHAR_GLYPH
+ || s->first_glyph->type == COMPOSITE_GLYPH))
+ {
+ haiku_clip_to_string (s);
+ haiku_maybe_draw_background (s, 1);
+ box_filled_p = 1;
+ haiku_draw_string_box (s, 0);
+ }
+ else if (!s->clip_head && !s->clip_tail &&
+ ((s->prev && s->left_overhang && s->prev->hl != s->hl) ||
+ (s->next && s->right_overhang && s->next->hl != s->hl)))
+ haiku_clip_to_string_exactly (s, s);
+ else
+ haiku_clip_to_string (s);
+
+ if (s->for_overlaps)
+ s->background_filled_p = 1;
+
+ switch (s->first_glyph->type)
+ {
+ case COMPOSITE_GLYPH:
+ if (s->for_overlaps || (s->cmp_from > 0
+ && ! s->first_glyph->u.cmp.automatic))
+ s->background_filled_p = 1;
+ else
+ haiku_maybe_draw_background (s, 1);
+ haiku_draw_composite_glyph_string_foreground (s);
+ break;
+ case CHAR_GLYPH:
+ if (s->for_overlaps)
+ s->background_filled_p = 1;
+ else
+ haiku_maybe_draw_background (s, 0);
+ haiku_draw_glyph_string_foreground (s);
+ break;
+ case STRETCH_GLYPH:
+ haiku_draw_stretch_glyph_string (s);
+ break;
+ case IMAGE_GLYPH:
+ haiku_draw_image_glyph_string (s);
+ break;
+ case GLYPHLESS_GLYPH:
+ if (s->for_overlaps)
+ s->background_filled_p = 1;
+ else
+ haiku_maybe_draw_background (s, 1);
+ haiku_draw_glyphless_glyph_string_foreground (s);
+ break;
+ }
+
+ if (!box_filled_p && face->box != FACE_NO_BOX)
+ haiku_draw_string_box (s, 1);
+ else
+ haiku_draw_text_decoration (s, face, face->foreground, s->width, s->x);
+
+ if (!s->for_overlaps)
+ {
+ 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;
+ struct face *save_face = prev->face;
+
+ prev->hl = s->hl;
+ prev->face = s->face;
+ haiku_start_clip (s);
+ haiku_clip_to_string_exactly (s, prev);
+ if (prev->first_glyph->type == CHAR_GLYPH)
+ haiku_draw_glyph_string_foreground (prev);
+ else
+ haiku_draw_composite_glyph_string_foreground (prev);
+ haiku_end_clip (s);
+ prev->hl = save;
+ prev->face = save_face;
+ 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;
+ struct face *save_face = next->face;
+
+ next->hl = s->hl;
+ next->face = s->face;
+ haiku_start_clip (s);
+ haiku_clip_to_string_exactly (s, next);
+ if (next->first_glyph->type == CHAR_GLYPH)
+ haiku_draw_glyph_string_foreground (next);
+ else
+ haiku_draw_composite_glyph_string_foreground (next);
+ haiku_end_clip (s);
+
+ next->background_filled_p = 0;
+ next->hl = save;
+ next->face = save_face;
+ next->clip_head = next;
+ next->num_clips = 0;
+ }
+ }
+ }
+ s->num_clips = 0;
+ haiku_end_clip (s);
+ unblock_input ();
+}
+
+static void
+haiku_after_update_window_line (struct window *w,
+ struct glyph_row *desired_row)
+{
+ eassert (w);
+ struct frame *f;
+ int width, height;
+
+ if (!desired_row->mode_line_p && !w->pseudo_window_p)
+ desired_row->redraw_fringe_bitmaps_p = true;
+
+ if (windows_or_buffers_changed
+ && desired_row->full_width_p
+ && (f = XFRAME (w->frame),
+ width = FRAME_INTERNAL_BORDER_WIDTH (f),
+ width != 0)
+ && (height = desired_row->visible_height,
+ height > 0))
+ {
+ int y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, desired_row->y));
+ int 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)
+ {
+ void *view = FRAME_HAIKU_VIEW (f);
+ BView_draw_lock (view);
+ BView_StartClip (view);
+ BView_SetHighColor (view, face->background_defaulted_p ?
+ FRAME_BACKGROUND_PIXEL (f) : face->background);
+ BView_FillRectangle (view, 0, y, width, height);
+ BView_FillRectangle (view, FRAME_PIXEL_WIDTH (f) - width,
+ y, width, height);
+ BView_EndClip (view);
+ BView_draw_unlock (view);
+ }
+ else
+ {
+ haiku_clear_frame_area (f, 0, y, width, height);
+ haiku_clear_frame_area (f, FRAME_PIXEL_WIDTH (f) - width,
+ y, width, height);
+ }
+ unblock_input ();
+ }
+}
+
+static void
+haiku_set_window_size (struct frame *f, bool change_gravity,
+ int width, int height)
+{
+ haiku_update_size_hints (f);
+
+ if (FRAME_HAIKU_WINDOW (f))
+ {
+ block_input ();
+ BWindow_resize (FRAME_HAIKU_WINDOW (f), width, height);
+ unblock_input ();
+ }
+}
+
+static void
+haiku_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 = XFRAME (WINDOW_FRAME (w));
+
+ struct glyph *phys_cursor_glyph;
+ struct glyph *cursor_glyph;
+
+ void *view = FRAME_HAIKU_VIEW (f);
+
+ int fx, fy, h, cursor_height;
+
+ if (!on_p)
+ return;
+
+ if (cursor_type == NO_CURSOR)
+ {
+ w->phys_cursor_width = 0;
+ return;
+ }
+
+ w->phys_cursor_on_p = true;
+ w->phys_cursor_type = cursor_type;
+
+ phys_cursor_glyph = get_phys_cursor_glyph (w);
+
+ if (!phys_cursor_glyph)
+ {
+ if (glyph_row->exact_window_width_line_p
+ && w->phys_cursor.hpos >= glyph_row->used[TEXT_AREA])
+ {
+ glyph_row->cursor_in_fringe_p = 1;
+ draw_fringe_bitmap (w, glyph_row, 0);
+ }
+ return;
+ }
+
+ get_phys_cursor_geometry (w, glyph_row, phys_cursor_glyph, &fx, &fy, &h);
+
+ if (cursor_type == BAR_CURSOR)
+ {
+ if (cursor_width < 1)
+ cursor_width = max (FRAME_CURSOR_WIDTH (f), 1);
+ if (cursor_width < w->phys_cursor_width)
+ w->phys_cursor_width = cursor_width;
+ }
+ else if (cursor_type == HBAR_CURSOR)
+ {
+ cursor_height = (cursor_width < 1) ? lrint (0.25 * h) : cursor_width;
+ if (cursor_height > glyph_row->height)
+ cursor_height = glyph_row->height;
+ if (h > cursor_height)
+ fy += h - cursor_height;
+ h = cursor_height;
+ }
+
+ BView_draw_lock (view);
+ BView_StartClip (view);
+ BView_SetHighColor (view, FRAME_CURSOR_COLOR (f).pixel);
+ haiku_clip_to_row (w, glyph_row, TEXT_AREA);
+
+ switch (cursor_type)
+ {
+ default:
+ case DEFAULT_CURSOR:
+ case NO_CURSOR:
+ break;
+ case HBAR_CURSOR:
+ BView_FillRectangle (view, fx, fy, w->phys_cursor_width, h);
+ break;
+ case BAR_CURSOR:
+ cursor_glyph = get_phys_cursor_glyph (w);
+ if (cursor_glyph->resolved_level & 1)
+ BView_FillRectangle (view, fx + cursor_glyph->pixel_width - w->phys_cursor_width,
+ fy, w->phys_cursor_width, h);
+ else
+ BView_FillRectangle (view, fx, fy, w->phys_cursor_width, h);
+ break;
+ case HOLLOW_BOX_CURSOR:
+ if (phys_cursor_glyph->type != IMAGE_GLYPH)
+ {
+ BView_SetPenSize (view, 1);
+ BView_StrokeRectangle (view, fx, fy, w->phys_cursor_width, h);
+ }
+ else
+ draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR);
+ break;
+ case FILLED_BOX_CURSOR:
+ draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR);
+ }
+ BView_EndClip (view);
+ BView_draw_unlock (view);
+}
+
+static void
+haiku_show_hourglass (struct frame *f)
+{
+ if (FRAME_OUTPUT_DATA (f)->hourglass_p)
+ return;
+
+ block_input ();
+ FRAME_OUTPUT_DATA (f)->hourglass_p = 1;
+
+ if (FRAME_HAIKU_VIEW (f))
+ BView_set_view_cursor (FRAME_HAIKU_VIEW (f),
+ FRAME_OUTPUT_DATA (f)->hourglass_cursor);
+ unblock_input ();
+}
+
+static void
+haiku_hide_hourglass (struct frame *f)
+{
+ if (!FRAME_OUTPUT_DATA (f)->hourglass_p)
+ return;
+
+ block_input ();
+ FRAME_OUTPUT_DATA (f)->hourglass_p = 0;
+
+ if (FRAME_HAIKU_VIEW (f))
+ BView_set_view_cursor (FRAME_HAIKU_VIEW (f),
+ FRAME_OUTPUT_DATA (f)->current_cursor);
+ unblock_input ();
+}
+
+static void
+haiku_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
+haiku_draw_vertical_window_border (struct window *w,
+ int x, int y_0, int y_1)
+{
+ struct frame *f = XFRAME (WINDOW_FRAME (w));
+ struct face *face;
+
+ face = FACE_FROM_ID_OR_NULL (f, VERTICAL_BORDER_FACE_ID);
+ void *view = FRAME_HAIKU_VIEW (f);
+ BView_draw_lock (view);
+ BView_StartClip (view);
+ if (face)
+ BView_SetHighColor (view, face->foreground);
+ BView_StrokeLine (view, x, y_0, x, y_1);
+ BView_EndClip (view);
+ BView_draw_unlock (view);
+}
+
+static void
+haiku_set_scroll_bar_default_width (struct frame *f)
+{
+ int unit = FRAME_COLUMN_WIDTH (f);
+ FRAME_CONFIG_SCROLL_BAR_WIDTH (f) = BScrollBar_default_size (0) + 1;
+ FRAME_CONFIG_SCROLL_BAR_COLS (f) =
+ (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) + unit - 1) / unit;
+}
+
+static void
+haiku_set_scroll_bar_default_height (struct frame *f)
+{
+ int height = FRAME_LINE_HEIGHT (f);
+ FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) = BScrollBar_default_size (1) + 1;
+ FRAME_CONFIG_SCROLL_BAR_LINES (f) =
+ (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) + height - 1) / height;
+}
+
+static void
+haiku_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));
+ void *view = FRAME_HAIKU_VIEW (f);
+
+ BView_draw_lock (view);
+ BView_StartClip (view);
+
+ if ((y1 - y0 > x1 - x0) && (x1 - x0 >= 3))
+ /* A vertical divider, at least three pixels wide: Draw first and
+ last pixels differently. */
+ {
+ BView_SetHighColor (view, color_first);
+ BView_StrokeLine (view, x0, y0, x0, y1 - 1);
+ BView_SetHighColor (view, color);
+ BView_FillRectangle (view, x0 + 1, y0, x1 - x0 - 2, y1 - y0);
+ BView_SetHighColor (view, color_last);
+ BView_StrokeLine (view, x1 - 1, y0, x1 - 1, y1 - 1);
+ }
+ else if ((x1 - x0 > y1 - y0) && (y1 - y0 >= 3))
+ /* A horizontal divider, at least three pixels high: Draw first and
+ last pixels differently. */
+ {
+ BView_SetHighColor (view, color_first);
+ BView_StrokeLine (f, x0, y0, x1 - 1, y0);
+ BView_SetHighColor (view, color);
+ BView_FillRectangle (view, x0, y0 + 1, x1 - x0, y1 - y0 - 2);
+ BView_SetHighColor (view, color_last);
+ BView_StrokeLine (view, x0, y1, x1 - 1, y1);
+ }
+ else
+ {
+ BView_SetHighColor (view, color);
+ BView_FillRectangleAbs (view, x0, y0, x1, y1);
+ }
+ BView_EndClip (view);
+ BView_draw_unlock (view);
+}
+
+static void
+haiku_condemn_scroll_bars (struct frame *frame)
+{
+ if (!NILP (FRAME_SCROLL_BARS (frame)))
+ {
+ if (!NILP (FRAME_CONDEMNED_SCROLL_BARS (frame)))
+ {
+ /* Prepend scrollbars to already condemned ones. */
+ Lisp_Object last = FRAME_SCROLL_BARS (frame);
+
+ while (!NILP (XSCROLL_BAR (last)->next))
+ last = XSCROLL_BAR (last)->next;
+
+ XSCROLL_BAR (last)->next = FRAME_CONDEMNED_SCROLL_BARS (frame);
+ XSCROLL_BAR (FRAME_CONDEMNED_SCROLL_BARS (frame))->prev = last;
+ }
+
+ fset_condemned_scroll_bars (frame, FRAME_SCROLL_BARS (frame));
+ fset_scroll_bars (frame, Qnil);
+ }
+}
+
+static void
+haiku_redeem_scroll_bar (struct window *w)
+{
+ struct scroll_bar *bar;
+ Lisp_Object barobj;
+ struct frame *f;
+
+ if (!NILP (w->vertical_scroll_bar) && WINDOW_HAS_VERTICAL_SCROLL_BAR (w))
+ {
+ bar = XSCROLL_BAR (w->vertical_scroll_bar);
+ /* Unlink it from the condemned list. */
+ f = XFRAME (WINDOW_FRAME (w));
+ if (NILP (bar->prev))
+ {
+ /* If the prev pointer is nil, it must be the first in one of
+ the lists. */
+ if (EQ (FRAME_SCROLL_BARS (f), w->vertical_scroll_bar))
+ /* It's not condemned. Everything's fine. */
+ goto horizontal;
+ else if (EQ (FRAME_CONDEMNED_SCROLL_BARS (f),
+ w->vertical_scroll_bar))
+ fset_condemned_scroll_bars (f, bar->next);
+ else
+ /* If its prev pointer is nil, it must be at the front of
+ one or the other! */
+ emacs_abort ();
+ }
+ else
+ XSCROLL_BAR (bar->prev)->next = bar->next;
+
+ if (! NILP (bar->next))
+ XSCROLL_BAR (bar->next)->prev = bar->prev;
+
+ bar->next = FRAME_SCROLL_BARS (f);
+ bar->prev = Qnil;
+ XSETVECTOR (barobj, bar);
+ fset_scroll_bars (f, barobj);
+ if (! NILP (bar->next))
+ XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar);
+ }
+ horizontal:
+ if (!NILP (w->horizontal_scroll_bar) && WINDOW_HAS_HORIZONTAL_SCROLL_BAR (w))
+ {
+ bar = XSCROLL_BAR (w->horizontal_scroll_bar);
+ /* Unlink it from the condemned list. */
+ f = XFRAME (WINDOW_FRAME (w));
+ if (NILP (bar->prev))
+ {
+ /* If the prev pointer is nil, it must be the first in one of
+ the lists. */
+ if (EQ (FRAME_SCROLL_BARS (f), w->horizontal_scroll_bar))
+ /* It's not condemned. Everything's fine. */
+ return;
+ else if (EQ (FRAME_CONDEMNED_SCROLL_BARS (f),
+ w->horizontal_scroll_bar))
+ fset_condemned_scroll_bars (f, bar->next);
+ else
+ /* If its prev pointer is nil, it must be at the front of
+ one or the other! */
+ emacs_abort ();
+ }
+ else
+ XSCROLL_BAR (bar->prev)->next = bar->next;
+
+ if (! NILP (bar->next))
+ XSCROLL_BAR (bar->next)->prev = bar->prev;
+
+ bar->next = FRAME_SCROLL_BARS (f);
+ bar->prev = Qnil;
+ XSETVECTOR (barobj, bar);
+ fset_scroll_bars (f, barobj);
+ if (! NILP (bar->next))
+ XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar);
+ }
+}
+
+static void
+haiku_judge_scroll_bars (struct frame *f)
+{
+ Lisp_Object bar, next;
+
+ bar = FRAME_CONDEMNED_SCROLL_BARS (f);
+
+ /* Clear out the condemned list now so we won't try to process any
+ more events on the hapless scroll bars. */
+ fset_condemned_scroll_bars (f, Qnil);
+
+ for (; ! NILP (bar); bar = next)
+ {
+ struct scroll_bar *b = XSCROLL_BAR (bar);
+
+ haiku_scroll_bar_remove (b);
+
+ next = b->next;
+ b->next = b->prev = Qnil;
+ }
+
+ /* Now there should be no references to the condemned scroll bars,
+ and they should get garbage-collected. */
+}
+
+static struct scroll_bar *
+haiku_scroll_bar_create (struct window *w, int left, int top,
+ int width, int height, bool horizontal_p)
+{
+ struct frame *f = XFRAME (WINDOW_FRAME (w));
+ Lisp_Object barobj;
+
+ void *sb = NULL;
+ void *vw = FRAME_HAIKU_VIEW (f);
+
+ block_input ();
+ struct scroll_bar *bar
+ = ALLOCATE_PSEUDOVECTOR (struct scroll_bar, prev, PVEC_OTHER);
+
+ XSETWINDOW (bar->window, w);
+ bar->top = top;
+ bar->left = left;
+ bar->width = width;
+ bar->height = height;
+ bar->position = 0;
+ bar->total = 0;
+ bar->dragging = 0;
+ bar->update = -1;
+ bar->horizontal = horizontal_p;
+
+ sb = BScrollBar_make_for_view (vw, horizontal_p,
+ left, top, left + width - 1,
+ top + height - 1, bar);
+
+ BView_publish_scroll_bar (vw, left, top, width, height);
+
+ bar->next = FRAME_SCROLL_BARS (f);
+ bar->prev = Qnil;
+ bar->scroll_bar = sb;
+ XSETVECTOR (barobj, bar);
+ fset_scroll_bars (f, barobj);
+
+ if (!NILP (bar->next))
+ XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar);
+
+ unblock_input ();
+ return bar;
+}
+
+static void
+haiku_set_horizontal_scroll_bar (struct window *w, int portion, int whole, int position)
+{
+ eassert (WINDOW_HAS_HORIZONTAL_SCROLL_BAR (w));
+ Lisp_Object barobj;
+ struct scroll_bar *bar;
+ int top, height, left, width;
+ int window_x, window_width;
+
+ /* Get window dimensions. */
+ window_box (w, ANY_AREA, &window_x, 0, &window_width, 0);
+ left = window_x;
+ width = window_width;
+ top = WINDOW_SCROLL_BAR_AREA_Y (w);
+ height = WINDOW_CONFIG_SCROLL_BAR_HEIGHT (w);
+
+ block_input ();
+
+ if (NILP (w->horizontal_scroll_bar))
+ {
+ bar = haiku_scroll_bar_create (w, left, top, width, height, true);
+ BView_scroll_bar_update (bar->scroll_bar, portion, whole, position);
+ bar->update = position;
+ bar->position = position;
+ bar->total = whole;
+ }
+ else
+ {
+ bar = XSCROLL_BAR (w->horizontal_scroll_bar);
+
+ if (bar->left != left || bar->top != top ||
+ bar->width != width || bar->height != height)
+ {
+ void *view = FRAME_HAIKU_VIEW (WINDOW_XFRAME (w));
+ BView_forget_scroll_bar (view, bar->left, bar->top,
+ bar->width, bar->height);
+ BView_move_frame (bar->scroll_bar, left, top,
+ left + width - 1, top + height - 1);
+ BView_publish_scroll_bar (view, left, top, width, height);
+ bar->left = left;
+ bar->top = top;
+ bar->width = width;
+ bar->height = height;
+ }
+
+ if (!bar->dragging)
+ {
+ BView_scroll_bar_update (bar->scroll_bar, portion, whole, position);
+ BView_invalidate (bar->scroll_bar);
+ }
+ }
+ bar->position = position;
+ bar->total = whole;
+ XSETVECTOR (barobj, bar);
+ wset_horizontal_scroll_bar (w, barobj);
+ unblock_input ();
+}
+
+static void
+haiku_set_vertical_scroll_bar (struct window *w,
+ int portion, int whole, int position)
+{
+ eassert (WINDOW_HAS_VERTICAL_SCROLL_BAR (w));
+ Lisp_Object barobj;
+ struct scroll_bar *bar;
+ int top, height, left, width;
+ int window_y, window_height;
+
+ /* Get window dimensions. */
+ window_box (w, ANY_AREA, 0, &window_y, 0, &window_height);
+ top = window_y;
+ height = window_height;
+
+ /* Compute the left edge and the width of the scroll bar area. */
+ left = WINDOW_SCROLL_BAR_AREA_X (w);
+ width = WINDOW_SCROLL_BAR_AREA_WIDTH (w);
+ block_input ();
+
+ if (NILP (w->vertical_scroll_bar))
+ {
+ bar = haiku_scroll_bar_create (w, left, top, width, height, false);
+ BView_scroll_bar_update (bar->scroll_bar, portion, whole, position);
+ bar->position = position;
+ bar->total = whole;
+ }
+ else
+ {
+ bar = XSCROLL_BAR (w->vertical_scroll_bar);
+
+ if (bar->left != left || bar->top != top ||
+ bar->width != width || bar->height != height)
+ {
+ void *view = FRAME_HAIKU_VIEW (WINDOW_XFRAME (w));
+ BView_forget_scroll_bar (view, bar->left, bar->top,
+ bar->width, bar->height);
+ BView_move_frame (bar->scroll_bar, left, top,
+ left + width - 1, top + height - 1);
+ flush_frame (WINDOW_XFRAME (w));
+ BView_publish_scroll_bar (view, left, top, width, height);
+ bar->left = left;
+ bar->top = top;
+ bar->width = width;
+ bar->height = height;
+ }
+
+ if (!bar->dragging)
+ {
+ BView_scroll_bar_update (bar->scroll_bar, portion, whole, position);
+ bar->update = position;
+ BView_invalidate (bar->scroll_bar);
+ }
+ }
+
+ bar->position = position;
+ bar->total = whole;
+
+ XSETVECTOR (barobj, bar);
+ wset_vertical_scroll_bar (w, barobj);
+ unblock_input ();
+}
+
+static void
+haiku_draw_fringe_bitmap (struct window *w, struct glyph_row *row,
+ struct draw_fringe_bitmap_params *p)
+{
+ void *view = FRAME_HAIKU_VIEW (XFRAME (WINDOW_FRAME (w)));
+ struct face *face = p->face;
+
+ BView_draw_lock (view);
+ BView_StartClip (view);
+
+ haiku_clip_to_row (w, row, ANY_AREA);
+ if (p->bx >= 0 && !p->overlay_p)
+ {
+ BView_SetHighColor (view, face->background);
+ BView_FillRectangle (view, p->bx, p->by, p->nx, p->ny);
+ }
+
+ if (p->which && p->which < fringe_bitmap_fillptr)
+ {
+ void *bitmap = fringe_bmps[p->which];
+
+ uint32_t col;
+
+ if (!p->cursor_p)
+ col = face->foreground;
+ else if (p->overlay_p)
+ col = face->background;
+ else
+ col = FRAME_CURSOR_COLOR (XFRAME (WINDOW_FRAME (w))).pixel;
+
+ if (!p->overlay_p)
+ {
+ BView_SetHighColor (view, face->background);
+ BView_FillRectangle (view, p->x, p->y, p->wd, p->h);
+ }
+
+ BView_SetLowColor (view, col);
+ BView_DrawBitmapWithEraseOp (view, bitmap, p->x, p->y, p->wd, p->h);
+ }
+ BView_EndClip (view);
+ BView_draw_unlock (view);
+}
+
+static void
+haiku_define_fringe_bitmap (int which, unsigned short *bits,
+ int h, int wd)
+{
+ if (which >= fringe_bitmap_fillptr)
+ {
+ int i = fringe_bitmap_fillptr;
+ fringe_bitmap_fillptr = which + 20;
+ fringe_bmps = !i ? xmalloc (fringe_bitmap_fillptr * sizeof (void *)) :
+ xrealloc (fringe_bmps, fringe_bitmap_fillptr * sizeof (void *));
+
+ while (i < fringe_bitmap_fillptr)
+ fringe_bmps[i++] = NULL;
+ }
+
+ fringe_bmps[which] = BBitmap_new (wd, h, 1);
+ BBitmap_import_mono_bits (fringe_bmps[which], bits, wd, h);
+}
+
+static void
+haiku_destroy_fringe_bitmap (int which)
+{
+ if (which >= fringe_bitmap_fillptr)
+ return;
+
+ if (fringe_bmps[which])
+ BBitmap_free (fringe_bmps[which]);
+ fringe_bmps[which] = NULL;
+}
+
+static void
+haiku_scroll_run (struct window *w, struct run *run)
+{
+ struct frame *f = XFRAME (w->frame);
+ void *view = FRAME_HAIKU_VIEW (f);
+ int x, y, width, height, from_y, to_y, bottom_y;
+ 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;
+ }
+
+ if (!height)
+ return;
+
+ block_input ();
+ gui_clear_cursor (w);
+ BView_draw_lock (view);
+#ifdef USE_BE_CAIRO
+ if (EmacsView_double_buffered_p (view))
+ {
+#endif
+ BView_StartClip (view);
+ BView_CopyBits (view, x, from_y, width, height,
+ x, to_y, width, height);
+ BView_EndClip (view);
+#ifdef USE_BE_CAIRO
+ }
+ else
+ {
+ EmacsWindow_begin_cr_critical_section (FRAME_HAIKU_WINDOW (f));
+ cairo_surface_t *surface = FRAME_CR_SURFACE (f);
+ cairo_surface_t *s
+ = cairo_surface_create_similar (surface,
+ cairo_surface_get_content (surface),
+ width, height);
+ cairo_t *cr = cairo_create (s);
+ if (surface)
+ {
+ cairo_set_source_surface (cr, surface, -x, -from_y);
+ cairo_paint (cr);
+ cairo_destroy (cr);
+
+ cr = haiku_begin_cr_clip (f, NULL);
+ cairo_save (cr);
+ cairo_set_source_surface (cr, s, x, to_y);
+ cairo_set_operator (cr, CAIRO_OPERATOR_SOURCE);
+ cairo_rectangle (cr, x, to_y, width, height);
+ cairo_fill (cr);
+ cairo_restore (cr);
+ cairo_surface_destroy (s);
+ haiku_end_cr_clip (cr);
+ }
+ EmacsWindow_end_cr_critical_section (FRAME_HAIKU_WINDOW (f));
+ }
+#endif
+ BView_draw_unlock (view);
+
+ unblock_input ();
+}
+
+static void
+haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window,
+ enum scroll_bar_part *part, Lisp_Object *x, Lisp_Object *y,
+ Time *timestamp)
+{
+ if (!fp)
+ return;
+
+ block_input ();
+ Lisp_Object frame, tail;
+ struct frame *f1 = NULL;
+ FOR_EACH_FRAME (tail, frame)
+ XFRAME (frame)->mouse_moved = false;
+
+ if (gui_mouse_grabbed (x_display_list) && !EQ (track_mouse, Qdropping))
+ f1 = x_display_list->last_mouse_frame;
+
+ if (!f1 || FRAME_TOOLTIP_P (f1))
+ f1 = ((EQ (track_mouse, Qdropping) && gui_mouse_grabbed (x_display_list))
+ ? x_display_list->last_mouse_frame
+ : NULL);
+
+ if (!f1 && insist > 0)
+ f1 = SELECTED_FRAME ();
+
+ if (!f1 || (!FRAME_HAIKU_P (f1) && (insist > 0)))
+ FOR_EACH_FRAME (tail, frame)
+ if (FRAME_HAIKU_P (XFRAME (frame)) &&
+ !FRAME_TOOLTIP_P (XFRAME (frame)))
+ f1 = XFRAME (frame);
+
+ if (FRAME_TOOLTIP_P (f1))
+ f1 = NULL;
+
+ if (f1 && FRAME_HAIKU_P (f1))
+ {
+ int sx, sy;
+ void *view = FRAME_HAIKU_VIEW (f1);
+ if (view)
+ {
+ BView_get_mouse (view, &sx, &sy);
+
+ remember_mouse_glyph (f1, sx, sy, &x_display_list->last_mouse_glyph);
+ x_display_list->last_mouse_glyph_frame = f1;
+
+ *bar_window = Qnil;
+ *part = scroll_bar_above_handle;
+ *fp = f1;
+ *timestamp = x_display_list->last_mouse_movement_time;
+ XSETINT (*x, sx);
+ XSETINT (*y, sy);
+ }
+ }
+
+ unblock_input ();
+}
+
+static void
+haiku_flush (struct frame *f)
+{
+ if (FRAME_VISIBLE_P (f))
+ BWindow_Flush (FRAME_HAIKU_WINDOW (f));
+}
+
+static void
+haiku_define_frame_cursor (struct frame *f, Emacs_Cursor cursor)
+{
+ if (f->tooltip)
+ return;
+ block_input ();
+ if (!f->pointer_invisible && FRAME_HAIKU_VIEW (f)
+ && !FRAME_OUTPUT_DATA (f)->hourglass_p)
+ BView_set_view_cursor (FRAME_HAIKU_VIEW (f), cursor);
+ unblock_input ();
+ FRAME_OUTPUT_DATA (f)->current_cursor = cursor;
+}
+
+static void
+haiku_update_window_end (struct window *w, bool cursor_on_p,
+ bool mouse_face_overwritten_p)
+{
+
+}
+
+static void
+haiku_default_font_parameter (struct frame *f, Lisp_Object parms)
+{
+ struct haiku_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 (EQ (font_param, Qunbound))
+ font_param = Qnil;
+
+ if (NILP (font_param))
+ {
+ /* System font should take precedence over X resources. We suggest this
+ regardless of font-use-system-font because .emacs may not have been
+ read yet. */
+ struct haiku_font_pattern ptn;
+ ptn.specified = 0;
+
+ if (f->tooltip)
+ BFont_populate_plain_family (&ptn);
+ else
+ BFont_populate_fixed_family (&ptn);
+
+ if (ptn.specified & FSPEC_FAMILY)
+ font = font_open_by_name (f, build_unibyte_string (ptn.family));
+ }
+
+ 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 = (const char *[]) { "monospace-12",
+ "Noto Sans Mono-12",
+ "Source Code Pro-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");
+ }
+ else if (!NILP (font_param))
+ {
+ /* Remember the explicit font parameter, so we can re-apply it
+ after we've applied the `default' face settings. */
+ AUTO_FRAME_ARG (arg, Qfont_parameter, font_param);
+ gui_set_frame_parameters (f, arg);
+ }
+
+ gui_default_parameter (f, parms, Qfont, font, "font", "Font",
+ RES_TYPE_STRING);
+}
+
+static struct redisplay_interface haiku_redisplay_interface =
+ {
+ haiku_frame_parm_handlers,
+ gui_produce_glyphs,
+ gui_write_glyphs,
+ gui_insert_glyphs,
+ gui_clear_end_of_line,
+ haiku_scroll_run,
+ haiku_after_update_window_line,
+ NULL,
+ haiku_update_window_end,
+ haiku_flush,
+ gui_clear_window_mouse_face,
+ gui_get_glyph_overhangs,
+ gui_fix_overlapping_area,
+ haiku_draw_fringe_bitmap,
+ haiku_define_fringe_bitmap,
+ haiku_destroy_fringe_bitmap,
+ haiku_compute_glyph_string_overhangs,
+ haiku_draw_glyph_string,
+ haiku_define_frame_cursor,
+ haiku_clear_frame_area,
+ haiku_clear_under_internal_border,
+ haiku_draw_window_cursor,
+ haiku_draw_vertical_window_border,
+ haiku_draw_window_divider,
+ 0, /* shift glyphs for insert */
+ haiku_show_hourglass,
+ haiku_hide_hourglass,
+ haiku_default_font_parameter,
+ };
+
+static void
+haiku_make_fullscreen_consistent (struct frame *f)
+{
+ Lisp_Object lval = get_frame_param (f, Qfullscreen);
+
+ if (!EQ (lval, Qmaximized) && FRAME_OUTPUT_DATA (f)->zoomed_p)
+ lval = Qmaximized;
+ else if (EQ (lval, Qmaximized) && !FRAME_OUTPUT_DATA (f)->zoomed_p)
+ lval = Qnil;
+
+ store_frame_param (f, Qfullscreen, lval);
+}
+
+static void
+flush_dirty_back_buffers (void)
+{
+ block_input ();
+ Lisp_Object tail, frame;
+ FOR_EACH_FRAME (tail, frame)
+ {
+ struct frame *f = XFRAME (frame);
+ if (FRAME_LIVE_P (f) &&
+ FRAME_HAIKU_P (f) &&
+ FRAME_HAIKU_WINDOW (f) &&
+ !FRAME_GARBAGED_P (f) &&
+ !buffer_flipping_blocked_p () &&
+ FRAME_DIRTY_P (f))
+ haiku_flip_buffers (f);
+ }
+ unblock_input ();
+}
+
+static int
+haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
+{
+ block_input ();
+ int message_count = 0;
+ static void *buf = NULL;
+ ssize_t b_size;
+ struct unhandled_event *unhandled_events = NULL;
+ int button_or_motion_p;
+ int need_flush = 0;
+
+ if (!buf)
+ buf = xmalloc (200);
+ haiku_read_size (&b_size);
+ while (b_size >= 0)
+ {
+ enum haiku_event_type type;
+ struct input_event inev, inev2;
+
+ if (b_size > 200)
+ emacs_abort ();
+
+ EVENT_INIT (inev);
+ EVENT_INIT (inev2);
+ inev.kind = NO_EVENT;
+ inev2.kind = NO_EVENT;
+ inev.arg = Qnil;
+ inev2.arg = Qnil;
+
+ button_or_motion_p = 0;
+
+ haiku_read (&type, buf, b_size);
+
+ switch (type)
+ {
+ case QUIT_REQUESTED:
+ {
+ struct haiku_quit_requested_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+
+ if (!f)
+ continue;
+
+ inev.kind = DELETE_WINDOW_EVENT;
+ XSETFRAME (inev.frame_or_window, f);
+ break;
+ }
+ case FRAME_RESIZED:
+ {
+ struct haiku_resize_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+
+ if (!f)
+ continue;
+
+ int width = lrint (b->px_widthf);
+ int height = lrint (b->px_heightf);
+
+ BView_draw_lock (FRAME_HAIKU_VIEW (f));
+ BView_resize_to (FRAME_HAIKU_VIEW (f), width, height);
+ BView_draw_unlock (FRAME_HAIKU_VIEW (f));
+ 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);
+ SET_FRAME_GARBAGED (f);
+ cancel_mouse_face (f);
+ haiku_clear_under_internal_border (f);
+ }
+
+ if (FRAME_OUTPUT_DATA (f)->pending_zoom_width != width ||
+ FRAME_OUTPUT_DATA (f)->pending_zoom_height != height)
+ {
+ FRAME_OUTPUT_DATA (f)->zoomed_p = 0;
+ haiku_make_fullscreen_consistent (f);
+ }
+ else
+ {
+ FRAME_OUTPUT_DATA (f)->zoomed_p = 1;
+ FRAME_OUTPUT_DATA (f)->pending_zoom_width = INT_MIN;
+ FRAME_OUTPUT_DATA (f)->pending_zoom_height = INT_MIN;
+ }
+ break;
+ }
+ case FRAME_EXPOSED:
+ {
+ struct haiku_expose_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+
+ if (!f)
+ continue;
+
+ expose_frame (f, b->x, b->y, b->width, b->height);
+
+ haiku_clear_under_internal_border (f);
+ break;
+ }
+ case KEY_DOWN:
+ {
+ struct haiku_key_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+ int non_ascii_p;
+ if (!f)
+ continue;
+
+ inev.code = b->unraw_mb_char;
+
+ BMapKey (b->kc, &non_ascii_p, &inev.code);
+
+ if (non_ascii_p)
+ inev.kind = NON_ASCII_KEYSTROKE_EVENT;
+ else
+ inev.kind = inev.code > 127 ? MULTIBYTE_CHAR_KEYSTROKE_EVENT :
+ ASCII_KEYSTROKE_EVENT;
+
+ inev.modifiers = haiku_modifiers_to_emacs (b->modifiers);
+ XSETFRAME (inev.frame_or_window, f);
+ break;
+ }
+ case ACTIVATION:
+ {
+ struct haiku_activation_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+
+ if (!f)
+ continue;
+
+ if ((x_display_list->focus_event_frame != f && b->activated_p) ||
+ (x_display_list->focus_event_frame == f && !b->activated_p))
+ {
+ haiku_new_focus_frame (b->activated_p ? f : NULL);
+ if (b->activated_p)
+ x_display_list->focus_event_frame = f;
+ else
+ x_display_list->focus_event_frame = NULL;
+ inev.kind = b->activated_p ? FOCUS_IN_EVENT : FOCUS_OUT_EVENT;
+ XSETFRAME (inev.frame_or_window, f);
+ }
+
+ break;
+ }
+ case MOUSE_MOTION:
+ {
+ struct haiku_mouse_motion_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+
+ if (!f)
+ continue;
+
+ Lisp_Object frame;
+ XSETFRAME (frame, f);
+
+ x_display_list->last_mouse_movement_time = time (NULL);
+ button_or_motion_p = 1;
+
+ if (b->just_exited_p)
+ {
+ Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f);
+ 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;
+ }
+
+ haiku_new_focus_frame (x_display_list->focused_frame);
+ help_echo_string = Qnil;
+ gen_help_event (Qnil, frame, Qnil, Qnil, 0);
+ }
+ else
+ {
+ struct haiku_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+ struct haiku_rect r = dpyinfo->last_mouse_glyph;
+
+ dpyinfo->last_mouse_motion_x = b->x;
+ dpyinfo->last_mouse_motion_y = b->y;
+ dpyinfo->last_mouse_motion_frame = f;
+
+ previous_help_echo_string = help_echo_string;
+ help_echo_string = Qnil;
+
+ if (f != dpyinfo->last_mouse_glyph_frame
+ || b->x < r.x || b->x >= r.x + r.width
+ || b->y < r.y || b->y >= r.y + r.height)
+ {
+ f->mouse_moved = true;
+ dpyinfo->last_mouse_scroll_bar = NULL;
+ note_mouse_highlight (f, b->x, b->y);
+ remember_mouse_glyph (f, b->x, b->y,
+ &FRAME_DISPLAY_INFO (f)->last_mouse_glyph);
+ dpyinfo->last_mouse_glyph_frame = f;
+ gen_help_event (help_echo_string, frame, help_echo_window,
+ help_echo_object, help_echo_pos);
+ }
+
+ if (MOUSE_HL_INFO (f)->mouse_face_hidden)
+ {
+ MOUSE_HL_INFO (f)->mouse_face_hidden = 0;
+ clear_mouse_face (MOUSE_HL_INFO (f));
+ }
+
+ 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);
+
+ if (WINDOWP (window)
+ && !EQ (window, last_mouse_window)
+ && !EQ (window, selected_window)
+ && (!NILP (focus_follows_mouse)
+ || (EQ (XWINDOW (window)->frame,
+ XWINDOW (selected_window)->frame))))
+ {
+ inev.kind = SELECT_WINDOW_EVENT;
+ inev.frame_or_window = window;
+ }
+
+ last_mouse_window = window;
+ }
+ }
+ break;
+ }
+ case BUTTON_UP:
+ case BUTTON_DOWN:
+ {
+ struct haiku_button_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+ Lisp_Object tab_bar_arg = Qnil;
+ int tab_bar_p = 0, tool_bar_p = 0;
+
+ if (!f)
+ continue;
+
+ struct haiku_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+
+ inev.modifiers = haiku_modifiers_to_emacs (b->modifiers);
+
+ x_display_list->last_mouse_glyph_frame = 0;
+ x_display_list->last_mouse_movement_time = time (NULL);
+ button_or_motion_p = 1;
+
+ /* 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 = b->x;
+ int y = b->y;
+
+ window = window_from_coordinates (f, x, y, 0, 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, type == BUTTON_DOWN, inev.modifiers);
+ need_flush = 1;
+ }
+ }
+
+ if (WINDOWP (f->tool_bar_window)
+ && WINDOW_TOTAL_LINES (XWINDOW (f->tool_bar_window)))
+ {
+ Lisp_Object window;
+ int x = b->x;
+ int y = b->y;
+
+ window = window_from_coordinates (f, x, y, 0, true, true);
+ tool_bar_p = EQ (window, f->tool_bar_window);
+
+ if (tool_bar_p)
+ {
+ handle_tool_bar_click
+ (f, x, y, type == BUTTON_DOWN, inev.modifiers);
+ need_flush = 1;
+ }
+ }
+
+ if (type == BUTTON_UP)
+ {
+ inev.modifiers |= up_modifier;
+ dpyinfo->grabbed &= ~(1 << b->btn_no);
+ }
+ else
+ {
+ inev.modifiers |= down_modifier;
+ dpyinfo->last_mouse_frame = f;
+ dpyinfo->grabbed |= (1 << b->btn_no);
+ if (f && !tab_bar_p)
+ f->last_tab_bar_item = -1;
+ if (f && !tool_bar_p)
+ f->last_tool_bar_item = -1;
+ }
+
+ if (!(tab_bar_p && NILP (tab_bar_arg)) && !tool_bar_p)
+ inev.kind = MOUSE_CLICK_EVENT;
+ inev.arg = tab_bar_arg;
+ inev.code = b->btn_no;
+
+ f->mouse_moved = false;
+
+ XSETINT (inev.x, b->x);
+ XSETINT (inev.y, b->y);
+
+ XSETFRAME (inev.frame_or_window, f);
+ break;
+ }
+ case ICONIFICATION:
+ {
+ struct haiku_iconification_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+
+ if (!f)
+ continue;
+
+ if (!b->iconified_p)
+ {
+ SET_FRAME_VISIBLE (f, 1);
+ SET_FRAME_ICONIFIED (f, 0);
+ inev.kind = DEICONIFY_EVENT;
+
+
+ /* Haiku doesn't expose frames on deiconification, but
+ if we are double-buffered, the previous screen
+ contents should have been preserved. */
+ if (!EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f)))
+ {
+ SET_FRAME_GARBAGED (f);
+ expose_frame (f, 0, 0, 0, 0);
+ }
+ }
+ else
+ {
+ SET_FRAME_VISIBLE (f, 0);
+ SET_FRAME_ICONIFIED (f, 1);
+ inev.kind = ICONIFY_EVENT;
+ }
+
+ XSETFRAME (inev.frame_or_window, f);
+ break;
+ }
+ case MOVE_EVENT:
+ {
+ struct haiku_move_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+
+ if (!f)
+ continue;
+
+ if (FRAME_OUTPUT_DATA (f)->pending_zoom_x != b->x ||
+ FRAME_OUTPUT_DATA (f)->pending_zoom_y != b->y)
+ FRAME_OUTPUT_DATA (f)->zoomed_p = 0;
+ else
+ {
+ FRAME_OUTPUT_DATA (f)->zoomed_p = 1;
+ FRAME_OUTPUT_DATA (f)->pending_zoom_x = INT_MIN;
+ FRAME_OUTPUT_DATA (f)->pending_zoom_y = INT_MIN;
+ }
+
+ if (FRAME_PARENT_FRAME (f))
+ haiku_coords_from_parent (f, &b->x, &b->y);
+
+ if (b->x != f->left_pos || b->y != f->top_pos)
+ {
+ inev.kind = MOVE_FRAME_EVENT;
+
+ XSETINT (inev.x, b->x);
+ XSETINT (inev.y, b->y);
+
+ f->left_pos = b->x;
+ f->top_pos = b->y;
+
+ struct frame *p;
+
+ if ((p = FRAME_PARENT_FRAME (f)))
+ {
+ void *window = FRAME_HAIKU_WINDOW (p);
+ EmacsWindow_move_weak_child (window, b->window, b->x, b->y);
+ }
+
+ XSETFRAME (inev.frame_or_window, f);
+ }
+
+ haiku_make_fullscreen_consistent (f);
+ break;
+ }
+ case SCROLL_BAR_VALUE_EVENT:
+ {
+ struct haiku_scroll_bar_value_event *b = buf;
+ struct scroll_bar *bar = b->scroll_bar;
+
+ struct window *w = XWINDOW (bar->window);
+
+ if (bar->update != -1)
+ {
+ bar->update = -1;
+ break;
+ }
+
+ if (bar->position != b->position)
+ {
+ inev.kind = bar->horizontal ? HORIZONTAL_SCROLL_BAR_CLICK_EVENT :
+ SCROLL_BAR_CLICK_EVENT;
+ inev.part = bar->horizontal ?
+ scroll_bar_horizontal_handle : scroll_bar_handle;
+
+ XSETINT (inev.x, b->position);
+ XSETINT (inev.y, bar->total);
+ XSETWINDOW (inev.frame_or_window, w);
+ }
+ break;
+ }
+ case SCROLL_BAR_DRAG_EVENT:
+ {
+ struct haiku_scroll_bar_drag_event *b = buf;
+ struct scroll_bar *bar = b->scroll_bar;
+
+ bar->dragging = b->dragging_p;
+ if (!b->dragging_p && bar->horizontal)
+ set_horizontal_scroll_bar (XWINDOW (bar->window));
+ else if (!b->dragging_p)
+ set_vertical_scroll_bar (XWINDOW (bar->window));
+ break;
+ }
+ case WHEEL_MOVE_EVENT:
+ {
+ struct haiku_wheel_move_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+ int x, y;
+ static float px = 0.0f, py = 0.0f;
+
+ if (!f)
+ continue;
+ BView_get_mouse (FRAME_HAIKU_VIEW (f), &x, &y);
+
+ inev.modifiers = haiku_modifiers_to_emacs (b->modifiers);
+
+ inev2.modifiers = inev.modifiers;
+
+ if (signbit (px) != signbit (b->delta_x))
+ px = 0;
+
+ if (signbit (py) != signbit (b->delta_y))
+ py = 0;
+
+ px += (b->delta_x
+ * powf (FRAME_PIXEL_HEIGHT (f), 2.0f / 3.0f));
+ py += (b->delta_y
+ * powf (FRAME_PIXEL_HEIGHT (f), 2.0f / 3.0f));
+
+ if (fabsf (py) >= FRAME_LINE_HEIGHT (f)
+ || fabsf (px) >= FRAME_COLUMN_WIDTH (f)
+ || !mwheel_coalesce_scroll_events)
+ {
+ inev.kind = (fabsf (px) > fabsf (py)
+ ? HORIZ_WHEEL_EVENT
+ : WHEEL_EVENT);
+ inev.code = 0;
+
+ XSETINT (inev.x, x);
+ XSETINT (inev.y, y);
+ inev.arg = list3 (Qnil, make_float (-px),
+ make_float (-py));
+ XSETFRAME (inev.frame_or_window, f);
+
+ inev.modifiers |= (signbit (inev.kind == HORIZ_WHEEL_EVENT
+ ? px : py)
+ ? up_modifier
+ : down_modifier);
+ py = 0.0f;
+ px = 0.0f;
+ }
+
+ break;
+ }
+
+ case MENU_BAR_RESIZE:
+ {
+ struct haiku_menu_bar_resize_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+
+ if (!f || !FRAME_EXTERNAL_MENU_BAR (f))
+ continue;
+
+ int old_height = FRAME_MENU_BAR_HEIGHT (f);
+
+ FRAME_MENU_BAR_HEIGHT (f) = b->height + 1;
+ FRAME_MENU_BAR_LINES (f) =
+ (b->height + FRAME_LINE_HEIGHT (f)) / FRAME_LINE_HEIGHT (f);
+
+ if (old_height != b->height)
+ {
+ adjust_frame_size (f, -1, -1, 3, true, Qmenu_bar_lines);
+ haiku_clear_under_internal_border (f);
+ }
+ break;
+ }
+ case MENU_BAR_OPEN:
+ case MENU_BAR_CLOSE:
+ {
+ struct haiku_menu_bar_state_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+
+ if (!f || !FRAME_EXTERNAL_MENU_BAR (f))
+ continue;
+
+ if (type == MENU_BAR_OPEN)
+ {
+ if (!FRAME_OUTPUT_DATA (f)->menu_up_to_date_p)
+ {
+ BView_draw_lock (FRAME_HAIKU_VIEW (f));
+ /* This shouldn't be here, but nsmenu does it, so
+ it should probably be safe. */
+ int was_waiting_for_input_p = waiting_for_input;
+ if (waiting_for_input)
+ waiting_for_input = 0;
+ set_frame_menubar (f, 1);
+ waiting_for_input = was_waiting_for_input_p;
+ BView_draw_unlock (FRAME_HAIKU_VIEW (f));
+ }
+ FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 1;
+ popup_activated_p += 1;
+ }
+ else
+ {
+ if (!popup_activated_p)
+ emacs_abort ();
+ if (FRAME_OUTPUT_DATA (f)->menu_bar_open_p)
+ {
+ FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 0;
+ popup_activated_p -= 1;
+ }
+ }
+ break;
+ }
+ case MENU_BAR_SELECT_EVENT:
+ {
+ struct haiku_menu_bar_select_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+
+ if (!f || !FRAME_EXTERNAL_MENU_BAR (f))
+ continue;
+
+ if (FRAME_OUTPUT_DATA (f)->menu_up_to_date_p)
+ find_and_call_menu_selection (f, f->menu_bar_items_used,
+ f->menu_bar_vector, b->ptr);
+ break;
+ }
+ case FILE_PANEL_EVENT:
+ {
+ if (!popup_activated_p)
+ continue;
+
+ struct unhandled_event *ev = xmalloc (sizeof *ev);
+ ev->next = unhandled_events;
+ ev->type = type;
+ memcpy (&ev->buffer, buf, 200);
+
+ unhandled_events = ev;
+ break;
+ }
+ case MENU_BAR_HELP_EVENT:
+ {
+ struct haiku_menu_bar_help_event *b = buf;
+
+ if (!popup_activated_p)
+ continue;
+
+ struct frame *f = haiku_window_to_frame (b->window);
+ if (!f || !FRAME_EXTERNAL_MENU_BAR (f) ||
+ !FRAME_OUTPUT_DATA (f)->menu_bar_open_p)
+ continue;
+
+ run_menu_bar_help_event (f, b->mb_idx);
+
+ break;
+ }
+ case ZOOM_EVENT:
+ {
+ struct haiku_zoom_event *b = buf;
+
+ struct frame *f = haiku_window_to_frame (b->window);
+
+ if (!f)
+ continue;
+
+ FRAME_OUTPUT_DATA (f)->pending_zoom_height = b->height;
+ FRAME_OUTPUT_DATA (f)->pending_zoom_width = b->width;
+ FRAME_OUTPUT_DATA (f)->pending_zoom_x = b->x;
+ FRAME_OUTPUT_DATA (f)->pending_zoom_y = b->y;
+
+ FRAME_OUTPUT_DATA (f)->zoomed_p = 1;
+ haiku_make_fullscreen_consistent (f);
+ break;
+ }
+ case REFS_EVENT:
+ {
+ struct haiku_refs_event *b = buf;
+ struct frame *f = haiku_window_to_frame (b->window);
+
+ if (!f)
+ continue;
+
+ inev.kind = DRAG_N_DROP_EVENT;
+ inev.arg = build_string_from_utf8 (b->ref);
+
+ XSETINT (inev.x, b->x);
+ XSETINT (inev.y, b->y);
+ XSETFRAME (inev.frame_or_window, f);
+
+ /* There should be no problem with calling free here.
+ free on Haiku is thread-safe. */
+ free (b->ref);
+ break;
+ }
+ case APP_QUIT_REQUESTED_EVENT:
+ case KEY_UP:
+ default:
+ break;
+ }
+
+ haiku_read_size (&b_size);
+
+ if (inev.kind != NO_EVENT)
+ {
+ if (inev.kind != HELP_EVENT)
+ inev.timestamp = (button_or_motion_p
+ ? x_display_list->last_mouse_movement_time
+ : time (NULL));
+ kbd_buffer_store_event_hold (&inev, hold_quit);
+ ++message_count;
+ }
+
+ if (inev2.kind != NO_EVENT)
+ {
+ if (inev2.kind != HELP_EVENT)
+ inev2.timestamp = (button_or_motion_p
+ ? x_display_list->last_mouse_movement_time
+ : time (NULL));
+ kbd_buffer_store_event_hold (&inev2, hold_quit);
+ ++message_count;
+ }
+ }
+
+ for (struct unhandled_event *ev = unhandled_events; ev;)
+ {
+ haiku_write_without_signal (ev->type, &ev->buffer);
+ struct unhandled_event *old = ev;
+ ev = old->next;
+ xfree (old);
+ }
+
+ if (need_flush)
+ flush_dirty_back_buffers ();
+
+ unblock_input ();
+ return message_count;
+}
+
+static void
+haiku_frame_rehighlight (struct frame *frame)
+{
+ haiku_rehighlight ();
+}
+
+static void
+haiku_delete_window (struct frame *f)
+{
+ check_window_system (f);
+ haiku_free_frame_resources (f);
+}
+
+static void
+haiku_free_pixmap (struct frame *f, Emacs_Pixmap pixmap)
+{
+ BBitmap_free (pixmap);
+}
+
+static void
+haiku_beep (struct frame *f)
+{
+ if (visible_bell)
+ {
+ void *view = FRAME_HAIKU_VIEW (f);
+ if (view)
+ {
+ block_input ();
+ BView_draw_lock (view);
+ if (!EmacsView_double_buffered_p (view))
+ {
+ BView_SetHighColorForVisibleBell (view, FRAME_FOREGROUND_PIXEL (f));
+ BView_FillRectangleForVisibleBell (view, 0, 0, FRAME_PIXEL_WIDTH (f),
+ FRAME_PIXEL_HEIGHT (f));
+ SET_FRAME_GARBAGED (f);
+ expose_frame (f, 0, 0, 0, 0);
+ }
+ else
+ {
+ EmacsView_do_visible_bell (view, FRAME_FOREGROUND_PIXEL (f));
+ haiku_flip_buffers (f);
+ }
+ BView_draw_unlock (view);
+ unblock_input ();
+ }
+ }
+ else
+ haiku_ring_bell ();
+}
+
+static void
+haiku_toggle_invisible_pointer (struct frame *f, bool invisible_p)
+{
+ void *view = FRAME_HAIKU_VIEW (f);
+
+ if (view)
+ {
+ block_input ();
+ BView_set_view_cursor (view, invisible_p ?
+ FRAME_OUTPUT_DATA (f)->no_cursor :
+ FRAME_OUTPUT_DATA (f)->current_cursor);
+ f->pointer_invisible = invisible_p;
+ unblock_input ();
+ }
+}
+
+static void
+haiku_fullscreen (struct frame *f)
+{
+ if (f->want_fullscreen == FULLSCREEN_MAXIMIZED)
+ {
+ EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0);
+ BWindow_zoom (FRAME_HAIKU_WINDOW (f));
+ }
+ else if (f->want_fullscreen == FULLSCREEN_BOTH)
+ EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 1);
+ else if (f->want_fullscreen == FULLSCREEN_NONE)
+ {
+ EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0);
+ EmacsWindow_unzoom (FRAME_HAIKU_WINDOW (f));
+ }
+
+ f->want_fullscreen = FULLSCREEN_NONE;
+
+ haiku_update_size_hints (f);
+}
+
+static struct terminal *
+haiku_create_terminal (struct haiku_display_info *dpyinfo)
+{
+ struct terminal *terminal;
+
+ terminal = create_terminal (output_haiku, &haiku_redisplay_interface);
+
+ terminal->display_info.haiku = dpyinfo;
+ dpyinfo->terminal = terminal;
+ terminal->kboard = allocate_kboard (Qhaiku);
+
+ terminal->iconify_frame_hook = haiku_iconify_frame;
+ terminal->focus_frame_hook = haiku_focus_frame;
+ terminal->ring_bell_hook = haiku_beep;
+ terminal->popup_dialog_hook = haiku_popup_dialog;
+ terminal->frame_visible_invisible_hook = haiku_set_frame_visible_invisible;
+ terminal->set_frame_offset_hook = haiku_set_offset;
+ terminal->delete_terminal_hook = haiku_delete_terminal;
+ terminal->get_string_resource_hook = get_string_resource;
+ terminal->set_new_font_hook = haiku_new_font;
+ terminal->defined_color_hook = haiku_defined_color;
+ terminal->set_window_size_hook = haiku_set_window_size;
+ terminal->read_socket_hook = haiku_read_socket;
+ terminal->implicit_set_name_hook = haiku_implicitly_set_name;
+ terminal->mouse_position_hook = haiku_mouse_position;
+ terminal->delete_frame_hook = haiku_delete_window;
+ terminal->frame_up_to_date_hook = haiku_frame_up_to_date;
+ terminal->buffer_flipping_unblocked_hook = haiku_buffer_flipping_unblocked_hook;
+ terminal->clear_frame_hook = haiku_clear_frame;
+ terminal->change_tab_bar_height_hook = haiku_change_tab_bar_height;
+ terminal->change_tool_bar_height_hook = haiku_change_tool_bar_height;
+ terminal->set_vertical_scroll_bar_hook = haiku_set_vertical_scroll_bar;
+ terminal->set_horizontal_scroll_bar_hook = haiku_set_horizontal_scroll_bar;
+ terminal->set_scroll_bar_default_height_hook = haiku_set_scroll_bar_default_height;
+ terminal->set_scroll_bar_default_width_hook = haiku_set_scroll_bar_default_width;
+ terminal->judge_scroll_bars_hook = haiku_judge_scroll_bars;
+ terminal->condemn_scroll_bars_hook = haiku_condemn_scroll_bars;
+ terminal->redeem_scroll_bar_hook = haiku_redeem_scroll_bar;
+ terminal->update_begin_hook = haiku_update_begin;
+ terminal->update_end_hook = haiku_update_end;
+ terminal->frame_rehighlight_hook = haiku_frame_rehighlight;
+ terminal->query_frame_background_color = haiku_query_frame_background_color;
+ terminal->free_pixmap = haiku_free_pixmap;
+ terminal->frame_raise_lower_hook = haiku_frame_raise_lower;
+ terminal->menu_show_hook = haiku_menu_show;
+ terminal->toggle_invisible_pointer_hook = haiku_toggle_invisible_pointer;
+ terminal->fullscreen_hook = haiku_fullscreen;
+
+ return terminal;
+}
+
+struct haiku_display_info *
+haiku_term_init (void)
+{
+ struct haiku_display_info *dpyinfo;
+ struct terminal *terminal;
+
+ Lisp_Object color_file, color_map;
+
+ block_input ();
+ Fset_input_interrupt_mode (Qnil);
+
+ baud_rate = 19200;
+
+ dpyinfo = xzalloc (sizeof *dpyinfo);
+
+ haiku_io_init ();
+
+ if (port_application_to_emacs < B_OK)
+ emacs_abort ();
+
+ color_file = Fexpand_file_name (build_string ("rgb.txt"),
+ Fsymbol_value (intern ("data-directory")));
+
+ color_map = Fx_load_color_file (color_file);
+ if (NILP (color_map))
+ fatal ("Could not read %s.\n", SDATA (color_file));
+
+ dpyinfo->color_map = color_map;
+
+ dpyinfo->display = BApplication_setup ();
+
+ BScreen_res (&dpyinfo->resx, &dpyinfo->resy);
+
+ dpyinfo->next = x_display_list;
+ dpyinfo->n_planes = be_get_display_planes ();
+ x_display_list = dpyinfo;
+
+ terminal = haiku_create_terminal (dpyinfo);
+ if (current_kboard == initial_kboard)
+ current_kboard = terminal->kboard;
+
+ terminal->kboard->reference_count++;
+ /* Never delete haiku displays -- there can only ever be one,
+ anyhow. */
+ terminal->reference_count++;
+ terminal->name = xstrdup ("be");
+
+ dpyinfo->name_list_element = Fcons (build_string ("be"), Qnil);
+ dpyinfo->smallest_font_height = 1;
+ dpyinfo->smallest_char_width = 1;
+
+ gui_init_fringe (terminal->rif);
+ unblock_input ();
+
+ return dpyinfo;
+}
+
+void
+put_xrm_resource (Lisp_Object name, Lisp_Object val)
+{
+ eassert (STRINGP (name));
+ eassert (STRINGP (val) || NILP (val));
+
+ Lisp_Object lval = assoc_no_quit (name, rdb);
+ if (!NILP (lval))
+ Fsetcdr (lval, val);
+ else
+ rdb = Fcons (Fcons (name, val), rdb);
+}
+
+void
+haiku_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 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_VIEW (f);
+ block_input ();
+ BView_draw_lock (view);
+ BView_StartClip (view);
+ BView_ClipToRect (view, 0, 0, FRAME_PIXEL_WIDTH (f),
+ FRAME_PIXEL_HEIGHT (f));
+
+ if (face)
+ BView_SetHighColor (view, face->background);
+ else
+ BView_SetHighColor (view, FRAME_BACKGROUND_PIXEL (f));
+
+ BView_FillRectangle (view, 0, margin, width, border);
+ 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_EndClip (view);
+ BView_draw_unlock (view);
+ unblock_input ();
+ }
+}
+
+void
+mark_haiku_display (void)
+{
+ if (x_display_list)
+ mark_object (x_display_list->color_map);
+}
+
+void
+haiku_scroll_bar_remove (struct scroll_bar *bar)
+{
+ block_input ();
+ void *view = FRAME_HAIKU_VIEW (WINDOW_XFRAME (XWINDOW (bar->window)));
+ BView_forget_scroll_bar (view, bar->left, bar->top, bar->width, bar->height);
+ BScrollBar_delete (bar->scroll_bar);
+ expose_frame (WINDOW_XFRAME (XWINDOW (bar->window)),
+ bar->left, bar->top, bar->width, bar->height);
+
+ if (bar->horizontal)
+ wset_horizontal_scroll_bar (XWINDOW (bar->window), Qnil);
+ else
+ wset_vertical_scroll_bar (XWINDOW (bar->window), Qnil);
+
+ unblock_input ();
+};
+
+void
+haiku_set_offset (struct frame *frame, int x, int y,
+ int change_gravity)
+{
+ if (change_gravity > 0)
+ {
+ frame->top_pos = y;
+ frame->left_pos = x;
+ frame->size_hint_flags &= ~ (XNegative | YNegative);
+ if (x < 0)
+ frame->size_hint_flags |= XNegative;
+ if (y < 0)
+ frame->size_hint_flags |= YNegative;
+ frame->win_gravity = NorthWestGravity;
+ }
+
+ haiku_update_size_hints (frame);
+
+ block_input ();
+ if (change_gravity)
+ BWindow_set_offset (FRAME_HAIKU_WINDOW (frame), x, y);
+ unblock_input ();
+}
+
+#ifdef USE_BE_CAIRO
+cairo_t *
+haiku_begin_cr_clip (struct frame *f, struct glyph_string *s)
+{
+ cairo_surface_t *surface = FRAME_CR_SURFACE (f);
+ if (!surface)
+ return NULL;
+
+ cairo_t *context = cairo_create (surface);
+ return context;
+}
+
+void
+haiku_end_cr_clip (cairo_t *cr)
+{
+ cairo_destroy (cr);
+}
+#endif
+
+void
+syms_of_haikuterm (void)
+{
+ DEFVAR_BOOL ("haiku-initialized", haiku_initialized,
+ doc: /* Non-nil if the Haiku terminal backend has been initialized. */);
+
+ DEFVAR_BOOL ("x-use-underline-position-properties",
+ x_use_underline_position_properties,
+ doc: /* SKIP: real doc in xterm.c. */);
+ x_use_underline_position_properties = 1;
+
+ DEFVAR_BOOL ("x-underline-at-descent-line",
+ x_underline_at_descent_line,
+ doc: /* SKIP: real doc in xterm.c. */);
+ x_underline_at_descent_line = 0;
+
+ DEFVAR_LISP ("x-toolkit-scroll-bars", Vx_toolkit_scroll_bars,
+ doc: /* SKIP: real doc in xterm.c. */);
+ Vx_toolkit_scroll_bars = Qt;
+
+ DEFVAR_BOOL ("haiku-debug-on-fatal-error", haiku_debug_on_fatal_error,
+ doc: /* If non-nil, Emacs will launch the system debugger upon a fatal error. */);
+ haiku_debug_on_fatal_error = 1;
+
+ DEFSYM (Qshift, "shift");
+ DEFSYM (Qcontrol, "control");
+ DEFSYM (Qoption, "option");
+ DEFSYM (Qcommand, "command");
+
+ DEFVAR_LISP ("haiku-meta-keysym", Vhaiku_meta_keysym,
+ doc: /* Which key Emacs uses as the meta modifier.
+This is either one of the symbols `shift', `control', `command', and
+`option', or nil, in which case it is treated as `command'.
+
+Setting it to any other value is equivalent to `command'. */);
+ Vhaiku_meta_keysym = Qnil;
+
+ DEFVAR_LISP ("haiku-control-keysym", Vhaiku_control_keysym,
+ doc: /* Which key Emacs uses as the control modifier.
+This is either one of the symbols `shift', `control', `command', and
+`option', or nil, in which case it is treated as `control'.
+
+Setting it to any other value is equivalent to `control'. */);
+ Vhaiku_control_keysym = Qnil;
+
+ DEFVAR_LISP ("haiku-super-keysym", Vhaiku_super_keysym,
+ doc: /* Which key Emacs uses as the super modifier.
+This is either one of the symbols `shift', `control', `command', and
+`option', or nil, in which case it is treated as `option'.
+
+Setting it to any other value is equivalent to `option'. */);
+ Vhaiku_super_keysym = Qnil;
+
+ DEFVAR_LISP ("haiku-shift-keysym", Vhaiku_shift_keysym,
+ doc: /* Which key Emacs uses as the shift modifier.
+This is either one of the symbols `shift', `control', `command', and
+`option', or nil, in which case it is treated as `shift'.
+
+Setting it to any other value is equivalent to `shift'. */);
+ Vhaiku_shift_keysym = Qnil;
+
+
+ DEFSYM (Qx_use_underline_position_properties,
+ "x-use-underline-position-properties");
+
+ DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line");
+
+ rdb = Qnil;
+ staticpro (&rdb);
+
+ Fprovide (Qhaiku, Qnil);
+#ifdef USE_BE_CAIRO
+ Fprovide (intern_c_string ("cairo"), Qnil);
+#endif
+}
diff --git a/src/haikuterm.h b/src/haikuterm.h
new file mode 100644
index 00000000000..7ed7485ef53
--- /dev/null
+++ b/src/haikuterm.h
@@ -0,0 +1,296 @@
+/* Haiku window system support
+ Copyright (C) 2021 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 _HAIKU_TERM_H_
+#define _HAIKU_TERM_H_
+
+#include <pthread.h>
+
+#ifdef USE_BE_CAIRO
+#include <cairo.h>
+#endif
+
+#include "haikugui.h"
+#include "frame.h"
+#include "character.h"
+#include "dispextern.h"
+#include "font.h"
+#include "systime.h"
+
+#define C_FRAME struct frame *
+#define C_FONT struct font *
+#define C_TERMINAL struct terminal *
+
+#define HAVE_CHAR_CACHE_MAX 65535
+
+extern int popup_activated_p;
+
+extern void be_app_quit (void);
+
+struct haikufont_info
+{
+ struct font font;
+ haiku be_font;
+ struct font_metrics **metrics;
+ short metrics_nrows;
+
+ unsigned short **glyphs;
+};
+
+struct haiku_bitmap_record
+{
+ haiku img;
+ char *file;
+ int refcount;
+ int height, width, depth;
+};
+
+struct haiku_display_info
+{
+ /* Chain of all haiku_display_info structures. */
+ struct haiku_display_info *next;
+ C_TERMINAL terminal;
+
+ Lisp_Object name_list_element;
+ Lisp_Object color_map;
+
+ int n_fonts;
+
+ int smallest_char_width;
+ int smallest_font_height;
+
+ struct frame *focused_frame;
+ struct frame *focus_event_frame;
+ struct frame *last_mouse_glyph_frame;
+
+ struct haiku_bitmap_record *bitmaps;
+ ptrdiff_t bitmaps_size;
+ ptrdiff_t bitmaps_last;
+
+ int grabbed;
+ int n_planes;
+ int color_p;
+
+ Window root_window;
+ Lisp_Object rdb;
+
+ Emacs_Cursor vertical_scroll_bar_cursor;
+ Emacs_Cursor horizontal_scroll_bar_cursor;
+
+ Mouse_HLInfo mouse_highlight;
+
+ C_FRAME highlight_frame;
+ C_FRAME last_mouse_frame;
+ C_FRAME last_mouse_motion_frame;
+
+ int last_mouse_motion_x;
+ int last_mouse_motion_y;
+
+ struct haiku_rect last_mouse_glyph;
+
+ void *last_mouse_scroll_bar;
+
+ haiku display;
+
+ double resx, resy;
+
+ Time last_mouse_movement_time;
+};
+
+struct haiku_output
+{
+ Emacs_Cursor text_cursor;
+ Emacs_Cursor nontext_cursor;
+ Emacs_Cursor modeline_cursor;
+ Emacs_Cursor hand_cursor;
+ Emacs_Cursor hourglass_cursor;
+ Emacs_Cursor horizontal_drag_cursor;
+ Emacs_Cursor vertical_drag_cursor;
+ Emacs_Cursor left_edge_cursor;
+ Emacs_Cursor top_left_corner_cursor;
+ Emacs_Cursor top_edge_cursor;
+ Emacs_Cursor top_right_corner_cursor;
+ Emacs_Cursor right_edge_cursor;
+ Emacs_Cursor bottom_right_corner_cursor;
+ Emacs_Cursor bottom_edge_cursor;
+ Emacs_Cursor bottom_left_corner_cursor;
+ Emacs_Cursor no_cursor;
+
+ Emacs_Cursor current_cursor;
+
+ struct haiku_display_info *display_info;
+
+ int baseline_offset;
+ int fontset;
+
+ Emacs_Color cursor_color;
+
+ Window window_desc, parent_desc;
+ char explicit_parent;
+
+ int titlebar_height;
+ int toolbar_height;
+
+ haiku window;
+ haiku view;
+ haiku menubar;
+
+ int menu_up_to_date_p;
+ int zoomed_p;
+
+ int pending_zoom_x;
+ int pending_zoom_y;
+ int pending_zoom_width;
+ int pending_zoom_height;
+
+ int menu_bar_open_p;
+
+ C_FONT font;
+
+ int hourglass_p;
+ uint32_t cursor_fg;
+ bool dirty_p;
+
+ /* The pending position we're waiting for. */
+ int pending_top, pending_left;
+};
+
+struct x_output
+{
+ /* Unused, makes term.c happy. */
+};
+
+extern struct haiku_display_info *x_display_list;
+extern struct font_driver const haikufont_driver;
+
+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 position and size of the scroll bar in pixels, relative to the
+ frame. */
+ int top, left, width, height;
+
+ /* The actual scrollbar. */
+ void *scroll_bar;
+
+ /* Non-nil if the scroll bar handle is currently being dragged by
+ the user. */
+ int dragging;
+
+ /* The update position if we are waiting for a scrollbar update, or
+ -1. */
+ int update;
+
+ /* The last known position of this scrollbar. */
+ int position;
+
+ /* The total number of units inside this scrollbar. */
+ int total;
+
+ /* True if the scroll bar is horizontal. */
+ bool horizontal;
+};
+
+#define XSCROLL_BAR(vec) ((struct scroll_bar *) XVECTOR (vec))
+
+#define FRAME_DIRTY_P(f) (FRAME_OUTPUT_DATA (f)->dirty_p)
+#define MAKE_FRAME_DIRTY(f) (FRAME_DIRTY_P (f) = 1)
+#define FRAME_OUTPUT_DATA(f) ((f)->output_data.haiku)
+#define FRAME_HAIKU_WINDOW(f) (FRAME_OUTPUT_DATA (f)->window)
+#define FRAME_HAIKU_VIEW(f) ((MAKE_FRAME_DIRTY (f)), FRAME_OUTPUT_DATA (f)->view)
+#define FRAME_HAIKU_MENU_BAR(f) (FRAME_OUTPUT_DATA (f)->menubar)
+#define FRAME_DISPLAY_INFO(f) (FRAME_OUTPUT_DATA (f)->display_info)
+#define FRAME_FONT(f) (FRAME_OUTPUT_DATA (f)->font)
+#define FRAME_FONTSET(f) (FRAME_OUTPUT_DATA (f)->fontset)
+#define FRAME_NATIVE_WINDOW(f) (FRAME_OUTPUT_DATA (f)->window)
+#define FRAME_BASELINE_OFFSET(f) (FRAME_OUTPUT_DATA (f)->baseline_offset)
+#define FRAME_CURSOR_COLOR(f) (FRAME_OUTPUT_DATA (f)->cursor_color)
+
+#ifdef USE_BE_CAIRO
+#define FRAME_CR_SURFACE(f) \
+ (FRAME_HAIKU_VIEW (f) ? EmacsView_cairo_surface (FRAME_HAIKU_VIEW (f)) : 0);
+#endif
+
+extern void syms_of_haikuterm (void);
+extern void syms_of_haikufns (void);
+extern void syms_of_haikumenu (void);
+extern void syms_of_haikufont (void);
+extern void syms_of_haikuselect (void);
+extern void init_haiku_select (void);
+
+extern void haiku_iconify_frame (struct frame *);
+extern void haiku_visualize_frame (struct frame *);
+extern void haiku_unvisualize_frame (struct frame *);
+extern void haiku_set_offset (struct frame *, int, int, int);
+extern void haiku_set_frame_visible_invisible (struct frame *, bool);
+extern void haiku_free_frame_resources (struct frame *f);
+extern void haiku_scroll_bar_remove (struct scroll_bar *bar);
+extern void haiku_clear_under_internal_border (struct frame *f);
+extern void haiku_set_name (struct frame *f, Lisp_Object name, bool explicit_p);
+
+extern struct haiku_display_info *haiku_term_init (void);
+
+extern void mark_haiku_display (void);
+
+extern int haiku_get_color (const char *name, Emacs_Color *color);
+extern void haiku_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval);
+extern void haiku_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval);
+extern void haiku_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval);
+extern void haiku_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval);
+extern void haiku_change_tab_bar_height (struct frame *f, int height);
+extern void haiku_change_tool_bar_height (struct frame *f, int height);
+
+extern void haiku_query_color (uint32_t col, Emacs_Color *color);
+
+extern unsigned long haiku_get_pixel (haiku bitmap, int x, int y);
+extern void haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel);
+
+extern Lisp_Object haiku_menu_show (struct frame *f, int x, int y, int menu_flags,
+ Lisp_Object title, const char **error_name);
+extern Lisp_Object haiku_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents);
+
+extern void initialize_frame_menubar (struct frame *f);
+
+extern void run_menu_bar_help_event (struct frame *f, int mb_idx);
+extern void put_xrm_resource (Lisp_Object name, Lisp_Object val);
+
+#ifdef HAVE_NATIVE_IMAGE_API
+extern bool haiku_can_use_native_image_api (Lisp_Object type);
+extern int haiku_load_image (struct frame *f, struct image *img,
+ Lisp_Object spec_file, Lisp_Object spec_data);
+extern void syms_of_haikuimage (void);
+#endif
+
+#ifdef USE_BE_CAIRO
+extern cairo_t *
+haiku_begin_cr_clip (struct frame *f, struct glyph_string *s);
+
+extern void
+haiku_end_cr_clip (cairo_t *cr);
+#endif
+#endif /* _HAIKU_TERM_H_ */
diff --git a/src/image.c b/src/image.c
index 49b26301e8b..dd5ea19fc15 100644
--- a/src/image.c
+++ b/src/image.c
@@ -20,6 +20,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
#include <fcntl.h>
+#include <math.h>
#include <unistd.h>
/* Include this before including <setjmp.h> to work around bugs with
@@ -30,6 +31,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <setjmp.h>
+#include <math.h>
#include <stdint.h>
#include <c-ctype.h>
#include <flexmember.h>
@@ -99,6 +101,15 @@ static unsigned long image_alloc_image_color (struct frame *, struct image *,
Lisp_Object, unsigned long);
#endif /* USE_CAIRO */
+#if defined HAVE_PGTK && defined HAVE_IMAGEMAGICK
+/* In pgtk, we don't want to create scaled image. If we create scaled
+ * image on scale=2.0 environment, the created image is half size and
+ * Gdk scales it back, and the result is blurry. To avoid this, we
+ * hold original size image as far as we can, and let Gdk to scale it
+ * when it is shown. */
+# define DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE
+#endif
+
#ifdef HAVE_NTGUI
/* We need (or want) w32.h only when we're _not_ compiling for Cygwin. */
@@ -129,12 +140,37 @@ typedef struct ns_bitmap_record Bitmap_Record;
#endif /* HAVE_NS */
+#ifdef HAVE_PGTK
+typedef struct pgtk_bitmap_record Bitmap_Record;
+#endif /* HAVE_PGTK */
+
#if (defined HAVE_X_WINDOWS \
&& ! (defined HAVE_NTGUI || defined USE_CAIRO || defined HAVE_NS))
/* W32_TODO : Color tables on W32. */
# define COLOR_TABLE_SUPPORT 1
#endif
+#ifdef HAVE_HAIKU
+#include "haiku_support.h"
+typedef struct haiku_bitmap_record Bitmap_Record;
+
+#define GET_PIXEL(ximg, x, y) haiku_get_pixel (ximg, x, y)
+#define PUT_PIXEL haiku_put_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);
@@ -396,6 +432,34 @@ image_reference_bitmap (struct frame *f, ptrdiff_t id)
++FRAME_DISPLAY_INFO (f)->bitmaps[id - 1].refcount;
}
+#ifdef HAVE_PGTK
+static cairo_pattern_t *
+image_create_pattern_from_pixbuf (struct frame *f, GdkPixbuf * pixbuf)
+{
+ 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_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);
+
+ cairo_pattern_t *pat = cairo_pattern_create_for_surface (surface);
+ cairo_pattern_set_extend (pat, CAIRO_EXTEND_REPEAT);
+
+ cairo_surface_destroy (surface);
+ g_object_unref (pb);
+
+ return pat;
+}
+#endif
+
/* Create a bitmap for frame F from a HEIGHT x WIDTH array of bits at BITS. */
ptrdiff_t
@@ -430,6 +494,54 @@ image_create_bitmap_from_data (struct frame *f, char *bits,
return -1;
#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++;
+ }
+ }
+ }
+#endif /* HAVE_PGTK */
+
+#ifdef HAVE_HAIKU
+ void *bitmap = BBitmap_new (width, height, 1);
+ BBitmap_import_mono_bits (bitmap, bits, width, height);
+#endif
+
id = image_allocate_bitmap_record (f);
#ifdef HAVE_NS
@@ -437,6 +549,18 @@ image_create_bitmap_from_data (struct frame *f, char *bits,
dpyinfo->bitmaps[id - 1].depth = 1;
#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);
+#endif
+
+#ifdef HAVE_HAIKU
+ dpyinfo->bitmaps[id - 1].img = bitmap;
+ dpyinfo->bitmaps[id - 1].depth = 1;
+#endif
+
dpyinfo->bitmaps[id - 1].file = NULL;
dpyinfo->bitmaps[id - 1].height = height;
dpyinfo->bitmaps[id - 1].width = width;
@@ -465,7 +589,7 @@ image_create_bitmap_from_data (struct frame *f, char *bits,
ptrdiff_t
image_create_bitmap_from_file (struct frame *f, Lisp_Object file)
{
-#ifdef HAVE_NTGUI
+#if defined (HAVE_NTGUI) || defined (HAVE_HAIKU)
return -1; /* W32_TODO : bitmap support */
#else
Display_Info *dpyinfo = FRAME_DISPLAY_INFO (f);
@@ -489,6 +613,30 @@ image_create_bitmap_from_file (struct frame *f, Lisp_Object file)
return id;
#endif
+#ifdef HAVE_PGTK
+ GError *err = NULL;
+ ptrdiff_t id;
+ void * bitmap = gdk_pixbuf_new_from_file (SSDATA (file), &err);
+
+ if (!bitmap)
+ {
+ g_error_free (err);
+ 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].depth = 1;
+ dpyinfo->bitmaps[id - 1].height = gdk_pixbuf_get_width (bitmap);
+ dpyinfo->bitmaps[id - 1].width = gdk_pixbuf_get_height (bitmap);
+ dpyinfo->bitmaps[id - 1].pattern
+ = image_create_pattern_from_pixbuf (f, bitmap);
+ return id;
+#endif
+
#ifdef HAVE_X_WINDOWS
unsigned int width, height;
Pixmap bitmap;
@@ -561,6 +709,15 @@ free_bitmap_record (Display_Info *dpyinfo, Bitmap_Record *bm)
ns_release_object (bm->img);
#endif
+#ifdef HAVE_PGTK
+ if (bm->pattern != NULL)
+ cairo_pattern_destroy (bm->pattern);
+#endif
+
+#ifdef HAVE_HAIKU
+ BBitmap_free (bm->img);
+#endif
+
if (bm->file)
{
xfree (bm->file);
@@ -1321,7 +1478,6 @@ image_ascent (struct image *img, struct face *face, struct glyph_slice *slice)
return ascent;
}
-
/* Image background colors. */
@@ -1345,6 +1501,7 @@ four_corners_best (Emacs_Pix_Context pimg, int *corners,
corner_pixels[3] = GET_PIXEL (pimg, corners[LEFT_CORNER], corners[BOT_CORNER] - 1);
}
else
+
{
/* Get the colors at the corner_pixels of pimg. */
corner_pixels[0] = GET_PIXEL (pimg, 0, 0);
@@ -1834,6 +1991,11 @@ image_size_in_bytes (struct image *img)
if (img->mask)
size += w32_image_size (img->mask);
+#elif defined HAVE_HAIKU
+ if (img->pixmap)
+ size += BBitmap_bytes_length (img->pixmap);
+ if (img->mask)
+ size += BBitmap_bytes_length (img->mask);
#endif
return size;
@@ -1975,14 +2137,16 @@ postprocess_image (struct frame *f, struct image *img)
safely rounded and clipped to int range. */
static int
-scale_image_size (int size, size_t divisor, size_t multiplier)
+scale_image_size (int size, double divisor, double multiplier)
{
if (divisor != 0)
{
- double s = size;
- double scaled = s * multiplier / divisor + 0.5;
+ double scaled = size * multiplier / divisor;
if (scaled < INT_MAX)
- return scaled;
+ {
+ /* Use ceil, as rounding can discard fractional SVG pixels. */
+ return ceil (scaled);
+ }
}
return INT_MAX;
}
@@ -2003,84 +2167,77 @@ image_get_dimension (struct image *img, Lisp_Object symbol)
if (FIXNATP (value))
return min (XFIXNAT (value), INT_MAX);
if (CONSP (value) && NUMBERP (CAR (value)) && EQ (Qem, CDR (value)))
- return min (img->face_font_size * XFLOATINT (CAR (value)), INT_MAX);
+ return scale_image_size (img->face_font_size, 1, XFLOATINT (CAR (value)));
return -1;
}
/* Compute the desired size of an image with native size WIDTH x HEIGHT.
- Use SPEC to deduce the size. Store the desired size into
+ Use IMG to deduce the size. Store the desired size into
*D_WIDTH x *D_HEIGHT. Store -1 x -1 if the native size is OK. */
static void
-compute_image_size (size_t width, size_t height,
+compute_image_size (double width, double height,
struct image *img,
int *d_width, int *d_height)
{
- Lisp_Object value;
- int int_value;
- int desired_width = -1, desired_height = -1, max_width = -1, max_height = -1;
double scale = 1;
-
- value = image_spec_value (img->spec, QCscale, NULL);
+ Lisp_Object value = image_spec_value (img->spec, QCscale, NULL);
if (NUMBERP (value))
- scale = XFLOATINT (value);
-
- int_value = image_get_dimension (img, QCmax_width);
- if (int_value >= 0)
- max_width = int_value;
-
- int_value = image_get_dimension (img, QCmax_height);
- if (int_value >= 0)
- max_height = int_value;
+ {
+ double dval = XFLOATINT (value);
+ if (0 <= dval)
+ scale = dval;
+ }
/* If width and/or height is set in the display spec assume we want
to scale to those values. If either h or w is unspecified, the
unspecified should be calculated from the specified to preserve
aspect ratio. */
- int_value = image_get_dimension (img, QCwidth);
- if (int_value >= 0)
+ int desired_width = image_get_dimension (img, QCwidth), max_width;
+ if (desired_width < 0)
+ max_width = image_get_dimension (img, QCmax_width);
+ else
{
- desired_width = int_value * scale;
+ desired_width = scale_image_size (desired_width, 1, scale);
/* :width overrides :max-width. */
max_width = -1;
}
- int_value = image_get_dimension (img, QCheight);
- if (int_value >= 0)
+ int desired_height = image_get_dimension (img, QCheight), max_height;
+ if (desired_height < 0)
+ max_height = image_get_dimension (img, QCmax_height);
+ else
{
- desired_height = int_value * scale;
+ desired_height = scale_image_size (desired_height, 1, scale);
/* :height overrides :max-height. */
max_height = -1;
}
/* If we have both width/height set explicitly, we skip past all the
aspect ratio-preserving computations below. */
- if (desired_width != -1 && desired_height != -1)
+ if (0 <= desired_width && 0 <= desired_height)
goto out;
- width = width * scale;
- height = height * scale;
-
- if (desired_width != -1)
+ if (0 <= desired_width)
/* Width known, calculate height. */
desired_height = scale_image_size (desired_width, width, height);
- else if (desired_height != -1)
+ else if (0 <= desired_height)
/* Height known, calculate width. */
desired_width = scale_image_size (desired_height, height, width);
else
{
- desired_width = width;
- desired_height = height;
+ desired_width = scale_image_size (width, 1, scale);
+ desired_height = scale_image_size (height, 1, scale);
}
- if (max_width != -1 && desired_width > max_width)
+ if (0 <= max_width && max_width < desired_width)
{
/* The image is wider than :max-width. */
desired_width = max_width;
desired_height = scale_image_size (desired_width, width, height);
}
- if (max_height != -1 && desired_height > max_height)
+ if (0 <= max_height && max_height < desired_height)
{
/* The image is higher than :max-height. */
desired_height = max_height;
@@ -2173,6 +2330,7 @@ compute_image_size (size_t width, size_t height,
single step, but the maths for each element is much more complex
and performing the steps separately makes for more readable code. */
+#ifndef HAVE_HAIKU
typedef double matrix3x3[3][3];
static void
@@ -2187,6 +2345,7 @@ matrix3x3_mult (matrix3x3 a, matrix3x3 b, matrix3x3 result)
result[i][j] = sum;
}
}
+#endif /* not HAVE_HAIKU */
static void
compute_image_rotation (struct image *img, double *rotation)
@@ -2211,7 +2370,8 @@ compute_image_rotation (struct image *img, double *rotation)
static void
image_set_transform (struct frame *f, struct image *img)
{
-# ifdef HAVE_IMAGEMAGICK
+# if (defined HAVE_IMAGEMAGICK \
+ && !defined DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE)
/* ImageMagick images already have the correct transform. */
if (EQ (image_spec_value (img->spec, QCtype, NULL), Qimagemagick))
return;
@@ -2244,6 +2404,7 @@ image_set_transform (struct frame *f, struct image *img)
double rotation = 0.0;
compute_image_rotation (img, &rotation);
+#ifndef HAVE_HAIKU
# if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_NS
/* We want scale up operations to use a nearest neighbor filter to
show real pixels instead of munging them, but scale down
@@ -2414,6 +2575,34 @@ image_set_transform (struct frame *f, struct image *img)
img->xform.eDx = matrix[2][0];
img->xform.eDy = matrix[2][1];
# endif
+#else
+ if (rotation != 0 &&
+ rotation != 90 &&
+ rotation != 180 &&
+ rotation != 270 &&
+ rotation != 360)
+ {
+ image_error ("No native support for rotation by %g degrees",
+ make_float (rotation));
+ return;
+ }
+
+ rotation = fmod (rotation, 360.0);
+
+ if (rotation == 90 || rotation == 270)
+ {
+ int w = width;
+ width = height;
+ height = w;
+ }
+
+ img->have_be_transforms_p = rotation != 0 || (img->width != width) || (img->height != height);
+ img->be_rotate = rotation;
+ img->be_scale_x = 1.0 / (img->width / (double) width);
+ img->be_scale_y = 1.0 / (img->height / (double) height);
+ img->width = width;
+ img->height = height;
+#endif /* not HAVE_HAIKU */
}
#endif /* HAVE_IMAGEMAGICK || HAVE_NATIVE_TRANSFORMS */
@@ -2820,6 +3009,30 @@ image_create_x_image_and_pixmap_1 (struct frame *f, int width, int height, int d
return 1;
#endif /* HAVE_X_WINDOWS */
+#ifdef HAVE_HAIKU
+ if (depth == 0)
+ depth = 24;
+
+ if (depth != 24 && depth != 1)
+ {
+ *pimg = NULL;
+ image_error ("Invalid image bit depth specified");
+ return 0;
+ }
+
+ *pixmap = BBitmap_new (width, height, depth == 1);
+
+ if (*pixmap == NO_PIXMAP)
+ {
+ *pimg = NULL;
+ image_error ("Unable to create pixmap", Qnil, Qnil);
+ return 0;
+ }
+
+ *pimg = *pixmap;
+ return 1;
+#endif
+
#ifdef HAVE_NTGUI
BITMAPINFOHEADER *header;
@@ -2960,7 +3173,7 @@ static void
gui_put_x_image (struct frame *f, Emacs_Pix_Container pimg,
Emacs_Pixmap pixmap, int width, int height)
{
-#ifdef USE_CAIRO
+#if defined USE_CAIRO || defined HAVE_HAIKU
eassert (pimg == pixmap);
#elif defined HAVE_X_WINDOWS
GC gc;
@@ -2972,14 +3185,6 @@ gui_put_x_image (struct frame *f, Emacs_Pix_Container pimg,
XFreeGC (FRAME_X_DISPLAY (f), gc);
#endif /* HAVE_X_WINDOWS */
-#ifdef HAVE_NTGUI
-#if 0 /* I don't think this is necessary looking at where it is used. */
- HDC hdc = get_frame_dc (f);
- SetDIBits (hdc, pixmap, 0, height, pimg->data, &(pimg->info), DIB_RGB_COLORS);
- release_frame_dc (f, hdc);
-#endif
-#endif /* HAVE_NTGUI */
-
#ifdef HAVE_NS
eassert (pimg == pixmap);
ns_retain_object (pimg);
@@ -3087,7 +3292,7 @@ image_unget_x_image_or_dc (struct image *img, bool mask_p,
static Emacs_Pix_Container
image_get_x_image (struct frame *f, struct image *img, bool mask_p)
{
-#ifdef USE_CAIRO
+#if defined USE_CAIRO || defined (HAVE_HAIKU)
return !mask_p ? img->pixmap : img->mask;
#elif defined HAVE_X_WINDOWS
XImage *ximg_in_img = !mask_p ? img->ximg : img->mask_img;
@@ -3547,10 +3752,8 @@ convert_mono_to_color_image (struct frame *f, struct image *img,
release_frame_dc (f, hdc);
old_prev = SelectObject (old_img_dc, img->pixmap);
new_prev = SelectObject (new_img_dc, new_pixmap);
- /* Windows convention for mono bitmaps is black = background,
- white = foreground. */
- SetTextColor (new_img_dc, background);
- SetBkColor (new_img_dc, foreground);
+ SetTextColor (new_img_dc, foreground);
+ SetBkColor (new_img_dc, background);
BitBlt (new_img_dc, 0, 0, img->width, img->height, old_img_dc,
0, 0, SRCCOPY);
@@ -4015,6 +4218,13 @@ xbm_load (struct frame *f, struct image *img)
XPM images
***********************************************************************/
+#if defined (HAVE_XPM) || defined (HAVE_NS) || defined (HAVE_PGTK)
+
+static bool xpm_image_p (Lisp_Object object);
+static bool xpm_load (struct frame *f, struct image *img);
+
+#endif /* HAVE_XPM || HAVE_NS */
+
#ifdef HAVE_XPM
#ifdef HAVE_NTGUI
/* Indicate to xpm.h that we don't have Xlib. */
@@ -4038,7 +4248,7 @@ xbm_load (struct frame *f, struct image *img)
#endif /* not HAVE_NTGUI */
#endif /* HAVE_XPM */
-#if defined HAVE_XPM || defined USE_CAIRO || defined HAVE_NS
+#if defined HAVE_XPM || defined USE_CAIRO || defined HAVE_NS || defined HAVE_HAIKU
/* Indices of image specification fields in xpm_format, below. */
@@ -4058,7 +4268,7 @@ enum xpm_keyword_index
XPM_LAST
};
-#if defined HAVE_XPM || defined HAVE_NS
+#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU || defined HAVE_PGTK
/* Vector of image_keyword structures describing the format
of valid XPM image specifications. */
@@ -4076,7 +4286,7 @@ static const struct image_keyword xpm_format[XPM_LAST] =
{":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
{":background", IMAGE_STRING_OR_NIL_VALUE, 0}
};
-#endif /* HAVE_XPM || HAVE_NS */
+#endif /* HAVE_XPM || HAVE_NS || HAVE_HAIKU || HAVE_PGTK */
#if defined HAVE_X_WINDOWS && !defined USE_CAIRO
@@ -4116,9 +4326,9 @@ struct xpm_cached_color
};
/* The hash table used for the color cache, and its bucket vector
- size. */
+ size (which should be prime). */
-#define XPM_COLOR_CACHE_BUCKETS 1001
+#define XPM_COLOR_CACHE_BUCKETS 1009
static struct xpm_cached_color **xpm_color_cache;
/* Initialize the color cache. */
@@ -4300,7 +4510,7 @@ init_xpm_functions (void)
#endif /* WINDOWSNT */
-#if defined HAVE_XPM || defined HAVE_NS
+#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU || defined HAVE_PGTK
/* 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. */
@@ -4336,9 +4546,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 */
+#endif /* HAVE_XPM || HAVE_NS || HAVE_HAIKU || HAVE_PGTK */
-#endif /* HAVE_XPM || USE_CAIRO || HAVE_NS */
+#endif /* HAVE_XPM || USE_CAIRO || HAVE_NS || HAVE_HAIKU */
#if defined HAVE_XPM && defined HAVE_X_WINDOWS && !defined USE_GTK
ptrdiff_t
@@ -4707,9 +4917,11 @@ xpm_load (struct frame *f, struct image *img)
#endif /* HAVE_XPM && !USE_CAIRO */
#if (defined USE_CAIRO && defined HAVE_XPM) \
- || (defined HAVE_NS && !defined HAVE_XPM)
+ || (defined HAVE_NS && !defined HAVE_XPM) \
+ || (defined HAVE_HAIKU && !defined HAVE_XPM) \
+ || (defined HAVE_PGTK && !defined HAVE_XPM)
-/* XPM support functions for NS where libxpm is not available, and for
+/* XPM support functions for NS and Haiku 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 *,
@@ -4906,7 +5118,7 @@ xpm_load_image (struct frame *f,
Lisp_Object (*get_color_table) (Lisp_Object, const char *, int);
Lisp_Object frame, color_symbols, color_table;
int best_key;
-#ifndef HAVE_NS
+#if !defined (HAVE_NS)
bool have_mask = false;
#endif
Emacs_Pix_Container ximg = NULL, mask_img = NULL;
@@ -5446,7 +5658,7 @@ 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
+#elif defined USE_CAIRO || defined HAVE_NS || defined HAVE_HAIKU
return RGB_TO_ULONG (r >> 8, g >> 8, b >> 8);
#else
xsignal1 (Qfile_error,
@@ -5519,7 +5731,7 @@ 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
+#if !defined USE_CAIRO && !defined HAVE_NS && !defined HAVE_HAIKU
Emacs_Color *row = p;
for (x = 0; x < img->width; ++x, ++p)
p->pixel = GET_PIXEL (ximg, x, y);
@@ -5527,7 +5739,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 */
+#else /* USE_CAIRO || HAVE_NS || HAVE_HAIKU */
for (x = 0; x < img->width; ++x, ++p)
{
p->pixel = GET_PIXEL (ximg, x, y);
@@ -5841,6 +6053,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 */
+#ifndef HAVE_HAIKU
#ifndef USE_CAIRO
#define CrossForeground(f) BLACK_PIX_DEFAULT (f)
@@ -5858,6 +6071,7 @@ image_disable_image (struct frame *f, struct image *img)
if (img->mask)
image_pixmap_draw_cross (f, img->mask, 0, 0, img->width, img->height,
MaskForeground (f));
+#endif /* !HAVE_HAIKU */
#endif /* !HAVE_NS */
#else
HDC hdc, bmpdc;
@@ -6415,15 +6629,16 @@ image_can_use_native_api (Lisp_Object type)
return w32_can_use_native_image_api (type);
# elif defined HAVE_NS
return ns_can_use_native_image_api (type);
+# elif defined HAVE_HAIKU
+ return haiku_can_use_native_image_api (type);
# else
return false;
# endif
}
/*
- * These functions are actually defined in the OS-native implementation
- * file. Currently, for Windows GDI+ interface, w32image.c, but other
- * operating systems can follow suit.
+ * These functions are actually defined in the OS-native implementation file.
+ * Currently, for Windows GDI+ interface, w32image.c, and nsimage.m for macOS.
*/
/* Indices of image specification fields in native format, below. */
@@ -6489,6 +6704,9 @@ native_image_load (struct frame *f, struct image *img)
# elif defined HAVE_NS
return ns_load_image (f, img, image_file,
image_spec_value (img->spec, QCdata, NULL));
+# elif defined HAVE_HAIKU
+ return haiku_load_image (f, img, image_file,
+ image_spec_value (img->spec, QCdata, NULL));
# else
return 0;
# endif
@@ -8233,24 +8451,30 @@ gif_image_p (Lisp_Object object)
# undef DrawText
# endif
-/* Giflib before 5.0 didn't define these macros (used only if HAVE_NTGUI). */
-# ifndef GIFLIB_MINOR
-# define GIFLIB_MINOR 0
-# endif
-# ifndef GIFLIB_RELEASE
-# define GIFLIB_RELEASE 0
-# endif
-
# else /* HAVE_NTGUI */
# include <gif_lib.h>
# endif /* HAVE_NTGUI */
-/* Giflib before 5.0 didn't define these macros. */
+/* Giflib before 4.1.6 didn't define these macros. */
# ifndef GIFLIB_MAJOR
# define GIFLIB_MAJOR 4
# endif
+# ifndef GIFLIB_MINOR
+# define GIFLIB_MINOR 0
+# endif
+# ifndef GIFLIB_RELEASE
+# define GIFLIB_RELEASE 0
+# endif
+/* Giflib before 5.0 didn't define these macros. */
+# if GIFLIB_MAJOR < 5
+# define DISPOSAL_UNSPECIFIED 0 /* No disposal specified. */
+# define DISPOSE_DO_NOT 1 /* Leave image in place. */
+# define DISPOSE_BACKGROUND 2 /* Set area too background color. */
+# define DISPOSE_PREVIOUS 3 /* Restore to previous content. */
+# define NO_TRANSPARENT_COLOR -1
+# endif
/* GifErrorString is declared to return char const * when GIFLIB_MAJOR
and GIFLIB_MINOR indicate 5.1 or later. Do not bother using it in
@@ -8273,6 +8497,8 @@ DEF_DLL_FN (GifFileType *, DGifOpenFileName, (const char *));
# else
DEF_DLL_FN (GifFileType *, DGifOpen, (void *, InputFunc, int *));
DEF_DLL_FN (GifFileType *, DGifOpenFileName, (const char *, int *));
+DEF_DLL_FN (int, DGifSavedExtensionToGCB,
+ (GifFileType *, int, GraphicsControlBlock *));
# endif
# if HAVE_GIFERRORSTRING
DEF_DLL_FN (char const *, GifErrorString, (int));
@@ -8290,6 +8516,9 @@ init_gif_functions (void)
LOAD_DLL_FN (library, DGifSlurp);
LOAD_DLL_FN (library, DGifOpen);
LOAD_DLL_FN (library, DGifOpenFileName);
+# if GIFLIB_MAJOR >= 5
+ LOAD_DLL_FN (library, DGifSavedExtensionToGCB);
+# endif
# if HAVE_GIFERRORSTRING
LOAD_DLL_FN (library, GifErrorString);
# endif
@@ -8300,12 +8529,18 @@ init_gif_functions (void)
# undef DGifOpen
# undef DGifOpenFileName
# undef DGifSlurp
+# if GIFLIB_MAJOR >= 5
+# undef DGifSavedExtensionToGCB
+# endif
# undef GifErrorString
# define DGifCloseFile fn_DGifCloseFile
# define DGifOpen fn_DGifOpen
# define DGifOpenFileName fn_DGifOpenFileName
# define DGifSlurp fn_DGifSlurp
+# if GIFLIB_MAJOR >= 5
+# define DGifSavedExtensionToGCB fn_DGifSavedExtensionToGCB
+# endif
# define GifErrorString fn_GifErrorString
# endif /* WINDOWSNT */
@@ -8383,7 +8618,7 @@ gif_load (struct frame *f, struct image *img)
if (!STRINGP (file))
{
image_error ("Cannot find image file `%s'", specified_file);
- return 0;
+ return false;
}
Lisp_Object encoded_file = ENCODE_FILE (file);
@@ -8406,8 +8641,7 @@ gif_load (struct frame *f, struct image *img)
else
#endif
image_error ("Cannot open `%s'", file);
-
- return 0;
+ return false;
}
}
else
@@ -8415,7 +8649,7 @@ gif_load (struct frame *f, struct image *img)
if (!STRINGP (specified_data))
{
image_error ("Invalid image data `%s'", specified_data);
- return 0;
+ return false;
}
/* Read from memory! */
@@ -8439,7 +8673,7 @@ gif_load (struct frame *f, struct image *img)
else
#endif
image_error ("Cannot open memory source `%s'", img->spec);
- return 0;
+ return false;
}
}
@@ -8447,8 +8681,7 @@ gif_load (struct frame *f, struct image *img)
if (!check_image_size (f, gif->SWidth, gif->SHeight))
{
image_size_error ();
- gif_close (gif, NULL);
- return 0;
+ goto gif_error;
}
/* Read entire contents. */
@@ -8459,8 +8692,7 @@ gif_load (struct frame *f, struct image *img)
image_error ("Error reading `%s'", img->spec);
else
image_error ("Error reading GIF data");
- gif_close (gif, NULL);
- return 0;
+ goto gif_error;
}
/* Which sub-image are we to display? */
@@ -8471,8 +8703,7 @@ gif_load (struct frame *f, struct image *img)
{
image_error ("Invalid image number `%s' in image `%s'",
image_number, img->spec);
- gif_close (gif, NULL);
- return 0;
+ goto gif_error;
}
}
@@ -8489,8 +8720,7 @@ gif_load (struct frame *f, struct image *img)
if (!check_image_size (f, width, height))
{
image_size_error ();
- gif_close (gif, NULL);
- return 0;
+ goto gif_error;
}
/* Check that the selected subimages fit. It's not clear whether
@@ -8507,18 +8737,14 @@ gif_load (struct frame *f, struct image *img)
&& 0 <= subimg_left && subimg_left <= width - subimg_width))
{
image_error ("Subimage does not fit in image");
- gif_close (gif, NULL);
- return 0;
+ goto gif_error;
}
}
/* Create the X image and pixmap. */
Emacs_Pix_Container ximg;
if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0))
- {
- gif_close (gif, NULL);
- return 0;
- }
+ goto gif_error;
/* Clear the part of the screen image not covered by the image.
Full animated GIF support requires more here (see the gif89 spec,
@@ -8577,13 +8803,17 @@ gif_load (struct frame *f, struct image *img)
char *, which invites problems with bytes >= 0x80. */
struct SavedImage *subimage = gif->SavedImages + j;
unsigned char *raster = (unsigned char *) subimage->RasterBits;
- int transparency_color_index = -1;
- int disposal = 0;
int subimg_width = subimage->ImageDesc.Width;
int subimg_height = subimage->ImageDesc.Height;
int subimg_top = subimage->ImageDesc.Top;
int subimg_left = subimage->ImageDesc.Left;
+ /* From gif89a spec: 1 = "keep in place", 2 = "restore
+ to background". Treat any other value like 2. */
+ int disposal = DISPOSAL_UNSPECIFIED;
+ int transparency_color_index = NO_TRANSPARENT_COLOR;
+
+#if GIFLIB_MAJOR < 5
/* Find the Graphic Control Extension block for this sub-image.
Extract the disposal method and transparency color. */
for (i = 0; i < subimage->ExtensionBlockCount; i++)
@@ -8594,24 +8824,29 @@ gif_load (struct frame *f, struct image *img)
&& extblock->ByteCount == 4
&& extblock->Bytes[0] & 1)
{
- /* From gif89a spec: 1 = "keep in place", 2 = "restore
- to background". Treat any other value like 2. */
disposal = (extblock->Bytes[0] >> 2) & 7;
transparency_color_index = (unsigned char) extblock->Bytes[3];
break;
}
}
+#else
+ GraphicsControlBlock gcb;
+ DGifSavedExtensionToGCB (gif, j, &gcb);
+ disposal = gcb.DisposalMode;
+ transparency_color_index = gcb.TransparentColor;
+#endif
/* We can't "keep in place" the first subimage. */
if (j == 0)
- disposal = 2;
+ disposal = DISPOSE_BACKGROUND;
- /* For disposal == 0, the spec says "No disposal specified. The
- decoder is not required to take any action." In practice, it
- seems we need to treat this like "keep in place", see e.g.
+ /* For disposal == 0 (DISPOSAL_UNSPECIFIED), the spec says
+ "No disposal specified. The decoder is not required to take
+ any action." In practice, it seems we need to treat this
+ like "keep in place" (DISPOSE_DO_NOT), see e.g.
https://upload.wikimedia.org/wikipedia/commons/3/37/Clock.gif */
- if (disposal == 0)
- disposal = 1;
+ if (disposal == DISPOSAL_UNSPECIFIED)
+ disposal = DISPOSE_DO_NOT;
gif_color_map = subimage->ImageDesc.ColorMap;
if (!gif_color_map)
@@ -8650,7 +8885,7 @@ gif_load (struct frame *f, struct image *img)
for (x = 0; x < subimg_width; x++)
{
int c = raster[y * subimg_width + x];
- if (transparency_color_index != c || disposal != 1)
+ if (transparency_color_index != c || disposal != DISPOSE_DO_NOT)
{
PUT_PIXEL (ximg, x + subimg_left, row + subimg_top,
pixel_colors[c]);
@@ -8664,7 +8899,7 @@ gif_load (struct frame *f, struct image *img)
for (x = 0; x < subimg_width; ++x)
{
int c = raster[y * subimg_width + x];
- if (transparency_color_index != c || disposal != 1)
+ if (transparency_color_index != c || disposal != DISPOSE_DO_NOT)
{
PUT_PIXEL (ximg, x + subimg_left, y + subimg_top,
pixel_colors[c]);
@@ -8734,14 +8969,302 @@ gif_load (struct frame *f, struct image *img)
/* Put ximg into the image. */
image_put_x_image (f, img, ximg, 0);
- return 1;
+ return true;
+
+ gif_error:
+ gif_close (gif, NULL);
+ return false;
}
#endif /* HAVE_GIF */
+#ifdef HAVE_WEBP
+
+
+/***********************************************************************
+ WebP
+ ***********************************************************************/
+
+#include "webp/decode.h"
+
+/* Indices of image specification fields in webp_format, below. */
+
+enum webp_keyword_index
+{
+ WEBP_TYPE,
+ WEBP_DATA,
+ WEBP_FILE,
+ WEBP_ASCENT,
+ WEBP_MARGIN,
+ WEBP_RELIEF,
+ WEBP_ALGORITHM,
+ WEBP_HEURISTIC_MASK,
+ WEBP_MASK,
+ WEBP_BACKGROUND,
+ WEBP_LAST
+};
+
+/* Vector of image_keyword structures describing the format
+ of valid user-defined image specifications. */
+
+static const struct image_keyword webp_format[WEBP_LAST] =
+{
+ {":type", IMAGE_SYMBOL_VALUE, 1},
+ {":data", IMAGE_STRING_VALUE, 0},
+ {":file", IMAGE_STRING_VALUE, 0},
+ {":ascent", IMAGE_ASCENT_VALUE, 0},
+ {":margin", IMAGE_NON_NEGATIVE_INTEGER_VALUE_OR_PAIR, 0},
+ {":relief", IMAGE_INTEGER_VALUE, 0},
+ {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
+ {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
+ {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
+ {":background", IMAGE_STRING_OR_NIL_VALUE, 0}
+};
+
+/* Return true if OBJECT is a valid WebP image specification. */
+
+static bool
+webp_image_p (Lisp_Object object)
+{
+ struct image_keyword fmt[WEBP_LAST];
+ memcpy (fmt, webp_format, sizeof fmt);
+
+ if (!parse_image_spec (object, fmt, WEBP_LAST, Qwebp))
+ return false;
+
+ /* Must specify either the :data or :file keyword. */
+ return fmt[WEBP_FILE].count + fmt[WEBP_DATA].count == 1;
+}
+
+#ifdef WINDOWSNT
+
+/* WebP library details. */
+
+DEF_DLL_FN (int, WebPGetInfo, (const uint8_t *, size_t, int *, int *));
+/* WebPGetFeatures is a static inline function defined in WebP's
+ decode.h. Since we cannot use that with dynamically-loaded libwebp
+ DLL, we instead load the internal function it calls and redirect to
+ that through a macro. */
+DEF_DLL_FN (VP8StatusCode, WebPGetFeaturesInternal,
+ (const uint8_t *, size_t, WebPBitstreamFeatures *, int));
+DEF_DLL_FN (uint8_t *, WebPDecodeRGBA, (const uint8_t *, size_t, int *, int *));
+DEF_DLL_FN (uint8_t *, WebPDecodeRGB, (const uint8_t *, size_t, int *, int *));
+DEF_DLL_FN (void, WebPFree, (void *));
+
+static bool
+init_webp_functions (void)
+{
+ HMODULE library;
+
+ if (!(library = w32_delayed_load (Qwebp)))
+ return false;
+
+ LOAD_DLL_FN (library, WebPGetInfo);
+ LOAD_DLL_FN (library, WebPGetFeaturesInternal);
+ LOAD_DLL_FN (library, WebPDecodeRGBA);
+ LOAD_DLL_FN (library, WebPDecodeRGB);
+ LOAD_DLL_FN (library, WebPFree);
+ return true;
+}
+
+#undef WebPGetInfo
+#undef WebPGetFeatures
+#undef WebPDecodeRGBA
+#undef WebPDecodeRGB
+#undef WebPFree
+
+#define WebPGetInfo fn_WebPGetInfo
+#define WebPGetFeatures(d,s,f) \
+ fn_WebPGetFeaturesInternal(d,s,f,WEBP_DECODER_ABI_VERSION)
+#define WebPDecodeRGBA fn_WebPDecodeRGBA
+#define WebPDecodeRGB fn_WebPDecodeRGB
+#define WebPFree fn_WebPFree
+
+#endif /* WINDOWSNT */
+
+/* Load WebP image IMG for use on frame F. Value is true if
+ successful. */
+
+static bool
+webp_load (struct frame *f, struct image *img)
+{
+ ptrdiff_t size = 0;
+ uint8_t *contents;
+ Lisp_Object file = Qnil;
+
+ /* Open the WebP file. */
+ Lisp_Object specified_file = image_spec_value (img->spec, QCfile, NULL);
+ Lisp_Object specified_data = image_spec_value (img->spec, QCdata, NULL);
+
+ 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);
+ if (contents == NULL)
+ {
+ image_error ("Error loading WebP image `%s'", file);
+ return false;
+ }
+ }
+ else
+ {
+ if (!STRINGP (specified_data))
+ {
+ image_error ("Invalid image data `%s'", specified_data);
+ return false;
+ }
+ contents = SDATA (specified_data);
+ size = SBYTES (specified_data);
+ }
+
+ /* Validate the WebP image header. */
+ if (!WebPGetInfo (contents, size, NULL, NULL))
+ {
+ if (!NILP (file))
+ image_error ("Not a WebP file: `%s'", file);
+ else
+ image_error ("Invalid header in WebP image data");
+ goto webp_error1;
+ }
+
+ /* Get WebP features. */
+ WebPBitstreamFeatures features;
+ VP8StatusCode result = WebPGetFeatures (contents, size, &features);
+ switch (result)
+ {
+ case VP8_STATUS_OK:
+ break;
+ case VP8_STATUS_NOT_ENOUGH_DATA:
+ case VP8_STATUS_OUT_OF_MEMORY:
+ case VP8_STATUS_INVALID_PARAM:
+ case VP8_STATUS_BITSTREAM_ERROR:
+ case VP8_STATUS_UNSUPPORTED_FEATURE:
+ case VP8_STATUS_SUSPENDED:
+ case VP8_STATUS_USER_ABORT:
+ default:
+ /* Error out in all other cases. */
+ if (!NILP (file))
+ image_error ("Error when interpreting WebP image data: `%s'", file);
+ else
+ image_error ("Error when interpreting WebP image data");
+ goto webp_error1;
+ }
+
+ /* Decode WebP data. */
+ uint8_t *decoded;
+ int width, height;
+ if (features.has_alpha)
+ /* Linear [r0, g0, b0, a0, r1, g1, b1, a1, ...] order. */
+ decoded = WebPDecodeRGBA (contents, size, &width, &height);
+ else
+ /* Linear [r0, g0, b0, r1, g1, b1, ...] order. */
+ decoded = WebPDecodeRGB (contents, size, &width, &height);
+
+ if (!decoded)
+ {
+ image_error ("Error when interpreting WebP image data");
+ goto webp_error1;
+ }
+
+ if (!(width <= INT_MAX && height <= INT_MAX
+ && check_image_size (f, width, height)))
+ {
+ image_size_error ();
+ goto webp_error2;
+ }
+
+ /* Create the x image and pixmap. */
+ Emacs_Pix_Container ximg, mask_img = NULL;
+ 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))
+ {
+ image_destroy_x_image (ximg);
+ image_clear_image_1 (f, img, CLEAR_IMAGE_PIXMAP);
+ goto webp_error2;
+ }
+
+ /* Fill the X image and mask from WebP data. */
+ init_color_table ();
+
+ uint8_t *p = decoded;
+ for (int y = 0; y < height; ++y)
+ {
+ 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. */
+ if (features.has_alpha)
+ {
+ if (mask_img)
+ PUT_PIXEL (mask_img, x, y, *p > 0 ? PIX_MASK_DRAW : PIX_MASK_RETAIN);
+ ++p;
+ }
+ }
+ }
+
+#ifdef COLOR_TABLE_SUPPORT
+ /* Remember colors allocated for this image. */
+ img->colors = colors_in_color_table (&img->ncolors);
+ free_color_table ();
+#endif /* COLOR_TABLE_SUPPORT */
+
+ /* 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;
+
+ /* Clean up. */
+ WebPFree (decoded);
+ if (NILP (specified_data))
+ xfree (contents);
+ return true;
+
+ webp_error2:
+ WebPFree (decoded);
+
+ webp_error1:
+ if (NILP (specified_data))
+ xfree (contents);
+ return false;
+}
+
+#endif /* HAVE_WEBP */
+
+
#ifdef HAVE_IMAGEMAGICK
+
/***********************************************************************
ImageMagick
***********************************************************************/
@@ -9117,11 +9640,15 @@ imagemagick_load_image (struct frame *f, struct image *img,
PixelWand **pixels, *bg_wand = NULL;
MagickPixelPacket pixel;
Lisp_Object image;
+#ifndef DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE
Lisp_Object value;
+#endif
Lisp_Object crop;
EMACS_INT ino;
int desired_width, desired_height;
+#ifndef DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE
double rotation;
+#endif
char hint_buffer[MaxTextExtent];
char *filename_hint = NULL;
imagemagick_initialize ();
@@ -9238,9 +9765,13 @@ imagemagick_load_image (struct frame *f, struct image *img,
PixelSetBlue (bg_wand, (double) bgcolor.blue / 65535);
}
+#ifndef DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE
compute_image_size (MagickGetImageWidth (image_wand),
MagickGetImageHeight (image_wand),
img, &desired_width, &desired_height);
+#else
+ desired_width = desired_height = -1;
+#endif
if (desired_width != -1 && desired_height != -1)
{
@@ -9284,6 +9815,7 @@ imagemagick_load_image (struct frame *f, struct image *img,
}
}
+#ifndef DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE
/* Furthermore :rotation. we need background color and angle for
rotation. */
/*
@@ -9302,6 +9834,7 @@ imagemagick_load_image (struct frame *f, struct image *img,
goto imagemagick_error;
}
}
+#endif
/* Set the canvas background color to the frame or specified
background, and flatten the image. Note: as of ImageMagick
@@ -9339,7 +9872,8 @@ imagemagick_load_image (struct frame *f, struct image *img,
init_color_table ();
-#if defined (HAVE_MAGICKEXPORTIMAGEPIXELS) && ! defined (HAVE_NS)
+#if defined (HAVE_MAGICKEXPORTIMAGEPIXELS) && \
+ ! defined (HAVE_NS) && ! defined (HAVE_HAIKU)
if (imagemagick_render_type != 0)
{
/* Magicexportimage is normally faster than pixelpushing. This
@@ -9432,8 +9966,8 @@ imagemagick_load_image (struct frame *f, struct image *img,
color_scale * pixel.red,
color_scale * pixel.green,
color_scale * pixel.blue));
- }
- }
+ }
+ }
DestroyPixelIterator (iterator);
}
@@ -9669,6 +10203,10 @@ DEF_DLL_FN (gboolean, rsvg_handle_close, (RsvgHandle *, GError **));
DEF_DLL_FN (void, rsvg_handle_set_dpi_x_y,
(RsvgHandle * handle, double dpi_x, double dpi_y));
+# if LIBRSVG_CHECK_VERSION (2, 52, 1)
+DEF_DLL_FN (gboolean, rsvg_handle_get_intrinsic_size_in_pixels,
+ (RsvgHandle *, gdouble *, gdouble *));
+# endif
# if LIBRSVG_CHECK_VERSION (2, 46, 0)
DEF_DLL_FN (void, rsvg_handle_get_intrinsic_dimensions,
(RsvgHandle *, gboolean *, RsvgLength *, gboolean *,
@@ -9676,14 +10214,15 @@ DEF_DLL_FN (void, rsvg_handle_get_intrinsic_dimensions,
DEF_DLL_FN (gboolean, rsvg_handle_get_geometry_for_layer,
(RsvgHandle *, const char *, const RsvgRectangle *,
RsvgRectangle *, RsvgRectangle *, GError **));
+# else
+DEF_DLL_FN (void, rsvg_handle_get_dimensions,
+ (RsvgHandle *, RsvgDimensionData *));
# endif
# if LIBRSVG_CHECK_VERSION (2, 48, 0)
DEF_DLL_FN (gboolean, rsvg_handle_set_stylesheet,
(RsvgHandle *, const guint8 *, gsize, GError **));
# endif
-DEF_DLL_FN (void, rsvg_handle_get_dimensions,
- (RsvgHandle *, RsvgDimensionData *));
DEF_DLL_FN (GdkPixbuf *, rsvg_handle_get_pixbuf, (RsvgHandle *));
DEF_DLL_FN (int, gdk_pixbuf_get_width, (const GdkPixbuf *));
DEF_DLL_FN (int, gdk_pixbuf_get_height, (const GdkPixbuf *));
@@ -9731,14 +10270,18 @@ init_svg_functions (void)
LOAD_DLL_FN (library, rsvg_handle_close);
#endif
LOAD_DLL_FN (library, rsvg_handle_set_dpi_x_y);
+#if LIBRSVG_CHECK_VERSION (2, 52, 1)
+ LOAD_DLL_FN (library, rsvg_handle_get_intrinsic_size_in_pixels);
+#endif
#if LIBRSVG_CHECK_VERSION (2, 46, 0)
LOAD_DLL_FN (library, rsvg_handle_get_intrinsic_dimensions);
LOAD_DLL_FN (library, rsvg_handle_get_geometry_for_layer);
+#else
+ LOAD_DLL_FN (library, rsvg_handle_get_dimensions);
#endif
#if LIBRSVG_CHECK_VERSION (2, 48, 0)
LOAD_DLL_FN (library, rsvg_handle_set_stylesheet);
#endif
- LOAD_DLL_FN (library, rsvg_handle_get_dimensions);
LOAD_DLL_FN (library, rsvg_handle_get_pixbuf);
LOAD_DLL_FN (gdklib, gdk_pixbuf_get_width);
@@ -9773,11 +10316,15 @@ init_svg_functions (void)
# undef g_clear_error
# undef g_object_unref
# undef g_type_init
+# if LIBRSVG_CHECK_VERSION (2, 52, 1)
+# undef rsvg_handle_get_intrinsic_size_in_pixels
+# endif
# if LIBRSVG_CHECK_VERSION (2, 46, 0)
# undef rsvg_handle_get_intrinsic_dimensions
# undef rsvg_handle_get_geometry_for_layer
+# else
+# undef rsvg_handle_get_dimensions
# endif
-# undef rsvg_handle_get_dimensions
# if LIBRSVG_CHECK_VERSION (2, 48, 0)
# undef rsvg_handle_set_stylesheet
# endif
@@ -9807,13 +10354,18 @@ init_svg_functions (void)
# if ! GLIB_CHECK_VERSION (2, 36, 0)
# define g_type_init fn_g_type_init
# endif
+# if LIBRSVG_CHECK_VERSION (2, 52, 1)
+# define rsvg_handle_get_intrinsic_size_in_pixels \
+ fn_rsvg_handle_get_intrinsic_size_in_pixels
+# endif
# if LIBRSVG_CHECK_VERSION (2, 46, 0)
# define rsvg_handle_get_intrinsic_dimensions \
fn_rsvg_handle_get_intrinsic_dimensions
# define rsvg_handle_get_geometry_for_layer \
fn_rsvg_handle_get_geometry_for_layer
+# else
+# define rsvg_handle_get_dimensions fn_rsvg_handle_get_dimensions
# endif
-# define rsvg_handle_get_dimensions fn_rsvg_handle_get_dimensions
# if LIBRSVG_CHECK_VERSION (2, 48, 0)
# define rsvg_handle_set_stylesheet fn_rsvg_handle_set_stylesheet
# endif
@@ -10043,72 +10595,85 @@ svg_load_image (struct frame *f, struct image *img, char *contents,
/* Get the image dimensions. */
#if LIBRSVG_CHECK_VERSION (2, 46, 0)
- RsvgRectangle zero_rect, viewbox, out_logical_rect;
-
- /* Try the intrinsic dimensions first. */
- gboolean has_width, has_height, has_viewbox;
- RsvgLength iwidth, iheight;
- double dpi = FRAME_DISPLAY_INFO (f)->resx;
-
- rsvg_handle_get_intrinsic_dimensions (rsvg_handle,
- &has_width, &iwidth,
- &has_height, &iheight,
- &has_viewbox, &viewbox);
+ gdouble gviewbox_width = 0, gviewbox_height = 0;
+ gboolean has_viewbox = FALSE;
+# if LIBRSVG_CHECK_VERSION (2, 52, 1)
+ has_viewbox = rsvg_handle_get_intrinsic_size_in_pixels (rsvg_handle,
+ &gviewbox_width,
+ &gviewbox_height);
+# endif
- if (has_width && has_height)
- {
- /* Success! We can use these values directly. */
- viewbox_width = svg_css_length_to_pixels (iwidth, dpi, img->face_font_size);
- viewbox_height = svg_css_length_to_pixels (iheight, dpi, img->face_font_size);
- }
- else if (has_width && has_viewbox)
- {
- viewbox_width = svg_css_length_to_pixels (iwidth, dpi, img->face_font_size);
- viewbox_height = svg_css_length_to_pixels (iwidth, dpi, img->face_font_size)
- * viewbox.height / viewbox.width;
- }
- else if (has_height && has_viewbox)
- {
- viewbox_height = svg_css_length_to_pixels (iheight, dpi, img->face_font_size);
- viewbox_width = svg_css_length_to_pixels (iheight, dpi, img->face_font_size)
- * viewbox.width / viewbox.height;
- }
- else if (has_viewbox)
+ if (has_viewbox)
{
- viewbox_width = viewbox.width;
- viewbox_height = viewbox.height;
+ viewbox_width = gviewbox_width;
+ viewbox_height = gviewbox_height;
}
else
{
- /* We haven't found a usable set of sizes, so try working out
- the visible area. */
- rsvg_handle_get_geometry_for_layer (rsvg_handle, NULL,
- &zero_rect, &viewbox,
- &out_logical_rect, NULL);
- viewbox_width = viewbox.x + viewbox.width;
- viewbox_height = viewbox.y + viewbox.height;
- }
+ RsvgRectangle zero_rect, viewbox, out_logical_rect;
- if (viewbox_width == 0 || viewbox_height == 0)
-#endif
- {
- /* The functions used above to get the geometry of the visible
- area of the SVG are only available in librsvg 2.46 and above,
- so in certain circumstances this code path can result in some
- parts of the SVG being cropped. */
- RsvgDimensionData dimension_data;
+ /* Try the intrinsic dimensions first. */
+ gboolean has_width, has_height;
+ RsvgLength iwidth, iheight;
+ double dpi = FRAME_DISPLAY_INFO (f)->resx;
- rsvg_handle_get_dimensions (rsvg_handle, &dimension_data);
+ rsvg_handle_get_intrinsic_dimensions (rsvg_handle,
+ &has_width, &iwidth,
+ &has_height, &iheight,
+ &has_viewbox, &viewbox);
- viewbox_width = dimension_data.width;
- viewbox_height = dimension_data.height;
- }
+ if (has_width && has_height)
+ {
+ /* Success! We can use these values directly. */
+ viewbox_width = svg_css_length_to_pixels (iwidth, dpi,
+ img->face_font_size);
+ viewbox_height = svg_css_length_to_pixels (iheight, dpi,
+ img->face_font_size);
+ }
+ else if (has_width && has_viewbox)
+ {
+ viewbox_width = svg_css_length_to_pixels (iwidth, dpi,
+ img->face_font_size);
+ viewbox_height = viewbox_width * viewbox.height / viewbox.width;
+ }
+ else if (has_height && has_viewbox)
+ {
+ viewbox_height = svg_css_length_to_pixels (iheight, dpi,
+ img->face_font_size);
+ viewbox_width = viewbox_height * viewbox.width / viewbox.height;
+ }
+ else if (has_viewbox)
+ {
+ viewbox_width = viewbox.width;
+ viewbox_height = viewbox.height;
+ }
+ else
+ viewbox_width = viewbox_height = 0;
+
+ if (! (0 < viewbox_width && 0 < viewbox_height))
+ {
+ /* We haven't found a usable set of sizes, so try working out
+ the visible area. */
+ rsvg_handle_get_geometry_for_layer (rsvg_handle, NULL,
+ &zero_rect, &viewbox,
+ &out_logical_rect, NULL);
+ viewbox_width = viewbox.x + viewbox.width;
+ viewbox_height = viewbox.y + viewbox.height;
+ }
+ }
+#else
+ /* In librsvg before 2.46.0, guess the viewbox from the image dimensions. */
+ RsvgDimensionData dimension_data;
+ rsvg_handle_get_dimensions (rsvg_handle, &dimension_data);
+ viewbox_width = dimension_data.width;
+ viewbox_height = dimension_data.height;
+#endif
compute_image_size (viewbox_width, viewbox_height, img,
&width, &height);
- width *= FRAME_SCALE_FACTOR (f);
- height *= FRAME_SCALE_FACTOR (f);
+ width = scale_image_size (width, 1, FRAME_SCALE_FACTOR (f));
+ height = scale_image_size (height, 1, FRAME_SCALE_FACTOR (f));
if (! check_image_size (f, width, height))
{
@@ -10555,16 +11120,6 @@ x_kill_gs_process (Pixmap pixmap, struct frame *f)
free_color_table ();
#endif
XDestroyImage (ximg);
-
-#if 0 /* This doesn't seem to be the case. If we free the colors
- here, we get a BadAccess later in image_clear_image when
- freeing the colors. */
- /* We have allocated colors once, but Ghostscript has also
- allocated colors on behalf of us. So, to get the
- reference counts right, free them once. */
- if (img->ncolors)
- x_free_colors (f, img->colors, img->ncolors);
-#endif
}
else
image_error ("Cannot get X image of `%s'; colors will not be freed",
@@ -10633,7 +11188,8 @@ The list of capabilities can include one or more of the following:
if (FRAME_WINDOW_P (f))
{
#ifdef HAVE_NATIVE_TRANSFORMS
-# if defined HAVE_IMAGEMAGICK || defined (USE_CAIRO) || defined (HAVE_NS)
+# if defined HAVE_IMAGEMAGICK || defined (USE_CAIRO) || defined (HAVE_NS) \
+ || defined (HAVE_HAIKU)
return list2 (Qscale, Qrotate90);
# elif defined (HAVE_X_WINDOWS) && defined (HAVE_XRENDER)
int event_basep, error_basep;
@@ -10723,10 +11279,14 @@ 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
+#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU || defined HAVE_PGTK
{ SYMBOL_INDEX (Qxpm), xpm_image_p, xpm_load, image_clear_image,
IMAGE_TYPE_INIT (init_xpm_functions) },
#endif
+#if defined HAVE_WEBP
+ { SYMBOL_INDEX (Qwebp), webp_image_p, webp_load, image_clear_image,
+ IMAGE_TYPE_INIT (init_webp_functions) },
+#endif
{ SYMBOL_INDEX (Qxbm), xbm_image_p, xbm_load, image_clear_image },
{ SYMBOL_INDEX (Qpbm), pbm_image_p, pbm_load, image_clear_image },
};
@@ -10867,7 +11427,8 @@ non-numeric, there is no explicit limit on the size of images. */);
DEFSYM (Qxbm, "xbm");
add_image_type (Qxbm);
-#if defined (HAVE_XPM) || defined (HAVE_NS)
+#if defined (HAVE_XPM) || defined (HAVE_NS) \
+ || defined (HAVE_HAIKU) || defined (HAVE_PGTK)
DEFSYM (Qxpm, "xpm");
add_image_type (Qxpm);
#endif
@@ -10892,6 +11453,11 @@ non-numeric, there is no explicit limit on the size of images. */);
add_image_type (Qpng);
#endif
+#if defined (HAVE_WEBP)
+ DEFSYM (Qwebp, "webp");
+ add_image_type (Qwebp);
+#endif
+
#if defined (HAVE_IMAGEMAGICK)
DEFSYM (Qimagemagick, "imagemagick");
add_image_type (Qimagemagick);
diff --git a/src/indent.c b/src/indent.c
index de6b4895616..914dabf1e72 100644
--- a/src/indent.c
+++ b/src/indent.c
@@ -2051,6 +2051,7 @@ window_column_x (struct window *w, Lisp_Object window,
/* Restore window's buffer and point. */
+/* FIXME: Merge with `with_echo_area_buffer_unwind_data`? */
static void
restore_window_buffer (Lisp_Object list)
{
diff --git a/src/intervals.c b/src/intervals.c
index f88a41f2549..11d5b6bbb6f 100644
--- a/src/intervals.c
+++ b/src/intervals.c
@@ -166,10 +166,11 @@ merge_properties (register INTERVAL source, register INTERVAL target)
}
}
-/* Return true if the two intervals have the same properties. */
+/* Return true if the two intervals have the same properties.
+ If use_equal is true, use Fequal for comparisons instead of EQ. */
-bool
-intervals_equal (INTERVAL i0, INTERVAL i1)
+static bool
+intervals_equal_1 (INTERVAL i0, INTERVAL i1, bool use_equal)
{
Lisp_Object i0_cdr, i0_sym;
Lisp_Object i1_cdr, i1_val;
@@ -204,7 +205,8 @@ intervals_equal (INTERVAL i0, INTERVAL i1)
/* i0 and i1 both have sym, but it has different values in each. */
if (!CONSP (i1_val)
|| (i1_val = XCDR (i1_val), !CONSP (i1_val))
- || !EQ (XCAR (i1_val), XCAR (i0_cdr)))
+ || use_equal ? NILP (Fequal (XCAR (i1_val), XCAR (i0_cdr)))
+ : !EQ (XCAR (i1_val), XCAR (i0_cdr)))
return false;
i0_cdr = XCDR (i0_cdr);
@@ -218,6 +220,14 @@ intervals_equal (INTERVAL i0, INTERVAL i1)
/* Lengths of the two plists were equal. */
return (NILP (i0_cdr) && NILP (i1_cdr));
}
+
+/* Return true if the two intervals have the same properties. */
+
+bool
+intervals_equal (INTERVAL i0, INTERVAL i1)
+{
+ return intervals_equal_1 (i0, i1, false);
+}
/* Traverse an interval tree TREE, performing FUNCTION on each node.
@@ -2291,7 +2301,7 @@ compare_string_intervals (Lisp_Object s1, Lisp_Object s2)
/* If we ever find a mismatch between the strings,
they differ. */
- if (! intervals_equal (i1, i2))
+ if (! intervals_equal_1 (i1, i2, true))
return 0;
/* Advance POS till the end of the shorter interval,
diff --git a/src/keyboard.c b/src/keyboard.c
index 1d8d98c9419..821a1b576be 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -375,6 +375,7 @@ static void timer_resume_idle (void);
static void deliver_user_signal (int);
static char *find_user_signal_name (int);
static void store_user_signal_events (void);
+static bool is_ignored_event (union buffered_input_event *);
/* Advance or retreat a buffered input event pointer. */
@@ -2943,20 +2944,8 @@ read_char (int commandflag, Lisp_Object map,
last_input_event = c;
call4 (Qcommand_execute, tem, Qnil, Fvector (1, &last_input_event), Qt);
- if (CONSP (c)
- && (EQ (XCAR (c), Qselect_window)
- || EQ (XCAR (c), Qfocus_out)
-#ifdef HAVE_DBUS
- || EQ (XCAR (c), Qdbus_event)
-#endif
-#ifdef USE_FILE_NOTIFY
- || EQ (XCAR (c), Qfile_notify)
-#endif
-#ifdef THREADS_ENABLED
- || EQ (XCAR (c), Qthread_event)
-#endif
- || EQ (XCAR (c), Qconfig_changed_event))
- && !end_time)
+ if (CONSP (c) && !NILP (Fmemq (XCAR (c), Vwhile_no_input_ignore_events))
+ && !end_time)
/* We stopped being idle for this event; undo that. This
prevents automatic window selection (under
mouse-autoselect-window) from acting as a real input event, for
@@ -3458,8 +3447,13 @@ readable_events (int flags)
if (flags & READABLE_EVENTS_DO_TIMERS_NOW)
timer_check ();
- /* If the buffer contains only FOCUS_IN/OUT_EVENT events, and
- READABLE_EVENTS_FILTER_EVENTS is set, report it as empty. */
+ /* READABLE_EVENTS_FILTER_EVENTS is meant to be used only by
+ input-pending-p and similar callers, which aren't interested in
+ some input events. If this flag is set, and
+ input-pending-p-filter-events is non-nil, ignore events in
+ while-no-input-ignore-events. If the flag is set and
+ input-pending-p-filter-events is nil, ignore only
+ FOCUS_IN/OUT_EVENT events. */
if (kbd_fetch_ptr != kbd_store_ptr)
{
/* See https://lists.gnu.org/r/emacs-devel/2005-05/msg00297.html
@@ -3478,8 +3472,11 @@ readable_events (int flags)
#ifdef USE_TOOLKIT_SCROLL_BARS
(flags & READABLE_EVENTS_FILTER_EVENTS) &&
#endif
- (event->kind == FOCUS_IN_EVENT
- || event->kind == FOCUS_OUT_EVENT))
+ ((!input_pending_p_filter_events
+ && (event->kind == FOCUS_IN_EVENT
+ || event->kind == FOCUS_OUT_EVENT))
+ || (input_pending_p_filter_events
+ && is_ignored_event (event))))
#ifdef USE_TOOLKIT_SCROLL_BARS
&& !((flags & READABLE_EVENTS_IGNORE_SQUEEZABLES)
&& (event->kind == SCROLL_BAR_CLICK_EVENT
@@ -3661,29 +3658,10 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event,
#endif /* subprocesses */
}
- Lisp_Object ignore_event;
-
- switch (event->kind)
- {
- case FOCUS_IN_EVENT: ignore_event = Qfocus_in; break;
- case FOCUS_OUT_EVENT: ignore_event = Qfocus_out; break;
- case HELP_EVENT: ignore_event = Qhelp_echo; break;
- case ICONIFY_EVENT: ignore_event = Qiconify_frame; break;
- case DEICONIFY_EVENT: ignore_event = Qmake_frame_visible; break;
- case SELECTION_REQUEST_EVENT: ignore_event = Qselection_request; break;
-#ifdef USE_FILE_NOTIFY
- case FILE_NOTIFY_EVENT: ignore_event = Qfile_notify; break;
-#endif
-#ifdef HAVE_DBUS
- case DBUS_EVENT: ignore_event = Qdbus_event; break;
-#endif
- default: ignore_event = Qnil; break;
- }
-
/* If we're inside while-no-input, and this event qualifies
as input, set quit-flag to cause an interrupt. */
if (!NILP (Vthrow_on_input)
- && NILP (Fmemq (ignore_event, Vwhile_no_input_ignore_events)))
+ && !is_ignored_event (event))
Vquit_flag = Vthrow_on_input;
}
@@ -3887,7 +3865,7 @@ kbd_buffer_get_event (KBOARD **kbp,
/* One way or another, wait until input is available; then, if
interrupt handlers have not read it, read it now. */
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
gobble_input ();
#endif
if (kbd_fetch_ptr != kbd_store_ptr)
@@ -3994,6 +3972,9 @@ kbd_buffer_get_event (KBOARD **kbp,
*used_mouse_menu = true;
FALLTHROUGH;
#endif
+#ifdef HAVE_PGTK
+ case PGTK_PREEDIT_TEXT_EVENT:
+#endif
#ifdef HAVE_NTGUI
case END_SESSION_EVENT:
case LANGUAGE_CHANGE_EVENT:
@@ -4015,6 +3996,7 @@ kbd_buffer_get_event (KBOARD **kbp,
#endif
#ifdef HAVE_XWIDGETS
case XWIDGET_EVENT:
+ case XWIDGET_DISPLAY_EVENT:
#endif
case SAVE_SESSION_EVENT:
case NO_EVENT:
@@ -4919,7 +4901,7 @@ static const char *const lispy_kana_keys[] =
/* You'll notice that this table is arranged to be conveniently
indexed by X Windows keysym values. */
-static const char *const lispy_function_keys[] =
+const char *const lispy_function_keys[] =
{
/* X Keysym value */
@@ -6002,7 +5984,11 @@ make_lispy_event (struct input_event *event)
ASIZE (wheel_syms));
}
- if (NUMBERP (event->arg))
+ if (CONSP (event->arg))
+ return list5 (head, position, make_fixnum (double_click_count),
+ XCAR (event->arg), Fcons (XCAR (XCDR (event->arg)),
+ XCAR (XCDR (XCDR (event->arg)))));
+ else if (NUMBERP (event->arg))
return list4 (head, position, make_fixnum (double_click_count),
event->arg);
else if (event->modifiers & (double_modifier | triple_modifier))
@@ -6011,6 +5997,61 @@ make_lispy_event (struct input_event *event)
return list2 (head, position);
}
+ case TOUCH_END_EVENT:
+ {
+ Lisp_Object position;
+
+ /* Build the position as appropriate for this mouse click. */
+ struct frame *f = XFRAME (event->frame_or_window);
+
+ if (! FRAME_LIVE_P (f))
+ return Qnil;
+
+ position = make_lispy_position (f, event->x, event->y,
+ event->timestamp);
+
+ return list2 (Qtouch_end, position);
+ }
+
+ case TOUCHSCREEN_BEGIN_EVENT:
+ case TOUCHSCREEN_END_EVENT:
+ {
+ Lisp_Object x, y, id, position;
+ struct frame *f = XFRAME (event->frame_or_window);
+
+ id = event->arg;
+ x = event->x;
+ y = event->y;
+
+ position = make_lispy_position (f, x, y, event->timestamp);
+
+ return list2 (((event->kind
+ == TOUCHSCREEN_BEGIN_EVENT)
+ ? Qtouchscreen_begin
+ : Qtouchscreen_end),
+ Fcons (id, position));
+ }
+
+ case TOUCHSCREEN_UPDATE_EVENT:
+ {
+ Lisp_Object x, y, id, position, tem, it, evt;
+ struct frame *f = XFRAME (event->frame_or_window);
+ evt = Qnil;
+
+ for (tem = event->arg; CONSP (tem); tem = XCDR (tem))
+ {
+ it = XCAR (tem);
+
+ x = XCAR (it);
+ y = XCAR (XCDR (it));
+ id = XCAR (XCDR (XCDR (it)));
+
+ position = make_lispy_position (f, x, y, event->timestamp);
+ evt = Fcons (Fcons (id, position), evt);
+ }
+
+ return list2 (Qtouchscreen_update, evt);
+ }
#ifdef USE_TOOLKIT_SCROLL_BARS
@@ -6145,23 +6186,20 @@ make_lispy_event (struct input_event *event)
#ifdef HAVE_DBUS
case DBUS_EVENT:
- {
- return Fcons (Qdbus_event, event->arg);
- }
+ return Fcons (Qdbus_event, event->arg);
#endif /* HAVE_DBUS */
#ifdef THREADS_ENABLED
case THREAD_EVENT:
- {
- return Fcons (Qthread_event, event->arg);
- }
+ return Fcons (Qthread_event, event->arg);
#endif /* THREADS_ENABLED */
#ifdef HAVE_XWIDGETS
case XWIDGET_EVENT:
- {
- return Fcons (Qxwidget_event, event->arg);
- }
+ return Fcons (Qxwidget_event, event->arg);
+
+ case XWIDGET_DISPLAY_EVENT:
+ return Fcons (Qxwidget_display_event, event->arg);
#endif
#ifdef USE_FILE_NOTIFY
@@ -6178,6 +6216,11 @@ make_lispy_event (struct input_event *event)
return list3 (Qconfig_changed_event,
event->arg, event->frame_or_window);
+#ifdef HAVE_PGTK
+ case PGTK_PREEDIT_TEXT_EVENT:
+ return list2 (intern ("pgtk-preedit-text"), event->arg);
+#endif
+
/* The 'kind' field of the event is something we don't recognize. */
default:
emacs_abort ();
@@ -7205,7 +7248,7 @@ tty_read_avail_input (struct terminal *terminal,
static void
handle_async_input (void)
{
-#ifdef USABLE_SIGIO
+#ifndef DOS_NT
while (1)
{
int nread = gobble_input ();
@@ -7268,7 +7311,7 @@ totally_unblock_input (void)
unblock_input_to (0);
}
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
void
handle_input_available_signal (int sig)
@@ -7284,7 +7327,7 @@ deliver_input_available_signal (int sig)
{
deliver_process_signal (sig, handle_input_available_signal);
}
-#endif /* USABLE_SIGIO */
+#endif /* defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) */
/* User signal events. */
@@ -7354,7 +7397,7 @@ handle_user_signal (int sig)
}
p->npending++;
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
if (interrupt_input)
handle_input_available_signal (sig);
else
@@ -7857,7 +7900,9 @@ parse_menu_item (Lisp_Object item, int inmenubar)
else if (EQ (tem, QCkeys))
{
tem = XCAR (item);
- if (CONSP (tem) || STRINGP (tem))
+ if (FUNCTIONP (tem))
+ ASET (item_properties, ITEM_PROPERTY_KEYEQ, call0 (tem));
+ else if (CONSP (tem) || STRINGP (tem))
ASET (item_properties, ITEM_PROPERTY_KEYEQ, tem);
}
else if (EQ (tem, QCbutton) && CONSP (XCAR (item)))
@@ -10185,7 +10230,8 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
use the corresponding lower-case letter instead. */
if (NILP (current_binding)
&& /* indec.start >= t && fkey.start >= t && */ keytran.start >= t
- && FIXNUMP (key))
+ && FIXNUMP (key)
+ && translate_upper_case_key_bindings)
{
Lisp_Object new_key;
EMACS_INT k = XFIXNUM (key);
@@ -10237,12 +10283,14 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
int modifiers
= CONSP (breakdown) ? (XFIXNUM (XCAR (XCDR (breakdown)))) : 0;
- if (modifiers & shift_modifier
- /* Treat uppercase keys as shifted. */
- || (FIXNUMP (key)
- && (KEY_TO_CHAR (key)
- < XCHAR_TABLE (BVAR (current_buffer, downcase_table))->header.size)
- && uppercasep (KEY_TO_CHAR (key))))
+ if (translate_upper_case_key_bindings
+ && (modifiers & shift_modifier
+ /* Treat uppercase keys as shifted. */
+ || (FIXNUMP (key)
+ && (KEY_TO_CHAR (key)
+ < XCHAR_TABLE (BVAR (current_buffer,
+ downcase_table))->header.size)
+ && uppercasep (KEY_TO_CHAR (key)))))
{
Lisp_Object new_key
= (modifiers & shift_modifier
@@ -11119,7 +11167,7 @@ See also `current-input-mode'. */)
(Lisp_Object interrupt)
{
bool new_interrupt_input;
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
#ifdef HAVE_X_WINDOWS
if (x_display_list != NULL)
{
@@ -11130,9 +11178,9 @@ See also `current-input-mode'. */)
else
#endif /* HAVE_X_WINDOWS */
new_interrupt_input = !NILP (interrupt);
-#else /* not USABLE_SIGIO */
+#else /* not USABLE_SIGIO || USABLE_SIGPOLL */
new_interrupt_input = false;
-#endif /* not USABLE_SIGIO */
+#endif /* not USABLE_SIGIO || USABLE_SIGPOLL */
if (new_interrupt_input != interrupt_input)
{
@@ -11561,12 +11609,16 @@ init_keyboard (void)
sigaction (SIGQUIT, &action, 0);
#endif /* not DOS_NT */
}
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
if (!noninteractive)
{
struct sigaction action;
emacs_sigaction_init (&action, deliver_input_available_signal);
+#ifdef USABLE_SIGIO
sigaction (SIGIO, &action, 0);
+#else
+ sigaction (SIGPOLL, &action, 0);
+#endif
}
#endif
@@ -11618,6 +11670,52 @@ static const struct event_head head_table[] = {
{SYMBOL_INDEX (Qselect_window), SYMBOL_INDEX (Qswitch_frame)}
};
+static Lisp_Object
+init_while_no_input_ignore_events (void)
+{
+ Lisp_Object events = listn (9, Qselect_window, Qhelp_echo, Qmove_frame,
+ Qiconify_frame, Qmake_frame_visible,
+ Qfocus_in, Qfocus_out, Qconfig_changed_event,
+ Qselection_request);
+
+#ifdef HAVE_DBUS
+ events = Fcons (Qdbus_event, events);
+#endif
+#ifdef USE_FILE_NOTIFY
+ events = Fcons (Qfile_notify, events);
+#endif
+#ifdef THREADS_ENABLED
+ events = Fcons (Qthread_event, events);
+#endif
+
+ return events;
+}
+
+static bool
+is_ignored_event (union buffered_input_event *event)
+{
+ Lisp_Object ignore_event;
+
+ switch (event->kind)
+ {
+ case FOCUS_IN_EVENT: ignore_event = Qfocus_in; break;
+ case FOCUS_OUT_EVENT: ignore_event = Qfocus_out; break;
+ case HELP_EVENT: ignore_event = Qhelp_echo; break;
+ case ICONIFY_EVENT: ignore_event = Qiconify_frame; break;
+ case DEICONIFY_EVENT: ignore_event = Qmake_frame_visible; break;
+ case SELECTION_REQUEST_EVENT: ignore_event = Qselection_request; break;
+#ifdef USE_FILE_NOTIFY
+ case FILE_NOTIFY_EVENT: ignore_event = Qfile_notify; break;
+#endif
+#ifdef HAVE_DBUS
+ case DBUS_EVENT: ignore_event = Qdbus_event; break;
+#endif
+ default: ignore_event = Qnil; break;
+ }
+
+ return !NILP (Fmemq (ignore_event, Vwhile_no_input_ignore_events));
+}
+
static void syms_of_keyboard_for_pdumper (void);
void
@@ -11704,12 +11802,15 @@ syms_of_keyboard (void)
#ifdef HAVE_XWIDGETS
DEFSYM (Qxwidget_event, "xwidget-event");
+ DEFSYM (Qxwidget_display_event, "xwidget-display-event");
#endif
#ifdef USE_FILE_NOTIFY
DEFSYM (Qfile_notify, "file-notify");
#endif /* USE_FILE_NOTIFY */
+ DEFSYM (Qtouch_end, "touch-end");
+
/* Menu and tool bar item parts. */
DEFSYM (QCenable, ":enable");
DEFSYM (QCvisible, ":visible");
@@ -12205,6 +12306,9 @@ See also `pre-command-hook'. */);
doc: /* Normal hook run when clearing the echo area. */);
#endif
DEFSYM (Qecho_area_clear_hook, "echo-area-clear-hook");
+ DEFSYM (Qtouchscreen_begin, "touchscreen-begin");
+ DEFSYM (Qtouchscreen_end, "touchscreen-end");
+ DEFSYM (Qtouchscreen_update, "touchscreen-update");
Fset (Qecho_area_clear_hook, Qnil);
DEFVAR_LISP ("lucid-menu-bar-dirty-flag", Vlucid_menu_bar_dirty_flag,
@@ -12512,7 +12616,35 @@ If nil, Emacs crashes immediately in response to fatal signals. */);
DEFVAR_LISP ("while-no-input-ignore-events",
Vwhile_no_input_ignore_events,
- doc: /* Ignored events from while-no-input. */);
+ doc: /* Ignored events from `while-no-input'.
+Events in this list do not count as pending input while running
+`while-no-input' and do not cause any idle timers to get reset when they
+occur. */);
+ Vwhile_no_input_ignore_events = init_while_no_input_ignore_events ();
+
+ DEFVAR_BOOL ("translate-upper-case-key-bindings",
+ translate_upper_case_key_bindings,
+ doc: /* If non-nil, interpret upper case keys as lower case (when applicable).
+Emacs allows binding both upper and lower case key sequences to
+commands. However, if there is a lower case key sequence bound to a
+command, and the user enters an upper case key sequence that is not
+bound to a command, Emacs will use the lower case binding. Setting
+this variable to nil inhibits this behaviour. */);
+ translate_upper_case_key_bindings = true;
+
+ DEFVAR_BOOL ("input-pending-p-filter-events",
+ input_pending_p_filter_events,
+ doc: /* If non-nil, `input-pending-p' ignores some input events.
+If this variable is non-nil (the default), `input-pending-p' and
+other similar functions ignore input events in `while-no-input-ignore-events'.
+This flag may eventually be removed once this behavior is deemed safe. */);
+ input_pending_p_filter_events = true;
+
+ DEFVAR_BOOL ("mwheel-coalesce-scroll-events", mwheel_coalesce_scroll_events,
+ doc: /* Non-nil means send a wheel event only for scrolling at least one screen line.
+Otherwise, a wheel event will be sent every time the mouse wheel is
+moved. */);
+ mwheel_coalesce_scroll_events = true;
pdumper_do_now_and_after_load (syms_of_keyboard_for_pdumper);
}
@@ -12562,6 +12694,8 @@ keys_of_keyboard (void)
"ns-put-working-text");
initial_define_lispy_key (Vspecial_event_map, "ns-unput-working-text",
"ns-unput-working-text");
+ initial_define_lispy_key (Vspecial_event_map, "pgtk-preedit-text",
+ "pgtk-preedit-text");
/* Here we used to use `ignore-event' which would simple set prefix-arg to
current-prefix-arg, as is done in `handle-switch-frame'.
But `handle-switch-frame is not run from the special-map.
diff --git a/src/keyboard.h b/src/keyboard.h
index 8bdffaa2bff..21c51ec3862 100644
--- a/src/keyboard.h
+++ b/src/keyboard.h
@@ -491,7 +491,7 @@ extern void process_pending_signals (void);
extern struct timespec timer_check (void);
extern void mark_kboards (void);
-#ifdef HAVE_NTGUI
+#if defined HAVE_NTGUI || defined HAVE_X_WINDOWS
extern const char *const lispy_function_keys[];
#endif
diff --git a/src/keymap.c b/src/keymap.c
index 28ff71c01da..0b882958b94 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -65,12 +65,16 @@ static Lisp_Object exclude_keys;
/* Pre-allocated 2-element vector for Fcommand_remapping to use. */
static Lisp_Object command_remapping_vector;
+/* Char table for the backwards-compatibility part in Flookup_key. */
+static Lisp_Object unicode_case_table;
+
/* Hash table used to cache a reverse-map to speed up calls to where-is. */
static Lisp_Object where_is_cache;
/* Which keymaps are reverse-stored in the cache. */
static Lisp_Object where_is_cache_keymaps;
-static Lisp_Object store_in_keymap (Lisp_Object, Lisp_Object, Lisp_Object);
+static Lisp_Object store_in_keymap (Lisp_Object, Lisp_Object, Lisp_Object,
+ bool);
static Lisp_Object define_as_prefix (Lisp_Object, Lisp_Object);
static void describe_vector (Lisp_Object, Lisp_Object, Lisp_Object,
@@ -127,7 +131,8 @@ in case you use it as a menu with `x-popup-menu'. */)
void
initial_define_lispy_key (Lisp_Object keymap, const char *keyname, const char *defname)
{
- store_in_keymap (keymap, intern_c_string (keyname), intern_c_string (defname));
+ store_in_keymap (keymap, intern_c_string (keyname),
+ intern_c_string (defname), false);
}
DEFUN ("keymapp", Fkeymapp, Skeymapp, 1, 1, 0,
@@ -726,7 +731,8 @@ get_keyelt (Lisp_Object object, bool autoload)
}
static Lisp_Object
-store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def)
+store_in_keymap (Lisp_Object keymap, register Lisp_Object idx,
+ Lisp_Object def, bool remove)
{
/* Flush any reverse-map cache. */
where_is_cache = Qnil;
@@ -802,21 +808,26 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def)
}
else if (CHAR_TABLE_P (elt))
{
+ Lisp_Object sdef = def;
+ if (remove)
+ sdef = Qnil;
+ /* nil has a special meaning for char-tables, so
+ we use something else to record an explicitly
+ unbound entry. */
+ else if (NILP (sdef))
+ sdef = Qt;
+
/* Character codes with modifiers
are not included in a char-table.
All character codes without modifiers are included. */
if (FIXNATP (idx) && !(XFIXNAT (idx) & CHAR_MODIFIER_MASK))
{
- Faset (elt, idx,
- /* nil has a special meaning for char-tables, so
- we use something else to record an explicitly
- unbound entry. */
- NILP (def) ? Qt : def);
+ Faset (elt, idx, sdef);
return def;
}
else if (CONSP (idx) && CHARACTERP (XCAR (idx)))
{
- Fset_char_table_range (elt, idx, NILP (def) ? Qt : def);
+ Fset_char_table_range (elt, idx, sdef);
return def;
}
insertion_point = tail;
@@ -835,7 +846,12 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def)
else if (EQ (idx, XCAR (elt)))
{
CHECK_IMPURE (elt, XCONS (elt));
- XSETCDR (elt, def);
+ if (remove)
+ /* Remove the element. */
+ insertion_point = Fdelq (elt, insertion_point);
+ else
+ /* Just set the definition. */
+ XSETCDR (elt, def);
return def;
}
else if (CONSP (idx)
@@ -848,7 +864,10 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def)
if (from <= XFIXNAT (XCAR (elt))
&& to >= XFIXNAT (XCAR (elt)))
{
- XSETCDR (elt, def);
+ if (remove)
+ insertion_point = Fdelq (elt, insertion_point);
+ else
+ XSETCDR (elt, def);
if (from == to)
return def;
}
@@ -1027,10 +1046,35 @@ is not copied. */)
/* Simple Keymap mutators and accessors. */
+static Lisp_Object
+possibly_translate_key_sequence (Lisp_Object key, ptrdiff_t *length)
+{
+ if (VECTORP (key) && ASIZE (key) == 1 && STRINGP (AREF (key, 0)))
+ {
+ /* KEY is on the ["C-c"] format, so translate to internal
+ format. */
+ if (NILP (Ffboundp (Qkey_valid_p)))
+ xsignal2 (Qerror,
+ build_string ("`key-valid-p' is not defined, so this syntax can't be used: %s"),
+ key);
+ if (NILP (call1 (Qkey_valid_p, AREF (key, 0))))
+ xsignal2 (Qerror, build_string ("Invalid `key-parse' syntax: %S"), key);
+ key = call1 (Qkey_parse, AREF (key, 0));
+ *length = CHECK_VECTOR_OR_STRING (key);
+ if (*length == 0)
+ xsignal2 (Qerror, build_string ("Invalid `key-parse' syntax: %S"), key);
+ }
+
+ return key;
+}
+
/* GC is possible in this function if it autoloads a keymap. */
-DEFUN ("define-key", Fdefine_key, Sdefine_key, 3, 3, 0,
+DEFUN ("define-key", Fdefine_key, Sdefine_key, 3, 4, 0,
doc: /* In KEYMAP, define key sequence KEY as DEF.
+This is a legacy function; see `keymap-set' for the recommended
+function to use instead.
+
KEYMAP is a keymap.
KEY is a string or a vector of symbols and characters, representing a
@@ -1050,15 +1094,23 @@ DEF is anything that can be a key's definition:
function definition, which should at that time be one of the above,
or another symbol whose function definition is used, etc.),
a cons (STRING . DEFN), meaning that DEFN is the definition
- (DEFN should be a valid definition in its own right),
+ (DEFN should be a valid definition in its own right) and
+ STRING is the menu item name (which is used only if the containing
+ keymap has been created with a menu name, see `make-keymap'),
or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP,
or an extended menu item definition.
(See info node `(elisp)Extended Menu Items'.)
+If REMOVE is non-nil, the definition will be removed. This is almost
+the same as setting the definition to nil, but makes a difference if
+the KEYMAP has a parent, and KEY is shadowing the same binding in the
+parent. With REMOVE, subsequent lookups will return the binding in
+the parent, and with a nil DEF, the lookups will return nil.
+
If KEYMAP is a sparse keymap with a binding for KEY, the existing
binding is altered. If there is no binding for KEY, the new pair
binding KEY to DEF is added at the front of KEYMAP. */)
- (Lisp_Object keymap, Lisp_Object key, Lisp_Object def)
+ (Lisp_Object keymap, Lisp_Object key, Lisp_Object def, Lisp_Object remove)
{
bool metized = false;
@@ -1085,6 +1137,8 @@ binding KEY to DEF is added at the front of KEYMAP. */)
def = tmp;
}
+ key = possibly_translate_key_sequence (key, &length);
+
ptrdiff_t idx = 0;
while (1)
{
@@ -1126,7 +1180,7 @@ binding KEY to DEF is added at the front of KEYMAP. */)
message_with_string ("Key sequence contains invalid event %s", c, 1);
if (idx == length)
- return store_in_keymap (keymap, c, def);
+ return store_in_keymap (keymap, c, def, !NILP (remove));
Lisp_Object cmd = access_keymap (keymap, c, 0, 1, 1);
@@ -1195,6 +1249,8 @@ lookup_key_1 (Lisp_Object keymap, Lisp_Object key, Lisp_Object accept_default)
if (length == 0)
return keymap;
+ key = possibly_translate_key_sequence (key, &length);
+
ptrdiff_t idx = 0;
while (1)
{
@@ -1229,6 +1285,9 @@ lookup_key_1 (Lisp_Object keymap, Lisp_Object key, Lisp_Object accept_default)
DEFUN ("lookup-key", Flookup_key, Slookup_key, 2, 3, 0,
doc: /* Look up key sequence KEY in KEYMAP. Return the definition.
+This is a legacy function; see `keymap-lookup' for the recommended
+function to use instead.
+
A value of nil means undefined. See doc of `define-key'
for kinds of definitions.
@@ -1251,39 +1310,126 @@ recognize the default bindings, just as `read-key-sequence' does. */)
return found;
/* Menu definitions might use mixed case symbols (notably in old
- versions of `easy-menu-define'). We accept this variation for
- backwards-compatibility. (Bug#50752) */
- ptrdiff_t key_len = VECTORP (key) ? ASIZE (key) : 0;
- if (key_len > 0 && EQ (AREF (key, 0), Qmenu_bar))
+ versions of `easy-menu-define'), or use " " instead of "-".
+ The rest of this function is about accepting these variations for
+ backwards-compatibility. (Bug#50752) */
+
+ /* Just skip everything below unless this is a menu item. */
+ if (!VECTORP (key) || !(ASIZE (key) > 0)
+ || !EQ (AREF (key, 0), Qmenu_bar))
+ return found;
+
+ /* Initialize the unicode case table, if it wasn't already. */
+ if (NILP (unicode_case_table))
+ {
+ unicode_case_table = uniprop_table (intern ("lowercase"));
+ /* uni-lowercase.el might be unavailable during bootstrap. */
+ if (NILP (unicode_case_table))
+ return found;
+ staticpro (&unicode_case_table);
+ }
+
+ ptrdiff_t key_len = ASIZE (key);
+ Lisp_Object new_key = make_vector (key_len, Qnil);
+
+ /* Try both the Unicode case table, and the buffer local one.
+ Otherwise, we will fail for e.g. the "Turkish" language
+ environment where 'I' does not downcase to 'i'. */
+ Lisp_Object tables[2] = {unicode_case_table, Fcurrent_case_table ()};
+ for (int tbl_num = 0; tbl_num < 2; tbl_num++)
{
- Lisp_Object new_key = make_vector (key_len, Qnil);
- for (int i = 0; i < key_len; ++i)
+ /* First, let's try converting all symbols like "Foo-Bar-Baz" to
+ "foo-bar-baz". */
+ for (int i = 0; i < key_len; i++)
{
Lisp_Object item = AREF (key, i);
if (!SYMBOLP (item))
ASET (new_key, i, item);
else
{
- Lisp_Object sym = Fsymbol_name (item);
- USE_SAFE_ALLOCA;
- unsigned char *dst = SAFE_ALLOCA (SBYTES (sym) + 1);
- memcpy (dst, SSDATA (sym), SBYTES (sym));
- /* We can walk the string data byte by byte, because
- UTF-8 encoding ensures that no other byte of any
- multibyte sequence will ever include a 7-bit byte
- equal to an ASCII single-byte character. */
- for (int j = 0; j < SBYTES (sym); ++j)
- if (dst[j] >= 'A' && dst[j] <= 'Z')
- dst[j] += 'a' - 'A'; /* Convert to lower case. */
- ASET (new_key, i, Fintern (make_multibyte_string ((char *) dst,
- SCHARS (sym),
- SBYTES (sym)),
- Qnil));
- SAFE_FREE ();
+ Lisp_Object key_item = Fsymbol_name (item);
+ Lisp_Object new_item;
+ if (!STRING_MULTIBYTE (key_item))
+ new_item = Fdowncase (key_item);
+ else
+ {
+ USE_SAFE_ALLOCA;
+ ptrdiff_t size = SCHARS (key_item), n;
+ if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &n))
+ n = PTRDIFF_MAX;
+ unsigned char *dst = SAFE_ALLOCA (n);
+ unsigned char *p = dst;
+ ptrdiff_t j_char = 0, j_byte = 0;
+
+ while (j_char < size)
+ {
+ int ch = fetch_string_char_advance (key_item,
+ &j_char, &j_byte);
+ Lisp_Object ch_conv = CHAR_TABLE_REF (tables[tbl_num],
+ ch);
+ if (!NILP (ch_conv))
+ CHAR_STRING (XFIXNUM (ch_conv), p);
+ else
+ CHAR_STRING (ch, p);
+ p = dst + j_byte;
+ }
+ new_item = make_multibyte_string ((char *) dst,
+ SCHARS (key_item),
+ SBYTES (key_item));
+ SAFE_FREE ();
+ }
+ ASET (new_key, i, Fintern (new_item, Qnil));
+ }
+ }
+
+ /* Check for match. */
+ found = lookup_key_1 (keymap, new_key, accept_default);
+ if (!NILP (found) && !NUMBERP (found))
+ break;
+
+ /* If we still don't have a match, let's convert any spaces in
+ our lowercased string into dashes, e.g. "foo bar baz" to
+ "foo-bar-baz". */
+ for (int i = 0; i < key_len; i++)
+ {
+ if (!SYMBOLP (AREF (new_key, i)))
+ continue;
+
+ Lisp_Object lc_key = Fsymbol_name (AREF (new_key, i));
+
+ /* If there are no spaces in this symbol, just skip it. */
+ if (!strstr (SSDATA (lc_key), " "))
+ continue;
+
+ USE_SAFE_ALLOCA;
+ ptrdiff_t size = SCHARS (lc_key), n;
+ if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &n))
+ n = PTRDIFF_MAX;
+ unsigned char *dst = SAFE_ALLOCA (n);
+
+ /* We can walk the string data byte by byte, because UTF-8
+ encoding ensures that no other byte of any multibyte
+ sequence will ever include a 7-bit byte equal to an ASCII
+ single-byte character. */
+ memcpy (dst, SSDATA (lc_key), SBYTES (lc_key));
+ for (int i = 0; i < SBYTES (lc_key); ++i)
+ {
+ if (dst[i] == ' ')
+ dst[i] = '-';
}
+ Lisp_Object new_it =
+ make_multibyte_string ((char *) dst,
+ SCHARS (lc_key), SBYTES (lc_key));
+ ASET (new_key, i, Fintern (new_it, Qnil));
+ SAFE_FREE ();
}
+
+ /* Check for match. */
found = lookup_key_1 (keymap, new_key, accept_default);
+ if (!NILP (found) && !NUMBERP (found))
+ break;
}
+
return found;
}
@@ -1295,7 +1441,7 @@ static Lisp_Object
define_as_prefix (Lisp_Object keymap, Lisp_Object c)
{
Lisp_Object cmd = Fmake_sparse_keymap (Qnil);
- store_in_keymap (keymap, c, cmd);
+ store_in_keymap (keymap, c, cmd, false);
return cmd;
}
@@ -2815,7 +2961,10 @@ You type Translation\n\
{
if (EQ (start1, BVAR (XBUFFER (buffer), keymap)))
{
- Lisp_Object msg = build_unibyte_string ("\f\nMajor Mode Bindings");
+ Lisp_Object msg =
+ CALLN (Fformat,
+ build_unibyte_string ("\f\n`%s' Major Mode Bindings"),
+ XBUFFER (buffer)->major_mode_);
CALLN (Ffuncall,
Qdescribe_map_tree,
start1, Qt, shadow, prefix,
@@ -3308,4 +3457,7 @@ that describe key bindings. That is why the default is nil. */);
defsubr (&Stext_char_description);
defsubr (&Swhere_is_internal);
defsubr (&Sdescribe_buffer_bindings);
+
+ DEFSYM (Qkey_parse, "key-parse");
+ DEFSYM (Qkey_valid_p, "key-valid-p");
}
diff --git a/src/lisp.h b/src/lisp.h
index af8a8451933..92ab05b4228 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -138,7 +138,12 @@ verify (BITS_WORD_MAX >> (BITS_PER_BITS_WORD - 1) == 1);
buffers and strings. Emacs never allocates objects larger than
PTRDIFF_MAX bytes, as they cause problems with pointer subtraction.
In C99, pD can always be "t"; configure it here for the sake of
- pre-C99 libraries such as glibc 2.0 and Solaris 8. */
+ pre-C99 libraries such as glibc 2.0 and Solaris 8.
+
+ On Haiku, the size of ptrdiff_t is inconsistent with the value of
+ PTRDIFF_MAX. In that case, "t" should be sufficient. */
+
+#ifndef HAIKU
#if PTRDIFF_MAX == INT_MAX
# define pD ""
#elif PTRDIFF_MAX == LONG_MAX
@@ -148,6 +153,9 @@ verify (BITS_WORD_MAX >> (BITS_PER_BITS_WORD - 1) == 1);
#else
# define pD "t"
#endif
+#else
+# define pD "t"
+#endif
/* Convenience macro for rarely-used functions that do not return. */
#define AVOID _Noreturn ATTRIBUTE_COLD void
@@ -251,6 +259,11 @@ DEFINE_GDB_SYMBOL_BEGIN (EMACS_INT, VALMASK)
# define VALMASK (USE_LSB_TAG ? - (1 << GCTYPEBITS) : VAL_MAX)
DEFINE_GDB_SYMBOL_END (VALMASK)
+/* Ignore 'alignas' on compilers lacking it. */
+#if !defined alignas && !defined __alignas_is_defined
+# define alignas(a)
+#endif
+
/* Minimum alignment requirement for Lisp objects, imposed by the
internal representation of tagged pointers. It is 2**GCTYPEBITS if
USE_LSB_TAG, 1 otherwise. It must be a literal integer constant,
@@ -1070,6 +1083,7 @@ enum pvec_type
PVEC_CONDVAR,
PVEC_MODULE_FUNCTION,
PVEC_NATIVE_COMP_UNIT,
+ PVEC_SQLITE,
/* These should be last, for internal_equal and sxhash_obj. */
PVEC_COMPILED,
@@ -2557,6 +2571,17 @@ xmint_pointer (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Misc_Ptr)->pointer;
}
+struct Lisp_Sqlite
+{
+ union vectorlike_header header;
+ void *db;
+ void *stmt;
+ char *name;
+ void (*finalizer) (void *);
+ bool eof;
+ bool is_statement;
+} GCALIGNED_STRUCT;
+
struct Lisp_User_Ptr
{
union vectorlike_header header;
@@ -2635,6 +2660,31 @@ XUSER_PTR (Lisp_Object a)
}
INLINE bool
+SQLITEP (Lisp_Object x)
+{
+ return PSEUDOVECTORP (x, PVEC_SQLITE);
+}
+
+INLINE bool
+SQLITE (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_SQLITE);
+}
+
+INLINE void
+CHECK_SQLITE (Lisp_Object x)
+{
+ CHECK_TYPE (SQLITE (x), Qsqlitep, x);
+}
+
+INLINE struct Lisp_Sqlite *
+XSQLITE (Lisp_Object a)
+{
+ eassert (SQLITEP (a));
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Sqlite);
+}
+
+INLINE bool
BIGNUMP (Lisp_Object x)
{
return PSEUDOVECTORP (x, PVEC_BIGNUM);
@@ -3332,7 +3382,7 @@ struct frame;
/* Define if the windowing system provides a menu bar. */
#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
- || defined (HAVE_NS) || defined (USE_GTK)
+ || defined (HAVE_NS) || defined (USE_GTK) || defined (HAVE_HAIKU)
#define HAVE_EXT_MENU_BAR true
#endif
@@ -3780,6 +3830,9 @@ extern Lisp_Object safe_eval (Lisp_Object);
extern bool pos_visible_p (struct window *, ptrdiff_t, int *,
int *, int *, int *, int *, int *);
+/* Defined in sqlite.c. */
+extern void syms_of_sqlite (void);
+
/* Defined in xsettings.c. */
extern void syms_of_xsettings (void);
@@ -3949,7 +4002,8 @@ build_string (const char *str)
extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object);
extern Lisp_Object make_vector (ptrdiff_t, Lisp_Object);
-extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t);
+extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t)
+ ATTRIBUTE_RETURNS_NONNULL;
/* Make an uninitialized vector for SIZE objects. NOTE: you must
be sure that GC cannot happen until the vector is completely
@@ -3962,7 +4016,8 @@ extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t);
allocate_vector has a similar problem. */
-extern struct Lisp_Vector *allocate_vector (ptrdiff_t);
+extern struct Lisp_Vector *allocate_vector (ptrdiff_t)
+ ATTRIBUTE_RETURNS_NONNULL;
INLINE Lisp_Object
make_uninit_vector (ptrdiff_t size)
@@ -3994,7 +4049,8 @@ make_nil_vector (ptrdiff_t size)
}
extern struct Lisp_Vector *allocate_pseudovector (int, int, int,
- enum pvec_type);
+ enum pvec_type)
+ ATTRIBUTE_RETURNS_NONNULL;
/* Allocate uninitialized pseudovector with no Lisp_Object slots. */
@@ -4026,7 +4082,7 @@ extern void free_cons (struct Lisp_Cons *);
extern void init_alloc_once (void);
extern void init_alloc (void);
extern void syms_of_alloc (void);
-extern struct buffer * allocate_buffer (void);
+extern struct buffer *allocate_buffer (void) ATTRIBUTE_RETURNS_NONNULL;
extern int valid_lisp_object_p (Lisp_Object);
/* Defined in gmalloc.c. */
@@ -4184,7 +4240,8 @@ extern Lisp_Object internal_condition_case_n
(Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *,
Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *));
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);
+extern struct handler *push_handler (Lisp_Object, enum handlertype)
+ ATTRIBUTE_RETURNS_NONNULL;
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);
@@ -4325,9 +4382,10 @@ extern void syms_of_marker (void);
/* Defined in fileio.c. */
-extern char *splice_dir_file (char *, char const *, char const *);
+extern char *splice_dir_file (char *, char const *, char const *)
+ ATTRIBUTE_RETURNS_NONNULL;
extern bool file_name_absolute_p (const char *);
-extern char const *get_homedir (void);
+extern char const *get_homedir (void) ATTRIBUTE_RETURNS_NONNULL;
extern Lisp_Object expand_and_dir_to_file (Lisp_Object);
extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, Lisp_Object, Lisp_Object,
@@ -4426,7 +4484,7 @@ extern Lisp_Object menu_bar_items (Lisp_Object);
extern Lisp_Object tab_bar_items (Lisp_Object, int *);
extern Lisp_Object tool_bar_items (Lisp_Object, int *);
extern void discard_mouse_events (void);
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
void handle_input_available_signal (int);
#endif
extern Lisp_Object pending_funcalls;
@@ -4481,7 +4539,7 @@ INLINE void fixup_locale (void) {}
INLINE void synchronize_system_messages_locale (void) {}
INLINE void synchronize_system_time_locale (void) {}
#endif
-extern char *emacs_strerror (int);
+extern char *emacs_strerror (int) ATTRIBUTE_RETURNS_NONNULL;
extern void shut_down_emacs (int, Lisp_Object);
/* True means don't do interactive redisplay and don't change tty modes. */
@@ -4547,7 +4605,7 @@ extern void setup_process_coding_systems (Lisp_Object);
extern int emacs_spawn (pid_t *, int, int, int, char **, char **,
const char *, const char *, const sigset_t *);
-extern char **make_environment_block (Lisp_Object);
+extern char **make_environment_block (Lisp_Object) ATTRIBUTE_RETURNS_NONNULL;
extern void init_callproc_1 (void);
extern void init_callproc (void);
extern void set_initial_environment (void);
@@ -4816,17 +4874,24 @@ extern char my_edata[];
extern char my_endbss[];
extern char *my_endbss_static;
-extern void *xmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
-extern void *xzalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
-extern void *xrealloc (void *, size_t) ATTRIBUTE_ALLOC_SIZE ((2));
+extern void *xmalloc (size_t)
+ ATTRIBUTE_MALLOC_SIZE ((1)) ATTRIBUTE_RETURNS_NONNULL;
+extern void *xzalloc (size_t)
+ ATTRIBUTE_MALLOC_SIZE ((1)) ATTRIBUTE_RETURNS_NONNULL;
+extern void *xrealloc (void *, size_t)
+ ATTRIBUTE_ALLOC_SIZE ((2)) ATTRIBUTE_RETURNS_NONNULL;
extern void xfree (void *);
-extern void *xnmalloc (ptrdiff_t, ptrdiff_t) ATTRIBUTE_MALLOC_SIZE ((1,2));
+extern void *xnmalloc (ptrdiff_t, ptrdiff_t)
+ ATTRIBUTE_MALLOC_SIZE ((1,2)) ATTRIBUTE_RETURNS_NONNULL;
extern void *xnrealloc (void *, ptrdiff_t, ptrdiff_t)
- ATTRIBUTE_ALLOC_SIZE ((2,3));
-extern void *xpalloc (void *, ptrdiff_t *, ptrdiff_t, ptrdiff_t, ptrdiff_t);
-
-extern char *xstrdup (const char *) ATTRIBUTE_MALLOC;
-extern char *xlispstrdup (Lisp_Object) ATTRIBUTE_MALLOC;
+ ATTRIBUTE_ALLOC_SIZE ((2,3)) ATTRIBUTE_RETURNS_NONNULL;
+extern void *xpalloc (void *, ptrdiff_t *, ptrdiff_t, ptrdiff_t, ptrdiff_t)
+ ATTRIBUTE_RETURNS_NONNULL;
+
+extern char *xstrdup (char const *)
+ ATTRIBUTE_MALLOC ATTRIBUTE_RETURNS_NONNULL;
+extern char *xlispstrdup (Lisp_Object)
+ ATTRIBUTE_MALLOC ATTRIBUTE_RETURNS_NONNULL;
extern void dupstring (char **, char const *);
/* Make DEST a copy of STRING's data. Return a pointer to DEST's terminating
@@ -4876,7 +4941,8 @@ extern void init_system_name (void);
enum MAX_ALLOCA { MAX_ALLOCA = 16 * 1024 };
-extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1));
+extern void *record_xmalloc (size_t)
+ ATTRIBUTE_ALLOC_SIZE ((1)) ATTRIBUTE_RETURNS_NONNULL;
#define USE_SAFE_ALLOCA \
ptrdiff_t sa_avail = MAX_ALLOCA; \
diff --git a/src/lread.c b/src/lread.c
index 9bb5f66adf3..5a2f1bc54e5 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -1045,12 +1045,18 @@ 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 (int fd)
+safe_to_load_version (Lisp_Object file, int fd)
{
+ struct stat st;
char buf[512];
int nbytes, i;
int version = 1;
+ /* 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))
+ 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);
@@ -1068,7 +1074,9 @@ safe_to_load_version (int fd)
version = 0;
}
- lseek (fd, 0, SEEK_SET);
+ if (lseek (fd, 0, SEEK_SET) < 0)
+ report_file_error ("Seeking to start of file", file);
+
return version;
}
@@ -1407,7 +1415,7 @@ 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 (fd)) > 1))
+ || (fd >= 0 && (version = safe_to_load_version (file, fd)) > 1))
/* Load .elc files directly, but not when they are
remote and have no handler! */
{
@@ -1416,11 +1424,8 @@ Return t if the file exists and loads successfully. */)
struct stat s1, s2;
int result;
- if (version < 0
- && ! (version = safe_to_load_version (fd)))
- {
- error ("File `%s' was not compiled in Emacs", SDATA (found));
- }
+ if (version < 0 && !(version = safe_to_load_version (file, fd)))
+ error ("File `%s' was not compiled in Emacs", SDATA (found));
compiled = 1;
@@ -2710,7 +2715,7 @@ read_escape (Lisp_Object readcharfun, bool stringp)
c = read_escape (readcharfun, 0);
if ((c & ~CHAR_MODIFIER_MASK) == '?')
return 0177 | (c & CHAR_MODIFIER_MASK);
- else if (! SINGLE_BYTE_CHAR_P ((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. */
diff --git a/src/macfont.m b/src/macfont.m
index 78ed5d53f39..ce7a5ec8cda 100644
--- a/src/macfont.m
+++ b/src/macfont.m
@@ -613,6 +613,21 @@ get_cgcolor(unsigned long idx, struct frame *f)
return cgColor;
}
+static CGColorRef
+get_cgcolor_from_nscolor (NSColor *nsColor, struct frame *f)
+{
+ [nsColor set];
+ CGColorSpaceRef colorSpace = [[nsColor colorSpace] CGColorSpace];
+ NSInteger noc = [nsColor numberOfComponents];
+ CGFloat *components = xmalloc (sizeof(CGFloat)*(1+noc));
+ CGColorRef cgColor;
+
+ [nsColor getComponents: components];
+ cgColor = CGColorCreate (colorSpace, components);
+ xfree (components);
+ return cgColor;
+}
+
#define CG_SET_FILL_COLOR_WITH_FACE_FOREGROUND(context, face, f) \
do { \
CGColorRef refcol_ = get_cgcolor (NS_FACE_FOREGROUND (face), f); \
@@ -2911,14 +2926,14 @@ macfont_draw (struct glyph_string *s, int from, int to, int x, int y,
if (!CGRectIsNull (background_rect))
{
- if (s->hl == DRAW_MOUSE_FACE)
+ if (s->hl == DRAW_CURSOR)
{
- face = FACE_FROM_ID_OR_NULL (s->f,
- MOUSE_HL_INFO (s->f)->mouse_face_face_id);
- if (!face)
- face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
+ CGColorRef colorref = get_cgcolor_from_nscolor (FRAME_CURSOR_COLOR (f), f);
+ CGContextSetFillColorWithColor (context, colorref);
+ CGColorRelease (colorref);
}
- CG_SET_FILL_COLOR_WITH_FACE_BACKGROUND (context, face, f);
+ else
+ CG_SET_FILL_COLOR_WITH_FACE_BACKGROUND (context, face, f);
CGContextFillRects (context, &background_rect, 1);
}
@@ -2927,7 +2942,14 @@ macfont_draw (struct glyph_string *s, int from, int to, int x, int y,
CGAffineTransform atfm;
CGContextScaleCTM (context, 1, -1);
- CG_SET_FILL_COLOR_WITH_FACE_FOREGROUND (context, face, s->f);
+ if (s->hl == DRAW_CURSOR)
+ {
+ CGColorRef colorref = get_cgcolor_from_nscolor (FRAME_BACKGROUND_COLOR (f), f);
+ CGContextSetFillColorWithColor (context, colorref);
+ CGColorRelease (colorref);
+ }
+ else
+ CG_SET_FILL_COLOR_WITH_FACE_FOREGROUND (context, face, s->f);
if (macfont_info->synthetic_italic_p)
atfm = synthetic_italic_atfm;
else
diff --git a/src/menu.c b/src/menu.c
index 1aafa78c3ce..b9da85ef3d5 100644
--- a/src/menu.c
+++ b/src/menu.c
@@ -50,7 +50,8 @@ extern AppendMenuW_Proc unicode_append_menu;
static bool
have_boxes (void)
{
-#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NTGUI) || defined(HAVE_NS)
+#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NTGUI) || defined (HAVE_NS) \
+ || defined (HAVE_HAIKU)
if (FRAME_WINDOW_P (XFRAME (Vmenu_updating_frame)))
return 1;
#endif
@@ -422,7 +423,8 @@ 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)
+#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) \
+ || defined (HAVE_NTGUI) || defined (HAVE_HAIKU) || defined (HAVE_PGTK)
/* Display a submenu using the toolkit. */
if (FRAME_WINDOW_P (XFRAME (Vmenu_updating_frame))
&& ! (NILP (map) || NILP (enabled)))
@@ -872,6 +874,10 @@ update_submenu_strings (widget_value *first_wv)
}
}
+#endif /* USE_X_TOOLKIT || USE_GTK || HAVE_NS || HAVE_NTGUI */
+#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) \
+ || defined (HAVE_NTGUI) || defined (HAVE_HAIKU)
+
/* Find the menu selection and store it in the keyboard buffer.
F is the frame the menu is on.
MENU_BAR_ITEMS_USED is the length of VECTOR.
@@ -959,7 +965,7 @@ find_and_call_menu_selection (struct frame *f, int menu_bar_items_used,
SAFE_FREE ();
}
-#endif /* USE_X_TOOLKIT || USE_GTK || HAVE_NS || HAVE_NTGUI */
+#endif /* USE_X_TOOLKIT || USE_GTK || HAVE_NS || HAVE_NTGUI || HAVE_HAIKU */
#ifdef HAVE_NS
/* As above, but return the menu selection instead of storing in kb buffer.
@@ -1107,7 +1113,7 @@ into menu items. */)
Lisp_Object
x_popup_menu_1 (Lisp_Object position, Lisp_Object menu)
{
- Lisp_Object keymap, tem, tem2;
+ Lisp_Object keymap, tem, tem2 = Qnil;
int xpos = 0, ypos = 0;
Lisp_Object title;
const char *error_name = NULL;
@@ -1246,8 +1252,21 @@ x_popup_menu_1 (Lisp_Object position, Lisp_Object menu)
CHECK_LIVE_WINDOW (window);
f = XFRAME (WINDOW_FRAME (win));
- xpos = WINDOW_LEFT_EDGE_X (win);
- ypos = WINDOW_TOP_EDGE_Y (win);
+ if (FIXNUMP (tem2))
+ {
+ /* Clicks in the text area, where TEM2 is a buffer
+ position, are relative to the top-left edge of the text
+ area, see keyboard.c:make_lispy_position. */
+ xpos = window_box_left (win, TEXT_AREA);
+ ypos = (WINDOW_TOP_EDGE_Y (win)
+ + WINDOW_TAB_LINE_HEIGHT (win)
+ + WINDOW_HEADER_LINE_HEIGHT (win));
+ }
+ else
+ {
+ xpos = WINDOW_LEFT_EDGE_X (win);
+ ypos = WINDOW_TOP_EDGE_Y (win);
+ }
}
else
/* ??? Not really clean; should be CHECK_WINDOW_OR_FRAME,
diff --git a/src/menu.h b/src/menu.h
index 6c67ab20bb0..30b946c0ea4 100644
--- a/src/menu.h
+++ b/src/menu.h
@@ -59,6 +59,12 @@ extern Lisp_Object ns_menu_show (struct frame *, int, int, int,
Lisp_Object, const char **);
extern void ns_activate_menubar (struct frame *);
#endif
+#ifdef HAVE_PGTK
+extern Lisp_Object pgtk_menu_show (struct frame *, int, int, int,
+ Lisp_Object, const char **);
+extern void pgtk_activate_menubar (struct frame *);
+#endif
+
extern Lisp_Object tty_menu_show (struct frame *, int, int, int,
Lisp_Object, const char **);
extern ptrdiff_t menu_item_width (const unsigned char *);
diff --git a/src/minibuf.c b/src/minibuf.c
index 4b72d3e896b..6c0cd358c50 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -1005,7 +1005,7 @@ set_minibuffer_mode (Lisp_Object buf, EMACS_INT depth)
if (!NILP (Ffboundp (Qminibuffer_inactive_mode)))
call0 (Qminibuffer_inactive_mode);
else
- Fkill_all_local_variables ();
+ Fkill_all_local_variables (Qnil);
}
buf = unbind_to (count, buf);
}
@@ -1545,6 +1545,27 @@ minibuf_conform_representation (Lisp_Object string, Lisp_Object basis)
return Fstring_make_multibyte (string);
}
+static bool
+match_regexps (Lisp_Object string, Lisp_Object regexps,
+ bool ignore_case)
+{
+ ptrdiff_t val;
+ for (; CONSP (regexps); regexps = XCDR (regexps))
+ {
+ CHECK_STRING (XCAR (regexps));
+
+ val = fast_string_match_internal
+ (XCAR (regexps), string,
+ (ignore_case ? BVAR (current_buffer, case_canon_table) : Qnil));
+
+ if (val == -2)
+ error ("Stack overflow in regexp matcher");
+ if (val < 0)
+ return false;
+ }
+ return true;
+}
+
DEFUN ("try-completion", Ftry_completion, Stry_completion, 2, 3, 0,
doc: /* Return common substring of all completions of STRING in COLLECTION.
Test each possible completion specified by COLLECTION
@@ -1578,6 +1599,7 @@ Additionally to this predicate, `completion-regexp-list'
is used to further constrain the set of candidates. */)
(Lisp_Object string, Lisp_Object collection, Lisp_Object predicate)
{
+
Lisp_Object bestmatch, tail, elt, eltstring;
/* Size in bytes of BESTMATCH. */
ptrdiff_t bestmatchsize = 0;
@@ -1591,7 +1613,6 @@ is used to further constrain the set of candidates. */)
? list_table : function_table));
ptrdiff_t idx = 0, obsize = 0;
int matchcount = 0;
- ptrdiff_t bindcount = -1;
Lisp_Object bucket, zero, end, tem;
CHECK_STRING (string);
@@ -1670,27 +1691,10 @@ is used to further constrain the set of candidates. */)
completion_ignore_case ? Qt : Qnil),
EQ (Qt, tem)))
{
- /* Yes. */
- Lisp_Object regexps;
-
/* Ignore this element if it fails to match all the regexps. */
- {
- for (regexps = Vcompletion_regexp_list; CONSP (regexps);
- regexps = XCDR (regexps))
- {
- if (bindcount < 0)
- {
- bindcount = SPECPDL_INDEX ();
- specbind (Qcase_fold_search,
- completion_ignore_case ? Qt : Qnil);
- }
- tem = Fstring_match (XCAR (regexps), eltstring, zero);
- if (NILP (tem))
- break;
- }
- if (CONSP (regexps))
- continue;
- }
+ if (!match_regexps (eltstring, Vcompletion_regexp_list,
+ completion_ignore_case))
+ continue;
/* Ignore this element if there is a predicate
and the predicate doesn't like it. */
@@ -1701,11 +1705,6 @@ is used to further constrain the set of candidates. */)
tem = Fcommandp (elt, Qnil);
else
{
- if (bindcount >= 0)
- {
- unbind_to (bindcount, Qnil);
- bindcount = -1;
- }
tem = (type == hash_table
? call2 (predicate, elt,
HASH_VALUE (XHASH_TABLE (collection),
@@ -1787,9 +1786,6 @@ is used to further constrain the set of candidates. */)
}
}
- if (bindcount >= 0)
- unbind_to (bindcount, Qnil);
-
if (NILP (bestmatch))
return Qnil; /* No completions found. */
/* If we are ignoring case, and there is no exact match,
@@ -1849,7 +1845,6 @@ with a space are ignored unless STRING itself starts with a space. */)
: VECTORP (collection) ? 2
: NILP (collection) || (CONSP (collection) && !FUNCTIONP (collection));
ptrdiff_t idx = 0, obsize = 0;
- ptrdiff_t bindcount = -1;
Lisp_Object bucket, tem, zero;
CHECK_STRING (string);
@@ -1934,27 +1929,10 @@ with a space are ignored unless STRING itself starts with a space. */)
completion_ignore_case ? Qt : Qnil),
EQ (Qt, tem)))
{
- /* Yes. */
- Lisp_Object regexps;
-
/* Ignore this element if it fails to match all the regexps. */
- {
- for (regexps = Vcompletion_regexp_list; CONSP (regexps);
- regexps = XCDR (regexps))
- {
- if (bindcount < 0)
- {
- bindcount = SPECPDL_INDEX ();
- specbind (Qcase_fold_search,
- completion_ignore_case ? Qt : Qnil);
- }
- tem = Fstring_match (XCAR (regexps), eltstring, zero);
- if (NILP (tem))
- break;
- }
- if (CONSP (regexps))
- continue;
- }
+ if (!match_regexps (eltstring, Vcompletion_regexp_list,
+ completion_ignore_case))
+ continue;
/* Ignore this element if there is a predicate
and the predicate doesn't like it. */
@@ -1965,11 +1943,6 @@ with a space are ignored unless STRING itself starts with a space. */)
tem = Fcommandp (elt, Qnil);
else
{
- if (bindcount >= 0)
- {
- unbind_to (bindcount, Qnil);
- bindcount = -1;
- }
tem = type == 3
? call2 (predicate, elt,
HASH_VALUE (XHASH_TABLE (collection), idx - 1))
@@ -1982,9 +1955,6 @@ with a space are ignored unless STRING itself starts with a space. */)
}
}
- if (bindcount >= 0)
- unbind_to (bindcount, Qnil);
-
return Fnreverse (allmatches);
}
@@ -2068,7 +2038,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 regexps, tail, tem = Qnil;
+ Lisp_Object tail, tem = Qnil;
ptrdiff_t i = 0;
CHECK_STRING (string);
@@ -2154,20 +2124,9 @@ the values STRING, PREDICATE and `lambda'. */)
return call3 (collection, string, predicate, Qlambda);
/* Reject this element if it fails to match all the regexps. */
- if (CONSP (Vcompletion_regexp_list))
- {
- ptrdiff_t count = SPECPDL_INDEX ();
- specbind (Qcase_fold_search, completion_ignore_case ? Qt : Qnil);
- for (regexps = Vcompletion_regexp_list; CONSP (regexps);
- regexps = XCDR (regexps))
- {
- /* We can test against STRING, because if we got here, then
- the element is equivalent to it. */
- if (NILP (Fstring_match (XCAR (regexps), string, Qnil)))
- return unbind_to (count, Qnil);
- }
- unbind_to (count, Qnil);
- }
+ if (!match_regexps (string, Vcompletion_regexp_list,
+ completion_ignore_case))
+ return Qnil;
/* Finally, check the predicate. */
if (!NILP (predicate))
diff --git a/src/module-env-29.h b/src/module-env-29.h
new file mode 100644
index 00000000000..6ca03773181
--- /dev/null
+++ b/src/module-env-29.h
@@ -0,0 +1,3 @@
+ /* 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/msdos.c b/src/msdos.c
index a6deea710f4..2272aba6fde 100644
--- a/src/msdos.c
+++ b/src/msdos.c
@@ -1794,7 +1794,7 @@ internal_terminal_init (void)
}
Vinitial_window_system = Qpc;
- Vwindow_system_version = make_fixnum (28); /* RE Emacs version */
+ Vwindow_system_version = make_fixnum (29); /* RE Emacs version */
tty->terminal->type = output_msdos_raw;
/* If Emacs was dumped on DOS/V machine, forget the stale VRAM
diff --git a/src/nsfns.m b/src/nsfns.m
index 797d0ce7820..81019fce09d 100644
--- a/src/nsfns.m
+++ b/src/nsfns.m
@@ -1236,6 +1236,7 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
"fontBackend", "FontBackend", RES_TYPE_STRING);
{
+#ifdef NS_IMPL_COCOA
/* use for default font name */
id font = [NSFont userFixedPitchFontOfSize: -1.0]; /* default */
gui_default_parameter (f, parms, Qfontsize,
@@ -1250,6 +1251,11 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
build_string (fontname),
"font", "Font", RES_TYPE_STRING);
xfree (fontname);
+#else
+ gui_default_parameter (f, parms, Qfont,
+ build_string ("fixed"),
+ "font", "Font", RES_TYPE_STRING);
+#endif
}
unblock_input ();
@@ -1359,6 +1365,10 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
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),
@@ -2352,6 +2362,47 @@ ns_get_string_resource (void *_rdb, const char *name, const char *class)
========================================================================== */
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1080
+/* Moving files to the system recycle bin.
+ Used by `move-file-to-trash' instead of the default moving to ~/.Trash */
+DEFUN ("system-move-file-to-trash", Fsystem_move_file_to_trash,
+ Ssystem_move_file_to_trash, 1, 1, 0,
+ doc: /* Move file or directory named FILENAME to the recycle bin. */)
+ (Lisp_Object filename)
+{
+ Lisp_Object handler;
+ Lisp_Object operation;
+
+ operation = Qdelete_file;
+ if (!NILP (Ffile_directory_p (filename))
+ && NILP (Ffile_symlink_p (filename)))
+ {
+ operation = intern ("delete-directory");
+ filename = Fdirectory_file_name (filename);
+ }
+
+ /* Must have fully qualified file names for moving files to Trash. */
+ filename = Fexpand_file_name (filename, Qnil);
+
+ handler = Ffind_file_name_handler (filename, operation);
+ if (!NILP (handler))
+ return call2 (handler, operation, filename);
+ else
+ {
+ NSFileManager *fm = [NSFileManager defaultManager];
+ BOOL result = NO;
+ NSURL *fileURL = [NSURL fileURLWithPath:[NSString stringWithLispString:filename]
+ isDirectory:!NILP (Ffile_directory_p (filename))];
+ if ([fm respondsToSelector:@selector(trashItemAtURL:resultingItemURL:error:)])
+ result = [fm trashItemAtURL:fileURL resultingItemURL:nil error:nil];
+
+ if (!result)
+ report_file_error ("Removing old name", list1 (filename));
+ }
+ return Qnil;
+}
+#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)
@@ -3233,6 +3284,10 @@ Default is t. */);
defsubr (&Sx_show_tip);
defsubr (&Sx_hide_tip);
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1080
+ defsubr (&Ssystem_move_file_to_trash);
+#endif
+
as_status = 0;
as_script = Qnil;
staticpro (&as_script);
diff --git a/src/nsfont.m b/src/nsfont.m
index 5a9cdfebc01..b3224629f05 100644
--- a/src/nsfont.m
+++ b/src/nsfont.m
@@ -1,4 +1,4 @@
-/* Font back-end driver for the NeXT/Open/GNUstep and macOS window system.
+/* Font back-end driver for the GNUstep window system.
See font.h
Copyright (C) 2006-2021 Free Software Foundation, Inc.
@@ -38,47 +38,269 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu)
#include "termchar.h"
#include "pdumper.h"
-/* TODO: Drop once we can assume gnustep-gui 0.17.1. */
+#import <Foundation/NSException.h>
#import <AppKit/NSFontDescriptor.h>
+#import <AppKit/NSLayoutManager.h>
+#import <GNUstepGUI/GSLayoutManager.h>
+#import <GNUstepGUI/GSFontInfo.h>
#define NSFONT_TRACE 0
-#define LCD_SMOOTHING_MARGIN 2
-/* Font glyph and metrics caching functions, implemented at end. */
-static void ns_uni_to_glyphs (struct nsfont_info *font_info,
- unsigned char block);
-static void ns_glyph_metrics (struct nsfont_info *font_info,
- unsigned char block);
+/* Structure used by GS `shape' functions for storing layout
+ information for each glyph. Borrowed from macfont.h. */
+struct ns_glyph_layout
+{
+ /* Range of indices of the characters composed into the group of
+ glyphs that share the cursor position with this glyph. The
+ members `location' and `length' are in UTF-16 indices. */
+ NSRange comp_range;
-#define INVALID_GLYPH 0xFFFF
+ /* UTF-16 index in the source string for the first character
+ associated with this glyph. */
+ NSUInteger string_index;
-/* ==========================================================================
+ /* Horizontal and vertical adjustments of glyph position. The
+ coordinate space is that of Core Text. So, the `baseline_delta'
+ value is negative if the glyph should be placed below the
+ baseline. */
+ CGFloat advance_delta, baseline_delta;
- Utilities
+ /* Typographical width of the glyph. */
+ CGFloat advance;
- ========================================================================== */
+ /* Glyph ID of the glyph. */
+ NSGlyph glyph_id;
+};
+
+
+enum lgstring_direction
+ {
+ DIR_R2L = -1, DIR_UNKNOWN = 0, DIR_L2R = 1
+ };
+
+enum gs_font_slant
+ {
+ GS_FONT_SLANT_ITALIC,
+ GS_FONT_SLANT_REVERSE_ITALIC,
+ GS_FONT_SLANT_NORMAL
+ };
+
+enum gs_font_weight
+ {
+ GS_FONT_WEIGHT_LIGHT,
+ GS_FONT_WEIGHT_BOLD,
+ GS_FONT_WEIGHT_NORMAL
+ };
+
+enum gs_font_width
+ {
+ GS_FONT_WIDTH_CONDENSED,
+ GS_FONT_WIDTH_EXPANDED,
+ GS_FONT_WIDTH_NORMAL
+ };
+
+enum gs_specified
+ {
+ GS_SPECIFIED_SLANT = 1,
+ GS_SPECIFIED_WEIGHT = 1 << 1,
+ GS_SPECIFIED_WIDTH = 1 << 2,
+ GS_SPECIFIED_FAMILY = 1 << 3,
+ GS_SPECIFIED_SPACING = 1 << 4
+ };
+struct gs_font_data
+{
+ int specified;
+ enum gs_font_slant slant;
+ enum gs_font_weight weight;
+ enum gs_font_width width;
+ bool monospace_p;
+ char *family_name;
+};
-/* Replace spaces w/another character so emacs core font parsing routines
- aren't thrown off. */
static void
-ns_escape_name (char *name)
+ns_done_font_data (struct gs_font_data *data)
{
- for (; *name; name++)
- if (*name == ' ')
- *name = '_';
+ if (data->specified & GS_SPECIFIED_FAMILY)
+ xfree (data->family_name);
}
-
-/* Reconstruct spaces in a font family name passed through emacs. */
static void
-ns_unescape_name (char *name)
+ns_get_font_data (NSFontDescriptor *desc, struct gs_font_data *dat)
{
- for (; *name; name++)
- if (*name == '_')
- *name = ' ';
+ NSNumber *tem;
+ NSFontSymbolicTraits traits = [desc symbolicTraits];
+ NSDictionary *dict = [desc objectForKey: NSFontTraitsAttribute];
+ NSString *family = [desc objectForKey: NSFontFamilyAttribute];
+
+ dat->specified = 0;
+
+ if (family != nil)
+ {
+ dat->specified |= GS_SPECIFIED_FAMILY;
+ dat->family_name = xstrdup ([family cStringUsingEncoding: NSUTF8StringEncoding]);
+ }
+
+ tem = [desc objectForKey: NSFontFixedAdvanceAttribute];
+
+ if ((tem != nil && [tem boolValue] != NO)
+ || (traits & NSFontMonoSpaceTrait))
+ {
+ dat->specified |= GS_SPECIFIED_SPACING;
+ dat->monospace_p = true;
+ }
+ else if (tem != nil && [tem boolValue] == NO)
+ {
+ dat->specified |= GS_SPECIFIED_SPACING;
+ dat->monospace_p = false;
+ }
+
+ if (traits & NSFontBoldTrait)
+ {
+ dat->specified |= GS_SPECIFIED_WEIGHT;
+ dat->weight = GS_FONT_WEIGHT_BOLD;
+ }
+
+ if (traits & NSFontItalicTrait)
+ {
+ dat->specified |= GS_SPECIFIED_SLANT;
+ dat->slant = GS_FONT_SLANT_ITALIC;
+ }
+
+ if (traits & NSFontCondensedTrait)
+ {
+ dat->specified |= GS_SPECIFIED_WIDTH;
+ dat->width = GS_FONT_WIDTH_CONDENSED;
+ }
+ else if (traits & NSFontExpandedTrait)
+ {
+ dat->specified |= GS_SPECIFIED_WIDTH;
+ dat->width = GS_FONT_WIDTH_EXPANDED;
+ }
+
+ if (dict != nil)
+ {
+ tem = [dict objectForKey: NSFontSlantTrait];
+
+ if (tem != nil)
+ {
+ dat->specified |= GS_SPECIFIED_SLANT;
+
+ dat->slant = [tem floatValue] > 0
+ ? GS_FONT_SLANT_ITALIC
+ : ([tem floatValue] < 0
+ ? GS_FONT_SLANT_REVERSE_ITALIC
+ : GS_FONT_SLANT_NORMAL);
+ }
+
+ tem = [dict objectForKey: NSFontWeightTrait];
+
+ if (tem != nil)
+ {
+ dat->specified |= GS_SPECIFIED_WEIGHT;
+
+ dat->weight = [tem floatValue] > 0
+ ? GS_FONT_WEIGHT_BOLD
+ : ([tem floatValue] < -0.4f
+ ? GS_FONT_WEIGHT_LIGHT
+ : GS_FONT_WEIGHT_NORMAL);
+ }
+
+ tem = [dict objectForKey: NSFontWidthTrait];
+
+ if (tem != nil)
+ {
+ dat->specified |= GS_SPECIFIED_WIDTH;
+
+ dat->width = [tem floatValue] > 0
+ ? GS_FONT_WIDTH_EXPANDED
+ : ([tem floatValue] < 0
+ ? GS_FONT_WIDTH_NORMAL
+ : GS_FONT_WIDTH_CONDENSED);
+ }
+ }
+}
+
+static bool
+ns_font_descs_match_p (NSFontDescriptor *desc, NSFontDescriptor *target)
+{
+ struct gs_font_data dat;
+ struct gs_font_data t;
+
+ ns_get_font_data (desc, &dat);
+ ns_get_font_data (target, &t);
+
+ if (!(t.specified & GS_SPECIFIED_WIDTH))
+ t.width = GS_FONT_WIDTH_NORMAL;
+ if (!(t.specified & GS_SPECIFIED_WEIGHT))
+ t.weight = GS_FONT_WEIGHT_NORMAL;
+ if (!(t.specified & GS_SPECIFIED_SPACING))
+ t.monospace_p = false;
+ if (!(t.specified & GS_SPECIFIED_SLANT))
+ t.slant = GS_FONT_SLANT_NORMAL;
+
+ if (!(t.specified & GS_SPECIFIED_FAMILY))
+ emacs_abort ();
+
+ bool match_p = true;
+
+ if (dat.specified & GS_SPECIFIED_WIDTH
+ && dat.width != t.width)
+ {
+ match_p = false;
+ goto gout;
+ }
+
+ if (dat.specified & GS_SPECIFIED_WEIGHT
+ && dat.weight != t.weight)
+ {
+ match_p = false;
+ goto gout;
+ }
+
+ if (dat.specified & GS_SPECIFIED_SPACING
+ && dat.monospace_p != t.monospace_p)
+ {
+ match_p = false;
+ goto gout;
+ }
+
+ if (dat.specified & GS_SPECIFIED_SLANT
+ && dat.monospace_p != t.monospace_p)
+ {
+ if (NSFONT_TRACE)
+ printf ("Matching monospace for %s: %d %d\n",
+ t.family_name, dat.monospace_p,
+ t.monospace_p);
+ match_p = false;
+ goto gout;
+ }
+
+ if (dat.specified & GS_SPECIFIED_FAMILY
+ && strcmp (dat.family_name, t.family_name))
+ match_p = false;
+
+ gout:
+ ns_done_font_data (&dat);
+ ns_done_font_data (&t);
+
+ return match_p;
}
+/* Font glyph and metrics caching functions, implemented at end. */
+static void ns_uni_to_glyphs (struct nsfont_info *font_info,
+ unsigned char block);
+static void ns_glyph_metrics (struct nsfont_info *font_info,
+ unsigned int block);
+
+#define INVALID_GLYPH 0xFFFF
+
+/* ==========================================================================
+
+ Utilities
+
+ ========================================================================== */
+
/* Extract family name from a font spec. */
static NSString *
@@ -91,66 +313,116 @@ ns_get_family (Lisp_Object font_spec)
{
char *tmp = xlispstrdup (SYMBOL_NAME (tem));
NSString *family;
- ns_unescape_name (tmp);
family = [NSString stringWithUTF8String: tmp];
xfree (tmp);
return family;
}
}
-
-/* Return 0 if attr not set, else value (which might also be 0).
- On Leopard 0 gets returned even on descriptors where the attribute
- was never set, so there's no way to distinguish between unspecified
- and set to not have. Callers should assume 0 means unspecified. */
-static float
-ns_attribute_fvalue (NSFontDescriptor *fdesc, NSString *trait)
-{
- NSDictionary *tdict = [fdesc objectForKey: NSFontTraitsAttribute];
- NSNumber *val = [tdict objectForKey: trait];
- return val == nil ? 0.0F : [val floatValue];
-}
-
-
/* Converts FONT_WEIGHT, FONT_SLANT, FONT_WIDTH, plus family and script/lang
to NSFont descriptor. Information under extra only needed for matching. */
-#define STYLE_REF 100
static NSFontDescriptor *
ns_spec_to_descriptor (Lisp_Object font_spec)
{
NSFontDescriptor *fdesc;
NSMutableDictionary *fdAttrs = [NSMutableDictionary new];
- NSMutableDictionary *tdict = [NSMutableDictionary new];
NSString *family = ns_get_family (font_spec);
- float n;
-
- /* Add each attr in font_spec to fdAttrs. */
- n = min (FONT_WEIGHT_NUMERIC (font_spec), 200);
- if (n != -1 && n != STYLE_REF)
- [tdict setObject: [NSNumber numberWithFloat: (n - 100.0F) / 100.0F]
- forKey: NSFontWeightTrait];
- n = min (FONT_SLANT_NUMERIC (font_spec), 200);
- if (n != -1 && n != STYLE_REF)
- [tdict setObject: [NSNumber numberWithFloat: (n - 100.0F) / 100.0F]
- forKey: NSFontSlantTrait];
- n = min (FONT_WIDTH_NUMERIC (font_spec), 200);
- if (n > -1 && (n > STYLE_REF + 10 || n < STYLE_REF - 10))
- [tdict setObject: [NSNumber numberWithFloat: (n - 100.0F) / 100.0F]
- forKey: NSFontWidthTrait];
- if ([tdict count] > 0)
- [fdAttrs setObject: tdict forKey: NSFontTraitsAttribute];
+ NSMutableDictionary *tdict = [NSMutableDictionary new];
- fdesc = [[[NSFontDescriptor fontDescriptorWithFontAttributes: fdAttrs]
- retain] autorelease];
+ Lisp_Object tem;
+
+ tem = FONT_SLANT_SYMBOLIC (font_spec);
+ if (!NILP (tem))
+ {
+ if (EQ (tem, Qitalic) || EQ (tem, Qoblique))
+ [tdict setObject: [NSNumber numberWithFloat: 1.0]
+ forKey: NSFontSlantTrait];
+ else if (EQ (tem, intern ("reverse-italic")) ||
+ EQ (tem, intern ("reverse-oblique")))
+ [tdict setObject: [NSNumber numberWithFloat: -1.0]
+ forKey: NSFontSlantTrait];
+ else
+ [tdict setObject: [NSNumber numberWithFloat: 0.0]
+ forKey: NSFontSlantTrait];
+ }
+
+ tem = FONT_WIDTH_SYMBOLIC (font_spec);
+ if (!NILP (tem))
+ {
+ if (EQ (tem, Qcondensed))
+ [tdict setObject: [NSNumber numberWithFloat: -1.0]
+ forKey: NSFontWidthTrait];
+ else if (EQ (tem, Qexpanded))
+ [tdict setObject: [NSNumber numberWithFloat: 1.0]
+ forKey: NSFontWidthTrait];
+ else
+ [tdict setObject: [NSNumber numberWithFloat: 0.0]
+ forKey: NSFontWidthTrait];
+ }
+
+ tem = FONT_WEIGHT_SYMBOLIC (font_spec);
+
+ if (!NILP (tem))
+ {
+ if (EQ (tem, Qbold))
+ {
+ [tdict setObject: [NSNumber numberWithFloat: 1.0]
+ forKey: NSFontWeightTrait];
+ }
+ else if (EQ (tem, Qlight))
+ {
+ [tdict setObject: [NSNumber numberWithFloat: -1.0]
+ forKey: NSFontWeightTrait];
+ }
+ else
+ {
+ [tdict setObject: [NSNumber numberWithFloat: 0.0]
+ forKey: NSFontWeightTrait];
+ }
+ }
+
+ tem = AREF (font_spec, FONT_SPACING_INDEX);
if (family != nil)
{
- NSFontDescriptor *fdesc2 = [fdesc fontDescriptorWithFamily: family];
- fdesc = [[fdesc2 retain] autorelease];
+ [fdAttrs setObject: family
+ forKey: NSFontFamilyAttribute];
}
- [fdAttrs release];
+ if (FIXNUMP (tem))
+ {
+ if (XFIXNUM (tem) != FONT_SPACING_PROPORTIONAL)
+ {
+ [fdAttrs setObject: [NSNumber numberWithBool:YES]
+ forKey: NSFontFixedAdvanceAttribute];
+ }
+ else
+ {
+ [fdAttrs setObject: [NSNumber numberWithBool:NO]
+ forKey: NSFontFixedAdvanceAttribute];
+ }
+ }
+
+ /* Handle special families such as ``fixed'' or ``Sans Serif''. */
+
+ if ([family isEqualToString: @"fixed"])
+ {
+ [fdAttrs setObject: [[NSFont userFixedPitchFontOfSize: 0] familyName]
+ forKey: NSFontFamilyAttribute];
+ }
+ else if ([family isEqualToString: @"Sans Serif"])
+ {
+ [fdAttrs setObject: [[NSFont userFontOfSize: 0] familyName]
+ forKey: NSFontFamilyAttribute];
+ }
+
+ [fdAttrs setObject: tdict forKey: NSFontTraitsAttribute];
+
+ fdesc = [[[NSFontDescriptor fontDescriptorWithFontAttributes: fdAttrs]
+ retain] autorelease];
+
[tdict release];
+ [fdAttrs release];
return fdesc;
}
@@ -161,61 +433,64 @@ ns_descriptor_to_entity (NSFontDescriptor *desc,
Lisp_Object extra,
const char *style)
{
- Lisp_Object font_entity = font_make_entity ();
- /* NSString *psName = [desc postscriptName]; */
- NSString *family = [desc objectForKey: NSFontFamilyAttribute];
- unsigned int traits = [desc symbolicTraits];
- char *escapedFamily;
-
- /* Shouldn't happen, but on Tiger fallback desc gets name but no family. */
- if (family == nil)
- family = [desc objectForKey: NSFontNameAttribute];
- if (family == nil)
- family = [[NSFont userFixedPitchFontOfSize: 0] familyName];
-
- escapedFamily = xstrdup ([family UTF8String]);
- ns_escape_name (escapedFamily);
-
- ASET (font_entity, FONT_TYPE_INDEX, Qns);
- ASET (font_entity, FONT_FOUNDRY_INDEX, Qapple);
- ASET (font_entity, FONT_FAMILY_INDEX, intern (escapedFamily));
- ASET (font_entity, FONT_ADSTYLE_INDEX, style ? intern (style) : Qnil);
- ASET (font_entity, FONT_REGISTRY_INDEX, Qiso10646_1);
-
- FONT_SET_STYLE (font_entity, FONT_WEIGHT_INDEX,
- traits & NSFontBoldTrait ? Qbold : Qmedium);
-/* FONT_SET_STYLE (font_entity, FONT_WEIGHT_INDEX,
- make_fixnum (100 + 100
- * ns_attribute_fvalue (desc, NSFontWeightTrait)));*/
- FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX,
- traits & NSFontItalicTrait ? Qitalic : Qnormal);
-/* FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX,
- make_fixnum (100 + 100
- * ns_attribute_fvalue (desc, NSFontSlantTrait)));*/
- FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX,
- traits & NSFontCondensedTrait ? Qcondensed :
- traits & NSFontExpandedTrait ? Qexpanded : Qnormal);
-/* FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX,
- make_fixnum (100 + 100
- * ns_attribute_fvalue (desc, NSFontWidthTrait)));*/
-
- ASET (font_entity, FONT_SIZE_INDEX, make_fixnum (0));
- ASET (font_entity, FONT_AVGWIDTH_INDEX, make_fixnum (0));
- ASET (font_entity, FONT_SPACING_INDEX,
- make_fixnum([desc symbolicTraits] & NSFontMonoSpaceTrait
- ? FONT_SPACING_MONO : FONT_SPACING_PROPORTIONAL));
-
- ASET (font_entity, FONT_EXTRA_INDEX, extra);
- ASET (font_entity, FONT_OBJLIST_INDEX, Qnil);
+ Lisp_Object font_entity = font_make_entity ();
+ struct gs_font_data data;
+ ns_get_font_data (desc, &data);
+
+ ASET (font_entity, FONT_TYPE_INDEX, Qns);
+ ASET (font_entity, FONT_FOUNDRY_INDEX, Qns);
+ if (data.specified & GS_SPECIFIED_FAMILY)
+ ASET (font_entity, FONT_FAMILY_INDEX, intern (data.family_name));
+ ASET (font_entity, FONT_ADSTYLE_INDEX, style ? intern (style) : Qnil);
+ ASET (font_entity, FONT_REGISTRY_INDEX, Qiso10646_1);
+
+ if (data.specified & GS_SPECIFIED_WEIGHT)
+ {
+ FONT_SET_STYLE (font_entity, FONT_WEIGHT_INDEX,
+ data.weight == GS_FONT_WEIGHT_BOLD
+ ? Qbold : (data.weight == GS_FONT_WEIGHT_LIGHT
+ ? Qlight : Qnormal));
+ }
+ else
+ FONT_SET_STYLE (font_entity, FONT_WEIGHT_INDEX, Qnormal);
- if (NSFONT_TRACE)
- {
- fputs ("created font_entity:\n ", stderr);
- debug_print (font_entity);
- }
+ if (data.specified & GS_SPECIFIED_SLANT)
+ {
+ FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX,
+ data.slant == GS_FONT_SLANT_ITALIC
+ ? Qitalic : (data.slant == GS_FONT_SLANT_REVERSE_ITALIC
+ ? intern ("reverse-italic") : Qnormal));
+ }
+ else
+ FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX, Qnormal);
+
+ if (data.specified & GS_SPECIFIED_WIDTH)
+ {
+ FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX,
+ data.width == GS_FONT_WIDTH_CONDENSED
+ ? Qcondensed : (data.width == GS_FONT_WIDTH_EXPANDED
+ ? intern ("expanded") : Qnormal));
+ }
+ else
+ FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX, Qnormal);
- xfree (escapedFamily);
- return font_entity;
+ ASET (font_entity, FONT_SIZE_INDEX, make_fixnum (0));
+ ASET (font_entity, FONT_AVGWIDTH_INDEX, make_fixnum (0));
+ ASET (font_entity, FONT_SPACING_INDEX,
+ make_fixnum ((data.specified & GS_SPECIFIED_WIDTH && data.monospace_p)
+ ? FONT_SPACING_MONO : FONT_SPACING_PROPORTIONAL));
+
+ ASET (font_entity, FONT_EXTRA_INDEX, extra);
+ ASET (font_entity, FONT_OBJLIST_INDEX, Qnil);
+
+ if (NSFONT_TRACE)
+ {
+ fputs ("created font_entity:\n ", stderr);
+ debug_print (font_entity);
+ }
+
+ ns_done_font_data (&data);
+ return font_entity;
}
@@ -223,8 +498,7 @@ ns_descriptor_to_entity (NSFontDescriptor *desc,
static Lisp_Object
ns_fallback_entity (void)
{
- return ns_descriptor_to_entity ([[NSFont userFixedPitchFontOfSize: 0]
- fontDescriptor], Qnil, NULL);
+ return ns_descriptor_to_entity ([[NSFont userFixedPitchFontOfSize: 1] fontDescriptor], Qnil, NULL);
}
@@ -510,21 +784,20 @@ static NSSet
return families;
}
+/* GNUstep font matching is very mediocre (it can't even compare
+ symbolic styles correctly), which is why our own font matching
+ mechanism must be implemented. */
-/* Implementation for list() and match(). List() can return nil, match()
-must return something. Strategy is to drop family name from attribute
-matching set for match. */
+/* Implementation for list and match. */
static Lisp_Object
ns_findfonts (Lisp_Object font_spec, BOOL isMatch)
{
Lisp_Object tem, list = Qnil;
- NSFontDescriptor *fdesc, *desc;
- NSMutableSet *fkeys;
- NSArray *matchingDescs;
- NSEnumerator *dEnum;
- NSString *family;
+ NSFontDescriptor *fdesc;
+ NSArray *all_descs;
+ GSFontEnumerator *enumerator = [GSFontEnumerator sharedEnumerator];
+
NSSet *cFamilies;
- BOOL foundItal = NO;
block_input ();
if (NSFONT_TRACE)
@@ -537,43 +810,22 @@ ns_findfonts (Lisp_Object font_spec, BOOL isMatch)
cFamilies = ns_get_covering_families (ns_get_req_script (font_spec), 0.90);
fdesc = ns_spec_to_descriptor (font_spec);
- fkeys = [NSMutableSet setWithArray: [[fdesc fontAttributes] allKeys]];
- if (isMatch)
- [fkeys removeObject: NSFontFamilyAttribute];
-
- matchingDescs = [fdesc matchingFontDescriptorsWithMandatoryKeys: fkeys];
+ all_descs = [enumerator availableFontDescriptors];
- if (NSFONT_TRACE)
- NSLog(@"Got desc %@ and found %lu matching fonts from it: ", fdesc,
- (unsigned long)[matchingDescs count]);
-
- for (dEnum = [matchingDescs objectEnumerator]; (desc = [dEnum nextObject]);)
+ for (NSFontDescriptor *desc in all_descs)
{
if (![cFamilies containsObject:
[desc objectForKey: NSFontFamilyAttribute]])
continue;
+ if (!ns_font_descs_match_p (fdesc, desc))
+ continue;
+
tem = ns_descriptor_to_entity (desc,
- AREF (font_spec, FONT_EXTRA_INDEX),
+ AREF (font_spec, FONT_EXTRA_INDEX),
NULL);
if (isMatch)
return tem;
list = Fcons (tem, list);
- if (fabs (ns_attribute_fvalue (desc, NSFontSlantTrait)) > 0.05)
- foundItal = YES;
- }
-
- /* Add synthItal member if needed. */
- family = [fdesc objectForKey: NSFontFamilyAttribute];
- if (family != nil && !foundItal && !NILP (list))
- {
- NSFontDescriptor *s1 = [NSFontDescriptor new];
- NSFontDescriptor *sDesc
- = [[s1 fontDescriptorWithSymbolicTraits: NSFontItalicTrait]
- fontDescriptorWithFamily: family];
- list = Fcons (ns_descriptor_to_entity (sDesc,
- AREF (font_spec, FONT_EXTRA_INDEX),
- "synthItal"), list);
- [s1 release];
}
unblock_input ();
@@ -652,7 +904,6 @@ nsfont_list_family (struct frame *f)
objectEnumerator];
while ((family = [families nextObject]))
list = Fcons (intern ([family UTF8String]), list);
- /* FIXME: escape the name? */
if (NSFONT_TRACE)
fprintf (stderr, "nsfont: list families returning %"pD"d entries\n",
@@ -668,18 +919,15 @@ nsfont_list_family (struct frame *f)
static Lisp_Object
nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
{
- BOOL synthItal;
- unsigned int traits = 0;
struct nsfont_info *font_info;
struct font *font;
NSFontDescriptor *fontDesc = ns_spec_to_descriptor (font_entity);
NSFontManager *fontMgr = [NSFontManager sharedFontManager];
NSString *family;
NSFont *nsfont, *sfont;
- Lisp_Object tem;
NSRect brect;
Lisp_Object font_object;
- int fixLeopardBug;
+ Lisp_Object tem;
block_input ();
@@ -692,42 +940,20 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
if (pixel_size <= 0)
{
/* try to get it out of frame params */
- Lisp_Object tem = get_frame_param (f, Qfontsize);
- pixel_size = NILP (tem) ? 0 : XFIXNAT (tem);
+ tem = get_frame_param (f, Qfontsize);
+ pixel_size = NILP (tem) ? 0 : XFIXNAT (tem);
}
tem = AREF (font_entity, FONT_ADSTYLE_INDEX);
- synthItal = !NILP (tem) && !strncmp ("synthItal", SSDATA (SYMBOL_NAME (tem)),
- 9);
family = ns_get_family (font_entity);
if (family == nil)
family = [[NSFont userFixedPitchFontOfSize: 0] familyName];
- /* Should be > 0.23 as some font descriptors (e.g. Terminus) set to that
- when setting family in ns_spec_to_descriptor(). */
- if (ns_attribute_fvalue (fontDesc, NSFontWeightTrait) > 0.50F)
- traits |= NSBoldFontMask;
- if (ns_attribute_fvalue (fontDesc, NSFontSlantTrait) > 0.05F)
- traits |= NSItalicFontMask;
-
- /* see https://web.archive.org/web/20100201175731/http://cocoadev.com/forums/comments.php?DiscussionID=74 */
- fixLeopardBug = traits & NSBoldFontMask ? 10 : 5;
- nsfont = [fontMgr fontWithFamily: family
- traits: traits weight: fixLeopardBug
- size: pixel_size];
- /* if didn't find, try synthetic italic */
- if (nsfont == nil && synthItal)
- {
- nsfont = [fontMgr fontWithFamily: family
- traits: traits & ~NSItalicFontMask
- weight: fixLeopardBug size: pixel_size];
- }
+
+ nsfont = [NSFont fontWithDescriptor: fontDesc
+ size: pixel_size];
if (nsfont == nil)
- {
- message_with_string ("*** Warning: font in family `%s' not found",
- build_string ([family UTF8String]), 1);
- nsfont = [NSFont userFixedPitchFontOfSize: pixel_size];
- }
+ nsfont = [NSFont userFixedPitchFontOfSize: pixel_size];
if (NSFONT_TRACE)
NSLog (@"%@\n", nsfont);
@@ -740,7 +966,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
if (!font)
{
unblock_input ();
- return Qnil; /* FIXME: other terms do, but returning Qnil causes segfault. */
+ return Qnil;
}
font_info->glyphs = xzalloc (0x100 * sizeof *font_info->glyphs);
@@ -781,7 +1007,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
font_info->name = xstrdup (fontName);
font_info->bold = [fontMgr traitsOfFont: nsfont] & NSBoldFontMask;
font_info->ital =
- synthItal || ([fontMgr traitsOfFont: nsfont] & NSItalicFontMask);
+ ([fontMgr traitsOfFont: nsfont] & NSItalicFontMask);
/* Metrics etc.; some fonts return an unusually large max advance, so we
only use it for fonts that have wide characters. */
@@ -808,8 +1034,6 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
lrint (brect.size.width - (CGFloat) font_info->width);
/* set up metrics portion of font struct */
- font->ascent = lrint([sfont ascender]);
- font->descent = -lrint(floor(adjusted_descender));
font->space_width = lrint (ns_char_width (sfont, ' '));
font->max_width = lrint (font_info->max_bounds.width);
font->min_width = font->space_width; /* Approximate. */
@@ -871,7 +1095,7 @@ nsfont_encode_char (struct font *font, int c)
{
struct nsfont_info *font_info = (struct nsfont_info *)font;
unsigned char high = (c & 0xff00) >> 8, low = c & 0x00ff;
- unsigned short g;
+ unsigned int g;
if (c > 0xFFFF)
return FONT_INVALID_CODE;
@@ -934,51 +1158,23 @@ nsfont_text_extents (struct font *font, const unsigned int *code,
static int
nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
bool with_background)
-/* NOTE: focus and clip must be set. */
{
- static unsigned char cbuf[1024];
- unsigned char *c = cbuf;
-#if GNUSTEP_GUI_MAJOR_VERSION > 0 || GNUSTEP_GUI_MINOR_VERSION > 22
- static CGFloat advances[1024];
- CGFloat *adv = advances;
-#else
- static float advances[1024];
- float *adv = advances;
-#endif
+ NSGlyph *c = alloca ((to - from) * sizeof *c);
+
struct face *face;
NSRect r;
struct nsfont_info *font;
- NSColor *col, *bgCol;
- unsigned *t = s->char2b;
- int i, len, flags;
+ NSColor *col;
+ int len = to - from;
char isComposite = s->first_glyph->type == COMPOSITE_GLYPH;
block_input ();
- font = (struct nsfont_info *)s->face->font;
+ font = (struct nsfont_info *) s->font;
if (font == NULL)
font = (struct nsfont_info *)FRAME_FONT (s->f);
- /* Select face based on input flags. */
- flags = s->hl == DRAW_CURSOR ? NS_DUMPGLYPH_CURSOR :
- (s->hl == DRAW_MOUSE_FACE ? NS_DUMPGLYPH_MOUSEFACE :
- (s->for_overlaps ? NS_DUMPGLYPH_FOREGROUND :
- NS_DUMPGLYPH_NORMAL));
-
- switch (flags)
- {
- case NS_DUMPGLYPH_CURSOR:
- face = s->face;
- break;
- case NS_DUMPGLYPH_MOUSEFACE:
- face = FACE_FROM_ID_OR_NULL (s->f,
- MOUSE_HL_INFO (s->f)->mouse_face_face_id);
- if (!face)
- face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
- break;
- default:
- face = s->face;
- }
+ face = s->face;
r.origin.x = s->x;
if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p)
@@ -987,91 +1183,24 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
r.origin.y = s->y;
r.size.height = FONT_HEIGHT (font);
- /* Convert UTF-16 (?) to UTF-8 and determine advances. Note if we just ask
- NS to render the string, it will come out differently from the individual
- character widths added up because of layout processing. */
- {
- int cwidth, twidth = 0;
- int hi, lo;
- /* FIXME: composition: no vertical displacement is considered. */
- t += from; /* advance into composition */
- for (i = from; i < to; i++, t++)
- {
- hi = (*t & 0xFF00) >> 8;
- lo = *t & 0x00FF;
- if (isComposite)
- {
- if (!s->first_glyph->u.cmp.automatic)
- cwidth = s->cmp->offsets[i * 2] /* (H offset) */ - twidth;
- else
- {
- Lisp_Object gstring = composition_gstring_from_id (s->cmp_id);
- Lisp_Object glyph = LGSTRING_GLYPH (gstring, i);
- if (NILP (LGLYPH_ADJUSTMENT (glyph)))
- cwidth = LGLYPH_WIDTH (glyph);
- else
- {
- cwidth = LGLYPH_WADJUST (glyph);
- *(adv-1) += LGLYPH_XOFF (glyph);
- }
- }
- }
- else
- {
- if (!font->metrics[hi]) /* FIXME: why/how can we need this now? */
- ns_glyph_metrics (font, hi);
- cwidth = font->metrics[hi][lo].width;
- }
- twidth += cwidth;
- *adv++ = cwidth;
- c += CHAR_STRING (*t, c); /* This converts the char to UTF-8. */
- }
- len = adv - advances;
- r.size.width = twidth;
- *c = 0;
- }
+ for (int i = from; i < to; ++i)
+ c[i] = s->char2b[i];
/* Fill background if requested. */
if (with_background && !isComposite)
{
- NSRect br = r;
- int fibw = FRAME_INTERNAL_BORDER_WIDTH (s->f);
- int mbox_line_width = max (s->face->box_vertical_line_width, 0);
-
- if (s->row->full_width_p)
- {
- if (br.origin.x <= fibw + 1 + mbox_line_width)
- {
- br.size.width += br.origin.x - mbox_line_width;
- br.origin.x = mbox_line_width;
- }
- if (FRAME_PIXEL_WIDTH (s->f) - (br.origin.x + br.size.width)
- <= fibw+1)
- br.size.width += fibw;
- }
- if (s->face->box == FACE_NO_BOX)
- {
- /* Expand unboxed top row over internal border. */
- if (br.origin.y <= fibw + 1 + mbox_line_width)
- {
- br.size.height += br.origin.y;
- br.origin.y = 0;
- }
- }
- else
- {
- int correction = abs (s->face->box_horizontal_line_width)+1;
- br.origin.y += correction;
- br.size.height -= 2*correction;
- correction = abs (s->face->box_vertical_line_width)+1;
- br.origin.x += correction;
- br.size.width -= 2*correction;
- }
+ NSRect br = NSMakeRect (x, y - FONT_BASE (s->font),
+ s->width, FONT_HEIGHT (s->font));
if (!s->face->stipple)
- [(NS_FACE_BACKGROUND (face) != 0
- ? ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f)
- : FRAME_BACKGROUND_COLOR (s->f)) set];
+ {
+ if (s->hl != DRAW_CURSOR)
+ [(NS_FACE_BACKGROUND (face) != 0
+ ? ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f)
+ : FRAME_BACKGROUND_COLOR (s->f)) set];
+ else
+ [FRAME_CURSOR_COLOR (s->f) set];
+ }
else
{
struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (s->f);
@@ -1080,43 +1209,32 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
NSRectFill (br);
}
-
/* set up for character rendering */
r.origin.y = y;
- col = (NS_FACE_FOREGROUND (face) != 0
- ? ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f)
- : FRAME_FOREGROUND_COLOR (s->f));
-
- bgCol = (flags != NS_DUMPGLYPH_FOREGROUND ? nil
- : (NS_FACE_BACKGROUND (face) != 0
- ? ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f)
- : FRAME_BACKGROUND_COLOR (s->f)));
+ if (s->hl == DRAW_CURSOR)
+ col = FRAME_BACKGROUND_COLOR (s->f);
+ else
+ col = (NS_FACE_FOREGROUND (face) != 0
+ ? ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f)
+ : FRAME_FOREGROUND_COLOR (s->f));
/* render under GNUstep using DPS */
{
- NSGraphicsContext *context = GSCurrentContext ();
-
+ NSGraphicsContext *context = [NSGraphicsContext currentContext];
DPSgsave (context);
- [font->nsfont set];
-
- /* do erase if "foreground" mode */
- if (bgCol != nil)
+ if (s->clip_head)
{
- [bgCol set];
- DPSmoveto (context, r.origin.x, r.origin.y);
-/*[context GSSetTextDrawingMode: GSTextFillStroke]; /// not implemented yet */
- DPSxshow (context, (const char *) cbuf, advances, len);
- DPSstroke (context);
- [col set];
-/*[context GSSetTextDrawingMode: GSTextFill]; /// not implemented yet */
+ DPSrectclip (context, s->clip_head->x, 0,
+ FRAME_PIXEL_WIDTH (s->f),
+ FRAME_PIXEL_HEIGHT (s->f));
}
+ [font->nsfont set];
[col set];
- /* draw with DPSxshow () */
DPSmoveto (context, r.origin.x, r.origin.y);
- DPSxshow (context, (const char *) cbuf, advances, len);
+ GSShowGlyphs (context, c, len);
DPSstroke (context);
DPSgrestore (context);
@@ -1126,6 +1244,360 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
return to-from;
}
+static NSUInteger
+ns_font_shape (NSFont *font, NSString *string,
+ struct ns_glyph_layout *glyph_layouts, NSUInteger glyph_len,
+ enum lgstring_direction dir)
+{
+ NSUInteger i;
+ NSUInteger result = 0;
+ NSTextStorage *textStorage;
+ NSLayoutManager *layoutManager;
+ NSTextContainer *textContainer;
+ NSUInteger stringLength;
+ NSPoint spaceLocation;
+ /* numberOfGlyphs can't actually be 0, but this pacifies GCC */
+ NSUInteger used, numberOfGlyphs = 0;
+
+ textStorage = [[NSTextStorage alloc] initWithString:string];
+ layoutManager = [[NSLayoutManager alloc] init];
+ textContainer = [[NSTextContainer alloc] init];
+
+ /* Append a trailing space to measure baseline position. */
+ [textStorage appendAttributedString:([[[NSAttributedString alloc]
+ initWithString:@" "] autorelease])];
+ [textStorage setFont:font];
+ [textContainer setLineFragmentPadding:0];
+
+ [layoutManager addTextContainer:textContainer];
+ [textContainer release];
+ [textStorage addLayoutManager:layoutManager];
+ [layoutManager release];
+
+ if (!(textStorage && layoutManager && textContainer))
+ emacs_abort ();
+
+ stringLength = [string length];
+
+ /* Force layout. */
+ (void) [layoutManager glyphRangeForTextContainer:textContainer];
+
+ spaceLocation = [layoutManager locationForGlyphAtIndex:stringLength];
+
+ /* Remove the appended trailing space because otherwise it may
+ generate a wrong result for a right-to-left text. */
+ [textStorage beginEditing];
+ [textStorage deleteCharactersInRange:(NSMakeRange (stringLength, 1))];
+ [textStorage endEditing];
+ (void) [layoutManager glyphRangeForTextContainer:textContainer];
+
+ i = 0;
+ while (i < stringLength)
+ {
+ NSRange range;
+ NSFont *fontInTextStorage =
+ [textStorage attribute: NSFontAttributeName
+ atIndex:i
+ longestEffectiveRange: &range
+ inRange: NSMakeRange (0, stringLength)];
+
+ if (!(fontInTextStorage == font
+ || [[fontInTextStorage fontName] isEqualToString:[font fontName]]))
+ break;
+ i = NSMaxRange (range);
+ }
+ if (i < stringLength)
+ /* Make the test `used <= glyph_len' below fail if textStorage
+ contained some fonts other than the specified one. */
+ used = glyph_len + 1;
+ else
+ {
+ NSRange range = NSMakeRange (0, stringLength);
+
+ range = [layoutManager glyphRangeForCharacterRange:range
+ actualCharacterRange:NULL];
+ numberOfGlyphs = NSMaxRange (range);
+ used = numberOfGlyphs;
+ for (i = 0; i < numberOfGlyphs; i++)
+ if ([layoutManager notShownAttributeForGlyphAtIndex:i])
+ used--;
+ }
+
+ if (0 < used && used <= glyph_len)
+ {
+ NSUInteger glyphIndex, prevGlyphIndex;
+ NSUInteger *permutation;
+ NSRange compRange, range;
+ CGFloat totalAdvance;
+
+ glyphIndex = 0;
+ while ([layoutManager notShownAttributeForGlyphAtIndex:glyphIndex])
+ glyphIndex++;
+
+ permutation = NULL;
+#define RIGHT_TO_LEFT_P permutation
+
+ /* Fill the `comp_range' member of struct mac_glyph_layout, and
+ setup a permutation for right-to-left text. */
+ compRange = NSMakeRange (0, 0);
+ for (range = NSMakeRange (0, 0); NSMaxRange (range) < used;
+ range.length++)
+ {
+ struct ns_glyph_layout *gl = glyph_layouts + NSMaxRange (range);
+ NSUInteger characterIndex =
+ [layoutManager characterIndexForGlyphAtIndex:glyphIndex];
+
+ gl->string_index = characterIndex;
+
+ if (characterIndex >= NSMaxRange (compRange))
+ {
+ compRange.location = NSMaxRange (compRange);
+ do
+ {
+ NSRange characterRange =
+ [string
+ rangeOfComposedCharacterSequenceAtIndex:characterIndex];
+
+ compRange.length =
+ NSMaxRange (characterRange) - compRange.location;
+ [layoutManager glyphRangeForCharacterRange:compRange
+ actualCharacterRange:&characterRange];
+ characterIndex = NSMaxRange (characterRange) - 1;
+ }
+ while (characterIndex >= NSMaxRange (compRange));
+
+ if (RIGHT_TO_LEFT_P)
+ for (i = 0; i < range.length; i++)
+ permutation[range.location + i] = NSMaxRange (range) - i - 1;
+
+ range = NSMakeRange (NSMaxRange (range), 0);
+ }
+
+ gl->comp_range.location = compRange.location;
+ gl->comp_range.length = compRange.length;
+
+ while (++glyphIndex < numberOfGlyphs)
+ if (![layoutManager notShownAttributeForGlyphAtIndex:glyphIndex])
+ break;
+ }
+ if (RIGHT_TO_LEFT_P)
+ for (i = 0; i < range.length; i++)
+ permutation[range.location + i] = NSMaxRange (range) - i - 1;
+
+ /* Then fill the remaining members. */
+ glyphIndex = prevGlyphIndex = 0;
+ while ([layoutManager notShownAttributeForGlyphAtIndex:glyphIndex])
+ glyphIndex++;
+
+ if (!RIGHT_TO_LEFT_P)
+ totalAdvance = 0;
+ else
+ {
+ NSUInteger nrects;
+ NSRect *glyphRects =
+ [layoutManager
+ rectArrayForGlyphRange:(NSMakeRange (0, numberOfGlyphs))
+ withinSelectedGlyphRange:(NSMakeRange (NSNotFound, 0))
+ inTextContainer:textContainer rectCount:&nrects];
+
+ totalAdvance = NSMaxX (glyphRects[0]);
+ }
+
+ for (i = 0; i < used; i++)
+ {
+ struct ns_glyph_layout *gl;
+ NSPoint location;
+ NSUInteger nextGlyphIndex;
+ NSRange glyphRange;
+ NSRect *glyphRects;
+ NSUInteger nrects;
+
+ if (!RIGHT_TO_LEFT_P)
+ gl = glyph_layouts + i;
+ else
+ {
+ NSUInteger dest = permutation[i];
+
+ gl = glyph_layouts + dest;
+ if (i < dest)
+ {
+ NSUInteger tmp = gl->string_index;
+
+ gl->string_index = glyph_layouts[i].string_index;
+ glyph_layouts[i].string_index = tmp;
+ }
+ }
+ gl->glyph_id = [layoutManager glyphAtIndex: glyphIndex];
+
+ location = [layoutManager locationForGlyphAtIndex:glyphIndex];
+ gl->baseline_delta = spaceLocation.y - location.y;
+
+ for (nextGlyphIndex = glyphIndex + 1; nextGlyphIndex < numberOfGlyphs;
+ nextGlyphIndex++)
+ if (![layoutManager
+ notShownAttributeForGlyphAtIndex:nextGlyphIndex])
+ break;
+
+ if (!RIGHT_TO_LEFT_P)
+ {
+ CGFloat maxX;
+
+ if (prevGlyphIndex == 0)
+ glyphRange = NSMakeRange (0, nextGlyphIndex);
+ else
+ glyphRange = NSMakeRange (glyphIndex,
+ nextGlyphIndex - glyphIndex);
+ glyphRects =
+ [layoutManager
+ rectArrayForGlyphRange:glyphRange
+ withinSelectedGlyphRange:(NSMakeRange (NSNotFound, 0))
+ inTextContainer:textContainer rectCount:&nrects];
+ maxX = max (NSMaxX (glyphRects[0]), totalAdvance);
+ gl->advance_delta = location.x - totalAdvance;
+ gl->advance = maxX - totalAdvance;
+ totalAdvance = maxX;
+ }
+ else
+ {
+ CGFloat minX;
+
+ if (nextGlyphIndex == numberOfGlyphs)
+ glyphRange = NSMakeRange (prevGlyphIndex,
+ numberOfGlyphs - prevGlyphIndex);
+ else
+ glyphRange = NSMakeRange (prevGlyphIndex,
+ glyphIndex + 1 - prevGlyphIndex);
+ glyphRects =
+ [layoutManager
+ rectArrayForGlyphRange:glyphRange
+ withinSelectedGlyphRange:(NSMakeRange (NSNotFound, 0))
+ inTextContainer:textContainer rectCount:&nrects];
+ minX = min (NSMinX (glyphRects[0]), totalAdvance);
+ gl->advance = totalAdvance - minX;
+ totalAdvance = minX;
+ gl->advance_delta = location.x - totalAdvance;
+ }
+
+ prevGlyphIndex = glyphIndex + 1;
+ glyphIndex = nextGlyphIndex;
+ }
+
+ if (RIGHT_TO_LEFT_P)
+ xfree (permutation);
+
+#undef RIGHT_TO_LEFT_P
+
+ result = used;
+ }
+ [textStorage release];
+
+ return result;
+}
+
+static Lisp_Object
+nsfont_shape (Lisp_Object lgstring, Lisp_Object direction)
+{
+ struct font *font = CHECK_FONT_GET_OBJECT (LGSTRING_FONT (lgstring));
+ struct nsfont_info *font_info = (struct nsfont_info *) font;
+ struct ns_glyph_layout *glyph_layouts;
+ NSFont *nsfont = font_info->nsfont;
+ ptrdiff_t glyph_len, len, i;
+ Lisp_Object tem;
+ unichar *mb_buf;
+ NSUInteger used;
+
+ glyph_len = LGSTRING_GLYPH_LEN (lgstring);
+ for (i = 0; i < glyph_len; ++i)
+ {
+ tem = LGSTRING_GLYPH (lgstring, i);
+
+ if (NILP (tem))
+ break;
+ }
+
+ len = i;
+
+ if (INT_MAX / 2 < len)
+ memory_full (SIZE_MAX);
+
+ block_input ();
+
+ mb_buf = alloca (len * sizeof *mb_buf);
+
+ for (i = 0; i < len; ++i)
+ {
+ uint32_t c = LGLYPH_CHAR (LGSTRING_GLYPH (lgstring, i));
+ mb_buf[i] = (unichar) c;
+ }
+
+ NSString *string = [NSString stringWithCharacters: mb_buf
+ length: len];
+ unblock_input ();
+
+ if (!string)
+ return Qnil;
+
+ block_input ();
+
+ enum lgstring_direction dir = DIR_UNKNOWN;
+
+ if (EQ (direction, QL2R))
+ dir = DIR_L2R;
+ else if (EQ (direction, QR2L))
+ dir = DIR_R2L;
+ glyph_layouts = alloca (sizeof (struct ns_glyph_layout) * glyph_len);
+ used = ns_font_shape (nsfont, string, glyph_layouts, glyph_len, dir);
+
+ for (i = 0; i < used; i++)
+ {
+ Lisp_Object lglyph = LGSTRING_GLYPH (lgstring, i);
+ struct ns_glyph_layout *gl = glyph_layouts + i;
+ EMACS_INT from, to;
+ struct font_metrics metrics;
+
+ if (NILP (lglyph))
+ {
+ lglyph = LGLYPH_NEW ();
+ LGSTRING_SET_GLYPH (lgstring, i, lglyph);
+ }
+
+ from = gl->comp_range.location;
+ LGLYPH_SET_FROM (lglyph, from);
+
+ to = gl->comp_range.location + gl->comp_range.length;
+ LGLYPH_SET_TO (lglyph, to - 1);
+
+ /* LGLYPH_CHAR is used in `describe-char' for checking whether
+ the composition is trivial. */
+ {
+ UTF32Char c;
+
+ if (mb_buf[gl->string_index] >= 0xD800
+ && mb_buf[gl->string_index] < 0xDC00)
+ c = (((mb_buf[gl->string_index] - 0xD800) << 10)
+ + (mb_buf[gl->string_index + 1] - 0xDC00) + 0x10000);
+ else
+ c = mb_buf[gl->string_index];
+
+ LGLYPH_SET_CHAR (lglyph, c);
+ }
+
+ {
+ unsigned long cc = gl->glyph_id;
+ LGLYPH_SET_CODE (lglyph, cc);
+ }
+
+ nsfont_text_extents (font, &gl->glyph_id, 1, &metrics);
+ LGLYPH_SET_WIDTH (lglyph, metrics.width);
+ LGLYPH_SET_LBEARING (lglyph, metrics.lbearing);
+ LGLYPH_SET_RBEARING (lglyph, metrics.rbearing);
+ LGLYPH_SET_ASCENT (lglyph, metrics.ascent);
+ LGLYPH_SET_DESCENT (lglyph, metrics.descent);
+ }
+ unblock_input ();
+
+ return make_fixnum (used);
+}
/* ==========================================================================
@@ -1134,6 +1606,50 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
========================================================================== */
+static NSGlyph
+ns_uni_to_glyphs_1 (struct nsfont_info *info, unsigned int c)
+{
+ unichar characters[] = { c };
+ NSString *string =
+ [NSString stringWithCharacters: characters
+ length: 1];
+ NSDictionary *attributes =
+ [NSDictionary dictionaryWithObjectsAndKeys:
+ info->nsfont, NSFontAttributeName, nil];
+ NSTextStorage *storage = [[NSTextStorage alloc] initWithString: string
+ attributes: attributes];
+ NSTextContainer *text_container = [[NSTextContainer alloc] init];
+ NSLayoutManager *manager = [[NSLayoutManager alloc] init];
+
+ [manager addTextContainer: text_container];
+ [text_container release]; /* Retained by manager */
+ [storage addLayoutManager: manager];
+ [manager release]; /* Retained by storage */
+
+ NSFont *font_in_storage = [storage attribute: NSFontAttributeName
+ atIndex:0
+ effectiveRange: NULL];
+ NSGlyph glyph = FONT_INVALID_CODE;
+
+ if ((font_in_storage == info->nsfont
+ || [[font_in_storage fontName] isEqualToString: [info->nsfont fontName]]))
+ {
+ @try
+ {
+ glyph = [manager glyphAtIndex: 0];
+ }
+ @catch (NSException *e)
+ {
+ /* GNUstep bug? */
+ glyph = 'X';
+ }
+ }
+
+ [storage release];
+
+ return glyph;
+}
+
/* Find and cache corresponding glyph codes for unicode values in given
hi-byte block of 256. */
static void
@@ -1141,7 +1657,7 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block)
{
unichar *unichars = xmalloc (0x101 * sizeof (unichar));
unsigned int i, g, idx;
- unsigned short *glyphs;
+ unsigned int *glyphs;
if (NSFONT_TRACE)
fprintf (stderr, "%p\tFinding glyphs for glyphs in block %d\n",
@@ -1149,7 +1665,7 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block)
block_input ();
- font_info->glyphs[block] = xmalloc (0x100 * sizeof (unsigned short));
+ font_info->glyphs[block] = xmalloc (0x100 * sizeof (unsigned int));
if (!unichars || !(font_info->glyphs[block]))
emacs_abort ();
@@ -1166,7 +1682,8 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block)
for (i = 0; i < 0x100; i++, glyphs++)
{
g = unichars[i];
- *glyphs = g;
+ NSGlyph glyph = ns_uni_to_glyphs_1 (font_info, g);
+ *glyphs = glyph;
}
}
@@ -1175,18 +1692,19 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block)
}
-/* Determine and cache metrics for corresponding glyph codes in given
- hi-byte block of 256. */
+/* Determine and cache metrics for glyphs in given hi-byte block of
+ 256. */
static void
-ns_glyph_metrics (struct nsfont_info *font_info, unsigned char block)
+ns_glyph_metrics (struct nsfont_info *font_info, unsigned int block)
{
- unsigned int i, g;
+ unsigned int i;
+ NSGlyph g;
unsigned int numGlyphs = [font_info->nsfont numberOfGlyphs];
NSFont *sfont;
struct font_metrics *metrics;
if (NSFONT_TRACE)
- fprintf (stderr, "%p\tComputing metrics for glyphs in block %d\n",
+ fprintf (stderr, "%p\tComputing metrics for glyphs in block %u\n",
font_info, block);
/* not implemented yet (as of startup 0.18), so punt */
@@ -1209,19 +1727,14 @@ ns_glyph_metrics (struct nsfont_info *font_info, unsigned char block)
w = max ([sfont advancementForGlyph: g].width, 2.0);
metrics->width = lrint (w);
- lb = r.origin.x;
- rb = r.size.width - w;
- // Add to bearing for LCD smoothing. We don't know if it is there.
- if (lb < 0)
- metrics->lbearing = round (lb - LCD_SMOOTHING_MARGIN);
- if (font_info->ital)
- rb += (CGFloat) (0.22F * font_info->height);
- metrics->rbearing = lrint (w + rb + LCD_SMOOTHING_MARGIN);
-
- metrics->descent = r.origin.y < 0 ? -r.origin.y : 0;
- /* lrint (hshrink * [sfont ascender] + expand * hd/2); */
- metrics->ascent = r.size.height - metrics->descent;
- /* -lrint (hshrink* [sfont descender] - expand * hd/2); */
+ lb = NSMinX (r);
+ rb = NSMaxX (r);
+
+ metrics->rbearing = lrint (rb);
+ metrics->lbearing = lrint (lb);
+
+ metrics->descent = NSMinY (r);
+ metrics->ascent = NSMaxY (r);
}
unblock_input ();
}
@@ -1257,6 +1770,7 @@ struct font_driver const nsfont_driver =
.has_char = nsfont_has_char,
.encode_char = nsfont_encode_char,
.text_extents = nsfont_text_extents,
+ .shape = nsfont_shape,
.draw = nsfont_draw,
};
@@ -1265,7 +1779,6 @@ syms_of_nsfont (void)
{
DEFSYM (Qcondensed, "condensed");
DEFSYM (Qexpanded, "expanded");
- DEFSYM (Qapple, "apple");
DEFSYM (Qmedium, "medium");
DEFVAR_LISP ("ns-reg-to-script", Vns_reg_to_script,
doc: /* Internal use: maps font registry to Unicode script. */);
diff --git a/src/nsmenu.m b/src/nsmenu.m
index 9b78643d56a..29201e69079 100644
--- a/src/nsmenu.m
+++ b/src/nsmenu.m
@@ -101,6 +101,15 @@ popup_activated (void)
static void
ns_update_menubar (struct frame *f, bool deep_p)
{
+#ifdef NS_IMPL_GNUSTEP
+ static int inside = 0;
+
+ if (inside)
+ return;
+
+ inside++;
+#endif
+
BOOL needsSet = NO;
id menu = [NSApp mainMenu];
bool owfi;
@@ -120,7 +129,12 @@ ns_update_menubar (struct frame *f, bool deep_p)
NSTRACE ("ns_update_menubar");
if (f != SELECTED_FRAME () || FRAME_EXTERNAL_MENU_BAR (f) == 0)
+ {
+#ifdef NS_IMPL_GNUSTEP
+ inside--;
+#endif
return;
+ }
XSETFRAME (Vmenu_updating_frame, f);
/*fprintf (stderr, "ns_update_menubar: frame: %p\tdeep: %d\tsub: %p\n", f, deep_p, submenu); */
@@ -144,10 +158,6 @@ ns_update_menubar (struct frame *f, bool deep_p)
t = -(1000*tb.time+tb.millitm);
#endif
-#ifdef NS_IMPL_GNUSTEP
- deep_p = 1; /* See comment in menuNeedsUpdate. */
-#endif
-
if (deep_p)
{
/* Make a widget-value tree representing the entire menu trees. */
@@ -275,6 +285,9 @@ ns_update_menubar (struct frame *f, bool deep_p)
free_menubar_widget_value_tree (first_wv);
discard_menu_items ();
unbind_to (specpdl_count, Qnil);
+#ifdef NS_IMPL_GNUSTEP
+ inside--;
+#endif
return;
}
@@ -408,6 +421,10 @@ ns_update_menubar (struct frame *f, bool deep_p)
if (needsSet)
[NSApp setMainMenu: menu];
+#ifdef NS_IMPL_GNUSTEP
+ inside--;
+#endif
+
unblock_input ();
}
@@ -452,17 +469,34 @@ set_frame_menubar (struct frame *f, bool deep_p)
call to ns_update_menubar. */
- (void)menuNeedsUpdate: (NSMenu *)menu
{
+#ifdef NS_IMPL_GNUSTEP
+ static int inside = 0;
+#endif
+
if (!FRAME_LIVE_P (SELECTED_FRAME ()))
return;
-#ifdef NS_IMPL_COCOA
-/* TODO: GNUstep calls this method when the menu is still being built
- which results in a recursive stack overflow. One possible solution
- is to use menuWillOpen instead, but the Apple docs explicitly warn
- against changing the contents of the menu in it. I don't know what
- the right thing to do for GNUstep is. */
+#ifdef NS_IMPL_GNUSTEP
+ /* GNUstep calls this method when the menu is still being built
+ which results in a recursive stack overflow, which this variable
+ prevents. */
+
+ if (!inside)
+ ++inside;
+ else
+ return;
+#endif
+
if (needsUpdate)
- ns_update_menubar (SELECTED_FRAME (), true);
+ {
+#ifdef NS_IMPL_GNUSTEP
+ needsUpdate = NO;
+#endif
+ ns_update_menubar (SELECTED_FRAME (), true);
+ }
+
+#ifdef NS_IMPL_GNUSTEP
+ --inside;
#endif
}
@@ -789,6 +823,9 @@ ns_menu_show (struct frame *f, int x, int y, int menuflags,
p.x = x; p.y = y;
+ /* Don't GC due to a mysterious bug. */
+ inhibit_garbage_collection ();
+
/* now parse stage 2 as in ns_update_menubar */
wv = make_widget_value ("contextmenu", NULL, true, Qnil);
wv->button_type = BUTTON_TYPE_NONE;
@@ -960,15 +997,17 @@ ns_menu_show (struct frame *f, int x, int y, int menuflags,
pmenu = [[EmacsMenu alloc] initWithTitle:
NILP (title) ? @"" : [NSString stringWithLispString: title]];
+ /* On GNUstep, this call makes menu_items nil for whatever reason
+ when displaying a context menu from `context-menu-mode'. */
+ Lisp_Object items = menu_items;
[pmenu fillWithWidgetValue: first_wv->contents];
+ menu_items = items;
free_menubar_widget_value_tree (first_wv);
- unbind_to (specpdl_count, Qnil);
-
popup_activated_flag = 1;
tem = [pmenu runMenuAt: p forFrame: f keymaps: keymaps];
popup_activated_flag = 0;
[[FRAME_NS_VIEW (SELECTED_FRAME ()) window] makeKeyWindow];
-
+ unbind_to (specpdl_count, Qnil);
unblock_input ();
return tem;
}
@@ -1019,6 +1058,15 @@ update_frame_tool_bar_1 (struct frame *f, EmacsToolbar *toolbar)
[toolbar clearActive];
#else
[toolbar clearAll];
+ /* It takes at least 3 such adjustments to fix an issue where the
+ tool bar is 2x too tall when a frame's tool bar is first shown.
+ This is ugly, but I have no other solution for this problem. */
+ if (FRAME_OUTPUT_DATA (f)->tool_bar_adjusted < 3)
+ {
+ [toolbar setVisible: NO];
+ FRAME_OUTPUT_DATA (f)->tool_bar_adjusted++;
+ [toolbar setVisible: YES];
+ }
#endif
/* Update EmacsToolbar as in GtkUtils, build items list. */
diff --git a/src/nsselect.m b/src/nsselect.m
index 5ab3ef77fec..8b23f6f51ad 100644
--- a/src/nsselect.m
+++ b/src/nsselect.m
@@ -215,9 +215,78 @@ ns_get_local_selection (Lisp_Object selection_name,
static Lisp_Object
ns_get_foreign_selection (Lisp_Object symbol, Lisp_Object target)
{
+ NSDictionary *typeLookup;
id pb;
pb = ns_symbol_to_pb (symbol);
- return pb != nil ? ns_string_from_pasteboard (pb) : Qnil;
+
+ /* Dictionary for looking up NS types from MIME types, and vice versa. */
+ typeLookup
+ = [NSDictionary
+ dictionaryWithObjectsAndKeys:
+ @"text/plain", NSPasteboardTypeURL,
+#if NS_USE_NSPasteboardTypeFileURL
+ @"text/plain", NSPasteboardTypeFileURL,
+#else
+ @"text/plain", NSFilenamesPboardType,
+#endif
+#ifdef NS_IMPL_COCOA
+ /* FIXME: I believe these are actually available in recent
+ versions of GNUstep. */
+ @"text/plain", NSPasteboardTypeMultipleTextSelection,
+ @"image/png", NSPasteboardTypePNG,
+#endif
+ @"text/html", NSPasteboardTypeHTML,
+ @"application/pdf", NSPasteboardTypePDF,
+ @"application/rtf", NSPasteboardTypeRTF,
+ @"application/rtfd", NSPasteboardTypeRTFD,
+ @"STRING", NSPasteboardTypeString,
+ @"text/plain", NSPasteboardTypeTabularText,
+ @"image/tiff", NSPasteboardTypeTIFF,
+ nil];
+
+ if (EQ (target, QTARGETS))
+ {
+ NSMutableArray *types = [NSMutableArray arrayWithCapacity:3];
+
+ NSString *type;
+ NSEnumerator *e = [[pb types] objectEnumerator];
+ while (type = [e nextObject])
+ {
+ NSString *val = [typeLookup valueForKey:type];
+ if (val && ! [types containsObject:val])
+ [types addObject:val];
+ }
+
+ Lisp_Object v = Fmake_vector (make_fixnum ([types count]+1), Qnil);
+ ASET (v, 0, QTARGETS);
+
+ for (int i = 0 ; i < [types count] ; i++)
+ ASET (v, i+1, intern ([[types objectAtIndex:i] UTF8String]));
+
+ return v;
+ }
+ else
+ {
+ NSData *d;
+ NSArray *availableTypes;
+ NSString *result, *t;
+
+ if (!NILP (target))
+ availableTypes
+ = [typeLookup allKeysForObject:
+ [NSString stringWithLispString:SYMBOL_NAME (target)]];
+ else
+ availableTypes = [NSArray arrayWithObject:NSPasteboardTypeString];
+
+ t = [pb availableTypeFromArray:availableTypes];
+
+ result = [pb stringForType:t];
+ if (result)
+ return [result lispString];
+
+ d = [pb dataForType:t];
+ return make_string ([d bytes], [d length]);
+ }
}
@@ -234,8 +303,6 @@ Lisp_Object
ns_string_from_pasteboard (id pb)
{
NSString *type, *str;
- const char *utfStr;
- int length;
type = [pb availableTypeFromArray: ns_return_types];
if (type == nil)
@@ -260,6 +327,14 @@ ns_string_from_pasteboard (id pb)
}
}
+ /* FIXME: Is the below EOL conversion even needed? I've removed it
+ for now so we can see if it causes problems. */
+ return [str lispString];
+
+#if 0
+ const char *utfStr;
+ int length;
+
/* assume UTF8 */
NS_DURING
{
@@ -294,6 +369,7 @@ ns_string_from_pasteboard (id pb)
NS_ENDHANDLER
return make_string (utfStr, length);
+#endif
}
@@ -491,6 +567,8 @@ syms_of_nsselect (void)
DEFSYM (QTEXT, "TEXT");
DEFSYM (QFILE_NAME, "FILE_NAME");
+ DEFSYM (QTARGETS, "TARGETS");
+
defsubr (&Sns_disown_selection_internal);
defsubr (&Sns_get_selection);
defsubr (&Sns_own_selection_internal);
diff --git a/src/nsterm.h b/src/nsterm.h
index 4bbcf43973a..ce8f5949024 100644
--- a/src/nsterm.h
+++ b/src/nsterm.h
@@ -820,7 +820,7 @@ struct nsfont_info
XCharStruct max_bounds;
/* We compute glyph codes and metrics on-demand in blocks of 256 indexed
by hibyte, lobyte. */
- unsigned short **glyphs; /* map Unicode index to glyph */
+ unsigned int **glyphs; /* map Unicode index to glyph */
struct font_metrics **metrics;
};
#endif
@@ -978,6 +978,12 @@ struct ns_output
/* Non-zero if we are doing an animation, e.g. toggling the tool bar. */
int in_animation;
+
+#ifdef NS_IMPL_GNUSTEP
+ /* Zero if this is the first time a toolbar has been updated on this
+ frame. */
+ int tool_bar_adjusted;
+#endif
};
/* This dummy declaration needed to support TTYs. */
@@ -1340,9 +1346,16 @@ enum NSWindowTabbingMode
#if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_14)
/* Deprecated in macOS 10.14. */
+/* FIXME: Some of these new names, if not all, are actually available
+ in some recent version of GNUstep. */
#define NSPasteboardTypeString NSStringPboardType
#define NSPasteboardTypeTabularText NSTabularTextPboardType
#define NSPasteboardTypeURL NSURLPboardType
+#define NSPasteboardTypeHTML NSHTMLPboardType
+#define NSPasteboardTypePDF NSPDFPboardType
+#define NSPasteboardTypeRTF NSRTFPboardType
+#define NSPasteboardTypeRTFD NSRTFDPboardType
+#define NSPasteboardTypeTIFF NSTIFFPboardType
#define NSControlStateValueOn NSOnState
#define NSControlStateValueOff NSOffState
#define NSBezelStyleRounded NSRoundedBezelStyle
diff --git a/src/nsterm.m b/src/nsterm.m
index aa29c13eb22..4e5ce5ef700 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -65,6 +65,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
#ifdef NS_IMPL_GNUSTEP
#include "process.h"
+#import <GNUstepGUI/GSDisplayServer.h>
#endif
#ifdef NS_IMPL_COCOA
@@ -534,8 +535,11 @@ ns_init_locale (void)
NSTRACE ("ns_init_locale");
- @try
+ /* If we were run from a terminal then assume an unset LANG variable
+ is intentional and don't try to "fix" it. */
+ if (!isatty (STDIN_FILENO))
{
+ char *oldLocale = setlocale (LC_ALL, NULL);
/* It seems macOS should probably use UTF-8 everywhere.
'localeIdentifier' does not specify the encoding, and I can't
find any way to get the OS to tell us which encoding to use,
@@ -543,12 +547,12 @@ ns_init_locale (void)
NSString *localeID = [NSString stringWithFormat:@"%@.UTF-8",
[locale localeIdentifier]];
- /* Set LANG to locale, but not if LANG is already set. */
- setenv("LANG", [localeID UTF8String], 0);
- }
- @catch (NSException *e)
- {
- NSLog (@"Locale detection failed: %@: %@", [e name], [e reason]);
+ /* Check the locale ID is valid and if so set LANG, but not if
+ it is already set. */
+ if (setlocale (LC_ALL, [localeID UTF8String]))
+ setenv("LANG", [localeID UTF8String], 0);
+
+ setlocale (LC_ALL, oldLocale);
}
}
@@ -1077,11 +1081,16 @@ ns_focus (struct frame *f, NSRect *r, int n)
/* clipping */
if (r)
{
- [[NSGraphicsContext currentContext] saveGraphicsState];
+ NSGraphicsContext *ctx = [NSGraphicsContext currentContext];
+ [ctx saveGraphicsState];
+#ifdef NS_IMPL_COCOA
if (n == 2)
NSRectClipList (r, 2);
else
NSRectClip (*r);
+#else
+ GSRectClipList (ctx, r, n);
+#endif
gsaved = YES;
}
}
@@ -2249,13 +2258,19 @@ frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y)
{
NSTRACE ("frame_set_mouse_pixel_position");
- /* FIXME: what about GNUstep? */
#ifdef NS_IMPL_COCOA
CGPoint mouse_pos =
CGPointMake(f->left_pos + pix_x,
f->top_pos + pix_y +
FRAME_NS_TITLEBAR_HEIGHT(f) + FRAME_TOOLBAR_HEIGHT(f));
CGWarpMouseCursorPosition (mouse_pos);
+#else
+ GSDisplayServer *server = GSServerForWindow ([FRAME_NS_VIEW (f) window]);
+ [server setMouseLocation: NSMakePoint (f->left_pos + pix_x,
+ f->top_pos + pix_y
+ + FRAME_NS_TITLEBAR_HEIGHT(f)
+ + FRAME_TOOLBAR_HEIGHT(f))
+ onScreen: [[[FRAME_NS_VIEW (f) window] screen] screenNumber]];
#endif
}
@@ -2433,9 +2448,6 @@ ns_define_frame_cursor (struct frame *f, Emacs_Cursor cursor)
EmacsView *view = FRAME_NS_VIEW (f);
FRAME_POINTER_TYPE (f) = cursor;
[[view window] invalidateCursorRectsForView: view];
- /* Redisplay assumes this function also draws the changed frame
- cursor, but this function doesn't, so do it explicitly. */
- gui_update_cursor (f, 1);
}
}
@@ -2571,8 +2583,7 @@ ns_get_shifted_character (NSEvent *event)
========================================================================== */
-#if 0
-/* FIXME: Remove this function. */
+#ifdef NS_IMPL_GNUSTEP
static void
ns_redraw_scroll_bars (struct frame *f)
{
@@ -2617,10 +2628,9 @@ ns_clear_frame (struct frame *f)
NSRectFill (r);
ns_unfocus (f);
- /* as of 2006/11 or so this is now needed */
- /* FIXME: I don't see any reason for this and removing it makes no
- difference here. Do we need it for GNUstep? */
- //ns_redraw_scroll_bars (f);
+#ifdef NS_IMPL_GNUSTEP
+ ns_redraw_scroll_bars (f);
+#endif
unblock_input ();
}
@@ -2847,31 +2857,31 @@ ns_compute_glyph_string_overhangs (struct glyph_string *s)
External (RIF); compute left/right overhang of whole string and set in s
-------------------------------------------------------------------------- */
{
- struct font *font = s->font;
-
- if (s->char2b)
+ if (s->cmp == NULL
+ && (s->first_glyph->type == CHAR_GLYPH
+ || s->first_glyph->type == COMPOSITE_GLYPH))
{
struct font_metrics metrics;
- unsigned int codes[2];
- codes[0] = *(s->char2b);
- codes[1] = *(s->char2b + s->nchars - 1);
- font->driver->text_extents (font, codes, 2, &metrics);
- s->left_overhang = -metrics.lbearing;
- s->right_overhang
- = metrics.rbearing > metrics.width
- ? metrics.rbearing - metrics.width : 0;
+ 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
+ else if (s->cmp)
{
- s->left_overhang = 0;
-#ifdef NS_IMPL_GNUSTEP
- if (EQ (font->driver->type, Qns))
- s->right_overhang = ((struct nsfont_info *)font)->ital ?
- FONT_HEIGHT (font) * 0.2 : 0;
- else
-#endif
- s->right_overhang = 0;
+ s->right_overhang = s->cmp->rbearing - s->cmp->pixel_width;
+ s->left_overhang = - s->cmp->lbearing;
}
}
@@ -3011,14 +3021,13 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row,
struct frame *f = WINDOW_XFRAME (w);
struct glyph *phys_cursor_glyph;
struct glyph *cursor_glyph;
- struct face *face;
- NSColor *hollow_color = FRAME_BACKGROUND_COLOR (f);
/* 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. */
- NSTRACE ("ns_draw_window_cursor");
+ NSTRACE ("ns_draw_window_cursor (on = %d, cursor_type = %d)",
+ on_p, cursor_type);
if (!on_p)
return;
@@ -3034,6 +3043,8 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row,
if ((phys_cursor_glyph = get_phys_cursor_glyph (w)) == NULL)
{
+ NSTRACE_MSG ("No phys cursor glyph was found!");
+
if (glyph_row->exact_window_width_line_p
&& w->phys_cursor.hpos >= glyph_row->used[TEXT_AREA])
{
@@ -3043,10 +3054,6 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row,
return;
}
- /* We draw the cursor (with NSRectFill), then draw the glyph on top
- (other terminals do it the other way round). We must set
- w->phys_cursor_width to the cursor width. For bar cursors, that
- is CURSOR_WIDTH; for box cursors, it is the glyph width. */
get_phys_cursor_geometry (w, glyph_row, phys_cursor_glyph, &fx, &fy, &h);
/* The above get_phys_cursor_geometry call set w->phys_cursor_width
@@ -3078,17 +3085,17 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row,
/* Prevent the cursor from being drawn outside the text area. */
r = NSIntersectionRect (r, ns_row_rect (w, glyph_row, TEXT_AREA));
- ns_focus (f, &r, 1);
+ ns_focus (f, NULL, 0);
- face = FACE_FROM_ID_OR_NULL (f, phys_cursor_glyph->face_id);
- if (face && NS_FACE_BACKGROUND (face)
- == ns_index_color (FRAME_CURSOR_COLOR (f), f))
- {
- [ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), f) set];
- hollow_color = FRAME_CURSOR_COLOR (f);
- }
- else
- [FRAME_CURSOR_COLOR (f) set];
+ NSGraphicsContext *ctx = [NSGraphicsContext currentContext];
+ [ctx saveGraphicsState];
+#ifdef NS_IMPL_GNUSTEP
+ GSRectClipList (ctx, &r, 1);
+#else
+ NSRectClip (r);
+#endif
+
+ [FRAME_CURSOR_COLOR (f) set];
switch (cursor_type)
{
@@ -3096,13 +3103,11 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row,
case NO_CURSOR:
break;
case FILLED_BOX_CURSOR:
- NSRectFill (r);
+ draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR);
break;
case HOLLOW_BOX_CURSOR:
- NSRectFill (r);
- [hollow_color set];
- NSRectFill (NSInsetRect (r, 1, 1));
- [FRAME_CURSOR_COLOR (f) set];
+ draw_phys_cursor_glyph (w, glyph_row, DRAW_NORMAL_TEXT);
+ [NSBezierPath strokeRect: r];
break;
case HBAR_CURSOR:
NSRectFill (r);
@@ -3118,12 +3123,9 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row,
NSRectFill (s);
break;
}
- ns_unfocus (f);
- /* Draw the character under the cursor. Other terms only draw
- the character on top of box cursors, so do the same here. */
- if (cursor_type == FILLED_BOX_CURSOR || cursor_type == HOLLOW_BOX_CURSOR)
- draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR);
+ [ctx restoreGraphicsState];
+ ns_unfocus (f);
}
@@ -3303,14 +3305,17 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face,
if (s->for_overlaps)
return;
+ if (s->hl == DRAW_CURSOR)
+ [FRAME_BACKGROUND_COLOR (s->f) set];
+ else
+ [defaultCol set];
+
/* Do underline. */
if (face->underline)
{
if (s->face->underline == FACE_UNDER_WAVE)
{
- if (face->underline_defaulted_p)
- [defaultCol set];
- else
+ if (!face->underline_defaulted_p)
[ns_lookup_indexed_color (face->underline_color, s->f) set];
ns_draw_underwave (s, width, x);
@@ -3384,9 +3389,7 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face,
r = NSMakeRect (x, s->ybase + position, width, thickness);
- if (face->underline_defaulted_p)
- [defaultCol set];
- else
+ if (!face->underline_defaulted_p)
[ns_lookup_indexed_color (face->underline_color, s->f) set];
NSRectFill (r);
}
@@ -3398,10 +3401,9 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face,
NSRect r;
r = NSMakeRect (x, s->y, width, 1);
- if (face->overline_color_defaulted_p)
- [defaultCol set];
- else
+ if (!face->overline_color_defaulted_p)
[ns_lookup_indexed_color (face->overline_color, s->f) set];
+
NSRectFill (r);
}
@@ -3424,10 +3426,9 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face,
dy = lrint ((glyph_height - h) / 2);
r = NSMakeRect (x, glyph_y + dy, width, 1);
- if (face->strike_through_color_defaulted_p)
- [defaultCol set];
- else
+ if (!face->strike_through_color_defaulted_p)
[ns_lookup_indexed_color (face->strike_through_color, s->f) set];
+
NSRectFill (r);
}
}
@@ -3575,17 +3576,7 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s)
struct glyph *last_glyph;
NSRect r;
int hthickness, vthickness;
- struct face *face;
-
- if (s->hl == DRAW_MOUSE_FACE)
- {
- face = FACE_FROM_ID_OR_NULL (s->f,
- MOUSE_HL_INFO (s->f)->mouse_face_face_id);
- if (!face)
- face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
- }
- else
- face = s->face;
+ struct face *face = s->face;
vthickness = face->box_vertical_line_width;
hthickness = face->box_horizontal_line_width;
@@ -3659,34 +3650,26 @@ ns_maybe_dumpglyphs_background (struct glyph_string *s, char force_p)
|| FONT_TOO_HIGH (s->font)
|| s->font_not_found_p || s->extends_to_end_of_line_p || force_p)
{
- struct face *face;
- if (s->hl == DRAW_MOUSE_FACE)
- {
- face
- = FACE_FROM_ID_OR_NULL (s->f,
- MOUSE_HL_INFO (s->f)->mouse_face_face_id);
- if (!face)
- face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
- }
- else
- face = FACE_FROM_ID (s->f, s->first_glyph->face_id);
+ struct face *face = s->face;
if (!face->stipple)
- [(NS_FACE_BACKGROUND (face) != 0
- ? ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f)
- : FRAME_BACKGROUND_COLOR (s->f)) set];
+ {
+ if (s->hl != DRAW_CURSOR)
+ [(NS_FACE_BACKGROUND (face) != 0
+ ? ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f)
+ : FRAME_BACKGROUND_COLOR (s->f)) set];
+ else
+ [FRAME_CURSOR_COLOR (s->f) set];
+ }
else
{
struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (s->f);
[[dpyinfo->bitmaps[face->stipple-1].img stippleMask] set];
}
- if (s->hl != DRAW_CURSOR)
- {
- NSRect r = NSMakeRect (s->x, s->y + box_line_width,
- s->background_width,
- s->height-2*box_line_width);
- NSRectFill (r);
- }
+ NSRect r = NSMakeRect (s->x, s->y + box_line_width,
+ s->background_width,
+ s->height-2*box_line_width);
+ NSRectFill (r);
s->background_filled_p = 1;
}
@@ -3707,7 +3690,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r)
int th;
char raised_p;
NSRect br;
- struct face *face;
+ struct face *face = s->face;
NSColor *tdCol;
NSTRACE ("ns_dumpglyphs_image");
@@ -3728,15 +3711,6 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r)
/* Draw BG: if we need larger area than image itself cleared, do that,
otherwise, since we composite the image under NS (instead of mucking
with its background color), we must clear just the image area. */
- if (s->hl == DRAW_MOUSE_FACE)
- {
- face = FACE_FROM_ID_OR_NULL (s->f,
- MOUSE_HL_INFO (s->f)->mouse_face_face_id);
- if (!face)
- face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
- }
- else
- face = FACE_FROM_ID (s->f, s->first_glyph->face_id);
[ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f) set];
@@ -3807,16 +3781,8 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r)
if (s->hl == DRAW_CURSOR)
{
- [FRAME_CURSOR_COLOR (s->f) set];
- if (s->w->phys_cursor_type == FILLED_BOX_CURSOR)
+ [FRAME_CURSOR_COLOR (s->f) set];
tdCol = ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f);
- else
- /* Currently on NS img->mask is always 0. Since
- get_window_cursor_type specifies a hollow box cursor when on
- a non-masked image we never reach this clause. But we put it
- in, in anticipation of better support for image masks on
- NS. */
- tdCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f);
}
else
{
@@ -3868,66 +3834,39 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r)
static void
ns_dumpglyphs_stretch (struct glyph_string *s)
{
- NSRect r[2];
NSRect glyphRect;
- int n;
- struct face *face;
+ struct face *face = s->face;
NSColor *fgCol, *bgCol;
if (!s->background_filled_p)
{
- n = ns_get_glyph_string_clip_rect (s, r);
- ns_focus (s->f, r, n);
- if (s->hl == DRAW_MOUSE_FACE)
- {
- face = FACE_FROM_ID_OR_NULL (s->f,
- MOUSE_HL_INFO (s->f)->mouse_face_face_id);
- if (!face)
- face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
- }
- else
- face = FACE_FROM_ID (s->f, s->first_glyph->face_id);
+ face = s->face;
bgCol = ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f);
fgCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f);
+ if (s->hl == DRAW_CURSOR)
+ {
+ fgCol = bgCol;
+ bgCol = FRAME_CURSOR_COLOR (s->f);
+ }
+
glyphRect = NSMakeRect (s->x, s->y, s->background_width, s->height);
[bgCol set];
- /* NOTE: under NS this is NOT used to draw cursors, but we must avoid
- overwriting cursor (usually when cursor on a tab) */
- if (s->hl == DRAW_CURSOR)
- {
- CGFloat x, width;
-
- /* FIXME: This looks like it will only work for left to
- right languages. */
- x = NSMinX (glyphRect);
- width = s->w->phys_cursor_width;
- glyphRect.size.width -= width;
- glyphRect.origin.x += width;
+ NSRectFill (glyphRect);
- NSRectFill (glyphRect);
+ /* Draw overlining, etc. on the stretch glyph (or the part of
+ the stretch glyph after the cursor). If the glyph has a box,
+ then decorations will be drawn after drawing the box in
+ ns_draw_glyph_string, in order to prevent them from being
+ overwritten by the box. */
+ if (s->face->box != FACE_NO_BOX)
+ ns_draw_text_decoration (s, face, fgCol, NSWidth (glyphRect),
+ NSMinX (glyphRect));
- /* Draw overlining, etc. on the cursor. */
- if (s->w->phys_cursor_type == FILLED_BOX_CURSOR)
- ns_draw_text_decoration (s, face, bgCol, width, x);
- else
- ns_draw_text_decoration (s, face, fgCol, width, x);
- }
- else
- {
- NSRectFill (glyphRect);
- }
-
- /* Draw overlining, etc. on the stretch glyph (or the part
- of the stretch glyph after the cursor). */
- ns_draw_text_decoration (s, face, fgCol, NSWidth (glyphRect),
- NSMinX (glyphRect));
-
- ns_unfocus (s->f);
s->background_filled_p = 1;
}
}
@@ -3936,7 +3875,7 @@ ns_dumpglyphs_stretch (struct glyph_string *s)
static void
ns_draw_glyph_string_foreground (struct glyph_string *s)
{
- int x, flags;
+ int x;
struct font *font = s->font;
/* If first glyph of S has a left box line, start drawing the text
@@ -3947,15 +3886,9 @@ ns_draw_glyph_string_foreground (struct glyph_string *s)
else
x = s->x;
- flags = s->hl == DRAW_CURSOR ? NS_DUMPGLYPH_CURSOR :
- (s->hl == DRAW_MOUSE_FACE ? NS_DUMPGLYPH_MOUSEFACE :
- (s->for_overlaps ? NS_DUMPGLYPH_FOREGROUND :
- NS_DUMPGLYPH_NORMAL));
-
font->driver->draw
(s, s->cmp_from, s->nchars, x, s->ybase,
- (flags == NS_DUMPGLYPH_NORMAL && !s->background_filled_p)
- || flags == NS_DUMPGLYPH_MOUSEFACE);
+ !s->for_overlaps && !s->background_filled_p);
}
@@ -4062,9 +3995,9 @@ ns_draw_glyph_string (struct glyph_string *s)
struct font *font = s->face->font;
if (! font) font = FRAME_FONT (s->f);
- NSTRACE_WHEN (NSTRACE_GROUP_GLYPHS, "ns_draw_glyph_string");
+ NSTRACE ("ns_draw_glyph_string (hl = %u)", s->hl);
- if (s->next && s->right_overhang && !s->for_overlaps/*&&s->hl!=DRAW_CURSOR*/)
+ if (s->next && s->right_overhang && !s->for_overlaps)
{
int width;
struct glyph_string *next;
@@ -4074,17 +4007,17 @@ ns_draw_glyph_string (struct glyph_string *s)
width += next->width, next = next->next)
if (next->first_glyph->type != IMAGE_GLYPH)
{
+ n = ns_get_glyph_string_clip_rect (s->next, r);
+ ns_focus (s->f, r, n);
if (next->first_glyph->type != STRETCH_GLYPH)
{
- n = ns_get_glyph_string_clip_rect (s->next, r);
- ns_focus (s->f, r, n);
ns_maybe_dumpglyphs_background (s->next, 1);
- ns_unfocus (s->f);
}
else
{
ns_dumpglyphs_stretch (s->next);
}
+ ns_unfocus (s->f);
next->num_clips = 0;
}
}
@@ -4101,14 +4034,21 @@ ns_draw_glyph_string (struct glyph_string *s)
box_drawn_p = 1;
}
+ n = ns_get_glyph_string_clip_rect (s, r);
+
+ 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)))
+ r[0] = NSIntersectionRect (r[0], NSMakeRect (s->x, s->y, s->width, s->height));
+
+ ns_focus (s->f, r, n);
+
switch (s->first_glyph->type)
{
case IMAGE_GLYPH:
- n = ns_get_glyph_string_clip_rect (s, r);
- ns_focus (s->f, r, n);
ns_dumpglyphs_image (s, r[0]);
- ns_unfocus (s->f);
break;
case XWIDGET_GLYPH:
@@ -4121,57 +4061,35 @@ ns_draw_glyph_string (struct glyph_string *s)
case CHAR_GLYPH:
case COMPOSITE_GLYPH:
- n = ns_get_glyph_string_clip_rect (s, r);
- ns_focus (s->f, r, n);
-
- if (s->for_overlaps || (s->cmp_from > 0
- && ! s->first_glyph->u.cmp.automatic))
- s->background_filled_p = 1;
- else
- ns_maybe_dumpglyphs_background
- (s, s->first_glyph->type == COMPOSITE_GLYPH);
-
- if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR)
- {
- unsigned long tmp = NS_FACE_BACKGROUND (s->face);
- NS_FACE_BACKGROUND (s->face) = NS_FACE_FOREGROUND (s->face);
- NS_FACE_FOREGROUND (s->face) = tmp;
- }
-
{
- BOOL isComposite = s->first_glyph->type == COMPOSITE_GLYPH;
+ BOOL isComposite = s->first_glyph->type == COMPOSITE_GLYPH;
+ if (s->for_overlaps || (isComposite
+ && (s->cmp_from > 0
+ && ! s->first_glyph->u.cmp.automatic)))
+ s->background_filled_p = 1;
+ else
+ ns_maybe_dumpglyphs_background
+ (s, s->first_glyph->type == COMPOSITE_GLYPH);
- if (isComposite)
- ns_draw_composite_glyph_string_foreground (s);
- else
- ns_draw_glyph_string_foreground (s);
- }
+ if (isComposite)
+ ns_draw_composite_glyph_string_foreground (s);
+ else
+ ns_draw_glyph_string_foreground (s);
- {
- NSColor *col = (NS_FACE_FOREGROUND (s->face) != 0
- ? ns_lookup_indexed_color (NS_FACE_FOREGROUND (s->face),
- s->f)
- : FRAME_FOREGROUND_COLOR (s->f));
- [col set];
-
- /* Draw underline, overline, strike-through. */
- ns_draw_text_decoration (s, s->face, col, s->width, s->x);
- }
+ {
+ NSColor *col = (NS_FACE_FOREGROUND (s->face) != 0
+ ? ns_lookup_indexed_color (NS_FACE_FOREGROUND (s->face),
+ s->f)
+ : FRAME_FOREGROUND_COLOR (s->f));
- if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR)
- {
- unsigned long tmp = NS_FACE_BACKGROUND (s->face);
- NS_FACE_BACKGROUND (s->face) = NS_FACE_FOREGROUND (s->face);
- NS_FACE_FOREGROUND (s->face) = tmp;
- }
+ /* Draw underline, overline, strike-through. */
+ ns_draw_text_decoration (s, s->face, col, s->width, s->x);
+ }
+ }
- ns_unfocus (s->f);
break;
case GLYPHLESS_GLYPH:
- n = ns_get_glyph_string_clip_rect (s, r);
- ns_focus (s->f, r, n);
-
if (s->for_overlaps || (s->cmp_from > 0
&& ! s->first_glyph->u.cmp.automatic))
s->background_filled_p = 1;
@@ -4181,7 +4099,6 @@ ns_draw_glyph_string (struct glyph_string *s)
/* ... */
/* Not yet implemented. */
/* ... */
- ns_unfocus (s->f);
break;
default:
@@ -4190,13 +4107,102 @@ ns_draw_glyph_string (struct glyph_string *s)
/* Draw box if not done already. */
if (!s->for_overlaps && !box_drawn_p && s->face->box != FACE_NO_BOX)
+ ns_dumpglyphs_box_or_relief (s);
+
+ if (s->face->box != FACE_NO_BOX
+ && s->first_glyph->type == STRETCH_GLYPH)
{
- n = ns_get_glyph_string_clip_rect (s, r);
- ns_focus (s->f, r, n);
- ns_dumpglyphs_box_or_relief (s);
+ NSColor *fg_color;
+
+ fg_color = ns_lookup_indexed_color (NS_FACE_FOREGROUND (s->face), s->f);
+ ns_draw_text_decoration (s, s->face, fg_color,
+ s->background_width, s->x);
+ }
+
+ ns_unfocus (s->f);
+
+ /* Draw surrounding overhangs. */
+ if (s->prev)
+ {
+ ns_focus (s->f, NULL, 0);
+ 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;
+ struct face *save_face = prev->face;
+
+ prev->face = s->face;
+ NSRect r = NSMakeRect (s->x, s->y, s->width, s->height);
+ [[NSGraphicsContext currentContext] saveGraphicsState];
+ NSRectClip (r);
+#ifdef NS_IMPL_GNUSTEP
+ DPSgsave ([NSGraphicsContext currentContext]);
+ DPSrectclip ([NSGraphicsContext currentContext], s->x, s->y,
+ s->width, s->height);
+#endif
+ prev->num_clips = 1;
+ prev->hl = s->hl;
+ if (prev->first_glyph->type == CHAR_GLYPH)
+ ns_draw_glyph_string_foreground (prev);
+ else
+ ns_draw_composite_glyph_string_foreground (prev);
+#ifdef NS_IMPL_GNUSTEP
+ DPSgrestore ([NSGraphicsContext currentContext]);
+#endif
+ [[NSGraphicsContext currentContext] restoreGraphicsState];
+ prev->hl = save;
+ prev->face = save_face;
+ prev->num_clips = 0;
+ }
ns_unfocus (s->f);
}
+ if (s->next)
+ {
+ ns_focus (s->f, NULL, 0);
+ 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;
+ struct face *save_face = next->face;
+
+ next->hl = s->hl;
+ next->face = s->face;
+ NSRect r = NSMakeRect (s->x, s->y, s->width, s->height);
+ [[NSGraphicsContext currentContext] saveGraphicsState];
+ NSRectClip (r);
+#ifdef NS_IMPL_GNUSTEP
+ DPSgsave ([NSGraphicsContext currentContext]);
+ DPSrectclip ([NSGraphicsContext currentContext], s->x, s->y,
+ s->width, s->height);
+#endif
+ next->num_clips = 1;
+ if (next->first_glyph->type == CHAR_GLYPH)
+ ns_draw_glyph_string_foreground (next);
+ else
+ ns_draw_composite_glyph_string_foreground (next);
+#ifdef NS_IMPL_GNUSTEP
+ DPSgrestore ([NSGraphicsContext currentContext]);
+#endif
+ [[NSGraphicsContext currentContext] restoreGraphicsState];
+ next->hl = save;
+ next->num_clips = 0;
+ next->face = save_face;
+ next->clip_head = next;
+ next->background_filled_p = 0;
+ }
+ ns_unfocus (s->f);
+ }
s->num_clips = 0;
}
@@ -4946,6 +4952,17 @@ ns_default_font_parameter (struct frame *f, Lisp_Object parms)
{
}
+#ifdef NS_IMPL_GNUSTEP
+static void
+ns_update_window_end (struct window *w, bool cursor_on_p,
+ bool mouse_face_overwritten_p)
+{
+ NSTRACE ("ns_update_window_end (cursor_on_p = %d)", cursor_on_p);
+
+ ns_redraw_scroll_bars (WINDOW_XFRAME (w));
+}
+#endif
+
/* This and next define (many of the) public functions in this file. */
/* gui_* are generic versions in xdisp.c that we, and other terms, get away
with using despite presence in the "system dependent" redisplay
@@ -4962,7 +4979,11 @@ static struct redisplay_interface ns_redisplay_interface =
ns_scroll_run,
ns_after_update_window_line,
NULL, /* update_window_begin */
+#ifndef NS_IMPL_GNUSTEP
NULL, /* update_window_end */
+#else
+ ns_update_window_end,
+#endif
0, /* flush_display */
gui_clear_window_mouse_face,
gui_get_glyph_overhangs,
@@ -6189,9 +6210,11 @@ not_in_argv (NSString *arg)
Lisp_Object kind = fnKeysym ? QCfunction : QCordinary;
emacs_event->modifiers = EV_MODIFIERS2 (flags, kind);
+#ifndef NS_IMPL_GNUSTEP
if (NS_KEYLOG)
fprintf (stderr, "keyDown: code =%x\tfnKey =%x\tflags = %x\tmods = %x\n",
code, fnKeysym, flags, emacs_event->modifiers);
+#endif
/* If it was a function key or had control-like modifiers, pass
it directly to Emacs. */
@@ -6561,6 +6584,7 @@ not_in_argv (NSString *arg)
*/
bool horizontal;
int lines = 0;
+ int x = 0, y = 0;
int scrollUp = NO;
/* FIXME: At the top or bottom of the buffer we should
@@ -6596,23 +6620,33 @@ not_in_argv (NSString *arg)
* reset the total delta for the direction we're NOT
* scrolling so that small movements don't add up. */
if (abs (totalDeltaX) > abs (totalDeltaY)
- && abs (totalDeltaX) > lineHeight)
+ && (!mwheel_coalesce_scroll_events
+ || abs (totalDeltaX) > lineHeight))
{
horizontal = YES;
scrollUp = totalDeltaX > 0;
lines = abs (totalDeltaX / lineHeight);
- totalDeltaX = totalDeltaX % lineHeight;
+ x = totalDeltaX;
+ if (!mwheel_coalesce_scroll_events)
+ totalDeltaX = 0;
+ else
+ totalDeltaX = totalDeltaX % lineHeight;
totalDeltaY = 0;
}
else if (abs (totalDeltaY) >= abs (totalDeltaX)
- && abs (totalDeltaY) > lineHeight)
+ && (!mwheel_coalesce_scroll_events
+ || abs (totalDeltaY) > lineHeight))
{
horizontal = NO;
scrollUp = totalDeltaY > 0;
lines = abs (totalDeltaY / lineHeight);
- totalDeltaY = totalDeltaY % lineHeight;
+ y = totalDeltaY;
+ if (!mwheel_coalesce_scroll_events)
+ totalDeltaY = 0;
+ else
+ totalDeltaY = totalDeltaY % lineHeight;
totalDeltaX = 0;
}
@@ -6638,13 +6672,25 @@ not_in_argv (NSString *arg)
? ceil (fabs (delta)) : 1;
scrollUp = delta > 0;
+ x = ([theEvent scrollingDeltaX]
+ * FRAME_COLUMN_WIDTH (emacsframe));
+ y = ([theEvent scrollingDeltaY]
+ * FRAME_LINE_HEIGHT (emacsframe));
}
- if (lines == 0)
+ if (lines == 0 && mwheel_coalesce_scroll_events)
return;
+ if (NUMBERP (Vns_scroll_event_delta_factor))
+ {
+ x *= XFLOATINT (Vns_scroll_event_delta_factor);
+ y *= XFLOATINT (Vns_scroll_event_delta_factor);
+ }
+
emacs_event->kind = horizontal ? HORIZ_WHEEL_EVENT : WHEEL_EVENT;
- emacs_event->arg = (make_fixnum (lines));
+ emacs_event->arg = list3 (make_fixnum (lines),
+ make_float (x),
+ make_float (y));
emacs_event->code = 0;
emacs_event->modifiers = EV_MODIFIERS (theEvent) |
@@ -6704,6 +6750,11 @@ not_in_argv (NSString *arg)
emacs_event->code = EV_BUTTON (theEvent);
emacs_event->modifiers = EV_MODIFIERS (theEvent)
| EV_UDMODIFIERS (theEvent);
+
+ if (emacs_event->modifiers & down_modifier)
+ FRAME_DISPLAY_INFO (emacsframe)->grabbed |= 1 << EV_BUTTON (theEvent);
+ else
+ FRAME_DISPLAY_INFO (emacsframe)->grabbed &= ~(1 << EV_BUTTON (theEvent));
}
XSETINT (emacs_event->x, lrint (p.x));
@@ -7004,7 +7055,6 @@ not_in_argv (NSString *arg)
height = (int)NSHeight (frame);
NSTRACE_SIZE ("New size", NSMakeSize (width, height));
- NSTRACE_SIZE ("Original size", size);
/* Reset the frame size to match the bounds of the superview (the
NSWindow's contentView). We need to do this as sometimes the
@@ -7073,6 +7123,7 @@ not_in_argv (NSString *arg)
XSETFRAME (frame, emacsframe);
help_echo_string = Qnil;
gen_help_event (Qnil, frame, Qnil, Qnil, 0);
+ any_help_event_p = NO;
}
if (emacs_event && is_focus_frame)
@@ -10001,8 +10052,15 @@ This variable is ignored on macOS < 10.7 and GNUstep. Default is t. */);
x_underline_at_descent_line,
doc: /* SKIP: real doc in xterm.c. */);
x_underline_at_descent_line = 0;
+
DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line");
+ DEFVAR_LISP ("ns-scroll-event-delta-factor", Vns_scroll_event_delta_factor,
+ doc: /* A factor to apply to pixel deltas reported in scroll events.
+ This is only effective for pixel deltas generated from touch pads or
+ mice with smooth scrolling capability. */);
+ Vns_scroll_event_delta_factor = make_float (1.0);
+
/* Tell Emacs about this window system. */
Fprovide (Qns, Qnil);
diff --git a/src/pdumper.c b/src/pdumper.c
index 2782648e7ab..554b53020e0 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -312,14 +312,15 @@ dump_reloc_set_offset (struct dump_reloc *reloc, dump_off offset)
error ("dump relocation out of range");
}
-static void
-dump_fingerprint (char const *label,
+void
+dump_fingerprint (FILE *output, char const *label,
unsigned char const xfingerprint[sizeof fingerprint])
{
enum { hexbuf_size = 2 * sizeof fingerprint };
char hexbuf[hexbuf_size];
hexbuf_digest (hexbuf, xfingerprint, sizeof fingerprint);
- fprintf (stderr, "%s: %.*s\n", label, hexbuf_size, hexbuf);
+ fprintf (output, "%s%s%.*s\n", label, *label ? ": " : "",
+ hexbuf_size, hexbuf);
}
/* To be used if some order in the relocation process has to be enforced. */
@@ -2947,7 +2948,7 @@ dump_vectorlike (struct dump_context *ctx,
Lisp_Object lv,
dump_off offset)
{
-#if CHECK_STRUCTS && !defined HASH_pvec_type_F5BA506141
+#if CHECK_STRUCTS && !defined HASH_pvec_type_19F6CF5169
# error "pvec_type changed. See CHECK_STRUCTS comment in config.h."
#endif
const struct Lisp_Vector *v = XVECTOR (lv);
@@ -3027,6 +3028,8 @@ dump_vectorlike (struct dump_context *ctx,
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");
default:
@@ -4129,7 +4132,7 @@ types. */)
ctx->header.fingerprint[i] = fingerprint[i];
const dump_off header_start = ctx->offset;
- dump_fingerprint ("Dumping fingerprint", ctx->header.fingerprint);
+ dump_fingerprint (stderr, "Dumping fingerprint", ctx->header.fingerprint);
dump_write (ctx, &ctx->header, sizeof (ctx->header));
const dump_off header_end = ctx->offset;
@@ -5350,7 +5353,7 @@ dump_do_dump_relocation (const uintptr_t dump_base,
their file names through expand-file-name and
decode-coding-string. */
comp_u->file = eln_fname;
- comp_u->handle = dynlib_open (SSDATA (eln_fname));
+ comp_u->handle = dynlib_open_for_eln (SSDATA (eln_fname));
if (!comp_u->handle)
{
fprintf (stderr, "Error using execdir %s:\n",
@@ -5597,8 +5600,8 @@ pdumper_load (const char *dump_filename, char *argv0)
desired[i] = fingerprint[i];
if (memcmp (header->fingerprint, desired, sizeof desired) != 0)
{
- dump_fingerprint ("desired fingerprint", desired);
- dump_fingerprint ("found fingerprint", header->fingerprint);
+ dump_fingerprint (stderr, "desired fingerprint", desired);
+ dump_fingerprint (stderr, "found fingerprint", header->fingerprint);
goto out;
}
@@ -5706,6 +5709,7 @@ pdumper_load (const char *dump_filename, char *argv0)
dump_mmap_release (&sections[i]);
if (dump_fd >= 0)
emacs_close (dump_fd);
+
return err;
}
@@ -5790,6 +5794,7 @@ syms_of_pdumper (void)
DEFSYM (Qdumped_with_pdumper, "dumped-with-pdumper");
DEFSYM (Qload_time, "load-time");
DEFSYM (Qdump_file_name, "dump-file-name");
+ DEFSYM (Qafter_pdump_load_hook, "after-pdump-load-hook");
defsubr (&Spdumper_stats);
#endif /* HAVE_PDUMPER */
}
diff --git a/src/pdumper.h b/src/pdumper.h
index deec9af046d..7f1f5e46ad9 100644
--- a/src/pdumper.h
+++ b/src/pdumper.h
@@ -20,6 +20,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifndef EMACS_PDUMPER_H
#define EMACS_PDUMPER_H
+#include <stdio.h>
+#include "fingerprint.h"
#include "lisp.h"
INLINE_HEADER_BEGIN
@@ -50,6 +52,9 @@ enum { PDUMPER_NO_OBJECT = -1 };
#define PDUMPER_REMEMBER_SCALAR(thing) \
pdumper_remember_scalar (&(thing), sizeof (thing))
+extern void dump_fingerprint (FILE *output, const char *label,
+ unsigned char const fingerp[sizeof fingerprint]);
+
extern void pdumper_remember_scalar_impl (void *data, ptrdiff_t nbytes);
INLINE void
diff --git a/src/pgtkfns.c b/src/pgtkfns.c
new file mode 100644
index 00000000000..44e3d2a37e2
--- /dev/null
+++ b/src/pgtkfns.c
@@ -0,0 +1,4144 @@
+/* Functions for the pure Gtk+-3.
+
+Copyright (C) 1989, 1992-1994, 2005-2006, 2008-2020 Free Software
+Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+
+/* This should be the first include, as it may set up #defines affecting
+ interpretation of even the system includes. */
+#include <config.h>
+
+#include <math.h>
+#include <c-strcase.h>
+
+#include "lisp.h"
+#include "blockinput.h"
+#include "gtkutil.h"
+#include "window.h"
+#include "character.h"
+#include "buffer.h"
+#include "keyboard.h"
+#include "termhooks.h"
+#include "fontset.h"
+#include "font.h"
+#include "xsettings.h"
+#include "atimer.h"
+
+
+#ifdef HAVE_PGTK
+
+/* Static variables to handle applescript execution. */
+static Lisp_Object as_script, *as_result;
+static int as_status;
+
+static ptrdiff_t image_cache_refcount;
+
+static int x_decode_color (struct frame *f, Lisp_Object color_name,
+ int mono_color);
+static struct pgtk_display_info *pgtk_display_info_for_name (Lisp_Object);
+
+static const char *pgtk_app_name = "Emacs";
+
+/* Scale factor manually set per monitor. */
+static Lisp_Object monitor_scale_factor_alist;
+
+/* ==========================================================================
+
+ Internal utility functions
+
+ ========================================================================== */
+
+static double
+pgtk_get_monitor_scale_factor (const char *model)
+{
+ if (model == NULL)
+ return 0.0;
+
+ Lisp_Object mdl = build_string (model);
+ Lisp_Object tem = Fassoc (mdl, monitor_scale_factor_alist, Qnil);
+ if (NILP (tem))
+ return 0;
+ Lisp_Object cdr = Fcdr (tem);
+ if (NILP (cdr))
+ return 0;
+ if (FIXNUMP (cdr))
+ return XFIXNUM (cdr);
+ else if (FLOATP (cdr))
+ return XFLOAT_DATA (cdr);
+ else
+ error ("unknown type of scale-factor");
+}
+
+struct pgtk_display_info *
+check_pgtk_display_info (Lisp_Object object)
+{
+ struct pgtk_display_info *dpyinfo = NULL;
+
+ if (NILP (object))
+ {
+ struct frame *sf = XFRAME (selected_frame);
+
+ if (FRAME_PGTK_P (sf) && FRAME_LIVE_P (sf))
+ dpyinfo = FRAME_DISPLAY_INFO (sf);
+ else if (x_display_list != 0)
+ dpyinfo = x_display_list;
+ else
+ error ("Frames are not in use or not initialized");
+ }
+ else if (TERMINALP (object))
+ {
+ struct terminal *t = decode_live_terminal (object);
+
+ if (t->type != output_pgtk)
+ error ("Terminal %d is not a display", t->id);
+
+ dpyinfo = t->display_info.pgtk;
+ }
+ else if (STRINGP (object))
+ dpyinfo = pgtk_display_info_for_name (object);
+ else
+ {
+ struct frame *f = decode_window_system_frame (object);
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+ }
+
+ return dpyinfo;
+}
+
+/* On Wayland, even if without WAYLAND_DISPLAY, --display DISPLAY
+ works, but gdk_display_get_name always return "wayland-0", which
+ may be different from DISPLAY. If with WAYLAND_DISPLAY, then it
+ always returns WAYLAND_DISPLAY. So pgtk Emacs is confused and
+ enters multi display environment. To workaround this situation,
+ treat all the wayland-* as the same display. */
+static Lisp_Object
+is_wayland_display (Lisp_Object dpyname)
+{
+ const char *p = SSDATA (dpyname);
+ if (strncmp (p, "wayland-", 8) != 0)
+ return Qnil;
+ p += 8;
+ do {
+ if (*p < '0' || *p > '9')
+ return Qnil;
+ } while (*++p != '\0');
+ return Qt;
+}
+
+/* Return the X display structure for the display named NAME.
+ Open a new connection if necessary. */
+static struct pgtk_display_info *
+pgtk_display_info_for_name (Lisp_Object name)
+{
+ struct pgtk_display_info *dpyinfo;
+
+ CHECK_STRING (name);
+
+ if (!NILP (is_wayland_display (name)))
+ {
+ for (dpyinfo = x_display_list; dpyinfo; dpyinfo = dpyinfo->next)
+ if (!NILP (is_wayland_display (XCAR (dpyinfo->name_list_element))))
+ return dpyinfo;
+ }
+ else
+ {
+ for (dpyinfo = x_display_list; dpyinfo; dpyinfo = dpyinfo->next)
+ if (!NILP (Fstring_equal (XCAR (dpyinfo->name_list_element), name)))
+ return dpyinfo;
+ }
+
+ /* Use this general default value to start with. */
+ Vx_resource_name = Vinvocation_name;
+
+ validate_x_resource_name ();
+
+ dpyinfo = pgtk_term_init (name, SSDATA (Vx_resource_name));
+
+ if (dpyinfo == 0)
+ error ("Cannot connect to display server %s", SDATA (name));
+
+ XSETFASTINT (Vwindow_system_version, 11);
+
+ return dpyinfo;
+}
+
+/* ==========================================================================
+
+ Frame parameter setters
+
+ ========================================================================== */
+
+
+static void
+x_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ unsigned long fg;
+
+ fg = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
+ FRAME_FOREGROUND_PIXEL (f) = fg;
+ FRAME_X_OUTPUT (f)->foreground_color = fg;
+
+ if (FRAME_GTK_WIDGET (f))
+ {
+ update_face_from_frame_parameter (f, Qforeground_color, arg);
+ if (FRAME_VISIBLE_P (f))
+ SET_FRAME_GARBAGED (f);
+ }
+}
+
+
+static void
+x_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ unsigned long bg;
+
+ bg = x_decode_color (f, arg, WHITE_PIX_DEFAULT (f));
+ FRAME_BACKGROUND_PIXEL (f) = bg;
+
+ /* Clear the frame. */
+ if (FRAME_VISIBLE_P (f))
+ pgtk_clear_frame (f);
+
+ FRAME_X_OUTPUT (f)->background_color = bg;
+
+ xg_set_background_color (f, bg);
+ update_face_from_frame_parameter (f, Qbackground_color, arg);
+
+ if (FRAME_VISIBLE_P (f))
+ SET_FRAME_GARBAGED (f);
+}
+
+static void
+x_set_border_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ int pix;
+
+ CHECK_STRING (arg);
+ pix = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
+ FRAME_X_OUTPUT (f)->border_pixel = pix;
+ pgtk_frame_rehighlight (FRAME_DISPLAY_INFO (f));
+}
+
+static void
+x_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ unsigned long fore_pixel, pixel;
+ struct pgtk_output *x = f->output_data.pgtk;
+
+ if (!NILP (Vx_cursor_fore_pixel))
+ {
+ fore_pixel = x_decode_color (f, Vx_cursor_fore_pixel,
+ WHITE_PIX_DEFAULT (f));
+ }
+ else
+ fore_pixel = FRAME_BACKGROUND_PIXEL (f);
+
+ pixel = x_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 = x->mouse_color;
+ if (pixel == fore_pixel)
+ {
+ fore_pixel = FRAME_BACKGROUND_PIXEL (f);
+ }
+ }
+
+ x->cursor_foreground_color = fore_pixel;
+ x->cursor_color = pixel;
+
+ if (FRAME_X_WINDOW (f) != 0)
+ {
+ x->cursor_xgcv.background = x->cursor_color;
+ x->cursor_xgcv.foreground = fore_pixel;
+
+ 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
+pgtk_set_name_internal (struct frame *f, Lisp_Object name)
+{
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ block_input ();
+ {
+ Lisp_Object encoded_name;
+
+ /* As ENCODE_UTF_8 may cause GC and relocation of string data,
+ we use it before x_encode_text that may return string data. */
+ encoded_name = ENCODE_UTF_8 (name);
+
+ gtk_window_set_title (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ SSDATA (encoded_name));
+ }
+ unblock_input ();
+ }
+}
+
+static void
+pgtk_set_name (struct frame *f, Lisp_Object name, int explicit)
+{
+ /* Make sure that requests from lisp code override requests from
+ Emacs redisplay code. */
+ if (explicit)
+ {
+ /* If we're switching from explicit to implicit, we had better
+ update the mode lines and thereby update the title. */
+ if (f->explicit_name && NILP (name))
+ update_mode_lines = 12;
+
+ f->explicit_name = !NILP (name);
+ }
+ else if (f->explicit_name)
+ return;
+
+ if (NILP (name))
+ name = build_string (pgtk_app_name);
+ else
+ CHECK_STRING (name);
+
+ /* Don't change the name if it's already NAME. */
+ if (!NILP (Fstring_equal (name, f->name)))
+ return;
+
+ fset_name (f, name);
+
+ /* Title overrides explicit name. */
+ if (!NILP (f->title))
+ name = f->title;
+
+ pgtk_set_name_internal (f, name);
+}
+
+
+/* This function should be called when the user's lisp code has
+ specified a name for the frame; the name will override any set by the
+ redisplay code. */
+static void
+x_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ pgtk_set_name (f, arg, true);
+}
+
+
+/* This function should be called by Emacs redisplay code to set the
+ name; names set this way will never override names set by the user's
+ lisp code. */
+void
+pgtk_implicitly_set_name (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
+{
+ pgtk_set_name (f, arg, false);
+}
+
+
+/* Change the title of frame F to NAME.
+ If NAME is nil, use the frame name as the title. */
+
+static void
+x_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name)
+{
+ /* Don't change the title if it's already NAME. */
+ if (EQ (name, f->title))
+ return;
+
+ update_mode_lines = 22;
+
+ fset_title (f, name);
+
+ if (NILP (name))
+ name = f->name;
+ else
+ CHECK_STRING (name);
+
+ pgtk_set_name_internal (f, name);
+}
+
+
+void
+pgtk_set_doc_edited (void)
+{
+}
+
+
+static void
+x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
+{
+ int nlines;
+ /* Right now, menu bars don't work properly in minibuf-only frames;
+ 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) = 0;
+ FRAME_MENU_BAR_HEIGHT (f) = 0;
+ if (nlines)
+ {
+ FRAME_EXTERNAL_MENU_BAR (f) = 1;
+ if (FRAME_PGTK_P (f) && f->output_data.pgtk->menubar_widget == 0)
+ /* Make sure next redisplay shows the menu bar. */
+ XWINDOW (FRAME_SELECTED_WINDOW (f))->update_mode_line = true;
+ }
+ else
+ {
+ if (FRAME_EXTERNAL_MENU_BAR (f) == 1)
+ free_frame_menubar (f);
+ FRAME_EXTERNAL_MENU_BAR (f) = 0;
+ if (FRAME_X_P (f))
+ f->output_data.pgtk->menubar_widget = 0;
+ }
+
+ adjust_frame_glyphs (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 changes the
+ height of all windows on frame F to match the new tab bar height.
+ The frame's height doesn't change. */
+
+static void
+x_set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
+{
+ int nlines;
+
+ /* 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;
+
+ x_change_tab_bar_height (f, nlines * FRAME_LINE_HEIGHT (f));
+}
+
+
+/* Set the pixel height of the tab bar of frame F to HEIGHT. */
+void
+x_change_tab_bar_height (struct frame *f, int height)
+{
+ int unit = FRAME_LINE_HEIGHT (f);
+ int old_height = FRAME_TAB_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);
+
+ /* 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_X_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);
+ if (FRAME_X_WINDOW (f))
+ pgtk_clear_under_internal_border (f);
+}
+
+/* Set the pixel height of the tool bar of frame F to HEIGHT. */
+static void
+x_change_tool_bar_height (struct frame *f, int height)
+{
+ FRAME_TOOL_BAR_LINES (f) = 0;
+ FRAME_TOOL_BAR_HEIGHT (f) = 0;
+ if (height)
+ {
+ FRAME_EXTERNAL_TOOL_BAR (f) = true;
+ if (FRAME_X_P (f) && f->output_data.pgtk->toolbar_widget == 0)
+ /* Make sure next redisplay shows the tool bar. */
+ XWINDOW (FRAME_SELECTED_WINDOW (f))->update_mode_line = true;
+ update_frame_tool_bar (f);
+ }
+ else
+ {
+ if (FRAME_EXTERNAL_TOOL_BAR (f))
+ free_frame_tool_bar (f);
+ FRAME_EXTERNAL_TOOL_BAR (f) = false;
+ }
+}
+
+/* Toolbar support. */
+static void
+x_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;
+
+ x_change_tool_bar_height (f, nlines * FRAME_LINE_HEIGHT (f));
+
+}
+
+static void
+x_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ int border = check_int_nonnegative (arg);
+
+ if (border != FRAME_CHILD_FRAME_BORDER_WIDTH (f))
+ {
+ f->child_frame_border_width = border;
+
+ if (FRAME_X_WINDOW (f))
+ {
+ adjust_frame_size (f, -1, -1, 3, false, Qchild_frame_border_width);
+ pgtk_clear_under_internal_border (f);
+ }
+ }
+
+}
+
+static void
+x_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_X_WINDOW (f))
+ {
+ adjust_frame_size (f, -1, -1, 3, false, Qinternal_border_width);
+ pgtk_clear_under_internal_border (f);
+ }
+ }
+}
+
+static void
+x_set_icon_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ bool result;
+
+ if (STRINGP (arg))
+ {
+ if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt))
+ return;
+ }
+ else if (!STRINGP (oldval) && NILP (oldval) == NILP (arg))
+ return;
+
+ block_input ();
+ if (NILP (arg))
+ result = pgtk_text_icon (f,
+ SSDATA ((!NILP (f->icon_name)
+ ? f->icon_name : f->name)));
+ else
+ result = FRAME_TERMINAL (f)->set_bitmap_icon_hook (f, arg);
+
+ if (result)
+ {
+ unblock_input ();
+ error ("No icon window available");
+ }
+
+ unblock_input ();
+}
+
+static void
+x_set_icon_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ bool result;
+
+ if (STRINGP (arg))
+ {
+ if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt))
+ return;
+ }
+ else if (!NILP (arg) || NILP (oldval))
+ return;
+
+ fset_icon_name (f, arg);
+
+ block_input ();
+
+ result = pgtk_text_icon (f,
+ SSDATA ((!NILP (f->icon_name)
+ ? f->icon_name
+ : !NILP (f->title)
+ ? f->title : f->name)));
+
+ if (result)
+ {
+ unblock_input ();
+ error ("No icon window available");
+ }
+
+ unblock_input ();
+}
+
+/* This is the same as the xfns.c definition. */
+static void
+x_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ set_frame_cursor_types (f, arg);
+}
+
+/* called to set mouse pointer color, but all other terms use it to
+ initialize pointer types (and don't set the color ;) */
+static void
+x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+}
+
+
+static void
+x_icon (struct frame *f, Lisp_Object parms)
+/* --------------------------------------------------------------------------
+ Strangely-named function to set icon position parameters in frame.
+ This is irrelevant under macOS, but might be needed under GNUstep,
+ depending on the window manager used. Note, this is not a standard
+ frame parameter-setter; it is called directly from x-create-frame.
+ -------------------------------------------------------------------------- */
+{
+#if 0
+ Lisp_Object icon_x, icon_y;
+ struct pgtk_display_info *dpyinfo = check_pgtk_display_info (Qnil);
+
+ FRAME_X_OUTPUT (f)->icon_top = -1;
+ FRAME_X_OUTPUT (f)->icon_left = -1;
+
+ /* Set the position of the icon. */
+ icon_x =
+ gui_display_get_arg (dpyinfo, parms, Qicon_left, 0, 0, RES_TYPE_NUMBER);
+ icon_y =
+ gui_display_get_arg (dpyinfo, parms, Qicon_top, 0, 0, RES_TYPE_NUMBER);
+ if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound))
+ {
+ CHECK_NUMBER (icon_x);
+ CHECK_NUMBER (icon_y);
+ FRAME_X_OUTPUT (f)->icon_top = XFIXNUM (icon_y);
+ FRAME_X_OUTPUT (f)->icon_left = XFIXNUM (icon_x);
+ }
+ else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound))
+ error ("Both left and top icon corners of icon must be specified");
+#endif
+}
+
+/**
+ * x_set_undecorated:
+ *
+ * Set frame F's `undecorated' parameter. If non-nil, F's window-system
+ * window is drawn without decorations, title, minimize/maximize boxes
+ * and external borders. This usually means that the window cannot be
+ * dragged, resized, iconified, maximized or deleted with the mouse. If
+ * nil, draw the frame with all the elements listed above unless these
+ * have been suspended via window manager settings.
+ *
+ * Some window managers may not honor this parameter.
+ */
+static void
+x_set_undecorated (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ if (!EQ (new_value, old_value))
+ {
+ FRAME_UNDECORATED (f) = NILP (new_value) ? false : true;
+ xg_set_undecorated (f, new_value);
+ }
+}
+
+/**
+ * x_set_skip_taskbar:
+ *
+ * Set frame F's `skip-taskbar' parameter. If non-nil, this should
+ * remove F's icon from the taskbar associated with the display of F's
+ * window-system window and inhibit switching to F's window via
+ * <Alt>-<TAB>. If nil, lift these restrictions.
+ *
+ * Some window managers may not honor this parameter.
+ */
+static void
+x_set_skip_taskbar (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ if (!EQ (new_value, old_value))
+ {
+ xg_set_skip_taskbar (f, new_value);
+ FRAME_SKIP_TASKBAR (f) = !NILP (new_value);
+ }
+}
+
+/**
+ * x_set_override_redirect:
+ *
+ * Set frame F's `override_redirect' parameter which, if non-nil, hints
+ * that the window manager doesn't want to deal with F. Usually, such
+ * frames have no decorations and always appear on top of all frames.
+ *
+ * Some window managers may not honor this parameter.
+ */
+static void
+x_set_override_redirect (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ if (!EQ (new_value, old_value))
+ {
+ /* Here (xfwm) override_redirect can be changed for invisible
+ frames only. */
+ pgtk_make_frame_invisible (f);
+
+ xg_set_override_redirect (f, new_value);
+
+ pgtk_make_frame_visible (f);
+ FRAME_OVERRIDE_REDIRECT (f) = !NILP (new_value);
+ }
+}
+
+/* Set icon from FILE for frame F. By using GTK functions the icon
+ may be any format that GdkPixbuf knows about, i.e. not just bitmaps. */
+
+bool
+xg_set_icon (struct frame *f, Lisp_Object file)
+{
+ bool result = false;
+ Lisp_Object found;
+
+ if (!FRAME_GTK_OUTER_WIDGET (f))
+ return false;
+
+ found = image_find_image_file (file);
+
+ if (!NILP (found))
+ {
+ GdkPixbuf *pixbuf;
+ GError *err = NULL;
+ char *filename = SSDATA (ENCODE_FILE (found));
+ block_input ();
+
+ pixbuf = gdk_pixbuf_new_from_file (filename, &err);
+
+ if (pixbuf)
+ {
+ gtk_window_set_icon (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ pixbuf);
+ g_object_unref (pixbuf);
+
+ result = true;
+ }
+ else
+ g_error_free (err);
+
+ unblock_input ();
+ }
+
+ return result;
+}
+
+bool
+xg_set_icon_from_xpm_data (struct frame *f, const char **data)
+{
+ GdkPixbuf *pixbuf = gdk_pixbuf_new_from_xpm_data (data);
+
+ if (!pixbuf)
+ return false;
+
+ if (!FRAME_GTK_OUTER_WIDGET (f))
+ return false;
+
+ gtk_window_set_icon (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), pixbuf);
+ g_object_unref (pixbuf);
+ return true;
+}
+
+static void
+pgtk_set_sticky (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ if (!FRAME_GTK_OUTER_WIDGET (f))
+ return;
+
+ if (!NILP (new_value))
+ gtk_window_stick (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)));
+ else
+ gtk_window_unstick (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)));
+}
+
+static void
+pgtk_set_tool_bar_position (struct frame *f,
+ Lisp_Object new_value, Lisp_Object old_value)
+{
+ Lisp_Object choice = list4 (Qleft, Qright, Qtop, Qbottom);
+
+ if (!NILP (Fmemq (new_value, choice)))
+ {
+ if (!EQ (new_value, old_value))
+ {
+ xg_change_toolbar_position (f, new_value);
+ fset_tool_bar_position (f, new_value);
+ }
+ }
+ else
+ wrong_choice (choice, new_value);
+}
+
+static void
+pgtk_set_scroll_bar_foreground (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ GtkCssProvider *css_provider =
+ FRAME_X_OUTPUT (f)->scrollbar_foreground_css_provider;
+
+ if (NILP (new_value))
+ {
+ gtk_css_provider_load_from_data (css_provider, "", -1, NULL);
+ update_face_from_frame_parameter (f, Qscroll_bar_foreground, new_value);
+ }
+ else if (STRINGP (new_value))
+ {
+ Emacs_Color rgb;
+
+ if (!pgtk_parse_color (f, SSDATA (new_value), &rgb))
+ error ("Unknown color.");
+
+ /* On pgtk, this frame parameter should be ignored, and honor gtk theme. */
+#if 0
+ char css[64];
+ sprintf (css, "scrollbar slider { background-color: #%06x; }",
+ (unsigned int) rgb.pixel & 0xffffff);
+ gtk_css_provider_load_from_data (css_provider, css, -1, NULL);
+#endif
+ update_face_from_frame_parameter (f, Qscroll_bar_foreground, new_value);
+
+ }
+ else
+ error ("Invalid scroll-bar-foreground.");
+}
+
+static void
+pgtk_set_scroll_bar_background (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ GtkCssProvider *css_provider =
+ FRAME_X_OUTPUT (f)->scrollbar_background_css_provider;
+
+ if (NILP (new_value))
+ {
+ gtk_css_provider_load_from_data (css_provider, "", -1, NULL);
+ update_face_from_frame_parameter (f, Qscroll_bar_background, new_value);
+ }
+ else if (STRINGP (new_value))
+ {
+ Emacs_Color rgb;
+
+ if (!pgtk_parse_color (f, SSDATA (new_value), &rgb))
+ error ("Unknown color.");
+
+ /* On pgtk, this frame parameter should be ignored, and honor gtk theme. */
+#if 0
+ char css[64];
+ sprintf (css, "scrollbar trough { background-color: #%06x; }",
+ (unsigned int) rgb.pixel & 0xffffff);
+ gtk_css_provider_load_from_data (css_provider, css, -1, NULL);
+#endif
+ update_face_from_frame_parameter (f, Qscroll_bar_background, new_value);
+
+ }
+ else
+ error ("Invalid scroll-bar-background.");
+}
+
+
+/***********************************************************************
+ Printing
+ ***********************************************************************/
+
+
+DEFUN ("x-export-frames", Fx_export_frames, Sx_export_frames, 0, 2, 0,
+ doc: /* Return image data of FRAMES in TYPE format.
+FRAMES should be nil (the selected frame), a frame, or a list of
+frames (each of which corresponds to one page). Each frame should be
+visible. Optional arg TYPE should be either `pdf' (default), `png',
+`postscript', or `svg'. Supported types are determined by the
+compile-time configuration of cairo.
+
+Note: Text drawn with the `x' font backend is shown with hollow boxes
+unless TYPE is `png'. */)
+ (Lisp_Object frames, Lisp_Object type)
+{
+ Lisp_Object rest, tmp;
+ cairo_surface_type_t surface_type;
+
+ if (!CONSP (frames))
+ frames = list1 (frames);
+
+ tmp = Qnil;
+ for (rest = frames; CONSP (rest); rest = XCDR (rest))
+ {
+ struct frame *f = decode_window_system_frame (XCAR (rest));
+ Lisp_Object frame;
+
+ XSETFRAME (frame, f);
+ if (!FRAME_VISIBLE_P (f))
+ error ("Frames to be exported must be visible.");
+ tmp = Fcons (frame, tmp);
+ }
+ frames = Fnreverse (tmp);
+
+#ifdef CAIRO_HAS_PDF_SURFACE
+ if (NILP (type) || EQ (type, Qpdf))
+ surface_type = CAIRO_SURFACE_TYPE_PDF;
+ else
+#endif
+#ifdef CAIRO_HAS_PNG_FUNCTIONS
+ if (EQ (type, Qpng))
+ {
+ if (!NILP (XCDR (frames)))
+ error ("PNG export cannot handle multiple frames.");
+ surface_type = CAIRO_SURFACE_TYPE_IMAGE;
+ }
+ else
+#endif
+#ifdef CAIRO_HAS_PS_SURFACE
+ if (EQ (type, Qpostscript))
+ surface_type = CAIRO_SURFACE_TYPE_PS;
+ else
+#endif
+#ifdef CAIRO_HAS_SVG_SURFACE
+ if (EQ (type, Qsvg))
+ {
+ /* For now, we stick to SVG 1.1. */
+ if (!NILP (XCDR (frames)))
+ error ("SVG export cannot handle multiple frames.");
+ surface_type = CAIRO_SURFACE_TYPE_SVG;
+ }
+ else
+#endif
+ error ("Unsupported export type");
+
+ return pgtk_cr_export_frames (frames, surface_type);
+}
+
+
+/* Note: see frame.c for template, also where generic functions are impl */
+frame_parm_handler pgtk_frame_parm_handlers[] = {
+ gui_set_autoraise, /* generic OK */
+ gui_set_autolower, /* generic OK */
+ x_set_background_color,
+ x_set_border_color,
+ gui_set_border_width,
+ x_set_cursor_color,
+ x_set_cursor_type,
+ gui_set_font, /* generic OK */
+ x_set_foreground_color,
+ x_set_icon_name,
+ x_set_icon_type,
+ x_set_child_frame_border_width,
+ x_set_internal_border_width, /* generic OK */
+ gui_set_right_divider_width,
+ gui_set_bottom_divider_width,
+ x_set_menu_bar_lines,
+ x_set_mouse_color,
+ x_explicitly_set_name,
+ gui_set_scroll_bar_width, /* generic OK */
+ gui_set_scroll_bar_height, /* generic OK */
+ x_set_title,
+ gui_set_unsplittable, /* generic OK */
+ gui_set_vertical_scroll_bars, /* generic OK */
+ gui_set_horizontal_scroll_bars, /* generic OK */
+ gui_set_visibility, /* generic OK */
+ x_set_tab_bar_lines,
+ x_set_tool_bar_lines,
+ pgtk_set_scroll_bar_foreground,
+ pgtk_set_scroll_bar_background,
+ gui_set_screen_gamma, /* generic OK */
+ gui_set_line_spacing, /* generic OK, sets f->extra_line_spacing to int */
+ gui_set_left_fringe, /* generic OK */
+ gui_set_right_fringe, /* generic OK */
+ 0, /* x_set_wait_for_wm */
+ gui_set_fullscreen, /* generic OK */
+ gui_set_font_backend, /* generic OK */
+ gui_set_alpha,
+ pgtk_set_sticky,
+ pgtk_set_tool_bar_position,
+ 0, /* x_set_inhibit_double_buffering */
+ x_set_undecorated,
+ x_set_parent_frame,
+ x_set_skip_taskbar,
+ x_set_no_focus_on_map,
+ x_set_no_accept_focus,
+ x_set_z_group,
+ x_set_override_redirect,
+ gui_set_no_special_glyphs,
+};
+
+
+/* Handler for signals raised during x_create_frame and
+ x_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 x_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++;
+
+ x_free_frame_resources (f);
+ free_glyphs (f);
+ return Qt;
+ }
+
+ return Qnil;
+}
+
+static void
+do_unwind_create_frame (Lisp_Object frame)
+{
+ unwind_create_frame (frame);
+}
+
+/* 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 int
+x_decode_color (struct frame *f, Lisp_Object color_name, int mono_color)
+{
+ Emacs_Color cdef;
+
+ CHECK_STRING (color_name);
+
+ /* Return MONO_COLOR for monochrome frames. */
+ if (FRAME_DISPLAY_INFO (f)->n_planes == 1)
+ return mono_color;
+
+ /* x_defined_color is responsible for coping with failures
+ by looking for a near-miss. */
+ if (pgtk_defined_color (f, SSDATA (color_name), &cdef, true, 0))
+ return cdef.pixel;
+
+ signal_error ("Undefined color", color_name);
+}
+
+void
+pgtk_default_font_parameter (struct frame *f, Lisp_Object parms)
+{
+ struct pgtk_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 (EQ (font_param, Qunbound))
+ font_param = Qnil;
+
+ if (NILP (font_param))
+ {
+ /* System font should take precedence over X resources. We suggest this
+ regardless of font-use-system-font because .emacs may not have been
+ read yet. */
+ const char *system_font = xsettings_get_system_font ();
+ if (system_font)
+ font = font_open_by_name (f, build_unibyte_string (system_font));
+ }
+
+ 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[] = {
+ "monospace-10",
+ "-adobe-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-1",
+ "-misc-fixed-medium-r-normal-*-*-140-*-*-c-*-iso8859-1",
+ "-*-*-medium-r-normal-*-*-140-*-*-c-*-iso8859-1",
+ /* This was formerly the first thing tried, but it finds
+ too many fonts and takes too long. */
+ "-*-*-medium-r-*-*-*-*-*-*-c-*-iso8859-1",
+ /* If those didn't work, look for something which will
+ at least work. */
+ "-*-fixed-*-*-*-*-*-140-*-*-c-*-iso8859-1",
+ "fixed",
+ 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");
+ }
+ else if (!NILP (font_param))
+ {
+ /* Remember the explicit font parameter, so we can re-apply it after
+ we've applied the `default' face settings. */
+ AUTO_FRAME_ARG (arg, Qfont_parameter, font_param);
+ gui_set_frame_parameters (f, arg);
+ }
+
+ /* This call will make X resources override any system font setting. */
+ gui_default_parameter (f, parms, Qfont, font, "font", "Font",
+ RES_TYPE_STRING);
+}
+
+static void
+update_watched_scale_factor (struct atimer *timer)
+{
+ struct frame *f = timer->client_data;
+ double scale_factor = FRAME_SCALE_FACTOR (f);
+
+ if (scale_factor != FRAME_X_OUTPUT (f)->watched_scale_factor)
+ {
+ FRAME_X_OUTPUT (f)->watched_scale_factor = scale_factor;
+ pgtk_cr_update_surface_desired_size (f,
+ FRAME_CR_SURFACE_DESIRED_WIDTH (f),
+ FRAME_CR_SURFACE_DESIRED_HEIGHT (f),
+ true);
+ }
+}
+
+/* ==========================================================================
+
+ Lisp definitions
+
+ ========================================================================== */
+
+DEFUN ("pgtk-set-monitor-scale-factor", Fpgtk_set_monitor_scale_factor,
+ Spgtk_set_monitor_scale_factor, 2, 2, 0,
+ doc: /* Set monitor MONITOR-MODEL's scale factor to SCALE-FACTOR.
+Since Gdk's scale factor is integer, physical pixel width/height is
+incorrect when you specify fractional scale factor in compositor.
+If you set scale factor by this function, it is used instead of Gdk's one.
+
+Pass nil as SCALE-FACTOR if you want to reset the specified monitor's
+scale factor. */ )
+ (Lisp_Object monitor_model, Lisp_Object scale_factor)
+{
+ CHECK_STRING (monitor_model);
+ if (!NILP (scale_factor))
+ {
+ CHECK_NUMBER (scale_factor);
+ if (FIXNUMP (scale_factor))
+ {
+ if (XFIXNUM (scale_factor) <= 0)
+ error ("scale factor must be > 0.");
+ }
+ else if (FLOATP (scale_factor))
+ {
+ if (XFLOAT_DATA (scale_factor) <= 0.0)
+ error ("scale factor must be > 0.");
+ }
+ else
+ error ("unknown type of scale-factor");
+ }
+
+ Lisp_Object tem = Fassoc (monitor_model, monitor_scale_factor_alist, Qnil);
+ if (NILP (tem))
+ {
+ if (!NILP (scale_factor))
+ monitor_scale_factor_alist = Fcons (Fcons (monitor_model, scale_factor),
+ monitor_scale_factor_alist);
+ }
+ else
+ Fsetcdr (tem, scale_factor);
+
+ return scale_factor;
+}
+
+DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, 1, 1, 0,
+ doc: /* Make a new X window, which is called a "frame" in Emacs terms.
+Return an Emacs frame object. PARMS is an alist of frame parameters.
+If the parameters specify that the frame should not have a minibuffer,
+and do not specify a specific minibuffer window to use, then
+`default-minibuffer-frame' must be a frame whose minibuffer can be
+shared by the new frame.
+
+This function is an internal primitive--use `make-frame' instead. */ )
+ (Lisp_Object parms)
+{
+ struct frame *f;
+ Lisp_Object frame, tem;
+ Lisp_Object name;
+ bool minibuffer_only = false;
+ bool undecorated = false, override_redirect = false;
+ long window_prompting = 0;
+ ptrdiff_t count = SPECPDL_INDEX ();
+ Lisp_Object display;
+ struct pgtk_display_info *dpyinfo = NULL;
+ Lisp_Object parent, parent_frame;
+ struct kboard *kb;
+
+ 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 (EQ (display, Qunbound))
+ display =
+ gui_display_get_arg (dpyinfo, parms, Qdisplay, 0, 0, RES_TYPE_STRING);
+ if (EQ (display, Qunbound))
+ display = Qnil;
+ dpyinfo = check_pgtk_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) && !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 (EQ (parent, Qunbound))
+ parent = Qnil;
+ if (!NILP (parent))
+ CHECK_NUMBER (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)
+ || EQ (parent_frame, Qunbound)
+ || NILP (parent_frame)
+ || !FRAMEP (parent_frame)
+ || !FRAME_LIVE_P (XFRAME (parent_frame))
+ || !FRAME_PGTK_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)))
+ && !(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)))
+ && !(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_pgtk;
+ FRAME_X_OUTPUT (f) = xzalloc (sizeof *FRAME_X_OUTPUT (f));
+#if 0
+ FRAME_X_OUTPUT (f)->icon_bitmap = -1;
+#endif
+ FRAME_FONTSET (f) = -1;
+ FRAME_X_OUTPUT (f)->white_relief.pixel = -1;
+ FRAME_X_OUTPUT (f)->black_relief.pixel = -1;
+
+ FRAME_X_OUTPUT (f)->scrollbar_foreground_css_provider =
+ gtk_css_provider_new ();
+ FRAME_X_OUTPUT (f)->scrollbar_background_css_provider =
+ gtk_css_provider_new ();
+
+ 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! */
+ {
+ 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;
+ FRAME_X_OUTPUT (f)->cursor_color = -1;
+ FRAME_X_OUTPUT (f)->cursor_foreground_color = -1;
+ FRAME_X_OUTPUT (f)->border_pixel = -1;
+ FRAME_X_OUTPUT (f)->mouse_color = -1;
+
+ black = build_string ("black");
+ FRAME_FOREGROUND_PIXEL (f)
+ = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ FRAME_BACKGROUND_PIXEL (f)
+ = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ FRAME_X_OUTPUT (f)->cursor_color
+ = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ FRAME_X_OUTPUT (f)->cursor_foreground_color
+ = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ FRAME_X_OUTPUT (f)->border_pixel
+ = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ FRAME_X_OUTPUT (f)->mouse_color
+ = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ }
+
+ /* Specify the parent under which to make this X window. */
+ if (!NILP (parent))
+ {
+ FRAME_X_OUTPUT (f)->parent_desc = (Window) XFIXNAT (parent);
+ FRAME_X_OUTPUT (f)->explicit_parent = true;
+ }
+ else
+ {
+ FRAME_X_OUTPUT (f)->parent_desc = FRAME_DISPLAY_INFO (f)->root_window;
+ FRAME_X_OUTPUT (f)->explicit_parent = false;
+ }
+
+ /* Set the name; the functions to which we pass f expect the name to
+ be set. */
+ if (EQ (name, Qunbound) || NILP (name))
+ {
+ fset_name (f, build_string (dpyinfo->x_id_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 (&ftcrfont_driver, f);
+#ifdef HAVE_HARFBUZZ
+ register_font_driver (&ftcrhbfont_driver, f);
+#endif /* HAVE_HARFBUZZ */
+
+ 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. */
+ pgtk_default_font_parameter (f, parms);
+ if (!FRAME_FONT (f))
+ {
+ delete_frame (frame, Qnoelisp);
+ error ("Invalid frame font");
+ }
+
+ /* Frame contents get displaced if an embedded X window has a border. */
+#if 0
+ if (!FRAME_X_EMBEDDED_P (f))
+#endif
+ 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 (!EQ (value, Qunbound))
+ parms = Fcons (Fcons (Qinternal_border_width, value), parms);
+ }
+
+ /* 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,
+ "childFrameBorderWidth", "childFrameBorderWidth",
+ RES_TYPE_NUMBER);
+ if (! EQ (value, Qunbound))
+ parms = Fcons (Fcons (Qchild_frame_border_width, value),
+ parms);
+
+ }
+
+ gui_default_parameter (f, parms, Qchild_frame_border_width,
+ make_fixnum (0),
+ "childFrameBorderWidth", "childFrameBorderWidth",
+ RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qinternal_border_width,
+ make_fixnum (0),
+ "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);
+ gui_default_parameter (f, parms, Qvertical_scroll_bars,
+ Qright,
+ "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);
+
+ gui_default_parameter (f, parms, Qscroll_bar_foreground, Qnil,
+ "scrollBarForeground", "ScrollBarForeground",
+ RES_TYPE_STRING);
+ gui_default_parameter (f, parms, Qscroll_bar_background, Qnil,
+ "scrollBarBackground", "ScrollBarBackground",
+ RES_TYPE_STRING);
+
+ /* 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);
+
+ /* We have to call adjust_frame_size here since otherwise
+ x_set_tool_bar_lines will already work with the character sizes
+ installed by init_frame_faces while the frame's pixel size is still
+ calculated from a character size of 1 and we subsequently hit the
+ (height >= 0) assertion in window_box_height.
+
+ The non-pixelwise code apparently worked around this because it
+ had one frame line vs one toolbar line which left us with a zero
+ root window height which was obviously wrong as well ...
+
+ Also process `min-width' and `min-height' parameters right here
+ because `frame-windows-min-size' needs them. */
+ tem =
+ gui_display_get_arg (dpyinfo, parms, Qmin_width, NULL, NULL,
+ RES_TYPE_NUMBER);
+ if (NUMBERP (tem))
+ store_frame_param (f, Qmin_width, tem);
+ tem =
+ gui_display_get_arg (dpyinfo, parms, Qmin_height, NULL, NULL,
+ RES_TYPE_NUMBER);
+ if (NUMBERP (tem))
+ store_frame_param (f, Qmin_height, tem);
+ adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
+ 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);
+
+#if 0
+ x_icon_verify (f, parms);
+#endif
+
+ /* Create the X widget or window. */
+ /* x_window (f); */
+ xg_create_frame_widgets (f);
+ pgtk_set_event_handler (f);
+
+
+#define INSTALL_CURSOR(FIELD, NAME) \
+ FRAME_X_OUTPUT (f)->FIELD = gdk_cursor_new_for_display (FRAME_X_DISPLAY (f), GDK_ ## NAME)
+
+ INSTALL_CURSOR (text_cursor, XTERM);
+ INSTALL_CURSOR (nontext_cursor, LEFT_PTR);
+ INSTALL_CURSOR (modeline_cursor, XTERM);
+ INSTALL_CURSOR (hand_cursor, HAND2);
+ INSTALL_CURSOR (hourglass_cursor, WATCH);
+ INSTALL_CURSOR (horizontal_drag_cursor, SB_H_DOUBLE_ARROW);
+ INSTALL_CURSOR (vertical_drag_cursor, SB_V_DOUBLE_ARROW);
+ INSTALL_CURSOR (left_edge_cursor, LEFT_SIDE);
+ INSTALL_CURSOR (right_edge_cursor, RIGHT_SIDE);
+ INSTALL_CURSOR (top_edge_cursor, TOP_SIDE);
+ INSTALL_CURSOR (bottom_edge_cursor, BOTTOM_SIDE);
+ INSTALL_CURSOR (top_left_corner_cursor, TOP_LEFT_CORNER);
+ INSTALL_CURSOR (top_right_corner_cursor, TOP_RIGHT_CORNER);
+ INSTALL_CURSOR (bottom_right_corner_cursor, BOTTOM_RIGHT_CORNER);
+ INSTALL_CURSOR (bottom_left_corner_cursor, BOTTOM_LEFT_CORNER);
+
+#undef INSTALL_CURSOR
+
+ x_icon (f, parms);
+#if 0
+ x_make_gc (f);
+#endif
+
+ /* Now consider the frame official. */
+ f->terminal->reference_count++;
+ FRAME_DISPLAY_INFO (f)->reference_count++;
+ Vframe_list = Fcons (frame, Vframe_list);
+
+ /* We need to do this after creating the X 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);
+ 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);
+
+ if (!NILP (parent_frame))
+ {
+ struct frame *p = XFRAME (parent_frame);
+
+ block_input ();
+
+ GtkWidget *fixed = FRAME_GTK_WIDGET (f);
+ GtkWidget *fixed_of_p = FRAME_GTK_WIDGET (p);
+ GtkWidget *whbox_of_f = gtk_widget_get_parent (fixed);
+ g_object_ref (fixed);
+ gtk_container_remove (GTK_CONTAINER (whbox_of_f), fixed);
+ gtk_fixed_put (GTK_FIXED (fixed_of_p), fixed, f->left_pos, f->top_pos);
+ gtk_widget_show_all (fixed);
+ g_object_unref (fixed);
+
+ gtk_widget_destroy (FRAME_GTK_OUTER_WIDGET (f));
+ FRAME_GTK_OUTER_WIDGET (f) = NULL;
+ FRAME_OUTPUT_DATA (f)->vbox_widget = NULL;
+ FRAME_OUTPUT_DATA (f)->hbox_widget = NULL;
+ FRAME_OUTPUT_DATA (f)->menubar_widget = NULL;
+ FRAME_OUTPUT_DATA (f)->toolbar_widget = NULL;
+ FRAME_OUTPUT_DATA (f)->ttip_widget = NULL;
+ FRAME_OUTPUT_DATA (f)->ttip_lbl = NULL;
+ FRAME_OUTPUT_DATA (f)->ttip_window = NULL;
+
+ unblock_input ();
+ }
+
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ GList *w = gtk_container_get_children (GTK_CONTAINER (FRAME_GTK_OUTER_WIDGET (f)));
+ for (; w != NULL; w = w->next)
+ gtk_widget_show_all (GTK_WIDGET (w->data));
+ }
+
+ 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);
+
+ /* Create the menu bar. */
+ if (!minibuffer_only && FRAME_EXTERNAL_MENU_BAR (f))
+ {
+ /* If this signals an error, we haven't set size hints for the
+ frame and we didn't make it visible. */
+ initialize_frame_menubar (f);
+
+ }
+
+ /* Consider frame official, now. */
+ f->can_set_window_size = true;
+
+ /* Tell the server what size and position, etc, we want, and how
+ badly we want them. This should be done after we have the menu
+ bar so that its size can be taken into account. */
+ block_input ();
+ x_wm_set_size_hint (f, window_prompting, false);
+ unblock_input ();
+
+ 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. */
+ gui_default_parameter (f, parms, Qfullscreen, Qnil,
+ "fullscreen", "Fullscreen", RES_TYPE_SYMBOL);
+
+ /* Make the window appear on the frame and enable display, unless
+ the caller says not to. However, with explicit parent, Emacs
+ cannot control visibility, so don't try. */
+ if (!FRAME_X_OUTPUT (f)->explicit_parent)
+ {
+ Lisp_Object visibility
+ =
+ gui_display_get_arg (dpyinfo, parms, Qvisibility, 0, 0,
+ RES_TYPE_SYMBOL);
+
+ if (EQ (visibility, Qicon))
+ pgtk_iconify_frame (f);
+ else
+ {
+ if (EQ (visibility, Qunbound))
+ visibility = Qt;
+
+ if (!NILP (visibility))
+ pgtk_make_frame_visible (f);
+ }
+
+ store_frame_param (f, Qvisibility, visibility);
+ }
+
+ /* 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));
+
+ FRAME_X_OUTPUT (f)->border_color_css_provider = NULL;
+
+ FRAME_X_OUTPUT (f)->cr_surface_visible_bell = NULL;
+ FRAME_X_OUTPUT (f)->atimer_visible_bell = NULL;
+ FRAME_X_OUTPUT (f)->watched_scale_factor = 1.0;
+ struct timespec ts = make_timespec (1, 0);
+ FRAME_X_OUTPUT (f)->scale_factor_atimer = start_atimer(ATIMER_CONTINUOUS,
+ ts,
+ update_watched_scale_factor,
+ f);
+
+ /* Make sure windows on this frame appear in calls to next-window
+ and similar functions. */
+ Vwindow_list = Qnil;
+
+ return unbind_to (count, frame);
+}
+
+
+#if 0
+static int
+pgtk_window_is_ancestor (PGTKWindow * win, PGTKWindow * candidate)
+/* Test whether CANDIDATE is an ancestor window of WIN. */
+{
+ if (candidate == NULL)
+ return 0;
+ else if (win == candidate)
+ return 1;
+ else
+ return pgtk_window_is_ancestor (win,[candidate parentWindow]);
+}
+#endif
+
+/**
+ * x_frame_restack:
+ *
+ * Restack frame F1 below frame F2, above if ABOVE_FLAG is non-nil. In
+ * practice this is a two-step action: The first step removes F1's
+ * window-system window from the display. The second step reinserts
+ * F1's window below (above if ABOVE_FLAG is true) that of F2.
+ */
+static void
+pgtk_frame_restack (struct frame *f1, struct frame *f2, bool above_flag)
+{
+ block_input ();
+ xg_frame_restack (f1, f2, above_flag);
+ unblock_input ();
+}
+
+
+DEFUN ("pgtk-frame-restack", Fpgtk_frame_restack, Spgtk_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.
+
+Some window managers may refuse to restack windows. */)
+ (Lisp_Object frame1, Lisp_Object frame2, Lisp_Object above)
+{
+ struct frame *f1 = decode_live_frame (frame1);
+ struct frame *f2 = decode_live_frame (frame2);
+
+ if (!(FRAME_GTK_OUTER_WIDGET (f1) && FRAME_GTK_OUTER_WIDGET (f2)))
+ error ("Cannot restack frames");
+ pgtk_frame_restack (f1, f2, !NILP (above));
+ return Qt;
+}
+
+#ifdef HAVE_GSETTINGS
+
+#define RESOURCE_KEY_MAX_LEN 128
+#define SCHEMA_ID "org.gnu.emacs.defaults"
+#define PATH_FOR_CLASS_TYPE "/org/gnu/emacs/defaults-by-class/"
+#define PATH_PREFIX_FOR_NAME_TYPE "/org/gnu/emacs/defaults-by-name/"
+
+static inline int
+pgtk_is_lower_char (int c)
+{
+ return c >= 'a' && c <= 'z';
+}
+
+static inline int
+pgtk_is_upper_char (int c)
+{
+ return c >= 'A' && c <= 'Z';
+}
+
+static inline int
+pgtk_is_numeric_char (int c)
+{
+ return c >= '0' && c <= '9';
+}
+
+static GSettings *
+parse_resource_key (const char *res_key, char *setting_key)
+{
+ char path[32 + RESOURCE_KEY_MAX_LEN];
+ const char *sp = res_key;
+ char *dp;
+
+ /*
+ * res_key="emacs.cursorBlink"
+ * -> path="/org/gnu/emacs/defaults-by-name/emacs/"
+ * setting_key="cursor-blink"
+ *
+ * res_key="Emacs.CursorBlink"
+ * -> path="/org/gnu/emacs/defaults-by-class/"
+ * setting_key="cursor-blink"
+ *
+ * Returns GSettings* if setting_key exists in schema, otherwise NULL.
+ */
+
+ /* generate path */
+ if (pgtk_is_upper_char (*sp))
+ {
+ /* First letter is upper case. It should be "Emacs",
+ * but don't care.
+ */
+ strcpy (path, PATH_FOR_CLASS_TYPE);
+ while (*sp != '\0')
+ {
+ if (*sp == '.')
+ break;
+ sp++;
+ }
+ }
+ else
+ {
+ strcpy (path, PATH_PREFIX_FOR_NAME_TYPE);
+ dp = path + strlen (path);
+ while (*sp != '\0')
+ {
+ int c = *sp;
+ if (c == '.')
+ break;
+ if (pgtk_is_lower_char (c))
+ (void) 0; /* lower -> NOP */
+ else if (pgtk_is_upper_char (c))
+ c = c - 'A' + 'a'; /* upper -> lower */
+ else if (pgtk_is_numeric_char (c))
+ (void) 0; /* numeric -> NOP */
+ else
+ return NULL; /* invalid */
+ *dp++ = c;
+ sp++;
+ }
+ *dp++ = '/'; /* must ends with '/' */
+ *dp = '\0';
+ }
+
+ if (*sp++ != '.')
+ return NULL;
+
+ /* generate setting_key */
+ dp = setting_key;
+ while (*sp != '\0')
+ {
+ int c = *sp;
+ if (pgtk_is_lower_char (c))
+ (void) 0; /* lower -> NOP */
+ else if (pgtk_is_upper_char (c))
+ {
+ c = c - 'A' + 'a'; /* upper -> lower */
+ if (dp != setting_key)
+ *dp++ = '-'; /* store '-' unless first char */
+ }
+ else if (pgtk_is_numeric_char (c))
+ (void) 0; /* numeric -> NOP */
+ else
+ return NULL; /* invalid */
+
+ *dp++ = c;
+ sp++;
+ }
+ *dp = '\0';
+
+ /* check existence of setting_key */
+ GSettingsSchemaSource *ssrc = g_settings_schema_source_get_default ();
+ GSettingsSchema *scm = g_settings_schema_source_lookup (ssrc, SCHEMA_ID, FALSE);
+ if (!scm)
+ return NULL; /* *.schema.xml is not installed. */
+ if (!g_settings_schema_has_key (scm, setting_key))
+ {
+ g_settings_schema_unref (scm);
+ return NULL;
+ }
+
+ /* create GSettings, and return it */
+ GSettings *gs = g_settings_new_full (scm, NULL, path);
+
+ g_settings_schema_unref (scm);
+ return gs;
+}
+
+const char *
+pgtk_get_defaults_value (const char *key)
+{
+ char skey[(RESOURCE_KEY_MAX_LEN + 1) * 2];
+
+ if (strlen (key) >= RESOURCE_KEY_MAX_LEN)
+ error ("resource key too long.");
+
+ GSettings *gs = parse_resource_key (key, skey);
+ if (gs == NULL)
+ {
+ return NULL;
+ }
+
+ gchar *str = g_settings_get_string (gs, skey);
+
+ /* There is no timing to free str.
+ * So, copy it here and free it.
+ *
+ * MEMO: Resource values for emacs shouldn't need such a long string value.
+ */
+ static char holder[128];
+ strncpy (holder, str, 128);
+ holder[127] = '\0';
+
+ g_object_unref (gs);
+ g_free (str);
+ return holder[0] != '\0' ? holder : NULL;
+}
+
+static void
+pgtk_set_defaults_value (const char *key, const char *value)
+{
+ char skey[(RESOURCE_KEY_MAX_LEN + 1) * 2];
+
+ if (strlen (key) >= RESOURCE_KEY_MAX_LEN)
+ error ("resource key too long.");
+
+ GSettings *gs = parse_resource_key (key, skey);
+ if (gs == NULL)
+ error ("unknown resource key.");
+
+ if (value != NULL)
+ {
+ g_settings_set_string (gs, skey, value);
+ }
+ else
+ {
+ g_settings_reset (gs, skey);
+ }
+
+ g_object_unref (gs);
+}
+
+#undef RESOURCE_KEY_MAX_LEN
+#undef SCHEMA_ID
+#undef PATH_FOR_CLASS_TYPE
+#undef PATH_PREFIX_FOR_NAME_TYPE
+
+#else /* not HAVE_GSETTINGS */
+
+const char *
+pgtk_get_defaults_value (const char *key)
+{
+ return NULL;
+}
+
+static void
+pgtk_set_defaults_value (const char *key, const char *value)
+{
+ error ("gsettings not supported.");
+}
+
+#endif
+
+
+DEFUN ("pgtk-set-resource", Fpgtk_set_resource, Spgtk_set_resource, 2, 2, 0,
+ doc: /* Set the value of ATTRIBUTE, of class CLASS, as VALUE, into defaults database. */ )
+ (Lisp_Object attribute, Lisp_Object value)
+{
+ check_window_system (NULL);
+
+ CHECK_STRING (attribute);
+ if (!NILP (value))
+ CHECK_STRING (value);
+
+ char *res = SSDATA (Vx_resource_name);
+ char *attr = SSDATA (attribute);
+ if (attr[0] >= 'A' && attr[0] <= 'Z')
+ res = SSDATA (Vx_resource_class);
+
+ char *key = g_strdup_printf ("%s.%s", res, attr);
+
+ pgtk_set_defaults_value (key, NILP (value) ? NULL : SSDATA (value));
+
+ return Qnil;
+}
+
+
+DEFUN ("x-server-max-request-size", Fx_server_max_request_size, Sx_server_max_request_size, 0, 1, 0,
+ doc: /* This function is a no-op. It is only present for completeness. */ )
+ (Lisp_Object terminal)
+{
+ check_pgtk_display_info (terminal);
+ /* This function has no real equivalent under PGTK. Return nil to
+ indicate this. */
+ return Qnil;
+}
+
+
+DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
+ doc: /* Return the "vendor ID" string of the display server TERMINAL.
+\(Labeling every distributor as a "vendor" embodies the false assumption
+that operating systems cannot be developed and distributed noncommercially.)
+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. */)
+ (Lisp_Object terminal)
+{
+ check_pgtk_display_info (terminal);
+ return Qnil;
+}
+
+
+DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0,
+ doc: /* Return the version numbers of the server of display TERMINAL.
+The value is a list of three integers: the major and minor
+version numbers of the X Protocol in use, and the distributor-specific release
+number. See also the function `x-server-vendor'.
+
+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. */ )
+ (Lisp_Object terminal)
+{
+ check_pgtk_display_info (terminal);
+ /*NOTE: it is unclear what would best correspond with "protocol";
+ we return 10.3, meaning Panther, since this is roughly the
+ level that GNUstep's APIs correspond to.
+ The last number is where we distinguish between the Apple
+ and GNUstep implementations ("distributor-specific release
+ number") and give int'ized versions of major.minor. */
+ return list3i (0, 0, 0);
+}
+
+
+DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0,
+ doc: /* Return the number of screens on the display server 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.
+
+Note: "screen" here is not in X11's. For the number of physical monitors,
+use `(length \(display-monitor-attributes-list TERMINAL))' instead. */)
+ (Lisp_Object terminal)
+{
+ check_pgtk_display_info (terminal);
+ return make_fixnum (1);
+}
+
+
+DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0,
+ doc: /* Return the height in millimeters of the the 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.
+
+On \"multi-monitor\" setups this refers to the height in millimeters for
+all physical monitors associated with TERMINAL. To get information
+for each physical monitor, use `display-monitor-attributes-list'. */)
+ (Lisp_Object terminal)
+{
+ struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal);
+ GdkDisplay *gdpy;
+ gint n_monitors, i;
+ int height_mm_at_0 = 0, height_mm_at_other = 0;
+
+ block_input ();
+ gdpy = dpyinfo->gdpy;
+ n_monitors = gdk_display_get_n_monitors (gdpy);
+
+ for (i = 0; i < n_monitors; ++i)
+ {
+ GdkRectangle rec;
+
+ GdkMonitor *monitor = gdk_display_get_monitor (gdpy, i);
+ gdk_monitor_get_geometry (monitor, &rec);
+
+ int mm = gdk_monitor_get_height_mm (monitor);
+
+ if (rec.y == 0)
+ height_mm_at_0 = max (height_mm_at_0, mm);
+ else
+ height_mm_at_other += mm;
+ }
+
+ unblock_input ();
+
+ return make_fixnum (height_mm_at_0 + height_mm_at_other);
+}
+
+
+DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0,
+ doc: /* Return the width in millimeters of the the 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.
+
+On \"multi-monitor\" setups this refers to the width in millimeters for
+all physical monitors associated with TERMINAL. To get information
+for each physical monitor, use `display-monitor-attributes-list'. */)
+ (Lisp_Object terminal)
+{
+ struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal);
+ GdkDisplay *gdpy;
+ gint n_monitors, i;
+ int width_mm_at_0 = 0, width_mm_at_other = 0;
+
+ block_input ();
+ gdpy = dpyinfo->gdpy;
+ n_monitors = gdk_display_get_n_monitors (gdpy);
+
+ for (i = 0; i < n_monitors; ++i)
+ {
+ GdkRectangle rec;
+
+ GdkMonitor *monitor = gdk_display_get_monitor (gdpy, i);
+ gdk_monitor_get_geometry (monitor, &rec);
+
+ int mm = gdk_monitor_get_width_mm (monitor);
+
+ if (rec.x == 0)
+ width_mm_at_0 = max (width_mm_at_0, mm);
+ else
+ width_mm_at_other += mm;
+ }
+
+ unblock_input ();
+
+ return make_fixnum (width_mm_at_0 + width_mm_at_other);
+}
+
+
+DEFUN ("x-display-backing-store", Fx_display_backing_store, Sx_display_backing_store, 0, 1, 0,
+ doc: /* Return an indication of whether the the display TERMINAL does backing store.
+The value may be `buffered', `retained', or `non-retained'.
+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. */)
+ (Lisp_Object terminal)
+{
+ check_pgtk_display_info (terminal);
+ return Qnil;
+}
+
+
+DEFUN ("x-display-visual-class", Fx_display_visual_class, Sx_display_visual_class, 0, 1, 0,
+ doc: /* Return the visual class of the the display TERMINAL.
+The value is one of the symbols `static-gray', `gray-scale',
+`static-color', `pseudo-color', `true-color', or `direct-color'.
+
+The optional argument TERMINAL specifies which display to ask about.
+TERMINAL should a terminal object, a frame or a display name (a string).
+If omitted or nil, that stands for the selected frame's display.
+
+On PGTK, always return true-color. */)
+ (Lisp_Object terminal)
+{
+ return intern ("true-color");
+}
+
+
+DEFUN ("x-display-save-under", Fx_display_save_under, Sx_display_save_under, 0, 1, 0,
+ doc: /* Return t if TERMINAL supports the save-under feature.
+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. */)
+ (Lisp_Object terminal)
+{
+ check_pgtk_display_info (terminal);
+ return Qnil;
+}
+
+
+DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection, 1, 3, 0,
+ doc: /* Open a connection to a display server.
+DISPLAY is the name of the display to connect to.
+Optional second arg XRM-STRING is a string of resources in xrdb format.
+If the optional third arg MUST-SUCCEED is non-nil,
+terminate Emacs if we can't open the connection. */)
+ (Lisp_Object display, Lisp_Object resource_string, Lisp_Object must_succeed)
+{
+ struct pgtk_display_info *dpyinfo;
+
+ if (NILP (display))
+ display = build_string ("");
+
+ CHECK_STRING (display);
+
+ nxatoms_of_pgtkselect ();
+ dpyinfo = pgtk_term_init (display, SSDATA (Vx_resource_name));
+ if (dpyinfo == 0)
+ {
+ if (!NILP (must_succeed))
+ fatal ("Display on %s not responding.\n", SSDATA (display));
+ else
+ error ("Display on %s not responding.\n", SSDATA (display));
+ }
+
+ return Qnil;
+}
+
+
+DEFUN ("x-close-connection", Fx_close_connection, Sx_close_connection, 1, 1, 0,
+ doc: /* Close the connection to TERMINAL's display server.
+For TERMINAL, specify a terminal object, a frame or a display name (a
+string). If TERMINAL is nil, that stands for the selected frame's
+terminal. */)
+ (Lisp_Object terminal)
+{
+ struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal);
+
+ if (dpyinfo->reference_count > 0)
+ error ("Display still has frames on it");
+
+ pgtk_delete_terminal (dpyinfo->terminal);
+
+ return Qnil;
+}
+
+
+DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0,
+ doc: /* Return the list of display names that Emacs has connections to. */)
+ (void)
+{
+ Lisp_Object result = Qnil;
+ struct pgtk_display_info *ndi;
+
+ for (ndi = x_display_list; ndi; ndi = ndi->next)
+ result = Fcons (XCAR (ndi->name_list_element), result);
+
+ return result;
+}
+
+
+DEFUN ("pgtk-hide-others", Fpgtk_hide_others, Spgtk_hide_others, 0, 0, 0,
+ doc: /* Hides all applications other than Emacs. */)
+ (void)
+{
+ check_window_system (NULL);
+ return Qnil;
+}
+
+DEFUN ("pgtk-hide-emacs", Fpgtk_hide_emacs, Spgtk_hide_emacs, 1, 1, 0,
+ doc: /* If ON is non-nil, the entire Emacs application is hidden.
+Otherwise if Emacs is hidden, it is unhidden.
+If ON is equal to `activate', Emacs is unhidden and becomes
+the active application. */)
+ (Lisp_Object on)
+{
+ check_window_system (NULL);
+ return Qnil;
+}
+
+
+DEFUN ("pgtk-font-name", Fpgtk_font_name, Spgtk_font_name, 1, 1, 0,
+ doc: /* Determine font PostScript or family name for font NAME.
+NAME should be a string containing either the font name or an XLFD
+font descriptor. If string contains `fontset' and not
+`fontset-startup', it is left alone. */)
+ (Lisp_Object name)
+{
+ char *nm;
+ CHECK_STRING (name);
+ nm = SSDATA (name);
+
+ if (nm[0] != '-')
+ return name;
+ if (strstr (nm, "fontset") && !strstr (nm, "fontset-startup"))
+ return name;
+
+ char *str = pgtk_xlfd_to_fontname (SSDATA (name));
+ name = build_string (str);
+ xfree (str);
+ return name;
+}
+
+/* ==========================================================================
+
+ Miscellaneous functions not called through hooks
+
+ ========================================================================== */
+
+/* Called from frame.c. */
+struct pgtk_display_info *
+check_x_display_info (Lisp_Object frame)
+{
+ return check_pgtk_display_info (frame);
+}
+
+
+void
+pgtk_set_scroll_bar_default_width (struct frame *f)
+{
+ int unit = FRAME_COLUMN_WIDTH (f);
+ int minw = xg_get_default_scrollbar_width (f);
+ /* A minimum width of 14 doesn't look good for toolkit scroll bars. */
+ FRAME_CONFIG_SCROLL_BAR_COLS (f) = (minw + unit - 1) / unit;
+ FRAME_CONFIG_SCROLL_BAR_WIDTH (f) = minw;
+}
+
+void
+pgtk_set_scroll_bar_default_height (struct frame *f)
+{
+ int height = FRAME_LINE_HEIGHT (f);
+ int min_height = xg_get_default_scrollbar_height (f);
+ /* A minimum height of 14 doesn't look good for toolkit scroll bars. */
+ FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) = min_height;
+ FRAME_CONFIG_SCROLL_BAR_LINES (f) = (min_height + height - 1) / height;
+}
+
+/* Terminals implement this instead of x-get-resource directly. */
+const char *
+pgtk_get_string_resource (XrmDatabase rdb, const char *name,
+ const char *class)
+{
+ check_window_system (NULL);
+
+ if (inhibit_x_resources)
+ /* --quick was passed, so this is a no-op. */
+ return NULL;
+
+ const char *res = pgtk_get_defaults_value (name);
+ if (res == NULL)
+ res = pgtk_get_defaults_value (class);
+
+ if (res == NULL)
+ return NULL;
+
+ if (c_strncasecmp (res, "YES", 3) == 0)
+ return "true";
+
+ if (c_strncasecmp (res, "NO", 2) == 0)
+ return "false";
+
+ return res;
+}
+
+
+Lisp_Object
+x_get_focus_frame (struct frame *frame)
+{
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame);
+ Lisp_Object focus;
+
+ if (!dpyinfo->x_focus_frame)
+ return Qnil;
+
+ XSETFRAME (focus, dpyinfo->x_focus_frame);
+ return focus;
+}
+
+/* ==========================================================================
+
+ Lisp definitions that, for whatever reason, we can't alias as 'ns-XXX'.
+
+ ========================================================================== */
+
+
+DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0,
+ doc: /* Internal function called by `color-defined-p', which see. */)
+ (Lisp_Object color, Lisp_Object frame)
+{
+ Emacs_Color col;
+ struct frame *f = decode_window_system_frame (frame);
+
+ CHECK_STRING (color);
+
+ if (pgtk_defined_color (f, SSDATA (color), &col, false, false))
+ return Qt;
+ else
+ return Qnil;
+}
+
+
+DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0,
+ doc: /* Internal function called by `color-values', which see. */)
+ (Lisp_Object color, Lisp_Object frame)
+{
+ Emacs_Color col;
+ struct frame *f = decode_window_system_frame (frame);
+
+ CHECK_STRING (color);
+
+ if (pgtk_defined_color (f, SSDATA (color), &col, false, false))
+ return list3i (col.red, col.green, col.blue);
+ else
+ return Qnil;
+}
+
+
+DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0,
+ doc: /* Internal function called by `display-color-p', which see. */)
+ (Lisp_Object terminal)
+{
+ check_pgtk_display_info (terminal);
+ return Qt;
+}
+
+
+DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p, 0, 1, 0,
+ doc: /* Return t if the display supports shades of gray.
+Note that color displays do support shades of gray.
+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. */)
+ (Lisp_Object terminal)
+{
+ return Qnil;
+}
+
+
+DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width, 0, 1, 0,
+ doc: /* Return the width in pixels of the display TERMINAL.
+The optional argument TERMINAL specifies which display to ask about.
+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.
+
+On \"multi-monitor\" setups this refers to the pixel width for all
+physical monitors associated with TERMINAL. To get information for
+each physical monitor, use `display-monitor-attributes-list'. */)
+ (Lisp_Object terminal)
+{
+ struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal);
+ GdkDisplay *gdpy;
+ gint n_monitors, i;
+ int width = 0;
+
+ block_input ();
+ gdpy = dpyinfo->gdpy;
+ n_monitors = gdk_display_get_n_monitors (gdpy);
+
+ for (i = 0; i < n_monitors; ++i)
+ {
+ GdkRectangle rec;
+ double scale = 1;
+
+ GdkMonitor *monitor = gdk_display_get_monitor (gdpy, i);
+ gdk_monitor_get_geometry (monitor, &rec);
+
+ /* GTK returns scaled sizes for the workareas. */
+ scale = pgtk_get_monitor_scale_factor (gdk_monitor_get_model (monitor));
+ if (scale == 0.0)
+ scale = gdk_monitor_get_scale_factor (monitor);
+ rec.x = rec.x * scale + 0.5;
+ rec.y = rec.y * scale + 0.5;
+ rec.width = rec.width * scale + 0.5;
+ rec.height = rec.height * scale + 0.5;
+
+ width = max (width, rec.x + rec.width);
+ }
+
+ unblock_input ();
+
+ return make_fixnum (width);
+}
+
+
+DEFUN ("x-display-pixel-height", Fx_display_pixel_height, Sx_display_pixel_height, 0, 1, 0,
+ doc: /* Return the height in pixels of the display TERMINAL.
+The optional argument TERMINAL specifies which display to ask about.
+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.
+
+On \"multi-monitor\" setups this refers to the pixel height for all
+physical monitors associated with TERMINAL. To get information for
+each physical monitor, use `display-monitor-attributes-list'. */)
+ (Lisp_Object terminal)
+{
+ struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal);
+ GdkDisplay *gdpy;
+ gint n_monitors, i;
+ int height = 0;
+
+ block_input ();
+ gdpy = dpyinfo->gdpy;
+ n_monitors = gdk_display_get_n_monitors (gdpy);
+
+ for (i = 0; i < n_monitors; ++i)
+ {
+ GdkRectangle rec;
+ double scale = 1;
+
+ GdkMonitor *monitor = gdk_display_get_monitor (gdpy, i);
+ gdk_monitor_get_geometry (monitor, &rec);
+
+ /* GTK returns scaled sizes for the workareas. */
+ scale = pgtk_get_monitor_scale_factor (gdk_monitor_get_model (monitor));
+ if (scale == 0.0)
+ scale = gdk_monitor_get_scale_factor (monitor);
+ rec.x = rec.x * scale + 0.5;
+ rec.y = rec.y * scale + 0.5;
+ rec.width = rec.width * scale + 0.5;
+ rec.height = rec.height * scale + 0.5;
+
+ height = max (height, rec.y + rec.height);
+ }
+
+ unblock_input ();
+
+ return make_fixnum (height);
+}
+
+DEFUN ("pgtk-display-monitor-attributes-list", Fpgtk_display_monitor_attributes_list,
+ Spgtk_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.
+
+In addition to the standard attribute keys listed in
+`display-monitor-attributes-list', the following keys are contained in
+the attributes:
+
+ source -- String describing the source from which multi-monitor
+ information is obtained, \"Gdk\"
+
+Internal use only, use `display-monitor-attributes-list' instead. */)
+ (Lisp_Object terminal)
+{
+ struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal);
+ Lisp_Object attributes_list = Qnil;
+
+ GdkDisplay *gdpy;
+ gint primary_monitor = 0, n_monitors, i;
+ Lisp_Object monitor_frames, rest, frame;
+ static const char *source = "Gdk";
+ struct MonitorInfo *monitors;
+
+ block_input ();
+ gdpy = dpyinfo->gdpy;
+ n_monitors = gdk_display_get_n_monitors (gdpy);
+ monitor_frames = make_nil_vector (n_monitors);
+ monitors = xzalloc (n_monitors * sizeof *monitors);
+
+ FOR_EACH_FRAME (rest, frame)
+ {
+ struct frame *f = XFRAME (frame);
+
+ if (FRAME_PGTK_P (f)
+ && FRAME_DISPLAY_INFO (f) == dpyinfo
+ && !FRAME_TOOLTIP_P (f))
+ {
+ GdkWindow *gwin = gtk_widget_get_window (FRAME_GTK_WIDGET (f));
+
+ for (i = 0; i < n_monitors; i++)
+ if (gdk_display_get_monitor_at_window (gdpy, gwin)
+ == gdk_display_get_monitor (gdpy, i))
+ break;
+ ASET (monitor_frames, i, Fcons (frame, AREF (monitor_frames, i)));
+ }
+ }
+
+ for (i = 0; i < n_monitors; ++i)
+ {
+ gint width_mm, height_mm;
+ GdkRectangle rec, work;
+ struct MonitorInfo *mi = &monitors[i];
+ double scale = 1;
+
+ GdkMonitor *monitor = gdk_display_get_monitor (gdpy, i);
+ if (gdk_monitor_is_primary (monitor))
+ primary_monitor = i;
+ gdk_monitor_get_geometry (monitor, &rec);
+
+ width_mm = gdk_monitor_get_width_mm (monitor);
+ height_mm = gdk_monitor_get_height_mm (monitor);
+ gdk_monitor_get_workarea (monitor, &work);
+
+ /* GTK returns scaled sizes for the workareas. */
+ scale = pgtk_get_monitor_scale_factor (gdk_monitor_get_model (monitor));
+ if (scale == 0.0)
+ scale = gdk_monitor_get_scale_factor (monitor);
+ rec.x = rec.x * scale + 0.5;
+ rec.y = rec.y * scale + 0.5;
+ rec.width = rec.width * scale + 0.5;
+ rec.height = rec.height * scale + 0.5;
+ work.x = work.x * scale + 0.5;
+ work.y = work.y * scale + 0.5;
+ work.width = work.width * scale + 0.5;
+ work.height = work.height * scale + 0.5;
+
+ mi->geom.x = rec.x;
+ mi->geom.y = rec.y;
+ mi->geom.width = rec.width;
+ mi->geom.height = rec.height;
+ mi->work.x = work.x;
+ mi->work.y = work.y;
+ mi->work.width = work.width;
+ mi->work.height = work.height;
+ mi->mm_width = width_mm;
+ mi->mm_height = height_mm;
+ mi->scale_factor = scale;
+
+ dupstring (&mi->name, (gdk_monitor_get_model (monitor)));
+ }
+
+ attributes_list = make_monitor_attribute_list (monitors,
+ n_monitors,
+ primary_monitor,
+ monitor_frames,
+ source);
+ free_monitors (monitors, n_monitors);
+ unblock_input ();
+
+ return attributes_list;
+}
+
+double
+pgtk_frame_scale_factor (struct frame *f)
+{
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+ GdkDisplay *gdpy = dpyinfo->gdpy;
+
+ block_input ();
+
+ GdkWindow *gwin = gtk_widget_get_window (FRAME_GTK_WIDGET (f));
+ GdkMonitor *gmon = gdk_display_get_monitor_at_window (gdpy, gwin);
+
+ /* GTK returns scaled sizes for the workareas. */
+ double scale = pgtk_get_monitor_scale_factor (gdk_monitor_get_model (gmon));
+ if (scale == 0.0)
+ scale = gdk_monitor_get_scale_factor (gmon);
+
+ unblock_input ();
+
+ return scale;
+}
+
+DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes, 0, 1, 0,
+ doc: /* Return the number of bitplanes of the 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. */)
+ (Lisp_Object terminal)
+{
+ check_pgtk_display_info (terminal);
+ return make_fixnum (32);
+}
+
+
+DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells, 0, 1, 0,
+ doc: /* Returns the number of color cells of the 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. */)
+ (Lisp_Object terminal)
+{
+ struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal);
+ /* We force 24+ bit depths to 24-bit to prevent an overflow. */
+ return make_fixnum (1 << min (dpyinfo->n_planes, 24));
+}
+
+/***********************************************************************
+ Tool tips
+ ***********************************************************************/
+
+/* The frame of the currently visible tooltip. */
+static Lisp_Object tip_frame;
+
+/* The window-system window corresponding to the frame of the
+ currently visible tooltip. */
+GtkWidget *tip_window;
+
+/* 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;
+
+
+static void
+unwind_create_tip_frame (Lisp_Object frame)
+{
+ Lisp_Object deleted;
+
+ deleted = unwind_create_frame (frame);
+ if (EQ (deleted, Qt))
+ {
+ tip_window = NULL;
+ tip_frame = Qnil;
+ }
+}
+
+
+/* Create a frame for a tooltip on the display described by DPYINFO.
+ PARMS is a list of frame parameters. TEXT is the string to
+ display in the tip frame. Value is the frame.
+
+ Note that functions called here, esp. gui_default_parameter can
+ signal errors, for instance when a specified color name is
+ undefined. We have to make sure that we're in a consistent state
+ when this happens. */
+
+static Lisp_Object
+x_create_tip_frame (struct pgtk_display_info *dpyinfo, Lisp_Object parms, struct frame *p)
+{
+ struct frame *f;
+ Lisp_Object frame;
+ Lisp_Object name;
+ ptrdiff_t 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)
+ && !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_pgtk;
+ f->output_data.pgtk = xzalloc (sizeof *f->output_data.pgtk);
+#if 0
+ f->output_data.pgtk->icon_bitmap = -1;
+#endif
+ FRAME_FONTSET (f) = -1;
+ f->output_data.pgtk->white_relief.pixel = -1;
+ f->output_data.pgtk->black_relief.pixel = -1;
+
+ f->tooltip = true;
+ fset_icon_name (f, Qnil);
+ FRAME_DISPLAY_INFO (f) = dpyinfo;
+ f->output_data.pgtk->parent_desc = FRAME_DISPLAY_INFO (f)->root_window;
+ f->output_data.pgtk->explicit_parent = false;
+
+ /* 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 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.pgtk->border_pixel = -1;
+
+ black = build_string ("black");
+ FRAME_FOREGROUND_PIXEL (f)
+ = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ FRAME_BACKGROUND_PIXEL (f)
+ = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ f->output_data.pgtk->border_pixel
+ = x_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 (EQ (name, Qunbound) || NILP (name))
+ {
+ fset_name (f, build_string (dpyinfo->x_id_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 (&ftcrfont_driver, f);
+#ifdef HAVE_HARFBUZZ
+ register_font_driver (&ftcrhbfont_driver, f);
+#endif /* HAVE_HARFBUZZ */
+
+ 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. */
+ pgtk_default_font_parameter (f, parms);
+
+ gui_default_parameter (f, parms, Qborder_width, make_fixnum (0),
+ "borderWidth", "BorderWidth", RES_TYPE_NUMBER);
+
+ /* This defaults to 2 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 (! 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);
+
+ /* 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);
+
+ f->output_data.pgtk->parent_desc = FRAME_DISPLAY_INFO (f)->root_window;
+
+ gui_default_parameter (f, parms, Qinhibit_double_buffering, Qnil,
+ "inhibitDoubleBuffering", "InhibitDoubleBuffering",
+ RES_TYPE_BOOLEAN);
+
+ gui_figure_window_size (f, parms, false, false);
+
+ xg_create_frame_widgets (f);
+ pgtk_set_event_handler (f);
+ tip_window = FRAME_GTK_OUTER_WIDGET (f);
+ gtk_window_set_transient_for (GTK_WINDOW (tip_window),
+ GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (p)));
+ gtk_window_set_attached_to (GTK_WINDOW (tip_window), FRAME_GTK_WIDGET (p));
+ gtk_window_set_destroy_with_parent (GTK_WINDOW (tip_window), TRUE);
+ gtk_window_set_decorated (GTK_WINDOW (tip_window), FALSE);
+ gtk_window_set_type_hint (GTK_WINDOW (tip_window), GDK_WINDOW_TYPE_HINT_TOOLTIP);
+ f->output_data.pgtk->current_cursor = f->output_data.pgtk->text_cursor;
+ gtk_widget_show_all (FRAME_GTK_OUTER_WIDGET (f));
+ gdk_window_set_cursor (gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (f)),
+ f->output_data.pgtk->current_cursor);
+
+#if 0
+ x_make_gc (f);
+#endif
+
+ 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);
+
+ /* 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 = intern ("color");
+
+ 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.
+
+ Frame parameters may be changed if .Xdefaults contains
+ specifications for the default font. For example, if there is an
+ `Emacs.default.attributeBackground: pink', the `background-color'
+ attribute of the frame get's set, which let's the internal border
+ of the tooltip frame appear in pink. Prevent this. */
+ {
+ 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. */
+ FRAME_DISPLAY_INFO (f)->reference_count++;
+ 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);
+}
+
+/* Compute where to display tip frame F. PARMS is the list of frame
+ parameters for F. DX and DY are specified offsets from the current
+ location of the mouse. WIDTH and HEIGHT are the width and height
+ of the tooltip. Return coordinates relative to the root window of
+ the display in *ROOT_X, and *ROOT_Y. */
+
+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;
+
+ /* User-specified position? */
+ left = Fcdr (Fassq (Qleft, parms));
+ top = Fcdr (Fassq (Qtop, parms));
+ right = Fcdr (Fassq (Qright, parms));
+ bottom = Fcdr (Fassq (Qbottom, parms));
+
+ /* Move the tooltip window where the mouse pointer is. Resize and
+ show it. */
+ if ((!INTEGERP (left) && !INTEGERP (right))
+ || (!INTEGERP (top) && !INTEGERP (bottom)))
+ {
+ Lisp_Object frame, attributes, monitor, geometry;
+ GdkSeat *seat =
+ gdk_display_get_default_seat (FRAME_DISPLAY_INFO (f)->gdpy);
+ GdkDevice *dev = gdk_seat_get_pointer (seat);
+ GdkScreen *scr;
+
+ block_input ();
+ gdk_device_get_position (dev, &scr, root_x, root_y);
+ unblock_input ();
+
+ XSETFRAME (frame, f);
+ attributes = Fpgtk_display_monitor_attributes_list (frame);
+
+ /* Try to determine the monitor where the mouse pointer is and
+ its geometry. See bug#22549. */
+ while (CONSP (attributes))
+ {
+ monitor = XCAR (attributes);
+ geometry = Fassq (Qgeometry, monitor);
+ if (CONSP (geometry))
+ {
+ min_x = XFIXNUM (Fnth (make_fixnum (1), geometry));
+ min_y = XFIXNUM (Fnth (make_fixnum (2), geometry));
+ max_x = min_x + XFIXNUM (Fnth (make_fixnum (3), geometry));
+ max_y = min_y + XFIXNUM (Fnth (make_fixnum (4), geometry));
+ if (min_x <= *root_x && *root_x < max_x
+ && min_y <= *root_y && *root_y < max_y)
+ {
+ break;
+ }
+ max_y = -1;
+ }
+
+ attributes = XCDR (attributes);
+ }
+ }
+
+ /* It was not possible to determine the monitor's geometry, so we
+ assign some sane defaults here: */
+ if (max_y < 0)
+ {
+ min_x = 0;
+ min_y = 0;
+ max_x = x_display_pixel_width (FRAME_DISPLAY_INFO (f));
+ max_y = x_display_pixel_height (FRAME_DISPLAY_INFO (f));
+ }
+
+ if (INTEGERP (top))
+ *root_y = XFIXNUM (top);
+ else if (INTEGERP (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 (INTEGERP (left))
+ *root_x = XFIXNUM (left);
+ else if (INTEGERP (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;
+}
+
+
+/* Hide tooltip. Delete its frame if DELETE is true. */
+static Lisp_Object
+x_hide_tip (bool delete)
+{
+ if (!NILP (tip_timer))
+ {
+ call1 (Qcancel_timer, tip_timer);
+ tip_timer = Qnil;
+ }
+
+ /* Any GTK+ system tooltip can be found via the x_output structure of
+ tip_last_frame, provided that frame is still live. Any Emacs
+ tooltip is found via the tip_frame variable. Note that the current
+ value of x_gtk_use_system_tooltips might not be the same as used
+ for the tooltip we have to hide, see Bug#30399. */
+ if ((NILP (tip_last_frame) && NILP (tip_frame))
+ || (!x_gtk_use_system_tooltips
+ && !delete
+ && FRAMEP (tip_frame)
+ && FRAME_LIVE_P (XFRAME (tip_frame))
+ && !FRAME_VISIBLE_P (XFRAME (tip_frame))))
+ /* Either there's no tooltip to hide or it's an already invisible
+ Emacs tooltip and we don't want to change its type. Return
+ quickly. */
+ return Qnil;
+ else
+ {
+ ptrdiff_t count;
+ Lisp_Object was_open = Qnil;
+
+ count = SPECPDL_INDEX ();
+ specbind (Qinhibit_redisplay, Qt);
+ specbind (Qinhibit_quit, Qt);
+
+ /* Try to hide the GTK+ system tip first. */
+ if (FRAMEP (tip_last_frame))
+ {
+ struct frame *f = XFRAME (tip_last_frame);
+
+ if (FRAME_LIVE_P (f))
+ {
+ if (xg_hide_tooltip (f))
+ was_open = Qt;
+ }
+ }
+
+ /* When using GTK+ system tooltips (compare Bug#41200) reset
+ tip_last_frame. It will be reassigned when showing the next
+ GTK+ system tooltip. */
+ if (x_gtk_use_system_tooltips)
+ tip_last_frame = Qnil;
+
+ /* Now look whether there's an Emacs tip around. */
+ if (FRAMEP (tip_frame))
+ {
+ struct frame *f = XFRAME (tip_frame);
+
+ if (FRAME_LIVE_P (f))
+ {
+ if (delete || x_gtk_use_system_tooltips)
+ {
+ /* Delete the Emacs tooltip frame when DELETE is true
+ or we change the tooltip type from an Emacs one to
+ a GTK+ system one. */
+ delete_frame (tip_frame, Qnil);
+ tip_frame = Qnil;
+ }
+ else
+ pgtk_make_frame_invisible (f);
+
+ was_open = Qt;
+ }
+ else
+ tip_frame = Qnil;
+ }
+ else
+ tip_frame = Qnil;
+
+ return unbind_to (count, was_open);
+ }
+}
+
+DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0,
+ doc: /* Show STRING in a "tooltip" window on frame FRAME.
+A tooltip window is a small X window displaying a string.
+
+This is an internal function; Lisp code should call `tooltip-show'.
+
+FRAME nil or omitted means use the selected frame.
+
+PARMS is an optional list of frame parameters which can be used to
+change the tooltip's appearance.
+
+Automatically hide the tooltip after TIMEOUT seconds. TIMEOUT nil
+means use the default timeout of 5 seconds.
+
+If the list of frame parameters PARMS contains a `left' parameter,
+display the tooltip at that x-position. If the list of frame parameters
+PARMS contains no `left' but a `right' parameter, display the tooltip
+right-adjusted at that x-position. Otherwise display it at the
+x-position of the mouse, with offset DX added (default is 5 if DX isn't
+specified).
+
+Likewise for the y-position: If a `top' frame parameter is specified, it
+determines the position of the upper edge of the tooltip window. If a
+`bottom' parameter but no `top' frame parameter is specified, it
+determines the position of the lower edge of the tooltip window.
+Otherwise display the tooltip window at the y-position of the mouse,
+with offset DY added (default is -10).
+
+A tooltip's maximum size is specified by `x-max-tooltip-size'.
+Text larger than the specified size is clipped. */)
+ (Lisp_Object string, Lisp_Object frame, Lisp_Object parms,
+ Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy)
+{
+ 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;
+ ptrdiff_t count = SPECPDL_INDEX ();
+ ptrdiff_t count_1;
+ Lisp_Object window, size, tip_buf;
+ 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 (!FRAME_GTK_OUTER_WIDGET (f))
+ return unbind_to (count, Qnil);
+
+ if (NILP (timeout))
+ timeout = make_fixnum (5);
+ else
+ 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);
+
+ if (x_gtk_use_system_tooltips)
+ {
+ bool ok;
+
+ /* Hide a previous tip, if any. */
+ Fx_hide_tip ();
+
+ block_input ();
+
+ ok = true;
+ xg_show_tooltip (f, string);
+ tip_last_frame = frame;
+
+ unblock_input ();
+ if (ok) goto start_timer;
+ }
+
+ if (FRAMEP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame)))
+ {
+ if (FRAME_VISIBLE_P (XFRAME (tip_frame))
+ && EQ (frame, tip_last_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);
+ gtk_window_move (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (tip_f)), root_x, root_y);
+ unblock_input ();
+
+ goto start_timer;
+ }
+ else if (tooltip_reuse_hidden_frame && 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 = Fcar (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 (Fcdr (elt), Fcdr (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 = Fcar (elt);
+ if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright)
+ && !EQ (parm, Qbottom) && !NILP (Fcdr (elt)))
+ {
+ /* We lost, delete the old tooltip. */
+ delete = true;
+ break;
+ }
+ }
+
+ x_hide_tip (delete);
+ }
+ else
+ x_hide_tip (true);
+ }
+ else
+ x_hide_tip (true);
+
+ tip_last_frame = frame;
+ tip_last_string = string;
+ tip_last_parms = parms;
+
+ if (!FRAMEP (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 = x_create_tip_frame (FRAME_DISPLAY_INFO (f), parms, f)))
+ /* 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;
+
+ /* 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. */
+ 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);
+ try_window (window, pos, TRY_WINDOW_IGNORE_FONTS_CHANGE);
+ /* 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 (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
+ height = XFIXNUM (Fcdr (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 ();
+ gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (tip_f)), width, height);
+ gtk_window_move (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (tip_f)), root_x, root_y);
+ unblock_input ();
+
+ pgtk_cr_update_surface_desired_size (tip_f, width, height, false);
+
+ 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;
+
+ start_timer:
+ /* Let the tip disappear after timeout seconds. */
+ tip_timer = call3 (intern ("run-at-time"), timeout, Qnil,
+ intern ("x-hide-tip"));
+
+ return unbind_to (count, Qnil);
+}
+
+
+DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0,
+ doc: /* Hide the current tooltip window, if there is any.
+Value is t if tooltip was open, nil otherwise. */)
+ (void)
+{
+ return x_hide_tip (!tooltip_reuse_hidden_frame);
+}
+
+/* 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
+ Fx_frame_geometry. */
+static Lisp_Object
+frame_geometry (Lisp_Object frame, Lisp_Object attribute)
+{
+ struct frame *f = decode_live_frame (frame);
+ Lisp_Object fullscreen_symbol = Fframe_parameter (frame, Qfullscreen);
+ bool fullscreen = (EQ (fullscreen_symbol, Qfullboth)
+ || EQ (fullscreen_symbol, Qfullscreen));
+ int border = fullscreen ? 0 : f->border_width;
+ int title_height = 0;
+ int native_width = FRAME_PIXEL_WIDTH (f);
+ int native_height = FRAME_PIXEL_HEIGHT (f);
+ int outer_width = native_width + 2 * border;
+ int outer_height = native_height + 2 * border + title_height;
+
+ /* Get these here because they can't be got in configure_event(). */
+ int left_pos, top_pos;
+
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ gtk_window_get_position (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ &left_pos, &top_pos);
+ }
+ else
+ {
+ GtkAllocation alloc;
+
+ if (FRAME_GTK_WIDGET (f) == NULL)
+ return Qnil; /* This can occur while creating a frame. */
+
+ gtk_widget_get_allocation (FRAME_GTK_WIDGET (f), &alloc);
+ left_pos = alloc.x;
+ top_pos = alloc.y;
+ }
+
+ int native_left = left_pos + border;
+ int native_top = top_pos + border + title_height;
+ int native_right = left_pos + outer_width - border;
+ int native_bottom = top_pos + outer_height - border;
+ int internal_border_width = FRAME_INTERNAL_BORDER_WIDTH (f);
+ int tab_bar_height = 0, tab_bar_width = 0;
+ int tool_bar_height = FRAME_TOOLBAR_HEIGHT (f);
+ int tool_bar_width = (tool_bar_height
+ ? outer_width - 2 * internal_border_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; */
+
+ /* Construct list. */
+ if (EQ (attribute, Qouter_edges))
+ return list4 (make_fixnum (left_pos), make_fixnum (top_pos),
+ make_fixnum (left_pos + outer_width),
+ make_fixnum (top_pos + outer_height));
+ else if (EQ (attribute, Qnative_edges))
+ return list4 (make_fixnum (native_left), make_fixnum (native_top),
+ make_fixnum (native_right), make_fixnum (native_bottom));
+ else if (EQ (attribute, Qinner_edges))
+ return list4 (make_fixnum (native_left + internal_border_width),
+ make_fixnum (native_top
+ + tool_bar_height
+ + internal_border_width),
+ make_fixnum (native_right - internal_border_width),
+ make_fixnum (native_bottom - internal_border_width));
+ else
+ return
+ list (Fcons (Qouter_position,
+ Fcons (make_fixnum (left_pos),
+ make_fixnum (top_pos))),
+ Fcons (Qouter_size,
+ Fcons (make_fixnum (outer_width),
+ make_fixnum (outer_height))),
+ Fcons (Qexternal_border_size,
+ (fullscreen
+ ? Fcons (make_fixnum (0), make_fixnum (0))
+ : Fcons (make_fixnum (border), make_fixnum (border)))),
+ Fcons (Qtitle_bar_size,
+ Fcons (make_fixnum (0), make_fixnum (title_height))),
+ Fcons (Qmenu_bar_external, Qnil),
+ Fcons (Qmenu_bar_size, Fcons (make_fixnum (0), make_fixnum (0))),
+ Fcons (Qtab_bar_size,
+ Fcons (make_fixnum (tab_bar_width),
+ make_fixnum (tab_bar_height))),
+ Fcons (Qtool_bar_external,
+ FRAME_EXTERNAL_TOOL_BAR (f) ? 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)));
+}
+
+DEFUN ("pgtk-frame-geometry", Fpgtk_frame_geometry, Spgtk_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)
+{
+ return frame_geometry (frame, Qnil);
+}
+
+DEFUN ("pgtk-frame-edges", Fpgtk_frame_edges, Spgtk_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)
+{
+ return frame_geometry (frame, ((EQ (type, Qouter_edges)
+ || EQ (type, Qinner_edges))
+ ? 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,
+ 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. */)
+ (Lisp_Object x, Lisp_Object y)
+{
+ struct frame *f = SELECTED_FRAME ();
+ GtkWidget *widget = gtk_widget_get_toplevel (FRAME_WIDGET (f));
+ GdkWindow *window = gtk_widget_get_window (widget);
+ GdkDisplay *gdpy = gdk_window_get_display (window);
+ GdkScreen *gscr = gdk_window_get_screen (window);
+ GdkSeat *seat = gdk_display_get_default_seat (gdpy);
+ GdkDevice *device = gdk_seat_get_pointer (seat);
+
+ gdk_device_warp (device, gscr, XFIXNUM (x), XFIXNUM (y)); /* No effect on wayland. */
+
+ return Qnil;
+}
+
+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
+position (0, 0) of the selected frame's terminal. */)
+ (void)
+{
+ struct frame *f = SELECTED_FRAME ();
+ GtkWidget *widget = gtk_widget_get_toplevel (FRAME_WIDGET (f));
+ GdkWindow *window = gtk_widget_get_window (widget);
+ GdkDisplay *gdpy = gdk_window_get_display (window);
+ GdkScreen *gscr;
+ GdkSeat *seat = gdk_display_get_default_seat (gdpy);
+ GdkDevice *device = gdk_seat_get_pointer (seat);
+ int x = 0, y = 0;
+
+ gdk_device_get_position (device, &gscr, &x, &y); /* can't get on wayland? */
+
+ return Fcons (make_fixnum (x), make_fixnum (y));
+}
+
+
+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)
+{
+ block_input ();
+ xg_page_setup_dialog ();
+ unblock_input ();
+
+ return Qnil;
+}
+
+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:
+
+orientation: page orientation (symbol `portrait', `landscape',
+`reverse-portrait', or `reverse-landscape').
+width, height: page width/height in points not including margins.
+left-margin, right-margin, top-margin, bottom-margin: print margins,
+which is the parts of the page that the printer cannot print
+on, in points.
+
+The paper width can be obtained as the sum of width, left-margin, and
+right-margin values if the page orientation is `portrait' or
+`reverse-portrait'. Otherwise, it is the sum of width, top-margin,
+and bottom-margin values. Likewise, the paper height is the sum of
+height, top-margin, and bottom-margin values if the page orientation
+is `portrait' or `reverse-portrait'. Otherwise, it is the sum of
+height, left-margin, and right-margin values. */)
+ (void)
+{
+ Lisp_Object result;
+
+ block_input ();
+ result = xg_get_page_setup ();
+ unblock_input ();
+
+ return result;
+}
+
+DEFUN ("pgtk-print-frames-dialog", Fpgtk_print_frames_dialog, Spgtk_print_frames_dialog, 0, 1, "",
+ doc: /* Pop up a print dialog to print the current contents of FRAMES.
+FRAMES should be nil (the selected frame), a frame, or a list of
+frames (each of which corresponds to one page). Each frame should be
+visible. */)
+ (Lisp_Object frames)
+{
+ Lisp_Object rest, tmp;
+ int count;
+
+ if (!CONSP (frames))
+ frames = list1 (frames);
+
+ tmp = Qnil;
+ for (rest = frames; CONSP (rest); rest = XCDR (rest))
+ {
+ struct frame *f = decode_window_system_frame (XCAR (rest));
+ Lisp_Object frame;
+
+ XSETFRAME (frame, f);
+ if (!FRAME_VISIBLE_P (f))
+ error ("Frames to be printed must be visible.");
+ tmp = Fcons (frame, tmp);
+ }
+ frames = Fnreverse (tmp);
+
+ /* Make sure the current matrices are up-to-date. */
+ count = SPECPDL_INDEX ();
+ specbind (Qredisplay_dont_pause, Qt);
+ redisplay_preserve_echo_area (32);
+ unbind_to (count, Qnil);
+
+ block_input ();
+ xg_print_frames_dialog (frames);
+ unblock_input ();
+
+ return Qnil;
+}
+
+static void
+clean_up_dialog (void)
+{
+ pgtk_menu_set_in_use (false);
+}
+
+DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 5, 0,
+ doc: /* Read file name, prompting with PROMPT in directory DIR.
+Use a file selection dialog. Select DEFAULT-FILENAME in the dialog's file
+selection box, if specified. If MUSTMATCH is non-nil, the returned file
+or directory must exist.
+
+This function is defined only on PGTK, NS, MS Windows, and X Windows with the
+Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored.
+Otherwise, if ONLY-DIR-P is non-nil, the user can select only directories.
+On MS Windows 7 and later, the file selection dialog "remembers" the last
+directory where the user selected a file, and will open that directory
+instead of DIR on subsequent invocations of this function with the same
+value of DIR as in previous invocations; this is standard MS Windows behavior. */)
+ (Lisp_Object prompt, Lisp_Object dir, Lisp_Object default_filename,
+ Lisp_Object mustmatch, Lisp_Object only_dir_p)
+{
+ struct frame *f = SELECTED_FRAME ();
+ char *fn;
+ Lisp_Object file = Qnil;
+ Lisp_Object decoded_file;
+ ptrdiff_t count = SPECPDL_INDEX ();
+ char *cdef_file;
+
+ check_window_system (f);
+
+ if (popup_activated ())
+ error ("Trying to use a menu from within a menu-entry");
+ else
+ pgtk_menu_set_in_use (true);
+
+ CHECK_STRING (prompt);
+ CHECK_STRING (dir);
+
+ /* Prevent redisplay. */
+ specbind (Qinhibit_redisplay, Qt);
+ record_unwind_protect_void (clean_up_dialog);
+
+ block_input ();
+
+ if (STRINGP (default_filename))
+ cdef_file = SSDATA (default_filename);
+ else
+ cdef_file = SSDATA (dir);
+
+ fn = xg_get_file_name (f, SSDATA (prompt), cdef_file,
+ !NILP (mustmatch), !NILP (only_dir_p));
+
+ if (fn)
+ {
+ file = build_string (fn);
+ xfree (fn);
+ }
+
+ unblock_input ();
+
+ /* Make "Cancel" equivalent to C-g. */
+ if (NILP (file))
+ quit ();
+
+ decoded_file = DECODE_FILE (file);
+
+ return unbind_to (count, decoded_file);
+}
+
+DEFUN ("pgtk-backend-display-class", Fpgtk_backend_display_class, Spgtk_backend_display_class, 0, 1, "",
+ doc: /* Return the name of the Gdk backend display class of 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. */)
+ (Lisp_Object terminal)
+{
+ struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal);
+ GdkDisplay *gdpy = dpyinfo->gdpy;
+ const gchar *type_name = G_OBJECT_TYPE_NAME (G_OBJECT (gdpy));
+ return build_string (type_name);
+}
+
+DEFUN ("x-select-font", Fx_select_font, Sx_select_font, 0, 2, 0,
+ doc: /* Read a font using a GTK dialog and return a font spec.
+
+FRAME is the frame on which to pop up the font chooser. If omitted or
+nil, it defaults to the selected frame. */)
+ (Lisp_Object frame, Lisp_Object ignored)
+{
+ struct frame *f = decode_window_system_frame (frame);
+ Lisp_Object font;
+ Lisp_Object font_param;
+ char *default_name = NULL;
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ if (popup_activated ())
+ error ("Trying to use a menu from within a menu-entry");
+ else
+ pgtk_menu_set_in_use (true);
+
+ /* Prevent redisplay. */
+ specbind (Qinhibit_redisplay, Qt);
+ record_unwind_protect_void (clean_up_dialog);
+
+ block_input ();
+
+ XSETFONT (font, FRAME_FONT (f));
+ font_param = Ffont_get (font, QCname);
+ if (STRINGP (font_param))
+ default_name = xlispstrdup (font_param);
+ else
+ {
+ font_param = Fframe_parameter (frame, Qfont_parameter);
+ if (STRINGP (font_param))
+ default_name = xlispstrdup (font_param);
+ }
+
+ font = xg_get_font (f, default_name);
+ xfree (default_name);
+
+ unblock_input ();
+
+ if (NILP (font))
+ quit ();
+
+ return unbind_to (count, font);
+}
+
+/* ==========================================================================
+
+ Lisp interface declaration
+
+ ========================================================================== */
+
+void
+syms_of_pgtkfns (void)
+{
+ DEFSYM (Qfont_parameter, "font-parameter");
+ DEFSYM (Qfontsize, "fontsize");
+ DEFSYM (Qcancel_timer, "cancel-timer");
+ DEFSYM (Qframe_title_format, "frame-title-format");
+ DEFSYM (Qicon_title_format, "icon-title-format");
+ DEFSYM (Qdark, "dark");
+ DEFSYM (Qhide, "hide");
+ DEFSYM (Qresize_mode, "resize-mode");
+
+ DEFVAR_LISP ("x-cursor-fore-pixel", Vx_cursor_fore_pixel,
+ doc: /* A string indicating the foreground color of the cursor box. */);
+ Vx_cursor_fore_pixel = Qnil;
+
+ DEFVAR_LISP ("pgtk-icon-type-alist", Vpgtk_icon_type_alist,
+ doc: /* Alist of elements (REGEXP . IMAGE) for images of icons associated to frames.
+If the title of a frame matches REGEXP, then IMAGE.tiff is
+selected as the image of the icon representing the frame when it's
+miniaturized. If an element is t, then Emacs tries to select an icon
+based on the filetype of the visited file.
+
+The images have to be installed in a folder called English.lproj in the
+Emacs folder. You have to restart Emacs after installing new icons.
+
+Example: Install an icon Gnus.tiff and execute the following code
+
+(setq pgtk-icon-type-alist
+(append pgtk-icon-type-alist
+\\='((\"^\\\\*\\\\(Group\\\\*$\\\\|Summary \\\\|Article\\\\*$\\\\)\"
+. \"Gnus\"))))
+
+When you miniaturize a Group, Summary or Article frame, Gnus.tiff will
+be used as the image of the icon representing the frame. */);
+ Vpgtk_icon_type_alist = list1 (Qt);
+
+
+ /* Provide x-toolkit also for GTK. Internally GTK does not use Xt so it
+ is not an X toolkit in that sense (USE_X_TOOLKIT is not defined).
+ But for a user it is a toolkit for X, and indeed, configure
+ 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+. */);
+ {
+ char *ver = g_strdup_printf ("%d.%d.%d",
+ GTK_MAJOR_VERSION, GTK_MINOR_VERSION,
+ GTK_MICRO_VERSION);
+ int len = strlen (ver);
+ Vgtk_version_string = make_pure_string (ver, len, len, false);
+ g_free (ver);
+ }
+
+
+ Fprovide (intern_c_string ("cairo"), Qnil);
+
+ DEFVAR_LISP ("cairo-version-string", Vcairo_version_string,
+ doc: /* Version info for cairo. */);
+ {
+ char *ver = g_strdup_printf ("%d.%d.%d",
+ CAIRO_VERSION_MAJOR, CAIRO_VERSION_MINOR,
+ CAIRO_VERSION_MICRO);
+ int len = strlen (ver);
+ Vcairo_version_string = make_pure_string (ver, len, len, false);
+ g_free (ver);
+ }
+
+
+ defsubr (&Spgtk_set_resource);
+ defsubr (&Sxw_display_color_p); /* this and next called directly by C code */
+ defsubr (&Sx_display_grayscale_p);
+ defsubr (&Spgtk_font_name);
+ defsubr (&Sxw_color_defined_p);
+ defsubr (&Sxw_color_values);
+ defsubr (&Sx_server_max_request_size);
+ defsubr (&Sx_server_vendor);
+ defsubr (&Sx_server_version);
+ defsubr (&Sx_display_pixel_width);
+ defsubr (&Sx_display_pixel_height);
+ defsubr (&Spgtk_display_monitor_attributes_list);
+ defsubr (&Spgtk_frame_geometry);
+ defsubr (&Spgtk_frame_edges);
+ defsubr (&Spgtk_frame_restack);
+ defsubr (&Spgtk_set_mouse_absolute_pixel_position);
+ defsubr (&Spgtk_mouse_absolute_pixel_position);
+ defsubr (&Sx_display_mm_width);
+ defsubr (&Sx_display_mm_height);
+ defsubr (&Sx_display_screens);
+ defsubr (&Sx_display_planes);
+ defsubr (&Sx_display_color_cells);
+ defsubr (&Sx_display_visual_class);
+ defsubr (&Sx_display_backing_store);
+ defsubr (&Sx_display_save_under);
+ defsubr (&Sx_create_frame);
+ defsubr (&Sx_open_connection);
+ defsubr (&Sx_close_connection);
+ defsubr (&Sx_display_list);
+
+ defsubr (&Spgtk_hide_others);
+ defsubr (&Spgtk_hide_emacs);
+
+ defsubr (&Sx_show_tip);
+ defsubr (&Sx_hide_tip);
+
+ defsubr (&Sx_export_frames);
+ defsubr (&Spgtk_page_setup_dialog);
+ defsubr (&Spgtk_get_page_setup);
+ defsubr (&Spgtk_print_frames_dialog);
+ defsubr (&Spgtk_backend_display_class);
+
+ defsubr (&Spgtk_set_monitor_scale_factor);
+
+ defsubr (&Sx_file_dialog);
+ defsubr (&Sx_select_font);
+
+ as_status = 0;
+ as_script = Qnil;
+ as_result = 0;
+
+ monitor_scale_factor_alist = Qnil;
+ staticpro (&monitor_scale_factor_alist);
+
+ 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);
+
+ /* This is not ifdef:ed, so other builds than GTK can customize it. */
+ DEFVAR_BOOL ("x-gtk-use-old-file-dialog", x_gtk_use_old_file_dialog,
+ doc: /* Non-nil means prompt with the old GTK file selection dialog.
+If nil or if the file selection dialog is not available, the new GTK file
+chooser is used instead. To turn off all file dialogs set the
+variable `use-file-dialog'. */);
+ x_gtk_use_old_file_dialog = false;
+
+ DEFVAR_BOOL ("x-gtk-show-hidden-files", x_gtk_show_hidden_files,
+ doc: /* If non-nil, the GTK file chooser will by default show hidden files.
+Note that this is just the default, there is a toggle button on the file
+chooser to show or not show hidden files on a case by case basis. */);
+ x_gtk_show_hidden_files = false;
+
+ DEFVAR_BOOL ("x-gtk-file-dialog-help-text", x_gtk_file_dialog_help_text,
+ doc: /* If non-nil, the GTK file chooser will show additional help text.
+If more space for files in the file chooser dialog is wanted, set this to nil
+to turn the additional text off. */);
+ x_gtk_file_dialog_help_text = true;
+
+ DEFVAR_BOOL ("x-gtk-use-system-tooltips", x_gtk_use_system_tooltips,
+ doc: /* If non-nil with a Gtk+ built Emacs, the Gtk+ tooltip is used.
+Otherwise use Emacs own tooltip implementation.
+When using Gtk+ tooltips, the tooltip face is not used. */);
+ x_gtk_use_system_tooltips = true;
+
+ DEFVAR_LISP ("x-max-tooltip-size", Vx_max_tooltip_size,
+ doc: /* Maximum size for tooltips.
+Value is a pair (COLUMNS . ROWS). Text larger than this is clipped. */);
+ Vx_max_tooltip_size = Fcons (make_fixnum (80), make_fixnum (40));
+
+ DEFVAR_LISP ("x-gtk-resize-child-frames", x_gtk_resize_child_frames,
+ doc: /* If non-nil, resize child frames specially with GTK builds.
+If this is nil, resize child frames like any other frames. This is the
+default and usually works with most desktops. Some desktop environments
+(GNOME shell in particular when using the mutter window manager),
+however, may refuse to resize a child frame when Emacs is built with
+GTK3. For those environments, the two settings below are provided.
+
+If this equals the symbol 'hide', Emacs temporarily hides the child
+frame during resizing. This approach seems to work reliably, may
+however induce some flicker when the frame is made visible again.
+
+If this equals the symbol 'resize-mode', Emacs uses GTK's resize mode to
+always trigger an immediate resize of the child frame. This method is
+deprecated by GTK and may not work in future versions of that toolkit.
+It also may freeze Emacs when used with other desktop environments. It
+avoids, however, the unpleasant flicker induced by the hiding approach.
+
+This variable is considered a temporary workaround and will be hopefully
+eliminated in future versions of Emacs. */);
+ x_gtk_resize_child_frames = Qnil;
+
+
+ DEFSYM (Qmono, "mono");
+ DEFSYM (Qassq_delete_all, "assq-delete-all");
+
+ DEFSYM (Qpdf, "pdf");
+
+ DEFSYM (Qorientation, "orientation");
+ DEFSYM (Qtop_margin, "top-margin");
+ DEFSYM (Qbottom_margin, "bottom-margin");
+ DEFSYM (Qportrait, "portrait");
+ DEFSYM (Qlandscape, "landscape");
+ DEFSYM (Qreverse_portrait, "reverse-portrait");
+ DEFSYM (Qreverse_landscape, "reverse-landscape");
+}
+
+#endif
diff --git a/src/pgtkgui.h b/src/pgtkgui.h
new file mode 100644
index 00000000000..035e0179f67
--- /dev/null
+++ b/src/pgtkgui.h
@@ -0,0 +1,119 @@
+/* Definitions and headers for communication on the pure Gtk+3.
+ Copyright (C) 1995, 2005, 2008-2020 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+
+#ifndef __PGTKGUI_H__
+#define __PGTKGUI_H__
+
+/* Emulate XCharStruct. */
+typedef struct _XCharStruct
+{
+ int rbearing;
+ int lbearing;
+ int width;
+ int ascent;
+ int descent;
+} XCharStruct;
+
+/* Fake structure from Xlib.h to represent two-byte characters. */
+typedef unsigned short unichar;
+typedef unichar XChar2b;
+
+#define STORE_XCHAR2B(chp, b1, b2) \
+ (*(chp) = ((XChar2b)((((b1) & 0x00ff) << 8) | ((b2) & 0x00ff))))
+
+#define XCHAR2B_BYTE1(chp) \
+ ((*(chp) & 0xff00) >> 8)
+
+#define XCHAR2B_BYTE2(chp) \
+ (*(chp) & 0x00ff)
+
+
+typedef struct _GdkCursor *Emacs_Cursor;
+
+typedef void *Color;
+typedef int Window;
+typedef struct _GdkDisplay Display;
+
+/* Xism */
+typedef void *XrmDatabase;
+
+
+/* Some sort of attempt to normalize rectangle handling.. seems a bit much
+ for what is accomplished. */
+typedef struct
+{
+ int x, y;
+ unsigned width, height;
+} XRectangle;
+
+/* This stuff is needed by frame.c. */
+#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 */
+
+
+#define NativeRectangle XRectangle
+
+#define CONVERT_TO_EMACS_RECT(xr, nr) \
+ ((xr).x = (nr).x, \
+ (xr).y = (nr).y, \
+ (xr).width = (nr).width, \
+ (xr).height = (nr).height)
+
+#define CONVERT_FROM_EMACS_RECT(xr, nr) \
+ ((nr).x = (xr).x, \
+ (nr).y = (xr).y, \
+ (nr).width = (xr).width, \
+ (nr).height = (xr).height)
+
+#define STORE_NATIVE_RECT(nr, px, py, pwidth, pheight) \
+ ((nr).x = (px), \
+ (nr).y = (py), \
+ (nr).width = (pwidth), \
+ (nr).height = (pheight))
+
+#endif /* __PGTKGUI_H__ */
diff --git a/src/pgtkim.c b/src/pgtkim.c
new file mode 100644
index 00000000000..c0104ebc0ae
--- /dev/null
+++ b/src/pgtkim.c
@@ -0,0 +1,311 @@
+/* Pure Gtk+-3 communication module.
+
+Copyright (C) 1989, 1993-1994, 2005-2006, 2008-2020 Free Software
+Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+
+/* This should be the first include, as it may set up #defines affecting
+ interpretation of even the system includes. */
+#include <config.h>
+
+#include "pgtkterm.h"
+
+static void
+im_context_commit_cb (GtkIMContext * imc, gchar * str, gpointer user_data)
+{
+ struct pgtk_display_info *dpyinfo = user_data;
+ struct frame *f = dpyinfo->im.focused_frame;
+
+ if (dpyinfo->im.context == NULL)
+ return;
+ if (f == NULL)
+ return;
+
+ pgtk_enqueue_string (f, str);
+}
+
+static gboolean
+im_context_retrieve_surrounding_cb (GtkIMContext * imc, gpointer user_data)
+{
+ gtk_im_context_set_surrounding (imc, "", -1, 0);
+ return TRUE;
+}
+
+static gboolean
+im_context_delete_surrounding_cb (GtkIMContext * imc, int offset, int n_chars,
+ gpointer user_data)
+{
+ return TRUE;
+}
+
+static Lisp_Object
+make_color_string (PangoAttrColor * pac)
+{
+ char buf[256];
+ sprintf (buf, "#%02x%02x%02x",
+ pac->color.red >> 8, pac->color.green >> 8, pac->color.blue >> 8);
+ return build_string (buf);
+}
+
+static void
+im_context_preedit_changed_cb (GtkIMContext * imc, gpointer user_data)
+{
+ struct pgtk_display_info *dpyinfo = user_data;
+ struct frame *f = dpyinfo->im.focused_frame;
+ char *str;
+ PangoAttrList *attrs;
+ int pos;
+
+ if (dpyinfo->im.context == NULL)
+ return;
+ if (f == NULL)
+ return;
+
+ gtk_im_context_get_preedit_string (imc, &str, &attrs, &pos);
+
+
+ /*
+ * (
+ * (TEXT (ul . COLOR) (bg . COLOR) (fg . COLOR))
+ * ...
+ * )
+ */
+ Lisp_Object list = Qnil;
+
+ PangoAttrIterator *iter;
+ iter = pango_attr_list_get_iterator (attrs);
+ do
+ {
+ int st, ed;
+ int has_underline = 0;
+ Lisp_Object part = Qnil;
+
+ pango_attr_iterator_range (iter, &st, &ed);
+
+ if (ed > strlen (str))
+ ed = strlen (str);
+ if (st >= ed)
+ continue;
+
+ Lisp_Object text = make_string (str + st, ed - st);
+ part = Fcons (text, part);
+
+ PangoAttrInt *ul =
+ (PangoAttrInt *) pango_attr_iterator_get (iter, PANGO_ATTR_UNDERLINE);
+ if (ul != NULL)
+ {
+ if (ul->value != PANGO_UNDERLINE_NONE)
+ has_underline = 1;
+ }
+
+ PangoAttrColor *pac;
+ if (has_underline)
+ {
+ pac =
+ (PangoAttrColor *) pango_attr_iterator_get (iter,
+ PANGO_ATTR_UNDERLINE_COLOR);
+ if (pac != NULL)
+ part = Fcons (Fcons (Qul, make_color_string (pac)), part);
+ else
+ part = Fcons (Fcons (Qul, Qt), part);
+ }
+
+ pac =
+ (PangoAttrColor *) pango_attr_iterator_get (iter,
+ PANGO_ATTR_FOREGROUND);
+ if (pac != NULL)
+ part = Fcons (Fcons (Qfg, make_color_string (pac)), part);
+
+ pac =
+ (PangoAttrColor *) pango_attr_iterator_get (iter,
+ PANGO_ATTR_BACKGROUND);
+ if (pac != NULL)
+ part = Fcons (Fcons (Qbg, make_color_string (pac)), part);
+
+ part = Fnreverse (part);
+ list = Fcons (part, list);
+ }
+ while (pango_attr_iterator_next (iter));
+
+ list = Fnreverse (list);
+ pgtk_enqueue_preedit (f, list);
+
+ g_free (str);
+ pango_attr_list_unref (attrs);
+}
+
+static void
+im_context_preedit_end_cb (GtkIMContext * imc, gpointer user_data)
+{
+ struct pgtk_display_info *dpyinfo = user_data;
+ struct frame *f = dpyinfo->im.focused_frame;
+
+ if (dpyinfo->im.context == NULL)
+ return;
+ if (f == NULL)
+ return;
+
+ pgtk_enqueue_preedit (f, Qnil);
+}
+
+static void
+im_context_preedit_start_cb (GtkIMContext * imc, gpointer user_data)
+{
+}
+
+void
+pgtk_im_focus_in (struct frame *f)
+{
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+ if (dpyinfo->im.context != NULL)
+ {
+ gtk_im_context_reset (dpyinfo->im.context);
+ gtk_im_context_set_client_window (dpyinfo->im.context,
+ gtk_widget_get_window
+ (FRAME_GTK_WIDGET (f)));
+ gtk_im_context_focus_in (dpyinfo->im.context);
+ }
+ dpyinfo->im.focused_frame = f;
+}
+
+void
+pgtk_im_focus_out (struct frame *f)
+{
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+ if (dpyinfo->im.focused_frame == f)
+ {
+ if (dpyinfo->im.context != NULL)
+ {
+ gtk_im_context_reset (dpyinfo->im.context);
+ gtk_im_context_focus_out (dpyinfo->im.context);
+ gtk_im_context_set_client_window (dpyinfo->im.context, NULL);
+ }
+ dpyinfo->im.focused_frame = NULL;
+ }
+}
+
+bool
+pgtk_im_filter_keypress (struct frame *f, GdkEventKey * ev)
+{
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+ if (dpyinfo->im.context != NULL)
+ {
+ if (gtk_im_context_filter_keypress (dpyinfo->im.context, ev))
+ return true;
+ }
+ return false;
+}
+
+void
+pgtk_im_set_cursor_location (struct frame *f, int x, int y, int width,
+ int height)
+{
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+ if (dpyinfo->im.context != NULL && dpyinfo->im.focused_frame == f)
+ {
+ GdkRectangle area = { x, y, width, height };
+ gtk_im_context_set_cursor_location (dpyinfo->im.context, &area);
+ }
+}
+
+static void
+pgtk_im_use_context (struct pgtk_display_info *dpyinfo, bool use_p)
+{
+ if (!use_p)
+ {
+ if (dpyinfo->im.context != NULL)
+ {
+ gtk_im_context_reset (dpyinfo->im.context);
+ gtk_im_context_focus_out (dpyinfo->im.context);
+ gtk_im_context_set_client_window (dpyinfo->im.context, NULL);
+
+ g_object_unref (dpyinfo->im.context);
+ dpyinfo->im.context = NULL;
+ }
+ }
+ else
+ {
+ if (dpyinfo->im.context == NULL)
+ {
+ dpyinfo->im.context = gtk_im_multicontext_new ();
+ g_signal_connect (dpyinfo->im.context, "commit",
+ G_CALLBACK (im_context_commit_cb), dpyinfo);
+ g_signal_connect (dpyinfo->im.context, "retrieve-surrounding",
+ G_CALLBACK (im_context_retrieve_surrounding_cb),
+ dpyinfo);
+ g_signal_connect (dpyinfo->im.context, "delete-surrounding",
+ G_CALLBACK (im_context_delete_surrounding_cb),
+ dpyinfo);
+ g_signal_connect (dpyinfo->im.context, "preedit-changed",
+ G_CALLBACK (im_context_preedit_changed_cb),
+ dpyinfo);
+ g_signal_connect (dpyinfo->im.context, "preedit-end",
+ G_CALLBACK (im_context_preedit_end_cb), dpyinfo);
+ g_signal_connect (dpyinfo->im.context, "preedit-start",
+ G_CALLBACK (im_context_preedit_start_cb),
+ dpyinfo);
+ gtk_im_context_set_use_preedit (dpyinfo->im.context, TRUE);
+
+ if (dpyinfo->im.focused_frame)
+ pgtk_im_focus_in (dpyinfo->im.focused_frame);
+ }
+ }
+}
+
+void
+pgtk_im_init (struct pgtk_display_info *dpyinfo)
+{
+ dpyinfo->im.context = NULL;
+
+ pgtk_im_use_context (dpyinfo, !NILP (Vpgtk_use_im_context_on_new_connection));
+}
+
+void
+pgtk_im_finish (struct pgtk_display_info *dpyinfo)
+{
+ if (dpyinfo->im.context != NULL)
+ g_object_unref (dpyinfo->im.context);
+ dpyinfo->im.context = NULL;
+}
+
+DEFUN ("pgtk-use-im-context", Fpgtk_use_im_context, Spgtk_use_im_context, 1, 2, 0,
+ doc: /* Set whether to use GtkIMContext. */)
+ (Lisp_Object use_p, Lisp_Object terminal)
+{
+ struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal);
+
+ pgtk_im_use_context (dpyinfo, !NILP (use_p));
+
+ return Qnil;
+}
+
+void
+syms_of_pgtkim (void)
+{
+ defsubr (&Spgtk_use_im_context);
+
+ DEFSYM (Qpgtk_refresh_preedit, "pgtk-refresh-preedit");
+ DEFSYM (Qul, "ul");
+ DEFSYM (Qfg, "fg");
+ DEFSYM (Qbg, "bg");
+
+ DEFVAR_LISP ("pgtk-use-im-context-on-new-connection", Vpgtk_use_im_context_on_new_connection,
+ doc: /* Whether to use GtkIMContext on a new connection.
+If you want to change it after connection, use the `pgtk-use-im-context'
+function. */ );
+ Vpgtk_use_im_context_on_new_connection = Qt;
+}
diff --git a/src/pgtkmenu.c b/src/pgtkmenu.c
new file mode 100644
index 00000000000..fd2c53a1b82
--- /dev/null
+++ b/src/pgtkmenu.c
@@ -0,0 +1,1159 @@
+/* Pure GTK3 menu and toolbar module.
+ Copyright (C) 2019-2020 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+
+/*
+ */
+
+
+/* This should be the first include, as it may set up #defines affecting
+ interpretation of even the system includes. */
+#include <config.h>
+
+#include "lisp.h"
+#include "frame.h"
+#include "window.h"
+#include "character.h"
+#include "buffer.h"
+#include "keymap.h"
+#include "coding.h"
+#include "commands.h"
+#include "blockinput.h"
+#include "termhooks.h"
+#include "keyboard.h"
+#include "menu.h"
+#include "pdumper.h"
+#include "xgselect.h"
+
+#include "gtkutil.h"
+#include <gtk/gtk.h>
+
+/* Flag which when set indicates a dialog or menu has been posted by
+ Xt on behalf of one of the widget sets. */
+static int popup_activated_flag;
+
+/* Set menu_items_inuse so no other popup menu or dialog is created. */
+
+void
+pgtk_menu_set_in_use (bool in_use)
+{
+ Lisp_Object frames, frame;
+
+ menu_items_inuse = in_use;
+ popup_activated_flag = in_use;
+
+ /* Don't let frames in `above' z-group obscure popups. */
+ FOR_EACH_FRAME (frames, frame)
+ {
+ struct frame *f = XFRAME (frame);
+
+ if (in_use && FRAME_Z_GROUP_ABOVE (f))
+ x_set_z_group (f, Qabove_suspended, Qabove);
+ else if (!in_use && FRAME_Z_GROUP_ABOVE_SUSPENDED (f))
+ x_set_z_group (f, Qabove, Qabove_suspended);
+ }
+}
+
+DEFUN ("x-menu-bar-open-internal", Fx_menu_bar_open_internal, Sx_menu_bar_open_internal, 0, 1, "i",
+ doc: /* Start key navigation of the menu bar in FRAME.
+ This initially opens the first menu bar item and you can then navigate with the
+ arrow keys, select a menu entry with the return key or cancel with the
+ escape key. If FRAME has no menu bar this function does nothing.
+
+ If FRAME is nil or not given, use the selected frame. */)
+ (Lisp_Object frame)
+{
+ GtkWidget *menubar;
+ struct frame *f;
+
+ block_input ();
+ f = decode_window_system_frame (frame);
+
+ if (FRAME_EXTERNAL_MENU_BAR (f))
+ set_frame_menubar (f, true);
+
+ menubar = FRAME_X_OUTPUT (f)->menubar_widget;
+ if (menubar)
+ {
+ /* Activate the first menu. */
+ GList *children = gtk_container_get_children (GTK_CONTAINER (menubar));
+
+ if (children)
+ {
+ g_signal_emit_by_name (children->data, "activate_item");
+ g_list_free (children);
+ }
+ }
+ unblock_input ();
+
+ return Qnil;
+}
+
+/* Loop util popup_activated_flag is set to zero in a callback.
+ Used for popup menus and dialogs. */
+
+static void
+popup_widget_loop (bool do_timers, GtkWidget *widget)
+{
+ ++popup_activated_flag;
+
+ /* Process events in the Gtk event loop until done. */
+ while (popup_activated_flag)
+ gtk_main_iteration ();
+}
+
+void
+pgtk_activate_menubar (struct frame *f)
+{
+ set_frame_menubar (f, true);
+
+ popup_activated_flag = 1;
+
+ /* f->output_data.pgtk->menubar_active = 1; */
+}
+
+/* This callback is invoked when a dialog or menu is finished being
+ used and has been unposted. */
+
+static void
+popup_deactivate_callback (GtkWidget *widget, gpointer client_data)
+{
+ popup_activated_flag = 0;
+}
+
+/* Function that finds the frame for WIDGET and shows the HELP text
+ for that widget.
+ F is the frame if known, or NULL if not known. */
+static void
+show_help_event (struct frame *f, GtkWidget *widget, Lisp_Object help)
+{
+ /* Don't show this tooltip.
+ * Tooltips are always tied to main widget, so stacking order
+ * on Wayland is:
+ * (above)
+ * - menu
+ * - tooltip
+ * - main widget
+ * (below)
+ * This is applicable to tooltips for menu, and menu tooltips
+ * are shown below menus.
+ * As a workaround, I entrust Gtk with menu tooltips, and
+ * let emacs not to show menu tooltips.
+ */
+
+#if 0
+ Lisp_Object frame;
+
+ if (f)
+ {
+ XSETFRAME (frame, f);
+ kbd_buffer_store_help_event (frame, help);
+ }
+ else
+ show_help_echo (help, Qnil, Qnil, Qnil);
+#endif
+}
+
+/* Callback called when menu items are highlighted/unhighlighted
+ while moving the mouse over them. WIDGET is the menu bar or menu
+ popup widget. ID is its LWLIB_ID. CALL_DATA contains a pointer to
+ the data structure for the menu item, or null in case of
+ unhighlighting. */
+
+static void
+menu_highlight_callback (GtkWidget *widget, gpointer call_data)
+{
+ xg_menu_item_cb_data *cb_data;
+ Lisp_Object help;
+
+ cb_data = g_object_get_data (G_OBJECT (widget), XG_ITEM_DATA);
+ if (!cb_data)
+ return;
+
+ help = call_data ? cb_data->help : Qnil;
+
+ /* If popup_activated_flag is greater than 1 we are in a popup menu.
+ Don't pass the frame to show_help_event for those.
+ Passing frame creates an Emacs event. As we are looping in
+ popup_widget_loop, it won't be handled. Passing NULL shows the tip
+ directly without using an Emacs event. This is what the Lucid code
+ does below. */
+ show_help_event (popup_activated_flag <= 1 ? cb_data->cl_data->f : NULL,
+ widget, help);
+}
+
+/* Gtk calls callbacks just because we tell it what item should be
+ selected in a radio group. If this variable is set to a non-zero
+ value, we are creating menus and don't want callbacks right now.
+*/
+static bool xg_crazy_callback_abort;
+
+/* This callback is called from the menu bar pulldown menu
+ when the user makes a selection.
+ Figure out what the user chose
+ and put the appropriate events into the keyboard buffer. */
+static void
+menubar_selection_callback (GtkWidget *widget, gpointer client_data)
+{
+ xg_menu_item_cb_data *cb_data = client_data;
+
+ if (xg_crazy_callback_abort)
+ return;
+
+ if (!cb_data || !cb_data->cl_data || !cb_data->cl_data->f)
+ return;
+
+ /* For a group of radio buttons, GTK calls the selection callback first
+ for the item that was active before the selection and then for the one that
+ is active after the selection. For C-h k this means we get the help on
+ the deselected item and then the selected item is executed. Prevent that
+ by ignoring the non-active item. */
+ if (GTK_IS_RADIO_MENU_ITEM (widget)
+ && !gtk_check_menu_item_get_active (GTK_CHECK_MENU_ITEM (widget)))
+ return;
+
+ /* When a menu is popped down, X generates a focus event (i.e. focus
+ goes back to the frame below the menu). Since GTK buffers events,
+ we force it out here before the menu selection event. Otherwise
+ sit-for will exit at once if the focus event follows the menu selection
+ event. */
+
+ block_input ();
+ while (gtk_events_pending ())
+ gtk_main_iteration ();
+ unblock_input ();
+
+ find_and_call_menu_selection (cb_data->cl_data->f,
+ cb_data->cl_data->menu_bar_items_used,
+ cb_data->cl_data->menu_bar_vector,
+ cb_data->call_data);
+}
+
+/* Recompute all the widgets of frame F, when the menu bar has been
+ changed. */
+
+static void
+update_frame_menubar (struct frame *f)
+{
+ xg_update_frame_menubar (f);
+}
+
+/* Set the contents of the menubar widgets of frame F.
+ The argument FIRST_TIME is currently ignored;
+ it is set the first time this is called, from initialize_frame_menubar. */
+
+void
+set_frame_menubar (struct frame *f, bool deep_p)
+{
+ GtkWidget *menubar_widget;
+ Lisp_Object items;
+ widget_value *wv, *first_wv, *prev_wv = 0;
+ int i;
+ int *submenu_start, *submenu_end;
+ bool *submenu_top_level_items;
+ int *submenu_n_panes;
+
+
+ menubar_widget = f->output_data.pgtk->menubar_widget;
+
+ XSETFRAME (Vmenu_updating_frame, f);
+
+ if (!menubar_widget)
+ deep_p = true;
+
+ if (deep_p)
+ {
+ struct buffer *prev = current_buffer;
+ Lisp_Object buffer;
+ ptrdiff_t specpdl_count = SPECPDL_INDEX ();
+ int previous_menu_items_used = f->menu_bar_items_used;
+ Lisp_Object *previous_items
+ = alloca (previous_menu_items_used * sizeof *previous_items);
+ int subitems;
+
+ /* If we are making a new widget, its contents are empty,
+ do always reinitialize them. */
+ if (!menubar_widget)
+ previous_menu_items_used = 0;
+
+ buffer = XWINDOW (FRAME_SELECTED_WINDOW (f))->contents;
+ specbind (Qinhibit_quit, Qt);
+ /* Don't let the debugger step into this code
+ because it is not reentrant. */
+ specbind (Qdebug_on_next_call, Qnil);
+
+ record_unwind_save_match_data ();
+ if (NILP (Voverriding_local_map_menu_flag))
+ {
+ specbind (Qoverriding_terminal_local_map, Qnil);
+ specbind (Qoverriding_local_map, Qnil);
+ }
+
+ set_buffer_internal_1 (XBUFFER (buffer));
+
+ /* Run the Lucid hook. */
+ safe_run_hooks (Qactivate_menubar_hook);
+
+ /* If it has changed current-menubar from previous value,
+ really recompute the menubar from the value. */
+ if (!NILP (Vlucid_menu_bar_dirty_flag))
+ call0 (Qrecompute_lucid_menubar);
+ safe_run_hooks (Qmenu_bar_update_hook);
+ fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f)));
+
+ items = FRAME_MENU_BAR_ITEMS (f);
+
+ /* Save the frame's previous menu bar contents data. */
+ if (previous_menu_items_used)
+ memcpy (previous_items, xvector_contents (f->menu_bar_vector),
+ previous_menu_items_used * word_size);
+
+ /* Fill in menu_items with the current menu bar contents.
+ This can evaluate Lisp code. */
+ save_menu_items ();
+
+ menu_items = f->menu_bar_vector;
+ menu_items_allocated = VECTORP (menu_items) ? ASIZE (menu_items) : 0;
+ subitems = ASIZE (items) / 4;
+ submenu_start = alloca ((subitems + 1) * sizeof *submenu_start);
+ submenu_end = alloca (subitems * sizeof *submenu_end);
+ submenu_n_panes = alloca (subitems * sizeof *submenu_n_panes);
+ submenu_top_level_items = alloca (subitems
+ * sizeof *submenu_top_level_items);
+ init_menu_items ();
+ for (i = 0; i < subitems; i++)
+ {
+ Lisp_Object key, string, maps;
+
+ key = AREF (items, 4 * i);
+ string = AREF (items, 4 * i + 1);
+ maps = AREF (items, 4 * i + 2);
+ if (NILP (string))
+ break;
+
+ submenu_start[i] = menu_items_used;
+
+ menu_items_n_panes = 0;
+ submenu_top_level_items[i]
+ = parse_single_submenu (key, string, maps);
+ submenu_n_panes[i] = menu_items_n_panes;
+
+ submenu_end[i] = menu_items_used;
+ }
+
+ submenu_start[i] = -1;
+ finish_menu_items ();
+
+ /* Convert menu_items into widget_value trees
+ to display the menu. This cannot evaluate Lisp code. */
+
+ wv = make_widget_value ("menubar", NULL, true, Qnil);
+ wv->button_type = BUTTON_TYPE_NONE;
+ first_wv = wv;
+
+ for (i = 0; submenu_start[i] >= 0; i++)
+ {
+ menu_items_n_panes = submenu_n_panes[i];
+ wv = digest_single_submenu (submenu_start[i], submenu_end[i],
+ submenu_top_level_items[i]);
+ if (prev_wv)
+ prev_wv->next = wv;
+ else
+ first_wv->contents = wv;
+ /* Don't set wv->name here; GC during the loop might relocate it. */
+ wv->enabled = true;
+ wv->button_type = BUTTON_TYPE_NONE;
+ prev_wv = wv;
+ }
+
+ set_buffer_internal_1 (prev);
+
+ /* If there has been no change in the Lisp-level contents
+ of the menu bar, skip redisplaying it. Just exit. */
+
+ /* Compare the new menu items with the ones computed last time. */
+ for (i = 0; i < previous_menu_items_used; i++)
+ if (menu_items_used == i
+ || (!EQ (previous_items[i], AREF (menu_items, i))))
+ break;
+ if (i == menu_items_used && i == previous_menu_items_used && i != 0)
+ {
+ /* The menu items have not changed. Don't bother updating
+ the menus in any form, since it would be a no-op. */
+ free_menubar_widget_value_tree (first_wv);
+ discard_menu_items ();
+ unbind_to (specpdl_count, Qnil);
+ return;
+ }
+
+ /* The menu items are different, so store them in the frame. */
+ fset_menu_bar_vector (f, menu_items);
+ f->menu_bar_items_used = menu_items_used;
+
+ /* This undoes save_menu_items. */
+ unbind_to (specpdl_count, Qnil);
+
+ /* Now GC cannot happen during the lifetime of the widget_value,
+ so it's safe to store data from a Lisp_String. */
+ wv = first_wv->contents;
+ for (i = 0; i < ASIZE (items); i += 4)
+ {
+ Lisp_Object string;
+ string = AREF (items, i + 1);
+ if (NILP (string))
+ break;
+ wv->name = SSDATA (string);
+ update_submenu_strings (wv->contents);
+ wv = wv->next;
+ }
+
+ }
+ else
+ {
+ /* Make a widget-value tree containing
+ just the top level menu bar strings. */
+
+ wv = make_widget_value ("menubar", NULL, true, Qnil);
+ wv->button_type = BUTTON_TYPE_NONE;
+ first_wv = wv;
+
+ items = FRAME_MENU_BAR_ITEMS (f);
+ for (i = 0; i < ASIZE (items); i += 4)
+ {
+ Lisp_Object string;
+
+ string = AREF (items, i + 1);
+ if (NILP (string))
+ break;
+
+ wv = make_widget_value (SSDATA (string), NULL, true, Qnil);
+ wv->button_type = BUTTON_TYPE_NONE;
+ /* This prevents lwlib from assuming this
+ menu item is really supposed to be empty. */
+ /* The intptr_t cast avoids a warning.
+ This value just has to be different from small integers. */
+ wv->call_data = (void *) (intptr_t) (-1);
+
+ if (prev_wv)
+ prev_wv->next = wv;
+ else
+ first_wv->contents = wv;
+ prev_wv = wv;
+ }
+
+ /* Forget what we thought we knew about what is in the
+ detailed contents of the menu bar menus.
+ Changing the top level always destroys the contents. */
+ f->menu_bar_items_used = 0;
+ }
+
+ block_input ();
+
+ xg_crazy_callback_abort = true;
+ if (menubar_widget)
+ {
+ /* The fourth arg is DEEP_P, which says to consider the entire
+ menu trees we supply, rather than just the menu bar item names. */
+ xg_modify_menubar_widgets (menubar_widget,
+ f,
+ first_wv,
+ deep_p,
+ G_CALLBACK (menubar_selection_callback),
+ G_CALLBACK (popup_deactivate_callback),
+ G_CALLBACK (menu_highlight_callback));
+ }
+ else
+ {
+ menubar_widget
+ = xg_create_widget ("menubar", "menubar", f, first_wv,
+ G_CALLBACK (menubar_selection_callback),
+ G_CALLBACK (popup_deactivate_callback),
+ G_CALLBACK (menu_highlight_callback));
+
+ f->output_data.pgtk->menubar_widget = menubar_widget;
+ }
+
+ free_menubar_widget_value_tree (first_wv);
+ update_frame_menubar (f);
+
+ xg_crazy_callback_abort = false;
+
+ unblock_input ();
+}
+
+/* Called from Fx_create_frame to create the initial menubar of a frame
+ before it is mapped, so that the window is mapped with the menubar already
+ there instead of us tacking it on later and thrashing the window after it
+ is visible. */
+
+void
+initialize_frame_menubar (struct frame *f)
+{
+ /* This function is called before the first chance to redisplay
+ the frame. It has to be, so the frame will have the right size. */
+ fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f)));
+ set_frame_menubar (f, true);
+}
+
+
+/* x_menu_show actually displays a menu using the panes and items in menu_items
+ and returns the value selected from it.
+ There are two versions of x_menu_show, one for Xt and one for Xlib.
+ Both assume input is blocked by the caller. */
+
+/* F is the frame the menu is for.
+ X and Y are the frame-relative specified position,
+ relative to the inside upper left corner of the frame F.
+ Bitfield MENUFLAGS bits are:
+ MENU_FOR_CLICK is set if this menu was invoked for a mouse click.
+ MENU_KEYMAPS is set if this menu was specified with keymaps;
+ in that case, we return a list containing the chosen item's value
+ and perhaps also the pane's prefix.
+ TITLE is the specified menu title.
+ ERROR is a place to store an error message string in case of failure.
+ (We return nil on failure, but the value doesn't actually matter.) */
+
+/* The item selected in the popup menu. */
+static Lisp_Object *volatile menu_item_selection;
+
+static void
+popup_selection_callback (GtkWidget *widget, gpointer client_data)
+{
+ xg_menu_item_cb_data *cb_data = client_data;
+
+ if (xg_crazy_callback_abort)
+ return;
+ if (cb_data)
+ menu_item_selection = cb_data->call_data;
+}
+
+static void
+pop_down_menu (void *arg)
+{
+ popup_activated_flag = 0;
+ block_input ();
+ gtk_widget_destroy (GTK_WIDGET (arg));
+ unblock_input ();
+}
+
+/* Pop up the menu for frame F defined by FIRST_WV at X/Y and loop until the
+ menu pops down.
+ menu_item_selection will be set to the selection. */
+static void
+create_and_show_popup_menu (struct frame *f, widget_value * first_wv,
+ int x, int y, bool for_click)
+{
+ GtkWidget *menu;
+ ptrdiff_t specpdl_count = SPECPDL_INDEX ();
+
+ eassert (FRAME_PGTK_P (f));
+
+ xg_crazy_callback_abort = true;
+ menu = xg_create_widget ("popup", first_wv->name, f, first_wv,
+ G_CALLBACK (popup_selection_callback),
+ G_CALLBACK (popup_deactivate_callback),
+ G_CALLBACK (menu_highlight_callback));
+ xg_crazy_callback_abort = false;
+
+ /* Display the menu. */
+ gtk_widget_show_all (menu);
+
+ if (for_click)
+ gtk_menu_popup_at_pointer (GTK_MENU (menu),
+ FRAME_DISPLAY_INFO (f)->last_click_event);
+ else
+ {
+ GdkRectangle rect;
+ rect.x = x;
+ rect.y = y;
+ rect.width = 1;
+ rect.height = 1;
+ gtk_menu_popup_at_rect (GTK_MENU (menu),
+ gtk_widget_get_window (FRAME_GTK_WIDGET (f)),
+ &rect,
+ GDK_GRAVITY_NORTH_WEST, GDK_GRAVITY_NORTH_WEST,
+ FRAME_DISPLAY_INFO (f)->last_click_event);
+ }
+
+ record_unwind_protect_ptr (pop_down_menu, menu);
+
+ if (gtk_widget_get_mapped (menu))
+ {
+ /* Set this to one. popup_widget_loop increases it by one, so it becomes
+ two. show_help_echo uses this to detect popup menus. */
+ popup_activated_flag = 1;
+ /* Process events that apply to the menu. */
+ popup_widget_loop (true, menu);
+ }
+
+ unbind_to (specpdl_count, Qnil);
+
+ /* Must reset this manually because the button release event is not passed
+ to Emacs event loop. */
+ FRAME_DISPLAY_INFO (f)->grabbed = 0;
+}
+
+static void
+cleanup_widget_value_tree (void *arg)
+{
+ free_menubar_widget_value_tree (arg);
+}
+
+Lisp_Object
+pgtk_menu_show (struct frame *f, int x, int y, int menuflags,
+ Lisp_Object title, const char **error_name)
+{
+ int i;
+ widget_value *wv, *save_wv = 0, *first_wv = 0, *prev_wv = 0;
+ widget_value **submenu_stack
+ = alloca (menu_items_used * sizeof *submenu_stack);
+ Lisp_Object *subprefix_stack
+ = alloca (menu_items_used * sizeof *subprefix_stack);
+ int submenu_depth = 0;
+
+ ptrdiff_t specpdl_count = SPECPDL_INDEX ();
+
+ eassert (FRAME_PGTK_P (f));
+
+ *error_name = NULL;
+
+ if (!FRAME_GTK_OUTER_WIDGET (f)) {
+ *error_name = "Can't popup from child frames.";
+ return Qnil;
+ }
+
+ if (menu_items_used <= MENU_ITEMS_PANE_LENGTH)
+ {
+ *error_name = "Empty menu";
+ return Qnil;
+ }
+
+ block_input ();
+
+ /* Create a tree of widget_value objects
+ representing the panes and their items. */
+ wv = make_widget_value ("menu", NULL, true, Qnil);
+ wv->button_type = BUTTON_TYPE_NONE;
+ first_wv = wv;
+ bool first_pane = true;
+
+ /* Loop over all panes and items, filling in the tree. */
+ i = 0;
+ while (i < menu_items_used)
+ {
+ if (NILP (AREF (menu_items, i)))
+ {
+ submenu_stack[submenu_depth++] = save_wv;
+ save_wv = prev_wv;
+ prev_wv = 0;
+ first_pane = true;
+ i++;
+ }
+ else if (EQ (AREF (menu_items, i), Qlambda))
+ {
+ prev_wv = save_wv;
+ save_wv = submenu_stack[--submenu_depth];
+ first_pane = false;
+ i++;
+ }
+ else if (EQ (AREF (menu_items, i), Qt) && submenu_depth != 0)
+ 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 if (EQ (AREF (menu_items, i), Qt))
+ {
+ /* Create a new pane. */
+ Lisp_Object pane_name, prefix;
+ const char *pane_string;
+
+ pane_name = AREF (menu_items, i + MENU_ITEMS_PANE_NAME);
+ prefix = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX);
+
+#ifndef HAVE_MULTILINGUAL_MENU
+ if (STRINGP (pane_name) && STRING_MULTIBYTE (pane_name))
+ {
+ pane_name = ENCODE_MENU_STRING (pane_name);
+ ASET (menu_items, i + MENU_ITEMS_PANE_NAME, pane_name);
+ }
+#endif
+ pane_string = (NILP (pane_name) ? "" : SSDATA (pane_name));
+ /* If there is just one top-level pane, put all its items directly
+ under the top-level menu. */
+ if (menu_items_n_panes == 1)
+ pane_string = "";
+
+ /* If the pane has a meaningful name,
+ make the pane a top-level menu item
+ with its items as a submenu beneath it. */
+ if (!(menuflags & MENU_KEYMAPS) && strcmp (pane_string, ""))
+ {
+ wv = make_widget_value (pane_string, NULL, true, Qnil);
+ if (save_wv)
+ save_wv->next = wv;
+ else
+ first_wv->contents = wv;
+ if ((menuflags & MENU_KEYMAPS) && !NILP (prefix))
+ wv->name++;
+ wv->button_type = BUTTON_TYPE_NONE;
+ save_wv = wv;
+ prev_wv = 0;
+ }
+ else if (first_pane)
+ {
+ save_wv = wv;
+ prev_wv = 0;
+ }
+ first_pane = false;
+ i += MENU_ITEMS_PANE_LENGTH;
+ }
+ else
+ {
+ /* Create a new item within current pane. */
+ Lisp_Object item_name, enable, descrip, def, type, selected, help;
+ item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME);
+ enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE);
+ descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY);
+ 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);
+
+#ifndef HAVE_MULTILINGUAL_MENU
+ if (STRINGP (item_name) && STRING_MULTIBYTE (item_name))
+ {
+ item_name = ENCODE_MENU_STRING (item_name);
+ ASET (menu_items, i + MENU_ITEMS_ITEM_NAME, item_name);
+ }
+
+ if (STRINGP (descrip) && STRING_MULTIBYTE (descrip))
+ {
+ descrip = ENCODE_MENU_STRING (descrip);
+ ASET (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY, descrip);
+ }
+#endif /* not HAVE_MULTILINGUAL_MENU */
+
+ wv = make_widget_value (SSDATA (item_name), NULL, !NILP (enable),
+ STRINGP (help) ? help : Qnil);
+ if (prev_wv)
+ prev_wv->next = wv;
+ else
+ save_wv->contents = wv;
+ if (!NILP (descrip))
+ wv->key = SSDATA (descrip);
+ /* If this item has a null value,
+ make the call_data null so that it won't display a box
+ when the mouse is on it. */
+ wv->call_data = !NILP (def) ? aref_addr (menu_items, i) : 0;
+
+ if (NILP (type))
+ wv->button_type = BUTTON_TYPE_NONE;
+ else if (EQ (type, QCtoggle))
+ wv->button_type = BUTTON_TYPE_TOGGLE;
+ else if (EQ (type, QCradio))
+ wv->button_type = BUTTON_TYPE_RADIO;
+ else
+ emacs_abort ();
+
+ wv->selected = !NILP (selected);
+
+ prev_wv = wv;
+
+ i += MENU_ITEMS_ITEM_LENGTH;
+ }
+ }
+
+ /* Deal with the title, if it is non-nil. */
+ if (!NILP (title))
+ {
+ widget_value *wv_title;
+ widget_value *wv_sep1 = make_widget_value ("--", NULL, false, Qnil);
+ widget_value *wv_sep2 = make_widget_value ("--", NULL, false, Qnil);
+
+ wv_sep2->next = first_wv->contents;
+ wv_sep1->next = wv_sep2;
+
+#ifndef HAVE_MULTILINGUAL_MENU
+ if (STRING_MULTIBYTE (title))
+ title = ENCODE_MENU_STRING (title);
+#endif
+
+ wv_title = make_widget_value (SSDATA (title), NULL, true, Qnil);
+ wv_title->button_type = BUTTON_TYPE_NONE;
+ wv_title->next = wv_sep1;
+ first_wv->contents = wv_title;
+ }
+
+ /* No selection has been chosen yet. */
+ menu_item_selection = 0;
+
+ /* Make sure to free the widget_value objects we used to specify the
+ contents even with longjmp. */
+ record_unwind_protect_ptr (cleanup_widget_value_tree, first_wv);
+
+ /* Actually create and show the menu until popped down. */
+ create_and_show_popup_menu (f, first_wv, x, y, menuflags & MENU_FOR_CLICK);
+
+ unbind_to (specpdl_count, Qnil);
+
+ /* Find the selected item, and its pane, to return
+ the proper value. */
+ if (menu_item_selection != 0)
+ {
+ Lisp_Object prefix, entry;
+
+ prefix = entry = Qnil;
+ i = 0;
+ while (i < menu_items_used)
+ {
+ if (NILP (AREF (menu_items, i)))
+ {
+ subprefix_stack[submenu_depth++] = prefix;
+ prefix = entry;
+ i++;
+ }
+ else if (EQ (AREF (menu_items, i), Qlambda))
+ {
+ prefix = subprefix_stack[--submenu_depth];
+ 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 (menu_item_selection == aref_addr (menu_items, i))
+ {
+ if (menuflags & MENU_KEYMAPS)
+ {
+ int j;
+
+ entry = list1 (entry);
+ if (!NILP (prefix))
+ entry = Fcons (prefix, entry);
+ for (j = submenu_depth - 1; j >= 0; j--)
+ if (!NILP (subprefix_stack[j]))
+ entry = Fcons (subprefix_stack[j], entry);
+ }
+ unblock_input ();
+ return entry;
+ }
+ i += MENU_ITEMS_ITEM_LENGTH;
+ }
+ }
+ }
+ else if (!(menuflags & MENU_FOR_CLICK))
+ {
+ unblock_input ();
+ /* Make "Cancel" equivalent to C-g. */
+ quit ();
+ }
+
+ unblock_input ();
+ return Qnil;
+}
+
+static void
+dialog_selection_callback (GtkWidget *widget, gpointer client_data)
+{
+ /* Treat the pointer as an integer. There's no problem
+ as long as pointers have enough bits to hold small integers. */
+ if ((intptr_t) client_data != -1)
+ menu_item_selection = client_data;
+
+ popup_activated_flag = 0;
+}
+
+/* Pop up the dialog for frame F defined by FIRST_WV and loop until the
+ dialog pops down.
+ menu_item_selection will be set to the selection. */
+static void
+create_and_show_dialog (struct frame *f, widget_value *first_wv)
+{
+ GtkWidget *menu;
+
+ eassert (FRAME_PGTK_P (f));
+
+ menu = xg_create_widget ("dialog", first_wv->name, f, first_wv,
+ G_CALLBACK (dialog_selection_callback),
+ G_CALLBACK (popup_deactivate_callback), 0);
+
+ if (menu)
+ {
+ ptrdiff_t specpdl_count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (pop_down_menu, menu);
+
+ /* Display the menu. */
+ gtk_widget_show_all (menu);
+
+ /* Process events that apply to the menu. */
+ popup_widget_loop (true, menu);
+
+ unbind_to (specpdl_count, Qnil);
+ }
+}
+
+static const char *button_names[] = {
+ "button1", "button2", "button3", "button4", "button5",
+ "button6", "button7", "button8", "button9", "button10"
+};
+
+Lisp_Object
+pgtk_dialog_show (struct frame *f, Lisp_Object title,
+ Lisp_Object header, const char **error_name)
+{
+ int i, nb_buttons = 0;
+ char dialog_name[6];
+
+ widget_value *wv, *first_wv = 0, *prev_wv = 0;
+
+ /* Number of elements seen so far, before boundary. */
+ int left_count = 0;
+ /* Whether we've seen the boundary between left-hand elts and right-hand. */
+ bool boundary_seen = false;
+
+ ptrdiff_t specpdl_count = SPECPDL_INDEX ();
+
+ eassert (FRAME_PGTK_P (f));
+
+ *error_name = NULL;
+
+ if (!FRAME_GTK_OUTER_WIDGET (f)) {
+ *error_name = "Can't popup from child frames.";
+ return Qnil;
+ }
+
+ if (menu_items_n_panes > 1)
+ {
+ *error_name = "Multiple panes in dialog box";
+ return Qnil;
+ }
+
+ /* Create a tree of widget_value objects
+ representing the text label and buttons. */
+ {
+ Lisp_Object pane_name;
+ const char *pane_string;
+ pane_name = AREF (menu_items, MENU_ITEMS_PANE_NAME);
+ pane_string = (NILP (pane_name) ? "" : SSDATA (pane_name));
+ prev_wv = make_widget_value ("message", (char *) pane_string, true, Qnil);
+ first_wv = prev_wv;
+
+ /* Loop over all panes and items, filling in the tree. */
+ i = MENU_ITEMS_PANE_LENGTH;
+ while (i < menu_items_used)
+ {
+
+ /* Create a new item within current pane. */
+ Lisp_Object item_name, enable, descrip;
+ item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME);
+ enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE);
+ descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY);
+
+ if (NILP (item_name))
+ {
+ free_menubar_widget_value_tree (first_wv);
+ *error_name = "Submenu in dialog items";
+ return Qnil;
+ }
+ if (EQ (item_name, Qquote))
+ {
+ /* This is the boundary between left-side elts
+ and right-side elts. Stop incrementing right_count. */
+ boundary_seen = true;
+ i++;
+ continue;
+ }
+ if (nb_buttons >= 9)
+ {
+ free_menubar_widget_value_tree (first_wv);
+ *error_name = "Too many dialog items";
+ return Qnil;
+ }
+
+ wv = make_widget_value (button_names[nb_buttons],
+ SSDATA (item_name), !NILP (enable), Qnil);
+ prev_wv->next = wv;
+ if (!NILP (descrip))
+ wv->key = SSDATA (descrip);
+ wv->call_data = aref_addr (menu_items, i);
+ prev_wv = wv;
+
+ if (!boundary_seen)
+ left_count++;
+
+ nb_buttons++;
+ i += MENU_ITEMS_ITEM_LENGTH;
+ }
+
+ /* If the boundary was not specified,
+ by default put half on the left and half on the right. */
+ if (!boundary_seen)
+ left_count = nb_buttons - nb_buttons / 2;
+
+ wv = make_widget_value (dialog_name, NULL, false, Qnil);
+
+ /* Frame title: 'Q' = Question, 'I' = Information.
+ Can also have 'E' = Error if, one day, we want
+ a popup for errors. */
+ if (NILP (header))
+ dialog_name[0] = 'Q';
+ else
+ dialog_name[0] = 'I';
+
+ /* Dialog boxes use a really stupid name encoding
+ which specifies how many buttons to use
+ and how many buttons are on the right. */
+ dialog_name[1] = '0' + nb_buttons;
+ dialog_name[2] = 'B';
+ dialog_name[3] = 'R';
+ /* Number of buttons to put on the right. */
+ dialog_name[4] = '0' + nb_buttons - left_count;
+ dialog_name[5] = 0;
+ wv->contents = first_wv;
+ first_wv = wv;
+ }
+
+ /* No selection has been chosen yet. */
+ menu_item_selection = 0;
+
+ /* Make sure to free the widget_value objects we used to specify the
+ contents even with longjmp. */
+ record_unwind_protect_ptr (cleanup_widget_value_tree, first_wv);
+
+ /* Actually create and show the dialog. */
+ create_and_show_dialog (f, first_wv);
+
+ unbind_to (specpdl_count, Qnil);
+
+ /* Find the selected item, and its pane, to return
+ the proper value. */
+ if (menu_item_selection != 0)
+ {
+ i = 0;
+ while (i < menu_items_used)
+ {
+ Lisp_Object entry;
+
+ 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 (menu_item_selection == aref_addr (menu_items, i))
+ return entry;
+ i += MENU_ITEMS_ITEM_LENGTH;
+ }
+ }
+ }
+ else
+ /* Make "Cancel" equivalent to C-g. */
+ quit ();
+
+ return Qnil;
+}
+
+Lisp_Object
+pgtk_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents)
+{
+ Lisp_Object title;
+ const char *error_name;
+ Lisp_Object selection;
+ ptrdiff_t 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. Also, the lesstif/motif version crashes if there are
+ no buttons. */
+ contents = list2 (title, Fcons (build_string ("Ok"), Qt));
+
+ list_of_panes (list1 (contents));
+
+ /* Display them in a dialog box. */
+ block_input ();
+ selection = pgtk_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;
+}
+
+/* Detect if a dialog or menu has been posted. MSDOS has its own
+ implementation on msdos.c. */
+
+int
+popup_activated (void)
+{
+ return popup_activated_flag;
+}
+
+/* The following is used by delayed window autoselection. */
+
+DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p, Smenu_or_popup_active_p, 0, 0, 0,
+ doc: /* Return t if a menu or popup dialog is active.
+\(On MS Windows, this refers to the selected frame.) */)
+ (void)
+{
+ return (popup_activated ())? Qt : Qnil;
+}
+
+static void syms_of_pgtkmenu_for_pdumper (void);
+
+void
+syms_of_pgtkmenu (void)
+{
+ DEFSYM (Qdebug_on_next_call, "debug-on-next-call");
+ defsubr (&Smenu_or_popup_active_p);
+
+ DEFSYM (Qframe_monitor_workarea, "frame-monitor-workarea");
+
+ defsubr (&Sx_menu_bar_open_internal);
+ Ffset (intern_c_string ("accelerate-menu"),
+ intern_c_string (Sx_menu_bar_open_internal.s.symbol_name));
+
+ pdumper_do_now_and_after_load (syms_of_pgtkmenu_for_pdumper);
+}
+
+static void
+syms_of_pgtkmenu_for_pdumper (void)
+{
+}
diff --git a/src/pgtkselect.c b/src/pgtkselect.c
new file mode 100644
index 00000000000..77a563dc3f3
--- /dev/null
+++ b/src/pgtkselect.c
@@ -0,0 +1,632 @@
+/* Gtk selection processing for emacs.
+ Copyright (C) 1993-1994, 2005-2006, 2008-2020 Free Software
+ Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+
+/*
+Originally by Carl Edman
+Updated by Christian Limpach (chris@nice.ch)
+OpenStep/Rhapsody port by Scott Bender (sbender@harmony-ds.com)
+macOS/Aqua port by Christophe de Dinechin (descubes@earthlink.net)
+GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
+*/
+
+/* This should be the first include, as it may set up #defines affecting
+ interpretation of even the system includes. */
+#include <config.h>
+
+#include "lisp.h"
+#include "pgtkterm.h"
+#include "termhooks.h"
+#include "keyboard.h"
+#include "pgtkselect.h"
+#include <gdk/gdk.h>
+
+#if 0
+static Lisp_Object Vselection_alist;
+#endif
+
+static GQuark quark_primary_data = 0;
+static GQuark quark_primary_size = 0;
+static GQuark quark_secondary_data = 0;
+static GQuark quark_secondary_size = 0;
+static GQuark quark_clipboard_data = 0;
+static GQuark quark_clipboard_size = 0;
+
+/* ==========================================================================
+
+ Internal utility functions
+
+ ========================================================================== */
+
+/* From a Lisp_Object, return a suitable frame for selection
+ operations. OBJECT may be a frame, a terminal object, or nil
+ (which stands for the selected frame--or, if that is not an pgtk
+ frame, the first pgtk display on the list). If no suitable frame can
+ be found, return NULL. */
+
+static struct frame *
+frame_for_pgtk_selection (Lisp_Object object)
+{
+ Lisp_Object tail, frame;
+ struct frame *f;
+
+ if (NILP (object))
+ {
+ f = XFRAME (selected_frame);
+ if (FRAME_PGTK_P (f) && FRAME_LIVE_P (f))
+ return f;
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ f = XFRAME (frame);
+ if (FRAME_PGTK_P (f) && FRAME_LIVE_P (f))
+ return f;
+ }
+ }
+ else if (TERMINALP (object))
+ {
+ struct terminal *t = decode_live_terminal (object);
+
+ if (t->type == output_pgtk)
+ FOR_EACH_FRAME (tail, frame)
+ {
+ f = XFRAME (frame);
+ if (FRAME_LIVE_P (f) && f->terminal == t)
+ return f;
+ }
+ }
+ else if (FRAMEP (object))
+ {
+ f = XFRAME (object);
+ if (FRAME_PGTK_P (f) && FRAME_LIVE_P (f))
+ return f;
+ }
+
+ return NULL;
+}
+
+static GtkClipboard *
+symbol_to_gtk_clipboard (GtkWidget * widget, Lisp_Object symbol)
+{
+ GdkAtom atom;
+
+ CHECK_SYMBOL (symbol);
+ if (NILP (symbol))
+ {
+ atom = GDK_SELECTION_PRIMARY;
+ }
+ else if (EQ (symbol, QCLIPBOARD))
+ {
+ atom = GDK_SELECTION_CLIPBOARD;
+ }
+ else if (EQ (symbol, QPRIMARY))
+ {
+ atom = GDK_SELECTION_PRIMARY;
+ }
+ else if (EQ (symbol, QSECONDARY))
+ {
+ atom = GDK_SELECTION_SECONDARY;
+ }
+ else if (EQ (symbol, Qt))
+ {
+ atom = GDK_SELECTION_SECONDARY;
+ }
+ else
+ {
+ atom = 0;
+ error ("Bad selection");
+ }
+
+ return gtk_widget_get_clipboard (widget, atom);
+}
+
+static void
+selection_type_to_quarks (GdkAtom type, GQuark * quark_data,
+ GQuark * quark_size)
+{
+ if (type == GDK_SELECTION_PRIMARY)
+ {
+ *quark_data = quark_primary_data;
+ *quark_size = quark_primary_size;
+ }
+ else if (type == GDK_SELECTION_SECONDARY)
+ {
+ *quark_data = quark_secondary_data;
+ *quark_size = quark_secondary_size;
+ }
+ else if (type == GDK_SELECTION_CLIPBOARD)
+ {
+ *quark_data = quark_clipboard_data;
+ *quark_size = quark_clipboard_size;
+ }
+ else
+ {
+ /* fixme: Is it safe to use 'error' here? */
+ error ("Unknown selection type.");
+ }
+}
+
+static void
+get_func (GtkClipboard * cb, GtkSelectionData * data, guint info,
+ gpointer user_data_or_owner)
+{
+ GObject *obj = G_OBJECT (user_data_or_owner);
+ const char *str;
+ int size;
+ GQuark quark_data, quark_size;
+
+ selection_type_to_quarks (gtk_clipboard_get_selection (cb), &quark_data,
+ &quark_size);
+
+ str = g_object_get_qdata (obj, quark_data);
+ size = GPOINTER_TO_SIZE (g_object_get_qdata (obj, quark_size));
+ gtk_selection_data_set_text (data, str, size);
+}
+
+static void
+clear_func (GtkClipboard * cb, gpointer user_data_or_owner)
+{
+ GObject *obj = G_OBJECT (user_data_or_owner);
+ GQuark quark_data, quark_size;
+
+ selection_type_to_quarks (gtk_clipboard_get_selection (cb), &quark_data,
+ &quark_size);
+
+ g_object_set_qdata (obj, quark_data, NULL);
+ g_object_set_qdata (obj, quark_size, 0);
+}
+
+
+/* ==========================================================================
+
+ Functions used externally
+
+ ========================================================================== */
+
+void
+pgtk_selection_init (void)
+{
+ if (quark_primary_data == 0)
+ {
+ quark_primary_data = g_quark_from_static_string ("pgtk-primary-data");
+ quark_primary_size = g_quark_from_static_string ("pgtk-primary-size");
+ quark_secondary_data =
+ g_quark_from_static_string ("pgtk-secondary-data");
+ quark_secondary_size =
+ g_quark_from_static_string ("pgtk-secondary-size");
+ quark_clipboard_data =
+ g_quark_from_static_string ("pgtk-clipboard-data");
+ quark_clipboard_size =
+ g_quark_from_static_string ("pgtk-clipboard-size");
+ }
+}
+
+void
+pgtk_selection_lost (GtkWidget * widget, GdkEventSelection * event,
+ gpointer user_data)
+{
+ GQuark quark_data, quark_size;
+
+ selection_type_to_quarks (event->selection, &quark_data, &quark_size);
+
+ g_object_set_qdata (G_OBJECT (widget), quark_data, NULL);
+ g_object_set_qdata (G_OBJECT (widget), quark_size, 0);
+}
+
+static bool
+pgtk_selection_usable (void)
+{
+ if (pgtk_enable_selection_on_multi_display)
+ return true;
+
+ /*
+ * https://github.com/GNOME/gtk/blob/gtk-3-24/gdk/wayland/gdkselection-wayland.c#L1033
+ *
+ * Gdk uses gdk_display_get_default() when handling selections, so
+ * selections don't work properly on multi-display environment.
+ *
+ * ----------------
+ * #include <gtk/gtk.h>
+ *
+ * static GtkWidget *top1, *top2;
+ *
+ * int main (int argc, char **argv)
+ * {
+ * GtkWidget *w;
+ * GtkTextBuffer *buf;
+ *
+ * gtk_init (&argc, &argv);
+ *
+ * static char *text = "\
+ * It is fine today.\n\
+ * It will be fine tomorrow too.\n\
+ * It is too hot.";
+ *
+ * top1 = gtk_window_new (GTK_WINDOW_TOPLEVEL);
+ * gtk_window_set_title (GTK_WINDOW (top1), "default");
+ * gtk_widget_show (top1);
+ * w = gtk_text_view_new ();
+ * gtk_container_add (GTK_CONTAINER (top1), w);
+ * gtk_widget_show (w);
+ * buf = gtk_text_view_get_buffer (GTK_TEXT_VIEW (w));
+ * gtk_text_buffer_insert_at_cursor (buf, text, strlen (text));
+ * gtk_text_buffer_add_selection_clipboard (buf, gtk_widget_get_clipboard (w, GDK_SELECTION_PRIMARY));
+ *
+ * unsetenv ("GDK_BACKEND");
+ * GdkDisplay *gdpy;
+ * const char *dpyname2;
+ * if (strcmp (G_OBJECT_TYPE_NAME (gtk_widget_get_window (top1)), "GdkWaylandWindow") == 0)
+ * dpyname2 = ":0";
+ * else
+ * dpyname2 = "wayland-0";
+ * gdpy = gdk_display_open (dpyname2);
+ * top2 = gtk_window_new (GTK_WINDOW_TOPLEVEL);
+ * gtk_window_set_title (GTK_WINDOW (top2), dpyname2);
+ * gtk_window_set_screen (GTK_WINDOW (top2), gdk_display_get_default_screen (gdpy));
+ * gtk_widget_show (top2);
+ * w = gtk_text_view_new ();
+ * gtk_container_add (GTK_CONTAINER (top2), w);
+ * gtk_widget_show (w);
+ * buf = gtk_text_view_get_buffer (GTK_TEXT_VIEW (w));
+ * gtk_text_buffer_insert_at_cursor (buf, text, strlen (text));
+ * gtk_text_buffer_add_selection_clipboard (buf, gtk_widget_get_clipboard (w, GDK_SELECTION_PRIMARY));
+ *
+ * gtk_main ();
+ *
+ * return 0;
+ * }
+ * ----------------
+ *
+ * This code fails if
+ * GDK_BACKEND=x11 ./test
+ * and select on both of windows.
+ *
+ * ----------------
+ * (test:15345): GLib-GObject-CRITICAL **: 01:56:38.041: g_object_ref: assertion 'G_IS_OBJECT (object)' failed
+ *
+ * (test:15345): GLib-GObject-CRITICAL **: 01:56:38.042: g_object_ref: assertion 'G_IS_OBJECT (object)' failed
+ *
+ * (test:15345): GLib-GObject-CRITICAL **: 01:56:39.113: g_object_ref: assertion 'G_IS_OBJECT (object)' failed
+ *
+ * (test:15345): GLib-GObject-CRITICAL **: 01:56:39.113: g_object_ref: assertion 'G_IS_OBJECT (object)' failed
+ * ----------------
+ * (gtk-3.24.10)
+ *
+ * This function checks whether selections work by the number of displays.
+ * If you use more than 2 displays, then selection is disabled.
+ */
+
+ GdkDisplayManager *dpyman = gdk_display_manager_get ();
+ GSList *list = gdk_display_manager_list_displays (dpyman);
+ int len = g_slist_length (list);
+ g_slist_free (list);
+ return len < 2;
+}
+
+/* ==========================================================================
+
+ Lisp Defuns
+
+ ========================================================================== */
+
+
+DEFUN ("pgtk-own-selection-internal", Fpgtk_own_selection_internal, Spgtk_own_selection_internal, 2, 3, 0,
+ doc: /* Assert an X selection of type SELECTION and value VALUE.
+SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
+\(Those are literal upper-case symbol names, since that's what X expects.)
+VALUE is typically a string, or a cons of two markers, but may be
+anything that the functions on `selection-converter-alist' know about.
+
+FRAME should be a frame that should own the selection. If omitted or
+nil, it defaults to the selected frame. */)
+ (Lisp_Object selection, Lisp_Object value, Lisp_Object frame)
+{
+ Lisp_Object successful_p = Qnil;
+ Lisp_Object target_symbol, rest;
+ GtkClipboard *cb;
+ struct frame *f;
+ GQuark quark_data, quark_size;
+
+ check_window_system (NULL);
+
+ if (!pgtk_selection_usable ())
+ return Qnil;
+
+ if (NILP (frame))
+ frame = selected_frame;
+ if (!FRAME_LIVE_P (XFRAME (frame)) || !FRAME_PGTK_P (XFRAME (frame)))
+ error ("pgtk selection unavailable for this frame");
+ f = XFRAME (frame);
+
+ cb = symbol_to_gtk_clipboard (FRAME_GTK_WIDGET (f), selection);
+ selection_type_to_quarks (gtk_clipboard_get_selection (cb), &quark_data,
+ &quark_size);
+
+ /* We only support copy of text. */
+ target_symbol = QTEXT;
+ if (STRINGP (value))
+ {
+ GtkTargetList *list;
+ GtkTargetEntry *targets;
+ gint n_targets;
+ GtkWidget *widget;
+
+ list = gtk_target_list_new (NULL, 0);
+ gtk_target_list_add_text_targets (list, 0);
+
+ {
+ /* text/plain: Strings encoded by Gtk are not correctly decoded by Chromium(Wayland). */
+ GdkAtom atom_text_plain = gdk_atom_intern ("text/plain", false);
+ gtk_target_list_remove (list, atom_text_plain);
+ }
+
+ targets = gtk_target_table_new_from_list (list, &n_targets);
+
+ int size = SBYTES (value);
+ gchar *str = xmalloc (size + 1);
+ memcpy (str, SSDATA (value), size);
+ str[size] = '\0';
+
+ widget = FRAME_GTK_WIDGET (f);
+ g_object_set_qdata_full (G_OBJECT (widget), quark_data, str, xfree);
+ g_object_set_qdata_full (G_OBJECT (widget), quark_size,
+ GSIZE_TO_POINTER (size), NULL);
+
+ if (gtk_clipboard_set_with_owner (cb,
+ targets, n_targets,
+ get_func, clear_func,
+ G_OBJECT (FRAME_GTK_WIDGET (f))))
+ {
+ successful_p = Qt;
+ }
+ gtk_clipboard_set_can_store (cb, NULL, 0);
+
+ gtk_target_table_free (targets, n_targets);
+ gtk_target_list_unref (list);
+ }
+
+ if (!EQ (Vpgtk_sent_selection_hooks, Qunbound))
+ {
+ /* FIXME: Use run-hook-with-args! */
+ for (rest = Vpgtk_sent_selection_hooks; CONSP (rest);
+ rest = Fcdr (rest))
+ call3 (Fcar (rest), selection, target_symbol, successful_p);
+ }
+
+ return value;
+}
+
+
+DEFUN ("pgtk-disown-selection-internal", Fpgtk_disown_selection_internal, Spgtk_disown_selection_internal, 1, 3, 0,
+ doc: /* If we own the selection SELECTION, disown it.
+Disowning it means there is no such selection.
+
+Sets the last-change time for the selection to TIME-OBJECT (by default
+the time of the last event).
+
+TERMINAL should be a terminal object or a frame specifying the X
+server to query. If omitted or nil, that stands for the selected
+frame's display, or the first available X display.
+
+On Nextstep, the TIME-OBJECT and TERMINAL arguments are unused.
+On MS-DOS, all this does is return non-nil if we own the selection.
+On PGTK, the TIME-OBJECT is unused. */)
+ (Lisp_Object selection, Lisp_Object time_object, Lisp_Object terminal)
+{
+ struct frame *f = frame_for_pgtk_selection (terminal);
+ GtkClipboard *cb;
+
+ if (!pgtk_selection_usable ())
+ return Qnil;
+
+ if (!f)
+ return Qnil;
+
+ cb = symbol_to_gtk_clipboard (FRAME_GTK_WIDGET (f), selection);
+
+ gtk_clipboard_clear (cb);
+
+ return Qt;
+}
+
+
+DEFUN ("pgtk-selection-exists-p", Fpgtk_selection_exists_p, Spgtk_selection_exists_p, 0, 2, 0,
+ doc: /* Whether there is an owner for the given X selection.
+SELECTION should be the name of the selection in question, typically
+one of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'. (X expects
+these literal upper-case names.) The symbol nil is the same as
+`PRIMARY', and t is the same as `SECONDARY'.
+
+TERMINAL should be a terminal object or a frame specifying the X
+server to query. If omitted or nil, that stands for the selected
+frame's display, or the first available X display.
+
+On Nextstep, TERMINAL is unused. */)
+ (Lisp_Object selection, Lisp_Object terminal)
+{
+ struct frame *f = frame_for_pgtk_selection (terminal);
+ GtkClipboard *cb;
+
+ if (!pgtk_selection_usable ())
+ return Qnil;
+
+ if (!f)
+ return Qnil;
+
+ cb = symbol_to_gtk_clipboard (FRAME_GTK_WIDGET (f), selection);
+
+ return gtk_clipboard_wait_is_text_available (cb) ? Qt : Qnil;
+}
+
+
+DEFUN ("pgtk-selection-owner-p", Fpgtk_selection_owner_p, Spgtk_selection_owner_p, 0, 2, 0,
+ doc: /* Whether the current Emacs process owns the given X Selection.
+The arg should be the name of the selection in question, typically one of
+the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
+\(Those are literal upper-case symbol names, since that's what X expects.)
+For convenience, the symbol nil is the same as `PRIMARY',
+and t is the same as `SECONDARY'.
+
+TERMINAL should be a terminal object or a frame specifying the X
+server to query. If omitted or nil, that stands for the selected
+frame's display, or the first available X display.
+
+On Nextstep, TERMINAL is unused. */)
+ (Lisp_Object selection, Lisp_Object terminal)
+{
+ struct frame *f = frame_for_pgtk_selection (terminal);
+ GtkClipboard *cb;
+ GObject *obj;
+ GQuark quark_data, quark_size;
+
+ if (!pgtk_selection_usable ())
+ return Qnil;
+
+ cb = symbol_to_gtk_clipboard (FRAME_GTK_WIDGET (f), selection);
+ selection_type_to_quarks (gtk_clipboard_get_selection (cb), &quark_data,
+ &quark_size);
+
+ obj = gtk_clipboard_get_owner (cb);
+
+ return obj && g_object_get_qdata (obj, quark_data) != NULL ? Qt : Qnil;
+}
+
+
+DEFUN ("pgtk-get-selection-internal", Fpgtk_get_selection_internal, Spgtk_get_selection_internal, 2, 4, 0,
+ doc: /* Return text selected from some X window.
+SELECTION-SYMBOL is typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
+\(Those are literal upper-case symbol names, since that's what X expects.)
+TARGET-TYPE is the type of data desired, typically `STRING'.
+
+TIME-STAMP is the time to use in the XConvertSelection call for foreign
+selections. If omitted, defaults to the time for the last event.
+
+TERMINAL should be a terminal object or a frame specifying the X
+server to query. If omitted or nil, that stands for the selected
+frame's display, or the first available X display.
+
+On Nextstep, TIME-STAMP and TERMINAL are unused.
+On PGTK, TIME-STAMP is unused. */)
+ (Lisp_Object selection_symbol, Lisp_Object target_type,
+ Lisp_Object time_stamp, Lisp_Object terminal)
+{
+ struct frame *f = frame_for_pgtk_selection (terminal);
+ GtkClipboard *cb;
+
+ CHECK_SYMBOL (selection_symbol);
+ CHECK_SYMBOL (target_type);
+ if (EQ (target_type, QMULTIPLE))
+ error ("Retrieving MULTIPLE selections is currently unimplemented");
+ if (!f)
+ error ("PGTK selection unavailable for this frame");
+
+ if (!pgtk_selection_usable ())
+ return Qnil;
+
+ cb = symbol_to_gtk_clipboard (FRAME_GTK_WIDGET (f), selection_symbol);
+
+ GdkAtom target_atom = gdk_atom_intern (SSDATA (SYMBOL_NAME (target_type)), false);
+ GtkSelectionData *seldata = gtk_clipboard_wait_for_contents (cb, target_atom);
+
+ if (seldata == NULL)
+ return Qnil;
+
+ const guchar *sd_data = gtk_selection_data_get_data (seldata);
+ int sd_len = gtk_selection_data_get_length (seldata);
+ int sd_format = gtk_selection_data_get_format (seldata);
+ GdkAtom sd_type = gtk_selection_data_get_data_type (seldata);
+
+ if (sd_format == 8)
+ {
+ Lisp_Object str, lispy_type;
+
+ str = make_unibyte_string ((char *) sd_data, sd_len);
+ /* Indicate that this string is from foreign selection by a text
+ property `foreign-selection' so that the caller of
+ x-get-selection-internal (usually x-get-selection) can know
+ that the string must be decode. */
+ if (sd_type == gdk_atom_intern ("COMPOUND_TEXT", false))
+ lispy_type = QCOMPOUND_TEXT;
+ else if (sd_type == gdk_atom_intern ("UTF8_STRING", false))
+ lispy_type = QUTF8_STRING;
+ else if (sd_type == gdk_atom_intern ("text/plain;charset=utf-8", false))
+ lispy_type = Qtext_plain_charset_utf_8;
+ else
+ lispy_type = QSTRING;
+ Fput_text_property (make_fixnum (0), make_fixnum (sd_len),
+ Qforeign_selection, lispy_type, str);
+
+ gtk_selection_data_free (seldata);
+ return str;
+ }
+
+ gtk_selection_data_free (seldata);
+ return Qnil;
+}
+
+
+void
+nxatoms_of_pgtkselect (void)
+{
+}
+
+void
+syms_of_pgtkselect (void)
+{
+ DEFSYM (QCLIPBOARD, "CLIPBOARD");
+ DEFSYM (QSECONDARY, "SECONDARY");
+ DEFSYM (QTEXT, "TEXT");
+ DEFSYM (QFILE_NAME, "FILE_NAME");
+ DEFSYM (QMULTIPLE, "MULTIPLE");
+
+ DEFSYM (Qforeign_selection, "foreign-selection");
+ DEFSYM (QUTF8_STRING, "UTF8_STRING");
+ DEFSYM (QSTRING, "STRING");
+ DEFSYM (QCOMPOUND_TEXT, "COMPOUND_TEXT");
+ DEFSYM (Qtext_plain_charset_utf_8, "text/plain;charset=utf-8");
+
+ defsubr (&Spgtk_disown_selection_internal);
+ defsubr (&Spgtk_get_selection_internal);
+ defsubr (&Spgtk_own_selection_internal);
+ defsubr (&Spgtk_selection_exists_p);
+ defsubr (&Spgtk_selection_owner_p);
+
+#if 0
+ Vselection_alist = Qnil;
+ staticpro (&Vselection_alist);
+#endif
+
+ DEFVAR_LISP ("pgtk-sent-selection-hooks", Vpgtk_sent_selection_hooks,
+ "A list of functions to be called when Emacs answers a selection request.\n\
+The functions are called with four arguments:\n\
+ - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
+ - the selection-type which Emacs was asked to convert the\n\
+ selection into before sending (for example, `STRING' or `LENGTH');\n\
+ - a flag indicating success or failure for responding to the request.\n\
+We might have failed (and declined the request) for any number of reasons,\n\
+including being asked for a selection that we no longer own, or being asked\n\
+to convert into a type that we don't know about or that is inappropriate.\n\
+This hook doesn't let you change the behavior of Emacs's selection replies,\n\
+it merely informs you that they have happened.");
+ Vpgtk_sent_selection_hooks = Qnil;
+
+ DEFVAR_BOOL ("pgtk-enable-selection-on-multi-display", pgtk_enable_selection_on_multi_display,
+ doc: /* Enable selection on multi display environment.
+This may cause crash. */);
+ pgtk_enable_selection_on_multi_display = false;
+}
diff --git a/src/pgtkselect.h b/src/pgtkselect.h
new file mode 100644
index 00000000000..7ad04c217ac
--- /dev/null
+++ b/src/pgtkselect.h
@@ -0,0 +1,33 @@
+/* Definitions and headers for selection of pure Gtk+3.
+ Copyright (C) 1989, 1993, 2005, 2008-2020 Free Software Foundation,
+ Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+
+
+#include "dispextern.h"
+#include "frame.h"
+
+#ifdef HAVE_PGTK
+
+#include <gtk/gtk.h>
+
+extern void pgtk_selection_init (void);
+extern void pgtk_selection_lost (GtkWidget * widget,
+ GdkEventSelection * event,
+ gpointer user_data);
+
+#endif /* HAVE_PGTK */
diff --git a/src/pgtkterm.c b/src/pgtkterm.c
new file mode 100644
index 00000000000..bd61c65edde
--- /dev/null
+++ b/src/pgtkterm.c
@@ -0,0 +1,7115 @@
+/* Pure Gtk+-3 communication module. -*- coding: utf-8 -*-
+
+Copyright (C) 1989, 1993-1994, 2005-2006, 2008-2020 Free Software
+Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+
+/* This should be the first include, as it may set up #defines affecting
+ interpretation of even the system includes. */
+#include <config.h>
+
+#include <cairo.h>
+#include <fcntl.h>
+#include <math.h>
+#include <pthread.h>
+#include <sys/types.h>
+#include <time.h>
+#include <signal.h>
+#include <unistd.h>
+#include <errno.h>
+
+#include <c-ctype.h>
+#include <c-strcase.h>
+#include <ftoastr.h>
+
+#include "lisp.h"
+#include "blockinput.h"
+#include "frame.h"
+#include "sysselect.h"
+#include "gtkutil.h"
+#include "systime.h"
+#include "character.h"
+#include "xwidget.h"
+#include "fontset.h"
+#include "composite.h"
+#include "ccl.h"
+#include "dynlib.h"
+
+#include "termhooks.h"
+#include "termopts.h"
+#include "termchar.h"
+#include "emacs-icon.h"
+#include "menu.h"
+#include "window.h"
+#include "keyboard.h"
+#include "atimer.h"
+#include "buffer.h"
+#include "font.h"
+#include "xsettings.h"
+#include "pgtkselect.h"
+#include "emacsgtkfixed.h"
+
+#ifdef GDK_WINDOWING_WAYLAND
+#include <gdk/gdkwayland.h>
+#endif
+
+#define STORE_KEYSYM_FOR_DEBUG(keysym) ((void)0)
+
+#define FRAME_CR_CONTEXT(f) ((f)->output_data.pgtk->cr_context)
+#define FRAME_CR_ACTIVE_CONTEXT(f) ((f)->output_data.pgtk->cr_active)
+#define FRAME_CR_SURFACE(f) (cairo_get_target (FRAME_CR_CONTEXT (f)))
+
+/* Non-zero means that a HELP_EVENT has been generated since Emacs
+ start. */
+
+static bool any_help_event_p;
+
+struct pgtk_display_info *x_display_list; /* Chain of existing displays */
+extern Lisp_Object tip_frame;
+
+static struct event_queue_t
+{
+ union buffered_input_event *q;
+ int nr, cap;
+} event_q = {
+ NULL, 0, 0,
+};
+
+/* Non-zero timeout value means ignore next mouse click if it arrives
+ before that timeout elapses (i.e. as part of the same sequence of
+ events resulting from clicking on a frame to select it). */
+
+static Time ignore_next_mouse_click_timeout;
+
+static Lisp_Object xg_default_icon_file;
+
+static void pgtk_delete_display (struct pgtk_display_info *dpyinfo);
+static void pgtk_clear_frame_area (struct frame *f, int x, int y, int width,
+ int height);
+static void pgtk_fill_rectangle (struct frame *f, unsigned long color, int x,
+ int y, int width, int height);
+static void pgtk_clip_to_row (struct window *w, struct glyph_row *row,
+ enum glyph_row_area area, cairo_t * cr);
+static struct frame *pgtk_any_window_to_frame (GdkWindow * window);
+
+/*
+ * This is not a flip context in the same sense as gpu rendering
+ * scences, it only occurs when a new context was required due to a
+ * resize or other fundamental change. This is called when that
+ * context's surface has completed drawing
+ */
+
+static void
+flip_cr_context (struct frame *f)
+{
+ cairo_t *cr = FRAME_CR_ACTIVE_CONTEXT (f);
+
+ block_input ();
+ if (cr != FRAME_CR_CONTEXT (f))
+ {
+ cairo_destroy (cr);
+ FRAME_CR_ACTIVE_CONTEXT (f) = cairo_reference (FRAME_CR_CONTEXT (f));
+
+ }
+ unblock_input ();
+}
+
+
+static void
+evq_enqueue (union buffered_input_event *ev)
+{
+ struct event_queue_t *evq = &event_q;
+ if (evq->cap == 0)
+ {
+ evq->cap = 4;
+ evq->q = xmalloc (sizeof *evq->q * evq->cap);
+ }
+
+ if (evq->nr >= evq->cap)
+ {
+ evq->cap += evq->cap / 2;
+ evq->q = xrealloc (evq->q, sizeof *evq->q * evq->cap);
+ }
+
+ evq->q[evq->nr++] = *ev;
+ raise (SIGIO);
+}
+
+static int
+evq_flush (struct input_event *hold_quit)
+{
+ struct event_queue_t *evq = &event_q;
+ int i, n = evq->nr;
+ for (i = 0; i < n; i++)
+ kbd_buffer_store_buffered_event (&evq->q[i], hold_quit);
+ evq->nr = 0;
+ return n;
+}
+
+void
+mark_pgtkterm (void)
+{
+ struct event_queue_t *evq = &event_q;
+ int i, n = evq->nr;
+ for (i = 0; i < n; i++)
+ {
+ union buffered_input_event *ev = &evq->q[i];
+ mark_object (ev->ie.x);
+ mark_object (ev->ie.y);
+ mark_object (ev->ie.frame_or_window);
+ mark_object (ev->ie.arg);
+ }
+}
+
+char *
+get_keysym_name (int keysym)
+/* --------------------------------------------------------------------------
+ Called by keyboard.c. Not sure if the return val is important, except
+ that it be unique.
+ -------------------------------------------------------------------------- */
+{
+ static char value[16];
+ sprintf (value, "%d", keysym);
+ return value;
+}
+
+void
+frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y)
+/* --------------------------------------------------------------------------
+ Programmatically reposition mouse pointer in pixel coordinates
+ -------------------------------------------------------------------------- */
+{
+}
+
+/* Raise frame F. */
+
+static void
+pgtk_raise_frame (struct frame *f)
+{
+ /* This works only for non-child frames on X.
+ It does not work for child frames on X, and it does not work
+ on Wayland too. */
+ block_input ();
+ if (FRAME_VISIBLE_P (f))
+ gdk_window_raise (gtk_widget_get_window (FRAME_WIDGET (f)));
+ unblock_input ();
+}
+
+/* Lower frame F. */
+
+static void
+pgtk_lower_frame (struct frame *f)
+{
+ if (FRAME_VISIBLE_P (f))
+ {
+ block_input ();
+ gdk_window_lower (gtk_widget_get_window (FRAME_WIDGET (f)));
+ unblock_input ();
+ }
+}
+
+static void
+pgtk_frame_raise_lower (struct frame *f, bool raise_flag)
+{
+ if (raise_flag)
+ pgtk_raise_frame (f);
+ else
+ pgtk_lower_frame (f);
+}
+
+/* Free X resources of frame F. */
+
+void
+x_free_frame_resources (struct frame *f)
+{
+ struct pgtk_display_info *dpyinfo;
+ Mouse_HLInfo *hlinfo;
+
+ check_window_system (f);
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+ hlinfo = MOUSE_HL_INFO (f);
+
+ block_input ();
+
+ free_frame_faces (f);
+
+ if (FRAME_X_OUTPUT (f)->scale_factor_atimer != NULL)
+ {
+ cancel_atimer (FRAME_X_OUTPUT (f)->scale_factor_atimer);
+ FRAME_X_OUTPUT (f)->scale_factor_atimer = NULL;
+ }
+
+#define CLEAR_IF_EQ(FIELD) \
+ do { if (f == dpyinfo->FIELD) dpyinfo->FIELD = 0; } while (false)
+
+ CLEAR_IF_EQ (x_focus_frame);
+ CLEAR_IF_EQ (highlight_frame);
+ CLEAR_IF_EQ (x_focus_event_frame);
+ CLEAR_IF_EQ (last_mouse_frame);
+ CLEAR_IF_EQ (last_mouse_motion_frame);
+ CLEAR_IF_EQ (last_mouse_glyph_frame);
+ CLEAR_IF_EQ (im.focused_frame);
+
+#undef CLEAR_IF_EQ
+
+ if (f == hlinfo->mouse_face_mouse_frame)
+ reset_mouse_highlight (hlinfo);
+
+ g_clear_object (&FRAME_X_OUTPUT (f)->text_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->nontext_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->modeline_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->hand_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->hourglass_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->horizontal_drag_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->vertical_drag_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->left_edge_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->right_edge_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->top_edge_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->bottom_edge_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->top_left_corner_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->top_right_corner_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->bottom_right_corner_cursor);
+ g_clear_object (&FRAME_X_OUTPUT (f)->bottom_left_corner_cursor);
+
+
+ if (FRAME_X_OUTPUT (f)->border_color_css_provider != NULL)
+ {
+ GtkStyleContext *ctxt = gtk_widget_get_style_context (FRAME_WIDGET (f));
+ GtkCssProvider *old = FRAME_X_OUTPUT (f)->border_color_css_provider;
+ gtk_style_context_remove_provider (ctxt, GTK_STYLE_PROVIDER (old));
+ g_object_unref (old);
+ FRAME_X_OUTPUT (f)->border_color_css_provider = NULL;
+ }
+
+ if (FRAME_X_OUTPUT (f)->scrollbar_foreground_css_provider != NULL)
+ {
+ GtkCssProvider *old =
+ FRAME_X_OUTPUT (f)->scrollbar_foreground_css_provider;
+ g_object_unref (old);
+ FRAME_X_OUTPUT (f)->scrollbar_foreground_css_provider = NULL;
+ }
+
+ if (FRAME_X_OUTPUT (f)->scrollbar_background_css_provider != NULL)
+ {
+ GtkCssProvider *old =
+ FRAME_X_OUTPUT (f)->scrollbar_background_css_provider;
+ g_object_unref (old);
+ FRAME_X_OUTPUT (f)->scrollbar_background_css_provider = NULL;
+ }
+
+ gtk_widget_destroy (FRAME_WIDGET (f));
+
+ if (FRAME_X_OUTPUT (f)->cr_surface_visible_bell != NULL)
+ {
+ cairo_surface_destroy (FRAME_X_OUTPUT (f)->cr_surface_visible_bell);
+ FRAME_X_OUTPUT (f)->cr_surface_visible_bell = NULL;
+ }
+
+ if (FRAME_X_OUTPUT (f)->atimer_visible_bell != NULL)
+ {
+ cancel_atimer (FRAME_X_OUTPUT (f)->atimer_visible_bell);
+ FRAME_X_OUTPUT (f)->atimer_visible_bell = NULL;
+ }
+
+ xfree (f->output_data.pgtk);
+ f->output_data.pgtk = NULL;
+
+ unblock_input ();
+}
+
+void
+x_destroy_window (struct frame *f)
+/* --------------------------------------------------------------------------
+ External: Delete the window
+ -------------------------------------------------------------------------- */
+{
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+
+ check_window_system (f);
+ if (dpyinfo->gdpy != NULL)
+ x_free_frame_resources (f);
+
+ dpyinfo->reference_count--;
+}
+
+/* Calculate the absolute position in frame F
+ from its current recorded position values and gravity. */
+
+static void
+x_calc_absolute_position (struct frame *f)
+{
+ int flags = f->size_hint_flags;
+ struct frame *p = FRAME_PARENT_FRAME (f);
+
+ /* We have nothing to do if the current position
+ is already for the top-left corner. */
+ if (! ((flags & XNegative) || (flags & YNegative)))
+ return;
+
+ /* Treat negative positions as relative to the leftmost bottommost
+ position that fits on the screen. */
+ if ((flags & XNegative) && (f->left_pos <= 0))
+ {
+ int width = FRAME_PIXEL_WIDTH (f);
+
+ /* A frame that has been visible at least once should have outer
+ edges. */
+ if (f->output_data.pgtk->has_been_visible && !p)
+ {
+ Lisp_Object frame;
+ Lisp_Object edges = Qnil;
+
+ XSETFRAME (frame, f);
+ edges = Fpgtk_frame_edges (frame, Qouter_edges);
+ if (!NILP (edges))
+ width = (XFIXNUM (Fnth (make_fixnum (2), edges))
+ - XFIXNUM (Fnth (make_fixnum (0), edges)));
+ }
+
+ if (p)
+ f->left_pos = (FRAME_PIXEL_WIDTH (p) - width - 2 * f->border_width
+ + f->left_pos);
+ else
+ f->left_pos = (x_display_pixel_width (FRAME_DISPLAY_INFO (f))
+ - width + f->left_pos);
+
+ }
+
+ if ((flags & YNegative) && (f->top_pos <= 0))
+ {
+ int height = FRAME_PIXEL_HEIGHT (f);
+
+ if (f->output_data.pgtk->has_been_visible && !p)
+ {
+ Lisp_Object frame;
+ Lisp_Object edges = Qnil;
+
+ XSETFRAME (frame, f);
+ if (NILP (edges))
+ edges = Fpgtk_frame_edges (frame, Qouter_edges);
+ if (!NILP (edges))
+ height = (XFIXNUM (Fnth (make_fixnum (3), edges))
+ - XFIXNUM (Fnth (make_fixnum (1), edges)));
+ }
+
+ if (p)
+ f->top_pos = (FRAME_PIXEL_HEIGHT (p) - height - 2 * f->border_width
+ + f->top_pos);
+ else
+ f->top_pos = (x_display_pixel_height (FRAME_DISPLAY_INFO (f))
+ - height + f->top_pos);
+ }
+
+ /* The left_pos and top_pos
+ are now relative to the top and left screen edges,
+ so the flags should correspond. */
+ f->size_hint_flags &= ~ (XNegative | YNegative);
+}
+
+/* CHANGE_GRAVITY is 1 when calling from Fset_frame_position,
+ to really change the position, and 0 when calling from
+ x_make_frame_visible (in that case, XOFF and YOFF are the current
+ position values). It is -1 when calling from x_set_frame_parameters,
+ which means, do adjust for borders but don't change the gravity. */
+
+static void
+x_set_offset (struct frame *f, int xoff, int yoff, int change_gravity)
+/* --------------------------------------------------------------------------
+ External: Position the window
+ -------------------------------------------------------------------------- */
+{
+ int modified_top, modified_left;
+
+ 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;
+ }
+
+ x_calc_absolute_position (f);
+
+ block_input ();
+ x_wm_set_size_hint (f, 0, false);
+
+ if (x_gtk_use_window_move)
+ {
+ if (change_gravity != 0)
+ {
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ gtk_window_move (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ f->left_pos, f->top_pos);
+ }
+ else
+ {
+ GtkWidget *fixed = FRAME_GTK_WIDGET (f);
+ GtkWidget *parent = gtk_widget_get_parent (fixed);
+ gtk_fixed_move (GTK_FIXED (parent), fixed,
+ f->left_pos, f->top_pos);
+ }
+ }
+ unblock_input ();
+ return;
+ }
+
+ modified_left = f->left_pos;
+ modified_top = f->top_pos;
+
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ gtk_window_move (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ modified_left, modified_top);
+ }
+ else
+ {
+ GtkWidget *fixed = FRAME_GTK_WIDGET (f);
+ GtkWidget *parent = gtk_widget_get_parent (fixed);
+ gtk_fixed_move (GTK_FIXED (parent), fixed,
+ modified_left, modified_top);
+ }
+
+ unblock_input ();
+}
+
+static void
+pgtk_set_window_size (struct frame *f, bool change_gravity,
+ int width, int height)
+/* --------------------------------------------------------------------------
+ Adjust window pixel size based on given character grid size
+ Impl is a bit more complex than other terms, need to do some
+ internal clipping.
+ -------------------------------------------------------------------------- */
+{
+ int pixelwidth, pixelheight;
+
+ block_input ();
+
+ gtk_widget_get_size_request (FRAME_GTK_WIDGET (f), &pixelwidth,
+ &pixelheight);
+
+#if 0
+ if (pixelwise)
+ {
+ pixelwidth = FRAME_TEXT_TO_PIXEL_WIDTH (f, width);
+ pixelheight = FRAME_TEXT_TO_PIXEL_HEIGHT (f, height);
+ }
+ else
+ {
+ pixelwidth = FRAME_TEXT_COLS_TO_PIXEL_WIDTH (f, width);
+ pixelheight = FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (f, height);
+ }
+#else
+ pixelwidth = width;
+ pixelheight = height;
+#endif
+
+#if 0
+ frame_size_history_add
+ (f, Qx_set_window_size_1, width, height,
+ list5 (Fcons (make_fixnum (pixelwidth), make_fixnum (pixelheight)),
+ Fcons (make_fixnum (pixelwidth), make_fixnum (pixelheight)),
+ make_fixnum (f->border_width),
+ make_fixnum (FRAME_PGTK_TITLEBAR_HEIGHT (f)),
+ make_fixnum (FRAME_TOOLBAR_HEIGHT (f))));
+#endif
+
+ for (GtkWidget * w = FRAME_GTK_WIDGET (f); w != NULL;
+ w = gtk_widget_get_parent (w))
+ {
+ gint wd, hi;
+ gtk_widget_get_size_request (w, &wd, &hi);
+ }
+
+ f->output_data.pgtk->preferred_width = pixelwidth;
+ f->output_data.pgtk->preferred_height = pixelheight;
+ x_wm_set_size_hint (f, 0, 0);
+ xg_frame_set_char_size (f, pixelwidth, pixelheight);
+ gtk_widget_queue_resize (FRAME_WIDGET (f));
+
+ unblock_input ();
+}
+
+void
+pgtk_iconify_frame (struct frame *f)
+/* --------------------------------------------------------------------------
+ External: Iconify window
+ -------------------------------------------------------------------------- */
+{
+ /* Don't keep the highlight on an invisible frame. */
+ if (FRAME_DISPLAY_INFO (f)->highlight_frame == f)
+ FRAME_DISPLAY_INFO (f)->highlight_frame = 0;
+
+ if (FRAME_ICONIFIED_P (f))
+ return;
+
+ block_input ();
+
+#if 0
+ x_set_bitmap_icon (f);
+#endif
+
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ if (!FRAME_VISIBLE_P (f))
+ gtk_widget_show_all (FRAME_GTK_OUTER_WIDGET (f));
+
+ gtk_window_iconify (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)));
+ SET_FRAME_VISIBLE (f, 0);
+ SET_FRAME_ICONIFIED (f, true);
+ unblock_input ();
+ return;
+ }
+
+ /* Make sure the X server knows where the window should be positioned,
+ in case the user deiconifies with the window manager. */
+ if (!FRAME_VISIBLE_P (f) && !FRAME_ICONIFIED_P (f)
+#if 0
+ && !FRAME_X_EMBEDDED_P (f)
+#endif
+ )
+ x_set_offset (f, f->left_pos, f->top_pos, 0);
+
+#if 0
+ if (!FRAME_VISIBLE_P (f))
+ {
+ /* If the frame was withdrawn, before, we must map it. */
+ XMapRaised (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f));
+ }
+#endif
+
+ SET_FRAME_ICONIFIED (f, true);
+ SET_FRAME_VISIBLE (f, 0);
+
+ unblock_input ();
+}
+
+static gboolean
+pgtk_make_frame_visible_wait_for_map_event_cb (GtkWidget * widget,
+ GdkEventAny * event,
+ gpointer user_data)
+{
+ int *foundptr = user_data;
+ *foundptr = 1;
+ return FALSE;
+}
+
+static gboolean
+pgtk_make_frame_visible_wait_for_map_event_timeout (gpointer user_data)
+{
+ int *timedoutptr = user_data;
+ *timedoutptr = 1;
+ return FALSE;
+}
+
+static void
+pgtk_wait_for_map_event (struct frame *f, bool multiple_times)
+{
+ if (FLOATP (Vpgtk_wait_for_event_timeout))
+ {
+ guint msec =
+ (guint) (XFLOAT_DATA (Vpgtk_wait_for_event_timeout) * 1000);
+ int found = 0;
+ int timed_out = 0;
+ gulong id =
+ g_signal_connect (FRAME_WIDGET (f), "map-event",
+ G_CALLBACK
+ (pgtk_make_frame_visible_wait_for_map_event_cb),
+ &found);
+ guint src =
+ g_timeout_add (msec,
+ pgtk_make_frame_visible_wait_for_map_event_timeout,
+ &timed_out);
+
+ if (!multiple_times)
+ {
+ while (!found && !timed_out)
+ gtk_main_iteration ();
+ }
+ else
+ {
+ while (!timed_out)
+ gtk_main_iteration ();
+ }
+
+ g_signal_handler_disconnect (FRAME_WIDGET (f), id);
+ if (!timed_out)
+ g_source_remove (src);
+ }
+}
+
+void
+pgtk_make_frame_visible (struct frame *f)
+/* --------------------------------------------------------------------------
+ External: Show the window (X11 semantics)
+ -------------------------------------------------------------------------- */
+{
+ GtkWidget *win = FRAME_GTK_OUTER_WIDGET (f);
+
+ if (!FRAME_VISIBLE_P (f))
+ {
+ gtk_widget_show (FRAME_WIDGET (f));
+ if (win)
+ gtk_window_deiconify (GTK_WINDOW (win));
+
+ pgtk_wait_for_map_event (f, false);
+ }
+}
+
+
+void
+pgtk_make_frame_invisible (struct frame *f)
+/* --------------------------------------------------------------------------
+ External: Hide the window (X11 semantics)
+ -------------------------------------------------------------------------- */
+{
+ gtk_widget_hide (FRAME_WIDGET (f));
+
+ /* Map events are emitted many times, and
+ * map_event() do SET_FRAME_VISIBLE(f, 1).
+ * I expect visible = 0, so process those map events here and
+ * SET_FRAME_VISIBLE(f, 0) after that.
+ */
+ pgtk_wait_for_map_event (f, true);
+
+ SET_FRAME_VISIBLE (f, 0);
+ SET_FRAME_ICONIFIED (f, false);
+}
+
+static void
+pgtk_make_frame_visible_invisible (struct frame *f, bool visible)
+{
+ if (visible)
+ pgtk_make_frame_visible (f);
+ else
+ pgtk_make_frame_invisible (f);
+}
+
+static Lisp_Object
+pgtk_new_font (struct frame *f, Lisp_Object font_object, int fontset)
+{
+ struct font *font = XFONT_OBJECT (font_object);
+ int 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 the scroll bar width in character columns. */
+ if (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0)
+ {
+ int wid = FRAME_COLUMN_WIDTH (f);
+ FRAME_CONFIG_SCROLL_BAR_COLS (f)
+ = (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) + wid - 1) / wid;
+ }
+ else
+ {
+ int wid = FRAME_COLUMN_WIDTH (f);
+ FRAME_CONFIG_SCROLL_BAR_COLS (f) = (14 + wid - 1) / wid;
+ }
+
+ /* Compute the scroll bar height in character lines. */
+ if (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) > 0)
+ {
+ int height = FRAME_LINE_HEIGHT (f);
+ FRAME_CONFIG_SCROLL_BAR_LINES (f)
+ = (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) + height - 1) / height;
+ }
+ else
+ {
+ int height = FRAME_LINE_HEIGHT (f);
+ FRAME_CONFIG_SCROLL_BAR_LINES (f) = (14 + height - 1) / height;
+ }
+
+ /* Now make the frame display the given font. */
+ if (FRAME_GTK_WIDGET (f) != NULL)
+ adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
+ FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 3,
+ false, Qfont);
+
+ return font_object;
+}
+
+int
+x_display_pixel_height (struct pgtk_display_info *dpyinfo)
+{
+ GdkDisplay *gdpy = dpyinfo->gdpy;
+ GdkScreen *gscr = gdk_display_get_default_screen (gdpy);
+ return gdk_screen_get_height (gscr);
+}
+
+int
+x_display_pixel_width (struct pgtk_display_info *dpyinfo)
+{
+ GdkDisplay *gdpy = dpyinfo->gdpy;
+ GdkScreen *gscr = gdk_display_get_default_screen (gdpy);
+ return gdk_screen_get_width (gscr);
+}
+
+void
+x_set_parent_frame (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+/* --------------------------------------------------------------------------
+ Set frame F's `parent-frame' parameter. If non-nil, make F a child
+ frame of the frame specified by that parameter. Technically, this
+ makes F's window-system window a child window of the parent frame's
+ window-system window. If nil, make F's window-system window a
+ top-level window--a child of its display's root window.
+
+ A child frame's `left' and `top' parameters specify positions
+ relative to the top-left corner of its parent frame's native
+ rectangle. On macOS moving a parent frame moves all its child
+ frames too, keeping their position relative to the parent
+ unaltered. When a parent frame is iconified or made invisible, its
+ child frames are made invisible. When a parent frame is deleted,
+ its child frames are deleted too.
+
+ Whether a child frame has a tool bar may be window-system or window
+ manager dependent. It's advisable to disable it via the frame
+ parameter settings.
+
+ Some window managers may not honor this parameter.
+ -------------------------------------------------------------------------- */
+{
+ struct frame *p = NULL;
+
+ if (!NILP (new_value)
+ && (!FRAMEP (new_value)
+ || !FRAME_LIVE_P (p = XFRAME (new_value))
+ || !FRAME_PGTK_P (p)))
+ {
+ store_frame_param (f, Qparent_frame, old_value);
+ error ("Invalid specification of `parent-frame'");
+ }
+
+ if (p != FRAME_PARENT_FRAME (f))
+ {
+ block_input ();
+
+ if (p != NULL)
+ {
+ if (FRAME_DISPLAY_INFO (f) != FRAME_DISPLAY_INFO (p))
+ error ("Cross display reparent.");
+ }
+
+ GtkWidget *fixed = FRAME_GTK_WIDGET (f);
+
+ GtkAllocation alloc;
+ gtk_widget_get_allocation (fixed, &alloc);
+ g_object_ref (fixed);
+
+ /* Remember the css provider, and restore it later. */
+ GtkCssProvider *provider = FRAME_X_OUTPUT (f)->border_color_css_provider;
+ FRAME_X_OUTPUT (f)->border_color_css_provider = NULL;
+ {
+ GtkStyleContext *ctxt = gtk_widget_get_style_context (FRAME_WIDGET (f));
+ if (provider != NULL)
+ gtk_style_context_remove_provider (ctxt, GTK_STYLE_PROVIDER (provider));
+ }
+
+ {
+ GtkWidget *whbox_of_f = gtk_widget_get_parent (fixed);
+ /* Here, unhighlight can be called and may change border_color_css_provider. */
+ gtk_container_remove (GTK_CONTAINER (whbox_of_f), fixed);
+
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ gtk_widget_destroy (FRAME_GTK_OUTER_WIDGET (f));
+ FRAME_GTK_OUTER_WIDGET (f) = NULL;
+ FRAME_OUTPUT_DATA (f)->vbox_widget = NULL;
+ FRAME_OUTPUT_DATA (f)->hbox_widget = NULL;
+ FRAME_OUTPUT_DATA (f)->menubar_widget = NULL;
+ FRAME_OUTPUT_DATA (f)->toolbar_widget = NULL;
+ FRAME_OUTPUT_DATA (f)->ttip_widget = NULL;
+ FRAME_OUTPUT_DATA (f)->ttip_lbl = NULL;
+ FRAME_OUTPUT_DATA (f)->ttip_window = NULL;
+ }
+ }
+
+ if (p == NULL)
+ {
+ xg_create_frame_outer_widgets (f);
+ pgtk_set_event_handler (f);
+ gtk_box_pack_start (GTK_BOX (f->output_data.pgtk->hbox_widget), fixed, TRUE, TRUE, 0);
+ f->output_data.pgtk->preferred_width = alloc.width;
+ f->output_data.pgtk->preferred_height = alloc.height;
+ x_wm_set_size_hint (f, 0, 0);
+ xg_frame_set_char_size (f, FRAME_PIXEL_TO_TEXT_WIDTH (f, alloc.width),
+ FRAME_PIXEL_TO_TEXT_HEIGHT (f, alloc.height));
+ gtk_widget_queue_resize (FRAME_WIDGET (f));
+ gtk_widget_show_all (FRAME_GTK_OUTER_WIDGET (f));
+ }
+ else
+ {
+ GtkWidget *fixed_of_p = FRAME_GTK_WIDGET (p);
+ gtk_fixed_put (GTK_FIXED (fixed_of_p), fixed, f->left_pos, f->top_pos);
+ gtk_widget_set_size_request (fixed, alloc.width, alloc.height);
+ gtk_widget_show_all (fixed);
+ }
+
+ /* Restore css provider. */
+ GtkStyleContext *ctxt = gtk_widget_get_style_context (FRAME_WIDGET (f));
+ GtkCssProvider *old = FRAME_X_OUTPUT (f)->border_color_css_provider;
+ FRAME_X_OUTPUT (f)->border_color_css_provider = provider;
+ if (provider != NULL)
+ {
+ gtk_style_context_add_provider (ctxt, GTK_STYLE_PROVIDER (provider),
+ GTK_STYLE_PROVIDER_PRIORITY_USER);
+ }
+ if (old != NULL)
+ {
+ gtk_style_context_remove_provider (ctxt, GTK_STYLE_PROVIDER (old));
+ g_object_unref(old);
+ }
+
+ g_object_unref (fixed);
+
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ if (EQ (x_gtk_resize_child_frames, Qresize_mode))
+ gtk_container_set_resize_mode
+ (GTK_CONTAINER (FRAME_GTK_OUTER_WIDGET (f)),
+ p ? GTK_RESIZE_IMMEDIATE : GTK_RESIZE_QUEUE);
+ }
+
+ unblock_input ();
+
+ fset_parent_frame (f, new_value);
+ }
+}
+
+
+void
+x_set_no_focus_on_map (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+/* Set frame F's `no-focus-on-map' parameter which, if non-nil, means
+ * that F's window-system window does not want to receive input focus
+ * when it is mapped. (A frame's window is mapped when the frame is
+ * displayed for the first time and when the frame changes its state
+ * from `iconified' or `invisible' to `visible'.)
+ *
+ * Some window managers may not honor this parameter. */
+{
+ /* doesn't work on wayland. */
+
+ if (!EQ (new_value, old_value))
+ {
+ xg_set_no_focus_on_map (f, new_value);
+ FRAME_NO_FOCUS_ON_MAP (f) = !NILP (new_value);
+ }
+}
+
+void
+x_set_no_accept_focus (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+/* Set frame F's `no-accept-focus' parameter which, if non-nil, hints
+ * that F's window-system window does not want to receive input focus
+ * via mouse clicks or by moving the mouse into it.
+ *
+ * If non-nil, this may have the unwanted side-effect that a user cannot
+ * scroll a non-selected frame with the mouse.
+ *
+ * Some window managers may not honor this parameter. */
+{
+ /* doesn't work on wayland. */
+
+ xg_set_no_accept_focus (f, new_value);
+ FRAME_NO_ACCEPT_FOCUS (f) = !NILP (new_value);
+}
+
+void
+x_set_z_group (struct frame *f, Lisp_Object new_value, Lisp_Object old_value)
+/* Set frame F's `z-group' parameter. If `above', F's window-system
+ window is displayed above all windows that do not have the `above'
+ property set. If nil, F's window is shown below all windows that
+ have the `above' property set and above all windows that have the
+ `below' property set. If `below', F's window is displayed below
+ all windows that do.
+
+ Some window managers may not honor this parameter. */
+{
+ /* doesn't work on wayland. */
+
+ if (!FRAME_GTK_OUTER_WIDGET (f))
+ return;
+
+ if (NILP (new_value))
+ {
+ gtk_window_set_keep_above (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ FALSE);
+ gtk_window_set_keep_below (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ FALSE);
+ FRAME_Z_GROUP (f) = z_group_none;
+ }
+ else if (EQ (new_value, Qabove))
+ {
+ gtk_window_set_keep_above (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ TRUE);
+ gtk_window_set_keep_below (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ FALSE);
+ FRAME_Z_GROUP (f) = z_group_above;
+ }
+ else if (EQ (new_value, Qabove_suspended))
+ {
+ gtk_window_set_keep_above (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ FALSE);
+ FRAME_Z_GROUP (f) = z_group_above_suspended;
+ }
+ else if (EQ (new_value, Qbelow))
+ {
+ gtk_window_set_keep_above (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ FALSE);
+ gtk_window_set_keep_below (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ TRUE);
+ FRAME_Z_GROUP (f) = z_group_below;
+ }
+ else
+ error ("Invalid z-group specification");
+}
+
+static void
+pgtk_initialize_display_info (struct pgtk_display_info *dpyinfo)
+/* --------------------------------------------------------------------------
+ Initialize global info and storage for display.
+ -------------------------------------------------------------------------- */
+{
+ dpyinfo->resx = 96;
+ dpyinfo->resy = 96;
+ dpyinfo->color_p = 1;
+ dpyinfo->n_planes = 32;
+ dpyinfo->root_window = 42; /* a placeholder.. */
+ dpyinfo->highlight_frame = dpyinfo->x_focus_frame = NULL;
+ dpyinfo->n_fonts = 0;
+ dpyinfo->smallest_font_height = 1;
+ dpyinfo->smallest_char_width = 1;
+
+ reset_mouse_highlight (&dpyinfo->mouse_highlight);
+}
+
+/* Set S->gc to a suitable GC for drawing glyph string S in cursor
+ face. */
+
+static void
+x_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->xgcv = FRAME_X_OUTPUT (s->f)->cursor_xgcv;
+ else
+ {
+ /* Cursor on non-default face: must merge. */
+ Emacs_GC xgcv;
+
+ xgcv.background = FRAME_X_OUTPUT (s->f)->cursor_color;
+ 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 = FRAME_X_OUTPUT (s->f)->cursor_foreground_color;
+ 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;
+ }
+
+ s->xgcv = xgcv;
+ }
+}
+
+
+/* Set up S->gc of glyph string S for drawing text in mouse face. */
+
+static void
+x_set_mouse_face_gc (struct glyph_string *s)
+{
+ prepare_face_for_display (s->f, s->face);
+
+ if (s->font == s->face->font)
+ {
+ s->xgcv.foreground = s->face->foreground;
+ s->xgcv.background = s->face->background;
+ }
+ else
+ {
+ /* Otherwise construct scratch_cursor_gc with values from FACE
+ except for FONT. */
+ Emacs_GC xgcv;
+
+ xgcv.background = s->face->background;
+ xgcv.foreground = s->face->foreground;
+
+ s->xgcv = xgcv;
+
+ }
+}
+
+
+/* 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
+x_set_mode_line_face_gc (struct glyph_string *s)
+{
+ s->xgcv.foreground = s->face->foreground;
+ s->xgcv.background = s->face->background;
+}
+
+
+/* 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
+x_set_glyph_string_gc (struct glyph_string *s)
+{
+ prepare_face_for_display (s->f, s->face);
+
+ if (s->hl == DRAW_NORMAL_TEXT)
+ {
+ s->xgcv.foreground = s->face->foreground;
+ s->xgcv.background = s->face->background;
+ s->stippled_p = s->face->stipple != 0;
+ }
+ else if (s->hl == DRAW_INVERSE_VIDEO)
+ {
+ x_set_mode_line_face_gc (s);
+ s->stippled_p = s->face->stipple != 0;
+ }
+ else if (s->hl == DRAW_CURSOR)
+ {
+ x_set_cursor_gc (s);
+ s->stippled_p = false;
+ }
+ else if (s->hl == DRAW_MOUSE_FACE)
+ {
+ x_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->xgcv.foreground = s->face->foreground;
+ s->xgcv.background = s->face->background;
+ s->stippled_p = s->face->stipple != 0;
+ }
+ else
+ emacs_abort ();
+}
+
+
+/* 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
+x_set_glyph_string_clipping (struct glyph_string *s, cairo_t * cr)
+{
+ XRectangle r[2];
+ int n = get_glyph_string_clip_rects (s, r, 2);
+
+ if (n > 0)
+ {
+ for (int i = 0; i < n; i++)
+ {
+ cairo_rectangle (cr, r[i].x, r[i].y, r[i].width, r[i].height);
+ }
+ cairo_clip (cr);
+ }
+}
+
+
+/* Set SRC's clipping for output of glyph string DST. This is called
+ when we are drawing DST's left_overhang or right_overhang only in
+ the area of SRC. */
+
+static void
+x_set_glyph_string_clipping_exactly (struct glyph_string *src,
+ struct glyph_string *dst, cairo_t * cr)
+{
+ dst->clip[0].x = src->x;
+ dst->clip[0].y = src->y;
+ dst->clip[0].width = src->width;
+ dst->clip[0].height = src->height;
+ dst->num_clips = 1;
+
+ cairo_rectangle (cr, src->x, src->y, src->width, src->height);
+ cairo_clip (cr);
+}
+
+
+/* RIF:
+ Compute left and right overhang of glyph string S. */
+
+static void
+pgtk_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)
+ {
+ unsigned *code = alloca (sizeof (unsigned) * s->nchars);
+ struct font *font = s->font;
+ int i;
+
+ for (i = 0; i < s->nchars; i++)
+ code[i] = s->char2b[i];
+ font->driver->text_extents (font, code, 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;
+ }
+}
+
+
+/* Fill rectangle X, Y, W, H with background color of glyph string S. */
+
+static void
+x_clear_glyph_string_rect (struct glyph_string *s, int x, int y, int w, int h)
+{
+ pgtk_fill_rectangle (s->f, s->xgcv.background, x, y, w, h);
+}
+
+
+static void
+fill_background_by_face (struct frame *f, struct face *face, int x, int y,
+ int width, int height)
+{
+ cairo_t *cr = pgtk_begin_cr_clip (f);
+
+ cairo_rectangle (cr, x, y, width, height);
+ cairo_clip (cr);
+
+ double r = ((face->background >> 16) & 0xff) / 255.0;
+ double g = ((face->background >> 8) & 0xff) / 255.0;
+ double b = ((face->background >> 0) & 0xff) / 255.0;
+ cairo_set_source_rgb (cr, r, g, b);
+ cairo_paint (cr);
+
+ if (face->stipple != 0)
+ {
+ cairo_pattern_t *mask =
+ FRAME_DISPLAY_INFO (f)->bitmaps[face->stipple - 1].pattern;
+
+ double r = ((face->foreground >> 16) & 0xff) / 255.0;
+ double g = ((face->foreground >> 8) & 0xff) / 255.0;
+ double b = ((face->foreground >> 0) & 0xff) / 255.0;
+ cairo_set_source_rgb (cr, r, g, b);
+ cairo_mask (cr, mask);
+ }
+
+ pgtk_end_cr_clip (f);
+}
+
+static void
+fill_background (struct glyph_string *s, int x, int y, int width, int height)
+{
+ fill_background_by_face (s->f, s->face, x, y, width, height);
+}
+
+/* Draw the background of glyph_string S. If S->background_filled_p
+ is non-zero don't draw it. FORCE_P non-zero means draw the
+ background even if it wouldn't be drawn normally. This is used
+ when a string preceding S draws into the background of S, or S
+ contains the first component of a composition. */
+
+static void
+x_draw_glyph_string_background (struct glyph_string *s, bool force_p)
+{
+ /* 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. */
+
+ fill_background (s,
+ s->x, s->y + box_line_width,
+ s->background_width,
+ s->height - 2 * box_line_width);
+ 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)
+ {
+ x_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
+pgtk_draw_rectangle (struct frame *f, unsigned long color, int x, int y,
+ int width, int height)
+{
+ cairo_t *cr;
+
+ cr = pgtk_begin_cr_clip (f);
+ pgtk_set_cr_source_with_color (f, color);
+ cairo_rectangle (cr, x + 0.5, y + 0.5, width, height);
+ cairo_set_line_width (cr, 1);
+ cairo_stroke (cr);
+ pgtk_end_cr_clip (f);
+}
+
+/* Draw the foreground of glyph string S. */
+
+static void
+x_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;
+ pgtk_draw_rectangle (s->f,
+ s->face->foreground, 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);
+ }
+}
+
+/* Draw the foreground of composite glyph string S. */
+
+static void
+x_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)
+ pgtk_draw_rectangle (s->f, s->face->foreground, 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);
+ }
+ }
+}
+
+
+/* Draw the foreground of glyph string S for glyphless characters. */
+
+static void
+x_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 (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)
+ pgtk_draw_rectangle (s->f, s->face->foreground,
+ x, s->ybase - glyph->ascent,
+ glyph->pixel_width - 1,
+ glyph->ascent + glyph->descent - 1);
+ x += glyph->pixel_width;
+ }
+}
+
+/* Brightness beyond which a color won't have its highlight brightness
+ boosted.
+
+ Nominally, highlight colors for `3d' faces are calculated by
+ brightening an object's color by a constant scale factor, but this
+ doesn't yield good results for dark colors, so for colors who's
+ brightness is less than this value (on a scale of 0-65535) have an
+ use an additional additive factor.
+
+ The value here is set so that the default menu-bar/mode-line color
+ (grey75) will not have its highlights changed at all. */
+#define HIGHLIGHT_COLOR_DARK_BOOST_LIMIT 48000
+
+
+/* Allocate a color which is lighter or darker than *PIXEL by FACTOR
+ or DELTA. Try a color with RGB values multiplied by FACTOR first.
+ If this produces the same color as PIXEL, try a color where all RGB
+ values have DELTA added. Return the allocated color in *PIXEL.
+ DISPLAY is the X display, CMAP is the colormap to operate on.
+ Value is non-zero if successful. */
+
+static bool
+x_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;
+ pgtk_query_color (f, &color);
+
+ /* 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. */
+ new.pixel = new.red >> 8 << 16 | new.green >> 8 << 8 | new.blue >> 8;
+ success_p = true;
+ 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);
+ new.pixel =
+ new.red >> 8 << 16 | new.green >> 8 << 8 | new.blue >> 8;
+ success_p = true;
+ }
+ else
+ success_p = true;
+ *pixel = new.pixel;
+ }
+
+ return success_p;
+}
+
+static void
+x_fill_trapezoid_for_relief (struct frame *f, unsigned long color, int x,
+ int y, int width, int height, int top_p)
+{
+ cairo_t *cr;
+
+ cr = pgtk_begin_cr_clip (f);
+ pgtk_set_cr_source_with_color (f, color);
+ cairo_move_to (cr, top_p ? x : x + height, y);
+ cairo_line_to (cr, x, y + height);
+ cairo_line_to (cr, top_p ? x + width - height : x + width, y + height);
+ cairo_line_to (cr, x + width, y);
+ cairo_fill (cr);
+ pgtk_end_cr_clip (f);
+}
+
+enum corners
+{
+ CORNER_BOTTOM_RIGHT, /* 0 -> pi/2 */
+ CORNER_BOTTOM_LEFT, /* pi/2 -> pi */
+ CORNER_TOP_LEFT, /* pi -> 3pi/2 */
+ CORNER_TOP_RIGHT, /* 3pi/2 -> 2pi */
+ CORNER_LAST
+};
+
+static void
+x_erase_corners_for_relief (struct frame *f, unsigned long color, int x,
+ int y, int width, int height, double radius,
+ double margin, int corners)
+{
+ cairo_t *cr;
+ int i;
+
+ cr = pgtk_begin_cr_clip (f);
+ pgtk_set_cr_source_with_color (f, color);
+ for (i = 0; i < CORNER_LAST; i++)
+ if (corners & (1 << i))
+ {
+ double xm, ym, xc, yc;
+
+ if (i == CORNER_TOP_LEFT || i == CORNER_BOTTOM_LEFT)
+ xm = x - margin, xc = xm + radius;
+ else
+ xm = x + width + margin, xc = xm - radius;
+ if (i == CORNER_TOP_LEFT || i == CORNER_TOP_RIGHT)
+ ym = y - margin, yc = ym + radius;
+ else
+ ym = y + height + margin, yc = ym - radius;
+
+ cairo_move_to (cr, xm, ym);
+ cairo_arc (cr, xc, yc, radius, i * M_PI_2, (i + 1) * M_PI_2);
+ }
+ cairo_clip (cr);
+ cairo_rectangle (cr, x, y, width, height);
+ cairo_fill (cr);
+ pgtk_end_cr_clip (f);
+}
+
+/* Set up the foreground color for drawing relief lines of glyph
+ string S. RELIEF is a pointer to a struct relief containing the GC
+ with which lines will be drawn. Use a color that is FACTOR or
+ DELTA lighter or darker than the relief's background which is found
+ in S->f->output_data.pgtk->relief_background. If such a color cannot
+ be allocated, use DEFAULT_PIXEL, instead. */
+
+static void
+x_setup_relief_color (struct frame *f, struct relief *relief, double factor,
+ int delta, unsigned long default_pixel)
+{
+ Emacs_GC xgcv;
+ struct pgtk_output *di = FRAME_X_OUTPUT (f);
+ unsigned long pixel;
+ unsigned long background = di->relief_background;
+
+ /* Allocate new color. */
+ xgcv.foreground = default_pixel;
+ pixel = background;
+ if (x_alloc_lighter_color (f, &pixel, factor, delta))
+ xgcv.foreground = relief->pixel = pixel;
+
+ relief->xgcv = xgcv;
+}
+
+/* Set up colors for the relief lines around glyph string S. */
+
+static void
+x_setup_relief_colors (struct glyph_string *s)
+{
+ struct pgtk_output *di = FRAME_X_OUTPUT (s->f);
+ unsigned long color;
+
+ 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
+ {
+ /* Get the background color of the face. */
+ color = s->xgcv.background;
+ }
+
+ if (TRUE)
+ {
+ di->relief_background = color;
+ x_setup_relief_color (s->f, &di->white_relief, 1.2, 0x8000,
+ WHITE_PIX_DEFAULT (s->f));
+ x_setup_relief_color (s->f, &di->black_relief, 0.6, 0x4000,
+ BLACK_PIX_DEFAULT (s->f));
+ }
+}
+
+
+static void
+x_set_clip_rectangles (struct frame *f, cairo_t * cr, XRectangle * rectangles,
+ int n)
+{
+ if (n > 0)
+ {
+ for (int i = 0; i < n; i++)
+ {
+ cairo_rectangle (cr,
+ rectangles[i].x,
+ rectangles[i].y,
+ rectangles[i].width, rectangles[i].height);
+ }
+ cairo_clip (cr);
+ }
+}
+
+/* Draw a relief on frame F inside the rectangle given by LEFT_X,
+ TOP_Y, RIGHT_X, and BOTTOM_Y. WIDTH is the thickness of the relief
+ to draw, it must be >= 0. RAISED_P means draw a raised
+ relief. LEFT_P means draw a relief on the left side of
+ the rectangle. RIGHT_P means draw a relief on the right
+ side of the rectangle. CLIP_RECT is the clipping rectangle to use
+ when drawing. */
+
+static void
+x_draw_relief_rect (struct frame *f,
+ int left_x, int top_y, int right_x, int bottom_y,
+ int hwidth, int vwidth, bool raised_p, bool top_p,
+ bool bot_p, bool left_p, bool right_p,
+ XRectangle * clip_rect)
+{
+ unsigned long top_left_color, bottom_right_color;
+ int corners = 0;
+
+ cairo_t *cr = pgtk_begin_cr_clip (f);
+
+ if (raised_p)
+ {
+ top_left_color = FRAME_X_OUTPUT (f)->white_relief.xgcv.foreground;
+ bottom_right_color = FRAME_X_OUTPUT (f)->black_relief.xgcv.foreground;
+ }
+ else
+ {
+ top_left_color = FRAME_X_OUTPUT (f)->black_relief.xgcv.foreground;
+ bottom_right_color = FRAME_X_OUTPUT (f)->white_relief.xgcv.foreground;
+ }
+
+ x_set_clip_rectangles (f, cr, clip_rect, 1);
+
+ if (left_p)
+ {
+ pgtk_fill_rectangle (f, top_left_color, left_x, top_y,
+ vwidth, bottom_y + 1 - top_y);
+ if (top_p)
+ corners |= 1 << CORNER_TOP_LEFT;
+ if (bot_p)
+ corners |= 1 << CORNER_BOTTOM_LEFT;
+ }
+ if (right_p)
+ {
+ pgtk_fill_rectangle (f, bottom_right_color, right_x + 1 - vwidth, top_y,
+ vwidth, bottom_y + 1 - top_y);
+ if (top_p)
+ corners |= 1 << CORNER_TOP_RIGHT;
+ if (bot_p)
+ corners |= 1 << CORNER_BOTTOM_RIGHT;
+ }
+ if (top_p)
+ {
+ if (!right_p)
+ pgtk_fill_rectangle (f, top_left_color, left_x, top_y,
+ right_x + 1 - left_x, hwidth);
+ else
+ x_fill_trapezoid_for_relief (f, top_left_color, left_x, top_y,
+ right_x + 1 - left_x, hwidth, 1);
+ }
+ if (bot_p)
+ {
+ if (!left_p)
+ pgtk_fill_rectangle (f, bottom_right_color, left_x,
+ bottom_y + 1 - hwidth, right_x + 1 - left_x,
+ hwidth);
+ else
+ x_fill_trapezoid_for_relief (f, bottom_right_color,
+ left_x, bottom_y + 1 - hwidth,
+ right_x + 1 - left_x, hwidth, 0);
+ }
+ if (left_p && vwidth > 1)
+ pgtk_fill_rectangle (f, bottom_right_color, left_x, top_y,
+ 1, bottom_y + 1 - top_y);
+ if (top_p && hwidth > 1)
+ pgtk_fill_rectangle (f, bottom_right_color, left_x, top_y,
+ right_x + 1 - left_x, 1);
+ if (corners)
+ {
+ x_erase_corners_for_relief (f, FRAME_BACKGROUND_PIXEL (f), left_x,
+ top_y, right_x - left_x + 1,
+ bottom_y - top_y + 1, 6, 1, corners);
+ }
+
+ pgtk_end_cr_clip (f);
+}
+
+/* Draw a box on frame F inside the rectangle given by LEFT_X, TOP_Y,
+ RIGHT_X, and BOTTOM_Y. WIDTH is the thickness of the lines to
+ draw, it must be >= 0. LEFT_P means draw a line on the
+ left side of the rectangle. RIGHT_P means draw a line
+ on the right side of the rectangle. CLIP_RECT is the clipping
+ rectangle to use when drawing. */
+
+static void
+x_draw_box_rect (struct glyph_string *s,
+ int left_x, int top_y, int right_x, int bottom_y, int hwidth,
+ int vwidth, bool left_p, bool right_p,
+ XRectangle * clip_rect)
+{
+ unsigned long foreground_backup;
+
+ cairo_t *cr = pgtk_begin_cr_clip (s->f);
+
+ foreground_backup = s->xgcv.foreground;
+ s->xgcv.foreground = s->face->box_color;
+
+ x_set_clip_rectangles (s->f, cr, clip_rect, 1);
+
+ /* Top. */
+ pgtk_fill_rectangle (s->f, s->xgcv.foreground,
+ left_x, top_y, right_x - left_x + 1, hwidth);
+
+ /* Left. */
+ if (left_p)
+ pgtk_fill_rectangle (s->f, s->xgcv.foreground,
+ left_x, top_y, vwidth, bottom_y - top_y + 1);
+
+ /* Bottom. */
+ pgtk_fill_rectangle (s->f, s->xgcv.foreground,
+ left_x, bottom_y - hwidth + 1, right_x - left_x + 1,
+ hwidth);
+
+ /* Right. */
+ if (right_p)
+ pgtk_fill_rectangle (s->f, s->xgcv.foreground,
+ right_x - vwidth + 1, top_y, vwidth,
+ bottom_y - top_y + 1);
+
+ s->xgcv.foreground = foreground_backup;
+
+ pgtk_end_cr_clip (s->f);
+}
+
+
+/* Draw a box around glyph string S. */
+
+static void
+x_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;
+ XRectangle 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. */
+ last_glyph = (s->cmp || s->img
+ ? s->first_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)
+ x_draw_box_rect (s, left_x, top_y, right_x, bottom_y, hwidth,
+ vwidth, left_p, right_p, &clip_rect);
+ else
+ {
+ x_setup_relief_colors (s);
+ x_draw_relief_rect (s->f, left_x, top_y, right_x, bottom_y, hwidth,
+ vwidth, raised_p, true, true, left_p, right_p,
+ &clip_rect);
+ }
+}
+
+static void
+x_get_scale_factor (int *scale_x, int *scale_y)
+{
+ *scale_x = *scale_y = 1;
+}
+
+static void
+x_draw_horizontal_wave (struct frame *f, unsigned long color, int x, int y,
+ int width, int height, int wave_length)
+{
+ cairo_t *cr;
+ double dx = wave_length, dy = height - 1;
+ int xoffset, n;
+
+ cr = pgtk_begin_cr_clip (f);
+ pgtk_set_cr_source_with_color (f, color);
+ cairo_rectangle (cr, x, y, width, height);
+ cairo_clip (cr);
+
+ if (x >= 0)
+ {
+ xoffset = x % (wave_length * 2);
+ if (xoffset == 0)
+ xoffset = wave_length * 2;
+ }
+ else
+ xoffset = x % (wave_length * 2) + wave_length * 2;
+ n = (width + xoffset) / wave_length + 1;
+ if (xoffset > wave_length)
+ {
+ xoffset -= wave_length;
+ --n;
+ y += height - 1;
+ dy = -dy;
+ }
+
+ cairo_move_to (cr, x - xoffset + 0.5, y + 0.5);
+ while (--n >= 0)
+ {
+ cairo_rel_line_to (cr, dx, dy);
+ dy = -dy;
+ }
+ cairo_set_line_width (cr, 1);
+ cairo_stroke (cr);
+ pgtk_end_cr_clip (f);
+}
+
+/*
+ Draw a wavy line under S. The wave fills wave_height pixels from y0.
+
+ x0 wave_length = 2
+ --
+ y0 * * * * *
+ |* * * * * * * * *
+ wave_height = 3 | * * * *
+
+*/
+static void
+x_draw_underwave (struct glyph_string *s, unsigned long color)
+{
+ /* Adjust for scale/HiDPI. */
+ int scale_x, scale_y;
+
+ x_get_scale_factor (&scale_x, &scale_y);
+
+ int wave_height = 3 * scale_y, wave_length = 2 * scale_x;
+
+ x_draw_horizontal_wave (s->f, color, s->x, s->ybase - wave_height + 3,
+ s->width, wave_height, wave_length);
+}
+
+/* Draw a relief around the image glyph string S. */
+
+static void
+x_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;
+ XRectangle 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;
+
+ x_setup_relief_colors (s);
+ get_glyph_string_clip_rect (s, &r);
+ x_draw_relief_rect (s->f, x, y, x1, y1, thick, thick, raised_p,
+ top_p, bot_p, left_p, right_p, &r);
+}
+
+/* Draw part of the background of glyph string S. X, Y, W, and H
+ give the rectangle to draw. */
+
+static void
+x_draw_glyph_string_bg_rect (struct glyph_string *s, int x, int y, int w,
+ int h)
+{
+ if (s->stippled_p)
+ {
+ /* Fill background with a stipple pattern. */
+
+ fill_background (s, x, y, w, h);
+ }
+ else
+ x_clear_glyph_string_rect (s, x, y, w, h);
+}
+
+static void
+x_cr_draw_image (struct frame *f, Emacs_GC *gc, cairo_pattern_t *image,
+ int src_x, int src_y, int width, int height,
+ int dest_x, int dest_y, bool overlay_p)
+{
+ cairo_t *cr = pgtk_begin_cr_clip (f);
+
+ if (overlay_p)
+ cairo_rectangle (cr, dest_x, dest_y, width, height);
+ else
+ {
+ pgtk_set_cr_source_with_gc_background (f, gc);
+ cairo_rectangle (cr, dest_x, dest_y, width, height);
+ cairo_fill_preserve (cr);
+ }
+
+ cairo_translate (cr, dest_x - src_x, dest_y - src_y);
+
+ cairo_surface_t *surface;
+ cairo_pattern_get_surface (image, &surface);
+ cairo_format_t format = cairo_image_surface_get_format (surface);
+ if (format != CAIRO_FORMAT_A8 && format != CAIRO_FORMAT_A1)
+ {
+ cairo_set_source (cr, image);
+ cairo_fill (cr);
+ }
+ else
+ {
+ pgtk_set_cr_source_with_gc_foreground (f, gc);
+ cairo_clip (cr);
+ cairo_mask (cr, image);
+ }
+
+ pgtk_end_cr_clip (f);
+}
+
+/* Draw foreground of image glyph string S. */
+
+static void
+x_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->cr_data)
+ {
+ cairo_t *cr = pgtk_begin_cr_clip (s->f);
+ x_set_glyph_string_clipping (s, cr);
+ x_cr_draw_image (s->f, &s->xgcv, s->img->cr_data,
+ s->slice.x, s->slice.y, s->slice.width, s->slice.height,
+ x, y, true);
+ if (!s->img->mask)
+ {
+ /* 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)
+ {
+ int relief = eabs (s->img->relief);
+ pgtk_draw_rectangle (s->f, s->xgcv.foreground, x - relief, y - relief,
+ s->slice.width + relief*2 - 1,
+ s->slice.height + relief*2 - 1);
+ }
+ }
+ pgtk_end_cr_clip (s->f);
+ }
+ else
+ /* Draw a rectangle if image could not be loaded. */
+ pgtk_draw_rectangle (s->f, s->xgcv.foreground, x, y,
+ s->slice.width - 1, s->slice.height - 1);
+}
+
+/* Draw image glyph string S.
+
+ s->y
+ s->x +-------------------------
+ | s->face->box
+ |
+ | +-------------------------
+ | | s->img->margin
+ | |
+ | | +-------------------
+ | | | the image
+
+ */
+
+static void
+x_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)
+ {
+ {
+ int x = s->x;
+ int y = s->y;
+ int width = s->background_width;
+
+ if (s->first_glyph->left_box_line_p
+ && s->slice.x == 0)
+ {
+ x += box_line_hwidth;
+ width -= box_line_hwidth;
+ }
+
+ if (s->slice.y == 0)
+ y += box_line_vwidth;
+
+ x_draw_glyph_string_bg_rect (s, x, y, width, height);
+ }
+
+ s->background_filled_p = true;
+ }
+
+ /* Draw the foreground. */
+ x_draw_image_foreground (s);
+
+ /* If we must draw a relief around the image, do it. */
+ if (s->img->relief
+ || s->hl == DRAW_IMAGE_RAISED
+ || s->hl == DRAW_IMAGE_SUNKEN)
+ x_draw_image_relief (s);
+}
+
+/* Draw stretch glyph string S. */
+
+static void
+x_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. */
+ x_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;
+ XRectangle r;
+ unsigned long color;
+
+ if (!s->row->reversed_p)
+ x += width;
+ else
+ x = s->x;
+ if (s->row->mouse_face_p && cursor_in_mouse_face_p (s->w))
+ {
+ x_set_mouse_face_gc (s);
+ color = s->xgcv.foreground;
+ }
+ else
+ color = s->face->background;
+
+ cairo_t *cr = pgtk_begin_cr_clip (s->f);
+
+ get_glyph_string_clip_rect (s, &r);
+ x_set_clip_rectangles (s->f, cr, &r, 1);
+
+ if (s->face->stipple)
+ {
+ /* Fill background with a stipple pattern. */
+ fill_background (s, x, y, w, h);
+ }
+ else
+ {
+ pgtk_fill_rectangle (s->f, color, x, y, w, h);
+ }
+
+ pgtk_end_cr_clip (s->f);
+ }
+ }
+ else if (!s->background_filled_p)
+ {
+ int background_width = s->background_width;
+ int x = s->x, text_left_x = window_box_left_offset (s->w, TEXT_AREA);
+
+ /* Don't draw into left fringe or scrollbar area except for
+ header line and mode line. */
+ if (x < text_left_x && !s->row->mode_line_p)
+ {
+ int left_x = WINDOW_LEFT_SCROLL_BAR_AREA_WIDTH (s->w);
+ int right_x = text_left_x;
+
+ if (WINDOW_HAS_FRINGES_OUTSIDE_MARGINS (s->w))
+ left_x += WINDOW_LEFT_FRINGE_WIDTH (s->w);
+ else
+ right_x -= WINDOW_LEFT_FRINGE_WIDTH (s->w);
+
+ /* Adjust X and BACKGROUND_WIDTH to fit inside the space
+ between LEFT_X and RIGHT_X. */
+ if (x < left_x)
+ {
+ background_width -= left_x - x;
+ x = left_x;
+ }
+ if (x + background_width > right_x)
+ background_width = right_x - x;
+ }
+ if (background_width > 0)
+ x_draw_glyph_string_bg_rect (s, x, s->y, background_width, s->height);
+ }
+
+ s->background_filled_p = true;
+}
+
+static void
+pgtk_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)
+ {
+ cairo_t *cr = pgtk_begin_cr_clip (next->f);
+ x_set_glyph_string_gc (next);
+ x_set_glyph_string_clipping (next, cr);
+ if (next->first_glyph->type == STRETCH_GLYPH)
+ x_draw_stretch_glyph_string (next);
+ else
+ x_draw_glyph_string_background (next, true);
+ next->num_clips = 0;
+ pgtk_end_cr_clip (next->f);
+ }
+ }
+
+ /* Set up S->gc, set clipping and draw S. */
+ x_set_glyph_string_gc (s);
+
+ cairo_t *cr = pgtk_begin_cr_clip (s->f);
+
+ /* 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))
+
+ {
+ x_set_glyph_string_clipping (s, cr);
+ x_draw_glyph_string_background (s, true);
+ x_draw_glyph_string_box (s);
+ x_set_glyph_string_clipping (s, cr);
+ 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. */
+ x_set_glyph_string_clipping_exactly (s, s, cr);
+ else
+ x_set_glyph_string_clipping (s, cr);
+
+ switch (s->first_glyph->type)
+ {
+ case IMAGE_GLYPH:
+ x_draw_image_glyph_string (s);
+ break;
+
+ case XWIDGET_GLYPH:
+ x_draw_xwidget_glyph_string (s);
+ break;
+
+ case STRETCH_GLYPH:
+ x_draw_stretch_glyph_string (s);
+ break;
+
+ case CHAR_GLYPH:
+ if (s->for_overlaps)
+ s->background_filled_p = true;
+ else
+ x_draw_glyph_string_background (s, false);
+ x_draw_glyph_string_foreground (s);
+ break;
+
+ case COMPOSITE_GLYPH:
+ if (s->for_overlaps || (s->cmp_from > 0
+ && !s->first_glyph->u.cmp.automatic))
+ s->background_filled_p = true;
+ else
+ x_draw_glyph_string_background (s, true);
+ x_draw_composite_glyph_string_foreground (s);
+ break;
+
+ case GLYPHLESS_GLYPH:
+ if (s->for_overlaps)
+ s->background_filled_p = true;
+ else
+ x_draw_glyph_string_background (s, true);
+ x_draw_glyphless_glyph_string_foreground (s);
+ break;
+
+ default:
+ emacs_abort ();
+ }
+
+ if (!s->for_overlaps)
+ {
+ /* Draw relief if not yet drawn. */
+ if (!relief_drawn_p && s->face->box != FACE_NO_BOX)
+ x_draw_glyph_string_box (s);
+
+ /* Draw underline. */
+ if (s->face->underline)
+ {
+ if (s->face->underline == FACE_UNDER_WAVE)
+ {
+ if (s->face->underline_defaulted_p)
+ x_draw_underwave (s, s->xgcv.foreground);
+ else
+ {
+ x_draw_underwave (s, s->face->underline_color);
+ }
+ }
+ else if (s->face->underline == FACE_UNDER_LINE)
+ {
+ unsigned long thickness, position;
+ int y;
+
+ if (s->prev && s->prev->face->underline
+ && s->prev->face->underline == FACE_UNDER_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);
+
+ /* Get the underline thickness. Default is 1 pixel. */
+ if (font && font->underline_thickness > 0)
+ thickness = font->underline_thickness;
+ else
+ thickness = 1;
+ if (x_underline_at_descent_line)
+ position = (s->height - thickness) - (s->ybase - s->y);
+ 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 (x_use_underline_position_properties
+ && font && font->underline_position >= 0)
+ position = font->underline_position;
+ else if (font)
+ position = (font->descent + 1) / 2;
+ else
+ position = underline_minimum_offset;
+ }
+ position = max (position, underline_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)
+ pgtk_fill_rectangle (s->f, s->xgcv.foreground,
+ s->x, y, s->width, thickness);
+ else
+ {
+ pgtk_fill_rectangle (s->f, s->face->underline_color,
+ s->x, y, s->width, thickness);
+ }
+ }
+ }
+ /* Draw overline. */
+ if (s->face->overline_p)
+ {
+ unsigned long dy = 0, h = 1;
+
+ if (s->face->overline_color_defaulted_p)
+ pgtk_fill_rectangle (s->f, s->xgcv.foreground, s->x, s->y + dy,
+ s->width, h);
+ else
+ {
+ pgtk_fill_rectangle (s->f, s->face->overline_color, s->x,
+ s->y + dy, s->width, h);
+ }
+ }
+
+ /* 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)
+ pgtk_fill_rectangle (s->f, s->xgcv.foreground, s->x, glyph_y + dy,
+ s->width, h);
+ else
+ {
+ pgtk_fill_rectangle (s->f, s->face->strike_through_color, s->x,
+ glyph_y + dy, s->width, h);
+ }
+ }
+
+ 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;
+ x_set_glyph_string_gc (prev);
+ cairo_save (cr);
+ x_set_glyph_string_clipping_exactly (s, prev, cr);
+ if (prev->first_glyph->type == CHAR_GLYPH)
+ x_draw_glyph_string_foreground (prev);
+ else
+ x_draw_composite_glyph_string_foreground (prev);
+ prev->hl = save;
+ prev->num_clips = 0;
+ cairo_restore (cr);
+ }
+ }
+
+ 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;
+ x_set_glyph_string_gc (next);
+ cairo_save (cr);
+ x_set_glyph_string_clipping_exactly (s, next, cr);
+ if (next->first_glyph->type == CHAR_GLYPH)
+ x_draw_glyph_string_foreground (next);
+ else
+ x_draw_composite_glyph_string_foreground (next);
+ cairo_restore (cr);
+ next->hl = save;
+ next->num_clips = 0;
+ next->clip_head = s->next;
+ }
+ }
+ }
+
+ /* Reset clipping. */
+ pgtk_end_cr_clip (s->f);
+ s->num_clips = 0;
+}
+
+/* RIF: Define cursor CURSOR on frame F. */
+
+static void
+pgtk_define_frame_cursor (struct frame *f, Emacs_Cursor cursor)
+{
+ if (!f->pointer_invisible && FRAME_X_OUTPUT (f)->current_cursor != cursor)
+ gdk_window_set_cursor (gtk_widget_get_window (FRAME_GTK_WIDGET (f)),
+ cursor);
+ FRAME_X_OUTPUT (f)->current_cursor = cursor;
+}
+
+static void
+pgtk_after_update_window_line (struct window *w,
+ struct glyph_row *desired_row)
+{
+ struct frame *f;
+ int width, height;
+
+ /* begin copy from other terms */
+ eassert (w);
+
+ if (!desired_row->mode_line_p && !w->pseudo_window_p)
+ desired_row->redraw_fringe_bitmaps_p = 1;
+
+ /* When a window has disappeared, make sure that no rest of
+ full-width rows stays visible in the internal border. */
+ if (windows_or_buffers_changed
+ && desired_row->full_width_p
+ && (f = XFRAME (w->frame),
+ width = FRAME_INTERNAL_BORDER_WIDTH (f),
+ width != 0) && (height = desired_row->visible_height, height > 0))
+ {
+ int y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, desired_row->y));
+
+ block_input ();
+ pgtk_clear_frame_area (f, 0, y, width, height);
+ pgtk_clear_frame_area (f,
+ FRAME_PIXEL_WIDTH (f) - width, y, width, height);
+ unblock_input ();
+ }
+}
+
+static void
+pgtk_clear_frame_area (struct frame *f, int x, int y, int width, int height)
+{
+ pgtk_clear_area (f, x, y, width, height);
+}
+
+/* Draw a hollow box cursor on window W in glyph row ROW. */
+
+static void
+x_draw_hollow_cursor (struct window *w, struct glyph_row *row)
+{
+ struct frame *f = XFRAME (WINDOW_FRAME (w));
+ int x, y, wd, h;
+ struct glyph *cursor_glyph;
+
+ /* 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. */
+ cairo_t *cr = pgtk_begin_cr_clip (f);
+ pgtk_set_cr_source_with_color (f, FRAME_X_OUTPUT (f)->cursor_color);
+
+ /* 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. */
+ pgtk_clip_to_row (w, row, TEXT_AREA, cr);
+ pgtk_draw_rectangle (f, FRAME_X_OUTPUT (f)->cursor_color, x, y, wd, h - 1);
+ pgtk_end_cr_clip (f);
+}
+
+/* Draw a bar cursor on window W in glyph row ROW.
+
+ Implementation note: One would like to draw a bar cursor with an
+ angle equal to the one given by the font property XA_ITALIC_ANGLE.
+ Unfortunately, I didn't find a font yet that has this property set.
+ --gerd. */
+
+static void
+x_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;
+
+ /* 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 face *face = FACE_FROM_ID (f, cursor_glyph->face_id);
+ unsigned long color;
+
+ cairo_t *cr = pgtk_begin_cr_clip (f);
+
+ /* 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 == FRAME_X_OUTPUT (f)->cursor_color)
+ color = face->foreground;
+ else
+ color = FRAME_X_OUTPUT (f)->cursor_color;
+
+ pgtk_clip_to_row (w, row, TEXT_AREA, cr);
+
+ 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;
+
+ pgtk_fill_rectangle (f, color, 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);
+
+ 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;
+ pgtk_fill_rectangle (f, color, x,
+ WINDOW_TO_FRAME_PIXEL_Y (w, w->phys_cursor.y +
+ row->height - width),
+ w->phys_cursor_width - 1, width);
+ }
+
+ pgtk_end_cr_clip (f);
+ }
+}
+
+/* RIF: Draw cursor on window W. */
+
+static void
+pgtk_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 = XFRAME (w->frame);
+ 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:
+ x_draw_hollow_cursor (w, glyph_row);
+ break;
+
+ case FILLED_BOX_CURSOR:
+ draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR);
+ break;
+
+ case BAR_CURSOR:
+ x_draw_bar_cursor (w, glyph_row, cursor_width, BAR_CURSOR);
+ break;
+
+ case HBAR_CURSOR:
+ x_draw_bar_cursor (w, glyph_row, cursor_width, HBAR_CURSOR);
+ break;
+
+ case NO_CURSOR:
+ w->phys_cursor_width = 0;
+ break;
+
+ default:
+ emacs_abort ();
+ }
+ }
+
+ if (w == XWINDOW (f->selected_window))
+ {
+ int frame_x =
+ WINDOW_TO_FRAME_PIXEL_X (w, x) + WINDOW_LEFT_FRINGE_WIDTH (w);
+ int frame_y = WINDOW_TO_FRAME_PIXEL_Y (w, y);
+ pgtk_im_set_cursor_location (f, frame_x, frame_y,
+ w->phys_cursor_width,
+ w->phys_cursor_height);
+ }
+ }
+
+}
+
+static void
+pgtk_copy_bits (struct frame *f, cairo_rectangle_t * src_rect,
+ cairo_rectangle_t * dst_rect)
+{
+ cairo_t *cr;
+ cairo_surface_t *surface; /* temporary surface */
+
+ surface =
+ cairo_surface_create_similar (FRAME_CR_SURFACE (f),
+ CAIRO_CONTENT_COLOR_ALPHA,
+ (int) src_rect->width,
+ (int) src_rect->height);
+
+ cr = cairo_create (surface);
+ cairo_set_source_surface (cr, FRAME_CR_SURFACE (f), -src_rect->x,
+ -src_rect->y);
+ cairo_rectangle (cr, 0, 0, src_rect->width, src_rect->height);
+ cairo_clip (cr);
+ cairo_paint (cr);
+ cairo_destroy (cr);
+
+ cr = pgtk_begin_cr_clip (f);
+ cairo_set_source_surface (cr, surface, dst_rect->x, dst_rect->y);
+ cairo_rectangle (cr, dst_rect->x, dst_rect->y, dst_rect->width,
+ dst_rect->height);
+ cairo_clip (cr);
+ cairo_paint (cr);
+ pgtk_end_cr_clip (f);
+
+ cairo_surface_destroy (surface);
+}
+
+/* Scroll part of the display as described by RUN. */
+
+static void
+pgtk_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 x_update_window_end. */
+ gui_clear_cursor (w);
+
+ {
+ cairo_rectangle_t src_rect = { x, from_y, width, height };
+ cairo_rectangle_t dst_rect = { x, to_y, width, height };
+ pgtk_copy_bits (f, &src_rect, &dst_rect);
+ }
+
+ unblock_input ();
+}
+
+/* Icons. */
+
+/* Make the x-window of frame F use the gnu icon bitmap. */
+
+static bool
+pgtk_bitmap_icon (struct frame *f, Lisp_Object file)
+{
+ ptrdiff_t bitmap_id;
+
+ if (FRAME_GTK_WIDGET (f) == 0)
+ return true;
+
+ /* Free up our existing icon bitmap and mask if any. */
+ if (f->output_data.pgtk->icon_bitmap > 0)
+ image_destroy_bitmap (f, f->output_data.pgtk->icon_bitmap);
+ f->output_data.pgtk->icon_bitmap = 0;
+
+ if (STRINGP (file))
+ {
+ /* Use gtk_window_set_icon_from_file () if available,
+ It's not restricted to bitmaps */
+ if (xg_set_icon (f, file))
+ return false;
+ bitmap_id = image_create_bitmap_from_file (f, file);
+ }
+ else
+ {
+ /* Create the GNU bitmap and mask if necessary. */
+ if (FRAME_DISPLAY_INFO (f)->icon_bitmap_id < 0)
+ {
+ ptrdiff_t rc = -1;
+
+ if (xg_set_icon (f, xg_default_icon_file)
+ || xg_set_icon_from_xpm_data (f, gnu_xpm_bits))
+ {
+ FRAME_DISPLAY_INFO (f)->icon_bitmap_id = -2;
+ return false;
+ }
+
+ /* If all else fails, use the (black and white) xbm image. */
+ if (rc == -1)
+ {
+ rc = image_create_bitmap_from_data (f,
+ (char *) gnu_xbm_bits,
+ gnu_xbm_width,
+ gnu_xbm_height);
+ if (rc == -1)
+ return true;
+
+ FRAME_DISPLAY_INFO (f)->icon_bitmap_id = rc;
+ }
+ }
+
+ /* The first time we create the GNU bitmap and mask,
+ this increments the ref-count one extra time.
+ As a result, the GNU bitmap and mask are never freed.
+ That way, we don't have to worry about allocating it again. */
+ image_reference_bitmap (f, FRAME_DISPLAY_INFO (f)->icon_bitmap_id);
+
+ 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;
+
+ return false;
+}
+
+
+/* Make the x-window of frame F use a rectangle with text.
+ Use ICON_NAME as the text. */
+
+bool
+pgtk_text_icon (struct frame *f, const char *icon_name)
+{
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ gtk_window_set_icon (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), NULL);
+ gtk_window_set_title (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), icon_name);
+ }
+
+ return false;
+}
+
+/***********************************************************************
+ Starting and ending an update
+ ***********************************************************************/
+
+/* 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 x_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
+pgtk_update_begin (struct frame *f)
+{
+ pgtk_clear_under_internal_border (f);
+}
+
+/* Draw a vertical window border from (x,y0) to (x,y1) */
+
+static void
+pgtk_draw_vertical_window_border (struct window *w, int x, int y0, int y1)
+{
+ struct frame *f = XFRAME (WINDOW_FRAME (w));
+ struct face *face;
+ cairo_t *cr;
+
+ cr = pgtk_begin_cr_clip (f);
+
+ face = FACE_FROM_ID_OR_NULL (f, VERTICAL_BORDER_FACE_ID);
+ if (face)
+ pgtk_set_cr_source_with_color (f, face->foreground);
+
+ cairo_rectangle (cr, x, y0, 1, y1 - y0);
+ cairo_fill (cr);
+
+ pgtk_end_cr_clip (f);
+}
+
+/* Draw a window divider from (x0,y0) to (x1,y1) */
+
+static void
+pgtk_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));
+ cairo_t *cr = pgtk_begin_cr_clip (f);
+
+ if (y1 - y0 > x1 - x0 && x1 - x0 > 2)
+ /* Vertical. */
+ {
+ pgtk_set_cr_source_with_color (f, color_first);
+ cairo_rectangle (cr, x0, y0, 1, y1 - y0);
+ cairo_fill (cr);
+ pgtk_set_cr_source_with_color (f, color);
+ cairo_rectangle (cr, x0 + 1, y0, x1 - x0 - 2, y1 - y0);
+ cairo_fill (cr);
+ pgtk_set_cr_source_with_color (f, color_last);
+ cairo_rectangle (cr, x1 - 1, y0, 1, y1 - y0);
+ cairo_fill (cr);
+ }
+ else if (x1 - x0 > y1 - y0 && y1 - y0 > 3)
+ /* Horizontal. */
+ {
+ pgtk_set_cr_source_with_color (f, color_first);
+ cairo_rectangle (cr, x0, y0, x1 - x0, 1);
+ cairo_fill (cr);
+ pgtk_set_cr_source_with_color (f, color);
+ cairo_rectangle (cr, x0, y0 + 1, x1 - x0, y1 - y0 - 2);
+ cairo_fill (cr);
+ pgtk_set_cr_source_with_color (f, color_last);
+ cairo_rectangle (cr, x0, y1 - 1, x1 - x0, 1);
+ cairo_fill (cr);
+ }
+ else
+ {
+ pgtk_set_cr_source_with_color (f, color);
+ cairo_rectangle (cr, x0, y0, x1 - x0, y1 - y0);
+ cairo_fill (cr);
+ }
+
+ pgtk_end_cr_clip (f);
+}
+
+/* End update of frame F. This function is installed as a hook in
+ update_end. */
+
+static void
+pgtk_update_end (struct frame *f)
+{
+ /* Mouse highlight may be displayed again. */
+ MOUSE_HL_INFO (f)->mouse_face_defer = false;
+}
+
+static void
+pgtk_frame_up_to_date (struct frame *f)
+{
+ block_input ();
+ FRAME_MOUSE_UPDATE (f);
+ if (!buffer_flipping_blocked_p ())
+ {
+ flip_cr_context (f);
+ gtk_widget_queue_draw (FRAME_GTK_WIDGET (f));
+ }
+ unblock_input ();
+}
+
+/* Return the current position of the mouse.
+ *FP should be a frame which indicates which display to ask about.
+
+ If the mouse movement started in a scroll bar, set *FP, *BAR_WINDOW,
+ and *PART to the frame, window, and scroll bar part that the mouse
+ is over. Set *X and *Y to the portion and whole of the mouse's
+ position on the scroll bar.
+
+ If the mouse movement started elsewhere, set *FP to the frame the
+ mouse is on, *BAR_WINDOW to nil, and *X and *Y to the character cell
+ the mouse is over.
+
+ Set *TIMESTAMP to the server time-stamp for the time at which the mouse
+ was at this position.
+
+ Don't store anything if we don't have a valid set of values to report.
+
+ This clears the mouse_moved flag, so we can wait for the next mouse
+ movement. */
+
+static void
+pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window,
+ enum scroll_bar_part *part, Lisp_Object * x,
+ Lisp_Object * y, Time * timestamp)
+{
+ struct frame *f1;
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (*fp);
+ int win_x, win_y;
+ GdkSeat *seat;
+ GdkDevice *device;
+ GdkModifierType mask;
+ GdkWindow *win;
+
+ block_input ();
+
+ Lisp_Object frame, tail;
+
+ /* Clear the mouse-moved flag for every frame on this display. */
+ FOR_EACH_FRAME (tail, frame)
+ if (FRAME_PGTK_P (XFRAME (frame))
+ && FRAME_X_DISPLAY (XFRAME (frame)) == FRAME_X_DISPLAY (*fp))
+ XFRAME (frame)->mouse_moved = false;
+
+ dpyinfo->last_mouse_scroll_bar = NULL;
+
+ if (gui_mouse_grabbed (dpyinfo))
+ {
+ /* 1.1. use last_mouse_frame as frame where the pointer is on. */
+ f1 = dpyinfo->last_mouse_frame;
+ }
+ else
+ {
+ f1 = *fp;
+ /* 1.2. get frame where the pointer is on. */
+ win = gtk_widget_get_window (FRAME_GTK_WIDGET (*fp));
+ seat = gdk_display_get_default_seat (dpyinfo->gdpy);
+ device = gdk_seat_get_pointer (seat);
+ win =
+ gdk_window_get_device_position (win, device, &win_x, &win_y, &mask);
+ if (win != NULL)
+ f1 = pgtk_any_window_to_frame (win);
+ else
+ {
+ /* crossing display server? */
+ f1 = SELECTED_FRAME ();
+ }
+ }
+
+ /* f1 can be a terminal frame. Bug#50322 */
+ if (f1 == NULL || !FRAME_PGTK_P (f1))
+ {
+ unblock_input ();
+ return;
+ }
+
+ /* 2. get the display and the device. */
+ win = gtk_widget_get_window (FRAME_GTK_WIDGET (f1));
+ GdkDisplay *gdpy = gdk_window_get_display (win);
+ seat = gdk_display_get_default_seat (gdpy);
+ device = gdk_seat_get_pointer (seat);
+
+ /* 3. get x, y relative to edit window of the frame. */
+ win = gdk_window_get_device_position (win, device, &win_x, &win_y, &mask);
+
+ if (f1 != NULL)
+ {
+ dpyinfo = FRAME_DISPLAY_INFO (f1);
+ remember_mouse_glyph (f1, win_x, win_y, &dpyinfo->last_mouse_glyph);
+ dpyinfo->last_mouse_glyph_frame = f1;
+
+ *bar_window = Qnil;
+ *part = 0;
+ *fp = f1;
+ XSETINT (*x, win_x);
+ XSETINT (*y, win_y);
+ *timestamp = dpyinfo->last_mouse_movement_time;
+ }
+
+ unblock_input ();
+}
+
+/* Fringe bitmaps. */
+
+static int max_fringe_bmp = 0;
+static cairo_pattern_t **fringe_bmp = 0;
+
+static void
+pgtk_define_fringe_bitmap (int which, unsigned short *bits, int h, int wd)
+{
+ int i, stride;
+ cairo_surface_t *surface;
+ unsigned char *data;
+ cairo_pattern_t *pattern;
+
+ if (which >= max_fringe_bmp)
+ {
+ i = max_fringe_bmp;
+ max_fringe_bmp = which + 20;
+ fringe_bmp =
+ (cairo_pattern_t **) xrealloc (fringe_bmp,
+ max_fringe_bmp *
+ sizeof (cairo_pattern_t *));
+ while (i < max_fringe_bmp)
+ fringe_bmp[i++] = 0;
+ }
+
+ block_input ();
+
+ surface = cairo_image_surface_create (CAIRO_FORMAT_A1, wd, h);
+ stride = cairo_image_surface_get_stride (surface);
+ data = cairo_image_surface_get_data (surface);
+
+ for (i = 0; i < h; i++)
+ {
+ *((unsigned short *) data) = bits[i];
+ data += stride;
+ }
+
+ cairo_surface_mark_dirty (surface);
+ pattern = cairo_pattern_create_for_surface (surface);
+ cairo_surface_destroy (surface);
+
+ unblock_input ();
+
+ fringe_bmp[which] = pattern;
+}
+
+static void
+pgtk_destroy_fringe_bitmap (int which)
+{
+ if (which >= max_fringe_bmp)
+ return;
+
+ if (fringe_bmp[which])
+ {
+ block_input ();
+ cairo_pattern_destroy (fringe_bmp[which]);
+ unblock_input ();
+ }
+ fringe_bmp[which] = 0;
+}
+
+static void
+pgtk_clip_to_row (struct window *w, struct glyph_row *row,
+ enum glyph_row_area area, cairo_t * cr)
+{
+ int window_x, window_y, window_width;
+ cairo_rectangle_int_t rect;
+
+ window_box (w, area, &window_x, &window_y, &window_width, 0);
+
+ rect.x = window_x;
+ rect.y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, row->y));
+ rect.y = max (rect.y, window_y);
+ rect.width = window_width;
+ rect.height = row->visible_height;
+
+ cairo_rectangle (cr, rect.x, rect.y, rect.width, rect.height);
+ cairo_clip (cr);
+}
+
+static void
+pgtk_cr_draw_image (struct frame *f, Emacs_GC * gc, cairo_pattern_t * image,
+ int src_x, int src_y, int width, int height,
+ int dest_x, int dest_y, bool overlay_p)
+{
+ cairo_t *cr = pgtk_begin_cr_clip (f);
+
+ if (overlay_p)
+ cairo_rectangle (cr, dest_x, dest_y, width, height);
+ else
+ {
+ pgtk_set_cr_source_with_gc_background (f, gc);
+ cairo_rectangle (cr, dest_x, dest_y, width, height);
+ cairo_fill_preserve (cr);
+ }
+ cairo_translate (cr, dest_x - src_x, dest_y - src_y);
+
+ cairo_surface_t *surface;
+ cairo_pattern_get_surface (image, &surface);
+ cairo_format_t format = cairo_image_surface_get_format (surface);
+ if (format != CAIRO_FORMAT_A8 && format != CAIRO_FORMAT_A1)
+ {
+ cairo_set_source (cr, image);
+ cairo_fill (cr);
+ }
+ else
+ {
+ pgtk_set_cr_source_with_gc_foreground (f, gc);
+ cairo_clip (cr);
+ cairo_mask (cr, image);
+ }
+
+ pgtk_end_cr_clip (f);
+}
+
+static void
+pgtk_draw_fringe_bitmap (struct window *w, struct glyph_row *row,
+ struct draw_fringe_bitmap_params *p)
+{
+ struct frame *f = XFRAME (WINDOW_FRAME (w));
+ struct face *face = p->face;
+
+ cairo_t *cr = pgtk_begin_cr_clip (f);
+
+ /* Must clip because of partially visible lines. */
+ pgtk_clip_to_row (w, row, ANY_AREA, cr);
+
+ 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
+ FillSolid in x_draw_glyph_string_background. */
+ if (face->stipple)
+ {
+ fill_background_by_face (f, face, p->bx, p->by, p->nx, p->ny);
+ }
+ else
+ {
+ pgtk_set_cr_source_with_color (f, face->background);
+ cairo_rectangle (cr, p->bx, p->by, p->nx, p->ny);
+ cairo_fill (cr);
+ }
+ }
+
+ if (p->which && p->which < max_fringe_bmp)
+ {
+ Emacs_GC gcv;
+
+ gcv.foreground = (p->cursor_p
+ ? (p->overlay_p ? face->background
+ : FRAME_X_OUTPUT (f)->cursor_color)
+ : face->foreground);
+ gcv.background = face->background;
+ pgtk_cr_draw_image (f, &gcv, fringe_bmp[p->which], 0, p->dh,
+ p->wd, p->h, p->x, p->y, p->overlay_p);
+ }
+
+ pgtk_end_cr_clip (f);
+}
+
+static struct atimer *hourglass_atimer = NULL;
+static int hourglass_enter_count = 0;
+
+static void
+hourglass_cb (struct atimer *timer)
+{
+ /*NOP*/}
+
+static void
+pgtk_show_hourglass (struct frame *f)
+{
+ struct pgtk_output *x = FRAME_X_OUTPUT (f);
+ if (x->hourglass_widget != NULL)
+ gtk_widget_destroy (x->hourglass_widget);
+ x->hourglass_widget = gtk_event_box_new (); /* gtk_event_box is GDK_INPUT_ONLY. */
+ gtk_widget_set_has_window (x->hourglass_widget, true);
+ gtk_fixed_put (GTK_FIXED (FRAME_GTK_WIDGET (f)), x->hourglass_widget, 0, 0);
+ gtk_widget_show (x->hourglass_widget);
+ gtk_widget_set_size_request (x->hourglass_widget, 30000, 30000);
+ gdk_window_raise (gtk_widget_get_window (x->hourglass_widget));
+ gdk_window_set_cursor (gtk_widget_get_window (x->hourglass_widget),
+ x->hourglass_cursor);
+
+ /* For cursor animation, we receive signals, set pending_signals, and dispatch. */
+ if (hourglass_enter_count++ == 0)
+ {
+ struct timespec ts = make_timespec (0, 50 * 1000 * 1000);
+ if (hourglass_atimer != NULL)
+ cancel_atimer (hourglass_atimer);
+ hourglass_atimer =
+ start_atimer (ATIMER_CONTINUOUS, ts, hourglass_cb, NULL);
+ }
+
+ /* Cursor frequently stops animation. gtk's bug? */
+}
+
+static void
+pgtk_hide_hourglass (struct frame *f)
+{
+ struct pgtk_output *x = FRAME_X_OUTPUT (f);
+ if (--hourglass_enter_count == 0)
+ {
+ if (hourglass_atimer != NULL)
+ {
+ cancel_atimer (hourglass_atimer);
+ hourglass_atimer = NULL;
+ }
+ }
+ if (x->hourglass_widget != NULL)
+ {
+ gtk_widget_destroy (x->hourglass_widget);
+ x->hourglass_widget = NULL;
+ }
+}
+
+/* Flushes changes to display. */
+static void
+pgtk_flush_display (struct frame *f)
+{
+}
+
+extern frame_parm_handler pgtk_frame_parm_handlers[];
+
+static struct redisplay_interface pgtk_redisplay_interface = {
+ pgtk_frame_parm_handlers,
+ gui_produce_glyphs,
+ gui_write_glyphs,
+ gui_insert_glyphs,
+ gui_clear_end_of_line,
+ pgtk_scroll_run,
+ pgtk_after_update_window_line,
+ NULL, /* gui_update_window_begin, */
+ NULL, /* gui_update_window_end, */
+ pgtk_flush_display,
+ gui_clear_window_mouse_face,
+ gui_get_glyph_overhangs,
+ gui_fix_overlapping_area,
+ pgtk_draw_fringe_bitmap,
+ pgtk_define_fringe_bitmap,
+ pgtk_destroy_fringe_bitmap,
+ pgtk_compute_glyph_string_overhangs,
+ pgtk_draw_glyph_string,
+ pgtk_define_frame_cursor,
+ pgtk_clear_frame_area,
+ pgtk_clear_under_internal_border,
+ pgtk_draw_window_cursor,
+ pgtk_draw_vertical_window_border,
+ pgtk_draw_window_divider,
+ NULL, /* pgtk_shift_glyphs_for_insert, */
+ pgtk_show_hourglass,
+ pgtk_hide_hourglass,
+ pgtk_default_font_parameter,
+};
+
+static void
+pgtk_redraw_scroll_bars (struct frame *f)
+{
+}
+
+void
+pgtk_clear_frame (struct frame *f)
+/* --------------------------------------------------------------------------
+ External (hook): Erase the entire frame
+ -------------------------------------------------------------------------- */
+{
+ /* comes on initial frame because we have
+ after-make-frame-functions = select-frame */
+ if (!FRAME_DEFAULT_FACE (f))
+ return;
+
+ /* mark_window_cursors_off (XWINDOW (FRAME_ROOT_WINDOW (f))); */
+
+ block_input ();
+
+ pgtk_clear_area (f, 0, 0, FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f));
+
+ /* as of 2006/11 or so this is now needed */
+ pgtk_redraw_scroll_bars (f);
+ unblock_input ();
+}
+
+/* Invert the middle quarter of the frame for .15 sec. */
+
+static void
+recover_from_visible_bell (struct atimer *timer)
+{
+ struct frame *f = timer->client_data;
+
+ if (FRAME_X_OUTPUT (f)->cr_surface_visible_bell != NULL)
+ {
+ cairo_surface_destroy (FRAME_X_OUTPUT (f)->cr_surface_visible_bell);
+ FRAME_X_OUTPUT (f)->cr_surface_visible_bell = NULL;
+ }
+
+ if (FRAME_X_OUTPUT (f)->atimer_visible_bell != NULL)
+ FRAME_X_OUTPUT (f)->atimer_visible_bell = NULL;
+}
+
+static void
+pgtk_flash (struct frame *f)
+{
+ block_input ();
+
+ {
+ cairo_surface_t *surface_orig = FRAME_CR_SURFACE (f);
+
+ int width = FRAME_CR_SURFACE_DESIRED_WIDTH (f);
+ int height = FRAME_CR_SURFACE_DESIRED_HEIGHT (f);
+ cairo_surface_t *surface =
+ cairo_surface_create_similar (surface_orig, CAIRO_CONTENT_COLOR_ALPHA,
+ width, height);
+
+ cairo_t *cr = cairo_create (surface);
+ cairo_set_source_surface (cr, surface_orig, 0, 0);
+ cairo_rectangle (cr, 0, 0, width, height);
+ cairo_clip (cr);
+ cairo_paint (cr);
+
+ cairo_set_source_rgb (cr, 1, 1, 1);
+ cairo_set_operator (cr, CAIRO_OPERATOR_DIFFERENCE);
+
+ {
+ /* Get the height not including a menu bar widget. */
+ int height = FRAME_PIXEL_HEIGHT (f);
+ /* Height of each line to flash. */
+ int flash_height = FRAME_LINE_HEIGHT (f);
+ /* These will be the left and right margins of the rectangles. */
+ int flash_left = FRAME_INTERNAL_BORDER_WIDTH (f);
+ int flash_right =
+ FRAME_PIXEL_WIDTH (f) - FRAME_INTERNAL_BORDER_WIDTH (f);
+ int width = flash_right - flash_left;
+
+ /* If window is tall, flash top and bottom line. */
+ if (height > 3 * FRAME_LINE_HEIGHT (f))
+ {
+ cairo_rectangle (cr,
+ flash_left,
+ (FRAME_INTERNAL_BORDER_WIDTH (f)
+ + FRAME_TOP_MARGIN_HEIGHT (f)),
+ width, flash_height);
+ cairo_fill (cr);
+
+ cairo_rectangle (cr,
+ flash_left,
+ (height - flash_height
+ - FRAME_INTERNAL_BORDER_WIDTH (f)),
+ width, flash_height);
+ cairo_fill (cr);
+ }
+ else
+ {
+ /* If it is short, flash it all. */
+ cairo_rectangle (cr,
+ flash_left, FRAME_INTERNAL_BORDER_WIDTH (f),
+ width, height - 2 * FRAME_INTERNAL_BORDER_WIDTH (f));
+ cairo_fill (cr);
+ }
+
+ FRAME_X_OUTPUT (f)->cr_surface_visible_bell = surface;
+ {
+ struct timespec delay = make_timespec (0, 50 * 1000 * 1000);
+ if (FRAME_X_OUTPUT (f)->atimer_visible_bell != NULL)
+ {
+ cancel_atimer (FRAME_X_OUTPUT (f)->atimer_visible_bell);
+ FRAME_X_OUTPUT (f)->atimer_visible_bell = NULL;
+ }
+ FRAME_X_OUTPUT (f)->atimer_visible_bell =
+ start_atimer (ATIMER_RELATIVE, delay, recover_from_visible_bell, f);
+ }
+
+ }
+
+ cairo_destroy (cr);
+ }
+
+ unblock_input ();
+}
+
+/* Make audible bell. */
+
+static void
+pgtk_ring_bell (struct frame *f)
+{
+ if (visible_bell)
+ {
+ pgtk_flash (f);
+ }
+ else
+ {
+ block_input ();
+ gtk_widget_error_bell (FRAME_GTK_WIDGET (f));
+ unblock_input ();
+ }
+}
+
+/* Read events coming from the X server.
+ Return as soon as there are no more events to be read.
+
+ Return the number of characters stored into the buffer,
+ thus pretending to be `read' (except the characters we store
+ in the keyboard buffer can be multibyte, so are not necessarily
+ C chars). */
+
+static int
+pgtk_read_socket (struct terminal *terminal, struct input_event *hold_quit)
+{
+ GMainContext *context;
+ bool context_acquired = false;
+ int count;
+
+ count = evq_flush (hold_quit);
+ if (count > 0)
+ {
+ return count;
+ }
+
+ context = g_main_context_default ();
+ context_acquired = g_main_context_acquire (context);
+
+ block_input ();
+
+ if (context_acquired)
+ {
+ while (g_main_context_pending (context))
+ {
+ g_main_context_dispatch (context);
+ }
+ }
+
+ unblock_input ();
+
+ if (context_acquired)
+ g_main_context_release (context);
+
+ count = evq_flush (hold_quit);
+ if (count > 0)
+ {
+ return count;
+ }
+
+ return 0;
+}
+
+/* Lisp window being scrolled. Set when starting to interact with
+ a toolkit scroll bar, reset to nil when ending the interaction. */
+
+static Lisp_Object window_being_scrolled;
+
+static void
+pgtk_send_scroll_bar_event (Lisp_Object window, enum scroll_bar_part part,
+ int portion, int whole, bool horizontal)
+{
+ union buffered_input_event inev;
+
+ EVENT_INIT (inev.ie);
+
+ inev.ie.kind =
+ horizontal ? HORIZONTAL_SCROLL_BAR_CLICK_EVENT : SCROLL_BAR_CLICK_EVENT;
+ inev.ie.frame_or_window = window;
+ inev.ie.arg = Qnil;
+ inev.ie.timestamp = 0;
+ inev.ie.code = 0;
+ inev.ie.part = part;
+ inev.ie.x = make_fixnum (portion);
+ inev.ie.y = make_fixnum (whole);
+ inev.ie.modifiers = 0;
+
+ evq_enqueue (&inev);
+}
+
+
+/* Scroll bar callback for GTK scroll bars. WIDGET is the scroll
+ bar widget. DATA is a pointer to the scroll_bar structure. */
+
+static gboolean
+xg_scroll_callback (GtkRange * range,
+ GtkScrollType scroll, gdouble value, gpointer user_data)
+{
+ int whole = 0, portion = 0;
+ struct scroll_bar *bar = user_data;
+ enum scroll_bar_part part = scroll_bar_nowhere;
+ GtkAdjustment *adj = GTK_ADJUSTMENT (gtk_range_get_adjustment (range));
+
+ if (xg_ignore_gtk_scrollbar)
+ return false;
+
+ switch (scroll)
+ {
+ case GTK_SCROLL_JUMP:
+#if 0
+ /* Buttons 1 2 or 3 must be grabbed. */
+ if (FRAME_DISPLAY_INFO (f)->grabbed != 0
+ && FRAME_DISPLAY_INFO (f)->grabbed < (1 << 4))
+#endif
+ {
+ if (bar->horizontal)
+ {
+ part = scroll_bar_horizontal_handle;
+ whole = (int) (gtk_adjustment_get_upper (adj) -
+ gtk_adjustment_get_page_size (adj));
+ portion = min ((int) value, whole);
+ bar->dragging = portion;
+ }
+ else
+ {
+ part = scroll_bar_handle;
+ whole = gtk_adjustment_get_upper (adj) -
+ gtk_adjustment_get_page_size (adj);
+ portion = min ((int) value, whole);
+ bar->dragging = portion;
+ }
+ }
+ break;
+ case GTK_SCROLL_STEP_BACKWARD:
+ part = (bar->horizontal ? scroll_bar_left_arrow : scroll_bar_up_arrow);
+ bar->dragging = -1;
+ break;
+ case GTK_SCROLL_STEP_FORWARD:
+ part = (bar->horizontal
+ ? scroll_bar_right_arrow : scroll_bar_down_arrow);
+ bar->dragging = -1;
+ break;
+ case GTK_SCROLL_PAGE_BACKWARD:
+ part = (bar->horizontal
+ ? scroll_bar_before_handle : scroll_bar_above_handle);
+ bar->dragging = -1;
+ break;
+ case GTK_SCROLL_PAGE_FORWARD:
+ part = (bar->horizontal
+ ? scroll_bar_after_handle : scroll_bar_below_handle);
+ bar->dragging = -1;
+ break;
+ default:
+ break;
+ }
+
+ if (part != scroll_bar_nowhere)
+ {
+ window_being_scrolled = bar->window;
+ pgtk_send_scroll_bar_event (bar->window, part, portion, whole,
+ bar->horizontal);
+ }
+
+ return false;
+}
+
+/* Callback for button release. Sets dragging to -1 when dragging is done. */
+
+static gboolean
+xg_end_scroll_callback (GtkWidget * widget,
+ GdkEventButton * event, gpointer user_data)
+{
+ struct scroll_bar *bar = user_data;
+ bar->dragging = -1;
+ if (WINDOWP (window_being_scrolled))
+ {
+ pgtk_send_scroll_bar_event (window_being_scrolled,
+ scroll_bar_end_scroll, 0, 0,
+ bar->horizontal);
+ window_being_scrolled = Qnil;
+ }
+
+ return false;
+}
+
+#define SCROLL_BAR_NAME "verticalScrollBar"
+#define SCROLL_BAR_HORIZONTAL_NAME "horizontalScrollBar"
+
+/* Create the widget for scroll bar BAR on frame F. Record the widget
+ and X window of the scroll bar in BAR. */
+
+static void
+x_create_toolkit_scroll_bar (struct frame *f, struct scroll_bar *bar)
+{
+ const char *scroll_bar_name = SCROLL_BAR_NAME;
+
+ block_input ();
+ xg_create_scroll_bar (f, bar, G_CALLBACK (xg_scroll_callback),
+ G_CALLBACK (xg_end_scroll_callback), scroll_bar_name);
+ unblock_input ();
+}
+
+static void
+x_create_horizontal_toolkit_scroll_bar (struct frame *f,
+ struct scroll_bar *bar)
+{
+ const char *scroll_bar_name = SCROLL_BAR_HORIZONTAL_NAME;
+
+ block_input ();
+ xg_create_horizontal_scroll_bar (f, bar, G_CALLBACK (xg_scroll_callback),
+ G_CALLBACK (xg_end_scroll_callback),
+ scroll_bar_name);
+ unblock_input ();
+}
+
+/* Set the thumb size and position of scroll bar BAR. We are currently
+ displaying PORTION out of a whole WHOLE, and our position POSITION. */
+
+static void
+x_set_toolkit_scroll_bar_thumb (struct scroll_bar *bar, int portion,
+ int position, int whole)
+{
+ xg_set_toolkit_scroll_bar_thumb (bar, portion, position, whole);
+}
+
+static void
+x_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar,
+ int portion, int position,
+ int whole)
+{
+ xg_set_toolkit_horizontal_scroll_bar_thumb (bar, portion, position, whole);
+}
+
+
+
+/* Create a scroll bar and return the scroll bar vector for it. W is
+ the Emacs window on which to create the scroll bar. TOP, LEFT,
+ WIDTH and HEIGHT are the pixel coordinates and dimensions of the
+ scroll bar. */
+
+static struct scroll_bar *
+x_scroll_bar_create (struct window *w, int top, int left,
+ int width, int height, bool horizontal)
+{
+ struct frame *f = XFRAME (w->frame);
+ struct scroll_bar *bar
+ = ALLOCATE_PSEUDOVECTOR (struct scroll_bar, prev, PVEC_OTHER);
+ Lisp_Object barobj;
+
+ block_input ();
+
+ if (horizontal)
+ x_create_horizontal_toolkit_scroll_bar (f, bar);
+ else
+ x_create_toolkit_scroll_bar (f, bar);
+
+ XSETWINDOW (bar->window, w);
+ bar->top = top;
+ bar->left = left;
+ bar->width = width;
+ bar->height = height;
+ bar->start = 0;
+ bar->end = 0;
+ bar->dragging = -1;
+ bar->horizontal = horizontal;
+
+ /* Add bar to its frame's list of scroll bars. */
+ bar->next = FRAME_SCROLL_BARS (f);
+ bar->prev = Qnil;
+ XSETVECTOR (barobj, bar);
+ fset_scroll_bars (f, barobj);
+ if (!NILP (bar->next))
+ XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar);
+
+ /* Map the window/widget. */
+ {
+ if (horizontal)
+ xg_update_horizontal_scrollbar_pos (f, bar->x_window, top,
+ left, width, max (height, 1));
+ else
+ xg_update_scrollbar_pos (f, bar->x_window, top,
+ left, width, max (height, 1));
+ }
+
+ unblock_input ();
+ return bar;
+}
+
+/* Destroy scroll bar BAR, and set its Emacs window's scroll bar to
+ nil. */
+
+static void
+x_scroll_bar_remove (struct scroll_bar *bar)
+{
+ struct frame *f = XFRAME (WINDOW_FRAME (XWINDOW (bar->window)));
+ block_input ();
+
+ xg_remove_scroll_bar (f, bar->x_window);
+
+ /* Dissociate this scroll bar from its window. */
+ if (bar->horizontal)
+ wset_horizontal_scroll_bar (XWINDOW (bar->window), Qnil);
+ else
+ wset_vertical_scroll_bar (XWINDOW (bar->window), Qnil);
+
+ unblock_input ();
+}
+
+/* Set the handle of the vertical scroll bar for WINDOW to indicate
+ that we are displaying PORTION characters out of a total of WHOLE
+ characters, starting at POSITION. If WINDOW has no scroll bar,
+ create one. */
+
+static void
+pgtk_set_vertical_scroll_bar (struct window *w, int portion, int whole,
+ int position)
+{
+ struct frame *f = XFRAME (w->frame);
+ Lisp_Object barobj;
+ struct scroll_bar *bar;
+ int top, height, left, width;
+ int window_y, window_height;
+
+ /* Get window dimensions. */
+ window_box (w, ANY_AREA, 0, &window_y, 0, &window_height);
+ top = window_y;
+ height = window_height;
+ left = WINDOW_SCROLL_BAR_AREA_X (w);
+ width = WINDOW_SCROLL_BAR_AREA_WIDTH (w);
+
+ /* Does the scroll bar exist yet? */
+ if (NILP (w->vertical_scroll_bar))
+ {
+ if (width > 0 && height > 0)
+ {
+ block_input ();
+ pgtk_clear_area (f, left, top, width, height);
+ unblock_input ();
+ }
+
+ bar = x_scroll_bar_create (w, top, left, width, max (height, 1), false);
+ }
+ else
+ {
+ /* It may just need to be moved and resized. */
+ unsigned int mask = 0;
+
+ bar = XSCROLL_BAR (w->vertical_scroll_bar);
+
+ block_input ();
+
+ if (left != bar->left)
+ mask |= 1;
+ if (top != bar->top)
+ mask |= 1;
+ if (width != bar->width)
+ mask |= 1;
+ if (height != bar->height)
+ mask |= 1;
+
+ /* Move/size the scroll bar widget. */
+ if (mask)
+ {
+ /* Since toolkit scroll bars are smaller than the space reserved
+ for them on the frame, we have to clear "under" them. */
+ if (width > 0 && height > 0)
+ pgtk_clear_area (f, left, top, width, height);
+ xg_update_scrollbar_pos (f, bar->x_window, top,
+ left, width, max (height, 1));
+ }
+
+ /* Remember new settings. */
+ bar->left = left;
+ bar->top = top;
+ bar->width = width;
+ bar->height = height;
+
+ unblock_input ();
+ }
+
+ x_set_toolkit_scroll_bar_thumb (bar, portion, position, whole);
+
+ XSETVECTOR (barobj, bar);
+ wset_vertical_scroll_bar (w, barobj);
+}
+
+
+static void
+pgtk_set_horizontal_scroll_bar (struct window *w, int portion, int whole,
+ int position)
+{
+ struct frame *f = XFRAME (w->frame);
+ Lisp_Object barobj;
+ struct scroll_bar *bar;
+ int top, height, left, width;
+ int window_x, window_width;
+ int pixel_width = WINDOW_PIXEL_WIDTH (w);
+
+ /* Get window dimensions. */
+ window_box (w, ANY_AREA, &window_x, 0, &window_width, 0);
+ left = window_x;
+ width = window_width;
+ top = WINDOW_SCROLL_BAR_AREA_Y (w);
+ height = WINDOW_SCROLL_BAR_AREA_HEIGHT (w);
+
+ /* Does the scroll bar exist yet? */
+ if (NILP (w->horizontal_scroll_bar))
+ {
+ if (width > 0 && height > 0)
+ {
+ block_input ();
+
+ /* Clear also part between window_width and
+ WINDOW_PIXEL_WIDTH. */
+ pgtk_clear_area (f, left, top, pixel_width, height);
+ unblock_input ();
+ }
+
+ bar = x_scroll_bar_create (w, top, left, width, height, true);
+ }
+ else
+ {
+ /* It may just need to be moved and resized. */
+ unsigned int mask = 0;
+
+ bar = XSCROLL_BAR (w->horizontal_scroll_bar);
+
+ block_input ();
+
+ if (left != bar->left)
+ mask |= 1;
+ if (top != bar->top)
+ mask |= 1;
+ if (width != bar->width)
+ mask |= 1;
+ if (height != bar->height)
+ mask |= 1;
+
+ /* Move/size the scroll bar widget. */
+ if (mask)
+ {
+ /* Since toolkit scroll bars are smaller than the space reserved
+ for them on the frame, we have to clear "under" them. */
+ if (width > 0 && height > 0)
+ pgtk_clear_area (f,
+ WINDOW_LEFT_EDGE_X (w), top,
+ pixel_width - WINDOW_RIGHT_DIVIDER_WIDTH (w),
+ height);
+ xg_update_horizontal_scrollbar_pos (f, bar->x_window, top, left,
+ width, height);
+ }
+
+ /* Remember new settings. */
+ bar->left = left;
+ bar->top = top;
+ bar->width = width;
+ bar->height = height;
+
+ unblock_input ();
+ }
+
+ x_set_toolkit_horizontal_scroll_bar_thumb (bar, portion, position, whole);
+
+ XSETVECTOR (barobj, bar);
+ wset_horizontal_scroll_bar (w, barobj);
+}
+
+/* The following three hooks are used when we're doing a thorough
+ redisplay of the frame. We don't explicitly know which scroll bars
+ are going to be deleted, because keeping track of when windows go
+ away is a real pain - "Can you say set-window-configuration, boys
+ and girls?" Instead, we just assert at the beginning of redisplay
+ that *all* scroll bars are to be removed, and then save a scroll bar
+ from the fiery pit when we actually redisplay its window. */
+
+/* Arrange for all scroll bars on FRAME to be removed at the next call
+ to `*judge_scroll_bars_hook'. A scroll bar may be spared if
+ `*redeem_scroll_bar_hook' is applied to its window before the judgment. */
+
+static void
+pgtk_condemn_scroll_bars (struct frame *frame)
+{
+ if (!NILP (FRAME_SCROLL_BARS (frame)))
+ {
+ if (!NILP (FRAME_CONDEMNED_SCROLL_BARS (frame)))
+ {
+ /* Prepend scrollbars to already condemned ones. */
+ Lisp_Object last = FRAME_SCROLL_BARS (frame);
+
+ while (!NILP (XSCROLL_BAR (last)->next))
+ last = XSCROLL_BAR (last)->next;
+
+ XSCROLL_BAR (last)->next = FRAME_CONDEMNED_SCROLL_BARS (frame);
+ XSCROLL_BAR (FRAME_CONDEMNED_SCROLL_BARS (frame))->prev = last;
+ }
+
+ fset_condemned_scroll_bars (frame, FRAME_SCROLL_BARS (frame));
+ fset_scroll_bars (frame, Qnil);
+ }
+}
+
+
+/* Un-mark WINDOW's scroll bar for deletion in this judgment cycle.
+ Note that WINDOW isn't necessarily condemned at all. */
+
+static void
+pgtk_redeem_scroll_bar (struct window *w)
+{
+ struct scroll_bar *bar;
+ Lisp_Object barobj;
+ struct frame *f;
+
+ /* We can't redeem this window's scroll bar if it doesn't have one. */
+ if (NILP (w->vertical_scroll_bar) && NILP (w->horizontal_scroll_bar))
+ emacs_abort ();
+
+ if (!NILP (w->vertical_scroll_bar) && WINDOW_HAS_VERTICAL_SCROLL_BAR (w))
+ {
+ bar = XSCROLL_BAR (w->vertical_scroll_bar);
+ /* Unlink it from the condemned list. */
+ f = XFRAME (WINDOW_FRAME (w));
+ if (NILP (bar->prev))
+ {
+ /* If the prev pointer is nil, it must be the first in one of
+ the lists. */
+ if (EQ (FRAME_SCROLL_BARS (f), w->vertical_scroll_bar))
+ /* It's not condemned. Everything's fine. */
+ goto horizontal;
+ else if (EQ (FRAME_CONDEMNED_SCROLL_BARS (f),
+ w->vertical_scroll_bar))
+ fset_condemned_scroll_bars (f, bar->next);
+ else
+ /* If its prev pointer is nil, it must be at the front of
+ one or the other! */
+ emacs_abort ();
+ }
+ else
+ XSCROLL_BAR (bar->prev)->next = bar->next;
+
+ if (!NILP (bar->next))
+ XSCROLL_BAR (bar->next)->prev = bar->prev;
+
+ bar->next = FRAME_SCROLL_BARS (f);
+ bar->prev = Qnil;
+ XSETVECTOR (barobj, bar);
+ fset_scroll_bars (f, barobj);
+ if (!NILP (bar->next))
+ XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar);
+ }
+
+horizontal:
+ if (!NILP (w->horizontal_scroll_bar)
+ && WINDOW_HAS_HORIZONTAL_SCROLL_BAR (w))
+ {
+ bar = XSCROLL_BAR (w->horizontal_scroll_bar);
+ /* Unlink it from the condemned list. */
+ f = XFRAME (WINDOW_FRAME (w));
+ if (NILP (bar->prev))
+ {
+ /* If the prev pointer is nil, it must be the first in one of
+ the lists. */
+ if (EQ (FRAME_SCROLL_BARS (f), w->horizontal_scroll_bar))
+ /* It's not condemned. Everything's fine. */
+ return;
+ else if (EQ (FRAME_CONDEMNED_SCROLL_BARS (f),
+ w->horizontal_scroll_bar))
+ fset_condemned_scroll_bars (f, bar->next);
+ else
+ /* If its prev pointer is nil, it must be at the front of
+ one or the other! */
+ emacs_abort ();
+ }
+ else
+ XSCROLL_BAR (bar->prev)->next = bar->next;
+
+ if (!NILP (bar->next))
+ XSCROLL_BAR (bar->next)->prev = bar->prev;
+
+ bar->next = FRAME_SCROLL_BARS (f);
+ bar->prev = Qnil;
+ XSETVECTOR (barobj, bar);
+ fset_scroll_bars (f, barobj);
+ if (!NILP (bar->next))
+ XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar);
+ }
+}
+
+/* Remove all scroll bars on FRAME that haven't been saved since the
+ last call to `*condemn_scroll_bars_hook'. */
+
+static void
+pgtk_judge_scroll_bars (struct frame *f)
+{
+ Lisp_Object bar, next;
+
+ bar = FRAME_CONDEMNED_SCROLL_BARS (f);
+
+ /* Clear out the condemned list now so we won't try to process any
+ more events on the hapless scroll bars. */
+ fset_condemned_scroll_bars (f, Qnil);
+
+ for (; !NILP (bar); bar = next)
+ {
+ struct scroll_bar *b = XSCROLL_BAR (bar);
+
+ x_scroll_bar_remove (b);
+
+ next = b->next;
+ b->next = b->prev = Qnil;
+ }
+
+ /* Now there should be no references to the condemned scroll bars,
+ and they should get garbage-collected. */
+}
+
+static void
+set_fullscreen_state (struct frame *f)
+{
+ if (!FRAME_GTK_OUTER_WIDGET (f))
+ return;
+
+ GtkWindow *widget = GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f));
+ switch (f->want_fullscreen)
+ {
+ case FULLSCREEN_NONE:
+ gtk_window_unfullscreen (widget);
+ gtk_window_unmaximize (widget);
+ store_frame_param (f, Qfullscreen, Qnil);
+ break;
+
+ case FULLSCREEN_BOTH:
+ gtk_window_unmaximize (widget);
+ gtk_window_fullscreen (widget);
+ store_frame_param (f, Qfullscreen, Qfullboth);
+ break;
+
+ case FULLSCREEN_MAXIMIZED:
+ gtk_window_unfullscreen (widget);
+ gtk_window_maximize (widget);
+ store_frame_param (f, Qfullscreen, Qmaximized);
+ break;
+
+ case FULLSCREEN_WIDTH:
+ case FULLSCREEN_HEIGHT:
+ /* Not supported by gtk. Ignore them. */
+ break;
+ }
+
+ f->want_fullscreen = FULLSCREEN_NONE;
+}
+
+static void
+pgtk_fullscreen_hook (struct frame *f)
+{
+ if (FRAME_VISIBLE_P (f))
+ {
+ block_input ();
+ set_fullscreen_state (f);
+ unblock_input ();
+ }
+}
+
+/* This function is called when the last frame on a display is deleted. */
+void
+pgtk_delete_terminal (struct terminal *terminal)
+{
+ struct pgtk_display_info *dpyinfo = terminal->display_info.pgtk;
+
+ /* Protect against recursive calls. delete_frame in
+ delete_terminal calls us back when it deletes our last frame. */
+ if (!terminal->name)
+ return;
+
+ block_input ();
+
+ pgtk_im_finish (dpyinfo);
+
+ /* Normally, the display is available... */
+ if (dpyinfo->gdpy)
+ {
+ image_destroy_all_bitmaps (dpyinfo);
+
+ g_clear_object (&dpyinfo->xg_cursor);
+ g_clear_object (&dpyinfo->vertical_scroll_bar_cursor);
+ g_clear_object (&dpyinfo->horizontal_scroll_bar_cursor);
+ g_clear_object (&dpyinfo->invisible_cursor);
+ if (dpyinfo->last_click_event != NULL) {
+ gdk_event_free (dpyinfo->last_click_event);
+ dpyinfo->last_click_event = NULL;
+ }
+
+ xg_display_close (dpyinfo->gdpy);
+
+ /* Do not close the connection here because it's already closed
+ by X(t)CloseDisplay (Bug#18403). */
+ dpyinfo->gdpy = NULL;
+ }
+
+ if (dpyinfo->connection >= 0)
+ emacs_close (dpyinfo->connection);
+
+ dpyinfo->connection = -1;
+
+ delete_keyboard_wait_descriptor (0);
+
+ pgtk_delete_display (dpyinfo);
+ unblock_input ();
+}
+
+/* Store F's background color into *BGCOLOR. */
+static void
+pgtk_query_frame_background_color (struct frame *f, Emacs_Color * bgcolor)
+{
+ bgcolor->pixel = FRAME_BACKGROUND_PIXEL (f);
+ pgtk_query_color (f, bgcolor);
+}
+
+static void
+pgtk_free_pixmap (struct frame *_f, Emacs_Pixmap pixmap)
+{
+ if (pixmap)
+ {
+ xfree (pixmap->data);
+ xfree (pixmap);
+ }
+}
+
+void
+pgtk_focus_frame (struct frame *f, bool noactivate)
+{
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+
+ GtkWidget *wid = FRAME_WIDGET (f);
+
+ if (dpyinfo->x_focus_frame != f && wid != NULL)
+ {
+ block_input ();
+ gtk_widget_grab_focus (wid);
+ unblock_input ();
+ }
+}
+
+
+static void
+set_opacity_recursively (GtkWidget * w, gpointer data)
+{
+ gtk_widget_set_opacity (w, *(double *) data);
+ if (GTK_IS_CONTAINER (w))
+ gtk_container_foreach (GTK_CONTAINER (w), set_opacity_recursively, data);
+}
+
+static void
+x_set_frame_alpha (struct frame *f)
+{
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+ double alpha = 1.0;
+ double alpha_min = 1.0;
+
+ if (dpyinfo->highlight_frame == f)
+ alpha = f->alpha[0];
+ else
+ alpha = f->alpha[1];
+
+ if (alpha < 0.0)
+ return;
+
+ if (FLOATP (Vframe_alpha_lower_limit))
+ alpha_min = XFLOAT_DATA (Vframe_alpha_lower_limit);
+ else if (FIXNUMP (Vframe_alpha_lower_limit))
+ alpha_min = (XFIXNUM (Vframe_alpha_lower_limit)) / 100.0;
+
+ if (alpha > 1.0)
+ alpha = 1.0;
+ else if (alpha < alpha_min && alpha_min <= 1.0)
+ alpha = alpha_min;
+
+#if 0
+ /* If there is a parent from the window manager, put the property there
+ also, to work around broken window managers that fail to do that.
+ Do this unconditionally as this function is called on reparent when
+ alpha has not changed on the frame. */
+
+ if (!FRAME_PARENT_FRAME (f))
+ {
+ Window parent = x_find_topmost_parent (f);
+ if (parent != None)
+ XChangeProperty (dpy, parent, dpyinfo->Xatom_net_wm_window_opacity,
+ XA_CARDINAL, 32, PropModeReplace,
+ (unsigned char *) &opac, 1);
+ }
+#endif
+
+ set_opacity_recursively (FRAME_WIDGET (f), &alpha);
+ /* without this, blending mode is strange on wayland. */
+ gtk_widget_queue_resize_no_redraw (FRAME_WIDGET (f));
+}
+
+static void
+frame_highlight (struct frame *f)
+{
+ /* We used to only do this if Vx_no_window_manager was non-nil, but
+ the ICCCM (section 4.1.6) says that the window's border pixmap
+ and border pixel are window attributes which are "private to the
+ client", so we can always change it to whatever we want. */
+ block_input ();
+ /* I recently started to get errors in this XSetWindowBorder, depending on
+ the window-manager in use, tho something more is at play since I've been
+ using that same window-manager binary for ever. Let's not crash just
+ because of this (bug#9310). */
+
+ GtkWidget *w = FRAME_WIDGET (f);
+
+ char *css =
+ g_strdup_printf ("decoration { border: solid %dpx #%06x; }",
+ f->border_width,
+ (unsigned int) FRAME_X_OUTPUT (f)->border_pixel & 0x00ffffff);
+
+ GtkStyleContext *ctxt = gtk_widget_get_style_context (w);
+ GtkCssProvider *css_provider = gtk_css_provider_new ();
+ gtk_css_provider_load_from_data (css_provider, css, -1, NULL);
+ gtk_style_context_add_provider (ctxt, GTK_STYLE_PROVIDER (css_provider),
+ GTK_STYLE_PROVIDER_PRIORITY_USER);
+ g_free (css);
+
+ GtkCssProvider *old = FRAME_X_OUTPUT (f)->border_color_css_provider;
+ FRAME_X_OUTPUT (f)->border_color_css_provider = css_provider;
+ if (old != NULL)
+ {
+ gtk_style_context_remove_provider (ctxt, GTK_STYLE_PROVIDER (old));
+ g_object_unref (old);
+ }
+
+ unblock_input ();
+ gui_update_cursor (f, true);
+ x_set_frame_alpha (f);
+}
+
+static void
+frame_unhighlight (struct frame *f)
+{
+ /* We used to only do this if Vx_no_window_manager was non-nil, but
+ the ICCCM (section 4.1.6) says that the window's border pixmap
+ and border pixel are window attributes which are "private to the
+ client", so we can always change it to whatever we want. */
+ block_input ();
+ /* Same as above for XSetWindowBorder (bug#9310). */
+
+ GtkWidget *w = FRAME_WIDGET (f);
+
+ char *css =
+ g_strdup_printf ("decoration { border: dotted %dpx #ffffff; }",
+ f->border_width);
+
+ GtkStyleContext *ctxt = gtk_widget_get_style_context (w);
+ GtkCssProvider *css_provider = gtk_css_provider_new ();
+ gtk_css_provider_load_from_data (css_provider, css, -1, NULL);
+ gtk_style_context_add_provider (ctxt, GTK_STYLE_PROVIDER (css_provider),
+ GTK_STYLE_PROVIDER_PRIORITY_USER);
+ g_free (css);
+
+ GtkCssProvider *old = FRAME_X_OUTPUT (f)->border_color_css_provider;
+ FRAME_X_OUTPUT (f)->border_color_css_provider = css_provider;
+ if (old != NULL)
+ {
+ gtk_style_context_remove_provider (ctxt, GTK_STYLE_PROVIDER (old));
+ g_object_unref (old);
+ }
+
+ unblock_input ();
+ gui_update_cursor (f, true);
+ x_set_frame_alpha (f);
+}
+
+
+void
+pgtk_frame_rehighlight (struct pgtk_display_info *dpyinfo)
+{
+ struct frame *old_highlight = dpyinfo->highlight_frame;
+
+ if (dpyinfo->x_focus_frame)
+ {
+ dpyinfo->highlight_frame
+ = ((FRAMEP (FRAME_FOCUS_FRAME (dpyinfo->x_focus_frame)))
+ ? XFRAME (FRAME_FOCUS_FRAME (dpyinfo->x_focus_frame))
+ : dpyinfo->x_focus_frame);
+ if (!FRAME_LIVE_P (dpyinfo->highlight_frame))
+ {
+ fset_focus_frame (dpyinfo->x_focus_frame, Qnil);
+ dpyinfo->highlight_frame = dpyinfo->x_focus_frame;
+ }
+ }
+ else
+ dpyinfo->highlight_frame = 0;
+
+ if (old_highlight)
+ frame_unhighlight (old_highlight);
+ if (dpyinfo->highlight_frame)
+ frame_highlight (dpyinfo->highlight_frame);
+}
+
+/* The focus has changed, or we have redirected a frame's focus to
+ another frame (this happens when a frame uses a surrogate
+ mini-buffer frame). Shift the highlight as appropriate.
+
+ The FRAME argument doesn't necessarily have anything to do with which
+ frame is being highlighted or un-highlighted; we only use it to find
+ the appropriate X display info. */
+
+static void
+XTframe_rehighlight (struct frame *frame)
+{
+ pgtk_frame_rehighlight (FRAME_DISPLAY_INFO (frame));
+}
+
+
+/* Toggle mouse pointer visibility on frame F by using invisible cursor. */
+
+static void
+x_toggle_visible_pointer (struct frame *f, bool invisible)
+{
+ Emacs_Cursor cursor;
+ if (invisible)
+ cursor = FRAME_DISPLAY_INFO (f)->invisible_cursor;
+ else
+ cursor = f->output_data.pgtk->current_cursor;
+ gdk_window_set_cursor (gtk_widget_get_window (FRAME_GTK_WIDGET (f)),
+ cursor);
+ f->pointer_invisible = invisible;
+}
+
+static void
+x_setup_pointer_blanking (struct pgtk_display_info *dpyinfo)
+{
+ dpyinfo->toggle_visible_pointer = x_toggle_visible_pointer;
+ dpyinfo->invisible_cursor =
+ gdk_cursor_new_for_display (dpyinfo->gdpy, GDK_BLANK_CURSOR);
+}
+
+static void
+XTtoggle_invisible_pointer (struct frame *f, bool invisible)
+{
+ block_input ();
+ FRAME_DISPLAY_INFO (f)->toggle_visible_pointer (f, invisible);
+ unblock_input ();
+}
+
+/* The focus has changed. Update the frames as necessary to reflect
+ the new situation. Note that we can't change the selected frame
+ here, because the Lisp code we are interrupting might become confused.
+ Each event gets marked with the frame in which it occurred, so the
+ Lisp code can tell when the switch took place by examining the events. */
+
+static void
+x_new_focus_frame (struct pgtk_display_info *dpyinfo, struct frame *frame)
+{
+ struct frame *old_focus = dpyinfo->x_focus_frame;
+ /* doesn't work on wayland */
+
+ if (frame != dpyinfo->x_focus_frame)
+ {
+ /* Set this before calling other routines, so that they see
+ the correct value of x_focus_frame. */
+ dpyinfo->x_focus_frame = frame;
+
+ if (old_focus && old_focus->auto_lower)
+ if (FRAME_GTK_OUTER_WIDGET (old_focus))
+ gdk_window_lower (gtk_widget_get_window
+ (FRAME_GTK_OUTER_WIDGET (old_focus)));
+
+ if (dpyinfo->x_focus_frame && dpyinfo->x_focus_frame->auto_raise)
+ if (FRAME_GTK_OUTER_WIDGET (dpyinfo->x_focus_frame))
+ gdk_window_raise (gtk_widget_get_window
+ (FRAME_GTK_OUTER_WIDGET (dpyinfo->x_focus_frame)));
+ }
+
+ pgtk_frame_rehighlight (dpyinfo);
+}
+
+static void
+pgtk_buffer_flipping_unblocked_hook (struct frame *f)
+{
+ block_input ();
+ flip_cr_context (f);
+ gtk_widget_queue_draw (FRAME_GTK_WIDGET (f));
+ unblock_input ();
+}
+
+static struct terminal *
+pgtk_create_terminal (struct pgtk_display_info *dpyinfo)
+/* --------------------------------------------------------------------------
+ Set up use of Gtk before we make the first connection.
+ -------------------------------------------------------------------------- */
+{
+ struct terminal *terminal;
+
+ terminal = create_terminal (output_pgtk, &pgtk_redisplay_interface);
+
+ terminal->display_info.pgtk = dpyinfo;
+ dpyinfo->terminal = terminal;
+
+ terminal->clear_frame_hook = pgtk_clear_frame;
+ terminal->ring_bell_hook = pgtk_ring_bell;
+ terminal->toggle_invisible_pointer_hook = XTtoggle_invisible_pointer;
+ terminal->update_begin_hook = pgtk_update_begin;
+ terminal->update_end_hook = pgtk_update_end;
+ terminal->read_socket_hook = pgtk_read_socket;
+ terminal->frame_up_to_date_hook = pgtk_frame_up_to_date;
+ terminal->mouse_position_hook = pgtk_mouse_position;
+ terminal->frame_rehighlight_hook = XTframe_rehighlight;
+ terminal->buffer_flipping_unblocked_hook = pgtk_buffer_flipping_unblocked_hook;
+ terminal->frame_raise_lower_hook = pgtk_frame_raise_lower;
+ terminal->frame_visible_invisible_hook = pgtk_make_frame_visible_invisible;
+ terminal->fullscreen_hook = pgtk_fullscreen_hook;
+ terminal->menu_show_hook = pgtk_menu_show;
+ terminal->activate_menubar_hook = pgtk_activate_menubar;
+ terminal->popup_dialog_hook = pgtk_popup_dialog;
+ terminal->change_tab_bar_height_hook = x_change_tab_bar_height;
+ terminal->set_vertical_scroll_bar_hook = pgtk_set_vertical_scroll_bar;
+ terminal->set_horizontal_scroll_bar_hook = pgtk_set_horizontal_scroll_bar;
+ terminal->condemn_scroll_bars_hook = pgtk_condemn_scroll_bars;
+ terminal->redeem_scroll_bar_hook = pgtk_redeem_scroll_bar;
+ terminal->judge_scroll_bars_hook = pgtk_judge_scroll_bars;
+ terminal->get_string_resource_hook = pgtk_get_string_resource;
+ terminal->delete_frame_hook = x_destroy_window;
+ terminal->delete_terminal_hook = pgtk_delete_terminal;
+ terminal->query_frame_background_color = pgtk_query_frame_background_color;
+ terminal->defined_color_hook = pgtk_defined_color;
+ terminal->set_new_font_hook = pgtk_new_font;
+ terminal->set_bitmap_icon_hook = pgtk_bitmap_icon;
+ terminal->implicit_set_name_hook = pgtk_implicitly_set_name;
+ terminal->iconify_frame_hook = pgtk_iconify_frame;
+ terminal->set_scroll_bar_default_width_hook =
+ pgtk_set_scroll_bar_default_width;
+ terminal->set_scroll_bar_default_height_hook =
+ pgtk_set_scroll_bar_default_height;
+ terminal->set_window_size_hook = pgtk_set_window_size;
+ terminal->query_colors = pgtk_query_colors;
+ terminal->get_focus_frame = x_get_focus_frame;
+ terminal->focus_frame_hook = pgtk_focus_frame;
+ terminal->set_frame_offset_hook = x_set_offset;
+ terminal->free_pixmap = pgtk_free_pixmap;
+
+ /* Other hooks are NULL by default. */
+
+ return terminal;
+}
+
+struct pgtk_window_is_of_frame_recursive_t
+{
+ GdkWindow *window;
+ bool result;
+ GtkWidget *emacs_gtk_fixed; /* stop on emacsgtkfixed other than this. */
+};
+
+static void
+pgtk_window_is_of_frame_recursive (GtkWidget * widget, gpointer data)
+{
+ struct pgtk_window_is_of_frame_recursive_t *datap = data;
+
+ if (datap->result)
+ return;
+
+ if (EMACS_IS_FIXED (widget) && widget != datap->emacs_gtk_fixed)
+ return;
+
+ if (gtk_widget_get_window (widget) == datap->window)
+ {
+ datap->result = true;
+ return;
+ }
+
+ if (GTK_IS_CONTAINER (widget)) {
+ gtk_container_foreach (GTK_CONTAINER (widget),
+ pgtk_window_is_of_frame_recursive, datap);
+ }
+}
+
+static bool
+pgtk_window_is_of_frame (struct frame *f, GdkWindow * window)
+{
+ struct pgtk_window_is_of_frame_recursive_t data;
+ data.window = window;
+ data.result = false;
+ data.emacs_gtk_fixed = FRAME_GTK_WIDGET (f);
+ pgtk_window_is_of_frame_recursive (FRAME_WIDGET (f), &data);
+ return data.result;
+}
+
+/* Like x_window_to_frame but also compares the window with the widget's
+ windows. */
+static struct frame *
+pgtk_any_window_to_frame (GdkWindow * window)
+{
+ Lisp_Object tail, frame;
+ struct frame *f, *found = NULL;
+
+ if (window == NULL)
+ return NULL;
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ if (found)
+ break;
+ f = XFRAME (frame);
+ if (FRAME_PGTK_P (f))
+ {
+ if (pgtk_window_is_of_frame (f, window))
+ found = f;
+ }
+ }
+
+ return found;
+}
+
+static gboolean
+pgtk_handle_event (GtkWidget * widget, GdkEvent * event, gpointer * data)
+{
+ return FALSE;
+}
+
+static void
+pgtk_fill_rectangle (struct frame *f, unsigned long color, int x, int y,
+ int width, int height)
+{
+ cairo_t *cr;
+ cr = pgtk_begin_cr_clip (f);
+ pgtk_set_cr_source_with_color (f, color);
+ cairo_rectangle (cr, x, y, width, height);
+ cairo_fill (cr);
+ pgtk_end_cr_clip (f);
+}
+
+void
+pgtk_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 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
+ }
+ 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
+ }
+
+ unblock_input ();
+ }
+}
+
+static gboolean
+pgtk_handle_draw (GtkWidget * widget, cairo_t * cr, gpointer * data)
+{
+ struct frame *f;
+
+ GdkWindow *win = gtk_widget_get_window (widget);
+
+ if (win != NULL)
+ {
+ cairo_surface_t *src = NULL;
+ f = pgtk_any_window_to_frame (win);
+ if (f != NULL)
+ {
+ src = FRAME_X_OUTPUT (f)->cr_surface_visible_bell;
+ if (src == NULL && FRAME_CR_ACTIVE_CONTEXT (f) != NULL)
+ src = cairo_get_target (FRAME_CR_ACTIVE_CONTEXT (f));
+ }
+ if (src != NULL)
+ {
+ cairo_set_source_surface (cr, src, 0, 0);
+ cairo_paint (cr);
+ }
+ }
+ return FALSE;
+}
+
+static void
+size_allocate (GtkWidget * widget, GtkAllocation * alloc,
+ gpointer user_data)
+{
+ struct frame *f = pgtk_any_window_to_frame (gtk_widget_get_window (widget));
+
+ /* Between a frame is created and not shown, size is allocated and
+ * this handler is called. When that, since the widget's window is
+ * NULL, we can't get f, pgtk_cr_update_surface_desired_size is not
+ * called, and its size is 0x0. That causes empty frame.
+ *
+ * Fortunately since we know f in pgtk_set_event_handler, we can get
+ * it through user_data;
+ */
+ if (!f)
+ f = user_data;
+
+ if (f)
+ {
+ xg_frame_resized (f, alloc->width, alloc->height);
+ pgtk_cr_update_surface_desired_size (f, alloc->width, alloc->height, false);
+ }
+}
+
+static void
+x_find_modifier_meanings (struct pgtk_display_info *dpyinfo)
+{
+ GdkDisplay *gdpy = dpyinfo->gdpy;
+ GdkKeymap *keymap = gdk_keymap_get_for_display (gdpy);
+ GdkModifierType state = GDK_META_MASK;
+ gboolean r = gdk_keymap_map_virtual_modifiers (keymap, &state);
+ if (r)
+ {
+ /* Meta key exists. */
+ if (state == GDK_META_MASK)
+ {
+ dpyinfo->meta_mod_mask = GDK_MOD1_MASK; /* maybe this is meta. */
+ dpyinfo->alt_mod_mask = 0;
+ }
+ else
+ {
+ dpyinfo->meta_mod_mask = state & ~GDK_META_MASK;
+ if (dpyinfo->meta_mod_mask == GDK_MOD1_MASK)
+ dpyinfo->alt_mod_mask = 0;
+ else
+ dpyinfo->alt_mod_mask = GDK_MOD1_MASK;
+ }
+ }
+ else
+ {
+ dpyinfo->meta_mod_mask = GDK_MOD1_MASK;
+ dpyinfo->alt_mod_mask = 0;
+ }
+
+ state = GDK_SUPER_MASK;
+ r = gdk_keymap_map_virtual_modifiers (keymap, &state);
+ if (r)
+ {
+ /* Super key exists. */
+ if (state == GDK_SUPER_MASK)
+ {
+ dpyinfo->super_mod_mask = GDK_MOD4_MASK; /* maybe this is super. */
+ }
+ else
+ {
+ dpyinfo->super_mod_mask = state & ~GDK_SUPER_MASK;
+ }
+ }
+ else
+ {
+ dpyinfo->super_mod_mask = GDK_MOD4_MASK;
+ }
+
+ state = GDK_HYPER_MASK;
+ r = gdk_keymap_map_virtual_modifiers (keymap, &state);
+ if (r)
+ {
+ /* Hyper key exists. */
+ if (state == GDK_HYPER_MASK)
+ {
+ dpyinfo->hyper_mod_mask = GDK_MOD3_MASK; /* maybe this is hyper. */
+ }
+ else
+ {
+ dpyinfo->hyper_mod_mask = state & ~GDK_HYPER_MASK;
+ }
+ }
+ else
+ {
+ dpyinfo->hyper_mod_mask = GDK_MOD3_MASK;
+ }
+
+ /* If xmodmap says:
+ * $ xmodmap | grep mod4
+ * mod4 Super_L (0x85), Super_R (0x86), Super_L (0xce), Hyper_L (0xcf)
+ * then, when mod4 is pressed, both of super and hyper are recognized ON.
+ * Maybe many people have such configuration, and they don't like such behavior,
+ * so I disable hyper if such configuration is detected.
+ */
+ if (dpyinfo->hyper_mod_mask == dpyinfo->super_mod_mask)
+ dpyinfo->hyper_mod_mask = 0;
+}
+
+static void
+get_modifier_values (int *mod_ctrl,
+ int *mod_meta,
+ int *mod_alt, int *mod_hyper, int *mod_super)
+{
+ Lisp_Object tem;
+
+ *mod_ctrl = ctrl_modifier;
+ *mod_meta = meta_modifier;
+ *mod_alt = alt_modifier;
+ *mod_hyper = hyper_modifier;
+ *mod_super = super_modifier;
+
+ tem = Fget (Vx_ctrl_keysym, Qmodifier_value);
+ if (INTEGERP (tem))
+ *mod_ctrl = XFIXNUM (tem) & INT_MAX;
+ tem = Fget (Vx_alt_keysym, Qmodifier_value);
+ if (INTEGERP (tem))
+ *mod_alt = XFIXNUM (tem) & INT_MAX;
+ tem = Fget (Vx_meta_keysym, Qmodifier_value);
+ if (INTEGERP (tem))
+ *mod_meta = XFIXNUM (tem) & INT_MAX;
+ tem = Fget (Vx_hyper_keysym, Qmodifier_value);
+ if (INTEGERP (tem))
+ *mod_hyper = XFIXNUM (tem) & INT_MAX;
+ tem = Fget (Vx_super_keysym, Qmodifier_value);
+ if (INTEGERP (tem))
+ *mod_super = XFIXNUM (tem) & INT_MAX;
+}
+
+int
+pgtk_gtk_to_emacs_modifiers (struct pgtk_display_info *dpyinfo, int state)
+{
+ int mod_ctrl;
+ int mod_meta;
+ int mod_alt;
+ int mod_hyper;
+ int mod_super;
+ int mod;
+
+ get_modifier_values (&mod_ctrl, &mod_meta, &mod_alt, &mod_hyper,
+ &mod_super);
+
+ mod = 0;
+ if (state & GDK_SHIFT_MASK)
+ mod |= shift_modifier;
+ if (state & GDK_CONTROL_MASK)
+ mod |= mod_ctrl;
+ if (state & dpyinfo->meta_mod_mask)
+ mod |= mod_meta;
+ if (state & dpyinfo->alt_mod_mask)
+ mod |= mod_alt;
+ if (state & dpyinfo->super_mod_mask)
+ mod |= mod_super;
+ if (state & dpyinfo->hyper_mod_mask)
+ mod |= mod_hyper;
+ return mod;
+}
+
+static int
+pgtk_emacs_to_gtk_modifiers (struct pgtk_display_info *dpyinfo, int state)
+{
+ int mod_ctrl;
+ int mod_meta;
+ int mod_alt;
+ int mod_hyper;
+ int mod_super;
+ int mask;
+
+ get_modifier_values (&mod_ctrl, &mod_meta, &mod_alt, &mod_hyper,
+ &mod_super);
+
+ mask = 0;
+ if (state & mod_alt)
+ mask |= dpyinfo->alt_mod_mask;
+ if (state & mod_super)
+ mask |= dpyinfo->super_mod_mask;
+ if (state & mod_hyper)
+ mask |= dpyinfo->hyper_mod_mask;
+ if (state & shift_modifier)
+ mask |= GDK_SHIFT_MASK;
+ if (state & mod_ctrl)
+ mask |= GDK_CONTROL_MASK;
+ if (state & mod_meta)
+ mask |= dpyinfo->meta_mod_mask;
+ return mask;
+}
+
+#define IsCursorKey(keysym) (0xff50 <= (keysym) && (keysym) < 0xff60)
+#define IsMiscFunctionKey(keysym) (0xff60 <= (keysym) && (keysym) < 0xff6c)
+#define IsKeypadKey(keysym) (0xff80 <= (keysym) && (keysym) < 0xffbe)
+#define IsFunctionKey(keysym) (0xffbe <= (keysym) && (keysym) < 0xffe1)
+#define IsModifierKey(keysym) \
+ ((((keysym) >= GDK_KEY_Shift_L) && ((keysym) <= GDK_KEY_Hyper_R)) \
+ || (((keysym) >= GDK_KEY_ISO_Lock) && ((keysym) <= GDK_KEY_ISO_Level5_Lock)) \
+ || ((keysym) == GDK_KEY_Mode_switch) \
+ || ((keysym) == GDK_KEY_Num_Lock))
+
+
+void
+pgtk_enqueue_string (struct frame *f, gchar * str)
+{
+ gunichar *ustr;
+
+ ustr = g_utf8_to_ucs4 (str, -1, NULL, NULL, NULL);
+ if (ustr == NULL)
+ return;
+ for (; *ustr != 0; ustr++)
+ {
+ union buffered_input_event inev;
+ Lisp_Object c = make_fixnum (*ustr);
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFIXNAT (c))
+ ? ASCII_KEYSTROKE_EVENT
+ : MULTIBYTE_CHAR_KEYSTROKE_EVENT);
+ inev.ie.arg = Qnil;
+ inev.ie.code = XFIXNAT (c);
+ XSETFRAME (inev.ie.frame_or_window, f);
+ inev.ie.modifiers = 0;
+ inev.ie.timestamp = 0;
+ evq_enqueue (&inev);
+ }
+
+}
+
+void
+pgtk_enqueue_preedit (struct frame *f, Lisp_Object preedit)
+{
+ union buffered_input_event inev;
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = PGTK_PREEDIT_TEXT_EVENT;
+ inev.ie.arg = preedit;
+ inev.ie.code = 0;
+ XSETFRAME (inev.ie.frame_or_window, f);
+ inev.ie.modifiers = 0;
+ inev.ie.timestamp = 0;
+ evq_enqueue (&inev);
+}
+
+static gboolean
+key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
+{
+ struct coding_system coding;
+ union buffered_input_event inev;
+ ptrdiff_t nbytes = 0;
+ Mouse_HLInfo *hlinfo;
+
+ USE_SAFE_ALLOCA;
+
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = NO_EVENT;
+ inev.ie.arg = Qnil;
+
+ struct frame *f = pgtk_any_window_to_frame (gtk_widget_get_window (widget));
+ hlinfo = MOUSE_HL_INFO (f);
+
+ /* If mouse-highlight is an integer, input clears out
+ mouse highlighting. */
+ if (!hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight))
+ {
+ clear_mouse_face (hlinfo);
+ hlinfo->mouse_face_hidden = true;
+ }
+
+ if (f != 0)
+ {
+ /* While super is pressed, gtk_im_context_filter_keypress() always process the
+ * key events ignoring super.
+ * As a work around, don't call it while super or hyper are pressed...
+ */
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+ if (!(event->key.state & (dpyinfo->super_mod_mask | dpyinfo->hyper_mod_mask)))
+ {
+ if (pgtk_im_filter_keypress (f, &event->key))
+ return TRUE;
+ }
+ }
+
+ if (f != 0)
+ {
+ guint keysym, orig_keysym;
+ /* al%imercury@uunet.uu.net says that making this 81
+ instead of 80 fixed a bug whereby meta chars made
+ his Emacs hang.
+
+ It seems that some version of XmbLookupString has
+ a bug of not returning XBufferOverflow in
+ status_return even if the input is too long to
+ fit in 81 bytes. So, we must prepare sufficient
+ bytes for copy_buffer. 513 bytes (256 chars for
+ two-byte character set) seems to be a fairly good
+ approximation. -- 2000.8.10 handa@etl.go.jp */
+ unsigned char copy_buffer[513];
+ unsigned char *copy_bufptr = copy_buffer;
+ int copy_bufsiz = sizeof (copy_buffer);
+ int modifiers;
+ Lisp_Object coding_system = Qlatin_1;
+ Lisp_Object c;
+ guint state = event->key.state;
+
+ state |=
+ pgtk_emacs_to_gtk_modifiers (FRAME_DISPLAY_INFO (f),
+ extra_keyboard_modifiers);
+ modifiers = state;
+
+ /* This will have to go some day... */
+
+ /* make_lispy_event turns chars into control chars.
+ Don't do it here because XLookupString is too eager. */
+ state &= ~GDK_CONTROL_MASK;
+ state &= ~(GDK_META_MASK
+ | GDK_SUPER_MASK | GDK_HYPER_MASK | GDK_MOD1_MASK);
+
+ nbytes = event->key.length;
+ if (nbytes > copy_bufsiz)
+ nbytes = copy_bufsiz;
+ memcpy (copy_bufptr, event->key.string, nbytes);
+
+ keysym = event->key.keyval;
+ orig_keysym = keysym;
+
+ /* Common for all keysym input events. */
+ XSETFRAME (inev.ie.frame_or_window, f);
+ inev.ie.modifiers =
+ pgtk_gtk_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), modifiers);
+ inev.ie.timestamp = event->key.time;
+
+ /* First deal with keysyms which have defined
+ translations to characters. */
+ if (keysym >= 32 && keysym < 128)
+ /* Avoid explicitly decoding each ASCII character. */
+ {
+ inev.ie.kind = ASCII_KEYSTROKE_EVENT;
+ inev.ie.code = keysym;
+ goto done;
+ }
+
+ /* Keysyms directly mapped to Unicode characters. */
+ if (keysym >= 0x01000000 && keysym <= 0x0110FFFF)
+ {
+ if (keysym < 0x01000080)
+ inev.ie.kind = ASCII_KEYSTROKE_EVENT;
+ else
+ inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT;
+ inev.ie.code = keysym & 0xFFFFFF;
+ goto done;
+ }
+
+ /* Now non-ASCII. */
+ if (HASH_TABLE_P (Vpgtk_keysym_table)
+ && (c = Fgethash (make_fixnum (keysym),
+ Vpgtk_keysym_table, Qnil), FIXNATP (c)))
+ {
+ inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFIXNAT (c))
+ ? ASCII_KEYSTROKE_EVENT
+ : MULTIBYTE_CHAR_KEYSTROKE_EVENT);
+ inev.ie.code = XFIXNAT (c);
+ goto done;
+ }
+
+ /* Random non-modifier sorts of keysyms. */
+ if (((keysym >= GDK_KEY_BackSpace && keysym <= GDK_KEY_Escape)
+ || keysym == GDK_KEY_Delete
+#ifdef GDK_KEY_ISO_Left_Tab
+ || (keysym >= GDK_KEY_ISO_Left_Tab && keysym <= GDK_KEY_ISO_Enter)
+#endif
+ || IsCursorKey (keysym) /* 0xff50 <= x < 0xff60 */
+ || IsMiscFunctionKey (keysym) /* 0xff60 <= x < VARIES */
+#ifdef HPUX
+ /* This recognizes the "extended function
+ keys". It seems there's no cleaner way.
+ Test IsModifierKey to avoid handling
+ mode_switch incorrectly. */
+ || (GDK_KEY_Select <= keysym && keysym < GDK_KEY_KP_Space)
+#endif
+#ifdef GDK_KEY_dead_circumflex
+ || orig_keysym == GDK_KEY_dead_circumflex
+#endif
+#ifdef GDK_KEY_dead_grave
+ || orig_keysym == GDK_KEY_dead_grave
+#endif
+#ifdef GDK_KEY_dead_tilde
+ || orig_keysym == GDK_KEY_dead_tilde
+#endif
+#ifdef GDK_KEY_dead_diaeresis
+ || orig_keysym == GDK_KEY_dead_diaeresis
+#endif
+#ifdef GDK_KEY_dead_macron
+ || orig_keysym == GDK_KEY_dead_macron
+#endif
+#ifdef GDK_KEY_dead_degree
+ || orig_keysym == GDK_KEY_dead_degree
+#endif
+#ifdef GDK_KEY_dead_acute
+ || orig_keysym == GDK_KEY_dead_acute
+#endif
+#ifdef GDK_KEY_dead_cedilla
+ || orig_keysym == GDK_KEY_dead_cedilla
+#endif
+#ifdef GDK_KEY_dead_breve
+ || orig_keysym == GDK_KEY_dead_breve
+#endif
+#ifdef GDK_KEY_dead_ogonek
+ || orig_keysym == GDK_KEY_dead_ogonek
+#endif
+#ifdef GDK_KEY_dead_caron
+ || orig_keysym == GDK_KEY_dead_caron
+#endif
+#ifdef GDK_KEY_dead_doubleacute
+ || orig_keysym == GDK_KEY_dead_doubleacute
+#endif
+#ifdef GDK_KEY_dead_abovedot
+ || orig_keysym == GDK_KEY_dead_abovedot
+#endif
+ || IsKeypadKey (keysym) /* 0xff80 <= x < 0xffbe */
+ || IsFunctionKey (keysym) /* 0xffbe <= x < 0xffe1 */
+ /* Any "vendor-specific" key is ok. */
+ || (orig_keysym & (1 << 28))
+ || (keysym != GDK_KEY_VoidSymbol && nbytes == 0))
+ && !(event->key.is_modifier
+ /* Gtk's modifier keys are different from Xlib's ones.
+ * I need to exclude them.
+ */
+ || IsModifierKey (orig_keysym)
+ /* The symbols from GDK_KEY_ISO_Lock
+ to GDK_KEY_ISO_Last_Group_Lock
+ don't have real modifiers but
+ should be treated similarly to
+ Mode_switch by Emacs. */
+#if defined GDK_KEY_ISO_Lock && defined GDK_KEY_ISO_Last_Group_Lock
+ || (GDK_KEY_ISO_Lock <= orig_keysym
+ && orig_keysym <= GDK_KEY_ISO_Last_Group_Lock)
+#endif
+ ))
+ {
+ STORE_KEYSYM_FOR_DEBUG (keysym);
+ /* make_lispy_event will convert this to a symbolic
+ key. */
+ inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT;
+ inev.ie.code = keysym;
+ goto done;
+ }
+
+ { /* Raw bytes, not keysym. */
+ ptrdiff_t i;
+ int nchars, len;
+
+ for (i = 0, nchars = 0; i < nbytes; i++)
+ {
+ if (ASCII_CHAR_P (copy_bufptr[i]))
+ nchars++;
+ STORE_KEYSYM_FOR_DEBUG (copy_bufptr[i]);
+ }
+
+ if (nchars < nbytes)
+ {
+ /* Decode the input data. */
+
+ /* The input should be decoded with locale `coding_system'. */
+ if (!NILP (Vlocale_coding_system))
+ coding_system = Vlocale_coding_system;
+ setup_coding_system (coding_system, &coding);
+ coding.src_multibyte = false;
+ coding.dst_multibyte = true;
+ /* The input is converted to events, thus we can't
+ handle composition. Anyway, there's no XIM that
+ gives us composition information. */
+ coding.common_flags &= ~CODING_ANNOTATION_MASK;
+
+ SAFE_NALLOCA (coding.destination, MAX_MULTIBYTE_LENGTH, nbytes);
+ coding.dst_bytes = MAX_MULTIBYTE_LENGTH * nbytes;
+ coding.mode |= CODING_MODE_LAST_BLOCK;
+ decode_coding_c_string (&coding, copy_bufptr, nbytes, Qnil);
+ nbytes = coding.produced;
+ nchars = coding.produced_char;
+ copy_bufptr = coding.destination;
+ }
+
+ /* Convert the input data to a sequence of
+ character events. */
+ for (i = 0; i < nbytes; i += len)
+ {
+ int ch;
+ if (nchars == nbytes)
+ ch = copy_bufptr[i], len = 1;
+ else
+ ch = string_char_and_length (copy_bufptr + i, &len);
+ inev.ie.kind = (SINGLE_BYTE_CHAR_P (ch)
+ ? ASCII_KEYSTROKE_EVENT
+ : MULTIBYTE_CHAR_KEYSTROKE_EVENT);
+ inev.ie.code = ch;
+ evq_enqueue (&inev);
+ }
+
+ /* count += nchars; */
+
+ inev.ie.kind = NO_EVENT; /* Already stored above. */
+
+ if (keysym == GDK_KEY_VoidSymbol)
+ goto done;
+ }
+ }
+
+done:
+ if (inev.ie.kind != NO_EVENT)
+ {
+ XSETFRAME (inev.ie.frame_or_window, f);
+ evq_enqueue (&inev);
+ /* count++; */
+ }
+
+ SAFE_FREE ();
+
+ return TRUE;
+}
+
+static gboolean
+key_release_event (GtkWidget *widget,
+ GdkEvent *event,
+ gpointer *user_data)
+{
+ return TRUE;
+}
+
+static gboolean
+configure_event (GtkWidget *widget,
+ GdkEvent *event,
+ gpointer *user_data)
+{
+ struct frame *f = pgtk_any_window_to_frame (event->configure.window);
+ if (f && widget == FRAME_GTK_OUTER_WIDGET (f))
+ {
+ if (any_help_event_p)
+ {
+ Lisp_Object frame;
+ if (f)
+ XSETFRAME (frame, f);
+ else
+ frame = Qnil;
+ help_echo_string = Qnil;
+ gen_help_event (Qnil, frame, Qnil, Qnil, 0);
+ }
+ }
+ return FALSE;
+}
+
+static gboolean
+map_event (GtkWidget *widget,
+ GdkEvent *event,
+ gpointer *user_data)
+{
+ struct frame *f = pgtk_any_window_to_frame (event->any.window);
+ union buffered_input_event inev;
+
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = NO_EVENT;
+ inev.ie.arg = Qnil;
+
+ if (f)
+ {
+ bool iconified = FRAME_ICONIFIED_P (f);
+
+ /* Check if fullscreen was specified before we where mapped the
+ first time, i.e. from the command line. */
+ if (!FRAME_X_OUTPUT (f)->has_been_visible)
+ {
+ set_fullscreen_state (f);
+ }
+
+ if (!iconified)
+ {
+ /* The `z-group' is reset every time a frame becomes
+ invisible. Handle this here. */
+ if (FRAME_Z_GROUP (f) == z_group_above)
+ x_set_z_group (f, Qabove, Qnil);
+ else if (FRAME_Z_GROUP (f) == z_group_below)
+ x_set_z_group (f, Qbelow, Qnil);
+ }
+
+ SET_FRAME_VISIBLE (f, 1);
+ SET_FRAME_ICONIFIED (f, false);
+ FRAME_X_OUTPUT (f)->has_been_visible = true;
+
+ if (iconified)
+ {
+ inev.ie.kind = DEICONIFY_EVENT;
+ XSETFRAME (inev.ie.frame_or_window, f);
+ }
+ }
+
+ if (inev.ie.kind != NO_EVENT)
+ evq_enqueue (&inev);
+ return FALSE;
+}
+
+static gboolean
+window_state_event (GtkWidget *widget,
+ GdkEvent *event,
+ gpointer *user_data)
+{
+ struct frame *f = pgtk_any_window_to_frame (event->window_state.window);
+ union buffered_input_event inev;
+
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = NO_EVENT;
+ inev.ie.arg = Qnil;
+
+ if (f)
+ {
+ if (event->window_state.new_window_state & GDK_WINDOW_STATE_FOCUSED)
+ {
+ if (FRAME_ICONIFIED_P (f))
+ {
+ /* Gnome shell does not iconify us when C-z is pressed.
+ It hides the frame. So if our state says we aren't
+ hidden anymore, treat it as deiconified. */
+ SET_FRAME_VISIBLE (f, 1);
+ SET_FRAME_ICONIFIED (f, false);
+ FRAME_X_OUTPUT (f)->has_been_visible = true;
+ inev.ie.kind = DEICONIFY_EVENT;
+ XSETFRAME (inev.ie.frame_or_window, f);
+ }
+ }
+ }
+
+ if (inev.ie.kind != NO_EVENT)
+ evq_enqueue (&inev);
+ return FALSE;
+}
+
+static gboolean
+delete_event (GtkWidget *widget,
+ GdkEvent *event, gpointer *user_data)
+{
+ struct frame *f = pgtk_any_window_to_frame (event->any.window);
+ union buffered_input_event inev;
+
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = NO_EVENT;
+ inev.ie.arg = Qnil;
+
+ if (f)
+ {
+ inev.ie.kind = DELETE_WINDOW_EVENT;
+ XSETFRAME (inev.ie.frame_or_window, f);
+ }
+
+ if (inev.ie.kind != NO_EVENT)
+ evq_enqueue (&inev);
+ return TRUE;
+}
+
+/* The focus may have changed. Figure out if it is a real focus change,
+ by checking both FocusIn/Out and Enter/LeaveNotify events.
+
+ Returns FOCUS_IN_EVENT event in *BUFP. */
+
+/* Handle FocusIn and FocusOut state changes for FRAME.
+ If FRAME has focus and there exists more than one frame, puts
+ a FOCUS_IN_EVENT into *BUFP. */
+
+static void
+x_focus_changed (gboolean is_enter, int state,
+ struct pgtk_display_info *dpyinfo, struct frame *frame,
+ union buffered_input_event *bufp)
+{
+ if (is_enter)
+ {
+ if (dpyinfo->x_focus_event_frame != frame)
+ {
+ x_new_focus_frame (dpyinfo, frame);
+ dpyinfo->x_focus_event_frame = frame;
+
+ /* Don't stop displaying the initial startup message
+ for a switch-frame event we don't need. */
+ /* When run as a daemon, Vterminal_frame is always NIL. */
+ bufp->ie.arg = (((NILP (Vterminal_frame)
+ || !FRAME_PGTK_P (XFRAME (Vterminal_frame))
+ || EQ (Fdaemonp (), Qt))
+ && CONSP (Vframe_list)
+ && !NILP (XCDR (Vframe_list))) ? Qt : Qnil);
+ bufp->ie.kind = FOCUS_IN_EVENT;
+ XSETFRAME (bufp->ie.frame_or_window, frame);
+ }
+
+ frame->output_data.pgtk->focus_state |= state;
+
+ }
+ else
+ {
+ frame->output_data.pgtk->focus_state &= ~state;
+
+ if (dpyinfo->x_focus_event_frame == frame)
+ {
+ dpyinfo->x_focus_event_frame = 0;
+ x_new_focus_frame (dpyinfo, 0);
+
+ bufp->ie.kind = FOCUS_OUT_EVENT;
+ XSETFRAME (bufp->ie.frame_or_window, frame);
+ }
+
+ if (frame->pointer_invisible)
+ XTtoggle_invisible_pointer (frame, false);
+ }
+}
+
+static gboolean
+enter_notify_event (GtkWidget *widget, GdkEvent *event,
+ gpointer *user_data)
+{
+ union buffered_input_event inev;
+ struct frame *frame =
+ pgtk_any_window_to_frame (gtk_widget_get_window (widget));
+ if (frame == NULL)
+ return FALSE;
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame);
+ struct frame *focus_frame = dpyinfo->x_focus_frame;
+ int focus_state
+ = focus_frame ? focus_frame->output_data.pgtk->focus_state : 0;
+
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = NO_EVENT;
+ inev.ie.arg = Qnil;
+
+ if (event->crossing.detail != GDK_NOTIFY_INFERIOR
+ && event->crossing.focus && !(focus_state & FOCUS_EXPLICIT))
+ x_focus_changed (TRUE, FOCUS_IMPLICIT, dpyinfo, frame, &inev);
+ if (inev.ie.kind != NO_EVENT)
+ evq_enqueue (&inev);
+ return TRUE;
+}
+
+static gboolean
+leave_notify_event (GtkWidget *widget, GdkEvent *event,
+ gpointer *user_data)
+{
+ union buffered_input_event inev;
+ struct frame *frame =
+ pgtk_any_window_to_frame (gtk_widget_get_window (widget));
+ if (frame == NULL)
+ return FALSE;
+ struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame);
+ struct frame *focus_frame = dpyinfo->x_focus_frame;
+ int focus_state
+ = focus_frame ? focus_frame->output_data.pgtk->focus_state : 0;
+ Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (frame);
+
+ if (frame == 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;
+ }
+
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = NO_EVENT;
+ inev.ie.arg = Qnil;
+
+ if (event->crossing.detail != GDK_NOTIFY_INFERIOR
+ && event->crossing.focus && !(focus_state & FOCUS_EXPLICIT))
+ x_focus_changed (FALSE, FOCUS_IMPLICIT, dpyinfo, frame, &inev);
+
+ if (frame)
+ {
+ if (any_help_event_p)
+ {
+ Lisp_Object frame_obj;
+ XSETFRAME (frame_obj, frame);
+ help_echo_string = Qnil;
+ gen_help_event (Qnil, frame_obj, Qnil, Qnil, 0);
+ }
+ }
+
+ if (inev.ie.kind != NO_EVENT)
+ evq_enqueue (&inev);
+ return TRUE;
+}
+
+static gboolean
+focus_in_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
+{
+ union buffered_input_event inev;
+ struct frame *frame =
+ pgtk_any_window_to_frame (gtk_widget_get_window (widget));
+
+ if (frame == NULL)
+ return TRUE;
+
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = NO_EVENT;
+ inev.ie.arg = Qnil;
+
+ x_focus_changed (TRUE, FOCUS_EXPLICIT,
+ FRAME_DISPLAY_INFO (frame), frame, &inev);
+ if (inev.ie.kind != NO_EVENT)
+ evq_enqueue (&inev);
+
+ pgtk_im_focus_in (frame);
+
+ return TRUE;
+}
+
+static gboolean
+focus_out_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
+{
+ union buffered_input_event inev;
+ struct frame *frame =
+ pgtk_any_window_to_frame (gtk_widget_get_window (widget));
+
+ if (frame == NULL)
+ return TRUE;
+
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = NO_EVENT;
+ inev.ie.arg = Qnil;
+
+ x_focus_changed (FALSE, FOCUS_EXPLICIT,
+ FRAME_DISPLAY_INFO (frame), frame, &inev);
+ if (inev.ie.kind != NO_EVENT)
+ evq_enqueue (&inev);
+
+ pgtk_im_focus_out (frame);
+
+ return TRUE;
+}
+
+/* Function to report a mouse movement to the mainstream Emacs code.
+ The input handler calls this.
+
+ We have received a mouse movement event, which is given in *event.
+ If the mouse is over a different glyph than it was last time, tell
+ the mainstream emacs code by setting mouse_moved. If not, ask for
+ another motion event, so we can check again the next time it moves. */
+
+static bool
+note_mouse_movement (struct frame *frame, const GdkEventMotion * event)
+{
+ XRectangle *r;
+ struct pgtk_display_info *dpyinfo;
+
+ if (!FRAME_X_OUTPUT (frame))
+ return false;
+
+ dpyinfo = FRAME_DISPLAY_INFO (frame);
+ dpyinfo->last_mouse_movement_time = event->time;
+ dpyinfo->last_mouse_motion_frame = frame;
+ dpyinfo->last_mouse_motion_x = event->x;
+ dpyinfo->last_mouse_motion_y = event->y;
+
+ if (event->window != gtk_widget_get_window (FRAME_GTK_WIDGET (frame)))
+ {
+ frame->mouse_moved = true;
+ dpyinfo->last_mouse_scroll_bar = NULL;
+ note_mouse_highlight (frame, -1, -1);
+ dpyinfo->last_mouse_glyph_frame = NULL;
+ return true;
+ }
+
+
+ /* 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)
+ {
+ frame->mouse_moved = true;
+ dpyinfo->last_mouse_scroll_bar = NULL;
+ 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 gboolean
+motion_notify_event (GtkWidget * widget, GdkEvent * event,
+ gpointer * user_data)
+{
+ union buffered_input_event inev;
+ struct frame *f, *frame;
+ struct pgtk_display_info *dpyinfo;
+ Mouse_HLInfo *hlinfo;
+
+ /* This is needed to make pointer visible when motion_notify event */
+ pending_signals = true;
+
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = NO_EVENT;
+ inev.ie.arg = Qnil;
+
+ previous_help_echo_string = help_echo_string;
+ help_echo_string = Qnil;
+
+ frame = pgtk_any_window_to_frame (gtk_widget_get_window (widget));
+ dpyinfo = FRAME_DISPLAY_INFO (frame);
+ f = (gui_mouse_grabbed (dpyinfo) ? dpyinfo->last_mouse_frame
+ : pgtk_any_window_to_frame (gtk_widget_get_window (widget)));
+ hlinfo = MOUSE_HL_INFO (f);
+
+ if (hlinfo->mouse_face_hidden)
+ {
+ hlinfo->mouse_face_hidden = false;
+ clear_mouse_face (hlinfo);
+ }
+
+ if (f && xg_event_is_for_scrollbar (f, event))
+ f = 0;
+ 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)
+ /* 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->motion.x, event->motion.y, 0, 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 (!note_mouse_movement (f, &event->motion))
+ help_echo_string = previous_help_echo_string;
+ }
+ else
+ {
+ /* If we move outside the frame, then we're
+ certainly no longer on any text in the frame. */
+ clear_mouse_face (hlinfo);
+ }
+
+ /* If the contents of the global variable help_echo_string
+ has changed, generate a HELP_EVENT. */
+ int do_help = 0;
+ if (!NILP (help_echo_string) || !NILP (previous_help_echo_string))
+ do_help = 1;
+
+ if (inev.ie.kind != NO_EVENT)
+ evq_enqueue (&inev);
+
+ if (do_help > 0)
+ {
+ Lisp_Object frame;
+
+ if (f)
+ XSETFRAME (frame, f);
+ else
+ frame = Qnil;
+
+ any_help_event_p = true;
+ gen_help_event (help_echo_string, frame, help_echo_window,
+ help_echo_object, help_echo_pos);
+ }
+
+ return TRUE;
+}
+
+/* Mouse clicks and mouse movement. Rah.
+
+ Formerly, we used PointerMotionHintMask (in standard_event_mask)
+ so that we would have to call XQueryPointer after each MotionNotify
+ event to ask for another such event. However, this made mouse tracking
+ slow, and there was a bug that made it eventually stop.
+
+ Simply asking for MotionNotify all the time seems to work better.
+
+ In order to avoid asking for motion events and then throwing most
+ of them away or busy-polling the server for mouse positions, we ask
+ the server for pointer motion hints. This means that we get only
+ one event per group of mouse movements. "Groups" are delimited by
+ other kinds of events (focus changes and button clicks, for
+ example), or by XQueryPointer calls; when one of these happens, we
+ get another MotionNotify event the next time the mouse moves. This
+ is at least as efficient as getting motion events when mouse
+ tracking is on, and I suspect only negligibly worse when tracking
+ is off. */
+
+/* Prepare a mouse-event in *RESULT for placement in the input queue.
+
+ If the event is a button press, then note that we have grabbed
+ the mouse. */
+
+static Lisp_Object
+construct_mouse_click (struct input_event *result,
+ const GdkEventButton * event, struct frame *f)
+{
+ /* 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 =
+ (pgtk_gtk_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), event->state) |
+ (event->type == GDK_BUTTON_RELEASE ? up_modifier : down_modifier));
+
+ XSETINT (result->x, event->x);
+ XSETINT (result->y, event->y);
+ XSETFRAME (result->frame_or_window, f);
+ result->arg = Qnil;
+ return Qnil;
+}
+
+static gboolean
+button_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
+{
+ union buffered_input_event inev;
+ struct frame *f, *frame;
+ struct pgtk_display_info *dpyinfo;
+
+ /* If we decide we want to generate an event to be seen
+ by the rest of Emacs, we put it here. */
+ bool tab_bar_p = false;
+ bool tool_bar_p = false;
+ Lisp_Object tab_bar_arg = Qnil;
+
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = NO_EVENT;
+ inev.ie.arg = Qnil;
+
+ /* ignore double click and triple click. */
+ if (event->type != GDK_BUTTON_PRESS && event->type != GDK_BUTTON_RELEASE)
+ return TRUE;
+
+ frame = pgtk_any_window_to_frame (gtk_widget_get_window (widget));
+ dpyinfo = FRAME_DISPLAY_INFO (frame);
+
+ dpyinfo->last_mouse_glyph_frame = NULL;
+#if 0
+ x_display_set_last_user_time (dpyinfo, event->button.time);
+#endif
+
+ if (gui_mouse_grabbed (dpyinfo))
+ f = dpyinfo->last_mouse_frame;
+ else
+ {
+ f = pgtk_any_window_to_frame (gtk_widget_get_window (widget));
+
+ if (f && event->button.type == GDK_BUTTON_PRESS
+ && !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)))
+ {
+ block_input ();
+ gtk_widget_grab_focus (FRAME_GTK_WIDGET (f));
+
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ gtk_window_present (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)));
+ unblock_input ();
+ }
+ }
+ }
+
+ /* xg_event_is_for_scrollbar() doesn't work correctly on sway, and
+ * we shouldn't need it.
+ */
+#if 0
+ if (f && xg_event_is_for_scrollbar (f, event))
+ f = 0;
+#endif
+
+ 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->button.x;
+ int y = event->button.y;
+
+ window = window_from_coordinates (f, x, y, 0, 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->type == GDK_BUTTON_PRESS,
+ pgtk_gtk_to_emacs_modifiers (dpyinfo, event->button.state));
+ }
+ }
+
+ if (f)
+ {
+ if (!(tab_bar_p && NILP (tab_bar_arg)) && !tool_bar_p)
+ {
+ if (ignore_next_mouse_click_timeout)
+ {
+ if (event->type == GDK_BUTTON_PRESS
+ && event->button.time > ignore_next_mouse_click_timeout)
+ {
+ ignore_next_mouse_click_timeout = 0;
+ construct_mouse_click (&inev.ie, &event->button, f);
+ }
+ if (event->type == GDK_BUTTON_RELEASE)
+ ignore_next_mouse_click_timeout = 0;
+ }
+ else
+ construct_mouse_click (&inev.ie, &event->button, f);
+
+ if (!NILP (tab_bar_arg))
+ inev.ie.arg = tab_bar_arg;
+ }
+#if 0
+ if (FRAME_X_EMBEDDED_P (f))
+ xembed_send_message (f, event->button.time,
+ XEMBED_REQUEST_FOCUS, 0, 0, 0);
+#endif
+ }
+
+ if (event->type == GDK_BUTTON_PRESS)
+ {
+ dpyinfo->grabbed |= (1 << event->button.button);
+ dpyinfo->last_mouse_frame = f;
+
+ if (dpyinfo->last_click_event != NULL)
+ gdk_event_free (dpyinfo->last_click_event);
+ dpyinfo->last_click_event = gdk_event_copy (event);
+ }
+ else
+ dpyinfo->grabbed &= ~(1 << event->button.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;
+
+ if (inev.ie.kind != NO_EVENT)
+ evq_enqueue (&inev);
+ return TRUE;
+}
+
+static gboolean
+scroll_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data)
+{
+ union buffered_input_event inev;
+ struct frame *f, *frame;
+ struct pgtk_display_info *dpyinfo;
+ GdkScrollDirection dir;
+ double delta_x, delta_y;
+
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = NO_EVENT;
+ inev.ie.arg = Qnil;
+
+ frame = pgtk_any_window_to_frame (gtk_widget_get_window (widget));
+ dpyinfo = FRAME_DISPLAY_INFO (frame);
+
+ if (gui_mouse_grabbed (dpyinfo))
+ f = dpyinfo->last_mouse_frame;
+ else
+ f = pgtk_any_window_to_frame (gtk_widget_get_window (widget));
+
+ inev.ie.kind = NO_EVENT;
+ inev.ie.timestamp = event->scroll.time;
+ inev.ie.modifiers =
+ pgtk_gtk_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), event->scroll.state);
+ XSETINT (inev.ie.x, event->scroll.x);
+ XSETINT (inev.ie.y, event->scroll.y);
+ XSETFRAME (inev.ie.frame_or_window, f);
+ inev.ie.arg = Qnil;
+
+ if (gdk_event_is_scroll_stop_event (event))
+ {
+ inev.ie.kind = TOUCH_END_EVENT;
+ evq_enqueue (&inev);
+ return TRUE;
+ }
+
+ if (gdk_event_get_scroll_direction (event, &dir))
+ {
+ switch (dir)
+ {
+ case GDK_SCROLL_UP:
+ inev.ie.kind = WHEEL_EVENT;
+ inev.ie.modifiers |= up_modifier;
+ break;
+ case GDK_SCROLL_DOWN:
+ inev.ie.kind = WHEEL_EVENT;
+ inev.ie.modifiers |= down_modifier;
+ break;
+ case GDK_SCROLL_LEFT:
+ inev.ie.kind = HORIZ_WHEEL_EVENT;
+ inev.ie.modifiers |= up_modifier;
+ break;
+ case GDK_SCROLL_RIGHT:
+ inev.ie.kind = HORIZ_WHEEL_EVENT;
+ inev.ie.modifiers |= down_modifier;
+ break;
+ case GDK_SCROLL_SMOOTH: /* shut up warning */
+ break;
+ }
+ }
+ else if (gdk_event_get_scroll_deltas (event, &delta_x, &delta_y))
+ {
+ dpyinfo->scroll.acc_x += delta_x;
+ dpyinfo->scroll.acc_y += delta_y;
+ if (dpyinfo->scroll.acc_y >= dpyinfo->scroll.y_per_line
+ || !mwheel_coalesce_scroll_events)
+ {
+ int nlines = dpyinfo->scroll.acc_y / dpyinfo->scroll.y_per_line;
+ inev.ie.kind = WHEEL_EVENT;
+ inev.ie.modifiers |= down_modifier;
+ inev.ie.arg = list3 (make_fixnum (nlines),
+ make_float (-dpyinfo->scroll.acc_x * 100),
+ make_float (-dpyinfo->scroll.acc_y * 100));
+ if (!mwheel_coalesce_scroll_events)
+ {
+ dpyinfo->scroll.acc_y = 0;
+ dpyinfo->scroll.acc_x = 0;
+ }
+ else
+ {
+ dpyinfo->scroll.acc_y -= dpyinfo->scroll.y_per_line * nlines;
+ }
+ }
+ else if (dpyinfo->scroll.acc_y <= -dpyinfo->scroll.y_per_line
+ || !mwheel_coalesce_scroll_events)
+ {
+ int nlines = -dpyinfo->scroll.acc_y / dpyinfo->scroll.y_per_line;
+ inev.ie.kind = WHEEL_EVENT;
+ inev.ie.modifiers |= up_modifier;
+ inev.ie.arg = list3 (make_fixnum (nlines),
+ make_float (-dpyinfo->scroll.acc_x * 100),
+ make_float (-dpyinfo->scroll.acc_y * 100));
+
+ if (!mwheel_coalesce_scroll_events)
+ {
+ dpyinfo->scroll.acc_y = 0;
+ dpyinfo->scroll.acc_x = 0;
+ }
+ else
+ dpyinfo->scroll.acc_y -= -dpyinfo->scroll.y_per_line * nlines;
+ }
+ else if (dpyinfo->scroll.acc_x >= dpyinfo->scroll.x_per_char
+ || !mwheel_coalesce_scroll_events)
+ {
+ int nchars = dpyinfo->scroll.acc_x / dpyinfo->scroll.x_per_char;
+ inev.ie.kind = HORIZ_WHEEL_EVENT;
+ inev.ie.modifiers |= up_modifier;
+ inev.ie.arg = list3 (make_fixnum (nchars),
+ make_float (-dpyinfo->scroll.acc_x * 100),
+ make_float (-dpyinfo->scroll.acc_y * 100));
+
+ if (mwheel_coalesce_scroll_events)
+ dpyinfo->scroll.acc_x -= dpyinfo->scroll.x_per_char * nchars;
+ else
+ {
+ dpyinfo->scroll.acc_x = 0;
+ dpyinfo->scroll.acc_y = 0;
+ }
+ }
+ else if (dpyinfo->scroll.acc_x <= -dpyinfo->scroll.x_per_char)
+ {
+ int nchars = -dpyinfo->scroll.acc_x / dpyinfo->scroll.x_per_char;
+ inev.ie.kind = HORIZ_WHEEL_EVENT;
+ inev.ie.modifiers |= down_modifier;
+ inev.ie.arg = list3 (make_fixnum (nchars),
+ make_float (-dpyinfo->scroll.acc_x * 100),
+ make_float (-dpyinfo->scroll.acc_y * 100));
+
+ if (mwheel_coalesce_scroll_events)
+ dpyinfo->scroll.acc_x -= -dpyinfo->scroll.x_per_char * nchars;
+ else
+ {
+ dpyinfo->scroll.acc_x = 0;
+ dpyinfo->scroll.acc_y = 0;
+ }
+ }
+ }
+
+ if (inev.ie.kind != NO_EVENT)
+ evq_enqueue (&inev);
+ return TRUE;
+}
+
+static void
+drag_data_received (GtkWidget * widget, GdkDragContext * context,
+ gint x, gint y,
+ GtkSelectionData * data,
+ guint info, guint time, gpointer user_data)
+{
+ struct frame *f = pgtk_any_window_to_frame (gtk_widget_get_window (widget));
+ gchar **uris = gtk_selection_data_get_uris (data);
+
+ if (uris != NULL)
+ {
+ for (int i = 0; uris[i] != NULL; i++)
+ {
+ union buffered_input_event inev;
+ Lisp_Object arg = Qnil;
+
+ EVENT_INIT (inev.ie);
+ inev.ie.kind = NO_EVENT;
+ inev.ie.arg = Qnil;
+
+ arg = list2 (Qurl, build_string (uris[i]));
+
+ inev.ie.kind = DRAG_N_DROP_EVENT;
+ inev.ie.modifiers = 0;
+ XSETINT (inev.ie.x, x);
+ XSETINT (inev.ie.y, y);
+ XSETFRAME (inev.ie.frame_or_window, f);
+ inev.ie.arg = arg;
+ inev.ie.timestamp = 0;
+
+ evq_enqueue (&inev);
+ }
+ }
+
+ gtk_drag_finish (context, TRUE, FALSE, time);
+}
+
+void
+pgtk_set_event_handler (struct frame *f)
+{
+ if (f->tooltip)
+ {
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "draw",
+ G_CALLBACK (pgtk_handle_draw), NULL);
+ return;
+ }
+
+ gtk_drag_dest_set (FRAME_GTK_WIDGET (f), GTK_DEST_DEFAULT_ALL, NULL, 0,
+ GDK_ACTION_COPY);
+ gtk_drag_dest_add_uri_targets (FRAME_GTK_WIDGET (f));
+
+ if (FRAME_GTK_OUTER_WIDGET (f))
+ {
+ g_signal_connect (G_OBJECT (FRAME_GTK_OUTER_WIDGET (f)),
+ "window-state-event", G_CALLBACK (window_state_event),
+ NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_OUTER_WIDGET (f)), "delete-event",
+ G_CALLBACK (delete_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_OUTER_WIDGET (f)), "event",
+ G_CALLBACK (pgtk_handle_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_OUTER_WIDGET (f)), "configure-event",
+ G_CALLBACK (configure_event), NULL);
+ }
+
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "map-event",
+ G_CALLBACK (map_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "size-allocate",
+ G_CALLBACK (size_allocate), f);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "key-press-event",
+ G_CALLBACK (key_press_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "key-release-event",
+ G_CALLBACK (key_release_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "focus-in-event",
+ G_CALLBACK (focus_in_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "focus-out-event",
+ G_CALLBACK (focus_out_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "enter-notify-event",
+ G_CALLBACK (enter_notify_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "leave-notify-event",
+ G_CALLBACK (leave_notify_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "motion-notify-event",
+ G_CALLBACK (motion_notify_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "button-press-event",
+ G_CALLBACK (button_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "button-release-event",
+ G_CALLBACK (button_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "scroll-event",
+ G_CALLBACK (scroll_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "selection-clear-event",
+ G_CALLBACK (pgtk_selection_lost), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "configure-event",
+ G_CALLBACK (configure_event), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "drag-data-received",
+ G_CALLBACK (drag_data_received), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "draw",
+ G_CALLBACK (pgtk_handle_draw), NULL);
+ g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "event",
+ G_CALLBACK (pgtk_handle_event), NULL);
+}
+
+static void
+my_log_handler (const gchar * log_domain, GLogLevelFlags log_level,
+ const gchar * msg, gpointer user_data)
+{
+ if (!strstr (msg, "g_set_prgname"))
+ fprintf (stderr, "%s-WARNING **: %s", log_domain, msg);
+}
+
+/* Test whether two display-name strings agree up to the dot that separates
+ the screen number from the server number. */
+static bool
+same_x_server (const char *name1, const char *name2)
+{
+ bool seen_colon = false;
+ Lisp_Object sysname = Fsystem_name ();
+ const char *system_name = SSDATA (sysname);
+ ptrdiff_t system_name_length = SBYTES (sysname);
+ ptrdiff_t length_until_period = 0;
+
+ while (system_name[length_until_period] != 0
+ && system_name[length_until_period] != '.')
+ length_until_period++;
+
+ /* Treat `unix' like an empty host name. */
+ if (!strncmp (name1, "unix:", 5))
+ name1 += 4;
+ if (!strncmp (name2, "unix:", 5))
+ name2 += 4;
+ /* Treat this host's name like an empty host name. */
+ if (!strncmp (name1, system_name, system_name_length)
+ && name1[system_name_length] == ':')
+ name1 += system_name_length;
+ if (!strncmp (name2, system_name, system_name_length)
+ && name2[system_name_length] == ':')
+ name2 += system_name_length;
+ /* Treat this host's domainless name like an empty host name. */
+ if (!strncmp (name1, system_name, length_until_period)
+ && name1[length_until_period] == ':')
+ name1 += length_until_period;
+ if (!strncmp (name2, system_name, length_until_period)
+ && name2[length_until_period] == ':')
+ name2 += length_until_period;
+
+ for (; *name1 != '\0' && *name1 == *name2; name1++, name2++)
+ {
+ if (*name1 == ':')
+ seen_colon = true;
+ if (seen_colon && *name1 == '.')
+ return true;
+ }
+ return (seen_colon
+ && (*name1 == '.' || *name1 == '\0')
+ && (*name2 == '.' || *name2 == '\0'));
+}
+
+#define GNOME_INTERFACE_SCHEMA "org.gnome.desktop.interface"
+
+static gdouble pgtk_text_scaling_factor (void)
+{
+ GSettingsSchemaSource *schema_source = g_settings_schema_source_get_default ();
+ if (schema_source != NULL)
+ {
+ GSettingsSchema *schema = g_settings_schema_source_lookup (schema_source,
+ GNOME_INTERFACE_SCHEMA, true);
+ if (schema != NULL)
+ {
+ g_settings_schema_unref (schema);
+ GSettings *set = g_settings_new (GNOME_INTERFACE_SCHEMA);
+ return g_settings_get_double (set, "text-scaling-factor");
+ }
+ }
+ return 1;
+}
+
+
+/* Open a connection to X display DISPLAY_NAME, and return
+ the structure that describes the open display.
+ If we cannot contact the display, return null. */
+
+struct pgtk_display_info *
+pgtk_term_init (Lisp_Object display_name, char *resource_name)
+{
+ GdkDisplay *dpy;
+ struct terminal *terminal;
+ struct pgtk_display_info *dpyinfo;
+ static int x_initialized = 0;
+ static unsigned x_display_id = 0;
+ static char *initial_display = NULL;
+ static dynlib_handle_ptr *handle = NULL;
+ char *dpy_name;
+ Lisp_Object lisp_dpy_name = Qnil;
+
+ block_input ();
+
+ if (!x_initialized)
+ {
+ any_help_event_p = false;
+
+ Fset_input_interrupt_mode (Qt);
+ baud_rate = 19200;
+
+#ifdef USE_CAIRO
+ gui_init_fringe (&pgtk_redisplay_interface);
+#endif
+
+ ++x_initialized;
+ }
+
+ dpy_name = SSDATA (display_name);
+ if (strlen (dpy_name) == 0 && initial_display != NULL)
+ dpy_name = initial_display;
+ lisp_dpy_name = build_string (dpy_name);
+
+ {
+#define NUM_ARGV 10
+ int argc;
+ char *argv[NUM_ARGV];
+ char **argv2 = argv;
+ guint id;
+
+ if (x_initialized++ > 1)
+ {
+ xg_display_open (dpy_name, &dpy);
+ }
+ else
+ {
+ static char display_opt[] = "--display";
+ static char name_opt[] = "--name";
+
+ for (argc = 0; argc < NUM_ARGV; ++argc)
+ argv[argc] = 0;
+
+ argc = 0;
+ argv[argc++] = initial_argv[0];
+
+ if (strlen (dpy_name) != 0)
+ {
+ argv[argc++] = display_opt;
+ argv[argc++] = dpy_name;
+ }
+
+ argv[argc++] = name_opt;
+ argv[argc++] = resource_name;
+
+ /* Work around GLib bug that outputs a faulty warning. See
+ https://bugzilla.gnome.org/show_bug.cgi?id=563627. */
+ id = g_log_set_handler ("GLib", G_LOG_LEVEL_WARNING | G_LOG_FLAG_FATAL
+ | G_LOG_FLAG_RECURSION, my_log_handler, NULL);
+
+ /* gtk_init does set_locale. Fix locale before and after. */
+ fixup_locale ();
+ unrequest_sigio (); /* See comment in x_display_ok. */
+ gtk_init (&argc, &argv2);
+ request_sigio ();
+ fixup_locale ();
+
+
+ g_log_remove_handler ("GLib", id);
+
+ xg_initialize ();
+
+ dpy = DEFAULT_GDK_DISPLAY ();
+
+ initial_display = g_strdup (gdk_display_get_name (dpy));
+ dpy_name = initial_display;
+ lisp_dpy_name = build_string (dpy_name);
+ }
+ }
+
+ /* Detect failure. */
+ if (dpy == 0)
+ {
+ unblock_input ();
+ return 0;
+ }
+
+
+ dpyinfo = xzalloc (sizeof *dpyinfo);
+ pgtk_initialize_display_info (dpyinfo);
+ terminal = pgtk_create_terminal (dpyinfo);
+
+ {
+ struct pgtk_display_info *share;
+
+ for (share = x_display_list; share; share = share->next)
+ if (same_x_server (SSDATA (XCAR (share->name_list_element)), dpy_name))
+ break;
+ if (share)
+ terminal->kboard = share->terminal->kboard;
+ else
+ {
+ terminal->kboard = allocate_kboard (Qpgtk);
+
+ /* Don't let the initial kboard remain current longer than necessary.
+ That would cause problems if a file loaded on startup tries to
+ prompt in the mini-buffer. */
+ if (current_kboard == initial_kboard)
+ current_kboard = terminal->kboard;
+ }
+ terminal->kboard->reference_count++;
+ }
+
+ /* Put this display on the chain. */
+ dpyinfo->next = x_display_list;
+ x_display_list = dpyinfo;
+
+ dpyinfo->name_list_element = Fcons (lisp_dpy_name, Qnil);
+ dpyinfo->gdpy = dpy;
+
+ /* https://lists.gnu.org/r/emacs-devel/2015-11/msg00194.html */
+ dpyinfo->smallest_font_height = 1;
+ dpyinfo->smallest_char_width = 1;
+
+ /* Set the name of the terminal. */
+ terminal->name = xlispstrdup (lisp_dpy_name);
+
+ Lisp_Object system_name = Fsystem_name ();
+ ptrdiff_t nbytes;
+ if (INT_ADD_WRAPV (SBYTES (Vinvocation_name), SBYTES (system_name) + 2,
+ &nbytes))
+ memory_full (SIZE_MAX);
+ dpyinfo->x_id = ++x_display_id;
+ dpyinfo->x_id_name = xmalloc (nbytes);
+ char *nametail = lispstpcpy (dpyinfo->x_id_name, Vinvocation_name);
+ *nametail++ = '@';
+ lispstpcpy (nametail, system_name);
+
+ /* Figure out which modifier bits mean what. */
+ x_find_modifier_meanings (dpyinfo);
+
+ /* Get the scroll bar cursor. */
+ /* We must create a GTK cursor, it is required for GTK widgets. */
+ dpyinfo->xg_cursor = xg_create_default_cursor (dpyinfo->gdpy);
+
+ dpyinfo->vertical_scroll_bar_cursor
+ = gdk_cursor_new_for_display (dpyinfo->gdpy, GDK_SB_V_DOUBLE_ARROW);
+
+ dpyinfo->horizontal_scroll_bar_cursor
+ = gdk_cursor_new_for_display (dpyinfo->gdpy, GDK_SB_H_DOUBLE_ARROW);
+
+ dpyinfo->icon_bitmap_id = -1;
+
+ reset_mouse_highlight (&dpyinfo->mouse_highlight);
+
+ {
+ GdkScreen *gscr = gdk_display_get_default_screen (dpyinfo->gdpy);
+
+ gdouble dpi = gdk_screen_get_resolution (gscr);
+ if (dpi < 0)
+ dpi = 96.0;
+
+ dpi *= pgtk_text_scaling_factor ();
+ dpyinfo->resx = dpi;
+ dpyinfo->resy = dpi;
+ }
+
+ /* smooth scroll setting */
+ dpyinfo->scroll.x_per_char = 2;
+ dpyinfo->scroll.y_per_line = 2;
+
+ dpyinfo->connection = -1;
+
+ if (!handle)
+ handle = dynlib_open (NULL);
+
+#ifdef GDK_WINDOWING_X11
+ if (!strcmp (G_OBJECT_TYPE_NAME (dpy), "GdkX11Display") && handle)
+ {
+ void *(*gdk_x11_display_get_xdisplay) (GdkDisplay *)
+ = dynlib_sym (handle, "gdk_x11_display_get_xdisplay");
+ int (*x_connection_number) (void *)
+ = dynlib_sym (handle, "XConnectionNumber");
+
+ if (x_connection_number
+ && gdk_x11_display_get_xdisplay)
+ dpyinfo->connection
+ = x_connection_number (gdk_x11_display_get_xdisplay (dpy));
+ }
+#endif
+
+#ifdef GDK_WINDOWING_WAYLAND
+ if (GDK_IS_WAYLAND_DISPLAY (dpy) && handle)
+ {
+ struct wl_display *wl_dpy = gdk_wayland_display_get_wl_display (dpy);
+ int (*display_get_fd) (struct wl_display *)
+ = dynlib_sym (handle, "wl_display_get_fd");
+
+ if (display_get_fd)
+ dpyinfo->connection = display_get_fd (wl_dpy);
+ }
+#endif
+
+ if (dpyinfo->connection >= 0)
+ {
+ add_keyboard_wait_descriptor (dpyinfo->connection);
+#ifdef F_SETOWN
+ fcntl (dpyinfo->connection, F_SETOWN, getpid ());
+#endif /* ! defined (F_SETOWN) */
+
+ if (interrupt_input)
+ init_sigio (dpyinfo->connection);
+ }
+
+ x_setup_pointer_blanking (dpyinfo);
+
+ xsettings_initialize (dpyinfo);
+
+ pgtk_selection_init ();
+
+ pgtk_im_init (dpyinfo);
+
+ unblock_input ();
+
+ return dpyinfo;
+}
+
+/* Get rid of display DPYINFO, deleting all frames on it,
+ and without sending any more commands to the X server. */
+
+static void
+pgtk_delete_display (struct pgtk_display_info *dpyinfo)
+{
+ struct terminal *t;
+
+ /* Close all frames and delete the generic struct terminal for this
+ X display. */
+ for (t = terminal_list; t; t = t->next_terminal)
+ if (t->type == output_pgtk && t->display_info.pgtk == dpyinfo)
+ {
+ delete_terminal (t);
+ break;
+ }
+
+ if (x_display_list == dpyinfo)
+ x_display_list = dpyinfo->next;
+ else
+ {
+ struct pgtk_display_info *tail;
+
+ for (tail = x_display_list; tail; tail = tail->next)
+ if (tail->next == dpyinfo)
+ tail->next = tail->next->next;
+ }
+
+ xfree (dpyinfo);
+}
+
+char *
+pgtk_xlfd_to_fontname (const char *xlfd)
+/* --------------------------------------------------------------------------
+ Convert an X font name (XLFD) to an Gtk font name.
+ Only family is used.
+ The string returned is temporarily allocated.
+ -------------------------------------------------------------------------- */
+{
+ char *name = xmalloc (180);
+
+ if (!strncmp (xlfd, "--", 2))
+ {
+ if (sscanf (xlfd, "--%179[^-]-", name) != 1)
+ name[0] = '\0';
+ }
+ else
+ {
+ if (sscanf (xlfd, "-%*[^-]-%179[^-]-", name) != 1)
+ name[0] = '\0';
+ }
+
+ /* stopgap for malformed XLFD input */
+ if (strlen (name) == 0)
+ strcpy (name, "Monospace");
+
+ return name;
+}
+
+bool
+pgtk_defined_color (struct frame *f,
+ const char *name,
+ Emacs_Color * color_def, bool alloc, bool makeIndex)
+/* --------------------------------------------------------------------------
+ Return true if named color found, and set color_def rgb accordingly.
+ If makeIndex and alloc are nonzero put the color in the color_table,
+ and set color_def pixel to the resulting index.
+ If makeIndex is zero, set color_def pixel to ARGB.
+ Return false if not found
+ -------------------------------------------------------------------------- */
+{
+ int r;
+
+ block_input ();
+ r = xg_check_special_colors (f, name, color_def);
+ if (!r)
+ r = pgtk_parse_color (f, name, color_def);
+ unblock_input ();
+ return r;
+}
+
+/* On frame F, translate the color name to RGB values. Use cached
+ information, if possible.
+
+ Note that there is currently no way to clean old entries out of the
+ cache. However, it is limited to names in the server's database,
+ and names we've actually looked up; list-colors-display is probably
+ the most color-intensive case we're likely to hit. */
+
+int
+pgtk_parse_color (struct frame *f, const char *color_name,
+ Emacs_Color * color)
+{
+ GdkRGBA rgba;
+ if (gdk_rgba_parse (&rgba, color_name))
+ {
+ color->red = rgba.red * 65535;
+ color->green = rgba.green * 65535;
+ color->blue = rgba.blue * 65535;
+ color->pixel =
+ (color->red >> 8) << 16 |
+ (color->green >> 8) << 8 |
+ (color->blue >> 8) << 0;
+ return 1;
+ }
+ return 0;
+}
+
+/* On frame F, translate pixel colors to RGB values for the NCOLORS
+ colors in COLORS. On W32, we no longer try to map colors to
+ a palette. */
+void
+pgtk_query_colors (struct frame *f, Emacs_Color * colors, int ncolors)
+{
+ int i;
+
+ for (i = 0; i < ncolors; i++)
+ {
+ unsigned long pixel = colors[i].pixel;
+ /* Convert to a 16 bit value in range 0 - 0xffff. */
+#define GetRValue(p) (((p) >> 16) & 0xff)
+#define GetGValue(p) (((p) >> 8) & 0xff)
+#define GetBValue(p) (((p) >> 0) & 0xff)
+ colors[i].red = GetRValue (pixel) * 257;
+ colors[i].green = GetGValue (pixel) * 257;
+ colors[i].blue = GetBValue (pixel) * 257;
+ }
+}
+
+void
+pgtk_query_color (struct frame *f, Emacs_Color * color)
+{
+ pgtk_query_colors (f, color, 1);
+}
+
+void
+pgtk_clear_area (struct frame *f, int x, int y, int width, int height)
+{
+ cairo_t *cr;
+
+ eassert (width > 0 && height > 0);
+
+ cr = pgtk_begin_cr_clip (f);
+ pgtk_set_cr_source_with_color (f, FRAME_X_OUTPUT (f)->background_color);
+ cairo_rectangle (cr, x, y, width, height);
+ cairo_fill (cr);
+ pgtk_end_cr_clip (f);
+}
+
+
+void
+syms_of_pgtkterm (void)
+{
+ /* from 23+ we need to tell emacs what modifiers there are.. */
+ DEFSYM (Qmodifier_value, "modifier-value");
+ DEFSYM (Qalt, "alt");
+ DEFSYM (Qhyper, "hyper");
+ DEFSYM (Qmeta, "meta");
+ DEFSYM (Qsuper, "super");
+ DEFSYM (Qcontrol, "control");
+ DEFSYM (QUTF8_STRING, "UTF8_STRING");
+
+ DEFSYM (Qfile, "file");
+ DEFSYM (Qurl, "url");
+
+ DEFSYM (Qlatin_1, "latin-1");
+
+ xg_default_icon_file =
+ build_pure_c_string ("icons/hicolor/scalable/apps/emacs.svg");
+ staticpro (&xg_default_icon_file);
+
+ DEFSYM (Qx_gtk_map_stock, "x-gtk-map-stock");
+
+
+ Fput (Qalt, Qmodifier_value, make_fixnum (alt_modifier));
+ Fput (Qhyper, Qmodifier_value, make_fixnum (hyper_modifier));
+ Fput (Qmeta, Qmodifier_value, make_fixnum (meta_modifier));
+ Fput (Qsuper, Qmodifier_value, make_fixnum (super_modifier));
+ Fput (Qcontrol, Qmodifier_value, make_fixnum (ctrl_modifier));
+
+ 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'. */ );
+ 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'. */ );
+ 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'. */ );
+ 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'. */ );
+ 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'. */ );
+ Vx_super_keysym = Qnil;
+
+ /* TODO: move to common code */
+ DEFVAR_LISP ("x-toolkit-scroll-bars", Vx_toolkit_scroll_bars,
+ doc: /* Which toolkit scroll bars Emacs uses, if any.
+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 or Nextstep, the value is t. */ );
+ /* Vx_toolkit_scroll_bars = Qt; */
+ Vx_toolkit_scroll_bars = intern_c_string ("gtk");
+
+ DEFVAR_BOOL ("x-use-underline-position-properties", x_use_underline_position_properties,
+ doc: /*Non-nil means make use of UNDERLINE_POSITION font properties.
+A value of nil means ignore them. If you encounter fonts with bogus
+UNDERLINE_POSITION font properties, for example 7x13 on XFree prior
+to 4.1, set this to nil. */);
+ x_use_underline_position_properties = 0;
+
+ DEFVAR_BOOL ("x-underline-at-descent-line", x_underline_at_descent_line,
+ doc: /* Non-nil means to draw the underline at the same place as the descent line.
+A value of nil means to draw the underline according to the value of the
+variable `x-use-underline-position-properties', which is usually at the
+baseline level. The default value is nil. */);
+ x_underline_at_descent_line = 0;
+
+ DEFVAR_BOOL ("x-gtk-use-window-move", x_gtk_use_window_move,
+ doc: /* Non-nil means rely on gtk_window_move to set frame positions.
+If this variable is t (the default), the GTK build uses the function
+gtk_window_move to set or store frame positions and disables some time
+consuming frame position adjustments. In newer versions of GTK, Emacs
+always uses gtk_window_move and ignores the value of this variable. */);
+ x_gtk_use_window_move = true;
+
+
+ DEFVAR_LISP ("pgtk-wait-for-event-timeout", Vpgtk_wait_for_event_timeout,
+ doc: /* How long to wait for X events.
+
+Emacs will wait up to this many seconds to receive X events after
+making changes which affect the state of the graphical interface.
+Under some window managers 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. */);
+ Vpgtk_wait_for_event_timeout = make_float (0.1);
+
+ 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);
+
+ window_being_scrolled = Qnil;
+ staticpro (&window_being_scrolled);
+
+ /* Tell Emacs about this window system. */
+ Fprovide (Qpgtk, Qnil);
+}
+
+/* Cairo does not allow resizing a surface/context after it is
+ * created, so we need to trash the old context, create a new context
+ * on the next cr_clip_begin with the new dimensions and request a
+ * re-draw.
+ *
+ * This Will leave the active context available to present on screen
+ * until a redrawn frame is completed.
+ */
+void
+pgtk_cr_update_surface_desired_size (struct frame *f, int width, int height, bool force)
+{
+ if (FRAME_CR_SURFACE_DESIRED_WIDTH (f) != width
+ || FRAME_CR_SURFACE_DESIRED_HEIGHT (f) != height
+ || force)
+ {
+ pgtk_cr_destroy_frame_context (f);
+ FRAME_CR_SURFACE_DESIRED_WIDTH (f) = width;
+ FRAME_CR_SURFACE_DESIRED_HEIGHT (f) = height;
+ SET_FRAME_GARBAGED (f);
+ }
+}
+
+
+cairo_t *
+pgtk_begin_cr_clip (struct frame *f)
+{
+ cairo_t *cr = FRAME_CR_CONTEXT (f);
+
+ if (!cr)
+ {
+ cairo_surface_t *surface =
+ gdk_window_create_similar_surface (gtk_widget_get_window
+ (FRAME_GTK_WIDGET (f)),
+ CAIRO_CONTENT_COLOR_ALPHA,
+ FRAME_CR_SURFACE_DESIRED_WIDTH (f),
+ FRAME_CR_SURFACE_DESIRED_HEIGHT
+ (f));
+
+ cr = FRAME_CR_CONTEXT (f) = cairo_create (surface);
+ cairo_surface_destroy (surface);
+ }
+
+ cairo_save (cr);
+
+ return cr;
+}
+
+void
+pgtk_end_cr_clip (struct frame *f)
+{
+ cairo_restore (FRAME_CR_CONTEXT (f));
+}
+
+void
+pgtk_set_cr_source_with_gc_foreground (struct frame *f, Emacs_GC * gc)
+{
+ pgtk_set_cr_source_with_color (f, gc->foreground);
+}
+
+void
+pgtk_set_cr_source_with_gc_background (struct frame *f, Emacs_GC * gc)
+{
+ pgtk_set_cr_source_with_color (f, gc->background);
+}
+
+void
+pgtk_set_cr_source_with_color (struct frame *f, unsigned long color)
+{
+ Emacs_Color col;
+ col.pixel = color;
+ pgtk_query_color (f, &col);
+ cairo_set_source_rgb (FRAME_CR_CONTEXT (f), col.red / 65535.0,
+ col.green / 65535.0, col.blue / 65535.0);
+}
+
+void
+pgtk_cr_draw_frame (cairo_t * cr, struct frame *f)
+{
+ cairo_set_source_surface (cr, FRAME_CR_SURFACE (f), 0, 0);
+ cairo_paint (cr);
+}
+
+static cairo_status_t
+pgtk_cr_accumulate_data (void *closure, const unsigned char *data,
+ unsigned int length)
+{
+ Lisp_Object *acc = (Lisp_Object *) closure;
+
+ *acc = Fcons (make_unibyte_string ((char const *) data, length), *acc);
+
+ return CAIRO_STATUS_SUCCESS;
+}
+
+void
+pgtk_cr_destroy_frame_context (struct frame *f)
+{
+ if (FRAME_CR_CONTEXT (f) != NULL)
+ {
+ cairo_destroy (FRAME_CR_CONTEXT (f));
+ FRAME_CR_CONTEXT (f) = NULL;
+ }
+}
+
+static void
+pgtk_cr_destroy (void *cr)
+{
+ block_input ();
+ cairo_destroy (cr);
+ unblock_input ();
+}
+
+
+
+Lisp_Object
+pgtk_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type)
+{
+ struct frame *f;
+ cairo_surface_t *surface;
+ cairo_t *cr;
+ int width, height;
+ void (*surface_set_size_func) (cairo_surface_t *, double, double) = NULL;
+ Lisp_Object acc = Qnil;
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ specbind (Qredisplay_dont_pause, Qt);
+ redisplay_preserve_echo_area (31);
+
+ f = XFRAME (XCAR (frames));
+ frames = XCDR (frames);
+ width = FRAME_PIXEL_WIDTH (f);
+ height = FRAME_PIXEL_HEIGHT (f);
+
+ block_input ();
+#ifdef CAIRO_HAS_PDF_SURFACE
+ if (surface_type == CAIRO_SURFACE_TYPE_PDF)
+ {
+ surface = cairo_pdf_surface_create_for_stream (pgtk_cr_accumulate_data, &acc,
+ width, height);
+ surface_set_size_func = cairo_pdf_surface_set_size;
+ }
+ else
+#endif
+#ifdef CAIRO_HAS_PNG_FUNCTIONS
+ if (surface_type == CAIRO_SURFACE_TYPE_IMAGE)
+ surface = cairo_image_surface_create (CAIRO_FORMAT_RGB24, width, height);
+ else
+#endif
+#ifdef CAIRO_HAS_PS_SURFACE
+ if (surface_type == CAIRO_SURFACE_TYPE_PS)
+ {
+ surface = cairo_ps_surface_create_for_stream (pgtk_cr_accumulate_data, &acc,
+ width, height);
+ surface_set_size_func = cairo_ps_surface_set_size;
+ }
+ else
+#endif
+#ifdef CAIRO_HAS_SVG_SURFACE
+ if (surface_type == CAIRO_SURFACE_TYPE_SVG)
+ surface = cairo_svg_surface_create_for_stream (pgtk_cr_accumulate_data, &acc,
+ width, height);
+ else
+#endif
+ abort ();
+
+ cr = cairo_create (surface);
+ cairo_surface_destroy (surface);
+ record_unwind_protect_ptr (pgtk_cr_destroy, cr);
+
+ while (1)
+ {
+ cairo_t *saved_cr = FRAME_CR_CONTEXT (f);
+ FRAME_CR_CONTEXT (f) = cr;
+ pgtk_clear_area (f, 0, 0, width, height);
+ expose_frame (f, 0, 0, width, height);
+ FRAME_CR_CONTEXT (f) = saved_cr;
+
+ if (NILP (frames))
+ break;
+
+ cairo_surface_show_page (surface);
+ f = XFRAME (XCAR (frames));
+ frames = XCDR (frames);
+ width = FRAME_PIXEL_WIDTH (f);
+ height = FRAME_PIXEL_HEIGHT (f);
+ if (surface_set_size_func)
+ (*surface_set_size_func) (surface, width, height);
+
+ unblock_input ();
+ maybe_quit ();
+ block_input ();
+ }
+
+#ifdef CAIRO_HAS_PNG_FUNCTIONS
+ if (surface_type == CAIRO_SURFACE_TYPE_IMAGE)
+ {
+ cairo_surface_flush (surface);
+ cairo_surface_write_to_png_stream (surface, pgtk_cr_accumulate_data, &acc);
+ }
+#endif
+ unblock_input ();
+
+ unbind_to (count, Qnil);
+
+ return CALLN (Fapply, intern ("concat"), Fnreverse (acc));
+}
+
+
+void
+init_pgtkterm (void)
+{
+}
diff --git a/src/pgtkterm.h b/src/pgtkterm.h
new file mode 100644
index 00000000000..e76411cf021
--- /dev/null
+++ b/src/pgtkterm.h
@@ -0,0 +1,664 @@
+/* Definitions and headers for communication with pure Gtk+3.
+ Copyright (C) 1989, 1993, 2005, 2008-2020 Free Software Foundation,
+ Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+
+
+#include "dispextern.h"
+#include "frame.h"
+#include "character.h"
+#include "font.h"
+#include "sysselect.h"
+
+#ifdef HAVE_PGTK
+
+#include <gtk/gtk.h>
+
+#ifdef CAIRO_HAS_PDF_SURFACE
+#include <cairo-pdf.h>
+#endif
+#ifdef CAIRO_HAS_PS_SURFACE
+#include <cairo-ps.h>
+#endif
+#ifdef CAIRO_HAS_SVG_SURFACE
+#include <cairo-svg.h>
+#endif
+
+/* could use list to store these, but rest of emacs has a big infrastructure
+ for managing a table of bitmap "records" */
+struct pgtk_bitmap_record
+{
+ void *img;
+ char *file;
+ int refcount;
+ int height, width, depth;
+ cairo_pattern_t *pattern;
+};
+
+#define RGB_TO_ULONG(r, g, b) (((r) << 16) | ((g) << 8) | (b))
+#define ARGB_TO_ULONG(a, r, g, b) (((a) << 24) | ((r) << 16) | ((g) << 8) | (b))
+
+#define ALPHA_FROM_ULONG(color) ((color) >> 24)
+#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff)
+#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff)
+#define BLUE_FROM_ULONG(color) ((color) & 0xff)
+
+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 from `x_window' down will not be traced by the GC. */
+
+ /* The X window representing this scroll bar. */
+ 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 co-ordinate 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;
+
+#if defined (USE_TOOLKIT_SCROLL_BARS) && defined (USE_LUCID)
+ /* Last scroll bar part seen in xaw_jump_callback and xaw_scroll_callback. */
+ enum scroll_bar_part last_seen_part;
+#endif
+
+#if defined (USE_TOOLKIT_SCROLL_BARS) && !defined (USE_GTK)
+ /* Last value of whole for horizontal scrollbars. */
+ int whole;
+#endif
+
+ /* True if the scroll bar is horizontal. */
+ bool horizontal;
+};
+
+
+/* init'd in pgtk_initialize_display_info () */
+struct pgtk_display_info
+{
+ /* Chain of all pgtk_display_info structures. */
+ struct pgtk_display_info *next;
+
+ /* The generic display parameters corresponding to this PGTK display. */
+ struct terminal *terminal;
+
+ /* This says how to access this display in Gdk. */
+ GdkDisplay *gdpy;
+
+ /* This is a cons cell of the form (NAME . FONT-LIST-CACHE). */
+ Lisp_Object name_list_element;
+
+ /* Number of frames that are on this display. */
+ int reference_count;
+
+ /* Logical identifier of this display. */
+ unsigned x_id;
+
+ /* Default name for all frames on this display. */
+ char *x_id_name;
+
+ /* The number of fonts loaded. */
+ int n_fonts;
+
+ /* 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;
+
+ struct pgtk_bitmap_record *bitmaps;
+ ptrdiff_t bitmaps_size;
+ ptrdiff_t bitmaps_last;
+
+ /* DPI resolution of this screen */
+ double resx, resy;
+
+ /* Mask of things that cause the mouse to be grabbed */
+ int grabbed;
+
+ int n_planes;
+
+ int color_p;
+
+ /* Emacs bitmap-id of the default icon bitmap for this frame.
+ Or -1 if none has been allocated yet. */
+ ptrdiff_t icon_bitmap_id;
+
+ Window root_window;
+
+ /* Xism */
+ XrmDatabase rdb;
+
+ /* The cursor to use for vertical scroll bars. */
+ Emacs_Cursor vertical_scroll_bar_cursor;
+
+ /* The cursor to use for horizontal scroll bars. */
+ Emacs_Cursor horizontal_scroll_bar_cursor;
+
+ /* Information about the range of text currently shown in
+ mouse-face. */
+ Mouse_HLInfo mouse_highlight;
+
+ struct frame *highlight_frame;
+ struct frame *x_focus_frame;
+
+ /* The last frame mentioned in a FocusIn or FocusOut event. This is
+ separate from x_focus_frame, because whether or not LeaveNotify
+ events cause us to lose focus depends on whether or not we have
+ received a FocusIn event for it. */
+ struct frame *x_focus_event_frame;
+
+ /* The frame where the mouse was last time we reported a mouse event. */
+ struct frame *last_mouse_frame;
+
+ /* The frame where the mouse was last time we reported a mouse motion. */
+ 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. */
+ int last_mouse_motion_x;
+ int last_mouse_motion_y;
+
+ /* Where the mouse was last time we reported a mouse position. */
+ XRectangle last_mouse_glyph;
+
+ /* Time of last mouse movement. */
+ Time last_mouse_movement_time;
+
+ /* The scroll bar in which the last motion event occurred. */
+ void *last_mouse_scroll_bar;
+
+ /* The invisible cursor used for pointer blanking.
+ Unused if this display supports Xfixes extension. */
+ Emacs_Cursor invisible_cursor;
+
+ /* Function used to toggle pointer visibility on this display. */
+ void (*toggle_visible_pointer) (struct frame *, bool);
+
+ /* The GDK cursor for scroll bars and popup menus. */
+ GdkCursor *xg_cursor;
+
+
+ /* The frame where the mouse was last time we reported a mouse position. */
+ struct frame *last_mouse_glyph_frame;
+
+ /* Modifier masks in gdk */
+ int meta_mod_mask, alt_mod_mask, super_mod_mask, hyper_mod_mask;
+
+ /* The last click event. */
+ GdkEvent *last_click_event;
+
+ /* input method */
+ struct
+ {
+ GtkIMContext *context;
+ struct frame *focused_frame;
+ } im;
+
+ struct
+ {
+ double acc_x, acc_y;
+ double x_per_char, y_per_line;
+ } scroll;
+
+ int connection;
+};
+
+/* This is a chain of structures for all the PGTK displays currently in use. */
+extern struct pgtk_display_info *x_display_list;
+
+struct pgtk_output
+{
+#if 0
+ void *view;
+ void *miniimage;
+#endif
+ unsigned long foreground_color;
+ unsigned long background_color;
+ void *toolbar;
+
+ /* Cursors */
+ Emacs_Cursor current_cursor;
+ Emacs_Cursor text_cursor;
+ Emacs_Cursor nontext_cursor;
+ Emacs_Cursor modeline_cursor;
+ Emacs_Cursor hand_cursor;
+ Emacs_Cursor hourglass_cursor;
+ Emacs_Cursor horizontal_drag_cursor;
+ Emacs_Cursor vertical_drag_cursor;
+ Emacs_Cursor left_edge_cursor;
+ Emacs_Cursor top_left_corner_cursor;
+ Emacs_Cursor top_edge_cursor;
+ Emacs_Cursor top_right_corner_cursor;
+ Emacs_Cursor right_edge_cursor;
+ Emacs_Cursor bottom_right_corner_cursor;
+ Emacs_Cursor bottom_edge_cursor;
+ Emacs_Cursor bottom_left_corner_cursor;
+
+ /* PGTK-specific */
+ Emacs_Cursor current_pointer;
+
+ /* border color */
+ unsigned long border_pixel;
+ GtkCssProvider *border_color_css_provider;
+
+ /* scrollbar color */
+ GtkCssProvider *scrollbar_foreground_css_provider;
+ GtkCssProvider *scrollbar_background_css_provider;
+
+ /* Widget whose cursor is hourglass_cursor. This widget is temporarily
+ mapped to display an hourglass cursor. */
+ GtkWidget *hourglass_widget;
+
+ Emacs_GC cursor_xgcv;
+
+ /* lord knows why Emacs needs to know about our Window ids.. */
+ Window window_desc, parent_desc;
+ char explicit_parent;
+
+ /* If >=0, a bitmap index. The indicated bitmap is used for the
+ icon. */
+ ptrdiff_t icon_bitmap;
+
+ struct font *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; /* only used with font_backend */
+
+ unsigned long mouse_color;
+ unsigned long cursor_color;
+ unsigned long cursor_foreground_color;
+
+ int icon_top;
+ int icon_left;
+
+ /* The size of the extra width currently allotted for vertical
+ scroll bars, in pixels. */
+ int vertical_scroll_bar_extra;
+
+ /* The height of the titlebar decoration (included in PGTKWindow's frame). */
+ int titlebar_height;
+
+ /* The height of the toolbar if displayed, else 0. */
+ int toolbar_height;
+
+ /* This is the Emacs structure for the PGTK display this frame is on. */
+ struct pgtk_display_info *display_info;
+
+ /* Non-zero if we are zooming (maximizing) the frame. */
+ int zooming;
+
+ /* Non-zero if we are doing an animation, e.g. toggling the tool bar. */
+ int in_animation;
+
+ /* The last size hints set. */
+ GdkGeometry size_hints;
+ long hint_flags;
+ int preferred_width, preferred_height;
+
+ /* The widget of this screen. This is the window of a top widget. */
+ GtkWidget *widget;
+ /* The widget of the edit portion of this screen; the window in
+ "window_desc" is inside of this. */
+ GtkWidget *edit_widget;
+ /* The widget used for laying out widgets vertically. */
+ GtkWidget *vbox_widget;
+ /* The widget used for laying out widgets horizontally. */
+ GtkWidget *hbox_widget;
+ /* The menubar in this frame. */
+ GtkWidget *menubar_widget;
+ /* The tool bar in this frame */
+ GtkWidget *toolbar_widget;
+ /* True if tool bar is packed into the hbox widget (i.e. vertical). */
+ bool_bf toolbar_in_hbox:1;
+ bool_bf toolbar_is_packed:1;
+
+ GtkTooltip *ttip_widget;
+ GtkWidget *ttip_lbl;
+ GtkWindow *ttip_window;
+
+ /* Height of menu bar widget, in pixels. This value
+ is not meaningful if the menubar is turned off. */
+ int menubar_height;
+
+ /* Height of tool bar widget, in pixels. top_height is used if tool bar
+ at top, bottom_height if tool bar is at the bottom.
+ Zero if not using an external tool bar or if tool bar is vertical. */
+ int toolbar_top_height, toolbar_bottom_height;
+
+ /* Width of tool bar widget, in pixels. left_width is used if tool bar
+ at left, right_width if tool bar is at the right.
+ Zero if not using an external tool bar or if tool bar is horizontal. */
+ int toolbar_left_width, toolbar_right_width;
+
+#ifdef USE_CAIRO
+ /* Cairo drawing contexts. */
+ cairo_t *cr_context, *cr_active;
+ int cr_surface_desired_width, cr_surface_desired_height;
+ /* Cairo surface for double buffering */
+ cairo_surface_t *cr_surface_visible_bell;
+#endif
+ struct atimer *atimer_visible_bell;
+
+ int has_been_visible;
+
+ /* Relief GCs, colors etc. */
+ struct relief
+ {
+ Emacs_GC xgcv;
+ 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;
+
+ /* Keep track of focus. May be EXPLICIT if we received a FocusIn for this
+ frame, or IMPLICIT if we received an EnterNotify.
+ FocusOut and LeaveNotify clears EXPLICIT/IMPLICIT. */
+ int focus_state;
+
+ /* Keep track of scale factor. If monitor's scale factor is changed, or
+ monitor is switched and scale factor is changed, then recreate cairo_t
+ and cairo_surface_t. I need GTK's such signal, but there isn't, so
+ I watch it periodically with atimer. */
+ double watched_scale_factor;
+ struct atimer *scale_factor_atimer;
+};
+
+/* this dummy decl needed to support TTYs */
+struct x_output
+{
+ int unused;
+};
+
+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
+};
+
+/* This gives the pgtk_display_info structure for the display F is on. */
+#define FRAME_X_OUTPUT(f) ((f)->output_data.pgtk)
+#define FRAME_OUTPUT_DATA(f) FRAME_X_OUTPUT (f)
+
+#define FRAME_DISPLAY_INFO(f) (FRAME_X_OUTPUT (f)->display_info)
+#define FRAME_FOREGROUND_COLOR(f) (FRAME_X_OUTPUT (f)->foreground_color)
+#define FRAME_BACKGROUND_COLOR(f) (FRAME_X_OUTPUT (f)->background_color)
+#define FRAME_CURSOR_COLOR(f) (FRAME_X_OUTPUT (f)->cursor_color)
+#define FRAME_POINTER_TYPE(f) (FRAME_X_OUTPUT (f)->current_pointer)
+#define FRAME_FONT(f) (FRAME_X_OUTPUT (f)->font)
+#define FRAME_GTK_OUTER_WIDGET(f) (FRAME_X_OUTPUT (f)->widget)
+#define FRAME_GTK_WIDGET(f) (FRAME_X_OUTPUT (f)->edit_widget)
+#define FRAME_WIDGET(f) (FRAME_GTK_OUTER_WIDGET (f) ? \
+ FRAME_GTK_OUTER_WIDGET (f) : \
+ FRAME_GTK_WIDGET (f))
+
+/* aliases */
+#define FRAME_PGTK_VIEW(f) FRAME_GTK_WIDGET (f)
+#define FRAME_X_WINDOW(f) FRAME_GTK_OUTER_WIDGET (f)
+#define FRAME_NATIVE_WINDOW(f) GTK_WINDOW (FRAME_X_WINDOW (f))
+
+#define FRAME_X_DISPLAY(f) (FRAME_DISPLAY_INFO (f)->gdpy)
+
+#define DEFAULT_GDK_DISPLAY() gdk_display_get_default ()
+
+/* Turning a lisp vector value into a pointer to a struct scroll_bar. */
+#define XSCROLL_BAR(vec) ((struct scroll_bar *) XVECTOR (vec))
+
+#define PGTK_FACE_FOREGROUND(f) ((f)->foreground)
+#define PGTK_FACE_BACKGROUND(f) ((f)->background)
+#define FRAME_DEFAULT_FACE(f) FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID)
+
+/* Compute pixel height of the frame's titlebar. */
+#define FRAME_PGTK_TITLEBAR_HEIGHT(f) 0
+
+/* Compute pixel size for vertical scroll bars */
+#define PGTK_SCROLL_BAR_WIDTH(f) \
+ (FRAME_HAS_VERTICAL_SCROLL_BARS (f) \
+ ? rint (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0 \
+ ? FRAME_CONFIG_SCROLL_BAR_WIDTH (f) \
+ : (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f))) \
+ : 0)
+
+/* Compute pixel size for horizontal scroll bars */
+#define PGTK_SCROLL_BAR_HEIGHT(f) \
+ (FRAME_HAS_HORIZONTAL_SCROLL_BARS (f) \
+ ? rint (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) > 0 \
+ ? FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) \
+ : (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f))) \
+ : 0)
+
+/* Difference btwn char-column-calculated and actual SB widths.
+ This is only a concern for rendering when SB on left. */
+#define PGTK_SCROLL_BAR_ADJUST(w, f) \
+ (WINDOW_HAS_VERTICAL_SCROLL_BAR_ON_LEFT (w) ? \
+ (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f) \
+ - PGTK_SCROLL_BAR_WIDTH (f)) : 0)
+
+/* Difference btwn char-line-calculated and actual SB heights.
+ This is only a concern for rendering when SB on top. */
+#define PGTK_SCROLL_BAR_ADJUST_HORIZONTALLY(w, f) \
+ (WINDOW_HAS_HORIZONTAL_SCROLL_BARS (w) ? \
+ (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f) \
+ - PGTK_SCROLL_BAR_HEIGHT (f)) : 0)
+
+#define FRAME_MENUBAR_HEIGHT(f) (FRAME_X_OUTPUT (f)->menubar_height)
+
+/* Calculate system coordinates of the left and top of the parent
+ window or, if there is no parent window, the screen. */
+#define PGTK_PARENT_WINDOW_LEFT_POS(f) \
+ (FRAME_PARENT_FRAME (f) != NULL \
+ ? [[FRAME_PGTK_VIEW (f) window] parentWindow].frame.origin.x : 0)
+#define PGTK_PARENT_WINDOW_TOP_POS(f) \
+ (FRAME_PARENT_FRAME (f) != NULL \
+ ? ([[FRAME_PGTK_VIEW (f) window] parentWindow].frame.origin.y \
+ + [[FRAME_PGTK_VIEW (f) window] parentWindow].frame.size.height \
+ - FRAME_PGTK_TITLEBAR_HEIGHT (FRAME_PARENT_FRAME (f))) \
+ : [[[PGTKScreen screepgtk] objectAtIndex: 0] frame].size.height)
+
+#define FRAME_PGTK_FONT_TABLE(f) (FRAME_DISPLAY_INFO (f)->font_table)
+
+#define FRAME_TOOLBAR_TOP_HEIGHT(f) ((f)->output_data.pgtk->toolbar_top_height)
+#define FRAME_TOOLBAR_BOTTOM_HEIGHT(f) \
+ ((f)->output_data.pgtk->toolbar_bottom_height)
+#define FRAME_TOOLBAR_HEIGHT(f) \
+ (FRAME_TOOLBAR_TOP_HEIGHT (f) + FRAME_TOOLBAR_BOTTOM_HEIGHT (f))
+#define FRAME_TOOLBAR_LEFT_WIDTH(f) ((f)->output_data.pgtk->toolbar_left_width)
+#define FRAME_TOOLBAR_RIGHT_WIDTH(f) ((f)->output_data.pgtk->toolbar_right_width)
+#define FRAME_TOOLBAR_WIDTH(f) \
+ (FRAME_TOOLBAR_LEFT_WIDTH (f) + FRAME_TOOLBAR_RIGHT_WIDTH (f))
+
+#define FRAME_FONTSET(f) (FRAME_X_OUTPUT (f)->fontset)
+
+#define FRAME_BASELINE_OFFSET(f) (FRAME_X_OUTPUT (f)->baseline_offset)
+#define BLACK_PIX_DEFAULT(f) 0x000000
+#define WHITE_PIX_DEFAULT(f) 0xFFFFFF
+
+/* First position where characters can be shown (instead of scrollbar, if
+ it is on left. */
+#define FIRST_CHAR_POSITION(f) \
+ (! (FRAME_HAS_VERTICAL_SCROLL_BARS_ON_LEFT (f)) ? 0 \
+ : FRAME_SCROLL_BAR_COLS (f))
+
+#define FRAME_CR_SURFACE_DESIRED_WIDTH(f) \
+ ((f)->output_data.pgtk->cr_surface_desired_width)
+#define FRAME_CR_SURFACE_DESIRED_HEIGHT(f) \
+ ((f)->output_data.pgtk->cr_surface_desired_height)
+
+/* Display init/shutdown functions implemented in pgtkterm.c */
+extern struct pgtk_display_info *pgtk_term_init (Lisp_Object display_name,
+ char *resource_name);
+extern void pgtk_term_shutdown (int sig);
+
+/* Implemented in pgtkterm, published in or needed from pgtkfns. */
+extern void pgtk_clear_frame (struct frame *f);
+extern char *pgtk_xlfd_to_fontname (const char *xlfd);
+
+/* Implemented in pgtkfns. */
+extern void pgtk_set_doc_edited (void);
+extern const char *pgtk_get_defaults_value (const char *key);
+extern const char *pgtk_get_string_resource (XrmDatabase rdb,
+ const char *name,
+ const char *class);
+extern void pgtk_implicitly_set_name (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval);
+
+/* Color management implemented in pgtkterm. */
+extern bool pgtk_defined_color (struct frame *f,
+ const char *name,
+ Emacs_Color * color_def, bool alloc,
+ bool makeIndex);
+extern void pgtk_query_color (struct frame *f, Emacs_Color * color);
+extern void pgtk_query_colors (struct frame *f, Emacs_Color * colors,
+ int ncolors);
+extern int pgtk_parse_color (struct frame *f, const char *color_name,
+ Emacs_Color * color);
+
+/* Implemented in pgtkterm.c */
+extern void pgtk_clear_area (struct frame *f, int x, int y, int width,
+ int height);
+extern int pgtk_gtk_to_emacs_modifiers (struct pgtk_display_info *dpyinfo,
+ int state);
+extern void pgtk_clear_under_internal_border (struct frame *f);
+extern void pgtk_set_event_handler (struct frame *f);
+
+/* Implemented in pgtkterm.c */
+extern int x_display_pixel_height (struct pgtk_display_info *);
+extern int x_display_pixel_width (struct pgtk_display_info *);
+
+/* Implemented in pgtkterm.c */
+extern void x_destroy_window (struct frame *f);
+extern void x_set_parent_frame (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value);
+extern void x_set_no_focus_on_map (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value);
+extern void x_set_no_accept_focus (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value);
+extern void x_set_z_group (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value);
+
+/* Cairo related functions implemented in pgtkterm.c */
+extern void pgtk_cr_update_surface_desired_size (struct frame *, int, int, bool);
+extern cairo_t *pgtk_begin_cr_clip (struct frame *f);
+extern void pgtk_end_cr_clip (struct frame *f);
+extern void pgtk_set_cr_source_with_gc_foreground (struct frame *f,
+ Emacs_GC * gc);
+extern void pgtk_set_cr_source_with_gc_background (struct frame *f,
+ Emacs_GC * gc);
+extern void pgtk_set_cr_source_with_color (struct frame *f,
+ unsigned long color);
+extern void pgtk_cr_draw_frame (cairo_t * cr, struct frame *f);
+extern void pgtk_cr_destroy_frame_context (struct frame *f);
+extern Lisp_Object pgtk_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type);
+
+/* Defined in pgtkmenu.c */
+extern Lisp_Object pgtk_popup_dialog (struct frame *f, Lisp_Object header,
+ Lisp_Object contents);
+extern Lisp_Object pgtk_dialog_show (struct frame *f, Lisp_Object title,
+ Lisp_Object header,
+ const char **error_name);
+extern void initialize_frame_menubar (struct frame *);
+
+
+/* Symbol initializations implemented in each pgtk sources. */
+extern void syms_of_pgtkterm (void);
+extern void syms_of_pgtkfns (void);
+extern void syms_of_pgtkmenu (void);
+extern void syms_of_pgtkselect (void);
+extern void syms_of_pgtkim (void);
+
+/* Implemented in pgtkselect. */
+extern void nxatoms_of_pgtkselect (void);
+
+/* Initialization and marking implemented in pgtkterm.c */
+extern void init_pgtkterm (void);
+extern void mark_pgtkterm (void);
+extern void pgtk_delete_terminal (struct terminal *terminal);
+
+extern void pgtk_make_frame_visible (struct frame *f);
+extern void pgtk_make_frame_invisible (struct frame *f);
+extern void x_wm_set_size_hint (struct frame *, long, bool);
+extern void x_free_frame_resources (struct frame *);
+extern void pgtk_iconify_frame (struct frame *f);
+extern void pgtk_focus_frame (struct frame *f, bool noactivate);
+extern void pgtk_set_scroll_bar_default_width (struct frame *f);
+extern void pgtk_set_scroll_bar_default_height (struct frame *f);
+extern Lisp_Object x_get_focus_frame (struct frame *frame);
+
+extern void pgtk_frame_rehighlight (struct pgtk_display_info *dpyinfo);
+
+extern void x_change_tab_bar_height (struct frame *, int);
+
+extern struct pgtk_display_info *check_pgtk_display_info (Lisp_Object object);
+
+extern void pgtk_default_font_parameter (struct frame *f, Lisp_Object parms);
+
+extern void pgtk_menu_set_in_use (bool in_use);
+
+
+extern void pgtk_enqueue_string (struct frame *f, gchar * str);
+extern void pgtk_enqueue_preedit (struct frame *f, Lisp_Object image_data);
+extern void pgtk_im_focus_in (struct frame *f);
+extern void pgtk_im_focus_out (struct frame *f);
+extern bool pgtk_im_filter_keypress (struct frame *f, GdkEventKey * ev);
+extern void pgtk_im_set_cursor_location (struct frame *f, int x, int y,
+ int width, int height);
+extern void pgtk_im_init (struct pgtk_display_info *dpyinfo);
+extern void pgtk_im_finish (struct pgtk_display_info *dpyinfo);
+
+extern bool xg_set_icon (struct frame *, Lisp_Object);
+extern bool xg_set_icon_from_xpm_data (struct frame *f, const char **data);
+
+extern bool pgtk_text_icon (struct frame *f, const char *icon_name);
+
+extern double pgtk_frame_scale_factor (struct frame *);
+
+#endif /* HAVE_PGTK */
diff --git a/src/print.c b/src/print.c
index 9f684bbeb53..214f1d12c11 100644
--- a/src/print.c
+++ b/src/print.c
@@ -564,7 +564,7 @@ temp_output_buffer_setup (const char *bufname)
Fset_buffer (Fget_buffer_create (build_string (bufname), Qnil));
- Fkill_all_local_variables ();
+ Fkill_all_local_variables (Qnil);
delete_all_overlays (current_buffer);
bset_directory (current_buffer, BVAR (old, directory));
bset_read_only (current_buffer, Qnil);
@@ -1521,8 +1521,26 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
printchar ('>', printcharfun);
break;
- case PVEC_XWIDGET: case PVEC_XWIDGET_VIEW:
- print_c_string ("#<xwidget ", printcharfun);
+ case PVEC_XWIDGET:
+#ifdef HAVE_XWIDGETS
+ {
+#ifdef USE_GTK
+ int len = sprintf (buf, "#<xwidget %u %p>",
+ XXWIDGET (obj)->xwidget_id,
+ XXWIDGET (obj)->widget_osr);
+#else
+ int len = sprintf (buf, "#<xwidget %u %p>",
+ XXWIDGET (obj)->xwidget_id,
+ XXWIDGET (obj)->xwWidget);
+#endif
+ strout (buf, len, len, printcharfun);
+ break;
+ }
+#else
+ emacs_abort ();
+#endif
+ case PVEC_XWIDGET_VIEW:
+ print_c_string ("#<xwidget view", printcharfun);
printchar ('>', printcharfun);
break;
@@ -1857,6 +1875,22 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
break;
#endif
+ case PVEC_SQLITE:
+ {
+ print_c_string ("#<sqlite ", printcharfun);
+ int i = sprintf (buf, "db=%p", XSQLITE (obj)->db);
+ strout (buf, i, i, printcharfun);
+ if (XSQLITE (obj)->is_statement)
+ {
+ i = sprintf (buf, " stmt=%p", XSQLITE (obj)->stmt);
+ strout (buf, i, i, printcharfun);
+ }
+ i = sprintf (buf, " name=%s", XSQLITE (obj)->name);
+ strout (buf, i, i, printcharfun);
+ printchar ('>', printcharfun);
+ }
+ break;
+
default:
emacs_abort ();
}
diff --git a/src/process.c b/src/process.c
index 1d307d5242c..76094988f25 100644
--- a/src/process.c
+++ b/src/process.c
@@ -261,7 +261,7 @@ static bool process_output_skip;
static void start_process_unwind (Lisp_Object);
static void create_process (Lisp_Object, char **, Lisp_Object);
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
static bool keyboard_bit_set (fd_set *);
#endif
static void deactivate_process (Lisp_Object);
@@ -2169,7 +2169,8 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
p->pty_flag = pty_flag;
pset_status (p, Qrun);
- if (!EQ (p->command, Qt))
+ if (!EQ (p->command, Qt)
+ && !EQ (p->filter, Qt))
add_process_read_fd (inchannel);
ptrdiff_t count = SPECPDL_INDEX ();
@@ -2287,7 +2288,8 @@ create_pty (Lisp_Object process)
pset_status (p, Qrun);
setup_process_coding_systems (process);
- add_process_read_fd (pty_fd);
+ if (!EQ (p->filter, Qt))
+ add_process_read_fd (pty_fd);
pset_tty_name (p, build_string (pty_name));
}
@@ -2396,7 +2398,8 @@ usage: (make-pipe-process &rest ARGS) */)
pset_command (p, Qt);
eassert (! p->pty_flag);
- if (!EQ (p->command, Qt))
+ if (!EQ (p->command, Qt)
+ && !EQ (p->filter, Qt))
add_process_read_fd (inchannel);
p->adaptive_read_buffering
= (NILP (Vprocess_adaptive_read_buffering) ? 0
@@ -3131,7 +3134,8 @@ usage: (make-serial-process &rest ARGS) */)
pset_command (p, Qt);
eassert (! p->pty_flag);
- if (!EQ (p->command, Qt))
+ if (!EQ (p->command, Qt)
+ && !EQ (p->filter, Qt))
add_process_read_fd (fd);
update_process_mark (p);
@@ -5586,6 +5590,15 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
timeout = make_timespec (0, 0);
#endif
+#if !defined USABLE_SIGIO && !defined WINDOWSNT
+ /* If we're polling for input, don't get stuck in select for
+ more than 25 msec. */
+ struct timespec short_timeout = make_timespec (0, 25000000);
+ if ((read_kbd || !NILP (wait_for_cell))
+ && timespec_cmp (short_timeout, timeout) < 0)
+ timeout = short_timeout;
+#endif
+
/* Non-macOS HAVE_GLIB builds call thread_select in xgselect.c. */
#if defined HAVE_GLIB && !defined HAVE_NS
nfds = xg_select (max_desc + 1,
@@ -5719,7 +5732,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell)))
break;
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
/* If we think we have keyboard input waiting, but didn't get SIGIO,
go read it. This can happen with X on BSD after logging out.
In that case, there really is no input and no SIGIO,
@@ -5727,7 +5740,11 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
if (read_kbd && interrupt_input
&& keyboard_bit_set (&Available) && ! noninteractive)
+#ifdef USABLE_SIGIO
handle_input_available_signal (SIGIO);
+#else
+ handle_input_available_signal (SIGPOLL);
+#endif
#endif
/* If checking input just got us a size-change event from X,
@@ -5979,7 +5996,8 @@ read_process_output_error_handler (Lisp_Object error_val)
cmd_error_internal (error_val, "error in process filter: ");
Vinhibit_quit = Qt;
update_echo_area ();
- Fsleep_for (make_fixnum (2), Qnil);
+ if (process_error_pause_time > 0)
+ Fsleep_for (make_fixnum (process_error_pause_time), Qnil);
return Qt;
}
@@ -7409,7 +7427,8 @@ exec_sentinel_error_handler (Lisp_Object error_val)
cmd_error_internal (error_val, "error in process sentinel: ");
Vinhibit_quit = Qt;
update_echo_area ();
- Fsleep_for (make_fixnum (2), Qnil);
+ if (process_error_pause_time > 0)
+ Fsleep_for (make_fixnum (process_error_pause_time), Qnil);
return Qt;
}
@@ -7724,7 +7743,7 @@ delete_gpm_wait_descriptor (int desc)
# endif
-# ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
/* Return true if *MASK has a bit set
that corresponds to one of the keyboard input descriptors. */
@@ -8574,6 +8593,12 @@ Enlarge the value only if the subprocess generates very large (megabytes)
amounts of data in one go. */);
read_process_output_max = 4096;
+ DEFVAR_INT ("process-error-pause-time", process_error_pause_time,
+ doc: /* The number of seconds to pause after handling process errors.
+This isn't used for all process-related errors, but is used when a
+sentinel or a process filter function has an error. */);
+ process_error_pause_time = 1;
+
DEFSYM (Qinternal_default_interrupt_process,
"internal-default-interrupt-process");
DEFSYM (Qinterrupt_process_functions, "interrupt-process-functions");
diff --git a/src/search.c b/src/search.c
index 08f1e9474f1..66e77d42b4a 100644
--- a/src/search.c
+++ b/src/search.c
@@ -260,7 +260,7 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp,
static Lisp_Object
-looking_at_1 (Lisp_Object string, bool posix)
+looking_at_1 (Lisp_Object string, bool posix, bool modify_data)
{
Lisp_Object val;
unsigned char *p1, *p2;
@@ -278,11 +278,11 @@ looking_at_1 (Lisp_Object string, bool posix)
CHECK_STRING (string);
/* Snapshot in case Lisp changes the value. */
- bool preserve_match_data = NILP (Vinhibit_changing_match_data);
+ bool modify_match_data = NILP (Vinhibit_changing_match_data) && modify_data;
struct regexp_cache *cache_entry = compile_pattern (
string,
- preserve_match_data ? &search_regs : NULL,
+ modify_match_data ? &search_regs : NULL,
(!NILP (BVAR (current_buffer, case_fold_search))
? BVAR (current_buffer, case_canon_table) : Qnil),
posix,
@@ -316,7 +316,7 @@ looking_at_1 (Lisp_Object string, bool posix)
re_match_object = Qnil;
i = re_match_2 (&cache_entry->buf, (char *) p1, s1, (char *) p2, s2,
PT_BYTE - BEGV_BYTE,
- preserve_match_data ? &search_regs : NULL,
+ modify_match_data ? &search_regs : NULL,
ZV_BYTE - BEGV_BYTE);
if (i == -2)
@@ -326,7 +326,7 @@ looking_at_1 (Lisp_Object string, bool posix)
}
val = (i >= 0 ? Qt : Qnil);
- if (preserve_match_data && i >= 0)
+ if (modify_match_data && i >= 0)
{
for (i = 0; i < search_regs.num_regs; i++)
if (search_regs.start[i] >= 0)
@@ -343,35 +343,37 @@ looking_at_1 (Lisp_Object string, bool posix)
return unbind_to (count, val);
}
-DEFUN ("looking-at", Flooking_at, Slooking_at, 1, 1, 0,
+DEFUN ("looking-at", Flooking_at, Slooking_at, 1, 2, 0,
doc: /* Return t if text after point matches regular expression REGEXP.
-This function modifies the match data that `match-beginning',
-`match-end' and `match-data' access; save and restore the match
-data if you want to preserve them. */)
- (Lisp_Object regexp)
+By default, this function modifies the match data that
+`match-beginning', `match-end' and `match-data' access. If
+INHIBIT-MODIFY is non-nil, don't modify the match data. */)
+ (Lisp_Object regexp, Lisp_Object inhibit_modify)
{
- return looking_at_1 (regexp, 0);
+ return looking_at_1 (regexp, 0, NILP (inhibit_modify));
}
-DEFUN ("posix-looking-at", Fposix_looking_at, Sposix_looking_at, 1, 1, 0,
+DEFUN ("posix-looking-at", Fposix_looking_at, Sposix_looking_at, 1, 2, 0,
doc: /* Return t if text after point matches REGEXP according to Posix rules.
Find the longest match, in accordance with Posix regular expression rules.
-This function modifies the match data that `match-beginning',
-`match-end' and `match-data' access; save and restore the match
-data if you want to preserve them. */)
- (Lisp_Object regexp)
+
+By default, this function modifies the match data that
+`match-beginning', `match-end' and `match-data' access. If
+INHIBIT-MODIFY is non-nil, don't modify the match data. */)
+ (Lisp_Object regexp, Lisp_Object inhibit_modify)
{
- return looking_at_1 (regexp, 1);
+ return looking_at_1 (regexp, 1, NILP (inhibit_modify));
}
static Lisp_Object
string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
- bool posix)
+ bool posix, bool modify_data)
{
ptrdiff_t val;
struct re_pattern_buffer *bufp;
EMACS_INT pos;
ptrdiff_t pos_byte, i;
+ bool modify_match_data = NILP (Vinhibit_changing_match_data) && modify_data;
if (running_asynch_code)
save_search_regs ();
@@ -400,8 +402,7 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
BVAR (current_buffer, case_eqv_table));
bufp = &compile_pattern (regexp,
- (NILP (Vinhibit_changing_match_data)
- ? &search_regs : NULL),
+ (modify_match_data ? &search_regs : NULL),
(!NILP (BVAR (current_buffer, case_fold_search))
? BVAR (current_buffer, case_canon_table) : Qnil),
posix,
@@ -410,18 +411,17 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
val = re_search (bufp, SSDATA (string),
SBYTES (string), pos_byte,
SBYTES (string) - pos_byte,
- (NILP (Vinhibit_changing_match_data)
- ? &search_regs : NULL));
+ (modify_match_data ? &search_regs : NULL));
/* Set last_thing_searched only when match data is changed. */
- if (NILP (Vinhibit_changing_match_data))
+ if (modify_match_data)
last_thing_searched = Qt;
if (val == -2)
matcher_overflow ();
if (val < 0) return Qnil;
- if (NILP (Vinhibit_changing_match_data))
+ if (modify_match_data)
for (i = 0; i < search_regs.num_regs; i++)
if (search_regs.start[i] >= 0)
{
@@ -434,32 +434,42 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
return make_fixnum (string_byte_to_char (string, val));
}
-DEFUN ("string-match", Fstring_match, Sstring_match, 2, 3, 0,
+DEFUN ("string-match", Fstring_match, Sstring_match, 2, 4, 0,
doc: /* Return index of start of first match for REGEXP in STRING, or nil.
Matching ignores case if `case-fold-search' is non-nil.
If third arg START is non-nil, start search at that index in STRING.
-For index of first char beyond the match, do (match-end 0).
-`match-end' and `match-beginning' also give indices of substrings
-matched by parenthesis constructs in the pattern.
-You can use the function `match-string' to extract the substrings
-matched by the parenthesis constructions in REGEXP. */)
- (Lisp_Object regexp, Lisp_Object string, Lisp_Object start)
+If INHIBIT-MODIFY is non-nil, match data is not changed.
+
+If INHIBIT-MODIFY is nil or missing, match data is changed, and
+`match-end' and `match-beginning' give indices of substrings matched
+by parenthesis constructs in the pattern. You can use the function
+`match-string' to extract the substrings matched by the parenthesis
+constructions in REGEXP. For index of first char beyond the match, do
+(match-end 0). */)
+ (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
+ Lisp_Object inhibit_modify)
{
- return string_match_1 (regexp, string, start, 0);
+ return string_match_1 (regexp, string, start, 0, NILP (inhibit_modify));
}
-DEFUN ("posix-string-match", Fposix_string_match, Sposix_string_match, 2, 3, 0,
+DEFUN ("posix-string-match", Fposix_string_match, Sposix_string_match, 2, 4, 0,
doc: /* Return index of start of first match for Posix REGEXP in STRING, or nil.
Find the longest match, in accord with Posix regular expression rules.
Case is ignored if `case-fold-search' is non-nil in the current buffer.
-If third arg START is non-nil, start search at that index in STRING.
-For index of first char beyond the match, do (match-end 0).
-`match-end' and `match-beginning' also give indices of substrings
-matched by parenthesis constructs in the pattern. */)
- (Lisp_Object regexp, Lisp_Object string, Lisp_Object start)
+
+If INHIBIT-MODIFY is non-nil, match data is not changed.
+
+If INHIBIT-MODIFY is nil or missing, match data is changed, and
+`match-end' and `match-beginning' give indices of substrings matched
+by parenthesis constructs in the pattern. You can use the function
+`match-string' to extract the substrings matched by the parenthesis
+constructions in REGEXP. For index of first char beyond the match, do
+(match-end 0). */)
+ (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
+ Lisp_Object inhibit_modify)
{
- return string_match_1 (regexp, string, start, 1);
+ return string_match_1 (regexp, string, start, 1, NILP (inhibit_modify));
}
/* Match REGEXP against STRING using translation table TABLE,
diff --git a/src/sound.c b/src/sound.c
index 9041076bdc0..d42bc8550d3 100644
--- a/src/sound.c
+++ b/src/sound.c
@@ -299,11 +299,15 @@ sound_perror (const char *msg)
int saved_errno = errno;
turn_on_atimers (1);
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
{
sigset_t unblocked;
sigemptyset (&unblocked);
+#ifdef USABLE_SIGIO
sigaddset (&unblocked, SIGIO);
+#else
+ sigaddset (&unblocked, SIGPOLL);
+#endif
pthread_sigmask (SIG_UNBLOCK, &unblocked, 0);
}
#endif
@@ -698,7 +702,7 @@ static void
vox_configure (struct sound_device *sd)
{
int val;
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
sigset_t oldset, blocked;
#endif
@@ -708,9 +712,13 @@ vox_configure (struct sound_device *sd)
interrupted by a signal. Block the ones we know to cause
troubles. */
turn_on_atimers (0);
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
sigemptyset (&blocked);
+#ifdef USABLE_SIGIO
sigaddset (&blocked, SIGIO);
+#else
+ sigaddset (&blocked, SIGPOLL);
+#endif
pthread_sigmask (SIG_BLOCK, &blocked, &oldset);
#endif
@@ -744,7 +752,7 @@ vox_configure (struct sound_device *sd)
}
turn_on_atimers (1);
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
pthread_sigmask (SIG_SETMASK, &oldset, 0);
#endif
}
@@ -760,10 +768,14 @@ vox_close (struct sound_device *sd)
/* On GNU/Linux, it seems that the device driver doesn't like to
be interrupted by a signal. Block the ones we know to cause
troubles. */
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
sigset_t blocked, oldset;
sigemptyset (&blocked);
+#ifdef USABLE_SIGIO
sigaddset (&blocked, SIGIO);
+#else
+ sigaddset (&blocked, SIGPOLL);
+#endif
pthread_sigmask (SIG_BLOCK, &blocked, &oldset);
#endif
turn_on_atimers (0);
@@ -772,7 +784,7 @@ vox_close (struct sound_device *sd)
ioctl (sd->fd, SNDCTL_DSP_SYNC, NULL);
turn_on_atimers (1);
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
pthread_sigmask (SIG_SETMASK, &oldset, 0);
#endif
diff --git a/src/sqlite.c b/src/sqlite.c
new file mode 100644
index 00000000000..428b84b21e7
--- /dev/null
+++ b/src/sqlite.c
@@ -0,0 +1,753 @@
+/*
+Copyright (C) 2021 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 based on the emacs-sqlite3 package written by Syohei
+YOSHIDA <syohex@gmail.com>, which can be found at:
+
+ https://github.com/syohex/emacs-sqlite3
+*/
+
+#include <config.h>
+#include "lisp.h"
+#include "coding.h"
+
+#ifdef HAVE_SQLITE3
+
+#include <sqlite3.h>
+
+#ifdef WINDOWSNT
+
+# include <windows.h>
+# include "w32common.h"
+# include "w32.h"
+
+DEF_DLL_FN (SQLITE_API int, sqlite3_finalize, (sqlite3_stmt*));
+DEF_DLL_FN (SQLITE_API int, sqlite3_close, (sqlite3*));
+DEF_DLL_FN (SQLITE_API int, sqlite3_open_v2,
+ (const char*, sqlite3**, int, const char*));
+DEF_DLL_FN (SQLITE_API int, sqlite3_reset, (sqlite3_stmt*));
+DEF_DLL_FN (SQLITE_API int, sqlite3_bind_text,
+ (sqlite3_stmt*, int, const char*, int, void(*)(void*)));
+DEF_DLL_FN (SQLITE_API int, sqlite3_bind_int64,
+ (sqlite3_stmt*, int, sqlite3_int64));
+DEF_DLL_FN (SQLITE_API int, sqlite3_bind_double, (sqlite3_stmt*, int, double));
+DEF_DLL_FN (SQLITE_API int, sqlite3_bind_null, (sqlite3_stmt*, int));
+DEF_DLL_FN (SQLITE_API int, sqlite3_bind_int, (sqlite3_stmt*, int, int));
+DEF_DLL_FN (SQLITE_API const char*, sqlite3_errmsg, (sqlite3*));
+DEF_DLL_FN (SQLITE_API int, sqlite3_step, (sqlite3_stmt*));
+DEF_DLL_FN (SQLITE_API int, sqlite3_changes, (sqlite3*));
+DEF_DLL_FN (SQLITE_API int, sqlite3_column_count, (sqlite3_stmt*));
+DEF_DLL_FN (SQLITE_API int, sqlite3_column_type, (sqlite3_stmt*, int));
+DEF_DLL_FN (SQLITE_API sqlite3_int64, sqlite3_column_int64,
+ (sqlite3_stmt*, int));
+DEF_DLL_FN (SQLITE_API double, sqlite3_column_double, (sqlite3_stmt*, int));
+DEF_DLL_FN (SQLITE_API const void*, sqlite3_column_blob,
+ (sqlite3_stmt*, int));
+DEF_DLL_FN (SQLITE_API int, sqlite3_column_bytes, (sqlite3_stmt*, int));
+DEF_DLL_FN (SQLITE_API const unsigned char*, sqlite3_column_text,
+ (sqlite3_stmt*, int));
+DEF_DLL_FN (SQLITE_API const char*, sqlite3_column_name, (sqlite3_stmt*, int));
+DEF_DLL_FN (SQLITE_API int, sqlite3_exec,
+ (sqlite3*, const char*, int (*callback)(void*,int,char**,char**),
+ void*, char**));
+DEF_DLL_FN (SQLITE_API int, sqlite3_prepare_v2,
+ (sqlite3*, const char*, int, sqlite3_stmt**, const char**));
+
+# ifdef HAVE_SQLITE3_LOAD_EXTENSION
+DEF_DLL_FN (SQLITE_API int, sqlite3_load_extension,
+ (sqlite3*, const char*, const char*, char**));
+# undef sqlite3_load_extension
+# define sqlite3_load_extension fn_sqlite3_load_extension
+# endif
+
+# undef sqlite3_finalize
+# undef sqlite3_close
+# undef sqlite3_open_v2
+# undef sqlite3_reset
+# undef sqlite3_bind_text
+# undef sqlite3_bind_int64
+# undef sqlite3_bind_double
+# undef sqlite3_bind_null
+# undef sqlite3_bind_int
+# undef sqlite3_errmsg
+# undef sqlite3_step
+# undef sqlite3_changes
+# undef sqlite3_column_count
+# undef sqlite3_column_type
+# undef sqlite3_column_int64
+# undef sqlite3_column_double
+# undef sqlite3_column_blob
+# undef sqlite3_column_bytes
+# undef sqlite3_column_text
+# undef sqlite3_column_name
+# undef sqlite3_exec
+# undef sqlite3_prepare_v2
+
+# define sqlite3_finalize fn_sqlite3_finalize
+# define sqlite3_close fn_sqlite3_close
+# define sqlite3_open_v2 fn_sqlite3_open_v2
+# define sqlite3_reset fn_sqlite3_reset
+# define sqlite3_bind_text fn_sqlite3_bind_text
+# define sqlite3_bind_int64 fn_sqlite3_bind_int64
+# define sqlite3_bind_double fn_sqlite3_bind_double
+# define sqlite3_bind_null fn_sqlite3_bind_null
+# define sqlite3_bind_int fn_sqlite3_bind_int
+# define sqlite3_errmsg fn_sqlite3_errmsg
+# define sqlite3_step fn_sqlite3_step
+# define sqlite3_changes fn_sqlite3_changes
+# define sqlite3_column_count fn_sqlite3_column_count
+# define sqlite3_column_type fn_sqlite3_column_type
+# define sqlite3_column_int64 fn_sqlite3_column_int64
+# define sqlite3_column_double fn_sqlite3_column_double
+# define sqlite3_column_blob fn_sqlite3_column_blob
+# define sqlite3_column_bytes fn_sqlite3_column_bytes
+# define sqlite3_column_text fn_sqlite3_column_text
+# define sqlite3_column_name fn_sqlite3_column_name
+# define sqlite3_exec fn_sqlite3_exec
+# define sqlite3_prepare_v2 fn_sqlite3_prepare_v2
+
+static bool
+load_dll_functions (HMODULE library)
+{
+ LOAD_DLL_FN (library, sqlite3_finalize);
+ LOAD_DLL_FN (library, sqlite3_close);
+ LOAD_DLL_FN (library, sqlite3_open_v2);
+ LOAD_DLL_FN (library, sqlite3_reset);
+ LOAD_DLL_FN (library, sqlite3_bind_text);
+ LOAD_DLL_FN (library, sqlite3_bind_int64);
+ LOAD_DLL_FN (library, sqlite3_bind_double);
+ LOAD_DLL_FN (library, sqlite3_bind_null);
+ LOAD_DLL_FN (library, sqlite3_bind_int);
+ LOAD_DLL_FN (library, sqlite3_errmsg);
+ LOAD_DLL_FN (library, sqlite3_step);
+ LOAD_DLL_FN (library, sqlite3_changes);
+ LOAD_DLL_FN (library, sqlite3_column_count);
+ LOAD_DLL_FN (library, sqlite3_column_type);
+ LOAD_DLL_FN (library, sqlite3_column_int64);
+ LOAD_DLL_FN (library, sqlite3_column_double);
+ LOAD_DLL_FN (library, sqlite3_column_blob);
+ LOAD_DLL_FN (library, sqlite3_column_bytes);
+ LOAD_DLL_FN (library, sqlite3_column_text);
+ LOAD_DLL_FN (library, sqlite3_column_name);
+ LOAD_DLL_FN (library, sqlite3_exec);
+# ifdef HAVE_SQLITE3_LOAD_EXTENSION
+ LOAD_DLL_FN (library, sqlite3_load_extension);
+# endif
+ LOAD_DLL_FN (library, sqlite3_prepare_v2);
+ return true;
+}
+#endif /* WINDOWSNT */
+
+static bool
+init_sqlite_functions (void)
+{
+#ifdef WINDOWSNT
+ static bool sqlite3_initialized;
+
+ if (!sqlite3_initialized)
+ {
+ HMODULE library = w32_delayed_load (Qsqlite3);
+
+ if (!library)
+ message1 ("sqlite3 library was not found");
+ else if (load_dll_functions (library))
+ {
+ sqlite3_initialized = true;
+ Vlibrary_cache = Fcons (Fcons (Qsqlite3, Qt), Vlibrary_cache);
+ }
+ else
+ {
+ message1 ("sqlite3 library was found, but could not be loaded successfully");
+ Vlibrary_cache = Fcons (Fcons (Qsqlite3, Qnil), Vlibrary_cache);
+ }
+ }
+ return sqlite3_initialized;
+#else /* !WINDOWSNT */
+ return true;
+#endif /* !WINDOWSNT */
+}
+
+
+static void
+sqlite_free (void *arg)
+{
+ struct Lisp_Sqlite *ptr = (struct Lisp_Sqlite *)arg;
+ if (ptr->is_statement)
+ sqlite3_finalize (ptr->stmt);
+ else if (ptr->db)
+ sqlite3_close (ptr->db);
+ xfree (ptr->name);
+ xfree (ptr);
+}
+
+static Lisp_Object
+encode_string (Lisp_Object string)
+{
+ if (STRING_MULTIBYTE (string))
+ return encode_string_utf_8 (string, Qnil, 0, Qt, Qt);
+ else
+ return string;
+}
+
+static Lisp_Object
+make_sqlite (bool is_statement, void *db, void *stmt, char *name)
+{
+ struct Lisp_Sqlite *ptr
+ = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Sqlite, PVEC_SQLITE);
+ ptr->is_statement = is_statement;
+ ptr->finalizer = sqlite_free;
+ ptr->db = db;
+ ptr->name = name;
+ ptr->stmt = stmt;
+ ptr->eof = false;
+ return make_lisp_ptr (ptr, Lisp_Vectorlike);
+}
+
+static void
+check_sqlite (Lisp_Object db, bool is_statement)
+{
+ init_sqlite_functions ();
+ CHECK_SQLITE (db);
+ if (is_statement && !XSQLITE (db)->is_statement)
+ xsignal1 (Qerror, build_string ("Invalid set object"));
+ else if (!is_statement && XSQLITE (db)->is_statement)
+ xsignal1 (Qerror, build_string ("Invalid database object"));
+ if (!is_statement && !XSQLITE (db)->db)
+ xsignal1 (Qerror, build_string ("Database closed"));
+ else if (is_statement && !XSQLITE (db)->db)
+ xsignal1 (Qerror, build_string ("Statement closed"));
+}
+
+static int db_count = 0;
+
+DEFUN ("sqlite-open", Fsqlite_open, Ssqlite_open, 0, 1, 0,
+ doc: /* Open FILE as an sqlite database.
+If FILE is nil, an in-memory database will be opened instead. */)
+ (Lisp_Object file)
+{
+ char *name;
+ if (!init_sqlite_functions ())
+ xsignal1 (Qerror, build_string ("sqlite support is not available"));
+
+ if (!NILP (file))
+ {
+ CHECK_STRING (file);
+ file = ENCODE_FILE (Fexpand_file_name (file, Qnil));
+ name = xstrdup (SSDATA (file));
+ }
+ else
+ /* In-memory database. These have to have different names to
+ refer to different databases. */
+ name = xstrdup (SSDATA (CALLN (Fformat, build_string (":memory:%d"),
+ make_int (++db_count))));
+
+ sqlite3 *sdb;
+ int ret = sqlite3_open_v2 (name,
+ &sdb,
+ SQLITE_OPEN_FULLMUTEX
+ | SQLITE_OPEN_READWRITE
+ | SQLITE_OPEN_CREATE
+ | (NILP (file) ? SQLITE_OPEN_MEMORY : 0)
+#ifdef SQLITE_OPEN_URI
+ | SQLITE_OPEN_URI
+#endif
+ | 0, NULL);
+
+ if (ret != SQLITE_OK)
+ return Qnil;
+
+ return make_sqlite (false, sdb, NULL, name);
+}
+
+DEFUN ("sqlite-close", Fsqlite_close, Ssqlite_close, 1, 1, 0,
+ doc: /* Close the sqlite database DB. */)
+ (Lisp_Object db)
+{
+ check_sqlite (db, false);
+ sqlite3_close (XSQLITE (db)->db);
+ XSQLITE (db)->db = NULL;
+ return Qt;
+}
+
+/* Bind values in a statement like
+ "insert into foo values (?, ?, ?)". */
+static const char *
+bind_values (sqlite3 *db, sqlite3_stmt *stmt, Lisp_Object values)
+{
+ sqlite3_reset (stmt);
+ int len;
+ if (VECTORP (values))
+ len = ASIZE (values);
+ else
+ len = list_length (values);
+
+ for (int i = 0; i < len; ++i)
+ {
+ int ret = SQLITE_MISMATCH;
+ Lisp_Object value;
+ if (VECTORP (values))
+ value = AREF (values, i);
+ else
+ {
+ value = XCAR (values);
+ values = XCDR (values);
+ }
+ Lisp_Object type = Ftype_of (value);
+
+ if (EQ (type, Qstring))
+ {
+ Lisp_Object encoded = encode_string (value);
+ ret = sqlite3_bind_text (stmt, i + 1,
+ 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))
+ ret = sqlite3_bind_double (stmt, i + 1, XFLOAT_DATA (value));
+ else if (NILP (value))
+ ret = sqlite3_bind_null (stmt, i + 1);
+ else if (EQ (value, Qt))
+ ret = sqlite3_bind_int (stmt, i + 1, 1);
+ else if (EQ (value, Qfalse))
+ ret = sqlite3_bind_int (stmt, i + 1, 0);
+ else
+ return "invalid argument";
+
+ if (ret != SQLITE_OK)
+ return sqlite3_errmsg (db);
+ }
+
+ return NULL;
+}
+
+DEFUN ("sqlite-execute", Fsqlite_execute, Ssqlite_execute, 2, 3, 0,
+ doc: /* Execute a non-select SQL statement.
+If VALUES is non-nil, it should be a vector or a list of values
+to bind when executing a statement like
+
+ insert into foo values (?, ?, ...)
+
+Value is the number of affected rows. */)
+ (Lisp_Object db, Lisp_Object query, Lisp_Object values)
+{
+ check_sqlite (db, false);
+ CHECK_STRING (query);
+ if (!(NILP (values) || CONSP (values) || VECTORP (values)))
+ xsignal1 (Qerror, build_string ("VALUES must be a list or a vector"));
+
+ sqlite3 *sdb = XSQLITE (db)->db;
+ Lisp_Object retval = Qnil;
+ const char *errmsg = NULL;
+ Lisp_Object encoded = encode_string (query);
+ sqlite3_stmt *stmt = NULL;
+
+ /* We only execute the first statement -- if there's several
+ (separated by a semicolon), the subsequent statements won't be
+ done. */
+ int ret = sqlite3_prepare_v2 (sdb, SSDATA (encoded), -1, &stmt, NULL);
+ if (ret != SQLITE_OK)
+ {
+ if (stmt != NULL)
+ {
+ sqlite3_finalize (stmt);
+ sqlite3_reset (stmt);
+ }
+
+ errmsg = sqlite3_errmsg (sdb);
+ goto exit;
+ }
+
+ /* Bind ? values. */
+ if (!NILP (values)) {
+ const char *err = bind_values (sdb, stmt, values);
+ if (err != NULL)
+ {
+ errmsg = err;
+ goto exit;
+ }
+ }
+
+ ret = sqlite3_step (stmt);
+ sqlite3_finalize (stmt);
+ if (ret != SQLITE_OK && ret != SQLITE_DONE)
+ {
+ errmsg = sqlite3_errmsg (sdb);
+ goto exit;
+ }
+
+ retval = make_fixnum (sqlite3_changes (sdb));
+
+ exit:
+ if (errmsg != NULL)
+ xsignal1 (ret == SQLITE_LOCKED || ret == SQLITE_BUSY?
+ Qsqlite_locked_error: Qerror,
+ build_string (errmsg));
+
+ return retval;
+}
+
+static Lisp_Object
+row_to_value (sqlite3_stmt *stmt)
+{
+ int len = sqlite3_column_count (stmt);
+ Lisp_Object values = Qnil;
+
+ for (int i = 0; i < len; ++i)
+ {
+ Lisp_Object v = Qnil;
+
+ switch (sqlite3_column_type (stmt, i))
+ {
+ case SQLITE_INTEGER:
+ v = make_int (sqlite3_column_int64 (stmt, i));
+ break;
+
+ case SQLITE_FLOAT:
+ v = make_float (sqlite3_column_double (stmt, i));
+ break;
+
+ case SQLITE_BLOB:
+ v =
+ code_convert_string_norecord
+ (make_unibyte_string (sqlite3_column_blob (stmt, i),
+ sqlite3_column_bytes (stmt, i)),
+ Qutf_8, false);
+ break;
+
+ case SQLITE_NULL:
+ v = Qnil;
+ break;
+
+ case SQLITE_TEXT:
+ v =
+ code_convert_string_norecord
+ (make_unibyte_string ((const char *)sqlite3_column_text (stmt, i),
+ sqlite3_column_bytes (stmt, i)),
+ Qutf_8, false);
+ break;
+ }
+
+ values = Fcons (v, values);
+ }
+
+ return Fnreverse (values);
+}
+
+static Lisp_Object
+column_names (sqlite3_stmt *stmt)
+{
+ Lisp_Object columns = Qnil;
+ int count = sqlite3_column_count (stmt);
+ for (int i = 0; i < count; ++i)
+ columns = Fcons (build_string (sqlite3_column_name (stmt, i)), columns);
+
+ return Fnreverse (columns);
+}
+
+DEFUN ("sqlite-select", Fsqlite_select, Ssqlite_select, 2, 4, 0,
+ doc: /* Select data from the database DB that matches QUERY.
+If VALUES is non-nil, it should be a list or a vector specifying the
+values that will be interpolated into a parameterized statement.
+
+By default, the return value is a list where the first element is a
+list of column names, and the rest of the elements are the matching data.
+
+RETURN-TYPE can be either nil (which means that the matching data
+should be returned as a list of rows), or `full' (the same, but the
+first element in the return list will be the column names), or `set',
+which means that we return a set object that can be queried with
+`sqlite-next' and other functions to get the data. */)
+ (Lisp_Object db, Lisp_Object query, Lisp_Object values,
+ Lisp_Object return_type)
+{
+ check_sqlite (db, false);
+ CHECK_STRING (query);
+
+ if (!(NILP (values) || CONSP (values) || VECTORP (values)))
+ xsignal1 (Qerror, build_string ("VALUES must be a list or a vector"));
+
+ sqlite3 *sdb = XSQLITE (db)->db;
+ Lisp_Object retval = Qnil;
+ const char *errmsg = NULL;
+ Lisp_Object encoded = encode_string (query);
+
+ sqlite3_stmt *stmt = NULL;
+ int ret = sqlite3_prepare_v2 (sdb, SSDATA (encoded), SBYTES (encoded),
+ &stmt, NULL);
+ if (ret != SQLITE_OK)
+ {
+ if (stmt)
+ sqlite3_finalize (stmt);
+
+ goto exit;
+ }
+
+ /* Query with parameters. */
+ if (!NILP (values))
+ {
+ const char *err = bind_values (sdb, stmt, values);
+ if (err != NULL)
+ {
+ sqlite3_finalize (stmt);
+ errmsg = err;
+ goto exit;
+ }
+ }
+
+ /* Return a handle to get the data. */
+ if (EQ (return_type, Qset))
+ {
+ retval = make_sqlite (true, sdb, stmt, XSQLITE (db)->name);
+ goto exit;
+ }
+
+ /* Return the data directly. */
+ Lisp_Object data = Qnil;
+ while ((ret = sqlite3_step (stmt)) == SQLITE_ROW)
+ data = Fcons (row_to_value (stmt), data);
+
+ if (EQ (return_type, Qfull))
+ retval = Fcons (column_names (stmt), Fnreverse (data));
+ else
+ retval = Fnreverse (data);
+ sqlite3_finalize (stmt);
+
+ exit:
+ if (errmsg != NULL)
+ xsignal1 (Qerror, build_string (errmsg));
+
+ return retval;
+}
+
+static Lisp_Object
+sqlite_exec (sqlite3 *sdb, const char *query)
+{
+ int ret = sqlite3_exec (sdb, query, NULL, NULL, NULL);
+ if (ret != SQLITE_OK)
+ return Qnil;
+
+ return Qt;
+}
+
+DEFUN ("sqlite-transaction", Fsqlite_transaction, Ssqlite_transaction, 1, 1, 0,
+ doc: /* Start a transaction in DB. */)
+ (Lisp_Object db)
+{
+ check_sqlite (db, false);
+ return sqlite_exec (XSQLITE (db)->db, "begin");
+}
+
+DEFUN ("sqlite-commit", Fsqlite_commit, Ssqlite_commit, 1, 1, 0,
+ doc: /* Commit a transaction in DB. */)
+ (Lisp_Object db)
+{
+ check_sqlite (db, false);
+ return sqlite_exec (XSQLITE (db)->db, "commit");
+}
+
+DEFUN ("sqlite-rollback", Fsqlite_rollback, Ssqlite_rollback, 1, 1, 0,
+ doc: /* Roll back a transaction in DB. */)
+ (Lisp_Object db)
+{
+ check_sqlite (db, false);
+ return sqlite_exec (XSQLITE (db)->db, "rollback");
+}
+
+DEFUN ("sqlite-pragma", Fsqlite_pragma, Ssqlite_pragma, 2, 2, 0,
+ doc: /* Execute PRAGMA in DB. */)
+ (Lisp_Object db, Lisp_Object pragma)
+{
+ check_sqlite (db, false);
+ CHECK_STRING (pragma);
+
+ return sqlite_exec (XSQLITE (db)->db,
+ SSDATA (concat2 (build_string ("PRAGMA "), pragma)));
+}
+
+#ifdef HAVE_SQLITE3_LOAD_EXTENSION
+DEFUN ("sqlite-load-extension", Fsqlite_load_extension,
+ Ssqlite_load_extension, 2, 2, 0,
+ doc: /* Load an SQlite MODULE into DB.
+MODULE should be the name of an SQlite module's file, a
+shared library in the system-dependent format and having a
+system-dependent file-name extension.
+
+Only modules on Emacs' list of allowed modules can be loaded. */)
+ (Lisp_Object db, Lisp_Object module)
+{
+ check_sqlite (db, false);
+ CHECK_STRING (module);
+
+ /* Add names of useful and free modules here. */
+ const char *allowlist[3] = { "pcre", "csvtable", NULL };
+ char *name = SSDATA (Ffile_name_nondirectory (module));
+ /* Possibly skip past a common prefix. */
+ const char *prefix = "libsqlite3_mod_";
+ if (!strncmp (name, prefix, strlen (prefix)))
+ name += strlen (prefix);
+
+ bool do_allow = false;
+ for (const char **allow = allowlist; *allow; allow++)
+ {
+ if (strlen (*allow) < strlen (name)
+ && !strncmp (*allow, name, strlen (*allow))
+ && (!strcmp (name + strlen (*allow), ".so")
+ || !strcmp (name + strlen (*allow), ".DLL")))
+ {
+ do_allow = true;
+ break;
+ }
+ }
+
+ if (!do_allow)
+ xsignal (Qerror, build_string ("Module name not on allowlist"));
+
+ int result = sqlite3_load_extension
+ (XSQLITE (db)->db,
+ SSDATA (ENCODE_FILE (Fexpand_file_name (module, Qnil))),
+ NULL, NULL);
+ if (result == SQLITE_OK)
+ return Qt;
+ return Qnil;
+}
+#endif /* HAVE_SQLITE3_LOAD_EXTENSION */
+
+DEFUN ("sqlite-next", Fsqlite_next, Ssqlite_next, 1, 1, 0,
+ doc: /* Return the next result set from SET. */)
+ (Lisp_Object set)
+{
+ check_sqlite (set, true);
+
+ int ret = sqlite3_step (XSQLITE (set)->stmt);
+ if (ret != SQLITE_ROW && ret != SQLITE_OK && ret != SQLITE_DONE)
+ xsignal1 (Qerror, build_string (sqlite3_errmsg (XSQLITE (set)->db)));
+
+ if (ret == SQLITE_DONE)
+ {
+ XSQLITE (set)->eof = true;
+ return Qnil;
+ }
+
+ return row_to_value (XSQLITE (set)->stmt);
+}
+
+DEFUN ("sqlite-columns", Fsqlite_columns, Ssqlite_columns, 1, 1, 0,
+ doc: /* Return the column names of SET. */)
+ (Lisp_Object set)
+{
+ check_sqlite (set, true);
+ return column_names (XSQLITE (set)->stmt);
+}
+
+DEFUN ("sqlite-more-p", Fsqlite_more_p, Ssqlite_more_p, 1, 1, 0,
+ doc: /* Say whether there are any further results in SET. */)
+ (Lisp_Object set)
+{
+ check_sqlite (set, true);
+
+ if (XSQLITE (set)->eof)
+ return Qnil;
+ else
+ return Qt;
+}
+
+DEFUN ("sqlite-finalize", Fsqlite_finalize, Ssqlite_finalize, 1, 1, 0,
+ doc: /* Mark this SET as being finished.
+This will free the resources held by SET. */)
+ (Lisp_Object set)
+{
+ check_sqlite (set, true);
+ sqlite3_finalize (XSQLITE (set)->stmt);
+ XSQLITE (set)->db = NULL;
+ return Qt;
+}
+
+#endif /* HAVE_SQLITE3 */
+
+DEFUN ("sqlitep", Fsqlitep, Ssqlitep, 1, 1, 0,
+ doc: /* Say whether OBJECT is an SQlite object. */)
+ (Lisp_Object object)
+{
+#ifdef HAVE_SQLITE3
+ return SQLITE (object)? Qt: Qnil;
+#else
+ return Qnil;
+#endif
+}
+
+DEFUN ("sqlite-available-p", Fsqlite_available_p, Ssqlite_available_p, 0, 0, 0,
+ doc: /* Return t if sqlite3 support is available in this instance of Emacs.*/)
+ (void)
+{
+#ifdef HAVE_SQLITE3
+# ifdef WINDOWSNT
+ Lisp_Object found = Fassq (Qsqlite3, Vlibrary_cache);
+ if (CONSP (found))
+ return XCDR (found);
+ else
+ return init_sqlite_functions () ? Qt : Qnil;
+# else
+ return Qt;
+#endif
+#else
+ return Qnil;
+#endif
+}
+
+void
+syms_of_sqlite (void)
+{
+#ifdef HAVE_SQLITE3
+ defsubr (&Ssqlite_open);
+ defsubr (&Ssqlite_close);
+ defsubr (&Ssqlite_execute);
+ defsubr (&Ssqlite_select);
+ defsubr (&Ssqlite_transaction);
+ defsubr (&Ssqlite_commit);
+ defsubr (&Ssqlite_rollback);
+ defsubr (&Ssqlite_pragma);
+#ifdef HAVE_SQLITE3_LOAD_EXTENSION
+ defsubr (&Ssqlite_load_extension);
+#endif
+ defsubr (&Ssqlite_next);
+ defsubr (&Ssqlite_columns);
+ defsubr (&Ssqlite_more_p);
+ defsubr (&Ssqlite_finalize);
+ DEFSYM (Qset, "set");
+ DEFSYM (Qfull, "full");
+#endif
+ defsubr (&Ssqlitep);
+ defsubr (&Ssqlite_available_p);
+
+ DEFSYM (Qsqlite_locked_error, "sqlite-locked-error");
+ Fput (Qsqlite_locked_error, Qerror_conditions,
+ Fpurecopy (list2 (Qsqlite_locked_error, Qerror)));
+ Fput (Qsqlite_locked_error, Qerror_message,
+ build_pure_c_string ("Database locked"));
+
+ DEFSYM (Qsqlitep, "sqlitep");
+ DEFSYM (Qfalse, "false");
+ DEFSYM (Qsqlite, "sqlite");
+ DEFSYM (Qsqlite3, "sqlite3");
+}
diff --git a/src/sysdep.c b/src/sysdep.c
index 8eaee224987..5e13dd097ec 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -678,6 +678,9 @@ sys_subshell (void)
#ifdef USABLE_SIGIO
saved_handlers[3].code = SIGIO;
saved_handlers[4].code = 0;
+#elif defined (USABLE_SIGPOLL)
+ saved_handlers[3].code = SIGPOLL;
+ saved_handlers[4].code = 0;
#else
saved_handlers[3].code = 0;
#endif
@@ -788,6 +791,7 @@ init_sigio (int fd)
}
#ifndef DOS_NT
+#ifdef F_SETOWN
static void
reset_sigio (int fd)
{
@@ -795,12 +799,13 @@ reset_sigio (int fd)
fcntl (fd, F_SETFL, old_fcntl_flags[fd]);
#endif
}
+#endif /* F_SETOWN */
#endif
void
request_sigio (void)
{
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
sigset_t unblocked;
if (noninteractive)
@@ -810,7 +815,11 @@ request_sigio (void)
# ifdef SIGWINCH
sigaddset (&unblocked, SIGWINCH);
# endif
+# ifdef USABLE_SIGIO
sigaddset (&unblocked, SIGIO);
+# else
+ sigaddset (&unblocked, SIGPOLL);
+# endif
pthread_sigmask (SIG_UNBLOCK, &unblocked, 0);
interrupts_deferred = 0;
@@ -820,7 +829,7 @@ request_sigio (void)
void
unrequest_sigio (void)
{
-#ifdef USABLE_SIGIO
+#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL)
sigset_t blocked;
if (noninteractive)
@@ -830,7 +839,11 @@ unrequest_sigio (void)
# ifdef SIGWINCH
sigaddset (&blocked, SIGWINCH);
# endif
+# ifdef USABLE_SIGIO
sigaddset (&blocked, SIGIO);
+# else
+ sigaddset (&blocked, SIGPOLL);
+# endif
pthread_sigmask (SIG_BLOCK, &blocked, 0);
interrupts_deferred = 1;
#endif
@@ -1256,9 +1269,12 @@ init_sys_modes (struct tty_display_info *tty_out)
/* This code added to insure that, if flow-control is not to be used,
we have an unlocked terminal at the start. */
+#ifndef HAIKU /* On Haiku, TCXONC is a no-op and causes spurious
+ compiler warnings. */
#ifdef TCXONC
if (!tty_out->flow_control) ioctl (fileno (tty_out->input), TCXONC, 1);
#endif
+#endif /* HAIKU */
#ifdef TIOCSTART
if (!tty_out->flow_control) ioctl (fileno (tty_out->input), TIOCSTART, 0);
#endif
@@ -1674,6 +1690,8 @@ emacs_sigaction_init (struct sigaction *action, signal_handler_t handler)
sigaddset (&action->sa_mask, SIGQUIT);
#ifdef USABLE_SIGIO
sigaddset (&action->sa_mask, SIGIO);
+#elif defined (USABLE_SIGPOLL)
+ sigaddset (&action->sa_mask, SIGPOLL);
#endif
}
@@ -2772,6 +2790,7 @@ static const struct speed_struct speeds[] =
#ifdef B150
{ 150, B150 },
#endif
+#ifndef HAVE_TINY_SPEED_T
#ifdef B200
{ 200, B200 },
#endif
@@ -2859,6 +2878,7 @@ static const struct speed_struct speeds[] =
#ifdef B4000000
{ 4000000, B4000000 },
#endif
+#endif /* HAVE_TINY_SPEED_T */
};
/* Convert a numerical speed (e.g., 9600) to a Bnnn constant (e.g.,
@@ -3120,8 +3140,9 @@ list_system_processes (void)
}
/* The WINDOWSNT implementation is in w32.c.
- The MSDOS implementation is in dosfns.c. */
-#elif !defined (WINDOWSNT) && !defined (MSDOS)
+ The MSDOS implementation is in dosfns.c.
+ The Haiku implementation is in haiku.c. */
+#elif !defined (WINDOWSNT) && !defined (MSDOS) && !defined (HAIKU)
Lisp_Object
list_system_processes (void)
@@ -4200,8 +4221,9 @@ system_process_attributes (Lisp_Object pid)
}
/* The WINDOWSNT implementation is in w32.c.
- The MSDOS implementation is in dosfns.c. */
-#elif !defined (WINDOWSNT) && !defined (MSDOS)
+ The MSDOS implementation is in dosfns.c.
+ The HAIKU implementation is in haiku.c. */
+#elif !defined (WINDOWSNT) && !defined (MSDOS) && !defined (HAIKU)
Lisp_Object
system_process_attributes (Lisp_Object pid)
diff --git a/src/sysstdio.h b/src/sysstdio.h
index d4df3d74567..d6ebfb455f5 100644
--- a/src/sysstdio.h
+++ b/src/sysstdio.h
@@ -26,7 +26,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <stdio.h>
#include "unlocked-io.h"
-extern FILE *emacs_fopen (char const *, char const *);
+extern FILE *emacs_fopen (char const *, char const *) ATTRIBUTE_MALLOC;
extern void errputc (int);
extern void errwrite (void const *, ptrdiff_t);
extern void close_output_streams (void);
diff --git a/src/systime.h b/src/systime.h
index 08ab5bdde33..ce9403c931d 100644
--- a/src/systime.h
+++ b/src/systime.h
@@ -80,8 +80,7 @@ struct lisp_time
/* Clock count as a Lisp integer. */
Lisp_Object ticks;
- /* Clock frequency (ticks per second) as a positive Lisp integer.
- (TICKS . HZ) is a valid Lisp timestamp unless HZ < 65536. */
+ /* Clock frequency (ticks per second) as a positive Lisp integer. */
Lisp_Object hz;
};
diff --git a/src/term.c b/src/term.c
index 6f0b827cfc8..8e106e7c639 100644
--- a/src/term.c
+++ b/src/term.c
@@ -1358,7 +1358,7 @@ term_get_fkeys_1 (void)
char *sequence = tgetstr (keys[i].cap, address);
if (sequence)
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence),
- make_vector (1, intern (keys[i].name)));
+ make_vector (1, intern (keys[i].name)), Qnil);
}
/* The uses of the "k0" capability are inconsistent; sometimes it
@@ -1377,13 +1377,13 @@ term_get_fkeys_1 (void)
/* Define f0 first, so that f10 takes precedence in case the
key sequences happens to be the same. */
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k0),
- make_vector (1, intern ("f0")));
+ make_vector (1, intern ("f0")), Qnil);
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k_semi),
- make_vector (1, intern ("f10")));
+ make_vector (1, intern ("f10")), Qnil);
}
else if (k0)
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k0),
- make_vector (1, intern (k0_name)));
+ make_vector (1, intern (k0_name)), Qnil);
}
/* Set up cookies for numbered function keys above f10. */
@@ -1405,8 +1405,10 @@ term_get_fkeys_1 (void)
if (sequence)
{
sprintf (fkey, "f%d", i);
- Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence),
- make_vector (1, intern (fkey)));
+ Fdefine_key (KVAR (kboard, Vinput_decode_map),
+ build_string (sequence),
+ make_vector (1, intern (fkey)),
+ Qnil);
}
}
}
@@ -1422,7 +1424,7 @@ term_get_fkeys_1 (void)
char *sequence = tgetstr (cap2, address); \
if (sequence) \
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence), \
- make_vector (1, intern (sym))); \
+ make_vector (1, intern (sym)), Qnil); \
}
/* if there's no key_next keycap, map key_npage to `next' keysym */
@@ -4152,10 +4154,12 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\
could return 32767. */
tty->TN_max_colors = 16777216;
}
- /* Fall back to xterm+direct (semicolon version) if requested
- by the COLORTERM environment variable. */
- else if ((bg = getenv("COLORTERM")) != NULL
- && strcasecmp(bg, "truecolor") == 0)
+ /* Fall back to xterm+direct (semicolon version) if Tc is set
+ (de-facto standard introduced by tmux) or if requested by
+ the COLORTERM environment variable. */
+ else if ((tigetflag ("Tc") > 0)
+ || ((bg = getenv ("COLORTERM")) != NULL
+ && strcasecmp (bg, "truecolor") == 0))
{
tty->TS_set_foreground = "\033[%?%p1%{8}%<%t3%p1%d%e38;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m";
tty->TS_set_background = "\033[%?%p1%{8}%<%t4%p1%d%e48;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m";
diff --git a/src/termhooks.h b/src/termhooks.h
index 1d3cdc8fe8d..9f22187b841 100644
--- a/src/termhooks.h
+++ b/src/termhooks.h
@@ -60,7 +60,9 @@ enum output_method
output_x_window,
output_msdos_raw,
output_w32,
- output_ns
+ output_ns,
+ output_pgtk,
+ output_haiku
};
/* Input queue declarations and hooks. */
@@ -119,7 +121,10 @@ enum event_kind
.timestamp gives a timestamp (in
milliseconds) for the event.
.arg may contain the number of
- lines to scroll. */
+ lines to scroll, or a list of
+ the form (NUMBER-OF-LINES . (X Y)) where
+ X and Y are the number of pixels
+ on each axis to scroll by. */
HORIZ_WHEEL_EVENT, /* A wheel event generated by a second
horizontal wheel that is present on some
mice. See WHEEL_EVENT. */
@@ -255,6 +260,8 @@ enum event_kind
#ifdef HAVE_XWIDGETS
/* events generated by xwidgets*/
, XWIDGET_EVENT
+ /* Event generated when WebKit asks us to display another widget. */
+ , XWIDGET_DISPLAY_EVENT
#endif
#ifdef USE_FILE_NOTIFY
@@ -262,6 +269,30 @@ enum event_kind
, FILE_NOTIFY_EVENT
#endif
+#ifdef HAVE_PGTK
+ /* Pre-edit text was changed. */
+ , PGTK_PREEDIT_TEXT_EVENT
+#endif
+
+ /* Either the mouse wheel has been released without it being
+ clicked, or the user has lifted his finger from a touchpad.
+
+ In the future, this may take into account other multi-touch
+ events generated from touchscreens and such. */
+ , TOUCH_END_EVENT
+
+ /* In a TOUCHSCREEN_UPDATE_EVENT, ARG is a list of elements of the
+ form (X Y ID), where X and Y are the coordinates of the
+ touchpoint relative to the top-left corner of the frame, and ID
+ is a unique number identifying the touchpoint.
+
+ 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. */
+
+ , TOUCHSCREEN_UPDATE_EVENT
+ , TOUCHSCREEN_BEGIN_EVENT
+ , TOUCHSCREEN_END_EVENT
};
/* Bit width of an enum event_kind tag at the start of structs and unions. */
@@ -442,6 +473,8 @@ struct terminal
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 */
} display_info;
@@ -515,7 +548,7 @@ struct terminal
BGCOLOR. */
void (*query_frame_background_color) (struct frame *f, Emacs_Color *bgcolor);
-#if defined (HAVE_X_WINDOWS) || defined (HAVE_NTGUI)
+#if defined (HAVE_X_WINDOWS) || defined (HAVE_NTGUI) || defined (HAVE_PGTK)
/* On frame F, translate pixel colors to RGB values for the NCOLORS
colors in COLORS. Use cached information, if available. */
@@ -830,6 +863,12 @@ extern struct terminal *terminal_list;
#elif defined (HAVE_NS)
#define TERMINAL_FONT_CACHE(t) \
(t->type == output_ns ? t->display_info.ns->name_list_element : Qnil)
+#elif defined (HAVE_PGTK)
+#define TERMINAL_FONT_CACHE(t) \
+ (t->type == output_pgtk ? t->display_info.pgtk->name_list_element : Qnil)
+#elif defined (HAVE_HAIKU)
+#define TERMINAL_FONT_CACHE(t) \
+ (t->type == output_haiku ? t->display_info.haiku->name_list_element : Qnil)
#endif
extern struct terminal *decode_live_terminal (Lisp_Object);
diff --git a/src/terminal.c b/src/terminal.c
index b83adc596bb..a9ecb63d85d 100644
--- a/src/terminal.c
+++ b/src/terminal.c
@@ -445,6 +445,10 @@ possible return values. */)
return Qpc;
case output_ns:
return Qns;
+ case output_pgtk:
+ return Qpgtk;
+ case output_haiku:
+ return Qhaiku;
default:
emacs_abort ();
}
diff --git a/src/timefns.c b/src/timefns.c
index a9921cdc108..74b5ca8d515 100644
--- a/src/timefns.c
+++ b/src/timefns.c
@@ -69,16 +69,6 @@ enum { TM_YEAR_BASE = 1900 };
# define FASTER_TIMEFNS 1
#endif
-/* Whether to warn about Lisp timestamps (TICKS . HZ) that may be
- instances of obsolete-format timestamps (HI . LO) where HI is
- the high-order bits and LO the low-order 16 bits. Currently this
- is true, but it should change to false in a future version of
- Emacs. Compile with -DWARN_OBSOLETE_TIMESTAMPS=0 to see what the
- future will be like. */
-#ifndef WARN_OBSOLETE_TIMESTAMPS
-enum { WARN_OBSOLETE_TIMESTAMPS = true };
-#endif
-
/* Although current-time etc. generate list-format timestamps
(HI LO US PS), the plan is to change these functions to generate
frequency-based timestamps (TICKS . HZ) in a future release.
@@ -817,14 +807,10 @@ decode_time_components (enum timeform form,
return decode_ticks_hz (make_integer_mpz (), hz, result, dresult);
}
-enum { DECODE_SECS_ONLY = WARN_OBSOLETE_TIMESTAMPS + 1 };
-
/* Decode a Lisp timestamp SPECIFIED_TIME that represents a time.
- FLAGS specifies conversion flags. If FLAGS & DECODE_SECS_ONLY,
- ignore and do not validate any sub-second components of an
- old-format SPECIFIED_TIME. If FLAGS & WARN_OBSOLETE_TIMESTAMPS,
- diagnose what could be obsolete (HIGH . LOW) timestamps.
+ If DECODE_SECS_ONLY, ignore and do not validate any sub-second
+ components of an old-format SPECIFIED_TIME.
If RESULT is not null, store into *RESULT the converted time;
otherwise, store into *DRESULT the number of seconds since the
@@ -833,7 +819,7 @@ enum { DECODE_SECS_ONLY = WARN_OBSOLETE_TIMESTAMPS + 1 };
Return the form of SPECIFIED-TIME. Signal an error if unsuccessful. */
static enum timeform
-decode_lisp_time (Lisp_Object specified_time, int flags,
+decode_lisp_time (Lisp_Object specified_time, bool decode_secs_only,
struct lisp_time *result, double *dresult)
{
Lisp_Object high = make_fixnum (0);
@@ -854,7 +840,7 @@ decode_lisp_time (Lisp_Object specified_time, int flags,
{
Lisp_Object low_tail = XCDR (low);
low = XCAR (low);
- if (! (flags & DECODE_SECS_ONLY))
+ if (! decode_secs_only)
{
if (CONSP (low_tail))
{
@@ -877,9 +863,6 @@ decode_lisp_time (Lisp_Object specified_time, int flags,
}
else
{
- if (flags & WARN_OBSOLETE_TIMESTAMPS
- && RANGED_FIXNUMP (0, low, (1 << LO_TIME_BITS) - 1))
- message ("obsolete timestamp with cdr %"pI"d", XFIXNUM (low));
form = TIMEFORM_TICKS_HZ;
}
@@ -1008,8 +991,7 @@ static struct lisp_time
lisp_time_struct (Lisp_Object specified_time, enum timeform *pform)
{
struct lisp_time t;
- enum timeform form
- = decode_lisp_time (specified_time, WARN_OBSOLETE_TIMESTAMPS, &t, 0);
+ enum timeform form = decode_lisp_time (specified_time, false, &t, 0);
if (pform)
*pform = form;
return t;
@@ -1034,9 +1016,8 @@ lisp_time_argument (Lisp_Object specified_time)
static time_t
lisp_seconds_argument (Lisp_Object specified_time)
{
- int flags = WARN_OBSOLETE_TIMESTAMPS | DECODE_SECS_ONLY;
struct lisp_time lt;
- decode_lisp_time (specified_time, flags, &lt, 0);
+ decode_lisp_time (specified_time, true, &lt, 0);
struct timespec t = lisp_to_timespec (lt);
if (! timespec_valid_p (t))
time_overflow ();
@@ -1138,24 +1119,6 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract)
mpz_t *ihz = &mpz[0];
mpz_mul (*ihz, *fa, *db);
- /* When warning about obsolete timestamps, if the smaller
- denominator comes from a non-(TICKS . HZ) timestamp and could
- generate a (TICKS . HZ) timestamp that would look obsolete,
- arrange for the result to have a higher HZ to avoid a
- spurious warning by a later consumer of this function's
- returned value. */
- verify (1 << LO_TIME_BITS <= ULONG_MAX);
- if (WARN_OBSOLETE_TIMESTAMPS
- && (da_lt_db ? aform : bform) == TIMEFORM_FLOAT
- && (da_lt_db ? bform : aform) != TIMEFORM_TICKS_HZ
- && mpz_cmp_ui (*hzmin, 1) > 0
- && mpz_cmp_ui (*hzmin, 1 << LO_TIME_BITS) < 0)
- {
- mpz_t *hzmin1 = &mpz[2 - da_lt_db];
- mpz_set_ui (*hzmin1, 1 << LO_TIME_BITS);
- hzmin = hzmin1;
- }
-
/* iticks = (fb * na) OP (fa * nb), where OP is + or -. */
mpz_t const *na = bignum_integer (iticks, ta.ticks);
mpz_mul (*iticks, *fb, *na);
@@ -1177,8 +1140,7 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract)
upwards by multiplying the normalized numerator and denominator
so that the resulting denominator becomes at least hzmin.
This rescaling avoids returning a timestamp that is less precise
- than both a and b, or a timestamp that looks obsolete when that
- might be a problem. */
+ than both a and b. */
if (!FASTER_TIMEFNS || mpz_cmp (*ihz, *hzmin) < 0)
{
/* Rescale straightforwardly. Although this might not
@@ -1303,7 +1265,7 @@ or (if you need time as a string) `format-time-string'. */)
(Lisp_Object specified_time)
{
double t;
- decode_lisp_time (specified_time, 0, 0, &t);
+ decode_lisp_time (specified_time, false, 0, &t);
return make_float (t);
}
@@ -1651,12 +1613,11 @@ saving flag to be guessed.
As an obsolescent calling convention, if this function is called with
6 or more arguments, the first 6 arguments are SECOND, MINUTE, HOUR,
-DAY, MONTH, and YEAR, and specify the components of a decoded time,
-where DST assumed to be -1 and FORM is omitted. If there are more
-than 6 arguments the *last* argument is used as ZONE and any other
-extra arguments are ignored, so that (apply #\\='encode-time
-(decode-time ...)) works. In this obsolescent convention, DST and
-ZONE default to -1 and nil respectively.
+DAY, MONTH, and YEAR, and specify the components of a decoded time.
+If there are more than 6 arguments the *last* argument is used as ZONE
+and any other extra arguments are ignored, so that (apply
+#\\='encode-time (decode-time ...)) works. In this obsolescent
+convention, DST and ZONE default to -1 and nil respectively.
Years before 1970 are not guaranteed to work. On some systems,
year values as low as 1901 do work.
@@ -1703,7 +1664,7 @@ usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */)
/* Let SEC = floor (LT.ticks / HZ), with SUBSECTICKS the remainder. */
struct lisp_time lt;
- decode_lisp_time (secarg, 0, &lt, 0);
+ decode_lisp_time (secarg, false, &lt, 0);
Lisp_Object hz = lt.hz, sec, subsecticks;
if (FASTER_TIMEFNS && EQ (hz, make_fixnum (1)))
{
@@ -1756,9 +1717,7 @@ Truncate the returned value toward minus infinity.
If FORM is nil (the default), return the same form as `current-time'.
If FORM is a positive integer, return a pair of integers (TICKS . FORM),
where TICKS is the number of clock ticks and FORM is the clock frequency
-in ticks per second. (Currently the positive integer should be at least
-65536 if the returned value is expected to be given to standard functions
-expecting Lisp timestamps.) If FORM is t, return (TICKS . PHZ), where
+in ticks per second. If FORM is t, return (TICKS . PHZ), where
PHZ is a suitable clock frequency in ticks per second. If FORM is
`integer', return an integer count of seconds. If FORM is `list',
return an integer list (HIGH LOW USEC PSEC), where HIGH has the most
@@ -1767,7 +1726,7 @@ bits, and USEC and PSEC are the microsecond and picosecond counts. */)
(Lisp_Object time, Lisp_Object form)
{
struct lisp_time t;
- enum timeform input_form = decode_lisp_time (time, 0, &t, 0);
+ enum timeform input_form = decode_lisp_time (time, false, &t, 0);
if (NILP (form))
form = CURRENT_TIME_LIST ? Qlist : Qt;
if (EQ (form, Qlist))
diff --git a/src/verbose.mk.in b/src/verbose.mk.in
index a5ff931ed09..9252971acc3 100644
--- a/src/verbose.mk.in
+++ b/src/verbose.mk.in
@@ -23,7 +23,9 @@ ifeq (${V},1)
AM_V_AR =
AM_V_at =
AM_V_CC =
+AM_V_CXX =
AM_V_CCLD =
+AM_V_CXXLD =
AM_V_ELC =
AM_V_ELN =
AM_V_GEN =
@@ -34,7 +36,9 @@ else
AM_V_AR = @echo " AR " $@;
AM_V_at = @
AM_V_CC = @echo " CC " $@;
+AM_V_CXX = @echo " CXX " $@;
AM_V_CCLD = @echo " CCLD " $@;
+AM_V_CXXLD = @echo " CXXLD " $@;
ifeq ($(HAVE_NATIVE_COMP),yes)
ifeq ($(NATIVE_DISABLED),1)
AM_V_ELC = @echo " ELC " $@;
diff --git a/src/w32.c b/src/w32.c
index 80e42acf500..1de148f0343 100644
--- a/src/w32.c
+++ b/src/w32.c
@@ -2820,53 +2820,6 @@ sys_putenv (char *str)
#define REG_ROOT "SOFTWARE\\GNU\\Emacs"
-LPBYTE
-w32_get_resource (const char *key, LPDWORD lpdwtype)
-{
- LPBYTE lpvalue;
- HKEY hrootkey = NULL;
- DWORD cbData;
-
- /* Check both the current user and the local machine to see if
- we have any resources. */
-
- if (RegOpenKeyEx (HKEY_CURRENT_USER, REG_ROOT, 0, KEY_READ, &hrootkey) == ERROR_SUCCESS)
- {
- lpvalue = NULL;
-
- if (RegQueryValueEx (hrootkey, key, NULL, NULL, NULL, &cbData) == ERROR_SUCCESS
- && (lpvalue = xmalloc (cbData)) != NULL
- && RegQueryValueEx (hrootkey, key, NULL, lpdwtype, lpvalue, &cbData) == ERROR_SUCCESS)
- {
- RegCloseKey (hrootkey);
- return (lpvalue);
- }
-
- xfree (lpvalue);
-
- RegCloseKey (hrootkey);
- }
-
- if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, REG_ROOT, 0, KEY_READ, &hrootkey) == ERROR_SUCCESS)
- {
- lpvalue = NULL;
-
- if (RegQueryValueEx (hrootkey, key, NULL, NULL, NULL, &cbData) == ERROR_SUCCESS
- && (lpvalue = xmalloc (cbData)) != NULL
- && RegQueryValueEx (hrootkey, key, NULL, lpdwtype, lpvalue, &cbData) == ERROR_SUCCESS)
- {
- RegCloseKey (hrootkey);
- return (lpvalue);
- }
-
- xfree (lpvalue);
-
- RegCloseKey (hrootkey);
- }
-
- return (NULL);
-}
-
/* The argv[] array holds ANSI-encoded strings, and so this function
works with ANS_encoded strings. */
void
@@ -3077,7 +3030,7 @@ init_environment (char ** argv)
int dont_free = 0;
char bufc[SET_ENV_BUF_SIZE];
- if ((lpval = w32_get_resource (env_vars[i].name, &dwType)) == NULL
+ if ((lpval = w32_get_resource (REG_ROOT, env_vars[i].name, &dwType)) == NULL
/* Also ignore empty environment variables. */
|| *lpval == 0)
{
@@ -8595,7 +8548,7 @@ fcntl (int s, int cmd, int options)
int
sys_close (int fd)
{
- int rc;
+ int rc = -1;
if (fd < 0)
{
@@ -8650,14 +8603,31 @@ sys_close (int fd)
}
}
- if (fd >= 0 && fd < MAXDESC)
- fd_info[fd].flags = 0;
-
/* Note that sockets do not need special treatment here (at least on
NT and Windows 95 using the standard tcp/ip stacks) - it appears that
closesocket is equivalent to CloseHandle, which is to be expected
because socket handles are fully fledged kernel handles. */
- rc = _close (fd);
+ if (fd < MAXDESC)
+ {
+ if ((fd_info[fd].flags & FILE_DONT_CLOSE) == 0)
+ {
+ fd_info[fd].flags = 0;
+ rc = _close (fd);
+ }
+ else
+ {
+ /* We don't close here descriptors open by pipe processes
+ for reading from the pipe, because the reader thread
+ might be stuck in _sys_read_ahead, and then we will hang
+ here. If the reader thread exits normally, it will close
+ the descriptor; otherwise we will leave a zombie thread
+ hanging around. */
+ rc = 0;
+ /* Leave the flag set for the reader thread to close the
+ descriptor. */
+ fd_info[fd].flags = FILE_DONT_CLOSE;
+ }
+ }
return rc;
}
@@ -10945,6 +10915,7 @@ register_aux_fd (int infd)
}
fd_info[ infd ].cp = cp;
fd_info[ infd ].hnd = (HANDLE) _get_osfhandle (infd);
+ fd_info[ infd ].flags |= FILE_DONT_CLOSE;
}
#ifdef HAVE_GNUTLS
diff --git a/src/w32.h b/src/w32.h
index 5aba0aed9a6..bb3ec40324a 100644
--- a/src/w32.h
+++ b/src/w32.h
@@ -135,6 +135,7 @@ extern filedesc fd_info [ MAXDESC ];
#define FILE_SOCKET 0x0200
#define FILE_NDELAY 0x0400
#define FILE_SERIAL 0x0800
+#define FILE_DONT_CLOSE 0x1000
extern child_process * new_child (void);
extern void delete_child (child_process *cp);
@@ -161,8 +162,9 @@ extern void prepare_standard_handles (int in, int out,
extern void reset_standard_handles (int in, int out,
int err, HANDLE handles[3]);
-/* Return the string resource associated with KEY of type TYPE. */
-extern LPBYTE w32_get_resource (const char * key, LPDWORD type);
+/* Query Windows Registry and return the resource associated
+ associated with KEY and NAME of type TYPE. */
+extern LPBYTE w32_get_resource (const char * key, const char * name, LPDWORD type);
extern void release_listen_threads (void);
extern void init_ntproc (int);
diff --git a/src/w32fns.c b/src/w32fns.c
index 14d1154a2bc..02a6d78b51c 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -73,6 +73,20 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <imm.h>
#include <windowsx.h>
+/*
+ Internal/undocumented constants for Windows Dark mode.
+ See: https://github.com/microsoft/WindowsAppSDK/issues/41
+*/
+#define DARK_MODE_APP_NAME L"DarkMode_Explorer"
+/* For Windows 10 version 1809, 1903, 1909. */
+#ifndef DWMWA_USE_IMMERSIVE_DARK_MODE_OLD
+#define DWMWA_USE_IMMERSIVE_DARK_MODE_OLD 19
+#endif
+/* For Windows 10 version 2004 and higher, and Windows 11. */
+#ifndef DWMWA_USE_IMMERSIVE_DARK_MODE
+#define DWMWA_USE_IMMERSIVE_DARK_MODE 20
+#endif
+
#ifndef FOF_NO_CONNECTED_ELEMENTS
#define FOF_NO_CONNECTED_ELEMENTS 0x2000
#endif
@@ -185,6 +199,11 @@ typedef BOOL (WINAPI *IsDebuggerPresent_Proc) (void);
typedef HRESULT (WINAPI *SetThreadDescription_Proc)
(HANDLE hThread, PCWSTR lpThreadDescription);
+typedef HRESULT (WINAPI * SetWindowTheme_Proc)
+ (IN HWND hwnd, IN LPCWSTR pszSubAppName, IN LPCWSTR pszSubIdList);
+typedef HRESULT (WINAPI * DwmSetWindowAttribute_Proc)
+ (HWND hwnd, DWORD dwAttribute, IN LPCVOID pvAttribute, DWORD cbAttribute);
+
TrackMouseEvent_Proc track_mouse_event_fn = NULL;
ImmGetCompositionString_Proc get_composition_string_fn = NULL;
ImmGetContext_Proc get_ime_context_fn = NULL;
@@ -199,6 +218,8 @@ EnumDisplayMonitors_Proc enum_display_monitors_fn = NULL;
GetTitleBarInfo_Proc get_title_bar_info_fn = NULL;
IsDebuggerPresent_Proc is_debugger_present = NULL;
SetThreadDescription_Proc set_thread_description = NULL;
+SetWindowTheme_Proc SetWindowTheme_fn = NULL;
+DwmSetWindowAttribute_Proc DwmSetWindowAttribute_fn = NULL;
extern AppendMenuW_Proc unicode_append_menu;
@@ -252,6 +273,9 @@ int w32_major_version;
int w32_minor_version;
int w32_build_number;
+/* If the OS is set to use dark mode. */
+BOOL w32_darkmode = FALSE;
+
/* Distinguish between Windows NT and Windows 95. */
int os_subtype;
@@ -2279,10 +2303,36 @@ w32_init_class (HINSTANCE hinst)
}
}
+/* Applies the Windows system theme (light or dark) to the window
+ handle HWND. */
+static void
+w32_applytheme (HWND hwnd)
+{
+ if (w32_darkmode)
+ {
+ /* Set window theme to that of a built-in Windows app (Explorer),
+ because it has dark scroll bars and other UI elements. */
+ if (SetWindowTheme_fn)
+ SetWindowTheme_fn (hwnd, DARK_MODE_APP_NAME, NULL);
+
+ /* Set the titlebar to system dark mode. */
+ if (DwmSetWindowAttribute_fn)
+ {
+ /* Windows 10 version 2004 and up, Windows 11. */
+ DWORD attr = DWMWA_USE_IMMERSIVE_DARK_MODE;
+ /* Windows 10 older than 2004. */
+ if (w32_build_number < 19041)
+ attr = DWMWA_USE_IMMERSIVE_DARK_MODE_OLD;
+ DwmSetWindowAttribute_fn (hwnd, attr,
+ &w32_darkmode, sizeof (w32_darkmode));
+ }
+ }
+}
+
static HWND
w32_createvscrollbar (struct frame *f, struct scroll_bar * bar)
{
- return CreateWindow ("SCROLLBAR", "",
+ HWND hwnd = CreateWindow ("SCROLLBAR", "",
/* Clip siblings so we don't draw over child
frames. Apparently this is not always
sufficient so we also try to make bar windows
@@ -2291,12 +2341,15 @@ w32_createvscrollbar (struct frame *f, struct scroll_bar * bar)
/* Position and size of scroll bar. */
bar->left, bar->top, bar->width, bar->height,
FRAME_W32_WINDOW (f), NULL, hinst, NULL);
+ if (hwnd)
+ w32_applytheme (hwnd);
+ return hwnd;
}
static HWND
w32_createhscrollbar (struct frame *f, struct scroll_bar * bar)
{
- return CreateWindow ("SCROLLBAR", "",
+ HWND hwnd = CreateWindow ("SCROLLBAR", "",
/* Clip siblings so we don't draw over child
frames. Apparently this is not always
sufficient so we also try to make bar windows
@@ -2305,6 +2358,9 @@ w32_createhscrollbar (struct frame *f, struct scroll_bar * bar)
/* Position and size of scroll bar. */
bar->left, bar->top, bar->width, bar->height,
FRAME_W32_WINDOW (f), NULL, hinst, NULL);
+ if (hwnd)
+ w32_applytheme (hwnd);
+ return hwnd;
}
static void
@@ -2390,6 +2446,9 @@ w32_createwindow (struct frame *f, int *coords)
/* Enable drag-n-drop. */
DragAcceptFiles (hwnd, TRUE);
+ /* Enable system light/dark theme. */
+ w32_applytheme (hwnd);
+
/* Do this to discard the default setting specified by our parent. */
ShowWindow (hwnd, SW_HIDE);
@@ -5114,6 +5173,13 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
goto dflt;
+ case WM_SETTINGCHANGE:
+ /* Inform the Lisp thread that some system-wide setting has
+ changed, so if Emacs is interested in some of them, it could
+ update its internal values. */
+ my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
+ goto dflt;
+
case WM_SETFOCUS:
dpyinfo->faked_key = 0;
reset_modifiers ();
@@ -7459,7 +7525,8 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0,
try_window (window, pos, TRY_WINDOW_IGNORE_FONTS_CHANGE);
/* Calculate size of tooltip window. */
size = Fwindow_text_pixel_size (window, Qnil, Qnil, Qnil,
- make_fixnum (w->pixel_height), Qnil);
+ make_fixnum (w->pixel_height), Qnil,
+ Qnil);
/* Add the frame's internal border to calculated size. */
width = XFIXNUM (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
height = XFIXNUM (Fcdr (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
@@ -10257,6 +10324,60 @@ to be converted to forward slashes by the caller. */)
}
#endif /* WINDOWSNT */
+
+/* Query a value from the Windows Registry (under HKCU and HKLM),
+ where `key` is the registry key, `name` is the name, and `lpdwtype`
+ is a pointer to the return value's type. `lpwdtype` can be NULL if
+ you do not care about the type.
+
+ Returns: pointer to the value, or null pointer if the key/name does
+ not exist. */
+LPBYTE
+w32_get_resource (const char *key, const char *name, LPDWORD lpdwtype)
+{
+ LPBYTE lpvalue;
+ HKEY hrootkey = NULL;
+ DWORD cbData;
+
+ /* Check both the current user and the local machine to see if
+ we have any resources. */
+
+ if (RegOpenKeyEx (HKEY_CURRENT_USER, key, 0, KEY_READ, &hrootkey) == ERROR_SUCCESS)
+ {
+ lpvalue = NULL;
+
+ if (RegQueryValueEx (hrootkey, name, NULL, NULL, NULL, &cbData) == ERROR_SUCCESS
+ && (lpvalue = xmalloc (cbData)) != NULL
+ && RegQueryValueEx (hrootkey, name, NULL, lpdwtype, lpvalue, &cbData) == ERROR_SUCCESS)
+ {
+ RegCloseKey (hrootkey);
+ return (lpvalue);
+ }
+
+ xfree (lpvalue);
+
+ RegCloseKey (hrootkey);
+ }
+
+ if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, key, 0, KEY_READ, &hrootkey) == ERROR_SUCCESS)
+ {
+ lpvalue = NULL;
+
+ if (RegQueryValueEx (hrootkey, name, NULL, NULL, NULL, &cbData) == ERROR_SUCCESS
+ && (lpvalue = xmalloc (cbData)) != NULL
+ && RegQueryValueEx (hrootkey, name, NULL, lpdwtype, lpvalue, &cbData) == ERROR_SUCCESS)
+ {
+ RegCloseKey (hrootkey);
+ return (lpvalue);
+ }
+
+ xfree (lpvalue);
+
+ RegCloseKey (hrootkey);
+ }
+
+ return (NULL);
+}
/***********************************************************************
Initialization
@@ -11028,6 +11149,37 @@ globals_of_w32fns (void)
set_thread_description = (SetThreadDescription_Proc)
get_proc_addr (hm_kernel32, "SetThreadDescription");
+ /* 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:
+ https://docs.microsoft.com/en-us/windows/release-health/release-information
+ */
+ if (os_subtype == OS_SUBTYPE_NT
+ && w32_major_version >= 10 && w32_build_number >= 17763)
+ {
+ /* Load dwmapi.dll and uxtheme.dll, which will be needed to set
+ window themes. */
+ HMODULE dwmapi_lib = LoadLibrary("dwmapi.dll");
+ DwmSetWindowAttribute_fn = (DwmSetWindowAttribute_Proc)
+ get_proc_addr (dwmapi_lib, "DwmSetWindowAttribute");
+ HMODULE uxtheme_lib = LoadLibrary("uxtheme.dll");
+ SetWindowTheme_fn = (SetWindowTheme_Proc)
+ get_proc_addr (uxtheme_lib, "SetWindowTheme");
+
+ /* Check Windows Registry for system theme and set w32_darkmode.
+ TODO: "Nice to have" would be to create a lisp setting (which
+ defaults to this Windows Registry value), then read that lisp
+ value here instead. This would allow the user to forcibly
+ override the system theme (which is also user-configurable in
+ Windows settings; see MS-Windows section in Emacs manual). */
+ LPBYTE val =
+ w32_get_resource ("Software\\Microsoft\\Windows\\CurrentVersion\\Themes\\Personalize",
+ "AppsUseLightTheme",
+ NULL);
+ if (val && *val == 0)
+ w32_darkmode = TRUE;
+ }
+
except_code = 0;
except_addr = 0;
#ifndef CYGWIN
diff --git a/src/w32font.c b/src/w32font.c
index 3025d0efa88..2d09f459f89 100644
--- a/src/w32font.c
+++ b/src/w32font.c
@@ -1974,10 +1974,11 @@ w32_decode_weight (int fnweight)
if (fnweight >= FW_EXTRABOLD) return 205;
if (fnweight >= FW_BOLD) return 200;
if (fnweight >= FW_SEMIBOLD) return 180;
- if (fnweight >= FW_NORMAL) return 100;
- if (fnweight >= FW_LIGHT) return 50;
- if (fnweight >= FW_EXTRALIGHT) return 40;
- if (fnweight > FW_THIN) return 20;
+ if (fnweight >= FW_MEDIUM) return 100;
+ if (fnweight >= FW_NORMAL) return 80;
+ if (fnweight >= FW_LIGHT) return 50;
+ if (fnweight >= FW_EXTRALIGHT) return 40;
+ if (fnweight >= FW_THIN) return 20;
return 0;
}
@@ -1988,10 +1989,11 @@ w32_encode_weight (int n)
if (n >= 205) return FW_EXTRABOLD;
if (n >= 200) return FW_BOLD;
if (n >= 180) return FW_SEMIBOLD;
- if (n >= 100) return FW_NORMAL;
- if (n >= 50) return FW_LIGHT;
- if (n >= 40) return FW_EXTRALIGHT;
- if (n >= 20) return FW_THIN;
+ if (n >= 100) return FW_MEDIUM;
+ if (n >= 80) return FW_NORMAL;
+ if (n >= 50) return FW_LIGHT;
+ if (n >= 40) return FW_EXTRALIGHT;
+ if (n >= 20) return FW_THIN;
return 0;
}
@@ -2000,14 +2002,15 @@ w32_encode_weight (int n)
static Lisp_Object
w32_to_fc_weight (int n)
{
- if (n >= FW_HEAVY) return intern ("black");
- if (n >= FW_EXTRABOLD) return Qextra_bold;
- if (n >= FW_BOLD) return Qbold;
- if (n >= FW_SEMIBOLD) return intern ("demibold");
- if (n >= FW_NORMAL) return intern ("medium");
- if (n >= FW_LIGHT) return Qlight;
+ if (n >= FW_HEAVY) return Qblack;
+ if (n >= FW_EXTRABOLD) return Qextra_bold;
+ if (n >= FW_BOLD) return Qbold;
+ if (n >= FW_SEMIBOLD) return Qsemi_bold;
+ if (n >= FW_MEDIUM) return Qmedium;
+ if (n >= FW_NORMAL) return Qnormal;
+ if (n >= FW_LIGHT) return Qlight;
if (n >= FW_EXTRALIGHT) return Qextra_light;
- return intern ("thin");
+ return Qthin;
}
/* Fill in all the available details of LOGFONT from FONT_SPEC. */
diff --git a/src/w32inevt.c b/src/w32inevt.c
index 894bc3ab089..4cc01d31c94 100644
--- a/src/w32inevt.c
+++ b/src/w32inevt.c
@@ -420,7 +420,7 @@ w32_console_mouse_position (struct frame **f,
*f = get_frame ();
*bar_window = Qnil;
*part = scroll_bar_above_handle;
- SELECTED_FRAME ()->mouse_moved = 0;
+ (*f)->mouse_moved = 0;
XSETINT (*x, movement_pos.X);
XSETINT (*y, movement_pos.Y);
@@ -436,7 +436,8 @@ mouse_moved_to (int x, int y)
/* If we're in the same place, ignore it. */
if (x != movement_pos.X || y != movement_pos.Y)
{
- SELECTED_FRAME ()->mouse_moved = 1;
+ struct frame *f = get_frame ();
+ f->mouse_moved = 1;
movement_pos.X = x;
movement_pos.Y = y;
movement_time = GetTickCount ();
@@ -471,13 +472,13 @@ do_mouse_event (MOUSE_EVENT_RECORD *event,
int i;
/* Mouse didn't move unless MOUSE_MOVED says it did. */
- SELECTED_FRAME ()->mouse_moved = 0;
+ struct frame *f = get_frame ();
+ f->mouse_moved = 0;
switch (flags)
{
case MOUSE_MOVED:
{
- struct frame *f = get_frame ();
Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f);
int mx = event->dwMousePosition.X, my = event->dwMousePosition.Y;
@@ -536,7 +537,6 @@ do_mouse_event (MOUSE_EVENT_RECORD *event,
case MOUSE_WHEELED:
case MOUSE_HWHEELED:
{
- struct frame *f = get_frame ();
/* Mouse positions in console wheel events are reported to
ReadConsoleInput relative to the display's top-left
corner(!), not relative to the origin of the console screen
@@ -588,8 +588,8 @@ do_mouse_event (MOUSE_EVENT_RECORD *event,
int x = event->dwMousePosition.X;
int y = event->dwMousePosition.Y;
- struct frame *f = get_frame ();
- emacs_ev->arg = tty_handle_tab_bar_click (f, x, y, (button_state & mask) != 0,
+ emacs_ev->arg = tty_handle_tab_bar_click (f, x, y,
+ (button_state & mask) != 0,
emacs_ev);
emacs_ev->modifiers |= ((button_state & mask)
diff --git a/src/w32proc.c b/src/w32proc.c
index 360f45e9e11..bfe720eb623 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -1206,6 +1206,7 @@ static DWORD WINAPI
reader_thread (void *arg)
{
child_process *cp;
+ int fd;
/* Our identity */
cp = (child_process *)arg;
@@ -1220,12 +1221,13 @@ reader_thread (void *arg)
{
int rc;
- if (cp->fd >= 0 && (fd_info[cp->fd].flags & FILE_CONNECT) != 0)
- rc = _sys_wait_connect (cp->fd);
- else if (cp->fd >= 0 && (fd_info[cp->fd].flags & FILE_LISTEN) != 0)
- rc = _sys_wait_accept (cp->fd);
+ fd = cp->fd;
+ if (fd >= 0 && (fd_info[fd].flags & FILE_CONNECT) != 0)
+ rc = _sys_wait_connect (fd);
+ else if (fd >= 0 && (fd_info[fd].flags & FILE_LISTEN) != 0)
+ rc = _sys_wait_accept (fd);
else
- rc = _sys_read_ahead (cp->fd);
+ rc = _sys_read_ahead (fd);
/* Don't bother waiting for the event if we already have been
told to exit by delete_child. */
@@ -1238,7 +1240,7 @@ reader_thread (void *arg)
{
DebPrint (("reader_thread.SetEvent(0x%x) failed with %lu for fd %ld (PID %d)\n",
(DWORD_PTR)cp->char_avail, GetLastError (),
- cp->fd, cp->pid));
+ fd, cp->pid));
return 1;
}
@@ -1266,6 +1268,13 @@ reader_thread (void *arg)
if (cp->status == STATUS_READ_ERROR)
break;
}
+ /* If this thread was reading from a pipe process, close the
+ descriptor used for reading, as sys_close doesn't in that case. */
+ if (fd_info[fd].flags == FILE_DONT_CLOSE)
+ {
+ fd_info[fd].flags = 0;
+ _close (fd);
+ }
return 0;
}
diff --git a/src/w32term.c b/src/w32term.c
index 9cf250cd73f..fdb088deda2 100644
--- a/src/w32term.c
+++ b/src/w32term.c
@@ -164,6 +164,10 @@ int last_scroll_bar_drag_pos;
/* Keyboard code page - may be changed by language-change events. */
int w32_keyboard_codepage;
+/* The number of screen lines to scroll for the default mouse-wheel
+ scroll amount, given by WHEEL_DELTA. */
+static UINT w32_wheel_scroll_lines;
+
#ifdef CYGWIN
int w32_message_fd = -1;
#endif /* CYGWIN */
@@ -272,6 +276,19 @@ XGetGCValues (void *ignore, XGCValues *gc,
#endif
static void
+w32_get_mouse_wheel_vertical_delta (void)
+{
+ if (os_subtype != OS_SUBTYPE_NT)
+ return;
+
+ UINT scroll_lines;
+ BOOL ret = SystemParametersInfo (SPI_GETWHEELSCROLLLINES, 0,
+ &scroll_lines, 0);
+ if (ret)
+ w32_wheel_scroll_lines = scroll_lines;
+}
+
+static void
w32_set_clip_rectangle (HDC hdc, RECT *rect)
{
if (rect)
@@ -954,22 +971,6 @@ w32_set_cursor_gc (struct glyph_string *s)
static void
w32_set_mouse_face_gc (struct glyph_string *s)
{
- int face_id;
- struct face *face;
-
- /* What face has to be used last for the mouse face? */
- face_id = MOUSE_HL_INFO (s->f)->mouse_face_face_id;
- face = FACE_FROM_ID_OR_NULL (s->f, face_id);
- if (face == NULL)
- face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
-
- if (s->first_glyph->type == CHAR_GLYPH)
- face_id = FACE_FOR_CHAR (s->f, face, s->first_glyph->u.ch, -1, Qnil);
- else
- face_id = FACE_FOR_CHAR (s->f, face, 0, -1, Qnil);
- s->face = FACE_FROM_ID (s->f, face_id);
- prepare_face_for_display (s->f, s->face);
-
/* If font in this face is same as S->font, use it. */
if (s->font == s->face->font)
s->gc = s->face->gc;
@@ -2539,6 +2540,10 @@ w32_draw_glyph_string (struct glyph_string *s)
if (!s->for_overlaps)
{
+ /* Draw relief if not yet drawn. */
+ if (!relief_drawn_p && s->face->box != FACE_NO_BOX)
+ w32_draw_glyph_string_box (s);
+
/* Draw underline. */
if (s->face->underline)
{
@@ -2682,10 +2687,6 @@ w32_draw_glyph_string (struct glyph_string *s)
}
}
- /* Draw relief if not yet drawn. */
- if (!relief_drawn_p && s->face->box != FACE_NO_BOX)
- w32_draw_glyph_string_box (s);
-
if (s->prev)
{
struct glyph_string *prev;
@@ -3219,32 +3220,94 @@ w32_construct_mouse_wheel (struct input_event *result, W32Msg *msg,
{
POINT p;
int delta;
+ static int sum_delta_y = 0;
result->kind = msg->msg.message == WM_MOUSEHWHEEL ? HORIZ_WHEEL_EVENT
: WHEEL_EVENT;
result->code = 0;
result->timestamp = msg->msg.time;
+ result->arg = Qnil;
/* A WHEEL_DELTA positive value indicates that the wheel was rotated
forward, away from the user (up); a negative value indicates that
the wheel was rotated backward, toward the user (down). */
delta = GET_WHEEL_DELTA_WPARAM (msg->msg.wParam);
+ if (delta == 0)
+ {
+ result->kind = NO_EVENT;
+ return Qnil;
+ }
+
+ /* With multiple monitors, we can legitimately get negative
+ coordinates, so cast to short to interpret them correctly. */
+ p.x = (short) LOWORD (msg->msg.lParam);
+ p.y = (short) HIWORD (msg->msg.lParam);
+
+ if (eabs (delta) < WHEEL_DELTA)
+ {
+ /* This is high-precision mouse wheel, which sends
+ fine-resolution wheel events. Produce a wheel event only if
+ the conditions for sending such an event are fulfilled. */
+ int scroll_unit = max (w32_wheel_scroll_lines, 1), nlines;
+ double value_to_report;
+
+ /* w32_wheel_scroll_lines == UINT_MAX means the user asked for
+ "entire page" to be the scroll unit. We interpret that as
+ the height of the window under the mouse pointer. */
+ if (w32_wheel_scroll_lines == UINT_MAX)
+ {
+ Lisp_Object window = window_from_coordinates (f, p.x, p.y, NULL,
+ false, false);
+ if (!WINDOWP (window))
+ {
+ result->kind = NO_EVENT;
+ return Qnil;
+ }
+ scroll_unit = XWINDOW (window)->pixel_height;
+ if (scroll_unit < 1) /* paranoia */
+ scroll_unit = 1;
+ }
+
+ /* If mwheel-coalesce-scroll-events is non-nil, report a wheel event
+ only when we have accumulated enough delta's for WHEEL_DELTA. */
+ if (mwheel_coalesce_scroll_events)
+ {
+ /* If the user changed the direction, reset the accumulated
+ deltas. */
+ if ((delta > 0) != (sum_delta_y > 0))
+ sum_delta_y = 0;
+ sum_delta_y += delta;
+ /* https://docs.microsoft.com/en-us/previous-versions/ms997498(v=msdn.10) */
+ if (eabs (sum_delta_y) < WHEEL_DELTA)
+ {
+ result->kind = NO_EVENT;
+ return Qnil;
+ }
+ value_to_report =
+ ((double)FRAME_LINE_HEIGHT (f) * scroll_unit)
+ / ((double)WHEEL_DELTA / sum_delta_y);
+ sum_delta_y = 0;
+ }
+ else
+ value_to_report =
+ ((double)FRAME_LINE_HEIGHT (f) * scroll_unit)
+ / ((double)WHEEL_DELTA / delta);
+ nlines = value_to_report / FRAME_LINE_HEIGHT (f) + 0.5;
+ result->arg = list3 (make_fixnum (nlines),
+ make_float (0.0),
+ make_float (value_to_report));
+ }
/* The up and down modifiers indicate if the wheel was rotated up or
down based on WHEEL_DELTA value. */
result->modifiers = (msg->dwModifiers
| ((delta < 0 ) ? down_modifier : up_modifier));
- /* With multiple monitors, we can legitimately get negative
- coordinates, so cast to short to interpret them correctly. */
- p.x = (short) LOWORD (msg->msg.lParam);
- p.y = (short) HIWORD (msg->msg.lParam);
/* For the case that F's w32 window is not msg->msg.hwnd. */
ScreenToClient (FRAME_W32_WINDOW (f), &p);
XSETINT (result->x, p.x);
XSETINT (result->y, p.y);
XSETFRAME (result->frame_or_window, f);
- result->arg = Qnil;
return Qnil;
}
@@ -4921,6 +4984,14 @@ w32_read_socket (struct terminal *terminal,
}
break;
+ case WM_SETTINGCHANGE:
+ /* We are only interested in changes of the number of lines
+ to scroll when the vertical mouse wheel is moved. This
+ is only supported on NT. */
+ if (msg.msg.wParam == SPI_SETWHEELSCROLLLINES)
+ w32_get_mouse_wheel_vertical_delta ();
+ break;
+
case WM_KEYDOWN:
case WM_SYSKEYDOWN:
f = w32_window_to_frame (dpyinfo, msg.msg.hwnd);
@@ -7538,6 +7609,8 @@ w32_initialize (void)
horizontal_scroll_bar_left_border = horizontal_scroll_bar_right_border
= GetSystemMetrics (SM_CYHSCROLL);
}
+
+ w32_get_mouse_wheel_vertical_delta ();
}
void
diff --git a/src/window.h b/src/window.h
index 2400c422c15..8e9a2eb3177 100644
--- a/src/window.h
+++ b/src/window.h
@@ -756,7 +756,7 @@ wset_next_buffers (struct window *w, Lisp_Object val)
#endif
/* True if W is a tab bar window. */
-#if defined (HAVE_WINDOW_SYSTEM)
+#if defined (HAVE_WINDOW_SYSTEM) && !defined (HAVE_PGTK)
# define WINDOW_TAB_BAR_P(W) \
(WINDOWP (WINDOW_XFRAME (W)->tab_bar_window) \
&& (W) == XWINDOW (WINDOW_XFRAME (W)->tab_bar_window))
diff --git a/src/xdisp.c b/src/xdisp.c
index 597b12d4d68..0c35d24c262 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -822,6 +822,9 @@ bool help_echo_showing_p;
/* Functions to mark elements as needing redisplay. */
enum { REDISPLAY_SOME = 2}; /* Arbitrary choice. */
+static bool calc_pixel_width_or_height (double *, struct it *, Lisp_Object,
+ struct font *, bool, int *);
+
void
redisplay_other_windows (void)
{
@@ -1179,7 +1182,13 @@ static void append_stretch_glyph (struct it *, Lisp_Object,
static Lisp_Object get_it_property (struct it *, Lisp_Object);
static Lisp_Object calc_line_height_property (struct it *, Lisp_Object,
struct font *, int, bool);
-
+static int adjust_glyph_width_for_mouse_face (struct glyph *,
+ struct glyph_row *,
+ struct window *, struct face *,
+ struct face *);
+static void get_cursor_offset_for_mouse_face (struct window *w,
+ struct glyph_row *row,
+ int *offset);
#endif /* HAVE_WINDOW_SYSTEM */
static void produce_special_glyphs (struct it *, enum display_element_type);
@@ -1276,8 +1285,8 @@ window_box_height (struct window *w)
if (ml_row && ml_row->mode_line_p)
height -= ml_row->height;
else
- height -= estimate_mode_line_height (f,
- CURRENT_MODE_LINE_FACE_ID (w));
+ height -= estimate_mode_line_height
+ (f, CURRENT_MODE_LINE_ACTIVE_FACE_ID (w));
}
}
@@ -1682,7 +1691,7 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y,
= window_parameter (w, Qmode_line_format);
w->mode_line_height
- = display_mode_line (w, CURRENT_MODE_LINE_FACE_ID (w),
+ = display_mode_line (w, CURRENT_MODE_LINE_ACTIVE_FACE_ID (w),
NILP (window_mode_line_format)
? BVAR (current_buffer, mode_line_format)
: window_mode_line_format);
@@ -3137,11 +3146,11 @@ CHECK_WINDOW_END (struct window *w)
will produce glyphs in that row.
BASE_FACE_ID is the id of a base face to use. It must be one of
- DEFAULT_FACE_ID for normal text, MODE_LINE_FACE_ID,
+ DEFAULT_FACE_ID for normal text, MODE_LINE_ACTIVE_FACE_ID,
MODE_LINE_INACTIVE_FACE_ID, or HEADER_LINE_FACE_ID for displaying
mode lines, or TOOL_BAR_FACE_ID for displaying the tool-bar.
- If ROW is null and BASE_FACE_ID is equal to MODE_LINE_FACE_ID,
+ If ROW is null and BASE_FACE_ID is equal to MODE_LINE_ACTIVE_FACE_ID,
MODE_LINE_INACTIVE_FACE_ID, or HEADER_LINE_FACE_ID, the iterator
will be initialized to use the corresponding mode line glyph row of
the desired matrix of W. */
@@ -3187,7 +3196,7 @@ init_iterator (struct it *it, struct window *w,
appropriate. */
if (row == NULL)
{
- if (base_face_id == MODE_LINE_FACE_ID
+ if (base_face_id == MODE_LINE_ACTIVE_FACE_ID
|| base_face_id == MODE_LINE_INACTIVE_FACE_ID)
row = MATRIX_MODE_LINE_ROW (w->desired_matrix);
else if (base_face_id == TAB_LINE_FACE_ID)
@@ -5151,6 +5160,160 @@ setup_for_ellipsis (struct it *it, int len)
it->ellipsis_p = true;
}
+
+static Lisp_Object
+find_display_property (Lisp_Object disp, Lisp_Object prop)
+{
+ if (NILP (disp))
+ return Qnil;
+ /* We have a vector of display specs. */
+ if (VECTORP (disp))
+ {
+ for (ptrdiff_t i = 0; i < ASIZE (disp); i++)
+ {
+ Lisp_Object elem = AREF (disp, i);
+ if (CONSP (elem)
+ && CONSP (XCDR (elem))
+ && EQ (XCAR (elem), prop))
+ return XCAR (XCDR (elem));
+ }
+ return Qnil;
+ }
+ /* We have a list of display specs. */
+ else if (CONSP (disp)
+ && CONSP (XCAR (disp)))
+ {
+ while (!NILP (disp))
+ {
+ Lisp_Object elem = XCAR (disp);
+ if (CONSP (elem)
+ && CONSP (XCDR (elem))
+ && EQ (XCAR (elem), prop))
+ return XCAR (XCDR (elem));
+
+ /* Check that we have a proper list before going to the next
+ element. */
+ if (CONSP (XCDR (disp)))
+ disp = XCDR (disp);
+ else
+ disp = Qnil;
+ }
+ return Qnil;
+ }
+ /* A simple display spec. */
+ else if (CONSP (disp)
+ && CONSP (XCDR (disp))
+ && EQ (XCAR (disp), prop))
+ return XCAR (XCDR (disp));
+ else
+ return Qnil;
+}
+
+static Lisp_Object
+get_display_property (ptrdiff_t bufpos, Lisp_Object prop, Lisp_Object object)
+{
+ return find_display_property (Fget_text_property (make_fixnum (bufpos),
+ Qdisplay, object),
+ prop);
+}
+
+static void
+display_min_width (struct it *it, ptrdiff_t bufpos,
+ Lisp_Object object, Lisp_Object width_spec)
+{
+ /* We're being called at the end of the `min-width' sequence,
+ probably. */
+ 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
+ :propertize run. */
+ if ((bufpos == 0
+ && !EQ (it->min_width_property,
+ get_display_property (0, Qmin_width, object)))
+ /* In a buffer -- check that we're really right after the
+ sequence of characters covered by this `min-width'. */
+ || (bufpos > BEGV
+ && EQ (it->min_width_property,
+ get_display_property (bufpos - 1, Qmin_width, object))))
+ {
+ Lisp_Object w = Qnil;
+ double width;
+#ifdef HAVE_WINDOW_SYSTEM
+ if (FRAME_WINDOW_P (it->f))
+ {
+ struct font *font = NULL;
+ struct face *face = FACE_FROM_ID (it->f, it->face_id);
+ font = face->font ? face->font : FRAME_FONT (it->f);
+ calc_pixel_width_or_height (&width, it,
+ XCAR (it->min_width_property),
+ font, true, NULL);
+ width -= it->current_x - it->min_width_start;
+ w = list1 (make_int (width));
+ }
+ else
+#endif
+ {
+ calc_pixel_width_or_height (&width, it,
+ XCAR (it->min_width_property),
+ NULL, true, NULL);
+ width -= (it->current_x - it->min_width_start) /
+ FRAME_COLUMN_WIDTH (it->f);
+ w = make_int (width);
+ }
+
+ /* Insert the stretch glyph. */
+ it->object = list3 (Qspace, QCwidth, w);
+ produce_stretch_glyph (it);
+ it->min_width_property = Qnil;
+ }
+ }
+
+ /* We're at the start of a `min-width' sequence -- record the
+ position and the property, so that we can later see if we're at
+ the end. */
+ if (CONSP (width_spec))
+ {
+ if (bufpos == BEGV
+ /* Mode line (see above). */
+ || (bufpos == 0
+ && !EQ (it->min_width_property,
+ get_display_property (0, Qmin_width, object)))
+ /* Buffer. */
+ || (bufpos > BEGV
+ && !EQ (width_spec,
+ get_display_property (bufpos - 1, Qmin_width, object))))
+ {
+ it->min_width_property = width_spec;
+ it->min_width_start = it->current_x;
+ }
+ }
+}
+
+DEFUN ("get-display-property", Fget_display_property,
+ Sget_display_property, 2, 4, 0,
+ doc: /* Get the value of the `display' property PROP at POSITION.
+If OBJECT, this should be a buffer or string where the property is
+fetched from. If omitted, OBJECT defaults to the current buffer.
+
+If PROPERTIES, look for value of PROP in PROPERTIES instead of the
+properties at POSITION. */)
+ (Lisp_Object position, Lisp_Object prop, Lisp_Object object,
+ Lisp_Object properties)
+{
+ if (NILP (properties))
+ properties = Fget_text_property (position, Qdisplay, object);
+ else
+ CHECK_LIST (properties);
+
+ return find_display_property (properties, prop);
+}
+
/***********************************************************************
@@ -5199,14 +5362,21 @@ handle_display_prop (struct it *it)
propval = get_char_property_and_overlay (make_fixnum (position->charpos),
Qdisplay, object, &overlay);
+
+ /* Rest of the code must have OBJECT be either a string or a buffer. */
+ if (!STRINGP (it->string))
+ object = it->w->contents;
+
+ /* Handle min-width ends. */
+ if (!NILP (it->min_width_property)
+ && NILP (find_display_property (propval, Qmin_width)))
+ display_min_width (it, bufpos, object, Qnil);
+
if (NILP (propval))
return HANDLED_NORMALLY;
/* Now OVERLAY is the overlay that gave us this property, or nil
if it was a text property. */
- if (!STRINGP (it->string))
- object = it->w->contents;
-
display_replaced = handle_display_spec (it, propval, object, overlay,
position, bufpos,
FRAME_WINDOW_P (it->f));
@@ -5260,6 +5430,7 @@ handle_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object,
&& !(CONSP (XCAR (spec)) && EQ (XCAR (XCAR (spec)), Qmargin))
&& !EQ (XCAR (spec), Qleft_fringe)
&& !EQ (XCAR (spec), Qright_fringe)
+ && !EQ (XCAR (spec), Qmin_width)
&& !NILP (XCAR (spec)))
{
for (; CONSP (spec); spec = XCDR (spec))
@@ -5493,6 +5664,17 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object,
return 0;
}
+ /* Handle `(min-width (WIDTH))'. */
+ if (CONSP (spec)
+ && EQ (XCAR (spec), Qmin_width)
+ && CONSP (XCDR (spec))
+ && CONSP (XCAR (XCDR (spec))))
+ {
+ if (it)
+ display_min_width (it, bufpos, object, XCAR (XCDR (spec)));
+ return 0;
+ }
+
/* Handle `(slice X Y WIDTH HEIGHT)'. */
if (CONSP (spec)
&& EQ (XCAR (spec), Qslice))
@@ -5640,8 +5822,15 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object,
if (CONSP (XCDR (XCDR (spec))))
{
Lisp_Object face_name = XCAR (XCDR (XCDR (spec)));
- int face_id2 = lookup_derived_face (it->w, it->f, face_name,
- FRINGE_FACE_ID, false);
+ int face_id2;
+ /* Don't allow quitting from lookup_derived_face, for when
+ we are displaying a non-selected window, and the buffer's
+ point was temporarily moved to the window-point. */
+ ptrdiff_t count1 = SPECPDL_INDEX ();
+ specbind (Qinhibit_quit, Qt);
+ face_id2 = lookup_derived_face (it->w, it->f, face_name,
+ FRINGE_FACE_ID, false);
+ unbind_to (count1, Qnil);
if (face_id2 >= 0)
face_id = face_id2;
}
@@ -7196,6 +7385,7 @@ reseat_1 (struct it *it, struct text_pos pos, bool set_stop_p)
}
/* This make the information stored in it->cmp_it invalidate. */
it->cmp_it.id = -1;
+ it->min_width_property = Qnil;
}
@@ -10637,73 +10827,22 @@ in_display_vector_p (struct it *it)
&& it->dpvec + it->current.dpvec_index != it->dpend);
}
-DEFUN ("window-text-pixel-size", Fwindow_text_pixel_size, Swindow_text_pixel_size, 0, 6, 0,
- doc: /* Return the size of the text of WINDOW's buffer in pixels.
-WINDOW must be a live window and defaults to the selected one. The
-return value is a cons of the maximum pixel-width of any text line
-and the pixel-height of all the text lines in the accessible portion
-of buffer text.
-
-This function exists to allow Lisp programs to adjust the dimensions
-of WINDOW to the buffer text it needs to display.
-
-The optional argument FROM, if non-nil, specifies the first text
-position to consider, and defaults to the minimum accessible position
-of the buffer. If FROM is t, it stands for the minimum accessible
-position that starts a non-empty line. TO, if non-nil, specifies the
-last text position and defaults to the maximum accessible position of
-the buffer. If TO is t, it stands for the maximum accessible position
-that ends a non-empty line.
-
-The optional argument X-LIMIT, if non-nil, specifies the maximum X
-coordinate beyond which the text should be ignored. It is therefore
-also the maximum width that the function can return. X-LIMIT nil or
-omitted means to use the pixel-width of WINDOW's body. This default
-means text of truncated lines wider than the window will be ignored;
-specify a large value for X-LIMIT if lines are truncated and you need
-to account for the truncated text. Use nil for X-LIMIT if you want to
-know how high WINDOW should become in order to fit all of its buffer's
-text with the width of WINDOW unaltered. Use the maximum width WINDOW
-may assume if you intend to change WINDOW's width. Since calculating
-the width of long lines can take some time, it's always a good idea to
-make this argument as small as possible; in particular, if the buffer
-contains long lines that shall be truncated anyway.
-
-The optional argument Y-LIMIT, if non-nil, specifies the maximum Y
-coordinate beyond which the text is to be ignored; it is therefore
-also the maximum height that the function can return (excluding the
-height of the mode- or header-line, if any). Y-LIMIT nil or omitted
-means consider all of the accessible portion of buffer text up to the
-position specified by TO. Since calculating the text height of a
-large buffer can take some time, it makes sense to specify this
-argument if the size of the buffer is large or unknown.
-
-Optional argument MODE-LINES nil or omitted means do not include the
-height of the mode-, tab- or header-line of WINDOW in the return value.
-If it is the symbol `mode-line', 'tab-line' or `header-line', include
-only the height of that line, if present, in the return value. If t,
-include the height of any of these, if present, in the return value. */)
- (Lisp_Object window, Lisp_Object from, Lisp_Object to, Lisp_Object x_limit,
- Lisp_Object y_limit, Lisp_Object mode_lines)
+/* This is like Fwindow_text_pixel_size but assumes that WINDOW's buffer
+ is the current buffer. Fbuffer_text_pixel_size calls it after it has
+ set WINDOW's buffer to the buffer specified by its BUFFER_OR_NAME
+ argument. */
+static Lisp_Object
+window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to,
+ Lisp_Object x_limit, Lisp_Object y_limit,
+ Lisp_Object mode_lines, Lisp_Object ignore_line_at_end)
{
struct window *w = decode_live_window (window);
- Lisp_Object buffer = w->contents;
- struct buffer *b;
struct it it;
- struct buffer *old_b = NULL;
ptrdiff_t start, end, bpos;
struct text_pos startp;
void *itdata = NULL;
int c, max_x = 0, max_y = 0, x = 0, y = 0;
-
- CHECK_BUFFER (buffer);
- b = XBUFFER (buffer);
-
- if (b != current_buffer)
- {
- old_b = current_buffer;
- set_buffer_internal (b);
- }
+ int doff = 0;
if (NILP (from))
{
@@ -10763,8 +10902,10 @@ include the height of any of these, if present, in the return value. */)
else
end = clip_to_bounds (start, fix_position (to), ZV);
- if (!NILP (x_limit) && RANGED_FIXNUMP (0, x_limit, INT_MAX))
+ if (RANGED_FIXNUMP (0, x_limit, INT_MAX))
max_x = XFIXNUM (x_limit);
+ else if (!NILP (x_limit))
+ max_x = INT_MAX;
if (NILP (y_limit))
max_y = INT_MAX;
@@ -10830,8 +10971,16 @@ include the height of any of these, if present, in the return value. */)
if (IT_CHARPOS (it) == end)
{
x += it.pixel_width;
- it.max_ascent = max (it.max_ascent, it.ascent);
- it.max_descent = max (it.max_descent, it.descent);
+
+ /* 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));
+ else
+ {
+ it.max_ascent = max (it.max_ascent, it.ascent);
+ it.max_descent = max (it.max_descent, it.descent);
+ }
}
}
else
@@ -10852,32 +11001,185 @@ include the height of any of these, if present, in the return value. */)
/* Subtract height of header-line and tab-line which was counted
automatically by start_display. */
- y = it.current_y + it.max_ascent + it.max_descent
- - WINDOW_TAB_LINE_HEIGHT (w) - WINDOW_HEADER_LINE_HEIGHT (w);
+ if (!NILP (ignore_line_at_end))
+ y = (it.current_y + doff
+ - WINDOW_TAB_LINE_HEIGHT (w)
+ - WINDOW_HEADER_LINE_HEIGHT (w));
+ else
+ y = (it.current_y + it.max_ascent + it.max_descent + doff
+ - WINDOW_TAB_LINE_HEIGHT (w) - WINDOW_HEADER_LINE_HEIGHT (w));
+
/* Don't return more than Y-LIMIT. */
if (y > max_y)
y = max_y;
- if (EQ (mode_lines, Qtab_line) || EQ (mode_lines, Qt))
- /* Re-add height of tab-line as requested. */
- y = y + WINDOW_TAB_LINE_HEIGHT (w);
+ if ((EQ (mode_lines, Qtab_line) || EQ (mode_lines, Qt))
+ && window_wants_tab_line (w))
+ /* Add height of tab-line as requested. */
+ {
+ Lisp_Object window_tab_line_format
+ = window_parameter (w, Qtab_line_format);
+
+ y = y + display_mode_line (w, TAB_LINE_FACE_ID,
+ NILP (window_tab_line_format)
+ ? BVAR (current_buffer, tab_line_format)
+ : window_tab_line_format);
+ }
+
+ if ((EQ (mode_lines, Qheader_line) || EQ (mode_lines, Qt))
+ && window_wants_header_line (w))
+ {
+ Lisp_Object window_header_line_format
+ = window_parameter (w, Qheader_line_format);
+
+ y = y + display_mode_line (w, HEADER_LINE_FACE_ID,
+ NILP (window_header_line_format)
+ ? BVAR (current_buffer, header_line_format)
+ : window_header_line_format);
+ }
- if (EQ (mode_lines, Qheader_line) || EQ (mode_lines, Qt))
- /* Re-add height of header-line as requested. */
- y = y + WINDOW_HEADER_LINE_HEIGHT (w);
+ if ((EQ (mode_lines, Qmode_line) || EQ (mode_lines, Qt))
+ && window_wants_mode_line (w))
+ {
+ Lisp_Object window_mode_line_format
+ = window_parameter (w, Qmode_line_format);
- if (EQ (mode_lines, Qmode_line) || EQ (mode_lines, Qt))
- /* Add height of mode-line as requested. */
- y = y + WINDOW_MODE_LINE_HEIGHT (w);
+ y = y + display_mode_line (w, CURRENT_MODE_LINE_ACTIVE_FACE_ID (w),
+ NILP (window_mode_line_format)
+ ? BVAR (current_buffer, mode_line_format)
+ : window_mode_line_format);
+ }
bidi_unshelve_cache (itdata, false);
+ return Fcons (make_fixnum (x - start_x), make_fixnum (y));
+}
+
+DEFUN ("window-text-pixel-size", Fwindow_text_pixel_size, Swindow_text_pixel_size, 0, 7, 0,
+ doc: /* Return the size of the text of WINDOW's buffer in pixels.
+WINDOW must be a live window and defaults to the selected one. The
+return value is a cons of the maximum pixel-width of any text line
+and the pixel-height of all the text lines in the accessible portion
+of buffer text.
+
+This function exists to allow Lisp programs to adjust the dimensions
+of WINDOW to the buffer text it needs to display.
+
+The optional argument FROM, if non-nil, specifies the first text
+position to consider, and defaults to the minimum accessible position
+of the buffer. If FROM is t, it stands for the minimum accessible
+position that starts a non-empty line. TO, if non-nil, specifies the
+last text position and defaults to the maximum accessible position of
+the buffer. If TO is t, it stands for the maximum accessible position
+that ends a non-empty line.
+
+The optional argument X-LIMIT, if non-nil, specifies the maximum X
+coordinate beyond which the text should be ignored. It is therefore
+also the maximum width that the function can return. X-LIMIT nil or
+omitted means to use the pixel-width of WINDOW's body. This default
+means text of truncated lines wider than the window will be ignored;
+specify a non-nil value for X-LIMIT if lines are truncated and you need
+to account for the truncated text.
+
+Use nil for X-LIMIT if you want to know how high WINDOW should become in
+order to fit all of its buffer's text with the width of WINDOW
+unaltered. Use the maximum width WINDOW may assume if you intend to
+change WINDOW's width. Use t for the maximum possible value. Since
+calculating the width of long lines can take some time, it's always a
+good idea to make this argument as small as possible; in particular, if
+the buffer contains long lines that shall be truncated anyway.
+
+The optional argument Y-LIMIT, if non-nil, specifies the maximum Y
+coordinate beyond which the text is to be ignored; it is therefore
+also the maximum height that the function can return (excluding the
+height of the mode- or header-line, if any). Y-LIMIT nil or omitted
+means consider all of the accessible portion of buffer text up to the
+position specified by TO. Since calculating the text height of a
+large buffer can take some time, it makes sense to specify this
+argument if the size of the buffer is large or unknown.
+
+Optional argument MODE-LINES nil or omitted means do not include the
+height of the mode-, tab- or header-line of WINDOW in the return value.
+If it is the symbol `mode-line', 'tab-line' or `header-line', include
+only the height of that line, if present, in the return value. If t,
+include the height of any of these, if present, in the return value.
+
+IGNORE-LINE-AT-END, if non-nil, means to not add the height of the
+screen line that includes TO to the returned height of the text. */)
+ (Lisp_Object window, Lisp_Object from, Lisp_Object to, Lisp_Object x_limit,
+ Lisp_Object y_limit, Lisp_Object mode_lines, Lisp_Object ignore_line_at_end)
+{
+ struct window *w = decode_live_window (window);
+ struct buffer *b = XBUFFER (w->contents);
+ struct buffer *old_b = NULL;
+ Lisp_Object value;
+
+ if (b != current_buffer)
+ {
+ old_b = current_buffer;
+ set_buffer_internal_1 (b);
+ }
+
+ value = window_text_pixel_size (window, from, to, x_limit, y_limit, mode_lines,
+ ignore_line_at_end);
+
if (old_b)
- set_buffer_internal (old_b);
+ set_buffer_internal_1 (old_b);
- return Fcons (make_fixnum (x - start_x), make_fixnum (y));
+ return value;
+}
+
+DEFUN ("buffer-text-pixel-size", Fbuffer_text_pixel_size, Sbuffer_text_pixel_size, 0, 4, 0,
+ doc: /* Return size of whole text of BUFFER-OR-NAME in WINDOW.
+BUFFER-OR-NAME must specify a live buffer or the name of a live buffer
+and defaults to the current buffer. WINDOW must be a live window and
+defaults to the selected one. The return value is a cons of the maximum
+pixel-width of any text line and the pixel-height of all the text lines
+of the buffer specified by BUFFER-OR-NAME.
+
+The optional arguments X-LIMIT and Y-LIMIT have the same meaning as with
+`window-text-pixel-size'.
+
+Do not use this function if the buffer specified by BUFFER-OR-NAME is
+already displayed in WINDOW. `window-text-pixel-size' is cheaper in
+that case because it does not have to temporarily show that buffer in
+WINDOW. */)
+ (Lisp_Object buffer_or_name, Lisp_Object window, Lisp_Object x_limit,
+ Lisp_Object y_limit)
+{
+ struct window *w = decode_live_window (window);
+ struct buffer *b = (NILP (buffer_or_name)
+ ? current_buffer
+ : XBUFFER (Fget_buffer (buffer_or_name)));
+ Lisp_Object buffer, value;
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ XSETBUFFER (buffer, b);
+
+ /* The unwind form of with_echo_area_buffer is what we need here to
+ make WINDOW temporarily show our buffer. */
+ /* FIXME: Can we move this into the `if (!EQ (buffer, w->contents))`? */
+ record_unwind_protect (unwind_with_echo_area_buffer,
+ with_echo_area_buffer_unwind_data (w));
+
+ set_buffer_internal_1 (b);
+
+ if (!EQ (buffer, w->contents))
+ {
+ wset_buffer (w, buffer);
+ set_marker_both (w->pointm, buffer, BEG, BEG_BYTE);
+ set_marker_both (w->old_pointm, buffer, BEG, BEG_BYTE);
+ }
+
+ value = window_text_pixel_size (window, Qnil, Qnil, x_limit, y_limit, Qnil,
+ Qnil);
+
+ unbind_to (count, Qnil);
+
+ return value;
}
+
DEFUN ("display--line-is-continued-p", Fdisplay__line_is_continued_p,
Sdisplay__line_is_continued_p, 0, 0, 0,
doc: /* Return non-nil if the current screen line is continued on display. */)
@@ -13877,7 +14179,6 @@ note_tab_bar_highlight (struct frame *f, int x, int y)
clear_mouse_face (hlinfo);
bool mouse_down_p = false;
-#ifndef HAVE_NS
/* Mouse is down, but on different tab-bar item? Or alternatively,
the mouse might've been pressed somewhere we don't know about,
and then have moved onto the tab bar. In this case,
@@ -13890,7 +14191,6 @@ note_tab_bar_highlight (struct frame *f, int x, int y)
if (mouse_down_p && f->last_tab_bar_item != prop_idx
&& f->last_tab_bar_item != -1)
return;
-#endif
draw = mouse_down_p ? DRAW_IMAGE_SUNKEN : DRAW_IMAGE_RAISED;
/* If tab-bar item is not enabled, don't highlight it. */
@@ -15635,13 +15935,18 @@ redisplay_internal (void)
if (!fr->glyphs_initialized_p)
return;
-#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS)
+#if defined (USE_X_TOOLKIT) || (defined (USE_GTK) && !defined (HAVE_PGTK)) || defined (HAVE_NS)
if (popup_activated ())
{
return;
}
#endif
+#if defined (HAVE_HAIKU)
+ if (popup_activated_p)
+ return;
+#endif
+
/* I don't think this happens but let's be paranoid. */
if (redisplaying_p)
return;
@@ -17806,7 +18111,7 @@ compute_window_start_on_continuation_line (struct window *w)
point will not be visible with any window start we
compute. */
if (IT_CHARPOS (it) <= PT
- || (CHARPOS (start_pos) - IT_CHARPOS (it)
+ && (CHARPOS (start_pos) - IT_CHARPOS (it)
/* PXW: Do we need upper bounds here? */
< WINDOW_TOTAL_LINES (w) * WINDOW_TOTAL_COLS (w)))
{
@@ -24495,7 +24800,7 @@ See also `bidi-paragraph-direction'. */)
DEFUN ("bidi-find-overridden-directionality",
Fbidi_find_overridden_directionality,
- Sbidi_find_overridden_directionality, 2, 3, 0,
+ Sbidi_find_overridden_directionality, 3, 4, 0,
doc: /* Return position between FROM and TO where directionality was overridden.
This function returns the first character position in the specified
@@ -24514,12 +24819,18 @@ a buffer is preferable when the buffer is displayed in some window,
because this function will then be able to correctly account for
window-specific overlays, which can affect the results.
+Optional argument BASE-DIR specifies the base paragraph directory
+of the text. It should be a symbol, either `left-to-right'
+or `right-to-left', and defaults to `left-to-right'.
+
Strong directional characters `L', `R', and `AL' can have their
intrinsic directionality overridden by directional override
-control characters RLO (u+202e) and LRO (u+202d). See the
-function `get-char-code-property' for a way to inquire about
+control characters RLO (u+202E) and LRO (u+202D). They can also
+have their directionality affected by other formatting control
+characters: LRE (u+202A), RLE (u+202B), LRI (u+2066), and RLI (u+2067).
+See the function `get-char-code-property' for a way to inquire about
the `bidi-class' property of a character. */)
- (Lisp_Object from, Lisp_Object to, Lisp_Object object)
+ (Lisp_Object from, Lisp_Object to, Lisp_Object object, Lisp_Object base_dir)
{
struct buffer *buf = current_buffer;
struct buffer *old = buf;
@@ -24616,10 +24927,9 @@ the `bidi-class' property of a character. */)
}
ptrdiff_t found;
+ bidi_dir_t bdir = EQ (base_dir, Qright_to_left) ? R2L : L2R;
do {
- /* For the purposes of this function, the actual base direction of
- the paragraph doesn't matter, so just set it to L2R. */
- bidi_paragraph_init (L2R, &itb, false);
+ bidi_paragraph_init (bdir, &itb, false);
while ((found = bidi_find_first_overridden (&itb)) < from_pos)
;
} while (found == ZV && itb.ch == '\n' && itb.charpos < to_pos);
@@ -25218,6 +25528,11 @@ display_menu_bar (struct window *w)
if (FRAME_W32_P (f))
return;
#endif
+#if defined (HAVE_PGTK)
+ if (FRAME_PGTK_P (f))
+ return;
+#endif
+
#if defined (USE_X_TOOLKIT) || defined (USE_GTK)
if (FRAME_X_P (f))
return;
@@ -25228,6 +25543,11 @@ display_menu_bar (struct window *w)
return;
#endif /* HAVE_NS */
+#ifdef HAVE_HAIKU
+ if (FRAME_HAIKU_P (f))
+ return;
+#endif /* HAVE_HAIKU */
+
#if defined (USE_X_TOOLKIT) || defined (USE_GTK)
eassert (!FRAME_WINDOW_P (f));
init_iterator (&it, w, -1, -1, f->desired_matrix->rows, MENU_FACE_ID);
@@ -25528,7 +25848,8 @@ display_mode_lines (struct window *w)
struct window *sel_w = XWINDOW (old_selected_window);
/* Select mode line face based on the real selected window. */
- display_mode_line (w, CURRENT_MODE_LINE_FACE_ID_3 (sel_w, sel_w, w),
+ display_mode_line (w,
+ CURRENT_MODE_LINE_ACTIVE_FACE_ID_3 (sel_w, sel_w, w),
NILP (window_mode_line_format)
? BVAR (current_buffer, mode_line_format)
: window_mode_line_format);
@@ -25567,11 +25888,11 @@ display_mode_lines (struct window *w)
}
-/* Display mode or header/tab line of window W. FACE_ID specifies which
- line to display; it is either MODE_LINE_FACE_ID, HEADER_LINE_FACE_ID or
- TAB_LINE_FACE_ID. FORMAT is the mode/header/tab line format to
- display. Value is the pixel height of the mode/header/tab line
- displayed. */
+/* Display mode or header/tab line of window W. FACE_ID specifies
+ which line to display; it is either MODE_LINE_ACTIVE_FACE_ID,
+ HEADER_LINE_FACE_ID or TAB_LINE_FACE_ID. FORMAT is the
+ mode/header/tab line format to display. Value is the pixel height
+ of the mode/header/tab line displayed. */
static int
display_mode_line (struct window *w, enum face_id face_id, Lisp_Object format)
@@ -26364,8 +26685,8 @@ are the selected window and the WINDOW's buffer). */)
face_id = (NILP (face) || EQ (face, Qdefault)) ? DEFAULT_FACE_ID
: EQ (face, Qt) ? (EQ (window, selected_window)
- ? MODE_LINE_FACE_ID : MODE_LINE_INACTIVE_FACE_ID)
- : EQ (face, Qmode_line) ? MODE_LINE_FACE_ID
+ ? MODE_LINE_ACTIVE_FACE_ID : MODE_LINE_INACTIVE_FACE_ID)
+ : EQ (face, Qmode_line_active) ? MODE_LINE_ACTIVE_FACE_ID
: EQ (face, Qmode_line_inactive) ? MODE_LINE_INACTIVE_FACE_ID
: EQ (face, Qheader_line) ? HEADER_LINE_FACE_ID
: EQ (face, Qtab_line) ? TAB_LINE_FACE_ID
@@ -28147,6 +28468,19 @@ fill_composite_glyph_string (struct glyph_string *s, struct face *base_face,
s->font = s->face->font;
}
+ if (s->hl == DRAW_MOUSE_FACE
+ || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w)))
+ {
+ int c = COMPOSITION_GLYPH (s->cmp, 0);
+ Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f);
+ s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id);
+ if (!s->face)
+ s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
+
+ s->face = FACE_FROM_ID (s->f, FACE_FOR_CHAR (s->f, s->face, c, -1, Qnil));
+ prepare_face_for_display (s->f, s->face);
+ }
+
/* All glyph strings for the same composition has the same width,
i.e. the width set for the first component of the composition. */
s->width = s->first_glyph->pixel_width;
@@ -28183,7 +28517,17 @@ fill_gstring_glyph_string (struct glyph_string *s, int face_id,
s->cmp_id = glyph->u.cmp.id;
s->cmp_from = glyph->slice.cmp.from;
s->cmp_to = glyph->slice.cmp.to + 1;
- s->face = FACE_FROM_ID (s->f, face_id);
+ if (s->hl == DRAW_MOUSE_FACE
+ || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w)))
+ {
+ Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f);
+ s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id);
+ if (!s->face)
+ s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
+ prepare_face_for_display (s->f, s->face);
+ }
+ else
+ s->face = FACE_FROM_ID (s->f, face_id);
lgstring = composition_gstring_from_id (s->cmp_id);
s->font = XFONT_OBJECT (LGSTRING_FONT (lgstring));
/* The width of a composition glyph string is the sum of the
@@ -28239,6 +28583,15 @@ fill_glyphless_glyph_string (struct glyph_string *s, int face_id,
voffset = glyph->voffset;
s->face = FACE_FROM_ID (s->f, face_id);
s->font = s->face->font ? s->face->font : FRAME_FONT (s->f);
+ if (s->hl == DRAW_MOUSE_FACE
+ || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w)))
+ {
+ Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f);
+ s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id);
+ if (!s->face)
+ s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
+ prepare_face_for_display (s->f, s->face);
+ }
s->nchars = 1;
s->width = glyph->pixel_width;
glyph++;
@@ -28302,6 +28655,19 @@ fill_glyph_string (struct glyph_string *s, int face_id,
s->font = s->face->font;
+ if (s->hl == DRAW_MOUSE_FACE
+ || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w)))
+ {
+ Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f);
+ s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id);
+ if (!s->face)
+ s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
+ s->face
+ = FACE_FROM_ID (s->f, FACE_FOR_CHAR (s->f, s->face,
+ s->first_glyph->u.ch, -1, Qnil));
+ prepare_face_for_display (s->f, s->face);
+ }
+
/* If the specified font could not be loaded, use the frame's font,
but record the fact that we couldn't load it in
S->font_not_found_p so that we can draw rectangles for the
@@ -28331,6 +28697,15 @@ fill_image_glyph_string (struct glyph_string *s)
s->slice = s->first_glyph->slice.img;
s->face = FACE_FROM_ID (s->f, s->first_glyph->face_id);
s->font = s->face->font;
+ if (s->hl == DRAW_MOUSE_FACE
+ || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w)))
+ {
+ Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f);
+ s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id);
+ if (!s->face)
+ s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
+ prepare_face_for_display (s->f, s->face);
+ }
s->width = s->first_glyph->pixel_width;
/* Adjust base line for subscript/superscript text. */
@@ -28345,9 +28720,18 @@ fill_xwidget_glyph_string (struct glyph_string *s)
eassert (s->first_glyph->type == XWIDGET_GLYPH);
s->face = FACE_FROM_ID (s->f, s->first_glyph->face_id);
s->font = s->face->font;
+ if (s->hl == DRAW_MOUSE_FACE
+ || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w)))
+ {
+ Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f);
+ s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id);
+ if (!s->face)
+ s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
+ prepare_face_for_display (s->f, s->face);
+ }
s->width = s->first_glyph->pixel_width;
s->ybase += s->first_glyph->voffset;
- s->xwidget = s->first_glyph->u.xwidget;
+ s->xwidget = xwidget_from_id (s->first_glyph->u.xwidget);
}
#endif
/* Fill glyph string S from a sequence of stretch glyphs.
@@ -28370,6 +28754,15 @@ fill_stretch_glyph_string (struct glyph_string *s, int start, int end)
face_id = glyph->face_id;
s->face = FACE_FROM_ID (s->f, face_id);
s->font = s->face->font;
+ if (s->hl == DRAW_MOUSE_FACE
+ || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w)))
+ {
+ Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f);
+ s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id);
+ if (!s->face)
+ s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
+ prepare_face_for_display (s->f, s->face);
+ }
s->width = glyph->pixel_width;
s->nchars = 1;
voffset = glyph->voffset;
@@ -28617,7 +29010,12 @@ right_overwriting (struct glyph_string *s)
/* Set background width of glyph string S. START is the index of the
first glyph following S. LAST_X is the right-most x-position + 1
- in the drawing area. */
+ in the drawing area.
+
+ If S->hl is DRAW_CURSOR, S->f is a window system frame, and the
+ cursor in S's window is currently inside mouse face, also update
+ S->width to take into account potentially differing :box
+ properties between the original face and the mouse face. */
static void
set_glyph_string_background_width (struct glyph_string *s, int start, int last_x)
@@ -28639,7 +29037,27 @@ set_glyph_string_background_width (struct glyph_string *s, int start, int last_x
if (s->extends_to_end_of_line_p)
s->background_width = last_x - s->x + 1;
else
- s->background_width = s->width;
+ {
+ s->background_width = s->width;
+#ifdef HAVE_WINDOW_SYSTEM
+ if (FRAME_WINDOW_P (s->f)
+ && s->hl == DRAW_CURSOR
+ && cursor_in_mouse_face_p (s->w))
+ {
+ /* Adjust the background width of the glyph string, because
+ if the glyph's face has the :box attribute, its
+ pixel_width might be different when it's displayed in the
+ mouse-face, if that also has the :box attribute. */
+ struct glyph *g = s->first_glyph;
+ struct face *regular_face = FACE_FROM_ID (s->f, g->face_id);
+ s->background_width +=
+ adjust_glyph_width_for_mouse_face (g, s->row, s->w,
+ regular_face, s->face);
+ /* S->width is probably worth adjusting here as well. */
+ s->width = s->background_width;
+ }
+#endif
+ }
}
@@ -29188,7 +29606,6 @@ draw_glyphs (struct window *w, int x, struct glyph_row *row,
for (s = head; s; s = s->next)
FRAME_RIF (f)->draw_glyph_string (s);
-#ifndef HAVE_NS
/* When focus a sole frame and move horizontally, this clears on_p
causing a failure to erase prev cursor position. */
if (area == TEXT_AREA
@@ -29207,7 +29624,6 @@ draw_glyphs (struct window *w, int x, struct glyph_row *row,
notice_overwritten_cursor (w, TEXT_AREA, x0, x1,
row->y, MATRIX_ROW_BOTTOM_Y (row));
}
-#endif
/* Value is the x-position up to which drawn, relative to AREA of W.
This doesn't include parts drawn because of overhangs. */
@@ -29540,6 +29956,8 @@ produce_image_glyph (struct it *it)
if (face->box != FACE_NO_BOX)
{
+ /* If you change the logic here, please change it in
+ get_cursor_offset_for_mouse_face as well. */
if (face->box_horizontal_line_width > 0)
{
if (slice.y == 0)
@@ -29716,7 +30134,7 @@ produce_xwidget_glyph (struct it *it)
glyph->padding_p = 0;
glyph->glyph_not_available_p = 0;
glyph->face_id = it->face_id;
- glyph->u.xwidget = it->xwidget;
+ glyph->u.xwidget = it->xwidget->xwidget_id;
glyph->font_type = FONT_TYPE_UNKNOWN;
if (it->bidi_p)
{
@@ -29899,7 +30317,8 @@ produce_stretch_glyph (struct it *it)
Compute the width of the characters having this `display'
property. */
struct it it2;
- Lisp_Object object = it->stack[it->sp - 1].string;
+ Lisp_Object object =
+ it->sp > 0 ? it->stack[it->sp - 1].string : it->string;
unsigned char *p = (STRINGP (object)
? SDATA (object) + IT_STRING_BYTEPOS (*it)
: BYTE_POS_ADDR (IT_BYTEPOS (*it)));
@@ -30001,7 +30420,8 @@ produce_stretch_glyph (struct it *it)
if (width > 0 && height > 0 && it->glyph_row)
{
Lisp_Object o_object = it->object;
- Lisp_Object object = it->stack[it->sp - 1].string;
+ Lisp_Object object =
+ it->sp > 0 ? it->stack[it->sp - 1].string : it->string;
int n = width;
if (!STRINGP (object))
@@ -30816,6 +31236,11 @@ gui_produce_glyphs (struct it *it)
it->max_ascent = max (it->max_ascent, font_ascent);
it->max_descent = max (it->max_descent, font_descent);
}
+
+ if (it->ascent < 0)
+ it->ascent = 0;
+ if (it->descent < 0)
+ it->descent = 0;
}
else if (it->what == IT_COMPOSITION && it->cmp_it.ch < 0)
{
@@ -31855,6 +32280,20 @@ erase_phys_cursor (struct window *w)
&& cursor_row->used[TEXT_AREA] > hpos && hpos >= 0)
mouse_face_here_p = true;
+#ifdef HAVE_WINDOW_SYSTEM
+ /* Since erasing the phys cursor will probably lead to corruption of
+ the mouse face display if the glyph's pixel_width is not kept up
+ to date with the :box property of the mouse face, just redraw the
+ mouse face. */
+ if (FRAME_WINDOW_P (WINDOW_XFRAME (w)) && mouse_face_here_p)
+ {
+ w->phys_cursor_on_p = false;
+ w->phys_cursor_type = NO_CURSOR;
+ show_mouse_face (MOUSE_HL_INFO (WINDOW_XFRAME (w)), DRAW_MOUSE_FACE);
+ return;
+ }
+#endif
+
/* Maybe clear the display under the cursor. */
if (w->phys_cursor_type == HOLLOW_BOX_CURSOR)
{
@@ -32126,6 +32565,9 @@ show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw)
&& hlinfo->mouse_face_end_row < w->current_matrix->nrows)
{
bool phys_cursor_on_p = w->phys_cursor_on_p;
+#ifdef HAVE_WINDOW_SYSTEM
+ int mouse_off = 0;
+#endif
struct glyph_row *row, *first, *last;
first = MATRIX_ROW (w->current_matrix, hlinfo->mouse_face_beg_row);
@@ -32199,6 +32641,15 @@ show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw)
row->mouse_face_p
= draw == DRAW_MOUSE_FACE || draw == DRAW_IMAGE_RAISED;
}
+#ifdef HAVE_WINDOW_SYSTEM
+ /* Compute the cursor offset due to mouse-highlight. */
+ if ((MATRIX_ROW_VPOS (row, w->current_matrix) == w->phys_cursor.vpos)
+ /* But not when highlighting a pseudo window, such as
+ the toolbar, which can't have a cursor anyway. */
+ && !w->pseudo_window_p
+ && draw == DRAW_MOUSE_FACE)
+ get_cursor_offset_for_mouse_face (w, row, &mouse_off);
+#endif
}
/* When we've written over the cursor, arrange for it to
@@ -32208,6 +32659,7 @@ show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw)
{
#ifdef HAVE_WINDOW_SYSTEM
int hpos = w->phys_cursor.hpos;
+ int old_phys_cursor_x = w->phys_cursor.x;
/* When the window is hscrolled, cursor hpos can legitimately be
out of bounds, but we draw the cursor at the corresponding
@@ -32219,7 +32671,11 @@ show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw)
block_input ();
display_and_set_cursor (w, true, hpos, w->phys_cursor.vpos,
- w->phys_cursor.x, w->phys_cursor.y);
+ w->phys_cursor.x + mouse_off,
+ w->phys_cursor.y);
+ /* Restore the original cursor coordinates, perhaps modified
+ to account for mouse-highlight. */
+ w->phys_cursor.x = old_phys_cursor_x;
unblock_input ();
#endif /* HAVE_WINDOW_SYSTEM */
}
@@ -33560,11 +34016,16 @@ 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 (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) || defined (MSDOS)
+#if defined (USE_X_TOOLKIT) || (defined (USE_GTK) && !defined (HAVE_PGTK)) || defined (HAVE_NS) || defined (MSDOS)
if (popup_activated ())
return;
#endif
+#if defined (HAVE_HAIKU)
+ if (popup_activated_p)
+ return;
+#endif
+
if (!f->glyphs_initialized_p
|| f->pointer_invisible)
return;
@@ -34892,9 +35353,11 @@ be let-bound around code that needs to disable messages temporarily. */);
defsubr (&Sinvisible_p);
defsubr (&Scurrent_bidi_paragraph_direction);
defsubr (&Swindow_text_pixel_size);
+ defsubr (&Sbuffer_text_pixel_size);
defsubr (&Smove_point_visually);
defsubr (&Sbidi_find_overridden_directionality);
defsubr (&Sdisplay__line_is_continued_p);
+ defsubr (&Sget_display_property);
DEFSYM (Qmenu_bar_update_hook, "menu-bar-update-hook");
DEFSYM (Qoverriding_terminal_local_map, "overriding-terminal-local-map");
@@ -35803,11 +36266,13 @@ message displayed by its counterpart function specified by
Vclear_message_function = Qnil;
DEFVAR_LISP ("redisplay--all-windows-cause", Vredisplay__all_windows_cause,
- doc: /* */);
+ doc: /* Code of the cause for redisplaying all windows.
+Internal use only. */);
Vredisplay__all_windows_cause = Fmake_hash_table (0, NULL);
DEFVAR_LISP ("redisplay--mode-lines-cause", Vredisplay__mode_lines_cause,
- doc: /* */);
+ doc: /* Code of the cause for redisplaying mode lines.
+Internal use only. */);
Vredisplay__mode_lines_cause = Fmake_hash_table (0, NULL);
DEFVAR_BOOL ("redisplay--inhibit-bidi", redisplay__inhibit_bidi,
@@ -35833,10 +36298,11 @@ mouse stays within the extent of a single glyph (except for images). */);
tab_bar__dragging_in_progress = false;
DEFVAR_BOOL ("redisplay-skip-initial-frame", redisplay_skip_initial_frame,
- doc: /* Non-nil to skip redisplay in initial frame.
-The initial frame is not displayed anywhere, so skipping it is
-best except in special circumstances such as running redisplay tests
-in batch mode. */);
+ doc: /* Non-nil means skip redisplay of the initial frame.
+The initial frame is the text-mode frame used by Emacs internally during
+the early stages of startup. That frame is not displayed anywhere, so
+skipping it is best except in special circumstances such as running
+redisplay tests in batch mode. */);
redisplay_skip_initial_frame = true;
DEFVAR_BOOL ("redisplay-skip-fontification-on-input",
@@ -36011,4 +36477,121 @@ cancel_hourglass (void)
}
}
+/* Return a correction to be applied to G->pixel_width when it is
+ displayed in MOUSE_FACE. This is needed for the first and the last
+ glyphs of text inside a face with :box when it is displayed with
+ MOUSE_FACE that has a different or no :box attribute.
+ ORIGINAL_FACE is the face G was originally drawn in, and MOUSE_FACE
+ is the face it will be drawn in now. ROW is the G's glyph row and
+ W is its window. */
+static int
+adjust_glyph_width_for_mouse_face (struct glyph *g, struct glyph_row *row,
+ struct window *w,
+ struct face *original_face,
+ struct face *mouse_face)
+{
+ int sum = 0;
+
+ bool do_left_box_p = g->left_box_line_p;
+ bool do_right_box_p = g->right_box_line_p;
+
+ /* This is required because we test some parameters of the image
+ slice before applying the box in produce_image_glyph. */
+ if (g->type == IMAGE_GLYPH)
+ {
+ if (!row->reversed_p)
+ {
+ struct image *img = IMAGE_FROM_ID (WINDOW_XFRAME (w),
+ g->u.img_id);
+ do_left_box_p = g->left_box_line_p &&
+ g->slice.img.x == 0;
+ do_right_box_p = g->right_box_line_p &&
+ g->slice.img.x + g->slice.img.width == img->width;
+ }
+ else
+ {
+ struct image *img = IMAGE_FROM_ID (WINDOW_XFRAME (w),
+ g->u.img_id);
+ do_left_box_p = g->left_box_line_p &&
+ g->slice.img.x + g->slice.img.width == img->width;
+ do_right_box_p = g->right_box_line_p &&
+ g->slice.img.x == 0;
+ }
+ }
+
+ /* If the glyph has a left box line, subtract it from the offset. */
+ if (do_left_box_p)
+ sum -= max (0, original_face->box_vertical_line_width);
+ /* Likewise with the right box line, as there may be a
+ box there as well. */
+ if (do_right_box_p)
+ sum -= max (0, original_face->box_vertical_line_width);
+ /* Now add the line widths from the new face. */
+ if (g->left_box_line_p)
+ sum += max (0, mouse_face->box_vertical_line_width);
+ if (g->right_box_line_p)
+ sum += max (0, mouse_face->box_vertical_line_width);
+
+ return sum;
+}
+
+/* Get the offset due to mouse-highlight to apply before drawing
+ phys_cursor, and return it in OFFSET. ROW should be the row that
+ is under mouse face and contains the phys cursor.
+
+ This is required because the produce_XXX_glyph series of functions
+ add the width of the various vertical box lines to the total width
+ of the glyphs, but that must be updated when the row is put under
+ mouse face, which can have different box dimensions. */
+static void
+get_cursor_offset_for_mouse_face (struct window *w, struct glyph_row *row,
+ int *offset)
+{
+ int sum = 0;
+ /* Return because the mode line can't possibly have a cursor. */
+ if (row->mode_line_p)
+ return;
+
+ block_input ();
+
+ struct frame *f = WINDOW_XFRAME (w);
+ Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f);
+ struct glyph *start, *end;
+ struct face *mouse_face = FACE_FROM_ID (f, hlinfo->mouse_face_face_id);
+ int hpos = w->phys_cursor.hpos;
+ end = &row->glyphs[TEXT_AREA][hpos];
+
+ if (!row->reversed_p)
+ {
+ if (MATRIX_ROW_VPOS (row, w->current_matrix) ==
+ hlinfo->mouse_face_beg_row)
+ start = &row->glyphs[TEXT_AREA][hlinfo->mouse_face_beg_col];
+ else
+ start = row->glyphs[TEXT_AREA];
+ }
+ else
+ {
+ if (MATRIX_ROW_VPOS (row, w->current_matrix) ==
+ hlinfo->mouse_face_end_row)
+ start = &row->glyphs[TEXT_AREA][hlinfo->mouse_face_end_col];
+ else
+ start = &row->glyphs[TEXT_AREA][row->used[TEXT_AREA] - 1];
+ }
+
+ /* Calculate the offset by which to correct phys_cursor x if we are
+ drawing the cursor inside mouse-face highlighted text. */
+
+ for ( ; row->reversed_p ? start > end : start < end;
+ row->reversed_p ? --start : ++start)
+ sum += adjust_glyph_width_for_mouse_face (start, row, w,
+ FACE_FROM_ID (f, start->face_id),
+ mouse_face);
+
+ if (row->reversed_p)
+ sum = -sum;
+
+ *offset = sum;
+
+ unblock_input ();
+}
#endif /* HAVE_WINDOW_SYSTEM */
diff --git a/src/xfaces.c b/src/xfaces.c
index 18e65d07e20..6f52637e916 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -246,6 +246,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifdef HAVE_NS
#define GCGraphicsExposures 0
#endif /* HAVE_NS */
+
+#ifdef HAVE_PGTK
+#define GCGraphicsExposures 0
+#endif /* HAVE_PGTK */
+
+#ifdef HAVE_HAIKU
+#define GCGraphicsExposures 0
+#endif /* HAVE_HAIKU */
#endif /* HAVE_WINDOW_SYSTEM */
#include "buffer.h"
@@ -555,8 +563,8 @@ x_free_gc (struct frame *f, Emacs_GC *gc)
#endif /* HAVE_NTGUI */
-#ifdef HAVE_NS
-/* NS emulation of GCs */
+#if defined (HAVE_NS) || defined (HAVE_HAIKU)
+/* NS and Haiku emulation of GCs */
static Emacs_GC *
x_create_gc (struct frame *f,
@@ -575,6 +583,26 @@ x_free_gc (struct frame *f, Emacs_GC *gc)
}
#endif /* HAVE_NS */
+#ifdef HAVE_PGTK
+/* PGTK emulation of GCs */
+
+static Emacs_GC *
+x_create_gc (struct frame *f,
+ unsigned long mask,
+ Emacs_GC *xgcv)
+{
+ Emacs_GC *gc = xmalloc (sizeof *gc);
+ *gc = *xgcv;
+ return gc;
+}
+
+static void
+x_free_gc (struct frame *f, Emacs_GC *gc)
+{
+ xfree (gc);
+}
+#endif /* HAVE_NS */
+
/***********************************************************************
Frames and faces
***********************************************************************/
@@ -1416,52 +1444,6 @@ enum xlfd_field
XLFD_LAST
};
-/* An enumerator for each possible slant value of a font. Taken from
- the XLFD specification. */
-
-enum xlfd_slant
-{
- XLFD_SLANT_UNKNOWN,
- XLFD_SLANT_ROMAN,
- XLFD_SLANT_ITALIC,
- XLFD_SLANT_OBLIQUE,
- XLFD_SLANT_REVERSE_ITALIC,
- XLFD_SLANT_REVERSE_OBLIQUE,
- XLFD_SLANT_OTHER
-};
-
-/* Relative font weight according to XLFD documentation. */
-
-enum xlfd_weight
-{
- XLFD_WEIGHT_UNKNOWN,
- XLFD_WEIGHT_ULTRA_LIGHT, /* 10 */
- XLFD_WEIGHT_EXTRA_LIGHT, /* 20 */
- XLFD_WEIGHT_LIGHT, /* 30 */
- XLFD_WEIGHT_SEMI_LIGHT, /* 40: SemiLight, Book, ... */
- XLFD_WEIGHT_MEDIUM, /* 50: Medium, Normal, Regular, ... */
- XLFD_WEIGHT_SEMI_BOLD, /* 60: SemiBold, DemiBold, ... */
- XLFD_WEIGHT_BOLD, /* 70: Bold, ... */
- XLFD_WEIGHT_EXTRA_BOLD, /* 80: ExtraBold, Heavy, ... */
- XLFD_WEIGHT_ULTRA_BOLD /* 90: UltraBold, Black, ... */
-};
-
-/* Relative proportionate width. */
-
-enum xlfd_swidth
-{
- XLFD_SWIDTH_UNKNOWN,
- XLFD_SWIDTH_ULTRA_CONDENSED, /* 10 */
- XLFD_SWIDTH_EXTRA_CONDENSED, /* 20 */
- XLFD_SWIDTH_CONDENSED, /* 30: Condensed, Narrow, Compressed, ... */
- XLFD_SWIDTH_SEMI_CONDENSED, /* 40: semicondensed */
- XLFD_SWIDTH_MEDIUM, /* 50: Medium, Normal, Regular, ... */
- XLFD_SWIDTH_SEMI_EXPANDED, /* 60: SemiExpanded, DemiExpanded, ... */
- XLFD_SWIDTH_EXPANDED, /* 70: Expanded... */
- XLFD_SWIDTH_EXTRA_EXPANDED, /* 80: ExtraExpanded, Wide... */
- XLFD_SWIDTH_ULTRA_EXPANDED /* 90: UltraExpanded... */
-};
-
/* Order by which font selection chooses fonts. The default values
mean `first, find a best match for the font width, then for the
font height, then for weight, then for slant.' This variable can be
@@ -4883,7 +4865,7 @@ lookup_named_face (struct window *w, struct frame *f,
/* Return the display face-id of the basic face whose canonical face-id
is FACE_ID. The return value will usually simply be FACE_ID, unless that
- basic face has bee remapped via Vface_remapping_alist. This function is
+ basic face has been remapped via Vface_remapping_alist. This function is
conservative: if something goes wrong, it will simply return FACE_ID
rather than signal an error. Window W, if non-NULL, is used to filter
face specifications for remapping. */
@@ -4899,7 +4881,7 @@ lookup_basic_face (struct window *w, struct frame *f, int face_id)
switch (face_id)
{
case DEFAULT_FACE_ID: name = Qdefault; break;
- case MODE_LINE_FACE_ID: name = Qmode_line; break;
+ case MODE_LINE_ACTIVE_FACE_ID: name = Qmode_line_active; break;
case MODE_LINE_INACTIVE_FACE_ID: name = Qmode_line_inactive; break;
case HEADER_LINE_FACE_ID: name = Qheader_line; break;
case TAB_LINE_FACE_ID: name = Qtab_line; break;
@@ -5373,6 +5355,10 @@ DEFUN ("display-supports-face-attributes-p",
The optional argument DISPLAY can be a display name, a frame, or
nil (meaning the selected frame's display).
+For instance, to check whether the display supports underlining:
+
+ (display-supports-face-attributes-p \\='(:underline t))
+
The definition of `supported' is somewhat heuristic, but basically means
that a face containing all the attributes in ATTRIBUTES, when merged
with the default face for display, can be represented in a way that's
@@ -5607,6 +5593,7 @@ realize_basic_faces (struct frame *f)
if (realize_default_face (f))
{
realize_named_face (f, Qmode_line, MODE_LINE_FACE_ID);
+ realize_named_face (f, Qmode_line_active, MODE_LINE_ACTIVE_FACE_ID);
realize_named_face (f, Qmode_line_inactive, MODE_LINE_INACTIVE_FACE_ID);
realize_named_face (f, Qtool_bar, TOOL_BAR_FACE_ID);
realize_named_face (f, Qfringe, FRINGE_FACE_ID);
@@ -6410,20 +6397,16 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos,
int face_id;
if (base_face_id >= 0)
- {
- face_id = base_face_id;
- /* Make sure the base face ID is usable: if someone freed the
- cached faces since we've looked up the base face, we need
- to look it up again. */
- if (!FACE_FROM_ID_OR_NULL (f, face_id))
- face_id = lookup_basic_face (w, f, DEFAULT_FACE_ID);
- }
+ face_id = base_face_id;
else if (NILP (Vface_remapping_alist))
face_id = DEFAULT_FACE_ID;
else
face_id = lookup_basic_face (w, f, DEFAULT_FACE_ID);
default_face = FACE_FROM_ID_OR_NULL (f, face_id);
+ /* Make sure the default face ID is usable: if someone freed the
+ cached faces since we've looked up these faces, we need to look
+ them up again. */
if (!default_face)
default_face = FACE_FROM_ID (f,
lookup_basic_face (w, f, DEFAULT_FACE_ID));
@@ -6611,7 +6594,9 @@ face_at_string_position (struct window *w, Lisp_Object string,
else
*endptr = -1;
- base_face = FACE_FROM_ID (f, base_face_id);
+ base_face = FACE_FROM_ID_OR_NULL (f, base_face_id);
+ if (!base_face)
+ base_face = FACE_FROM_ID (f, lookup_basic_face (w, f, DEFAULT_FACE_ID));
/* Optimize the default case that there is no face property. */
if (NILP (prop)
@@ -6936,13 +6921,20 @@ syms_of_xfaces (void)
DEFSYM (Qpressed_button, "pressed-button");
DEFSYM (Qflat_button, "flat-button");
DEFSYM (Qnormal, "normal");
+ DEFSYM (Qthin, "thin");
DEFSYM (Qextra_light, "extra-light");
+ DEFSYM (Qultra_light, "ultra-light");
DEFSYM (Qlight, "light");
DEFSYM (Qsemi_light, "semi-light");
+ DEFSYM (Qmedium, "medium");
DEFSYM (Qsemi_bold, "semi-bold");
+ DEFSYM (Qbook, "book");
DEFSYM (Qbold, "bold");
DEFSYM (Qextra_bold, "extra-bold");
DEFSYM (Qultra_bold, "ultra-bold");
+ DEFSYM (Qheavy, "heavy");
+ DEFSYM (Qultra_heavy, "ultra-heavy");
+ DEFSYM (Qblack, "black");
DEFSYM (Qoblique, "oblique");
DEFSYM (Qitalic, "italic");
@@ -6978,6 +6970,7 @@ syms_of_xfaces (void)
DEFSYM (Qborder, "border");
DEFSYM (Qmouse, "mouse");
DEFSYM (Qmode_line_inactive, "mode-line-inactive");
+ DEFSYM (Qmode_line_active, "mode-line-active");
DEFSYM (Qvertical_border, "vertical-border");
DEFSYM (Qwindow_divider, "window-divider");
DEFSYM (Qwindow_divider_first_pixel, "window-divider-first-pixel");
diff --git a/src/xfns.c b/src/xfns.c
index 785ae3baca5..30ed358fb28 100644
--- a/src/xfns.c
+++ b/src/xfns.c
@@ -57,6 +57,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <X11/extensions/Xdbe.h>
#endif
+#ifdef HAVE_XINPUT2
+#include <X11/extensions/XInput2.h>
+#endif
+
#ifdef USE_X_TOOLKIT
#include <X11/Shell.h>
@@ -2912,6 +2916,60 @@ initial_set_up_x_back_buffer (struct frame *f)
unblock_input ();
}
+#if defined HAVE_XINPUT2
+static void
+setup_xi_event_mask (struct frame *f)
+{
+ XIEventMask mask;
+ ptrdiff_t l = XIMaskLen (XI_LASTEVENT);
+ unsigned char *m;
+
+ mask.mask = m = alloca (l);
+ memset (m, 0, l);
+ mask.mask_len = l;
+
+ block_input ();
+#ifndef USE_GTK
+ mask.deviceid = XIAllMasterDevices;
+
+ XISetMask (m, XI_ButtonPress);
+ XISetMask (m, XI_ButtonRelease);
+ XISetMask (m, XI_KeyPress);
+ XISetMask (m, XI_KeyRelease);
+ XISetMask (m, XI_Motion);
+ XISetMask (m, XI_Enter);
+ XISetMask (m, XI_Leave);
+#if 0
+ XISetMask (m, XI_FocusIn);
+ XISetMask (m, XI_FocusOut);
+#endif
+ XISelectEvents (FRAME_X_DISPLAY (f),
+ FRAME_X_WINDOW (f),
+ &mask, 1);
+
+ memset (m, 0, l);
+#endif /* !USE_GTK */
+
+ mask.deviceid = XIAllDevices;
+
+ XISetMask (m, XI_PropertyEvent);
+ XISetMask (m, XI_HierarchyChanged);
+ XISetMask (m, XI_DeviceChanged);
+#ifdef XI_TouchBegin
+ if (FRAME_DISPLAY_INFO (f)->xi2_version >= 2)
+ {
+ XISetMask (m, XI_TouchBegin);
+ XISetMask (m, XI_TouchUpdate);
+ XISetMask (m, XI_TouchEnd);
+ }
+#endif
+ XISelectEvents (FRAME_X_DISPLAY (f),
+ FRAME_X_WINDOW (f),
+ &mask, 1);
+ unblock_input ();
+}
+#endif
+
#ifdef USE_X_TOOLKIT
/* Create and set up the X widget for frame F. */
@@ -3074,6 +3132,11 @@ x_window (struct frame *f, long window_prompting)
class_hints.res_class = SSDATA (Vx_resource_class);
XSetClassHint (FRAME_X_DISPLAY (f), XtWindow (shell_widget), &class_hints);
+#ifdef HAVE_XINPUT2
+ if (FRAME_DISPLAY_INFO (f)->supports_xi2)
+ setup_xi_event_mask (f);
+#endif
+
#ifdef HAVE_X_I18N
FRAME_XIC (f) = NULL;
if (use_xim)
@@ -3200,6 +3263,11 @@ x_window (struct frame *f)
unblock_input ();
}
#endif
+
+#ifdef HAVE_XINPUT2
+ if (FRAME_DISPLAY_INFO (f)->supports_xi2)
+ setup_xi_event_mask (f);
+#endif
}
#else /*! USE_GTK */
@@ -3254,6 +3322,11 @@ x_window (struct frame *f)
}
#endif /* HAVE_X_I18N */
+#ifdef HAVE_XINPUT2
+ if (FRAME_DISPLAY_INFO (f)->supports_xi2)
+ setup_xi_event_mask (f);
+#endif
+
validate_x_resource_name ();
class_hints.res_name = SSDATA (Vx_resource_name);
@@ -4416,7 +4489,8 @@ For GNU and Unix system, the first 2 numbers are the version of the X
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.
+hard-coded and the 3rd represents the OS version. For Haiku, all 3
+numbers are hard-coded.
See also the function `x-server-vendor'.
@@ -7095,7 +7169,8 @@ Text larger than the specified size is clipped. */)
try_window (window, pos, TRY_WINDOW_IGNORE_FONTS_CHANGE);
/* Calculate size of tooltip window. */
size = Fwindow_text_pixel_size (window, Qnil, Qnil, Qnil,
- make_fixnum (w->pixel_height), Qnil);
+ make_fixnum (w->pixel_height), Qnil,
+ Qnil);
/* Add the frame's internal border to calculated size. */
width = XFIXNUM (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
height = XFIXNUM (Fcdr (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
@@ -7374,7 +7449,7 @@ Use a file selection dialog. Select DEFAULT-FILENAME in the dialog's file
selection box, if specified. If MUSTMATCH is non-nil, the returned file
or directory must exist.
-This function is defined only on NS, MS Windows, and X Windows with the
+This function is defined only on NS, Haiku, MS Windows, and X Windows with the
Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored.
Otherwise, if ONLY-DIR-P is non-nil, the user can select only directories.
On MS Windows 7 and later, the file selection dialog "remembers" the last
@@ -8038,6 +8113,12 @@ eliminated in future versions of Emacs. */);
/* Tell Emacs about this window system. */
Fprovide (Qx, Qnil);
+#ifdef HAVE_XINPUT2
+ DEFSYM (Qxinput2, "xinput2");
+
+ Fprovide (Qxinput2, Qnil);
+#endif
+
#ifdef USE_X_TOOLKIT
Fprovide (intern_c_string ("x-toolkit"), Qnil);
#ifdef USE_MOTIF
diff --git a/src/xmenu.c b/src/xmenu.c
index ea2cbab2030..07255911f97 100644
--- a/src/xmenu.c
+++ b/src/xmenu.c
@@ -105,7 +105,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
/* Flag which when set indicates a dialog or menu has been posted by
Xt on behalf of one of the widget sets. */
+#ifndef HAVE_XINPUT2
static int popup_activated_flag;
+#else
+int popup_activated_flag;
+#endif
#ifdef USE_X_TOOLKIT
diff --git a/src/xsettings.c b/src/xsettings.c
index 58dfd43ad18..d6a715e1dfc 100644
--- a/src/xsettings.c
+++ b/src/xsettings.c
@@ -26,7 +26,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <byteswap.h>
#include "lisp.h"
+#ifndef HAVE_PGTK
#include "xterm.h"
+#else
+#include "gtkutil.h"
+#endif
#include "xsettings.h"
#include "frame.h"
#include "keyboard.h"
@@ -34,7 +38,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "termhooks.h"
#include "pdumper.h"
+#ifndef HAVE_PGTK
#include <X11/Xproto.h>
+#else
+typedef unsigned short CARD16;
+typedef unsigned int CARD32;
+#endif
#ifdef HAVE_GSETTINGS
#include <glib-object.h>
@@ -55,7 +64,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
static char *current_mono_font;
static char *current_font;
-static struct x_display_info *first_dpyinfo;
+static Display_Info *first_dpyinfo;
static Lisp_Object current_tool_bar_style;
/* Store a config changed event in to the event queue. */
@@ -73,14 +82,18 @@ store_config_changed_event (Lisp_Object arg, Lisp_Object display_name)
/* Return true if DPYINFO is still valid. */
static bool
-dpyinfo_valid (struct x_display_info *dpyinfo)
+dpyinfo_valid (Display_Info *dpyinfo)
{
bool found = false;
if (dpyinfo != NULL)
{
- struct x_display_info *d;
+ Display_Info *d;
for (d = x_display_list; !found && d; d = d->next)
+#ifndef HAVE_PGTK
found = d == dpyinfo && d->display == dpyinfo->display;
+#else
+ found = d == dpyinfo && d->gdpy == dpyinfo->gdpy;
+#endif
}
return found;
}
@@ -149,7 +162,7 @@ map_tool_bar_style (const char *tool_bar_style)
static void
store_tool_bar_style_changed (const char *newstyle,
- struct x_display_info *dpyinfo)
+ Display_Info *dpyinfo)
{
Lisp_Object style = map_tool_bar_style (newstyle);
if (EQ (current_tool_bar_style, style))
@@ -161,10 +174,12 @@ store_tool_bar_style_changed (const char *newstyle,
XCAR (dpyinfo->name_list_element));
}
+#ifndef HAVE_PGTK
#if defined USE_CAIRO || defined HAVE_XFT
#define XSETTINGS_FONT_NAME "Gtk/FontName"
#endif
#define XSETTINGS_TOOL_BAR_STYLE "Gtk/ToolbarStyle"
+#endif
enum {
SEEN_AA = 0x01,
@@ -321,10 +336,11 @@ something_changed_gconfCB (GConfClient *client,
#endif /* USE_CAIRO || HAVE_XFT */
+#ifndef HAVE_PGTK
/* Find the window that contains the XSETTINGS property values. */
static void
-get_prop_window (struct x_display_info *dpyinfo)
+get_prop_window (Display_Info *dpyinfo)
{
Display *dpy = dpyinfo->display;
@@ -339,6 +355,9 @@ get_prop_window (struct x_display_info *dpyinfo)
XUngrabServer (dpy);
}
+#endif
+
+#ifndef HAVE_PGTK
#define PAD(nr) (((nr) + 3) & ~3)
@@ -566,13 +585,15 @@ parse_settings (unsigned char *prop,
return settings_seen;
}
+#endif
+#ifndef HAVE_PGTK
/* Read settings from the XSettings property window on display for DPYINFO.
Store settings read in SETTINGS.
Return true iff successful. */
static bool
-read_settings (struct x_display_info *dpyinfo, struct xsettings *settings)
+read_settings (Display_Info *dpyinfo, struct xsettings *settings)
{
Atom act_type;
int act_form;
@@ -600,12 +621,14 @@ read_settings (struct x_display_info *dpyinfo, struct xsettings *settings)
return got_settings;
}
+#endif
+#ifndef HAVE_PGTK
/* Apply Xft settings in SETTINGS to the Xft library.
Store a Lisp event that Xft settings changed. */
static void
-apply_xft_settings (struct x_display_info *dpyinfo,
+apply_xft_settings (Display_Info *dpyinfo,
struct xsettings *settings)
{
#ifdef HAVE_XFT
@@ -731,12 +754,14 @@ apply_xft_settings (struct x_display_info *dpyinfo,
FcPatternDestroy (pat);
#endif /* HAVE_XFT */
}
+#endif
+#ifndef HAVE_PGTK
/* Read XSettings from the display for DPYINFO.
If SEND_EVENT_P store a Lisp event settings that changed. */
static void
-read_and_apply_settings (struct x_display_info *dpyinfo, bool send_event_p)
+read_and_apply_settings (Display_Info *dpyinfo, bool send_event_p)
{
struct xsettings settings;
@@ -763,11 +788,13 @@ read_and_apply_settings (struct x_display_info *dpyinfo, bool send_event_p)
}
#endif
}
+#endif
+#ifndef HAVE_PGTK
/* Check if EVENT for the display in DPYINFO is XSettings related. */
void
-xft_settings_event (struct x_display_info *dpyinfo, const XEvent *event)
+xft_settings_event (Display_Info *dpyinfo, const XEvent *event)
{
bool check_window_p = false, apply_settings_p = false;
@@ -805,6 +832,7 @@ xft_settings_event (struct x_display_info *dpyinfo, const XEvent *event)
if (apply_settings_p)
read_and_apply_settings (dpyinfo, true);
}
+#endif
/* Initialize GSettings and read startup values. */
@@ -940,10 +968,11 @@ init_gconf (void)
#endif /* HAVE_GCONF */
}
+#ifndef HAVE_PGTK
/* Init Xsettings and read startup values. */
static void
-init_xsettings (struct x_display_info *dpyinfo)
+init_xsettings (Display_Info *dpyinfo)
{
Display *dpy = dpyinfo->display;
@@ -959,13 +988,16 @@ init_xsettings (struct x_display_info *dpyinfo)
unblock_input ();
}
+#endif
void
-xsettings_initialize (struct x_display_info *dpyinfo)
+xsettings_initialize (Display_Info *dpyinfo)
{
if (first_dpyinfo == NULL) first_dpyinfo = dpyinfo;
init_gconf ();
+#ifndef HAVE_PGTK
init_xsettings (dpyinfo);
+#endif
init_gsettings ();
}
diff --git a/src/xsettings.h b/src/xsettings.h
index 26717fc08cb..dae41e8a3b8 100644
--- a/src/xsettings.h
+++ b/src/xsettings.h
@@ -20,12 +20,23 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifndef XSETTINGS_H
#define XSETTINGS_H
+#ifndef HAVE_PGTK
#include <X11/Xlib.h>
+#endif
struct x_display_info;
+struct pgtk_display_info;
+
+#ifndef HAVE_PGTK
+typedef struct x_display_info Display_Info;
+#else
+typedef struct pgtk_display_info Display_Info;
+#endif
-extern void xsettings_initialize (struct x_display_info *);
-extern void xft_settings_event (struct x_display_info *, const XEvent *);
+extern void xsettings_initialize (Display_Info *);
+#ifndef HAVE_PGTK
+extern void xft_settings_event (Display_Info *, const XEvent *);
+#endif
extern const char *xsettings_get_system_font (void);
#ifdef USE_LUCID
extern const char *xsettings_get_system_normal_font (void);
diff --git a/src/xterm.c b/src/xterm.c
index 89885e0d889..7456b3b6beb 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -42,6 +42,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <X11/extensions/Xdbe.h>
#endif
+#ifdef HAVE_XINPUT2
+#include <X11/extensions/XInput2.h>
+#endif
+
/* Load sys/types.h if not already loaded.
In some systems loading it twice is suicidal. */
#ifndef makedev
@@ -223,9 +227,15 @@ static bool x_handle_net_wm_state (struct frame *, const XPropertyEvent *);
static void x_check_fullscreen (struct frame *);
static void x_check_expected_move (struct frame *, int, int);
static void x_sync_with_move (struct frame *, int, int, bool);
+#ifndef HAVE_XINPUT2
static int handle_one_xevent (struct x_display_info *,
const XEvent *, int *,
struct input_event *);
+#else
+static int handle_one_xevent (struct x_display_info *,
+ XEvent *, int *,
+ struct input_event *);
+#endif
#if ! (defined USE_X_TOOLKIT || defined USE_MOTIF) && defined USE_GTK
static int x_dispatch_event (XEvent *, Display *);
#endif
@@ -335,6 +345,336 @@ x_extension_initialize (struct x_display_info *dpyinfo)
dpyinfo->ext_codes = ext_codes;
}
+#endif /* HAVE_CAIRO */
+
+#ifdef HAVE_XINPUT2
+
+/* Free all XI2 devices on dpyinfo. */
+static void
+x_free_xi_devices (struct x_display_info *dpyinfo)
+{
+ struct xi_touch_point_t *tem, *last;
+
+ block_input ();
+
+ if (dpyinfo->num_devices)
+ {
+ for (int i = 0; i < dpyinfo->num_devices; ++i)
+ {
+ XIUngrabDevice (dpyinfo->display, dpyinfo->devices[i].device_id,
+ CurrentTime);
+ xfree (dpyinfo->devices[i].valuators);
+
+ tem = dpyinfo->devices[i].touchpoints;
+ while (tem)
+ {
+ last = tem;
+ tem = tem->next;
+ xfree (last);
+ }
+ }
+
+ xfree (dpyinfo->devices);
+ dpyinfo->devices = NULL;
+ dpyinfo->num_devices = 0;
+ }
+
+ unblock_input ();
+}
+
+/* The code below handles the tracking of scroll valuators on XInput
+ 2, in order to support scroll wheels that report information more
+ granular than a screen line.
+
+ On X, when the XInput 2 extension is being utilized, the states of
+ the mouse wheels in each axis are stored as absolute values inside
+ "valuators" attached to each mouse device. To obtain the delta of
+ the scroll wheel from a motion event (which is used to report that
+ some valuator has changed), it is necessary to iterate over every
+ valuator that changed, and compare its previous value to the
+ current value of the valuator.
+
+ Each individual valuator also has an "interval", which is the
+ amount you must divide that delta by in order to obtain a delta in
+ the terms of scroll units.
+
+ This delta however is still intermediate, to make driver
+ implementations easier. The XInput developers recommend (and most
+ programs use) the following algorithm to convert from scroll unit
+ deltas to pixel deltas:
+
+ pixels_scrolled = pow (window_height, 2.0 / 3.0) * delta; */
+
+/* Setup valuator tracking for XI2 master devices on
+ DPYINFO->display. */
+
+static void
+x_init_master_valuators (struct x_display_info *dpyinfo)
+{
+ int ndevices;
+ XIDeviceInfo *infos;
+
+ block_input ();
+ x_free_xi_devices (dpyinfo);
+ infos = XIQueryDevice (dpyinfo->display,
+ XIAllDevices,
+ &ndevices);
+
+ if (!ndevices)
+ {
+ XIFreeDeviceInfo (infos);
+ unblock_input ();
+ return;
+ }
+
+ int actual_devices = 0;
+ dpyinfo->devices = xmalloc (sizeof *dpyinfo->devices * ndevices);
+
+ for (int i = 0; i < ndevices; ++i)
+ {
+ XIDeviceInfo *device = &infos[i];
+
+ if (device->enabled)
+ {
+ int actual_valuator_count = 0;
+ struct xi_device_t *xi_device = &dpyinfo->devices[actual_devices++];
+ xi_device->device_id = device->deviceid;
+ xi_device->grab = 0;
+ xi_device->valuators =
+ xmalloc (sizeof *xi_device->valuators * device->num_classes);
+ xi_device->touchpoints = NULL;
+ xi_device->master_p = (device->use == XIMasterKeyboard
+ || device->use == XIMasterPointer);
+ xi_device->direct_p = false;
+
+ for (int c = 0; c < device->num_classes; ++c)
+ {
+ switch (device->classes[c]->type)
+ {
+#ifdef XIScrollClass /* XInput 2.1 */
+ case XIScrollClass:
+ {
+ XIScrollClassInfo *info =
+ (XIScrollClassInfo *) device->classes[c];
+ struct xi_scroll_valuator_t *valuator;
+
+ if (xi_device->master_p)
+ {
+ valuator = &xi_device->valuators[actual_valuator_count++];
+ valuator->horizontal
+ = (info->scroll_type == XIScrollTypeHorizontal);
+ valuator->invalid_p = true;
+ valuator->emacs_value = DBL_MIN;
+ valuator->increment = info->increment;
+ valuator->number = info->number;
+ }
+
+ break;
+ }
+#endif
+#ifdef XITouchClass /* XInput 2.2 */
+ case XITouchClass:
+ {
+ XITouchClassInfo *info;
+
+ info = (XITouchClassInfo *) device->classes[c];
+ xi_device->direct_p = info->mode == XIDirectTouch;
+ }
+#endif
+ default:
+ break;
+ }
+ }
+
+ xi_device->scroll_valuator_count = actual_valuator_count;
+ }
+ }
+
+ dpyinfo->num_devices = actual_devices;
+ XIFreeDeviceInfo (infos);
+ unblock_input ();
+}
+
+/* Return the delta of the scroll valuator VALUATOR_NUMBER under
+ DEVICE_ID in the display DPYINFO with VALUE. The valuator's
+ valuator will be set to VALUE afterwards. In case no scroll
+ valuator is found, or if device_id is not known to Emacs, DBL_MAX
+ is returned. Otherwise, the valuator is returned in
+ VALUATOR_RETURN. */
+static double
+x_get_scroll_valuator_delta (struct x_display_info *dpyinfo, int device_id,
+ int valuator_number, double value,
+ struct xi_scroll_valuator_t **valuator_return)
+{
+ block_input ();
+
+ for (int i = 0; i < dpyinfo->num_devices; ++i)
+ {
+ struct xi_device_t *device = &dpyinfo->devices[i];
+
+ if (device->device_id == device_id && device->master_p)
+ {
+ for (int j = 0; j < device->scroll_valuator_count; ++j)
+ {
+ struct xi_scroll_valuator_t *sv = &device->valuators[j];
+
+ if (sv->number == valuator_number)
+ {
+ if (sv->invalid_p)
+ {
+ sv->current_value = value;
+ sv->invalid_p = false;
+ *valuator_return = sv;
+
+ unblock_input ();
+ return 0.0;
+ }
+ else
+ {
+ double delta = (sv->current_value - value) / sv->increment;
+ sv->current_value = value;
+ *valuator_return = sv;
+
+ unblock_input ();
+ return delta;
+ }
+ }
+ }
+
+ unblock_input ();
+ return DBL_MAX;
+ }
+ }
+
+ unblock_input ();
+ return DBL_MAX;
+}
+
+static struct xi_device_t *
+xi_device_from_id (struct x_display_info *dpyinfo, int deviceid)
+{
+ for (int i = 0; i < dpyinfo->num_devices; ++i)
+ {
+ if (dpyinfo->devices[i].device_id == deviceid)
+ return &dpyinfo->devices[i];
+ }
+
+ return NULL;
+}
+
+#ifdef XI_TouchBegin
+
+static void
+xi_link_touch_point (struct xi_device_t *device,
+ int detail, double x, double y)
+{
+ struct xi_touch_point_t *touchpoint;
+
+ touchpoint = xmalloc (sizeof *touchpoint);
+ touchpoint->next = device->touchpoints;
+ touchpoint->x = x;
+ touchpoint->y = y;
+ touchpoint->number = detail;
+
+ device->touchpoints = touchpoint;
+}
+
+static bool
+xi_unlink_touch_point (int detail,
+ struct xi_device_t *device)
+{
+ struct xi_touch_point_t *last, *tem;
+
+ for (last = NULL, tem = device->touchpoints; tem;
+ last = tem, tem = tem->next)
+ {
+ if (tem->number == detail)
+ {
+ if (!last)
+ device->touchpoints = tem->next;
+ else
+ last->next = tem->next;
+
+ xfree (tem);
+ return true;
+ }
+ }
+
+ return false;
+}
+
+static struct xi_touch_point_t *
+xi_find_touch_point (struct xi_device_t *device, int detail)
+{
+ struct xi_touch_point_t *point;
+
+ for (point = device->touchpoints; point; point = point->next)
+ {
+ if (point->number == detail)
+ return point;
+ }
+
+ return NULL;
+}
+
+#endif /* XI_TouchBegin */
+
+static void
+xi_grab_or_ungrab_device (struct xi_device_t *device,
+ struct x_display_info *dpyinfo,
+ Window window)
+{
+ XIEventMask mask;
+ ptrdiff_t l = XIMaskLen (XI_LASTEVENT);
+ unsigned char *m;
+ mask.mask = m = alloca (l);
+ memset (m, 0, l);
+ mask.mask_len = l;
+
+ XISetMask (m, XI_ButtonPress);
+ XISetMask (m, XI_ButtonRelease);
+ XISetMask (m, XI_Motion);
+ XISetMask (m, XI_Enter);
+ XISetMask (m, XI_Leave);
+
+ if (device->grab)
+ {
+ XIGrabDevice (dpyinfo->display, device->device_id, window,
+ CurrentTime, None, GrabModeAsync,
+ GrabModeAsync, True, &mask);
+ }
+ else
+ {
+ XIUngrabDevice (dpyinfo->display, device->device_id, CurrentTime);
+ }
+}
+
+static void
+xi_reset_scroll_valuators_for_device_id (struct x_display_info *dpyinfo, int id)
+{
+ struct xi_device_t *device = xi_device_from_id (dpyinfo, id);
+ struct xi_scroll_valuator_t *valuator;
+
+ if (!device || !device->master_p)
+ return;
+
+ if (!device->scroll_valuator_count)
+ return;
+
+ for (int i = 0; i < device->scroll_valuator_count; ++i)
+ {
+ valuator = &device->valuators[i];
+ valuator->invalid_p = true;
+ valuator->emacs_value = 0.0;
+ }
+
+ return;
+}
+
+#endif
+
+#ifdef USE_CAIRO
+
void
x_cr_destroy_frame_context (struct frame *f)
{
@@ -1563,22 +1903,6 @@ x_set_cursor_gc (struct glyph_string *s)
static void
x_set_mouse_face_gc (struct glyph_string *s)
{
- int face_id;
- struct face *face;
-
- /* What face has to be used last for the mouse face? */
- face_id = MOUSE_HL_INFO (s->f)->mouse_face_face_id;
- face = FACE_FROM_ID_OR_NULL (s->f, face_id);
- if (face == NULL)
- face = FACE_FROM_ID (s->f, MOUSE_FACE_ID);
-
- if (s->first_glyph->type == CHAR_GLYPH)
- face_id = FACE_FOR_CHAR (s->f, face, s->first_glyph->u.ch, -1, Qnil);
- else
- face_id = FACE_FOR_CHAR (s->f, face, 0, -1, Qnil);
- s->face = FACE_FROM_ID (s->f, face_id);
- prepare_face_for_display (s->f, s->face);
-
if (s->font == s->face->font)
s->gc = s->face->gc;
else
@@ -3806,6 +4130,10 @@ x_draw_glyph_string (struct glyph_string *s)
if (!s->for_overlaps)
{
+ /* Draw relief if not yet drawn. */
+ if (!relief_drawn_p && s->face->box != FACE_NO_BOX)
+ x_draw_glyph_string_box (s);
+
/* Draw underline. */
if (s->face->underline)
{
@@ -3961,10 +4289,6 @@ x_draw_glyph_string (struct glyph_string *s)
}
}
- /* Draw relief if not yet drawn. */
- if (!relief_drawn_p && s->face->box != FACE_NO_BOX)
- x_draw_glyph_string_box (s);
-
if (s->prev)
{
struct glyph_string *prev;
@@ -4142,6 +4466,8 @@ x_show_hourglass (struct frame *f)
XMapRaised (dpy, x->hourglass_window);
XFlush (dpy);
+ /* Ensure that the spinning hourglass is shown. */
+ flush_frame (f);
}
}
}
@@ -4405,6 +4731,99 @@ x_scroll_run (struct window *w, struct run *run)
/* Cursor off. Will be switched on again in gui_update_window_end. */
gui_clear_cursor (w);
+#ifdef HAVE_XWIDGETS
+ /* "Copy" xwidget windows in the area that will be scrolled. */
+ Display *dpy = FRAME_X_DISPLAY (f);
+ Window window = FRAME_X_WINDOW (f);
+
+ Window root, parent, *children;
+ unsigned int nchildren;
+
+ if (XQueryTree (dpy, window, &root, &parent, &children, &nchildren))
+ {
+ /* Now find xwidget views situated between from_y and to_y, and
+ attached to w. */
+ for (unsigned int i = 0; i < nchildren; ++i)
+ {
+ Window child = children[i];
+ struct xwidget_view *view = xwidget_view_from_window (child);
+
+ if (view && !view->hidden)
+ {
+ int window_y = view->y + view->clip_top;
+ int window_height = view->clip_bottom - view->clip_top;
+
+ Emacs_Rectangle r1, r2, result;
+ r1.x = w->pixel_left;
+ r1.y = from_y;
+ r1.width = w->pixel_width;
+ r1.height = height;
+ r2 = r1;
+ r2.y = window_y;
+ r2.height = window_height;
+
+ /* The window is offscreen, just unmap it. */
+ if (window_height == 0)
+ {
+ view->hidden = true;
+ XUnmapWindow (dpy, child);
+ continue;
+ }
+
+ bool intersects_p =
+ gui_intersect_rectangles (&r1, &r2, &result);
+
+ if (XWINDOW (view->w) == w && intersects_p)
+ {
+ int y = view->y + (to_y - from_y);
+ int text_area_x, text_area_y, text_area_width, text_area_height;
+ int clip_top, clip_bottom;
+
+ window_box (w, view->area, &text_area_x, &text_area_y,
+ &text_area_width, &text_area_height);
+
+ view->y = y;
+
+ clip_top = 0;
+ clip_bottom = XXWIDGET (view->model)->height;
+
+ if (y < text_area_y)
+ clip_top = text_area_y - y;
+
+ if ((y + clip_bottom) > (text_area_y + text_area_height))
+ {
+ clip_bottom -= (y + clip_bottom) - (text_area_y + text_area_height);
+ }
+
+ view->clip_top = clip_top;
+ view->clip_bottom = clip_bottom;
+
+ /* This means the view has moved offscreen. Unmap
+ it and hide it here. */
+ if ((view->clip_bottom - view->clip_top) <= 0)
+ {
+ view->hidden = true;
+ XUnmapWindow (dpy, child);
+ }
+ else
+ {
+ XMoveResizeWindow (dpy, child, view->x + view->clip_left,
+ view->y + view->clip_top,
+ view->clip_right - view->clip_left,
+ view->clip_bottom - view->clip_top);
+ cairo_xlib_surface_set_size (view->cr_surface,
+ view->clip_right - view->clip_left,
+ view->clip_bottom - view->clip_top);
+ }
+ xwidget_expose (view);
+ XFlush (dpy);
+ }
+ }
+ }
+ XFree (children);
+ }
+#endif
+
#ifdef USE_CAIRO
if (FRAME_CR_CONTEXT (f))
{
@@ -4578,8 +4997,9 @@ x_focus_changed (int type, int state, struct x_display_info *dpyinfo, struct fra
}
}
-/* Return the Emacs frame-object corresponding to an X window.
- It could be the frame's main window or an icon window. */
+/* Return the Emacs frame-object corresponding to an X window. It
+ could be the frame's main window, an icon window, or an xwidget
+ window. */
static struct frame *
x_window_to_frame (struct x_display_info *dpyinfo, int wdesc)
@@ -4590,6 +5010,13 @@ x_window_to_frame (struct x_display_info *dpyinfo, int wdesc)
if (wdesc == None)
return NULL;
+#ifdef HAVE_XWIDGETS
+ struct xwidget_view *xvw = xwidget_view_from_window (wdesc);
+
+ if (xvw && xvw->frame)
+ return xvw->frame;
+#endif
+
FOR_EACH_FRAME (tail, frame)
{
f = XFRAME (frame);
@@ -4681,7 +5108,16 @@ static struct frame *
x_menubar_window_to_frame (struct x_display_info *dpyinfo,
const XEvent *event)
{
- Window wdesc = event->xany.window;
+ Window wdesc;
+#ifdef HAVE_XINPUT2
+ if (event->type == GenericEvent
+ && dpyinfo->supports_xi2
+ && (event->xcookie.evtype == XI_ButtonPress
+ || event->xcookie.evtype == XI_ButtonRelease))
+ wdesc = ((XIDeviceEvent *) event->xcookie.data)->event;
+ else
+#endif
+ wdesc = event->xany.window;
Lisp_Object tail, frame;
struct frame *f;
struct x_output *x;
@@ -4784,6 +5220,37 @@ x_detect_focus_change (struct x_display_info *dpyinfo, struct frame *frame,
}
break;
+#ifdef HAVE_XINPUT2
+ case GenericEvent:
+ {
+ XIEvent *xi_event = (XIEvent *) event;
+
+ struct frame *focus_frame = dpyinfo->x_focus_event_frame;
+ int focus_state
+ = focus_frame ? focus_frame->output_data.x->focus_state : 0;
+
+#ifdef USE_GTK
+ if (xi_event->evtype == XI_FocusIn
+ || xi_event->evtype == XI_FocusOut)
+ x_focus_changed ((xi_event->evtype == XI_FocusIn
+ ? FocusIn : FocusOut),
+ FOCUS_EXPLICIT,
+ dpyinfo, frame, bufp);
+ else
+#endif
+ if ((xi_event->evtype == XI_Enter
+ || xi_event->evtype == XI_Leave)
+ && (((XIEnterEvent *) xi_event)->detail
+ != XINotifyInferior)
+ && !(focus_state & FOCUS_EXPLICIT))
+ x_focus_changed ((xi_event->evtype == XI_Enter
+ ? FocusIn : FocusOut),
+ FOCUS_IMPLICIT,
+ dpyinfo, frame, bufp);
+ break;
+ }
+#endif
+
case FocusIn:
case FocusOut:
/* Ignore transient focus events from hotkeys, window manager
@@ -5012,7 +5479,7 @@ x_x_to_emacs_modifiers (struct x_display_info *dpyinfo, int state)
| ((state & dpyinfo->hyper_mod_mask) ? mod_hyper : 0));
}
-static int
+int
x_emacs_to_x_modifiers (struct x_display_info *dpyinfo, intmax_t state)
{
EMACS_INT mod_ctrl = ctrl_modifier;
@@ -7888,7 +8355,11 @@ mouse_or_wdesc_frame (struct x_display_info *dpyinfo, int wdesc)
static int
handle_one_xevent (struct x_display_info *dpyinfo,
+#ifndef HAVE_XINPUT2
const XEvent *event,
+#else
+ XEvent *event,
+#endif
int *finish, struct input_event *hold_quit)
{
union buffered_input_event inev;
@@ -7914,7 +8385,14 @@ handle_one_xevent (struct x_display_info *dpyinfo,
inev.ie.kind = NO_EVENT;
inev.ie.arg = Qnil;
- any = x_any_window_to_frame (dpyinfo, event->xany.window);
+#ifdef HAVE_XINPUT2
+ if (event->type != GenericEvent)
+#endif
+ any = x_any_window_to_frame (dpyinfo, event->xany.window);
+#ifdef HAVE_XINPUT2
+ else
+ any = NULL;
+#endif
if (any && any->wait_event_type == event->type)
any->wait_event_type = 0; /* Indicates we got it. */
@@ -8226,6 +8704,18 @@ handle_one_xevent (struct x_display_info *dpyinfo,
case Expose:
f = x_window_to_frame (dpyinfo, event->xexpose.window);
+#ifdef HAVE_XWIDGETS
+ {
+ struct xwidget_view *xv =
+ xwidget_view_from_window (event->xexpose.window);
+
+ if (xv)
+ {
+ xwidget_expose (xv);
+ goto OTHER;
+ }
+ }
+#endif
if (f)
{
if (!FRAME_VISIBLE_P (f))
@@ -8381,6 +8871,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
goto OTHER;
case MapNotify:
+#if defined HAVE_XINPUT2 && defined HAVE_GTK3
+ if (xg_is_menu_window (dpyinfo->display, event->xmap.window))
+ popup_activated_flag = 1;
+#endif
/* We use x_top_window_to_frame because map events can
come for sub-windows and they don't mean that the
frame is visible. */
@@ -8806,6 +9300,31 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_display_set_last_user_time (dpyinfo, event->xcrossing.time);
x_detect_focus_change (dpyinfo, any, event, &inev.ie);
+#ifdef HAVE_XWIDGETS
+ {
+ struct xwidget_view *xvw = xwidget_view_from_window (event->xcrossing.window);
+ Mouse_HLInfo *hlinfo;
+
+ if (xvw)
+ {
+ xwidget_motion_or_crossing (xvw, event);
+ hlinfo = MOUSE_HL_INFO (xvw->frame);
+
+ if (xvw->frame == hlinfo->mouse_face_mouse_frame)
+ {
+ clear_mouse_face (hlinfo);
+ hlinfo->mouse_face_mouse_frame = 0;
+ }
+
+ if (any_help_event_p)
+ {
+ do_help = -1;
+ }
+ goto OTHER;
+ }
+ }
+#endif
+
f = any;
if (f && x_mouse_click_focus_ignore_position)
@@ -8849,6 +9368,17 @@ handle_one_xevent (struct x_display_info *dpyinfo,
goto OTHER;
case LeaveNotify:
+#ifdef HAVE_XWIDGETS
+ {
+ struct xwidget_view *xvw = xwidget_view_from_window (event->xcrossing.window);
+
+ if (xvw)
+ {
+ xwidget_motion_or_crossing (xvw, event);
+ goto OTHER;
+ }
+ }
+#endif
x_display_set_last_user_time (dpyinfo, event->xcrossing.time);
x_detect_focus_change (dpyinfo, any, event, &inev.ie);
@@ -8899,6 +9429,12 @@ handle_one_xevent (struct x_display_info *dpyinfo,
if (f && xg_event_is_for_scrollbar (f, event))
f = 0;
#endif
+#ifdef HAVE_XWIDGETS
+ struct xwidget_view *xvw = xwidget_view_from_window (event->xmotion.window);
+
+ if (xvw)
+ xwidget_motion_or_crossing (xvw, event);
+#endif
if (f)
{
/* Maybe generate a SELECT_WINDOW_EVENT for
@@ -9153,6 +9689,24 @@ handle_one_xevent (struct x_display_info *dpyinfo,
case ButtonRelease:
case ButtonPress:
{
+#ifdef HAVE_XWIDGETS
+ struct xwidget_view *xvw = xwidget_view_from_window (event->xmotion.window);
+
+ if (xvw)
+ {
+ xwidget_button (xvw, event->type == ButtonPress,
+ event->xbutton.x, event->xbutton.y,
+ event->xbutton.button, event->xbutton.state,
+ event->xbutton.time);
+
+ if (!EQ (selected_window, xvw->w) && (event->xbutton.button < 4))
+ {
+ inev.ie.kind = SELECT_WINDOW_EVENT;
+ inev.ie.frame_or_window = xvw->w;
+ }
+ goto OTHER;
+ }
+#endif
/* If we decide we want to generate an event to be seen
by the rest of Emacs, we put it here. */
Lisp_Object tab_bar_arg = Qnil;
@@ -9352,6 +9906,11 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_find_modifier_meanings (dpyinfo);
FALLTHROUGH;
case MappingKeyboard:
+#ifdef HAVE_XKB
+ if (dpyinfo->xkb_desc)
+ XkbGetUpdatedMap (dpyinfo->display, XkbAllComponentsMask,
+ dpyinfo->xkb_desc);
+#endif
XRefreshKeyboardMapping ((XMappingEvent *) &event->xmapping);
}
goto OTHER;
@@ -9359,6 +9918,1107 @@ handle_one_xevent (struct x_display_info *dpyinfo,
case DestroyNotify:
xft_settings_event (dpyinfo, event);
break;
+#ifdef HAVE_XINPUT2
+ case GenericEvent:
+ {
+ if (!dpyinfo->supports_xi2)
+ goto OTHER;
+ if (event->xgeneric.extension != dpyinfo->xi2_opcode)
+ /* Not an XI2 event. */
+ goto OTHER;
+ bool must_free_data = false;
+ XIEvent *xi_event = (XIEvent *) event->xcookie.data;
+ /* Sometimes the event is already claimed by GTK, which
+ will free its data in due course. */
+ if (!xi_event && XGetEventData (dpyinfo->display, &event->xcookie))
+ {
+ must_free_data = true;
+ xi_event = (XIEvent *) event->xcookie.data;
+ }
+
+ XIDeviceEvent *xev = (XIDeviceEvent *) xi_event;
+ XILeaveEvent *leave = (XILeaveEvent *) xi_event;
+ XIEnterEvent *enter = (XIEnterEvent *) xi_event;
+ XIFocusInEvent *focusin = (XIFocusInEvent *) xi_event;
+ XIFocusOutEvent *focusout = (XIFocusOutEvent *) xi_event;
+ XIValuatorState *states;
+ double *values;
+ bool found_valuator = false;
+#ifdef HAVE_XWIDGETS
+ bool any_stop_p = false;
+#endif /* HAVE_XWIDGETS */
+
+ /* A fake XMotionEvent for x_note_mouse_movement. */
+ XMotionEvent ev;
+ /* A fake XButtonEvent for x_construct_mouse_click. */
+ XButtonEvent bv;
+
+ if (!xi_event)
+ {
+ eassert (!must_free_data);
+ goto OTHER;
+ }
+
+ switch (event->xcookie.evtype)
+ {
+ case XI_FocusIn:
+ any = x_any_window_to_frame (dpyinfo, focusin->event);
+#ifndef 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/deconifying. Check here if we
+ are deiconizing a window (Bug42655).
+
+ But don't do that 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. */
+ f = any;
+ if (f && FRAME_ICONIFIED_P (f))
+ {
+ SET_FRAME_VISIBLE (f, 1);
+ SET_FRAME_ICONIFIED (f, false);
+ f->output_data.x->has_been_visible = true;
+ inev.ie.kind = DEICONIFY_EVENT;
+ XSETFRAME (inev.ie.frame_or_window, f);
+ }
+#endif /* USE_GTK */
+ x_detect_focus_change (dpyinfo, any, event, &inev.ie);
+ goto XI_OTHER;
+ case XI_FocusOut:
+ any = x_any_window_to_frame (dpyinfo, focusout->event);
+ x_detect_focus_change (dpyinfo, any, event, &inev.ie);
+ goto XI_OTHER;
+ case XI_Enter:
+ any = x_any_window_to_frame (dpyinfo, enter->event);
+ ev.x = lrint (enter->event_x);
+ ev.y = lrint (enter->event_y);
+ ev.window = leave->event;
+
+ x_display_set_last_user_time (dpyinfo, xi_event->time);
+ x_detect_focus_change (dpyinfo, any, event, &inev.ie);
+
+ /* One problem behind the design of XInput 2 scrolling is
+ that valuators are not unique to each window, but only
+ the window that has grabbed the valuator's device or
+ the window that the device's pointer is on top of can
+ receive motion events. There is also no way to
+ retrieve the value of a valuator outside of each motion
+ event.
+
+ As such, to prevent wildly inaccurate results when the
+ valuators have changed outside Emacs, we reset our
+ records of each valuator's value whenever the pointer
+ re-enters a frame after its valuators have potentially
+ been changed elsewhere. */
+ if (enter->detail != XINotifyInferior
+ && enter->mode != XINotifyPassiveUngrab
+ && enter->mode != XINotifyUngrab && any)
+ xi_reset_scroll_valuators_for_device_id (dpyinfo, enter->deviceid);
+
+ f = any;
+
+ if (f && x_mouse_click_focus_ignore_position)
+ ignore_next_mouse_click_timeout = xi_event->time + 200;
+
+ /* EnterNotify counts as mouse movement,
+ so update things that depend on mouse position. */
+ if (f && !f->output_data.x->hourglass_p)
+ x_note_mouse_movement (f, &ev);
+#ifdef USE_GTK
+ /* We may get an EnterNotify on the buttons in the toolbar. In that
+ case we moved out of any highlighted area and need to note this. */
+ if (!f && dpyinfo->last_mouse_glyph_frame)
+ x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev);
+#endif
+ goto XI_OTHER;
+ case XI_Leave:
+ ev.x = lrint (leave->event_x);
+ ev.y = lrint (leave->event_y);
+ ev.window = leave->event;
+ any = x_any_window_to_frame (dpyinfo, leave->event);
+
+ x_display_set_last_user_time (dpyinfo, xi_event->time);
+ x_detect_focus_change (dpyinfo, any, event, &inev.ie);
+
+ f = x_top_window_to_frame (dpyinfo, leave->event);
+ if (f)
+ {
+ 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;
+ }
+
+ /* 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)
+ do_help = -1;
+ }
+#ifdef USE_GTK
+ /* See comment in EnterNotify above */
+ else if (dpyinfo->last_mouse_glyph_frame)
+ x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev);
+#endif
+ goto XI_OTHER;
+ case XI_Motion:
+ {
+ struct xi_device_t *device;
+
+ states = &xev->valuators;
+ values = states->values;
+ device = xi_device_from_id (dpyinfo, xev->deviceid);
+
+ if (!device || !device->master_p)
+ goto XI_OTHER;
+
+#ifdef XI_TouchBegin
+ if (xev->flags & XIPointerEmulated
+ && dpyinfo->xi2_version >= 2)
+ goto XI_OTHER;
+#endif
+
+ x_display_set_last_user_time (dpyinfo, xi_event->time);
+
+#ifdef HAVE_XWIDGETS
+ struct xwidget_view *xv = xwidget_view_from_window (xev->event);
+ double xv_total_x = 0.0;
+ double xv_total_y = 0.0;
+#endif
+
+ for (int i = 0; i < states->mask_len * 8; i++)
+ {
+ if (XIMaskIsSet (states->mask, i))
+ {
+ struct xi_scroll_valuator_t *val;
+ double delta, scroll_unit;
+ int scroll_height;
+ Lisp_Object window;
+
+
+ /* See the comment on top of
+ x_init_master_valuators for more details on how
+ scroll wheel movement is reported on XInput 2. */
+ delta = x_get_scroll_valuator_delta (dpyinfo, xev->deviceid,
+ i, *values, &val);
+
+ if (delta != DBL_MAX)
+ {
+#ifdef HAVE_XWIDGETS
+ if (xv)
+ {
+ if (val->horizontal)
+ xv_total_x += delta;
+ else
+ xv_total_y += delta;
+
+ found_valuator = true;
+
+ if (delta == 0.0)
+ any_stop_p = true;
+
+ continue;
+ }
+#endif
+ if (!f)
+ {
+ f = x_any_window_to_frame (dpyinfo, xev->event);
+
+ if (!f)
+ goto XI_OTHER;
+ }
+
+ found_valuator = true;
+
+ if (signbit (delta) != signbit (val->emacs_value))
+ val->emacs_value = 0;
+
+ val->emacs_value += delta;
+
+ if (mwheel_coalesce_scroll_events
+ && (fabs (val->emacs_value) < 1)
+ && (fabs (delta) > 0))
+ continue;
+
+ bool s = signbit (val->emacs_value);
+ inev.ie.kind = (fabs (delta) > 0
+ ? (val->horizontal
+ ? HORIZ_WHEEL_EVENT
+ : WHEEL_EVENT)
+ : TOUCH_END_EVENT);
+ inev.ie.timestamp = xev->time;
+
+ XSETINT (inev.ie.x, lrint (xev->event_x));
+ XSETINT (inev.ie.y, lrint (xev->event_y));
+ XSETFRAME (inev.ie.frame_or_window, f);
+
+ if (fabs (delta) > 0)
+ {
+ inev.ie.modifiers = !s ? up_modifier : down_modifier;
+ inev.ie.modifiers
+ |= x_x_to_emacs_modifiers (dpyinfo,
+ xev->mods.effective);
+ }
+
+ window = window_from_coordinates (f, xev->event_x,
+ xev->event_y, NULL,
+ 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 (f);
+
+ scroll_unit = pow (scroll_height, 2.0 / 3.0);
+
+ if (NUMBERP (Vx_scroll_event_delta_factor))
+ scroll_unit *= XFLOATINT (Vx_scroll_event_delta_factor);
+
+ if (fabs (delta) > 0)
+ {
+ if (val->horizontal)
+ {
+ inev.ie.arg
+ = list3 (Qnil,
+ make_float (val->emacs_value
+ * scroll_unit),
+ make_float (0));
+ }
+ else
+ {
+ inev.ie.arg = list3 (Qnil, make_float (0),
+ make_float (val->emacs_value
+ * scroll_unit));
+ }
+ }
+ else
+ {
+ inev.ie.arg = Qnil;
+ }
+
+ kbd_buffer_store_event_hold (&inev.ie, hold_quit);
+
+ val->emacs_value = 0;
+ }
+ values++;
+ }
+
+ inev.ie.kind = NO_EVENT;
+ }
+
+#ifdef HAVE_XWIDGETS
+ if (xv)
+ {
+ if (found_valuator)
+ xwidget_scroll (xv, xev->event_x, xev->event_y,
+ xv_total_x, xv_total_y, xev->mods.effective,
+ xev->time, any_stop_p);
+ else
+ xwidget_motion_notify (xv, xev->event_x, xev->event_y,
+ xev->mods.effective, xev->time);
+
+ goto XI_OTHER;
+ }
+#endif
+ if (found_valuator)
+ goto XI_OTHER;
+
+ ev.x = lrint (xev->event_x);
+ ev.y = lrint (xev->event_y);
+ ev.window = xev->event;
+ ev.time = xev->time;
+
+ 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 = mouse_or_wdesc_frame (dpyinfo, xev->event);
+
+#ifdef USE_GTK
+ if (f && xg_event_is_for_scrollbar (f, event))
+ f = 0;
+#endif
+ 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, ev.x, ev.y, 0, 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 (!x_note_mouse_movement (f, &ev))
+ help_echo_string = previous_help_echo_string;
+ }
+ else
+ {
+#ifndef USE_TOOLKIT_SCROLL_BARS
+ struct scroll_bar *bar
+ = x_window_to_scroll_bar (xi_event->display, xev->event, 2);
+
+ if (bar)
+ x_scroll_bar_note_movement (bar, &ev);
+#endif /* USE_TOOLKIT_SCROLL_BARS */
+
+ /* If we move outside the frame, then we're
+ certainly no longer on any text in the frame. */
+ clear_mouse_face (hlinfo);
+ }
+
+ /* If the contents of the global variable help_echo_string
+ has changed, generate a HELP_EVENT. */
+ if (!NILP (help_echo_string)
+ || !NILP (previous_help_echo_string))
+ do_help = 1;
+ goto XI_OTHER;
+ }
+ case XI_ButtonRelease:
+ case XI_ButtonPress:
+ {
+ /* If we decide we want to generate an event to be seen
+ by the rest of Emacs, we put it here. */
+ Lisp_Object tab_bar_arg = Qnil;
+ bool tab_bar_p = false;
+ bool tool_bar_p = false;
+ struct xi_device_t *device;
+
+#ifdef XIPointerEmulated
+ /* Ignore emulated scroll events when XI2 native
+ scroll events are present. */
+ if (dpyinfo->xi2_version >= 1
+ && xev->detail >= 4
+ && xev->detail <= 8
+ && xev->flags & XIPointerEmulated)
+ {
+ *finish = X_EVENT_DROP;
+ goto XI_OTHER;
+ }
+#endif
+
+ device = xi_device_from_id (dpyinfo, xev->deviceid);
+
+ if (!device || !device->master_p)
+ goto XI_OTHER;
+
+ bv.button = xev->detail;
+ bv.type = xev->evtype == XI_ButtonPress ? ButtonPress : ButtonRelease;
+ bv.x = lrint (xev->event_x);
+ bv.y = lrint (xev->event_y);
+ bv.window = xev->event;
+ bv.state = xev->mods.effective;
+ bv.time = xev->time;
+
+ memset (&compose_status, 0, sizeof (compose_status));
+ dpyinfo->last_mouse_glyph_frame = NULL;
+ x_display_set_last_user_time (dpyinfo, xev->time);
+
+ f = mouse_or_wdesc_frame (dpyinfo, xev->event);
+
+ if (f && xev->evtype == XI_ButtonPress
+ && !popup_activated ()
+ && !x_window_to_scroll_bar (xev->display, xev->event, 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)))
+ {
+ block_input ();
+ XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
+ RevertToParent, CurrentTime);
+ if (FRAME_PARENT_FRAME (f))
+ XRaiseWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f));
+ unblock_input ();
+ }
+ }
+
+#ifdef USE_GTK
+ if (f && xg_event_is_for_scrollbar (f, event))
+ f = 0;
+#endif
+
+ 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 = bv.x;
+ int y = bv.y;
+
+ window = window_from_coordinates (f, x, y, 0, 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, xev->evtype == XI_ButtonPress,
+ x_x_to_emacs_modifiers (dpyinfo, bv.state));
+ }
+
+#if ! defined (USE_GTK)
+ /* 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 = bv.x;
+ int y = bv.y;
+
+ window = window_from_coordinates (f, x, y, 0, true, true);
+ tool_bar_p = EQ (window, f->tool_bar_window);
+
+ if (tool_bar_p && xev->detail < 4)
+ handle_tool_bar_click
+ (f, x, y, xev->evtype == XI_ButtonPress,
+ x_x_to_emacs_modifiers (dpyinfo, bv.state));
+ }
+#endif /* !USE_GTK */
+
+ if (!(tab_bar_p && NILP (tab_bar_arg)) && !tool_bar_p)
+#if defined (USE_X_TOOLKIT) || defined (USE_GTK)
+ if (! popup_activated ())
+#endif
+ {
+ if (ignore_next_mouse_click_timeout)
+ {
+ if (xev->evtype == XI_ButtonPress
+ && xev->time > ignore_next_mouse_click_timeout)
+ {
+ ignore_next_mouse_click_timeout = 0;
+ x_construct_mouse_click (&inev.ie, &bv, f);
+ }
+ if (xev->evtype == XI_ButtonRelease)
+ ignore_next_mouse_click_timeout = 0;
+ }
+ else
+ x_construct_mouse_click (&inev.ie, &bv, f);
+
+ if (!NILP (tab_bar_arg))
+ inev.ie.arg = tab_bar_arg;
+ }
+ if (FRAME_X_EMBEDDED_P (f))
+ xembed_send_message (f, xev->time,
+ XEMBED_REQUEST_FOCUS, 0, 0, 0);
+ }
+
+ if (xev->evtype == XI_ButtonPress)
+ {
+ dpyinfo->grabbed |= (1 << xev->detail);
+ device->grab |= (1 << xev->detail);
+ dpyinfo->last_mouse_frame = f;
+ if (f && !tab_bar_p)
+ f->last_tab_bar_item = -1;
+#if ! defined (USE_GTK)
+ if (f && !tool_bar_p)
+ f->last_tool_bar_item = -1;
+#endif /* not USE_GTK */
+
+ }
+ else
+ {
+ dpyinfo->grabbed &= ~(1 << xev->detail);
+ device->grab &= ~(1 << xev->detail);
+ }
+
+ xi_grab_or_ungrab_device (device, dpyinfo, xev->event);
+
+ if (f)
+ f->mouse_moved = false;
+
+#if defined (USE_GTK)
+ /* No Xt toolkit currently available has support for XI2.
+ So the code here assumes use of GTK. */
+ f = x_menubar_window_to_frame (dpyinfo, event);
+ if (f /* Gtk+ menus only react to the first three buttons. */
+ && xev->detail < 3)
+ {
+ /* What is done with Core Input ButtonPressed is not
+ possible here, because GenericEvents cannot be saved. */
+ bool was_waiting_for_input = waiting_for_input;
+ /* This hack was adopted from the NS port. Whether
+ or not it is actually safe is a different story
+ altogether. */
+ if (waiting_for_input)
+ waiting_for_input = 0;
+ set_frame_menubar (f, true);
+ waiting_for_input = was_waiting_for_input;
+ }
+#endif
+ goto XI_OTHER;
+ }
+ case XI_KeyPress:
+ {
+ int state = xev->mods.effective;
+ Lisp_Object c;
+#ifdef HAVE_XKB
+ unsigned int mods_rtrn;
+#endif
+ int keycode = xev->detail;
+ KeySym keysym;
+ char copy_buffer[81];
+ char *copy_bufptr = copy_buffer;
+ unsigned char *copy_ubufptr;
+ int copy_bufsiz = sizeof (copy_buffer);
+ ptrdiff_t i;
+ int nchars, len;
+ struct xi_device_t *device;
+
+ device = xi_device_from_id (dpyinfo, xev->deviceid);
+
+ if (!device || !device->master_p)
+ goto XI_OTHER;
+
+#if defined (USE_X_TOOLKIT) || defined (USE_GTK)
+ /* Dispatch XI_KeyPress events when in menu. */
+ if (popup_activated ())
+ goto XI_OTHER;
+#endif
+
+#ifdef HAVE_X_I18N
+ XKeyPressedEvent xkey;
+
+ memset (&xkey, 0, sizeof xkey);
+
+ xkey.type = KeyPress;
+ xkey.serial = xev->serial;
+ xkey.send_event = xev->send_event;
+ xkey.display = xev->display;
+ xkey.window = xev->event;
+ xkey.root = xev->root;
+ xkey.subwindow = xev->child;
+ xkey.time = xev->time;
+ xkey.state = xev->mods.effective;
+ xkey.keycode = xev->detail;
+ xkey.same_screen = True;
+
+ if (x_filter_event (dpyinfo, (XEvent *) &xkey))
+ {
+ *finish = X_EVENT_DROP;
+ goto XI_OTHER;
+ }
+#endif
+
+#ifdef HAVE_XKB
+ if (dpyinfo->xkb_desc)
+ {
+ if (!XkbTranslateKeyCode (dpyinfo->xkb_desc, keycode,
+ 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;
+
+ x_display_set_last_user_time (dpyinfo, xev->time);
+ ignore_next_mouse_click_timeout = 0;
+
+ f = x_any_window_to_frame (dpyinfo, xev->event);
+
+ /* 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
+ || !EQ (f->tab_bar_window, hlinfo->mouse_face_window))
+ )
+ {
+ clear_mouse_face (hlinfo);
+ hlinfo->mouse_face_hidden = true;
+ }
+
+ if (f != 0)
+ {
+#ifdef USE_GTK
+ /* Don't pass keys to GTK. A Tab will shift focus to the
+ tool bar in GTK 2.4. Keys will still go to menus and
+ dialogs because in that case popup_activated is nonzero
+ (see above). */
+ *finish = X_EVENT_DROP;
+#endif
+ /* If not using XIM/XIC, and a compose sequence is in progress,
+ we break here. Otherwise, chars_matched is always 0. */
+ if (compose_status.chars_matched > 0 && nbytes == 0)
+ goto XI_OTHER;
+
+ memset (&compose_status, 0, sizeof (compose_status));
+
+ XSETFRAME (inev.ie.frame_or_window, f);
+ inev.ie.modifiers
+ = x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), state);
+ inev.ie.timestamp = xev->time;
+
+#ifdef HAVE_X_I18N
+ if (FRAME_XIC (f))
+ {
+ Status status_return;
+ nbytes = XmbLookupString (FRAME_XIC (f),
+ &xkey, (char *) copy_bufptr,
+ copy_bufsiz, &keysym,
+ &status_return);
+
+ if (status_return == XBufferOverflow)
+ {
+ copy_bufsiz = nbytes + 1;
+ copy_bufptr = alloca (copy_bufsiz);
+ nbytes = XmbLookupString (FRAME_XIC (f),
+ &xkey, (char *) copy_bufptr,
+ copy_bufsiz, &keysym,
+ &status_return);
+ }
+
+ if (status_return == XLookupNone)
+ goto xi_done_keysym;
+ else if (status_return == XLookupChars)
+ {
+ keysym = NoSymbol;
+ state = 0;
+ }
+ else if (status_return != XLookupKeySym
+ && status_return != XLookupBoth)
+ emacs_abort ();
+ }
+ else
+#endif
+ {
+#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);
+ if (overflow)
+ {
+ copy_bufptr = alloca ((copy_bufsiz += overflow)
+ * sizeof *copy_bufptr);
+ overflow = 0;
+ nbytes = XkbTranslateKeySym (dpyinfo->display, &sym,
+ state & ~mods_rtrn, copy_bufptr,
+ copy_bufsiz, &overflow);
+
+ if (overflow)
+ nbytes = 0;
+ }
+ }
+ else
+#endif
+ {
+ nbytes = XLookupString (&xkey, copy_bufptr,
+ copy_bufsiz, &keysym,
+ &compose_status);
+ }
+ }
+
+ /* First deal with keysyms which have defined
+ translations to characters. */
+ if (keysym >= 32 && keysym < 128)
+ /* Avoid explicitly decoding each ASCII character. */
+ {
+ inev.ie.kind = ASCII_KEYSTROKE_EVENT;
+ inev.ie.code = keysym;
+
+ goto xi_done_keysym;
+ }
+
+ /* Keysyms directly mapped to Unicode characters. */
+ if (keysym >= 0x01000000 && keysym <= 0x0110FFFF)
+ {
+ if (keysym < 0x01000080)
+ inev.ie.kind = ASCII_KEYSTROKE_EVENT;
+ else
+ inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT;
+ inev.ie.code = keysym & 0xFFFFFF;
+ goto xi_done_keysym;
+ }
+
+ /* Now non-ASCII. */
+ if (HASH_TABLE_P (Vx_keysym_table)
+ && (c = Fgethash (make_fixnum (keysym),
+ Vx_keysym_table,
+ Qnil),
+ FIXNATP (c)))
+ {
+ inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFIXNAT (c))
+ ? ASCII_KEYSTROKE_EVENT
+ : MULTIBYTE_CHAR_KEYSTROKE_EVENT);
+ inev.ie.code = XFIXNAT (c);
+ goto xi_done_keysym;
+ }
+
+ /* Random non-modifier sorts of keysyms. */
+ if (((keysym >= XK_BackSpace && keysym <= XK_Escape)
+ || keysym == XK_Delete
+#ifdef XK_ISO_Left_Tab
+ || (keysym >= XK_ISO_Left_Tab
+ && keysym <= XK_ISO_Enter)
+#endif
+ || IsCursorKey (keysym) /* 0xff50 <= x < 0xff60 */
+ || IsMiscFunctionKey (keysym) /* 0xff60 <= x < VARIES */
+#ifdef HPUX
+ /* This recognizes the "extended function
+ keys". It seems there's no cleaner way.
+ Test IsModifierKey to avoid handling
+ mode_switch incorrectly. */
+ || (XK_Select <= keysym && keysym < XK_KP_Space)
+#endif
+#ifdef XK_dead_circumflex
+ || keysym == XK_dead_circumflex
+#endif
+#ifdef XK_dead_grave
+ || keysym == XK_dead_grave
+#endif
+#ifdef XK_dead_tilde
+ || keysym == XK_dead_tilde
+#endif
+#ifdef XK_dead_diaeresis
+ || keysym == XK_dead_diaeresis
+#endif
+#ifdef XK_dead_macron
+ || keysym == XK_dead_macron
+#endif
+#ifdef XK_dead_degree
+ || keysym == XK_dead_degree
+#endif
+#ifdef XK_dead_acute
+ || keysym == XK_dead_acute
+#endif
+#ifdef XK_dead_cedilla
+ || keysym == XK_dead_cedilla
+#endif
+#ifdef XK_dead_breve
+ || keysym == XK_dead_breve
+#endif
+#ifdef XK_dead_ogonek
+ || keysym == XK_dead_ogonek
+#endif
+#ifdef XK_dead_caron
+ || keysym == XK_dead_caron
+#endif
+#ifdef XK_dead_doubleacute
+ || keysym == XK_dead_doubleacute
+#endif
+#ifdef XK_dead_abovedot
+ || keysym == XK_dead_abovedot
+#endif
+ || IsKeypadKey (keysym) /* 0xff80 <= x < 0xffbe */
+ || IsFunctionKey (keysym) /* 0xffbe <= x < 0xffe1 */
+ /* Any "vendor-specific" key is ok. */
+ || (keysym & (1 << 28))
+ || (keysym != NoSymbol && nbytes == 0))
+ && ! (IsModifierKey (keysym)
+ /* The symbols from XK_ISO_Lock
+ to XK_ISO_Last_Group_Lock
+ don't have real modifiers but
+ should be treated similarly to
+ Mode_switch by Emacs. */
+#if defined XK_ISO_Lock && defined XK_ISO_Last_Group_Lock
+ || (XK_ISO_Lock <= keysym
+ && keysym <= XK_ISO_Last_Group_Lock)
+#endif
+ ))
+ {
+ STORE_KEYSYM_FOR_DEBUG (keysym);
+ /* make_lispy_event will convert this to a symbolic
+ key. */
+ inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT;
+ inev.ie.code = keysym;
+ goto xi_done_keysym;
+ }
+
+ for (i = 0, nchars = 0; i < nbytes; i++)
+ {
+ if (ASCII_CHAR_P (copy_bufptr[i]))
+ nchars++;
+ STORE_KEYSYM_FOR_DEBUG (copy_bufptr[i]);
+ }
+
+ if (nchars < nbytes)
+ {
+ /* Decode the input data. */
+
+ setup_coding_system (Vlocale_coding_system, &coding);
+ coding.src_multibyte = false;
+ coding.dst_multibyte = true;
+ /* The input is converted to events, thus we can't
+ handle composition. Anyway, there's no XIM that
+ gives us composition information. */
+ coding.common_flags &= ~CODING_ANNOTATION_MASK;
+
+ SAFE_NALLOCA (coding.destination, MAX_MULTIBYTE_LENGTH,
+ nbytes);
+ coding.dst_bytes = MAX_MULTIBYTE_LENGTH * nbytes;
+ coding.mode |= CODING_MODE_LAST_BLOCK;
+ decode_coding_c_string (&coding, (unsigned char *) copy_bufptr,
+ nbytes, Qnil);
+ nbytes = coding.produced;
+ nchars = coding.produced_char;
+ copy_bufptr = (char *) coding.destination;
+ }
+
+ copy_ubufptr = (unsigned char *) copy_bufptr;
+
+ /* Convert the input data to a sequence of
+ character events. */
+ for (i = 0; i < nbytes; i += len)
+ {
+ int ch;
+ if (nchars == nbytes)
+ ch = copy_ubufptr[i], len = 1;
+ else
+ ch = string_char_and_length (copy_ubufptr + i, &len);
+ inev.ie.kind = (SINGLE_BYTE_CHAR_P (ch)
+ ? ASCII_KEYSTROKE_EVENT
+ : MULTIBYTE_CHAR_KEYSTROKE_EVENT);
+ inev.ie.code = ch;
+ kbd_buffer_store_buffered_event (&inev, hold_quit);
+ }
+
+ inev.ie.kind = NO_EVENT;
+ goto xi_done_keysym;
+ }
+ goto XI_OTHER;
+ }
+ case XI_KeyRelease:
+ x_display_set_last_user_time (dpyinfo, xev->time);
+#ifdef HAVE_X_I18N
+ XKeyPressedEvent xkey;
+
+ memset (&xkey, 0, sizeof xkey);
+
+ xkey.type = KeyRelease;
+ xkey.serial = xev->serial;
+ xkey.send_event = xev->send_event;
+ xkey.display = xev->display;
+ xkey.window = xev->event;
+ xkey.root = xev->root;
+ xkey.subwindow = xev->child;
+ xkey.time = xev->time;
+ xkey.state = xev->mods.effective;
+ xkey.keycode = xev->detail;
+ xkey.same_screen = True;
+
+ x_filter_event (dpyinfo, (XEvent *) &xkey);
+#endif
+ goto XI_OTHER;
+ case XI_PropertyEvent:
+ case XI_HierarchyChanged:
+ case XI_DeviceChanged:
+ x_init_master_valuators (dpyinfo);
+ goto XI_OTHER;
+#ifdef XI_TouchBegin
+ case XI_TouchBegin:
+ {
+ struct xi_device_t *device;
+ device = xi_device_from_id (dpyinfo, xev->deviceid);
+
+ if (!device)
+ goto XI_OTHER;
+
+ if (xi_find_touch_point (device, xev->detail))
+ emacs_abort ();
+
+ f = x_any_window_to_frame (dpyinfo, xev->event);
+
+ if (f && device->direct_p)
+ {
+ x_catch_errors (dpyinfo->display);
+ 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);
+
+#ifdef HAVE_GTK3
+ if (FRAME_X_OUTPUT (f)->menubar_widget
+ && xg_event_is_for_menubar (f, event))
+ {
+ bool was_waiting_for_input = waiting_for_input;
+ /* This hack was adopted from the NS port. Whether
+ or not it is actually safe is a different story
+ altogether. */
+ if (waiting_for_input)
+ waiting_for_input = 0;
+ set_frame_menubar (f, true);
+ waiting_for_input = was_waiting_for_input;
+ }
+#endif
+
+ inev.ie.kind = TOUCHSCREEN_BEGIN_EVENT;
+ inev.ie.timestamp = xev->time;
+ XSETFRAME (inev.ie.frame_or_window, f);
+ XSETINT (inev.ie.x, lrint (xev->event_x));
+ XSETINT (inev.ie.y, lrint (xev->event_y));
+ XSETINT (inev.ie.arg, xev->detail);
+ }
+ x_uncatch_errors_after_check ();
+ }
+ else
+ {
+ x_catch_errors (dpyinfo->display);
+ XIAllowTouchEvents (dpyinfo->display, xev->deviceid,
+ xev->detail, xev->event, XIRejectTouch);
+ x_uncatch_errors ();
+ }
+
+ goto XI_OTHER;
+ }
+ case XI_TouchUpdate:
+ {
+ struct xi_device_t *device;
+ struct xi_touch_point_t *touchpoint;
+ Lisp_Object arg = Qnil;
+
+ device = xi_device_from_id (dpyinfo, xev->deviceid);
+
+ if (!device)
+ goto XI_OTHER;
+
+ touchpoint = xi_find_touch_point (device, xev->detail);
+
+ if (!touchpoint)
+ goto XI_OTHER;
+
+ touchpoint->x = xev->event_x;
+ touchpoint->y = xev->event_y;
+
+ f = x_any_window_to_frame (dpyinfo, xev->event);
+
+ if (f && device->direct_p)
+ {
+ inev.ie.kind = TOUCHSCREEN_UPDATE_EVENT;
+ inev.ie.timestamp = xev->time;
+ XSETFRAME (inev.ie.frame_or_window, f);
+
+ for (touchpoint = device->touchpoints;
+ touchpoint; touchpoint = touchpoint->next)
+ {
+ arg = Fcons (list3i (lrint (touchpoint->x),
+ lrint (touchpoint->y),
+ lrint (touchpoint->number)),
+ arg);
+ }
+
+ inev.ie.arg = arg;
+ }
+
+ goto XI_OTHER;
+ }
+ case XI_TouchEnd:
+ {
+ struct xi_device_t *device;
+ bool unlinked_p;
+
+ device = xi_device_from_id (dpyinfo, xev->deviceid);
+
+ if (!device)
+ goto XI_OTHER;
+
+ unlinked_p = xi_unlink_touch_point (xev->detail, device);
+
+ if (unlinked_p)
+ {
+ f = x_any_window_to_frame (dpyinfo, xev->event);
+
+ if (f && device->direct_p)
+ {
+ inev.ie.kind = TOUCHSCREEN_END_EVENT;
+ inev.ie.timestamp = xev->time;
+ XSETFRAME (inev.ie.frame_or_window, f);
+ XSETINT (inev.ie.x, lrint (xev->event_x));
+ XSETINT (inev.ie.y, lrint (xev->event_y));
+ XSETINT (inev.ie.arg, xev->detail);
+ }
+ }
+
+ goto XI_OTHER;
+ }
+#endif
+ default:
+ goto XI_OTHER;
+ }
+ xi_done_keysym:
+#ifdef HAVE_X_I18N
+ if (FRAME_XIC (f) && (FRAME_XIC_STYLE (f) & XIMStatusArea))
+ xic_set_statusarea (f);
+#endif
+ if (must_free_data)
+ XFreeEventData (dpyinfo->display, &event->xcookie);
+ goto done_keysym;
+ XI_OTHER:
+ if (must_free_data)
+ XFreeEventData (dpyinfo->display, &event->xcookie);
+ goto OTHER;
+ }
+#endif
default:
OTHER:
@@ -11564,6 +13224,13 @@ x_lower_frame (struct frame *f)
XFlush (FRAME_X_DISPLAY (f));
unblock_input ();
}
+#ifdef HAVE_XWIDGETS
+ /* Make sure any X windows owned by xwidget views of the parent
+ still display below the lowered frame. */
+
+ if (FRAME_PARENT_FRAME (f))
+ lower_frame_xwidget_views (FRAME_PARENT_FRAME (f));
+#endif
}
static void
@@ -12123,6 +13790,10 @@ x_free_frame_resources (struct frame *f)
xfree (f->shell_position);
#else /* !USE_X_TOOLKIT */
+#ifdef HAVE_XWIDGETS
+ kill_frame_xwidget_views (f);
+#endif
+
#ifdef USE_GTK
xg_free_frame_widgets (f);
#endif /* USE_GTK */
@@ -13029,6 +14700,40 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
dpyinfo->supports_xdbe = true;
#endif
+#ifdef HAVE_XINPUT2
+ dpyinfo->supports_xi2 = false;
+ int rc;
+ int major = 2;
+#ifdef XI_BarrierHit /* XInput 2.3 */
+ int minor = 3;
+#elif defined XI_TouchBegin /* XInput 2.2 */
+ int minor = 2;
+#elif defined XIScrollClass /* XInput 2.1 */
+ int minor = 1;
+#else /* Some old version of XI2 we're not interested in. */
+ int minor = 0;
+#endif
+ int fer, fee;
+
+ if (XQueryExtension (dpyinfo->display, "XInputExtension",
+ &dpyinfo->xi2_opcode, &fer, &fee))
+ {
+ rc = XIQueryVersion (dpyinfo->display, &major, &minor);
+ if (rc == Success)
+ {
+ dpyinfo->supports_xi2 = true;
+ x_init_master_valuators (dpyinfo);
+ }
+ }
+ dpyinfo->xi2_version = minor;
+#endif
+
+#ifdef HAVE_XKB
+ dpyinfo->xkb_desc = XkbGetMap (dpyinfo->display,
+ XkbAllComponentsMask,
+ XkbUseCoreKbd);
+#endif
+
#if defined USE_CAIRO || defined HAVE_XFT
{
/* If we are using Xft, the following precautions should be made:
@@ -13461,6 +15166,14 @@ x_delete_terminal (struct terminal *terminal)
XrmDestroyDatabase (dpyinfo->rdb);
#endif
+#ifdef HAVE_XKB
+ if (dpyinfo->xkb_desc)
+ XkbFreeKeyboard (dpyinfo->xkb_desc, XkbAllComponentsMask, True);
+#endif
+#ifdef HAVE_XINPUT2
+ if (dpyinfo->supports_xi2)
+ x_free_xi_devices (dpyinfo);
+#endif
#ifdef USE_GTK
xg_display_close (dpyinfo->display);
#else
@@ -13620,9 +15333,12 @@ x_initialize (void)
void
init_xterm (void)
{
- /* Emacs can handle only core input events, so make sure
- Gtk doesn't use Xinput or Xinput2 extensions. */
+#ifndef HAVE_XINPUT2
+ /* Emacs can handle only core input events when built without XI2
+ support, so make sure Gtk doesn't use Xinput or Xinput2
+ extensions. */
xputenv ("GDK_CORE_DEVICE_EVENTS=1");
+#endif
}
#endif
@@ -13679,7 +15395,7 @@ selected window or cursor position is preserved. */);
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 or Nextstep, the value is t. */);
+With MS Windows, Haiku windowing or Nextstep, the value is t. */);
#ifdef USE_TOOLKIT_SCROLL_BARS
#ifdef USE_MOTIF
Vx_toolkit_scroll_bars = intern_c_string ("motif");
@@ -13779,4 +15495,10 @@ gtk_window_move to set or store frame positions and disables some time
consuming frame position adjustments. In newer versions of GTK, Emacs
always uses gtk_window_move and ignores the value of this variable. */);
x_gtk_use_window_move = true;
+
+ DEFVAR_LISP ("x-scroll-event-delta-factor", Vx_scroll_event_delta_factor,
+ doc: /* A scale to apply to pixel deltas reported in scroll events.
+This option is only effective when Emacs is built with XInput 2
+support. */);
+ Vx_scroll_event_delta_factor = make_float (1.0);
}
diff --git a/src/xterm.h b/src/xterm.h
index de6ea50385d..d9ace002d58 100644
--- a/src/xterm.h
+++ b/src/xterm.h
@@ -88,6 +88,10 @@ typedef GtkWidget *xt_or_gtk_widget;
#include <X11/Xlib-xcb.h>
#endif
+#ifdef HAVE_XKB
+#include <X11/XKBlib.h>
+#endif
+
#include "dispextern.h"
#include "termhooks.h"
@@ -163,6 +167,39 @@ struct color_name_cache_entry
char *name;
};
+#ifdef HAVE_XINPUT2
+struct xi_scroll_valuator_t
+{
+ bool invalid_p;
+ double current_value;
+ double emacs_value;
+ double increment;
+
+ int number;
+ int horizontal;
+};
+
+struct xi_touch_point_t
+{
+ struct xi_touch_point_t *next;
+
+ int number;
+ double x, y;
+};
+
+struct xi_device_t
+{
+ int device_id;
+ int scroll_valuator_count;
+ int grab;
+ bool master_p;
+ bool direct_p;
+
+ struct xi_scroll_valuator_t *valuators;
+ struct xi_touch_point_t *touchpoints;
+};
+#endif
+
Status x_parse_color (struct frame *f, const char *color_name,
XColor *color);
@@ -474,6 +511,19 @@ struct x_display_info
#ifdef HAVE_XDBE
bool supports_xdbe;
#endif
+
+#ifdef HAVE_XINPUT2
+ bool supports_xi2;
+ int xi2_version;
+ int xi2_opcode;
+
+ int num_devices;
+ struct xi_device_t *devices;
+#endif
+
+#ifdef HAVE_XKB
+ XkbDescPtr xkb_desc;
+#endif
};
#ifdef HAVE_X_I18N
@@ -481,6 +531,11 @@ struct x_display_info
extern bool use_xim;
#endif
+#ifdef HAVE_XINPUT2
+/* Defined in xmenu.c. */
+extern int popup_activated_flag;
+#endif
+
/* This is a chain of structures for all the X displays currently in use. */
extern struct x_display_info *x_display_list;
@@ -1108,6 +1163,7 @@ extern void x_mouse_leave (struct x_display_info *);
extern int x_dispatch_event (XEvent *, Display *);
#endif
extern int x_x_to_emacs_modifiers (struct x_display_info *, int);
+extern int x_emacs_to_x_modifiers (struct x_display_info *, intmax_t);
#ifdef USE_CAIRO
extern void x_cr_destroy_frame_context (struct frame *);
extern void x_cr_update_surface_desired_size (struct frame *, int, int);
diff --git a/src/xwidget.c b/src/xwidget.c
index e4b42e6e0c6..63ac0555dbb 100644
--- a/src/xwidget.c
+++ b/src/xwidget.c
@@ -19,6 +19,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
+#include "buffer.h"
+#include "coding.h"
#include "xwidget.h"
#include "lisp.h"
@@ -30,15 +32,41 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "sysstdio.h"
#include "termhooks.h"
#include "window.h"
+#include "process.h"
/* Include xwidget bottom end headers. */
#ifdef USE_GTK
#include <webkit2/webkit2.h>
#include <JavaScriptCore/JavaScript.h>
+#include <cairo.h>
+#include <X11/Xlib.h>
+#ifdef HAVE_XINPUT2
+#include <X11/extensions/XInput2.h>
+#endif
#elif defined NS_IMPL_COCOA
#include "nsxwidget.h"
#endif
+#include <math.h>
+
+static Lisp_Object id_to_xwidget_map;
+static Lisp_Object internal_xwidget_view_list;
+static Lisp_Object internal_xwidget_list;
+static uint32_t xwidget_counter = 0;
+
+#ifdef USE_GTK
+static Lisp_Object x_window_to_xwv_map;
+static gboolean offscreen_damage_event (GtkWidget *, GdkEvent *, gpointer);
+static void synthesize_focus_in_event (GtkWidget *);
+static GdkDevice *find_suitable_keyboard (struct frame *);
+static gboolean webkit_script_dialog_cb (WebKitWebView *, WebKitScriptDialog *,
+ gpointer);
+static void record_osr_embedder (struct xwidget_view *);
+static void from_embedder (GdkWindow *, double, double, gpointer, gpointer, gpointer);
+static void to_embedder (GdkWindow *, double, double, gpointer, gpointer, gpointer);
+static GdkWindow *pick_embedded_child (GdkWindow *, double, double, gpointer);
+#endif
+
static struct xwidget *
allocate_xwidget (void)
{
@@ -56,6 +84,8 @@ allocate_xwidget_view (void)
static struct xwidget_view *xwidget_view_lookup (struct xwidget *,
struct window *);
+static void kill_xwidget (struct xwidget *);
+
#ifdef USE_GTK
static void webkit_view_load_changed_cb (WebKitWebView *,
WebKitLoadEvent,
@@ -64,18 +94,35 @@ static void webkit_javascript_finished_cb (GObject *,
GAsyncResult *,
gpointer);
static gboolean webkit_download_cb (WebKitWebContext *, WebKitDownload *, gpointer);
-
+static GtkWidget *webkit_create_cb (WebKitWebView *, WebKitNavigationAction *, gpointer);
static gboolean
webkit_decide_policy_cb (WebKitWebView *,
WebKitPolicyDecision *,
WebKitPolicyDecisionType,
gpointer);
+static GtkWidget *find_widget_at_pos (GtkWidget *, int, int, int *, int *);
+static gboolean run_file_chooser_cb (WebKitWebView *,
+ WebKitFileChooserRequest *,
+ gpointer);
+
+struct widget_search_data
+{
+ int x;
+ int y;
+ bool foundp;
+ bool first;
+ GtkWidget *data;
+};
+
+static void find_widget (GtkWidget *t, struct widget_search_data *);
+static void mouse_target_changed (WebKitWebView *, WebKitHitTestResult *, guint,
+ gpointer);
#endif
DEFUN ("make-xwidget",
Fmake_xwidget, Smake_xwidget,
- 5, 6, 0,
+ 4, 7, 0,
doc: /* Make an xwidget of TYPE.
If BUFFER is nil, use the current buffer.
If BUFFER is a string and no such buffer exists, create it.
@@ -83,10 +130,13 @@ TYPE is a symbol which can take one of the following values:
- webkit
-Returns the newly constructed xwidget, or nil if construction fails. */)
+RELATED is nil, or an xwidget. When constructing a WebKit widget, it
+will share the same settings and internal subprocess as RELATED.
+Returns the newly constructed xwidget, or nil if construction
+fails. */)
(Lisp_Object type,
Lisp_Object title, Lisp_Object width, Lisp_Object height,
- Lisp_Object arguments, Lisp_Object buffer)
+ Lisp_Object arguments, Lisp_Object buffer, Lisp_Object related)
{
#ifdef USE_GTK
if (!xg_gtk_initialized)
@@ -96,6 +146,11 @@ Returns the newly constructed xwidget, or nil if construction fails. */)
CHECK_FIXNAT (width);
CHECK_FIXNAT (height);
+ if (!EQ (type, Qwebkit))
+ error ("Bad xwidget type");
+
+ Frequire (Qxwidget, Qnil, Qnil);
+
struct xwidget *xw = allocate_xwidget ();
Lisp_Object val;
xw->type = type;
@@ -106,15 +161,22 @@ Returns the newly constructed xwidget, or nil if construction fails. */)
xw->width = XFIXNAT (width);
xw->kill_without_query = false;
XSETXWIDGET (val, xw);
- Vxwidget_list = Fcons (val, Vxwidget_list);
+ internal_xwidget_list = Fcons (val, internal_xwidget_list);
+ Vxwidget_list = Fcopy_sequence (internal_xwidget_list);
xw->plist = Qnil;
+ xw->xwidget_id = ++xwidget_counter;
+ xw->find_text = NULL;
+
+ Fputhash (make_fixnum (xw->xwidget_id), val, id_to_xwidget_map);
#ifdef USE_GTK
xw->widgetwindow_osr = NULL;
xw->widget_osr = NULL;
+ xw->hit_result = 0;
if (EQ (xw->type, Qwebkit))
{
block_input ();
+ WebKitSettings *settings;
WebKitWebContext *webkit_context = webkit_web_context_get_default ();
# if WEBKIT_CHECK_VERSION (2, 26, 0)
@@ -123,23 +185,46 @@ Returns the newly constructed xwidget, or nil if construction fails. */)
# endif
xw->widgetwindow_osr = gtk_offscreen_window_new ();
+#ifndef HAVE_PGTK
gtk_window_resize (GTK_WINDOW (xw->widgetwindow_osr), xw->width,
xw->height);
+#else
+ gtk_container_check_resize (GTK_CONTAINER (xw->widgetwindow_osr));
+#endif
if (EQ (xw->type, Qwebkit))
{
- xw->widget_osr = webkit_web_view_new ();
-
- /* webkitgtk uses GSubprocess which sets sigaction causing
- Emacs to not catch SIGCHLD with its usual handle setup in
- catch_child_signal(). This resets the SIGCHLD
- sigaction. */
- struct sigaction old_action;
- sigaction (SIGCHLD, NULL, &old_action);
- webkit_web_view_load_uri(WEBKIT_WEB_VIEW (xw->widget_osr),
- "about:blank");
- sigaction (SIGCHLD, &old_action, NULL);
- }
+ WebKitWebView *related_view;
+
+ if (NILP (related)
+ || !XWIDGETP (related)
+ || !EQ (XXWIDGET (related)->type, Qwebkit))
+ {
+ WebKitWebContext *ctx = webkit_web_context_new ();
+ xw->widget_osr = webkit_web_view_new_with_context (ctx);
+ g_object_unref (ctx);
+
+ g_signal_connect (G_OBJECT (ctx),
+ "download-started",
+ G_CALLBACK (webkit_download_cb), xw);
+
+ webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr),
+ "about:blank");
+ /* webkitgtk uses GSubprocess which sets sigaction causing
+ Emacs to not catch SIGCHLD with its usual handle setup in
+ 'catch_child_signal'. This resets the SIGCHLD sigaction. */
+ catch_child_signal ();
+ }
+ else
+ {
+ related_view = WEBKIT_WEB_VIEW (XXWIDGET (related)->widget_osr);
+ xw->widget_osr = webkit_web_view_new_with_related_view (related_view);
+ }
+
+ /* 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);
+ }
gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width,
xw->height);
@@ -157,6 +242,16 @@ Returns the newly constructed xwidget, or nil if construction fails. */)
gtk_widget_show (xw->widget_osr);
gtk_widget_show (xw->widgetwindow_osr);
+#ifndef HAVE_XINPUT2
+ synthesize_focus_in_event (xw->widgetwindow_osr);
+#endif
+
+ g_signal_connect (G_OBJECT (gtk_widget_get_window (xw->widgetwindow_osr)),
+ "from-embedder", G_CALLBACK (from_embedder), NULL);
+ g_signal_connect (G_OBJECT (gtk_widget_get_window (xw->widgetwindow_osr)),
+ "to-embedder", G_CALLBACK (to_embedder), NULL);
+ g_signal_connect (G_OBJECT (gtk_widget_get_window (xw->widgetwindow_osr)),
+ "pick-embedded-child", G_CALLBACK (pick_embedded_child), NULL);
/* Store some xwidget data in the gtk widgets for convenient
retrieval in the event handlers. */
@@ -170,17 +265,33 @@ Returns the newly constructed xwidget, or nil if construction fails. */)
"load-changed",
G_CALLBACK (webkit_view_load_changed_cb), xw);
- g_signal_connect (G_OBJECT (webkit_context),
- "download-started",
- G_CALLBACK (webkit_download_cb), xw);
-
g_signal_connect (G_OBJECT (xw->widget_osr),
"decide-policy",
G_CALLBACK
(webkit_decide_policy_cb),
xw);
+
+ g_signal_connect (G_OBJECT (xw->widget_osr),
+ "mouse-target-changed",
+ G_CALLBACK (mouse_target_changed),
+ xw);
+ g_signal_connect (G_OBJECT (xw->widget_osr),
+ "create",
+ G_CALLBACK (webkit_create_cb),
+ xw);
+ g_signal_connect (G_OBJECT (xw->widget_osr),
+ "script-dialog",
+ G_CALLBACK (webkit_script_dialog_cb),
+ NULL);
+ g_signal_connect (G_OBJECT (xw->widget_osr),
+ "run-file-chooser",
+ G_CALLBACK (run_file_chooser_cb),
+ NULL);
}
+ g_signal_connect (G_OBJECT (xw->widgetwindow_osr), "damage-event",
+ G_CALLBACK (offscreen_damage_event), xw);
+
unblock_input ();
}
#elif defined NS_IMPL_COCOA
@@ -190,6 +301,180 @@ Returns the newly constructed xwidget, or nil if construction fails. */)
return val;
}
+DEFUN ("xwidget-live-p", Fxwidget_live_p, Sxwidget_live_p,
+ 1, 1, 0, doc: /* Return t if OBJECT is an xwidget that has not been killed.
+Value is nil if OBJECT is not an xwidget or if it has been killed. */)
+ (Lisp_Object object)
+{
+ return ((XWIDGETP (object)
+ && !NILP (XXWIDGET (object)->buffer))
+ ? Qt : Qnil);
+}
+
+#ifdef USE_GTK
+static void
+set_widget_if_text_view (GtkWidget *widget, void *data)
+{
+ GtkWidget **pointer = data;
+
+ if (GTK_IS_TEXT_VIEW (widget))
+ *pointer = widget;
+}
+#endif
+
+DEFUN ("xwidget-perform-lispy-event",
+ Fxwidget_perform_lispy_event, Sxwidget_perform_lispy_event,
+ 2, 3, 0, doc: /* Send a lispy event to XWIDGET.
+EVENT should be the event that will be sent. FRAME should be the
+frame which generated the event, and defaults to the selected frame.
+On X11, modifier keys will not be processed if FRAME is nil and the
+selected frame is not an X-Windows frame. */)
+ (Lisp_Object xwidget, Lisp_Object event, Lisp_Object frame)
+{
+ struct xwidget *xw;
+ struct frame *f = NULL;
+ int character = -1, keycode = -1;
+ int modifiers = 0;
+
+#ifdef USE_GTK
+ GdkEvent *xg_event;
+ GtkContainerClass *klass;
+ GtkWidget *widget;
+ GtkWidget *temp = NULL;
+#ifdef HAVE_XINPUT2
+ GdkWindow *embedder;
+ GdkWindow *osw;
+#endif
+#endif
+
+ CHECK_LIVE_XWIDGET (xwidget);
+ xw = XXWIDGET (xwidget);
+
+ if (!NILP (frame))
+ f = decode_window_system_frame (frame);
+ else if (FRAME_X_P (SELECTED_FRAME ()))
+ f = SELECTED_FRAME ();
+
+#ifdef USE_GTK
+#ifdef HAVE_XINPUT2
+ /* XI2 GDK devices crash if we try this without an embedder set. */
+ if (!f)
+ return Qnil;
+
+ osw = gtk_widget_get_window (xw->widgetwindow_osr);
+ embedder = gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (f));
+
+ gdk_offscreen_window_set_embedder (osw, embedder);
+#endif
+ widget = gtk_window_get_focus (GTK_WINDOW (xw->widgetwindow_osr));
+
+ if (!widget)
+ widget = xw->widget_osr;
+
+ if (RANGED_FIXNUMP (0, event, INT_MAX))
+ {
+ character = XFIXNUM (event);
+
+ if (character < 32)
+ modifiers |= ctrl_modifier;
+
+ modifiers |= character & meta_modifier;
+ modifiers |= character & hyper_modifier;
+ modifiers |= character & super_modifier;
+ modifiers |= character & shift_modifier;
+ modifiers |= character & ctrl_modifier;
+
+ character = character & ~(1 << 21);
+
+ if (character < 32)
+ character += '_';
+
+ if (f)
+ modifiers = x_emacs_to_x_modifiers (FRAME_DISPLAY_INFO (f), modifiers);
+ else
+ modifiers = 0;
+ }
+ else if (SYMBOLP (event))
+ {
+ Lisp_Object decoded = parse_modifiers (event);
+ Lisp_Object decoded_name = SYMBOL_NAME (XCAR (decoded));
+
+ int off = 0;
+ bool found = false;
+
+ while (off < 256)
+ {
+ if (lispy_function_keys[off]
+ && !strcmp (lispy_function_keys[off],
+ SSDATA (decoded_name)))
+ {
+ found = true;
+ break;
+ }
+ ++off;
+ }
+
+ if (f)
+ modifiers = x_emacs_to_x_modifiers (FRAME_DISPLAY_INFO (f),
+ XFIXNUM (XCAR (XCDR (decoded))));
+ else
+ modifiers = 0;
+
+ if (found)
+ keycode = off + 0xff00;
+ }
+
+ if (character == -1 && keycode == -1)
+ return Qnil;
+
+ block_input ();
+ xg_event = gdk_event_new (GDK_KEY_PRESS);
+ xg_event->any.window = gtk_widget_get_window (xw->widget_osr);
+ g_object_ref (xg_event->any.window);
+
+ if (character > -1)
+ keycode = gdk_unicode_to_keyval (character);
+
+ xg_event->key.keyval = keycode;
+ xg_event->key.state = modifiers;
+
+ if (keycode > -1)
+ {
+ /* WebKitGTK internals abuse follows. */
+ if (WEBKIT_IS_WEB_VIEW (widget))
+ {
+ /* WebKitGTK relies on an internal GtkTextView object to
+ "translate" keys such as backspace. We must find that
+ widget and activate its binding to this key if any. */
+ klass = GTK_CONTAINER_CLASS (G_OBJECT_GET_CLASS (widget));
+
+ klass->forall (GTK_CONTAINER (xw->widget_osr), TRUE,
+ set_widget_if_text_view, &temp);
+
+ if (GTK_IS_WIDGET (temp))
+ {
+ if (!gtk_widget_get_realized (temp))
+ gtk_widget_realize (temp);
+
+ gtk_bindings_activate (G_OBJECT (temp), keycode, modifiers);
+ }
+ }
+ }
+
+ if (f)
+ gdk_event_set_device (xg_event,
+ find_suitable_keyboard (SELECTED_FRAME ()));
+
+ gtk_main_do_event (xg_event);
+ xg_event->type = GDK_KEY_RELEASE;
+ gtk_main_do_event (xg_event);
+ gdk_event_free (xg_event);
+ unblock_input ();
+#endif
+
+ return Qnil;
+}
+
DEFUN ("get-buffer-xwidgets", Fget_buffer_xwidgets, Sget_buffer_xwidgets,
1, 1, 0,
doc: /* Return a list of xwidgets associated with BUFFER.
@@ -206,7 +491,7 @@ BUFFER may be a buffer or the name of one. */)
xw_list = Qnil;
- for (tail = Vxwidget_list; CONSP (tail); tail = XCDR (tail))
+ for (tail = internal_xwidget_list; CONSP (tail); tail = XCDR (tail))
{
xw = XCAR (tail);
if (XWIDGETP (xw) && EQ (Fxwidget_buffer (xw), buffer))
@@ -221,16 +506,719 @@ xwidget_hidden (struct xwidget_view *xv)
return xv->hidden;
}
+struct xwidget *
+xwidget_from_id (uint32_t id)
+{
+ Lisp_Object key = make_fixnum (id);
+ Lisp_Object xwidget = Fgethash (key, id_to_xwidget_map, Qnil);
+
+ if (NILP (xwidget))
+ emacs_abort ();
+
+ return XXWIDGET (xwidget);
+}
+
#ifdef USE_GTK
+static GdkWindow *
+pick_embedded_child (GdkWindow *window, double x, double y,
+ gpointer user_data)
+{
+ GtkWidget *widget;
+ GtkWidget *child;
+ GdkEvent event;
+ int xout, yout;
+
+ event.any.window = window;
+ event.any.type = GDK_NOTHING;
+
+ widget = gtk_get_event_widget (&event);
+
+ if (!widget)
+ return NULL;
+
+ child = find_widget_at_pos (widget, lrint (x), lrint (y),
+ &xout, &yout);
+
+ if (!child)
+ return NULL;
+
+ return gtk_widget_get_window (child);
+}
+
+static void
+record_osr_embedder (struct xwidget_view *view)
+{
+ struct xwidget *xw;
+ GdkWindow *window, *embedder;
+
+ xw = XXWIDGET (view->model);
+ window = gtk_widget_get_window (xw->widgetwindow_osr);
+ embedder = gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (view->frame));
+
+ gdk_offscreen_window_set_embedder (window, embedder);
+ xw->embedder = view->frame;
+ xw->embedder_view = view;
+}
+
+static struct xwidget *
+find_xwidget_for_offscreen_window (GdkWindow *window)
+{
+ Lisp_Object tem;
+ struct xwidget *xw;
+ GdkWindow *w;
+
+ for (tem = internal_xwidget_list; CONSP (tem); tem = XCDR (tem))
+ {
+ if (XWIDGETP (XCAR (tem)))
+ {
+ xw = XXWIDGET (XCAR (tem));
+ w = gtk_widget_get_window (xw->widgetwindow_osr);
+
+ if (w == window)
+ return xw;
+ }
+ }
+
+ return NULL;
+}
+
+static void
+from_embedder (GdkWindow *window, double x, double y,
+ gpointer x_out_ptr, gpointer y_out_ptr,
+ gpointer user_data)
+{
+ double *xout = x_out_ptr;
+ double *yout = y_out_ptr;
+ struct xwidget *xw = find_xwidget_for_offscreen_window (window);
+ struct xwidget_view *xvw;
+ gint xoff, yoff;
+
+ if (!xw)
+ emacs_abort ();
+
+ xvw = xw->embedder_view;
+
+ if (!xvw)
+ {
+ *xout = x;
+ *yout = y;
+ }
+ else
+ {
+ gtk_widget_translate_coordinates (FRAME_GTK_WIDGET (xvw->frame),
+ FRAME_GTK_OUTER_WIDGET (xvw->frame),
+ 0, 0, &xoff, &yoff);
+
+ *xout = x - xvw->x - xoff;
+ *yout = y - xvw->y - yoff;
+ }
+}
+
+static void
+to_embedder (GdkWindow *window, double x, double y,
+ gpointer x_out_ptr, gpointer y_out_ptr,
+ gpointer user_data)
+{
+ double *xout = x_out_ptr;
+ double *yout = y_out_ptr;
+ struct xwidget *xw = find_xwidget_for_offscreen_window (window);
+ struct xwidget_view *xvw;
+ gint xoff, yoff;
+
+ if (!xw)
+ emacs_abort ();
+
+ xvw = xw->embedder_view;
+
+ if (!xvw)
+ {
+ *xout = x;
+ *yout = y;
+ }
+ else
+ {
+ gtk_widget_translate_coordinates (FRAME_GTK_WIDGET (xvw->frame),
+ FRAME_GTK_OUTER_WIDGET (xvw->frame),
+ 0, 0, &xoff, &yoff);
+
+ *xout = x + xvw->x + xoff;
+ *yout = y + xvw->y + yoff;
+ }
+}
+
+static GdkDevice *
+find_suitable_pointer (struct frame *f)
+{
+ GdkSeat *seat = gdk_display_get_default_seat
+ (gtk_widget_get_display (FRAME_GTK_WIDGET (f)));
+
+ if (!seat)
+ return NULL;
+
+ return gdk_seat_get_pointer (seat);
+}
+
+static GdkDevice *
+find_suitable_keyboard (struct frame *f)
+{
+ GdkSeat *seat = gdk_display_get_default_seat
+ (gtk_widget_get_display (FRAME_GTK_WIDGET (f)));
+
+ if (!seat)
+ return NULL;
+
+ return gdk_seat_get_keyboard (seat);
+}
+
+static void
+find_widget_cb (GtkWidget *widget, void *user)
+{
+ find_widget (widget, user);
+}
+
+static void
+find_widget (GtkWidget *widget,
+ struct widget_search_data *data)
+{
+ GtkAllocation new_allocation;
+ GdkWindow *window;
+ int x_offset = 0;
+ int y_offset = 0;
+
+ gtk_widget_get_allocation (widget, &new_allocation);
+
+ if (gtk_widget_get_has_window (widget))
+ {
+ new_allocation.x = 0;
+ new_allocation.y = 0;
+ }
+
+ if (gtk_widget_get_parent (widget) && !data->first)
+ {
+ window = gtk_widget_get_window (widget);
+ while (window != gtk_widget_get_window (gtk_widget_get_parent (widget)))
+ {
+ gint tx, ty, twidth, theight;
+
+ if (!window)
+ return;
+
+ twidth = gdk_window_get_width (window);
+ theight = gdk_window_get_height (window);
+
+ if (new_allocation.x < 0)
+ {
+ new_allocation.width += new_allocation.x;
+ new_allocation.x = 0;
+ }
+
+ if (new_allocation.y < 0)
+ {
+ new_allocation.height += new_allocation.y;
+ new_allocation.y = 0;
+ }
+
+ if (new_allocation.x + new_allocation.width > twidth)
+ new_allocation.width = twidth - new_allocation.x;
+ if (new_allocation.y + new_allocation.height > theight)
+ new_allocation.height = theight - new_allocation.y;
+
+ gdk_window_get_position (window, &tx, &ty);
+ new_allocation.x += tx;
+ x_offset += tx;
+ new_allocation.y += ty;
+ y_offset += ty;
+
+ window = gdk_window_get_parent (window);
+ }
+ }
+
+ if ((data->x >= new_allocation.x) && (data->y >= new_allocation.y) &&
+ (data->x < new_allocation.x + new_allocation.width) &&
+ (data->y < new_allocation.y + new_allocation.height))
+ {
+ /* First, check if the drag is in a valid drop site in one of
+ our children. */
+ if (GTK_IS_CONTAINER (widget))
+ {
+ struct widget_search_data new_data = *data;
+
+ new_data.x -= x_offset;
+ new_data.y -= y_offset;
+ new_data.foundp = false;
+ new_data.first = false;
+
+ gtk_container_forall (GTK_CONTAINER (widget),
+ find_widget_cb, &new_data);
+
+ data->foundp = new_data.foundp;
+ if (data->foundp)
+ data->data = new_data.data;
+ }
+
+ /* If not, and this widget is registered as a drop site, check
+ to emit "drag_motion" to check if we are actually in a drop
+ site. */
+ if (!data->foundp)
+ {
+ data->foundp = true;
+ data->data = widget;
+ }
+ }
+}
+
+static GtkWidget *
+find_widget_at_pos (GtkWidget *w, int x, int y,
+ int *new_x, int *new_y)
+{
+ struct widget_search_data data;
+
+ data.x = x;
+ data.y = y;
+ data.foundp = false;
+ data.first = true;
+
+ find_widget (w, &data);
+
+ if (data.foundp)
+ {
+ gtk_widget_translate_coordinates (w, data.data, x,
+ y, new_x, new_y);
+ return data.data;
+ }
+
+ *new_x = x;
+ *new_y = y;
+
+ return NULL;
+}
+
+static Emacs_Cursor
+cursor_for_hit (guint result, struct frame *frame)
+{
+ Emacs_Cursor cursor = FRAME_OUTPUT_DATA (frame)->nontext_cursor;
+
+ if ((result & WEBKIT_HIT_TEST_RESULT_CONTEXT_EDITABLE)
+ || (result & WEBKIT_HIT_TEST_RESULT_CONTEXT_SELECTION)
+ || (result & WEBKIT_HIT_TEST_RESULT_CONTEXT_DOCUMENT))
+ cursor = FRAME_X_OUTPUT (frame)->text_cursor;
+
+ if (result & WEBKIT_HIT_TEST_RESULT_CONTEXT_SCROLLBAR)
+ cursor = FRAME_X_OUTPUT (frame)->vertical_drag_cursor;
+
+ if (result & WEBKIT_HIT_TEST_RESULT_CONTEXT_LINK)
+ cursor = FRAME_X_OUTPUT (frame)->hand_cursor;
+
+ return cursor;
+}
+
+static void
+define_cursors (struct xwidget *xw, WebKitHitTestResult *res)
+{
+ struct xwidget_view *xvw;
+
+ xw->hit_result = webkit_hit_test_result_get_context (res);
+
+ for (Lisp_Object tem = internal_xwidget_view_list; CONSP (tem);
+ tem = XCDR (tem))
+ {
+ if (XWIDGET_VIEW_P (XCAR (tem)))
+ {
+ xvw = XXWIDGET_VIEW (XCAR (tem));
+
+ if (XXWIDGET (xvw->model) == xw)
+ {
+ xvw->cursor = cursor_for_hit (xw->hit_result, xvw->frame);
+ if (xvw->wdesc != None)
+ XDefineCursor (xvw->dpy, xvw->wdesc, xvw->cursor);
+ }
+ }
+ }
+}
+
+static void
+mouse_target_changed (WebKitWebView *webview,
+ WebKitHitTestResult *hitresult,
+ guint modifiers, gpointer xw)
+{
+ define_cursors (xw, hitresult);
+}
+
+static gboolean
+run_file_chooser_cb (WebKitWebView *webview,
+ WebKitFileChooserRequest *request,
+ gpointer user_data)
+{
+ struct frame *f = SELECTED_FRAME ();
+ GtkFileChooserNative *chooser;
+ GtkFileFilter *filter;
+ bool select_multiple_p;
+ guint response;
+ GSList *filenames;
+ GSList *tem;
+ int i, len;
+ gchar **files;
+
+ /* Return TRUE to prevent WebKit from showing the default script
+ dialog in the offscreen window, which runs a nested main loop
+ Emacs can't respond to, and as such can't pass X events to. */
+ if (!FRAME_WINDOW_P (f))
+ return TRUE;
+
+ chooser = gtk_file_chooser_native_new ("Select file",
+ GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ GTK_FILE_CHOOSER_ACTION_OPEN, "Select",
+ "Cancel");
+ filter = webkit_file_chooser_request_get_mime_types_filter (request);
+ select_multiple_p = webkit_file_chooser_request_get_select_multiple (request);
+
+ gtk_file_chooser_set_select_multiple (GTK_FILE_CHOOSER (chooser),
+ select_multiple_p);
+ gtk_file_chooser_add_filter (GTK_FILE_CHOOSER (chooser), filter);
+ response = gtk_native_dialog_run (GTK_NATIVE_DIALOG (chooser));
+
+ if (response != GTK_RESPONSE_ACCEPT)
+ {
+ gtk_native_dialog_destroy (GTK_NATIVE_DIALOG (chooser));
+ webkit_file_chooser_request_cancel (request);
+
+ return TRUE;
+ }
+
+ filenames = gtk_file_chooser_get_filenames (GTK_FILE_CHOOSER (chooser));
+ len = g_slist_length (filenames);
+ files = alloca (sizeof *files * (len + 1));
+
+ for (tem = filenames, i = 0; tem; tem = tem->next, ++i)
+ files[i] = tem->data;
+ files[len] = NULL;
+
+ g_slist_free (filenames);
+ webkit_file_chooser_request_select_files (request, (const gchar **) files);
+
+ for (i = 0; i < len; ++i)
+ g_free (files[i]);
+
+ gtk_native_dialog_destroy (GTK_NATIVE_DIALOG (chooser));
+
+ return TRUE;
+}
+
+
+static void
+xwidget_button_1 (struct xwidget_view *view,
+ bool down_p, int x, int y, int button,
+ int modifier_state, Time time)
+{
+ GdkEvent *xg_event = gdk_event_new (down_p ? GDK_BUTTON_PRESS : GDK_BUTTON_RELEASE);
+ struct xwidget *model = XXWIDGET (view->model);
+ GtkWidget *target;
+#ifdef HAVE_XINPUT2
+ struct x_display_info *dpyinfo;
+ struct xi_device_t *xi_device;
+ GdkSeat *seat;
+ GdkDevice *device;
+#endif
+
+ /* X and Y should be relative to the origin of view->wdesc. */
+ x += view->clip_left;
+ y += view->clip_top;
+
+ target = find_widget_at_pos (model->widgetwindow_osr, x, y, &x, &y);
+
+ if (!target)
+ target = model->widget_osr;
+
+ xg_event->any.window = gtk_widget_get_window (target);
+ g_object_ref (xg_event->any.window); /* The window will be unrefed
+ later by gdk_event_free. */
+
+ xg_event->button.x = x;
+ xg_event->button.x_root = x;
+ xg_event->button.y = y;
+ xg_event->button.y_root = y;
+ xg_event->button.button = button;
+ xg_event->button.state = modifier_state;
+ xg_event->button.time = time;
+ xg_event->button.device = find_suitable_pointer (view->frame);
+
+#ifdef HAVE_XINPUT2
+ dpyinfo = FRAME_DISPLAY_INFO (view->frame);
+ device = xg_event->button.device;
+
+ for (int idx = 0; idx < dpyinfo->num_devices; ++idx)
+ {
+ xi_device = &dpyinfo->devices[idx];
+
+ XIUngrabDevice (view->dpy, xi_device->device_id, CurrentTime);
+ }
+
+ if (device)
+ {
+ seat = gdk_device_get_seat (device);
+ gdk_seat_ungrab (seat);
+ }
+#endif
+
+ gtk_main_do_event (xg_event);
+ gdk_event_free (xg_event);
+}
+
+void
+xwidget_button (struct xwidget_view *view,
+ bool down_p, int x, int y, int button,
+ int modifier_state, Time time)
+{
+ if (NILP (XXWIDGET (view->model)->buffer))
+ return;
+
+ record_osr_embedder (view);
+
+ if (button < 4 || button > 8)
+ xwidget_button_1 (view, down_p, x, y, button, modifier_state, time);
+#ifndef HAVE_XINPUT2
+ else
+#else
+ else if (!FRAME_DISPLAY_INFO (view->frame)->supports_xi2
+ || FRAME_DISPLAY_INFO (view->frame)->xi2_version < 1)
+#endif
+ {
+ GdkEvent *xg_event = gdk_event_new (GDK_SCROLL);
+ struct xwidget *model = XXWIDGET (view->model);
+ GtkWidget *target;
+
+ x += view->clip_left;
+ y += view->clip_top;
+
+ target = find_widget_at_pos (model->widgetwindow_osr, x, y, &x, &y);
+
+ if (!target)
+ target = model->widget_osr;
+
+ xg_event->any.window = gtk_widget_get_window (target);
+ g_object_ref (xg_event->any.window); /* The window will be unrefed
+ later by gdk_event_free. */
+ if (button == 4)
+ xg_event->scroll.direction = GDK_SCROLL_UP;
+ else if (button == 5)
+ xg_event->scroll.direction = GDK_SCROLL_DOWN;
+ else if (button == 6)
+ xg_event->scroll.direction = GDK_SCROLL_LEFT;
+ else
+ xg_event->scroll.direction = GDK_SCROLL_RIGHT;
+
+ xg_event->scroll.device = find_suitable_pointer (view->frame);
+
+ xg_event->scroll.x = x;
+ xg_event->scroll.x_root = x;
+ xg_event->scroll.y = y;
+ xg_event->scroll.y_root = y;
+ xg_event->scroll.state = modifier_state;
+ xg_event->scroll.time = time;
+
+ xg_event->scroll.delta_x = 0;
+ xg_event->scroll.delta_y = 0;
+
+ gtk_main_do_event (xg_event);
+ gdk_event_free (xg_event);
+ }
+}
+
+#ifdef HAVE_XINPUT2
+void
+xwidget_motion_notify (struct xwidget_view *view,
+ double x, double y, uint state, Time time)
+{
+ GdkEvent *xg_event;
+ GtkWidget *target;
+ struct xwidget *model = XXWIDGET (view->model);
+ int target_x, target_y;
+
+ if (NILP (model->buffer))
+ return;
+
+ record_osr_embedder (view);
+
+ target = find_widget_at_pos (model->widgetwindow_osr,
+ lrint (x), lrint (y),
+ &target_x, &target_y);
+
+ if (!target)
+ {
+ target_x = lrint (x);
+ target_y = lrint (y);
+ target = model->widget_osr;
+ }
+
+ xg_event = gdk_event_new (GDK_MOTION_NOTIFY);
+ xg_event->any.window = gtk_widget_get_window (target);
+ xg_event->motion.x = target_x;
+ xg_event->motion.y = target_y;
+ xg_event->motion.x_root = lrint (x);
+ xg_event->motion.y_root = lrint (y);
+ xg_event->motion.time = time;
+ xg_event->motion.state = state;
+ xg_event->motion.device = find_suitable_pointer (view->frame);
+
+ g_object_ref (xg_event->any.window);
+
+ gtk_main_do_event (xg_event);
+ gdk_event_free (xg_event);
+}
+
+void
+xwidget_scroll (struct xwidget_view *view, double x, double y,
+ double dx, double dy, uint state, Time time,
+ bool stop_p)
+{
+ GdkEvent *xg_event;
+ GtkWidget *target;
+ struct xwidget *model = XXWIDGET (view->model);
+ int target_x, target_y;
+
+ if (NILP (model->buffer))
+ return;
+
+ record_osr_embedder (view);
+
+ target = find_widget_at_pos (model->widgetwindow_osr,
+ lrint (x), lrint (y),
+ &target_x, &target_y);
+
+ if (!target)
+ {
+ target_x = lrint (x);
+ target_y = lrint (y);
+ target = model->widget_osr;
+ }
+
+ xg_event = gdk_event_new (GDK_SCROLL);
+ xg_event->any.window = gtk_widget_get_window (target);
+ xg_event->scroll.direction = GDK_SCROLL_SMOOTH;
+ xg_event->scroll.x = target_x;
+ xg_event->scroll.y = target_y;
+ xg_event->scroll.x_root = lrint (x);
+ xg_event->scroll.y_root = lrint (y);
+ xg_event->scroll.time = time;
+ xg_event->scroll.state = state;
+ xg_event->scroll.delta_x = dx;
+ xg_event->scroll.delta_y = dy;
+ xg_event->scroll.device = find_suitable_pointer (view->frame);
+ xg_event->scroll.is_stop = stop_p;
+
+ g_object_ref (xg_event->any.window);
+
+ gtk_main_do_event (xg_event);
+ gdk_event_free (xg_event);
+}
+#endif
+
+void
+xwidget_motion_or_crossing (struct xwidget_view *view, const XEvent *event)
+{
+ GdkEvent *xg_event;
+ struct xwidget *model = XXWIDGET (view->model);
+ int x;
+ int y;
+ GtkWidget *target;
+
+ if (NILP (model->buffer))
+ return;
+
+ xg_event = gdk_event_new (event->type == MotionNotify
+ ? GDK_MOTION_NOTIFY
+ : (event->type == LeaveNotify
+ ? GDK_LEAVE_NOTIFY
+ : GDK_ENTER_NOTIFY));
+
+ target = find_widget_at_pos (model->widgetwindow_osr,
+ (event->type == MotionNotify
+ ? event->xmotion.x + view->clip_left
+ : event->xcrossing.x + view->clip_left),
+ (event->type == MotionNotify
+ ? event->xmotion.y + view->clip_top
+ : event->xcrossing.y + view->clip_top),
+ &x, &y);
+
+ if (!target)
+ target = model->widget_osr;
+
+ record_osr_embedder (view);
+ xg_event->any.window = gtk_widget_get_window (target);
+ g_object_ref (xg_event->any.window); /* The window will be unrefed
+ later by gdk_event_free. */
+
+ if (event->type == MotionNotify)
+ {
+ xg_event->motion.x = x;
+ xg_event->motion.y = y;
+ xg_event->motion.x_root = event->xmotion.x_root;
+ xg_event->motion.y_root = event->xmotion.y_root;
+ xg_event->motion.time = event->xmotion.time;
+ xg_event->motion.state = event->xmotion.state;
+ xg_event->motion.device = find_suitable_pointer (view->frame);
+ }
+ else
+ {
+ xg_event->crossing.detail = min (5, event->xcrossing.detail);
+ xg_event->crossing.time = event->xcrossing.time;
+ xg_event->crossing.x = x;
+ xg_event->crossing.y = y;
+ xg_event->crossing.x_root = event->xcrossing.x_root;
+ xg_event->crossing.y_root = event->xcrossing.y_root;
+ gdk_event_set_device (xg_event, find_suitable_pointer (view->frame));
+ }
+
+ gtk_main_do_event (xg_event);
+ gdk_event_free (xg_event);
+}
+
+static void
+synthesize_focus_in_event (GtkWidget *offscreen_window)
+{
+ GdkWindow *wnd;
+ GdkEvent *focus_event;
+
+ if (!gtk_widget_get_realized (offscreen_window))
+ gtk_widget_realize (offscreen_window);
+
+ wnd = gtk_widget_get_window (offscreen_window);
+
+ focus_event = gdk_event_new (GDK_FOCUS_CHANGE);
+ focus_event->focus_change.window = wnd;
+ focus_event->focus_change.in = TRUE;
+
+ if (FRAME_WINDOW_P (SELECTED_FRAME ()))
+ gdk_event_set_device (focus_event,
+ find_suitable_pointer (SELECTED_FRAME ()));
+
+ g_object_ref (wnd);
+
+ gtk_main_do_event (focus_event);
+ gdk_event_free (focus_event);
+}
+
+struct xwidget_view *
+xwidget_view_from_window (Window wdesc)
+{
+ Lisp_Object key = make_fixnum (wdesc);
+ Lisp_Object xwv = Fgethash (key, x_window_to_xwv_map, Qnil);
+
+ if (NILP (xwv))
+ return NULL;
+
+ return XXWIDGET_VIEW (xwv);
+}
+
static void
xwidget_show_view (struct xwidget_view *xv)
{
xv->hidden = false;
- gtk_widget_show (xv->widgetwindow);
- gtk_fixed_move (GTK_FIXED (xv->emacswindow),
- xv->widgetwindow,
- xv->x + xv->clip_left,
- xv->y + xv->clip_top);
+ XMoveWindow (xv->dpy, xv->wdesc,
+ xv->x + xv->clip_left,
+ xv->y + xv->clip_top);
+ XMapWindow (xv->dpy, xv->wdesc);
+ XFlush (xv->dpy);
}
/* Hide an xwidget view. */
@@ -238,28 +1226,74 @@ static void
xwidget_hide_view (struct xwidget_view *xv)
{
xv->hidden = true;
- gtk_fixed_move (GTK_FIXED (xv->emacswindow), xv->widgetwindow,
- 10000, 10000);
+ XUnmapWindow (xv->dpy, xv->wdesc);
+ XFlush (xv->dpy);
+}
+
+static void
+xv_do_draw (struct xwidget_view *xw, struct xwidget *w)
+{
+ GtkOffscreenWindow *wnd;
+ cairo_surface_t *surface;
+
+ if (xw->just_resized)
+ return;
+
+ if (NILP (w->buffer))
+ {
+ XClearWindow (xw->dpy, xw->wdesc);
+ return;
+ }
+
+ block_input ();
+ wnd = GTK_OFFSCREEN_WINDOW (w->widgetwindow_osr);
+ surface = gtk_offscreen_window_get_surface (wnd);
+
+ cairo_save (xw->cr_context);
+ if (surface)
+ {
+ cairo_translate (xw->cr_context, -xw->clip_left, -xw->clip_top);
+ cairo_set_source_surface (xw->cr_context, surface, 0, 0);
+ cairo_set_operator (xw->cr_context, CAIRO_OPERATOR_SOURCE);
+ cairo_paint (xw->cr_context);
+ }
+ cairo_restore (xw->cr_context);
+
+ unblock_input ();
}
/* When the off-screen webkit master view changes this signal is called.
It copies the bitmap from the off-screen instance. */
static gboolean
offscreen_damage_event (GtkWidget *widget, GdkEvent *event,
- gpointer xv_widget)
-{
- /* Queue a redraw of onscreen widget.
- There is a guard against receiving an invalid widget,
- which should only happen if we failed to remove the
- specific signal handler for the damage event. */
- if (GTK_IS_WIDGET (xv_widget))
- gtk_widget_queue_draw (GTK_WIDGET (xv_widget));
- else
- message ("Warning, offscreen_damage_event received invalid xv pointer:%p\n",
- xv_widget);
+ gpointer xwidget)
+{
+ block_input ();
+
+ for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail);
+ tail = XCDR (tail))
+ {
+ if (XWIDGET_VIEW_P (XCAR (tail)))
+ {
+ struct xwidget_view *view = XXWIDGET_VIEW (XCAR (tail));
+
+ if (view->wdesc && XXWIDGET (view->model) == xwidget)
+ xv_do_draw (view, XXWIDGET (view->model));
+ }
+ }
+
+ unblock_input ();
return FALSE;
}
+
+void
+xwidget_expose (struct xwidget_view *xv)
+{
+ struct xwidget *xw = XXWIDGET (xv->model);
+
+ xv_do_draw (xv, xw);
+}
#endif /* USE_GTK */
void
@@ -313,22 +1347,121 @@ store_xwidget_js_callback_event (struct xwidget *xw,
#ifdef USE_GTK
+static void
+store_xwidget_display_event (struct xwidget *xw,
+ struct xwidget *src)
+{
+ struct input_event evt;
+ Lisp_Object val, src_val;
+
+ XSETXWIDGET (val, xw);
+ XSETXWIDGET (src_val, src);
+ EVENT_INIT (evt);
+ evt.kind = XWIDGET_DISPLAY_EVENT;
+ evt.frame_or_window = Qnil;
+ evt.arg = list2 (val, src_val);
+ kbd_buffer_store_event (&evt);
+}
+
+static void
+webkit_ready_to_show (WebKitWebView *new_view,
+ gpointer user_data)
+{
+ Lisp_Object tem;
+ struct xwidget *xw;
+ struct xwidget *src;
+
+ src = find_xwidget_for_offscreen_window (GDK_WINDOW (user_data));
+
+ for (tem = internal_xwidget_list; CONSP (tem); tem = XCDR (tem))
+ {
+ if (XWIDGETP (XCAR (tem)))
+ {
+ xw = XXWIDGET (XCAR (tem));
+
+ if (EQ (xw->type, Qwebkit)
+ && WEBKIT_WEB_VIEW (xw->widget_osr) == new_view)
+ {
+ /* The source widget was destroyed before we had a
+ chance to display the new widget. */
+ if (!src)
+ kill_xwidget (xw);
+ else
+ store_xwidget_display_event (xw, src);
+ }
+ }
+ }
+}
+
+static GtkWidget *
+webkit_create_cb_1 (WebKitWebView *webview,
+ struct xwidget *xv)
+{
+ Lisp_Object related;
+ Lisp_Object xwidget;
+ GtkWidget *widget;
+
+ XSETXWIDGET (related, xv);
+ xwidget = Fmake_xwidget (Qwebkit, Qnil, make_fixnum (0),
+ make_fixnum (0), Qnil,
+ build_string (" *detached xwidget buffer*"),
+ related);
+
+ if (NILP (xwidget))
+ return NULL;
+
+ widget = XXWIDGET (xwidget)->widget_osr;
+
+ g_signal_connect (G_OBJECT (widget), "ready-to-show",
+ G_CALLBACK (webkit_ready_to_show),
+ gtk_widget_get_window (xv->widgetwindow_osr));
+
+ return widget;
+}
+
+static GtkWidget *
+webkit_create_cb (WebKitWebView *webview,
+ WebKitNavigationAction *nav_action,
+ gpointer user_data)
+{
+ switch (webkit_navigation_action_get_navigation_type (nav_action))
+ {
+ case WEBKIT_NAVIGATION_TYPE_OTHER:
+ return webkit_create_cb_1 (webview, user_data);
+
+ case WEBKIT_NAVIGATION_TYPE_BACK_FORWARD:
+ case WEBKIT_NAVIGATION_TYPE_RELOAD:
+ case WEBKIT_NAVIGATION_TYPE_FORM_SUBMITTED:
+ case WEBKIT_NAVIGATION_TYPE_FORM_RESUBMITTED:
+ case WEBKIT_NAVIGATION_TYPE_LINK_CLICKED:
+ default:
+ return NULL;
+ }
+}
+
void
webkit_view_load_changed_cb (WebKitWebView *webkitwebview,
WebKitLoadEvent load_event,
gpointer data)
{
- switch (load_event) {
- case WEBKIT_LOAD_FINISHED:
+ struct xwidget *xw = g_object_get_data (G_OBJECT (webkitwebview),
+ XG_XWIDGET);
+
+ switch (load_event)
{
- struct xwidget *xw = g_object_get_data (G_OBJECT (webkitwebview),
- XG_XWIDGET);
- store_xwidget_event_string (xw, "load-changed", "");
+ case WEBKIT_LOAD_FINISHED:
+ store_xwidget_event_string (xw, "load-changed", "load-finished");
+ break;
+ case WEBKIT_LOAD_STARTED:
+ store_xwidget_event_string (xw, "load-changed", "load-started");
+ break;
+ case WEBKIT_LOAD_REDIRECTED:
+ store_xwidget_event_string (xw, "load-changed", "load-redirected");
+ break;
+ case WEBKIT_LOAD_COMMITTED:
+ store_xwidget_event_string (xw, "load-changed", "load-committed");
break;
}
- default:
- break;
- }
}
/* Recursively convert a JavaScript value to a Lisp value. */
@@ -419,8 +1552,8 @@ webkit_javascript_finished_cb (GObject *webview,
if (!js_result)
{
- g_warning ("Error running javascript: %s", error->message);
- g_error_free (error);
+ if (error)
+ g_error_free (error);
return;
}
@@ -479,6 +1612,33 @@ webkit_decide_policy_cb (WebKitWebView *webView,
break;
}
case WEBKIT_POLICY_DECISION_TYPE_NEW_WINDOW_ACTION:
+ {
+ WebKitNavigationPolicyDecision *navigation_decision =
+ WEBKIT_NAVIGATION_POLICY_DECISION (decision);
+ WebKitNavigationAction *navigation_action =
+ webkit_navigation_policy_decision_get_navigation_action (navigation_decision);
+ WebKitURIRequest *request =
+ webkit_navigation_action_get_request (navigation_action);
+ WebKitWebView *newview;
+ struct xwidget *xw = g_object_get_data (G_OBJECT (webView), XG_XWIDGET);
+ Lisp_Object val, new_xwidget;
+
+ XSETXWIDGET (val, xw);
+
+ new_xwidget = Fmake_xwidget (Qwebkit, Qnil, make_fixnum (0),
+ make_fixnum (0), Qnil,
+ build_string (" *detached xwidget buffer*"),
+ val);
+
+ if (NILP (new_xwidget))
+ return FALSE;
+
+ newview = WEBKIT_WEB_VIEW (XXWIDGET (new_xwidget)->widget_osr);
+ webkit_web_view_load_request (newview, request);
+
+ store_xwidget_display_event (XXWIDGET (new_xwidget), xw);
+ return TRUE;
+ }
case WEBKIT_POLICY_DECISION_TYPE_NAVIGATION_ACTION:
{
WebKitNavigationPolicyDecision *navigation_decision =
@@ -499,49 +1659,75 @@ webkit_decide_policy_cb (WebKitWebView *webView,
}
}
-
-/* For gtk3 offscreen rendered widgets. */
static gboolean
-xwidget_osr_draw_cb (GtkWidget *widget, cairo_t *cr, gpointer data)
+webkit_script_dialog_cb (WebKitWebView *webview,
+ WebKitScriptDialog *script_dialog,
+ gpointer user)
{
- struct xwidget *xw = g_object_get_data (G_OBJECT (widget), XG_XWIDGET);
- struct xwidget_view *xv = g_object_get_data (G_OBJECT (widget),
- XG_XWIDGET_VIEW);
+ struct frame *f = SELECTED_FRAME ();
+ WebKitScriptDialogType type;
+ GtkWidget *widget;
+ GtkWidget *dialog;
+ GtkWidget *entry;
+ GtkWidget *content_area;
+ GtkWidget *box;
+ GtkWidget *label;
+ const gchar *content;
+ const gchar *message;
+ gint result;
+
+ /* Return TRUE to prevent WebKit from showing the default script
+ dialog in the offscreen window, which runs a nested main loop
+ Emacs can't respond to, and as such can't pass X events to. */
+ if (!FRAME_WINDOW_P (f))
+ return TRUE;
+
+ type = webkit_script_dialog_get_dialog_type (script_dialog);;
+ widget = FRAME_GTK_OUTER_WIDGET (f);
+ content = webkit_script_dialog_get_message (script_dialog);
+
+ if (type == WEBKIT_SCRIPT_DIALOG_ALERT)
+ dialog = gtk_dialog_new_with_buttons ("Alert", GTK_WINDOW (widget),
+ GTK_DIALOG_MODAL,
+ "Dismiss", 1, NULL);
+ else
+ dialog = gtk_dialog_new_with_buttons ("Question", GTK_WINDOW (widget),
+ GTK_DIALOG_MODAL,
+ "OK", 0, "Cancel", 1, NULL);
- cairo_rectangle (cr, 0, 0, xv->clip_right, xv->clip_bottom);
- cairo_clip (cr);
+ box = gtk_box_new (GTK_ORIENTATION_VERTICAL, 8);
+ label = gtk_label_new (content);
+ content_area = gtk_dialog_get_content_area (GTK_DIALOG (dialog));
+ gtk_container_add (GTK_CONTAINER (content_area), box);
- gtk_widget_draw (xw->widget_osr, cr);
- return FALSE;
-}
+ gtk_widget_show (box);
+ gtk_widget_show (label);
-static gboolean
-xwidget_osr_event_forward (GtkWidget *widget, GdkEvent *event,
- gpointer user_data)
-{
- /* Copy events that arrive at the outer widget to the offscreen widget. */
- struct xwidget *xw = g_object_get_data (G_OBJECT (widget), XG_XWIDGET);
- GdkEvent *eventcopy = gdk_event_copy (event);
- eventcopy->any.window = gtk_widget_get_window (xw->widget_osr);
+ gtk_box_pack_start (GTK_BOX (box), label, TRUE, TRUE, 0);
- /* TODO: This might leak events. They should be deallocated later,
- perhaps in xwgir_event_cb. */
- gtk_main_do_event (eventcopy);
+ if (type == WEBKIT_SCRIPT_DIALOG_PROMPT)
+ {
+ entry = gtk_entry_new ();
+ message = webkit_script_dialog_prompt_get_default_text (script_dialog);
- /* Don't propagate this event further. */
- return TRUE;
-}
+ gtk_widget_show (entry);
+ gtk_entry_set_text (GTK_ENTRY (entry), message);
+ gtk_box_pack_end (GTK_BOX (box), entry, TRUE, TRUE, 0);
+ }
-static gboolean
-xwidget_osr_event_set_embedder (GtkWidget *widget, GdkEvent *event,
- gpointer data)
-{
- struct xwidget_view *xv = data;
- struct xwidget *xww = XXWIDGET (xv->model);
- gdk_offscreen_window_set_embedder (gtk_widget_get_window
- (xww->widgetwindow_osr),
- gtk_widget_get_window (xv->widget));
- return FALSE;
+ result = gtk_dialog_run (GTK_DIALOG (dialog));
+
+ if (type == WEBKIT_SCRIPT_DIALOG_CONFIRM
+ || type == WEBKIT_SCRIPT_DIALOG_BEFORE_UNLOAD_CONFIRM)
+ webkit_script_dialog_confirm_set_confirmed (script_dialog, result == 0);
+
+ if (type == WEBKIT_SCRIPT_DIALOG_PROMPT)
+ webkit_script_dialog_prompt_set_text (script_dialog,
+ gtk_entry_get_text (GTK_ENTRY (entry)));
+
+ gtk_widget_destroy (GTK_WIDGET (dialog));
+
+ return TRUE;
}
#endif /* USE_GTK */
@@ -562,69 +1748,27 @@ xwidget_init_view (struct xwidget *xww,
Lisp_Object val;
XSETXWIDGET_VIEW (val, xv);
- Vxwidget_view_list = Fcons (val, Vxwidget_view_list);
+ internal_xwidget_view_list = Fcons (val, internal_xwidget_view_list);
+ Vxwidget_view_list = Fcopy_sequence (internal_xwidget_view_list);
XSETWINDOW (xv->w, s->w);
XSETXWIDGET (xv->model, xww);
#ifdef USE_GTK
- if (EQ (xww->type, Qwebkit))
- {
- xv->widget = gtk_drawing_area_new ();
- /* Expose event handling. */
- gtk_widget_set_app_paintable (xv->widget, TRUE);
- gtk_widget_add_events (xv->widget, GDK_ALL_EVENTS_MASK);
-
- /* Draw the view on damage-event. */
- g_signal_connect (G_OBJECT (xww->widgetwindow_osr), "damage-event",
- G_CALLBACK (offscreen_damage_event), xv->widget);
+ xv->dpy = FRAME_X_DISPLAY (s->f);
- if (EQ (xww->type, Qwebkit))
- {
- g_signal_connect (G_OBJECT (xv->widget), "button-press-event",
- G_CALLBACK (xwidget_osr_event_forward), NULL);
- g_signal_connect (G_OBJECT (xv->widget), "button-release-event",
- G_CALLBACK (xwidget_osr_event_forward), NULL);
- g_signal_connect (G_OBJECT (xv->widget), "motion-notify-event",
- G_CALLBACK (xwidget_osr_event_forward), NULL);
- }
- else
- {
- /* xwgir debug, orthogonal to forwarding. */
- g_signal_connect (G_OBJECT (xv->widget), "enter-notify-event",
- G_CALLBACK (xwidget_osr_event_set_embedder), xv);
- }
- g_signal_connect (G_OBJECT (xv->widget), "draw",
- G_CALLBACK (xwidget_osr_draw_cb), NULL);
- }
-
- /* Widget realization.
-
- Make container widget first, and put the actual widget inside the
- container later. Drawing should crop container window if necessary
- to handle case where xwidget is partially obscured by other Emacs
- windows. Other containers than gtk_fixed where explored, but
- gtk_fixed had the most predictable behavior so far. */
-
- xv->emacswindow = FRAME_GTK_WIDGET (s->f);
- xv->widgetwindow = gtk_fixed_new ();
- gtk_widget_set_has_window (xv->widgetwindow, TRUE);
- gtk_container_add (GTK_CONTAINER (xv->widgetwindow), xv->widget);
-
- /* Store some xwidget data in the gtk widgets. */
- g_object_set_data (G_OBJECT (xv->widget), XG_FRAME_DATA, s->f);
- g_object_set_data (G_OBJECT (xv->widget), XG_XWIDGET, xww);
- g_object_set_data (G_OBJECT (xv->widget), XG_XWIDGET_VIEW, xv);
- g_object_set_data (G_OBJECT (xv->widgetwindow), XG_XWIDGET, xww);
- g_object_set_data (G_OBJECT (xv->widgetwindow), XG_XWIDGET_VIEW, xv);
-
- gtk_widget_set_size_request (GTK_WIDGET (xv->widget), xww->width,
- xww->height);
- gtk_widget_set_size_request (xv->widgetwindow, xww->width, xww->height);
- gtk_fixed_put (GTK_FIXED (FRAME_GTK_WIDGET (s->f)), xv->widgetwindow, x, y);
xv->x = x;
xv->y = y;
- gtk_widget_show_all (xv->widgetwindow);
+
+ xv->clip_left = 0;
+ xv->clip_right = xww->width;
+ xv->clip_top = 0;
+ xv->clip_bottom = xww->height;
+
+ xv->wdesc = None;
+ xv->frame = s->f;
+ xv->cursor = cursor_for_hit (xww->hit_result, s->f);
+ xv->just_resized = false;
#elif defined NS_IMPL_COCOA
nsxwidget_init_view (xv, xww, s, x, y);
nsxwidget_resize_view(xv, xww->width, xww->height);
@@ -656,6 +1800,8 @@ x_draw_xwidget_glyph_string (struct glyph_string *s)
#ifdef USE_GTK
if (!xv)
xv = xwidget_init_view (xww, s, x, y);
+
+ xv->just_resized = false;
#elif defined NS_IMPL_COCOA
if (!xv)
{
@@ -678,21 +1824,10 @@ x_draw_xwidget_glyph_string (struct glyph_string *s)
}
#endif
- window_box (s->w, TEXT_AREA, &text_area_x, &text_area_y,
- &text_area_width, &text_area_height);
+ xv->area = s->area;
- /* Resize xwidget webkit if its container window size is changed in
- some ways, for example, a buffer became hidden in small split
- window, then it can appear front in merged whole window. */
- if (EQ (xww->type, Qwebkit)
- && (xww->width != text_area_width || xww->height != text_area_height))
- {
- Lisp_Object xwl;
- XSETXWIDGET (xwl, xww);
- Fxwidget_resize (xwl,
- make_int (text_area_width),
- make_int (text_area_height));
- }
+ window_box (s->w, xv->area, &text_area_x, &text_area_y,
+ &text_area_width, &text_area_height);
clip_left = max (0, text_area_x - x);
clip_right = max (clip_left,
@@ -711,15 +1846,75 @@ x_draw_xwidget_glyph_string (struct glyph_string *s)
later. */
bool moved = (xv->x + xv->clip_left != x + clip_left
|| xv->y + xv->clip_top != y + clip_top);
+
+#ifdef USE_GTK
+ bool wdesc_was_none = xv->wdesc == None;
+#endif
xv->x = x;
xv->y = y;
+#ifdef USE_GTK
+ block_input ();
+ if (xv->wdesc == None)
+ {
+ Lisp_Object xvw;
+ XSETXWIDGET_VIEW (xvw, xv);
+ XSetWindowAttributes a;
+ a.event_mask = (ExposureMask | ButtonPressMask | ButtonReleaseMask
+ | PointerMotionMask | EnterWindowMask | LeaveWindowMask);
+
+ if (clip_right - clip_left <= 0
+ || clip_bottom - clip_top <= 0)
+ {
+ unblock_input ();
+ return;
+ }
+
+ xv->wdesc = XCreateWindow (xv->dpy, FRAME_X_WINDOW (s->f),
+ x + clip_left, y + clip_top,
+ clip_right - clip_left,
+ clip_bottom - clip_top, 0,
+ CopyFromParent, CopyFromParent,
+ CopyFromParent, CWEventMask, &a);
+#ifdef HAVE_XINPUT2
+ XIEventMask mask;
+ ptrdiff_t l = XIMaskLen (XI_LASTEVENT);
+ unsigned char *m;
+
+ if (FRAME_DISPLAY_INFO (s->f)->supports_xi2)
+ {
+ mask.mask = m = alloca (l);
+ memset (m, 0, l);
+ mask.mask_len = l;
+ mask.deviceid = XIAllMasterDevices;
+
+ XISetMask (m, XI_Motion);
+ XISelectEvents (xv->dpy, xv->wdesc, &mask, 1);
+ }
+#endif
+ XLowerWindow (xv->dpy, xv->wdesc);
+ XDefineCursor (xv->dpy, xv->wdesc, xv->cursor);
+ xv->cr_surface = cairo_xlib_surface_create (xv->dpy,
+ xv->wdesc,
+ FRAME_DISPLAY_INFO (s->f)->visual,
+ clip_right - clip_left,
+ clip_bottom - clip_top);
+ xv->cr_context = cairo_create (xv->cr_surface);
+ Fputhash (make_fixnum (xv->wdesc), xvw, x_window_to_xwv_map);
+
+ moved = false;
+ }
+#endif
+
/* Has it moved? */
if (moved)
{
#ifdef USE_GTK
- gtk_fixed_move (GTK_FIXED (FRAME_GTK_WIDGET (s->f)),
- xv->widgetwindow, x + clip_left, y + clip_top);
+ XMoveResizeWindow (xv->dpy, xv->wdesc, x + clip_left, y + clip_top,
+ clip_right - clip_left, clip_bottom - clip_top);
+ XFlush (xv->dpy);
+ cairo_xlib_surface_set_size (xv->cr_surface, clip_right - clip_left,
+ clip_bottom - clip_top);
#elif defined NS_IMPL_COCOA
nsxwidget_move_view (xv, x + clip_left, y + clip_top);
#endif
@@ -735,10 +1930,23 @@ x_draw_xwidget_glyph_string (struct glyph_string *s)
|| xv->clip_top != clip_top || xv->clip_left != clip_left)
{
#ifdef USE_GTK
- gtk_widget_set_size_request (xv->widgetwindow, clip_right - clip_left,
- clip_bottom - clip_top);
- gtk_fixed_move (GTK_FIXED (xv->widgetwindow), xv->widget, -clip_left,
- -clip_top);
+ if (!wdesc_was_none && !moved)
+ {
+ if (clip_right - clip_left <= 0
+ || clip_bottom - clip_top <= 0)
+ {
+ XUnmapWindow (xv->dpy, xv->wdesc);
+ xv->hidden = true;
+ }
+ else
+ {
+ XResizeWindow (xv->dpy, xv->wdesc, clip_right - clip_left,
+ clip_bottom - clip_top);
+ }
+ XFlush (xv->dpy);
+ cairo_xlib_surface_set_size (xv->cr_surface, clip_right - clip_left,
+ clip_bottom - clip_top);
+ }
#elif defined NS_IMPL_COCOA
nsxwidget_resize_view (xv, clip_right - clip_left,
clip_bottom - clip_top);
@@ -755,37 +1963,45 @@ x_draw_xwidget_glyph_string (struct glyph_string *s)
a redraw. It seems its possible to get out of sync with emacs
redraws so emacs background sometimes shows up instead of the
xwidgets background. It's just a visual glitch though. */
- if (!xwidget_hidden (xv))
+ /* When xww->buffer is nil, that means the xwidget has been killed. */
+ if (!NILP (xww->buffer))
{
+ if (!xwidget_hidden (xv))
+ {
#ifdef USE_GTK
- gtk_widget_queue_draw (xv->widgetwindow);
- gtk_widget_queue_draw (xv->widget);
+ gtk_widget_queue_draw (xww->widget_osr);
#elif defined NS_IMPL_COCOA
- nsxwidget_set_needsdisplay (xv);
+ nsxwidget_set_needsdisplay (xv);
#endif
+ }
}
-}
+#ifdef USE_GTK
+ else
+ {
+ XSetWindowBackground (xv->dpy, xv->wdesc,
+ FRAME_BACKGROUND_PIXEL (s->f));
+ }
+#endif
+
+#ifdef HAVE_XINPUT2
+ record_osr_embedder (xv);
+ synthesize_focus_in_event (xww->widget_osr);
+#endif
-static bool
-xwidget_is_web_view (struct xwidget *xw)
-{
#ifdef USE_GTK
- return xw->widget_osr != NULL && WEBKIT_IS_WEB_VIEW (xw->widget_osr);
-#elif defined NS_IMPL_COCOA
- return nsxwidget_is_web_view (xw);
+ unblock_input ();
#endif
}
+#define CHECK_WEBKIT_WIDGET(xw) \
+ if (NILP (xw->buffer) || !EQ (xw->type, Qwebkit)) \
+ error ("Not a WebKit widget")
+
/* Macro that checks xwidget hold webkit web view first. */
#define WEBKIT_FN_INIT() \
- CHECK_XWIDGET (xwidget); \
+ CHECK_LIVE_XWIDGET (xwidget); \
struct xwidget *xw = XXWIDGET (xwidget); \
- if (!xwidget_is_web_view (xw)) \
- { \
- fputs ("ERROR xw->widget_osr does not hold a webkit instance\n", \
- stdout); \
- return Qnil; \
- }
+ CHECK_WEBKIT_WIDGET (xw)
DEFUN ("xwidget-webkit-uri",
Fxwidget_webkit_uri, Sxwidget_webkit_uri,
@@ -796,7 +2012,10 @@ DEFUN ("xwidget-webkit-uri",
WEBKIT_FN_INIT ();
#ifdef USE_GTK
WebKitWebView *wkwv = WEBKIT_WEB_VIEW (xw->widget_osr);
- return build_string (webkit_web_view_get_uri (wkwv));
+ const gchar *uri = webkit_web_view_get_uri (wkwv);
+ if (!uri)
+ return build_string ("");
+ return build_string (uri);
#elif defined NS_IMPL_COCOA
return nsxwidget_webkit_uri (xw);
#endif
@@ -830,6 +2049,7 @@ DEFUN ("xwidget-webkit-goto-uri",
uri = ENCODE_FILE (uri);
#ifdef USE_GTK
webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr), SSDATA (uri));
+ catch_child_signal ();
#elif defined NS_IMPL_COCOA
nsxwidget_webkit_goto_uri (xw, SSDATA (uri));
#endif
@@ -839,21 +2059,32 @@ DEFUN ("xwidget-webkit-goto-uri",
DEFUN ("xwidget-webkit-goto-history",
Fxwidget_webkit_goto_history, Sxwidget_webkit_goto_history,
2, 2, 0,
- doc: /* Make the XWIDGET webkit load REL-POS (-1, 0, 1) page in browse history. */)
+ doc: /* Make the XWIDGET webkit the REL-POSth element in load history.
+
+If REL-POS is 0, the widget will be just reload the current element in
+history. If REL-POS is more or less than 0, the widget will load the
+REL-POSth element around the current spot in the load history. */)
(Lisp_Object xwidget, Lisp_Object rel_pos)
{
WEBKIT_FN_INIT ();
- /* Should be one of -1, 0, 1 */
- if (XFIXNUM (rel_pos) < -1 || XFIXNUM (rel_pos) > 1)
- args_out_of_range_3 (rel_pos, make_fixnum (-1), make_fixnum (1));
+ CHECK_FIXNUM (rel_pos);
#ifdef USE_GTK
WebKitWebView *wkwv = WEBKIT_WEB_VIEW (xw->widget_osr);
- switch (XFIXNAT (rel_pos))
+ WebKitBackForwardList *list;
+ WebKitBackForwardListItem *it;
+
+ if (XFIXNUM (rel_pos) == 0)
+ webkit_web_view_reload (wkwv);
+ else
{
- case -1: webkit_web_view_go_back (wkwv); break;
- case 0: webkit_web_view_reload (wkwv); break;
- case 1: webkit_web_view_go_forward (wkwv); break;
+ list = webkit_web_view_get_back_forward_list (wkwv);
+ it = webkit_back_forward_list_get_nth_item (list, XFIXNUM (rel_pos));
+
+ if (!it)
+ error ("There is no item at this index");
+
+ webkit_web_view_go_to_back_forward_list_item (wkwv, it);
}
#elif defined NS_IMPL_COCOA
nsxwidget_webkit_goto_history (xw, XFIXNAT (rel_pos));
@@ -946,7 +2177,7 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0,
doc: /* Resize XWIDGET to NEW_WIDTH, NEW_HEIGHT. */ )
(Lisp_Object xwidget, Lisp_Object new_width, Lisp_Object new_height)
{
- CHECK_XWIDGET (xwidget);
+ CHECK_LIVE_XWIDGET (xwidget);
int w = check_integer_range (new_width, 0, INT_MAX);
int h = check_integer_range (new_height, 0, INT_MAX);
struct xwidget *xw = XXWIDGET (xwidget);
@@ -954,21 +2185,10 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0,
xw->width = w;
xw->height = h;
- /* If there is an offscreen widget resize it first. */
-#ifdef USE_GTK
- if (xw->widget_osr)
- {
- gtk_window_resize (GTK_WINDOW (xw->widgetwindow_osr), xw->width,
- xw->height);
- gtk_container_resize_children (GTK_CONTAINER (xw->widgetwindow_osr));
- gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width,
- xw->height);
- }
-#elif defined NS_IMPL_COCOA
- nsxwidget_resize (xw);
-#endif
+ block_input ();
- for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); tail = XCDR (tail))
+ for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail);
+ tail = XCDR (tail))
{
if (XWIDGET_VIEW_P (XCAR (tail)))
{
@@ -976,15 +2196,33 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0,
if (XXWIDGET (xv->model) == xw)
{
#ifdef USE_GTK
- gtk_widget_set_size_request (GTK_WIDGET (xv->widget), xw->width,
- xw->height);
-#elif defined NS_IMPL_COCOA
- nsxwidget_resize_view(xv, xw->width, xw->height);
+ xv->just_resized = true;
+ SET_FRAME_GARBAGED (xv->frame);
+#else
+ wset_redisplay (XWINDOW (xv->w));
#endif
}
}
}
+ redisplay ();
+
+ /* If there is an offscreen widget resize it first. */
+#ifdef USE_GTK
+ if (xw->widget_osr)
+ {
+ gtk_window_resize (GTK_WINDOW (xw->widgetwindow_osr), xw->width,
+ xw->height);
+ gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width,
+ xw->height);
+
+ gtk_widget_queue_allocate (GTK_WIDGET (xw->widget_osr));
+ }
+#elif defined NS_IMPL_COCOA
+ nsxwidget_resize (xw);
+#endif
+ unblock_input ();
+
return Qnil;
}
@@ -999,7 +2237,7 @@ This can be used to read the xwidget desired size, and resizes the
Emacs allocated area accordingly. */)
(Lisp_Object xwidget)
{
- CHECK_XWIDGET (xwidget);
+ CHECK_LIVE_XWIDGET (xwidget);
#ifdef USE_GTK
GtkRequisition requisition;
gtk_widget_size_request (XXWIDGET (xwidget)->widget_osr, &requisition);
@@ -1034,7 +2272,7 @@ DEFUN ("xwidget-info",
Currently [TYPE TITLE WIDTH HEIGHT]. */)
(Lisp_Object xwidget)
{
- CHECK_XWIDGET (xwidget);
+ CHECK_LIVE_XWIDGET (xwidget);
struct xwidget *xw = XXWIDGET (xwidget);
return CALLN (Fvector, xw->type, xw->title,
make_fixed_natnum (xw->width), make_fixed_natnum (xw->height));
@@ -1084,18 +2322,34 @@ DEFUN ("delete-xwidget-view",
CHECK_XWIDGET_VIEW (xwidget_view);
struct xwidget_view *xv = XXWIDGET_VIEW (xwidget_view);
#ifdef USE_GTK
- gtk_widget_destroy (xv->widgetwindow);
- /* xv->model still has signals pointing to the view. There can be
- several views. Find the matching signals and delete them all. */
- g_signal_handlers_disconnect_matched (XXWIDGET (xv->model)->widgetwindow_osr,
- G_SIGNAL_MATCH_DATA,
- 0, 0, 0, 0,
- xv->widget);
+ struct xwidget *xw = XXWIDGET (xv->model);
+ GdkWindow *w;
+
+ if (xv->wdesc != None)
+ {
+ block_input ();
+ cairo_destroy (xv->cr_context);
+ cairo_surface_destroy (xv->cr_surface);
+ XDestroyWindow (xv->dpy, xv->wdesc);
+ Fremhash (make_fixnum (xv->wdesc), x_window_to_xwv_map);
+ unblock_input ();
+ }
+
+ if (xw->embedder_view == xv && !NILP (xw->buffer))
+ {
+ w = gtk_widget_get_window (xw->widgetwindow_osr);
+
+ XXWIDGET (xv->model)->embedder_view = NULL;
+ XXWIDGET (xv->model)->embedder = NULL;
+
+ gdk_offscreen_window_set_embedder (w, NULL);
+ }
#elif defined NS_IMPL_COCOA
nsxwidget_delete_view (xv);
#endif
- Vxwidget_view_list = Fdelq (xwidget_view, Vxwidget_view_list);
+ internal_xwidget_view_list = Fdelq (xwidget_view, internal_xwidget_view_list);
+ Vxwidget_view_list = Fcopy_sequence (internal_xwidget_view_list);
return Qnil;
}
@@ -1113,7 +2367,7 @@ Return nil if no association is found. */)
window = Fselected_window ();
CHECK_WINDOW (window);
- for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail);
+ for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail);
tail = XCDR (tail))
{
Lisp_Object xwidget_view = XCAR (tail);
@@ -1131,7 +2385,7 @@ DEFUN ("xwidget-plist",
doc: /* Return the plist of XWIDGET. */)
(Lisp_Object xwidget)
{
- CHECK_XWIDGET (xwidget);
+ CHECK_LIVE_XWIDGET (xwidget);
return XXWIDGET (xwidget)->plist;
}
@@ -1145,6 +2399,19 @@ DEFUN ("xwidget-buffer",
return XXWIDGET (xwidget)->buffer;
}
+DEFUN ("set-xwidget-buffer",
+ Fset_xwidget_buffer, Sset_xwidget_buffer,
+ 2, 2, 0,
+ doc: /* Set XWIDGET's buffer to BUFFER. */)
+ (Lisp_Object xwidget, Lisp_Object buffer)
+{
+ CHECK_LIVE_XWIDGET (xwidget);
+ CHECK_BUFFER (buffer);
+
+ XXWIDGET (xwidget)->buffer = buffer;
+ return Qnil;
+}
+
DEFUN ("set-xwidget-plist",
Fset_xwidget_plist, Sset_xwidget_plist,
2, 2, 0,
@@ -1152,7 +2419,7 @@ DEFUN ("set-xwidget-plist",
Returns PLIST. */)
(Lisp_Object xwidget, Lisp_Object plist)
{
- CHECK_XWIDGET (xwidget);
+ CHECK_LIVE_XWIDGET (xwidget);
CHECK_LIST (plist);
XXWIDGET (xwidget)->plist = plist;
@@ -1168,7 +2435,7 @@ exiting or killing a buffer if XWIDGET is running.
This function returns FLAG. */)
(Lisp_Object xwidget, Lisp_Object flag)
{
- CHECK_XWIDGET (xwidget);
+ CHECK_LIVE_XWIDGET (xwidget);
XXWIDGET (xwidget)->kill_without_query = NILP (flag);
return flag;
}
@@ -1179,16 +2446,414 @@ DEFUN ("xwidget-query-on-exit-flag",
doc: /* Return the current value of the query-on-exit flag for XWIDGET. */)
(Lisp_Object xwidget)
{
- CHECK_XWIDGET (xwidget);
+ CHECK_LIVE_XWIDGET (xwidget);
return (XXWIDGET (xwidget)->kill_without_query ? Qnil : Qt);
}
+DEFUN ("xwidget-webkit-search", Fxwidget_webkit_search, Sxwidget_webkit_search,
+ 2, 5, 0,
+ doc: /* Begin an incremental search operation in an xwidget.
+QUERY should be a string containing the text to search for. XWIDGET
+should be a WebKit xwidget where the search will take place. When the
+search operation is complete, callers should also call
+`xwidget-webkit-finish-search' to complete the search operation.
+
+CASE-INSENSITIVE, when non-nil, will cause the search to ignore the
+case of characters inside QUERY. BACKWARDS, when non-nil, will cause
+the search to proceed towards the beginning of the widget's contents.
+WRAP-AROUND, when nil, will cause the search to stop upon hitting the
+end of the widget's contents.
+
+It is OK to call this function even when a search is already in
+progress. In that case, the previous search query will be replaced
+with QUERY. */)
+ (Lisp_Object query, Lisp_Object xwidget, Lisp_Object case_insensitive,
+ Lisp_Object backwards, Lisp_Object wrap_around)
+{
+#ifdef USE_GTK
+ WebKitWebView *webview;
+ WebKitFindController *controller;
+ WebKitFindOptions opt;
+ struct xwidget *xw;
+ gchar *g_query;
+#endif
+
+ CHECK_STRING (query);
+ CHECK_LIVE_XWIDGET (xwidget);
+
+#ifdef USE_GTK
+ xw = XXWIDGET (xwidget);
+ CHECK_WEBKIT_WIDGET (xw);
+
+ webview = WEBKIT_WEB_VIEW (xw->widget_osr);
+ query = ENCODE_UTF_8 (query);
+ opt = WEBKIT_FIND_OPTIONS_NONE;
+ g_query = xstrdup (SSDATA (query));
+
+ if (!NILP (case_insensitive))
+ opt |= WEBKIT_FIND_OPTIONS_CASE_INSENSITIVE;
+ if (!NILP (backwards))
+ opt |= WEBKIT_FIND_OPTIONS_BACKWARDS;
+ if (!NILP (wrap_around))
+ opt |= WEBKIT_FIND_OPTIONS_WRAP_AROUND;
+
+ if (xw->find_text)
+ xfree (xw->find_text);
+ xw->find_text = g_query;
+
+ block_input ();
+ controller = webkit_web_view_get_find_controller (webview);
+ webkit_find_controller_search (controller, g_query, opt, G_MAXUINT);
+ unblock_input ();
+#endif
+
+ return Qnil;
+}
+
+DEFUN ("xwidget-webkit-next-result", Fxwidget_webkit_next_result,
+ Sxwidget_webkit_next_result, 1, 1, 0,
+ doc: /* Show the next result matching the current search query.
+
+XWIDGET should be an xwidget that currently has a search query.
+Before calling this function, you should start a search operation
+using `xwidget-webkit-search'. */)
+ (Lisp_Object xwidget)
+{
+ struct xwidget *xw;
+#ifdef USE_GTK
+ WebKitWebView *webview;
+ WebKitFindController *controller;
+#endif
+
+ CHECK_LIVE_XWIDGET (xwidget);
+ xw = XXWIDGET (xwidget);
+ CHECK_WEBKIT_WIDGET (xw);
+
+ if (!xw->find_text)
+ error ("Widget has no ongoing search operation");
+
+#ifdef USE_GTK
+ block_input ();
+ webview = WEBKIT_WEB_VIEW (xw->widget_osr);
+ controller = webkit_web_view_get_find_controller (webview);
+ webkit_find_controller_search_next (controller);
+ unblock_input ();
+#endif
+
+ return Qnil;
+}
+
+DEFUN ("xwidget-webkit-previous-result", Fxwidget_webkit_previous_result,
+ Sxwidget_webkit_previous_result, 1, 1, 0,
+ doc: /* Show the previous result matching the current search query.
+
+XWIDGET should be an xwidget that currently has a search query.
+Before calling this function, you should start a search operation
+using `xwidget-webkit-search'. */)
+ (Lisp_Object xwidget)
+{
+ struct xwidget *xw;
+#ifdef USE_GTK
+ WebKitWebView *webview;
+ WebKitFindController *controller;
+#endif
+
+ CHECK_LIVE_XWIDGET (xwidget);
+ xw = XXWIDGET (xwidget);
+ CHECK_WEBKIT_WIDGET (xw);
+
+ if (!xw->find_text)
+ error ("Widget has no ongoing search operation");
+
+#ifdef USE_GTK
+ block_input ();
+ webview = WEBKIT_WEB_VIEW (xw->widget_osr);
+ controller = webkit_web_view_get_find_controller (webview);
+ webkit_find_controller_search_previous (controller);
+ unblock_input ();
+#endif
+
+ return Qnil;
+}
+
+DEFUN ("xwidget-webkit-finish-search", Fxwidget_webkit_finish_search,
+ Sxwidget_webkit_finish_search, 1, 1, 0,
+ doc: /* Finish XWIDGET's search operation.
+
+XWIDGET should be an xwidget that currently has a search query.
+Before calling this function, you should start a search operation
+using `xwidget-webkit-search'. */)
+ (Lisp_Object xwidget)
+{
+ struct xwidget *xw;
+#ifdef USE_GTK
+ WebKitWebView *webview;
+ WebKitFindController *controller;
+#endif
+
+ CHECK_LIVE_XWIDGET (xwidget);
+ xw = XXWIDGET (xwidget);
+ CHECK_WEBKIT_WIDGET (xw);
+
+ if (!xw->find_text)
+ error ("Widget has no ongoing search operation");
+
+#ifdef USE_GTK
+ block_input ();
+ webview = WEBKIT_WEB_VIEW (xw->widget_osr);
+ controller = webkit_web_view_get_find_controller (webview);
+ webkit_find_controller_search_finish (controller);
+
+ if (xw->find_text)
+ {
+ xfree (xw->find_text);
+ xw->find_text = NULL;
+ }
+ unblock_input ();
+#endif
+
+ return Qnil;
+}
+
+DEFUN ("kill-xwidget", Fkill_xwidget, Skill_xwidget,
+ 1, 1, 0,
+ doc: /* Kill the specified XWIDGET.
+This releases all window system resources associated with XWIDGET,
+removes it from `xwidget-list', and detaches it from its buffer. */)
+ (Lisp_Object xwidget)
+{
+ struct xwidget *xw;
+
+ CHECK_LIVE_XWIDGET (xwidget);
+ xw = XXWIDGET (xwidget);
+
+ block_input ();
+ kill_xwidget (xw);
+ unblock_input ();
+
+ return Qnil;
+}
+
+#ifdef USE_GTK
+DEFUN ("xwidget-webkit-load-html", Fxwidget_webkit_load_html,
+ Sxwidget_webkit_load_html, 2, 3, 0,
+ doc: /* Make XWIDGET's WebKit widget render TEXT.
+XWIDGET should be a WebKit xwidget, that will receive TEXT. TEXT
+should be a string that will be displayed by XWIDGET as HTML markup.
+BASE-URI should be a string containing a URI that is used to locate
+resources with relative URLs, and if not specified, defaults
+to "about:blank". */)
+ (Lisp_Object xwidget, Lisp_Object text, Lisp_Object base_uri)
+{
+ struct xwidget *xw;
+ WebKitWebView *webview;
+ char *data, *uri;
+
+ CHECK_LIVE_XWIDGET (xwidget);
+ CHECK_STRING (text);
+ if (NILP (base_uri))
+ base_uri = build_string ("about:blank");
+ else
+ CHECK_STRING (base_uri);
+
+ base_uri = ENCODE_UTF_8 (base_uri);
+ text = ENCODE_UTF_8 (text);
+ xw = XXWIDGET (xwidget);
+ CHECK_WEBKIT_WIDGET (xw);
+
+ data = SSDATA (text);
+ uri = SSDATA (base_uri);
+ webview = WEBKIT_WEB_VIEW (xw->widget_osr);
+
+ block_input ();
+ webkit_web_view_load_html (webview, data, uri);
+ unblock_input ();
+
+ return Qnil;
+}
+
+DEFUN ("xwidget-webkit-back-forward-list", Fxwidget_webkit_back_forward_list,
+ Sxwidget_webkit_back_forward_list, 1, 2, 0,
+ doc: /* Return the navigation history of XWIDGET, a WebKit xwidget.
+
+Return the history as a list of the form (BACK HERE FORWARD), where
+HERE is the current navigation item, while BACK and FORWARD are lists
+of history items of the form (IDX TITLE URI). Here, IDX is an index
+that can be passed to `xwidget-webkit-goto-history', TITLE is a string
+containing the human-readable title of the history item, and URI is
+the URI of the history item.
+
+BACK, HERE, and FORWARD can all be nil depending on the state of the
+navigation history.
+
+BACK and FORWARD will each not contain more elements than LIMIT. If
+LIMIT is not specified or nil, it is treated as `50'. */)
+ (Lisp_Object xwidget, Lisp_Object limit)
+{
+ struct xwidget *xw;
+ Lisp_Object back, here, forward;
+ WebKitWebView *webview;
+ WebKitBackForwardList *list;
+ WebKitBackForwardListItem *item;
+ GList *parent, *tem;
+ int i;
+ unsigned int lim;
+ Lisp_Object title, uri;
+ const gchar *item_title, *item_uri;
+
+ back = Qnil;
+ here = Qnil;
+ forward = Qnil;
+
+ if (NILP (limit))
+ limit = make_fixnum (50);
+ else
+ CHECK_FIXNAT (limit);
+
+ CHECK_LIVE_XWIDGET (xwidget);
+ xw = XXWIDGET (xwidget);
+
+ webview = WEBKIT_WEB_VIEW (xw->widget_osr);
+ list = webkit_web_view_get_back_forward_list (webview);
+ item = webkit_back_forward_list_get_current_item (list);
+ lim = XFIXNAT (limit);
+
+ if (item)
+ {
+ item_title = webkit_back_forward_list_item_get_title (item);
+ item_uri = webkit_back_forward_list_item_get_uri (item);
+ here = list3 (make_fixnum (0),
+ build_string_from_utf8 (item_title ? item_title : ""),
+ build_string_from_utf8 (item_uri ? item_uri : ""));
+ }
+ parent = webkit_back_forward_list_get_back_list_with_limit (list, lim);
+
+ if (parent)
+ {
+ for (i = 1, tem = parent; tem; tem = tem->next, ++i)
+ {
+ item = tem->data;
+ item_title = webkit_back_forward_list_item_get_title (item);
+ item_uri = webkit_back_forward_list_item_get_uri (item);
+ title = build_string_from_utf8 (item_title ? item_title : "");
+ uri = build_string_from_utf8 (item_uri ? item_uri : "");
+ back = Fcons (list3 (make_fixnum (-i), title, uri), back);
+ }
+ }
+
+ back = Fnreverse (back);
+ g_list_free (parent);
+
+ parent = webkit_back_forward_list_get_forward_list_with_limit (list, lim);
+
+ if (parent)
+ {
+ for (i = 1, tem = parent; tem; tem = tem->next, ++i)
+ {
+ item = tem->data;
+ item_title = webkit_back_forward_list_item_get_title (item);
+ item_uri = webkit_back_forward_list_item_get_uri (item);
+ title = build_string_from_utf8 (item_title ? item_title : "");
+ uri = build_string_from_utf8 (item_uri ? item_uri : "");
+ forward = Fcons (list3 (make_fixnum (i), title, uri), forward);
+ }
+ }
+
+ forward = Fnreverse (forward);
+ g_list_free (parent);
+
+ return list3 (back, here, forward);
+}
+
+DEFUN ("xwidget-webkit-estimated-load-progress",
+ Fxwidget_webkit_estimated_load_progress, Sxwidget_webkit_estimated_load_progress,
+ 1, 1, 0, doc: /* Get the estimated load progress of XWIDGET, a WebKit widget.
+Return a value ranging from 0.0 to 1.0, based on how close XWIDGET
+is to completely loading its page. */)
+ (Lisp_Object xwidget)
+{
+ struct xwidget *xw;
+ WebKitWebView *webview;
+ double value;
+
+ CHECK_LIVE_XWIDGET (xwidget);
+ xw = XXWIDGET (xwidget);
+ CHECK_WEBKIT_WIDGET (xw);
+
+ block_input ();
+ webview = WEBKIT_WEB_VIEW (xw->widget_osr);
+ value = webkit_web_view_get_estimated_load_progress (webview);
+ unblock_input ();
+
+ return make_float (value);
+}
+#endif
+
+DEFUN ("xwidget-webkit-set-cookie-storage-file",
+ Fxwidget_webkit_set_cookie_storage_file, Sxwidget_webkit_set_cookie_storage_file,
+ 2, 2, 0, doc: /* Make the WebKit widget XWIDGET load and store cookies in FILE.
+
+Cookies will be stored as plain text in FILE, which must be an
+absolute file name. All xwidgets related to XWIDGET will also
+store cookies in FILE and load them from there. */)
+ (Lisp_Object xwidget, Lisp_Object file)
+{
+#ifdef USE_GTK
+ struct xwidget *xw;
+ WebKitWebView *webview;
+ WebKitWebContext *context;
+ WebKitCookieManager *manager;
+
+ CHECK_LIVE_XWIDGET (xwidget);
+ xw = XXWIDGET (xwidget);
+ CHECK_WEBKIT_WIDGET (xw);
+ CHECK_STRING (file);
+
+ block_input ();
+ webview = WEBKIT_WEB_VIEW (xw->widget_osr);
+ context = webkit_web_view_get_context (webview);
+ manager = webkit_web_context_get_cookie_manager (context);
+ webkit_cookie_manager_set_persistent_storage (manager,
+ SSDATA (ENCODE_UTF_8 (file)),
+ WEBKIT_COOKIE_PERSISTENT_STORAGE_TEXT);
+ unblock_input ();
+#endif
+
+ return Qnil;
+}
+
+DEFUN ("xwidget-webkit-stop-loading", Fxwidget_webkit_stop_loading,
+ Sxwidget_webkit_stop_loading,
+ 1, 1, 0, doc: /* Stop loading data in the WebKit widget XWIDGET.
+This will stop any data transfer that may still be in progress inside
+XWIDGET as part of loading a page. */)
+ (Lisp_Object xwidget)
+{
+#ifdef USE_GTK
+ struct xwidget *xw;
+ WebKitWebView *webview;
+
+ CHECK_LIVE_XWIDGET (xwidget);
+ xw = XXWIDGET (xwidget);
+ CHECK_WEBKIT_WIDGET (xw);
+
+ block_input ();
+ webview = WEBKIT_WEB_VIEW (xw->widget_osr);
+ webkit_web_view_stop_loading (webview);
+ unblock_input ();
+#endif
+
+ return Qnil;
+}
+
void
syms_of_xwidget (void)
{
defsubr (&Smake_xwidget);
defsubr (&Sxwidgetp);
+ defsubr (&Sxwidget_live_p);
DEFSYM (Qxwidgetp, "xwidgetp");
+ DEFSYM (Qxwidget_live_p, "xwidget-live-p");
defsubr (&Sxwidget_view_p);
DEFSYM (Qxwidget_view_p, "xwidget-view-p");
defsubr (&Sxwidget_info);
@@ -1215,6 +2880,20 @@ syms_of_xwidget (void)
defsubr (&Sxwidget_plist);
defsubr (&Sxwidget_buffer);
defsubr (&Sset_xwidget_plist);
+ defsubr (&Sxwidget_perform_lispy_event);
+ defsubr (&Sxwidget_webkit_search);
+ defsubr (&Sxwidget_webkit_finish_search);
+ defsubr (&Sxwidget_webkit_next_result);
+ defsubr (&Sxwidget_webkit_previous_result);
+ defsubr (&Sset_xwidget_buffer);
+ defsubr (&Sxwidget_webkit_set_cookie_storage_file);
+ defsubr (&Sxwidget_webkit_stop_loading);
+#ifdef USE_GTK
+ defsubr (&Sxwidget_webkit_load_html);
+ defsubr (&Sxwidget_webkit_back_forward_list);
+ defsubr (&Sxwidget_webkit_estimated_load_progress);
+#endif
+ defsubr (&Skill_xwidget);
DEFSYM (QCxwidget, ":xwidget");
DEFSYM (QCtitle, ":title");
@@ -1228,14 +2907,29 @@ syms_of_xwidget (void)
DEFSYM (QCplist, ":plist");
DEFVAR_LISP ("xwidget-list", Vxwidget_list,
- doc: /* xwidgets list. */);
+ doc: /* List of all xwidgets that have not been killed. */);
Vxwidget_list = Qnil;
DEFVAR_LISP ("xwidget-view-list", Vxwidget_view_list,
- doc: /* xwidget views list. */);
+ doc: /* List of all xwidget views. */);
Vxwidget_view_list = Qnil;
Fprovide (intern ("xwidget-internal"), Qnil);
+
+ id_to_xwidget_map = CALLN (Fmake_hash_table, QCtest, Qeq,
+ QCweakness, Qvalue);
+ staticpro (&id_to_xwidget_map);
+
+ internal_xwidget_list = Qnil;
+ staticpro (&internal_xwidget_list);
+ internal_xwidget_view_list = Qnil;
+ staticpro (&internal_xwidget_view_list);
+
+#ifdef USE_GTK
+ x_window_to_xwv_map = CALLN (Fmake_hash_table, QCtest, Qeq);
+
+ staticpro (&x_window_to_xwv_map);
+#endif
}
@@ -1276,7 +2970,7 @@ void
xwidget_view_delete_all_in_window (struct window *w)
{
struct xwidget_view *xv = NULL;
- for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail);
+ for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail);
tail = XCDR (tail))
{
if (XWIDGET_VIEW_P (XCAR (tail)))
@@ -1321,7 +3015,7 @@ lookup_xwidget (Lisp_Object spec)
static void
xwidget_start_redisplay (void)
{
- for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail);
+ for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail);
tail = XCDR (tail))
{
if (XWIDGET_VIEW_P (XCAR (tail)))
@@ -1374,25 +3068,22 @@ xwidget_end_redisplay (struct window *w, struct glyph_matrix *matrix)
/* The only call to xwidget_end_redisplay is in dispnew.
xwidget_end_redisplay (w->current_matrix); */
struct xwidget_view *xv
- = xwidget_view_lookup (glyph->u.xwidget, w);
-#ifdef USE_GTK
- /* FIXME: Is it safe to assume xwidget_view_lookup
- always succeeds here? If so, this comment can be removed.
- If not, the code probably needs fixing. */
- eassume (xv);
- xwidget_touch (xv);
-#elif defined NS_IMPL_COCOA
- /* In NS xwidget, xv can be NULL for the second or
+ = xwidget_view_lookup (xwidget_from_id (glyph->u.xwidget), w);
+
+ /* In NS xwidget, xv can be NULL for the second or
later views for a model, the result of 1 to 1
- model view relation enforcement. */
+ model view relation enforcement. `xwidget_view_lookup'
+ has also been observed to return NULL here on X-Windows
+ at least once, so stay safe and only touch it if it's
+ not NULL. */
+
if (xv)
xwidget_touch (xv);
-#endif
}
}
}
- for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail);
+ for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail);
tail = XCDR (tail))
{
if (XWIDGET_VIEW_P (XCAR (tail)))
@@ -1424,6 +3115,78 @@ xwidget_end_redisplay (struct window *w, struct glyph_matrix *matrix)
}
}
+#ifdef USE_GTK
+void
+lower_frame_xwidget_views (struct frame *f)
+{
+ struct xwidget_view *xv;
+
+ for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail);
+ tail = XCDR (tail))
+ {
+ xv = XXWIDGET_VIEW (XCAR (tail));
+ if (xv->frame == f && xv->wdesc != None)
+ XLowerWindow (xv->dpy, xv->wdesc);
+ }
+}
+
+void
+kill_frame_xwidget_views (struct frame *f)
+{
+ Lisp_Object rem = Qnil;
+
+ for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail);
+ tail = XCDR (tail))
+ {
+ if (XWIDGET_VIEW_P (XCAR (tail))
+ && XXWIDGET_VIEW (XCAR (tail))->frame == f)
+ rem = Fcons (XCAR (tail), rem);
+ }
+
+ for (; CONSP (rem); rem = XCDR (rem))
+ Fdelete_xwidget_view (XCAR (rem));
+}
+#endif
+
+static void
+kill_xwidget (struct xwidget *xw)
+{
+ Lisp_Object val;
+ XSETXWIDGET (val, xw);
+
+ internal_xwidget_list = Fdelq (val, internal_xwidget_list);
+ Vxwidget_list = Fcopy_sequence (internal_xwidget_list);
+#ifdef USE_GTK
+ xw->buffer = Qnil;
+
+ if (xw->widget_osr && xw->widgetwindow_osr)
+ {
+ gtk_widget_destroy (xw->widget_osr);
+ gtk_widget_destroy (xw->widgetwindow_osr);
+ }
+
+ if (xw->find_text)
+ xfree (xw->find_text);
+
+ if (!NILP (xw->script_callbacks))
+ {
+ for (ptrdiff_t idx = 0; idx < ASIZE (xw->script_callbacks); idx++)
+ {
+ Lisp_Object cb = AREF (xw->script_callbacks, idx);
+ if (!NILP (cb))
+ xfree (xmint_pointer (XCAR (cb)));
+ ASET (xw->script_callbacks, idx, Qnil);
+ }
+ }
+
+ xw->widget_osr = NULL;
+ xw->widgetwindow_osr = NULL;
+ xw->find_text = NULL;
+#elif defined NS_IMPL_COCOA
+ nsxwidget_kill (xw);
+#endif
+}
+
/* Kill all xwidget in BUFFER. */
void
kill_buffer_xwidgets (Lisp_Object buffer)
@@ -1432,28 +3195,11 @@ kill_buffer_xwidgets (Lisp_Object buffer)
for (tail = Fget_buffer_xwidgets (buffer); CONSP (tail); tail = XCDR (tail))
{
xwidget = XCAR (tail);
- Vxwidget_list = Fdelq (xwidget, Vxwidget_list);
- /* TODO free the GTK things in xw. */
{
- CHECK_XWIDGET (xwidget);
+ CHECK_LIVE_XWIDGET (xwidget);
struct xwidget *xw = XXWIDGET (xwidget);
-#ifdef USE_GTK
- if (xw->widget_osr && xw->widgetwindow_osr)
- {
- gtk_widget_destroy (xw->widget_osr);
- gtk_widget_destroy (xw->widgetwindow_osr);
- }
- if (!NILP (xw->script_callbacks))
- for (ptrdiff_t idx = 0; idx < ASIZE (xw->script_callbacks); idx++)
- {
- Lisp_Object cb = AREF (xw->script_callbacks, idx);
- if (!NILP (cb))
- xfree (xmint_pointer (XCAR (cb)));
- ASET (xw->script_callbacks, idx, Qnil);
- }
-#elif defined NS_IMPL_COCOA
- nsxwidget_kill (xw);
-#endif
+
+ kill_xwidget (xw);
}
}
}
diff --git a/src/xwidget.h b/src/xwidget.h
index 591f23489db..a03006fde9a 100644
--- a/src/xwidget.h
+++ b/src/xwidget.h
@@ -32,6 +32,8 @@ struct window;
#if defined (USE_GTK)
#include <gtk/gtk.h>
+#include <X11/Xlib.h>
+#include "xterm.h"
#elif defined (NS_IMPL_COCOA) && defined (__OBJC__)
#import <AppKit/NSView.h>
#import "nsxwidget.h"
@@ -59,11 +61,16 @@ struct xwidget
int height;
int width;
+ uint32_t xwidget_id;
+ char *find_text;
#if defined (USE_GTK)
/* For offscreen widgets, unused if not osr. */
GtkWidget *widget_osr;
GtkWidget *widgetwindow_osr;
+ struct frame *embedder;
+ struct xwidget_view *embedder_view;
+ guint hit_result;
#elif defined (NS_IMPL_COCOA)
# ifdef __OBJC__
/* For offscreen widgets, unused if not osr. */
@@ -97,10 +104,17 @@ struct xwidget_view
/* The "live" instance isn't drawn. */
bool hidden;
+ enum glyph_row_area area;
+
#if defined (USE_GTK)
- GtkWidget *widget;
- GtkWidget *widgetwindow;
- GtkWidget *emacswindow;
+ Display *dpy;
+ Window wdesc;
+ Emacs_Cursor cursor;
+ struct frame *frame;
+
+ cairo_surface_t *cr_surface;
+ cairo_t *cr_context;
+ int just_resized;
#elif defined (NS_IMPL_COCOA)
# ifdef __OBJC__
XvWindow *xvWindow;
@@ -127,9 +141,16 @@ struct xwidget_view
#define XXWIDGET(a) (eassert (XWIDGETP (a)), \
XUNTAG (a, Lisp_Vectorlike, struct xwidget))
+#define XWIDGET_LIVE_P(w) (!NILP ((w)->buffer))
+
#define CHECK_XWIDGET(x) \
CHECK_TYPE (XWIDGETP (x), Qxwidgetp, x)
+#define CHECK_LIVE_XWIDGET(x) \
+ CHECK_TYPE ((XWIDGETP (x) \
+ && XWIDGET_LIVE_P (XXWIDGET (x))), \
+ Qxwidget_live_p, x)
+
/* Test for xwidget_view pseudovector. */
#define XWIDGET_VIEW_P(x) PSEUDOVECTORP (x, PVEC_XWIDGET_VIEW)
#define XXWIDGET_VIEW(a) (eassert (XWIDGET_VIEW_P (a)), \
@@ -162,6 +183,25 @@ void store_xwidget_download_callback_event (struct xwidget *xw,
void store_xwidget_js_callback_event (struct xwidget *xw,
Lisp_Object proc,
Lisp_Object argument);
+
+extern struct xwidget *xwidget_from_id (uint32_t id);
+
+#ifdef HAVE_X_WINDOWS
+struct xwidget_view *xwidget_view_from_window (Window wdesc);
+void xwidget_expose (struct xwidget_view *xv);
+extern void lower_frame_xwidget_views (struct frame *f);
+extern void kill_frame_xwidget_views (struct frame *f);
+extern void xwidget_button (struct xwidget_view *, bool, int,
+ int, int, int, Time);
+extern void xwidget_motion_or_crossing (struct xwidget_view *,
+ const XEvent *);
+#ifdef HAVE_XINPUT2
+extern void xwidget_motion_notify (struct xwidget_view *, double,
+ double, uint, Time);
+extern void xwidget_scroll (struct xwidget_view *, double, double,
+ double, double, uint, Time, bool);
+#endif
+#endif
#else
INLINE_HEADER_BEGIN
INLINE void syms_of_xwidget (void) {}
diff --git a/test/Makefile.in b/test/Makefile.in
index bb32ef672db..eeda2918fa3 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -31,7 +31,7 @@
SHELL = @SHELL@
srcdir = @srcdir@
-abs_top_srcdir=@abs_top_srcdir@
+abs_top_srcdir = @abs_top_srcdir@
top_builddir = @top_builddir@
VPATH = $(srcdir)
@@ -67,7 +67,7 @@ elpa_opts = $(foreach el,$(elpa_els),$(and $(wildcard $(el)),-L $(dir $(el)) -l
# directory, we can use emacs --chdir.
EMACS = ../src/emacs
-EMACS_EXTRAOPT=
+EMACS_EXTRAOPT =
# Command line flags for Emacs.
# Apparently MSYS bash would convert "-L :" to "-L ;" anyway,
@@ -77,9 +77,14 @@ EMACSOPT = --no-init-file --no-site-file --no-site-lisp -L "$(SEPCHAR)$(srcdir)"
# Prevent any settings in the user environment causing problems.
unexport EMACSDATA EMACSDOC EMACSPATH GREP_OPTIONS XDG_CONFIG_HOME
-## To run tests under a debugger, set this to eg: "gdb --args".
+# To run tests under a debugger, set this to eg: "gdb --args".
GDB =
+# Whether a timeout shall be given, writing possibly a core dump.
+ifneq (${EMACS_TEST_TIMEOUT},)
+TEST_TIMEOUT = timeout -s ABRT ${EMACS_TEST_TIMEOUT}
+endif
+
# Set this to 'yes' to run the tests in an interactive instance.
TEST_INTERACTIVE ?= no
@@ -117,7 +122,7 @@ endif
# and prevent locals to influence the text of the errors we expect to receive.
emacs = LANG=C EMACSLOADPATH= \
EMACS_TEST_DIRECTORY=$(abspath $(srcdir)) \
- $(GDB) "$(EMACS)" $(MODULES_EMACSOPT) $(EMACSOPT)
+ $(GDB) $(TEST_TIMEOUT) "$(EMACS)" $(MODULES_EMACSOPT) $(EMACSOPT)
# Set HOME to a nonexistent directory to prevent tests from accessing
# it accidentally (e.g., popping up a gnupg dialog if ~/.authinfo.gpg
@@ -167,7 +172,7 @@ lisp/net/tramp-tests.log \
: WRITE_LOG = 2>&1 | tee $@
endif
ifdef EMACS_EMBA_CI
-lisp/filenotify-tests.log lisp/net/tramp-tests.log src/emacs-module-tests.el \
+lisp/filenotify-tests.log lisp/net/tramp-tests.log src/emacs-module-tests.log \
: WRITE_LOG = 2>&1 | tee $@
endif
@@ -247,9 +252,12 @@ endef
$(foreach test,${TESTS},$(eval $(call test_template,${test})))
## Get the tests for only a specific directory.
-SUBDIRS = $(sort $(shell cd ${srcdir} && find lib-src lisp misc src -type d ! -path "*resources*" -print))
+SUBDIRS = $(sort $(shell cd ${srcdir} && find lib-src lisp misc src -type d \
+ ! \( -path "*resources*" -o -path "*auto-save-list" \) -print))
+SUBDIR_TARGETS =
define subdir_template
+ SUBDIR_TARGETS += check-$(subst /,-,$(1))
.PHONY: check-$(subst /,-,$(1))
check-$(subst /,-,$(1)):
@${MAKE} check LOGFILES="$(patsubst %.el,%.log, \
@@ -345,6 +353,7 @@ mostlyclean:
clean:
find . '(' -name '*.log' -o -name '*.log~' ')' $(FIND_DELETE)
+ find . '(' -name '*.xml' -a ! -path '*resources*' ')' $(FIND_DELETE)
rm -f ${srcdir}/lisp/gnus/mml-sec-resources/random_seed
rm -f $(test_module_dir)/*.o $(test_module_dir)/*.so \
$(test_module_dir)/*.dll
@@ -362,3 +371,14 @@ maintainer-clean: distclean bootstrap-clean
check-declare:
$(emacs) --batch -l check-declare \
--eval '(check-declare-directory "$(srcdir)")'
+
+.PHONY: subdirs subdir-targets generate-test-jobs
+
+subdirs:
+ @echo $(SUBDIRS)
+
+subdir-targets:
+ @echo $(SUBDIR_TARGETS)
+
+generate-test-jobs:
+ @$(MAKE) -C infra generate-test-jobs SUBDIRS="$(SUBDIRS)"
diff --git a/test/README b/test/README
index a0961249cfa..2bd84b5f9b3 100644
--- a/test/README
+++ b/test/README
@@ -114,6 +114,9 @@ mode--only the names of the failed tests are listed. If the
$EMACS_TEST_VERBOSE environment variable is set, the failure summaries
will also include the data from the failing test.
+If the $EMACS_TEST_JUNIT_REPORT environment variable is set to a file
+name, a JUnit test report is generated under this name.
+
Some of the tests require a remote temporary directory
(autorevert-tests.el, filenotify-tests.el, shadowfile-tests.el and
tramp-tests.el). Per default, a mock-up connection method is used
@@ -140,6 +143,11 @@ these test environments.
$EMACS_HYDRA_CI indicates the hydra environment, and $EMACS_EMBA_CI
indicates the emba environment, respectively.
+If tests on these premises take too long, and it is needed to create a
+core dump for further analysis, the environment variable
+$EMACS_TEST_TIMEOUT could set a limit (in seconds) when this shall
+happen.
+
(Also, see etc/compilation.txt for compilation mode font lock tests
and etc/grep.txt for grep mode font lock tests.)
diff --git a/test/data/image/black.gif b/test/data/image/black.gif
new file mode 100644
index 00000000000..6ab623e367e
--- /dev/null
+++ b/test/data/image/black.gif
Binary files differ
diff --git a/test/data/image/black.webp b/test/data/image/black.webp
new file mode 100644
index 00000000000..5dbe716415b
--- /dev/null
+++ b/test/data/image/black.webp
Binary files differ
diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba
index 71b4e76865f..aef68c6e81e 100644
--- a/test/infra/Dockerfile.emba
+++ b/test/infra/Dockerfile.emba
@@ -29,7 +29,7 @@ FROM debian:stretch as 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 \
+ libdbus-1-dev libacl1-dev acl git texinfo gdb \
&& rm -rf /var/lib/apt/lists/*
FROM emacs-base as emacs-inotify
@@ -72,14 +72,14 @@ RUN ./autogen.sh autoconf
RUN ./configure --with-ns
RUN make bootstrap
-FROM emacs-base as emacs-native-comp-speed0
+FROM emacs-base as emacs-native-comp
RUN apt-get update && \
apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \
libgccjit-6-dev \
&& rm -rf /var/lib/apt/lists/*
-ARG make_bootstrap_params=""
+FROM emacs-native-comp as emacs-native-comp-speed0
COPY . /checkout
WORKDIR /checkout
@@ -87,3 +87,19 @@ RUN ./autogen.sh autoconf
RUN ./configure --with-native-compilation
RUN make bootstrap -j2 \
NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"'
+
+FROM emacs-native-comp as emacs-native-comp-speed1
+
+COPY . /checkout
+WORKDIR /checkout
+RUN ./autogen.sh autoconf
+RUN ./configure --with-native-compilation
+RUN make bootstrap -j2 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"'
+
+FROM emacs-native-comp as emacs-native-comp-speed2
+
+COPY . /checkout
+WORKDIR /checkout
+RUN ./autogen.sh autoconf
+RUN ./configure --with-native-compilation
+RUN make bootstrap -j2
diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in
new file mode 100644
index 00000000000..368be7392b2
--- /dev/null
+++ b/test/infra/Makefile.in
@@ -0,0 +1,100 @@
+### @configure_input@
+
+# Copyright (C) 2021 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:
+
+## Generate the test-jobs.yml file for emba.
+
+### Code:
+
+SHELL = @SHELL@
+
+top_builddir = @top_builddir@
+
+-include ${top_builddir}/src/verbose.mk
+
+## Get the tests for only a specific directory.
+SUBDIRS ?= $(shell make -s -C .. subdirs)
+SUBDIR_TARGETS =
+FILE = test-jobs.yml
+tn = $$$${test_name}
+cps = $$$$CI_PIPELINE_SOURCE
+
+define subdir_template
+ $(eval target = check-$(subst /,-,$(1)))
+ SUBDIR_TARGETS += $(target)
+
+ $(eval
+ ifeq ($(findstring src, $(1)), src)
+ define changes
+ @echo ' - $(1)/*.{h,c}' >>$(FILE)
+ endef
+ else ifeq ($(findstring eieio, $(1)), eieio)
+ define changes
+ @echo ' - lisp/emacs-lisp/eieio*.el' >>$(FILE)
+ endef
+ else ifeq ($(findstring faceup, $(1)), faceup)
+ define changes
+ @echo ' - lisp/emacs-lisp/faceup*.el' >>$(FILE)
+ endef
+ else ifeq ($(findstring so-long, $(1)), so-long)
+ define changes
+ @echo ' - lisp/so-long*.el' >>$(FILE)
+ endef
+ else ifeq ($(findstring misc, $(1)), misc)
+ define changes
+ @echo ' - admin/*.el' >>$(FILE)
+ endef
+ else
+ define changes
+ @echo ' - $(1)/*.el' >>$(FILE)
+ endef
+ endif)
+
+ $(target):
+ @echo >>$(FILE)
+ @echo 'test-$(subst /,-,$(1))-inotify:' >>$(FILE)
+ @echo ' stage: normal' >>$(FILE)
+ @echo ' extends: [.job-template, .test-template]' >>$(FILE)
+ @echo ' needs:' >>$(FILE)
+ @echo ' - job: build-image-inotify' >>$(FILE)
+ @echo ' optional: true' >>$(FILE)
+ @echo ' rules:' >>$(FILE)
+ @echo " - if: '"'${cps} == "schedule"'"'" >>$(FILE)
+ @echo ' when: never' >>$(FILE)
+ @echo ' - changes:' >>$(FILE)
+ $(changes)
+ @echo ' - test/$(1)/*.el' >>$(FILE)
+ @echo ' - test/$(1)/*resources/**' >>$(FILE)
+ @echo ' variables:' >>$(FILE)
+ @echo ' target: emacs-inotify' >>$(FILE)
+ @echo ' make_params: "-k -C test $(target)"' >>$(FILE)
+endef
+
+$(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir))))
+
+all: generate-test-jobs
+
+.PHONY: generate-test-jobs $(FILE) $(SUBDIR_TARGETS)
+
+generate-test-jobs: $(FILE) $(SUBDIR_TARGETS)
+
+$(FILE):
+ $(AM_V_GEN)
+ @echo "# Generated by \"make generate-test-jobs\", don't edit." >$(FILE)
diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml
index b233c0fbc54..dd3f517e74a 100644
--- a/test/infra/gitlab-ci.yml
+++ b/test/infra/gitlab-ci.yml
@@ -15,7 +15,7 @@
# You should have received a copy of the GNU General Public License
# along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-# GNU Emacs support for the GitLab protocol for CI
+# GNU Emacs support for the GitLab protocol for CI.
# The presence of this file does not imply any FSF/GNU endorsement of
# any particular service that uses that protocol. Also, it is intended for
@@ -44,8 +44,10 @@ workflow:
variables:
GIT_STRATEGY: fetch
EMACS_EMBA_CI: 1
+ EMACS_TEST_JUNIT_REPORT: junit-test-report.xml
+ EMACS_TEST_TIMEOUT: 3600
EMACS_TEST_VERBOSE: 1
- # # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled
+ # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled
# DOCKER_HOST: tcp://docker:2376
# DOCKER_TLS_CERTDIR: "/certs"
# Put the configuration for each run in a separate directory to
@@ -55,6 +57,8 @@ variables:
# We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap
# across multiple builds.
BUILD_TAG: ${CI_COMMIT_REF_SLUG}
+ # Disable if you don't need it, it can be a security risk.
+ # CI_DEBUG_TRACE: "true"
default:
image: docker:19.03.12
@@ -67,31 +71,6 @@ default:
.job-template:
variables:
test_name: ${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}
- rules:
- - changes:
- - "**/Makefile.in"
- - .gitlab-ci.yml
- - aclocal.m4
- - autogen.sh
- - configure.ac
- - lib/*.{h,c}
- - lisp/**/*.el
- - src/*.{h,c}
- - test/infra/*
- - test/lib-src/*.el
- - test/lisp/**/*.el
- - test/src/*.el
- - changes:
- # gfilemonitor, kqueue
- - src/gfilenotify.c
- - src/kqueue.c
- # MS Windows
- - "**/w32*"
- # GNUstep
- - lisp/term/ns-win.el
- - src/ns*.{h,m}
- - src/macfont.{h,m}
- when: never
# These will be cached across builds.
cache:
key: ${CI_COMMIT_SHA}
@@ -107,25 +86,31 @@ 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} --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 -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}"'
after_script:
# - docker ps -a
# - printenv
# - test -n "$(docker ps -aq -f name=${test_name})" && ( docker export ${test_name} | tar -tvf - )
+ # Prepare test artifacts.
- test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name}
- test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name}
+ - find ${test_name} ! \( -name "*.log" -o -name ${EMACS_TEST_JUNIT_REPORT} \) -type f -delete
+ # BusyBox find does not know -empty.
+ - find ${test_name} -type d -depth -exec rmdir {} + 2>/dev/null
.build-template:
+ needs: []
rules:
- if: '$CI_PIPELINE_SOURCE == "web"'
when: always
- changes:
- - "**/Makefile.in"
- - .gitlab-ci.yml
+ - "**.in"
+ - GNUmakefile
- aclocal.m4
- autogen.sh
- configure.ac
- lib/*.{h,c}
+ - lib/malloc/*.{h,c}
- lisp/emacs-lisp/*.el
- src/*.{h,c}
- test/infra/*
@@ -134,7 +119,7 @@ default:
- src/gfilenotify.c
- src/kqueue.c
# MS Windows
- - "**/w32*"
+ - "**w32*"
# GNUstep
- lisp/term/ns-win.el
- src/ns*.{h,m}
@@ -145,32 +130,26 @@ default:
- docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG}
.test-template:
- # Do not block later stages.
- allow_failure: true
- # Do not run fast and normal test jobs when scheduled.
- rules:
- - if: '$CI_JOB_STAGE =~ "fast|normal" && $CI_PIPELINE_SOURCE == "schedule"'
- when: never
- - when: always
artifacts:
name: ${test_name}
public: true
expire_in: 1 week
+ when: always
paths:
- - "${test_name}/**/*.log"
+ - ${test_name}/
+ reports:
+ junit: ${test_name}/${EMACS_TEST_JUNIT_REPORT}
.gnustep-template:
rules:
- if: '$CI_PIPELINE_SOURCE == "web"'
- if: '$CI_PIPELINE_SOURCE == "schedule"'
changes:
- - "**/Makefile.in"
- - .gitlab-ci.yml
- - configure.ac
+ - "**.in"
- src/ns*.{h,m}
- src/macfont.{h,m}
- lisp/term/ns-win.el
- - nextstep/**/*
+ - nextstep/**
- test/infra/*
.filenotify-gio-template:
@@ -178,8 +157,7 @@ default:
- if: '$CI_PIPELINE_SOURCE == "web"'
- if: '$CI_PIPELINE_SOURCE == "schedule"'
changes:
- - "**/Makefile.in"
- - .gitlab-ci.yml
+ - "**.in"
- lisp/autorevert.el
- lisp/filenotify.el
- lisp/net/tramp-sh.el
@@ -193,8 +171,7 @@ default:
- if: '$CI_PIPELINE_SOURCE == "web"'
- if: '$CI_PIPELINE_SOURCE == "schedule"'
changes:
- - "**/Makefile.in"
- - .gitlab-ci.yml
+ - "**.in"
- lisp/emacs-lisp/comp.el
- lisp/emacs-lisp/comp-cstr.el
- src/comp.{h,m}
@@ -205,13 +182,11 @@ default:
stages:
- build-images
-# - fast
- normal
- platform-images
- platforms
- native-comp-images
- native-comp
- - slow
build-image-inotify:
stage: build-images
@@ -219,26 +194,22 @@ build-image-inotify:
variables:
target: emacs-inotify
-# test-fast-inotify:
-# stage: fast
-# extends: [.job-template, .test-template]
-# variables:
-# target: emacs-inotify
-# make_params: "-C test check"
-
-test-lisp-inotify:
- stage: normal
- extends: [.job-template, .test-template]
- variables:
- target: emacs-inotify
- make_params: "-C test check-lisp"
+include: '/test/infra/test-jobs.yml'
-test-lisp-net-inotify:
+test-all-inotify:
+ # This tests also file monitor libraries inotify and inotifywatch.
stage: normal
extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ # Note there's no "changes" section, so this always runs on a schedule.
+ - if: '$CI_PIPELINE_SOURCE == "web"'
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
variables:
target: emacs-inotify
- make_params: "-C test check-lisp-net"
+ make_params: check-expensive
build-image-filenotify-gio:
stage: platform-images
@@ -246,80 +217,62 @@ build-image-filenotify-gio:
variables:
target: emacs-filenotify-gio
-build-image-gnustep:
- stage: platform-images
- extends: [.job-template, .build-template, .gnustep-template]
- variables:
- target: emacs-gnustep
-
test-filenotify-gio:
# This tests file monitor libraries gfilemonitor and gio.
stage: platforms
- needs: [build-image-filenotify-gio]
extends: [.job-template, .test-template, .filenotify-gio-template]
+ needs:
+ - job: build-image-filenotify-gio
+ optional: true
variables:
target: emacs-filenotify-gio
- make_params: "-k -C test autorevert-tests.log filenotify-tests.log"
+ # 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-gnustep:
+ stage: platform-images
+ extends: [.job-template, .build-template, .gnustep-template]
+ variables:
+ target: emacs-gnustep
test-gnustep:
# This tests the GNUstep build process.
stage: platforms
- needs: [build-image-gnustep]
extends: [.job-template, .gnustep-template]
+ needs:
+ - job: build-image-gnustep
+ optional: true
variables:
target: emacs-gnustep
make_params: install
-build-native-bootstrap-speed0:
+build-native-comp-speed0:
stage: native-comp-images
extends: [.job-template, .build-template, .native-comp-template]
variables:
target: emacs-native-comp-speed0
-# build-native-bootstrap-speed0:
-# # Test a full native bootstrap
-# # Run for now only speed 0 to limit memory usage and compilation time.
-# stage: native-comp-images
-# # Uncomment the following to run it only when scheduled.
-# # only:
-# # - schedules
-# script:
-# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev
-# - ./autogen.sh autoconf
-# - ./configure --with-native-compilation
-# - make bootstrap NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2
-# timeout: 8 hours
-
-# build-native-bootstrap-speed1:
-# stage: native-comp-images
-# script:
-# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev
-# - ./autogen.sh autoconf
-# - ./configure --with-native-compilation
-# - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"'
-# timeout: 8 hours
+build-native-comp-speed1:
+ stage: native-comp-images
+ extends: [.job-template, .build-template, .native-comp-template]
+ variables:
+ target: emacs-native-comp-speed1
-# build-native-bootstrap-speed2:
-# stage: native-comp-images
-# script:
-# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev
-# - ./autogen.sh autoconf
-# - ./configure --with-native-compilation
-# - make bootstrap
-# timeout: 8 hours
+build-native-comp-speed2:
+ stage: native-comp-images
+ extends: [.job-template, .build-template, .native-comp-template]
+ variables:
+ target: emacs-native-comp-speed2
-test-all-inotify:
- # This tests also file monitor libraries inotify and inotifywatch.
- stage: slow
- needs: [build-image-inotify]
- extends: [.job-template, .test-template]
- rules:
- # Note there's no "changes" section, so this always runs on a schedule.
- - if: '$CI_PIPELINE_SOURCE == "web"'
- - if: '$CI_PIPELINE_SOURCE == "schedule"'
+test-native-comp-speed0:
+ stage: native-comp
+ extends: [.job-template, .test-template, .native-comp-template]
+ needs:
+ - job: build-native-comp-speed0
+ optional: true
variables:
- target: emacs-inotify
- make_params: check-expensive
+ target: emacs-native-comp-speed0
+ make_params: "-k -C test check SELECTOR='(not (tag :unstable))'"
# Local Variables:
# add-log-current-defun-header-regexp: "^\\([-_.[:alnum:]]+\\)[ \t]*:"
diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml
new file mode 100644
index 00000000000..51707c181b1
--- /dev/null
+++ b/test/infra/test-jobs.yml
@@ -0,0 +1,545 @@
+# Generated by "make generate-test-jobs", don't edit.
+
+test-lib-src-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lib-src/*.{h,c}
+ - test/lib-src/*.el
+ - test/lib-src/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lib-src"
+
+test-lisp-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/*.el
+ - test/lisp/*.el
+ - test/lisp/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp"
+
+test-lisp-calc-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/calc/*.el
+ - test/lisp/calc/*.el
+ - test/lisp/calc/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-calc"
+
+test-lisp-calendar-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/calendar/*.el
+ - test/lisp/calendar/*.el
+ - test/lisp/calendar/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-calendar"
+
+test-lisp-cedet-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/cedet/*.el
+ - test/lisp/cedet/*.el
+ - test/lisp/cedet/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-cedet"
+
+test-lisp-cedet-semantic-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/cedet/semantic/*.el
+ - test/lisp/cedet/semantic/*.el
+ - test/lisp/cedet/semantic/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-cedet-semantic"
+
+test-lisp-cedet-semantic-bovine-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/cedet/semantic/bovine/*.el
+ - test/lisp/cedet/semantic/bovine/*.el
+ - test/lisp/cedet/semantic/bovine/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-cedet-semantic-bovine"
+
+test-lisp-cedet-srecode-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/cedet/srecode/*.el
+ - test/lisp/cedet/srecode/*.el
+ - test/lisp/cedet/srecode/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-cedet-srecode"
+
+test-lisp-emacs-lisp-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/emacs-lisp/*.el
+ - test/lisp/emacs-lisp/*.el
+ - test/lisp/emacs-lisp/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-emacs-lisp"
+
+test-lisp-emacs-lisp-eieio-tests-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/emacs-lisp/eieio*.el
+ - test/lisp/emacs-lisp/eieio-tests/*.el
+ - test/lisp/emacs-lisp/eieio-tests/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-emacs-lisp-eieio-tests"
+
+test-lisp-emacs-lisp-faceup-tests-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/emacs-lisp/faceup*.el
+ - test/lisp/emacs-lisp/faceup-tests/*.el
+ - test/lisp/emacs-lisp/faceup-tests/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-emacs-lisp-faceup-tests"
+
+test-lisp-emulation-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/emulation/*.el
+ - test/lisp/emulation/*.el
+ - test/lisp/emulation/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-emulation"
+
+test-lisp-erc-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/erc/*.el
+ - test/lisp/erc/*.el
+ - test/lisp/erc/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-erc"
+
+test-lisp-eshell-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/eshell/*.el
+ - test/lisp/eshell/*.el
+ - test/lisp/eshell/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-eshell"
+
+test-lisp-gnus-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/gnus/*.el
+ - test/lisp/gnus/*.el
+ - test/lisp/gnus/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-gnus"
+
+test-lisp-image-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/image/*.el
+ - test/lisp/image/*.el
+ - test/lisp/image/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-image"
+
+test-lisp-international-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/international/*.el
+ - test/lisp/international/*.el
+ - test/lisp/international/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-international"
+
+test-lisp-mail-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/mail/*.el
+ - test/lisp/mail/*.el
+ - test/lisp/mail/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-mail"
+
+test-lisp-mh-e-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/mh-e/*.el
+ - test/lisp/mh-e/*.el
+ - test/lisp/mh-e/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-mh-e"
+
+test-lisp-net-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/net/*.el
+ - test/lisp/net/*.el
+ - test/lisp/net/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-net"
+
+test-lisp-nxml-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/nxml/*.el
+ - test/lisp/nxml/*.el
+ - test/lisp/nxml/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-nxml"
+
+test-lisp-obsolete-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/obsolete/*.el
+ - test/lisp/obsolete/*.el
+ - test/lisp/obsolete/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-obsolete"
+
+test-lisp-org-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/org/*.el
+ - test/lisp/org/*.el
+ - test/lisp/org/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-org"
+
+test-lisp-play-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/play/*.el
+ - test/lisp/play/*.el
+ - test/lisp/play/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-play"
+
+test-lisp-progmodes-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/progmodes/*.el
+ - test/lisp/progmodes/*.el
+ - test/lisp/progmodes/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-progmodes"
+
+test-lisp-so-long-tests-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/so-long*.el
+ - test/lisp/so-long-tests/*.el
+ - test/lisp/so-long-tests/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-so-long-tests"
+
+test-lisp-term-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/term/*.el
+ - test/lisp/term/*.el
+ - test/lisp/term/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-term"
+
+test-lisp-textmodes-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/textmodes/*.el
+ - test/lisp/textmodes/*.el
+ - test/lisp/textmodes/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-textmodes"
+
+test-lisp-url-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/url/*.el
+ - test/lisp/url/*.el
+ - test/lisp/url/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-url"
+
+test-lisp-vc-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - lisp/vc/*.el
+ - test/lisp/vc/*.el
+ - test/lisp/vc/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-lisp-vc"
+
+test-misc-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - admin/*.el
+ - test/misc/*.el
+ - test/misc/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-misc"
+
+test-src-inotify:
+ stage: normal
+ extends: [.job-template, .test-template]
+ needs:
+ - job: build-image-inotify
+ optional: true
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ when: never
+ - changes:
+ - src/*.{h,c}
+ - test/src/*.el
+ - test/src/*resources/**
+ variables:
+ target: emacs-inotify
+ make_params: "-k -C test check-src"
diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el
index 2dcfb1c309e..863806af7b3 100644
--- a/test/lisp/abbrev-tests.el
+++ b/test/lisp/abbrev-tests.el
@@ -28,6 +28,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'abbrev)
(require 'seq)
@@ -236,44 +237,41 @@
(ert-deftest read-write-abbrev-file-test ()
"Test reading and writing abbrevs from file."
- (let ((temp-test-file (make-temp-file "ert-abbrev-test"))
- (ert-test-abbrevs (setup-test-abbrev-table)))
- (write-abbrev-file temp-test-file)
- (clear-abbrev-table ert-test-abbrevs)
- (should (abbrev-table-empty-p ert-test-abbrevs))
- (read-abbrev-file temp-test-file)
- (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs)))
- (delete-file temp-test-file)))
+ (ert-with-temp-file temp-test-file
+ (let ((ert-test-abbrevs (setup-test-abbrev-table)))
+ (write-abbrev-file temp-test-file)
+ (clear-abbrev-table ert-test-abbrevs)
+ (should (abbrev-table-empty-p ert-test-abbrevs))
+ (read-abbrev-file temp-test-file)
+ (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs))))))
(ert-deftest read-write-abbrev-file-test-with-props ()
"Test reading and writing abbrevs from file."
- (let ((temp-test-file (make-temp-file "ert-abbrev-test"))
- (ert-test-abbrevs (setup-test-abbrev-table-with-props)))
- (write-abbrev-file temp-test-file)
- (clear-abbrev-table ert-test-abbrevs)
- (should (abbrev-table-empty-p ert-test-abbrevs))
- (read-abbrev-file temp-test-file)
- (should (equal "fooBar" (abbrev-expansion "fb" ert-test-abbrevs)))
- (delete-file temp-test-file)))
+ (ert-with-temp-file temp-test-file
+ (let ((ert-test-abbrevs (setup-test-abbrev-table-with-props)))
+ (write-abbrev-file temp-test-file)
+ (clear-abbrev-table ert-test-abbrevs)
+ (should (abbrev-table-empty-p ert-test-abbrevs))
+ (read-abbrev-file temp-test-file)
+ (should (equal "fooBar" (abbrev-expansion "fb" ert-test-abbrevs))))))
(ert-deftest abbrev-edit-save-to-file-test ()
"Test saving abbrev definitions in buffer to file."
(defvar ert-save-test-table nil)
- (let ((temp-test-file (make-temp-file "ert-abbrev-test"))
- (ert-test-abbrevs (setup-test-abbrev-table)))
- (with-temp-buffer
- (goto-char (point-min))
- (insert "(ert-save-test-table)\n")
- (insert "\n" "\"s-a-t\"\t" "0\t" "\"save-abbrevs-test\"\n")
- (should (equal "abbrev-ert-test"
- (abbrev-expansion "a-e-t" ert-test-abbrevs)))
- ;; clears abbrev tables
- (abbrev-edit-save-to-file temp-test-file)
- (should-not (abbrev-expansion "a-e-t" ert-test-abbrevs))
- (read-abbrev-file temp-test-file)
- (should (equal "save-abbrevs-test"
- (abbrev-expansion "s-a-t" ert-save-test-table)))
- (delete-file temp-test-file))))
+ (ert-with-temp-file temp-test-file
+ (let ((ert-test-abbrevs (setup-test-abbrev-table)))
+ (with-temp-buffer
+ (goto-char (point-min))
+ (insert "(ert-save-test-table)\n")
+ (insert "\n" "\"s-a-t\"\t" "0\t" "\"save-abbrevs-test\"\n")
+ (should (equal "abbrev-ert-test"
+ (abbrev-expansion "a-e-t" ert-test-abbrevs)))
+ ;; clears abbrev tables
+ (abbrev-edit-save-to-file temp-test-file)
+ (should-not (abbrev-expansion "a-e-t" ert-test-abbrevs))
+ (read-abbrev-file temp-test-file)
+ (should (equal "save-abbrevs-test"
+ (abbrev-expansion "s-a-t" ert-save-test-table)))))))
(ert-deftest inverse-add-abbrev-skips-trailing-nonword ()
"Test that adding an inverse abbrev skips trailing nonword characters."
diff --git a/test/lisp/ansi-color-tests.el b/test/lisp/ansi-color-tests.el
index 953fdff8933..14a14ca4f06 100644
--- a/test/lisp/ansi-color-tests.el
+++ b/test/lisp/ansi-color-tests.el
@@ -24,10 +24,12 @@
;;; Code:
(require 'ansi-color)
+(eval-when-compile (require 'cl-lib))
(defvar ansi-color-tests--strings
(let ((bright-yellow (face-foreground 'ansi-color-bright-yellow nil 'default))
- (yellow (face-foreground 'ansi-color-yellow nil 'default)))
+ (yellow (face-foreground 'ansi-color-yellow nil 'default))
+ (custom-color "#87FFFF"))
`(("Hello World" "Hello World")
("\e[33mHello World\e[0m" "Hello World"
(:foreground ,yellow))
@@ -51,7 +53,25 @@
(ansi-color-bold (:foreground ,bright-yellow)))
("\e[1m\e[3m\e[5mbold italics blink\e[0m" "bold italics blink"
(ansi-color-bold ansi-color-italic ansi-color-slow-blink))
- ("\e[10munrecognized\e[0m" "unrecognized"))))
+ ("\e[10munrecognized\e[0m" "unrecognized")
+ ("\e[38;5;3;1mHello World\e[0m" "Hello World"
+ (ansi-color-bold (:foreground ,yellow))
+ (ansi-color-bold (:foreground ,bright-yellow)))
+ ("\e[48;5;123;1mHello World\e[0m" "Hello World"
+ (ansi-color-bold (:background ,custom-color)))
+ ("\e[48;2;135;255;255;1mHello World\e[0m" "Hello World"
+ (ansi-color-bold (:background ,custom-color))))))
+
+(defun ansi-color-tests-equal-props (o1 o2)
+ "Return t if two Lisp objects have similar structure and contents.
+While `equal-including-properties' compares text properties of
+strings with `eq', this function compares them with `equal'."
+ (or (equal-including-properties o1 o2)
+ (and (stringp o1)
+ (equal o1 o2)
+ (cl-loop for i below (length o1)
+ always (equal (text-properties-at i o1)
+ (text-properties-at i o2))))))
(ert-deftest ansi-color-apply-on-region-test ()
(pcase-dolist (`(,input ,text ,face) ansi-color-tests--strings)
@@ -83,6 +103,76 @@
(ansi-color-apply-on-region (point-min) (point-max) t)
(should (equal (buffer-string) (car pair))))))
+(ert-deftest ansi-color-incomplete-sequences-test ()
+ (let* ((strs (list "\e[" "2;31m Hello World "
+ "\e" "[108;5;12" "3m" "Greetings"
+ "\e[0m\e[35;6m" "Hello"))
+ (complete-str (apply #'concat strs))
+ (filtered-str)
+ (propertized-str)
+ (ansi-color-apply-face-function
+ #'ansi-color-apply-text-property-face)
+ (ansi-filt (lambda (str) (ansi-color-filter-apply
+ (copy-sequence str))))
+ (ansi-app (lambda (str) (ansi-color-apply
+ (copy-sequence str)))))
+
+ (with-temp-buffer
+ (setq filtered-str
+ (replace-regexp-in-string "\e\\[.*?m" "" complete-str))
+ (setq propertized-str (funcall ansi-app complete-str))
+
+ (should-not (ansi-color-tests-equal-props
+ filtered-str propertized-str))
+ (should (equal filtered-str propertized-str)))
+
+ ;; Tests for `ansi-color-filter-apply'
+ (with-temp-buffer
+ (should (equal-including-properties
+ filtered-str
+ (funcall ansi-filt complete-str))))
+
+ (with-temp-buffer
+ (should (equal-including-properties
+ filtered-str
+ (mapconcat ansi-filt strs ""))))
+
+ ;; Tests for `ansi-color-filter-region'
+ (with-temp-buffer
+ (insert complete-str)
+ (ansi-color-filter-region (point-min) (point-max))
+ (should (equal-including-properties
+ filtered-str (buffer-string))))
+
+ (with-temp-buffer
+ (dolist (str strs)
+ (let ((opoint (point)))
+ (insert str)
+ (ansi-color-filter-region opoint (point))))
+ (should (equal-including-properties
+ filtered-str (buffer-string))))
+
+ ;; Test for `ansi-color-apply'
+ (with-temp-buffer
+ (should (ansi-color-tests-equal-props
+ propertized-str
+ (mapconcat ansi-app strs ""))))
+
+ ;; Tests for `ansi-color-apply-on-region'
+ (with-temp-buffer
+ (insert complete-str)
+ (ansi-color-apply-on-region (point-min) (point-max))
+ (should (ansi-color-tests-equal-props
+ propertized-str (buffer-string))))
+
+ (with-temp-buffer
+ (dolist (str strs)
+ (let ((opoint (point)))
+ (insert str)
+ (ansi-color-apply-on-region opoint (point))))
+ (should (ansi-color-tests-equal-props
+ propertized-str (buffer-string))))))
+
(provide 'ansi-color-tests)
;;; ansi-color-tests.el ends here
diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el
index 5140970b0b6..34c68b421c9 100644
--- a/test/lisp/auth-source-tests.el
+++ b/test/lisp/auth-source-tests.el
@@ -27,6 +27,7 @@
;;; Code:
(require 'ert)
+(eval-when-compile (require 'ert-x))
(require 'cl-lib)
(require 'auth-source)
(require 'secrets)
@@ -277,34 +278,33 @@
"((:host \"a1\" :port \"a2\" :user \"a3\" :secret \"a4\") (:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\") (:host \"c1\" :port \"c2\" :user \"c3\" :secret \"c4\"))"
:host t :max 4)
("host b1, default max is 1"
- "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))"
+ "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))"
:host "b1")
("host b1, port b2, user b3, default max is 1"
- "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))"
+ "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))"
:host "b1" :port "b2" :user "b3")
- ))
-
- (netrc-file (make-temp-file "auth-source-test" nil nil
- (mapconcat 'identity entries "\n")))
- (auth-sources (list netrc-file))
- (auth-source-do-cache nil)
- found found-as-string)
-
- (dolist (test tests)
- (cl-destructuring-bind (testname needed &rest parameters) test
- (setq found (apply #'auth-source-search parameters))
- (when (listp found)
- (dolist (f found)
- (setf f (plist-put f :secret
- (let ((secret (plist-get f :secret)))
- (if (functionp secret)
- (funcall secret)
- secret))))))
-
- (setq found-as-string (format "%s: %S" testname found))
- ;; (message "With parameters %S found: [%s] needed: [%s]" parameters found-as-string needed)
- (should (equal found-as-string (concat testname ": " needed)))))
- (delete-file netrc-file)))
+ )))
+ (ert-with-temp-file netrc-file
+ :text (mapconcat 'identity entries "\n")
+ (let ((auth-sources (list netrc-file))
+ (auth-source-do-cache nil)
+ found found-as-string)
+
+ (dolist (test tests)
+ (cl-destructuring-bind (testname needed &rest parameters) test
+ (setq found (apply #'auth-source-search parameters))
+ (when (listp found)
+ (dolist (f found)
+ (setf f (plist-put f :secret
+ (let ((secret (plist-get f :secret)))
+ (if (functionp secret)
+ (funcall secret)
+ secret))))))
+
+ (setq found-as-string (format "%s: %S" testname found))
+ ;; (message "With parameters %S found: [%s] needed: [%s]"
+ ;; parameters found-as-string needed)
+ (should (equal found-as-string (concat testname ": " needed)))))))))
(ert-deftest auth-source-test-secrets-create-secret ()
(skip-unless secrets-enabled)
@@ -360,77 +360,73 @@
(format "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host))))))
(ert-deftest auth-source-test-netrc-create-secret ()
- (let* ((netrc-file (make-temp-file "auth-source-test"))
- (auth-sources (list netrc-file))
- (auth-source-save-behavior t)
- host auth-info auth-passwd)
- (unwind-protect
- (dolist (passwd '("foo" "" nil))
- ;; Redefine `read-*' in order to avoid interactive input.
- (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd))
- ((symbol-function 'read-string)
- (lambda (_prompt &optional _initial _history default
- _inherit-input-method)
- default)))
- (setq host
- (md5 (concat (prin1-to-string process-environment) passwd))
- auth-info
- (car (auth-source-search
- :max 1 :host host :require '(:user :secret) :create t))
- auth-passwd (plist-get auth-info :secret)
- auth-passwd (if (functionp auth-passwd)
- (funcall auth-passwd)
- auth-passwd))
- (should (string-equal (plist-get auth-info :user) (user-login-name)))
- (should (string-equal (plist-get auth-info :host) host))
- (should (equal auth-passwd passwd))
- (when (functionp (plist-get auth-info :save-function))
- (funcall (plist-get auth-info :save-function)))
-
- ;; Check, that the item has been created indeed.
- (auth-source-forget+ :host t)
- (setq auth-source-netrc-cache nil)
- (setq auth-info (car (auth-source-search :host host))
- auth-passwd (plist-get auth-info :secret)
- auth-passwd (if (functionp auth-passwd)
- (funcall auth-passwd)
- auth-passwd))
- (with-temp-buffer
- (insert-file-contents netrc-file)
- (if (zerop (length passwd))
- (progn
- (should-not (plist-get auth-info :user))
- (should-not (plist-get auth-info :host))
- (should-not auth-passwd)
- (should-not (search-forward host nil 'noerror)))
- (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 (search-forward host nil 'noerror))))))
-
- ;; Cleanup.
- (delete-file netrc-file))))
+ (ert-with-temp-file netrc-file
+ :suffix "auth-source-test"
+ (let* ((auth-sources (list netrc-file))
+ (auth-source-save-behavior t)
+ host auth-info auth-passwd)
+ (dolist (passwd '("foo" "" nil))
+ ;; Redefine `read-*' in order to avoid interactive input.
+ (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd))
+ ((symbol-function 'read-string)
+ (lambda (_prompt &optional _initial _history default
+ _inherit-input-method)
+ default)))
+ (setq host
+ (md5 (concat (prin1-to-string process-environment) passwd))
+ auth-info
+ (car (auth-source-search
+ :max 1 :host host :require '(:user :secret) :create t))
+ auth-passwd (plist-get auth-info :secret)
+ auth-passwd (if (functionp auth-passwd)
+ (funcall auth-passwd)
+ auth-passwd))
+ (should (string-equal (plist-get auth-info :user) (user-login-name)))
+ (should (string-equal (plist-get auth-info :host) host))
+ (should (equal auth-passwd passwd))
+ (when (functionp (plist-get auth-info :save-function))
+ (funcall (plist-get auth-info :save-function)))
+
+ ;; Check, that the item has been created indeed.
+ (auth-source-forget+ :host t)
+ (setq auth-source-netrc-cache nil)
+ (setq auth-info (car (auth-source-search :host host))
+ auth-passwd (plist-get auth-info :secret)
+ auth-passwd (if (functionp auth-passwd)
+ (funcall auth-passwd)
+ auth-passwd))
+ (with-temp-buffer
+ (insert-file-contents netrc-file)
+ (if (zerop (length passwd))
+ (progn
+ (should-not (plist-get auth-info :user))
+ (should-not (plist-get auth-info :host))
+ (should-not auth-passwd)
+ (should-not (search-forward host nil 'noerror)))
+ (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 (search-forward host nil 'noerror)))))))))
(ert-deftest auth-source-delete ()
- (let* ((netrc-file (make-temp-file "auth-source-test" nil nil "\
+ (ert-with-temp-file netrc-file
+ :suffix "auth-source-test" :text "\
machine a1 port a2 user a3 password a4
machine b1 port b2 user b3 password b4
-machine c1 port c2 user c3 password c4\n"))
- (auth-sources (list netrc-file))
- (auth-source-do-cache nil)
- (expected '((:host "a1" :port "a2" :user "a3" :secret "a4")))
- (parameters '(:max 1 :host t)))
- (unwind-protect
- (let ((found (apply #'auth-source-delete parameters)))
- (dolist (f found)
- (let ((s (plist-get f :secret)))
- (setf f (plist-put f :secret
- (if (functionp s) (funcall s) s)))))
- ;; Note: The netrc backend doesn't delete anything, so
- ;; this is actually the same as `auth-source-search'.
- (should (equal found expected)))
- (delete-file netrc-file))))
+machine c1 port c2 user c3 password c4\n"
+ (let* ((auth-sources (list netrc-file))
+ (auth-source-do-cache nil)
+ (expected '((:host "a1" :port "a2" :user "a3" :secret "a4")))
+ (parameters '(:max 1 :host t))
+ (found (apply #'auth-source-delete parameters)))
+ (dolist (f found)
+ (let ((s (plist-get f :secret)))
+ (setf f (plist-put f :secret
+ (if (functionp s) (funcall s) s)))))
+ ;; Note: The netrc backend doesn't delete anything, so
+ ;; this is actually the same as `auth-source-search'.
+ (should (equal found expected)))))
(provide 'auth-source-tests)
;;; auth-source-tests.el ends here
diff --git a/test/lisp/autoinsert-tests.el b/test/lisp/autoinsert-tests.el
index 7ec4bf63791..b264323ca15 100644
--- a/test/lisp/autoinsert-tests.el
+++ b/test/lisp/autoinsert-tests.el
@@ -28,6 +28,7 @@
(require 'autoinsert)
(require 'ert)
+(require 'ert-x)
(ert-deftest autoinsert-tests-auto-insert-skeleton ()
(let ((auto-insert-alist '((text-mode nil "f" _ "oo")))
@@ -39,16 +40,14 @@
(should (equal (point) (+ (point-min) 1))))))
(ert-deftest autoinsert-tests-auto-insert-file ()
- (let ((temp-file (make-temp-file "autoinsert-tests" nil nil "foo")))
- (unwind-protect
- (let ((auto-insert-alist `((text-mode . ,temp-file)))
- (auto-insert-query nil))
- (with-temp-buffer
- (text-mode)
- (auto-insert)
- (should (equal (buffer-string) "foo"))))
- (when (file-exists-p temp-file)
- (delete-file temp-file)))))
+ (ert-with-temp-file temp-file
+ :text "foo"
+ (let ((auto-insert-alist `((text-mode . ,temp-file)))
+ (auto-insert-query nil))
+ (with-temp-buffer
+ (text-mode)
+ (auto-insert)
+ (should (equal (buffer-string) "foo"))))))
(ert-deftest autoinsert-tests-auto-insert-function ()
(let ((auto-insert-alist '((text-mode . (lambda () (insert "foo")))))
diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el
index 7dce39810ab..2508b6a499f 100644
--- a/test/lisp/autorevert-tests.el
+++ b/test/lisp/autorevert-tests.el
@@ -127,7 +127,7 @@ This expects `auto-revert--messages' to be bound by
`ert-with-message-capture' before calling."
;; Remote files do not cooperate well with timers. So we count ourselves.
(let ((ct (current-time)))
- (while (and (< (float-time (time-subtract (current-time) ct))
+ (while (and (< (float-time (time-subtract nil ct))
(auto-revert--timeout))
(null (string-match
(format-message
@@ -167,49 +167,48 @@ This expects `auto-revert--messages' to be bound by
(defun auto-revert-tests--write-file (text file time-delta &optional append)
(write-region text nil file append 'no-message)
- (set-file-times file (time-subtract (current-time) time-delta)))
+ (set-file-times file (time-subtract nil time-delta)))
(ert-deftest auto-revert-test00-auto-revert-mode ()
"Check autorevert for a file."
;; `auto-revert-buffers' runs every 5". And we must wait, until the
;; file has been reverted.
(with-auto-revert-test
- (let ((tmpfile (make-temp-file "auto-revert-test"))
- (times '(60 30 15))
- buf)
- (unwind-protect
- (progn
- (auto-revert-tests--write-file "any text" tmpfile (pop times))
- (setq buf (find-file-noselect tmpfile))
- (with-current-buffer buf
- (ert-with-message-capture auto-revert--messages
- (should (string-equal (buffer-string) "any text"))
- ;; `buffer-stale--default-function' checks for
- ;; `verify-visited-file-modtime'. We must ensure that it
- ;; returns nil.
- (auto-revert-mode 1)
- (should auto-revert-mode)
-
- (auto-revert-tests--write-file "another text" tmpfile (pop times))
-
- ;; Check, that the buffer has been reverted.
- (auto-revert--wait-for-revert buf))
- (should (string-match "another text" (buffer-string)))
-
- ;; When the buffer is modified, it shall not be reverted.
- (ert-with-message-capture auto-revert--messages
- (set-buffer-modified-p t)
- (auto-revert-tests--write-file "any text" tmpfile (pop times))
-
- ;; Check, that the buffer hasn't been reverted.
- (auto-revert--wait-for-revert buf))
- (should-not (string-match "any text" (buffer-string)))))
-
- ;; Exit.
- (ignore-errors
- (with-current-buffer buf (set-buffer-modified-p nil))
- (kill-buffer buf))
- (ignore-errors (delete-file tmpfile))))))
+ (ert-with-temp-file tmpfile
+ (let ((times '(60 30 15))
+ buf)
+ (unwind-protect
+ (progn
+ (auto-revert-tests--write-file "any text" tmpfile (pop times))
+ (setq buf (find-file-noselect tmpfile))
+ (with-current-buffer buf
+ (ert-with-message-capture auto-revert--messages
+ (should (string-equal (buffer-string) "any text"))
+ ;; `buffer-stale--default-function' checks for
+ ;; `verify-visited-file-modtime'. We must ensure that it
+ ;; returns nil.
+ (auto-revert-mode 1)
+ (should auto-revert-mode)
+
+ (auto-revert-tests--write-file "another text" tmpfile (pop times))
+
+ ;; Check, that the buffer has been reverted.
+ (auto-revert--wait-for-revert buf))
+ (should (string-match "another text" (buffer-string)))
+
+ ;; When the buffer is modified, it shall not be reverted.
+ (ert-with-message-capture auto-revert--messages
+ (set-buffer-modified-p t)
+ (auto-revert-tests--write-file "any text" tmpfile (pop times))
+
+ ;; Check, that the buffer hasn't been reverted.
+ (auto-revert--wait-for-revert buf))
+ (should-not (string-match "any text" (buffer-string)))))
+
+ ;; Exit.
+ (ignore-errors
+ (with-current-buffer buf (set-buffer-modified-p nil))
+ (kill-buffer buf)))))))
(auto-revert--deftest-remote auto-revert-test00-auto-revert-mode
"Check autorevert for a remote file.")
@@ -219,63 +218,61 @@ This expects `auto-revert--messages' to be bound by
"Check autorevert for several files at once."
(skip-unless (executable-find "cp" (file-remote-p temporary-file-directory)))
- (with-auto-revert-test
- (let* ((cp (executable-find "cp" (file-remote-p temporary-file-directory)))
- (tmpdir1 (make-temp-file "auto-revert-test" 'dir))
- (tmpdir2 (make-temp-file "auto-revert-test" 'dir))
- (tmpfile1
- (make-temp-file (expand-file-name "auto-revert-test" tmpdir1)))
- (tmpfile2
- (make-temp-file (expand-file-name "auto-revert-test" tmpdir1)))
- (times '(120 60 30 15))
- buf1 buf2)
- (unwind-protect
- (ert-with-message-capture auto-revert--messages
- (auto-revert-tests--write-file "any text" tmpfile1 (pop times))
- (setq buf1 (find-file-noselect tmpfile1))
- (auto-revert-tests--write-file "any text" tmpfile2 (pop times))
- (setq buf2 (find-file-noselect tmpfile2))
-
- (dolist (buf (list buf1 buf2))
- (with-current-buffer buf
- (should (string-equal (buffer-string) "any text"))
- ;; `buffer-stale--default-function' checks for
- ;; `verify-visited-file-modtime'. We must ensure that
- ;; it returns nil.
- (auto-revert-mode 1)
- (should auto-revert-mode)))
-
- ;; Modify files. We wait for a second, in order to have
- ;; another timestamp.
- (auto-revert-tests--write-file
- "another text"
- (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2)
- (pop times))
- (auto-revert-tests--write-file
- "another text"
- (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2)
- (pop times))
- ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents)
- ;; Strange, that `copy-directory' does not work as expected.
- ;; The following shell command is not portable on all
- ;; platforms, unfortunately.
- (shell-command
- (format "%s -f %s/* %s"
- cp (file-local-name tmpdir2) (file-local-name tmpdir1)))
-
- ;; Check, that the buffers have been reverted.
- (dolist (buf (list buf1 buf2))
- (with-current-buffer buf
- (auto-revert--wait-for-revert buf)
- (should (string-match "another text" (buffer-string))))))
-
- ;; Exit.
- (ignore-errors
- (dolist (buf (list buf1 buf2))
- (with-current-buffer buf (set-buffer-modified-p nil))
- (kill-buffer buf)))
- (ignore-errors (delete-directory tmpdir1 'recursive))
- (ignore-errors (delete-directory tmpdir2 'recursive))))))
+ (ert-with-temp-directory tmpdir1
+ (ert-with-temp-directory tmpdir2
+ (ert-with-temp-file tmpfile1
+ :prefix (expand-file-name "auto-revert-test" tmpdir1)
+ (ert-with-temp-file tmpfile2
+ :prefix (expand-file-name "auto-revert-test" tmpdir1)
+ (with-auto-revert-test
+ (let* ((cp (executable-find "cp" (file-remote-p temporary-file-directory)))
+ (times '(120 60 30 15))
+ buf1 buf2)
+ (unwind-protect
+ (ert-with-message-capture auto-revert--messages
+ (auto-revert-tests--write-file "any text" tmpfile1 (pop times))
+ (setq buf1 (find-file-noselect tmpfile1))
+ (auto-revert-tests--write-file "any text" tmpfile2 (pop times))
+ (setq buf2 (find-file-noselect tmpfile2))
+
+ (dolist (buf (list buf1 buf2))
+ (with-current-buffer buf
+ (should (string-equal (buffer-string) "any text"))
+ ;; `buffer-stale--default-function' checks for
+ ;; `verify-visited-file-modtime'. We must ensure that
+ ;; it returns nil.
+ (auto-revert-mode 1)
+ (should auto-revert-mode)))
+
+ ;; Modify files. We wait for a second, in order to have
+ ;; another timestamp.
+ (auto-revert-tests--write-file
+ "another text"
+ (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2)
+ (pop times))
+ (auto-revert-tests--write-file
+ "another text"
+ (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2)
+ (pop times))
+ ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents)
+ ;; Strange, that `copy-directory' does not work as expected.
+ ;; The following shell command is not portable on all
+ ;; platforms, unfortunately.
+ (shell-command
+ (format "%s -f %s/* %s"
+ cp (file-local-name tmpdir2) (file-local-name tmpdir1)))
+
+ ;; Check, that the buffers have been reverted.
+ (dolist (buf (list buf1 buf2))
+ (with-current-buffer buf
+ (auto-revert--wait-for-revert buf)
+ (should (string-match "another text" (buffer-string))))))
+
+ ;; Exit.
+ (ignore-errors
+ (dolist (buf (list buf1 buf2))
+ (with-current-buffer buf (set-buffer-modified-p nil))
+ (kill-buffer buf)))))))))))
(auto-revert--deftest-remote auto-revert-test01-auto-revert-several-files
"Check autorevert for several remote files at once.")
@@ -284,80 +281,79 @@ This expects `auto-revert--messages' to be bound by
(ert-deftest auto-revert-test02-auto-revert-deleted-file ()
"Check autorevert for a deleted file."
;; Repeated unpredictable failures, bug#32645.
- ;; Unlikely to be hydra-specific?
-; (skip-unless (not (getenv "EMACS_HYDRA_CI")))
:tags '(:unstable)
+ ;; Unlikely to be hydra-specific?
+ ;; (skip-unless (not (getenv "EMACS_HYDRA_CI")))
(with-auto-revert-test
- (let ((tmpfile (make-temp-file "auto-revert-test"))
- ;; Try to catch bug#32645.
- (auto-revert-debug (getenv "EMACS_HYDRA_CI"))
- (file-notify-debug (getenv "EMACS_HYDRA_CI"))
- (times '(120 60 30 15))
- buf desc)
- (unwind-protect
- (progn
- (auto-revert-tests--write-file "any text" tmpfile (pop times))
- (setq buf (find-file-noselect tmpfile))
- (with-current-buffer buf
- (should-not
- (file-notify-valid-p auto-revert-notify-watch-descriptor))
- (should (string-equal (buffer-string) "any text"))
- ;; `buffer-stale--default-function' checks for
- ;; `verify-visited-file-modtime'. We must ensure that
- ;; it returns nil.
- (auto-revert-mode 1)
- (should auto-revert-mode)
- (setq desc auto-revert-notify-watch-descriptor)
-
- ;; Remove file while reverting. We simulate this by
- ;; modifying `before-revert-hook'.
- (add-hook
- 'before-revert-hook
- (lambda ()
- (when auto-revert-debug
- (message "%s deleted" buffer-file-name))
- (delete-file buffer-file-name))
- nil t)
-
- (ert-with-message-capture auto-revert--messages
- (auto-revert-tests--write-file "another text" tmpfile (pop times))
- (auto-revert--wait-for-revert buf))
- ;; Check, that the buffer hasn't been reverted. File
- ;; notification should be disabled, falling back to
- ;; polling.
- (should (string-match "any text" (buffer-string)))
- ;; With w32notify, and on emba, the `stopped' events are not sent.
- (or (eq file-notify--library 'w32notify)
- (getenv "EMACS_EMBA_CI")
- (should-not
- (file-notify-valid-p auto-revert-notify-watch-descriptor)))
-
- ;; Once the file has been recreated, the buffer shall be
- ;; reverted.
- (kill-local-variable 'before-revert-hook)
- (ert-with-message-capture auto-revert--messages
- (auto-revert-tests--write-file "another text" tmpfile (pop times))
- (auto-revert--wait-for-revert buf))
- ;; Check, that the buffer has been reverted.
- (should (string-match "another text" (buffer-string)))
- ;; When file notification is used, it must be reenabled
- ;; after recreation of the file. We cannot expect that
- ;; the descriptor is the same, so we just check the
- ;; existence.
- (should (eq (null desc) (null auto-revert-notify-watch-descriptor)))
-
- ;; An empty file shall still be reverted.
- (ert-with-message-capture auto-revert--messages
- (auto-revert-tests--write-file "" tmpfile (pop times))
- (auto-revert--wait-for-revert buf))
- ;; Check, that the buffer has been reverted.
- (should (string-equal "" (buffer-string)))))
-
- ;; Exit.
- (ignore-errors
- (with-current-buffer buf (set-buffer-modified-p nil))
- (kill-buffer buf))
- (ignore-errors (delete-file tmpfile))))))
+ (ert-with-temp-file tmpfile
+ (let (;; Try to catch bug#32645.
+ (auto-revert-debug (getenv "EMACS_HYDRA_CI"))
+ (file-notify-debug (getenv "EMACS_HYDRA_CI"))
+ (times '(120 60 30 15))
+ buf desc)
+ (unwind-protect
+ (progn
+ (auto-revert-tests--write-file "any text" tmpfile (pop times))
+ (setq buf (find-file-noselect tmpfile))
+ (with-current-buffer buf
+ (should-not
+ (file-notify-valid-p auto-revert-notify-watch-descriptor))
+ (should (string-equal (buffer-string) "any text"))
+ ;; `buffer-stale--default-function' checks for
+ ;; `verify-visited-file-modtime'. We must ensure that
+ ;; it returns nil.
+ (auto-revert-mode 1)
+ (should auto-revert-mode)
+ (setq desc auto-revert-notify-watch-descriptor)
+
+ ;; Remove file while reverting. We simulate this by
+ ;; modifying `before-revert-hook'.
+ (add-hook
+ 'before-revert-hook
+ (lambda ()
+ (when auto-revert-debug
+ (message "%s deleted" buffer-file-name))
+ (delete-file buffer-file-name))
+ nil t)
+
+ (ert-with-message-capture auto-revert--messages
+ (auto-revert-tests--write-file "another text" tmpfile (pop times))
+ (auto-revert--wait-for-revert buf))
+ ;; Check, that the buffer hasn't been reverted. File
+ ;; notification should be disabled, falling back to
+ ;; polling.
+ (should (string-match "any text" (buffer-string)))
+ ;; With w32notify, and on emba, the `stopped' events are not sent.
+ (or (eq file-notify--library 'w32notify)
+ (getenv "EMACS_EMBA_CI")
+ (should-not
+ (file-notify-valid-p auto-revert-notify-watch-descriptor)))
+
+ ;; Once the file has been recreated, the buffer shall be
+ ;; reverted.
+ (kill-local-variable 'before-revert-hook)
+ (ert-with-message-capture auto-revert--messages
+ (auto-revert-tests--write-file "another text" tmpfile (pop times))
+ (auto-revert--wait-for-revert buf))
+ ;; Check, that the buffer has been reverted.
+ (should (string-match "another text" (buffer-string)))
+ ;; When file notification is used, it must be reenabled
+ ;; after recreation of the file. We cannot expect that
+ ;; the descriptor is the same, so we just check the
+ ;; existence.
+ (should (eq (null desc) (null auto-revert-notify-watch-descriptor)))
+
+ ;; An empty file shall still be reverted.
+ (ert-with-message-capture auto-revert--messages
+ (auto-revert-tests--write-file "" tmpfile (pop times))
+ (auto-revert--wait-for-revert buf))
+ ;; Check, that the buffer has been reverted.
+ (should (string-equal "" (buffer-string)))))
+
+ ;; Exit.
+ (ignore-errors
+ (with-current-buffer buf (set-buffer-modified-p nil))
+ (kill-buffer buf)))))))
(auto-revert--deftest-remote auto-revert-test02-auto-revert-deleted-file
"Check autorevert for a deleted remote file.")
@@ -366,34 +362,33 @@ This expects `auto-revert--messages' to be bound by
"Check autorevert tail mode."
;; `auto-revert-buffers' runs every 5". And we must wait, until the
;; file has been reverted.
- (let ((tmpfile (make-temp-file "auto-revert-test"))
- (times '(30 15))
- buf)
- (unwind-protect
- (ert-with-message-capture auto-revert--messages
- (auto-revert-tests--write-file "any text" tmpfile (pop times))
- (setq buf (find-file-noselect tmpfile))
- (with-current-buffer buf
- ;; `buffer-stale--default-function' checks for
- ;; `verify-visited-file-modtime'. We must ensure that it
- ;; returns nil.
- (auto-revert-tail-mode 1)
- (should auto-revert-tail-mode)
- (erase-buffer)
- (insert "modified text\n")
- (set-buffer-modified-p nil)
-
- ;; Modify file.
- (auto-revert-tests--write-file "another text" tmpfile (pop times) 'append)
-
- ;; Check, that the buffer has been reverted.
- (auto-revert--wait-for-revert buf)
- (should
- (string-match "modified text\nanother text" (buffer-string)))))
-
- ;; Exit.
- (ignore-errors (kill-buffer buf))
- (ignore-errors (delete-file tmpfile)))))
+ (ert-with-temp-file tmpfile
+ (let ((times '(30 15))
+ buf)
+ (unwind-protect
+ (ert-with-message-capture auto-revert--messages
+ (auto-revert-tests--write-file "any text" tmpfile (pop times))
+ (setq buf (find-file-noselect tmpfile))
+ (with-current-buffer buf
+ ;; `buffer-stale--default-function' checks for
+ ;; `verify-visited-file-modtime'. We must ensure that it
+ ;; returns nil.
+ (auto-revert-tail-mode 1)
+ (should auto-revert-tail-mode)
+ (erase-buffer)
+ (insert "modified text\n")
+ (set-buffer-modified-p nil)
+
+ ;; Modify file.
+ (auto-revert-tests--write-file "another text" tmpfile (pop times) 'append)
+
+ ;; Check, that the buffer has been reverted.
+ (auto-revert--wait-for-revert buf)
+ (should
+ (string-match "modified text\nanother text" (buffer-string)))))
+
+ ;; Exit.
+ (ignore-errors (kill-buffer buf))))))
(auto-revert--deftest-remote auto-revert-test03-auto-revert-tail-mode
"Check remote autorevert tail mode.")
@@ -403,46 +398,45 @@ This expects `auto-revert--messages' to be bound by
;; `auto-revert-buffers' runs every 5". And we must wait, until the
;; file has been reverted.
(with-auto-revert-test
- (let* ((tmpfile (make-temp-file "auto-revert-test"))
- (name (file-name-nondirectory tmpfile))
- (times '(30))
- buf)
- (unwind-protect
- (progn
- (setq buf (dired-noselect temporary-file-directory))
- (with-current-buffer buf
- ;; `buffer-stale--default-function' checks for
- ;; `verify-visited-file-modtime'. We must ensure that it
- ;; returns nil.
- (auto-revert-mode 1)
- (should auto-revert-mode)
- (should
- (string-match name (substring-no-properties (buffer-string))))
-
- (ert-with-message-capture auto-revert--messages
- ;; Delete file.
- (delete-file tmpfile)
- (auto-revert--wait-for-revert buf))
- ;; Check, that the buffer has been reverted.
- (should-not
- (string-match name (substring-no-properties (buffer-string))))
-
- (ert-with-message-capture auto-revert--messages
- ;; Make dired buffer modified. Check, that the buffer has
- ;; been still reverted.
- (set-buffer-modified-p t)
- (auto-revert-tests--write-file "any text" tmpfile (pop times))
-
- (auto-revert--wait-for-revert buf))
- ;; Check, that the buffer has been reverted.
- (should
- (string-match name (substring-no-properties (buffer-string))))))
-
- ;; Exit.
- (ignore-errors
- (with-current-buffer buf (set-buffer-modified-p nil))
- (kill-buffer buf))
- (ignore-errors (delete-file tmpfile))))))
+ (ert-with-temp-file tmpfile
+ (let* ((name (file-name-nondirectory tmpfile))
+ (times '(30))
+ buf)
+ (unwind-protect
+ (progn
+ (setq buf (dired-noselect temporary-file-directory))
+ (with-current-buffer buf
+ ;; `buffer-stale--default-function' checks for
+ ;; `verify-visited-file-modtime'. We must ensure that it
+ ;; returns nil.
+ (auto-revert-mode 1)
+ (should auto-revert-mode)
+ (should
+ (string-match name (substring-no-properties (buffer-string))))
+
+ (ert-with-message-capture auto-revert--messages
+ ;; Delete file.
+ (delete-file tmpfile)
+ (auto-revert--wait-for-revert buf))
+ ;; Check, that the buffer has been reverted.
+ (should-not
+ (string-match name (substring-no-properties (buffer-string))))
+
+ (ert-with-message-capture auto-revert--messages
+ ;; Make dired buffer modified. Check, that the buffer has
+ ;; been still reverted.
+ (set-buffer-modified-p t)
+ (auto-revert-tests--write-file "any text" tmpfile (pop times))
+
+ (auto-revert--wait-for-revert buf))
+ ;; Check, that the buffer has been reverted.
+ (should
+ (string-match name (substring-no-properties (buffer-string))))))
+
+ ;; Exit.
+ (ignore-errors
+ (with-current-buffer buf (set-buffer-modified-p nil))
+ (kill-buffer buf)))))))
(auto-revert--deftest-remote auto-revert-test04-auto-revert-mode-dired
"Check remote autorevert for dired.")
@@ -459,7 +453,7 @@ This expects `auto-revert--messages' to be bound by
(defun auto-revert-test--wait-for (pred max-wait)
"Wait until PRED is true, or MAX-WAIT seconds elapsed."
(let ((ct (current-time)))
- (while (and (< (float-time (time-subtract (current-time) ct)) max-wait)
+ (while (and (< (float-time (time-subtract nil ct)) max-wait)
(not (funcall pred)))
(read-event nil nil 0.1))))
@@ -485,99 +479,84 @@ This expects `auto-revert--messages' to be bound by
(skip-unless (or file-notify--library
(file-remote-p temporary-file-directory)))
(with-auto-revert-test
- (let* ((auto-revert-use-notify t)
- (auto-revert-avoid-polling t)
- (auto-revert-debug (getenv "EMACS_EMBA_CI"))
- (file-notify-debug (getenv "EMACS_EMBA_CI"))
- (was-in-global-auto-revert-mode global-auto-revert-mode)
- (file-1 (make-temp-file "global-auto-revert-test-1"))
- (file-2 (make-temp-file "global-auto-revert-test-2"))
- (file-3 (make-temp-file "global-auto-revert-test-3"))
- (file-2b (concat file-2 "-b"))
- require-final-newline buf-1 buf-2 buf-3)
- (unwind-protect
- (progn
- (setq buf-1 (find-file-noselect file-1))
- (auto-revert-test--instrument-kill-buffer-hook buf-1)
- (setq buf-2 (find-file-noselect file-2))
- (auto-revert-test--instrument-kill-buffer-hook buf-2)
- (auto-revert-test--write-file "1-a" file-1)
- (should (equal (auto-revert-test--buffer-string buf-1) ""))
-
- (global-auto-revert-mode 1) ; Turn it on.
-
- (should (buffer-local-value
- 'auto-revert-notify-watch-descriptor buf-1))
- (should (buffer-local-value
- 'auto-revert-notify-watch-descriptor buf-2))
-
- ;; buf-1 should have been reverted immediately when the mode
- ;; was enabled.
- (should (equal (auto-revert-test--buffer-string buf-1) "1-a"))
-
- ;; Alter a file.
- (auto-revert-test--write-file "2-a" file-2)
- ;; Allow for some time to handle notification events.
- (auto-revert-test--wait-for-buffer-text buf-2 "2-a" 1)
- (should (equal (auto-revert-test--buffer-string buf-2) "2-a"))
-
- ;; Visit a file, and modify it on disk.
- (setq buf-3 (find-file-noselect file-3))
- (auto-revert-test--instrument-kill-buffer-hook buf-3)
- ;; Newly opened buffers won't be use notification until the
- ;; first poll cycle; wait for it.
- (auto-revert-test--wait-for
- (lambda () (buffer-local-value
- 'auto-revert-notify-watch-descriptor buf-3))
- (auto-revert--timeout))
- (should (buffer-local-value
- 'auto-revert-notify-watch-descriptor buf-3))
- (auto-revert-test--write-file "3-a" file-3)
- (auto-revert-test--wait-for-buffer-text buf-3 "3-a" 1)
- (should (equal (auto-revert-test--buffer-string buf-3) "3-a"))
-
- ;; Delete a visited file, and re-create it with new contents.
- (when auto-revert-debug (message "Hallo0"))
- (delete-file file-1)
- (when auto-revert-debug (message "Hallo1"))
- (should (equal (auto-revert-test--buffer-string buf-1) "1-a"))
- (when auto-revert-debug (message "Hallo2"))
- (auto-revert-test--write-file "1-b" file-1)
- (when auto-revert-debug (message "Hallo3"))
- (auto-revert-test--wait-for-buffer-text
- buf-1 "1-b" (auto-revert--timeout))
- ;; On emba, `buf-1' is a killed buffer.
- (when auto-revert-debug
- (message
- "Hallo4 %s %s %s %s %s %s %s"
- buf-1 (buffer-name buf-1) (buffer-live-p buf-1)
- file-1 (get-file-buffer file-1)
- (buffer-name (get-file-buffer file-1))
- (buffer-live-p (get-file-buffer file-1)))
- (with-current-buffer buf-1
- (message "Hallo5\n%s" (buffer-local-variables))))
- (should (buffer-local-value
- 'auto-revert-notify-watch-descriptor buf-1))
- (when auto-revert-debug (message "Hallo6"))
-
- ;; Write a buffer to a new file, then modify the new file on disk.
- (with-current-buffer buf-2
- (write-file file-2b))
- (should (equal (auto-revert-test--buffer-string buf-2) "2-a"))
- (auto-revert-test--write-file "2-b" file-2b)
- (auto-revert-test--wait-for-buffer-text
- buf-2 "2-b" (auto-revert--timeout))
- (should (buffer-local-value
- 'auto-revert-notify-watch-descriptor buf-2)))
-
- ;; Clean up.
- (unless was-in-global-auto-revert-mode
- (global-auto-revert-mode 0)) ; Turn it off.
- (dolist (buf (list buf-1 buf-2 buf-3))
- (with-current-buffer buf (setq-local kill-buffer-hook nil))
- (ignore-errors (kill-buffer buf)))
- (dolist (file (list file-1 file-2 file-2b file-3))
- (ignore-errors (delete-file file)))))))
+ (ert-with-temp-file file-1
+ (ert-with-temp-file file-2
+ (ert-with-temp-file file-3
+ (let* ((auto-revert-use-notify t)
+ (auto-revert-avoid-polling t)
+ (was-in-global-auto-revert-mode global-auto-revert-mode)
+ (file-2b (concat file-2 "-b"))
+ require-final-newline buf-1 buf-2 buf-3)
+ (unwind-protect
+ (progn
+ (setq buf-1 (find-file-noselect file-1))
+ (auto-revert-test--instrument-kill-buffer-hook buf-1)
+ (setq buf-2 (find-file-noselect file-2))
+ (auto-revert-test--instrument-kill-buffer-hook buf-2)
+ (auto-revert-test--write-file "1-a" file-1)
+ (should (equal (auto-revert-test--buffer-string buf-1) ""))
+
+ (global-auto-revert-mode 1) ; Turn it on.
+
+ (should (buffer-local-value
+ 'auto-revert-notify-watch-descriptor buf-1))
+ (should (buffer-local-value
+ 'auto-revert-notify-watch-descriptor buf-2))
+
+ ;; buf-1 should have been reverted immediately when the mode
+ ;; was enabled.
+ (should (equal (auto-revert-test--buffer-string buf-1) "1-a"))
+
+ ;; Alter a file.
+ (auto-revert-test--write-file "2-a" file-2)
+ ;; Allow for some time to handle notification events.
+ (auto-revert-test--wait-for-buffer-text buf-2 "2-a" 1)
+ (should (equal (auto-revert-test--buffer-string buf-2) "2-a"))
+
+ ;; Visit a file, and modify it on disk.
+ (setq buf-3 (find-file-noselect file-3))
+ (auto-revert-test--instrument-kill-buffer-hook buf-3)
+ ;; Newly opened buffers won't be use notification until the
+ ;; first poll cycle; wait for it.
+ (auto-revert-test--wait-for
+ (lambda () (buffer-local-value
+ 'auto-revert-notify-watch-descriptor buf-3))
+ (auto-revert--timeout))
+ (should (buffer-local-value
+ 'auto-revert-notify-watch-descriptor buf-3))
+ (auto-revert-test--write-file "3-a" file-3)
+ (auto-revert-test--wait-for-buffer-text buf-3 "3-a" 1)
+ (should (equal (auto-revert-test--buffer-string buf-3) "3-a"))
+
+ ;; Delete a visited file, and re-create it with new contents.
+ (delete-file file-1)
+ (should (equal (auto-revert-test--buffer-string buf-1) "1-a"))
+ (auto-revert-test--write-file "1-b" file-1)
+ ;; Since the file is deleted, it needs at least
+ ;; `autorevert-interval' to recognize the new file,
+ ;; while polling. So increase the timeout.
+ (auto-revert-test--wait-for-buffer-text
+ buf-1 "1-b" (* 2 (auto-revert--timeout)))
+ (should (buffer-local-value
+ 'auto-revert-notify-watch-descriptor buf-1))
+
+ ;; Write a buffer to a new file, then modify the new file on disk.
+ (with-current-buffer buf-2
+ (write-file file-2b))
+ (should (equal (auto-revert-test--buffer-string buf-2) "2-a"))
+ (auto-revert-test--write-file "2-b" file-2b)
+ (auto-revert-test--wait-for-buffer-text
+ buf-2 "2-b" (auto-revert--timeout))
+ (should (buffer-local-value
+ 'auto-revert-notify-watch-descriptor buf-2)))
+
+ ;; Clean up.
+ (unless was-in-global-auto-revert-mode
+ (global-auto-revert-mode 0)) ; Turn it off.
+ (dolist (buf (list buf-1 buf-2 buf-3))
+ (with-current-buffer buf (setq-local kill-buffer-hook nil))
+ (ignore-errors (kill-buffer buf)))
+ (ignore-errors (delete-file file-2b)))))))))
(auto-revert--deftest-remote auto-revert-test05-global-notify
"Test `global-auto-revert-mode' without polling for remote buffers.")
@@ -587,31 +566,30 @@ This expects `auto-revert--messages' to be bound by
(skip-unless (or file-notify--library
(file-remote-p temporary-file-directory)))
(with-auto-revert-test
- (let* ((auto-revert-use-notify t)
- (file-1 (make-temp-file "auto-revert-test"))
- (file-2 (concat file-1 "-2"))
- require-final-newline buf)
- (unwind-protect
- (progn
- (setq buf (find-file-noselect file-1))
- (with-current-buffer buf
- (insert "A")
- (save-buffer)
+ (ert-with-temp-file file-1
+ (let* ((auto-revert-use-notify t)
+ (file-2 (concat file-1 "-2"))
+ require-final-newline buf)
+ (unwind-protect
+ (progn
+ (setq buf (find-file-noselect file-1))
+ (with-current-buffer buf
+ (insert "A")
+ (save-buffer)
- (auto-revert-mode 1)
+ (auto-revert-mode 1)
- (insert "B")
- (write-file file-2)
+ (insert "B")
+ (write-file file-2)
- (auto-revert-test--write-file "C" file-2)
- (auto-revert-test--wait-for-buffer-text
- buf "C" (auto-revert--timeout))
- (should (equal (buffer-string) "C"))))
+ (auto-revert-test--write-file "C" file-2)
+ (auto-revert-test--wait-for-buffer-text
+ buf "C" (auto-revert--timeout))
+ (should (equal (buffer-string) "C"))))
- ;; Clean up.
- (ignore-errors (kill-buffer buf))
- (ignore-errors (delete-file file-1))
- (ignore-errors (delete-file file-2))))))
+ ;; Clean up.
+ (ignore-errors (kill-buffer buf))
+ (ignore-errors (delete-file file-2)))))))
(auto-revert--deftest-remote auto-revert-test06-write-file
"Test `write-file' in `auto-revert-mode' for remote buffers.")
@@ -620,82 +598,81 @@ This expects `auto-revert--messages' to be bound by
(ert-deftest auto-revert-test07-auto-revert-several-buffers ()
"Check autorevert for several buffers visiting the same file."
;; (with-auto-revert-test
- (let ((auto-revert-use-notify t)
- (tmpfile (make-temp-file "auto-revert-test"))
- (times '(120 60 30 15))
- (num-buffers 10)
- require-final-newline buffers)
-
- (unwind-protect
- ;; Check indirect buffers.
- (ert-with-message-capture auto-revert--messages
- (auto-revert-tests--write-file "any text" tmpfile (pop times))
- (push (find-file-noselect tmpfile) buffers)
- (with-current-buffer (car buffers)
- (should (string-equal (buffer-string) "any text"))
- ;; `buffer-stale--default-function' checks for
- ;; `verify-visited-file-modtime'. We must ensure that
- ;; it returns nil.
- (auto-revert-mode 1)
- (should auto-revert-mode))
-
- (dotimes (i num-buffers)
- (push (make-indirect-buffer
- (car buffers)
- (format "%s-%d" (buffer-file-name (car buffers)) i)
- 'clone)
- buffers))
- (setq buffers (nreverse buffers))
- (dolist (buf buffers)
- (with-current-buffer buf
- (should (string-equal (buffer-string) "any text"))
- (should auto-revert-mode)))
-
- (auto-revert-tests--write-file "another text" tmpfile (pop times))
- ;; Check, that the buffer has been reverted.
- (auto-revert--wait-for-revert (car buffers))
- (dolist (buf buffers)
- (with-current-buffer buf
- (should (string-equal (buffer-string) "another text")))))
-
- ;; Exit.
- (ignore-errors
- (dolist (buf buffers)
- (with-current-buffer buf (set-buffer-modified-p nil))
- (kill-buffer buf)))
- (setq buffers nil)
- (ignore-errors (delete-file tmpfile)))
-
- ;; Check direct buffers.
- (unwind-protect
- (ert-with-message-capture auto-revert--messages
- (auto-revert-tests--write-file "any text" tmpfile (pop times))
-
- (dotimes (i num-buffers)
- (push (generate-new-buffer
- (format "%s-%d" (file-name-nondirectory tmpfile) i))
- buffers))
- (setq buffers (nreverse buffers))
- (dolist (buf buffers)
- (with-current-buffer buf
- (insert-file-contents tmpfile 'visit)
- (should (string-equal (buffer-string) "any text"))
- (auto-revert-mode 1)
- (should auto-revert-mode)))
-
- (auto-revert-tests--write-file "another text" tmpfile (pop times))
- ;; Check, that the buffers have been reverted.
- (dolist (buf buffers)
- (auto-revert--wait-for-revert buf)
- (with-current-buffer buf
- (should (string-equal (buffer-string) "another text")))))
-
- ;; Exit.
- (ignore-errors
- (dolist (buf buffers)
- (with-current-buffer buf (set-buffer-modified-p nil))
- (kill-buffer buf)))
- (ignore-errors (delete-file tmpfile)))));)
+ (ert-with-temp-file tmpfile
+ (let ((auto-revert-use-notify t)
+ (times '(120 60 30 15))
+ (num-buffers 10)
+ require-final-newline buffers)
+
+ (unwind-protect
+ ;; Check indirect buffers.
+ (ert-with-message-capture auto-revert--messages
+ (auto-revert-tests--write-file "any text" tmpfile (pop times))
+ (push (find-file-noselect tmpfile) buffers)
+ (with-current-buffer (car buffers)
+ (should (string-equal (buffer-string) "any text"))
+ ;; `buffer-stale--default-function' checks for
+ ;; `verify-visited-file-modtime'. We must ensure that
+ ;; it returns nil.
+ (auto-revert-mode 1)
+ (should auto-revert-mode))
+
+ (dotimes (i num-buffers)
+ (push (make-indirect-buffer
+ (car buffers)
+ (format "%s-%d" (buffer-file-name (car buffers)) i)
+ 'clone)
+ buffers))
+ (setq buffers (nreverse buffers))
+ (dolist (buf buffers)
+ (with-current-buffer buf
+ (should (string-equal (buffer-string) "any text"))
+ (should auto-revert-mode)))
+
+ (auto-revert-tests--write-file "another text" tmpfile (pop times))
+ ;; Check, that the buffer has been reverted.
+ (auto-revert--wait-for-revert (car buffers))
+ (dolist (buf buffers)
+ (with-current-buffer buf
+ (should (string-equal (buffer-string) "another text")))))
+
+ ;; Exit.
+ (ignore-errors
+ (dolist (buf buffers)
+ (with-current-buffer buf (set-buffer-modified-p nil))
+ (kill-buffer buf)))
+ (setq buffers nil)
+ (ignore-errors (delete-file tmpfile)))
+
+ ;; Check direct buffers.
+ (unwind-protect
+ (ert-with-message-capture auto-revert--messages
+ (auto-revert-tests--write-file "any text" tmpfile (pop times))
+
+ (dotimes (i num-buffers)
+ (push (generate-new-buffer
+ (format "%s-%d" (file-name-nondirectory tmpfile) i))
+ buffers))
+ (setq buffers (nreverse buffers))
+ (dolist (buf buffers)
+ (with-current-buffer buf
+ (insert-file-contents tmpfile 'visit)
+ (should (string-equal (buffer-string) "any text"))
+ (auto-revert-mode 1)
+ (should auto-revert-mode)))
+
+ (auto-revert-tests--write-file "another text" tmpfile (pop times))
+ ;; Check, that the buffers have been reverted.
+ (dolist (buf buffers)
+ (auto-revert--wait-for-revert buf)
+ (with-current-buffer buf
+ (should (string-equal (buffer-string) "another text")))))
+
+ ;; Exit.
+ (ignore-errors
+ (dolist (buf buffers)
+ (with-current-buffer buf (set-buffer-modified-p nil))
+ (kill-buffer buf)))))));)
(auto-revert--deftest-remote auto-revert-test07-auto-revert-several-buffers
"Check autorevert for several buffers visiting the same remote file.")
diff --git a/test/lisp/bookmark-tests.el b/test/lisp/bookmark-tests.el
index 9c33a27288a..dc2dec68ee3 100644
--- a/test/lisp/bookmark-tests.el
+++ b/test/lisp/bookmark-tests.el
@@ -371,16 +371,14 @@ Same as `with-bookmark-test' but also sets a temporary
`bookmark-default-file', evaluates BODY, and then runs the test
that saves and then loads the bookmark file."
`(with-bookmark-test
- (let ((file (make-temp-file "bookmark-tests-")))
- (unwind-protect
- (let ((bookmark-default-file file)
- (old-alist bookmark-alist))
- ,@body
- (bookmark-save nil file t)
- (setq bookmark-alist nil)
- (bookmark-load file nil t)
- (should (equal bookmark-alist old-alist)))
- (delete-file file)))))
+ (ert-with-temp-file file
+ (let ((bookmark-default-file file)
+ (old-alist bookmark-alist))
+ ,@body
+ (bookmark-save nil file t)
+ (setq bookmark-alist nil)
+ (bookmark-load file nil t)
+ (should (equal bookmark-alist old-alist))))))
(defvar bookmark-tests-non-ascii-data
(concat "Здра́вствуйте!" "中文,普通话,汉语" "åäöøñ"
diff --git a/test/lisp/buff-menu-tests.el b/test/lisp/buff-menu-tests.el
index 18c988656d3..b223a643083 100644
--- a/test/lisp/buff-menu-tests.el
+++ b/test/lisp/buff-menu-tests.el
@@ -24,19 +24,20 @@
;;; Code:
(require 'ert)
+(eval-when-compile (require 'ert-x))
(ert-deftest buff-menu-24962 ()
"Test for https://debbugs.gnu.org/24962 ."
- (let* ((file (make-temp-file "foo"))
- (buf (find-file file)))
- (unwind-protect
- (progn
- (rename-buffer " foo")
- (list-buffers)
- (with-current-buffer "*Buffer List*"
- (should (string= " foo" (buffer-name (Buffer-menu-buffer))))))
- (and (buffer-live-p buf) (kill-buffer buf))
- (and (file-exists-p file) (delete-file file)))))
+ (ert-with-temp-file file
+ :suffix "foo"
+ (let ((buf (find-file file)))
+ (unwind-protect
+ (progn
+ (rename-buffer " foo")
+ (list-buffers)
+ (with-current-buffer "*Buffer List*"
+ (should (string= " foo" (buffer-name (Buffer-menu-buffer))))))
+ (and (buffer-live-p buf) (kill-buffer buf))))))
(provide 'buff-menu-tests)
diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el
index 8a78a068242..3eb6b34c132 100644
--- a/test/lisp/calc/calc-tests.el
+++ b/test/lisp/calc/calc-tests.el
@@ -810,6 +810,12 @@ An existing calc stack is reused, otherwise a new one is created."
(should (equal (calcFunc-test6 3) (* (* 3 2) (- 3 1))))
(should (equal (calcFunc-test7 3) (* 3 2))))
+(ert-deftest calc-nth-root ()
+ ;; bug#51209
+ (let* ((calc-display-working-message nil)
+ (x (calc-tests--calc-to-number (math-pow 8 '(frac 1 6)))))
+ (should (< (abs (- x (sqrt 2.0))) 1.0e-10))))
+
(provide 'calc-tests)
;;; calc-tests.el ends here
diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el
index a1853ff3d4e..1551922028c 100644
--- a/test/lisp/calendar/icalendar-tests.el
+++ b/test/lisp/calendar/icalendar-tests.el
@@ -698,17 +698,18 @@ and ISO style input data must use english month names."
"Actually perform export test.
Argument INPUT input diary string.
Argument EXPECTED-OUTPUT expected iCalendar result string."
- (let ((temp-file (make-temp-file "icalendar-tests-ics")))
+ (ert-with-temp-file temp-file
+ :suffix "icalendar-tests-ics"
(unwind-protect
- (progn
- (with-temp-buffer
- (insert input)
- (icalendar-export-region (point-min) (point-max) temp-file))
- (save-excursion
- (find-file temp-file)
- (goto-char (point-min))
- (cond (expected-output
- (should (re-search-forward "^\\s-*BEGIN:VCALENDAR
+ (progn
+ (with-temp-buffer
+ (insert input)
+ (icalendar-export-region (point-min) (point-max) temp-file))
+ (save-excursion
+ (find-file temp-file)
+ (goto-char (point-min))
+ (cond (expected-output
+ (should (re-search-forward "^\\s-*BEGIN:VCALENDAR
PRODID:-//Emacs//NONSGML icalendar.el//EN
VERSION:2.0
BEGIN:VEVENT
@@ -717,23 +718,22 @@ UID:emacs[0-9]+
END:VEVENT
END:VCALENDAR
\\s-*$"
- nil t))
- (should (string-match
- (concat "^\\s-*"
- (regexp-quote (buffer-substring-no-properties
- (match-beginning 1) (match-end 1)))
- "\\s-*$")
- expected-output)))
- (t
- (should (re-search-forward "^\\s-*BEGIN:VCALENDAR
+ nil t))
+ (should (string-match
+ (concat "^\\s-*"
+ (regexp-quote (buffer-substring-no-properties
+ (match-beginning 1) (match-end 1)))
+ "\\s-*$")
+ expected-output)))
+ (t
+ (should (re-search-forward "^\\s-*BEGIN:VCALENDAR
PRODID:-//Emacs//NONSGML icalendar.el//EN
VERSION:2.0
END:VCALENDAR
\\s-*$"
- nil t))))))
+ nil t))))))
;; cleanup!!
- (kill-buffer (find-buffer-visiting temp-file))
- (delete-file temp-file))))
+ (kill-buffer (find-buffer-visiting temp-file)))))
(ert-deftest icalendar-export-ordinary-no-time ()
"Perform export test."
@@ -1031,7 +1031,8 @@ During import test the timezone is set to Central European Time."
(defun icalendar-tests--do-test-import (expected-output)
"Actually perform import test.
Argument EXPECTED-OUTPUT file containing expected diary string."
- (let ((temp-file (make-temp-file "icalendar-test-diary")))
+ (ert-with-temp-file temp-file
+ :suffix "icalendar-test-diary"
;; Test the Catch-the-mysterious-coding-header logic below.
;; Ruby-mode adds an after-save-hook which inserts the header!
;; (save-excursion
@@ -1061,8 +1062,7 @@ Argument EXPECTED-OUTPUT file containing expected diary string."
(let ((result (buffer-substring-no-properties (point-min) (point-max))))
(should (string= expected-output result)))
- (kill-buffer (find-buffer-visiting temp-file))
- (delete-file temp-file))))
+ (kill-buffer (find-buffer-visiting temp-file)))))
(ert-deftest icalendar-import-non-recurring ()
"Perform standard import tests."
@@ -1240,35 +1240,33 @@ Argument INPUT icalendar event string."
(defun icalendar-tests--do-test-cycle ()
"Actually perform import/export cycle test."
- (let ((temp-diary (make-temp-file "icalendar-test-diary"))
- (temp-ics (make-temp-file "icalendar-test-ics"))
- (org-input (buffer-substring-no-properties (point-min) (point-max))))
-
- (unwind-protect
- (progn
- ;; step 1: import
- (icalendar-import-buffer temp-diary t t)
-
- ;; step 2: export what was just imported
- (save-excursion
- (find-file temp-diary)
- (icalendar-export-region (point-min) (point-max) temp-ics))
-
- ;; compare the output of step 2 with the input of step 1
- (save-excursion
- (find-file temp-ics)
- (goto-char (point-min))
- ;;(when (re-search-forward "\nUID:.*\n" nil t)
- ;;(replace-match "\n"))
- (let ((cycled (buffer-substring-no-properties (point-min) (point-max))))
- (should (string= org-input cycled)))))
- ;; clean up
- (kill-buffer (find-buffer-visiting temp-diary))
- (with-current-buffer (find-buffer-visiting temp-ics)
- (set-buffer-modified-p nil)
- (kill-buffer (current-buffer)))
- (delete-file temp-diary)
- (delete-file temp-ics))))
+ (ert-with-temp-file temp-diary
+ (ert-with-temp-file temp-ics
+ (let ((org-input (buffer-substring-no-properties (point-min) (point-max))))
+
+ (unwind-protect
+ (progn
+ ;; step 1: import
+ (icalendar-import-buffer temp-diary t t)
+
+ ;; step 2: export what was just imported
+ (save-excursion
+ (find-file temp-diary)
+ (icalendar-export-region (point-min) (point-max) temp-ics))
+
+ ;; compare the output of step 2 with the input of step 1
+ (save-excursion
+ (find-file temp-ics)
+ (goto-char (point-min))
+ ;;(when (re-search-forward "\nUID:.*\n" nil t)
+ ;;(replace-match "\n"))
+ (let ((cycled (buffer-substring-no-properties (point-min) (point-max))))
+ (should (string= org-input cycled)))))
+ ;; clean up
+ (kill-buffer (find-buffer-visiting temp-diary))
+ (with-current-buffer (find-buffer-visiting temp-ics)
+ (set-buffer-modified-p nil)
+ (kill-buffer (current-buffer))))))))
(ert-deftest icalendar-cycle ()
"Perform cycling tests.
@@ -1635,28 +1633,32 @@ SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30
(let ((time (icalendar--decode-isodatetime string day zone)))
(format-time-string "%FT%T%z" (encode-time time) 0)))
-(defun icalendar-tests--decode-isodatetime (_ical-string)
+(ert-deftest icalendar-tests--decode-isodatetime ()
"Test `icalendar--decode-isodatetime'."
- (should (equal (icalendar-test--format "20040917T050910-0200")
- "2004-09-17T03:09:10+0000"))
- (should (equal (icalendar-test--format "20040917T050910")
+ (should (equal (icalendar-test--format "20040917T050910-02:00")
"2004-09-17T03:09:10+0000"))
+ (let ((orig (icalendar-test--format "20040917T050910")))
+ (unwind-protect
+ (progn
+ (set-time-zone-rule "UTC-02:00")
+ (should (equal (icalendar-test--format "20040917T050910")
+ "2004-09-17T03:09:10+0000"))
+ (should (equal (icalendar-test--format "20040917T0509")
+ "2004-09-17T03:09:00+0000"))
+ (should (equal (icalendar-test--format "20040917")
+ "2004-09-16T22:00:00+0000"))
+ (should (equal (icalendar-test--format "20040917T050910" 1)
+ "2004-09-18T03:09:10+0000"))
+ (should (equal (icalendar-test--format "20040917T050910" 30)
+ "2004-10-17T03:09:10+0000")))
+ (set-time-zone-rule 'wall) ;; (set-time-zone-rule nil) is broken
+ (should (equal orig (icalendar-test--format "20040917T050910")))))
(should (equal (icalendar-test--format "20040917T050910Z")
"2004-09-17T05:09:10+0000"))
- (should (equal (icalendar-test--format "20040917T0509")
- "2004-09-17T03:09:00+0000"))
- (should (equal (icalendar-test--format "20040917")
- "2004-09-16T22:00:00+0000"))
- (should (equal (icalendar-test--format "20040917T050910" 1)
- "2004-09-18T03:09:10+0000"))
- (should (equal (icalendar-test--format "20040917T050910" 30)
- "2004-10-17T03:09:10+0000"))
- (should (equal (icalendar-test--format "20040917T050910" -1)
- "2004-09-16T03:09:10+0000"))
-
+ (should (equal (icalendar-test--format "20040917T050910" -1 0)
+ "2004-09-16T05:09:10+0000"))
(should (equal (icalendar-test--format "20040917T050910" nil -3600)
"2004-09-17T06:09:10+0000")))
-
(provide 'icalendar-tests)
;;; icalendar-tests.el ends here
diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el
index 4568947c0b3..ed842e34fd6 100644
--- a/test/lisp/calendar/time-date-tests.el
+++ b/test/lisp/calendar/time-date-tests.el
@@ -41,6 +41,13 @@
(encode-time-value 1 2 3 4 3))
'(1 2 3 4))))
+(ert-deftest test-date-to-time ()
+ (should (equal (format-time-string "%F %T" (date-to-time "2021-12-04"))
+ "2021-12-04 00:00:00")))
+
+(ert-deftest test-days-between ()
+ (should (equal (days-between "2021-10-22" "2020-09-29") 388)))
+
(ert-deftest test-leap-year ()
(should-not (date-leap-year-p 1999))
(should-not (date-leap-year-p 1900))
@@ -48,13 +55,13 @@
(should (date-leap-year-p 2004)))
(ert-deftest test-days-to-time ()
- (should (equal (days-to-time 0) '(0 0)))
- (should (equal (days-to-time 1) '(1 20864)))
- (should (equal (days-to-time 999) '(1317 2688)))
- (should (equal (days-to-time 0.0) '(0 0 0 0)))
- (should (equal (days-to-time 0.5) '(0 43200 0 0)))
- (should (equal (days-to-time 1.0) '(1 20864 0 0)))
- (should (equal (days-to-time 999.0) '(1317 2688 0 0))))
+ (should (time-equal-p (days-to-time 0) '(0 0)))
+ (should (time-equal-p (days-to-time 1) '(1 20864)))
+ (should (time-equal-p (days-to-time 999) '(1317 2688)))
+ (should (time-equal-p (days-to-time 0.0) '(0 0 0 0)))
+ (should (time-equal-p (days-to-time 0.5) '(0 43200 0 0)))
+ (should (time-equal-p (days-to-time 1.0) '(1 20864 0 0)))
+ (should (time-equal-p (days-to-time 999.0) '(1317 2688 0 0))))
(ert-deftest test-seconds-to-string ()
(should (equal (seconds-to-string 0) "0s"))
@@ -163,7 +170,8 @@
(ert-deftest test-time-since ()
(should (time-equal-p 0 (time-since nil)))
- (should (= (cadr (time-since (time-subtract (current-time) 1))) 1)))
+ (should (time-equal-p 1 (time-convert (time-since (time-subtract nil 1))
+ 'integer))))
(ert-deftest test-time-decoded-period ()
(should (equal (decoded-time-period '(nil nil 1 nil nil nil nil nil nil))
diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el
index 9b5d990b9bd..79978a2041f 100644
--- a/test/lisp/calendar/todo-mode-tests.el
+++ b/test/lisp/calendar/todo-mode-tests.el
@@ -37,25 +37,24 @@
(defmacro with-todo-test (&rest body)
"Set up an isolated `todo-mode' test environment."
(declare (debug (body)))
- `(let* ((todo-test-home (make-temp-file "todo-test-home-" t))
- ;; Since we change HOME, clear this to avoid a conflict
- ;; e.g. if Emacs runs within the user's home directory.
- (abbreviated-home-dir nil)
- (process-environment (cons (format "HOME=%s" todo-test-home)
- process-environment))
- (todo-directory (ert-resource-directory))
- (todo-default-todo-file (todo-short-file-name
- (car (funcall todo-files-function)))))
- (unwind-protect
- (progn ,@body)
- ;; Restore pre-test-run state of test files.
- (dolist (f (directory-files todo-directory))
- (let ((buf (get-file-buffer f)))
- (when buf
- (with-current-buffer buf
- (restore-buffer-modified-p nil)
- (kill-buffer)))))
- (delete-directory todo-test-home t))))
+ `(ert-with-temp-directory todo-test-home
+ (let* (;; Since we change HOME, clear this to avoid a conflict
+ ;; e.g. if Emacs runs within the user's home directory.
+ (abbreviated-home-dir nil)
+ (process-environment (cons (format "HOME=%s" todo-test-home)
+ process-environment))
+ (todo-directory (ert-resource-directory))
+ (todo-default-todo-file (todo-short-file-name
+ (car (funcall todo-files-function)))))
+ (unwind-protect
+ (progn ,@body)
+ ;; Restore pre-test-run state of test files.
+ (dolist (f (directory-files todo-directory))
+ (let ((buf (get-file-buffer f)))
+ (when buf
+ (with-current-buffer buf
+ (restore-buffer-modified-p nil)
+ (kill-buffer)))))))))
(defun todo-test--show (num &optional archive)
"Display category NUM of test todo file.
diff --git a/test/lisp/cedet/semantic/bovine/gcc-tests.el b/test/lisp/cedet/semantic/bovine/gcc-tests.el
index d049f95b4cd..ba84ce4d81b 100644
--- a/test/lisp/cedet/semantic/bovine/gcc-tests.el
+++ b/test/lisp/cedet/semantic/bovine/gcc-tests.el
@@ -127,8 +127,9 @@ gcc version 2.95.2 19991024 (release)"
;; Some macOS machines run llvm when you type gcc. (!)
;; We can't even check if it's a symlink; it's a binary placed in
;; "/usr/bin/gcc". So check the output and just skip this test if
- ;; it says "Apple LLVM".
- (unless (string-match "Apple LLVM" (car semantic-gcc-test-strings))
+ ;; it looks like that's the case.
+ (unless (string-match "Apple LLVM\\|Xcode.app"
+ (car semantic-gcc-test-strings))
(semantic-gcc-test-output-parser))))
;;; gcc-tests.el ends here
diff --git a/test/lisp/cedet/srecode/fields-tests.el b/test/lisp/cedet/srecode/fields-tests.el
index 5f634a5e4ce..3c66f219bd6 100644
--- a/test/lisp/cedet/srecode/fields-tests.el
+++ b/test/lisp/cedet/srecode/fields-tests.el
@@ -57,8 +57,7 @@ It is filled with some text."
(end-of-line)
(forward-word -1)
- (setq f (srecode-field "Test"
- :name "TEST"
+ (setq f (srecode-field :name "TEST"
:start 6
:end 8))
@@ -99,19 +98,17 @@ It is filled with some text."
(reg nil)
(fields
(list
- (srecode-field "Test1" :name "TEST-1" :start 5 :end 10)
- (srecode-field "Test2" :name "TEST-2" :start 15 :end 20)
- (srecode-field "Test3" :name "TEST-3" :start 25 :end 30)
+ (srecode-field :name "TEST-1" :start 5 :end 10)
+ (srecode-field :name "TEST-2" :start 15 :end 20)
+ (srecode-field :name "TEST-3" :start 25 :end 30)
- (srecode-field "Test4" :name "TEST-4" :start 35 :end 35))
- ))
+ (srecode-field :name "TEST-4" :start 35 :end 35))))
(when (not (= (length srecode-field-archive) 4))
(error "Region Test: Found %d fields. Expected 4"
(length srecode-field-archive)))
- (setq reg (srecode-template-inserted-region "REG"
- :start 4
+ (setq reg (srecode-template-inserted-region :start 4
:end 40))
(srecode-overlaid-activate reg)
@@ -183,10 +180,10 @@ It is filled with some text."
;; Test variable linkage.
(let* ((srecode-field-archive nil)
- (f1 (srecode-field "Test1" :name "TEST" :start 6 :end 8))
- (f2 (srecode-field "Test2" :name "TEST" :start 28 :end 30))
- (f3 (srecode-field "Test3" :name "NOTTEST" :start 35 :end 40))
- (reg (srecode-template-inserted-region "REG" :start 4 :end 40)))
+ (f1 (srecode-field :name "TEST" :start 6 :end 8))
+ (f2 (srecode-field :name "TEST" :start 28 :end 30))
+ (f3 (srecode-field :name "NOTTEST" :start 35 :end 40))
+ (reg (srecode-template-inserted-region :start 4 :end 40)))
(srecode-overlaid-activate reg)
(when (not (string= (srecode-overlaid-text f1)
diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el
index e1bac81a185..0bd5c1e9d15 100644
--- a/test/lisp/comint-tests.el
+++ b/test/lisp/comint-tests.el
@@ -43,6 +43,7 @@
"PIN for user:" ; Bug#35523
"Password (again):"
"Enter password:"
+ "(user@host) Password: " ; openssh-8.6p1
"Current password:" ; "passwd" (to change password) in Debian.
"Enter encryption key: " ; ccrypt
"Enter decryption key: " ; ccrypt
diff --git a/test/lisp/custom-tests.el b/test/lisp/custom-tests.el
index f4c43b0a148..769db6ceab4 100644
--- a/test/lisp/custom-tests.el
+++ b/test/lisp/custom-tests.el
@@ -25,20 +25,9 @@
(require 'wid-edit)
(require 'cus-edit)
-(defmacro custom-tests--with-temp-dir (&rest body)
- "Eval BODY with `temporary-file-directory' bound to a fresh directory.
-Ensure the directory is recursively deleted after the fact."
- (declare (debug t) (indent 0))
- (let ((dir (make-symbol "dir")))
- `(let ((,dir (file-name-as-directory (make-temp-file "custom-tests-" t))))
- (unwind-protect
- (let ((temporary-file-directory ,dir))
- ,@body)
- (delete-directory ,dir t)))))
-
(ert-deftest custom-theme--load-path ()
"Test `custom-theme--load-path' behavior."
- (custom-tests--with-temp-dir
+ (ert-with-temp-directory temporary-file-directory
;; Path is empty.
(let ((custom-theme-load-path ()))
(should (null (custom-theme--load-path))))
@@ -50,28 +39,28 @@ Ensure the directory is recursively deleted after the fact."
(should (null (custom-theme--load-path))))
;; Path comprises existing file.
- (let* ((file (make-temp-file "file"))
- (custom-theme-load-path (list file)))
- (should (file-exists-p file))
- (should (not (file-directory-p file)))
- (should (null (custom-theme--load-path))))
+ (ert-with-temp-file file
+ (let* ((custom-theme-load-path (list file)))
+ (should (file-exists-p file))
+ (should (not (file-directory-p file)))
+ (should (null (custom-theme--load-path)))))
;; Path comprises existing directory.
- (let* ((dir (make-temp-file "dir" t))
- (custom-theme-load-path (list dir)))
- (should (file-directory-p dir))
- (should (equal (custom-theme--load-path) custom-theme-load-path)))
+ (ert-with-temp-directory dir
+ (let* ((custom-theme-load-path (list dir)))
+ (should (file-directory-p dir))
+ (should (equal (custom-theme--load-path) custom-theme-load-path))))
;; Expand `custom-theme-directory' path element.
(let ((custom-theme-load-path '(custom-theme-directory)))
(let ((custom-theme-directory (make-temp-name temporary-file-directory)))
(should (not (file-exists-p custom-theme-directory)))
(should (null (custom-theme--load-path))))
- (let ((custom-theme-directory (make-temp-file "file")))
+ (ert-with-temp-file custom-theme-directory
(should (file-exists-p custom-theme-directory))
(should (not (file-directory-p custom-theme-directory)))
(should (null (custom-theme--load-path))))
- (let ((custom-theme-directory (make-temp-file "dir" t)))
+ (ert-with-temp-directory custom-theme-directory
(should (file-directory-p custom-theme-directory))
(should (equal (custom-theme--load-path)
(list custom-theme-directory)))))
@@ -97,7 +86,7 @@ Ensure the directory is recursively deleted after the fact."
(ert-deftest custom-tests-require-theme ()
"Test `require-theme'."
(require 'warnings)
- (custom-tests--with-temp-dir
+ (ert-with-temp-directory temporary-file-directory
(let* ((default-directory temporary-file-directory)
(custom-theme-load-path (list default-directory))
(load-path ()))
diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el
index d5940ed8ca7..69fc95ba552 100644
--- a/test/lisp/dired-aux-tests.el
+++ b/test/lisp/dired-aux-tests.el
@@ -19,26 +19,25 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'dired-aux)
(eval-when-compile (require 'cl-lib))
(ert-deftest dired-test-bug27496 ()
"Test for https://debbugs.gnu.org/27496 ."
(skip-unless (executable-find shell-file-name))
- (let* ((foo (make-temp-file "foo"))
- (files (list foo)))
- (unwind-protect
- (cl-letf (((symbol-function 'read-char-from-minibuffer) 'error))
- (dired temporary-file-directory)
- (dired-goto-file foo)
- ;; `dired-do-shell-command' returns nil on success.
- (should-error (dired-do-shell-command "ls ? ./?" nil files))
- (should-error (dired-do-shell-command "ls ./? ?" nil files))
- (should-not (dired-do-shell-command "ls ? ?" nil files))
- (should-error (dired-do-shell-command "ls * ./*" nil files))
- (should-not (dired-do-shell-command "ls * *" nil files))
- (should-not (dired-do-shell-command "ls ? ./`?`" nil files)))
- (delete-file foo))))
+ (ert-with-temp-file foo
+ (let* ((files (list foo)))
+ (cl-letf (((symbol-function 'read-char-from-minibuffer) 'error))
+ (dired temporary-file-directory)
+ (dired-goto-file foo)
+ ;; `dired-do-shell-command' returns nil on success.
+ (should-error (dired-do-shell-command "ls ? ./?" nil files))
+ (should-error (dired-do-shell-command "ls ./? ?" nil files))
+ (should-not (dired-do-shell-command "ls ? ?" nil files))
+ (should-error (dired-do-shell-command "ls * ./*" nil files))
+ (should-not (dired-do-shell-command "ls * *" nil files))
+ (should-not (dired-do-shell-command "ls ? ./`?`" nil files))))))
;; Auxiliary macro for `dired-test-bug28834': it binds
;; `dired-create-destination-dirs' to CREATE-DIRS and execute BODY.
@@ -47,28 +46,25 @@
(defmacro with-dired-bug28834-test (create-dirs yes-or-no &rest body)
(declare (debug (form symbolp body)))
(let ((foo (make-symbol "foo")))
- `(let* ((,foo (make-temp-file "foo" 'dir))
- (dired-create-destination-dirs ,create-dirs))
- (setq from (make-temp-file "from"))
- (setq to-cp
- (expand-file-name
- "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo))))
- (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)
- ;; clean up
- (delete-directory ,foo 'recursive)
- (delete-file from)))))
+ `(ert-with-temp-directory ,foo
+ (ert-with-temp-file from
+ (let* ((dired-create-destination-dirs ,create-dirs))
+ (setq to-cp
+ (expand-file-name
+ "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo))))
+ (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)))))))
(ert-deftest dired-test-bug28834 ()
"test for https://debbugs.gnu.org/28834 ."
- (let (from to-cp to-mv)
+ (let (to-cp to-mv)
;; `dired-create-destination-dirs' set to 'always.
(with-dired-bug28834-test
'always nil
diff --git a/test/lisp/dired-resources/insert-directory/test_dir/bar b/test/lisp/dired-resources/insert-directory/test_dir/bar
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/test/lisp/dired-resources/insert-directory/test_dir/bar
diff --git a/test/lisp/dired-resources/insert-directory/test_dir/foo b/test/lisp/dired-resources/insert-directory/test_dir/foo
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/test/lisp/dired-resources/insert-directory/test_dir/foo
diff --git a/test/lisp/dired-resources/insert-directory/test_dir_other/bar b/test/lisp/dired-resources/insert-directory/test_dir_other/bar
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/test/lisp/dired-resources/insert-directory/test_dir_other/bar
diff --git a/test/lisp/dired-resources/insert-directory/test_dir_other/foo b/test/lisp/dired-resources/insert-directory/test_dir_other/foo
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/test/lisp/dired-resources/insert-directory/test_dir_other/foo
diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el
index 83f7dc3cac7..1c4f37bd327 100644
--- a/test/lisp/dired-tests.el
+++ b/test/lisp/dired-tests.el
@@ -19,6 +19,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'dired)
(ert-deftest dired-autoload ()
@@ -141,116 +142,113 @@
(ert-deftest dired-test-bug27243-01 ()
"Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#5 ."
- (let* ((test-dir (file-name-as-directory (make-temp-file "test-dir-" t)))
- (save-pos (lambda ()
- (with-current-buffer (car (dired-buffers-for-dir test-dir))
- (dired-save-positions))))
- (dired-auto-revert-buffer t) buffers)
- ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the
- ;; corresponding long file names exist, otherwise such names trip
- ;; dired-buffers-for-dir.
- (if (eq system-type 'windows-nt)
- (setq test-dir (file-truename test-dir)))
- (should-not (dired-buffers-for-dir test-dir))
- (with-current-buffer (find-file-noselect test-dir)
- (make-directory "test-subdir"))
- (message "Saved pos: %S" (funcall save-pos))
- ;; Point must be at end-of-buffer.
- (with-current-buffer (car (dired-buffers-for-dir test-dir))
- (should (eobp)))
- (push (dired test-dir) buffers)
- (message "Saved pos: %S" (funcall save-pos))
- ;; Previous dired call shouldn't create a new buffer: must visit the one
- ;; created by `find-file-noselect' above.
- (should (eq 1 (length (dired-buffers-for-dir test-dir))))
- (unwind-protect
- (let ((buf (current-buffer))
- (pt1 (point))
- (test-file (concat (file-name-as-directory "test-subdir")
- "test-file")))
- (message "Saved pos: %S" (funcall save-pos))
- (write-region "Test" nil test-file nil 'silent nil 'excl)
- (message "Saved pos: %S" (funcall save-pos))
- ;; Sanity check: point should now be on the subdirectory.
- (should (equal (dired-file-name-at-point)
- (concat test-dir (file-name-as-directory "test-subdir"))))
- (message "Saved pos: %S" (funcall save-pos))
- (push (dired-find-file) buffers)
- (let ((pt2 (point))) ; Point is on test-file.
- (pop-to-buffer-same-window buf)
- ;; Sanity check: point should now be back on the subdirectory.
- (should (eq (point) pt1))
+ (ert-with-temp-directory test-dir
+ (let* ((save-pos (lambda ()
+ (with-current-buffer (car (dired-buffers-for-dir test-dir))
+ (dired-save-positions))))
+ (dired-auto-revert-buffer t) buffers)
+ ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the
+ ;; corresponding long file names exist, otherwise such names trip
+ ;; dired-buffers-for-dir.
+ (if (eq system-type 'windows-nt)
+ (setq test-dir (file-truename test-dir)))
+ (should-not (dired-buffers-for-dir test-dir))
+ (with-current-buffer (find-file-noselect test-dir)
+ (make-directory "test-subdir"))
+ (message "Saved pos: %S" (funcall save-pos))
+ ;; Point must be at end-of-buffer.
+ (with-current-buffer (car (dired-buffers-for-dir test-dir))
+ (should (eobp)))
+ (push (dired test-dir) buffers)
+ (message "Saved pos: %S" (funcall save-pos))
+ ;; Previous dired call shouldn't create a new buffer: must visit the one
+ ;; created by `find-file-noselect' above.
+ (should (eq 1 (length (dired-buffers-for-dir test-dir))))
+ (unwind-protect
+ (let ((buf (current-buffer))
+ (pt1 (point))
+ (test-file (concat (file-name-as-directory "test-subdir")
+ "test-file")))
+ (message "Saved pos: %S" (funcall save-pos))
+ (write-region "Test" nil test-file nil 'silent nil 'excl)
+ (message "Saved pos: %S" (funcall save-pos))
+ ;; Sanity check: point should now be on the subdirectory.
+ (should (equal (dired-file-name-at-point)
+ (concat test-dir (file-name-as-directory "test-subdir"))))
+ (message "Saved pos: %S" (funcall save-pos))
(push (dired-find-file) buffers)
- (should (eq (point) pt2))))
- (dolist (buf buffers)
- (when (buffer-live-p buf) (kill-buffer buf)))
- (delete-directory test-dir t))))
+ (let ((pt2 (point))) ; Point is on test-file.
+ (pop-to-buffer-same-window buf)
+ ;; Sanity check: point should now be back on the subdirectory.
+ (should (eq (point) pt1))
+ (push (dired-find-file) buffers)
+ (should (eq (point) pt2))))
+ (dolist (buf buffers)
+ (when (buffer-live-p buf) (kill-buffer buf)))))))
(ert-deftest dired-test-bug27243-02 ()
"Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#28 ."
- (let ((test-dir (make-temp-file "test-dir-" t))
- (dired-auto-revert-buffer t) buffers)
- ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the
- ;; corresponding long file names exist, otherwise such names trip
- ;; string comparisons below.
- (if (eq system-type 'windows-nt)
- (setq test-dir (file-truename test-dir)))
- (with-current-buffer (find-file-noselect test-dir)
- (make-directory "test-subdir"))
- (push (dired test-dir) buffers)
- (unwind-protect
- (let ((buf (current-buffer))
- (pt1 (point))
- (test-file (concat (file-name-as-directory "test-subdir")
- "test-file")))
- (write-region "Test" nil test-file nil 'silent nil 'excl)
- ;; Sanity check: point should now be on the subdirectory.
- (should (equal (dired-file-name-at-point)
- (concat (file-name-as-directory test-dir)
- (file-name-as-directory "test-subdir"))))
- (push (dired-find-file) buffers)
- ;; Point is on test-file.
- (switch-to-buffer buf)
- ;; Sanity check: point should now be back on the subdirectory.
- (should (eq (point) pt1))
- (push (dired test-dir) buffers)
- (should (eq (point) pt1)))
- (dolist (buf buffers)
- (when (buffer-live-p buf) (kill-buffer buf)))
- (delete-directory test-dir t))))
+ (ert-with-temp-directory test-dir
+ (let ((dired-auto-revert-buffer t) buffers)
+ ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the
+ ;; corresponding long file names exist, otherwise such names trip
+ ;; string comparisons below.
+ (if (eq system-type 'windows-nt)
+ (setq test-dir (file-truename test-dir)))
+ (with-current-buffer (find-file-noselect test-dir)
+ (make-directory "test-subdir"))
+ (push (dired test-dir) buffers)
+ (unwind-protect
+ (let ((buf (current-buffer))
+ (pt1 (point))
+ (test-file (concat (file-name-as-directory "test-subdir")
+ "test-file")))
+ (write-region "Test" nil test-file nil 'silent nil 'excl)
+ ;; Sanity check: point should now be on the subdirectory.
+ (should (equal (dired-file-name-at-point)
+ (concat (file-name-as-directory test-dir)
+ (file-name-as-directory "test-subdir"))))
+ (push (dired-find-file) buffers)
+ ;; Point is on test-file.
+ (switch-to-buffer buf)
+ ;; Sanity check: point should now be back on the subdirectory.
+ (should (eq (point) pt1))
+ (push (dired test-dir) buffers)
+ (should (eq (point) pt1)))
+ (dolist (buf buffers)
+ (when (buffer-live-p buf) (kill-buffer buf)))))))
(ert-deftest dired-test-bug27243-03 ()
"Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#61 ."
- (let ((test-dir (make-temp-file "test-dir-" t))
- (dired-auto-revert-buffer t)
- allbufs)
- (unwind-protect
- (progn
- (with-current-buffer (find-file-noselect test-dir)
- (push (current-buffer) allbufs)
- (make-directory "test-subdir1")
- (make-directory "test-subdir2")
- (let ((test-file1 "test-file1")
- (test-file2 "test-file2"))
- (with-current-buffer (find-file-noselect "test-subdir1")
- (push (current-buffer) allbufs)
- (write-region "Test1" nil test-file1 nil 'silent nil 'excl))
- (with-current-buffer (find-file-noselect "test-subdir2")
- (push (current-buffer) allbufs)
- (write-region "Test2" nil test-file2 nil 'silent nil 'excl))))
- ;; Call find-file with a wild card and test point in each file.
- (let ((buffers (find-file (concat (file-name-as-directory test-dir)
- "*")
- t)))
- (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)))
- (dolist (buf allbufs)
- (when (buffer-live-p buf) (kill-buffer buf)))
- (delete-directory test-dir t))))
+ (ert-with-temp-directory test-dir
+ (let ((dired-auto-revert-buffer t)
+ allbufs)
+ (unwind-protect
+ (progn
+ (with-current-buffer (find-file-noselect test-dir)
+ (push (current-buffer) allbufs)
+ (make-directory "test-subdir1")
+ (make-directory "test-subdir2")
+ (let ((test-file1 "test-file1")
+ (test-file2 "test-file2"))
+ (with-current-buffer (find-file-noselect "test-subdir1")
+ (push (current-buffer) allbufs)
+ (write-region "Test1" nil test-file1 nil 'silent nil 'excl))
+ (with-current-buffer (find-file-noselect "test-subdir2")
+ (push (current-buffer) allbufs)
+ (write-region "Test2" nil test-file2 nil 'silent nil 'excl))))
+ ;; Call find-file with a wild card and test point in each file.
+ (let ((buffers (find-file (concat (file-name-as-directory test-dir)
+ "*")
+ t)))
+ (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)))
+ (dolist (buf allbufs)
+ (when (buffer-live-p buf) (kill-buffer buf)))))))
(ert-deftest dired-test-bug7131 ()
"Test for https://debbugs.gnu.org/7131 ."
@@ -274,22 +272,21 @@
;; ls-lisp-tests.el and em-ls-tests.el.
(skip-unless (and (not (featurep 'ls-lisp))
(not (featurep 'eshell))))
- (let* ((dir (make-temp-file "bug27631" 'dir))
- (dir1 (expand-file-name "dir1" dir))
- (dir2 (expand-file-name "dir2" dir))
- (default-directory dir)
- buf)
- (unwind-protect
- (progn
- (make-directory dir1)
- (make-directory dir2)
- (with-temp-file (expand-file-name "a.txt" dir1))
- (with-temp-file (expand-file-name "b.txt" dir2))
- (setq buf (dired (expand-file-name "dir*/*.txt" dir)))
- (dired-toggle-marks)
- (should (cdr (dired-get-marked-files))))
- (delete-directory dir 'recursive)
- (when (buffer-live-p buf) (kill-buffer buf)))))
+ (ert-with-temp-directory dir
+ (let* ((dir1 (expand-file-name "dir1" dir))
+ (dir2 (expand-file-name "dir2" dir))
+ (default-directory dir)
+ buf)
+ (unwind-protect
+ (progn
+ (make-directory dir1)
+ (make-directory dir2)
+ (with-temp-file (expand-file-name "a.txt" dir1))
+ (with-temp-file (expand-file-name "b.txt" dir2))
+ (setq buf (dired (expand-file-name "dir*/*.txt" dir)))
+ (dired-toggle-marks)
+ (should (cdr (dired-get-marked-files))))
+ (when (buffer-live-p buf) (kill-buffer buf))))))
(ert-deftest dired-test-bug27899 ()
"Test for https://debbugs.gnu.org/27899 ."
@@ -310,72 +307,69 @@
(ert-deftest dired-test-bug27968 ()
"Test for https://debbugs.gnu.org/27968 ."
- (let* ((top-dir (make-temp-file "top-dir" t))
- (subdir (expand-file-name "subdir" top-dir))
- (header-len-fn (lambda ()
- (save-excursion
- (goto-char 1)
- (forward-line 1)
- (- (point-at-eol) (point)))))
- orig-len len diff pos line-nb)
- (make-directory subdir 'parents)
- (unwind-protect
- (with-current-buffer (dired-noselect subdir)
- (setq orig-len (funcall header-len-fn)
- pos (point)
- line-nb (line-number-at-pos))
- ;; Bug arises when the header line changes its length; this may
- ;; happen if the used space has changed: for instance, with the
- ;; creation of additional files.
- (make-directory "subdir" t)
- (dired-revert)
- ;; Change the header line.
- (save-excursion
- (goto-char 1)
- (forward-line 1)
- (let ((inhibit-read-only t)
- (new-header " test-bug27968"))
- (delete-region (point) (point-at-eol))
- (when (= orig-len (length new-header))
- ;; Wow lucky guy! I must buy lottery today.
- (setq new-header (concat new-header " :-)")))
- (insert new-header)))
- (setq len (funcall header-len-fn)
- diff (- len orig-len))
- (should-not (zerop diff)) ; Header length has changed.
- ;; If diff > 0, then the point moves back.
- ;; If diff < 0, then the point moves forward.
- ;; If diff = 0, then the point doesn't move.
- ;; Sometimes this point movement causes
- ;; line-nb != (line-number-at-pos pos), so that we get
- ;; an unexpected file at point if we store buffer points.
- ;; Note that the line number before/after revert
- ;; doesn't change.
- (should (= line-nb
- (line-number-at-pos)
- (line-number-at-pos (+ pos diff))))
- ;; After revert, the point must be in 'subdir' line.
- (should (equal "subdir" (dired-get-filename 'local t))))
- (delete-directory top-dir t))))
+ (ert-with-temp-directory top-dir
+ (let* ((subdir (expand-file-name "subdir" top-dir))
+ (header-len-fn (lambda ()
+ (save-excursion
+ (goto-char 1)
+ (forward-line 1)
+ (- (point-at-eol) (point)))))
+ orig-len len diff pos line-nb)
+ (make-directory subdir 'parents)
+ (with-current-buffer (dired-noselect subdir)
+ (setq orig-len (funcall header-len-fn)
+ pos (point)
+ line-nb (line-number-at-pos))
+ ;; Bug arises when the header line changes its length; this may
+ ;; happen if the used space has changed: for instance, with the
+ ;; creation of additional files.
+ (make-directory "subdir" t)
+ (dired-revert)
+ ;; Change the header line.
+ (save-excursion
+ (goto-char 1)
+ (forward-line 1)
+ (let ((inhibit-read-only t)
+ (new-header " test-bug27968"))
+ (delete-region (point) (point-at-eol))
+ (when (= orig-len (length new-header))
+ ;; Wow lucky guy! I must buy lottery today.
+ (setq new-header (concat new-header " :-)")))
+ (insert new-header)))
+ (setq len (funcall header-len-fn)
+ diff (- len orig-len))
+ (should-not (zerop diff)) ; Header length has changed.
+ ;; If diff > 0, then the point moves back.
+ ;; If diff < 0, then the point moves forward.
+ ;; If diff = 0, then the point doesn't move.
+ ;; Sometimes this point movement causes
+ ;; line-nb != (line-number-at-pos pos), so that we get
+ ;; an unexpected file at point if we store buffer points.
+ ;; Note that the line number before/after revert
+ ;; doesn't change.
+ (should (= line-nb
+ (line-number-at-pos)
+ (line-number-at-pos (+ pos diff))))
+ ;; After revert, the point must be in 'subdir' line.
+ (should (equal "subdir" (dired-get-filename 'local t)))))))
(defmacro dired-test-with-temp-dirs (just-empty-dirs &rest body)
"Helper macro for Bug#27940 test."
(declare (indent 1) (debug body))
(let ((dir (make-symbol "dir")))
- `(let* ((,dir (make-temp-file "bug27940" t))
- (dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts.
- (inhibit-message t)
- (default-directory ,dir))
- (dotimes (i 5) (make-directory (format "empty-dir-%d" i)))
- (unless ,just-empty-dirs
- (dotimes (i 5) (make-directory (format "non-empty-%d/foo" i) 'parents)))
- (make-directory "zeta-empty-dir")
- (unwind-protect
- (progn
- ,@body)
- (delete-directory ,dir t)
- (kill-buffer (current-buffer))))))
+ `(ert-with-temp-directory ,dir
+ (let* ((dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts.
+ (inhibit-message t)
+ (default-directory ,dir))
+ (dotimes (i 5) (make-directory (format "empty-dir-%d" i)))
+ (unless ,just-empty-dirs
+ (dotimes (i 5) (make-directory (format "non-empty-%d/foo" i) 'parents)))
+ (make-directory "zeta-empty-dir")
+ (unwind-protect
+ (progn
+ ,@body)
+ (kill-buffer (current-buffer)))))))
(ert-deftest dired-test-bug27940 ()
"Test for https://debbugs.gnu.org/27940 ."
@@ -517,5 +511,92 @@
(when (file-directory-p testdir)
(delete-directory testdir t)))))
+;; `dired-insert-directory' output tests.
+(let* ((data-dir "insert-directory")
+ (test-dir (file-name-as-directory
+ (ert-resource-file
+ (concat data-dir "/test_dir"))))
+ (test-dir-other (file-name-as-directory
+ (ert-resource-file
+ (concat data-dir "/test_dir_other"))))
+ (test-files `(,test-dir "foo" "bar")) ;expected files to be found
+ ;; Free space test data for `insert-directory'.
+ ;; Meaning: (path free-space-bytes-to-stub expected-free-space-string)
+ (free-data `((,test-dir 10 "available 10 B")
+ (,test-dir-other 100 "available 100 B")
+ (:default 999 "available 999 B"))))
+
+ (defun files-tests--look-up-free-data (path)
+ "Look up free space test data, with a default for unspecified paths."
+ (let ((path (file-name-as-directory path)))
+ (cdr (or (assoc path free-data)
+ (assoc :default free-data)))))
+
+ (defun files-tests--make-file-system-info-stub (&optional static-path)
+ "Return a stub for `file-system-info' using dynamic or static test data.
+If that data should be static, pass STATIC-PATH to choose which
+path's data to use."
+ (lambda (path)
+ (let* ((path (cond (static-path)
+ ;; file-system-info knows how to handle ".", so we
+ ;; do the same thing
+ ((equal "." path) default-directory)
+ (path)))
+ (return-size
+ ;; It is always defined but this silences the byte-compiler:
+ (when (fboundp 'files-tests--look-up-free-data)
+ (car (files-tests--look-up-free-data path)))))
+ (list return-size return-size return-size))))
+
+ (defun files-tests--insert-directory-output (dir &optional _verbose)
+ "Run `insert-directory' and return its output."
+ (with-current-buffer-window "files-tests--insert-directory" nil nil
+ (let ((dired-free-space 'separate))
+ (dired-insert-directory dir "-l" nil nil t))
+ (buffer-substring-no-properties (point-min) (point-max))))
+
+ (ert-deftest files-tests-insert-directory-shows-files ()
+ "Verify `insert-directory' reports the files in the directory."
+ ;; It is always defined but this silences the byte-compiler:
+ (when (fboundp 'files-tests--insert-directory-output)
+ (let* ((test-dir (car test-files))
+ (files (cdr test-files))
+ (output (files-tests--insert-directory-output test-dir)))
+ (dolist (file files)
+ (should (string-match-p file output))))))
+
+ (defun files-tests--insert-directory-shows-given-free (dir &optional
+ info-func)
+ "Run `insert-directory' and verify it reports the correct available space.
+Stub `file-system-info' to ensure the available space is consistent,
+either with the given stub function or a default one using test data."
+ ;; It is always defined but this silences the byte-compiler:
+ (when (and (fboundp 'files-tests--make-file-system-info-stub)
+ (fboundp 'files-tests--look-up-free-data)
+ (fboundp 'files-tests--insert-directory-output))
+ (cl-letf (((symbol-function 'file-system-info)
+ (or info-func
+ (files-tests--make-file-system-info-stub))))
+ (should (string-match-p (cadr
+ (files-tests--look-up-free-data dir))
+ (files-tests--insert-directory-output dir t))))))
+
+ (ert-deftest files-tests-insert-directory-shows-free ()
+ "Test that verbose `insert-directory' shows the correct available space."
+ ;; It is always defined but this silences the byte-compiler:
+ (when (and (fboundp 'files-tests--insert-directory-shows-given-free)
+ (fboundp 'files-tests--make-file-system-info-stub))
+ (files-tests--insert-directory-shows-given-free
+ test-dir
+ (files-tests--make-file-system-info-stub test-dir))))
+
+ (ert-deftest files-tests-bug-50630 ()
+ "Verify verbose `insert-directory' shows free space of the target directory.
+The current directory at call time should not affect the result (Bug#50630)."
+ ;; It is always defined but this silences the byte-compiler:
+ (when (fboundp 'files-tests--insert-directory-shows-given-free)
+ (let ((default-directory test-dir-other))
+ (files-tests--insert-directory-shows-given-free test-dir)))))
+
(provide 'dired-tests)
;;; dired-tests.el ends here
diff --git a/test/lisp/dired-x-tests.el b/test/lisp/dired-x-tests.el
index d00815e543c..69c88c060a1 100644
--- a/test/lisp/dired-x-tests.el
+++ b/test/lisp/dired-x-tests.el
@@ -19,6 +19,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'dired-x)
@@ -31,23 +32,20 @@
(append (copy-sequence dirs)
(delete "c" (copy-sequence files)))
#'string<))
- (dir (make-temp-file "Bug25942" 'dir))
(extension "c"))
- (unwind-protect
- (progn
- (dolist (d dirs)
- (make-directory (expand-file-name d dir)))
- (dolist (f files)
- (write-region nil nil (expand-file-name f dir)))
- (dired dir)
- (dired-mark-extension extension)
- (should (equal '("bar.c" "foo.c")
- (sort (dired-get-marked-files 'local) #'string<)))
- (dired-unmark-all-marks)
- (dired-mark-suffix extension)
- (should (equal all-but-c
- (sort (dired-get-marked-files 'local) #'string<))))
- (delete-directory dir 'recursive))))
+ (ert-with-temp-directory dir
+ (dolist (d dirs)
+ (make-directory (expand-file-name d dir)))
+ (dolist (f files)
+ (write-region nil nil (expand-file-name f dir)))
+ (dired dir)
+ (dired-mark-extension extension)
+ (should (equal '("bar.c" "foo.c")
+ (sort (dired-get-marked-files 'local) #'string<)))
+ (dired-unmark-all-marks)
+ (dired-mark-suffix extension)
+ (should (equal all-but-c
+ (sort (dired-get-marked-files 'local) #'string<))))))
(ert-deftest dired-guess-default ()
(let ((dired-guess-shell-alist-user nil)
@@ -62,5 +60,15 @@
(should (equal (dired-guess-default '("/tmp/foo.png" "/tmp/foo.txt"))
nil))))
+(ert-deftest dired-x--string-to-number ()
+ (should (= (dired-x--string-to-number "2.4K") 2457.6))
+ (should (= (dired-x--string-to-number "2400") 2400))
+ (should (= (dired-x--string-to-number "123.4M") 129394278.4))
+ (should (= (dired-x--string-to-number "123.40000M") 129394278.4))
+ (should (= (dired-x--string-to-number "4.134") 4134))
+ (should (= (dired-x--string-to-number "4,134") 4134))
+ (should (= (dired-x--string-to-number "4 134") 4134))
+ (should (= (dired-x--string-to-number "41,52,134") 4152134)))
+
(provide 'dired-x-tests)
;;; dired-x-tests.el ends here
diff --git a/test/lisp/edmacro-tests.el b/test/lisp/edmacro-tests.el
new file mode 100644
index 00000000000..974f506a367
--- /dev/null
+++ b/test/lisp/edmacro-tests.el
@@ -0,0 +1,47 @@
+;;; edmacro-tests.el --- Tests for edmacro.el -*- lexical-binding:t -*-
+
+;; Copyright (C) 2021 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 'edmacro)
+
+(ert-deftest edmacro-test-edmacro-parse-keys ()
+ (should (equal (edmacro-parse-keys "") ""))
+ (should (equal (edmacro-parse-keys "x") "x"))
+ (should (equal (edmacro-parse-keys "C-a") "\C-a"))
+
+ ;; comments
+ (should (equal (edmacro-parse-keys ";; foobar") ""))
+ (should (equal (edmacro-parse-keys ";;;") ""))
+ (should (equal (edmacro-parse-keys "; ; ;") ";;;"))
+ (should (equal (edmacro-parse-keys "REM foobar") ""))
+ (should (equal (edmacro-parse-keys "x ;; foobar") "x"))
+ (should (equal (edmacro-parse-keys "x REM foobar") "x"))
+ (should (equal (edmacro-parse-keys "<<goto-line>>")
+ [134217848 103 111 116 111 45 108 105 110 101 13]))
+
+ ;; repetitions
+ (should (equal (edmacro-parse-keys "3*x") "xxx"))
+ (should (equal (edmacro-parse-keys "3*C-m") "\C-m\C-m\C-m"))
+ (should (equal (edmacro-parse-keys "10*foo") "foofoofoofoofoofoofoofoofoofoo")))
+
+;;; edmacro-tests.el ends here
diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el
index f59f9d9ccac..85727bd0916 100644
--- a/test/lisp/electric-tests.el
+++ b/test/lisp/electric-tests.el
@@ -97,8 +97,8 @@
(with-temp-buffer
(cl-progv
;; FIXME: avoid `eval'
- (mapcar #'car (eval bindings))
- (mapcar #'cdr (eval bindings))
+ (mapcar #'car (eval bindings t))
+ (mapcar #'cdr (eval bindings t))
(dlet ((python-indent-guess-indent-offset-verbose nil))
(funcall mode)
(insert fixture)
@@ -176,7 +176,7 @@ The buffer's contents should %s:
expected-string
expected-point
bindings
- (modes '(quote (ruby-mode js-mode python-mode)))
+ (modes '(quote (ruby-mode js-mode python-mode c-mode)))
(test-in-comments t)
(test-in-strings t)
(test-in-code t)
@@ -187,7 +187,7 @@ The buffer's contents should %s:
(fixture-fn '#'electric-pair-mode))
`(progn
,@(cl-loop
- for mode in (eval modes) ;FIXME: avoid `eval'
+ for mode in (eval modes t) ;FIXME: avoid `eval'
append
(cl-loop
for (prefix suffix extra-desc) in
@@ -428,7 +428,9 @@ baz\"\""
:bindings '((electric-pair-skip-whitespace . chomp))
:test-in-strings nil
:test-in-code nil
- :test-in-comments t)
+ :test-in-comments t
+ :fixture-fn (lambda () (when (eq major-mode 'c-mode)
+ (c-toggle-comment-style -1))))
(define-electric-pair-test whitespace-skipping-for-quotes-not-outside
" \" \"" "\"-----" :expected-string "\"\" \" \""
@@ -548,16 +550,6 @@ baz\"\""
(electric-indent-mode 1)
(electric-layout-mode 1)))
-(define-electric-pair-test js-mode-braces-with-layout-and-indent
- "" "{" :expected-string "{\n \n}" :expected-point 7
- :modes '(js-mode)
- :test-in-comments nil
- :test-in-strings nil
- :fixture-fn (lambda ()
- (electric-pair-mode 1)
- (electric-indent-mode 1)
- (electric-layout-mode 1)))
-
;;; Backspacing
;;; TODO: better tests
diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el
index 5c4e5305ecc..e35a7a729bc 100644
--- a/test/lisp/emacs-lisp/backtrace-tests.el
+++ b/test/lisp/emacs-lisp/backtrace-tests.el
@@ -49,7 +49,7 @@
(setq backtrace-frames (seq-subseq backtrace-frames 0 (1+ this-index))))
(backtrace-print))))
- (eval backtrace-tests--uncompiled-functions))
+ (eval backtrace-tests--uncompiled-functions t))
(defun backtrace-tests--backtrace-lines ()
(if debugger-stack-frame-as-list
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el
new file mode 100644
index 00000000000..37cfe463bfe
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el
@@ -0,0 +1,17 @@
+;;; -*- lexical-binding: t -*-
+(defalias 'foo #'ignore
+ "None of this should be considered too wide.
+
+; this should be treated as 60 characters - no warning
+\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]
+
+; 64 * 'x' does not warn
+\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'
+
+; keymaps are just ignored
+\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>
+
+\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}
+
+bar baz foo bar baz foo bar baz foo bar baz foo bar baz foo bar
+")
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index a6e224b3d2c..a442eb473be 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -640,6 +640,58 @@ inner loops respectively."
(f (list (lambda (x) (setq a x)))))
(funcall (car f) 3)
(list a b))
+
+ (cond)
+ (mapcar (lambda (x) (cond ((= x 0)))) '(0 1))
+
+ ;; These expressions give different results in lexbind and dynbind modes,
+ ;; but in each the compiler and interpreter should agree!
+ ;; (They look much the same but come in pairs exercising both the
+ ;; `let' and `let*' paths.)
+ (let ((f (lambda (x)
+ (lambda ()
+ (let ((g (lambda () x)))
+ (let ((x 'a))
+ (list x (funcall g))))))))
+ (funcall (funcall f 'b)))
+ (let ((f (lambda (x)
+ (lambda ()
+ (let ((g (lambda () x)))
+ (let* ((x 'a))
+ (list x (funcall g))))))))
+ (funcall (funcall f 'b)))
+ (let ((f (lambda (x)
+ (lambda ()
+ (let ((g (lambda () x)))
+ (setq x (list x x))
+ (let ((x 'a))
+ (list x (funcall g))))))))
+ (funcall (funcall f 'b)))
+ (let ((f (lambda (x)
+ (lambda ()
+ (let ((g (lambda () x)))
+ (setq x (list x x))
+ (let* ((x 'a))
+ (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)))))))
+ (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)))))))
+ (funcall (funcall f 'b)))
+
+ ;; Test constant-propagation of access to captured variables.
+ (let* ((x 2)
+ (f (lambda ()
+ (let ((y x)) (list y 3 y)))))
+ (funcall f))
)
"List of expressions for cross-testing interpreted and compiled code.")
@@ -690,24 +742,19 @@ byte-compiled. Run with dynamic binding."
(defun test-byte-comp-compile-and-load (compile &rest forms)
(declare (indent 1))
- (let ((elfile nil)
- (elcfile nil))
- (unwind-protect
- (progn
- (setf elfile (make-temp-file "test-bytecomp" nil ".el"))
- (when compile
- (setf elcfile (make-temp-file "test-bytecomp" nil ".elc")))
- (with-temp-buffer
- (dolist (form forms)
- (print form (current-buffer)))
- (write-region (point-min) (point-max) elfile nil 'silent))
- (if compile
- (let ((byte-compile-dest-file-function
- (lambda (e) elcfile)))
- (byte-compile-file elfile)))
- (load elfile nil 'nomessage))
- (when elfile (delete-file elfile))
- (when elcfile (delete-file elcfile)))))
+ (ert-with-temp-file elfile
+ :suffix ".el"
+ (ert-with-temp-file elcfile
+ :suffix ".elc"
+ (with-temp-buffer
+ (dolist (form forms)
+ (print form (current-buffer)))
+ (write-region (point-min) (point-max) elfile nil 'silent))
+ (if compile
+ (let ((byte-compile-dest-file-function
+ (lambda (e) elcfile)))
+ (byte-compile-file elfile)))
+ (load elfile nil 'nomessage))))
(ert-deftest test-byte-comp-macro-expansion ()
(test-byte-comp-compile-and-load t
@@ -810,8 +857,7 @@ byte-compiled. Run with dynamic binding."
(byte-compile-file ,(ert-resource-file file))
(ert-info ((buffer-string) :prefix "buffer: ")
(,(if reverse 'should-not 'should)
- (re-search-forward ,(string-replace " " "[ \n]+" re-warning)
- nil t))))))
+ (re-search-forward ,re-warning nil t))))))
(bytecomp--define-warning-file-test "error-lexical-var-with-add-hook.el"
"add-hook.*lexical var")
@@ -939,7 +985,7 @@ byte-compiled. Run with dynamic binding."
(bytecomp--define-warning-file-test
"warn-wide-docstring-defun.el"
- "wider than .* characters")
+ "Warning: docstring wider than .* characters")
(bytecomp--define-warning-file-test
"warn-wide-docstring-defvar.el"
@@ -958,6 +1004,10 @@ byte-compiled. Run with dynamic binding."
"defvar .foo-bar. docstring wider than .* characters" 'reverse)
(bytecomp--define-warning-file-test
+ "warn-wide-docstring-ignore-substitutions.el"
+ "defvar .foo-bar. docstring wider than .* characters" 'reverse)
+
+(bytecomp--define-warning-file-test
"warn-wide-docstring-ignore.el"
"defvar .foo-bar. docstring wider than .* characters" 'reverse)
@@ -1013,10 +1063,9 @@ byte-compiled. Run with dynamic binding."
(defmacro bytecomp-tests--with-temp-file (file-name-var &rest body)
(declare (indent 1))
(cl-check-type file-name-var symbol)
- `(let ((,file-name-var (make-temp-file "emacs")))
+ `(ert-with-temp-file ,file-name-var
(unwind-protect
(progn ,@body)
- (delete-file ,file-name-var)
(let ((elc (concat ,file-name-var ".elc")))
(if (file-exists-p elc) (delete-file elc))))))
@@ -1243,25 +1292,25 @@ literals (Bug#20852)."
(ert-deftest bytecomp-tests--not-writable-directory ()
"Test that byte compilation works if the output directory isn't
writable (Bug#44631)."
- (let ((directory (make-temp-file "bytecomp-tests-" :directory)))
- (unwind-protect
- (let* ((input-file (expand-file-name "test.el" directory))
- (output-file (expand-file-name "test.elc" directory))
- (byte-compile-dest-file-function
- (lambda (_) output-file))
- (byte-compile-error-on-warn t))
- (write-region "" 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)
- (set-file-modes directory #o500)
- (should (byte-compile-file input-file))
- (should (file-regular-p output-file))
- (should (cl-plusp (file-attribute-size
- (file-attributes output-file)))))
- (with-demoted-errors "Error cleaning up directory: %s"
- (set-file-modes directory #o700)
- (delete-directory directory :recursive)))))
+ (ert-with-temp-directory directory
+ (let* ((input-file (expand-file-name "test.el" directory))
+ (output-file (expand-file-name "test.elc" directory))
+ (byte-compile-dest-file-function
+ (lambda (_) output-file))
+ (byte-compile-error-on-warn t))
+ (unwind-protect
+ (progn
+ (write-region "" 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)
+ (set-file-modes directory #o500)
+ (should (byte-compile-file input-file))
+ (should (file-regular-p output-file))
+ (should (cl-plusp (file-attribute-size
+ (file-attributes output-file)))))
+ ;; Allow the directory to be deleted.
+ (set-file-modes directory #o777)))))
(ert-deftest bytecomp-tests--dest-mountpoint ()
"Test that byte compilation works if the destination file is a
@@ -1273,56 +1322,53 @@ mountpoint (Bug#44631)."
(skip-unless (not (file-remote-p bwrap)))
(skip-unless (file-executable-p emacs))
(skip-unless (not (file-remote-p emacs)))
- (let ((directory (make-temp-file "bytecomp-tests-" :directory)))
- (unwind-protect
- (let* ((input-file (expand-file-name "test.el" directory))
- (output-file (expand-file-name "test.elc" directory))
- (unquoted-file (file-name-unquote output-file))
- (byte-compile-dest-file-function
- (lambda (_) output-file))
- (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 "" nil output-file nil nil nil 'excl)
- (set-file-modes input-file #o400)
- (set-file-modes output-file #o200)
- (set-file-modes directory #o500)
- (with-temp-buffer
- (let ((status (call-process
- bwrap nil t nil
- "--ro-bind" "/" "/"
- "--bind" unquoted-file unquoted-file
- emacs "--quick" "--batch" "--load=bytecomp"
- (format "--eval=%S"
- `(setq byte-compile-dest-file-function
- (lambda (_) ,output-file)
- byte-compile-error-on-warn t))
- "--funcall=batch-byte-compile" input-file)))
- (unless (eql status 0)
- (ert-fail `((status . ,status)
- (output . ,(buffer-string)))))))
- (should (file-regular-p output-file))
- (should (cl-plusp (file-attribute-size
- (file-attributes output-file)))))
- (with-demoted-errors "Error cleaning up directory: %s"
- (set-file-modes directory #o700)
- (delete-directory directory :recursive))))))
+ (ert-with-temp-directory directory
+ (let* ((input-file (expand-file-name "test.el" directory))
+ (output-file (expand-file-name "test.elc" directory))
+ (unquoted-file (file-name-unquote output-file))
+ (byte-compile-dest-file-function
+ (lambda (_) output-file))
+ (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 "" nil output-file nil nil nil 'excl)
+ (unwind-protect
+ (progn
+ (set-file-modes input-file #o400)
+ (set-file-modes output-file #o200)
+ (set-file-modes directory #o500)
+ (with-temp-buffer
+ (let ((status (call-process
+ bwrap nil t nil
+ "--ro-bind" "/" "/"
+ "--bind" unquoted-file unquoted-file
+ emacs "--quick" "--batch" "--load=bytecomp"
+ (format "--eval=%S"
+ `(setq byte-compile-dest-file-function
+ (lambda (_) ,output-file)
+ byte-compile-error-on-warn t))
+ "--funcall=batch-byte-compile" input-file)))
+ (unless (eql status 0)
+ (ert-fail `((status . ,status)
+ (output . ,(buffer-string)))))))
+ (should (file-regular-p output-file))
+ (should (cl-plusp (file-attribute-size
+ (file-attributes output-file)))))
+ ;; Allow the directory to be deleted.
+ (set-file-modes directory #o777))))))
(ert-deftest bytecomp-tests--target-file-no-directory ()
"Check that Bug#45287 is fixed."
- (let ((directory (make-temp-file "bytecomp-tests-" :directory)))
- (unwind-protect
- (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)
- (should (byte-compile-file "test.el"))
- (should (file-regular-p "test.elc"))
- (should (cl-plusp (file-attribute-size
- (file-attributes "test.elc")))))
- (with-demoted-errors "Error cleaning up directory: %s"
- (delete-directory directory :recursive)))))
+ (ert-with-temp-directory directory
+ (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)
+ (should (byte-compile-file "test.el"))
+ (should (file-regular-p "test.elc"))
+ (should (cl-plusp (file-attribute-size
+ (file-attributes "test.elc")))))))
(defun bytecomp-tests--get-vars ()
(list (ignore-errors (symbol-value 'bytecomp-tests--var1))
diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el
index 4290571735e..0701892b8c4 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -205,5 +205,157 @@
nil 99)
42)))
+(defun cconv-tests--intern-all (x)
+ "Intern all symbols in X."
+ (cond ((symbolp x) (intern (symbol-name x)))
+ ((consp x) (cons (cconv-tests--intern-all (car x))
+ (cconv-tests--intern-all (cdr x))))
+ ;; Assume we don't need to deal with vectors etc.
+ (t x)))
+
+(ert-deftest cconv-closure-convert-remap-var ()
+ ;; Verify that we correctly remap shadowed lambda-lifted variables.
+
+ ;; We intern all symbols for ease of comparison; this works because
+ ;; the `cconv-closure-convert' result should contain no pair of
+ ;; distinct symbols having the same name.
+
+ ;; Sanity check: captured variable, no lambda-lifting or shadowing:
+ (should (equal (cconv-tests--intern-all
+ (cconv-closure-convert
+ '#'(lambda (x)
+ #'(lambda () x))))
+ '#'(lambda (x)
+ (internal-make-closure
+ nil (x) nil
+ (internal-get-closed-var 0)))))
+
+ ;; Basic case:
+ (should (equal (cconv-tests--intern-all
+ (cconv-closure-convert
+ '#'(lambda (x)
+ (let ((f #'(lambda () x)))
+ (let ((x 'b))
+ (list x (funcall f)))))))
+ '#'(lambda (x)
+ (let ((f #'(lambda (x) x)))
+ (let ((x 'b)
+ (closed-x x))
+ (list x (funcall f closed-x)))))))
+ (should (equal (cconv-tests--intern-all
+ (cconv-closure-convert
+ '#'(lambda (x)
+ (let ((f #'(lambda () x)))
+ (let* ((x 'b))
+ (list x (funcall f)))))))
+ '#'(lambda (x)
+ (let ((f #'(lambda (x) x)))
+ (let* ((closed-x x)
+ (x 'b))
+ (list x (funcall f closed-x)))))))
+
+ ;; With the lambda-lifted shadowed variable also being captured:
+ (should (equal
+ (cconv-tests--intern-all
+ (cconv-closure-convert
+ '#'(lambda (x)
+ #'(lambda ()
+ (let ((f #'(lambda () x)))
+ (let ((x 'a))
+ (list x (funcall f))))))))
+ '#'(lambda (x)
+ (internal-make-closure
+ nil (x) nil
+ (let ((f #'(lambda (x) x)))
+ (let ((x 'a)
+ (closed-x (internal-get-closed-var 0)))
+ (list x (funcall f closed-x))))))))
+ (should (equal
+ (cconv-tests--intern-all
+ (cconv-closure-convert
+ '#'(lambda (x)
+ #'(lambda ()
+ (let ((f #'(lambda () x)))
+ (let* ((x 'a))
+ (list x (funcall f))))))))
+ '#'(lambda (x)
+ (internal-make-closure
+ nil (x) nil
+ (let ((f #'(lambda (x) x)))
+ (let* ((closed-x (internal-get-closed-var 0))
+ (x 'a))
+ (list x (funcall f closed-x))))))))
+ ;; With lambda-lifted shadowed variable also being mutably captured:
+ (should (equal
+ (cconv-tests--intern-all
+ (cconv-closure-convert
+ '#'(lambda (x)
+ #'(lambda ()
+ (let ((f #'(lambda () x)))
+ (setq x x)
+ (let ((x 'a))
+ (list x (funcall f))))))))
+ '#'(lambda (x)
+ (let ((x (list x)))
+ (internal-make-closure
+ nil (x) nil
+ (let ((f #'(lambda (x) (car-safe x))))
+ (setcar (internal-get-closed-var 0)
+ (car-safe (internal-get-closed-var 0)))
+ (let ((x 'a)
+ (closed-x (internal-get-closed-var 0)))
+ (list x (funcall f closed-x)))))))))
+ (should (equal
+ (cconv-tests--intern-all
+ (cconv-closure-convert
+ '#'(lambda (x)
+ #'(lambda ()
+ (let ((f #'(lambda () x)))
+ (setq x x)
+ (let* ((x 'a))
+ (list x (funcall f))))))))
+ '#'(lambda (x)
+ (let ((x (list x)))
+ (internal-make-closure
+ nil (x) nil
+ (let ((f #'(lambda (x) (car-safe x))))
+ (setcar (internal-get-closed-var 0)
+ (car-safe (internal-get-closed-var 0)))
+ (let* ((closed-x (internal-get-closed-var 0))
+ (x 'a))
+ (list x (funcall f closed-x)))))))))
+ ;; Lambda-lifted variable that isn't actually captured where it is shadowed:
+ (should (equal
+ (cconv-tests--intern-all
+ (cconv-closure-convert
+ '#'(lambda (x)
+ (let ((g #'(lambda () x))
+ (h #'(lambda () (setq x x))))
+ (let ((x 'b))
+ (list x (funcall g) (funcall h)))))))
+ '#'(lambda (x)
+ (let ((x (list x)))
+ (let ((g #'(lambda (x) (car-safe x)))
+ (h #'(lambda (x) (setcar x (car-safe x)))))
+ (let ((x 'b)
+ (closed-x x))
+ (list x (funcall g closed-x) (funcall h closed-x))))))))
+ (should (equal
+ (cconv-tests--intern-all
+ (cconv-closure-convert
+ '#'(lambda (x)
+ (let ((g #'(lambda () x))
+ (h #'(lambda () (setq x x))))
+ (let* ((x 'b))
+ (list x (funcall g) (funcall h)))))))
+ '#'(lambda (x)
+ (let ((x (list x)))
+ (let ((g #'(lambda (x) (car-safe x)))
+ (h #'(lambda (x) (setcar x (car-safe x)))))
+ (let* ((closed-x x)
+ (x 'b))
+ (list x (funcall g closed-x) (funcall h closed-x))))))))
+ )
+
(provide 'cconv-tests)
;;; cconv-tests.el ends here
diff --git a/test/lisp/emacs-lisp/check-declare-tests.el b/test/lisp/emacs-lisp/check-declare-tests.el
index 276530fb4d3..5c9d847e34a 100644
--- a/test/lisp/emacs-lisp/check-declare-tests.el
+++ b/test/lisp/emacs-lisp/check-declare-tests.el
@@ -28,6 +28,7 @@
(require 'check-declare)
(require 'ert)
+(require 'ert-x)
(eval-when-compile (require 'subr-x))
(ert-deftest check-declare-tests-locate ()
@@ -36,62 +37,53 @@
(string-prefix-p "ext:" (check-declare-locate "ext:foo" ""))))
(ert-deftest check-declare-tests-scan ()
- (let ((file (make-temp-file "check-declare-tests-")))
- (unwind-protect
- (progn
- (with-temp-file file
- (insert
- (string-join
- '(";; foo comment"
- "(declare-function ring-insert \"ring\" (ring item))"
- "(let ((foo 'code)) foo)")
- "\n")))
- (let ((res (check-declare-scan file)))
- (should (= (length res) 1))
- (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res))
- (should (string-match-p "ring" fnfile))
- (should (equal "ring-insert" fn))
- (should (equal '(ring item) arglist))
- (should-not fileonly))))
- (delete-file file))))
+ (ert-with-temp-file file
+ (with-temp-file file
+ (insert
+ (string-join
+ '(";; foo comment"
+ "(declare-function ring-insert \"ring\" (ring item))"
+ "(let ((foo 'code)) foo)")
+ "\n")))
+ (let ((res (check-declare-scan file)))
+ (should (= (length res) 1))
+ (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res))
+ (should (string-match-p "ring" fnfile))
+ (should (equal "ring-insert" fn))
+ (should (equal '(ring item) arglist))
+ (should-not fileonly)))))
(ert-deftest check-declare-tests-verify ()
- (let ((file (make-temp-file "check-declare-tests-")))
- (unwind-protect
- (progn
- (with-temp-file file
- (insert
- (string-join
- '(";; foo comment"
- "(defun foo-fun ())"
- "(defun ring-insert (ring item)"
- "\"Insert onto ring RING the item ITEM.\""
- "nil)")
- "\n")))
- (should-not
- (check-declare-verify
- file '(("foo.el" "ring-insert" (ring item))))))
- (delete-file file))))
+ (ert-with-temp-file file
+ (with-temp-file file
+ (insert
+ (string-join
+ '(";; foo comment"
+ "(defun foo-fun ())"
+ "(defun ring-insert (ring item)"
+ "\"Insert onto ring RING the item ITEM.\""
+ "nil)")
+ "\n")))
+ (should-not
+ (check-declare-verify
+ file '(("foo.el" "ring-insert" (ring item)))))))
(ert-deftest check-declare-tests-verify-mismatch ()
- (let ((file (make-temp-file "check-declare-tests-")))
- (unwind-protect
- (progn
- (with-temp-file file
- (insert
- (string-join
- '(";; foo comment"
- "(defun foo-fun ())"
- "(defun ring-insert (ring)"
- "\"Insert onto ring RING the item ITEM.\""
- "nil)")
- "\n")))
- (should
- (equal
- (check-declare-verify
- file '(("foo.el" "ring-insert" (ring item))))
- '(("foo.el" "ring-insert" "arglist mismatch")))))
- (delete-file file))))
+ (ert-with-temp-file file
+ (with-temp-file file
+ (insert
+ (string-join
+ '(";; foo comment"
+ "(defun foo-fun ())"
+ "(defun ring-insert (ring)"
+ "\"Insert onto ring RING the item ITEM.\""
+ "nil)")
+ "\n")))
+ (should
+ (equal
+ (check-declare-verify
+ file '(("foo.el" "ring-insert" (ring item))))
+ '(("foo.el" "ring-insert" "arglist mismatch"))))))
(ert-deftest check-declare-tests-sort ()
(should-not (check-declare-sort '()))
diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el
index dd7511e9afe..9c285a9facf 100644
--- a/test/lisp/emacs-lisp/cl-generic-tests.el
+++ b/test/lisp/emacs-lisp/cl-generic-tests.el
@@ -200,9 +200,14 @@
(fmakunbound 'cl--generic-1)
(cl-defgeneric cl--generic-1 (x y))
(cl-defmethod cl--generic-1 ((x t) y)
- (list x y (cl-next-method-p)))
+ (list x y
+ (with-suppressed-warnings ((obsolete cl-next-method-p))
+ (cl-next-method-p))))
(cl-defmethod cl--generic-1 ((_x (eql 4)) _y)
- (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method)))
+ (cl-list* "quatre"
+ (with-suppressed-warnings ((obsolete cl-next-method-p))
+ (cl-next-method-p))
+ (cl-call-next-method)))
(should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil))))
(ert-deftest cl-generic-test-12-context ()
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el
index a132d736383..a0facc81dbe 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -353,13 +353,6 @@
(should (= 5 (cl-fifth '(1 2 3 4 5 6))))
(should-error (cl-fifth "12345") :type 'wrong-type-argument))
-(ert-deftest cl-lib-test-fifth ()
- (should (null (cl-fifth '())))
- (should (null (cl-fifth '(1 2 3 4))))
- (should (= 5 (cl-fifth '(1 2 3 4 5))))
- (should (= 5 (cl-fifth '(1 2 3 4 5 6))))
- (should-error (cl-fifth "12345") :type 'wrong-type-argument))
-
(ert-deftest cl-lib-test-sixth ()
(should (null (cl-sixth '())))
(should (null (cl-sixth '(1 2 3 4 5))))
@@ -558,4 +551,9 @@
(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))
+ '(3 3 3 3))))
+
+
;;; cl-lib-tests.el ends here
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index f4e2e46a019..13da60ec45e 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -529,7 +529,7 @@ collection clause."
(should-error
;; Use `eval' so the error is signaled when running the test rather than
;; when macroexpanding it.
- (eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0)))))
+ (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)))
@@ -637,17 +637,26 @@ collection clause."
(/ 1 (logand n 1))
(arith-error (len3 (cdr xs) (1+ n)))
(:success (len3 (cdr xs) (+ n k))))
- n)))
+ n))
+
+ ;; Tail calls in `cond'.
+ (len4 (xs n)
+ (cond (xs (cond (nil 'nevertrue)
+ ((len4 (cdr xs) (1+ n)))))
+ (t n))))
(should (equal (len nil 0) 0))
(should (equal (len2 nil 0) 0))
(should (equal (len3 nil 0) 0))
+ (should (equal (len4 nil 0) 0))
(should (equal (len list-42 0) 42))
(should (equal (len2 list-42 0) 42))
(should (equal (len3 list-42 0) 42))
+ (should (equal (len4 list-42 0) 42))
;; Should not bump into stack depth limits.
(should (equal (len list-42k 0) 42000))
(should (equal (len2 list-42k 0) 42000))
- (should (equal (len3 list-42k 0) 42000))))
+ (should (equal (len3 list-42k 0) 42000))
+ (should (equal (len4 list-42k 0) 42000))))
;; Check that non-recursive functions are handled more efficiently.
(should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5)))
@@ -660,8 +669,12 @@ collection clause."
(`(function (lambda (,_ ,_) . ,_)) t))))
(ert-deftest cl-macs--progv ()
- (should (= (cl-progv '(test test) '(1 2) test) 2))
- (should (equal (cl-progv '(test1 test2) '(1 2) (list test1 test2))
+ (defvar cl-macs--test)
+ (defvar cl-macs--test1)
+ (defvar cl-macs--test2)
+ (should (= (cl-progv '(cl-macs--test cl-macs--test) '(1 2) cl-macs--test) 2))
+ (should (equal (cl-progv '(cl-macs--test1 cl-macs--test2) '(1 2)
+ (list cl-macs--test1 cl-macs--test2))
'(1 2))))
;;; cl-macs-tests.el ends here
diff --git a/test/lisp/emacs-lisp/derived-tests.el b/test/lisp/emacs-lisp/derived-tests.el
index 9c8e6c33b4c..2647b86826a 100644
--- a/test/lisp/emacs-lisp/derived-tests.el
+++ b/test/lisp/emacs-lisp/derived-tests.el
@@ -24,13 +24,13 @@
(define-derived-mode derived-tests--parent-mode prog-mode "P"
:after-hook
(let ((f (let ((x "S")) (lambda () x))))
- (insert (format "AFP=%s " (let ((x "D")) (funcall f)))))
+ (insert (format "AFP=%s " (let ((x "D")) x (funcall f)))))
(insert "PB "))
(define-derived-mode derived-tests--child-mode derived-tests--parent-mode "C"
:after-hook
(let ((f (let ((x "S")) (lambda () x))))
- (insert (format "AFC=%s " (let ((x "D")) (funcall f)))))
+ (insert (format "AFC=%s " (let ((x "D")) x (funcall f)))))
(insert "CB "))
(ert-deftest derived-tests-after-hook-lexical ()
diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el
index f8fa223da4c..210bf24880b 100644
--- a/test/lisp/emacs-lisp/edebug-tests.el
+++ b/test/lisp/emacs-lisp/edebug-tests.el
@@ -107,27 +107,27 @@ back to the top level.")
"Set up the environment for an Edebug test BODY, run it, and clean up."
(declare (debug (body)))
`(edebug-tests-with-default-config
- (let ((edebug-tests-failure-in-post-command nil)
- (edebug-tests-temp-file (make-temp-file "edebug-tests-" nil ".el"))
- (find-file-suppress-same-file-warnings t))
- (edebug-tests-setup-code-file edebug-tests-temp-file)
- (ert-with-message-capture
- edebug-tests-messages
- (unwind-protect
- (with-current-buffer (find-file edebug-tests-temp-file)
- (read-only-mode)
- (setq lexical-binding t)
- (eval-buffer)
- ,@body
- (when edebug-tests-failure-in-post-command
- (signal (car edebug-tests-failure-in-post-command)
- (cdr edebug-tests-failure-in-post-command))))
- (unload-feature 'edebug-test-code)
- (with-current-buffer (find-file-noselect edebug-tests-temp-file)
- (set-buffer-modified-p nil))
- (ignore-errors (kill-buffer (find-file-noselect
- edebug-tests-temp-file)))
- (ignore-errors (delete-file edebug-tests-temp-file)))))))
+ (ert-with-temp-file edebug-tests-temp-file
+ :suffix ".el"
+ (let ((edebug-tests-failure-in-post-command nil)
+ (find-file-suppress-same-file-warnings t))
+ (edebug-tests-setup-code-file edebug-tests-temp-file)
+ (ert-with-message-capture
+ edebug-tests-messages
+ (unwind-protect
+ (with-current-buffer (find-file edebug-tests-temp-file)
+ (read-only-mode)
+ (setq lexical-binding t)
+ (eval-buffer)
+ ,@body
+ (when edebug-tests-failure-in-post-command
+ (signal (car edebug-tests-failure-in-post-command)
+ (cdr edebug-tests-failure-in-post-command))))
+ (unload-feature 'edebug-test-code)
+ (with-current-buffer (find-file-noselect edebug-tests-temp-file)
+ (set-buffer-modified-p nil))
+ (ignore-errors (kill-buffer (find-file-noselect
+ edebug-tests-temp-file)))))))))
;; The following macro and its support functions implement an extension
;; to keyboard macros to allow interleaving of keyboard macro
@@ -860,7 +860,8 @@ test and possibly others should be updated."
(let ((inhibit-read-only t))
(delete-region (point-min) (point-max))
(insert "`1"))
- (edebug-eval-defun nil)
+ (with-suppressed-warnings ((obsolete edebug-eval-defun))
+ (edebug-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,7 +871,8 @@ test and possibly others should be updated."
(setq edebug-initial-mode 'go)
;; In Bug#23651 Edebug would hang reading `1.
- (edebug-eval-defun t)))
+ (with-suppressed-warnings ((obsolete edebug-eval-defun))
+ (edebug-eval-defun t))))
(ert-deftest edebug-tests-trivial-comma ()
"Edebug can read a trivial comma expression (Bug#23651)."
@@ -879,7 +881,8 @@ test and possibly others should be updated."
(delete-region (point-min) (point-max))
(insert ",1")
(read-only-mode)
- (should-error (edebug-eval-defun t))))
+ (with-suppressed-warnings ((obsolete edebug-eval-defun))
+ (should-error (edebug-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 d1da066dc45..e881e46a2d1 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el
@@ -85,37 +85,40 @@
(defclass eitest-B-base2 () ())
(defclass eitest-B (eitest-B-base1 eitest-B-base2) ())
-(defmethod eitest-F :BEFORE ((_p eitest-B-base1))
- (eieio-test-method-store :BEFORE 'eitest-B-base1))
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric)
+ (obsolete call-next-method)
+ (obsolete next-method-p))
+ (defmethod eitest-F :BEFORE ((_p eitest-B-base1))
+ (eieio-test-method-store :BEFORE 'eitest-B-base1))
-(defmethod eitest-F :BEFORE ((_p eitest-B-base2))
- (eieio-test-method-store :BEFORE 'eitest-B-base2))
+ (defmethod eitest-F :BEFORE ((_p eitest-B-base2))
+ (eieio-test-method-store :BEFORE 'eitest-B-base2))
-(defmethod eitest-F :BEFORE ((_p eitest-B))
- (eieio-test-method-store :BEFORE 'eitest-B))
+ (defmethod eitest-F :BEFORE ((_p eitest-B))
+ (eieio-test-method-store :BEFORE 'eitest-B))
-(defmethod eitest-F ((_p eitest-B))
- (eieio-test-method-store :PRIMARY 'eitest-B)
- (call-next-method))
-
-(defmethod eitest-F ((_p eitest-B-base1))
- (eieio-test-method-store :PRIMARY 'eitest-B-base1)
- (call-next-method))
+ (defmethod eitest-F ((_p eitest-B))
+ (eieio-test-method-store :PRIMARY 'eitest-B)
+ (call-next-method))
-(defmethod eitest-F ((_p eitest-B-base2))
- (eieio-test-method-store :PRIMARY 'eitest-B-base2)
- (when (next-method-p)
+ (defmethod eitest-F ((_p eitest-B-base1))
+ (eieio-test-method-store :PRIMARY 'eitest-B-base1)
(call-next-method))
- )
-(defmethod eitest-F :AFTER ((_p eitest-B-base1))
- (eieio-test-method-store :AFTER 'eitest-B-base1))
+ (defmethod eitest-F ((_p eitest-B-base2))
+ (eieio-test-method-store :PRIMARY 'eitest-B-base2)
+ (when (next-method-p)
+ (call-next-method)))
-(defmethod eitest-F :AFTER ((_p eitest-B-base2))
- (eieio-test-method-store :AFTER 'eitest-B-base2))
+ (defmethod eitest-F :AFTER ((_p eitest-B-base1))
+ (eieio-test-method-store :AFTER 'eitest-B-base1))
-(defmethod eitest-F :AFTER ((_p eitest-B))
- (eieio-test-method-store :AFTER 'eitest-B))
+ (defmethod eitest-F :AFTER ((_p eitest-B-base2))
+ (eieio-test-method-store :AFTER 'eitest-B-base2))
+
+ (defmethod eitest-F :AFTER ((_p eitest-B))
+ (eieio-test-method-store :AFTER 'eitest-B)))
(ert-deftest eieio-test-method-order-list-3 ()
(let ((eieio-test-method-order-list nil)
@@ -138,9 +141,11 @@
;;; Test static invocation
;;
-(defmethod eitest-H :STATIC ((_class eitest-A))
- "No need to do work in here."
- 'moose)
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod eitest-H :STATIC ((_class eitest-A))
+ "No need to do work in here."
+ 'moose))
(ert-deftest eieio-test-method-order-list-4 ()
;; Both of these situations should succeed.
@@ -149,17 +154,19 @@
;;; Return value from :PRIMARY
;;
-(defmethod eitest-I :BEFORE ((_a eitest-A))
- (eieio-test-method-store :BEFORE 'eitest-A)
- ":before")
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod eitest-I :BEFORE ((_a eitest-A))
+ (eieio-test-method-store :BEFORE 'eitest-A)
+ ":before")
-(defmethod eitest-I :PRIMARY ((_a eitest-A))
- (eieio-test-method-store :PRIMARY 'eitest-A)
- ":primary")
+ (defmethod eitest-I :PRIMARY ((_a eitest-A))
+ (eieio-test-method-store :PRIMARY 'eitest-A)
+ ":primary")
-(defmethod eitest-I :AFTER ((_a eitest-A))
- (eieio-test-method-store :AFTER 'eitest-A)
- ":after")
+ (defmethod eitest-I :AFTER ((_a eitest-A))
+ (eieio-test-method-store :AFTER 'eitest-A)
+ ":after"))
(ert-deftest eieio-test-method-order-list-5 ()
(let ((eieio-test-method-order-list nil)
@@ -175,16 +182,18 @@
(defclass C-base2 () ())
(defclass C (C-base1 C-base2) ())
-;; Just use the obsolete name once, to make sure it also works.
-(defmethod constructor :STATIC ((_p C-base1) &rest _args)
- (eieio-test-method-store :STATIC 'C-base1)
- (if (next-method-p) (call-next-method))
- )
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric)
+ (obsolete next-method-p)
+ (obsolete call-next-method))
+ ;; Just use the obsolete name once, to make sure it also works.
+ (defmethod constructor :STATIC ((_p C-base1) &rest _args)
+ (eieio-test-method-store :STATIC 'C-base1)
+ (if (next-method-p) (call-next-method)))
-(defmethod make-instance :STATIC ((_p C-base2) &rest _args)
- (eieio-test-method-store :STATIC 'C-base2)
- (if (next-method-p) (call-next-method))
- )
+ (defmethod make-instance :STATIC ((_p C-base2) &rest _args)
+ (eieio-test-method-store :STATIC 'C-base2)
+ (if (next-method-p) (call-next-method))))
(cl-defmethod make-instance ((_p (subclass C)) &rest _args)
(eieio-test-method-store :STATIC 'C)
@@ -215,29 +224,32 @@
(defclass D-base2 (D-base0) () :method-invocation-order :depth-first)
(defclass D (D-base1 D-base2) () :method-invocation-order :depth-first)
-(defmethod eitest-F ((_p D))
- "D"
- (eieio-test-method-store :PRIMARY 'D)
- (call-next-method))
-
-(defmethod eitest-F ((_p D-base0))
- "D-base0"
- (eieio-test-method-store :PRIMARY 'D-base0)
- ;; This should have no next
- ;; (when (next-method-p) (call-next-method))
- )
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric)
+ (obsolete call-next-method)
+ (obsolete next-method-p))
+ (defmethod eitest-F ((_p D))
+ "D"
+ (eieio-test-method-store :PRIMARY 'D)
+ (call-next-method))
-(defmethod eitest-F ((_p D-base1))
- "D-base1"
- (eieio-test-method-store :PRIMARY 'D-base1)
- (call-next-method))
+ (defmethod eitest-F ((_p D-base0))
+ "D-base0"
+ (eieio-test-method-store :PRIMARY 'D-base0)
+ ;; This should have no next
+ ;; (when (next-method-p) (call-next-method))
+ )
-(defmethod eitest-F ((_p D-base2))
- "D-base2"
- (eieio-test-method-store :PRIMARY 'D-base2)
- (when (next-method-p)
+ (defmethod eitest-F ((_p D-base1))
+ "D-base1"
+ (eieio-test-method-store :PRIMARY 'D-base1)
(call-next-method))
- )
+
+ (defmethod eitest-F ((_p D-base2))
+ "D-base2"
+ (eieio-test-method-store :PRIMARY 'D-base2)
+ (when (next-method-p)
+ (call-next-method))))
(ert-deftest eieio-test-method-order-list-7 ()
(let ((eieio-test-method-order-list nil)
@@ -258,25 +270,27 @@
(defclass E-base2 (E-base0) () :method-invocation-order :breadth-first)
(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)
-(defmethod eitest-F ((_p E))
- (eieio-test-method-store :PRIMARY 'E)
- (call-next-method))
-
-(defmethod eitest-F ((_p E-base0))
- (eieio-test-method-store :PRIMARY 'E-base0)
- ;; This should have no next
- ;; (when (next-method-p) (call-next-method))
- )
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete next-method-p)
+ (obsolete call-next-method))
+ (defmethod eitest-F ((_p E))
+ (eieio-test-method-store :PRIMARY 'E)
+ (call-next-method))
-(defmethod eitest-F ((_p E-base1))
- (eieio-test-method-store :PRIMARY 'E-base1)
- (call-next-method))
+ (defmethod eitest-F ((_p E-base0))
+ (eieio-test-method-store :PRIMARY 'E-base0)
+ ;; This should have no next
+ ;; (when (next-method-p) (call-next-method))
+ )
-(defmethod eitest-F ((_p E-base2))
- (eieio-test-method-store :PRIMARY 'E-base2)
- (when (next-method-p)
+ (defmethod eitest-F ((_p E-base1))
+ (eieio-test-method-store :PRIMARY 'E-base1)
(call-next-method))
- )
+
+ (defmethod eitest-F ((_p E-base2))
+ (eieio-test-method-store :PRIMARY 'E-base2)
+ (when (next-method-p)
+ (call-next-method))))
(ert-deftest eieio-test-method-order-list-8 ()
(let ((eieio-test-method-order-list nil)
@@ -295,24 +309,32 @@
(defclass eitest-Ja ()
())
-(defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots)
- ;(message "+Ja")
- ;; FIXME: Using next-method-p in an after-method is invalid!
- (when (next-method-p)
- (call-next-method))
- ;(message "-Ja")
- )
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric)
+ (obsolete next-method-p)
+ (obsolete call-next-method))
+ (defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots)
+ ;;(message "+Ja")
+ ;; FIXME: Using next-method-p in an after-method is invalid!
+ (when (next-method-p)
+ (call-next-method))
+ ;;(message "-Ja")
+ ))
(defclass eitest-Jb ()
())
-(defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots)
- ;(message "+Jb")
- ;; FIXME: Using next-method-p in an after-method is invalid!
- (when (next-method-p)
- (call-next-method))
- ;(message "-Jb")
- )
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric)
+ (obsolete next-method-p)
+ (obsolete call-next-method))
+ (defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots)
+ ;;(message "+Jb")
+ ;; FIXME: Using next-method-p in an after-method is invalid!
+ (when (next-method-p)
+ (call-next-method))
+ ;;(message "-Jb")
+ ))
(defclass eitest-Jc (eitest-Jb)
())
@@ -320,12 +342,16 @@
(defclass eitest-Jd (eitest-Jc eitest-Ja)
())
-(defmethod initialize-instance ((_this eitest-Jd) &rest _slots)
- ;(message "+Jd")
- (when (next-method-p)
- (call-next-method))
- ;(message "-Jd")
- )
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric)
+ (obsolete next-method-p)
+ (obsolete call-next-method))
+ (defmethod initialize-instance ((_this eitest-Jd) &rest _slots)
+ ;;(message "+Jd")
+ (when (next-method-p)
+ (call-next-method))
+ ;;(message "-Jd")
+ ))
(ert-deftest eieio-test-method-order-list-9 ()
(should (eitest-Jd)))
@@ -345,32 +371,36 @@
(defclass CNM-2 (CNM-1-1 CNM-1-2)
())
-(defmethod CNM-M ((this CNM-0) args)
- (push (cons 'CNM-0 (copy-sequence args))
- eieio-test-call-next-method-arguments)
- (when (next-method-p)
- (call-next-method
- this (cons 'CNM-0 args))))
-
-(defmethod CNM-M ((this CNM-1-1) args)
- (push (cons 'CNM-1-1 (copy-sequence args))
- eieio-test-call-next-method-arguments)
- (when (next-method-p)
- (call-next-method
- this (cons 'CNM-1-1 args))))
-
-(defmethod CNM-M ((_this CNM-1-2) args)
- (push (cons 'CNM-1-2 (copy-sequence args))
- eieio-test-call-next-method-arguments)
- (when (next-method-p)
- (call-next-method)))
-
-(defmethod CNM-M ((this CNM-2) args)
- (push (cons 'CNM-2 (copy-sequence args))
- eieio-test-call-next-method-arguments)
- (when (next-method-p)
- (call-next-method
- this (cons 'CNM-2 args))))
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric)
+ (obsolete next-method-p)
+ (obsolete call-next-method))
+ (defmethod CNM-M ((this CNM-0) args)
+ (push (cons 'CNM-0 (copy-sequence args))
+ eieio-test-call-next-method-arguments)
+ (when (next-method-p)
+ (call-next-method
+ this (cons 'CNM-0 args))))
+
+ (defmethod CNM-M ((this CNM-1-1) args)
+ (push (cons 'CNM-1-1 (copy-sequence args))
+ eieio-test-call-next-method-arguments)
+ (when (next-method-p)
+ (call-next-method
+ this (cons 'CNM-1-1 args))))
+
+ (defmethod CNM-M ((_this CNM-1-2) args)
+ (push (cons 'CNM-1-2 (copy-sequence args))
+ eieio-test-call-next-method-arguments)
+ (when (next-method-p)
+ (call-next-method)))
+
+ (defmethod CNM-M ((this CNM-2) args)
+ (push (cons 'CNM-2 (copy-sequence args))
+ eieio-test-call-next-method-arguments)
+ (when (next-method-p)
+ (call-next-method
+ this (cons 'CNM-2 args)))))
(ert-deftest eieio-test-method-order-list-10 ()
(let ((eieio-test-call-next-method-arguments 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 fd044ff3734..d1183b81c6c 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
@@ -99,7 +99,7 @@ This is usually a symbol that starts with `:'."
(defclass persist-simple (eieio-persistent)
((slot1 :initarg :slot1
:type symbol
- :initform moose)
+ :initform 'moose)
(slot2 :initarg :slot2
:initform "foo")
(slot3 :initform 2))
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
index 9eb7fb02230..25b36c0f1cc 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
@@ -31,14 +31,19 @@
(eval-when-compile (require 'cl-lib))
+;; Silence byte-compiler.
+(eval-when-compile
+ (dolist (slot '(:a :b ooga-booga :derived-value missing-slot))
+ (cl-pushnew slot eieio--known-slot-names)))
+
;;; Code:
;; Set up some test classes
(defclass class-a ()
((water :initarg :water
- :initform h20
+ :initform 'h20
:type symbol
:documentation "Detail about water.")
- (classslot :initform penguin
+ (classslot :initform 'penguin
:type symbol
:documentation "A class allocated slot."
:allocation :class)
@@ -63,7 +68,7 @@
(defclass class-c ()
((slot-1 :initarg :moose
- :initform moose
+ :initform 'moose
:type symbol
:allocation :instance
:documentation "First slot testing slot arguments."
@@ -82,7 +87,7 @@
:accessor get-slot-2
:protection :private)
(slot-3 :initarg :emu
- :initform emu
+ :initform 'emu
:type symbol
:allocation :class
:documentation "Third slot test class allocated accessor"
@@ -160,30 +165,33 @@
;; error
(should-error (abstract-class)))
-(defgeneric generic1 () "First generic function.")
+(with-suppressed-warnings ((obsolete defgeneric))
+ (defgeneric generic1 () "First generic function."))
(ert-deftest eieio-test-03-generics ()
- (defun anormalfunction () "A plain function for error testing." nil)
- (should-error
- (progn
- (defgeneric anormalfunction ()
- "Attempt to turn it into a generic.")))
-
- ;; Check that generic-p works
- (should (generic-p 'generic1))
-
- (defmethod generic1 ((c class-a))
- "Method on generic1."
- 'monkey)
-
- (defmethod generic1 (not-an-object)
- "Method generic1 that can take a non-object."
- not-an-object)
-
- (let ((ans-obj (generic1 (class-a)))
- (ans-num (generic1 666)))
- (should (eq ans-obj 'monkey))
- (should (eq ans-num 666))))
+ (with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defun anormalfunction () "A plain function for error testing." nil)
+ (should-error
+ (progn
+ (defgeneric anormalfunction ()
+ "Attempt to turn it into a generic.")))
+
+ ;; Check that generic-p works
+ (should (generic-p 'generic1))
+
+ (defmethod generic1 ((_c class-a))
+ "Method on generic1."
+ 'monkey)
+
+ (defmethod generic1 (not-an-object)
+ "Method generic1 that can take a non-object."
+ not-an-object)
+
+ (let ((ans-obj (generic1 (class-a)))
+ (ans-num (generic1 666)))
+ (should (eq ans-obj 'monkey))
+ (should (eq ans-num 666)))))
(defclass static-method-class ()
((some-slot :initform nil
@@ -191,11 +199,13 @@
:documentation "A slot."))
:documentation "A class used for testing static methods.")
-(defmethod static-method-class-method :STATIC ((c static-method-class) value)
- "Test static methods.
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod static-method-class-method :STATIC ((c static-method-class) value)
+ "Test static methods.
Argument C is the class bound to this static method."
- (if (eieio-object-p c) (setq c (eieio-object-class c)))
- (oset-default c some-slot value))
+ (if (eieio-object-p c) (setq c (eieio-object-class c)))
+ (oset-default c some-slot value)))
(ert-deftest eieio-test-04-static-method ()
;; Call static method on a class and see if it worked
@@ -209,11 +219,13 @@ Argument C is the class bound to this static method."
()
"A second class after the previous for static methods.")
- (defmethod static-method-class-method :STATIC ((c static-method-class-2) value)
- "Test static methods.
+ (with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod static-method-class-method :STATIC ((c static-method-class-2) value)
+ "Test static methods.
Argument C is the class bound to this static method."
- (if (eieio-object-p c) (setq c (eieio-object-class c)))
- (oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))
+ (if (eieio-object-p c) (setq c (eieio-object-class c)))
+ (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))))
(static-method-class-method 'static-method-class-2 'class)
(should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class))
@@ -240,64 +252,71 @@ Argument C is the class bound to this static method."
(should (make-instance 'class-a :water 'cho))
(should (make-instance 'class-b)))
-(defmethod class-cn ((a class-a))
- "Try calling `call-next-method' when there isn't one.
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod class-cn ((_a class-a))
+ "Try calling `call-next-method' when there isn't one.
Argument A is object of type symbol `class-a'."
- (call-next-method))
+ (with-suppressed-warnings ((obsolete call-next-method))
+ (call-next-method)))
-(defmethod no-next-method ((a class-a) &rest args)
- "Override signal throwing for variable `class-a'.
+ (defmethod no-next-method ((_a class-a) &rest _args)
+ "Override signal throwing for variable `class-a'.
Argument A is the object of class variable `class-a'."
- 'moose)
+ 'moose))
(ert-deftest eieio-test-08-call-next-method ()
;; Play with call-next-method
(should (eq (class-cn eitest-ab) 'moose)))
-(defmethod no-applicable-method ((b class-b) method &rest args)
- "No need.
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod no-applicable-method ((_b class-b) _method &rest _args)
+ "No need.
Argument B is for booger.
METHOD is the method that was attempting to be called."
- 'moose)
+ 'moose))
(ert-deftest eieio-test-09-no-applicable-method ()
;; Non-existing methods.
(should (eq (class-cn eitest-b) 'moose)))
-(defmethod class-fun ((a class-a))
- "Fun with class A."
- 'moose)
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod class-fun ((_a class-a))
+ "Fun with class A."
+ 'moose)
-(defmethod class-fun ((b class-b))
- "Fun with class B."
- (error "Class B fun should not be called")
- )
+ (defmethod class-fun ((_b class-b))
+ "Fun with class B."
+ (error "Class B fun should not be called"))
-(defmethod class-fun-foo ((b class-b))
- "Foo Fun with class B."
- 'moose)
+ (defmethod class-fun-foo ((_b class-b))
+ "Foo Fun with class B."
+ 'moose)
-(defmethod class-fun2 ((a class-a))
- "More fun with class A."
- 'moose)
+ (defmethod class-fun2 ((_a class-a))
+ "More fun with class A."
+ 'moose)
-(defmethod class-fun2 ((b class-b))
- "More fun with class B."
- (error "Class B fun2 should not be called")
- )
+ (defmethod class-fun2 ((_b class-b))
+ "More fun with class B."
+ (error "Class B fun2 should not be called"))
-(defmethod class-fun2 ((ab class-ab))
- "More fun with class AB."
- (call-next-method))
+ (defmethod class-fun2 ((_ab class-ab))
+ "More fun with class AB."
+ (with-suppressed-warnings ((obsolete call-next-method))
+ (call-next-method)))
-;; How about if B is the only slot?
-(defmethod class-fun3 ((b class-b))
- "Even More fun with class B."
- 'moose)
+ ;; How about if B is the only slot?
+ (defmethod class-fun3 ((_b class-b))
+ "Even More fun with class B."
+ 'moose)
-(defmethod class-fun3 ((ab class-ab))
- "Even More fun with class AB."
- (call-next-method))
+ (defmethod class-fun3 ((_ab class-ab))
+ "Even More fun with class AB."
+ (with-suppressed-warnings ((obsolete call-next-method))
+ (call-next-method))))
(ert-deftest eieio-test-10-multiple-inheritance ()
;; play with methods and mi
@@ -314,20 +333,22 @@ METHOD is the method that was attempting to be called."
(defvar class-fun-value-seq '())
-(defmethod class-fun-value :BEFORE ((a class-a))
- "Return `before', and push `before' in `class-fun-value-seq'."
- (push 'before class-fun-value-seq)
- 'before)
-
-(defmethod class-fun-value :PRIMARY ((a class-a))
- "Return `primary', and push `primary' in `class-fun-value-seq'."
- (push 'primary class-fun-value-seq)
- 'primary)
-
-(defmethod class-fun-value :AFTER ((a class-a))
- "Return `after', and push `after' in `class-fun-value-seq'."
- (push 'after class-fun-value-seq)
- 'after)
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod class-fun-value :BEFORE ((_a class-a))
+ "Return `before', and push `before' in `class-fun-value-seq'."
+ (push 'before class-fun-value-seq)
+ 'before)
+
+ (defmethod class-fun-value :PRIMARY ((_a class-a))
+ "Return `primary', and push `primary' in `class-fun-value-seq'."
+ (push 'primary class-fun-value-seq)
+ 'primary)
+
+ (defmethod class-fun-value :AFTER ((_a class-a))
+ "Return `after', and push `after' in `class-fun-value-seq'."
+ (push 'after class-fun-value-seq)
+ 'after))
(ert-deftest eieio-test-12-generic-function-call ()
;; Test value of a generic function call
@@ -343,20 +364,23 @@ METHOD is the method that was attempting to be called."
;;
(ert-deftest eieio-test-13-init-methods ()
- (defmethod initialize-instance ((a class-a) &rest slots)
- "Initialize the slots of class-a."
- (call-next-method)
- (if (/= (oref a test-tag) 1)
- (error "shared-initialize test failed."))
- (oset a test-tag 2))
-
- (defmethod shared-initialize ((a class-a) &rest slots)
- "Shared initialize method for class-a."
- (call-next-method)
- (oset a test-tag 1))
-
- (let ((ca (class-a)))
- (should (= (oref ca test-tag) 2))))
+ (with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric)
+ (obsolete call-next-method))
+ (defmethod initialize-instance ((a class-a) &rest _slots)
+ "Initialize the slots of class-a."
+ (call-next-method)
+ (if (/= (oref a test-tag) 1)
+ (error "shared-initialize test failed."))
+ (oset a test-tag 2))
+
+ (defmethod shared-initialize ((a class-a) &rest _slots)
+ "Shared initialize method for class-a."
+ (call-next-method)
+ (oset a test-tag 1))
+
+ (let ((ca (class-a)))
+ (should (= (oref ca test-tag) 2)))))
;;; Perform slot testing
@@ -368,10 +392,11 @@ METHOD is the method that was attempting to be called."
(should (oref eitest-ab amphibian)))
(ert-deftest eieio-test-15-slot-missing ()
-
- (defmethod slot-missing ((ab class-ab) &rest foo)
- "If a slot in AB is unbound, return something cool. FOO."
- 'moose)
+ (with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod slot-missing ((_ab class-ab) &rest _foo)
+ "If a slot in AB is unbound, return something cool. FOO."
+ 'moose))
(should (eq (oref eitest-ab ooga-booga) 'moose))
(should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name))
@@ -391,17 +416,20 @@ METHOD is the method that was attempting to be called."
(defclass virtual-slot-class ()
((base-value :initarg :base-value))
"Class has real slot :base-value and simulated slot :derived-value.")
-(defmethod slot-missing ((vsc virtual-slot-class)
- slot-name operation &optional new-value)
- "Simulate virtual slot derived-value."
- (cond
- ((or (eq slot-name :derived-value)
- (eq slot-name 'derived-value))
- (with-slots (base-value) vsc
- (if (eq operation 'oref)
- (+ base-value 1)
- (setq base-value (- new-value 1)))))
- (t (call-next-method))))
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod slot-missing ((vsc virtual-slot-class)
+ slot-name operation &optional new-value)
+ "Simulate virtual slot derived-value."
+ (cond
+ ((or (eq slot-name :derived-value)
+ (eq slot-name 'derived-value))
+ (with-slots (base-value) vsc
+ (if (eq operation 'oref)
+ (+ base-value 1)
+ (setq base-value (- new-value 1)))))
+ (t (with-suppressed-warnings ((obsolete call-next-method))
+ (call-next-method))))))
(ert-deftest eieio-test-17-virtual-slot ()
(setq eitest-vsca (virtual-slot-class :base-value 1))
@@ -424,35 +452,37 @@ METHOD is the method that was attempting to be called."
(should (= (oref eitest-vscb :derived-value) 5)))
(ert-deftest eieio-test-18-slot-unbound ()
-
- (defmethod slot-unbound ((a class-a) &rest foo)
- "If a slot in A is unbound, ignore FOO."
- 'moose)
-
- (should (eq (oref eitest-a water) 'moose))
-
- ;; Check if oset of unbound works
- (oset eitest-a water 'moose)
- (should (eq (oref eitest-a water) 'moose))
-
- ;; oref/oref-default comparison
- (should-not (eq (oref eitest-a water) (oref-default eitest-a water)))
-
- ;; oset-default -> oref/oref-default comparison
- (oset-default (eieio-object-class eitest-a) water 'moose)
- (should (eq (oref eitest-a water) (oref-default eitest-a water)))
-
- ;; After setting 'water to 'moose, make sure a new object has
- ;; the right stuff.
- (oset-default (eieio-object-class eitest-a) water 'penguin)
- (should (eq (oref (class-a) water) 'penguin))
-
- ;; Revert the above
- (defmethod slot-unbound ((a class-a) &rest foo)
- "If a slot in A is unbound, ignore FOO."
- ;; Disable the old slot-unbound so we can run this test
- ;; more than once
- (call-next-method)))
+ (with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod slot-unbound ((_a class-a) &rest _foo)
+ "If a slot in A is unbound, ignore FOO."
+ 'moose)
+
+ (should (eq (oref eitest-a water) 'moose))
+
+ ;; Check if oset of unbound works
+ (oset eitest-a water 'moose)
+ (should (eq (oref eitest-a water) 'moose))
+
+ ;; oref/oref-default comparison
+ (should-not (eq (oref eitest-a water) (oref-default eitest-a water)))
+
+ ;; oset-default -> oref/oref-default comparison
+ (oset-default (eieio-object-class eitest-a) water 'moose)
+ (should (eq (oref eitest-a water) (oref-default eitest-a water)))
+
+ ;; After setting 'water to 'moose, make sure a new object has
+ ;; the right stuff.
+ (oset-default (eieio-object-class eitest-a) water 'penguin)
+ (should (eq (oref (class-a) water) 'penguin))
+
+ ;; Revert the above
+ (defmethod slot-unbound ((_a class-a) &rest _foo)
+ "If a slot in A is unbound, ignore FOO."
+ ;; Disable the old slot-unbound so we can run this test
+ ;; more than once
+ (with-suppressed-warnings ((obsolete call-next-method))
+ (call-next-method)))))
(ert-deftest eieio-test-19-slot-type-checking ()
;; Slot type checking
@@ -489,7 +519,7 @@ METHOD is the method that was attempting to be called."
(defclass inittest nil
((staticval :initform 1)
- (symval :initform eieio-test-permuting-value)
+ (symval :initform 'eieio-test-permuting-value)
(evalval :initform (symbol-value 'eieio-test-permuting-value))
(evalnow :initform (symbol-value 'eieio-test-permuting-value)
:allocation :class)
@@ -617,12 +647,14 @@ METHOD is the method that was attempting to be called."
()
"Protection testing baseclass.")
-(defmethod prot0-slot-2 ((s2 prot-0))
- "Try to access slot-2 from this class which doesn't have it.
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod prot0-slot-2 ((s2 prot-0))
+ "Try to access slot-2 from this class which doesn't have it.
The object S2 passed in will be of class prot-1, which does have
the slot. This could be allowed, and currently is in EIEIO.
Needed by the eieio persistent base class."
- (oref s2 slot-2))
+ (oref s2 slot-2)))
(defclass prot-1 (prot-0)
((slot-1 :initarg :slot-1
@@ -640,26 +672,28 @@ Needed by the eieio persistent base class."
nil
"A class for testing the :protection option.")
-(defmethod prot1-slot-2 ((s2 prot-1))
- "Try to access slot-2 in S2."
- (oref s2 slot-2))
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod prot1-slot-2 ((s2 prot-1))
+ "Try to access slot-2 in S2."
+ (oref s2 slot-2))
-(defmethod prot1-slot-2 ((s2 prot-2))
- "Try to access slot-2 in S2."
- (oref s2 slot-2))
+ (defmethod prot1-slot-2 ((s2 prot-2))
+ "Try to access slot-2 in S2."
+ (oref s2 slot-2))
-(defmethod prot1-slot-3-only ((s2 prot-1))
- "Try to access slot-3 in S2.
+ (defmethod prot1-slot-3-only ((s2 prot-1))
+ "Try to access slot-3 in S2.
Do not override for `prot-2'."
- (oref s2 slot-3))
+ (oref s2 slot-3))
-(defmethod prot1-slot-3 ((s2 prot-1))
- "Try to access slot-3 in S2."
- (oref s2 slot-3))
+ (defmethod prot1-slot-3 ((s2 prot-1))
+ "Try to access slot-3 in S2."
+ (oref s2 slot-3))
-(defmethod prot1-slot-3 ((s2 prot-2))
- "Try to access slot-3 in S2."
- (oref s2 slot-3))
+ (defmethod prot1-slot-3 ((s2 prot-2))
+ "Try to access slot-3 in S2."
+ (oref s2 slot-3)))
(defvar eitest-p1 nil)
(defvar eitest-p2 nil)
@@ -729,7 +763,7 @@ Do not override for `prot-2'."
(should (eq (oref eitest-II3 slot3) 'penguin)))
(defclass slotattr-base ()
- ((initform :initform init)
+ ((initform :initform 'init)
(type :type list)
(initarg :initarg :initarg)
(protection :protection :private)
@@ -744,7 +778,7 @@ Do not override for `prot-2'."
Subclasses to override slot attributes.")
(defclass slotattr-ok (slotattr-base)
- ((initform :initform no-init)
+ ((initform :initform 'no-init)
(initarg :initarg :initblarg)
(custom :custom string
:label "One String"
@@ -780,7 +814,7 @@ Subclasses to override slot attributes.")
(defclass slotattr-class-base ()
((initform :allocation :class
- :initform init)
+ :initform 'init)
(type :allocation :class
:type list)
(initarg :allocation :class
@@ -799,7 +833,7 @@ Subclasses to override slot attributes.")
Subclasses to override slot attributes.")
(defclass slotattr-class-ok (slotattr-class-base)
- ((initform :initform no-init)
+ ((initform :initform 'no-init)
(initarg :initarg :initblarg)
(custom :custom string
:label "One String"
@@ -861,7 +895,7 @@ Subclasses to override slot attributes.")
(should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1))))
(defclass IT (eieio-instance-tracker)
- ((tracking-symbol :initform IT-list)
+ ((tracking-symbol :initform 'IT-list)
(slot1 :initform 'die))
"Instance Tracker test object.")
@@ -914,8 +948,10 @@ Subclasses to override slot attributes.")
(defclass eieio--testing () ())
-(defmethod constructor :static ((_x eieio--testing) newname &rest _args)
- (list newname 2))
+(with-suppressed-warnings ((obsolete defmethod)
+ (obsolete defgeneric))
+ (defmethod constructor :static ((_x eieio--testing) newname &rest _args)
+ (list newname 2)))
(ert-deftest eieio-test-37-obsolete-name-in-constructor ()
;; FIXME repeated intermittent failures on hydra and elsewhere (bug#24503).
@@ -969,6 +1005,21 @@ Subclasses to override slot attributes.")
(should (eieio-instance-inheritor-slot-boundp C :b))
(should-not (eieio-instance-inheritor-slot-boundp C :c))))
+;;;; Interaction with defstruct
+
+(cl-defstruct eieio-test--struct a b (c nil :read-only t))
+
+(ert-deftest eieio-test-defstruct-slot-value ()
+ (let ((x (make-eieio-test--struct :a 'A :b 'B :c 'C)))
+ (should (eq (eieio-test--struct-a x)
+ (slot-value x 'a)))
+ (should (eq (eieio-test--struct-b x)
+ (slot-value x 'b)))
+ (should (eq (eieio-test--struct-c x)
+ (slot-value x 'c)))
+ (setf (slot-value x 'a) 1)
+ (should (eq (eieio-test--struct-a x) 1))
+ (should-error (setf (slot-value x 'c) 3) :type 'eieio-read-only)))
(provide 'eieio-tests)
diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el
index a18664bba3b..1a8c9bf4f08 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -39,10 +39,11 @@
(defun ert-self-test ()
"Run ERT's self-tests and make sure they actually ran."
(let ((window-configuration (current-window-configuration)))
- (let ((ert--test-body-was-run nil))
+ (let ((ert--test-body-was-run nil)
+ (ert--output-buffer-name " *ert self-tests*"))
;; The buffer name chosen here should not compete with the default
;; results buffer name for completion in `switch-to-buffer'.
- (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*")))
+ (let ((stats (ert-run-tests-interactively "^ert-")))
(cl-assert ert--test-body-was-run)
(if (zerop (ert-stats-completed-unexpected stats))
;; Hide results window only when everything went well.
@@ -519,17 +520,18 @@ This macro is used to test if macroexpansion in `should' works."
:body (lambda () (ert-skip
"skip message")))))
(let ((ert-debug-on-error nil))
- (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*"))
- (messages nil)
- (mock-message-fn
- (lambda (format-string &rest args)
- (push (apply #'format format-string args) messages))))
+ (cl-letf* ((buffer-name (generate-new-buffer-name
+ " *ert-test-run-tests*"))
+ (ert--output-buffer-name buffer-name)
+ (messages nil)
+ ((symbol-function 'message)
+ (lambda (format-string &rest args)
+ (push (apply #'format format-string args) messages))))
(save-window-excursion
(unwind-protect
(let ((case-fold-search nil))
(ert-run-tests-interactively
- `(member ,passing-test ,failing-test, skipped-test) buffer-name
- mock-message-fn)
+ `(member ,passing-test ,failing-test, skipped-test))
(should (equal messages `(,(concat
"Ran 3 tests, 1 results were "
"as expected, 1 unexpected, "
@@ -551,6 +553,68 @@ This macro is used to test if macroexpansion in `should' works."
(when (get-buffer buffer-name)
(kill-buffer buffer-name))))))))
+(ert-deftest ert-test-run-tests-batch ()
+ (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc"))))))))
+ (long-list (make-list 11 1))
+ (failing-test-1
+ (make-ert-test :name 'failing-test-1
+ :body (lambda () (should (equal complex-list 1)))))
+ (failing-test-2
+ (make-ert-test :name 'failing-test-2
+ :body (lambda () (should (equal long-list 1))))))
+ (let ((ert-debug-on-error nil)
+ messages)
+ (cl-letf* (((symbol-function 'message)
+ (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 ((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
+ found-complex)
+ (cl-loop for msg in (reverse messages)
+ do
+ (unless found-long
+ (setq found-long (string-match long-text msg)))
+ (unless found-complex
+ (setq found-complex (string-match complex-text msg))))
+ (should found-long)
+ (should found-complex)))))
+
+(ert-deftest ert-test-run-tests-batch-expensive ()
+ (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc"))))))))
+ (failing-test-1
+ (make-ert-test :name 'failing-test-1
+ :body (lambda () (should (equal complex-list 1))))))
+ (let ((ert-debug-on-error nil)
+ messages)
+ (cl-letf* (((symbol-function 'message)
+ (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 ((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)
+ do
+ (unless found-frame
+ (setq found-frame (cl-search frame msg :test 'equal))))
+ (should found-frame)))))
+
(ert-deftest ert-test-special-operator-p ()
(should (ert--special-operator-p 'if))
(should-not (ert--special-operator-p 'car))
@@ -695,49 +759,40 @@ This macro is used to test if macroexpansion in `should' works."
(should (equal (ert--abbreviate-string "bar" 0 t) "")))
(ert-deftest ert-test-explain-equal-string-properties ()
- (should
- (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b))
- "foo")
- '(char 0 "f"
- (different-properties-for-key a (different-atoms b nil))
- context-before ""
- context-after "oo")))
- (should (equal (ert--explain-equal-including-properties
+ (should-not (ert--explain-equal-including-properties-rec "foo" "foo"))
+ (should-not (ert--explain-equal-including-properties-rec
+ #("foo" 0 3 (a b))
+ (propertize "foo" 'a 'b)))
+ (should-not (ert--explain-equal-including-properties-rec
+ #("foo" 0 3 (a b c d))
+ (propertize "foo" 'a 'b 'c 'd)))
+ (should-not (ert--explain-equal-including-properties-rec
+ #("foo" 0 3 (a (t)))
+ (propertize "foo" 'a (list t))))
+
+ (should (equal (ert--explain-equal-including-properties-rec
+ #("foo" 0 3 (a b c e))
+ (propertize "foo" 'a 'b 'c 'd))
+ '(char 0 "f" (different-properties-for-key c (different-atoms e d))
+ context-before ""
+ context-after "oo")))
+ (should (equal (ert--explain-equal-including-properties-rec
+ #("foo" 0 1 (a b))
+ "foo")
+ '(char 0 "f"
+ (different-properties-for-key a (different-atoms b nil))
+ context-before ""
+ context-after "oo")))
+ (should (equal (ert--explain-equal-including-properties-rec
#("foo" 1 3 (a b))
#("goo" 0 1 (c d)))
'(array-elt 0 (different-atoms (?f "#x66" "?f")
(?g "#x67" "?g")))))
- (should
- (equal (ert--explain-equal-including-properties
- #("foo" 0 1 (a b c d) 1 3 (a b))
- #("foo" 0 1 (c d a b) 1 2 (a foo)))
- '(char 1 "o" (different-properties-for-key a (different-atoms b foo))
- context-before "f" context-after "o"))))
-
-(ert-deftest ert-test-equal-including-properties ()
- (should (equal-including-properties "foo" "foo"))
- (should (ert-equal-including-properties "foo" "foo"))
-
- (should (equal-including-properties #("foo" 0 3 (a b))
- (propertize "foo" 'a 'b)))
- (should (ert-equal-including-properties #("foo" 0 3 (a b))
- (propertize "foo" 'a 'b)))
-
- (should (equal-including-properties #("foo" 0 3 (a b c d))
- (propertize "foo" 'a 'b 'c 'd)))
- (should (ert-equal-including-properties #("foo" 0 3 (a b c d))
- (propertize "foo" 'a 'b 'c 'd)))
-
- (should-not (equal-including-properties #("foo" 0 3 (a b c e))
- (propertize "foo" 'a 'b 'c 'd)))
- (should-not (ert-equal-including-properties #("foo" 0 3 (a b c e))
- (propertize "foo" 'a 'b 'c 'd)))
-
- ;; This is bug 6581.
- (should-not (equal-including-properties #("foo" 0 3 (a (t)))
- (propertize "foo" 'a (list t))))
- (should (ert-equal-including-properties #("foo" 0 3 (a (t)))
- (propertize "foo" 'a (list t)))))
+ (should (equal (ert--explain-equal-including-properties-rec
+ #("foo" 0 1 (a b c d) 1 3 (a b))
+ #("foo" 0 1 (c d a b) 1 2 (a foo)))
+ '(char 1 "o" (different-properties-for-key a (different-atoms b foo))
+ context-before "f" context-after "o"))))
(ert-deftest ert-test-stats-set-test-and-result ()
(let* ((test-1 (make-ert-test :name 'test-1
diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el
index 9f40a18d343..7106b7abc0c 100644
--- a/test/lisp/emacs-lisp/ert-x-tests.el
+++ b/test/lisp/emacs-lisp/ert-x-tests.el
@@ -90,10 +90,10 @@
"foo baz")))
(ert-deftest ert-propertized-string ()
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(ert-propertized-string "a" '(a b) "b" '(c t) "cd")
#("abcd" 1 2 (a b) 2 4 (c t))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(ert-propertized-string "foo " '(face italic) "bar" " baz" nil
" quux")
#("foo bar baz quux" 4 11 (face italic)))))
@@ -103,23 +103,27 @@
(ert-deftest ert-test-run-tests-interactively-2 ()
:tags '(:causes-redisplay)
- (let* ((passing-test (make-ert-test :name 'passing-test
- :body (lambda () (ert-pass))))
- (failing-test (make-ert-test :name 'failing-test
- :body (lambda ()
- (ert-info ((propertize "foo\nbar"
- 'a 'b))
- (ert-fail
- "failure message")))))
- (skipped-test (make-ert-test :name 'skipped-test
- :body (lambda () (ert-skip
- "skip message"))))
- (ert-debug-on-error nil)
- (buffer-name (generate-new-buffer-name "*ert-test-run-tests*"))
- (messages nil)
- (mock-message-fn
- (lambda (format-string &rest args)
- (push (apply #'format format-string args) messages))))
+ (cl-letf* ((passing-test (make-ert-test
+ :name 'passing-test
+ :body (lambda () (ert-pass))))
+ (failing-test (make-ert-test
+ :name 'failing-test
+ :body (lambda ()
+ (ert-info ((propertize "foo\nbar"
+ 'a 'b))
+ (ert-fail
+ "failure message")))))
+ (skipped-test (make-ert-test
+ :name 'skipped-test
+ :body (lambda () (ert-skip
+ "skip message"))))
+ (ert-debug-on-error nil)
+ (messages nil)
+ (buffer-name (generate-new-buffer-name "*ert-test-run-tests*"))
+ ((symbol-function 'message)
+ (lambda (format-string &rest args)
+ (push (apply #'format format-string args) messages)))
+ (ert--output-buffer-name buffer-name))
(cl-flet ((expected-string (with-font-lock-p)
(ert-propertized-string
"Selector: (member <passing-test> <failing-test> "
@@ -152,21 +156,19 @@
"failing-test"
nil "\n Info: " '(a b) "foo\n"
nil " " '(a b) "bar"
- nil "\n (ert-test-failed \"failure message\")\n\n\n"
- )))
+ nil "\n (ert-test-failed \"failure message\")\n\n\n")))
(save-window-excursion
(unwind-protect
(let ((case-fold-search nil))
(ert-run-tests-interactively
- `(member ,passing-test ,failing-test ,skipped-test) buffer-name
- mock-message-fn)
+ `(member ,passing-test ,failing-test ,skipped-test))
(should (equal messages `(,(concat
"Ran 3 tests, 1 results were "
"as expected, 1 unexpected, "
"1 skipped"))))
(with-current-buffer buffer-name
(font-lock-mode 0)
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(ert-filter-string (buffer-string)
'("Started at:\\(.*\\)$" 1)
'("Finished at:\\(.*\\)$" 1))
@@ -175,7 +177,7 @@
;; pretend we are.
(let ((noninteractive nil))
(font-lock-mode 1))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(ert-filter-string (buffer-string)
'("Started at:\\(.*\\)$" 1)
'("Finished at:\\(.*\\)$" 1))
@@ -271,6 +273,62 @@ desired effect."
(cl-loop for x in '(0 1 2 3 4 t) do
(should (equal (c x) (lisp x))))))
+(ert-deftest ert-x-tests--with-temp-file-generate-suffix ()
+ (should (equal (ert--with-temp-file-generate-suffix "foo.el") "-foo"))
+ (should (equal (ert--with-temp-file-generate-suffix "foo-test.el") "-foo"))
+ (should (equal (ert--with-temp-file-generate-suffix "foo-tests.el") "-foo"))
+ (should (equal (ert--with-temp-file-generate-suffix "foo-bar-baz.el")
+ "-foo-bar-baz"))
+ (should (equal (ert--with-temp-file-generate-suffix "/foo/bar/baz.el")
+ "-baz")))
+
+(ert-deftest ert-x-tests-with-temp-file ()
+ (let (saved)
+ (ert-with-temp-file fil
+ (setq saved fil)
+ (should (file-exists-p fil))
+ (should (file-regular-p fil)))
+ (should-not (file-exists-p saved))))
+
+(ert-deftest ert-x-tests-with-temp-file/handle-error ()
+ (let (saved)
+ (ignore-errors
+ (ert-with-temp-file fil
+ (setq saved fil)
+ (error "foo")))
+ (should-not (file-exists-p saved))))
+
+(ert-deftest ert-x-tests-with-temp-file/prefix-and-suffix-kwarg ()
+ (ert-with-temp-file fil
+ :prefix "foo"
+ :suffix "bar"
+ (should (string-match "foo.*bar" fil))))
+
+(ert-deftest ert-x-tests-with-temp-file/text-kwarg ()
+ (ert-with-temp-file fil
+ :text "foobar3"
+ (let ((buf (find-file-noselect fil)))
+ (unwind-protect
+ (with-current-buffer buf
+ (should (equal (buffer-string) "foobar3")))
+ (kill-buffer buf)))))
+
+(ert-deftest ert-x-tests-with-temp-file/unknown-kwarg-signals-error ()
+ (should-error
+ (ert-with-temp-file fil :foo "foo" nil)))
+
+(ert-deftest ert-x-tests-with-temp-directory ()
+ (let (saved)
+ (ert-with-temp-directory dir
+ (setq saved dir)
+ (should (file-exists-p dir))
+ (should (file-directory-p dir))
+ (should (equal dir (file-name-as-directory dir))))
+ (should-not (file-exists-p saved))))
+
+(ert-deftest ert-x-tests-with-temp-directory/text-signals-error ()
+ (should-error
+ (ert-with-temp-directory dir :text "foo" nil)))
(provide 'ert-x-tests)
diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el
index c81d3d09e7d..1d2aa7ab374 100644
--- a/test/lisp/emacs-lisp/generator-tests.el
+++ b/test/lisp/emacs-lisp/generator-tests.el
@@ -74,7 +74,7 @@ identical output."
(cps-testcase cps-prog1-b (prog1 1))
(cps-testcase cps-prog1-c (prog2 1 2 3))
(cps-testcase cps-quote (progn 'hello))
-(cps-testcase cps-function (progn #'hello))
+(cps-testcase cps-function (progn #'message))
(cps-testcase cps-and-fail (and 1 nil 2))
(cps-testcase cps-and-succeed (and 1 2 3))
@@ -85,9 +85,9 @@ identical output."
(cps-testcase cps-or-empty (or))
(cps-testcase cps-let* (let* ((i 10)) i))
-(cps-testcase cps-let*-shadow-empty (let* ((i 10)) (let (i) i)))
+(cps-testcase cps-let*-shadow-empty (let* ((i 10)) i (let ((i nil)) i)))
(cps-testcase cps-let (let ((i 10)) i))
-(cps-testcase cps-let-shadow-empty (let ((i 10)) (let (i) i)))
+(cps-testcase cps-let-shadow-empty (let ((i 10)) i (let ((i nil)) i)))
(cps-testcase cps-let-novars (let nil 42))
(cps-testcase cps-let*-novars (let* nil 42))
@@ -95,7 +95,7 @@ identical output."
(let ((a 5) (b 6)) (let ((a b) (b a)) (list a b))))
(cps-testcase cps-let*-parallel
- (let* ((a 5) (b 6)) (let* ((a b) (b a)) (list a b))))
+ (let* ((a 5) (b 6)) a (let* ((a b) (b a)) (list a b))))
(cps-testcase cps-while-dynamic
(setq *cps-test-i* 0)
@@ -219,7 +219,7 @@ identical output."
(should (eql (iter-next it -1) 42))
(should (eql (iter-next it -1) -1))))
-(ert-deftest cps-loop ()
+(ert-deftest cps-loop-2 ()
(should
(equal (cl-loop for x iter-by (mygenerator 42)
collect x)
@@ -307,6 +307,7 @@ identical output."
(1+ it)))))))
-2)))
+(defun generator-tests-edebug ()) ; silence byte-compiler
(ert-deftest generator-tests-edebug ()
"Check that Bug#40434 is fixed."
(with-temp-buffer
diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el
index b9850eca8b9..6ee274ae10f 100644
--- a/test/lisp/emacs-lisp/gv-tests.el
+++ b/test/lisp/emacs-lisp/gv-tests.el
@@ -21,22 +21,21 @@
(require 'edebug)
(require 'ert)
+(require 'ert-x)
(eval-when-compile (require 'cl-lib))
(cl-defmacro gv-tests--in-temp-dir ((elvar elcvar)
(&rest filebody)
&rest body)
(declare (indent 2))
- `(let ((default-directory (make-temp-file "gv-test" t)))
- (unwind-protect
- (let ((,elvar "gv-test-deffoo.el")
- (,elcvar "gv-test-deffoo.elc"))
- (with-temp-file ,elvar
- (insert ";; -*- lexical-binding: t; -*-\n")
- (dolist (form ',filebody)
- (pp form (current-buffer))))
- ,@body)
- (delete-directory default-directory t))))
+ `(ert-with-temp-directory default-directory
+ (let ((,elvar "gv-test-deffoo.el")
+ (,elcvar "gv-test-deffoo.elc"))
+ (with-temp-file ,elvar
+ (insert ";; -*- lexical-binding: t; -*-\n")
+ (dolist (form ',filebody)
+ (pp form (current-buffer))))
+ ,@body)))
(ert-deftest gv-define-expander-in-file ()
(gv-tests--in-temp-dir (el elc)
diff --git a/test/lisp/emacs-lisp/let-alist-tests.el b/test/lisp/emacs-lisp/let-alist-tests.el
index 88e689c80b8..bbceb04b49d 100644
--- a/test/lisp/emacs-lisp/let-alist-tests.el
+++ b/test/lisp/emacs-lisp/let-alist-tests.el
@@ -82,7 +82,7 @@
(ert-deftest let-alist-list-to-sexp ()
"Check that multiple dots are handled correctly."
- (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1)))))))))
+ (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1)))))) t)))
(should (equal (let-alist--access-sexp '.foo.bar.baz 'var)
'(cdr (assq 'baz (cdr (assq 'bar (cdr (assq 'foo var))))))))
(should (equal (let-alist--access-sexp '..foo.bar.baz 'var) '.foo.bar.baz)))
diff --git a/test/lisp/emacs-lisp/lisp-tests.el b/test/lisp/emacs-lisp/lisp-tests.el
index 78ecf3ff03d..7f4d50c5958 100644
--- a/test/lisp/emacs-lisp/lisp-tests.el
+++ b/test/lisp/emacs-lisp/lisp-tests.el
@@ -213,6 +213,7 @@
(should-error (forward-sexp)))) ;; FIXME: Shouldn't be an error.
;; Test some core Elisp rules.
+(defvar c-e-x)
(ert-deftest core-elisp-tests-1-defvar-in-let ()
"Test some core Elisp rules."
(with-temp-buffer
@@ -235,7 +236,7 @@
(should (or (not mark-active) (mark)))))
(ert-deftest core-elisp-tests-3-backquote ()
- (should (eq 3 (eval ``,,'(+ 1 2)))))
+ (should (eq 3 (eval ``,,'(+ 1 2) t))))
;; Test up-list and backward-up-list.
(defun lisp-run-up-list-test (fn data start instructions)
@@ -324,7 +325,7 @@ start."
(declare (indent 1) (debug (def-form body)))
(let* ((var-pos nil)
(text (with-temp-buffer
- (insert (eval contents))
+ (insert (eval contents t))
(goto-char (point-min))
(while (re-search-forward elisp-test-point-position-regex nil t)
(push (list (intern (match-string-no-properties 1))
diff --git a/test/lisp/emacs-lisp/multisession-tests.el b/test/lisp/emacs-lisp/multisession-tests.el
new file mode 100644
index 00000000000..1bf0a533a70
--- /dev/null
+++ b/test/lisp/emacs-lisp/multisession-tests.el
@@ -0,0 +1,201 @@
+;;; multisession-tests.el --- Tests for multisession.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 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 'multisession)
+(require 'ert)
+(require 'ert-x)
+(require 'cl-lib)
+
+(ert-deftest multi-test-sqlite-simple ()
+ (skip-unless (sqlite-available-p))
+ (ert-with-temp-file dir
+ :directory t
+ (let ((user-init-file "/tmp/foo.el")
+ (multisession-storage 'sqlite)
+ (multisession-directory dir))
+ (unwind-protect
+ (progn
+ (define-multisession-variable multisession--foo 0
+ ""
+ :synchronized t)
+ (should (= (multisession-value multisession--foo) 0))
+ (cl-incf (multisession-value multisession--foo))
+ (should (= (multisession-value multisession--foo) 1))
+ (call-process
+ (concat invocation-directory invocation-name)
+ nil t nil
+ "-Q" "-batch"
+ "--eval" (prin1-to-string
+ `(progn
+ (require 'multisession)
+ (let ((multisession-directory ,dir)
+ (multisession-storage 'sqlite)
+ (user-init-file "/tmp/foo.el"))
+ (define-multisession-variable multisession--foo 0
+ ""
+ :synchronized t)
+ (cl-incf (multisession-value multisession--foo))))))
+ (should (= (multisession-value multisession--foo) 2)))
+ (sqlite-close multisession--db)
+ (setq multisession--db nil)))))
+
+(ert-deftest multi-test-sqlite-busy ()
+ (skip-unless (and t (sqlite-available-p)))
+ (ert-with-temp-file dir
+ :directory t
+ (let ((user-init-file "/tmp/foo.el")
+ (multisession-directory dir)
+ (multisession-storage 'sqlite)
+ proc)
+ (unwind-protect
+ (progn
+ (define-multisession-variable multisession--bar 0
+ ""
+ :synchronized t)
+ (should (= (multisession-value multisession--bar) 0))
+ (cl-incf (multisession-value multisession--bar))
+ (should (= (multisession-value multisession--bar) 1))
+ (setq proc
+ (start-process
+ "other-emacs"
+ nil
+ (concat invocation-directory invocation-name)
+ "-Q" "-batch"
+ "--eval" (prin1-to-string
+ `(progn
+ (require 'multisession)
+ (let ((multisession-directory ,dir)
+ (multisession-storage 'sqlite)
+ (user-init-file "/tmp/bar.el"))
+ (define-multisession-variable multisession--bar 0
+ "" :synchronized t)
+ (dotimes (i 100)
+ (cl-incf (multisession-value multisession--bar))))))))
+ (while (process-live-p proc)
+ (ignore-error 'sqlite-locked-error
+ (message "multisession--bar %s" (multisession-value multisession--bar))
+ ;;(cl-incf (multisession-value multisession--bar))
+ )
+ (sleep-for 0.1))
+ (message "multisession--bar ends up as %s" (multisession-value multisession--bar))
+ (should (< (multisession-value multisession--bar) 1003)))
+ (sqlite-close multisession--db)
+ (setq multisession--db nil)))))
+
+(ert-deftest multi-test-files-simple ()
+ (ert-with-temp-file dir
+ :directory t
+ (let ((user-init-file "/tmp/sfoo.el")
+ (multisession-storage 'files)
+ (multisession-directory dir))
+ (define-multisession-variable multisession--sfoo 0
+ ""
+ :synchronized t)
+ (should (= (multisession-value multisession--sfoo) 0))
+ (cl-incf (multisession-value multisession--sfoo))
+ (should (= (multisession-value multisession--sfoo) 1))
+ (call-process
+ (concat invocation-directory invocation-name)
+ nil t nil
+ "-Q" "-batch"
+ "--eval" (prin1-to-string
+ `(progn
+ (require 'multisession)
+ (let ((multisession-directory ,dir)
+ (multisession-storage 'files)
+ (user-init-file "/tmp/sfoo.el"))
+ (define-multisession-variable multisession--sfoo 0
+ ""
+ :synchronized t)
+ (cl-incf (multisession-value multisession--sfoo))))))
+ (should (= (multisession-value multisession--sfoo) 2)))))
+
+(ert-deftest multi-test-files-busy ()
+ (skip-unless (and t (sqlite-available-p)))
+ (ert-with-temp-file dir
+ :directory t
+ (let ((user-init-file "/tmp/foo.el")
+ (multisession-storage 'files)
+ (multisession-directory dir)
+ proc)
+ (define-multisession-variable multisession--sbar 0
+ ""
+ :synchronized t)
+ (should (= (multisession-value multisession--sbar) 0))
+ (cl-incf (multisession-value multisession--sbar))
+ (should (= (multisession-value multisession--sbar) 1))
+ (setq proc
+ (start-process
+ "other-emacs"
+ nil
+ (concat invocation-directory invocation-name)
+ "-Q" "-batch"
+ "--eval" (prin1-to-string
+ `(progn
+ (require 'multisession)
+ (let ((multisession-directory ,dir)
+ (multisession-storage 'files)
+ (user-init-file "/tmp/sbar.el"))
+ (define-multisession-variable multisession--sbar 0
+ "" :synchronized t)
+ (dotimes (i 1000)
+ (cl-incf (multisession-value multisession--sbar))))))))
+ (while (process-live-p proc)
+ (message "multisession--sbar %s" (multisession-value multisession--sbar))
+ ;;(cl-incf (multisession-value multisession--sbar))
+ (sleep-for 0.1))
+ (message "multisession--sbar ends up as %s" (multisession-value multisession--sbar))
+ (should (< (multisession-value multisession--sbar) 2000)))))
+
+(ert-deftest multi-test-files-some-values ()
+ (ert-with-temp-file dir
+ :directory t
+ (let ((user-init-file "/tmp/sfoo.el")
+ (multisession-storage 'files)
+ (multisession-directory dir))
+ (define-multisession-variable multisession--foo1 nil)
+ (should (eq (multisession-value multisession--foo1) nil))
+ (setf (multisession-value multisession--foo1) nil)
+ (should (eq (multisession-value multisession--foo1) nil))
+ (setf (multisession-value multisession--foo1) t)
+ (should (eq (multisession-value multisession--foo1) t))
+
+ (define-multisession-variable multisession--foo2 t)
+ (setf (multisession-value multisession--foo2) nil)
+ (should (eq (multisession-value multisession--foo2) nil))
+ (setf (multisession-value multisession--foo2) t)
+ (should (eq (multisession-value multisession--foo2) t))
+
+ (define-multisession-variable multisession--foo3 t)
+ (should-error (setf (multisession-value multisession--foo3) (make-marker)))
+
+ (let ((string (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert 0 1 2)
+ (buffer-string))))
+ (should-not (multibyte-string-p string))
+ (define-multisession-variable multisession--foo4 nil)
+ (setf (multisession-value multisession--foo4) string)
+ (should (equal (multisession-value multisession--foo4) string))))))
+
+;;; multisession-tests.el ends here
diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el
new file mode 100644
index 00000000000..724f88ec9ea
--- /dev/null
+++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el
@@ -0,0 +1,12 @@
+;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*-
+
+;; Author: Artur Malabarba <emacs@endlessparentheses.com>
+
+;;; Code:
+
+(defun macro-builtin-aux-1 ( &rest forms)
+ "Description"
+ `(progn ,@forms))
+
+(provide 'macro-builtin-aux)
+;;; macro-builtin-aux.el ends here
diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el
new file mode 100644
index 00000000000..828968a0576
--- /dev/null
+++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el
@@ -0,0 +1,21 @@
+;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*-
+
+;; Author: Artur Malabarba <emacs@endlessparentheses.com>
+;; Keywords: tools
+;; Version: 1.0
+
+;;; Code:
+
+(require 'macro-builtin-aux)
+
+(defmacro macro-builtin-1 ( &rest forms)
+ "Description"
+ `(progn ,@forms))
+
+(defun macro-builtin-func ()
+ ""
+ (macro-builtin-1 'a 'b)
+ (macro-builtin-aux-1 'a 'b))
+
+(provide 'macro-builtin)
+;;; macro-builtin.el ends here
diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el
new file mode 100644
index 00000000000..9f257d9d22c
--- /dev/null
+++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el
@@ -0,0 +1,16 @@
+;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*-
+
+;; Author: Artur Malabarba <emacs@endlessparentheses.com>
+
+;;; Code:
+
+(defmacro macro-builtin-aux-1 ( &rest forms)
+ "Description"
+ `(progn ,@forms))
+
+(defmacro macro-builtin-aux-3 ( &rest _)
+ "Description"
+ 90)
+
+(provide 'macro-builtin-aux)
+;;; macro-builtin-aux.el ends here
diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el
new file mode 100644
index 00000000000..5d241c082d0
--- /dev/null
+++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el
@@ -0,0 +1,30 @@
+;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*-
+
+;; Author: Artur Malabarba <emacs@endlessparentheses.com>
+;; Keywords: tools
+;; Version: 2.0
+
+;;; Code:
+
+(require 'macro-builtin-aux)
+
+(defmacro macro-builtin-1 ( &rest forms)
+ "Description"
+ `(progn ,(cadr (car forms))))
+
+
+(defun macro-builtin-func ()
+ ""
+ (list (macro-builtin-1 '1 'b)
+ (macro-builtin-aux-1 'a 'b)))
+
+(defmacro macro-builtin-3 (&rest _)
+ "Description"
+ 10)
+
+(defun macro-builtin-10-and-90 ()
+ ""
+ (list (macro-builtin-3 haha) (macro-builtin-aux-3 hehe)))
+
+(provide 'macro-builtin)
+;;; macro-builtin.el ends here
diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el
index 1fd93bc1be7..efa9f834110 100644
--- a/test/lisp/emacs-lisp/package-tests.el
+++ b/test/lisp/emacs-lisp/package-tests.el
@@ -115,57 +115,55 @@
&rest body)
"Set up temporary locations and variables for testing."
(declare (indent 1) (debug (([&rest form]) body)))
- `(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t))
- (process-environment (cons (format "HOME=%s" package-test-user-dir)
- process-environment))
- (package-user-dir package-test-user-dir)
- (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir))
- (package-archives `(("gnu" . ,(or ,location package-test-data-dir))))
- (default-directory package-test-file-dir)
- abbreviated-home-dir
- package--initialized
- package-alist
- ,@(if update-news
- '(package-update-news-on-upload t)
- (list (cl-gensym)))
- ,@(if upload-base
- '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t))
- (package-archive-upload-base package-test-archive-upload-base))
- (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil
- (let ((buf (get-buffer "*Packages*")))
- (when (buffer-live-p buf)
- (kill-buffer buf)))
- (unwind-protect
- (progn
- ,(if basedir `(cd ,basedir))
- (unless (file-directory-p package-user-dir)
- (mkdir package-user-dir))
- (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t))
- ((symbol-function 'y-or-n-p) (lambda (&rest _) t)))
- ,@(when install
- `((package-initialize)
- (package-refresh-contents)
- (mapc 'package-install ,install)))
- (with-temp-buffer
- ,(if file
- `(insert-file-contents ,file))
- ,@body)))
-
- (when ,upload-base
- (dolist (f '("archive-contents"
- "simple-single-1.3.el"
- "simple-single-1.4.el"
- "simple-single-readme.txt"))
- (ignore-errors
- (delete-file
- (expand-file-name f package-test-archive-upload-base))))
- (delete-directory package-test-archive-upload-base))
- (when (file-directory-p package-test-user-dir)
- (delete-directory package-test-user-dir t))
-
- (when (and (boundp 'package-test-archive-upload-base)
- (file-directory-p package-test-archive-upload-base))
- (delete-directory package-test-archive-upload-base t)))))
+ `(ert-with-temp-directory package-test-user-dir
+ (let* ((process-environment (cons (format "HOME=%s" package-test-user-dir)
+ process-environment))
+ (package-user-dir package-test-user-dir)
+ (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir))
+ (package-archives `(("gnu" . ,(or ,location package-test-data-dir))))
+ (default-directory package-test-file-dir)
+ abbreviated-home-dir
+ package--initialized
+ package-alist
+ ,@(if update-news
+ '(package-update-news-on-upload t)
+ (list (cl-gensym)))
+ ,@(if upload-base
+ '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t))
+ (package-archive-upload-base package-test-archive-upload-base))
+ (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil
+ (let ((buf (get-buffer "*Packages*")))
+ (when (buffer-live-p buf)
+ (kill-buffer buf)))
+ (unwind-protect
+ (progn
+ ,(if basedir `(cd ,basedir))
+ (unless (file-directory-p package-user-dir)
+ (mkdir package-user-dir))
+ (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t))
+ ((symbol-function 'y-or-n-p) (lambda (&rest _) t)))
+ ,@(when install
+ `((package-initialize)
+ (package-refresh-contents)
+ (mapc 'package-install ,install)))
+ (with-temp-buffer
+ ,(if file
+ `(insert-file-contents ,file))
+ ,@body)))
+
+ (when ,upload-base
+ (dolist (f '("archive-contents"
+ "simple-single-1.3.el"
+ "simple-single-1.4.el"
+ "simple-single-readme.txt"))
+ (ignore-errors
+ (delete-file
+ (expand-file-name f package-test-archive-upload-base))))
+ (delete-directory package-test-archive-upload-base))
+
+ (when (and (boundp 'package-test-archive-upload-base)
+ (file-directory-p package-test-archive-upload-base))
+ (delete-directory package-test-archive-upload-base t))))))
(defmacro with-fake-help-buffer (&rest body)
"Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer."
@@ -342,9 +340,13 @@ but with a different end of line convention (bug#48137)."
(declare-function macro-problem-func "macro-problem" ())
(declare-function macro-problem-10-and-90 "macro-problem" ())
+(declare-function macro-builtin-func "macro-builtin" ())
+(declare-function macro-builtin-10-and-90 "macro-builtin" ())
(ert-deftest package-test-macro-compilation ()
- "Install a package which includes a dependency."
+ "\"Activation has to be done before compilation, so that if we're
+ upgrading and macros have changed we load the new definitions
+ before compiling.\" -- package.el"
(with-package-test (:basedir (ert-resource-directory))
(package-install-file (expand-file-name "macro-problem-package-1.0/"))
(require 'macro-problem)
@@ -357,6 +359,32 @@ but with a different end of line convention (bug#48137)."
;; `macro-problem-10-and-90' depends on an entirely new macro from `macro-aux'.
(should (equal (macro-problem-10-and-90) '(10 90)))))
+(ert-deftest package-test-macro-compilation-gz ()
+ "Built-in's can be superseded as well."
+ (with-package-test (:basedir (ert-resource-directory))
+ (let ((dir (expand-file-name "macro-builtin-package-1.0")))
+ (unwind-protect
+ (let ((load-path load-path))
+ (add-to-list 'load-path (directory-file-name dir))
+ (byte-recompile-directory dir 0 t)
+ (mapc (lambda (f) (call-process "gzip" nil nil nil f))
+ (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))
+ (require 'macro-builtin)
+ (should (member (expand-file-name "macro-builtin-aux.elc" dir)
+ (mapcar #'car load-history)))
+ ;; `macro-builtin-func' uses a macro from `macro-aux'.
+ (should (equal (macro-builtin-func) '(progn a b)))
+ (package-install-file (expand-file-name "macro-builtin-package-2.0/"))
+ ;; After upgrading, `macro-builtin-func' depends on a new version
+ ;; of the macro from `macro-builtin-aux'.
+ (should (equal (macro-builtin-func) '(1 b)))
+ ;; `macro-builtin-10-and-90' depends on an entirely new macro from `macro-aux'.
+ (should (equal (macro-builtin-10-and-90) '(10 90))))
+ (mapc #'delete-file
+ (directory-files-recursively dir "\\`[^\\.].*\\.elc\\'"))
+ (mapc (lambda (f) (call-process "gunzip" nil nil nil f))
+ (directory-files-recursively dir "\\`[^\\.].*\\.el\\.gz\\'"))))))
+
(ert-deftest package-test-install-two-dependencies ()
"Install a package which includes a dependency."
(with-package-test ()
@@ -685,25 +713,23 @@ but with a different end of line convention (bug#48137)."
(defvar epg-config--program-alist) ; Silence byte-compiler.
(ert-deftest package-test-signed ()
"Test verifying package signature."
- (skip-unless (let ((homedir (make-temp-file "package-test" t)))
- (unwind-protect
- (let ((process-environment
- (cons (concat "HOME=" homedir)
- process-environment)))
- (require 'epg-config)
- (defvar epg-config--program-alist)
- (epg-find-configuration
- 'OpenPGP nil
- ;; By default we require gpg2 2.1+ due to some
- ;; practical problems with pinentry. But this
- ;; test works fine with 2.0 as well.
- (let ((prog-alist (copy-tree epg-config--program-alist)))
- (setf (alist-get "gpg2"
- (alist-get 'OpenPGP prog-alist)
- nil nil #'equal)
- "2.0")
- prog-alist)))
- (delete-directory homedir t))))
+ (skip-unless (ert-with-temp-directory homedir
+ (let ((process-environment
+ (cons (concat "HOME=" homedir)
+ process-environment)))
+ (require 'epg-config)
+ (defvar epg-config--program-alist)
+ (epg-find-configuration
+ 'OpenPGP nil
+ ;; By default we require gpg2 2.1+ due to some
+ ;; practical problems with pinentry. But this
+ ;; test works fine with 2.0 as well.
+ (let ((prog-alist (copy-tree epg-config--program-alist)))
+ (setf (alist-get "gpg2"
+ (alist-get 'OpenPGP prog-alist)
+ nil nil #'equal)
+ "2.0")
+ prog-alist)))))
(let* ((keyring (expand-file-name "key.pub" package-test-data-dir))
(package-test-data-dir (ert-resource-file "signed")))
(with-package-test ()
diff --git a/test/lisp/emacs-lisp/pp-resources/code-formats.erts b/test/lisp/emacs-lisp/pp-resources/code-formats.erts
new file mode 100644
index 00000000000..2b2001d0964
--- /dev/null
+++ b/test/lisp/emacs-lisp/pp-resources/code-formats.erts
@@ -0,0 +1,124 @@
+Code:
+ (lambda ()
+ (emacs-lisp-mode)
+ (let ((code (read (current-buffer))))
+ (erase-buffer)
+ (pp-emacs-lisp-code code)
+ (untabify (point-min) (point-max))))
+
+Name: code-formats1
+
+=-=
+(defun foo (bar)
+ "Yes."
+ (let ((a 1)
+ (b 2))
+ (zot 1 2 (funcall bar 2))))
+=-=-=
+
+
+Name: code-formats2
+
+=-=
+(defun pp-emacs-lisp-code (sexp)
+ "Insert SEXP into the current buffer, formatted as Emacs Lisp code."
+ (require 'edebug)
+ (let ((start (point))
+ (standard-output (current-buffer)))
+ (pp--insert-lisp sexp)
+ (insert "\n")
+ (goto-char start)
+ (indent-sexp)))
+=-=-=
+
+
+Name: code-formats3
+
+=-=
+(defun foo (bar)
+ "Yes."
+ (let ((a 1)
+ (b 2))
+ (zot-zot-zot-zot-zot-zot 1 2 (funcall
+ bar-bar-bar-bar-bar-bar-bar-bar-bar-bar
+ 2))))
+=-=-=
+
+
+Name: code-formats4
+
+=-=
+(defun foo (bar)
+ "Yes."
+ (let ((a 1)
+ (b 2)
+ foo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo
+ bar zot)
+ (zot 1 2 (funcall bar 2))))
+=-=-=
+
+
+Name: code-formats5
+
+=-=
+(defgroup pp ()
+ "Pretty printer for Emacs Lisp."
+ :prefix "pp-"
+ :group 'lisp)
+=-=-=
+
+Name: code-formats6
+
+=-=
+(defcustom pp-escape-newlines t
+ "Value of `print-escape-newlines' used by pp-* functions."
+ :type 'boolean
+ :group 'pp)
+=-=-=
+
+Name: code-formats7
+
+=-=
+(defun pp (object &optional stream)
+ (princ (pp-to-string object) (or stream standard-output)))
+=-=-=
+
+
+Name: code-formats8
+
+=-=
+(defun pp-eval-expression (expression)
+ "Evaluate EXPRESSION and pretty-print its value.
+Also add the value to the front of the list in the variable `values'."
+ (interactive (list (read--expression "Eval: ")))
+ (message "Evaluating...")
+ (let ((result (eval expression lexical-binding)))
+ (values--store-value result)
+ (pp-display-expression result "*Pp Eval Output*")))
+=-=-=
+
+Name: code-formats9
+
+=-=
+(lambda ()
+ (interactive)
+ 1)
+=-=-=
+
+
+Name: code-formats10
+
+=-=
+(funcall foo (concat "zot" (if (length> site 0) site
+ "bar")
+ "+"
+ (string-replace " " "+" query)))
+=-=-=
+
+
+Name: code-formats11
+
+=-=
+(lambda ()
+ [(foo bar) (foo bar)])
+=-=-=
diff --git a/test/lisp/emacs-lisp/pp-tests.el b/test/lisp/emacs-lisp/pp-tests.el
index b04030cc432..4cae1a73775 100644
--- a/test/lisp/emacs-lisp/pp-tests.el
+++ b/test/lisp/emacs-lisp/pp-tests.el
@@ -20,6 +20,7 @@
;;; Code:
(require 'pp)
+(require 'ert-x)
(ert-deftest pp-print-quote ()
(should (string= (pp-to-string 'quote) "quote"))
@@ -32,4 +33,7 @@
(should (string= (pp-to-string '(quotefoo)) "(quotefoo)\n"))
(should (string= (pp-to-string '(a b)) "(a b)\n")))
+(ert-deftest test-indentation ()
+ (ert-test-erts-file (ert-resource-file "code-formats.erts")))
+
;;; pp-tests.el ends here.
diff --git a/test/lisp/emacs-lisp/ring-tests.el b/test/lisp/emacs-lisp/ring-tests.el
index 55df4f36685..3ec20a1e8ef 100644
--- a/test/lisp/emacs-lisp/ring-tests.el
+++ b/test/lisp/emacs-lisp/ring-tests.el
@@ -199,7 +199,7 @@
(should (= (ring-size ring) 3))
(should (equal (ring-elements ring) '(5 4 3)))))
-(ert-deftest ring-tests-insert ()
+(ert-deftest ring-tests-insert-2 ()
(let ((ring (make-ring 2)))
(ring-insert+extend ring :a)
(ring-insert+extend ring :b)
diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el
index 8dc0b93b5af..4b940af81f1 100644
--- a/test/lisp/emacs-lisp/seq-tests.el
+++ b/test/lisp/emacs-lisp/seq-tests.el
@@ -173,16 +173,18 @@ Evaluate BODY for each created sequence.
(should (seq-find #'null '(1 2 3) 'sentinel)))
(ert-deftest test-seq-contains ()
- (with-test-sequences (seq '(3 4 5 6))
- (should (seq-contains seq 3))
- (should-not (seq-contains seq 7)))
- (with-test-sequences (seq '())
- (should-not (seq-contains seq 3))
- (should-not (seq-contains seq nil))))
+ (with-suppressed-warnings ((obsolete seq-contains))
+ (with-test-sequences (seq '(3 4 5 6))
+ (should (seq-contains seq 3))
+ (should-not (seq-contains seq 7)))
+ (with-test-sequences (seq '())
+ (should-not (seq-contains seq 3))
+ (should-not (seq-contains seq nil)))))
(ert-deftest test-seq-contains-should-return-the-elt ()
- (with-test-sequences (seq '(3 4 5 6))
- (should (= 5 (seq-contains seq 5)))))
+ (with-suppressed-warnings ((obsolete seq-contains))
+ (with-test-sequences (seq '(3 4 5 6))
+ (should (= 5 (seq-contains seq 5))))))
(ert-deftest test-seq-contains-p ()
(with-test-sequences (seq '(3 4 5 6))
@@ -404,7 +406,7 @@ Evaluate BODY for each created sequence.
(let ((seq '(1 (2 (3 (4))))))
(seq-let (_ (_ (_ (a)))) seq
(should (= a 4))))
- (let (seq)
+ (let ((seq nil))
(seq-let (a b c) seq
(should (null a))
(should (null b))
@@ -428,7 +430,7 @@ Evaluate BODY for each created sequence.
(seq '(1 (2 (3 (4))))))
(seq-setq (_ (_ (_ (a)))) seq)
(should (= a 4)))
- (let (seq a b c)
+ (let ((seq nil) a b c)
(seq-setq (a b c) seq)
(should (null a))
(should (null b))
diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el
index 1d19496ba44..821b6770ba0 100644
--- a/test/lisp/emacs-lisp/subr-x-tests.el
+++ b/test/lisp/emacs-lisp/subr-x-tests.el
@@ -169,13 +169,13 @@
"no")
"no"))
(should (equal
- (let (z)
+ (let ((z nil))
(if-let* (z (a 1) (b 2) (c 3))
"yes"
"no"))
"no"))
(should (equal
- (let (d)
+ (let ((d nil))
(if-let* ((a 1) (b 2) (c 3) d)
"yes"
"no"))
@@ -191,7 +191,7 @@
(ert-deftest subr-x-test-if-let*-and-laziness-is-preserved ()
"Test `if-let' respects `and' laziness."
- (let (a-called b-called c-called)
+ (let ((a-called nil) (b-called nil) c-called)
(should (equal
(if-let* ((a nil)
(b (setq b-called t))
@@ -199,7 +199,7 @@
"yes"
(list a-called b-called c-called))
(list nil nil nil))))
- (let (a-called b-called c-called)
+ (let ((a-called nil) (b-called nil) c-called)
(should (equal
(if-let* ((a (setq a-called t))
(b nil)
@@ -207,12 +207,12 @@
"yes"
(list a-called b-called c-called))
(list t nil nil))))
- (let (a-called b-called c-called)
+ (let ((a-called nil) (b-called nil) c-called)
(should (equal
(if-let* ((a (setq a-called t))
- (b (setq b-called t))
- (c nil)
- (d (setq c-called t)))
+ (b (setq b-called t))
+ (c nil)
+ (d (setq c-called t)))
"yes"
(list a-called b-called c-called))
(list t t nil)))))
@@ -329,12 +329,12 @@
"no")
nil))
(should (equal
- (let (z)
+ (let ((z nil))
(when-let* (z (a 1) (b 2) (c 3))
"no"))
nil))
(should (equal
- (let (d)
+ (let ((d nil))
(when-let* ((a 1) (b 2) (c 3) d)
"no"))
nil)))
@@ -348,7 +348,7 @@
(ert-deftest subr-x-test-when-let*-and-laziness-is-preserved ()
"Test `when-let' respects `and' laziness."
- (let (a-called b-called c-called)
+ (let ((a-called nil) (b-called nil) (c-called nil))
(should (equal
(progn
(when-let* ((a nil)
@@ -357,7 +357,7 @@
"yes")
(list a-called b-called c-called))
(list nil nil nil))))
- (let (a-called b-called c-called)
+ (let ((a-called nil) (b-called nil) (c-called nil))
(should (equal
(progn
(when-let* ((a (setq a-called t))
@@ -366,7 +366,7 @@
"yes")
(list a-called b-called c-called))
(list t nil nil))))
- (let (a-called b-called c-called)
+ (let ((a-called nil) (b-called nil) (c-called nil))
(should (equal
(progn
(when-let* ((a (setq a-called t))
@@ -638,5 +638,79 @@
(should (equal (string-chop-newline "foo\nbar\n") "foo\nbar"))
(should (equal (string-chop-newline "foo\nbar") "foo\nbar")))
+(ert-deftest subr-ensure-empty-lines ()
+ (should
+ (equal
+ (with-temp-buffer
+ (insert "foo")
+ (goto-char (point-min))
+ (ensure-empty-lines 2)
+ (buffer-string))
+ "\n\nfoo"))
+ (should
+ (equal
+ (with-temp-buffer
+ (insert "foo")
+ (ensure-empty-lines 2)
+ (buffer-string))
+ "foo\n\n\n"))
+ (should
+ (equal
+ (with-temp-buffer
+ (insert "foo\n")
+ (ensure-empty-lines 2)
+ (buffer-string))
+ "foo\n\n\n"))
+ (should
+ (equal
+ (with-temp-buffer
+ (insert "foo\n\n\n\n\n")
+ (ensure-empty-lines 2)
+ (buffer-string))
+ "foo\n\n\n"))
+ (should
+ (equal
+ (with-temp-buffer
+ (insert "foo\n\n\n")
+ (ensure-empty-lines 0)
+ (buffer-string))
+ "foo\n")))
+
+(ert-deftest subr-x-test-add-display-text-property ()
+ (with-temp-buffer
+ (insert "Foo bar zot gazonk")
+ (add-display-text-property 4 8 'height 2.0)
+ (add-display-text-property 2 12 'raise 0.5)
+ (should (equal (get-text-property 2 'display) '(raise 0.5)))
+ (should (equal (get-text-property 5 'display)
+ '((raise 0.5) (height 2.0))))
+ (should (equal (get-text-property 9 'display) '(raise 0.5))))
+ (with-temp-buffer
+ (insert "Foo bar zot gazonk")
+ (put-text-property 4 8 'display [(height 2.0)])
+ (add-display-text-property 2 12 'raise 0.5)
+ (should (equal (get-text-property 2 'display) '(raise 0.5)))
+ (should (equal (get-text-property 5 'display)
+ [(raise 0.5) (height 2.0)]))
+ (should (equal (get-text-property 9 'display) '(raise 0.5)))))
+
+(ert-deftest subr-x-named-let ()
+ (let ((funs ()))
+ (named-let loop
+ ((rest '(1 42 3))
+ (sum 0))
+ (when rest
+ ;; Here, we make sure that the variables are distinct in every
+ ;; iteration, since a naive tail-call optimization would tend to end up
+ ;; with a single `sum' variable being shared by all the closures.
+ (push (lambda () sum) funs)
+ ;; Here we add a dummy `sum' variable which shadows the `sum' iteration
+ ;; variable since a naive tail-call optimization could also trip here
+ ;; thinking it can `(setq sum ...)' to set the iteration
+ ;; variable's value.
+ (let ((sum sum))
+ (loop (cdr rest) (+ sum (car rest))))))
+ (should (equal (mapcar #'funcall funs) '(43 1 0)))))
+
(provide 'subr-x-tests)
;;; subr-x-tests.el ends here
diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el
index 29094526d7e..4d49e5ae70c 100644
--- a/test/lisp/emacs-lisp/testcover-resources/testcases.el
+++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el
@@ -424,7 +424,7 @@
(defmacro testcover-testcase-nth-case (arg vec)
(declare (indent 1)
(debug (form (vector &rest form))))
- `(eval (aref ,vec%%% ,arg%%%))%%%)
+ `(eval (aref ,vec%%% ,arg%%%) t)%%%)
(defun testcover-testcase-use-nth-case (choice val)
(testcover-testcase-nth-case choice
diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el
index 7854e33e77d..a7e055a28b1 100644
--- a/test/lisp/emacs-lisp/testcover-tests.el
+++ b/test/lisp/emacs-lisp/testcover-tests.el
@@ -45,34 +45,34 @@ testcases.el. This can be used to create test cases if Testcover
is working correctly on a code sample. OPTARGS are optional
arguments for `testcover-start'."
(interactive "r")
- (let ((tempfile (make-temp-file "testcover-tests-" nil ".el"))
- (find-file-suppress-same-file-warnings t)
- (code (buffer-substring beg end))
- (marked-up-code))
- (unwind-protect
- (progn
- (with-temp-file tempfile
- (insert code))
- (save-current-buffer
- (let ((buf (find-file-noselect tempfile)))
- (set-buffer buf)
- (apply 'testcover-start (cons tempfile optargs))
- (testcover-mark-all buf)
- (dolist (overlay (overlays-in (point-min) (point-max)))
- (let ((ov-face (overlay-get overlay 'face)))
- (goto-char (overlay-end overlay))
- (cond
- ((eq ov-face 'testcover-nohits) (insert "!!!"))
- ((eq ov-face 'testcover-1value) (insert "%%%"))
- (t nil))))
- (setq marked-up-code (buffer-string)))
- (set-buffer-modified-p nil)))
- (ignore-errors (kill-buffer (find-file-noselect tempfile)))
- (ignore-errors (delete-file tempfile)))
-
- ;; Now replace the original code with the marked up code.
- (delete-region beg end)
- (insert marked-up-code))))
+ (ert-with-temp-file tempfile
+ :suffix ".el"
+ (let ((find-file-suppress-same-file-warnings t)
+ (code (buffer-substring beg end))
+ (marked-up-code))
+ (unwind-protect
+ (progn
+ (with-temp-file tempfile
+ (insert code))
+ (save-current-buffer
+ (let ((buf (find-file-noselect tempfile)))
+ (set-buffer buf)
+ (apply 'testcover-start (cons tempfile optargs))
+ (testcover-mark-all buf)
+ (dolist (overlay (overlays-in (point-min) (point-max)))
+ (let ((ov-face (overlay-get overlay 'face)))
+ (goto-char (overlay-end overlay))
+ (cond
+ ((eq ov-face 'testcover-nohits) (insert "!!!"))
+ ((eq ov-face 'testcover-1value) (insert "%%%"))
+ (t nil))))
+ (setq marked-up-code (buffer-string)))
+ (set-buffer-modified-p nil)))
+ (ignore-errors (kill-buffer (find-file-noselect tempfile))))
+
+ ;; Now replace the original code with the marked up code.
+ (delete-region beg end)
+ (insert marked-up-code)))))
(eval-and-compile
(defun testcover-tests-unmarkup-region (beg end)
@@ -99,32 +99,32 @@ arguments for `testcover-start'."
(eval-and-compile
(defun testcover-tests-run-test-case (marked-up-code)
"Test the operation of Testcover on the string MARKED-UP-CODE."
- (let ((tempfile (make-temp-file "testcover-tests-" nil ".el"))
- (find-file-suppress-same-file-warnings t))
- (unwind-protect
- (progn
- (with-temp-file tempfile
- (insert marked-up-code))
- ;; Remove the marks and mark the code up again. The original
- ;; and recreated versions should match.
- (save-current-buffer
- (set-buffer (find-file-noselect tempfile))
- ;; Fail the test if the debugger tries to become active,
- ;; which can happen if Testcover fails to attach itself
- ;; correctly. Note that this will prevent debugging
- ;; these tests using Edebug.
- (cl-letf (((symbol-function #'edebug-default-enter)
- (lambda (&rest _args)
- (ert-fail "Debugger invoked during test run"))))
- (dolist (byte-compile '(t nil))
- (testcover-tests-unmarkup-region (point-min) (point-max))
- (unwind-protect
- (testcover-tests-markup-region (point-min) (point-max) byte-compile)
- (set-buffer-modified-p nil))
- (should (string= marked-up-code
- (buffer-string)))))))
- (ignore-errors (kill-buffer (find-file-noselect tempfile)))
- (ignore-errors (delete-file tempfile))))))
+ (ert-with-temp-file tempfile
+ :suffix ".el"
+ (let ((find-file-suppress-same-file-warnings t))
+ (unwind-protect
+ (progn
+ (with-temp-file tempfile
+ (insert marked-up-code))
+ ;; Remove the marks and mark the code up again. The original
+ ;; and recreated versions should match.
+ (save-current-buffer
+ (set-buffer (find-file-noselect tempfile))
+ ;; Fail the test if the debugger tries to become active,
+ ;; which can happen if Testcover fails to attach itself
+ ;; correctly. Note that this will prevent debugging
+ ;; these tests using Edebug.
+ (cl-letf (((symbol-function #'edebug-default-enter)
+ (lambda (&rest _args)
+ (ert-fail "Debugger invoked during test run"))))
+ (dolist (byte-compile '(t nil))
+ (testcover-tests-unmarkup-region (point-min) (point-max))
+ (unwind-protect
+ (testcover-tests-markup-region (point-min) (point-max) byte-compile)
+ (set-buffer-modified-p nil))
+ (should (string= marked-up-code
+ (buffer-string)))))))
+ (ignore-errors (kill-buffer (find-file-noselect tempfile))))))))
;; Convert test case file to ert-defmethod.
diff --git a/test/lisp/emacs-lisp/timer-tests.el b/test/lisp/emacs-lisp/timer-tests.el
index 7856c217f9e..0f5b1a71868 100644
--- a/test/lisp/emacs-lisp/timer-tests.el
+++ b/test/lisp/emacs-lisp/timer-tests.el
@@ -37,7 +37,8 @@
(ert-deftest timer-tests-debug-timer-check ()
;; This function exists only if --enable-checking.
(skip-unless (fboundp 'debug-timer-check))
- (should (debug-timer-check)))
+ (when (fboundp 'debug-timer-check) ; silence byte-compiler
+ (should (debug-timer-check))))
(ert-deftest timer-test-multiple-of-time ()
(should (time-equal-p
diff --git a/test/lisp/emulation/viper-tests.el b/test/lisp/emulation/viper-tests.el
index 0d999763b61..b8efc87ab70 100644
--- a/test/lisp/emulation/viper-tests.el
+++ b/test/lisp/emulation/viper-tests.el
@@ -21,7 +21,8 @@
;;; Code:
-
+(require 'ert)
+(require 'ert-x)
(require 'viper)
(defun viper-test-undo-kmacro (kmacro)
@@ -30,47 +31,42 @@
This function makes as many attempts as possible to clean up
after itself, although it will leave a buffer called
*viper-test-buffer* if it fails (this is deliberate!)."
- (let (
- ;; Viper just turns itself off during batch use.
- (noninteractive nil)
- ;; Switch off start up message or it will chew the key presses.
- (viper-inhibit-startup-message 't)
- ;; Select an expert-level for the same reason.
- (viper-expert-level 5)
- ;; viper loads this even with -q so make sure it's empty!
- (viper-custom-file-name (make-temp-file "viper-tests" nil ".elc"))
- (before-buffer (current-buffer)))
- (unwind-protect
- (progn
- ;; viper-mode is essentially global, so set it here.
- (viper-mode)
- ;; We must switch to buffer because we are using a keyboard macro
- ;; which appears to not go to the current-buffer but what ever is
- ;; currently taking keyboard events. We use a named buffer because
- ;; then we can see what it in it if it all goes wrong.
- (switch-to-buffer
- (get-buffer-create
- "*viper-test-buffer*"))
- (erase-buffer)
- ;; The new buffer fails to enter vi state so set it.
- (viper-change-state-to-vi)
- ;; Run the macro.
- (execute-kbd-macro kmacro)
- (let ((rtn
- (buffer-substring-no-properties
- (point-min)
- (point-max))))
- ;; Kill the buffer iff the macro succeeds.
- (kill-buffer)
- rtn))
- ;; Switch everything off and restore the buffer.
- (toggle-viper-mode)
- (delete-file viper-custom-file-name)
- (switch-to-buffer before-buffer))))
-
-(ert-deftest viper-test-go ()
- "Test that this file is running."
- (should t))
+ (ert-with-temp-file viper-custom-file-name
+ ;; viper loads this even with -q so make sure it's empty!
+ :prefix "emacs-viper-tests" :suffix ".elc"
+ (let (;; Viper just turns itself off during batch use.
+ (noninteractive nil)
+ ;; Switch off start up message or it will chew the key presses.
+ (viper-inhibit-startup-message 't)
+ ;; Select an expert-level for the same reason.
+ (viper-expert-level 5)
+ (before-buffer (current-buffer)))
+ (unwind-protect
+ (progn
+ ;; viper-mode is essentially global, so set it here.
+ (viper-mode)
+ ;; We must switch to buffer because we are using a keyboard macro
+ ;; which appears to not go to the current-buffer but what ever is
+ ;; currently taking keyboard events. We use a named buffer because
+ ;; then we can see what it in it if it all goes wrong.
+ (switch-to-buffer
+ (get-buffer-create
+ "*viper-test-buffer*"))
+ (erase-buffer)
+ ;; The new buffer fails to enter vi state so set it.
+ (viper-change-state-to-vi)
+ ;; Run the macro.
+ (execute-kbd-macro kmacro)
+ (let ((rtn
+ (buffer-substring-no-properties
+ (point-min)
+ (point-max))))
+ ;; Kill the buffer iff the macro succeeds.
+ (kill-buffer)
+ rtn))
+ ;; Switch everything off and restore the buffer.
+ (toggle-viper-mode)
+ (switch-to-buffer before-buffer)))))
(ert-deftest viper-test-fix ()
"Test that the viper kmacro fixture is working."
diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el
index 741574f0adf..1384221c491 100644
--- a/test/lisp/epg-tests.el
+++ b/test/lisp/epg-tests.el
@@ -58,48 +58,45 @@
(cl-defmacro with-epg-tests ((&optional &key require-passphrase
require-public-key
require-secret-key)
- &rest body)
+ &rest body)
"Set up temporary locations and variables for testing."
(declare (indent 1) (debug (sexp body)))
- `(let* ((epg-tests-home-directory (make-temp-file "epg-tests-homedir" t))
- (process-environment
- (append
- (list "GPG_AGENT_INFO"
- (format "GNUPGHOME=%s" epg-tests-home-directory))
- process-environment)))
- (unwind-protect
- ;; GNUPGHOME is needed to find a usable gpg, so we can't
- ;; check whether to skip any earlier (Bug#23561).
- (let ((epg-config (or (epg-tests-find-usable-gpg-configuration
- ,require-passphrase ,require-public-key)
- (ert-skip "No usable gpg config")))
- (context (epg-make-context 'OpenPGP)))
- (setf (epg-context-program context)
- (alist-get 'program epg-config))
- (setf (epg-context-home-directory context)
- epg-tests-home-directory)
- ,(if require-passphrase
- '(with-temp-file (expand-file-name
- "gpg-agent.conf" epg-tests-home-directory)
- (insert "pinentry-program "
- (ert-resource-file "dummy-pinentry")
- "\n")
- (epg-context-set-passphrase-callback
- context
- #'epg-tests-passphrase-callback)))
- ,(if require-public-key
- '(epg-import-keys-from-file
- context
- (ert-resource-file "pubkey.asc")))
- ,(if require-secret-key
- '(epg-import-keys-from-file
- context
- (ert-resource-file "seckey.asc")))
- (with-temp-buffer
- (setq-local epg-tests-context context)
- ,@body))
- (when (file-directory-p epg-tests-home-directory)
- (delete-directory epg-tests-home-directory t)))))
+ `(ert-with-temp-directory epg-tests-home-directory
+ (let* ((process-environment
+ (append
+ (list "GPG_AGENT_INFO"
+ (format "GNUPGHOME=%s" epg-tests-home-directory))
+ process-environment)))
+ ;; GNUPGHOME is needed to find a usable gpg, so we can't
+ ;; check whether to skip any earlier (Bug#23561).
+ (let ((epg-config (or (epg-tests-find-usable-gpg-configuration
+ ,require-passphrase ,require-public-key)
+ (ert-skip "No usable gpg config")))
+ (context (epg-make-context 'OpenPGP)))
+ (setf (epg-context-program context)
+ (alist-get 'program epg-config))
+ (setf (epg-context-home-directory context)
+ epg-tests-home-directory)
+ ,(if require-passphrase
+ '(with-temp-file (expand-file-name
+ "gpg-agent.conf" epg-tests-home-directory)
+ (insert "pinentry-program "
+ (ert-resource-file "dummy-pinentry")
+ "\n")
+ (epg-context-set-passphrase-callback
+ context
+ #'epg-tests-passphrase-callback)))
+ ,(if require-public-key
+ '(epg-import-keys-from-file
+ context
+ (ert-resource-file "pubkey.asc")))
+ ,(if require-secret-key
+ '(epg-import-keys-from-file
+ context
+ (ert-resource-file "seckey.asc")))
+ (with-temp-buffer
+ (setq-local epg-tests-context context)
+ ,@body)))))
(ert-deftest epg-decrypt-1 ()
:expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index 6ed26f68289..b2dbc1012de 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -228,4 +228,75 @@
(kill-buffer "*erc-protocol*")
(should-not erc-debug-irc-protocol)))
+
+;; 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"))
+ calls)
+ (with-temp-buffer
+ (cl-letf (((symbol-function 'erc-cmd-MSG)
+ (lambda (line)
+ (push line calls)
+ (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))
+
+ (ert-info ("Dispatch to user command handler")
+
+ (ert-info ("Baseline")
+ (erc-process-input-line "/msg #chan hi\n")
+ (should (equal (pop calls) " #chan hi"))
+ (should (equal (pop erc-server-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)
+ '("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)
+ '("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)
+ '("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)
+ '("PRIVMSG #chan :\r\n" . utf-8)))))
+
+ (ert-info ("Implicit cmd via `erc-send-input-line-function'")
+
+ (ert-info ("Baseline")
+ (erc-process-input-line "hi")
+ (should (equal (pop erc-server-flood-queue)
+ '("PRIVMSG #chan :hi\r\n" . utf-8))))
+
+ (ert-info ("Spaces preserved")
+ (erc-process-input-line "hi you")
+ (should (equal (pop erc-server-flood-queue)
+ '("PRIVMSG #chan :hi you\r\n" . utf-8))))
+
+ (ert-info ("Empty line transmitted without injected-space kludge")
+ (erc-process-input-line "")
+ (should (equal (pop erc-server-flood-queue)
+ '("PRIVMSG #chan :\r\n" . utf-8))))
+
+ (should-not calls))))))
+
;;; erc-tests.el ends here
diff --git a/test/lisp/eshell/em-hist-tests.el b/test/lisp/eshell/em-hist-tests.el
index 31967a61c3c..5bc5690675d 100644
--- a/test/lisp/eshell/em-hist-tests.el
+++ b/test/lisp/eshell/em-hist-tests.el
@@ -20,19 +20,18 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'em-hist)
(ert-deftest eshell-write-readonly-history ()
"Test that having read-only strings in history is okay."
- (let ((histfile (make-temp-file "eshell-history"))
- (eshell-history-ring (make-ring 2)))
- (ring-insert eshell-history-ring
- (propertize "echo foo" 'read-only t))
- (ring-insert eshell-history-ring
- (propertize "echo bar" 'read-only t))
- (unwind-protect
- (eshell-write-history histfile)
- (delete-file histfile))))
+ (ert-with-temp-file histfile
+ (let ((eshell-history-ring (make-ring 2)))
+ (ring-insert eshell-history-ring
+ (propertize "echo foo" 'read-only t))
+ (ring-insert eshell-history-ring
+ (propertize "echo bar" 'read-only t))
+ (eshell-write-history histfile))))
(provide 'em-hist-test)
diff --git a/test/lisp/eshell/em-ls-tests.el b/test/lisp/eshell/em-ls-tests.el
index 5d1742b76fd..3ea11ab2de1 100644
--- a/test/lisp/eshell/em-ls-tests.el
+++ b/test/lisp/eshell/em-ls-tests.el
@@ -25,30 +25,30 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'em-ls)
(require 'dired)
(ert-deftest em-ls-test-bug27631 ()
"Test for https://debbugs.gnu.org/27631 ."
- (let* ((dir (make-temp-file "bug27631" 'dir))
- (dir1 (expand-file-name "dir1" dir))
- (dir2 (expand-file-name "dir2" dir))
- (default-directory dir)
- (orig eshell-ls-use-in-dired)
- buf)
- (unwind-protect
- (progn
- (customize-set-value 'eshell-ls-use-in-dired t)
- (make-directory dir1)
- (make-directory dir2)
- (with-temp-file (expand-file-name "a.txt" dir1))
- (with-temp-file (expand-file-name "b.txt" dir2))
- (setq buf (dired (expand-file-name "dir*/*.txt" dir)))
- (dired-toggle-marks)
- (should (cdr (dired-get-marked-files))))
- (customize-set-variable 'eshell-ls-use-in-dired orig)
- (delete-directory dir 'recursive)
- (when (buffer-live-p buf) (kill-buffer buf)))))
+ (ert-with-temp-directory dir
+ (let* ((dir1 (expand-file-name "dir1" dir))
+ (dir2 (expand-file-name "dir2" dir))
+ (default-directory dir)
+ (orig eshell-ls-use-in-dired)
+ buf)
+ (unwind-protect
+ (progn
+ (customize-set-value 'eshell-ls-use-in-dired t)
+ (make-directory dir1)
+ (make-directory dir2)
+ (with-temp-file (expand-file-name "a.txt" dir1))
+ (with-temp-file (expand-file-name "b.txt" dir2))
+ (setq buf (dired (expand-file-name "dir*/*.txt" dir)))
+ (dired-toggle-marks)
+ (should (cdr (dired-get-marked-files))))
+ (customize-set-variable 'eshell-ls-use-in-dired orig)
+ (when (buffer-live-p buf) (kill-buffer buf))))))
(ert-deftest em-ls-test-bug27817 ()
"Test for https://debbugs.gnu.org/27817 ."
diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el
index a460f45bf13..0974784ef4c 100644
--- a/test/lisp/eshell/eshell-tests.el
+++ b/test/lisp/eshell/eshell-tests.el
@@ -26,23 +26,23 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'esh-mode)
(require 'eshell)
(defmacro with-temp-eshell (&rest body)
"Evaluate BODY in a temporary Eshell buffer."
- `(let* ((eshell-directory-name (make-temp-file "eshell" t))
- ;; We want no history file, so prevent Eshell from falling
- ;; back on $HISTFILE.
- (process-environment (cons "HISTFILE" process-environment))
- (eshell-history-file-name nil)
- (eshell-buffer (eshell t)))
- (unwind-protect
- (with-current-buffer eshell-buffer
- ,@body)
- (let (kill-buffer-query-functions)
- (kill-buffer eshell-buffer)
- (delete-directory eshell-directory-name t)))))
+ `(ert-with-temp-directory eshell-directory-name
+ (let* (;; We want no history file, so prevent Eshell from falling
+ ;; back on $HISTFILE.
+ (process-environment (cons "HISTFILE" process-environment))
+ (eshell-history-file-name nil)
+ (eshell-buffer (eshell t)))
+ (unwind-protect
+ (with-current-buffer eshell-buffer
+ ,@body)
+ (let (kill-buffer-query-functions)
+ (kill-buffer eshell-buffer))))))
(defun eshell-insert-command (text &optional func)
"Insert a command at the end of the buffer."
@@ -65,11 +65,9 @@
(defun eshell-test-command-result (command)
"Like `eshell-command-result', but not using HOME."
- (let ((eshell-directory-name (make-temp-file "eshell" t))
- (eshell-history-file-name nil))
- (unwind-protect
- (eshell-command-result command)
- (delete-directory eshell-directory-name t))))
+ (ert-with-temp-directory eshell-directory-name
+ (let ((eshell-history-file-name nil))
+ (eshell-command-result command))))
;;; Tests:
diff --git a/test/lisp/ffap-tests.el b/test/lisp/ffap-tests.el
index f8113bffc1a..df5c264baad 100644
--- a/test/lisp/ffap-tests.el
+++ b/test/lisp/ffap-tests.el
@@ -25,30 +25,29 @@
(require 'cl-lib)
(require 'ert)
+(require 'ert-x)
(require 'ffap)
(ert-deftest ffap-tests-25243 ()
"Test for https://debbugs.gnu.org/25243 ."
- (let ((file (make-temp-file "test-Bug#25243")))
- (unwind-protect
- (with-temp-file file
- (let ((str "diff --git b/lisp/ffap.el a/lisp/ffap.el
+ (ert-with-temp-file file
+ :suffix "-bug25243"
+ (let ((str "diff --git b/lisp/ffap.el a/lisp/ffap.el
index 3d7cebadcf..ad4b70d737 100644
--- b/lisp/ffap.el
+++ a/lisp/ffap.el
@@ -203,6 +203,9 @@ ffap-foo-at-bar-prefix
"))
- (transient-mark-mode 1)
- (when (natnump ffap-max-region-length)
- (insert
- (concat
- str
- (make-string ffap-max-region-length #xa)
- (format "%s ENDS HERE" file)))
- (call-interactively 'mark-whole-buffer)
- (should (equal "" (ffap-string-at-point)))
- (should (equal '(1 1) ffap-string-at-point-region)))))
- (and (file-exists-p file) (delete-file file)))))
+ (transient-mark-mode 1)
+ (when (natnump ffap-max-region-length)
+ (insert
+ (concat
+ str
+ (make-string ffap-max-region-length #xa)
+ (format "%s ENDS HERE" file)))
+ (call-interactively 'mark-whole-buffer)
+ (should (equal "" (ffap-string-at-point)))
+ (should (equal '(1 1) ffap-string-at-point-region))))))
(ert-deftest ffap-gopher-at-point ()
(with-temp-buffer
@@ -133,7 +132,7 @@ left alone when opening a URL in an external browser."
;; Macros in BODY are expanded when the test is defined, not when it
;; is run. If a macro (possibly with side effects) is to be tested,
;; it has to be wrapped in `(eval (quote ...))'.
- (eval (quote (ido-everywhere)))
+ (eval (quote (ido-everywhere)) t)
(let ((read-file-name-function (lambda (&rest args)
(expand-file-name
(nth 4 args)
diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el
index 9be515ab176..0fe72f278dc 100644
--- a/test/lisp/filenotify-tests.el
+++ b/test/lisp/filenotify-tests.el
@@ -162,9 +162,7 @@ Return nil when any other file notification watch is still active."
(defun file-notify--test-cleanup ()
"Cleanup after a test."
- (file-notify-rm-watch file-notify--test-desc)
- (file-notify-rm-watch file-notify--test-desc1)
- (file-notify-rm-watch file-notify--test-desc2)
+ (file-notify-rm-all-watches)
(ignore-errors
(delete-file (file-newest-backup file-notify--test-tmpfile)))
@@ -421,7 +419,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
;; This test is inspired by Bug#26126 and Bug#26127.
(ert-deftest file-notify-test02-rm-watch ()
- "Check `file-notify-rm-watch'."
+ "Check `file-notify-rm-watch' and `file-notify-rm-all-watches'."
(skip-unless (file-notify--test-local-enabled))
(unwind-protect
@@ -517,6 +515,31 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(file-notify--test-cleanup-p))))
;; Cleanup.
+ (file-notify--test-cleanup))
+
+ (unwind-protect
+ ;; Check `file-notify-rm-all-watches'.
+ (progn
+ (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
+ file-notify--test-tmpfile1 (file-notify--test-make-temp-name))
+ (write-region "any text" nil file-notify--test-tmpfile nil 'no-message)
+ (write-region "any text" nil file-notify--test-tmpfile1 nil 'no-message)
+ (should
+ (setq file-notify--test-desc
+ (file-notify-add-watch
+ file-notify--test-tmpfile '(change) #'ignore)))
+ (should
+ (setq file-notify--test-desc1
+ (file-notify-add-watch
+ file-notify--test-tmpfile1 '(change) #'ignore)))
+ (file-notify-rm-all-watches)
+ (delete-file file-notify--test-tmpfile)
+ (delete-file file-notify--test-tmpfile1)
+
+ ;; The environment shall be cleaned up.
+ (file-notify--test-cleanup-p))
+
+ ;; Cleanup.
(file-notify--test-cleanup)))
(file-notify--deftest-remote file-notify-test02-rm-watch
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index 9547ac2b695..462048802f0 100644
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -136,7 +136,7 @@ form.")
;; Prevent any dir-locals file interfering with the tests.
(enable-dir-local-variables nil))
(hack-local-variables)
- (eval (nth 2 test-settings)))))
+ (eval (nth 2 test-settings) t))))
(ert-deftest files-tests-local-variables ()
"Test the file-local variables implementation."
@@ -176,15 +176,14 @@ form.")
;; If called interactively, environment variable
;; $EMACS_TEST_DIRECTORY does not exist.
(skip-unless (file-exists-p files-test-bug-18141-file))
- (let ((tempfile (make-temp-file "files-test-bug-18141" nil ".gz")))
- (unwind-protect
- (progn
- (copy-file files-test-bug-18141-file tempfile t)
- (with-current-buffer (find-file-noselect tempfile)
- (set-buffer-modified-p t)
- (save-buffer)
- (should (eq buffer-file-coding-system 'iso-2022-7bit-unix))))
- (delete-file tempfile))))
+ (ert-with-temp-file tempfile
+ :prefix "emacs-test-files-bug-18141"
+ :suffix ".gz"
+ (copy-file files-test-bug-18141-file tempfile t)
+ (with-current-buffer (find-file-noselect tempfile)
+ (set-buffer-modified-p t)
+ (save-buffer)
+ (should (eq buffer-file-coding-system 'iso-2022-7bit-unix)))))
(ert-deftest files-tests-make-temp-file-empty-prefix ()
"Test make-temp-file with an empty prefix."
@@ -283,22 +282,20 @@ If we are in a directory named `~', the default value should not
be $HOME."
(cl-letf (((symbol-function 'completing-read)
(lambda (_prompt _coll &optional _pred _req init _hist def _)
- (or def init)))
- (dir (make-temp-file "read-file-name-test" t)))
- (unwind-protect
- (let ((subdir (expand-file-name "./~/" dir)))
- (make-directory subdir t)
- (with-temp-buffer
- (setq default-directory subdir)
- (should-not (equal
- (expand-file-name (read-file-name "File: "))
- (expand-file-name "~/")))
- ;; Don't overquote either!
- (setq default-directory (concat "/:" subdir))
- (should-not (equal
- (expand-file-name (read-file-name "File: "))
- (concat "/:/:" subdir)))))
- (delete-directory dir 'recursive))))
+ (or def init))))
+ (ert-with-temp-directory dir
+ (let ((subdir (expand-file-name "./~/" dir)))
+ (make-directory subdir t)
+ (with-temp-buffer
+ (setq default-directory subdir)
+ (should-not (equal
+ (expand-file-name (read-file-name "File: "))
+ (expand-file-name "~/")))
+ ;; Don't overquote either!
+ (setq default-directory (concat "/:" subdir))
+ (should-not (equal
+ (expand-file-name (read-file-name "File: "))
+ (concat "/:/:" subdir))))))))
(ert-deftest files-tests-file-name-non-special-quote-unquote ()
(let (;; Just in case it is quoted, who knows.
@@ -341,14 +338,6 @@ be $HOME."
(progn ,@body)
(advice-remove #',symbol ,function)))))
-(defmacro files-tests--with-temp-file (name &rest body)
- (declare (indent 1) (debug (symbolp body)))
- (cl-check-type name symbol)
- `(let ((,name (make-temp-file "emacs")))
- (unwind-protect
- (progn ,@body)
- (delete-file ,name))))
-
(ert-deftest files-tests-file-name-non-special--buffers ()
"Check that Bug#25951 is fixed.
We call `verify-visited-file-modtime' on a buffer visiting a file
@@ -357,7 +346,7 @@ the buffer current and a nil argument, second passing the buffer
object explicitly. In both cases no error should be raised and
the `file-name-non-special' handler for quoted file names should
be invoked with the right arguments."
- (files-tests--with-temp-file temp-file-name
+ (ert-with-temp-file temp-file-name
(with-temp-buffer
(let* ((buffer-visiting-file (current-buffer))
(actual-args ())
@@ -476,6 +465,15 @@ unquoted file names."
(let (file-name-handler-alist)
(concat (file-name-sans-extension name) part (file-name-extension name t))))
+(ert-deftest files-tests-file-name-non-special-abbreviate-file-name ()
+ (let* ((homedir temporary-file-directory)
+ (process-environment (cons (format "HOME=%s" homedir)
+ process-environment))
+ (abbreviated-home-dir nil))
+ ;; Check that abbreviation doesn't occur for quoted file names.
+ (should (equal (concat "/:" homedir "foo/bar")
+ (abbreviate-file-name (concat "/:" homedir "foo/bar"))))))
+
(ert-deftest files-tests-file-name-non-special-access-file ()
(files-tests--with-temp-non-special (tmpfile nospecial)
;; Both versions of the file name work.
@@ -1239,26 +1237,26 @@ works as expected if the default directory is quoted."
(insert-directory-wildcard-in-dir-p (car path-res)))))))
(ert-deftest files-tests-make-directory ()
- (let* ((dir (make-temp-file "files-mkdir-test" t))
- (dirname (file-name-as-directory dir))
- (file (concat dirname "file"))
- (subdir1 (concat dirname "subdir1"))
- (subdir2 (concat dirname "subdir2"))
- (a/b (concat dirname "a/b")))
- (write-region "" nil file)
- (should-error (make-directory "/"))
- (should-not (make-directory "/" t))
- (should-error (make-directory dir))
- (should-not (make-directory dir t))
- (should-error (make-directory dirname))
- (should-not (make-directory dirname t))
- (should-error (make-directory file))
- (should-error (make-directory file t))
- (should-not (make-directory subdir1))
- (should-not (make-directory subdir2 t))
- (should-error (make-directory a/b))
- (should-not (make-directory a/b t))
- (delete-directory dir 'recursive)))
+ (ert-with-temp-directory dir
+ (let* ((dirname (file-name-as-directory dir))
+ (file (concat dirname "file"))
+ (subdir1 (concat dirname "subdir1"))
+ (subdir2 (concat dirname "subdir2"))
+ (a/b (concat dirname "a/b")))
+ (write-region "" nil file)
+ (should-error (make-directory "/"))
+ (should-not (make-directory "/" t))
+ (should-error (make-directory dir))
+ (should-not (make-directory dir t))
+ (should-error (make-directory dirname))
+ (should-not (make-directory dirname t))
+ (should-error (make-directory file))
+ (should-error (make-directory file t))
+ (should-not (make-directory subdir1))
+ (should-not (make-directory subdir2 t))
+ (should-error (make-directory a/b))
+ (should-not (make-directory a/b t))
+ (delete-directory dir 'recursive))))
(ert-deftest files-tests-file-modes-symbolic-to-number ()
(let ((alist (list (cons "a=rwx" #o777)
@@ -1318,7 +1316,7 @@ name (Bug#28412)."
(set-buffer-modified-p t)
(should-error (save-buffer) :type 'error))
;; Then a buffer visiting a file: should save normally.
- (files-tests--with-temp-file temp-file-name
+ (ert-with-temp-file temp-file-name
(with-current-buffer (find-file-noselect temp-file-name)
(setq write-contents-functions nil)
(insert "p")
@@ -1326,21 +1324,21 @@ name (Bug#28412)."
(should (eq (buffer-size) 1))))))
(ert-deftest files-tests-copy-directory ()
- (let* ((dir (make-temp-file "files-mkdir-test" t))
- (dirname (file-name-as-directory dir))
- (source (concat dirname "source"))
- (dest (concat dirname "dest/new/directory/"))
- (file (concat (file-name-as-directory source) "file"))
- (source2 (concat dirname "source2"))
- (dest2 (concat dirname "dest/new2")))
- (make-directory source)
- (write-region "" nil file)
- (copy-directory source dest t t t)
- (should (file-exists-p (concat dest "file")))
- (make-directory (concat (file-name-as-directory source2) "a") t)
- (copy-directory source2 dest2)
- (should (file-directory-p (concat (file-name-as-directory dest2) "a")))
- (delete-directory dir 'recursive)))
+ (ert-with-temp-directory dir
+ (let* ((dirname (file-name-as-directory dir))
+ (source (concat dirname "source"))
+ (dest (concat dirname "dest/new/directory/"))
+ (file (concat (file-name-as-directory source) "file"))
+ (source2 (concat dirname "source2"))
+ (dest2 (concat dirname "dest/new2")))
+ (make-directory source)
+ (write-region "" nil file)
+ (copy-directory source dest t t t)
+ (should (file-exists-p (concat dest "file")))
+ (make-directory (concat (file-name-as-directory source2) "a") t)
+ (copy-directory source2 dest2)
+ (should (file-directory-p (concat (file-name-as-directory dest2) "a")))
+ (delete-directory dir 'recursive))))
(ert-deftest files-tests-abbreviate-file-name-homedir ()
;; Check homedir abbreviation.
@@ -1392,43 +1390,40 @@ See <https://debbugs.gnu.org/19657#20>."
(ert-deftest files-tests-executable-find ()
"Test that `executable-find' works also with a relative or remote PATH.
See <https://debbugs.gnu.org/35241>."
- (let ((tmpfile (make-temp-file "files-test" nil (car exec-suffixes))))
- (unwind-protect
- (progn
- (set-file-modes tmpfile #o777)
- (let ((exec-path `(,temporary-file-directory)))
- (should
- (equal tmpfile
- (executable-find (file-name-nondirectory tmpfile)))))
- ;; An empty element of `exec-path' means `default-directory'.
- (let ((default-directory temporary-file-directory)
- (exec-path nil))
- (should
- (equal tmpfile
- (executable-find (file-name-nondirectory tmpfile)))))
- ;; The remote file name shall be quoted, and handled like a
- ;; non-existing directory.
- (let ((default-directory "/ssh::")
- (exec-path (append exec-path `("." ,temporary-file-directory))))
- (should
- (equal tmpfile
- (executable-find (file-name-nondirectory tmpfile))))))
- (delete-file tmpfile))))
+ (ert-with-temp-file tmpfile
+ :suffix (car exec-suffixes)
+ (set-file-modes tmpfile #o755)
+ (let ((exec-path `(,temporary-file-directory)))
+ (should
+ (equal tmpfile
+ (executable-find (file-name-nondirectory tmpfile)))))
+ ;; An empty element of `exec-path' means `default-directory'.
+ (let ((default-directory temporary-file-directory)
+ (exec-path nil))
+ (should
+ (equal tmpfile
+ (executable-find (file-name-nondirectory tmpfile)))))
+ ;; The remote file name shall be quoted, and handled like a
+ ;; non-existing directory.
+ (let ((default-directory "/ssh::")
+ (exec-path (append exec-path `("." ,temporary-file-directory))))
+ (should
+ (equal tmpfile
+ (executable-find (file-name-nondirectory tmpfile)))))))
(ert-deftest files-tests-dont-rewrite-precious-files ()
"Test that `file-precious-flag' forces files to be saved by
renaming only, rather than modified in-place."
- (let* ((temp-file-name (make-temp-file "files-tests"))
- (advice (lambda (_start _end filename &rest _r)
- (should-not (string= filename temp-file-name)))))
- (unwind-protect
- (with-current-buffer (find-file-noselect temp-file-name)
- (advice-add #'write-region :before advice)
- (setq-local file-precious-flag t)
- (insert "foobar")
- (should (null (save-buffer))))
- (ignore-errors (advice-remove #'write-region advice))
- (ignore-errors (delete-file temp-file-name)))))
+ (ert-with-temp-file temp-file-name
+ (let* ((advice (lambda (_start _end filename &rest _r)
+ (should-not (string= filename temp-file-name)))))
+ (unwind-protect
+ (with-current-buffer (find-file-noselect temp-file-name)
+ (advice-add #'write-region :before advice)
+ (setq-local file-precious-flag t)
+ (insert "foobar")
+ (should (null (save-buffer))))
+ (ignore-errors (advice-remove #'write-region advice))))))
(ert-deftest files-test-file-size-human-readable ()
(should (equal (file-size-human-readable 13) "13"))
@@ -1542,26 +1537,32 @@ The door of all subtleties!
(ert-deftest files-tests-revert-buffer ()
"Test that revert-buffer is successful."
- (files-tests--with-temp-file temp-file-name
+ (ert-with-temp-file temp-file-name
(with-temp-buffer
(insert files-tests-lao)
- (write-file temp-file-name)
- (erase-buffer)
- (insert files-tests-tzu)
- (revert-buffer t t t)
+ ;; Disable lock files, since that barfs in
+ ;; userlock--check-content-unchanged on MS-Windows.
+ (let (create-lockfiles)
+ (write-file temp-file-name)
+ (erase-buffer)
+ (insert files-tests-tzu)
+ (revert-buffer t t t))
(should (compare-strings files-tests-lao nil nil
(buffer-substring (point-min) (point-max))
nil nil)))))
(ert-deftest files-tests-revert-buffer-with-fine-grain ()
"Test that revert-buffer-with-fine-grain is successful."
- (files-tests--with-temp-file temp-file-name
+ (ert-with-temp-file temp-file-name
(with-temp-buffer
(insert files-tests-lao)
- (write-file temp-file-name)
- (erase-buffer)
- (insert files-tests-tzu)
- (should (revert-buffer-with-fine-grain t t))
+ ;; Disable lock files, since that barfs in
+ ;; userlock--check-content-unchanged on MS-Windows.
+ (let (create-lockfiles)
+ (write-file temp-file-name)
+ (erase-buffer)
+ (insert files-tests-tzu)
+ (should (revert-buffer-with-fine-grain t t)))
(should (compare-strings files-tests-lao nil nil
(buffer-substring (point-min) (point-max))
nil nil)))))
@@ -1584,6 +1585,14 @@ The door of all subtleties!
(should-error (file-name-with-extension "Jack" "."))
(should-error (file-name-with-extension "/is/a/directory/" "css")))
+(ert-deftest files-tests-file-name-base ()
+ (should (equal (file-name-base "") ""))
+ (should (equal (file-name-base "/foo/") ""))
+ (should (equal (file-name-base "/foo") "foo"))
+ (should (equal (file-name-base "/foo/bar") "bar"))
+ (should (equal (file-name-base "foo") "foo"))
+ (should (equal (file-name-base "foo/bar") "bar")))
+
(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"))
@@ -1611,40 +1620,39 @@ on BUF-1 and BUF-2 after the `save-some-buffers' call.
The test is repeated with `save-some-buffers-default-predicate'
let-bound to PRED and passing nil as second arg of
`save-some-buffers'."
- (let* ((dir (make-temp-file "testdir" 'dir))
- (file-1 (expand-file-name "subdir-1/file.foo" dir))
- (file-2 (expand-file-name "subdir-2/file.bar" dir))
- (inhibit-message t)
- buf-1 buf-2)
- (unwind-protect
- (progn
- (make-empty-file file-1 'parens)
- (make-empty-file file-2 'parens)
- (setq buf-1 (find-file file-1)
- buf-2 (find-file file-2))
- (dolist (buf (list buf-1 buf-2))
- (with-current-buffer buf (insert "foobar\n")))
- ;; Run the test.
- (with-current-buffer buf-1
- (let ((save-some-buffers-default-predicate def-pred-bind))
- (save-some-buffers t pred))
- (should (eq exp-1 (buffer-modified-p buf-1)))
- (should (eq exp-2 (buffer-modified-p buf-2))))
- ;; Set both buffers as modified to run another test.
- (dolist (buf (list buf-1 buf-2))
- (with-current-buffer buf (set-buffer-modified-p t)))
- ;; The result of this test must be identical as the previous one.
- (with-current-buffer buf-1
- (let ((save-some-buffers-default-predicate (or pred def-pred-bind)))
- (save-some-buffers t nil))
- (should (eq exp-1 (buffer-modified-p buf-1)))
- (should (eq exp-2 (buffer-modified-p buf-2)))))
- ;; Clean up.
- (dolist (buf (list buf-1 buf-2))
- (with-current-buffer buf
- (set-buffer-modified-p nil)
- (kill-buffer buf)))
- (delete-directory dir 'recursive))))
+ (ert-with-temp-directory dir
+ (let* ((file-1 (expand-file-name "subdir-1/file.foo" dir))
+ (file-2 (expand-file-name "subdir-2/file.bar" dir))
+ (inhibit-message t)
+ buf-1 buf-2)
+ (unwind-protect
+ (progn
+ (make-empty-file file-1 'parens)
+ (make-empty-file file-2 'parens)
+ (setq buf-1 (find-file file-1)
+ buf-2 (find-file file-2))
+ (dolist (buf (list buf-1 buf-2))
+ (with-current-buffer buf (insert "foobar\n")))
+ ;; Run the test.
+ (with-current-buffer buf-1
+ (let ((save-some-buffers-default-predicate def-pred-bind))
+ (save-some-buffers t pred))
+ (should (eq exp-1 (buffer-modified-p buf-1)))
+ (should (eq exp-2 (buffer-modified-p buf-2))))
+ ;; Set both buffers as modified to run another test.
+ (dolist (buf (list buf-1 buf-2))
+ (with-current-buffer buf (set-buffer-modified-p t)))
+ ;; The result of this test must be identical as the previous one.
+ (with-current-buffer buf-1
+ (let ((save-some-buffers-default-predicate (or pred def-pred-bind)))
+ (save-some-buffers t nil))
+ (should (eq exp-1 (buffer-modified-p buf-1)))
+ (should (eq exp-2 (buffer-modified-p buf-2)))))
+ ;; Clean up.
+ (dolist (buf (list buf-1 buf-2))
+ (with-current-buffer buf
+ (set-buffer-modified-p nil)
+ (kill-buffer buf)))))))
(ert-deftest files-tests-save-some-buffers ()
"Test `save-some-buffers'.
@@ -1807,6 +1815,12 @@ Prompt users for any modified buffer with `buffer-offer-save' non-nil."
;; `save-some-buffers-default-predicate' (i.e. the 2nd element) is ignored.
(nil save-some-buffers-root ,nb-might-save))))))
+(ert-deftest test-file-name-split ()
+ (should (equal (file-name-split "foo/bar") '("foo" "bar")))
+ (should (equal (file-name-split "/foo/bar") '("" "foo" "bar")))
+ (should (equal (file-name-split "/foo/bar/zot") '("" "foo" "bar" "zot")))
+ (should (equal (file-name-split "/foo/bar/") '("" "foo" "bar" "")))
+ (should (equal (file-name-split "foo/bar/") '("foo" "bar" ""))))
(provide 'files-tests)
;;; files-tests.el ends here
diff --git a/test/lisp/format-spec-tests.el b/test/lisp/format-spec-tests.el
index ff2abdeaad5..3c6fa540fe8 100644
--- a/test/lisp/format-spec-tests.el
+++ b/test/lisp/format-spec-tests.el
@@ -56,7 +56,7 @@
(ert-deftest format-spec-do-flags-truncate ()
"Test `format-spec--do-flags' truncation."
- (let (flags)
+ (let ((flags nil))
(should (equal (format-spec--do-flags "" flags nil 0) ""))
(should (equal (format-spec--do-flags "" flags nil 1) ""))
(should (equal (format-spec--do-flags "a" flags nil 0) ""))
@@ -75,7 +75,7 @@
(ert-deftest format-spec-do-flags-pad ()
"Test `format-spec--do-flags' padding."
- (let (flags)
+ (let ((flags nil))
(should (equal (format-spec--do-flags "" flags 0 nil) ""))
(should (equal (format-spec--do-flags "" flags 1 nil) " "))
(should (equal (format-spec--do-flags "a" flags 0 nil) "a"))
diff --git a/test/lisp/gnus/gnus-group-tests.el b/test/lisp/gnus/gnus-group-tests.el
new file mode 100644
index 00000000000..ee1e01be4b2
--- /dev/null
+++ b/test/lisp/gnus/gnus-group-tests.el
@@ -0,0 +1,52 @@
+;;; gnus-group-tests.el --- Tests for gnus-group.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 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 'gnus-group)
+(require 'ert)
+
+(ert-deftest gnus-short-group-name ()
+ (map-apply
+ (lambda (input expected)
+ (should (string-equal (gnus-short-group-name input) expected)))
+ '(("nnimap+email@example.com:archives/2020/03" . "email@example:a/2/03")
+ ("nndiary+diary:birthdays" . "diary:birthdays")
+ ("nnimap+email@example.com:test" . "email@example:test")
+ ("nnimap+email@example.com:234" . "email@example:234")
+
+ ;; This is a very aggressive shortening of the left hand side.
+ ("nnimap+email@banana.salesman.example.com:234" . "email@banana:234")
+ ("nntp+some.where.edu:soc.motss" . "some:s.motss")
+ ("nntp+news.gmane.org:gmane.emacs.gnus.general" . "news:g.e.g.general")
+ ("nntp+news.gnus.org:gmane.text.docbook.apps" . "news:g.t.d.apps")
+
+ ;; nnimap groups.
+ ("nnimap+email@example.com:[Invoices]/Bananas" . "email@example:I/Bananas")
+ ("nnimap+email@banana.salesman.example.com:[Invoices]/Bananas"
+ . "email@banana:I/Bananas")
+
+ ;; The "n" from "nnspool" is perhaps not optimal.
+ ("nnspool+alt.binaries.pictures.furniture" . "n.b.p.furniture"))))
+
+;;; gnus-group-tests.el ends here
diff --git a/test/lisp/gnus/gnus-icalendar-tests.el b/test/lisp/gnus/gnus-icalendar-tests.el
index 90c3a34a5c0..1206a976f6e 100644
--- a/test/lisp/gnus/gnus-icalendar-tests.el
+++ b/test/lisp/gnus/gnus-icalendar-tests.el
@@ -216,7 +216,7 @@ RRULE:FREQ=WEEKLY;BYDAY=FR,MO,TH,TU,WE
DTSTAMP:20200915T120627Z
ORGANIZER;CN=anon@anoncompany.com:mailto:anon@anoncompany.com
UID:7b6g3m7iftuo90ei4ul00feqn_R20200915T120000@google.com
-ATTENDEE;CUTYPE=INDIVIDUAL;ROLE=REQ-PARTICIPANT;PARTSTAT=ACCEPTED;RSVP=TRUE
+ATTENDEE;CUTYPE=INDIVIDUAL;PARTSTAT=ACCEPTED;RSVP=TRUE
;CN=participant@anoncompany.com;X-NUM-GUESTS=0:mailto:participant@anoncompany.com
CREATED:20200325T095723Z
DESCRIPTION:Coffee talk
diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el
index 513a0c2daea..24a42290a3f 100644
--- a/test/lisp/help-fns-tests.el
+++ b/test/lisp/help-fns-tests.el
@@ -148,7 +148,7 @@ Return first line of the output of (describe-function-1 FUNC)."
(ert-deftest help-fns-test-describe-keymap/value ()
(describe-keymap minibuffer-local-must-match-map)
(with-current-buffer "*Help*"
- (should (looking-at "^key"))))
+ (should (looking-at "\nKey"))))
(ert-deftest help-fns-test-describe-keymap/not-keymap ()
(should-error (describe-keymap nil))
@@ -158,7 +158,7 @@ Return first line of the output of (describe-function-1 FUNC)."
(let ((foobar minibuffer-local-must-match-map))
(describe-keymap foobar)
(with-current-buffer "*Help*"
- (should (looking-at "^key")))))
+ (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)
diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el
index 871417da3d2..281d97ee929 100644
--- a/test/lisp/help-tests.el
+++ b/test/lisp/help-tests.el
@@ -65,7 +65,7 @@
result))))
(test-re
(lambda (orig regexp)
- (should (string-match (concat "^" regexp "$")
+ (should (string-match (concat "\\`" regexp "\\'")
(substitute-command-keys orig))))))
,@body))
@@ -88,20 +88,37 @@
(test "\\[emacs-version]\\[next-line]" "M-x emacs-versionC-n")
(test-re "\\[emacs-version]`foo'" "M-x emacs-version[`'‘]foo['’]")))
-(ert-deftest help-tests-substitute-command-keys/keymaps ()
+(ert-deftest help-tests-substitute-command-keys/literal-key-sequence ()
+ "Literal replacement."
(with-substitute-command-keys-test
- (test "\\{minibuffer-local-must-match-map}"
- "\
-key binding
---- -------
+ (test "\\`C-m'" "C-m")
+ (test "\\`C-m'\\`C-j'" "C-mC-j")
+ (test "foo\\`C-m'bar\\`C-j'baz" "fooC-mbarC-jbaz")))
+
+(ert-deftest help-tests-substitute-command-keys/literal-key-sequence-errors ()
+ (should-error (substitute-command-keys "\\`'"))
+ (should-error (substitute-command-keys "\\`c-c'"))
+ (should-error (substitute-command-keys "\\`<foo bar baz>'")))
+
+(ert-deftest help-tests-substitute-key-bindings/face-help-key-binding ()
+ (should (eq (get-text-property 0 'face (substitute-command-keys "\\[next-line]"))
+ 'help-key-binding))
+ (should (eq (get-text-property 0 'face (substitute-command-keys "\\`f'"))
+ 'help-key-binding)))
+
+(ert-deftest help-tests-substitute-command-keys/keymaps ()
+ (with-substitute-command-keys-test
+ (test-re "\\{minibuffer-local-must-match-map}"
+ "
+Key Binding
+-+
C-g abort-minibuffers
TAB minibuffer-complete
C-j minibuffer-complete-and-exit
RET minibuffer-complete-and-exit
-ESC Prefix Command
SPC minibuffer-complete-word
-? minibuffer-completion-help
+\\? minibuffer-completion-help
C-<tab> file-cache-minibuffer-complete
<XF86Back> previous-history-element
<XF86Forward> next-history-element
@@ -110,11 +127,8 @@ C-<tab> file-cache-minibuffer-complete
<prior> switch-to-completions
<up> previous-line-or-history-element
-M-g Prefix Command
M-v switch-to-completions
-M-g ESC Prefix Command
-
M-< minibuffer-beginning-of-buffer
M-n next-history-element
M-p previous-history-element
@@ -122,7 +136,6 @@ M-r previous-matching-history-element
M-s next-matching-history-element
M-g M-c switch-to-completions
-
")))
(ert-deftest help-tests-substitute-command-keys/keymap-change ()
@@ -180,7 +193,7 @@ M-g M-c switch-to-completions
(let ((text-quoting-style 'grave))
(test "\\=`x\\='" "`x'"))))
-(ert-deftest help-tests-substitute-command-keys/no-change ()
+(ert-deftest help-tests-substitute-command-keys/no-change-2 ()
(with-substitute-command-keys-test
(test "\\[foobar" "\\[foobar")
(test "\\=" "\\=")))
@@ -249,11 +262,10 @@ M-g M-c switch-to-completions
(with-substitute-command-keys-test
(with-temp-buffer
(help-tests-major-mode)
- (test "\\{help-tests-major-mode-map}"
- "\
-key binding
---- -------
-
+ (test-re "\\{help-tests-major-mode-map}"
+ "
+Key Binding
+-+
( .. ) short-range
1 .. 4 foo-range
a .. c foo-other-range
@@ -261,7 +273,6 @@ a .. c foo-other-range
C-e foo-something
x foo-original
<F1> foo-function-key1
-
"))))
(ert-deftest help-tests-substitute-command-keys/shadow ()
@@ -269,11 +280,10 @@ x foo-original
(with-temp-buffer
(help-tests-major-mode)
(help-tests-minor-mode)
- (test "\\{help-tests-major-mode-map}"
- "\
-key binding
---- -------
-
+ (test-re "\\{help-tests-major-mode-map}"
+ "
+Key Binding
+-+
( .. ) short-range
1 .. 4 foo-range
a .. c foo-other-range
@@ -283,7 +293,6 @@ C-e foo-something
x foo-original
(this binding is currently shadowed)
<F1> foo-function-key1
-
"))))
(ert-deftest help-tests-substitute-command-keys/command-remap ()
@@ -292,15 +301,11 @@ x foo-original
(with-temp-buffer
(help-tests-major-mode)
(define-key help-tests-major-mode-map [remap foo] 'bar)
- (test "\\{help-tests-major-mode-map}"
- "\
-key binding
---- -------
-
-<remap> Prefix Command
-
+ (test-re "\\{help-tests-major-mode-map}"
+ "
+Key Binding
+-+
<remap> <foo> bar
-
")))))
(ert-deftest help-tests-describe-map-tree/no-menu-t ()
@@ -312,12 +317,11 @@ key binding
:enable mark-active
:help "Help text"))))))
(describe-map-tree map nil nil nil nil t nil nil nil)
- (should (equal (buffer-string) "key binding
---- -------
-
-C-a foo
-
-")))))
+ (should (string-match "
+Key Binding
+-+
+C-a foo\n"
+ (buffer-string))))))
(ert-deftest help-tests-describe-map-tree/no-menu-nil ()
(with-temp-buffer
@@ -328,15 +332,13 @@ C-a foo
:enable mark-active
:help "Help text"))))))
(describe-map-tree map nil nil nil nil nil nil nil nil)
- (should (equal (buffer-string) "key binding
---- -------
-
+ (should (string-match "
+Key Binding
+-+
C-a foo
-<menu-bar> Prefix Command
-<menu-bar> <foo> foo
-
-")))))
+<menu-bar> <foo> foo\n"
+ (buffer-string))))))
(ert-deftest help-tests-describe-map-tree/mention-shadow-t ()
(with-temp-buffer
@@ -345,14 +347,13 @@ C-a foo
(2 . bar))))
(shadow-maps '((keymap . ((1 . baz))))))
(describe-map-tree map t shadow-maps nil nil t nil nil t)
- (should (equal (buffer-string) "key binding
---- -------
-
+ (should (string-match "
+Key Binding
+-+
C-a foo
(this binding is currently shadowed)
-C-b bar
-
-")))))
+C-b bar\n"
+ (buffer-string))))))
(ert-deftest help-tests-describe-map-tree/mention-shadow-nil ()
(with-temp-buffer
@@ -361,12 +362,11 @@ C-b bar
(2 . bar))))
(shadow-maps '((keymap . ((1 . baz))))))
(describe-map-tree map t shadow-maps nil nil t nil nil nil)
- (should (equal (buffer-string) "key binding
---- -------
-
-C-b bar
-
-")))))
+ (should (string-match "
+Key Binding
+-+
+C-b bar\n"
+ (buffer-string))))))
(ert-deftest help-tests-describe-map-tree/partial-t ()
(with-temp-buffer
@@ -374,12 +374,11 @@ C-b bar
(map '(keymap . ((1 . foo)
(2 . undefined)))))
(describe-map-tree map t nil nil nil nil nil nil nil)
- (should (equal (buffer-string) "key binding
---- -------
-
-C-a foo
-
-")))))
+ (should (string-match "
+Key Binding
+-+
+C-a foo\n"
+ (buffer-string))))))
(ert-deftest help-tests-describe-map-tree/partial-nil ()
(with-temp-buffer
@@ -387,13 +386,12 @@ C-a foo
(map '(keymap . ((1 . foo)
(2 . undefined)))))
(describe-map-tree map nil nil nil nil nil nil nil nil)
- (should (equal (buffer-string) "key binding
---- -------
-
+ (should (string-match "
+Key Binding
+-+
C-a foo
-C-b undefined
-
-")))))
+C-b undefined\n"
+ (buffer-string))))))
(defvar help-tests--was-in-buffer nil)
diff --git a/test/lisp/image-dired-tests.el b/test/lisp/image-dired-tests.el
new file mode 100644
index 00000000000..3f0304ee405
--- /dev/null
+++ b/test/lisp/image-dired-tests.el
@@ -0,0 +1,37 @@
+;;; image-dired-tests.el --- Tests for image-dired.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021 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 'image-dired)
+
+(defun image-dired-test-image-file (name)
+ (expand-file-name
+ name (expand-file-name "data/image"
+ (or (getenv "EMACS_TEST_DIRECTORY")
+ "../"))))
+
+(ert-deftest image-dired-tests-get-exif-file-name ()
+ (skip-unless (image-type-available-p 'jpeg))
+ (let ((img (image-dired-test-image-file "black.jpg")))
+ (should (equal (image-dired-get-exif-file-name img)
+ "2019_09_21_16_22_13_black.jpg"))))
+
+;;; image-dired-tests.el ends here
diff --git a/test/lisp/image-tests.el b/test/lisp/image-tests.el
index aa8600609c4..79b0014f60a 100644
--- a/test/lisp/image-tests.el
+++ b/test/lisp/image-tests.el
@@ -28,6 +28,27 @@
(expand-file-name "images" data-directory)
"Directory containing Emacs images.")
+(defconst image-tests--files
+ `((gif . ,(expand-file-name "test/data/image/black.gif"
+ source-directory))
+ (jpeg . ,(expand-file-name "test/data/image/black.jpg"
+ source-directory))
+ (pbm . ,(expand-file-name "splash.pbm"
+ image-tests--emacs-images-directory))
+ (png . ,(expand-file-name "splash.png"
+ image-tests--emacs-images-directory))
+ (svg . ,(expand-file-name "splash.svg"
+ image-tests--emacs-images-directory))
+ (tiff . ,(expand-file-name
+ "nextstep/GNUstep/Emacs.base/Resources/emacs.tiff"
+ source-directory))
+ (webp . ,(expand-file-name "test/data/image/black.webp"
+ source-directory))
+ (xbm . ,(expand-file-name "gnus/gnus.xbm"
+ image-tests--emacs-images-directory))
+ (xpm . ,(expand-file-name "splash.xpm"
+ image-tests--emacs-images-directory))))
+
(ert-deftest image--set-property ()
"Test `image--set-property' behavior."
(let ((image (list 'image)))
@@ -49,12 +70,14 @@
(should (equal image '(image)))))
(ert-deftest image-find-image ()
- (find-image '((:type xpm :file "undo.xpm")))
- (find-image '((:type png :file "newsticker/rss-feed.png" :ascent center))))
+ (should (listp (find-image '((:type xpm :file "undo.xpm")))))
+ (should (listp (find-image '((:type png :file "newsticker/rss-feed.png" :ascent center)))))
+ (should-not (find-image '((:type png :file "does-not-exist-foo-bar.png")))))
(ert-deftest image-type-from-file-name ()
(should (eq (image-type-from-file-name "foo.jpg") 'jpeg))
- (should (eq (image-type-from-file-name "foo.png") 'png)))
+ (should (eq (image-type-from-file-name "foo.png") 'png))
+ (should (eq (image-type-from-file-name "foo.webp") 'webp)))
(ert-deftest image-type/from-filename ()
;; On emba, `image-types' and `image-load-path' do not exist.
@@ -62,12 +85,37 @@
(bound-and-true-p image-load-path)))
(should (eq (image-type "foo.jpg") 'jpeg)))
-(ert-deftest image-type-from-file-header-test ()
+(defun image-tests--type-from-file-header (type)
"Test image-type-from-file-header."
- (should (eq (if (image-type-available-p 'svg) 'svg)
- (image-type-from-file-header
- (expand-file-name "splash.svg"
- image-tests--emacs-images-directory)))))
+ (should (eq (if (image-type-available-p type) type)
+ (image-type-from-file-header (cdr (assq type image-tests--files))))))
+
+(ert-deftest image-type-from-file-header-test/gif ()
+ (image-tests--type-from-file-header 'gif))
+
+(ert-deftest image-type-from-file-header-test/jpeg ()
+ (image-tests--type-from-file-header 'jpeg))
+
+(ert-deftest image-type-from-file-header-test/pbm ()
+ (image-tests--type-from-file-header 'pbm))
+
+(ert-deftest image-type-from-file-header-test/png ()
+ (image-tests--type-from-file-header 'png))
+
+(ert-deftest image-type-from-file-header-test/svg ()
+ (image-tests--type-from-file-header 'svg))
+
+(ert-deftest image-type-from-file-header-test/tiff ()
+ (image-tests--type-from-file-header 'tiff))
+
+(ert-deftest image-type-from-file-header-test/webp ()
+ (image-tests--type-from-file-header 'webp))
+
+(ert-deftest image-type-from-file-header-test/xbm ()
+ (image-tests--type-from-file-header 'xbm))
+
+(ert-deftest image-type-from-file-header-test/xpm ()
+ (image-tests--type-from-file-header 'xpm))
(ert-deftest image-rotate ()
"Test `image-rotate'."
diff --git a/test/lisp/image/exif-tests.el b/test/lisp/image/exif-tests.el
index ddbee75467e..2357113f630 100644
--- a/test/lisp/image/exif-tests.el
+++ b/test/lisp/image/exif-tests.el
@@ -28,24 +28,19 @@
(or (getenv "EMACS_TEST_DIRECTORY")
"../../"))))
-(defun exif-elem (exif elem)
- (plist-get (seq-find (lambda (e)
- (eq elem (plist-get e :tag-name)))
- exif)
- :value))
-
(ert-deftest test-exif-parse ()
(let ((exif (exif-parse-file (test-image-file "black.jpg"))))
- (should (equal (exif-elem exif 'make) "Panasonic"))
- (should (equal (exif-elem exif 'orientation) 1))
- (should (equal (exif-elem exif 'x-resolution) '(180 . 1)))))
+ (should (equal (exif-field 'make exif) "Panasonic"))
+ (should (equal (exif-field 'orientation exif) 1))
+ (should (equal (exif-field 'x-resolution exif) '(180 . 1)))
+ (should (equal (exif-field 'date-time exif) "2019:09:21 16:22:13"))))
(ert-deftest test-exif-parse-short ()
(let ((exif (exif-parse-file (test-image-file "black-short.jpg"))))
- (should (equal (exif-elem exif 'make) "thr"))
- (should (equal (exif-elem exif 'model) "four"))
- (should (equal (exif-elem exif 'software) "em"))
- (should (equal (exif-elem exif 'artist) "z"))))
+ (should (equal (exif-field 'make exif) "thr"))
+ (should (equal (exif-field 'model exif) "four"))
+ (should (equal (exif-field 'software exif) "em"))
+ (should (equal (exif-field 'artist exif) "z"))))
(ert-deftest test-exit-direct-ascii-value ()
(should (equal (exif--direct-ascii-value 28005 2 t) (string ?e ?m 0)))
diff --git a/test/lisp/info-tests.el b/test/lisp/info-tests.el
new file mode 100644
index 00000000000..3e2aa3e089d
--- /dev/null
+++ b/test/lisp/info-tests.el
@@ -0,0 +1,39 @@
+;;; info-tests.el --- Tests for info.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 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 'info)
+(require 'ert)
+(require 'ert-x)
+
+(ert-deftest test-info-urls ()
+ (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")))
+
+;;; info-tests.el ends here
diff --git a/test/lisp/info-xref-tests.el b/test/lisp/info-xref-tests.el
index 0b8091f17af..9379a53fe1d 100644
--- a/test/lisp/info-xref-tests.el
+++ b/test/lisp/info-xref-tests.el
@@ -22,6 +22,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'info-xref)
(defun info-xref-test-internal (body result)
@@ -96,15 +97,17 @@ text.
(ert-deftest info-xref-test-makeinfo ()
"Test that info-xref can parse basic makeinfo output."
(skip-unless (executable-find "makeinfo"))
- (let ((tempfile (make-temp-file "info-xref-test" nil ".texi"))
- (tempfile2 (make-temp-file "info-xref-test2" nil ".texi"))
- (errflag t))
- (unwind-protect
- (progn
- ;; tempfile contains xrefs to various things, including tempfile2.
- (info-xref-test-write-file
- tempfile
- (concat "\
+ (ert-with-temp-file tempfile
+ :suffix ".texi"
+ (ert-with-temp-file tempfile2
+ :suffix ".texi"
+ (let ((errflag t))
+ (unwind-protect
+ (progn
+ ;; tempfile contains xrefs to various things, including tempfile2.
+ (info-xref-test-write-file
+ tempfile
+ (concat "\
@xref{nodename,,,missing,Missing Manual}.
@xref{nodename,crossref,title,missing,Missing Manual}.
@@ -114,35 +117,36 @@ text.
@xref{Chapter One,Something}.
"
- (format "@xref{Chapter One,,,%s,Present Manual}.\n"
- (file-name-sans-extension (file-name-nondirectory
- tempfile2)))))
- ;; Something for tempfile to xref to.
- (info-xref-test-write-file tempfile2 "")
- (require 'info)
- (save-window-excursion
- (let ((Info-directory-list
- (list
- (or (file-name-directory tempfile) ".")))
- Info-additional-directory-list)
- (info-xref-check (format "%s.info" (file-name-sans-extension
- tempfile))))
- (should (equal (list info-xref-bad info-xref-good
- info-xref-unavail)
- '(0 1 2)))
- (setq errflag nil)
- ;; If there was an error, we can leave this around.
- (kill-buffer info-xref-output-buffer)))
- ;; Useful diagnostic in case of problems.
- (if errflag
- (with-temp-buffer
- (call-process "makeinfo" nil t nil "--version")
- (message "%s" (buffer-string))))
- (mapc 'delete-file (list tempfile tempfile2
- (format "%s.info" (file-name-sans-extension
- tempfile))
- (format "%s.info" (file-name-sans-extension
- tempfile2)))))))
+ (format "@xref{Chapter One,,,%s,Present Manual}.\n"
+ (file-name-sans-extension (file-name-nondirectory
+ tempfile2)))))
+ ;; Something for tempfile to xref to.
+ (info-xref-test-write-file tempfile2 "")
+ (require 'info)
+ (save-window-excursion
+ (let ((Info-directory-list
+ (list
+ (or (file-name-directory tempfile) ".")))
+ Info-additional-directory-list)
+ (info-xref-check (format "%s.info" (file-name-sans-extension
+ tempfile))))
+ (should (equal (list info-xref-bad info-xref-good
+ info-xref-unavail)
+ '(0 1 2)))
+ (setq errflag nil)
+ ;; If there was an error, we can leave this around.
+ (kill-buffer info-xref-output-buffer)))
+ ;; Useful diagnostic in case of problems.
+ (if errflag
+ (with-temp-buffer
+ (call-process "makeinfo" nil t nil "--version")
+ (message "%s" (buffer-string))))
+ (ignore-errors
+ (delete-file (format "%s.info" (file-name-sans-extension
+ tempfile))))
+ (ignore-errors
+ (delete-file (format "%s.info" (file-name-sans-extension
+ tempfile2)))))))))
(ert-deftest info-xref-test-emacs-manuals ()
"Test that all internal links in the Emacs manuals work."
diff --git a/test/lisp/ls-lisp-tests.el b/test/lisp/ls-lisp-tests.el
index e386398eea2..9f2c63225b5 100644
--- a/test/lisp/ls-lisp-tests.el
+++ b/test/lisp/ls-lisp-tests.el
@@ -25,6 +25,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'ls-lisp)
(require 'dired)
@@ -53,28 +54,29 @@
(kill-buffer buf)
(setq buf (dired (nconc (list dir) files)))
(should (looking-at "src"))
- (next-line) ; File names must be aligned.
+ (with-suppressed-warnings ((interactive-only next-line))
+ (next-line)) ; File names must be aligned.
(should (looking-at "src")))
(when (buffer-live-p buf) (kill-buffer buf)))))
(ert-deftest ls-lisp-test-bug27631 ()
"Test for https://debbugs.gnu.org/27631 ."
- (let* ((dir (make-temp-file "bug27631" 'dir))
- (dir1 (expand-file-name "dir1" dir))
- (dir2 (expand-file-name "dir2" dir))
- (default-directory dir)
- ls-lisp-use-insert-directory-program buf)
- (unwind-protect
- (progn
- (make-directory dir1)
- (make-directory dir2)
- (with-temp-file (expand-file-name "a.txt" dir1))
- (with-temp-file (expand-file-name "b.txt" dir2))
- (setq buf (dired (expand-file-name "dir*/*.txt" dir)))
- (dired-toggle-marks)
- (should (cdr (dired-get-marked-files))))
- (delete-directory dir 'recursive)
- (when (buffer-live-p buf) (kill-buffer buf)))))
+ (ert-with-temp-directory dir
+ :suffix "bug27631"
+ (let* ((dir1 (expand-file-name "dir1" dir))
+ (dir2 (expand-file-name "dir2" dir))
+ (default-directory dir)
+ ls-lisp-use-insert-directory-program buf)
+ (unwind-protect
+ (progn
+ (make-directory dir1)
+ (make-directory dir2)
+ (with-temp-file (expand-file-name "a.txt" dir1))
+ (with-temp-file (expand-file-name "b.txt" dir2))
+ (setq buf (dired (expand-file-name "dir*/*.txt" dir)))
+ (dired-toggle-marks)
+ (should (cdr (dired-get-marked-files))))
+ (when (buffer-live-p buf) (kill-buffer buf))))))
(ert-deftest ls-lisp-test-bug27693 ()
"Test for https://debbugs.gnu.org/27693 ."
diff --git a/test/lisp/mail/mail-utils-tests.el b/test/lisp/mail/mail-utils-tests.el
index 5b54f2440c7..f75de5c620c 100644
--- a/test/lisp/mail/mail-utils-tests.el
+++ b/test/lisp/mail/mail-utils-tests.el
@@ -85,7 +85,8 @@
"foo@example.org\\|bar@example.org\\|baz@example.org")))
(ert-deftest mail-utils-tests-mail-rfc822-time-zone ()
- (should (stringp (mail-rfc822-time-zone (current-time)))))
+ (with-suppressed-warnings ((obsolete mail-rfc822-time-zone))
+ (should (stringp (mail-rfc822-time-zone (current-time))))))
(ert-deftest mail-utils-test-mail-rfc822-date/contains-year ()
(should (string-match (rx " 20" digit digit " ")
diff --git a/test/lisp/mail/uudecode-tests.el b/test/lisp/mail/uudecode-tests.el
index 981ce1c4ae0..1899ff50f69 100644
--- a/test/lisp/mail/uudecode-tests.el
+++ b/test/lisp/mail/uudecode-tests.el
@@ -50,14 +50,11 @@ Same as `uudecode-tests-encoded-str' but plain text.")
(should (equal (buffer-string) uudecode-tests-decoded-str)))
;; Write to file
(with-temp-buffer
- (let ((tmpfile (make-temp-file "uudecode-tests-")))
- (unwind-protect
- (progn
- (insert uudecode-tests-encoded-str)
- (uudecode-decode-region-internal (point-min) (point-max) tmpfile)
- (should (equal (uudecode-tests-read-file tmpfile)
- uudecode-tests-decoded-str)))
- (delete-file tmpfile)))))
+ (ert-with-temp-file tmpfile
+ (insert uudecode-tests-encoded-str)
+ (uudecode-decode-region-internal (point-min) (point-max) tmpfile)
+ (should (equal (uudecode-tests-read-file tmpfile)
+ uudecode-tests-decoded-str)))))
(ert-deftest uudecode-tests-decode-region-external ()
;; Write to buffer
@@ -68,14 +65,11 @@ Same as `uudecode-tests-encoded-str' but plain text.")
(should (equal (buffer-string) uudecode-tests-decoded-str)))
;; Write to file
(with-temp-buffer
- (let ((tmpfile (make-temp-file "uudecode-tests-")))
- (unwind-protect
- (progn
- (insert uudecode-tests-encoded-str)
- (uudecode-decode-region-external (point-min) (point-max) tmpfile)
- (should (equal (uudecode-tests-read-file tmpfile)
- uudecode-tests-decoded-str)))
- (delete-file tmpfile))))))
+ (ert-with-temp-file tmpfile
+ (insert uudecode-tests-encoded-str)
+ (uudecode-decode-region-external (point-min) (point-max) tmpfile)
+ (should (equal (uudecode-tests-read-file tmpfile)
+ uudecode-tests-decoded-str))))))
(provide 'uudecode-tests)
;;; uudecode-tests.el ends here
diff --git a/test/lisp/mh-e/mh-thread-tests.el b/test/lisp/mh-e/mh-thread-tests.el
new file mode 100644
index 00000000000..4f09677e53f
--- /dev/null
+++ b/test/lisp/mh-e/mh-thread-tests.el
@@ -0,0 +1,131 @@
+;;; mh-thread-tests.el --- tests for mh-thread.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021 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 'mh-thread)
+(eval-when-compile (require 'cl-lib))
+
+(defun mh-thread-tests-before-from ()
+ "Generate the fields of a scan line up to where the 'From' field would start.
+The exact contents are not important, but the number of characters is."
+ (concat (make-string mh-cmd-note ?9)
+ (make-string mh-scan-cmd-note-width ?A)
+ (make-string mh-scan-destination-width ?t)
+ (make-string mh-scan-date-width ?/)
+ (make-string mh-scan-date-flag-width ?*)))
+
+;;; Tests of support routines
+
+(ert-deftest mh-thread-current-indentation-level ()
+ "Test that `mh-thread-current-indentation-level' identifies the level."
+ (with-temp-buffer
+ (insert (mh-thread-tests-before-from) "[Sender One] Subject of msg 1\n")
+ (insert (mh-thread-tests-before-from) " [Sender Two] Subject of msg 2\n")
+ (goto-char (point-min))
+ (should (equal 0 (mh-thread-current-indentation-level)))
+ (forward-line)
+ (should (equal 2 (mh-thread-current-indentation-level)))))
+
+(ert-deftest mh-thread-find-children ()
+ "Test `mh-thread-find-children'."
+ (let (expected-start expected-end)
+ (with-temp-buffer
+ (insert (mh-thread-tests-before-from) "[Sender One] line 1\n")
+ (setq expected-start (point))
+ (insert (mh-thread-tests-before-from) " [Sender Two] line 2\n")
+ (insert (mh-thread-tests-before-from) " [Sender Three] line 3\n")
+ (insert (mh-thread-tests-before-from) " [Sender Four] line 4\n")
+ (setq expected-end (1- (point)))
+ (insert (mh-thread-tests-before-from) " [Sender Five] line 5\n")
+ (goto-char (1+ expected-start))
+ (should (equal (list expected-start expected-end)
+ (mh-thread-find-children))))))
+
+(ert-deftest mh-thread-immediate-ancestor ()
+ "Test that `mh-thread-immediate-ancestor' moves to the correct message."
+ (with-temp-buffer
+ (insert (mh-thread-tests-before-from) "[Sender Other] line 1\n")
+ (insert (mh-thread-tests-before-from) "[Sender One] line 2\n")
+ (insert (mh-thread-tests-before-from) " [Sender Two] line 3\n")
+ (insert (mh-thread-tests-before-from) " [Sender Three] line 4\n")
+ (insert (mh-thread-tests-before-from) " [Sender Four] line 5\n")
+ (insert (mh-thread-tests-before-from) " [Sender Five] line 6\n")
+ (forward-line -1)
+ (should (equal (line-number-at-pos) 6))
+ (mh-thread-immediate-ancestor)
+ (should (equal (line-number-at-pos) 4)) ;skips over sibling
+ (mh-thread-immediate-ancestor)
+ (should (equal (line-number-at-pos) 3)) ;goes up only one level at a time
+ (mh-thread-immediate-ancestor)
+ (should (equal (line-number-at-pos) 2))
+ (mh-thread-immediate-ancestor)
+ (should (equal (line-number-at-pos) 2)))) ;no further motion at thread root
+
+;;; Tests of MH-Folder Commands
+
+(ert-deftest mh-thread-sibling-and-ancestor ()
+ "Test motion by `mh-thread-ancestor' and `mh-thread-next-sibling'."
+ (with-temp-buffer
+ (insert (mh-thread-tests-before-from) "[Sender Other] line 1\n")
+ (insert (mh-thread-tests-before-from) "[Sender One] line 2\n")
+ (insert (mh-thread-tests-before-from) " [Sender Two] line 3\n")
+ (insert (mh-thread-tests-before-from) " [Sender Three] line 4\n")
+ (insert (mh-thread-tests-before-from) " [Sender Four] line 5\n")
+ (insert (mh-thread-tests-before-from) " [Sender Five] line 6\n")
+ (forward-line -1)
+ (let ((mh-view-ops '(unthread))
+ (show-count 0))
+ (cl-letf (((symbol-function 'mh-maybe-show)
+ (lambda ()
+ (setq show-count (1+ show-count)))))
+ (should (equal (line-number-at-pos) 6))
+ ;; test mh-thread-ancestor
+ (mh-thread-ancestor)
+ (should (equal (line-number-at-pos) 4)) ;skips over sibling
+ (should (equal show-count 1))
+ (mh-thread-ancestor t)
+ (should (equal (line-number-at-pos) 2)) ;root flag skips to root
+ (should (equal show-count 2))
+ (mh-thread-ancestor)
+ (should (equal (line-number-at-pos) 2)) ;do not move from root
+ (should (equal show-count 2)) ;do not re-show at root
+ ;; test mh-thread-sibling
+ (mh-thread-next-sibling)
+ (should (equal (line-number-at-pos) 2)) ;no next sibling, no motion
+ (should (equal show-count 2)) ;no sibling, no show
+ (mh-thread-next-sibling t)
+ (should (equal (line-number-at-pos) 1))
+ (should (equal show-count 3))
+ (mh-thread-next-sibling t)
+ (should (equal (line-number-at-pos) 1)) ;no previous sibling
+ (should (equal show-count 3))
+ (goto-char (point-max))
+ (forward-line -1)
+ (should (equal (line-number-at-pos) 6))
+ (mh-thread-next-sibling t)
+ (should (equal (line-number-at-pos) 5))
+ (should (equal show-count 4))
+ (mh-thread-next-sibling t)
+ (should (equal (line-number-at-pos) 5)) ;no previous sibling
+ (should (equal show-count 4))
+ ))))
+
+;;; mh-thread-tests.el ends here
diff --git a/test/lisp/mh-e/mh-utils-tests.el b/test/lisp/mh-e/mh-utils-tests.el
index d9a26e58959..f282a0b08f3 100644
--- a/test/lisp/mh-e/mh-utils-tests.el
+++ b/test/lisp/mh-e/mh-utils-tests.el
@@ -80,6 +80,54 @@
(mh-normalize-folder-name "+inbox////../news/" nil t)))
(should (equal "+inbox/news" (mh-normalize-folder-name "+inbox////./news"))))
+(ert-deftest mh-sub-folders-parse-no-folder ()
+ "Test `mh-sub-folders-parse' with no starting folder."
+ (let (others-position)
+ (with-temp-buffer
+ (insert "lines without has-string are ignored\n")
+ (insert "onespace has no messages.\n")
+ (insert "twospace has no messages.\n")
+ (insert " precedingblanks has no messages.\n")
+ (insert ".leadingdot has no messages.\n")
+ (insert "#leadinghash has no messages.\n")
+ (insert ",leadingcomma has no messages.\n")
+ (insert "withothers has no messages ; (others)")
+ (setq others-position (point))
+ (insert ".\n")
+ (insert "curf has no messages.\n")
+ (insert "curf+ has 123 messages.\n")
+ (insert "curf2+ has 17 messages.\n")
+ (insert "\ntotal after blank line is ignored has no messages.\n")
+ (should (equal
+ (mh-sub-folders-parse nil "curf+")
+ (list '("onespace") '("twospace") '("precedingblanks")
+ (cons "withothers" others-position)
+ '("curf") '("curf") '("curf2+")))))))
+
+(ert-deftest mh-sub-folders-parse-relative-folder ()
+ "Test `mh-sub-folders-parse' with folder."
+ (let (others-position)
+ (with-temp-buffer
+ (insert "testf+ has no messages.\n")
+ (insert "testf/sub1 has no messages.\n")
+ (insert "testf/sub2 has no messages ; (others)")
+ (setq others-position (point))
+ (insert ".\n")
+ (should (equal
+ (mh-sub-folders-parse "+testf" "testf+")
+ (list '("sub1") (cons "sub2" others-position)))))))
+
+(ert-deftest mh-sub-folders-parse-root-folder ()
+ "Test `mh-sub-folders-parse' with root folder."
+ (with-temp-buffer
+ (insert "/+ has no messages.\n")
+ (insert "/ has no messages.\n")
+ (insert "//nmh-style has no messages.\n")
+ (insert "/mu-style has no messages.\n")
+ (should (equal
+ (mh-sub-folders-parse "+/" "inbox+")
+ '(("") ("nmh-style") ("mu-style"))))))
+
;; Folder names that are used by the following tests.
(defvar mh-test-rel-folder "rela-folder")
@@ -211,6 +259,10 @@ The tests use this method if no configured MH variant is found."
"/abso-folder/bar has no messages."
"/abso-folder/foo has no messages."
"/abso-folder/food has no messages."))
+ (("folders" "-noheader" "-norecurse" "-nototal" "+/") .
+ ("/+ has no messages ; (others)."
+ "/abso-folder has no messages ; (others)."
+ "/tmp has no messages ; (others)."))
))
(arglist (cons (file-name-base program) args)))
(let ((response-list-cons (assoc arglist argument-responses)))
@@ -303,6 +355,15 @@ if `mh-test-utils-debug-mocks' is non-nil."
(message "file-directory-p: %S -> %s" filename result))
result))
+(defun mh-test-variant-handles-plus-slash (variant)
+ "Returns non-nil if this MH variant handles \"folders +/\".
+Mailutils 3.5, 3.7, and 3.13 are known not to."
+ (cond ((not (stringp variant))) ;our mock handles it
+ ((string-search "GNU Mailutils" variant)
+ (let ((mu-version (string-remove-prefix "GNU Mailutils " variant)))
+ (version<= "3.13.91" mu-version)))
+ (t))) ;no other known failures
+
(ert-deftest mh-sub-folders-actual ()
"Test `mh-sub-folders-actual'."
@@ -310,14 +371,15 @@ if `mh-test-utils-debug-mocks' is non-nil."
;; already been normalized with
;; (mh-normalize-folder-name folder nil nil t)
(with-mh-test-env
- (should (equal
+ (should (member
mh-test-rel-folder
- (car (assoc mh-test-rel-folder (mh-sub-folders-actual nil)))))
+ (mapcar (lambda (x) (car x)) (mh-sub-folders-actual nil))))
;; Empty string and "+" not tested since mh-normalize-folder-name
;; would change them to nil.
- (should (equal "foo"
- (car (assoc "foo" (mh-sub-folders-actual
- (format "+%s" mh-test-rel-folder))))))
+ (should (member "foo"
+ (mapcar (lambda (x) (car x))
+ (mh-sub-folders-actual
+ (format "+%s" mh-test-rel-folder)))))
;; Folder with trailing slash not tested since
;; mh-normalize-folder-name would strip it.
(should (equal
@@ -328,6 +390,10 @@ if `mh-test-utils-debug-mocks' is non-nil."
(list (list "bar") (list "foo") (list "food"))
(mh-sub-folders-actual (format "+%s" mh-test-abs-folder))))
+ (when (mh-test-variant-handles-plus-slash mh-variant-in-use)
+ (should (member "tmp" (mapcar (lambda (x) (car x))
+ (mh-sub-folders-actual "+/")))))
+
;; FIXME: mh-sub-folders-actual doesn't (yet) expect to be given a
;; nonexistent folder.
;; (should (equal nil
@@ -339,13 +405,12 @@ if `mh-test-utils-debug-mocks' is non-nil."
(ert-deftest mh-sub-folders ()
"Test `mh-sub-folders'."
(with-mh-test-env
- (should (equal mh-test-rel-folder
- (car (assoc mh-test-rel-folder (mh-sub-folders nil)))))
- (should (equal mh-test-rel-folder
- (car (assoc mh-test-rel-folder (mh-sub-folders "")))))
- (should (equal nil
- (car (assoc mh-test-no-such-folder (mh-sub-folders
- "+")))))
+ (should (member mh-test-rel-folder
+ (mapcar (lambda (x) (car x)) (mh-sub-folders nil))))
+ (should (member mh-test-rel-folder
+ (mapcar (lambda (x) (car x)) (mh-sub-folders ""))))
+ (should-not (member mh-test-no-such-folder
+ (mapcar (lambda (x) (car x)) (mh-sub-folders "+"))))
(should (equal (list (list "bar") (list "foo") (list "food"))
(mh-sub-folders (format "+%s" mh-test-rel-folder))))
(should (equal (list (list "bar") (list "foo") (list "food"))
@@ -356,6 +421,9 @@ if `mh-test-utils-debug-mocks' is non-nil."
(mh-sub-folders (format "+%s/foo" mh-test-rel-folder))))
(should (equal (list (list "bar") (list "foo") (list "food"))
(mh-sub-folders (format "+%s" mh-test-abs-folder))))
+ (when (mh-test-variant-handles-plus-slash mh-variant-in-use)
+ (should (member "tmp"
+ (mapcar (lambda (x) (car x)) (mh-sub-folders "+/")))))
;; FIXME: mh-sub-folders doesn't (yet) expect to be given a
;; nonexistent folder.
@@ -437,18 +505,20 @@ and the `should' macro requires idempotent evaluation anyway."
(ert-deftest mh-folder-completion-function-08-plus-slash ()
"Test `mh-folder-completion-function' with `+/'."
- :expected-result :failed ;to be fixed in a patch by mkupfer
- (mh-test-folder-completion-1 "+/" "+/" "tmp/" nil)
- ;; case "bb"
- (with-mh-test-env
- (should (equal nil
- (member (format "+%s/" mh-test-rel-folder)
- (mh-folder-completion-function "+/" nil t))))))
+ (with-mh-test-env
+ (skip-unless (mh-test-variant-handles-plus-slash mh-variant-in-use)))
+ (mh-test-folder-completion-1 "+/" "+/" "tmp/" t)
+ ;; case "bb"
+ (with-mh-test-env
+ (should (equal nil
+ (member (format "+%s/" mh-test-rel-folder)
+ (mh-folder-completion-function "+/" nil t))))))
(ert-deftest mh-folder-completion-function-09-plus-slash-tmp ()
"Test `mh-folder-completion-function' with `+/tmp'."
- :expected-result :failed ;to be fixed in a patch by mkupfer
- (mh-test-folder-completion-1 "+/tmp" "+/tmp" "tmp/" t))
+ (with-mh-test-env
+ (skip-unless (mh-test-variant-handles-plus-slash mh-variant-in-use)))
+ (mh-test-folder-completion-1 "+/tmp" "+/tmp/" "tmp/" t))
(ert-deftest mh-folder-completion-function-10-plus-slash-abs-folder ()
"Test `mh-folder-completion-function' with `+/abso-folder'."
diff --git a/test/lisp/mh-e/test-all-mh-variants.sh b/test/lisp/mh-e/test-all-mh-variants.sh
index e917d8155bc..eaee98fcf4d 100755
--- a/test/lisp/mh-e/test-all-mh-variants.sh
+++ b/test/lisp/mh-e/test-all-mh-variants.sh
@@ -79,12 +79,10 @@ for path in "${mh_sys_path[@]}"; do
continue
fi
fi
- echo "Testing with PATH $path"
+ 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 \
- LD_LIBRARY_PATH=/usr/local/lib HOME=/nonexistent \
+ 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/net/browse-url-tests.el b/test/lisp/net/browse-url-tests.el
index 4264e03d912..68c7c349013 100644
--- a/test/lisp/net/browse-url-tests.el
+++ b/test/lisp/net/browse-url-tests.el
@@ -28,6 +28,7 @@
(require 'browse-url)
(require 'ert)
+(require 'ert-x)
(ert-deftest browse-url-tests-browser-kind ()
(should (eq (browse-url--browser-kind #'browse-url-w3 "gnu.org")
@@ -87,11 +88,10 @@
"ftp://foo/")))
(ert-deftest browse-url-tests-delete-temp-file ()
- (let ((browse-url-temp-file-name
- (make-temp-file "browse-url-tests-")))
+ (ert-with-temp-file browse-url-temp-file-name
(browse-url-delete-temp-file)
(should-not (file-exists-p browse-url-temp-file-name)))
- (let ((file (make-temp-file "browse-url-tests-")))
+ (ert-with-temp-file file
(browse-url-delete-temp-file file)
(should-not (file-exists-p file))))
diff --git a/test/lisp/net/netrc-tests.el b/test/lisp/net/netrc-tests.el
index f75328a59f7..2f68b9bbb24 100644
--- a/test/lisp/net/netrc-tests.el
+++ b/test/lisp/net/netrc-tests.el
@@ -48,7 +48,7 @@
(should (equal (netrc-credentials "ftp.example.org")
'("jrh" "*baz*")))))
-(ert-deftest test-netrc-credentials ()
+(ert-deftest test-netrc-credentials-2 ()
(let ((netrc-file (ert-resource-file "netrc-folding")))
(should
(equal (netrc-parse netrc-file)
diff --git a/test/lisp/net/ntlm-tests.el b/test/lisp/net/ntlm-tests.el
index 2420b3b48a9..7b89e6b0784 100644
--- a/test/lisp/net/ntlm-tests.el
+++ b/test/lisp/net/ntlm-tests.el
@@ -227,6 +227,8 @@ This string will be returned from the NTLM server to the NTLM client."
;; Silence some byte-compiler warnings that occur when
;; web-server/web-server.el is not found.
+(eval-when-compile (cl-pushnew 'headers eieio--known-slot-names)
+ (cl-pushnew 'process eieio--known-slot-names))
(declare-function ws-send nil)
(declare-function ws-parse-request nil)
(declare-function ws-start nil)
diff --git a/test/lisp/net/puny-tests.el b/test/lisp/net/puny-tests.el
index 28c0d49cbee..9119084209e 100644
--- a/test/lisp/net/puny-tests.el
+++ b/test/lisp/net/puny-tests.el
@@ -61,4 +61,11 @@
;; Only allowed in unrestricted.
(should-not (puny-highly-restrictive-domain-p "I♥NY.org")))
+(ert-deftest puny-normalize ()
+ (should (equal (puny-encode-string (string-glyph-compose "Bä.com"))
+ "xn--b.com-gra"))
+ (should (equal (puny-encode-string "Bä.com")
+ "xn--b.com-gra"))
+ (should (equal (puny-encode-string "Bä.com") "xn--b.com-gra")))
+
;;; puny-tests.el ends here
diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el
index 0a484ff9bd1..a307a40157f 100644
--- a/test/lisp/net/tramp-archive-tests.el
+++ b/test/lisp/net/tramp-archive-tests.el
@@ -122,12 +122,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-emacs26-p ()
- "Check for Emacs version >= 26.1.
-Some semantics has been changed for there, w/o new functions or
-variables, so we check the Emacs version directly."
- (>= emacs-major-version 26))
-
(defun tramp-archive--test-emacs27-p ()
"Check for Emacs version >= 27.1.
Some semantics has been changed for there, w/o new functions or
@@ -433,7 +427,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(setq tmp-name
(file-local-copy
(expand-file-name "what" tramp-archive-test-archive)))
- :type tramp-file-missing))
+ :type 'file-missing))
;; Cleanup.
(ignore-errors (tramp-archive--test-delete tmp-name))
@@ -461,7 +455,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(should-error
(insert-file-contents
(expand-file-name "what" tramp-archive-test-archive))
- :type tramp-file-missing))
+ :type 'file-missing))
;; Cleanup.
(tramp-archive-cleanup-hash))))
@@ -552,11 +546,9 @@ This checks also `file-name-as-directory', `file-name-directory',
(should (file-directory-p tmp-name2))
(should (file-exists-p tmp-name4))
;; Target directory does exist already.
- ;; This has been changed in Emacs 26.1.
- (when (tramp-archive--test-emacs26-p)
- (should-error
- (copy-directory tmp-name1 tmp-name2)
- :type 'file-error))
+ (should-error
+ (copy-directory tmp-name1 tmp-name2)
+ :type 'file-error)
(tramp-archive--test-delete tmp-name4)
(copy-directory tmp-name1 (file-name-as-directory tmp-name2))
(should (file-directory-p tmp-name3))
@@ -621,13 +613,11 @@ This checks also `file-name-as-directory', `file-name-directory',
(append '("LANG=C" "LANGUAGE=C" "LC_ALL=C") process-environment)))
(unwind-protect
(progn
- ;; Due to Bug#29423, this works only since for Emacs 26.1.
- (when nil ;; TODO (tramp-archive--test-emacs26-p)
- (with-temp-buffer
- (insert-directory tramp-archive-test-archive nil)
- (goto-char (point-min))
- (should
- (looking-at-p (regexp-quote tramp-archive-test-archive)))))
+ (with-temp-buffer
+ (insert-directory tramp-archive-test-archive nil)
+ (goto-char (point-min))
+ (should
+ (looking-at-p (regexp-quote tramp-archive-test-archive))))
(with-temp-buffer
(insert-directory tramp-archive-test-archive "-al")
(goto-char (point-min))
@@ -655,7 +645,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(should-error
(insert-directory
(expand-file-name "baz" tramp-archive-test-archive) nil)
- :type tramp-file-missing)))
+ :type 'file-missing)))
;; Cleanup.
(tramp-archive-cleanup-hash))))
@@ -715,7 +705,7 @@ This tests also `access-file', `file-readable-p' and `file-regular-p'."
;; Check error case.
(should-error
(access-file tmp-name4 "error")
- :type tramp-file-missing))
+ :type 'file-missing))
;; Cleanup.
(tramp-archive-cleanup-hash))))
@@ -854,38 +844,27 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
;; Cleanup.
(tramp-archive-cleanup-hash))))
-;; The functions were introduced in Emacs 26.1.
(ert-deftest tramp-archive-test40-make-nearby-temp-file ()
"Check `make-nearby-temp-file' and `temporary-file-directory'."
(skip-unless tramp-archive-enabled)
- ;; Since Emacs 26.1.
- (skip-unless
- (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory)))
- ;; `make-nearby-temp-file' and `temporary-file-directory' exists
- ;; since Emacs 26.1. We don't want to see compiler warnings for
- ;; older Emacsen.
(let ((default-directory tramp-archive-test-archive)
tmp-file)
;; The file archive shall know a temporary file directory. It is
;; not in the archive itself.
- (should
- (stringp (with-no-warnings (with-no-warnings (temporary-file-directory)))))
- (should-not
- (tramp-archive-file-name-p (with-no-warnings (temporary-file-directory))))
+ (should (stringp (temporary-file-directory)))
+ (should-not (tramp-archive-file-name-p (temporary-file-directory)))
;; A temporary file or directory shall not be located in the
;; archive itself.
- (setq tmp-file
- (with-no-warnings (make-nearby-temp-file "tramp-archive-test")))
+ (setq tmp-file (make-nearby-temp-file "tramp-archive-test"))
(should (file-exists-p tmp-file))
(should (file-regular-p tmp-file))
(should-not (tramp-archive-file-name-p tmp-file))
(delete-file tmp-file)
(should-not (file-exists-p tmp-file))
- (setq tmp-file
- (with-no-warnings (make-nearby-temp-file "tramp-archive-test" 'dir)))
+ (setq tmp-file (make-nearby-temp-file "tramp-archive-test" 'dir))
(should (file-exists-p tmp-file))
(should (file-directory-p tmp-file))
(should-not (tramp-archive-file-name-p tmp-file))
@@ -909,7 +888,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
(zerop (nth 1 fsi))
(zerop (nth 2 fsi))))))
-(ert-deftest tramp-archive-test45-auto-load ()
+(ert-deftest tramp-archive-test46-auto-load ()
"Check that `tramp-archive' autoloads properly."
:tags '(:expensive-test)
(skip-unless tramp-archive-enabled)
@@ -949,7 +928,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
(mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument (format code file))))))))))
-(ert-deftest tramp-archive-test45-delay-load ()
+(ert-deftest tramp-archive-test46-delay-load ()
"Check that `tramp-archive' is loaded lazily, only when needed."
:tags '(:expensive-test)
(skip-unless tramp-archive-enabled)
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 1fa8fbea172..9c65f9a6351 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -43,8 +43,10 @@
(require 'cl-lib)
(require 'dired)
+(require 'dired-aux)
(require 'ert)
(require 'ert-x)
+(require 'seq) ; For `seq-random-elt', autoloaded since Emacs 28.1
(require 'trace)
(require 'tramp)
(require 'vc)
@@ -74,11 +76,6 @@
(defvar tramp-remote-path)
(defvar tramp-remote-process-environment)
-;; Needed for Emacs 25.
-(defvar connection-local-criteria-alist)
-(defvar connection-local-profile-alist)
-;; Needed for Emacs 26.
-(defvar async-shell-command-width)
;; Needed for Emacs 27.
(defvar process-file-return-signal-string)
(defvar shell-command-dont-erase-buffer)
@@ -222,8 +219,7 @@ is greater than 10.
(when (and (null tramp--test-instrument-test-case-p) (> tramp-verbose 3))
(untrace-all)
(dolist (buf (tramp-list-tramp-buffers))
- (with-current-buffer buf
- (message ";; %s\n%s" buf (buffer-string)))
+ (message ";; %s\n%s" buf (tramp-get-buffer-string buf))
(kill-buffer buf))))))
(defsubst tramp--test-message (fmt-string &rest arguments)
@@ -243,8 +239,7 @@ is greater than 10.
(unwind-protect
(progn ,@body)
(tramp--test-message
- "%s %f sec"
- ,message (float-time (time-subtract (current-time) start))))))
+ "%s %f sec" ,message (float-time (time-subtract nil start))))))
;; `always' is introduced with Emacs 28.1.
(defalias 'tramp--test-always
@@ -2083,44 +2078,41 @@ Also see `ignore'."
(substitute-in-file-name "/method:host:/:/path//foo")
"/method:host:/:/path//foo"))
- ;; Forwhatever reasons, the following tests let Emacs crash for
- ;; Emacs 25, occasionally. No idea what's up.
- (when (tramp--test-emacs26-p)
- (should
- (string-equal
- (substitute-in-file-name (concat "/method:host://~" foo))
- (concat "/~" foo)))
- (should
- (string-equal
- (substitute-in-file-name (concat "/method:host:/~" foo))
- (concat "/method:host:/~" foo)))
- (should
- (string-equal
- (substitute-in-file-name (concat "/method:host:/path//~" foo))
- (concat "/~" foo)))
- ;; (substitute-in-file-name "/path/~foo") expands only for a local
- ;; user "foo" to "/~foo"". Otherwise, it doesn't expand.
- (should
- (string-equal
- (substitute-in-file-name (concat "/method:host:/path/~" foo))
- (concat "/method:host:/path/~" foo)))
- ;; Quoting local part.
- (should
- (string-equal
- (substitute-in-file-name (concat "/method:host:/://~" foo))
- (concat "/method:host:/://~" foo)))
- (should
- (string-equal
- (substitute-in-file-name (concat "/method:host:/:/~" foo))
- (concat "/method:host:/:/~" foo)))
- (should
- (string-equal
- (substitute-in-file-name (concat "/method:host:/:/path//~" foo))
- (concat "/method:host:/:/path//~" foo)))
- (should
- (string-equal
- (substitute-in-file-name (concat "/method:host:/:/path/~" foo))
- (concat "/method:host:/:/path/~" foo))))
+ (should
+ (string-equal
+ (substitute-in-file-name (concat "/method:host://~" foo))
+ (concat "/~" foo)))
+ (should
+ (string-equal
+ (substitute-in-file-name (concat "/method:host:/~" foo))
+ (concat "/method:host:/~" foo)))
+ (should
+ (string-equal
+ (substitute-in-file-name (concat "/method:host:/path//~" foo))
+ (concat "/~" foo)))
+ ;; (substitute-in-file-name "/path/~foo") expands only for a local
+ ;; user "foo" to "/~foo"". Otherwise, it doesn't expand.
+ (should
+ (string-equal
+ (substitute-in-file-name (concat "/method:host:/path/~" foo))
+ (concat "/method:host:/path/~" foo)))
+ ;; Quoting local part.
+ (should
+ (string-equal
+ (substitute-in-file-name (concat "/method:host:/://~" foo))
+ (concat "/method:host:/://~" foo)))
+ (should
+ (string-equal
+ (substitute-in-file-name (concat "/method:host:/:/~" foo))
+ (concat "/method:host:/:/~" foo)))
+ (should
+ (string-equal
+ (substitute-in-file-name (concat "/method:host:/:/path//~" foo))
+ (concat "/method:host:/:/path//~" foo)))
+ (should
+ (string-equal
+ (substitute-in-file-name (concat "/method:host:/:/path/~" foo))
+ (concat "/method:host:/:/path/~" foo)))
(let (process-environment)
(should
@@ -2294,6 +2286,46 @@ This checks also `file-name-as-directory', `file-name-directory',
(should (string-equal (file-name-directory file) file))
(should (string-equal (file-name-nondirectory file) "")))))))
+(ert-deftest tramp-test07-abbreviate-file-name ()
+ "Check that Tramp abbreviates file names correctly."
+ (skip-unless (tramp--test-enabled))
+ (skip-unless (tramp--test-emacs29-p))
+ (skip-unless (not (tramp--test-ange-ftp-p)))
+
+ (let* ((remote-host (file-remote-p tramp-test-temporary-file-directory))
+ ;; Not all methods can expand "~".
+ (home-dir (ignore-errors (expand-file-name (concat remote-host "~")))))
+ (skip-unless home-dir)
+
+ ;; Check home-dir abbreviation.
+ (unless (string-suffix-p "~" home-dir)
+ (should (equal (abbreviate-file-name (concat home-dir "/foo/bar"))
+ (concat remote-host "~/foo/bar")))
+ (should (equal (abbreviate-file-name
+ (concat remote-host "/nowhere/special"))
+ (concat remote-host "/nowhere/special"))))
+
+ ;; Check `directory-abbrev-alist' abbreviation.
+ (let ((directory-abbrev-alist
+ `((,(concat "\\`" (regexp-quote home-dir) "/foo")
+ . ,(concat home-dir "/f"))
+ (,(concat "\\`" (regexp-quote remote-host) "/nowhere")
+ . ,(concat remote-host "/nw")))))
+ (should (equal (abbreviate-file-name (concat home-dir "/foo/bar"))
+ (concat remote-host "~/f/bar")))
+ (should (equal (abbreviate-file-name
+ (concat remote-host "/nowhere/special"))
+ (concat remote-host "/nw/special"))))
+
+ ;; Check that home-dir abbreviation doesn't occur when home-dir is just "/".
+ (setq home-dir (concat remote-host "/"))
+ ;; The remote home directory is kept in the connection property
+ ;; "home-directory". We fake this setting.
+ (tramp-set-connection-property tramp-test-vec "home-directory" home-dir)
+ (should (equal (concat home-dir "foo/bar")
+ (abbreviate-file-name (concat home-dir "foo/bar"))))
+ (tramp-flush-connection-property tramp-test-vec "home-directory")))
+
(ert-deftest tramp-test07-file-exists-p ()
"Check `file-exist-p', `write-region' and `delete-file'."
(skip-unless (tramp--test-enabled))
@@ -2352,7 +2384,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(delete-file tmp-name2)
(should-error
(setq tmp-name2 (file-local-copy tmp-name1))
- :type tramp-file-missing))
+ :type 'file-missing))
;; Cleanup.
(ignore-errors
@@ -2391,7 +2423,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(delete-file tmp-name)
(should-error
(insert-file-contents tmp-name)
- :type tramp-file-missing))
+ :type 'file-missing))
;; Cleanup.
(ignore-errors (delete-file tmp-name))))))
@@ -2462,23 +2494,20 @@ This checks also `file-name-as-directory', `file-name-directory',
(should (string-equal (buffer-string) "34")))
;; Check message.
- ;; Macro `ert-with-message-capture' was introduced in Emacs 26.1.
- (with-no-warnings (when (symbol-plist 'ert-with-message-capture)
- (let (inhibit-message)
- (dolist
- (noninteractive (unless (tramp--test-ange-ftp-p) '(nil t)))
- (dolist (visit '(nil t "string" no-message))
- (ert-with-message-capture tramp--test-messages
- (write-region "foo" nil tmp-name nil visit)
- ;; We must check the last line. There could be
- ;; other messages from the progress reporter.
- (should
- (string-match-p
- (if (and (null noninteractive)
- (or (eq visit t) (null visit) (stringp visit)))
- (format "^Wrote %s\n\\'" (regexp-quote tmp-name))
- "^\\'")
- tramp--test-messages))))))))
+ (let (inhibit-message)
+ (dolist (noninteractive (unless (tramp--test-ange-ftp-p) '(nil t)))
+ (dolist (visit '(nil t "string" no-message))
+ (ert-with-message-capture tramp--test-messages
+ (write-region "foo" nil tmp-name nil visit)
+ ;; We must check the last line. There could be
+ ;; other messages from the progress reporter.
+ (should
+ (string-match-p
+ (if (and (null noninteractive)
+ (or (eq visit t) (null visit) (stringp visit)))
+ (format "^Wrote %s\n\\'" (regexp-quote tmp-name))
+ "^\\'")
+ tramp--test-messages))))))
;; We do not test lockname here. See
;; `tramp-test39-make-lock-file-name'.
@@ -2488,17 +2517,15 @@ This checks also `file-name-as-directory', `file-name-directory',
;; Ange-FTP.
((symbol-function 'yes-or-no-p) #'tramp--test-always))
(write-region "foo" nil tmp-name nil nil nil 'mustbenew))
- ;; `mustbenew' is passed to Tramp since Emacs 26.1.
- (when (tramp--test-emacs26-p)
- (should-error
- (cl-letf (((symbol-function #'y-or-n-p) #'ignore)
- ;; Ange-FTP.
- ((symbol-function #'yes-or-no-p) #'ignore))
- (write-region "foo" nil tmp-name nil nil nil 'mustbenew))
- :type 'file-already-exists)
- (should-error
- (write-region "foo" nil tmp-name nil nil nil 'excl)
- :type 'file-already-exists)))
+ (should-error
+ (cl-letf (((symbol-function #'y-or-n-p) #'ignore)
+ ;; Ange-FTP.
+ ((symbol-function #'yes-or-no-p) #'ignore))
+ (write-region "foo" nil tmp-name nil nil nil 'mustbenew))
+ :type 'file-already-exists)
+ (should-error
+ (write-region "foo" nil tmp-name nil nil nil 'excl)
+ :type 'file-already-exists))
;; Cleanup.
(ignore-errors (delete-file tmp-name))))))
@@ -2561,7 +2588,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(progn
(should-error
(copy-file source target)
- :type tramp-file-missing)
+ :type 'file-missing)
(write-region "foo" nil source)
(should (file-exists-p source))
(copy-file source target)
@@ -2587,8 +2614,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(should (file-exists-p source))
(make-directory target)
(should (file-directory-p target))
- ;; This has been changed in Emacs 26.1.
- (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p))
+ (when (tramp--test-expensive-test)
(should-error
(copy-file source target)
:type 'file-already-exists)
@@ -2673,7 +2699,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(progn
(should-error
(rename-file source target)
- :type tramp-file-missing)
+ :type 'file-missing)
(write-region "foo" nil source)
(should (file-exists-p source))
(rename-file source target)
@@ -2702,8 +2728,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(should (file-exists-p source))
(make-directory target)
(should (file-directory-p target))
- ;; This has been changed in Emacs 26.1.
- (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p))
+ (when (tramp--test-expensive-test)
(should-error
(rename-file source target)
:type 'file-already-exists)
@@ -2881,7 +2906,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(ert-deftest tramp-test15-copy-directory ()
"Check `copy-directory'."
(skip-unless (tramp--test-enabled))
- (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p))))
+ (skip-unless (not (tramp--test-rclone-p)))
(dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((tmp-name1 (tramp--test-make-temp-name nil quoted))
@@ -2898,7 +2923,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(progn
(should-error
(copy-directory tmp-name1 tmp-name2)
- :type tramp-file-missing)
+ :type 'file-missing)
;; Copy empty directory.
(make-directory tmp-name1)
(write-region "foo" nil tmp-name4)
@@ -2908,11 +2933,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(should (file-directory-p tmp-name2))
(should (file-exists-p tmp-name5))
;; Target directory does exist already.
- ;; This has been changed in Emacs 26.1.
- (when (tramp--test-emacs26-p)
- (should-error
- (copy-directory tmp-name1 tmp-name2)
- :type 'file-already-exists))
+ (should-error
+ (copy-directory tmp-name1 tmp-name2)
+ :type 'file-already-exists)
(copy-directory tmp-name1 (file-name-as-directory tmp-name2))
(should (file-directory-p tmp-name3))
(should (file-exists-p tmp-name6)))
@@ -3002,7 +3025,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(progn
(should-error
(directory-files tmp-name1)
- :type tramp-file-missing)
+ :type 'file-missing)
(make-directory tmp-name1)
(write-region "foo" nil tmp-name2)
(write-region "bla" nil tmp-name3)
@@ -3125,14 +3148,12 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(insert-directory tmp-name1 nil)
(goto-char (point-min))
(should (looking-at-p (regexp-quote tmp-name1))))
- ;; This has been fixed in Emacs 26.1. See Bug#29423.
- (when (tramp--test-emacs26-p)
- (with-temp-buffer
- (insert-directory (file-name-as-directory tmp-name1) nil)
- (goto-char (point-min))
- (should
- (looking-at-p
- (regexp-quote (file-name-as-directory tmp-name1))))))
+ (with-temp-buffer
+ (insert-directory (file-name-as-directory tmp-name1) nil)
+ (goto-char (point-min))
+ (should
+ (looking-at-p
+ (regexp-quote (file-name-as-directory tmp-name1)))))
(with-temp-buffer
(insert-directory tmp-name1 "-al")
(goto-char (point-min))
@@ -3164,7 +3185,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
;; modes are still "accessible".
(not (tramp--test-sshfs-p))
;; A directory is always accessible for user "root".
- (not (zerop (tramp-compat-file-attribute-user-id
+ (not (zerop (file-attribute-user-id
(file-attributes tmp-name1)))))
(set-file-modes tmp-name1 0)
(with-temp-buffer
@@ -3176,7 +3197,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(with-temp-buffer
(should-error
(insert-directory tmp-name1 nil)
- :type tramp-file-missing)))
+ :type 'file-missing)))
;; Cleanup.
(ignore-errors (delete-directory tmp-name1 'recursive))))))
@@ -3190,8 +3211,6 @@ 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)))
- ;; Since Emacs 26.1.
- (skip-unless (fboundp 'insert-directory-wildcard-in-dir-p))
(dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((tmp-name1
@@ -3320,7 +3339,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(goto-char (point-min))
(while (not (or (eobp)
(string-equal
- (dired-get-filename 'localp 'no-error)
+ (dired-get-filename 'no-dir 'no-error)
(file-name-nondirectory tmp-name2))))
(forward-line 1))
(should-not (eobp))
@@ -3330,14 +3349,14 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
;; Point shall still be the recent file.
(should
(string-equal
- (dired-get-filename 'localp 'no-error)
+ (dired-get-filename 'no-dir 'no-error)
(file-name-nondirectory tmp-name2)))
(should-not (re-search-forward "dired" nil t))
;; The copied file has been inserted the line before.
(forward-line -1)
(should
(string-equal
- (dired-get-filename 'localp 'no-error)
+ (dired-get-filename 'no-dir 'no-error)
(file-name-nondirectory tmp-name3))))
(kill-buffer buffer))
@@ -3379,15 +3398,14 @@ This tests also `access-file', `file-readable-p',
(file-modes tramp-test-temporary-file-directory))))
(write-region "foo" nil tmp-name1)
(setq test-file-ownership-preserved-p
- (= (tramp-compat-file-attribute-group-id
- (file-attributes tmp-name1))
+ (= (file-attribute-group-id (file-attributes tmp-name1))
(tramp-get-remote-gid tramp-test-vec 'integer)))
(delete-file tmp-name1))
(when (tramp--test-supports-set-file-modes-p)
(write-region "foo" nil tmp-name1)
;; A file is always accessible for user "root".
- (when (not (zerop (tramp-compat-file-attribute-user-id
+ (when (not (zerop (file-attribute-user-id
(file-attributes tmp-name1))))
(set-file-modes tmp-name1 0)
(should-error
@@ -3397,7 +3415,7 @@ This tests also `access-file', `file-readable-p',
(delete-file tmp-name1))
(should-error
(access-file tmp-name1 "error")
- :type tramp-file-missing)
+ :type 'file-missing)
;; `file-ownership-preserved-p' should return t for
;; non-existing files.
@@ -3414,33 +3432,29 @@ This tests also `access-file', `file-readable-p',
;; We do not test inodes and device numbers.
(setq attr (file-attributes tmp-name1))
(should (consp attr))
- (should (null (tramp-compat-file-attribute-type attr)))
- (should (numberp (tramp-compat-file-attribute-link-number attr)))
- (should (numberp (tramp-compat-file-attribute-user-id attr)))
- (should (numberp (tramp-compat-file-attribute-group-id attr)))
+ (should (null (file-attribute-type attr)))
+ (should (numberp (file-attribute-link-number attr)))
+ (should (numberp (file-attribute-user-id attr)))
+ (should (numberp (file-attribute-group-id attr)))
(should
- (stringp
- (current-time-string
- (tramp-compat-file-attribute-access-time attr))))
+ (stringp (current-time-string (file-attribute-access-time attr))))
(should
(stringp
- (current-time-string
- (tramp-compat-file-attribute-modification-time attr))))
+ (current-time-string (file-attribute-modification-time attr))))
(should
(stringp
- (current-time-string
- (tramp-compat-file-attribute-status-change-time attr))))
- (should (numberp (tramp-compat-file-attribute-size attr)))
- (should (stringp (tramp-compat-file-attribute-modes attr)))
+ (current-time-string (file-attribute-status-change-time attr))))
+ (should (numberp (file-attribute-size attr)))
+ (should (stringp (file-attribute-modes attr)))
(setq attr (file-attributes tmp-name1 'string))
- (should (stringp (tramp-compat-file-attribute-user-id attr)))
- (should (stringp (tramp-compat-file-attribute-group-id attr)))
+ (should (stringp (file-attribute-user-id attr)))
+ (should (stringp (file-attribute-group-id attr)))
(tramp--test-ignore-make-symbolic-link-error
(should-error
(access-file tmp-name2 "error")
- :type tramp-file-missing)
+ :type 'file-missing)
(when test-file-ownership-preserved-p
(should (file-ownership-preserved-p tmp-name2 'group)))
(make-symbolic-link tmp-name1 tmp-name2)
@@ -3454,7 +3468,7 @@ This tests also `access-file', `file-readable-p',
(string-equal
(funcall
(if quoted #'tramp-compat-file-name-quote #'identity)
- (tramp-compat-file-attribute-type attr))
+ (file-attribute-type attr))
(file-remote-p (file-truename tmp-name1) 'localname)))
(delete-file tmp-name2))
@@ -3473,7 +3487,7 @@ This tests also `access-file', `file-readable-p',
(setq attr (file-attributes tmp-name2))
(should
(string-equal
- (tramp-compat-file-attribute-type attr)
+ (file-attribute-type attr)
(tramp-file-name-localname
(tramp-dissect-file-name tmp-name3))))
(delete-file tmp-name2))
@@ -3489,7 +3503,7 @@ This tests also `access-file', `file-readable-p',
(when test-file-ownership-preserved-p
(should (file-ownership-preserved-p tmp-name1 'group)))
(setq attr (file-attributes tmp-name1))
- (should (eq (tramp-compat-file-attribute-type attr) t)))
+ (should (eq (file-attribute-type attr) t)))
;; Cleanup.
(ignore-errors (delete-directory tmp-name1))
@@ -3507,9 +3521,9 @@ They might differ only in time attributes or directory size."
(start-time (- tramp--test-start-time 10)))
;; Link number. For directories, it includes the number of
;; subdirectories. Set it to 1.
- (when (eq (tramp-compat-file-attribute-type attr1) t)
+ (when (eq (file-attribute-type attr1) t)
(setcar (nthcdr 1 attr1) 1))
- (when (eq (tramp-compat-file-attribute-type attr2) t)
+ (when (eq (file-attribute-type attr2) t)
(setcar (nthcdr 1 attr2) 1))
;; Access time.
(setcar (nthcdr 4 attr1) tramp-time-dont-know)
@@ -3522,42 +3536,33 @@ They might differ only in time attributes or directory size."
;; order to compensate a possible timestamp resolution higher than
;; a second on the remote machine.
(when (or (tramp-compat-time-equal-p
- (tramp-compat-file-attribute-modification-time attr1)
- tramp-time-dont-know)
+ (file-attribute-modification-time attr1) tramp-time-dont-know)
(tramp-compat-time-equal-p
- (tramp-compat-file-attribute-modification-time attr2)
- tramp-time-dont-know))
+ (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))
(when (< start-time
- (float-time (tramp-compat-file-attribute-modification-time attr1)))
+ (float-time (file-attribute-modification-time attr1)))
(setcar (nthcdr 5 attr1) tramp-time-dont-know))
(when (< start-time
- (float-time (tramp-compat-file-attribute-modification-time attr2)))
+ (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
- (tramp-compat-file-attribute-status-change-time attr1)
- tramp-time-dont-know)
+ (file-attribute-status-change-time attr1) tramp-time-dont-know)
(tramp-compat-time-equal-p
- (tramp-compat-file-attribute-status-change-time attr2)
- tramp-time-dont-know))
+ (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))
- (when
- (< start-time
- (float-time
- (tramp-compat-file-attribute-status-change-time attr1)))
+ (when (< start-time (float-time (file-attribute-status-change-time attr1)))
(setcar (nthcdr 6 attr1) tramp-time-dont-know))
- (when
- (< start-time
- (float-time (tramp-compat-file-attribute-status-change-time attr2)))
+ (when (< start-time (float-time (file-attribute-status-change-time attr2)))
(setcar (nthcdr 6 attr2) tramp-time-dont-know))
;; Size. Set it to 0 for directories, because it might have
;; changed. For example the upper directory "../".
- (when (eq (tramp-compat-file-attribute-type attr1) t)
+ (when (eq (file-attribute-type attr1) t)
(setcar (nthcdr 7 attr1) 0))
- (when (eq (tramp-compat-file-attribute-type attr2) t)
+ (when (eq (file-attribute-type attr2) t)
(setcar (nthcdr 7 attr2) 0))
;; The check.
(unless (equal attr1 attr2) (tramp--test-message "%S\n%S" attr1 attr2))
@@ -3581,12 +3586,12 @@ They might differ only in time attributes or directory size."
(progn
(should-error
(directory-files-and-attributes tmp-name1)
- :type tramp-file-missing)
+ :type 'file-missing)
(make-directory tmp-name1)
(should (file-directory-p tmp-name1))
(setq tramp--test-start-time
(float-time
- (tramp-compat-file-attribute-modification-time
+ (file-attribute-modification-time
(file-attributes tmp-name1))))
(make-directory tmp-name2)
(should (file-directory-p tmp-name2))
@@ -3644,8 +3649,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
(should (= (file-modes tmp-name1) #o444))
(should-not (file-executable-p tmp-name1))
;; A file is always writable for user "root".
- (unless (zerop (tramp-compat-file-attribute-user-id
- (file-attributes tmp-name1)))
+ (unless (zerop (file-attribute-user-id (file-attributes tmp-name1)))
(should-not (file-writable-p tmp-name1)))
;; Check the NOFOLLOW arg. It exists since Emacs 28. For
;; regular files, there shouldn't be a difference.
@@ -3719,9 +3723,6 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
"Check `file-symlink-p'.
This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(skip-unless (tramp--test-enabled))
- ;; The semantics have changed heavily in Emacs 26.1. We cannot test
- ;; older Emacsen, therefore.
- (skip-unless (tramp--test-emacs26-p))
(dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
;; We must use `file-truename' for the temporary directory,
@@ -3938,11 +3939,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(when (tramp--test-expensive-test)
(should-error
(with-temp-buffer (insert-file-contents tmp-name2))
- :type tramp-file-missing))
+ :type 'file-missing))
(when (tramp--test-expensive-test)
(should-error
(with-temp-buffer (insert-file-contents tmp-name3))
- :type tramp-file-missing))
+ :type 'file-missing))
;; `directory-files' does not show symlinks to
;; non-existing targets in the "smb" case. So we remove
;; the symlinks manually.
@@ -4003,7 +4004,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(progn
(write-region "foo" nil tmp-name1)
(should (file-exists-p tmp-name1))
- (should (consp (tramp-compat-file-attribute-modification-time
+ (should (consp (file-attribute-modification-time
(file-attributes tmp-name1))))
;; Skip the test, if the remote handler is not able to set
;; the correct time.
@@ -4011,13 +4012,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; 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
- (tramp-compat-file-attribute-modification-time
+ (file-attribute-modification-time
(file-attributes tmp-name1))
tramp-time-dont-know)
(should
(tramp-compat-time-equal-p
- (tramp-compat-file-attribute-modification-time
- (file-attributes tmp-name1))
+ (file-attribute-modification-time (file-attributes tmp-name1))
(seconds-to-time 1)))
(write-region "bla" nil tmp-name2)
(should (file-exists-p tmp-name2))
@@ -4032,7 +4032,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(set-file-times tmp-name1 (seconds-to-time 1) 'nofollow)
(should
(tramp-compat-time-equal-p
- (tramp-compat-file-attribute-modification-time
+ (file-attribute-modification-time
(file-attributes tmp-name1))
(seconds-to-time 1)))))))
@@ -4946,8 +4946,6 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(skip-unless (not (tramp--test-crypt-p)))
- ;; Since Emacs 26.1.
- (skip-unless (boundp 'interrupt-process-functions))
;; We must use `file-truename' for the temporary directory, in
;; order to establish the connection prior running an asynchronous
@@ -5054,8 +5052,8 @@ INPUT, if non-nil, is a string sent to the process."
"echo foo >&2; echo bar" (current-buffer) stderr)
(should (string-equal "bar\n" (buffer-string)))
;; Check stderr.
- (with-current-buffer stderr
- (should (string-equal "foo\n" (buffer-string)))))
+ (should
+ (string-equal "foo\n" (tramp-get-buffer-string stderr))))
;; Cleanup.
(ignore-errors (kill-buffer stderr))))))
@@ -5362,9 +5360,6 @@ Use direct async.")
;; Since Emacs 27.1.
(skip-unless (fboundp 'with-connection-local-variables))
- ;; `connection-local-set-profile-variables' and
- ;; `connection-local-set-profiles' exist since Emacs 26.1. We don't
- ;; want to see compiler warnings for older Emacsen.
(let* ((default-directory tramp-test-temporary-file-directory)
(tmp-name1 (tramp--test-make-temp-name))
(tmp-name2 (expand-file-name "foo" tmp-name1))
@@ -5380,23 +5375,22 @@ Use direct async.")
;; `local-variable' is buffer-local due to explicit setting.
(with-no-warnings
- (defvar-local local-variable 'buffer))
+ (defvar-local local-variable 'buffer))
(with-temp-buffer
(should (eq local-variable 'buffer)))
;; `local-variable' is connection-local due to Tramp.
(write-region "foo" nil tmp-name2)
(should (file-exists-p tmp-name2))
- (with-no-warnings
- (connection-local-set-profile-variables
- 'local-variable-profile
- '((local-variable . connect)))
- (connection-local-set-profiles
- `(:application tramp
- :protocol ,(file-remote-p default-directory 'method)
- :user ,(file-remote-p default-directory 'user)
- :machine ,(file-remote-p default-directory 'host))
- 'local-variable-profile))
+ (connection-local-set-profile-variables
+ 'local-variable-profile
+ '((local-variable . connect)))
+ (connection-local-set-profiles
+ `(:application tramp
+ :protocol ,(file-remote-p default-directory 'method)
+ :user ,(file-remote-p default-directory 'user)
+ :machine ,(file-remote-p default-directory 'host))
+ 'local-variable-profile)
(with-current-buffer (find-file-noselect tmp-name2)
(should (eq local-variable 'connect))
(kill-buffer (current-buffer)))
@@ -5421,7 +5415,6 @@ Use direct async.")
;; Cleanup.
(ignore-errors (delete-directory tmp-name1 'recursive)))))
-;; The functions were introduced in Emacs 26.1.
(ert-deftest tramp-test34-explicit-shell-file-name ()
"Check that connection-local `explicit-shell-file-name' is set."
:tags '(:expensive-test)
@@ -5431,13 +5424,7 @@ Use direct async.")
;; remote processes in Emacs. That doesn't work for tramp-adb.el.
(when (tramp--test-adb-p)
(skip-unless (tramp--test-emacs27-p)))
- ;; Since Emacs 26.1.
- (skip-unless (and (fboundp 'connection-local-set-profile-variables)
- (fboundp 'connection-local-set-profiles)))
- ;; `connection-local-set-profile-variables' and
- ;; `connection-local-set-profiles' exist since Emacs 26.1. We don't
- ;; want to see compiler warnings for older Emacsen.
(let ((default-directory tramp-test-temporary-file-directory)
explicit-shell-file-name kill-buffer-query-functions
connection-local-profile-alist connection-local-criteria-alist)
@@ -5446,19 +5433,16 @@ Use direct async.")
;; `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)
- ;; Declare connection-local variables `explicit-shell-file-name'
- ;; and `explicit-sh-args'.
- (with-no-warnings
- (connection-local-set-profile-variables
- 'remote-sh
- `((explicit-shell-file-name . ,(tramp--test-shell-file-name))
- (explicit-sh-args . ("-c" "echo foo"))))
- (connection-local-set-profiles
- `(:application tramp
- :protocol ,(file-remote-p default-directory 'method)
- :user ,(file-remote-p default-directory 'user)
- :machine ,(file-remote-p default-directory 'host))
- 'remote-sh))
+ (connection-local-set-profile-variables
+ 'remote-sh
+ `((explicit-shell-file-name . ,(tramp--test-shell-file-name))
+ (explicit-sh-args . ("-c" "echo foo"))))
+ (connection-local-set-profiles
+ `(:application tramp
+ :protocol ,(file-remote-p default-directory 'method)
+ :user ,(file-remote-p default-directory 'user)
+ :machine ,(file-remote-p default-directory 'host))
+ 'remote-sh)
(put 'explicit-shell-file-name 'safe-local-variable #'identity)
(put 'explicit-sh-args 'safe-local-variable #'identity)
@@ -5761,7 +5745,7 @@ Use direct async.")
;; files, owned by root.
(let ((tramp-auto-save-directory temporary-file-directory))
(write-region "foo" nil tmp-name1)
- (when (zerop (or (tramp-compat-file-attribute-user-id
+ (when (zerop (or (file-attribute-user-id
(file-attributes tmp-name1))
tramp-unknown-id-integer))
(with-temp-buffer
@@ -5908,8 +5892,7 @@ Use direct async.")
(let ((backup-directory-alist `(("." . ,temporary-file-directory)))
tramp-backup-directory-alist)
(write-region "foo" nil tmp-name1)
- (when (zerop (or (tramp-compat-file-attribute-user-id
- (file-attributes tmp-name1))
+ (when (zerop (or (file-attribute-user-id (file-attributes tmp-name1))
tramp-unknown-id-integer))
(tramp-cleanup-connection
tramp-test-vec 'keep-debug 'keep-password)
@@ -6045,8 +6028,7 @@ Use direct async.")
;; files, owned by root.
(let ((lock-file-name-transforms auto-save-file-name-transforms))
(write-region "foo" nil tmp-name1)
- (when (zerop (or (tramp-compat-file-attribute-user-id
- (file-attributes tmp-name1))
+ (when (zerop (or (file-attribute-user-id (file-attributes tmp-name1))
tramp-unknown-id-integer))
(tramp-cleanup-connection
tramp-test-vec 'keep-debug 'keep-password)
@@ -6064,29 +6046,22 @@ Use direct async.")
(ignore-errors (delete-file tmp-name1))
(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))
(skip-unless (not (tramp--test-ange-ftp-p)))
- ;; Since Emacs 26.1.
- (skip-unless
- (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory)))
- ;; `make-nearby-temp-file' and `temporary-file-directory' exists
- ;; since Emacs 26.1. We don't want to see compiler warnings for
- ;; older Emacsen.
(let ((default-directory tramp-test-temporary-file-directory)
tmp-file)
;; The remote host shall know a temporary file directory.
- (should (stringp (with-no-warnings (temporary-file-directory))))
+ (should (stringp (temporary-file-directory)))
(should
(string-equal
(file-remote-p default-directory)
- (file-remote-p (with-no-warnings (temporary-file-directory)))))
+ (file-remote-p (temporary-file-directory))))
;; The temporary file shall be located on the remote host.
- (setq tmp-file (with-no-warnings (make-nearby-temp-file "tramp-test")))
+ (setq tmp-file (make-nearby-temp-file "tramp-test"))
(should (file-exists-p tmp-file))
(should (file-regular-p tmp-file))
(should
@@ -6096,18 +6071,12 @@ Use direct async.")
(delete-file tmp-file)
(should-not (file-exists-p tmp-file))
- (setq tmp-file (with-no-warnings (make-nearby-temp-file "tramp-test" 'dir)))
+ (setq tmp-file (make-nearby-temp-file "tramp-test" 'dir))
(should (file-exists-p tmp-file))
(should (file-directory-p tmp-file))
(delete-directory tmp-file)
(should-not (file-exists-p tmp-file))))
-(defun tramp--test-emacs26-p ()
- "Check for Emacs version >= 26.1.
-Some semantics has been changed for there, w/o new functions or
-variables, so we check the Emacs version directly."
- (>= emacs-major-version 26))
-
(defun tramp--test-emacs27-p ()
"Check for Emacs version >= 27.1.
Some semantics has been changed for there, w/o new functions or
@@ -6120,6 +6089,12 @@ Some semantics has been changed for there, w/o new functions or
variables, so we check the Emacs version directly."
(>= emacs-major-version 28))
+(defun tramp--test-emacs29-p ()
+ "Check for Emacs version >= 29.1.
+Some semantics has been changed for there, w/o new functions or
+variables, so we check the Emacs version directly."
+ (>= emacs-major-version 29))
+
(defun tramp--test-adb-p ()
"Check, whether the remote host runs Android.
This requires restrictions of file name syntax."
@@ -6335,7 +6310,7 @@ This requires restrictions of file name syntax."
(string-equal
(funcall
(if quoted #'tramp-compat-file-name-quote #'identity)
- (tramp-compat-file-attribute-type (file-attributes file3)))
+ (file-attribute-type (file-attributes file3)))
(file-remote-p (file-truename file1) 'localname)))
;; Check file contents.
(with-temp-buffer
@@ -6366,7 +6341,7 @@ This requires restrictions of file name syntax."
(setq buffer (dired-noselect tmp-name1 "--dired -al"))
(goto-char (point-min))
(while (not (eobp))
- (when-let ((name (dired-get-filename 'localp 'no-error)))
+ (when-let ((name (dired-get-filename 'no-dir 'no-error)))
(unless
(string-match-p name directory-files-no-dot-files-regexp)
(should (member name files))))
@@ -6536,7 +6511,7 @@ This requires restrictions of file name syntax."
(skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 245s
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-rsync-p)))
- (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p))))
+ (skip-unless (not (tramp--test-rclone-p)))
(tramp--test-special-characters))
@@ -6632,7 +6607,7 @@ Use the \"ls\" command."
;; Use all available language specific snippets.
(lambda (x)
(and
- (stringp (setq x (eval (get-language-info (car x) 'sample-text))))
+ (stringp (setq x (eval (get-language-info (car x) 'sample-text) t)))
;; Filter out strings which use unencodable characters.
(not (and (or (tramp--test-gvfs-p) (tramp--test-smb-p))
(unencodable-char-position
@@ -6659,7 +6634,7 @@ Use the \"ls\" command."
(skip-unless (not (tramp--test-ksh-p)))
(skip-unless (not (tramp--test-gdrive-p)))
(skip-unless (not (tramp--test-crypt-p)))
- (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p))))
+ (skip-unless (not (tramp--test-rclone-p)))
(tramp--test-utf8))
@@ -6871,11 +6846,7 @@ process sentinels. They shall not disturb each other."
(when buffers
(let ((time (float-time))
(default-directory tmp-name)
- (file
- (buffer-name
- ;; Use `seq-random-elt' once <26.1 support
- ;; is dropped.
- (nth (random (length buffers)) buffers)))
+ (file (buffer-name (seq-random-elt buffers)))
;; A remote operation in a timer could
;; confuse Tramp heavily. So we ignore this
;; error here.
@@ -6940,8 +6911,7 @@ process sentinels. They shall not disturb each other."
;; the buffers. Mix with regular operation.
(let ((buffers (copy-sequence buffers)))
(while buffers
- ;; Use `seq-random-elt' once <26.1 support is dropped.
- (let* ((buf (nth (random (length buffers)) buffers))
+ (let* ((buf (seq-random-elt buffers))
(proc (get-buffer-process buf))
(file (process-get proc 'foo))
(count (process-get proc 'bar)))
@@ -6997,8 +6967,51 @@ process sentinels. They shall not disturb each other."
;; (tramp--test--deftest-direct-async-process tramp-test44-asynchronous-requests
;; "Check parallel direct asynchronous requests." 'unstable)
+(ert-deftest tramp-test45-dired-compress-file ()
+ "Check that Tramp (un)compresses normal files."
+ (skip-unless (tramp--test-enabled))
+ (skip-unless (tramp--test-sh-p))
+ (skip-unless (not (tramp--test-crypt-p)))
+ ;; Starting with Emacs 29.1, `dired-compress-file' is performed by
+ ;; default handler.
+ (skip-unless (not (tramp--test-emacs29-p)))
+
+ (let ((default-directory tramp-test-temporary-file-directory)
+ (tmp-name (tramp--test-make-temp-name)))
+ (write-region "foo" nil tmp-name)
+ (dired default-directory)
+ (dired-revert)
+ (dired-goto-file tmp-name)
+ (should-not (dired-compress))
+ (should (string= (concat tmp-name ".gz") (dired-get-filename)))
+ (should-not (dired-compress))
+ (should (string= tmp-name (dired-get-filename)))
+ (delete-file tmp-name)))
+
+(ert-deftest tramp-test45-dired-compress-dir ()
+ "Check that Tramp (un)compresses directories."
+ (skip-unless (tramp--test-enabled))
+ (skip-unless (tramp--test-sh-p))
+ (skip-unless (not (tramp--test-crypt-p)))
+ ;; Starting with Emacs 29.1, `dired-compress-file' is performed by
+ ;; default handler.
+ (skip-unless (not (tramp--test-emacs29-p)))
+
+ (let ((default-directory tramp-test-temporary-file-directory)
+ (tmp-name (tramp--test-make-temp-name)))
+ (make-directory tmp-name)
+ (dired default-directory)
+ (dired-revert)
+ (dired-goto-file tmp-name)
+ (should-not (dired-compress))
+ (should (string= (concat tmp-name ".tar.gz") (dired-get-filename)))
+ (should-not (dired-compress))
+ (should (string= tmp-name (dired-get-filename)))
+ (delete-directory tmp-name)
+ (delete-file (concat tmp-name ".tar.gz"))))
+
;; This test is inspired by Bug#29163.
-(ert-deftest tramp-test45-auto-load ()
+(ert-deftest tramp-test46-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.
@@ -7023,12 +7036,8 @@ process sentinels. They shall not disturb each other."
(mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument code)))))))
-(ert-deftest tramp-test45-delay-load ()
+(ert-deftest tramp-test46-delay-load ()
"Check that Tramp is loaded lazily, only when needed."
- ;; The autoloaded Tramp objects are different since Emacs 26.1. We
- ;; cannot test older Emacsen, therefore.
- (skip-unless (tramp--test-emacs26-p))
-
;; Tramp is neither loaded at Emacs startup, nor when completing a
;; non-Tramp file name like "/foo". Completing a Tramp-alike file
;; name like "/foo:" autoloads Tramp, when `tramp-mode' is t.
@@ -7056,7 +7065,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-test45-recursive-load ()
+(ert-deftest tramp-test46-recursive-load ()
"Check that Tramp does not fail due to recursive load."
(skip-unless (tramp--test-enabled))
@@ -7080,12 +7089,8 @@ process sentinels. They shall not disturb each other."
(mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument code))))))))
-(ert-deftest tramp-test45-remote-load-path ()
+(ert-deftest tramp-test46-remote-load-path ()
"Check that Tramp autoloads its packages with remote `load-path'."
- ;; The autoloaded Tramp objects are different since Emacs 26.1. We
- ;; cannot test older Emacsen, therefore.
- (skip-unless (tramp--test-emacs26-p))
-
;; `tramp-cleanup-all-connections' is autoloaded from tramp-cmds.el.
;; It shall still work, when a remote file name is in the
;; `load-path'.
@@ -7109,15 +7114,11 @@ process sentinels. They shall not disturb each other."
(mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument code)))))))
-(ert-deftest tramp-test46-unload ()
+(ert-deftest tramp-test47-unload ()
"Check that Tramp and its subpackages unload completely.
Since it unloads Tramp, it shall be the last test to run."
:tags '(:expensive-test)
(skip-unless noninteractive)
- ;; The autoloaded Tramp objects are different since Emacs 26.1. We
- ;; cannot test older Emacsen, therefore.
- (skip-unless (tramp--test-emacs26-p))
-
;; We have autoloaded objects from tramp.el and tramp-archive.el.
;; In order to remove them, we first need to load both packages.
(require 'tramp)
@@ -7177,8 +7178,7 @@ If INTERACTIVE is non-nil, the tests are run interactively."
;; TODO:
-;; * dired-compress-file
-;; * dired-uncache
+;; * dired-uncache (partly done in other test functions)
;; * file-equal-p (partly done in `tramp-test21-file-links')
;; * file-in-directory-p
;; * file-name-case-insensitive-p
diff --git a/test/lisp/obsolete/cl-tests.el b/test/lisp/obsolete/cl-tests.el
index 0e02e1ca1bc..659c51ebcf8 100644
--- a/test/lisp/obsolete/cl-tests.el
+++ b/test/lisp/obsolete/cl-tests.el
@@ -25,12 +25,11 @@
(require 'cl))
(require 'ert)
-
-
(ert-deftest labels-function-quoting ()
"Test that #'foo does the right thing in `labels'." ; Bug#31792.
- (should (eq (funcall (labels ((foo () t))
- #'foo))
- t)))
+ (with-suppressed-warnings ((obsolete labels))
+ (should (eq (funcall (labels ((foo () t))
+ #'foo))
+ t))))
;;; cl-tests.el ends here
diff --git a/test/lisp/paren-tests.el b/test/lisp/paren-tests.el
index c4bec5d86de..11249ee9bc1 100644
--- a/test/lisp/paren-tests.el
+++ b/test/lisp/paren-tests.el
@@ -117,5 +117,36 @@
(- (point-max) 1) (point-max)
nil)))))
+(ert-deftest paren-tests-open-paren-line ()
+ (cl-flet ((open-paren-line ()
+ (let* ((data (show-paren--default))
+ (here-beg (nth 0 data))
+ (there-beg (nth 2 data)))
+ (blink-paren-open-paren-line-string
+ (min here-beg there-beg)))))
+ ;; Lisp-like
+ (with-temp-buffer
+ (insert "(defun foo ()
+ (dummy))")
+ (goto-char (point-max))
+ (should (string= "(defun foo ()" (open-paren-line))))
+
+ ;; C-like
+ (with-temp-buffer
+ (insert "int foo() {
+ int blah;
+ }")
+ (goto-char (point-max))
+ (should (string= "int foo() {" (open-paren-line))))
+
+ ;; C-like with hanging {
+ (with-temp-buffer
+ (insert "int foo()
+ {
+ int blah;
+ }")
+ (goto-char (point-max))
+ (should (string= "int foo()...{" (open-paren-line))))))
+
(provide 'paren-tests)
;;; paren-tests.el ends here
diff --git a/test/lisp/progmodes/bug-reference-tests.el b/test/lisp/progmodes/bug-reference-tests.el
new file mode 100644
index 00000000000..7a3ab5fbda0
--- /dev/null
+++ b/test/lisp/progmodes/bug-reference-tests.el
@@ -0,0 +1,128 @@
+;;; bug-reference-tests.el --- Tests for bug-reference.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 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 'bug-reference)
+(require 'ert)
+
+(defun test--get-github-entry (url)
+ (and (string-match
+ (car (bug-reference--build-forge-setup-entry
+ "github.com" 'github "https"))
+ url)
+ (match-string 1 url)))
+
+(defun test--get-gitlab-entry (url)
+ (and (string-match
+ (car (bug-reference--build-forge-setup-entry
+ "gitlab.com" 'gitlab "https"))
+ url)
+ (match-string 1 url)))
+
+(defun test--get-gitea-entry (url)
+ (and (string-match
+ (car (bug-reference--build-forge-setup-entry
+ "gitea.com" 'gitea "https"))
+ url)
+ (match-string 1 url)))
+
+(ert-deftest test-github-entry ()
+ (should
+ (equal
+ (test--get-github-entry "git@github.com:larsmagne/csid.git")
+ "larsmagne/csid"))
+ (should
+ (equal
+ (test--get-github-entry "git@github.com:larsmagne/csid")
+ "larsmagne/csid"))
+ (should
+ (equal
+ (test--get-github-entry "https://github.com/magit/magit.git")
+ "magit/magit"))
+ (should
+ (equal
+ (test--get-github-entry "https://github.com/magit/magit.git/")
+ "magit/magit"))
+ (should
+ (equal
+ (test--get-github-entry "https://github.com/magit/magit")
+ "magit/magit"))
+ (should
+ (equal
+ (test--get-github-entry "https://github.com/magit/magit/")
+ "magit/magit")))
+
+(ert-deftest test-gitlab-entry ()
+ (should
+ (equal
+ (test--get-gitlab-entry "git@gitlab.com:larsmagne/csid.git")
+ "larsmagne/csid"))
+ (should
+ (equal
+ (test--get-gitlab-entry "git@gitlab.com:larsmagne/csid")
+ "larsmagne/csid"))
+ (should
+ (equal
+ (test--get-gitlab-entry "https://gitlab.com/magit/magit.git")
+ "magit/magit"))
+ (should
+ (equal
+ (test--get-gitlab-entry "https://gitlab.com/magit/magit.git/")
+ "magit/magit"))
+ (should
+ (equal
+ (test--get-gitlab-entry "https://gitlab.com/magit/magit")
+ "magit/magit"))
+ (should
+ (equal
+ (test--get-gitlab-entry "https://gitlab.com/magit/magit/")
+ "magit/magit")))
+
+(ert-deftest test-gitea-entry ()
+ (should
+ (equal
+ (test--get-gitea-entry "git@gitea.com:larsmagne/csid.git")
+ "larsmagne/csid"))
+ (should
+ (equal
+ (test--get-gitea-entry "git@gitea.com:larsmagne/csid")
+ "larsmagne/csid"))
+ (should
+ (equal
+ (test--get-gitea-entry "https://gitea.com/magit/magit.git")
+ "magit/magit"))
+ (should
+ (equal
+ (test--get-gitea-entry "https://gitea.com/magit/magit.git/")
+ "magit/magit"))
+ (should
+ (equal
+ (test--get-gitea-entry "https://gitea.com/magit/magit")
+ "magit/magit"))
+ (should
+ (equal
+ (test--get-gitea-entry "https://gitea.com/magit/magit/")
+ "magit/magit")))
+
+;;; bug-reference-tests.el ends here
diff --git a/test/lisp/progmodes/compile-tests.el b/test/lisp/progmodes/compile-tests.el
index 2a3bb3dafae..c87a4453cbd 100644
--- a/test/lisp/progmodes/compile-tests.el
+++ b/test/lisp/progmodes/compile-tests.el
@@ -230,6 +230,7 @@
(gnu "foo.c:8:23:information: message" 1 23 8 "foo.c")
(gnu "foo.c:8.23-45: Informational: message" 1 (23 . 45) (8 . nil) "foo.c")
(gnu "foo.c:8-23: message" 1 nil (8 . 23) "foo.c")
+ (gnu " |foo.c:8: message" 1 nil 8 "foo.c")
;; The next one is not in the GNU standards AFAICS.
;; Here we seem to interpret it as LINE1-LINE2.COL2.
(gnu "foo.c:8-45.3: message" 1 (nil . 3) (8 . 45) "foo.c")
@@ -491,7 +492,7 @@ The test data is in `compile-tests--test-regexps-data'."
(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 96))
+ (should (eq compilation-num-errors-found 97))
(should (eq compilation-num-warnings-found 35))
(should (eq compilation-num-infos-found 28)))))
diff --git a/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts b/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts
new file mode 100644
index 00000000000..2c0d51edae8
--- /dev/null
+++ b/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts
@@ -0,0 +1,88 @@
+Code:
+ (lambda ()
+ (emacs-lisp-mode)
+ (indent-region (point-min) (point-max)))
+
+Name: defun
+
+=-=
+(defun foo ()
+"doc"
+(+ 1 2))
+=-=
+(defun foo ()
+ "doc"
+ (+ 1 2))
+=-=-=
+
+Name: function call
+
+=-=
+(foo zot
+bar
+(zot bar))
+=-=
+(foo zot
+ bar
+ (zot bar))
+=-=-=
+
+Name: lisp data
+
+=-=
+( foo zot
+bar
+(zot bar))
+=-=
+( foo zot
+ bar
+ (zot bar))
+=-=-=
+
+Name: defun-space
+
+=-=
+(defun x ()
+ (print (quote ( thingy great
+ stuff)))
+ (print (quote (thingy great
+ stuff))))
+=-=-=
+
+Name: defvar-keymap
+
+=-=
+(defvar-keymap eww-link-keymap
+ :copy shr-map
+ :foo bar
+ "\r" #'eww-follow-link)
+=-=-=
+
+Name: def-indent1
+
+=-=
+(defzot-does-not-exist 1
+ 2 3)
+=-=-=
+
+Name: def-indent2
+
+=-=
+(define-keymap 1
+ 2 3)
+=-=-=
+
+Name: elisp-indents1
+
+=-=
+(defvar foo
+ ()
+ "bar")
+=-=-=
+
+Name: elisp-indents2
+
+=-=
+(defvar foo ()
+ "bar")
+=-=-=
diff --git a/test/lisp/progmodes/elisp-mode-resources/flet.erts b/test/lisp/progmodes/elisp-mode-resources/flet.erts
new file mode 100644
index 00000000000..da3dcb6ec3e
--- /dev/null
+++ b/test/lisp/progmodes/elisp-mode-resources/flet.erts
@@ -0,0 +1,353 @@
+Name: flet1
+
+=-=
+(cl-flet ()
+ (a (dangerous-position
+ b)))
+=-=-=
+
+Name: flet2
+
+=-=
+(cl-flet wrong-syntax-but-should-not-obstruct-indentation
+ (a (dangerous-position
+ b)))
+=-=-=
+
+Name: flet3
+
+=-=
+(cl-flet ((a (arg-of-flet-a)
+ b
+ c)))
+=-=-=
+
+Name: flet4
+
+=-=
+(cl-flet ((a (arg-of-flet-a)
+ b
+ c
+ (if d
+ e
+ f))
+ (irregular-local-def (form
+ returning
+ lambda))
+ (g (arg-of--flet-g)
+ h
+ i))
+ (let ((j k))
+ (if dangerous-position
+ l
+ m)))
+=-=-=
+
+Name: flet5
+
+=-=
+(cl-flet ((a (arg-of-flet-a)
+ b
+ c
+ (if d
+ e
+ f))
+ (irregular-local-def (form
+ returning
+ lambda))
+ (g (arg-of--flet-g)
+ h
+ i))
+ (let ((j k))
+ (if dangerous-position
+ l
+ m)))
+=-=-=
+
+Name: flet6
+
+=-=
+(cl-flet ((a (arg-of-flet-a)
+ b
+ c
+ (if d
+ e
+ f))
+ (irregular-local-def (form
+ returning
+ lambda))
+ (irregular-local-def (form returning
+ lambda))
+ wrong-syntax-but-should-not-osbtruct-indentation
+ (g (arg-of--flet-g)
+ h
+ i))
+ (let ((j k))
+ (if dangerous-position
+ l
+ m)))
+=-=-=
+
+Name: flet7
+
+=-=
+(cl-flet ((a (arg-of-flet-a)
+ b
+ c
+ (if d
+ e
+ f))
+ (irregular-local-def (form
+ returning
+ lambda))
+ wrong-syntax-but-should-not-osbtruct-indentation
+ (g (arg-of--flet-g)
+ h
+ i))
+ (let ((j k))
+ (if dangerous-position
+ l
+ m)))
+=-=-=
+
+Name: flet8
+
+=-=
+(cl-flet (wrong-syntax-but-should-not-obstruct-indentation
+ (g (arg-of--flet-g)
+ h
+ i))
+ (let ((j k))
+ (if dangerous-position
+ l
+ m)))
+=-=-=
+
+;; (setf _) not yet supported but looks like it will be
+Name: flet9
+
+=-=
+(cl-flet (((setf a) (new value)
+ stuff)
+ wrong-syntax-but-should-not-obstruct-indentation
+ (g (arg-of--flet-g)
+ h
+ i))
+ (let ((j k))
+ (if dangerous-position
+ l
+ m)))
+=-=-=
+
+Name: flet10
+
+=-=
+(cl-flet ( (a (arg-of-flet-a)
+ b
+ c
+ (if d
+ e
+ f))
+ (irregular-local-def (form
+ returning
+ lambda))
+ (g (arg-of--flet-g)
+ h
+ i))
+ (let ((j k))
+ (if dangerous-position
+ l
+ m)))
+=-=-=
+
+Name: flet11
+
+=-=
+(cl-flet ( wrong-syntax-but-should-not-obstruct-indentation
+ (g (arg-of--flet-g)
+ h
+ i))
+ (let ((j k))
+ (if dangerous-position
+ l
+ m)))
+=-=-=
+
+Name: flet12
+
+=-=
+(cl-flet ( wrong-syntax-but-should-not-obstruct-indentation
+ (g (arg-of--flet-g)
+ h
+ i))
+ (let ((j k))
+ (if dangerous-position
+ l
+ m)))
+=-=-=
+
+Name: flet13
+
+=-=
+(cl-flet (wrong-syntax-but-should-not-obstruct-indentation
+ (g (arg-of--flet-g)
+ h
+ i)
+ wrong-syntax-but-should-not-obstruct-indentation
+ (g (arg-of--flet-g)
+ h
+ i)))
+=-=-=
+
+Name: flet14
+
+=-=
+(cl-flet (wrong-syntax-but-should-not-obstruct-indentation
+ wrong-syntax-but-should-not-obstruct-indentation
+ (g (arg-of--flet-g)
+ h
+ i)
+ wrong-syntax-but-should-not-obstruct-indentation))
+=-=-=
+
+Name: flet15
+
+=-=
+(cl-flet (wrong-syntax-but-should-not-obstruct-indentation
+ wrong-syntax-but-should-not-obstruct-indentation
+ wrong-syntax-but-should-not-obstruct-indentation
+ (g (arg-of--flet-g)
+ h
+ i)))
+=-=-=
+
+Name: flet16
+
+=-=
+(cl-flet ((f (x)
+ (g x)))
+ (pcase e
+ ((dangerous-expression)
+ (form))))
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-no-side-effects-1
+Code: (lambda () (emacs-lisp-mode) (setq indent-tabs-mode nil) (newline nil t))
+Point-Char: |
+
+=-=
+(let ((x (and y|
+=-=
+(let ((x (and y
+ |
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-no-side-effects-2
+
+=-=
+(let ((x|
+=-=
+(let ((x
+ |
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-missing-whitespace-1
+Point-Char: |
+
+=-=
+(cl-flet((f (x)|
+=-=
+(cl-flet((f (x)
+ |
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-missing-whitespace-2
+Point-Char: |
+
+=-=
+(cl-flet((f(x)|
+=-=
+(cl-flet((f(x)
+ |
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-missing-whitespace-3
+
+=-=
+(cl-flet ((f(x)|
+=-=
+(cl-flet ((f(x)
+ |
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-missing-whitespace-4
+
+=-=
+(cl-flet( (f (x)|
+=-=
+(cl-flet( (f (x)
+ |
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-missing-whitespace-5
+
+=-=
+(cl-flet( (f(x)|
+=-=
+(cl-flet( (f(x)
+ |
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-1
+
+=-=
+(cl-flet((f (x)|
+=-=
+(cl-flet((f (x)
+ |
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-2
+
+=-=
+(cl-flet ((f(x)|
+=-=
+(cl-flet ((f(x)
+ |
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-3
+
+=-=
+(cl-flet( (f (x)|
+=-=
+(cl-flet( (f (x)
+ |
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-4
+
+=-=
+(cl-flet( (f (x)|
+=-=
+(cl-flet( (f (x)
+ |
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-5
+
+=-=
+(cl-flet( (f (x)|
+=-=
+(cl-flet( (f (x)
+ |
+=-=-=
+
+Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-6
+
+=-=
+(cl-flet( (f(x)|
+=-=
+(cl-flet( (f(x)
+ |
+=-=-=
diff --git a/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el b/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el
index 14c8e845d11..9b41fb5426c 100644
--- a/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el
+++ b/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el
@@ -1,3 +1,5 @@
+;;; simple-shorthand-test.el --- -*- lexical-binding: t; -*-
+
(defun f-test ()
(let ((read-symbol-shorthands '(("foo-" . "bar-"))))
(with-temp-buffer
diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el
index f887bb1dca5..9dc5e8cadcf 100644
--- a/test/lisp/progmodes/elisp-mode-tests.el
+++ b/test/lisp/progmodes/elisp-mode-tests.el
@@ -26,6 +26,7 @@
(require 'ert-x)
(require 'xref)
(eval-when-compile (require 'cl-lib))
+(require 'ert-x)
;;; Completion
@@ -108,7 +109,7 @@
(should (member "backup-inhibited" comps))
(should-not (member "backup-buffer" comps))))))
-(ert-deftest elisp-completes-functions-after-let-bindings ()
+(ert-deftest elisp-completes-functions-after-let-bindings-2 ()
(with-temp-buffer
(emacs-lisp-mode)
(insert "(let ((bar 1) (baz 2)) (ba")
@@ -301,12 +302,9 @@
;; tmp may be on a different filesystem to the tests, but, ehh.
(defvar xref--case-insensitive
- (let ((dir (make-temp-file "xref-test" t)))
- (unwind-protect
- (progn
- (with-temp-file (expand-file-name "hElLo" dir) "hello")
- (file-exists-p (expand-file-name "HELLO" dir)))
- (delete-directory dir t)))
+ (ert-with-temp-directory dir
+ (with-temp-file (expand-file-name "hElLo" dir) "hello")
+ (file-exists-p (expand-file-name "HELLO" dir)))
"Non-nil if file system seems to be case-insensitive.")
(defun xref-elisp-test-run (xrefs expected-xrefs)
@@ -440,7 +438,8 @@ to (xref-elisp-test-descr-to-target xref)."
;; track down the problem.
(cl-defmethod xref-elisp-generic-no-default ((this xref-elisp-root-type) arg2)
"Doc string generic no-default xref-elisp-root-type."
- "non-default for no-default")
+ "non-default for no-default"
+ (list this arg2)) ; silence byte-compiler
;; defgeneric after defmethod in file to ensure the fallback search
;; method of just looking for the function name will fail.
@@ -465,19 +464,23 @@ to (xref-elisp-test-descr-to-target xref)."
(cl-defmethod xref-elisp-generic-separate-default (arg1 arg2)
"Doc string generic separate-default default."
- "separate default")
+ "separate default"
+ (list arg1 arg2)) ; silence byte-compiler
(cl-defmethod xref-elisp-generic-separate-default ((this xref-elisp-root-type) arg2)
"Doc string generic separate-default xref-elisp-root-type."
- "non-default for separate-default")
+ "non-default for separate-default"
+ (list this arg2)) ; silence byte-compiler
(cl-defmethod xref-elisp-generic-implicit-generic (arg1 arg2)
"Doc string generic implicit-generic default."
- "default for implicit generic")
+ "default for implicit generic"
+ (list arg1 arg2)) ; silence byte-compiler
(cl-defmethod xref-elisp-generic-implicit-generic ((this xref-elisp-root-type) arg2)
"Doc string generic implicit-generic xref-elisp-root-type."
- "non-default for implicit generic")
+ "non-default for implicit generic"
+ (list this arg2)) ; silence byte-compiler
(xref-elisp-deftest find-defs-defgeneric-no-methods
@@ -612,7 +615,7 @@ to (xref-elisp-test-descr-to-target xref)."
))
(xref-elisp-deftest find-defs-defgeneric-eval
- (elisp--xref-find-definitions (eval '(cl-defgeneric stephe-leake-cl-defgeneric ())))
+ (elisp--xref-find-definitions (eval '(cl-defgeneric stephe-leake-cl-defgeneric ()) t))
nil)
;; Define some mode-local overloadable/overridden functions for xref to find
@@ -714,7 +717,7 @@ to (xref-elisp-test-descr-to-target xref)."
(expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir)))))
(xref-elisp-deftest find-defs-defun-eval
- (elisp--xref-find-definitions (eval '(defun stephe-leake-defun ())))
+ (elisp--xref-find-definitions (eval '(defun stephe-leake-defun ()) t))
nil)
(xref-elisp-deftest find-defs-defun-c
@@ -781,11 +784,11 @@ to (xref-elisp-test-descr-to-target xref)."
))
(xref-elisp-deftest find-defs-defvar-el
- (elisp--xref-find-definitions 'xref--marker-ring)
+ (elisp--xref-find-definitions 'xref--history)
(list
- (xref-make "(defvar xref--marker-ring)"
+ (xref-make "(defvar xref--history)"
(xref-make-elisp-location
- 'xref--marker-ring 'defvar
+ 'xref--history 'defvar
(expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir)))
))
@@ -799,7 +802,7 @@ to (xref-elisp-test-descr-to-target xref)."
"DEFVAR_PER_BUFFER (\"default-directory\"")))
(xref-elisp-deftest find-defs-defvar-eval
- (elisp--xref-find-definitions (eval '(defvar stephe-leake-defvar nil)))
+ (elisp--xref-find-definitions (eval '(defvar stephe-leake-defvar nil) t))
nil)
(xref-elisp-deftest find-defs-face-el
@@ -817,7 +820,7 @@ to (xref-elisp-test-descr-to-target xref)."
))
(xref-elisp-deftest find-defs-face-eval
- (elisp--xref-find-definitions (eval '(defface stephe-leake-defface nil "")))
+ (elisp--xref-find-definitions (eval '(defface stephe-leake-defface nil "") t))
nil)
(xref-elisp-deftest find-defs-feature-el
@@ -832,7 +835,7 @@ to (xref-elisp-test-descr-to-target xref)."
))
(xref-elisp-deftest find-defs-feature-eval
- (elisp--xref-find-definitions (eval '(provide 'stephe-leake-feature)))
+ (elisp--xref-find-definitions (eval '(provide 'stephe-leake-feature) t))
nil)
(ert-deftest elisp--preceding-sexp--char-name ()
@@ -841,25 +844,14 @@ to (xref-elisp-test-descr-to-target xref)."
(insert "?\\N{HEAVY CHECK MARK}")
(should (equal (elisp--preceding-sexp) ?\N{HEAVY CHECK MARK}))))
-(ert-deftest elisp-indent-basic ()
- (with-temp-buffer
- (emacs-lisp-mode)
- (let ((orig "(defun x ()
- (print (quote ( thingy great
- stuff)))
- (print (quote (thingy great
- stuff))))"))
- (insert orig)
- (indent-region (point-min) (point-max))
- (should (equal (buffer-string) orig)))))
-
(defun test--font (form search)
(with-temp-buffer
(emacs-lisp-mode)
(if (stringp form)
(insert form)
(pp form (current-buffer)))
- (font-lock-debug-fontify)
+ (with-suppressed-warnings ((interactive-only font-lock-debug-fontify))
+ (font-lock-debug-fontify))
(goto-char (point-min))
(and (re-search-forward search nil t)
(get-text-property (match-beginning 1) 'face))))
@@ -1115,17 +1107,12 @@ evaluation of BODY."
(buffer-string)))))))
(should (equal observed expected-longhand-form))))
-(ert-deftest test-cl-flet-indentation ()
- :expected-result :failed ; FIXME: bug#9622
- (should (equal
- (with-temp-buffer
- (emacs-lisp-mode)
- (insert "(cl-flet ((bla (x)\n(* x x)))\n(bla 42))")
- (indent-region (point-min) (point-max))
- (buffer-string))
- "(cl-flet ((bla (x)
- (* x x)))
- (bla 42))")))
+(ert-deftest test-indentation ()
+ (ert-test-erts-file (ert-resource-file "elisp-indents.erts"))
+ (ert-test-erts-file (ert-resource-file "flet.erts")
+ (lambda ()
+ (emacs-lisp-mode)
+ (indent-region (point-min) (point-max)))))
(provide 'elisp-mode-tests)
;;; elisp-mode-tests.el ends here
diff --git a/test/lisp/progmodes/etags-tests.el b/test/lisp/progmodes/etags-tests.el
index 9b14a3ae860..32b73f101e1 100644
--- a/test/lisp/progmodes/etags-tests.el
+++ b/test/lisp/progmodes/etags-tests.el
@@ -22,6 +22,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'etags)
(eval-when-compile (require 'cl-lib))
@@ -95,21 +96,19 @@
(ert-deftest etags-buffer-local-tags-table-list ()
"Test that a buffer-local value of `tags-table-list' is used."
- (let ((file (make-temp-file "etag-test-tmpfile")))
- (unwind-protect
- (progn
- (set-buffer (find-file-noselect file))
- (fundamental-mode)
- (setq-local tags-table-list
- (list (expand-file-name "manual/etags/ETAGS.good_3"
- etags-tests--test-dir)))
- (cl-letf ((tag-tables tags-table-list)
- (tags-file-name nil)
- ((symbol-function 'read-file-name)
- (lambda (&rest _)
- (error "We should not prompt the user"))))
- (should (visit-tags-table-buffer))
- (should (equal tags-file-name (car tag-tables)))))
- (delete-file file))))
+ (ert-with-temp-file file
+ :suffix "etag-test-tmpfile"
+ (set-buffer (find-file-noselect file))
+ (fundamental-mode)
+ (setq-local tags-table-list
+ (list (expand-file-name "manual/etags/ETAGS.good_3"
+ etags-tests--test-dir)))
+ (cl-letf ((tag-tables tags-table-list)
+ (tags-file-name nil)
+ ((symbol-function 'read-file-name)
+ (lambda (&rest _)
+ (error "We should not prompt the user"))))
+ (should (visit-tags-table-buffer))
+ (should (equal tags-file-name (car tag-tables))))))
;;; etags-tests.el ends here
diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el
index 4c0d15d1e1b..4840018236a 100644
--- a/test/lisp/progmodes/flymake-tests.el
+++ b/test/lisp/progmodes/flymake-tests.el
@@ -23,6 +23,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'flymake)
(eval-when-compile (require 'subr-x)) ; string-trim
@@ -123,22 +124,21 @@ SEVERITY-PREDICATE is used to setup
"Test the ruby backend."
(skip-unless (executable-find "ruby"))
;; Some versions of ruby fail if HOME doesn't exist (bug#29187).
- (let* ((tempdir (make-temp-file "flymake-tests-ruby" t))
- (process-environment (cons (format "HOME=%s" tempdir)
- process-environment))
- ;; And see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19657#20
- ;; for this particular yuckiness
- (abbreviated-home-dir nil))
- (unwind-protect
- (let ((ruby-mode-hook
- (lambda ()
- (setq flymake-diagnostic-functions '(ruby-flymake-simple)))))
- (flymake-tests--with-flymake ("test.rb")
- (flymake-goto-next-error)
- (should (eq 'flymake-warning (face-at-point)))
- (flymake-goto-next-error)
- (should (eq 'flymake-error (face-at-point)))))
- (delete-directory tempdir t))))
+ (ert-with-temp-directory tempdir
+ :suffix "flymake-tests-ruby"
+ (let* ((process-environment (cons (format "HOME=%s" tempdir)
+ process-environment))
+ ;; And see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19657#20
+ ;; for this particular yuckiness
+ (abbreviated-home-dir nil)
+ (ruby-mode-hook
+ (lambda ()
+ (setq flymake-diagnostic-functions '(ruby-flymake-simple)))))
+ (flymake-tests--with-flymake ("test.rb")
+ (flymake-goto-next-error)
+ (should (eq 'flymake-warning (face-at-point)))
+ (flymake-goto-next-error)
+ (should (eq 'flymake-error (face-at-point)))))))
(ert-deftest different-diagnostic-types ()
"Test GCC warning via function predicate."
diff --git a/test/lisp/progmodes/perl-mode-tests.el b/test/lisp/progmodes/perl-mode-tests.el
index 3f4af5e1f61..b059f539159 100644
--- a/test/lisp/progmodes/perl-mode-tests.el
+++ b/test/lisp/progmodes/perl-mode-tests.el
@@ -37,4 +37,6 @@
(file-name-directory (or load-file-name
buffer-file-name)))))
+(setq ert-load-file-name load-file-name)
+
;;; perl-mode-tests.el ends here
diff --git a/test/lisp/progmodes/project-tests.el b/test/lisp/progmodes/project-tests.el
index 1e3f258ac2a..a469414a743 100644
--- a/test/lisp/progmodes/project-tests.el
+++ b/test/lisp/progmodes/project-tests.el
@@ -29,29 +29,17 @@
(require 'cl-lib)
(require 'ert)
+(require 'ert-x) ; ert-with-temp-directory
(require 'grep)
(require 'xref)
-(defmacro project-tests--with-temporary-directory (var &rest body)
- "Create a new temporary directory.
-Bind VAR to the name of the directory, and evaluate BODY. Delete
-the directory after BODY exits."
- (declare (debug (symbolp body)) (indent 1))
- (cl-check-type var symbol)
- (let ((directory (make-symbol "directory")))
- `(let ((,directory (make-temp-file "project-tests-" :directory)))
- (unwind-protect
- (let ((,var ,directory))
- ,@body)
- (delete-directory ,directory :recursive)))))
-
(ert-deftest project/quoted-directory ()
"Check that `project-files' and `project-find-regexp' deal with
quoted directory names (Bug#47799)."
(skip-unless (executable-find find-program))
(skip-unless (executable-find "xargs"))
(skip-unless (executable-find "grep"))
- (project-tests--with-temporary-directory directory
+ (ert-with-temp-directory directory
(let ((default-directory directory)
(project-current-inhibit-prompt t)
(project-find-functions nil)
@@ -95,7 +83,7 @@ quoted directory names (Bug#47799)."
returned by `project-ignores' if the root directory is a
directory name (Bug#48471)."
(skip-unless (executable-find find-program))
- (project-tests--with-temporary-directory dir
+ (ert-with-temp-directory dir
(make-empty-file (expand-file-name "some-file" dir))
(make-empty-file (expand-file-name "ignored-file" dir))
(let* ((project (make-project-tests--trivial
@@ -111,7 +99,7 @@ directory name (Bug#48471)."
"Check that `project-files' does not ignore all files.
When `project-ignores' includes a name matching project dir."
(skip-unless (executable-find find-program))
- (project-tests--with-temporary-directory dir
+ (ert-with-temp-directory dir
(make-empty-file (expand-file-name "some-file" dir))
(let* ((project (make-project-tests--trivial
:root (file-name-as-directory dir)
diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el
index 752a4f0113f..2d1ccdca41d 100644
--- a/test/lisp/progmodes/python-tests.el
+++ b/test/lisp/progmodes/python-tests.el
@@ -22,6 +22,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'python)
;; Dependencies for testing:
@@ -48,17 +49,17 @@ BODY is code to be executed within the temp buffer. Point is
always located at the beginning of buffer."
(declare (indent 1) (debug t))
;; temp-file never actually used for anything?
- `(let* ((temp-file (make-temp-file "python-tests" nil ".py"))
- (buffer (find-file-noselect temp-file))
- (python-indent-guess-indent-offset nil))
- (unwind-protect
- (with-current-buffer buffer
- (python-mode)
- (insert ,contents)
- (goto-char (point-min))
- ,@body)
- (and buffer (kill-buffer buffer))
- (delete-file temp-file))))
+ `(ert-with-temp-file temp-file
+ :suffix "-python.py"
+ (let ((buffer (find-file-noselect temp-file))
+ (python-indent-guess-indent-offset nil))
+ (unwind-protect
+ (with-current-buffer buffer
+ (python-mode)
+ (insert ,contents)
+ (goto-char (point-min))
+ ,@body)
+ (and buffer (kill-buffer buffer))))))
(defun python-tests-look-at (string &optional num restore-point)
"Move point at beginning of STRING in the current buffer.
diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el
index 99b79b61d65..1bbe3a95e90 100644
--- a/test/lisp/progmodes/sql-tests.el
+++ b/test/lisp/progmodes/sql-tests.el
@@ -28,6 +28,7 @@
(require 'cl-lib)
(require 'ert)
+(require 'ert-x)
(require 'sql)
(ert-deftest sql-tests-postgres-list-databases ()
@@ -63,52 +64,49 @@ Identify tests by ID. Set :sql-login dialect attribute to
LOGIN-PARAMS. Provide the CONNECTION parameters and the EXPECTED
string of values passed to the comint function for validation."
(declare (indent 2))
- `(cl-letf
- ((sql-test-login-params ' ,login-params)
- ((symbol-function 'sql-comint-test)
- (lambda (product options &optional buf-name)
- (with-current-buffer (get-buffer-create buf-name)
- (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database))))))
- ((symbol-function 'sql-run-test)
- (lambda (&optional buffer)
- (interactive "P")
- (sql-product-interactive 'sqltest buffer)))
- (sql-user nil)
- (sql-server nil)
- (sql-database nil)
- (sql-product-alist
- '((ansi)
- (sqltest
- :name "SqlTest"
- :sqli-login sql-test-login-params
- :sqli-comint-func sql-comint-test)))
- (sql-connection-alist
- '((,(format "test-%s" id)
- ,@connection)))
- (sql-password-wallet
- (list
- (make-temp-file
- "sql-test-netrc" nil nil
- (mapconcat #'identity
- '("machine aMachine user aUserName password \"netrc-A aPassword\""
- "machine aServer user aUserName password \"netrc-B aPassword\""
- "machine aMachine server aServer user aUserName password \"netrc-C aPassword\""
- "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\""
- "machine aDatabase user aUserName password \"netrc-E aPassword\""
- "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\""
- "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\""
- ) "\n")))))
-
- (let* ((connection ,(format "test-%s" id))
- (buffername (format "*SQL: ERT TEST <%s>*" connection)))
- (when (get-buffer buffername)
- (kill-buffer buffername))
- (sql-connect connection buffername)
- (should (get-buffer buffername))
- (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected))
- (when (get-buffer buffername)
- (kill-buffer buffername))
- (delete-file (car sql-password-wallet)))))
+ `(ert-with-temp-file tempfile
+ :suffix "sql-test-netrc"
+ :text (concat
+ "machine aMachine user aUserName password \"netrc-A aPassword\""
+ "machine aServer user aUserName password \"netrc-B aPassword\""
+ "machine aMachine server aServer user aUserName password \"netrc-C aPassword\""
+ "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\""
+ "machine aDatabase user aUserName password \"netrc-E aPassword\""
+ "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\""
+ "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\""
+ "\n")
+ (cl-letf
+ ((sql-test-login-params ' ,login-params)
+ ((symbol-function 'sql-comint-test)
+ (lambda (product options &optional buf-name)
+ (with-current-buffer (get-buffer-create buf-name)
+ (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database))))))
+ ((symbol-function 'sql-run-test)
+ (lambda (&optional buffer)
+ (interactive "P")
+ (sql-product-interactive 'sqltest buffer)))
+ (sql-user nil)
+ (sql-server nil)
+ (sql-database nil)
+ (sql-product-alist
+ '((ansi)
+ (sqltest
+ :name "SqlTest"
+ :sqli-login sql-test-login-params
+ :sqli-comint-func sql-comint-test)))
+ (sql-connection-alist
+ '((,(format "test-%s" id)
+ ,@connection)))
+ (sql-password-wallet (list tempfile)))
+ (let* ((connection ,(format "test-%s" id))
+ (buffername (format "*SQL: ERT TEST <%s>*" connection)))
+ (when (get-buffer buffername)
+ (kill-buffer buffername))
+ (sql-connect connection buffername)
+ (should (get-buffer buffername))
+ (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected))
+ (when (get-buffer buffername)
+ (kill-buffer buffername))))))
(ert-deftest sql-test-connect ()
"Test of basic `sql-connect'."
@@ -416,6 +414,16 @@ The ACTION will be tested after set-up of PRODUCT."
(kill-buffer "*SQL: exist*")))
+(ert-deftest sql-tests-comint-automatic-password ()
+ (let ((sql-password nil))
+ (should-not (sql-comint-automatic-password "Password: ")))
+ (let ((sql-password ""))
+ (should-not (sql-comint-automatic-password "Password: ")))
+ (let ((sql-password "password"))
+ (should (equal "password" (sql-comint-automatic-password "Password: "))))
+ ;; Also, we shouldn't care what the password is - we rely on comint for that.
+ (let ((sql-password "password"))
+ (should (equal "password" (sql-comint-automatic-password "")))))
(provide 'sql-tests)
;;; sql-tests.el ends here
diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el
index 7f62a417a02..dcd5ebb1fe6 100644
--- a/test/lisp/replace-tests.el
+++ b/test/lisp/replace-tests.el
@@ -599,11 +599,12 @@ bound to HIGHLIGHT-LOCUS."
(with-temp-buffer
(insert before)
(goto-char (point-min))
- (replace-regexp
- "\\(\\(L\\)\\|\\(R\\)\\)"
- '(replace-eval-replacement
- replace-quote
- (if (match-string 2) "R" "L")))
+ (with-suppressed-warnings ((interactive-only replace-regexp))
+ (replace-regexp
+ "\\(\\(L\\)\\|\\(R\\)\\)"
+ '(replace-eval-replacement
+ replace-quote
+ (if (match-string 2) "R" "L"))))
(should (equal (buffer-string) after)))))
(ert-deftest test-count-matches ()
diff --git a/test/lisp/saveplace-tests.el b/test/lisp/saveplace-tests.el
index 63577fdd167..190ffb78288 100644
--- a/test/lisp/saveplace-tests.el
+++ b/test/lisp/saveplace-tests.el
@@ -41,49 +41,42 @@
(ert-deftest saveplace-test-save-place-to-alist/file ()
(save-place-mode)
- (let* ((tmpfile (make-temp-file "emacs-test-saveplace-"))
- (tmpfile (file-truename tmpfile))
- (save-place-alist nil)
- (save-place-loaded t)
- (loc tmpfile)
- (pos 4))
- (unwind-protect
- (save-window-excursion
- (find-file loc)
- (insert "abc") ; must insert something
- (save-place-to-alist)
- (should (equal save-place-alist (list (cons tmpfile pos)))))
- (delete-file tmpfile))))
+ (ert-with-temp-file tmpfile
+ (let* ((tmpfile (file-truename tmpfile))
+ (save-place-alist nil)
+ (save-place-loaded t)
+ (loc tmpfile)
+ (pos 4))
+ (save-window-excursion
+ (find-file loc)
+ (insert "abc") ; must insert something
+ (save-place-to-alist)
+ (should (equal save-place-alist (list (cons tmpfile pos))))))))
(ert-deftest saveplace-test-forget-unreadable-files ()
(save-place-mode)
- (let* ((save-place-loaded t)
- (tmpfile (make-temp-file "emacs-test-saveplace-"))
- (alist-orig (list (cons "/this/file/does/not/exist" 10)
- (cons tmpfile 1917)))
- (save-place-alist alist-orig))
- (unwind-protect
- (progn
- (save-place-forget-unreadable-files)
- (should (equal save-place-alist (cdr alist-orig))))
- (delete-file tmpfile))))
+ (ert-with-temp-file tmpfile
+ :suffix "-saveplace"
+ (let* ((save-place-loaded t)
+ (alist-orig (list (cons "/this/file/does/not/exist" 10)
+ (cons tmpfile 1917)))
+ (save-place-alist alist-orig))
+ (save-place-forget-unreadable-files)
+ (should (equal save-place-alist (cdr alist-orig))))))
(ert-deftest saveplace-test-place-alist-to-file ()
(save-place-mode)
- (let* ((tmpfile (make-temp-file "emacs-test-saveplace-"))
- (tmpfile2 (make-temp-file "emacs-test-saveplace-"))
- (save-place-file tmpfile)
- (save-place-alist (list (cons tmpfile2 99))))
- (unwind-protect
- (progn (save-place-alist-to-file)
- (setq save-place-alist nil)
- (save-window-excursion
- (find-file save-place-file)
- (unwind-protect
- (should (string-match tmpfile2 (buffer-string)))
- (kill-buffer))))
- (delete-file tmpfile)
- (delete-file tmpfile2))))
+ (ert-with-temp-file tmpfile
+ (ert-with-temp-file tmpfile2
+ (let* ((save-place-file tmpfile)
+ (save-place-alist (list (cons tmpfile2 99))))
+ (save-place-alist-to-file)
+ (setq save-place-alist nil)
+ (save-window-excursion
+ (find-file save-place-file)
+ (unwind-protect
+ (should (string-match tmpfile2 (buffer-string)))
+ (kill-buffer)))))))
(ert-deftest saveplace-test-load-alist-from-file ()
(save-place-mode)
diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el
index 9a7fb502d7c..932291afcc1 100644
--- a/test/lisp/ses-tests.el
+++ b/test/lisp/ses-tests.el
@@ -24,6 +24,10 @@
(require 'ert)
(require 'ses)
+;; Silence byte-compiler.
+(with-suppressed-warnings ((lexical A2) (lexical A3))
+ (defvar A2)
+ (defvar A3))
;; PLAIN FORMULA TESTS
;; ======================================================================
diff --git a/test/lisp/so-long-tests/so-long-tests.el b/test/lisp/so-long-tests/so-long-tests.el
index 7eee345aadd..cda5ae497fd 100644
--- a/test/lisp/so-long-tests/so-long-tests.el
+++ b/test/lisp/so-long-tests/so-long-tests.el
@@ -32,7 +32,7 @@
;; Running manually:
;;
;; for test in lisp/so-long-tests/*-tests.el; do make ${test%.el}; done \
-;; 2>&1 | egrep -v '^(Loading|Source file|make|Changed to so-long-mode)'
+;; 2>&1 | grep -E -v '^(Loading|Source file|make|Changed to so-long-mode)'
;;
;; Which is equivalent to:
;;
@@ -41,7 +41,7 @@
;; "../src/emacs" --no-init-file --no-site-file --no-site-lisp \
;; -L ":." -l ert -l "$test" --batch --eval \
;; '(ert-run-tests-batch-and-exit (quote (not (tag :unstable))))'; \
-;; done 2>&1 | egrep -v '^(Loading|Source file|Changed to so-long-mode)'
+;; done 2>&1 | grep -E -v '^(Loading|Source file|Changed to so-long-mode)'
;;
;; See also `ert-run-tests-batch-and-exit'.
diff --git a/test/lisp/so-long-tests/spelling-tests.el b/test/lisp/so-long-tests/spelling-tests.el
index f778b646635..b598366ba7a 100644
--- a/test/lisp/so-long-tests/spelling-tests.el
+++ b/test/lisp/so-long-tests/spelling-tests.el
@@ -23,6 +23,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'ispell)
(require 'cl-lib)
@@ -50,20 +51,19 @@
;; The Emacs test Makefile's use of HOME=/nonexistent triggers an error
;; when starting the inferior ispell process, so we set HOME to a valid
;; (but empty) temporary directory for this test.
- (let* ((tmpdir (make-temp-file "so-long." :dir ".ispell"))
- (process-environment (cons (format "HOME=%s" tmpdir)
- process-environment))
- (find-spelling-mistake
- (unwind-protect
- (cl-letf (((symbol-function 'ispell-command-loop)
- (lambda (_miss _guess word _start _end)
- (message "Unrecognised word: %s." word)
- (throw 'mistake t))))
- (catch 'mistake
- (find-library "so-long")
- (ispell-buffer)
- nil))
- (delete-directory tmpdir))))
- (should (not find-spelling-mistake)))))
+ (ert-with-temp-file tmpdir
+ :suffix "so-long.ispell"
+ (let* ((process-environment (cons (format "HOME=%s" tmpdir)
+ process-environment))
+ (find-spelling-mistake
+ (cl-letf (((symbol-function 'ispell-command-loop)
+ (lambda (_miss _guess word _start _end)
+ (message "Unrecognised word: %s." word)
+ (throw 'mistake t))))
+ (catch 'mistake
+ (find-library "so-long")
+ (ispell-buffer)
+ nil))))
+ (should (not find-spelling-mistake))))))
;;; spelling-tests.el ends here
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 0da1ae96873..063c6fe6a7b 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -84,16 +84,237 @@
;;;; Keymap support.
(ert-deftest subr-test-kbd ()
+ (should (equal (kbd "") ""))
(should (equal (kbd "f") "f"))
+ (should (equal (kbd "X") "X"))
+ (should (equal (kbd "foobar") "foobar")) ; 6 characters
+ (should (equal (kbd "return") "return")) ; 6 characters
+
+ (should (equal (kbd "<F2>") [F2]))
+ (should (equal (kbd "<f1> <f2> TAB") [f1 f2 ?\t]))
+ (should (equal (kbd "<f1> RET") [f1 ?\r]))
+ (should (equal (kbd "<f1> SPC") [f1 ? ]))
(should (equal (kbd "<f1>") [f1]))
- (should (equal (kbd "RET") "\C-m"))
+ (should (equal (kbd "<f1>") [f1]))
+ (should (equal (kbd "[f1]") "[f1]"))
+ (should (equal (kbd "<return>") [return]))
+ (should (equal (kbd "< right >") "<right>")) ; 7 characters
+
+ ;; Modifiers:
+ (should (equal (kbd "C-x") "\C-x"))
(should (equal (kbd "C-x a") "\C-xa"))
- ;; Check that kbd handles both new and old style key descriptions
- ;; (bug#45536).
+ (should (equal (kbd "C-;") [?\C-\;]))
+ (should (equal (kbd "C-a") "\C-a"))
+ (should (equal (kbd "C-c SPC") "\C-c "))
+ (should (equal (kbd "C-c TAB") "\C-c\t"))
+ (should (equal (kbd "C-c c") "\C-cc"))
+ (should (equal (kbd "C-x 4 C-f") "\C-x4\C-f"))
+ (should (equal (kbd "C-x C-f") "\C-x\C-f"))
+ (should (equal (kbd "C-M-<down>") [C-M-down]))
+ (should (equal (kbd "<C-M-down>") [C-M-down]))
+ (should (equal (kbd "C-RET") [?\C-\C-m]))
+ (should (equal (kbd "C-SPC") [?\C- ]))
+ (should (equal (kbd "C-TAB") [?\C-\t]))
+ (should (equal (kbd "C-<down>") [C-down]))
+ (should (equal (kbd "C-c C-c C-c") "\C-c\C-c\C-c"))
+
+ (should (equal (kbd "M-a") [?\M-a]))
+ (should (equal (kbd "M-<DEL>") [?\M-\d]))
+ (should (equal (kbd "M-C-a") [?\M-\C-a]))
+ (should (equal (kbd "M-ESC") [?\M-\e]))
+ (should (equal (kbd "M-RET") [?\M-\r]))
+ (should (equal (kbd "M-SPC") [?\M- ]))
+ (should (equal (kbd "M-TAB") [?\M-\t]))
+ (should (equal (kbd "M-x a") [?\M-x ?a]))
+ (should (equal (kbd "M-<up>") [M-up]))
+ (should (equal (kbd "M-c M-c M-c") [?\M-c ?\M-c ?\M-c]))
+
+ (should (equal (kbd "s-SPC") [?\s- ]))
+ (should (equal (kbd "s-a") [?\s-a]))
+ (should (equal (kbd "s-x a") [?\s-x ?a]))
+ (should (equal (kbd "s-c s-c s-c") [?\s-c ?\s-c ?\s-c]))
+
+ (should (equal (kbd "S-H-a") [?\S-\H-a]))
+ (should (equal (kbd "S-a") [?\S-a]))
+ (should (equal (kbd "S-x a") [?\S-x ?a]))
+ (should (equal (kbd "S-c S-c S-c") [?\S-c ?\S-c ?\S-c]))
+
+ (should (equal (kbd "H-<RET>") [?\H-\r]))
+ (should (equal (kbd "H-DEL") [?\H-\d]))
+ (should (equal (kbd "H-a") [?\H-a]))
+ (should (equal (kbd "H-x a") [?\H-x ?a]))
+ (should (equal (kbd "H-c H-c H-c") [?\H-c ?\H-c ?\H-c]))
+
+ (should (equal (kbd "A-H-a") [?\A-\H-a]))
+ (should (equal (kbd "A-SPC") [?\A- ]))
+ (should (equal (kbd "A-TAB") [?\A-\t]))
+ (should (equal (kbd "A-a") [?\A-a]))
+ (should (equal (kbd "A-c A-c A-c") [?\A-c ?\A-c ?\A-c]))
+
+ (should (equal (kbd "C-M-a") [?\C-\M-a]))
+ (should (equal (kbd "C-M-<up>") [C-M-up]))
+
+ ;; Special characters.
+ (should (equal (kbd "DEL") "\d"))
+ (should (equal (kbd "ESC C-a") "\e\C-a"))
+ (should (equal (kbd "ESC") "\e"))
+ (should (equal (kbd "LFD") "\n"))
+ (should (equal (kbd "NUL") "\0"))
+ (should (equal (kbd "RET") "\C-m"))
+ (should (equal (kbd "SPC") "\s"))
+ (should (equal (kbd "TAB") "\t"))
+ (should (equal (kbd "\^i") ""))
+ (should (equal (kbd "^M") "\^M"))
+
+ ;; With numbers.
+ (should (equal (kbd "\177") "\^?"))
+ (should (equal (kbd "\000") "\0"))
+ (should (equal (kbd "\\177") "\^?"))
+ (should (equal (kbd "\\000") "\0"))
+ (should (equal (kbd "C-x \\150") "\C-xh"))
+
+ ;; Multibyte
+ (should (equal (kbd "ñ") [?ñ]))
+ (should (equal (kbd "ü") [?ü]))
+ (should (equal (kbd "ö") [?ö]))
+ (should (equal (kbd "ğ") [?ğ]))
+ (should (equal (kbd "ա") [?ա]))
+ (should (equal (kbd "üüöö") [?ü ?ü ?ö ?ö]))
+ (should (equal (kbd "C-ü") [?\C-ü]))
+ (should (equal (kbd "M-ü") [?\M-ü]))
+ (should (equal (kbd "H-ü") [?\H-ü]))
+
+ ;; Handle both new and old style key descriptions (bug#45536).
(should (equal (kbd "s-<return>") [s-return]))
(should (equal (kbd "<s-return>") [s-return]))
(should (equal (kbd "C-M-<return>") [C-M-return]))
- (should (equal (kbd "<C-M-return>") [C-M-return])))
+ (should (equal (kbd "<C-M-return>") [C-M-return]))
+
+ ;; Error.
+ (should-error (kbd "C-xx"))
+ (should-error (kbd "M-xx"))
+ (should-error (kbd "M-x<TAB>"))
+
+ ;; These should be equivalent:
+ (should (equal (kbd "\C-xf") (kbd "C-x f"))))
+
+(ert-deftest subr-test-key-valid-p ()
+ (should (not (key-valid-p "")))
+ (should (key-valid-p "f"))
+ (should (key-valid-p "X"))
+ (should (not (key-valid-p " X")))
+ (should (key-valid-p "X f"))
+ (should (not (key-valid-p "a b")))
+ (should (not (key-valid-p "foobar")))
+ (should (not (key-valid-p "return")))
+
+ (should (key-valid-p "<F2>"))
+ (should (key-valid-p "<f1> <f2> TAB"))
+ (should (key-valid-p "<f1> RET"))
+ (should (key-valid-p "<f1> SPC"))
+ (should (key-valid-p "<f1>"))
+ (should (not (key-valid-p "[f1]")))
+ (should (key-valid-p "<return>"))
+ (should (not (key-valid-p "< right >")))
+
+ ;; Modifiers:
+ (should (key-valid-p "C-x"))
+ (should (key-valid-p "C-x a"))
+ (should (key-valid-p "C-;"))
+ (should (key-valid-p "C-a"))
+ (should (key-valid-p "C-c SPC"))
+ (should (key-valid-p "C-c TAB"))
+ (should (key-valid-p "C-c c"))
+ (should (key-valid-p "C-x 4 C-f"))
+ (should (key-valid-p "C-x C-f"))
+ (should (key-valid-p "C-M-<down>"))
+ (should (not (key-valid-p "<C-M-down>")))
+ (should (key-valid-p "C-RET"))
+ (should (key-valid-p "C-SPC"))
+ (should (key-valid-p "C-TAB"))
+ (should (key-valid-p "C-<down>"))
+ (should (key-valid-p "C-c C-c C-c"))
+
+ (should (key-valid-p "M-a"))
+ (should (key-valid-p "M-<DEL>"))
+ (should (not (key-valid-p "M-C-a")))
+ (should (key-valid-p "C-M-a"))
+ (should (key-valid-p "M-ESC"))
+ (should (key-valid-p "M-RET"))
+ (should (key-valid-p "M-SPC"))
+ (should (key-valid-p "M-TAB"))
+ (should (key-valid-p "M-x a"))
+ (should (key-valid-p "M-<up>"))
+ (should (key-valid-p "M-c M-c M-c"))
+
+ (should (key-valid-p "s-SPC"))
+ (should (key-valid-p "s-a"))
+ (should (key-valid-p "s-x a"))
+ (should (key-valid-p "s-c s-c s-c"))
+
+ (should (not (key-valid-p "S-H-a")))
+ (should (key-valid-p "S-a"))
+ (should (key-valid-p "S-x a"))
+ (should (key-valid-p "S-c S-c S-c"))
+
+ (should (key-valid-p "H-<RET>"))
+ (should (key-valid-p "H-DEL"))
+ (should (key-valid-p "H-a"))
+ (should (key-valid-p "H-x a"))
+ (should (key-valid-p "H-c H-c H-c"))
+
+ (should (key-valid-p "A-H-a"))
+ (should (key-valid-p "A-SPC"))
+ (should (key-valid-p "A-TAB"))
+ (should (key-valid-p "A-a"))
+ (should (key-valid-p "A-c A-c A-c"))
+
+ (should (key-valid-p "C-M-a"))
+ (should (key-valid-p "C-M-<up>"))
+
+ ;; Special characters.
+ (should (key-valid-p "DEL"))
+ (should (key-valid-p "ESC C-a"))
+ (should (key-valid-p "ESC"))
+ (should (key-valid-p "LFD"))
+ (should (key-valid-p "NUL"))
+ (should (key-valid-p "RET"))
+ (should (key-valid-p "SPC"))
+ (should (key-valid-p "TAB"))
+ (should (not (key-valid-p "\^i")))
+ (should (not (key-valid-p "^M")))
+
+ ;; With numbers.
+ (should (not (key-valid-p "\177")))
+ (should (not (key-valid-p "\000")))
+ (should (not (key-valid-p "\\177")))
+ (should (not (key-valid-p "\\000")))
+ (should (not (key-valid-p "C-x \\150")))
+
+ ;; Multibyte
+ (should (key-valid-p "ñ"))
+ (should (key-valid-p "ü"))
+ (should (key-valid-p "ö"))
+ (should (key-valid-p "ğ"))
+ (should (key-valid-p "ա"))
+ (should (not (key-valid-p "üüöö")))
+ (should (key-valid-p "C-ü"))
+ (should (key-valid-p "M-ü"))
+ (should (key-valid-p "H-ü"))
+
+ ;; Handle both new and old style key descriptions (bug#45536).
+ (should (key-valid-p "s-<return>"))
+ (should (not (key-valid-p "<s-return>")))
+ (should (key-valid-p "C-M-<return>"))
+ (should (not (key-valid-p "<C-M-return>")))
+
+ (should (key-valid-p "<mouse-1>"))
+ (should (key-valid-p "<Scroll_Lock>"))
+
+ (should (not (key-valid-p "c-x")))
+ (should (not (key-valid-p "C-xx")))
+ (should (not (key-valid-p "M-xx")))
+ (should (not (key-valid-p "M-x<TAB>"))))
(ert-deftest subr-test-define-prefix-command ()
(define-prefix-command 'foo-prefix-map)
@@ -390,12 +611,13 @@ indirectly `mapbacktrace'."
(ert-deftest subr-tests--dolist--wrong-number-of-args ()
"Test that `dolist' doesn't accept wrong types or length of SPEC,
cf. Bug#25477."
- (should-error (eval '(dolist (a)))
- :type 'wrong-number-of-arguments)
- (should-error (eval '(dolist (a () 'result 'invalid)) t)
- :type 'wrong-number-of-arguments)
- (should-error (eval '(dolist "foo") t)
- :type 'wrong-type-argument))
+ (dolist (lb '(nil t))
+ (should-error (eval '(dolist (a)) lb)
+ :type 'wrong-number-of-arguments)
+ (should-error (eval '(dolist (a () 'result 'invalid)) lb)
+ :type 'wrong-number-of-arguments)
+ (should-error (eval '(dolist "foo") lb)
+ :type 'wrong-type-argument)))
(ert-deftest subr-tests-bug22027 ()
"Test for https://debbugs.gnu.org/22027 ."
@@ -704,6 +926,7 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350."
(should-not (apropos-internal "^next-line$" #'keymapp)))
+(defvar test-global-boundp)
(ert-deftest test-buffer-local-boundp ()
(let ((buf (generate-new-buffer "boundp")))
(with-current-buffer buf
@@ -776,7 +999,8 @@ mode runs the hook ‘foo-bar-baz-very-long-name-indeed-mode-hook’, as the fin
or penultimate step during initialization."))
"In addition to any hooks its parent mode might have run, this mode
runs the hook ‘foo-bar-baz-very-long-name-indeed-mode-hook’, as the
-final or penultimate step during initialization.")))
+final or penultimate step during initialization."))
+ (should-error (internal--format-docstring-line "foo\nbar")))
(ert-deftest test-ensure-list ()
(should (equal (ensure-list nil) nil))
diff --git a/test/lisp/tar-mode-tests.el b/test/lisp/tar-mode-tests.el
index 6964d423185..2e0d1529a57 100644
--- a/test/lisp/tar-mode-tests.el
+++ b/test/lisp/tar-mode-tests.el
@@ -32,7 +32,8 @@
(cons 1024 "-----S---")
(cons 2048 "--S------"))))
(dolist (x alist)
- (should (equal (cdr x) (tar-grind-file-mode (car x)))))))
+ (with-suppressed-warnings ((obsolete tar-grind-file-mode))
+ (should (equal (cdr x) (tar-grind-file-mode (car x))))))))
(ert-deftest tar-mode-test-tar-extract-gz ()
(skip-unless (executable-find "gzip"))
diff --git a/test/lisp/term-tests.el b/test/lisp/term-tests.el
index 96b6d734882..73d39cf3b66 100644
--- a/test/lisp/term-tests.el
+++ b/test/lisp/term-tests.el
@@ -42,36 +42,50 @@
`( :foreground "unspecified-fg"
:background ,(face-background 'term-color-bright-yellow nil 'default)
:inverse-video nil))
+(defvar custom-color-fg-props
+ `( :foreground "#87FFFF"
+ :background "unspecified-bg" :inverse-video nil))
(defvar ansi-test-strings
`(("\e[33mHello World\e[0m"
- ,(propertize "Hello World" 'font-lock-face yellow-fg-props))
+ ,(propertize "Hello World" 'font-lock-face `(,yellow-fg-props)))
("\e[43mHello World\e[0m"
- ,(propertize "Hello World" 'font-lock-face yellow-bg-props))
+ ,(propertize "Hello World" 'font-lock-face `(,yellow-bg-props)))
("\e[93mHello World\e[0m"
- ,(propertize "Hello World" 'font-lock-face bright-yellow-fg-props))
+ ,(propertize "Hello World" 'font-lock-face `(,bright-yellow-fg-props)))
("\e[103mHello World\e[0m"
- ,(propertize "Hello World" 'font-lock-face bright-yellow-bg-props))
+ ,(propertize "Hello World" 'font-lock-face `(,bright-yellow-bg-props)))
("\e[1;33mHello World\e[0m"
,(propertize "Hello World" 'font-lock-face
- `(,yellow-fg-props :inherit term-bold))
+ `(,yellow-fg-props term-bold))
,(propertize "Hello World" 'font-lock-face
- `(,bright-yellow-fg-props :inherit term-bold)))
+ `(,bright-yellow-fg-props term-bold)))
("\e[33;1mHello World\e[0m"
,(propertize "Hello World" 'font-lock-face
- `(,yellow-fg-props :inherit term-bold))
+ `(,yellow-fg-props term-bold))
,(propertize "Hello World" 'font-lock-face
- `(,bright-yellow-fg-props :inherit term-bold)))
+ `(,bright-yellow-fg-props term-bold)))
("\e[1m\e[33mHello World\e[0m"
,(propertize "Hello World" 'font-lock-face
- `(,yellow-fg-props :inherit term-bold))
+ `(,yellow-fg-props term-bold))
,(propertize "Hello World" 'font-lock-face
- `(,bright-yellow-fg-props :inherit term-bold)))
+ `(,bright-yellow-fg-props term-bold)))
("\e[33m\e[1mHello World\e[0m"
,(propertize "Hello World" 'font-lock-face
- `(,yellow-fg-props :inherit term-bold))
+ `(,yellow-fg-props term-bold))
+ ,(propertize "Hello World" 'font-lock-face
+ `(,bright-yellow-fg-props term-bold)))
+ ("\e[38;5;3;1mHello World\e[0m"
+ ,(propertize "Hello World" 'font-lock-face
+ `(,yellow-fg-props term-bold))
+ ,(propertize "Hello World" 'font-lock-face
+ `(,bright-yellow-fg-props term-bold)))
+ ("\e[38;5;123;1mHello World\e[0m"
+ ,(propertize "Hello World" 'font-lock-face
+ `(,custom-color-fg-props term-bold)))
+ ("\e[38;2;135;255;255;1mHello World\e[0m"
,(propertize "Hello World" 'font-lock-face
- `(,bright-yellow-fg-props :inherit term-bold)))))
+ `(,custom-color-fg-props term-bold)))))
(defun term-test-screen-from-input (width height input &optional return-var)
(with-temp-buffer
diff --git a/test/lisp/textmodes/fill-tests.el b/test/lisp/textmodes/fill-tests.el
index fcc2c757091..2a1195b87ea 100644
--- a/test/lisp/textmodes/fill-tests.el
+++ b/test/lisp/textmodes/fill-tests.el
@@ -76,6 +76,28 @@
(buffer-string)
"aaa = baaaaaaaa aaaaaaaaaa\n aaaaaaaaaa\n")))))
+(ert-deftest test-fill-end-period ()
+ (should
+ (equal
+ (with-temp-buffer
+ (text-mode)
+ (auto-fill-mode)
+ (insert "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius.")
+ (self-insert-command 1 ?\s)
+ (buffer-string))
+ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius. "))
+ (should
+ (equal
+ (with-temp-buffer
+ (text-mode)
+ (auto-fill-mode)
+ (insert "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius.Foo")
+ (forward-char -3)
+ (self-insert-command 1 ?\s)
+ (buffer-string))
+ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do
+eius. Foo")))
+
(provide 'fill-tests)
;;; fill-tests.el ends here
diff --git a/test/lisp/textmodes/reftex-tests.el b/test/lisp/textmodes/reftex-tests.el
index b824e05f6d5..cc5b23e1c9c 100644
--- a/test/lisp/textmodes/reftex-tests.el
+++ b/test/lisp/textmodes/reftex-tests.el
@@ -24,6 +24,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
;;; reftex
(require 'reftex)
@@ -33,32 +34,31 @@
(ert-deftest reftex-locate-bibliography-files ()
"Test `reftex-locate-bibliography-files'."
- (let ((temp-dir (make-temp-file "reftex-bib" 'dir))
- (files '("ref1.bib" "ref2.bib"))
- (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib"))
- ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib"))
- ("\\begin{document}\n\\bibliographystyle{plain}\n
+ (ert-with-temp-directory temp-dir
+ (let ((files '("ref1.bib" "ref2.bib"))
+ (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib"))
+ ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib"))
+ ("\\begin{document}\n\\bibliographystyle{plain}\n
\\bibliography{ref1,ref2}\n\\end{document}" . ("ref1.bib" "ref2.bib"))))
- (reftex-bibliography-commands
- ;; Default value: See reftex-vars.el `reftex-bibliography-commands'
- '("bibliography" "nobibliography" "setupbibtex\\[.*?database="
- "addbibresource")))
- (with-temp-buffer
- (insert "test\n")
+ (reftex-bibliography-commands
+ ;; Default value: See reftex-vars.el `reftex-bibliography-commands'
+ '("bibliography" "nobibliography" "setupbibtex\\[.*?database="
+ "addbibresource")))
+ (with-temp-buffer
+ (insert "test\n")
+ (mapc
+ (lambda (file)
+ (write-region (point-min) (point-max) (expand-file-name file
+ temp-dir)))
+ files))
(mapc
- (lambda (file)
- (write-region (point-min) (point-max) (expand-file-name file
- temp-dir)))
- files))
- (mapc
- (lambda (data)
- (with-temp-buffer
- (insert (car data))
- (let ((res (mapcar #'file-name-nondirectory
- (reftex-locate-bibliography-files temp-dir))))
- (should (equal res (cdr data))))))
- test)
- (delete-directory temp-dir 'recursive)))
+ (lambda (data)
+ (with-temp-buffer
+ (insert (car data))
+ (let ((res (mapcar #'file-name-nondirectory
+ (reftex-locate-bibliography-files temp-dir))))
+ (should (equal res (cdr data))))))
+ test))))
(ert-deftest reftex-what-environment-test ()
"Test `reftex-what-environment'."
@@ -102,12 +102,12 @@
;; reason. (An alternative solution would be to use file-equal-p,
;; but I'm too lazy to do that, as one of the tests compares a
;; list.)
- (let* ((temp-dir (file-truename (make-temp-file "reftex-parse" 'dir)))
- (tex-file (expand-file-name "test.tex" temp-dir))
- (bib-file (expand-file-name "ref.bib" temp-dir)))
- (with-temp-buffer
- (insert
-"\\begin{document}
+ (ert-with-temp-directory temp-dir
+ (let* ((tex-file (expand-file-name "test.tex" temp-dir))
+ (bib-file (expand-file-name "ref.bib" temp-dir)))
+ (with-temp-buffer
+ (insert
+ "\\begin{document}
\\section{test}\\label{sec:test}
\\subsection{subtest}
@@ -118,27 +118,26 @@
\\bibliographystyle{plain}
\\bibliography{ref}
\\end{document}")
- (write-region (point-min) (point-max) tex-file))
- (with-temp-buffer
- (insert "test\n")
- (write-region (point-min) (point-max) bib-file))
- (reftex-ensure-compiled-variables)
- (let ((parsed (reftex-parse-from-file tex-file nil temp-dir)))
- (should (equal (car parsed) `(eof ,tex-file)))
- (pop parsed)
- (while parsed
- (let ((entry (pop parsed)))
- (cond
- ((eq (car entry) 'bib)
- (should (string= (cadr entry) bib-file)))
- ((eq (car entry) 'toc)) ;; ...
- ((string= (car entry) "eq:foo"))
- ((string= (car entry) "sec:test"))
- ((eq (car entry) 'bof)
- (should (string= (cadr entry) tex-file))
- (should (null parsed)))
- (t (should-not t)))))
- (delete-directory temp-dir 'recursive))))
+ (write-region (point-min) (point-max) tex-file))
+ (with-temp-buffer
+ (insert "test\n")
+ (write-region (point-min) (point-max) bib-file))
+ (reftex-ensure-compiled-variables)
+ (let ((parsed (reftex-parse-from-file tex-file nil temp-dir)))
+ (should (equal (car parsed) `(eof ,tex-file)))
+ (pop parsed)
+ (while parsed
+ (let ((entry (pop parsed)))
+ (cond
+ ((eq (car entry) 'bib)
+ (should (string= (cadr entry) bib-file)))
+ ((eq (car entry) 'toc)) ;; ...
+ ((string= (car entry) "eq:foo"))
+ ((string= (car entry) "sec:test"))
+ ((eq (car entry) 'bof)
+ (should (string= (cadr entry) tex-file))
+ (should (null parsed)))
+ (t (should-not t)))))))))
;;; reftex-cite
(require 'reftex-cite)
diff --git a/test/lisp/textmodes/texinfo-resources/fill.erts b/test/lisp/textmodes/texinfo-resources/fill.erts
new file mode 100644
index 00000000000..95f3b09eba8
--- /dev/null
+++ b/test/lisp/textmodes/texinfo-resources/fill.erts
@@ -0,0 +1,70 @@
+Code:
+ (lambda ()
+ (texinfo-mode)
+ (fill-paragraph))
+
+Name: fill1
+Point-Char: |
+
+=-=
+@noindent Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed.
+=-=
+@noindent Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+=-=-=
+
+Name: fill2
+Point-Char: |
+
+=-=
+@cindex relative| remapping, faces
+@cindex base remapping, faces
+ The following functions implement a higher-level interface to @code{face-remapping-alist}.
+=-=-=
+
+
+Name: fill3
+Point-Char: |
+
+=-=
+@cindex relative remapping, faces
+@cindex base remapping, faces|
+ The following functions implement a higher-level interface to @code{face-remapping-alist}.
+=-=-=
+
+Name: fill4
+Point-Char: |
+
+=-=
+@cindex relative remapping, faces
+@cindex base remapping, faces
+ The following functions| implement a higher-level interface to @code{face-remapping-alist}.
+=-=
+@cindex relative remapping, faces
+@cindex base remapping, faces
+ The following functions| implement a higher-level interface to
+@code{face-remapping-alist}.
+=-=-=
+
+Name: fill5
+Point-Char: |
+
+=-=
+@defun face-remap-add-relative face &rest specs
+|This function adds the face spec in @var{specs} as relative
+remappings for face @var{face} in the current buffer. The remaining
+arguments, @var{specs}, should form either a list of face names, or a
+property list of attribute/value pairs.
+=-=
+@defun face-remap-add-relative face &rest specs
+This function adds the face spec in @var{specs} as relative remappings
+for face @var{face} in the current buffer. The remaining arguments,
+@var{specs}, should form either a list of face names, or a property
+list of attribute/value pairs.
+=-=-=
+
+Name: fill6
+
+=-=
+@subsection This is a very very very very very very very very very very long subsection name
+=-=-=
diff --git a/test/lisp/textmodes/texinfo-tests.el b/test/lisp/textmodes/texinfo-tests.el
new file mode 100644
index 00000000000..fa0c4de005e
--- /dev/null
+++ b/test/lisp/textmodes/texinfo-tests.el
@@ -0,0 +1,33 @@
+;;; texinfo-tests.el --- Tests for texinfo.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 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 'texinfo)
+(require 'ert)
+(require 'ert-x)
+
+(ert-deftest test-filling ()
+ (ert-test-erts-file (ert-resource-file "fill.erts")))
+
+;;; texinfo-tests.el ends here
diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el
index 2a32dc57b1c..f2031fa79ab 100644
--- a/test/lisp/thingatpt-tests.el
+++ b/test/lisp/thingatpt-tests.el
@@ -170,21 +170,13 @@ position to retrieve THING.")
(forward-char -1)
(should (eq (symbol-at-point) 'bar))))
-(ert-deftest test-symbol-thing-2 ()
- (with-temp-buffer
- (insert " bar ")
- (goto-char (point-max))
- (should (eq (symbol-at-point) nil))
- (forward-char -1)
- (should (eq (symbol-at-point) 'bar))))
-
(ert-deftest test-symbol-thing-3 ()
(with-temp-buffer
(insert "bar")
(goto-char 2)
(should (eq (symbol-at-point) 'bar))))
-(ert-deftest test-symbol-thing-3 ()
+(ert-deftest test-symbol-thing-4 ()
(with-temp-buffer
(insert "`[[`(")
(goto-char 2)
diff --git a/test/lisp/thumbs-tests.el b/test/lisp/thumbs-tests.el
index ee096138453..a9b41d7c00f 100644
--- a/test/lisp/thumbs-tests.el
+++ b/test/lisp/thumbs-tests.el
@@ -20,15 +20,13 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'thumbs)
(ert-deftest thumbs-tests-thumbsdir/create-if-missing ()
- (let ((thumbs-thumbsdir (make-temp-file "thumbs-test" t)))
- (unwind-protect
- (progn
- (delete-directory thumbs-thumbsdir)
- (should (file-directory-p (thumbs-thumbsdir))))
- (delete-directory thumbs-thumbsdir))))
+ (ert-with-temp-directory thumbs-thumbsdir
+ (delete-directory thumbs-thumbsdir)
+ (should (file-directory-p (thumbs-thumbsdir)))))
(provide 'thumbs-tests)
;;; thumbs-tests.el ends here
diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el
index cb446eb486e..a049e5de58a 100644
--- a/test/lisp/time-stamp-tests.el
+++ b/test/lisp/time-stamp-tests.el
@@ -595,8 +595,12 @@
;; incorrectly nested parens do not crash us
(should-not (equal (time-stamp-string "%(stuffB" ref-time3) May))
(should-not (equal (time-stamp-string "%)B" ref-time3) May))
+ ;; unterminated format does not crash us
+ (should-not (equal (time-stamp-string "%" ref-time3) May))
;; not all punctuation is allowed
- (should-not (equal (time-stamp-string "%&B" ref-time3) May)))))
+ (should-not (equal (time-stamp-string "%&B" ref-time3) May))
+ (should-not (equal (time-stamp-string "%/B" ref-time3) May))
+ (should-not (equal (time-stamp-string "%;B" ref-time3) May)))))
(ert-deftest time-stamp-format-non-conversions ()
"Test that without a %, the text is copied literally."
@@ -635,8 +639,8 @@
(concat Mon "." Monday "." Mon)))
(should (equal (time-stamp-string "%5z.%5::z.%5z" ref-time1)
"+0000.+00:00:00.+0000"))
- ;; format letter is independent
- (should (equal (time-stamp-string "%H:%M" ref-time1) "15:04")))))
+ ;; format character is independent
+ (should (equal (time-stamp-string "%H:%M%%%S" ref-time1) "15:04%05")))))
(ert-deftest time-stamp-format-string-width ()
"Test time-stamp string width modifiers."
diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el
index ef19fe0e0e8..909d5620de6 100644
--- a/test/lisp/vc/diff-mode-tests.el
+++ b/test/lisp/vc/diff-mode-tests.el
@@ -173,35 +173,33 @@ wristwatches
wrongheadedly
wrongheadedness
youthfulness
-")
- (temp-dir (make-temp-file "diff-mode-test" 'dir)))
-
- (let ((buf (find-file-noselect (format "%s/%s" temp-dir "fil" )))
- (buf2 (find-file-noselect (format "%s/%s" temp-dir "fil2"))))
- (unwind-protect
- (progn
- (with-current-buffer buf (insert fil_before) (save-buffer))
- (with-current-buffer buf2 (insert fil2_before) (save-buffer))
-
- (with-temp-buffer
- (cd temp-dir)
- (insert patch)
- (goto-char (point-min))
- (diff-apply-hunk)
- (diff-apply-hunk)
- (diff-apply-hunk))
-
- (should (equal (with-current-buffer buf (buffer-string))
- fil_after))
- (should (equal (with-current-buffer buf2 (buffer-string))
- fil2_after)))
-
- (ignore-errors
- (with-current-buffer buf (set-buffer-modified-p nil))
- (kill-buffer buf)
- (with-current-buffer buf2 (set-buffer-modified-p nil))
- (kill-buffer buf2)
- (delete-directory temp-dir 'recursive))))))
+"))
+ (ert-with-temp-directory temp-dir
+ (let ((buf (find-file-noselect (format "%s/%s" temp-dir "fil" )))
+ (buf2 (find-file-noselect (format "%s/%s" temp-dir "fil2"))))
+ (unwind-protect
+ (progn
+ (with-current-buffer buf (insert fil_before) (save-buffer))
+ (with-current-buffer buf2 (insert fil2_before) (save-buffer))
+
+ (with-temp-buffer
+ (cd temp-dir)
+ (insert patch)
+ (goto-char (point-min))
+ (diff-apply-hunk)
+ (diff-apply-hunk)
+ (diff-apply-hunk))
+
+ (should (equal (with-current-buffer buf (buffer-string))
+ fil_after))
+ (should (equal (with-current-buffer buf2 (buffer-string))
+ fil2_after)))
+
+ (ignore-errors
+ (with-current-buffer buf (set-buffer-modified-p nil))
+ (kill-buffer buf)
+ (with-current-buffer buf2 (set-buffer-modified-p nil))
+ (kill-buffer buf2)))))))
(ert-deftest diff-mode-test-hunk-text-no-newline ()
"Check output of `diff-hunk-text' with no newline at end of file."
diff --git a/test/lisp/vc/ediff-ptch-tests.el b/test/lisp/vc/ediff-ptch-tests.el
index a464db2349d..0f09616a816 100644
--- a/test/lisp/vc/ediff-ptch-tests.el
+++ b/test/lisp/vc/ediff-ptch-tests.el
@@ -22,6 +22,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'ediff-ptch)
(ert-deftest ediff-ptch-test-bug25010 ()
@@ -45,34 +46,33 @@ index 6a07f80..6e8e947 100644
"Test for https://debbugs.gnu.org/26084 ."
(skip-unless (executable-find "git"))
(skip-unless (executable-find ediff-patch-program))
- (let* ((tmpdir (make-temp-file "ediff-ptch-test" t))
- (default-directory (file-name-as-directory tmpdir))
- (patch (make-temp-file "ediff-ptch-test"))
- (qux (expand-file-name "qux.txt" tmpdir))
- (bar (expand-file-name "bar.txt" tmpdir))
- (git-program (executable-find "git")))
- ;; Create repository.
- (with-temp-buffer
- (insert "qux here\n")
- (write-region nil nil qux nil 'silent)
- (erase-buffer)
- (insert "bar here\n")
- (write-region nil nil bar nil 'silent))
- (call-process git-program nil nil nil "init")
- (call-process git-program nil nil nil "add" ".")
- (call-process git-program nil nil nil "commit" "-m" "Test repository.")
- ;; Update repo., save the diff and reset to initial state.
- (with-temp-buffer
- (insert "foo here\n")
- (write-region nil nil qux nil 'silent)
- (write-region nil nil bar nil 'silent))
- (call-process git-program nil `(:file ,patch) nil "diff")
- (call-process git-program nil nil nil "reset" "--hard" "HEAD")
- ;; Visit the diff file i.e., patch; extract from it the parts
- ;; affecting just each of the files: store in patch-bar the part
- ;; affecting 'bar', and in patch-qux the part affecting 'qux'.
- (find-file patch)
- (unwind-protect
+ (ert-with-temp-directory tmpdir
+ (ert-with-temp-file patch
+ (let* ((default-directory (file-name-as-directory tmpdir))
+ (qux (expand-file-name "qux.txt" tmpdir))
+ (bar (expand-file-name "bar.txt" tmpdir))
+ (git-program (executable-find "git")))
+ ;; Create repository.
+ (with-temp-buffer
+ (insert "qux here\n")
+ (write-region nil nil qux nil 'silent)
+ (erase-buffer)
+ (insert "bar here\n")
+ (write-region nil nil bar nil 'silent))
+ (call-process git-program nil nil nil "init")
+ (call-process git-program nil nil nil "add" ".")
+ (call-process git-program nil nil nil "commit" "-m" "Test repository.")
+ ;; Update repo., save the diff and reset to initial state.
+ (with-temp-buffer
+ (insert "foo here\n")
+ (write-region nil nil qux nil 'silent)
+ (write-region nil nil bar nil 'silent))
+ (call-process git-program nil `(:file ,patch) nil "diff")
+ (call-process git-program nil nil nil "reset" "--hard" "HEAD")
+ ;; Visit the diff file i.e., patch; extract from it the parts
+ ;; affecting just each of the files: store in patch-bar the part
+ ;; affecting 'bar', and in patch-qux the part affecting 'qux'.
+ (find-file patch)
(let* ((info
(progn (ediff-map-patch-buffer (current-buffer)) ediff-patch-map))
(patch-bar
@@ -116,9 +116,7 @@ index 6a07f80..6e8e947 100644
(buffer-string))
(with-temp-buffer
(insert-file-contents backup)
- (buffer-string)))))))
- (delete-directory tmpdir 'recursive)
- (delete-file patch)))))
+ (buffer-string))))))))))))
(provide 'ediff-ptch-tests)
diff --git a/test/lisp/vc/vc-bzr-tests.el b/test/lisp/vc/vc-bzr-tests.el
index 43385de5955..afced819fbc 100644
--- a/test/lisp/vc/vc-bzr-tests.el
+++ b/test/lisp/vc/vc-bzr-tests.el
@@ -25,6 +25,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'vc-bzr)
(require 'vc-dir)
@@ -51,106 +52,97 @@
;; temporary directory.
;; TODO does this means tests should be setting XDG_ variables (not
;; just HOME) to temporary values too?
- (let* ((homedir (make-temp-file "vc-bzr-test" t))
- (bzrdir (expand-file-name "bzr" homedir))
- (ignored-dir (progn
- (make-directory bzrdir)
- (expand-file-name "ignored-dir" bzrdir)))
- (default-directory (file-name-as-directory bzrdir))
- (process-environment (cons (format "HOME=%s" homedir)
- process-environment)))
- (unwind-protect
- (progn
- (make-directory ignored-dir)
- (with-temp-buffer
- (insert (file-name-nondirectory ignored-dir))
- (write-region nil nil (expand-file-name ".bzrignore" bzrdir)
- nil 'silent))
- (skip-unless (eq 0 ; some internal bzr error
- (call-process vc-bzr-program nil nil nil "init")))
- (call-process vc-bzr-program nil nil nil "add")
- (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1")
- (with-temp-buffer
- (insert "unregistered file")
- (write-region nil nil (expand-file-name "testfile2" ignored-dir)
- nil 'silent))
- (vc-dir ignored-dir)
- (while (vc-dir-busy)
- (sit-for 0.1))
- ;; FIXME better to explicitly test for error from process sentinel.
- (with-current-buffer "*vc-dir*"
- (goto-char (point-min))
- (should (search-forward "unregistered" nil t))))
- (delete-directory homedir t))))
+ (ert-with-temp-directory homedir
+ (let* ((bzrdir (expand-file-name "bzr" homedir))
+ (ignored-dir (progn
+ (make-directory bzrdir)
+ (expand-file-name "ignored-dir" bzrdir)))
+ (default-directory (file-name-as-directory bzrdir))
+ (process-environment (cons (format "HOME=%s" homedir)
+ process-environment)))
+ (make-directory ignored-dir)
+ (with-temp-buffer
+ (insert (file-name-nondirectory ignored-dir))
+ (write-region nil nil (expand-file-name ".bzrignore" bzrdir)
+ nil 'silent))
+ (skip-unless (eq 0 ; some internal bzr error
+ (call-process vc-bzr-program nil nil nil "init")))
+ (call-process vc-bzr-program nil nil nil "add")
+ (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1")
+ (with-temp-buffer
+ (insert "unregistered file")
+ (write-region nil nil (expand-file-name "testfile2" ignored-dir)
+ nil 'silent))
+ (vc-dir ignored-dir)
+ (while (vc-dir-busy)
+ (sit-for 0.1))
+ ;; FIXME better to explicitly test for error from process sentinel.
+ (with-current-buffer "*vc-dir*"
+ (goto-char (point-min))
+ (should (search-forward "unregistered" nil t))))))
;; Not specific to bzr.
(ert-deftest vc-bzr-test-bug9781 ()
"Test for https://debbugs.gnu.org/9781 ."
(skip-unless (executable-find vc-bzr-program))
- (let* ((homedir (make-temp-file "vc-bzr-test" t))
- (bzrdir (expand-file-name "bzr" homedir))
- (subdir (progn
- (make-directory bzrdir)
- (expand-file-name "subdir" bzrdir)))
- (file (expand-file-name "file" bzrdir))
- (default-directory (file-name-as-directory bzrdir))
- (process-environment (cons (format "HOME=%s" homedir)
- process-environment)))
- (unwind-protect
- (progn
- (skip-unless (eq 0 ; some internal bzr error
- (call-process vc-bzr-program nil nil nil "init")))
- (make-directory subdir)
- (with-temp-buffer
- (insert "text")
- (write-region nil nil file nil 'silent)
- (write-region nil nil (expand-file-name "subfile" subdir)
- nil 'silent))
- (call-process vc-bzr-program nil nil nil "add")
- (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1")
- (call-process vc-bzr-program nil nil nil "remove" subdir)
- (with-temp-buffer
- (insert "different text")
- (write-region nil nil file nil 'silent))
- (vc-dir bzrdir)
- (while (vc-dir-busy)
- (sit-for 0.1))
- (vc-dir-mark-all-files t)
- (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) t)))
- (vc-next-action nil))
- (should (get-buffer "*vc-log*")))
- (delete-directory homedir t))))
+ (ert-with-temp-directory homedir
+ (let* ((bzrdir (expand-file-name "bzr" homedir))
+ (subdir (progn
+ (make-directory bzrdir)
+ (expand-file-name "subdir" bzrdir)))
+ (file (expand-file-name "file" bzrdir))
+ (default-directory (file-name-as-directory bzrdir))
+ (process-environment (cons (format "HOME=%s" homedir)
+ process-environment)))
+ (skip-unless (eq 0 ; some internal bzr error
+ (call-process vc-bzr-program nil nil nil "init")))
+ (make-directory subdir)
+ (with-temp-buffer
+ (insert "text")
+ (write-region nil nil file nil 'silent)
+ (write-region nil nil (expand-file-name "subfile" subdir)
+ nil 'silent))
+ (call-process vc-bzr-program nil nil nil "add")
+ (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1")
+ (call-process vc-bzr-program nil nil nil "remove" subdir)
+ (with-temp-buffer
+ (insert "different text")
+ (write-region nil nil file nil 'silent))
+ (vc-dir bzrdir)
+ (while (vc-dir-busy)
+ (sit-for 0.1))
+ (vc-dir-mark-all-files t)
+ (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) t)))
+ (vc-next-action nil))
+ (should (get-buffer "*vc-log*")))))
;; https://lists.gnu.org/r/help-gnu-emacs/2012-04/msg00145.html
(ert-deftest vc-bzr-test-faulty-bzr-autoloads ()
"Test we can generate autoloads in a bzr directory when bzr is faulty."
(skip-unless (executable-find vc-bzr-program))
- (let* ((homedir (make-temp-file "vc-bzr-test" t))
- (bzrdir (expand-file-name "bzr" homedir))
- (file (progn
- (make-directory bzrdir)
- (expand-file-name "foo.el" bzrdir)))
- (default-directory (file-name-as-directory bzrdir))
- (process-environment (cons (format "HOME=%s" homedir)
- process-environment)))
- (unwind-protect
- (progn
- (call-process vc-bzr-program nil nil nil "init")
- (with-temp-buffer
- (insert ";;;###autoload
+ (ert-with-temp-directory homedir
+ (let* ((bzrdir (expand-file-name "bzr" homedir))
+ (file (progn
+ (make-directory bzrdir)
+ (expand-file-name "foo.el" bzrdir)))
+ (default-directory (file-name-as-directory bzrdir))
+ (process-environment (cons (format "HOME=%s" homedir)
+ process-environment)))
+ (call-process vc-bzr-program nil nil nil "init")
+ (with-temp-buffer
+ (insert ";;;###autoload
\(defun foo () \"foo\" (interactive) (message \"foo!\"))")
- (write-region nil nil file nil 'silent))
- (call-process vc-bzr-program nil nil nil "add")
- (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1")
- ;; Deleting dirstate ensures both that vc-bzr's status heuristic
- ;; fails, so it has to call the external bzr status, and
- ;; causes bzr status to fail. This simulates a broken bzr
- ;; installation.
- (delete-file ".bzr/checkout/dirstate")
- (should (progn (make-directory-autoloads
- default-directory
- (expand-file-name "loaddefs.el" bzrdir))
- t)))
- (delete-directory homedir t))))
+ (write-region nil nil file nil 'silent))
+ (call-process vc-bzr-program nil nil nil "add")
+ (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1")
+ ;; Deleting dirstate ensures both that vc-bzr's status heuristic
+ ;; fails, so it has to call the external bzr status, and
+ ;; causes bzr status to fail. This simulates a broken bzr
+ ;; installation.
+ (delete-file ".bzr/checkout/dirstate")
+ (should (progn (make-directory-autoloads
+ default-directory
+ (expand-file-name "loaddefs.el" bzrdir))
+ t)))))
;;; vc-bzr-tests.el ends here
diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el
new file mode 100644
index 00000000000..997ab3c4b5c
--- /dev/null
+++ b/test/lisp/vc/vc-git-tests.el
@@ -0,0 +1,67 @@
+;;; vc-git-tests.el --- tests for vc/vc-git.el -*- lexical-binding:t -*-
+
+;; Copyright (C) 2016-2021 Free Software Foundation, Inc.
+
+;; Author: Justin Schell <justinmschell@gmail.com>
+;; 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-git)
+
+(ert-deftest vc-git-test-program-version-general ()
+ (vc-git-test--run-program-version-test
+ "git version 2.30.1.0"
+ "2.30.1.0"))
+
+(ert-deftest vc-git-test-program-version-windows ()
+ (vc-git-test--run-program-version-test
+ "git version 2.30.1.1.windows.1"
+ "2.30.1.1"))
+
+(ert-deftest vc-git-test-program-version-apple ()
+ (vc-git-test--run-program-version-test
+ "git version 2.30.1.2 (Apple Git-130)"
+ "2.30.1.2"))
+
+(ert-deftest vc-git-test-program-version-other ()
+ (vc-git-test--run-program-version-test
+ "git version 2.30.1.3.foo.bar"
+ "2.30.1.3"))
+
+(ert-deftest vc-git-test-program-version-invalid-leading-string ()
+ (vc-git-test--run-program-version-test
+ "git version foo.bar.2.30.1.4"
+ "0"))
+
+(ert-deftest vc-git-test-program-version-invalid-leading-dot ()
+ (vc-git-test--run-program-version-test
+ "git version .2.30.1.5"
+ "0"))
+
+(defun vc-git-test--run-program-version-test
+ (mock-version-string expected-output)
+ (cl-letf* (((symbol-function 'vc-git--run-command-string)
+ (lambda (_file _args) mock-version-string))
+ (vc-git--program-version nil)
+ (actual-output (vc-git--program-version)))
+ (should (equal actual-output expected-output))))
+
+;;; vc-git-tests.el ends here
diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el
index aa401a23914..578d7ebb418 100644
--- a/test/lisp/vc/vc-tests.el
+++ b/test/lisp/vc/vc-tests.el
@@ -109,6 +109,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'vc)
(require 'log-edit)
@@ -178,41 +179,38 @@ For backends which dont support it, it is emulated."
(defun vc-test--create-repo (backend)
"Create a test repository in `default-directory', a temporary directory."
-
- (let ((vc-handled-backends `(,backend))
- (default-directory
- (file-name-as-directory
- (expand-file-name
- (make-temp-name "vc-test") temporary-file-directory)))
- (process-environment process-environment)
- tempdir
- vc-test--cleanup-hook)
- (when (eq backend 'Bzr)
- (setq tempdir (make-temp-file "vc-test--create-repo" t)
- process-environment (cons (format "BZR_HOME=%s" tempdir)
- process-environment)))
-
- (unwind-protect
- (progn
- ;; Cleanup.
- (add-hook
- 'vc-test--cleanup-hook
- `(lambda () (delete-directory ,default-directory 'recursive)))
-
- ;; Check the revision granularity.
- (should (memq (vc-test--revision-granularity-function backend)
- '(file repository)))
-
- ;; Create empty repository.
- (make-directory default-directory)
- (should (file-directory-p default-directory))
- (vc-test--create-repo-function backend)
- (should (eq (vc-responsible-backend default-directory) backend)))
-
- ;; Save exit.
- (ignore-errors
- (if tempdir (delete-directory tempdir t))
- (run-hooks 'vc-test--cleanup-hook)))))
+ (ert-with-temp-directory tempdir
+ (let ((vc-handled-backends `(,backend))
+ (default-directory
+ (file-name-as-directory
+ (expand-file-name
+ (make-temp-name "vc-test") temporary-file-directory)))
+ (process-environment process-environment)
+ vc-test--cleanup-hook)
+ (when (eq backend 'Bzr)
+ (setq process-environment (cons (format "BZR_HOME=%s" tempdir)
+ process-environment)))
+
+ (unwind-protect
+ (progn
+ ;; Cleanup.
+ (add-hook
+ 'vc-test--cleanup-hook
+ `(lambda () (delete-directory ,default-directory 'recursive)))
+
+ ;; Check the revision granularity.
+ (should (memq (vc-test--revision-granularity-function backend)
+ '(file repository)))
+
+ ;; Create empty repository.
+ (make-directory default-directory)
+ (should (file-directory-p default-directory))
+ (vc-test--create-repo-function backend)
+ (should (eq (vc-responsible-backend default-directory) backend)))
+
+ ;; Save exit.
+ (ignore-errors
+ (run-hooks 'vc-test--cleanup-hook))))))
;; FIXME: Why isn't there `vc-unregister'?
(defun vc-test--unregister-function (backend file)
@@ -235,447 +233,429 @@ Catch the `vc-not-supported' error."
(defun vc-test--register (backend)
"Register and unregister a file.
This checks also `vc-backend' and `vc-responsible-backend'."
-
- (let ((vc-handled-backends `(,backend))
- (default-directory
- (file-name-as-directory
- (expand-file-name
- (make-temp-name "vc-test") temporary-file-directory)))
- (process-environment process-environment)
- tempdir
- vc-test--cleanup-hook)
- (when (eq backend 'Bzr)
- (setq tempdir (make-temp-file "vc-test--register" t)
- process-environment (cons (format "BZR_HOME=%s" tempdir)
- process-environment)))
- (unwind-protect
- (progn
- ;; Cleanup.
- (add-hook
- 'vc-test--cleanup-hook
- `(lambda () (delete-directory ,default-directory 'recursive)))
-
- ;; Create empty repository.
- (make-directory default-directory)
- (vc-test--create-repo-function backend)
- ;; For file oriented backends CVS, RCS and SVN the backend is
- ;; returned, and the directory is registered already.
- (should (if (vc-backend default-directory)
- (vc-registered default-directory)
- (not (vc-registered default-directory))))
- (should (eq (vc-responsible-backend default-directory) backend))
-
- (let ((tmp-name1 (expand-file-name "foo" default-directory))
- (tmp-name2 "bla"))
- ;; Register files. Check for it.
- (write-region "foo" nil tmp-name1 nil 'nomessage)
- (should (file-exists-p tmp-name1))
- (should-not (vc-backend tmp-name1))
- (should (eq (vc-responsible-backend tmp-name1) backend))
- (should-not (vc-registered tmp-name1))
-
- (write-region "bla" nil tmp-name2 nil 'nomessage)
- (should (file-exists-p tmp-name2))
- (should-not (vc-backend tmp-name2))
- (should (eq (vc-responsible-backend tmp-name2) backend))
- (should-not (vc-registered tmp-name2))
-
- (vc-register (list backend (list tmp-name1 tmp-name2)))
- (should (file-exists-p tmp-name1))
- (should (eq (vc-backend tmp-name1) backend))
- (should (eq (vc-responsible-backend tmp-name1) backend))
- (should (vc-registered tmp-name1))
-
- (should (file-exists-p tmp-name2))
- (should (eq (vc-backend tmp-name2) backend))
- (should (eq (vc-responsible-backend tmp-name2) backend))
- (should (vc-registered tmp-name2))
-
- ;; `vc-backend' accepts also a list of files,
- ;; `vc-responsible-backend' doesn't.
- (should (vc-backend (list tmp-name1 tmp-name2)))
-
- ;; Unregister the files.
- (unless (eq (vc-test--run-maybe-unsupported-function
- 'vc-test--unregister-function backend tmp-name1)
- 'vc-not-supported)
+ (ert-with-temp-directory tempdir
+ (let ((vc-handled-backends `(,backend))
+ (default-directory
+ (file-name-as-directory
+ (expand-file-name
+ (make-temp-name "vc-test") temporary-file-directory)))
+ (process-environment process-environment)
+ vc-test--cleanup-hook)
+ (when (eq backend 'Bzr)
+ (setq process-environment (cons (format "BZR_HOME=%s" tempdir)
+ process-environment)))
+ (unwind-protect
+ (progn
+ ;; Cleanup.
+ (add-hook
+ 'vc-test--cleanup-hook
+ `(lambda () (delete-directory ,default-directory 'recursive)))
+
+ ;; Create empty repository.
+ (make-directory default-directory)
+ (vc-test--create-repo-function backend)
+ ;; For file oriented backends CVS, RCS and SVN the backend is
+ ;; returned, and the directory is registered already.
+ (should (if (vc-backend default-directory)
+ (vc-registered default-directory)
+ (not (vc-registered default-directory))))
+ (should (eq (vc-responsible-backend default-directory) backend))
+
+ (let ((tmp-name1 (expand-file-name "foo" default-directory))
+ (tmp-name2 "bla"))
+ ;; Register files. Check for it.
+ (write-region "foo" nil tmp-name1 nil 'nomessage)
+ (should (file-exists-p tmp-name1))
(should-not (vc-backend tmp-name1))
- (should-not (vc-registered tmp-name1)))
- (unless (eq (vc-test--run-maybe-unsupported-function
- 'vc-test--unregister-function backend tmp-name2)
- 'vc-not-supported)
- (should-not (vc-backend tmp-name2))
- (should-not (vc-registered tmp-name2)))
+ (should (eq (vc-responsible-backend tmp-name1) backend))
+ (should-not (vc-registered tmp-name1))
- ;; The files should still exist.
- (should (file-exists-p tmp-name1))
- (should (file-exists-p tmp-name2))))
-
- ;; Save exit.
- (ignore-errors
- (if tempdir (delete-directory tempdir t))
- (run-hooks 'vc-test--cleanup-hook)))))
+ (write-region "bla" nil tmp-name2 nil 'nomessage)
+ (should (file-exists-p tmp-name2))
+ (should-not (vc-backend tmp-name2))
+ (should (eq (vc-responsible-backend tmp-name2) backend))
+ (should-not (vc-registered tmp-name2))
+
+ (vc-register (list backend (list tmp-name1 tmp-name2)))
+ (should (file-exists-p tmp-name1))
+ (should (eq (vc-backend tmp-name1) backend))
+ (should (eq (vc-responsible-backend tmp-name1) backend))
+ (should (vc-registered tmp-name1))
+
+ (should (file-exists-p tmp-name2))
+ (should (eq (vc-backend tmp-name2) backend))
+ (should (eq (vc-responsible-backend tmp-name2) backend))
+ (should (vc-registered tmp-name2))
+
+ ;; `vc-backend' accepts also a list of files,
+ ;; `vc-responsible-backend' doesn't.
+ (should (vc-backend (list tmp-name1 tmp-name2)))
+
+ ;; Unregister the files.
+ (unless (eq (vc-test--run-maybe-unsupported-function
+ 'vc-test--unregister-function backend tmp-name1)
+ 'vc-not-supported)
+ (should-not (vc-backend tmp-name1))
+ (should-not (vc-registered tmp-name1)))
+ (unless (eq (vc-test--run-maybe-unsupported-function
+ 'vc-test--unregister-function backend tmp-name2)
+ 'vc-not-supported)
+ (should-not (vc-backend tmp-name2))
+ (should-not (vc-registered tmp-name2)))
+
+ ;; The files should still exist.
+ (should (file-exists-p tmp-name1))
+ (should (file-exists-p tmp-name2))))
+
+ ;; Save exit.
+ (ignore-errors
+ (run-hooks 'vc-test--cleanup-hook))))))
(defun vc-test--state (backend)
"Check the different states of a file."
-
- (let ((vc-handled-backends `(,backend))
- (default-directory
- (file-name-as-directory
- (expand-file-name
- (make-temp-name "vc-test") temporary-file-directory)))
- (process-environment process-environment)
- tempdir
- vc-test--cleanup-hook)
- (when (eq backend 'Bzr)
- (setq tempdir (make-temp-file "vc-test--state" t)
- process-environment (cons (format "BZR_HOME=%s" tempdir)
- process-environment)))
- (unwind-protect
- (progn
- ;; Cleanup.
- (add-hook
- 'vc-test--cleanup-hook
- `(lambda () (delete-directory ,default-directory 'recursive)))
-
- ;; Create empty repository.
- (make-directory default-directory)
- (vc-test--create-repo-function backend)
-
- (let ((tmp-name (expand-file-name "foo" default-directory)))
- ;; Check state of a nonexistent file.
-
- (message "vc-state2 %s" (vc-state tmp-name))
- (should (null (vc-state tmp-name)))
-
- ;; Write a new file. Check state.
- (write-region "foo" nil tmp-name nil 'nomessage)
-
- ;; nil: Mtn
- ;; unregistered: Bzr CVS Git Hg SVN RCS
- (message "vc-state3 %s %s" backend (vc-state tmp-name backend))
- (should (memq (vc-state tmp-name backend) '(nil unregistered)))
-
- ;; Register a file. Check state.
- (vc-register
- (list backend (list (file-name-nondirectory tmp-name))))
-
- ;; FIXME: nil is definitely wrong.
- ;; nil: SRC
- ;; added: Bzr CVS Git Hg Mtn SVN
- ;; up-to-date: RCS SCCS
- (message "vc-state4 %s" (vc-state tmp-name))
- (should (memq (vc-state tmp-name) '(nil added up-to-date)))
-
- ;; Unregister the file. Check state.
- (if (eq (vc-test--run-maybe-unsupported-function
- 'vc-test--unregister-function backend tmp-name)
- 'vc-not-supported)
- (message "vc-state5 unsupported")
- ;; unregistered: Bzr Git RCS Hg
- ;; unsupported: CVS Mtn SCCS SRC SVN
- (message "vc-state5 %s %s" backend (vc-state tmp-name backend))
- (should (memq (vc-state tmp-name backend)
- '(nil unregistered))))))
-
- ;; Save exit.
- (ignore-errors
- (if tempdir (delete-directory tempdir t))
- (run-hooks 'vc-test--cleanup-hook)))))
+ (ert-with-temp-directory tempdir
+ (let ((vc-handled-backends `(,backend))
+ (default-directory
+ (file-name-as-directory
+ (expand-file-name
+ (make-temp-name "vc-test") temporary-file-directory)))
+ (process-environment process-environment)
+ vc-test--cleanup-hook)
+ (when (eq backend 'Bzr)
+ (setq process-environment (cons (format "BZR_HOME=%s" tempdir)
+ process-environment)))
+ (unwind-protect
+ (progn
+ ;; Cleanup.
+ (add-hook
+ 'vc-test--cleanup-hook
+ `(lambda () (delete-directory ,default-directory 'recursive)))
+
+ ;; Create empty repository.
+ (make-directory default-directory)
+ (vc-test--create-repo-function backend)
+
+ (let ((tmp-name (expand-file-name "foo" default-directory)))
+ ;; Check state of a nonexistent file.
+
+ (message "vc-state2 %s" (vc-state tmp-name))
+ (should (null (vc-state tmp-name)))
+
+ ;; Write a new file. Check state.
+ (write-region "foo" nil tmp-name nil 'nomessage)
+
+ ;; nil: Mtn
+ ;; unregistered: Bzr CVS Git Hg SVN RCS
+ (message "vc-state3 %s %s" backend (vc-state tmp-name backend))
+ (should (memq (vc-state tmp-name backend) '(nil unregistered)))
+
+ ;; Register a file. Check state.
+ (vc-register
+ (list backend (list (file-name-nondirectory tmp-name))))
+
+ ;; FIXME: nil is definitely wrong.
+ ;; nil: SRC
+ ;; added: Bzr CVS Git Hg Mtn SVN
+ ;; up-to-date: RCS SCCS
+ (message "vc-state4 %s" (vc-state tmp-name))
+ (should (memq (vc-state tmp-name) '(nil added up-to-date)))
+
+ ;; Unregister the file. Check state.
+ (if (eq (vc-test--run-maybe-unsupported-function
+ 'vc-test--unregister-function backend tmp-name)
+ 'vc-not-supported)
+ (message "vc-state5 unsupported")
+ ;; unregistered: Bzr Git RCS Hg
+ ;; unsupported: CVS Mtn SCCS SRC SVN
+ (message "vc-state5 %s %s" backend (vc-state tmp-name backend))
+ (should (memq (vc-state tmp-name backend)
+ '(nil unregistered))))))
+
+ ;; Save exit.
+ (ignore-errors
+ (run-hooks 'vc-test--cleanup-hook))))))
(defun vc-test--working-revision (backend)
"Check the working revision of a repository."
-
- (let ((vc-handled-backends `(,backend))
- (default-directory
- (file-name-as-directory
- (expand-file-name
- (make-temp-name "vc-test") temporary-file-directory)))
- (process-environment process-environment)
- tempdir
- vc-test--cleanup-hook)
- (when (eq backend 'Bzr)
- (setq tempdir (make-temp-file "vc-test--working-revision" t)
- process-environment (cons (format "BZR_HOME=%s" tempdir)
- process-environment)))
-
- (unwind-protect
- (progn
- ;; Cleanup.
- (add-hook
- 'vc-test--cleanup-hook
- `(lambda () (delete-directory ,default-directory 'recursive)))
-
- ;; Create empty repository. Check working revision of
- ;; repository, should be nil.
- (make-directory default-directory)
- (vc-test--create-repo-function backend)
-
- ;; FIXME: Is the value for SVN correct?
- ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC
- ;; "0": SVN
- (message
- "vc-working-revision1 %s" (vc-working-revision default-directory))
- (should (member (vc-working-revision default-directory) '(nil "0")))
-
- (let ((tmp-name (expand-file-name "foo" default-directory)))
- ;; Check initial working revision, should be nil until
- ;; it's registered.
-
- (message "vc-working-revision2 %s" (vc-working-revision tmp-name))
- (should-not (vc-working-revision tmp-name))
-
- ;; Write a new file. Check working revision.
- (write-region "foo" nil tmp-name nil 'nomessage)
-
- (message "vc-working-revision3 %s" (vc-working-revision tmp-name))
- (should-not (vc-working-revision tmp-name))
-
- ;; Register a file. Check working revision.
- (vc-register
- (list backend (list (file-name-nondirectory tmp-name))))
-
- ;; XXX: nil is fine, at least in Git's case, because
- ;; `vc-register' only makes the file `added' in this case.
- ;; nil: Git Mtn
- ;; "0": Bzr CVS Hg SRC SVN
- ;; "1.1": RCS SCCS
- ;; "-1": Hg versions before 5 (probably)
- (message "vc-working-revision4 %s" (vc-working-revision tmp-name))
- (should (member (vc-working-revision tmp-name) '(nil "0" "1.1" "-1")))
-
- ;; TODO: Call `vc-checkin', and check the resulting
- ;; working revision. None of the return values should be
- ;; nil then.
-
- ;; Unregister the file. Check working revision.
- (if (eq (vc-test--run-maybe-unsupported-function
- 'vc-test--unregister-function backend tmp-name)
- 'vc-not-supported)
- (message "vc-working-revision5 unsupported")
- ;; nil: Bzr Git Hg RCS
- ;; unsupported: CVS Mtn SCCS SRC SVN
- (message "vc-working-revision5 %s" (vc-working-revision tmp-name))
- (should-not (vc-working-revision tmp-name)))))
-
- ;; Save exit.
- (ignore-errors
- (if tempdir (delete-directory tempdir t))
- (run-hooks 'vc-test--cleanup-hook)))))
+ (ert-with-temp-directory tempdir
+ (let ((vc-handled-backends `(,backend))
+ (default-directory
+ (file-name-as-directory
+ (expand-file-name
+ (make-temp-name "vc-test") temporary-file-directory)))
+ (process-environment process-environment)
+ vc-test--cleanup-hook)
+ (when (eq backend 'Bzr)
+ (setq process-environment (cons (format "BZR_HOME=%s" tempdir)
+ process-environment)))
+
+ (unwind-protect
+ (progn
+ ;; Cleanup.
+ (add-hook
+ 'vc-test--cleanup-hook
+ `(lambda () (delete-directory ,default-directory 'recursive)))
+
+ ;; Create empty repository. Check working revision of
+ ;; repository, should be nil.
+ (make-directory default-directory)
+ (vc-test--create-repo-function backend)
+
+ ;; FIXME: Is the value for SVN correct?
+ ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC
+ ;; "0": SVN
+ (message
+ "vc-working-revision1 %s" (vc-working-revision default-directory))
+ (should (member (vc-working-revision default-directory) '(nil "0")))
+
+ (let ((tmp-name (expand-file-name "foo" default-directory)))
+ ;; Check initial working revision, should be nil until
+ ;; it's registered.
+
+ (message "vc-working-revision2 %s" (vc-working-revision tmp-name))
+ (should-not (vc-working-revision tmp-name))
+
+ ;; Write a new file. Check working revision.
+ (write-region "foo" nil tmp-name nil 'nomessage)
+
+ (message "vc-working-revision3 %s" (vc-working-revision tmp-name))
+ (should-not (vc-working-revision tmp-name))
+
+ ;; Register a file. Check working revision.
+ (vc-register
+ (list backend (list (file-name-nondirectory tmp-name))))
+
+ ;; XXX: nil is fine, at least in Git's case, because
+ ;; `vc-register' only makes the file `added' in this case.
+ ;; nil: Git Mtn
+ ;; "0": Bzr CVS Hg SRC SVN
+ ;; "1.1": RCS SCCS
+ ;; "-1": Hg versions before 5 (probably)
+ (message "vc-working-revision4 %s" (vc-working-revision tmp-name))
+ (should (member (vc-working-revision tmp-name) '(nil "0" "1.1" "-1")))
+
+ ;; TODO: Call `vc-checkin', and check the resulting
+ ;; working revision. None of the return values should be
+ ;; nil then.
+
+ ;; Unregister the file. Check working revision.
+ (if (eq (vc-test--run-maybe-unsupported-function
+ 'vc-test--unregister-function backend tmp-name)
+ 'vc-not-supported)
+ (message "vc-working-revision5 unsupported")
+ ;; nil: Bzr Git Hg RCS
+ ;; unsupported: CVS Mtn SCCS SRC SVN
+ (message "vc-working-revision5 %s" (vc-working-revision tmp-name))
+ (should-not (vc-working-revision tmp-name)))))
+
+ ;; Save exit.
+ (ignore-errors
+ (run-hooks 'vc-test--cleanup-hook))))))
(defun vc-test--checkout-model (backend)
"Check the checkout model of a repository."
-
- (let ((vc-handled-backends `(,backend))
- (default-directory
- (file-name-as-directory
- (expand-file-name
- (make-temp-name "vc-test") temporary-file-directory)))
- (process-environment process-environment)
- tempdir
- vc-test--cleanup-hook)
- (when (eq backend 'Bzr)
- (setq tempdir (make-temp-file "vc-test--checkout-model" t)
- process-environment (cons (format "BZR_HOME=%s" tempdir)
- process-environment)))
-
- (unwind-protect
- (progn
- ;; Cleanup.
- (add-hook
- 'vc-test--cleanup-hook
- `(lambda () (delete-directory ,default-directory 'recursive)))
-
- ;; Create empty repository. Check repository checkout model.
- (make-directory default-directory)
- (vc-test--create-repo-function backend)
-
- ;; Surprisingly, none of the backends returns 'announce.
- ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
- ;; locking: RCS SCCS
- (message
- "vc-checkout-model1 %s"
- (vc-checkout-model backend default-directory))
- (should (memq (vc-checkout-model backend default-directory)
- '(announce implicit locking)))
-
- (let ((tmp-name (expand-file-name "foo" default-directory)))
- ;; Check checkout model of a nonexistent file.
-
- ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
- ;; locking: RCS SCCS
+ (ert-with-temp-directory tempdir
+ (let ((vc-handled-backends `(,backend))
+ (default-directory
+ (file-name-as-directory
+ (expand-file-name
+ (make-temp-name "vc-test") temporary-file-directory)))
+ (process-environment process-environment)
+ vc-test--cleanup-hook)
+ (when (eq backend 'Bzr)
+ (setq process-environment (cons (format "BZR_HOME=%s" tempdir)
+ process-environment)))
+
+ (unwind-protect
+ (progn
+ ;; Cleanup.
+ (add-hook
+ 'vc-test--cleanup-hook
+ `(lambda () (delete-directory ,default-directory 'recursive)))
+
+ ;; Create empty repository. Check repository checkout model.
+ (make-directory default-directory)
+ (vc-test--create-repo-function backend)
+
+ ;; Surprisingly, none of the backends returns 'announce.
+ ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
+ ;; locking: RCS SCCS
(message
- "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name))
- (should (memq (vc-checkout-model backend tmp-name)
- '(announce implicit locking)))
+ "vc-checkout-model1 %s"
+ (vc-checkout-model backend default-directory))
+ (should (memq (vc-checkout-model backend default-directory)
+ '(announce implicit locking)))
- ;; Write a new file. Check checkout model.
- (write-region "foo" nil tmp-name nil 'nomessage)
+ (let ((tmp-name (expand-file-name "foo" default-directory)))
+ ;; Check checkout model of a nonexistent file.
- ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
- ;; locking: RCS SCCS
- (message
- "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name))
- (should (memq (vc-checkout-model backend tmp-name)
- '(announce implicit locking)))
+ ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
+ ;; locking: RCS SCCS
+ (message
+ "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name))
+ (should (memq (vc-checkout-model backend tmp-name)
+ '(announce implicit locking)))
- ;; Register a file. Check checkout model.
- (vc-register
- (list backend (list (file-name-nondirectory tmp-name))))
+ ;; Write a new file. Check checkout model.
+ (write-region "foo" nil tmp-name nil 'nomessage)
- ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
- ;; locking: RCS SCCS
- (message
- "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name))
- (should (memq (vc-checkout-model backend tmp-name)
- '(announce implicit locking)))
-
- ;; Unregister the file. Check checkout model.
- (if (eq (vc-test--run-maybe-unsupported-function
- 'vc-test--unregister-function backend tmp-name)
- 'vc-not-supported)
- (message "vc-checkout-model5 unsupported")
- ;; implicit: Bzr Git Hg
- ;; locking: RCS
- ;; unsupported: CVS Mtn SCCS SRC SVN
+ ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
+ ;; locking: RCS SCCS
(message
- "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name))
+ "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name))
(should (memq (vc-checkout-model backend tmp-name)
- '(announce implicit locking))))))
+ '(announce implicit locking)))
- ;; Save exit.
- (ignore-errors
- (if tempdir (delete-directory tempdir t))
- (run-hooks 'vc-test--cleanup-hook)))))
+ ;; Register a file. Check checkout model.
+ (vc-register
+ (list backend (list (file-name-nondirectory tmp-name))))
+
+ ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
+ ;; locking: RCS SCCS
+ (message
+ "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name))
+ (should (memq (vc-checkout-model backend tmp-name)
+ '(announce implicit locking)))
+
+ ;; Unregister the file. Check checkout model.
+ (if (eq (vc-test--run-maybe-unsupported-function
+ 'vc-test--unregister-function backend tmp-name)
+ 'vc-not-supported)
+ (message "vc-checkout-model5 unsupported")
+ ;; implicit: Bzr Git Hg
+ ;; locking: RCS
+ ;; unsupported: CVS Mtn SCCS SRC SVN
+ (message
+ "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name))
+ (should (memq (vc-checkout-model backend tmp-name)
+ '(announce implicit locking))))))
+
+ ;; Save exit.
+ (ignore-errors
+ (run-hooks 'vc-test--cleanup-hook))))))
(defun vc-test--rename-file (backend)
"Check the rename-file action."
-
- (let ((vc-handled-backends `(,backend))
- (default-directory
- (file-name-as-directory
- (expand-file-name
- (make-temp-name "vc-test") temporary-file-directory)))
- (process-environment process-environment)
- tempdir
- vc-test--cleanup-hook)
- (when (eq backend 'Bzr)
- (setq tempdir (make-temp-file "vc-test--rename-file" t)
- process-environment (cons (format "BZR_HOME=%s" tempdir)
- process-environment)))
-
- (unwind-protect
- (progn
- ;; Cleanup.
- (add-hook
- 'vc-test--cleanup-hook
- `(lambda () (delete-directory ,default-directory 'recursive)))
-
- ;; Create empty repository.
- (make-directory default-directory)
- (vc-test--create-repo-function backend)
-
- (let ((tmp-name (expand-file-name "foo" default-directory))
- (new-name (expand-file-name "bar" default-directory)))
- ;; Write a new file.
- (write-region "foo" nil tmp-name nil 'nomessage)
-
- ;; Register it. Renaming can fail otherwise.
- (vc-register
- (list backend (list (file-name-nondirectory tmp-name))))
-
- (vc-rename-file tmp-name new-name)
-
- (should (not (file-exists-p tmp-name)))
- (should (file-exists-p new-name))
-
- (should (equal (vc-state new-name)
- (if (memq backend '(RCS SCCS))
- 'up-to-date
- 'added)))))
-
- ;; Save exit.
- (ignore-errors
- (if tempdir (delete-directory tempdir t))
- (run-hooks 'vc-test--cleanup-hook)))))
+ (ert-with-temp-directory tempdir
+ (let ((vc-handled-backends `(,backend))
+ (default-directory
+ (file-name-as-directory
+ (expand-file-name
+ (make-temp-name "vc-test") temporary-file-directory)))
+ (process-environment process-environment)
+ vc-test--cleanup-hook)
+ (when (eq backend 'Bzr)
+ (setq process-environment (cons (format "BZR_HOME=%s" tempdir)
+ process-environment)))
+
+ (unwind-protect
+ (progn
+ ;; Cleanup.
+ (add-hook
+ 'vc-test--cleanup-hook
+ `(lambda () (delete-directory ,default-directory 'recursive)))
+
+ ;; Create empty repository.
+ (make-directory default-directory)
+ (vc-test--create-repo-function backend)
+
+ (let ((tmp-name (expand-file-name "foo" default-directory))
+ (new-name (expand-file-name "bar" default-directory)))
+ ;; Write a new file.
+ (write-region "foo" nil tmp-name nil 'nomessage)
+
+ ;; Register it. Renaming can fail otherwise.
+ (vc-register
+ (list backend (list (file-name-nondirectory tmp-name))))
+
+ (vc-rename-file tmp-name new-name)
+
+ (should (not (file-exists-p tmp-name)))
+ (should (file-exists-p new-name))
+
+ (should (equal (vc-state new-name)
+ (if (memq backend '(RCS SCCS))
+ 'up-to-date
+ 'added)))))
+
+ ;; Save exit.
+ (ignore-errors
+ (run-hooks 'vc-test--cleanup-hook))))))
(declare-function log-edit-done "vc/log-edit")
(defun vc-test--version-diff (backend)
"Check the diff version of a repository."
-
- (let ((vc-handled-backends `(,backend))
- (default-directory
- (file-name-as-directory
- (expand-file-name
- (make-temp-name "vc-test") temporary-file-directory)))
- (process-environment process-environment)
- tempdir
- vc-test--cleanup-hook)
- (when (eq backend 'Bzr)
- (setq tempdir (make-temp-file "vc-test--version-diff" t)
- process-environment (cons (format "BZR_HOME=%s" tempdir)
- process-environment)))
- ;; git tries various approaches to guess a user name and email,
- ;; which can fail depending on how the system is configured.
- ;; Eg if the user account has no GECOS, git commit can fail with
- ;; status 128 "fatal: empty ident name".
- (when (memq backend '(Bzr Git))
- (setq process-environment (cons "EMAIL=john@doe.ee"
- process-environment)))
- (if (eq backend 'Git)
- (setq process-environment (append '("GIT_AUTHOR_NAME=A"
- "GIT_COMMITTER_NAME=C")
- process-environment)))
- (unwind-protect
- (progn
- ;; Cleanup.
- (add-hook
- 'vc-test--cleanup-hook
- `(lambda () (delete-directory ,default-directory 'recursive)))
-
- ;; Create empty repository. Check repository checkout model.
- (make-directory default-directory)
- (vc-test--create-repo-function backend)
-
- (let* ((tmp-name (expand-file-name "foo" default-directory))
- (files (list (file-name-nondirectory tmp-name))))
- ;; Write and register a new file.
- (write-region "originaltext" nil tmp-name nil 'nomessage)
- (vc-register (list backend files))
-
- (let ((buff (find-file tmp-name)))
- (with-current-buffer buff
+ (ert-with-temp-directory tempdir
+ (let ((vc-handled-backends `(,backend))
+ (default-directory
+ (file-name-as-directory
+ (expand-file-name
+ (make-temp-name "vc-test") temporary-file-directory)))
+ (process-environment process-environment)
+ vc-test--cleanup-hook)
+ (when (eq backend 'Bzr)
+ (setq process-environment (cons (format "BZR_HOME=%s" tempdir)
+ process-environment)))
+ ;; git tries various approaches to guess a user name and email,
+ ;; which can fail depending on how the system is configured.
+ ;; Eg if the user account has no GECOS, git commit can fail with
+ ;; status 128 "fatal: empty ident name".
+ (when (memq backend '(Bzr Git))
+ (setq process-environment (cons "EMAIL=john@doe.ee"
+ process-environment)))
+ (if (eq backend 'Git)
+ (setq process-environment (append '("GIT_AUTHOR_NAME=A"
+ "GIT_COMMITTER_NAME=C")
+ process-environment)))
+ (unwind-protect
+ (progn
+ ;; Cleanup.
+ (add-hook
+ 'vc-test--cleanup-hook
+ `(lambda () (delete-directory ,default-directory 'recursive)))
+
+ ;; Create empty repository. Check repository checkout model.
+ (make-directory default-directory)
+ (vc-test--create-repo-function backend)
+
+ (let* ((tmp-name (expand-file-name "foo" default-directory))
+ (files (list (file-name-nondirectory tmp-name))))
+ ;; Write and register a new file.
+ (write-region "originaltext" nil tmp-name nil 'nomessage)
+ (vc-register (list backend files))
+
+ (let ((buff (find-file tmp-name)))
+ (with-current-buffer buff
+ (progn
+ ;; Optionally checkout file.
+ (when (memq backend '(RCS CVS SCCS))
+ (vc-checkout tmp-name))
+
+ ;; Checkin file.
+ (vc-checkin files backend)
+ (insert "Testing vc-version-diff")
+ (log-edit-done))))
+
+ ;; Modify file content.
+ (when (memq backend '(RCS CVS SCCS))
+ (vc-checkout tmp-name))
+ (write-region "updatedtext" nil tmp-name nil 'nomessage)
+
+ ;; Check version diff.
+ (vc-version-diff files nil nil)
+ (should (bufferp (get-buffer "*vc-diff*")))
+
+ (with-current-buffer "*vc-diff*"
(progn
- ;; Optionally checkout file.
- (when (memq backend '(RCS CVS SCCS))
- (vc-checkout tmp-name))
-
- ;; Checkin file.
- (vc-checkin files backend)
- (insert "Testing vc-version-diff")
- (log-edit-done))))
-
- ;; Modify file content.
- (when (memq backend '(RCS CVS SCCS))
- (vc-checkout tmp-name))
- (write-region "updatedtext" nil tmp-name nil 'nomessage)
-
- ;; Check version diff.
- (vc-version-diff files nil nil)
- (should (bufferp (get-buffer "*vc-diff*")))
-
- (with-current-buffer "*vc-diff*"
- (progn
- (let ((rawtext (buffer-substring-no-properties (point-min)
- (point-max))))
- (should (string-search "-originaltext" rawtext))
- (should (string-search "+updatedtext" rawtext)))))))
-
- ;; Save exit.
- (ignore-errors
- (if tempdir (delete-directory tempdir t))
- (run-hooks 'vc-test--cleanup-hook)))))
+ (let ((rawtext (buffer-substring-no-properties (point-min)
+ (point-max))))
+ (should (string-search "-originaltext" rawtext))
+ (should (string-search "+updatedtext" rawtext)))))))
+
+ ;; Save exit.
+ (ignore-errors
+ (run-hooks 'vc-test--cleanup-hook))))))
;; Create the test cases.
diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el
index 96a01fc2c7b..47ed26f609d 100644
--- a/test/lisp/wdired-tests.el
+++ b/test/lisp/wdired-tests.el
@@ -20,7 +20,9 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'dired)
+(require 'dired-x)
(require 'wdired)
(defvar dired-query) ; Pacify byte compiler.
@@ -28,108 +30,100 @@
(ert-deftest wdired-test-bug32173-01 ()
"Test using non-nil wdired-use-interactive-rename.
Partially modifying a file name should succeed."
- (let* ((test-dir (make-temp-file "test-dir-" t))
- (test-file (concat (file-name-as-directory test-dir) "foo.c"))
- (replace "bar")
- (new-file (string-replace "foo" replace test-file))
- (wdired-use-interactive-rename t))
- (write-region "" nil test-file nil 'silent)
- (advice-add 'dired-query ; Don't ask confirmation to overwrite a file.
- :override
- (lambda (_sym _prompt &rest _args) (setq dired-query t))
- '((name . "advice-dired-query")))
- (let ((buf (find-file-noselect test-dir)))
- (unwind-protect
- (with-current-buffer buf
- (should (equal (dired-file-name-at-point) test-file))
- (dired-toggle-read-only)
- (kill-region (point) (progn (search-forward ".")
- (forward-char -1) (point)))
- (insert replace)
- (wdired-finish-edit)
- (should (equal (dired-file-name-at-point) new-file)))
- (if buf (kill-buffer buf))
- (delete-directory test-dir t)))))
+ (ert-with-temp-directory test-dir
+ (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c"))
+ (replace "bar")
+ (new-file (string-replace "foo" replace test-file))
+ (wdired-use-interactive-rename t))
+ (write-region "" nil test-file nil 'silent)
+ (advice-add 'dired-query ; Don't ask confirmation to overwrite a file.
+ :override
+ (lambda (_sym _prompt &rest _args) (setq dired-query t))
+ '((name . "advice-dired-query")))
+ (let ((buf (find-file-noselect test-dir)))
+ (unwind-protect
+ (with-current-buffer buf
+ (should (equal (dired-file-name-at-point) test-file))
+ (dired-toggle-read-only)
+ (kill-region (point) (progn (search-forward ".")
+ (forward-char -1) (point)))
+ (insert replace)
+ (wdired-finish-edit)
+ (should (equal (dired-file-name-at-point) new-file)))
+ (if buf (kill-buffer buf)))))))
(ert-deftest wdired-test-bug32173-02 ()
"Test using non-nil wdired-use-interactive-rename.
Aborting an edit should leaving original file name unchanged."
- (let* ((test-dir (make-temp-file "test-dir-" t))
- (test-file (concat (file-name-as-directory test-dir) "foo.c"))
- (wdired-use-interactive-rename t))
- (write-region "" nil test-file nil 'silent)
- ;; Make dired-do-create-files-regexp a noop to mimic typing C-g
- ;; at its prompt before wdired-finish-edit returns.
- (advice-add 'dired-do-create-files-regexp
- :override
- (lambda (&rest _) (ignore))
- '((name . "advice-dired-do-create-files-regexp")))
- (let ((buf (find-file-noselect test-dir)))
- (unwind-protect
- (with-current-buffer buf
- (should (equal (dired-file-name-at-point) test-file))
- (dired-toggle-read-only)
- (kill-region (point) (progn (search-forward ".")
- (forward-char -1) (point)))
- (insert "bar")
- (wdired-finish-edit)
- (should (equal (dired-get-filename) test-file)))
- (if buf (kill-buffer buf))
- (delete-directory test-dir t)))))
+ (ert-with-temp-directory test-dir
+ (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c"))
+ (wdired-use-interactive-rename t))
+ (write-region "" nil test-file nil 'silent)
+ ;; Make dired-do-create-files-regexp a noop to mimic typing C-g
+ ;; at its prompt before wdired-finish-edit returns.
+ (advice-add 'dired-do-create-files-regexp
+ :override
+ (lambda (&rest _) (ignore))
+ '((name . "advice-dired-do-create-files-regexp")))
+ (let ((buf (find-file-noselect test-dir)))
+ (unwind-protect
+ (with-current-buffer buf
+ (should (equal (dired-file-name-at-point) test-file))
+ (dired-toggle-read-only)
+ (kill-region (point) (progn (search-forward ".")
+ (forward-char -1) (point)))
+ (insert "bar")
+ (wdired-finish-edit)
+ (should (equal (dired-get-filename) test-file)))
+ (if buf (kill-buffer buf)))))))
(ert-deftest wdired-test-symlink-name ()
"Test the file name of a symbolic link.
The Dired and WDired functions returning the name should include
only the name before the link arrow."
- (let* ((test-dir (make-temp-file "test-dir-" t))
- (link-name "foo"))
- (let ((buf (find-file-noselect test-dir)))
- (unwind-protect
- (with-current-buffer buf
- (skip-unless
- ;; This check is for wdired, not symbolic links, so skip
- ;; it when make-symbolic-link fails for any reason (like
- ;; insufficient privileges).
- (ignore-errors (make-symbolic-link "./bar/baz" link-name) t))
- (revert-buffer)
- (let* ((file-name (dired-get-filename))
- (dir-part (file-name-directory file-name))
- (lf-name (concat dir-part link-name)))
- (should (equal file-name lf-name))
- (dired-toggle-read-only)
- (should (equal (wdired-get-filename) lf-name))
- (dired-toggle-read-only)))
- (if buf (kill-buffer buf))
- (delete-directory test-dir t)))))
+ (ert-with-temp-directory test-dir
+ (let* ((link-name "foo"))
+ (let ((buf (find-file-noselect test-dir)))
+ (unwind-protect
+ (with-current-buffer buf
+ (skip-unless
+ ;; This check is for wdired, not symbolic links, so skip
+ ;; it when make-symbolic-link fails for any reason (like
+ ;; insufficient privileges).
+ (ignore-errors (make-symbolic-link "./bar/baz" link-name) t))
+ (revert-buffer)
+ (let* ((file-name (dired-get-filename))
+ (dir-part (file-name-directory file-name))
+ (lf-name (concat dir-part link-name)))
+ (should (equal file-name lf-name))
+ (dired-toggle-read-only)
+ (should (equal (wdired-get-filename) lf-name))
+ (dired-toggle-read-only)))
+ (if buf (kill-buffer buf)))))))
(ert-deftest wdired-test-unfinished-edit-01 ()
"Test editing a file name without saving the change.
Finding the new name should be possible while still in
wdired-mode."
- (let* ((test-dir (make-temp-file "test-dir-" t))
- (test-file (concat (file-name-as-directory test-dir) "foo.c"))
- (replace "bar")
- (new-file (string-replace "foo" replace test-file)))
- (write-region "" nil test-file nil 'silent)
- (let ((buf (find-file-noselect test-dir)))
- (unwind-protect
- (with-current-buffer buf
- (should (equal (dired-file-name-at-point) test-file))
- (dired-toggle-read-only)
- (kill-region (point) (progn (search-forward ".")
- (forward-char -1) (point)))
- (insert replace)
- (should (equal (dired-get-filename) new-file)))
- (when buf
- (with-current-buffer buf
- ;; Prevent kill-buffer-query-functions from chiming in.
- (set-buffer-modified-p nil)
- (kill-buffer buf)))
- (delete-directory test-dir t)))))
-
-(defvar server-socket-dir)
-(declare-function dired-smart-shell-command "dired-x"
- (command &optional output-buffer error-buffer))
+ (ert-with-temp-directory test-dir
+ (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c"))
+ (replace "bar")
+ (new-file (string-replace "foo" replace test-file)))
+ (write-region "" nil test-file nil 'silent)
+ (let ((buf (find-file-noselect test-dir)))
+ (unwind-protect
+ (with-current-buffer buf
+ (should (equal (dired-file-name-at-point) test-file))
+ (dired-toggle-read-only)
+ (kill-region (point) (progn (search-forward ".")
+ (forward-char -1) (point)))
+ (insert replace)
+ (should (equal (dired-get-filename) new-file)))
+ (when buf
+ (with-current-buffer buf
+ ;; Prevent kill-buffer-query-functions from chiming in.
+ (set-buffer-modified-p nil)
+ (kill-buffer buf))))))))
(ert-deftest wdired-test-bug34915 ()
"Test editing when dired-listing-switches includes -F.
@@ -139,61 +133,61 @@ dired-move-to-end-of-filename handles indicator characters, it
suffices to compare the return values of dired-get-filename and
wdired-get-filename before and after editing."
;; FIXME: Add a test for a door (indicator ">") only under Solaris?
- (let* ((test-dir (make-temp-file "test-dir-" t))
- (server-socket-dir test-dir)
- (dired-listing-switches "-Fl")
- (dired-ls-F-marks-symlinks (eq system-type 'darwin))
- (buf (find-file-noselect test-dir)))
- (unwind-protect
- (progn
- (with-current-buffer buf
- (dired-create-empty-file "foo")
- (set-file-modes "foo" (file-modes-symbolic-to-number "+x"))
- (make-symbolic-link "foo" "bar")
- (make-directory "foodir")
- (require 'dired-x)
- (dired-smart-shell-command "mkfifo foopipe")
- (server-force-delete)
- ;; FIXME? This seems a heavy-handed way of making a socket.
- (server-start) ; Add a socket file.
- (kill-buffer buf))
- (dired test-dir)
- (dired-toggle-read-only)
- (let (names)
- ;; Test that the file names are the same in Dired and WDired.
- (while (not (eobp))
- (should (equal (dired-get-filename 'no-dir t)
- (wdired-get-filename t)))
- (insert "w")
- (push (wdired-get-filename t) names)
- (dired-next-line 1))
- (wdired-finish-edit)
- ;; Test that editing the file names ignores the indicator
- ;; character.
- (let (dir)
- (while (and (dired-previous-line 1)
- (setq dir (dired-get-filename 'no-dir t)))
- (should (equal dir (pop names)))))))
- (kill-buffer (get-buffer test-dir))
- (server-force-delete)
- (delete-directory test-dir t))))
+ (ert-with-temp-directory test-dir
+ (let* ((dired-listing-switches "-Fl")
+ (dired-ls-F-marks-symlinks (eq system-type 'darwin))
+ (buf (find-file-noselect test-dir))
+ proc)
+ (unwind-protect
+ (progn
+ (with-current-buffer buf
+ (dired-create-empty-file "foo")
+ (set-file-modes "foo" (file-modes-symbolic-to-number "+x"))
+ (make-symbolic-link "foo" "bar")
+ (make-directory "foodir")
+ (dired-smart-shell-command "mkfifo foopipe")
+ (when (featurep 'make-network-process '(:family local))
+ (setq proc (make-network-process
+ :name "foo"
+ :family 'local
+ :server t
+ :service (expand-file-name "foosocket" test-dir))))
+ (kill-buffer buf))
+ (dired test-dir)
+ (dired-toggle-read-only)
+ (let (names)
+ ;; Test that the file names are the same in Dired and WDired.
+ (while (not (eobp))
+ (should (equal (dired-get-filename 'no-dir t)
+ (wdired-get-filename t)))
+ (insert "w")
+ (push (wdired-get-filename t) names)
+ (dired-next-line 1))
+ (wdired-finish-edit)
+ ;; Test that editing the file names ignores the indicator
+ ;; character.
+ (let (dir)
+ (while (and (dired-previous-line 1)
+ (setq dir (dired-get-filename 'no-dir t)))
+ (should (equal dir (pop names)))))))
+ (kill-buffer (get-buffer test-dir))
+ (ignore-errors (delete-process proc))))))
(ert-deftest wdired-test-bug39280 ()
"Test for https://debbugs.gnu.org/39280."
- (let* ((test-dir (make-temp-file "test-dir" 'dir))
- (fname "foo")
- (full-fname (expand-file-name fname test-dir)))
- (make-empty-file full-fname)
- (let ((buf (find-file-noselect test-dir)))
- (unwind-protect
- (with-current-buffer buf
- (dired-toggle-read-only)
- (dolist (old '(t nil))
- (should (equal fname (wdired-get-filename 'nodir old)))
- (should (equal full-fname (wdired-get-filename nil old))))
- (wdired-finish-edit))
- (if buf (kill-buffer buf))
- (delete-directory test-dir t)))))
+ (ert-with-temp-directory test-dir
+ (let* ((fname "foo")
+ (full-fname (expand-file-name fname test-dir)))
+ (make-empty-file full-fname)
+ (let ((buf (find-file-noselect test-dir)))
+ (unwind-protect
+ (with-current-buffer buf
+ (dired-toggle-read-only)
+ (dolist (old '(t nil))
+ (should (equal fname (wdired-get-filename 'nodir old)))
+ (should (equal full-fname (wdired-get-filename nil old))))
+ (wdired-finish-edit))
+ (if buf (kill-buffer buf)))))))
(provide 'wdired-tests)
;;; wdired-tests.el ends here
diff --git a/test/manual/cedet/cedet-utests.el b/test/manual/cedet/cedet-utests.el
index d68b5b8c090..af6b4defb3c 100644
--- a/test/manual/cedet/cedet-utests.el
+++ b/test/manual/cedet/cedet-utests.el
@@ -252,9 +252,7 @@ Optional argument TITLE is the title of this testing session."
(defun cedet-utest-elapsed-time (start end)
"Copied from elp.el. Was elp-elapsed-time.
Argument START and END bound the time being calculated."
- (+ (* (- (car end) (car start)) 65536.0)
- (- (car (cdr end)) (car (cdr start)))
- (/ (- (car (cdr (cdr end))) (car (cdr (cdr start)))) 1000000.0)))
+ (float-time (time-subtract start end)))
(defun cedet-utest-log-shutdown (title &optional _errorcondition)
"Shut-down a larger test suite.
diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el
index 059926ff46b..9b7023d18b9 100644
--- a/test/src/buffer-tests.el
+++ b/test/src/buffer-tests.el
@@ -19,6 +19,8 @@
;;; Code:
+(require 'ert)
+(require 'ert-x)
(require 'cl-lib)
(ert-deftest overlay-modification-hooks-message-other-buf ()
@@ -145,7 +147,7 @@ with parameters from the *Messages* buffer modification."
(defmacro deftest-overlayp-1 (id arg-expr should-expr)
(declare (indent 1))
- `(ert-deftest ,(buffer-tests--make-test-name 'overlay-buffer 1 id) ()
+ `(ert-deftest ,(buffer-tests--make-test-name 'overlayp 1 id) ()
(with-temp-buffer
(should (equal ,should-expr (overlayp ,arg-expr))))))
@@ -434,14 +436,14 @@ with parameters from the *Messages* buffer modification."
(deftest-next-overlay-change-1 I 10 (point-max) (10 10))
(deftest-next-overlay-change-1 J 20 (point-max) (10 10))
;; 2 non-empty, non-intersecting
-(deftest-next-overlay-change-1 D 10 20 (20 30) (40 50))
-(deftest-next-overlay-change-1 E 35 40 (20 30) (40 50))
-(deftest-next-overlay-change-1 F 60 (point-max) (20 30) (40 50))
-(deftest-next-overlay-change-1 G 30 40 (20 30) (40 50))
-(deftest-next-overlay-change-1 H 50 (point-max) (20 30) (40 50))
+(deftest-next-overlay-change-1 D2 10 20 (20 30) (40 50))
+(deftest-next-overlay-change-1 E2 35 40 (20 30) (40 50))
+(deftest-next-overlay-change-1 F2 60 (point-max) (20 30) (40 50))
+(deftest-next-overlay-change-1 G2 30 40 (20 30) (40 50))
+(deftest-next-overlay-change-1 H2 50 (point-max) (20 30) (40 50))
;; 2 non-empty, intersecting
-(deftest-next-overlay-change-1 I 10 20 (20 30) (25 35))
-(deftest-next-overlay-change-1 J 20 25 (20 30) (25 35))
+(deftest-next-overlay-change-1 I2 10 20 (20 30) (25 35))
+(deftest-next-overlay-change-1 J2 20 25 (20 30) (25 35))
(deftest-next-overlay-change-1 K 23 25 (20 30) (25 35))
(deftest-next-overlay-change-1 L 25 30 (20 30) (25 35))
(deftest-next-overlay-change-1 M 28 30 (20 30) (25 35))
@@ -471,11 +473,11 @@ with parameters from the *Messages* buffer modification."
(deftest-next-overlay-change-1 k 30 (point-max) (20 20) (20 30))
(deftest-next-overlay-change-1 l 40 (point-max) (20 20) (20 30))
;; 1 empty, 1 non-empty, intersecting at end
-(deftest-next-overlay-change-1 h 10 20 (30 30) (20 30))
-(deftest-next-overlay-change-1 i 20 30 (30 30) (20 30))
-(deftest-next-overlay-change-1 j 25 30 (30 30) (20 30))
-(deftest-next-overlay-change-1 k 30 (point-max) (20 20) (20 30))
-(deftest-next-overlay-change-1 l 40 (point-max) (20 20) (20 30))
+(deftest-next-overlay-change-1 h2 10 20 (30 30) (20 30))
+(deftest-next-overlay-change-1 i2 20 30 (30 30) (20 30))
+(deftest-next-overlay-change-1 j2 25 30 (30 30) (20 30))
+(deftest-next-overlay-change-1 k2 30 (point-max) (20 20) (20 30))
+(deftest-next-overlay-change-1 l2 40 (point-max) (20 20) (20 30))
;; 1 empty, 1 non-empty, intersecting in the middle
(deftest-next-overlay-change-1 m 10 20 (25 25) (20 30))
(deftest-next-overlay-change-1 n 20 25 (25 25) (20 30))
@@ -522,14 +524,14 @@ with parameters from the *Messages* buffer modification."
(deftest-previous-overlay-change-1 I 10 1 (10 10))
(deftest-previous-overlay-change-1 J 20 10 (10 10))
;; 2 non-empty, non-intersecting
-(deftest-previous-overlay-change-1 D 10 1 (20 30) (40 50))
-(deftest-previous-overlay-change-1 E 35 30 (20 30) (40 50))
-(deftest-previous-overlay-change-1 F 60 50 (20 30) (40 50))
-(deftest-previous-overlay-change-1 G 30 20 (20 30) (40 50))
-(deftest-previous-overlay-change-1 H 50 40 (20 30) (40 50))
+(deftest-previous-overlay-change-1 D2 10 1 (20 30) (40 50))
+(deftest-previous-overlay-change-1 E2 35 30 (20 30) (40 50))
+(deftest-previous-overlay-change-1 F2 60 50 (20 30) (40 50))
+(deftest-previous-overlay-change-1 G2 30 20 (20 30) (40 50))
+(deftest-previous-overlay-change-1 H2 50 40 (20 30) (40 50))
;; 2 non-empty, intersecting
-(deftest-previous-overlay-change-1 I 10 1 (20 30) (25 35))
-(deftest-previous-overlay-change-1 J 20 1 (20 30) (25 35))
+(deftest-previous-overlay-change-1 I2 10 1 (20 30) (25 35))
+(deftest-previous-overlay-change-1 J2 20 1 (20 30) (25 35))
(deftest-previous-overlay-change-1 K 23 20 (20 30) (25 35))
(deftest-previous-overlay-change-1 L 25 20 (20 30) (25 35))
(deftest-previous-overlay-change-1 M 28 25 (20 30) (25 35))
@@ -619,28 +621,28 @@ with parameters from the *Messages* buffer modification."
(deftest-overlays-at-1 P 50 () (a 10 20) (b 30 40))
;; 2 non-empty overlays intersecting
-(deftest-overlays-at-1 G 1 () (a 10 30) (b 20 40))
-(deftest-overlays-at-1 H 10 (a) (a 10 30) (b 20 40))
-(deftest-overlays-at-1 I 15 (a) (a 10 30) (b 20 40))
-(deftest-overlays-at-1 K 20 (a b) (a 10 30) (b 20 40))
-(deftest-overlays-at-1 L 25 (a b) (a 10 30) (b 20 40))
-(deftest-overlays-at-1 M 30 (b) (a 10 30) (b 20 40))
-(deftest-overlays-at-1 N 35 (b) (a 10 30) (b 20 40))
-(deftest-overlays-at-1 O 40 () (a 10 30) (b 20 40))
-(deftest-overlays-at-1 P 50 () (a 10 30) (b 20 40))
+(deftest-overlays-at-1 G2 1 () (a 10 30) (b 20 40))
+(deftest-overlays-at-1 H2 10 (a) (a 10 30) (b 20 40))
+(deftest-overlays-at-1 I2 15 (a) (a 10 30) (b 20 40))
+(deftest-overlays-at-1 K2 20 (a b) (a 10 30) (b 20 40))
+(deftest-overlays-at-1 L2 25 (a b) (a 10 30) (b 20 40))
+(deftest-overlays-at-1 M2 30 (b) (a 10 30) (b 20 40))
+(deftest-overlays-at-1 N2 35 (b) (a 10 30) (b 20 40))
+(deftest-overlays-at-1 O2 40 () (a 10 30) (b 20 40))
+(deftest-overlays-at-1 P2 50 () (a 10 30) (b 20 40))
;; 2 non-empty overlays continuous
-(deftest-overlays-at-1 G 1 () (a 10 20) (b 20 30))
-(deftest-overlays-at-1 H 10 (a) (a 10 20) (b 20 30))
-(deftest-overlays-at-1 I 15 (a) (a 10 20) (b 20 30))
-(deftest-overlays-at-1 K 20 (b) (a 10 20) (b 20 30))
-(deftest-overlays-at-1 L 25 (b) (a 10 20) (b 20 30))
-(deftest-overlays-at-1 M 30 () (a 10 20) (b 20 30))
+(deftest-overlays-at-1 G3 1 () (a 10 20) (b 20 30))
+(deftest-overlays-at-1 H3 10 (a) (a 10 20) (b 20 30))
+(deftest-overlays-at-1 I3 15 (a) (a 10 20) (b 20 30))
+(deftest-overlays-at-1 K3 20 (b) (a 10 20) (b 20 30))
+(deftest-overlays-at-1 L3 25 (b) (a 10 20) (b 20 30))
+(deftest-overlays-at-1 M3 30 () (a 10 20) (b 20 30))
;; overlays-at never returns empty overlays.
-(deftest-overlays-at-1 N 1 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50))
-(deftest-overlays-at-1 O 20 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50))
-(deftest-overlays-at-1 P 30 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50))
+(deftest-overlays-at-1 N3 1 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50))
+(deftest-overlays-at-1 O3 20 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50))
+(deftest-overlays-at-1 P3 30 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50))
(deftest-overlays-at-1 Q 40 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50))
(deftest-overlays-at-1 R 50 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50))
(deftest-overlays-at-1 S 60 () (a 1 60) (c 1 1) (b 30 30) (d 50 50))
@@ -1107,7 +1109,7 @@ with parameters from the *Messages* buffer modification."
(should (eq ov (car (overlays-in 1 1)))))))))
;; properties
-(ert-deftest test-buffer-swap-text-1 ()
+(ert-deftest test-buffer-swap-text-2 ()
(buffer-tests--with-temp-buffers (buffer other)
(with-current-buffer other
(overlay-put (make-overlay 1 1) 'buffer 'other))
@@ -1421,66 +1423,63 @@ with parameters from the *Messages* buffer modification."
(should (= (length (overlays-in (point-min) (point-max))) 0))))
(ert-deftest test-kill-buffer-auto-save-default ()
- (let ((file (make-temp-file "ert"))
- auto-save)
- (should (file-exists-p file))
- ;; Always answer yes.
- (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t)))
- (unwind-protect
- (progn
- (find-file file)
- (auto-save-mode t)
- (insert "foo\n")
- (should buffer-auto-save-file-name)
- (setq auto-save buffer-auto-save-file-name)
- (do-auto-save)
- (should (file-exists-p auto-save))
- (kill-buffer (current-buffer))
- (should (file-exists-p auto-save)))
- (ignore-errors (delete-file file))
- (when auto-save
- (ignore-errors (delete-file auto-save)))))))
+ (ert-with-temp-file file
+ (let (auto-save)
+ ;; Always answer yes.
+ (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t)))
+ (unwind-protect
+ (progn
+ (find-file file)
+ (auto-save-mode t)
+ (insert "foo\n")
+ (should buffer-auto-save-file-name)
+ (setq auto-save buffer-auto-save-file-name)
+ (do-auto-save)
+ (should (file-exists-p auto-save))
+ (kill-buffer (current-buffer))
+ (should (file-exists-p auto-save)))
+ (when auto-save
+ (ignore-errors (delete-file auto-save))))))))
(ert-deftest test-kill-buffer-auto-save-delete ()
- (let ((file (make-temp-file "ert"))
- auto-save)
- (should (file-exists-p file))
- (setq kill-buffer-delete-auto-save-files t)
- ;; Always answer yes.
- (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t)))
- (unwind-protect
- (progn
- (find-file file)
- (auto-save-mode t)
- (insert "foo\n")
- (should buffer-auto-save-file-name)
- (setq auto-save buffer-auto-save-file-name)
- (do-auto-save)
- (should (file-exists-p auto-save))
- ;; This should delete the auto-save file.
- (kill-buffer (current-buffer))
- (should-not (file-exists-p auto-save)))
- (ignore-errors (delete-file file))
- (when auto-save
- (ignore-errors (delete-file auto-save)))))
- ;; Answer no to deletion.
- (cl-letf (((symbol-function #'yes-or-no-p)
- (lambda (prompt)
- (not (string-search "Delete auto-save file" prompt)))))
- (unwind-protect
- (progn
- (find-file file)
- (auto-save-mode t)
- (insert "foo\n")
- (should buffer-auto-save-file-name)
- (setq auto-save buffer-auto-save-file-name)
- (do-auto-save)
- (should (file-exists-p auto-save))
- ;; This should not delete the auto-save file.
- (kill-buffer (current-buffer))
- (should (file-exists-p auto-save)))
- (ignore-errors (delete-file file))
- (when auto-save
- (ignore-errors (delete-file auto-save)))))))
+ (ert-with-temp-file file
+ (let (auto-save)
+ (should (file-exists-p file))
+ (setq kill-buffer-delete-auto-save-files t)
+ ;; Always answer yes.
+ (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t)))
+ (unwind-protect
+ (progn
+ (find-file file)
+ (auto-save-mode t)
+ (insert "foo\n")
+ (should buffer-auto-save-file-name)
+ (setq auto-save buffer-auto-save-file-name)
+ (do-auto-save)
+ (should (file-exists-p auto-save))
+ ;; This should delete the auto-save file.
+ (kill-buffer (current-buffer))
+ (should-not (file-exists-p auto-save)))
+ (ignore-errors (delete-file file))
+ (when auto-save
+ (ignore-errors (delete-file auto-save)))))
+ ;; Answer no to deletion.
+ (cl-letf (((symbol-function #'yes-or-no-p)
+ (lambda (prompt)
+ (not (string-search "Delete auto-save file" prompt)))))
+ (unwind-protect
+ (progn
+ (find-file file)
+ (auto-save-mode t)
+ (insert "foo\n")
+ (should buffer-auto-save-file-name)
+ (setq auto-save buffer-auto-save-file-name)
+ (do-auto-save)
+ (should (file-exists-p auto-save))
+ ;; This should not delete the auto-save file.
+ (kill-buffer (current-buffer))
+ (should (file-exists-p auto-save)))
+ (when auto-save
+ (ignore-errors (delete-file auto-save))))))))
;;; buffer-tests.el ends here
diff --git a/test/src/casefiddle-tests.el b/test/src/casefiddle-tests.el
index 9fa54dcaf43..dbbe9f30925 100644
--- a/test/src/casefiddle-tests.el
+++ b/test/src/casefiddle-tests.el
@@ -278,4 +278,20 @@
(with-temp-buffer
(should-error (upcase-region nil nil t)))))
+(ert-deftest casefiddle-turkish ()
+ (skip-unless (member "tr_TR.utf8" (get-locale-names)))
+ ;; See bug#50752. The point is that unibyte and multibyte strings
+ ;; are upcased differently in the "dotless i" case in Turkish,
+ ;; turning ASCII into non-ASCII, which is very unusual.
+ (with-locale-environment "tr_TR.utf8"
+ (should (string-equal (downcase "I ı") "ı ı"))
+ (should (string-equal (downcase "İ i") "i̇ i"))
+ (should (string-equal (downcase "I") "i"))
+ (should (string-equal (capitalize "bIte") "Bite"))
+ (should (string-equal (capitalize "bIté") "Bıté"))
+ (should (string-equal (capitalize "indIa") "India"))
+ ;; This does not work -- it produces "Indıa".
+ ;;(should (string-equal (capitalize "indIá") "İndıa"))
+ ))
+
;;; casefiddle-tests.el ends here
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index ecf62a4c128..5b20cf38ec6 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -28,17 +28,23 @@
(require 'ert)
(require 'ert-x)
(require 'cl-lib)
+(require 'comp)
+(require 'comp-cstr)
-(defconst comp-test-src (ert-resource-file "comp-test-funcs.el"))
+(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"))
-
-(when (featurep 'native-compile)
- (require 'comp)
+(when (native-comp-available-p)
(message "Compiling tests...")
(load (native-compile comp-test-src))
(load (native-compile comp-test-dyn-src)))
+;; Load the test code here so the compiler can check the function
+;; 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!
+
(defmacro comp-deftest (name args &rest docstring-and-body)
"Define a test for the native compiler tagging it as :nativecomp."
(declare (indent defun)
@@ -53,30 +59,32 @@
"Compile the compiler and load it to compile it-self.
Check that the resulting binaries do not differ."
:tags '(:expensive-test :nativecomp)
- (let* ((byte+native-compile t) ; FIXME HACK
- (comp-src (expand-file-name "../../../lisp/emacs-lisp/comp.el"
+ (ert-with-temp-file comp1-src
+ :suffix "-comp-stage1.el"
+ (ert-with-temp-file comp2-src
+ :suffix "-comp-stage2.el"
+ (let* ((byte+native-compile t) ; FIXME HACK
+ (comp-src (expand-file-name "../../../lisp/emacs-lisp/comp.el"
(ert-resource-directory)))
- (comp1-src (make-temp-file "stage1-" nil ".el"))
- (comp2-src (make-temp-file "stage2-" nil ".el"))
- ;; Can't use debug symbols.
- (native-comp-debug 0))
- (copy-file comp-src comp1-src t)
- (copy-file comp-src comp2-src t)
- (let ((load-no-native t))
- (load (concat comp-src "c") nil nil t t))
- (should-not (subr-native-elisp-p (symbol-function #'native-compile)))
- (message "Compiling stage1...")
- (let* ((t0 (current-time))
- (comp1-eln (native-compile comp1-src)))
- (message "Done in %d secs" (float-time (time-since t0)))
- (load comp1-eln nil nil t t)
- (should (subr-native-elisp-p (symbol-function 'native-compile)))
- (message "Compiling stage2...")
- (let ((t0 (current-time))
- (comp2-eln (native-compile comp2-src)))
- (message "Done in %d secs" (float-time (time-since t0)))
- (message "Comparing %s %s" comp1-eln comp2-eln)
- (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0))))))
+ ;; Can't use debug symbols.
+ (native-comp-debug 0))
+ (copy-file comp-src comp1-src t)
+ (copy-file comp-src comp2-src t)
+ (let ((load-no-native t))
+ (load (concat comp-src "c") nil nil t t))
+ (should-not (subr-native-elisp-p (symbol-function 'native-compile)))
+ (message "Compiling stage1...")
+ (let* ((t0 (current-time))
+ (comp1-eln (native-compile comp1-src)))
+ (message "Done in %d secs" (float-time (time-since t0)))
+ (load comp1-eln nil nil t t)
+ (should (subr-native-elisp-p (symbol-function 'native-compile)))
+ (message "Compiling stage2...")
+ (let ((t0 (current-time))
+ (comp2-eln (native-compile comp2-src)))
+ (message "Done in %d secs" (float-time (time-since t0)))
+ (message "Comparing %s %s" comp1-eln comp2-eln)
+ (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0))))))))
(comp-deftest provide ()
"Testing top level provide."
@@ -350,6 +358,8 @@ Check that the resulting binaries do not differ."
comp-test-interactive-form2-f)))
(should-not (commandp #'comp-tests-doc-f)))
+(declare-function comp-tests-free-fun-f nil)
+
(comp-deftest free-fun ()
"Check we are able to compile a single function."
(eval '(defun comp-tests-free-fun-f ()
@@ -359,7 +369,7 @@ Check that the resulting binaries do not differ."
t)
(native-compile #'comp-tests-free-fun-f)
- (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f)))
+ (should (subr-native-elisp-p (symbol-function 'comp-tests-free-fun-f)))
(should (= (comp-tests-free-fun-f) 3))
(should (string= (documentation #'comp-tests-free-fun-f)
"Some doc."))
@@ -367,11 +377,13 @@ Check that the resulting binaries do not differ."
(should (equal (interactive-form #'comp-tests-free-fun-f)
'(interactive))))
+(declare-function comp-tests/free\fun-f nil)
+
(comp-deftest free-fun-silly-name ()
"Check we are able to compile a single function."
(eval '(defun comp-tests/free\fun-f ()) t)
(native-compile #'comp-tests/free\fun-f)
- (should (subr-native-elisp-p (symbol-function #'comp-tests/free\fun-f))))
+ (should (subr-native-elisp-p (symbol-function 'comp-tests/free\fun-f))))
(comp-deftest bug-40187 ()
"Check function name shadowing.
@@ -382,7 +394,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html."
(comp-deftest speed--1 ()
"Check that at speed -1 we do not native compile."
(should (= (comp-test-speed--1-f) 3))
- (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f))))
+ (should-not (subr-native-elisp-p (symbol-function 'comp-test-speed--1-f))))
(comp-deftest bug-42360 ()
"<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-07/msg00418.html>."
@@ -431,7 +443,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html."
(comp-deftest primitive-redefine ()
"Test effectiveness of primitive redefinition."
(cl-letf ((comp-test-primitive-redefine-args nil)
- ((symbol-function #'-)
+ ((symbol-function '-)
(lambda (&rest args)
(setq comp-test-primitive-redefine-args args)
'xxx)))
@@ -452,11 +464,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html."
(comp-deftest comp-test-defsubst ()
;; Bug#42664, Bug#43280, Bug#44209.
- (should-not (subr-native-elisp-p (symbol-function #'comp-test-defsubst-f))))
+ (should-not (subr-native-elisp-p (symbol-function 'comp-test-defsubst-f))))
(comp-deftest primitive-redefine-compile-44221 ()
"Test the compiler still works while primitives are redefined (bug#44221)."
- (cl-letf (((symbol-function #'delete-region)
+ (cl-letf (((symbol-function 'delete-region)
(lambda (_ _))))
(should (subr-native-elisp-p
(native-compile
@@ -492,12 +504,12 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html."
(comp-deftest 45603-1 ()
"<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01994.html>"
(load (native-compile (ert-resource-file "comp-test-45603.el")))
- (should (fboundp #'comp-test-45603--file-local-name)))
+ (should (fboundp 'comp-test-45603--file-local-name)))
(comp-deftest 46670-1 ()
"<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-02/msg01413.html>"
(should (string= (comp-test-46670-2-f "foo") "foo"))
- (should (equal (subr-type (symbol-function #'comp-test-46670-2-f))
+ (should (equal (subr-type (symbol-function 'comp-test-46670-2-f))
'(function (t) t))))
(comp-deftest 46824-1 ()
@@ -727,7 +739,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html."
(comp-deftest dynamic-help-arglist ()
"Test `help-function-arglist' works on lisp/d (bug#42572)."
(should (equal (help-function-arglist
- (symbol-function #'comp-tests-ffuncall-callee-opt-rest-dyn-f)
+ (symbol-function 'comp-tests-ffuncall-callee-opt-rest-dyn-f)
t)
'(a b &optional c &rest d))))
@@ -784,6 +796,8 @@ Return a list of results."
(comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t)
insn)))))))
+(declare-function comp-tests-tco-f nil)
+
(comp-deftest tco ()
"Check for tail recursion elimination."
(let ((native-comp-speed 3)
@@ -798,7 +812,7 @@ Return a list of results."
(comp-tests-tco-f (+ a b) a (- count 1))))
t)
(native-compile #'comp-tests-tco-f)
- (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f)))
+ (should (subr-native-elisp-p (symbol-function 'comp-tests-tco-f)))
(should (= (comp-tests-tco-f 1 0 10) 55))))
(defun comp-tests-fw-prop-checker-1 (_)
@@ -812,6 +826,8 @@ Return a list of results."
(or (comp-tests-mentioned-p 'concat insn)
(comp-tests-mentioned-p 'length insn)))))))
+(declare-function comp-tests-fw-prop-1-f nil)
+
(comp-deftest fw-prop-1 ()
"Some tests for forward propagation."
(let ((native-comp-speed 2)
@@ -823,7 +839,7 @@ Return a list of results."
(length c))) ; <= has to optimize
t)
(native-compile #'comp-tests-fw-prop-1-f)
- (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f)))
+ (should (subr-native-elisp-p (symbol-function 'comp-tests-fw-prop-1-f)))
(should (= (comp-tests-fw-prop-1-f) 6))))
(defun comp-tests-check-ret-type-spec (func-form ret-type)
@@ -1403,11 +1419,13 @@ folded."
(comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1
comp-tests-pure-checker-2))))
(load (native-compile (ert-resource-file "comp-test-pure.el")))
+ (declare-function comp-tests-pure-caller-f nil)
+ (declare-function comp-tests-pure-fibn-entry-f nil)
- (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-caller-f)))
+ (should (subr-native-elisp-p (symbol-function 'comp-tests-pure-caller-f)))
(should (= (comp-tests-pure-caller-f) 4))
- (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-fibn-entry-f)))
+ (should (subr-native-elisp-p (symbol-function 'comp-tests-pure-fibn-entry-f)))
(should (= (comp-tests-pure-fibn-entry-f) 6765))))
(defvar comp-tests-cond-rw-checked-function nil
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index 756c41b6ff3..8cc271b9e1c 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -419,7 +419,7 @@ comparing the subr with a much slower Lisp implementation."
"Test setting a keyword constant."
(with-no-warnings (should-error (setq :keyword 'bob) :type 'setting-constant)))
-(ert-deftest binding-test-set-constant-nil ()
+(ert-deftest binding-test-set-constant-itself ()
"Test setting a keyword to itself."
(with-no-warnings (should (setq :keyword :keyword))))
@@ -433,26 +433,27 @@ comparing the subr with a much slower Lisp implementation."
;; More specifically, test the problem seen in bug#41029 where setting
;; the default value of a variable takes time proportional to the
;; number of buffers.
- (let* ((fun #'error)
- (test (lambda ()
- (with-temp-buffer
- (let ((st (car (current-cpu-time))))
- (dotimes (_ 1000)
- (let ((case-fold-search 'data-test))
- ;; Use an indirection through a mutable var
- ;; to try and make sure the byte-compiler
- ;; doesn't optimize away the let bindings.
- (funcall fun)))
- ;; FIXME: Handle the wraparound, if any.
- (- (car (current-cpu-time)) st)))))
- (_ (setq fun #'ignore))
- (time1 (funcall test))
- (bufs (mapcar (lambda (_) (generate-new-buffer " data-test"))
- (make-list 1000 nil)))
- (time2 (funcall test)))
- (mapc #'kill-buffer bufs)
- ;; Don't divide one time by the other since they may be 0.
- (should (< time2 (* time1 5)))))
+ (when (fboundp 'current-cpu-time) ; silence byte-compiler
+ (let* ((fun #'error)
+ (test (lambda ()
+ (with-temp-buffer
+ (let ((st (car (current-cpu-time))))
+ (dotimes (_ 1000)
+ (let ((case-fold-search 'data-test))
+ ;; Use an indirection through a mutable var
+ ;; to try and make sure the byte-compiler
+ ;; doesn't optimize away the let bindings.
+ (funcall fun)))
+ ;; FIXME: Handle the wraparound, if any.
+ (- (car (current-cpu-time)) st)))))
+ (_ (setq fun #'ignore))
+ (time1 (funcall test))
+ (bufs (mapcar (lambda (_) (generate-new-buffer " data-test"))
+ (make-list 1000 nil)))
+ (time2 (funcall test)))
+ (mapc #'kill-buffer bufs)
+ ;; Don't divide one time by the other since they may be 0.
+ (should (< time2 (* time1 5))))))
;; More tests to write -
;; kill-local-variable
@@ -690,7 +691,7 @@ comparing the subr with a much slower Lisp implementation."
(let ((n (* 2 most-negative-fixnum)))
(should (= (logand -1 n) n))))
-(ert-deftest data-tests-logcount ()
+(ert-deftest data-tests-logcount-2 ()
(should (= (logcount (read "#xffffffffffffffffffffffffffffffff")) 128)))
(ert-deftest data-tests-logior ()
diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el
index a731a95ccf0..6b2eb32396e 100644
--- a/test/src/editfns-tests.el
+++ b/test/src/editfns-tests.el
@@ -23,16 +23,16 @@
(ert-deftest format-properties ()
;; Bug #23730
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (propertize "%d" 'face '(:background "red")) 1)
#("1" 0 1 (face (:background "red")))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (propertize "%2d" 'face '(:background "red")) 1)
#(" 1" 0 2 (face (:background "red")))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (propertize "%02d" 'face '(:background "red")) 1)
#("01" 0 2 (face (:background "red")))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (concat (propertize "%2d" 'x 'X)
(propertize "a" 'a 'A)
(propertize "b" 'b 'B))
@@ -40,27 +40,27 @@
#(" 1ab" 0 2 (x X) 2 3 (a A) 3 4 (b B))))
;; Bug #5306
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format "%.10s"
(concat "1234567890aaaa"
(propertize "12345678901234567890" 'xxx 25)))
"1234567890"))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format "%.10s"
(concat "123456789"
(propertize "12345678901234567890" 'xxx 25)))
#("1234567891" 9 10 (xxx 25))))
;; Bug #23859
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format "%4s" (propertize "hi" 'face 'bold))
#(" hi" 2 4 (face bold))))
;; Bug #23897
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format "%s" (concat (propertize "01234" 'face 'bold) "56789"))
#("0123456789" 0 5 (face bold))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format "%s" (concat (propertize "01" 'face 'bold)
(propertize "23" 'face 'underline)
"45"))
@@ -68,63 +68,63 @@
;; The last property range is extended to include padding on the
;; right, but the first range is not extended to the left to include
;; padding on the left!
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format "%12s" (concat (propertize "01234" 'face 'bold) "56789"))
#(" 0123456789" 2 7 (face bold))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format "%-12s" (concat (propertize "01234" 'face 'bold) "56789"))
#("0123456789 " 0 5 (face bold))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format "%10s" (concat (propertize "01" 'face 'bold)
(propertize "23" 'face 'underline)
"45"))
#(" 012345" 4 6 (face bold) 6 8 (face underline))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format "%-10s" (concat (propertize "01" 'face 'bold)
(propertize "23" 'face 'underline)
"45"))
#("012345 " 0 2 (face bold) 2 4 (face underline))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format "%-10s" (concat (propertize "01" 'face 'bold)
(propertize "23" 'face 'underline)
(propertize "45" 'face 'italic)))
#("012345 "
0 2 (face bold) 2 4 (face underline) 4 10 (face italic))))
;; Bug #38191
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (propertize "‘foo’ %s bar" 'face 'bold) "xxx")
#("‘foo’ xxx bar" 0 13 (face bold))))
;; Bug #32404
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (concat (propertize "%s" 'face 'bold)
""
(propertize "%s" 'face 'error))
"foo" "bar")
#("foobar" 0 3 (face bold) 3 6 (face error))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (concat "%s" (propertize "%s" 'face 'error)) "foo" "bar")
#("foobar" 3 6 (face error))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (concat "%s " (propertize "%s" 'face 'error)) "foo" "bar")
#("foo bar" 4 7 (face error))))
;; Bug #46317
(let ((s (propertize "X" 'prop "val")))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (concat "%3s/" s) 12)
#(" 12/X" 4 5 (prop "val"))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (concat "%3S/" s) 12)
#(" 12/X" 4 5 (prop "val"))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (concat "%3d/" s) 12)
#(" 12/X" 4 5 (prop "val"))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (concat "%-3s/" s) 12)
#("12 /X" 4 5 (prop "val"))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (concat "%-3S/" s) 12)
#("12 /X" 4 5 (prop "val"))))
- (should (ert-equal-including-properties
+ (should (equal-including-properties
(format (concat "%-3d/" s) 12)
#("12 /X" 4 5 (prop "val"))))))
@@ -413,4 +413,17 @@
(translate-region-internal (point-min) (point-max) tt)
(should (string-equal (buffer-string) "*")))))
+(ert-deftest find-fields ()
+ (with-temp-buffer
+ (insert "foo" (propertize "bar" 'field 'bar) "zot")
+ (goto-char (point-min))
+ (should (= (field-beginning) (point-min)))
+ (should (= (field-end) 4))
+ (goto-char 5)
+ (should (= (field-beginning) 4))
+ (should (= (field-end) 7))
+ (goto-char 8)
+ (should (= (field-beginning) 7))
+ (should (= (field-end) (point-max)))))
+
;;; editfns-tests.el ends here
diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el
index 646c7bb2705..988b311f5b5 100644
--- a/test/src/emacs-module-tests.el
+++ b/test/src/emacs-module-tests.el
@@ -32,6 +32,11 @@
(require 'help-fns)
(require 'subr-x)
+;; Catch information for bug#50902.
+(when (getenv "EMACS_EMBA_CI")
+ (start-process-shell-command
+ "*timeout*" nil (format "sleep 60; kill -ABRT %d" (emacs-pid))))
+
(defconst mod-test-emacs
(expand-file-name invocation-name invocation-directory)
"File name of the Emacs binary currently running.")
@@ -206,20 +211,6 @@ changes."
(should (equal (help-function-arglist #'mod-test-sum)
'(arg1 arg2))))
-(defmacro module--with-temp-directory (name &rest body)
- "Bind NAME to the name of a temporary directory and evaluate BODY.
-NAME must be a symbol. Delete the temporary directory after BODY
-exits normally or non-locally. NAME will be bound to the
-directory name (not the directory file name) of the temporary
-directory."
- (declare (indent 1))
- (cl-check-type name symbol)
- `(let ((,name (file-name-as-directory
- (make-temp-file "emacs-module-test" :directory))))
- (unwind-protect
- (progn ,@body)
- (delete-directory ,name :recursive))))
-
(defmacro module--test-assertion (pattern &rest body)
"Test that PATTERN matches the assertion triggered by BODY.
Run Emacs as a subprocess, load the test module `mod-test-file',
@@ -228,7 +219,7 @@ assertion message that matches PATTERN. PATTERN is evaluated and
must evaluate to a regular expression string."
(declare (indent 1))
;; To contain any core dumps.
- `(module--with-temp-directory tempdir
+ `(ert-with-temp-directory tempdir
(with-temp-buffer
(let* ((default-directory tempdir)
(status (call-process mod-test-emacs nil t nil
@@ -256,6 +247,7 @@ must evaluate to a regular expression string."
(ert-deftest module--test-assertions--load-non-live-object ()
"Check that -module-assertions verify that non-live objects aren't accessed."
+ :tags (if (getenv "EMACS_EMBA_CI") '(:unstable))
(skip-unless (or (file-executable-p mod-test-emacs)
(and (eq system-type 'windows-nt)
(file-executable-p (concat mod-test-emacs ".exe")))))
@@ -274,6 +266,7 @@ must evaluate to a regular expression string."
This differs from `module--test-assertions-load-non-live-object'
in that it stows away a global reference. The module assertions
should nevertheless detect the invalid load."
+ :tags (if (getenv "EMACS_EMBA_CI") '(:unstable))
(skip-unless (or (file-executable-p mod-test-emacs)
(and (eq system-type 'windows-nt)
(file-executable-p (concat mod-test-emacs ".exe")))))
@@ -290,6 +283,7 @@ should nevertheless detect the invalid load."
(ert-deftest module--test-assertions--call-emacs-from-gc ()
"Check that -module-assertions prevents calling Emacs functions
during garbage collection."
+ :tags (if (getenv "EMACS_EMBA_CI") '(:unstable))
(skip-unless (or (file-executable-p mod-test-emacs)
(and (eq system-type 'windows-nt)
(file-executable-p (concat mod-test-emacs ".exe")))))
@@ -301,7 +295,8 @@ during garbage collection."
(ert-deftest module--test-assertions--globref-invalid-free ()
"Check that -module-assertions detects invalid freeing of a
local reference."
- (skip-unless (or (file-executable-p mod-test-emacs)
+ :tags (if (getenv "EMACS_EMBA_CI") '(:unstable))
+ (skip-unless (or (file-executable-p mod-test-emacs)
(and (eq system-type 'windows-nt)
(file-executable-p (concat mod-test-emacs ".exe")))))
(module--test-assertion
diff --git a/test/src/emacs-tests.el b/test/src/emacs-tests.el
index ac08e055b55..a1a412423cb 100644
--- a/test/src/emacs-tests.el
+++ b/test/src/emacs-tests.el
@@ -25,6 +25,7 @@
(require 'cl-lib)
(require 'ert)
+(require 'ert-x) ; ert-with-temp-file
(require 'rx)
(require 'subr-x)
@@ -46,22 +47,6 @@
"--seccomp=/does-not-exist.bpf")
0))))
-(cl-defmacro emacs-tests--with-temp-file
- (var (prefix &optional suffix text) &rest body)
- "Evaluate BODY while a new temporary file exists.
-Bind VAR to the name of the file. Pass PREFIX, SUFFIX, and TEXT
-to `make-temp-file', which see."
- (declare (indent 2) (debug (symbolp (form form form) body)))
- (cl-check-type var symbol)
- ;; Use an uninterned symbol so that the code still works if BODY
- ;; changes VAR.
- (let ((filename (make-symbol "filename")))
- `(let ((,filename (make-temp-file ,prefix nil ,suffix ,text)))
- (unwind-protect
- (let ((,var ,filename))
- ,@body)
- (delete-file ,filename)))))
-
(ert-deftest emacs-tests/seccomp/empty-file ()
(skip-unless (string-match-p (rx bow "SECCOMP" eow)
system-configuration-features))
@@ -69,7 +54,8 @@ to `make-temp-file', which see."
(expand-file-name invocation-name invocation-directory))
(process-environment nil))
(skip-unless (file-executable-p emacs))
- (emacs-tests--with-temp-file filter ("seccomp-invalid-" ".bpf")
+ (ert-with-temp-file filter
+ :prefix "seccomp-invalid-" :suffix ".bpf"
;; The --seccomp option is processed early, without filename
;; handlers. Therefore remote or quoted filenames wouldn't
;; work.
@@ -94,9 +80,9 @@ to `make-temp-file', which see."
;; Either 8 or 16, but 16 should be large enough in all cases.
(filter-size 16))
(skip-unless (file-executable-p emacs))
- (emacs-tests--with-temp-file
- filter ("seccomp-too-large-" ".bpf"
- (make-string (* (1+ ushort-max) filter-size) ?a))
+ (ert-with-temp-file filter
+ :prefix "seccomp-too-large-" :suffix ".bpf"
+ :text (make-string (* (1+ ushort-max) filter-size) ?a)
;; The --seccomp option is processed early, without filename
;; handlers. Therefore remote or quoted filenames wouldn't
;; work.
@@ -117,8 +103,8 @@ to `make-temp-file', which see."
(expand-file-name invocation-name invocation-directory))
(process-environment nil))
(skip-unless (file-executable-p emacs))
- (emacs-tests--with-temp-file filter ("seccomp-invalid-" ".bpf"
- "123456")
+ (ert-with-temp-file filter
+ :prefix "seccomp-invalid-" :suffix ".bpf" :text "123456"
;; The --seccomp option is processed early, without filename
;; handlers. Therefore remote or quoted filenames wouldn't
;; work.
diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el
index 3c3e7033419..727c98aa5fa 100644
--- a/test/src/eval-tests.el
+++ b/test/src/eval-tests.el
@@ -86,23 +86,27 @@ Bug#24912."
(ert-deftest eval-tests--if-dot-string ()
"Check that Emacs rejects (if . \"string\")."
- (should-error (eval '(if . "abc")) :type 'wrong-type-argument)
+ (should-error (eval '(if . "abc") nil) :type 'wrong-type-argument)
+ (should-error (eval '(if . "abc") t) :type 'wrong-type-argument)
(let ((if-tail (list '(setcdr if-tail "abc") t)))
- (should-error (eval (cons 'if if-tail))))
+ (should-error (eval (cons 'if if-tail) nil) :type 'void-variable)
+ (should-error (eval (cons 'if if-tail) t) :type 'void-variable))
(let ((if-tail (list '(progn (setcdr if-tail "abc") nil) t)))
- (should-error (eval (cons 'if if-tail)))))
+ (should-error (eval (cons 'if if-tail) nil) :type 'void-variable)
+ (should-error (eval (cons 'if if-tail) t) :type 'void-variable)))
(ert-deftest eval-tests--let-with-circular-defs ()
"Check that Emacs reports an error for (let VARS ...) when VARS is circular."
(let ((vars (list 'v)))
(setcdr vars vars)
(dolist (let-sym '(let let*))
- (should-error (eval (list let-sym vars))))))
+ (should-error (eval (list let-sym vars) nil)))))
(ert-deftest eval-tests--mutating-cond ()
"Check that Emacs doesn't crash on a cond clause that mutates during eval."
(let ((clauses (list '((progn (setcdr clauses "ouch") nil)))))
- (should-error (eval (cons 'cond clauses)))))
+ (should-error (eval (cons 'cond clauses) nil))
+ (should-error (eval (cons 'cond clauses) t))))
(defun eval-tests--exceed-specbind-limit ()
(defvar eval-tests--var1)
@@ -179,12 +183,13 @@ are found on the stack and therefore not garbage collected."
"Remove the Lisp reference to the byte-compiled object."
(setf (symbol-function #'eval-tests-33014-func) nil))
-(defun eval-tests-19790-backquote-comma-dot-substitution ()
+(ert-deftest eval-tests-19790-backquote-comma-dot-substitution ()
"Regression test for Bug#19790.
Don't handle destructive splicing in backquote expressions (like
in Common Lisp). Instead, make sure substitution in backquote
expressions works for identifiers starting with period."
- (should (equal (let ((.x 'identity)) (eval `(,.x 'ok))) 'ok)))
+ (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) nil)) 'ok))
+ (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) t)) 'ok)))
(ert-deftest eval-tests/backtrace-in-batch-mode ()
(let ((emacs (expand-file-name invocation-name invocation-directory)))
diff --git a/test/src/filelock-tests.el b/test/src/filelock-tests.el
index a96d6d67289..24dd37e5a4d 100644
--- a/test/src/filelock-tests.el
+++ b/test/src/filelock-tests.el
@@ -28,6 +28,7 @@
(require 'cl-macs)
(require 'ert)
+(require 'ert-x)
(require 'seq)
(defun filelock-tests--fixture (test-function)
@@ -36,22 +37,20 @@ Create a test directory and a buffer whose `buffer-file-name' and
`buffer-file-truename' are a file within it, then call
TEST-FUNCTION. Finally, delete the buffer and the test
directory."
- (let* ((temp-dir (make-temp-file "filelock-tests" t))
- (name (concat (file-name-as-directory temp-dir)
- "userfile"))
- (create-lockfiles t))
- (unwind-protect
- (with-temp-buffer
- (setq buffer-file-name name
- buffer-file-truename name)
- (unwind-protect
- (save-current-buffer
- (funcall test-function))
- ;; Set `buffer-file-truename' nil to prevent unlocking,
- ;; which might prompt the user and/or signal errors.
- (setq buffer-file-name nil
- buffer-file-truename nil)))
- (delete-directory temp-dir t nil))))
+ (ert-with-temp-directory temp-dir
+ (let ((name (concat (file-name-as-directory temp-dir)
+ "userfile"))
+ (create-lockfiles t))
+ (with-temp-buffer
+ (setq buffer-file-name name
+ buffer-file-truename name)
+ (unwind-protect
+ (save-current-buffer
+ (funcall test-function))
+ ;; Set `buffer-file-truename' nil to prevent unlocking,
+ ;; which might prompt the user and/or signal errors.
+ (setq buffer-file-name nil
+ buffer-file-truename nil))))))
(defun filelock-tests--make-lock-name (file-name)
"Return the lock file name for FILE-NAME.
@@ -124,7 +123,9 @@ the case)."
(filelock-tests--spoil-lock-file buffer-file-truename)
(let ((err (should-error (file-locked-p (buffer-file-name)))))
(should (equal (seq-subseq err 0 2)
- '(file-error "Testing file lock")))))))
+ (if (eq system-type 'windows-nt)
+ '(permission-denied "Testing file lock")
+ '(file-error "Testing file lock"))))))))
(ert-deftest filelock-tests-unlock-spoiled ()
"Check that `unlock-buffer' fails if the lockfile is \"spoiled\"."
@@ -145,8 +146,11 @@ the case)."
(lambda (err) (push err errors))))
(unlock-buffer))
(should (consp errors))
- (should (equal '(file-error "Unlocking file")
- (seq-subseq (car errors) 0 2)))
+ (should (equal
+ (if (eq system-type 'windows-nt)
+ '(permission-denied "Unlocking file")
+ '(file-error "Unlocking file"))
+ (seq-subseq (car errors) 0 2)))
(should (equal (length errors) 1))))))
(ert-deftest filelock-tests-kill-buffer-spoiled ()
@@ -175,8 +179,11 @@ the case)."
(lambda (err) (push err errors))))
(kill-buffer))
(should (consp errors))
- (should (equal '(file-error "Unlocking file")
- (seq-subseq (car errors) 0 2)))
+ (should (equal
+ (if (eq system-type 'windows-nt)
+ '(permission-denied "Unlocking file")
+ '(file-error "Unlocking file"))
+ (seq-subseq (car errors) 0 2)))
(should (equal (length errors) 1))))))
(provide 'filelock-tests)
diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el
index 47fa1941626..a066d2e15e2 100644
--- a/test/src/floatfns-tests.el
+++ b/test/src/floatfns-tests.el
@@ -21,6 +21,68 @@
(require 'ert)
+(ert-deftest floatfns-tests-cos ()
+ (should (= (cos 0) 1.0))
+ (should (= (cos float-pi) -1.0)))
+
+(ert-deftest floatfns-tests-sin ()
+ (should (= (sin 0) 0.0)))
+
+(ert-deftest floatfns-tests-tan ()
+ (should (= (tan 0) 0.0)))
+
+(ert-deftest floatfns-tests-isnan ()
+ (should (isnan 0.0e+NaN))
+ (should (isnan -0.0e+NaN))
+ (should-error (isnan "foo") :type 'wrong-type-argument))
+
+(ert-deftest floatfns-tests-exp ()
+ (should (= (exp 0) 1.0)))
+
+(ert-deftest floatfns-tests-expt ()
+ (should (= (expt 2 8) 256)))
+
+(ert-deftest floatfns-tests-log ()
+ (should (= (log 1000 10) 3.0)))
+
+(ert-deftest floatfns-tests-sqrt ()
+ (should (= (sqrt 25) 5)))
+
+(ert-deftest floatfns-tests-abs ()
+ (should (= (abs 10) 10))
+ (should (= (abs -10) 10)))
+
+(ert-deftest floatfns-tests-logb ()
+ (should (= (logb 10000) 13)))
+
+(ert-deftest floatfns-tests-ceiling ()
+ (should (= (ceiling 0.5) 1)))
+
+(ert-deftest floatfns-tests-floor ()
+ (should (= (floor 1.5) 1)))
+
+(ert-deftest floatfns-tests-round ()
+ (should (= (round 1.49999999999) 1))
+ (should (= (round 1.50000000000) 2))
+ (should (= (round 1.50000000001) 2)))
+
+(ert-deftest floatfns-tests-truncate ()
+ (should (= (truncate float-pi) 3)))
+
+(ert-deftest floatfns-tests-fceiling ()
+ (should (= (fceiling 0.5) 1.0)))
+
+(ert-deftest floatfns-tests-ffloor ()
+ (should (= (ffloor 1.5) 1.0)))
+
+(ert-deftest floatfns-tests-fround ()
+ (should (= (fround 1.49999999999) 1.0))
+ (should (= (fround 1.50000000000) 2.0))
+ (should (= (fround 1.50000000001) 2.0)))
+
+(ert-deftest floatfns-tests-ftruncate ()
+ (should (= (ftruncate float-pi) 3.0)))
+
(ert-deftest divide-extreme-sign ()
(should (= (ceiling most-negative-fixnum -1.0) (- most-negative-fixnum)))
(should (= (floor most-negative-fixnum -1.0) (- most-negative-fixnum)))
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 57594572094..bec5c03f9e7 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -23,6 +23,29 @@
(require 'cl-lib)
+(ert-deftest fns-tests-identity ()
+ (let ((num 12345)) (should (eq (identity num) num)))
+ (let ((str "foo")) (should (eq (identity str) str)))
+ (let ((lst '(11))) (should (eq (identity lst) lst))))
+
+(ert-deftest fns-tests-random ()
+ (should (integerp (random)))
+ (should (>= (random 10) 0))
+ (should (< (random 10) 10)))
+
+(ert-deftest fns-tests-length ()
+ (should (= (length nil) 0))
+ (should (= (length '(1 2 3)) 3))
+ (should (= (length '[1 2 3]) 3))
+ (should (= (length "foo") 3))
+ (should-error (length t)))
+
+(ert-deftest fns-tests-safe-length ()
+ (should (= (safe-length '(1 2 3)) 3)))
+
+(ert-deftest fns-tests-string-bytes ()
+ (should (= (string-bytes "abc") 3)))
+
;; Test that equality predicates work correctly on NaNs when combined
;; with hash tables based on those predicates. This was not the case
;; for eql in Emacs 26.
@@ -34,6 +57,33 @@
(puthash nan t h)
(should (eq (funcall test nan -nan) (gethash -nan h))))))
+(ert-deftest fns-tests-equal-including-properties ()
+ (should (equal-including-properties "" ""))
+ (should (equal-including-properties "foo" "foo"))
+ (should (equal-including-properties #("foo" 0 3 (a b))
+ (propertize "foo" 'a 'b)))
+ (should (equal-including-properties #("foo" 0 3 (a b c d))
+ (propertize "foo" 'a 'b 'c 'd)))
+ (should (equal-including-properties #("a" 0 1 (k v))
+ #("a" 0 1 (k v))))
+ (should-not (equal-including-properties #("a" 0 1 (k v))
+ #("a" 0 1 (k x))))
+ (should-not (equal-including-properties #("a" 0 1 (k v))
+ #("b" 0 1 (k v))))
+ (should-not (equal-including-properties #("foo" 0 3 (a b c e))
+ (propertize "foo" 'a 'b 'c 'd))))
+
+(ert-deftest fns-tests-equal-including-properties/string-prop-vals ()
+ "Handle string property values. (Bug#6581)"
+ (should (equal-including-properties #("a" 0 1 (k "v"))
+ #("a" 0 1 (k "v"))))
+ (should (equal-including-properties #("foo" 0 3 (a (t)))
+ (propertize "foo" 'a (list t))))
+ (should-not (equal-including-properties #("a" 0 1 (k "v"))
+ #("a" 0 1 (k "x"))))
+ (should-not (equal-including-properties #("a" 0 1 (k "v"))
+ #("b" 0 1 (k "v")))))
+
(ert-deftest fns-tests-reverse ()
(should-error (reverse))
(should-error (reverse 1))
@@ -430,6 +480,23 @@
(buffer-hash))
(sha1 "foo"))))
+(ert-deftest fns-tests-mapconcat ()
+ (should (string= (mapconcat #'identity '()) ""))
+ (should (string= (mapconcat #'identity '("a" "b")) "ab"))
+ (should (string= (mapconcat #'identity '() "_") ""))
+ (should (string= (mapconcat #'identity '("A") "_") "A"))
+ (should (string= (mapconcat #'identity '("A" "B") "_") "A_B"))
+ (should (string= (mapconcat #'identity '("A" "B" "C") "_") "A_B_C"))
+ ;; non-ASCII strings
+ (should (string= (mapconcat #'identity '("Ä" "ø" "☭" "தமிழ்") "_漢字_")
+ "Ä_漢字_ø_漢字_☭_漢字_தமிழ்"))
+ ;; vector
+ (should (string= (mapconcat #'identity ["a" "b"] "") "ab"))
+ ;; bool-vector
+ (should (string= (mapconcat #'identity [nil nil] "") ""))
+ (should-error (mapconcat #'identity [nil nil t])
+ :type 'wrong-type-argument))
+
(ert-deftest fns-tests-mapcan ()
(should-error (mapcan))
(should-error (mapcan #'identity))
diff --git a/test/src/image-tests.el b/test/src/image-tests.el
new file mode 100644
index 00000000000..2b236086b6f
--- /dev/null
+++ b/test/src/image-tests.el
@@ -0,0 +1,245 @@
+;;; image-tests.el --- Tests for image.c -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: Stefan Kangas <stefan@marxist.se>
+
+;; 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:
+
+;; Most of these tests will only run in a GUI session, and not with
+;; "make check". Run them manually in an interactive session with
+;; `M-x eval-buffer' followed by `M-x ert'.
+
+;;; Code:
+
+(require 'ert)
+
+(defmacro image-skip-unless (format)
+ `(skip-unless (and (display-images-p)
+ (image-type-available-p ,format))))
+
+;;;; Images
+
+(defconst image-tests--images
+ `((gif . ,(expand-file-name "test/data/image/black.gif"
+ source-directory))
+ (jpeg . ,(expand-file-name "test/data/image/black.jpg"
+ source-directory))
+ (pbm . ,(find-image '((:file "splash.svg" :type svg))))
+ (png . ,(find-image '((:file "splash.png" :type png))))
+ (svg . ,(find-image '((:file "splash.pbm" :type pbm))))
+ (tiff . ,(expand-file-name
+ "nextstep/GNUstep/Emacs.base/Resources/emacs.tiff"
+ source-directory))
+ (webp . ,(expand-file-name "test/data/image/black.webp"
+ source-directory))
+ (xbm . ,(find-image '((:file "gnus/gnus.xbm" :type xbm))))
+ (xpm . ,(find-image '((:file "splash.xpm" :type xpm))))))
+
+;;;; image-test-size
+
+(ert-deftest image-tests-image-size/gif ()
+ (image-skip-unless 'gif)
+ (pcase (image-size (create-image (cdr (assq 'gif image-tests--images))))
+ (`(,a . ,b)
+ (should (floatp a))
+ (should (floatp b)))))
+
+(ert-deftest image-tests-image-size/jpeg ()
+ (image-skip-unless 'jpeg)
+ (pcase (image-size (create-image (cdr (assq 'jpeg image-tests--images))))
+ (`(,a . ,b)
+ (should (floatp a))
+ (should (floatp b)))))
+
+(ert-deftest image-tests-image-size/pbm ()
+ (image-skip-unless 'pbm)
+ (pcase (image-size (cdr (assq 'pbm image-tests--images)))
+ (`(,a . ,b)
+ (should (floatp a))
+ (should (floatp b)))))
+
+(ert-deftest image-tests-image-size/png ()
+ (image-skip-unless 'png)
+ (pcase (image-size (cdr (assq 'png image-tests--images)))
+ (`(,a . ,b)
+ (should (floatp a))
+ (should (floatp b)))))
+
+(ert-deftest image-tests-image-size/svg ()
+ (image-skip-unless 'svg)
+ (pcase (image-size (cdr (assq 'svg image-tests--images)))
+ (`(,a . ,b)
+ (should (floatp a))
+ (should (floatp b)))))
+
+(ert-deftest image-tests-image-size/tiff ()
+ (image-skip-unless 'tiff)
+ (pcase (image-size (create-image (cdr (assq 'tiff image-tests--images))))
+ (`(,a . ,b)
+ (should (floatp a))
+ (should (floatp b)))))
+
+(ert-deftest image-tests-image-size/webp ()
+ (image-skip-unless 'webp)
+ (pcase (image-size (create-image (cdr (assq 'webp image-tests--images))))
+ (`(,a . ,b)
+ (should (floatp a))
+ (should (floatp b)))))
+
+(ert-deftest image-tests-image-size/xbm ()
+ (image-skip-unless 'xbm)
+ (pcase (image-size (cdr (assq 'xbm image-tests--images)))
+ (`(,a . ,b)
+ (should (floatp a))
+ (should (floatp b)))))
+
+(ert-deftest image-tests-image-size/xpm ()
+ (image-skip-unless 'xpm)
+ (pcase (image-size (cdr (assq 'xpm image-tests--images)))
+ (`(,a . ,b)
+ (should (floatp a))
+ (should (floatp b)))))
+
+(ert-deftest image-tests-image-size/error-on-invalid-spec ()
+ (skip-unless (display-images-p))
+ (should-error (image-size 'invalid-spec)))
+
+(ert-deftest image-tests-image-size/error-on-nongraphical-display ()
+ (skip-unless (not (display-images-p)))
+ (should-error (image-size 'invalid-spec)))
+
+;;;; image-mask-p
+
+(ert-deftest image-tests-image-mask-p/gif ()
+ (image-skip-unless 'gif)
+ (should-not (image-mask-p (create-image
+ (cdr (assq 'gif image-tests--images))))))
+
+(ert-deftest image-tests-image-mask-p/jpeg ()
+ (image-skip-unless 'jpeg)
+ (should-not (image-mask-p (create-image
+ (cdr (assq 'jpeg image-tests--images))))))
+
+(ert-deftest image-tests-image-mask-p/pbm ()
+ (image-skip-unless 'pbm)
+ (should-not (image-mask-p (cdr (assq 'pbm image-tests--images)))))
+
+(ert-deftest image-tests-image-mask-p/png ()
+ (image-skip-unless 'png)
+ (should-not (image-mask-p (cdr (assq 'png image-tests--images)))))
+
+(ert-deftest image-tests-image-mask-p/svg ()
+ (image-skip-unless 'svg)
+ (should-not (image-mask-p (cdr (assq 'svg image-tests--images)))))
+
+(ert-deftest image-tests-image-mask-p/tiff ()
+ (image-skip-unless 'tiff)
+ (should-not (image-mask-p (create-image
+ (cdr (assq 'tiff image-tests--images))))))
+
+(ert-deftest image-tests-image-mask-p/webp ()
+ (image-skip-unless 'webp)
+ (should-not (image-mask-p (create-image
+ (cdr (assq 'webp image-tests--images))))))
+
+(ert-deftest image-tests-image-mask-p/xbm ()
+ (image-skip-unless 'xbm)
+ (should-not (image-mask-p (cdr (assq 'xbm image-tests--images)))))
+
+(ert-deftest image-tests-image-mask-p/xpm ()
+ (image-skip-unless 'xpm)
+ (should-not (image-mask-p (cdr (assq 'xpm image-tests--images)))))
+
+(ert-deftest image-tests-image-mask-p/error-on-invalid-spec ()
+ (skip-unless (display-images-p))
+ (should-error (image-mask-p 'invalid-spec)))
+
+(ert-deftest image-tests-image-mask-p/error-on-nongraphical-display ()
+ (skip-unless (not (display-images-p)))
+ (should-error (image-mask-p (cdr (assq 'xpm image-tests--images)))))
+
+;;;; image-metadata
+
+;; TODO: These tests could be expanded with files that actually
+;; contain metadata.
+
+(ert-deftest image-tests-image-metadata/gif ()
+ (image-skip-unless 'gif)
+ (should-not (image-metadata
+ (create-image (cdr (assq 'gif image-tests--images))))))
+
+(ert-deftest image-tests-image-metadata/jpeg ()
+ (image-skip-unless 'jpeg)
+ (should-not (image-metadata
+ (create-image (cdr (assq 'jpeg image-tests--images))))))
+
+(ert-deftest image-tests-image-metadata/pbm ()
+ (image-skip-unless 'pbm)
+ (should-not (image-metadata (cdr (assq 'pbm image-tests--images)))))
+
+(ert-deftest image-tests-image-metadata/png ()
+ (image-skip-unless 'png)
+ (should-not (image-metadata (cdr (assq 'png image-tests--images)))))
+
+(ert-deftest image-tests-image-metadata/svg ()
+ (image-skip-unless 'svg)
+ (should-not (image-metadata (cdr (assq 'svg image-tests--images)))))
+
+(ert-deftest image-tests-image-metadata/tiff ()
+ (image-skip-unless 'tiff)
+ (should-not (image-metadata
+ (create-image (cdr (assq 'tiff image-tests--images))))))
+
+(ert-deftest image-tests-image-metadata/webp ()
+ (image-skip-unless 'webp)
+ (should-not (image-metadata
+ (create-image (cdr (assq 'webp image-tests--images))))))
+
+(ert-deftest image-tests-image-metadata/xbm ()
+ (image-skip-unless 'xbm)
+ (should-not (image-metadata (cdr (assq 'xbm image-tests--images)))))
+
+(ert-deftest image-tests-image-metadata/xpm ()
+ (image-skip-unless 'xpm)
+ (should-not (image-metadata (cdr (assq 'xpm image-tests--images)))))
+
+(ert-deftest image-tests-image-metadata/nil-on-invalid-spec ()
+ (skip-unless (display-images-p))
+ (should-not (image-metadata 'invalid-spec)))
+
+(ert-deftest image-tests-image-metadata/error-on-nongraphical-display ()
+ (skip-unless (not (display-images-p)))
+ (should-error (image-metadata (cdr (assq 'xpm image-tests--images)))))
+
+;;;; ImageMagick
+
+(ert-deftest image-tests-imagemagick-types ()
+ (skip-unless (fboundp 'imagemagick-types))
+ (when (fboundp 'imagemagick-types)
+ (should (listp (imagemagick-types)))))
+
+;;;; Initialization
+
+(ert-deftest image-tests-init-image-library ()
+ (skip-unless (fboundp 'init-image-library))
+ (should (init-image-library 'pbm)) ; built-in
+ (should (init-image-library 'xpm)) ; built-in
+ (should-not (init-image-library 'invalid-image-type)))
+
+;;; image-tests.el ends here
diff --git a/test/src/inotify-tests.el b/test/src/inotify-tests.el
index 8aab7eeb30a..70330ac8657 100644
--- a/test/src/inotify-tests.el
+++ b/test/src/inotify-tests.el
@@ -24,6 +24,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(declare-function inotify-add-watch "inotify.c" (file-name aspect callback))
(declare-function inotify-rm-watch "inotify.c" (watch-descriptor))
@@ -37,8 +38,7 @@
;; (ert-deftest filewatch-file-watch-aspects-check ()
;; "Test whether `file-watch' properly checks the aspects."
-;; (let ((temp-file (make-temp-file "filewatch-aspects")))
-;; (should (stringp temp-file))
+;; (ert-with-temp-file temp-file
;; (should-error (file-watch temp-file 'wrong nil)
;; :type 'error)
;; (should-error (file-watch temp-file '(modify t) nil)
@@ -50,23 +50,21 @@
(ert-deftest inotify-file-watch-simple ()
"Test if watching a normal file works."
-
(skip-unless (featurep 'inotify))
- (let ((temp-file (make-temp-file "inotify-simple"))
- (events 0))
- (let ((wd
- (inotify-add-watch temp-file t (lambda (_ev)
- (setq events (1+ events))))))
- (unwind-protect
- (progn
- (with-temp-file temp-file
- (insert "Foo\n"))
- (read-event nil nil 5)
- (should (> events 0)))
- (should (inotify-valid-p wd))
- (inotify-rm-watch wd)
- (should-not (inotify-valid-p wd))
- (delete-file temp-file)))))
+ (ert-with-temp-file temp-file
+ (let ((events 0))
+ (let ((wd
+ (inotify-add-watch temp-file t (lambda (_ev)
+ (setq events (1+ events))))))
+ (unwind-protect
+ (progn
+ (with-temp-file temp-file
+ (insert "Foo\n"))
+ (read-event nil nil 5)
+ (should (> events 0)))
+ (should (inotify-valid-p wd))
+ (inotify-rm-watch wd)
+ (should-not (inotify-valid-p wd)))))))
(provide 'inotify-tests)
diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el
index 1943e719ab2..629d6c55849 100644
--- a/test/src/keymap-tests.el
+++ b/test/src/keymap-tests.el
@@ -134,6 +134,45 @@
(define-key map [menu-bar i-bar] 'foo)
(should (eq (lookup-key map [menu-bar I-bar]) 'foo))))
+(ert-deftest keymap-lookup-key/mixed-case-multibyte ()
+ "Backwards compatibility behaviour (Bug#50752)."
+ (let ((map (make-keymap)))
+ ;; (downcase "Åäö") => "åäö"
+ (define-key map [menu-bar åäö bar] 'foo)
+ (should (eq (lookup-key map [menu-bar åäö bar]) 'foo))
+ (should (eq (lookup-key map [menu-bar Åäö Bar]) 'foo))
+ ;; (downcase "Γ") => "γ"
+ (define-key map [menu-bar γ bar] 'baz)
+ (should (eq (lookup-key map [menu-bar γ bar]) 'baz))
+ (should (eq (lookup-key map [menu-bar Γ Bar]) 'baz))))
+
+(ert-deftest keymap-lookup-key/menu-non-symbol ()
+ "Test for Bug#51527."
+ (let ((map (make-keymap)))
+ (define-key map [menu-bar buffer 1] 'foo)
+ (should (eq (lookup-key map [menu-bar buffer 1]) 'foo))))
+
+(ert-deftest keymap-lookup-keymap/with-spaces ()
+ "Backwards compatibility behaviour (Bug#50752)."
+ (let ((map (make-keymap)))
+ (define-key map [menu-bar foo-bar] 'foo)
+ (should (eq (lookup-key map [menu-bar Foo\ Bar]) 'foo))))
+
+(ert-deftest keymap-lookup-keymap/with-spaces-multibyte ()
+ "Backwards compatibility behaviour (Bug#50752)."
+ (let ((map (make-keymap)))
+ (define-key map [menu-bar åäö-bar] 'foo)
+ (should (eq (lookup-key map [menu-bar Åäö\ Bar]) 'foo))))
+
+(ert-deftest keymap-lookup-keymap/with-spaces-multibyte-lang-env ()
+ "Backwards compatibility behaviour (Bug#50752)."
+ (let ((lang-env current-language-environment))
+ (set-language-environment "Turkish")
+ (let ((map (make-keymap)))
+ (define-key map [menu-bar i-bar] 'foo)
+ (should (eq (lookup-key map [menu-bar I-bar]) 'foo)))
+ (set-language-environment lang-env)))
+
(ert-deftest describe-buffer-bindings/header-in-current-buffer ()
"Header should be inserted into the current buffer.
https://debbugs.gnu.org/39149#31"
@@ -284,12 +323,12 @@ commit 86c19714b097aa477d339ed99ffb5136c755a046."
(with-temp-buffer
(help--describe-vector (cadr orig-map) nil #'help--describe-command
t shadow-map orig-map t)
- (should (equal (buffer-string)
- "
+ (should (equal (buffer-substring-no-properties (point-min) (point-max))
+ (string-replace "\t" "" "
e foo
f foo (currently shadowed by `bar')
g .. h foo
-")))))
+"))))))
(ert-deftest help--describe-vector/bug-9293-same-command-does-not-shadow ()
"Check that a command can't be shadowed by the same command."
@@ -310,10 +349,10 @@ g .. h foo
(with-temp-buffer
(help--describe-vector (cadr range-map) nil #'help--describe-command
t shadow-map range-map t)
- (should (equal (buffer-string)
- "
+ (should (equal (buffer-substring-no-properties (point-min) (point-max))
+ (string-replace "\t" "" "
0 .. 3 foo
-")))))
+"))))))
(ert-deftest keymap--key-description ()
(should (equal (key-description [right] [?\C-x])
@@ -327,6 +366,47 @@ g .. h foo
(should (equal (single-key-description 'C-s-home)
"C-s-<home>")))
+(ert-deftest keymap-test-lookups ()
+ (should (eq (lookup-key (current-global-map) "\C-x\C-f") 'find-file))
+ (should (eq (lookup-key (current-global-map) [(control x) (control f)])
+ 'find-file))
+ (should (eq (lookup-key (current-global-map) ["C-x C-f"]) 'find-file))
+ (should (eq (lookup-key (current-global-map) [?\C-x ?\C-f]) 'find-file)))
+
+(ert-deftest keymap-removal ()
+ ;; Set to nil.
+ (let ((map (define-keymap "a" 'foo)))
+ (should (equal map '(keymap (97 . foo))))
+ (define-key map "a" nil)
+ (should (equal map '(keymap (97)))))
+ ;; Remove.
+ (let ((map (define-keymap "a" 'foo)))
+ (should (equal map '(keymap (97 . foo))))
+ (define-key map "a" nil t)
+ (should (equal map '(keymap)))))
+
+(ert-deftest keymap-removal-inherit ()
+ ;; Set to nil.
+ (let ((parent (make-sparse-keymap))
+ (child (make-keymap)))
+ (set-keymap-parent child parent)
+ (define-key parent [?a] 'foo)
+ (define-key child [?a] 'bar)
+
+ (should (eq (lookup-key child [?a]) 'bar))
+ (define-key child [?a] nil)
+ (should (eq (lookup-key child [?a]) nil)))
+ ;; Remove.
+ (let ((parent (make-sparse-keymap))
+ (child (make-keymap)))
+ (set-keymap-parent child parent)
+ (define-key parent [?a] 'foo)
+ (define-key child [?a] 'bar)
+
+ (should (eq (lookup-key child [?a]) 'bar))
+ (define-key child [?a] nil t)
+ (should (eq (lookup-key child [?a]) 'foo))))
+
(provide 'keymap-tests)
;;; keymap-tests.el ends here
diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index dac8f95bc4d..c635c592b28 100644
--- a/test/src/lread-tests.el
+++ b/test/src/lread-tests.el
@@ -115,18 +115,14 @@
(should-error (read "#24r") :type 'invalid-read-syntax)
(should-error (read "#") :type 'invalid-read-syntax))
+(ert-deftest lread-char-modifiers ()
+ (should (eq ?\C-\M-é (+ (- ?\M-a ?a) ?\C-é)))
+ (should (eq (- ?\C-ŗ ?ŗ) (- ?\C-é ?é))))
+
(ert-deftest lread-record-1 ()
(should (equal '(#s(foo) #s(foo))
(read "(#1=#s(foo) #1#)"))))
-(defmacro lread-tests--with-temp-file (file-name-var &rest body)
- (declare (indent 1))
- (cl-check-type file-name-var symbol)
- `(let ((,file-name-var (make-temp-file "emacs")))
- (unwind-protect
- (progn ,@body)
- (delete-file ,file-name-var))))
-
(defun lread-tests--last-message ()
(with-current-buffer "*Messages*"
(save-excursion
@@ -137,7 +133,7 @@
(ert-deftest lread-tests--unescaped-char-literals ()
"Check that loading warns about unescaped character
literals (Bug#20852)."
- (lread-tests--with-temp-file file-name
+ (ert-with-temp-file file-name
(write-region "?) ?( ?; ?\" ?[ ?]" nil file-name)
(should (equal (load file-name nil :nomessage :nosuffix) t))
(should (equal (lread-tests--last-message)
diff --git a/test/src/process-tests.el b/test/src/process-tests.el
index 44f3ea2fbb4..f14a460d1a5 100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@ -25,6 +25,7 @@
(require 'cl-lib)
(require 'ert)
+(require 'ert-x) ; ert-with-temp-directory
(require 'puny)
(require 'subr-x)
(require 'dns)
@@ -64,24 +65,22 @@
(when (eq system-type 'windows-nt)
(ert-deftest process-test-quoted-batfile ()
"Check that Emacs hides CreateProcess deficiency (bug#18745)."
- (let (batfile)
- (unwind-protect
- (progn
- ;; CreateProcess will fail when both the bat file and 1st
- ;; argument are quoted, so include spaces in both of those
- ;; to force quoting.
- (setq batfile (make-temp-file "echo args" nil ".bat"))
- (with-temp-file batfile
- (insert "@echo arg1=%1, arg2=%2\n"))
- (with-temp-buffer
- (call-process batfile nil '(t t) t "x &y")
- (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))
- (with-temp-buffer
- (call-process-shell-command
- (mapconcat #'shell-quote-argument (list batfile "x &y") " ")
- nil '(t t) t)
- (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))))
- (when batfile (delete-file batfile))))))
+ (ert-with-temp-file batfile
+ ;; CreateProcess will fail when both the bat file and 1st
+ ;; argument are quoted, so include spaces in both of those
+ ;; to force quoting.
+ :prefix "echo args"
+ :suffix ".bat"
+ (with-temp-file batfile
+ (insert "@echo arg1=%1, arg2=%2\n"))
+ (with-temp-buffer
+ (call-process batfile nil '(t t) t "x &y")
+ (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))
+ (with-temp-buffer
+ (call-process-shell-command
+ (mapconcat #'shell-quote-argument (list batfile "x &y") " ")
+ nil '(t t) t)
+ (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))))))
(ert-deftest process-test-stderr-buffer ()
(skip-unless (executable-find "bash"))
@@ -531,18 +530,6 @@ FD_SETSIZE."
(delete-process (pop ,processes))
,@body)))))
-(defmacro process-tests--with-temp-directory (var &rest body)
- "Bind VAR to the name of a new directory and evaluate BODY.
-Afterwards, delete the directory."
- (declare (indent 1) (debug (symbolp body)))
- (cl-check-type var symbol)
- (let ((dir (make-symbol "dir")))
- `(let ((,dir (make-temp-file "emacs-test-" :dir)))
- (unwind-protect
- (let ((,var ,dir))
- ,@body)
- (delete-directory ,dir :recursive)))))
-
;; Tests for FD_SETSIZE overflow (Bug#24325). The following tests
;; generate lots of process objects of the various kinds. Running the
;; tests with assertions enabled should not result in any crashes due
@@ -630,7 +617,7 @@ FD_SETSIZE file descriptors (Bug#24325)."
;; Avoid hang due to connect/accept handshake on Cygwin (bug#49496).
(skip-unless (not (eq system-type 'cygwin)))
(with-timeout (60 (ert-fail "Test timed out"))
- (process-tests--with-temp-directory directory
+ (ert-with-temp-directory directory
(process-tests--with-processes processes
(let* ((num-clients 10)
(socket-name (expand-file-name "socket" directory))
@@ -800,6 +787,7 @@ have written output."
(list (list process "finished\n"))))))))))
(ert-deftest process-tests/multiple-threads-waiting ()
+ :tags (if (getenv "EMACS_EMBA_CI") '(:unstable))
(skip-unless (fboundp 'make-thread))
(with-timeout (60 (ert-fail "Test timed out"))
(process-tests--with-processes processes
diff --git a/test/src/search-tests.el b/test/src/search-tests.el
index b7b4ab9a8ff..b5f4730f265 100644
--- a/test/src/search-tests.el
+++ b/test/src/search-tests.el
@@ -28,7 +28,7 @@
(setq ov-set (make-overlay 3 5))
(overlay-put
ov-set 'modification-hooks
- (list (lambda (o after &rest _args)
+ (list (lambda (_o after &rest _args)
(when after
(let ((inhibit-modification-hooks t))
(save-excursion
diff --git a/test/src/sqlite-tests.el b/test/src/sqlite-tests.el
new file mode 100644
index 00000000000..27ba74e9d23
--- /dev/null
+++ b/test/src/sqlite-tests.el
@@ -0,0 +1,218 @@
+;;; sqlite-tests.el --- Tests for sqlite.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 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 'ert-x)
+
+(declare-function sqlite-execute "sqlite.c")
+(declare-function sqlite-close "sqlite.c")
+(declare-function sqlitep "sqlite.c")
+(declare-function sqlite-available-p "sqlite.c")
+(declare-function sqlite-finalize "sqlite.c")
+(declare-function sqlite-next "sqlite.c")
+(declare-function sqlite-more-p "sqlite.c")
+(declare-function sqlite-select "sqlite.c")
+(declare-function sqlite-open "sqlite.c")
+
+(ert-deftest sqlite-select ()
+ (skip-unless (sqlite-available-p))
+ (let ((db (sqlite-open)))
+ (should (eq (type-of db) 'sqlite))
+ (should (sqlitep db))
+ (should-not (sqlitep 'foo))
+
+ (should
+ (zerop
+ (sqlite-execute
+ db "create table if not exists test1 (col1 text, col2 integer, col3 float, col4 blob)")))
+
+ (should-error
+ (sqlite-execute
+ db "insert into test1 (col1, col2, col3, col4) values ('foo', 2, 9.45, 'bar', 'zot')"))
+
+ (should
+ (=
+ (sqlite-execute
+ db "insert into test1 (col1, col2, col3, col4) values ('foo', 2, 9.45, 'bar')")
+ 1))
+
+ (should
+ (equal
+ (sqlite-select db "select * from test1" nil 'full)
+ '(("col1" "col2" "col3" "col4") ("foo" 2 9.45 "bar"))))))
+
+(ert-deftest sqlite-set ()
+ (skip-unless (sqlite-available-p))
+ (let ((db (sqlite-open))
+ set)
+ (should
+ (zerop
+ (sqlite-execute
+ db "create table if not exists test1 (col1 text, col2 integer)")))
+
+ (should
+ (=
+ (sqlite-execute db "insert into test1 (col1, col2) values ('foo', 1)")
+ 1))
+ (should
+ (=
+ (sqlite-execute db "insert into test1 (col1, col2) values ('bar', 2)")
+ 1))
+
+ (setq set (sqlite-select db "select * from test1" nil 'set))
+ (should (sqlitep set))
+ (should (sqlite-more-p set))
+ (should (equal (sqlite-next set)
+ '("foo" 1)))
+ (should (equal (sqlite-next set)
+ '("bar" 2)))
+ (should-not (sqlite-next set))
+ (should-not (sqlite-more-p set))
+ (sqlite-finalize set)
+ (should-error (sqlite-next set))))
+
+(ert-deftest sqlite-chars ()
+ (skip-unless (sqlite-available-p))
+ (let (db)
+ (setq db (sqlite-open))
+ (sqlite-execute
+ db "create table if not exists test2 (col1 text, col2 integer)")
+ (sqlite-execute
+ db "insert into test2 (col1, col2) values ('fóo', 3)")
+ (sqlite-execute
+ db "insert into test2 (col1, col2) values ('fó‚o', 3)")
+ (sqlite-execute
+ db "insert into test2 (col1, col2) values ('f‚o', 4)")
+ (should
+ (equal (sqlite-select db "select * from test2" nil 'full)
+ '(("col1" "col2") ("fóo" 3) ("fó‚o" 3) ("f‚o" 4))))))
+
+(ert-deftest sqlite-numbers ()
+ (skip-unless (sqlite-available-p))
+ (let (db)
+ (setq db (sqlite-open))
+ (sqlite-execute
+ db "create table if not exists test3 (col1 integer)")
+ (let ((big (expt 2 50))
+ (small (expt 2 10)))
+ (sqlite-execute db (format "insert into test3 values (%d)" small))
+ (sqlite-execute db (format "insert into test3 values (%d)" big))
+ (should
+ (equal
+ (sqlite-select db "select * from test3")
+ (list (list small) (list big)))))))
+
+(ert-deftest sqlite-param ()
+ (skip-unless (sqlite-available-p))
+ (let (db)
+ (setq db (sqlite-open))
+ (sqlite-execute
+ db "create table if not exists test4 (col1 text, col2 number)")
+ (sqlite-execute db "insert into test4 values (?, ?)" (list "foo" 1))
+ (should
+ (equal
+ (sqlite-select db "select * from test4 where col2 = ?" '(1))
+ '(("foo" 1))))
+ (should
+ (equal
+ (sqlite-select db "select * from test4 where col2 = ?" [1])
+ '(("foo" 1))))))
+
+(ert-deftest sqlite-binary ()
+ (skip-unless (sqlite-available-p))
+ (let (db)
+ (setq db (sqlite-open))
+ (sqlite-execute
+ db "create table if not exists test5 (col1 text, col2 number)")
+ (let ((string (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert 0 1 2)
+ (buffer-string))))
+ (should-not (multibyte-string-p string))
+ (sqlite-execute
+ db "insert into test5 values (?, ?)" (list string 2))
+ (let ((out (caar
+ (sqlite-select db "select col1 from test5 where col2 = 2"))))
+ (should (equal out string))))))
+
+(ert-deftest sqlite-different-dbs ()
+ (skip-unless (sqlite-available-p))
+ (let (db1 db2)
+ (setq db1 (sqlite-open))
+ (setq db2 (sqlite-open))
+ (sqlite-execute
+ db1 "create table if not exists test6 (col1 text, col2 number)")
+ (sqlite-execute
+ db2 "create table if not exists test6 (col1 text, col2 number)")
+ (sqlite-execute
+ db1 "insert into test6 values (?, ?)" '("foo" 2))
+ (should (sqlite-select db1 "select * from test6"))
+ (should-not (sqlite-select db2 "select * from test6"))))
+
+(ert-deftest sqlite-close-dbs ()
+ (skip-unless (sqlite-available-p))
+ (let (db)
+ (setq db (sqlite-open))
+ (sqlite-execute
+ db "create table if not exists test6 (col1 text, col2 number)")
+ (sqlite-execute db "insert into test6 values (?, ?)" '("foo" 2))
+ (should (sqlite-select db "select * from test6"))
+ (sqlite-close db)
+ (should-error (sqlite-select db "select * from test6"))))
+
+(ert-deftest sqlite-load-extension ()
+ (skip-unless (sqlite-available-p))
+ (skip-unless (fboundp 'sqlite-load-extension))
+ (let (db)
+ (setq db (sqlite-open))
+ (should-error
+ (sqlite-load-extension db "/usr/lib/sqlite3/notpcre.so"))
+ (should-error
+ (sqlite-load-extension db "/usr/lib/sqlite3/n"))
+ (should-error
+ (sqlite-load-extension db "/usr/lib/sqlite3/"))
+ (should-error
+ (sqlite-load-extension db "/usr/lib/sqlite3"))
+ (should
+ (memq
+ (sqlite-load-extension db "/usr/lib/sqlite3/pcre.so")
+ '(nil t)))
+
+ (should-error
+ (sqlite-load-extension
+ db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_notcsvtable.so"))
+ (should-error
+ (sqlite-load-extension
+ db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtablen.so"))
+ (should-error
+ (sqlite-load-extension
+ db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtable"))
+ (should
+ (memq
+ (sqlite-load-extension
+ db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtable.so")
+ '(nil t)))))
+
+;;; sqlite-tests.el ends here
diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el
index bba9b3fcd8c..f801478a9a1 100644
--- a/test/src/timefns-tests.el
+++ b/test/src/timefns-tests.el
@@ -242,4 +242,16 @@ a fixed place on the right and are padded on the left."
(should (= xdiv (float-time (time-convert xdiv t))))))
(setq x (* x 2)))))
+(ert-deftest time-convert-forms ()
+ ;; These computations involve numbers that should have exact
+ ;; representations on any Emacs platform.
+ (dolist (time '(-86400 -1 0 1 86400))
+ (dolist (delta '(0 0.0 0.25 3.25 1000 1000.25))
+ (let ((time+ (+ time delta))
+ (time- (- time delta)))
+ (dolist (form '(nil t list 4 1000 1000000 1000000000))
+ (should (time-equal-p time (time-convert time form)))
+ (should (time-equal-p time- (time-convert time- form)))
+ (should (time-equal-p time+ (time-convert time+ form))))))))
+
;;; timefns-tests.el ends here
diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el
index a658bccf6dc..88fcfad14cc 100644
--- a/test/src/undo-tests.el
+++ b/test/src/undo-tests.el
@@ -46,6 +46,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
(require 'facemenu)
(ert-deftest undo-test0 ()
@@ -218,17 +219,14 @@
(ert-deftest undo-test-file-modified ()
"Test undoing marks buffer visiting file unmodified."
- (let ((tempfile (make-temp-file "undo-test")))
- (unwind-protect
- (progn
- (with-current-buffer (find-file-noselect tempfile)
- (insert "1")
- (undo-boundary)
- (set-buffer-modified-p nil)
- (insert "2")
- (undo)
- (should-not (buffer-modified-p))))
- (delete-file tempfile))))
+ (ert-with-temp-file tempfile
+ (with-current-buffer (find-file-noselect tempfile)
+ (insert "1")
+ (undo-boundary)
+ (set-buffer-modified-p nil)
+ (insert "2")
+ (undo)
+ (should-not (buffer-modified-p)))))
(ert-deftest undo-test-region-not-most-recent ()
"Test undo in region of an edit not the most recent."
diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el
index 4e7d2ad8ab2..ae4aacd9c7c 100644
--- a/test/src/xdisp-tests.el
+++ b/test/src/xdisp-tests.el
@@ -99,4 +99,75 @@
(width-in-chars (/ (car size) char-width)))
(should (equal width-in-chars 3)))))
+(ert-deftest xdisp-tests--find-directional-overrides-case-1 ()
+ (with-temp-buffer
+ (insert "\
+int main() {
+ bool isAdmin = false;
+ /*‮ }⁦if (isAdmin)⁩ ⁦ begin admins only */
+ printf(\"You are an admin.\\n\");
+ /* end admins only ‮ { ⁦*/
+ return 0;
+}")
+ (goto-char (point-min))
+ (should (eq (bidi-find-overridden-directionality (point-min) (point-max)
+ nil)
+ 46))))
+
+(ert-deftest xdisp-tests--find-directional-overrides-case-2 ()
+ (with-temp-buffer
+ (insert "\
+#define is_restricted_user(user) \\
+ !strcmp (user, \"root\") ? 0 : \\
+ !strcmp (user, \"admin\") ? 0 : \\
+ !strcmp (user, \"superuser‮⁦? 0 : 1⁩ ⁦\")⁩‬
+
+int main () {
+ printf (\"root: %d\\n\", is_restricted_user (\"root\"));
+ printf (\"admin: %d\\n\", is_restricted_user (\"admin\"));
+ printf (\"superuser: %d\\n\", is_restricted_user (\"superuser\"));
+ printf (\"luser: %d\\n\", is_restricted_user (\"luser\"));
+ printf (\"nobody: %d\\n\", is_restricted_user (\"nobody\"));
+}")
+ (goto-char (point-min))
+ (should (eq (bidi-find-overridden-directionality (point-min) (point-max)
+ nil)
+ 138))))
+
+(ert-deftest xdisp-tests--find-directional-overrides-case-3 ()
+ (with-temp-buffer
+ (insert "\
+#define is_restricted_user(user) \\
+ !strcmp (user, \"root\") ? 0 : \\
+ !strcmp (user, \"admin\") ? 0 : \\
+ !strcmp (user, \"superuser‮⁦? '#' : '!'⁩ ⁦\")⁩‬
+
+int main () {
+ printf (\"root: %d\\n\", is_restricted_user (\"root\"));
+ printf (\"admin: %d\\n\", is_restricted_user (\"admin\"));
+ printf (\"superuser: %d\\n\", is_restricted_user (\"superuser\"));
+ printf (\"luser: %d\\n\", is_restricted_user (\"luser\"));
+ printf (\"nobody: %d\\n\", is_restricted_user (\"nobody\"));
+}")
+ (goto-char (point-min))
+ (should (eq (bidi-find-overridden-directionality (point-min) (point-max)
+ nil)
+ 138))))
+
+(ert-deftest test-get-display-property ()
+ (with-temp-buffer
+ (insert (propertize "foo" 'face 'bold 'display '(height 2.0)))
+ (should (equal (get-display-property 2 'height) 2.0)))
+ (with-temp-buffer
+ (insert (propertize "foo" 'face 'bold 'display '((height 2.0)
+ (space-width 2.0))))
+ (should (equal (get-display-property 2 'height) 2.0))
+ (should (equal (get-display-property 2 'space-width) 2.0)))
+ (with-temp-buffer
+ (insert (propertize "foo bar" 'face 'bold
+ 'display '[(height 2.0)
+ (space-width 20)]))
+ (should (equal (get-display-property 2 'height) 2.0))
+ (should (equal (get-display-property 2 'space-width) 20))))
+
;;; xdisp-tests.el ends here