From 748f0d4bc65b601dd05077d26361eda35289778f Mon Sep 17 00:00:00 2001 From: Nicolas Petton Date: Wed, 29 Jul 2020 22:48:14 +0200 Subject: [PATCH 001/145] * admin/authors.el (authors-aliases): Remove a faulty regexp. --- admin/authors.el | 1 - 1 file changed, 1 deletion(-) diff --git a/admin/authors.el b/admin/authors.el index acaa7dfaa77..a418efea44f 100644 --- a/admin/authors.el +++ b/admin/authors.el @@ -212,7 +212,6 @@ files.") ("Carlos Pita" "memeplex") ("Vinicius Jose Latorre" "viniciusjl") ("Gaby Launay" "galaunay") - ("Alex Gramiak" "alex") ("Dick R. Chiang" "dickmao") ) "Alist of author aliases. From e12d1fbc1568cc90b3b99bb6b9f244e5d10e97a4 Mon Sep 17 00:00:00 2001 From: Nicolas Petton Date: Wed, 29 Jul 2020 22:50:01 +0200 Subject: [PATCH 002/145] ; ChangeLog.3 and etc/AUTHORS fixes --- ChangeLog.3 | 2 +- etc/AUTHORS | 136 +++++++++++++++++++++++++++++++++++++++------------- 2 files changed, 105 insertions(+), 33 deletions(-) diff --git a/ChangeLog.3 b/ChangeLog.3 index 4aa52a762fc..c8dd40b5eb6 100644 --- a/ChangeLog.3 +++ b/ChangeLog.3 @@ -58779,7 +58779,7 @@ * lisp/net/soap-client.el (soap-type-of): Optimize for Emacs≥26 -2018-07-17 Alex +2018-07-17 Alexander Gramiak Remove menu name from emacs-lisp-mode-map (Bug#27114) diff --git a/etc/AUTHORS b/etc/AUTHORS index 2d4e0731202..848d9e07f9d 100644 --- a/etc/AUTHORS +++ b/etc/AUTHORS @@ -127,18 +127,84 @@ Albert L. Ting: changed gnus-group.el mail-hist.el Aleksei Gusev: changed progmodes/compile.el -Alexandru Harsanyi: changed soap-client.el soap-inspect.el emacs3.py - vc-hooks.el vc.el xml.el +Alexander Becher: changed vc-annotate.el -Alex Gramiak: wrote ansi-color.el conf-mode-tests.el cus-theme.el - erc-compat.el erc-hecomplete.el erc-join.el erc-lang.el erc-ring.el - erc.el gnus-mlspl.el master.el soap-client.el soap-inspect.el - spam-stat.el sql.el vc-git.el which-func.el +Alexander Gramiak: changed w32term.c xterm.c nsterm.m dispextern.h + xdisp.c frame.c image.c nsgui.h w32gui.h xfns.c frame.el termhooks.h + w32fns.c w32term.h faces.el nsterm.h xfaces.c xterm.h frame.h xfont.c + configure.ac and 65 other files + +Alexander Haeckel: changed getset.el + +Alexander Klimov: changed files.el calc-graph.el files.texi man.el rx.el + sendmail.el + +Alexander Kreuzer: changed nnrss.el + +Alexander Kuleshov: changed dns-mode.el files.texi image-mode.el + keyboard.c ld-script.el xdisp.c + +Alexander L. Belikoff: wrote erc.el + +Alexander Pohoyda: co-wrote mail/rmailmm.el +and changed rmailsum.el man.el rmail.el sendmail.el + +Alexander Shopov: changed code-pages.el + +Alexander Vorobiev: changed org-compat.el + +Alexander Zhuckov: changed ebrowse.c + +Alexandre Garreau: changed message.el + +Alexandre Julliard: wrote vc-git.el +and changed vc.el ewoc.el + +Alexandre Oliva: wrote gnus-mlspl.el +and changed unexelf.c format.el iris4d.h iris5d.h regex.c unexsgi.c + +Alexandre Veyrenc: changed fr-refcard.tex + +Alexandru Harsanyi: wrote soap-client.el soap-inspect.el +and changed emacs3.py vc-hooks.el vc.el xml.el + +Alex Branham: changed checkdoc.el bibtex.el em-rebind.el esh-util.el + indent.el js.el lpr.el message.el subr.el text.texi .dir-locals.el + auth-source-pass.el bug-reference.el comint.el conf-mode-tests.el + conf-mode.el dired-x.el dired.el ediff-diff.el ediff-help.el + ediff-hook.el and 41 other files + +Alex Coventry: changed files.el + +Alex Dunn: changed subr-tests.el subr.el + +Alexei Khlebnikov: changed autorevert.el vc-git.el + +Alex Gramiak: changed prolog.el terminal.c + +Alex Kosorukoff: changed org-capture.el + +Alex Murray: changed erc-desktop-notifications.el network-stream.el + +Alex Ott: changed TUTORIAL.ru ede/files.el ru-refcard.tex base.el + cedet-files.el cpp-root.el ede.el ede/generic.el idle.el ispell.el + semantic/format.el + +Alex Reed: changed verilog-mode.el + +Alex Rezinsky: wrote which-func.el + +Alex Schroeder: wrote ansi-color.el cus-theme.el erc-compat.el + erc-hecomplete.el erc-join.el erc-lang.el erc-ring.el master.el + spam-stat.el sql.el and co-wrote longlines.el mail/rmailmm.el -and changed erc-track.el erc-button.el w32term.c xterm.c erc-stamp.el - nsterm.m xdisp.c dispextern.h frame.c image.c nsgui.h w32gui.h xfns.c - erc-match.el frame.el termhooks.h w32fns.c Makefile TUTORIAL.ru - erc-autoaway.el erc-nickserv.el and 215 other files +and changed erc.el erc-track.el erc-button.el erc-stamp.el erc-match.el + erc-autoaway.el erc-nickserv.el rcirc.texi Makefile erc-autojoin.el + erc-fill.el erc-pcomplete.el erc-complete.el erc-ibuffer.el + erc-members.el rmail.el comint.el custom.el erc-bbdb.el erc-chess.el + erc-ezbounce.el and 35 other files + +Alex Shinn: changed files.el Alfred Correira: changed generic-x.el @@ -700,7 +766,7 @@ and co-wrote longlines.el tango-dark-theme.el tango-theme.el and changed simple.el display.texi xdisp.c files.el frames.texi cus-edit.el files.texi custom.el subr.el text.texi faces.el keyboard.c startup.el package.el misc.texi emacs.texi modes.texi mouse.el - custom.texi image.c window.el and 933 other files + custom.texi image.c window.el and 934 other files Chris Chase: co-wrote idlw-shell.el idlwave.el @@ -1381,7 +1447,7 @@ Eli Zaretskii: wrote [bidirectional display in xdisp.c] and changed xdisp.c msdos.c w32.c display.texi w32fns.c simple.el files.el fileio.c keyboard.c w32term.c emacs.c w32proc.c files.texi text.texi dispnew.c frames.texi lisp.h dispextern.h window.c process.c - term.c and 1191 other files + term.c and 1192 other files Emanuele Giaquinta: changed configure.ac rxvt.el charset.c etags.c fontset.c frame.el gnus-faq.texi loadup.el lread.c sh-script.el @@ -1466,7 +1532,7 @@ and changed c.srt ede.texi info.el rmail.el speedbspec.el cedet.el ede-autoconf.srt ede-make.srt eieio.texi gud.el sb-dir-minus.xpm sb-dir-plus.xpm sb-dir.xpm sb-mail.xpm sb-pg-minus.xpm sb-pg-plus.xpm sb-pg.xpm sb-tag-gt.xpm sb-tag-minus.xpm sb-tag-plus.xpm - and 50 other files + and 51 other files Eric Schulte: wrote ob-asymptote.el ob-awk.el ob-calc.el ob-comint.el ob-coq.el ob-css.el ob-ditaa.el ob-dot.el ob-emacs-lisp.el ob-eval.el @@ -1793,7 +1859,7 @@ and changed configure.ac Makefile.in src/Makefile.in calendar.el diary-lib.el lisp/Makefile.in files.el make-dist rmail.el progmodes/f90.el bytecomp.el simple.el authors.el admin.el startup.el emacs.texi misc/Makefile.in display.texi lib-src/Makefile.in ack.texi - subr.el and 1760 other files + subr.el and 1761 other files Glynn Clements: wrote gamegrid.el snake.el tetris.el @@ -1925,7 +1991,7 @@ Hideki Iwamoto: changed etags.c Hiroshi Fujishima: changed efaq.texi gnus-score.el mail-source.el spam-stat.el -Hiroshi Nakano: changed ralloc.c unexelf.c +Hiroshi Nakano: changed unexelf.c ralloc.c Hiroshi Oota: changed coding.c @@ -2085,6 +2151,8 @@ Jaeyoun Chung: changed hangul3.el hanja3.el gnus-mule.el hangul.el Jakub-W: changed calculator.el +J. Alexander Branham: wrote conf-mode-tests.el + Jambunathan K: wrote ox-odt.el and co-wrote ox-html.el and changed org-lparse.el org.el org.texi ox.el icomplete.el @@ -2121,7 +2189,7 @@ James Wright: changed em-unix.el Jamie Zawinski: wrote mailabbrev.el tar-mode.el and co-wrote byte-opt.el byte-run.el bytecomp.el disass.el font-lock.el -and changed bytecode.c mail-extr.el subr.el +and changed mail-extr.el subr.el bytecode.c Jan Beich: changed configure.ac mml-smime.el @@ -2578,7 +2646,7 @@ and changed xterm.c xfns.c keyboard.c screen.c dispnew.c xdisp.c window.c process.c alloc.c buffer.h files.el screen.el insdel.c emacs.c and 106 other files -Joseph M. Kelsey: changed fileio.c skeleton.el +Joseph M. Kelsey: changed skeleton.el fileio.c Josh Elsasser: changed configure.ac @@ -2652,7 +2720,7 @@ Juri Linkov: wrote files-x.el misearch.el replace-tests.el tab-bar.el and changed isearch.el info.el simple.el replace.el dired.el dired-aux.el progmodes/grep.el image-mode.el progmodes/compile.el startup.el subr.el diff-mode.el files.el menu-bar.el faces.el display.texi bindings.el - desktop.el comint.el minibuffer.el search.texi and 419 other files + desktop.el comint.el minibuffer.el search.texi and 420 other files Jussi Lahdenniemi: changed w32fns.c ms-w32.h msdos.texi w32.c w32.h w32console.c w32heap.c w32inevt.c w32term.h @@ -2676,7 +2744,7 @@ and co-wrote longlines.el tramp-sh.el tramp.el and changed message.el gnus-agent.el gnus-sum.el files.el nnmail.el tramp.texi nntp.el gnus.el simple.el ange-ftp.el dired.el paragraphs.el bindings.el files.texi gnus-art.el gnus-group.el man.el INSTALL - Makefile.in crisp.el fileio.c and 44 other files + Makefile.in crisp.el fileio.c and 45 other files Kailash C. Chowksey: changed HELLO ind-util.el kannada.el knd-util.el lisp/Makefile.in loadup.el @@ -3080,7 +3148,7 @@ Luc Teirlinck: wrote help-at-pt.el and changed files.el autorevert.el cus-edit.el subr.el simple.el frames.texi startup.el display.texi files.texi dired.el comint.el modes.texi custom.texi emacs.texi fns.c frame.el ielm.el minibuf.texi - variables.texi buffers.texi commands.texi and 211 other files + variables.texi buffers.texi commands.texi and 212 other files Ludovic Courtès: wrote nnregistry.el and changed configure.ac gnus.texi loadup.el @@ -3505,7 +3573,7 @@ Michael Olson: changed erc.el erc-backend.el Makefile erc-track.el erc-log.el erc-stamp.el erc-autoaway.el erc-dcc.el erc-goodies.el erc-list.el erc-compat.el erc-identd.el erc.texi ERC-NEWS erc-bbdb.el erc-match.el erc-notify.el erc-ibuffer.el erc-services.el remember.el - erc-button.el and 54 other files + erc-button.el and 55 other files Michael Orlitzky: changed tex-mode.el @@ -3924,7 +3992,7 @@ and co-wrote cal-dst.el and changed lisp.h configure.ac alloc.c process.c fileio.c editfns.c xdisp.c sysdep.c image.c keyboard.c emacs.c data.c fns.c lread.c xterm.c eval.c callproc.c Makefile.in frame.c buffer.c gnulib-comp.m4 - and 1822 other files + and 1824 other files Paul Fisher: changed fns.c @@ -4357,7 +4425,7 @@ and changed process.c ftfont.c gtkutil.c processes.texi vc-git.el configure.ac font.c network-stream.el nsm.el process-tests.el xfns.c custom.texi dispextern.h files.texi ftcrfont.c gnus-icalendar.el gnutls.el gtkutil.h network-stream-tests.el nsterm.m text.texi - and 92 other files + and 93 other files Robert Thorpe: changed cus-start.el indent.el @@ -4379,8 +4447,8 @@ Rodrigo Real: changed pt-br-refcard.tex Roger Breitenstein: changed smtpmail.el -Roland B. Roberts: changed buffer.h callproc.c dired.c files.el - gnus-group.el gnus-sum.el process.c sort.el sysdep.c systty.h +Roland B. Roberts: changed gnus-group.el gnus-sum.el buffer.h callproc.c + dired.c files.el process.c sort.el sysdep.c systty.h Roland Kaufmann: changed ox.el @@ -4644,7 +4712,7 @@ Shun-ichi Goto: changed url-http.el Shyam Karanatt: changed image-mode.el -Sidney Markowitz: changed doctor.el nsmenu.m +Sidney Markowitz: changed nsmenu.m doctor.el Sigbjorn Finne: changed gnus-srvr.el @@ -4767,7 +4835,7 @@ and changed wdired.el todo-mode.texi diary-lib.el wdired-tests.el dired-tests.el doc-view.el files.el minibuffer.el dired.el frames.texi hl-line.el info.el menu-bar.el mouse.el otodo-mode.el subr.el .gitattributes TUTORIAL allout.el artist.el compile.texi - and 44 other files + and 45 other files Stephen C. Gilardi: changed configure.ac @@ -4939,7 +5007,7 @@ Teodor Zlatanov: wrote auth-source.el gnus-registry.el gnus-tests.el and changed spam.el gnus.el nnimap.el gnus.texi gnutls.c gnus-sum.el auth.texi cfengine.el gnus-sync.el gnus-util.el gnus-start.el netrc.el gnutls.h message.el spam-stat.el encrypt.el mail-source.el nnir.el - nnmail.el auth-source-tests.el configure.ac and 119 other files + nnmail.el auth-source-tests.el configure.ac and 120 other files Terje Rosten: changed xfns.c version.el xterm.c xterm.h @@ -5140,7 +5208,7 @@ and co-wrote package.el tcl.el and changed data.c lisp.h js.el buffer.c data-tests.el alloc.c css-mode.el js-tests.el mhtml-mode.el process.c window.c editfns.c fns.c keyboard.c keymap.c lread.c makefile.el xfns.c bytecode.c cmds.c - configure.ac and 206 other files + configure.ac and 208 other files Tom Willemse: changed elec-pair.el package.el perl-mode.el prog-mode.el progmodes/python.el simple.el @@ -5239,6 +5307,8 @@ Valentin Gatien-Baron: changed emacs-module.c Valentin Wüstholz: changed org.el +Valery Alexeev: changed cyril-util.el cyrillic.el + Van L: changed subr.el Vasilij Schneidermann: changed cus-start.el eww.el cc-mode.el @@ -5298,6 +5368,8 @@ and changed erc-backend.el erc.el erc-services.el hexl.el emacs.c erc-button.el erc-capab.el erc-join.el htmlfontify.texi sh-script.el xterm.c xterm.h +Vladimir Alexiev: changed arc-mode.el nnvirtual.el tmm.el + Vladimir Kazanov: changed java.srt Vladimir Lomov: changed ox-html.el @@ -5402,9 +5474,9 @@ and changed configure.ac gmalloc.c gnus-agent.el image-mode.el man.el Wolfgang Lux: changed nsterm.m keyboard.c Wolfgang Rupprecht: wrote float-sup.el floatfns.c sup-mouse.el -and changed process.c alloc.c callint.c config.in configure.ac data.c - fns.c lisp-mode.el lisp.h loadup.el lread.c net-utils.el nntp.el - print.c sort.el +and changed process.c config.in configure.ac net-utils.el nntp.el alloc.c + callint.c data.c fns.c lisp-mode.el lisp.h loadup.el lread.c print.c + sort.el Wolfgang Scherer: changed vc-cvs.el vc-dir.el vc-svn.el vc.el pcvs.el From 8ecca2f09f6bc387412f258c4fc4e3ddf807b2b3 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Thu, 23 Jul 2020 13:48:43 +0200 Subject: [PATCH 003/145] Backport: Fix memory leak for global module objects (Bug#42482). Instead of storing the global values in a global 'emacs_value_storage' object, store them as hash values alongside the reference counts. That way the garbage collector takes care of cleaning them up. * src/emacs-module.c (global_storage): Remove. (struct module_global_reference): New pseudovector type. (XMODULE_GLOBAL_REFERENCE): New helper function. (module_make_global_ref, module_free_global_ref): Use 'module_global_reference' struct for global reference values. (value_to_lisp, module_handle_nonlocal_exit): Adapt to deletion of 'global_storage'. (cherry picked from commit 5c5eb9790898e4ab10bcbbdb6871947ed3018569) --- src/emacs-module.c | 82 ++++++++++++++++++++++++++++++---------------- 1 file changed, 54 insertions(+), 28 deletions(-) diff --git a/src/emacs-module.c b/src/emacs-module.c index 911b82b8a1a..4269b0ba2ac 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -159,11 +159,11 @@ struct emacs_value_frame /* A structure that holds an initial frame (so that the first local values require no dynamic allocation) and keeps track of the current frame. */ -static struct emacs_value_storage +struct emacs_value_storage { struct emacs_value_frame initial; struct emacs_value_frame *current; -} global_storage; +}; /* Private runtime and environment members. */ @@ -351,10 +351,35 @@ module_get_environment (struct emacs_runtime *ert) } /* To make global refs (GC-protected global values) keep a hash that - maps global Lisp objects to reference counts. */ + maps global Lisp objects to 'struct module_global_reference' + objects. We store the 'emacs_value' in the hash table so that it + is automatically garbage-collected (Bug#42482). */ static Lisp_Object Vmodule_refs_hash; +/* Pseudovector type for global references. The pseudovector tag is + PVEC_OTHER since these values are never printed and don't need to + be special-cased for garbage collection. */ + +struct module_global_reference { + /* Pseudovector header, must come first. */ + union vectorlike_header header; + + /* Holds the emacs_value for the object. The Lisp_Object stored + therein must be the same as the hash key. */ + struct emacs_value_tag value; + + /* Reference count, always positive. */ + ptrdiff_t refcount; +}; + +static struct module_global_reference * +XMODULE_GLOBAL_REFERENCE (Lisp_Object o) +{ + eassert (PSEUDOVECTORP (o, PVEC_OTHER)); + return XUNTAG (o, Lisp_Vectorlike, struct module_global_reference); +} + static emacs_value module_make_global_ref (emacs_env *env, emacs_value ref) { @@ -363,21 +388,30 @@ module_make_global_ref (emacs_env *env, emacs_value ref) Lisp_Object new_obj = value_to_lisp (ref), hashcode; ptrdiff_t i = hash_lookup (h, new_obj, &hashcode); + /* Note: This approach requires the garbage collector to never move + objects. */ + if (i >= 0) { Lisp_Object value = HASH_VALUE (h, i); - EMACS_INT refcount = XFIXNAT (value) + 1; - if (MOST_POSITIVE_FIXNUM < refcount) + struct module_global_reference *ref = XMODULE_GLOBAL_REFERENCE (value); + bool overflow = INT_ADD_WRAPV (ref->refcount, 1, &ref->refcount); + if (overflow) overflow_error (); - value = make_fixed_natnum (refcount); - set_hash_value_slot (h, i, value); + return &ref->value; } else { - hash_put (h, new_obj, make_fixed_natnum (1), hashcode); + struct module_global_reference *ref + = ALLOCATE_PLAIN_PSEUDOVECTOR (struct module_global_reference, + PVEC_OTHER); + ref->value.v = new_obj; + ref->refcount = 1; + Lisp_Object value; + XSETPSEUDOVECTOR (value, ref, PVEC_OTHER); + hash_put (h, new_obj, value, hashcode); + return &ref->value; } - - return allocate_emacs_value (env, &global_storage, new_obj); } static void @@ -393,23 +427,16 @@ module_free_global_ref (emacs_env *env, emacs_value ref) if (i >= 0) { - EMACS_INT refcount = XFIXNAT (HASH_VALUE (h, i)) - 1; - if (refcount > 0) - set_hash_value_slot (h, i, make_fixed_natnum (refcount)); - else - { - eassert (refcount == 0); - hash_remove_from_table (h, obj); - } + Lisp_Object value = HASH_VALUE (h, i); + struct module_global_reference *ref = XMODULE_GLOBAL_REFERENCE (value); + eassert (0 < ref->refcount); + if (--ref->refcount == 0) + hash_remove_from_table (h, obj); } - - if (module_assertions) + else if (module_assertions) { - ptrdiff_t count = 0; - if (value_storage_contains_p (&global_storage, ref, &count)) - return; module_abort ("Global value was not found in list of %"pD"d globals", - count); + h->count); } } @@ -1190,8 +1217,10 @@ value_to_lisp (emacs_value v) ++num_environments; } /* Also check global values. */ - if (value_storage_contains_p (&global_storage, v, &num_values)) + struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); + if (hash_lookup (h, v->v, NULL) != -1) goto ok; + INT_ADD_WRAPV (num_values, h->count, &num_values); module_abort (("Emacs value not found in %"pD"d values " "of %"pD"d environments"), num_values, num_environments); @@ -1404,10 +1433,7 @@ module_handle_nonlocal_exit (emacs_env *env, enum nonlocal_exit type, void init_module_assertions (bool enable) { - /* If enabling module assertions, use a hidden environment for - storing the globals. This environment is never freed. */ module_assertions = enable; - initialize_storage (&global_storage); } /* Return whether STORAGE contains VALUE. Used to check module From 8c94ca94dc2772e5c651de6cf46bfffc388234d5 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sat, 25 Jul 2020 23:04:05 +0200 Subject: [PATCH 004/145] Backport: Fix subtle bug when checking liveness of module values. We can't simply look up the Lisp object in the global reference table because an invalid local and a valid global reference might refer to the same object. Instead, we have to test the address of the global reference against the stored references. * src/emacs-module.c (module_global_reference_p): New helper function. (value_to_lisp): Use it. (cherry picked from commit 6355a3ec62f43c9b99d483982ff851d32dd78891) --- src/emacs-module.c | 27 ++++++++++++++++++++++++--- 1 file changed, 24 insertions(+), 3 deletions(-) diff --git a/src/emacs-module.c b/src/emacs-module.c index 4269b0ba2ac..099a6a3cf25 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -78,6 +78,7 @@ To add a new module function, proceed as follows: #include "emacs-module.h" #include +#include #include #include #include @@ -380,6 +381,28 @@ XMODULE_GLOBAL_REFERENCE (Lisp_Object o) return XUNTAG (o, Lisp_Vectorlike, struct module_global_reference); } +/* Returns whether V is a global reference. Only used to check module + assertions. If V is not a global reference, increment *N by the + number of global references (for debugging output). */ + +static bool +module_global_reference_p (emacs_value v, ptrdiff_t *n) +{ + struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); + /* Note that we can't use `hash_lookup' because V might be a local + reference that's identical to some global reference. */ + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + { + if (!EQ (HASH_KEY (h, i), Qunbound) + && &XMODULE_GLOBAL_REFERENCE (HASH_VALUE (h, i))->value == v) + return true; + } + /* Only used for debugging, so we don't care about overflow, just + make sure the operation is defined. */ + INT_ADD_WRAPV (*n, h->count, n); + return false; +} + static emacs_value module_make_global_ref (emacs_env *env, emacs_value ref) { @@ -1217,10 +1240,8 @@ value_to_lisp (emacs_value v) ++num_environments; } /* Also check global values. */ - struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); - if (hash_lookup (h, v->v, NULL) != -1) + if (module_global_reference_p (v, &num_values)) goto ok; - INT_ADD_WRAPV (num_values, h->count, &num_values); module_abort (("Emacs value not found in %"pD"d values " "of %"pD"d environments"), num_values, num_environments); From d767418b76818e4e83bf19cc08307c1329144c13 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sat, 25 Jul 2020 23:23:19 +0200 Subject: [PATCH 005/145] Backport: Make checking for liveness of global values more precise. We can't just use a hash lookup because a global and a local reference might refer to the same Lisp object. * src/emacs-module.c (module_free_global_ref): More precise check for global liveness. (cherry picked from commit 9f01ce6327af886f26399924a9aadf16cdd4fd9f) --- src/emacs-module.c | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/emacs-module.c b/src/emacs-module.c index 099a6a3cf25..a90a9765dbf 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -448,6 +448,14 @@ module_free_global_ref (emacs_env *env, emacs_value ref) Lisp_Object obj = value_to_lisp (ref); ptrdiff_t i = hash_lookup (h, obj, NULL); + if (module_assertions) + { + ptrdiff_t n = 0; + if (! module_global_reference_p (ref, &n)) + module_abort ("Global value was not found in list of %"pD"d globals", + n); + } + if (i >= 0) { Lisp_Object value = HASH_VALUE (h, i); @@ -456,11 +464,6 @@ module_free_global_ref (emacs_env *env, emacs_value ref) if (--ref->refcount == 0) hash_remove_from_table (h, obj); } - else if (module_assertions) - { - module_abort ("Global value was not found in list of %"pD"d globals", - h->count); - } } static enum emacs_funcall_exit From f54ddb0198640e38c1d34bf6031ff5117c117c85 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Fri, 31 Jul 2020 23:50:04 +0200 Subject: [PATCH 006/145] ; * test/lisp/emacs-lisp/generator-tests.el: Style fixes. --- test/lisp/emacs-lisp/generator-tests.el | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index 0d325f1485a..e0d9167118e 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -22,6 +22,10 @@ ;;; Commentary: +;; Unit tests for generator.el. + +;;; Code: + (require 'generator) (require 'ert) (require 'cl-lib) @@ -38,8 +42,7 @@ `cps-testcase' defines an ERT testcase called NAME that evaluates BODY twice: once using ordinary `eval' and once using lambda-generators. The test ensures that the two forms produce -identical output. -" +identical output." `(progn (ert-deftest ,name () (should @@ -302,3 +305,5 @@ identical output. (lambda (it) (- it)) (1+ it))))))) -2))) + +;;; generator-tests.el ends here From 418ea25bbf306c448516ea79c9eaf25b904e62e4 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 2 Aug 2020 17:05:00 +0300 Subject: [PATCH 007/145] Fix last change in alloc.c. * src/alloc.c (mark_maybe_object) [WIDE_EMACS_INT]: Avoid compiler warning about 'overflow' being unused. --- src/alloc.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/alloc.c b/src/alloc.c index be293cca54a..da11426075b 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -4649,6 +4649,8 @@ mark_maybe_object (Lisp_Object obj) significant bits as tag bits, the tag is small enough to not overflow either. */ eassert (!overflow); +#else + (void) overflow; #endif void *po = (char *) ((intptr_t) (char *) XLP (obj) + offset); From e6eb554b95327549992c3684910921db9181ffb6 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 2 Aug 2020 16:01:47 +0200 Subject: [PATCH 008/145] =?UTF-8?q?Don=E2=80=99t=20generate=20duplicate=20?= =?UTF-8?q?symbols=20for=20secondary=20CL=20methods=20(Bug#42671)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * lisp/emacs-lisp/edebug.el (edebug-match-cl-generic-method-qualifier): Add matcher for ‘cl-defmethod’ qualifier. * lisp/emacs-lisp/cl-generic.el (cl-defmethod): Use it. * test/lisp/emacs-lisp/edebug-tests.el (edebug-cl-defmethod-qualifier): New unit test. --- lisp/emacs-lisp/cl-generic.el | 5 ++--- lisp/emacs-lisp/edebug.el | 12 ++++++++++++ test/lisp/emacs-lisp/edebug-tests.el | 22 ++++++++++++++++++++++ 3 files changed, 36 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 4e8423eb5b1..c67681b0960 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -432,9 +432,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (&define ; this means we are defining something [&or name ("setf" name :name setf)] ;; ^^ This is the methods symbol - [ &rest atom ] ; Multiple qualifiers are allowed. - ; Like in CLOS spec, we support - ; any non-list values. + [ &rest cl-generic-method-qualifier ] + ;; Multiple qualifiers are allowed. cl-generic-method-args ; arguments lambda-doc ; documentation string def-body))) ; part to be debugged diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index a565e8f6dcb..7627829e034 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1731,6 +1731,8 @@ contains a circular object." ;; Less frequently used: ;; (function . edebug-match-function) (lambda-expr . edebug-match-lambda-expr) + (cl-generic-method-qualifier + . edebug-match-cl-generic-method-qualifier) (cl-generic-method-args . edebug-match-cl-generic-method-args) (cl-macrolet-expr . edebug-match-cl-macrolet-expr) (cl-macrolet-name . edebug-match-cl-macrolet-name) @@ -2035,6 +2037,16 @@ contains a circular object." spec)) nil) +(defun edebug-match-cl-generic-method-qualifier (cursor) + "Match a QUALIFIER for `cl-defmethod' at CURSOR." + (let ((args (edebug-top-element-required cursor "Expected qualifier"))) + ;; Like in CLOS spec, we support any non-list values. + (unless (atom args) (edebug-no-match cursor "Atom expected")) + ;; Append the arguments to `edebug-def-name' (Bug#42671). + (setq edebug-def-name (intern (format "%s %s" edebug-def-name args))) + (edebug-move-cursor cursor) + (list args))) + (defun edebug-match-cl-generic-method-args (cursor) (let ((args (edebug-top-element-required cursor "Expected arguments"))) (if (not (consp args)) diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 41811c9dc07..89b1f293743 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -938,5 +938,27 @@ test and possibly others should be updated." "g" (should (equal edebug-tests-@-result '(0 1)))))) +(ert-deftest edebug-cl-defmethod-qualifier () + "Check that secondary `cl-defmethod' forms don't stomp over +primary ones (Bug#42671)." + (with-temp-buffer + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (defined-symbols ()) + (edebug-new-definition-function + (lambda (def-name) + (push def-name defined-symbols) + (edebug-new-definition def-name)))) + (dolist (form '((cl-defmethod edebug-cl-defmethod-qualifier ((_ number))) + (cl-defmethod edebug-cl-defmethod-qualifier + :around ((_ number))))) + (print form (current-buffer))) + (eval-buffer) + (should + (equal + defined-symbols + (list (intern "edebug-cl-defmethod-qualifier :around ((_ number))") + (intern "edebug-cl-defmethod-qualifier ((_ number))"))))))) + (provide 'edebug-tests) ;;; edebug-tests.el ends here From 2e9d1f4d44036e7c0605cfeac091368e013e3ed9 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 2 Aug 2020 16:05:44 +0200 Subject: [PATCH 009/145] * src/alloc.c (mark_maybe_object): Avoid signed integer overflow --- src/alloc.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/alloc.c b/src/alloc.c index da11426075b..5220ef84783 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -4652,7 +4652,8 @@ mark_maybe_object (Lisp_Object obj) #else (void) overflow; #endif - void *po = (char *) ((intptr_t) (char *) XLP (obj) + offset); + INT_ADD_WRAPV (offset, (intptr_t) (char *) XLP (obj), &offset); + void *po = (char *) offset; /* If the pointer is in the dump image and the dump has a record of the object starting at the place where the pointer points, we From a07ec21bf24b8d1dc41808f997dd0fb78cad3870 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 2 Aug 2020 18:27:33 +0300 Subject: [PATCH 010/145] Re-enable scroll-margin when cursor-motion optimization is disabled * src/xdisp.c (try_window): Fix logic of disabling margins when cursor is close to BOB or EOB. Account for header-line, if any, when computing the scroll margin in pixels. (Bug#42653) --- src/xdisp.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/xdisp.c b/src/xdisp.c index fc17014c029..a8cd4dc853c 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -19223,18 +19223,20 @@ try_window (Lisp_Object window, struct text_pos pos, int flags) && !MINI_WINDOW_P (w)) { int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS); + if (window_wants_header_line (w)) + this_scroll_margin += CURRENT_HEADER_LINE_HEIGHT (w); start_display (&it, w, pos); if ((w->cursor.y >= 0 /* not vscrolled */ && w->cursor.y < this_scroll_margin - && CHARPOS (pos) > BEGV - && it_charpos < ZV) + && CHARPOS (pos) > BEGV) /* rms: considering make_cursor_line_fully_visible_p here seems to give wrong results. We don't want to recenter when the last line is partly visible, we want to allow that case to be handled in the usual way. */ - || w->cursor.y > (it.last_visible_y - partial_line_height (&it) - - this_scroll_margin - 1)) + || (it_charpos < ZV /* if EOB is visible, disable bottom margin */ + && w->cursor.y > (it.last_visible_y - partial_line_height (&it) + - this_scroll_margin - 1))) { w->cursor.vpos = -1; clear_glyph_matrix (w->desired_matrix); From d8ab98843edccd233c2354d3c518c7a4b18023bd Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 2 Aug 2020 17:17:00 +0200 Subject: [PATCH 011/145] =?UTF-8?q?Avoid=20duplicate=20Edebug=20symbols=20?= =?UTF-8?q?when=20using=20=E2=80=98cl-flet=E2=80=99=20(Bug#41989)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * lisp/emacs-lisp/edebug.el (edebug-match-:unique): Add a new ‘:unique’ specifier to generate unique names. * lisp/emacs-lisp/cl-macs.el (cl-flet): Use it. This requires inlining the ‘cl-defun’ specification. * test/lisp/emacs-lisp/edebug-tests.el (edebug-tests-cl-flet): New unit test. * doc/lispref/edebug.texi (Specification List): Document new ‘:unique’ construct. --- doc/lispref/edebug.texi | 10 +++++++ etc/NEWS | 4 +++ lisp/emacs-lisp/cl-macs.el | 7 ++++- lisp/emacs-lisp/edebug.el | 12 +++++++++ test/lisp/emacs-lisp/edebug-tests.el | 40 ++++++++++++++++++++++++++++ 5 files changed, 72 insertions(+), 1 deletion(-) diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index d879f3dcadf..6404e068dae 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -1438,6 +1438,16 @@ name component for the definition. You can use this to add a unique, static component to the name of the definition. It may be used more than once. +@item :unique +This construct is like @code{:name}, but generates unique names. It +does not match an argument. The element following @code{:unique} +should be a string; it is used as the prefix for an additional name +component for the definition. You can use this to add a unique, +dynamic component to the name of the definition. This is useful for +macros that can define the same symbol multiple times in different +scopes, such as @code{cl-flet}; @ref{Function Bindings,,,cl}. It may +be used more than once. + @item arg The argument, a symbol, is the name of an argument of the defining form. However, lambda-list keywords (symbols starting with @samp{&}) diff --git a/etc/NEWS b/etc/NEWS index 492d01feed0..aeba96e3811 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -260,6 +260,10 @@ To revert to the previous behaviour, unconditionally aborts the current edebug instrumentation with the supplied error message. +*** Edebug specification lists can use the new keyword ':unique', +which appends a unique suffix to the Edebug name of the current +definition. + +++ ** ElDoc diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 6c1426ce5cb..c38019d4a73 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2016,7 +2016,12 @@ info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) - (debug ((&rest [&or (&define name function-form) (cl-defun)]) + (debug ((&rest [&or (&define name :unique "cl-flet@" function-form) + (&define name :unique "cl-flet@" + cl-lambda-list + cl-declarations-or-string + [&optional ("interactive" interactive)] + def-body)]) cl-declarations body))) (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 7627829e034..cef97e0fb45 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1725,6 +1725,7 @@ contains a circular object." (&define . edebug-match-&define) (name . edebug-match-name) (:name . edebug-match-colon-name) + (:unique . edebug-match-:unique) (arg . edebug-match-arg) (def-body . edebug-match-def-body) (def-form . edebug-match-def-form) @@ -2037,6 +2038,17 @@ contains a circular object." spec)) nil) +(defun edebug-match-:unique (_cursor spec) + "Match a `:unique PREFIX' specifier. +SPEC is the symbol name prefix for `gensym'." + (let ((suffix (gensym spec))) + (setq edebug-def-name + (if edebug-def-name + ;; Construct a new name by appending to previous name. + (intern (format "%s@%s" edebug-def-name suffix)) + suffix))) + nil) + (defun edebug-match-cl-generic-method-qualifier (cursor) "Match a QUALIFIER for `cl-defmethod' at CURSOR." (let ((args (edebug-top-element-required cursor "Expected qualifier"))) diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 89b1f293743..be9f1503795 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -960,5 +960,45 @@ primary ones (Bug#42671)." (list (intern "edebug-cl-defmethod-qualifier :around ((_ number))") (intern "edebug-cl-defmethod-qualifier ((_ number))"))))))) +(ert-deftest edebug-tests-cl-flet () + "Check what Edebug can instrument `cl-flet' forms without name +clashes (Bug#41853)." + (with-temp-buffer + (dolist (form '((defun edebug-tests-cl-flet-1 () + (cl-flet ((inner () 0)) (message "Hi")) + (cl-flet ((inner () 1)) (inner))) + (defun edebug-tests-cl-flet-2 () + (cl-flet ((inner () 2)) (inner))))) + (print form (current-buffer))) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name))) + ;; Make generated symbols reproducible. + (gensym-counter 10000)) + (eval-buffer) + (should (equal (reverse instrumented-names) + ;; The outer definitions come after the inner + ;; ones because their body ends later. + ;; FIXME: There are twice as many inner + ;; definitions as expected due to Bug#41988. + ;; Once that bug is fixed, remove the duplicates. + ;; FIXME: We'd rather have names such as + ;; `edebug-tests-cl-flet-1@inner@cl-flet@10000', + ;; but that requires further changes to Edebug. + '(inner@cl-flet@10000 + inner@cl-flet@10001 + inner@cl-flet@10002 + inner@cl-flet@10003 + edebug-tests-cl-flet-1 + inner@cl-flet@10004 + inner@cl-flet@10005 + edebug-tests-cl-flet-2)))))) + (provide 'edebug-tests) ;;; edebug-tests.el ends here From 0a65e060207def5d31fb7d96b8d3bb1441fd13c9 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 2 Aug 2020 18:04:18 +0200 Subject: [PATCH 012/145] ; * test/lisp/emacs-lisp/edebug-tests.el (edebug-tests-cl-flet): Fix typo. --- test/lisp/emacs-lisp/edebug-tests.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index be9f1503795..1be68f6ff46 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -961,7 +961,7 @@ primary ones (Bug#42671)." (intern "edebug-cl-defmethod-qualifier ((_ number))"))))))) (ert-deftest edebug-tests-cl-flet () - "Check what Edebug can instrument `cl-flet' forms without name + "Check that Edebug can instrument `cl-flet' forms without name clashes (Bug#41853)." (with-temp-buffer (dolist (form '((defun edebug-tests-cl-flet-1 () From 3e0c3479b24e1978d30bbcc00faac7bdd6bdd170 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 2 Aug 2020 18:05:36 +0200 Subject: [PATCH 013/145] Add a workaround for Bug#42672 * lisp/emacs-lisp/cl-generic.el (cl-defgeneric): Work around Bug#42672 by uniquifying inline method names. * test/lisp/emacs-lisp/cl-generic-tests.el (cl-defgeneric/edebug/method): New regression test. --- lisp/emacs-lisp/cl-generic.el | 11 +++++++- test/lisp/emacs-lisp/cl-generic-tests.el | 36 ++++++++++++++++++++++++ 2 files changed, 46 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index c67681b0960..640eb6b06d4 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -211,7 +211,16 @@ DEFAULT-BODY, if present, is used as the body of a default method. [&rest [&or ("declare" &rest sexp) (":argument-precedence-order" &rest sexp) - (&define ":method" [&rest atom] + (&define ":method" + ;; FIXME: The `:unique' + ;; construct works around + ;; Bug#42672. We'd rather want + ;; names like those generated by + ;; `cl-defmethod', but that + ;; requires larger changes to + ;; Edebug. + :unique "cl-generic-:method@" + [&rest atom] cl-generic-method-args lambda-doc def-body)]] def-body))) diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index 51c9884ddc8..fc39e349523 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -24,6 +24,7 @@ ;;; Code: (require 'cl-generic) +(require 'edebug) ;; Don't indirectly require `cl-lib' at run-time. (eval-when-compile (require 'ert)) @@ -249,5 +250,40 @@ (should-not (cl--generic-method-files 'cl-generic-tests--undefined-generic)) (should-not (cl--generic-method-files 'cl-generic-tests--generic-without-methods))) +(ert-deftest cl-defgeneric/edebug/method () + "Check that `:method' forms in `cl-defgeneric' create unique +Edebug symbols (Bug#42672)." + (with-temp-buffer + (dolist (form '((cl-defgeneric cl-defgeneric/edebug/method/1 (_) + (:method ((_ number)) 1) + (:method ((_ string)) 2)) + (cl-defgeneric cl-defgeneric/edebug/method/2 (_) + (:method ((_ number)) 3)))) + (print form (current-buffer))) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name))) + ;; Make generated symbols reproducible. + (gensym-counter 10000)) + (eval-buffer) + (should (equal (reverse instrumented-names) + ;; The generic function definitions come after + ;; the method definitions because their body ends + ;; later. + ;; FIXME: We'd rather have names such as + ;; `cl-defgeneric/edebug/method/1 ((_ number))', + ;; but that requires further changes to Edebug. + (list (intern "cl-generic-:method@10000 ((_ number))") + (intern "cl-generic-:method@10001 ((_ string))") + 'cl-defgeneric/edebug/method/1 + (intern "cl-generic-:method@10002 ((_ number))") + 'cl-defgeneric/edebug/method/2)))))) + (provide 'cl-generic-tests) ;;; cl-generic-tests.el ends here From 94b6eb807c8991897796fd18ccd414c7d9b9ad3b Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 2 Aug 2020 19:03:07 +0200 Subject: [PATCH 014/145] Document that :width/:height in XBM images are peculiar * doc/lispref/display.texi (XBM Images): Note the peculiarities of :width/:height in XBM images (bug#39735). --- doc/lispref/display.texi | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 25eabd6c3fc..d3adb62c1bd 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -5572,6 +5572,15 @@ The value, @var{width}, specifies the width of the image, in pixels. @item :height @var{height} The value, @var{height}, specifies the height of the image, in pixels. +Note that @code{:width} and @code{:height} can only be used if passing +in data that doesn't specify the width and height (e.g., a string or a +vector containing the bits of the image). @acronym{XBM} files usually +specify this themselves, and it's an error to use these two properties +on these files. Also note that @code{:width} and @code{:height} are +used by most other image formats to specify what the displayed image +is supposed to be, which usually means performing some sort of +scaling. This isn't supported for @acronym{XBM} images. + @item :stride @var{stride} The number of bool vector entries stored for each row; the smallest multiple of 8 greater than or equal to @var{width}. From 72c5f71cd45c860299950cd058d8e13b87375741 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9gory=20Mouni=C3=A9?= Date: Sun, 2 Aug 2020 15:56:33 +0200 Subject: [PATCH 015/145] Avoid segfaults if XIM is set but not xim_styles Emacs segfaults at the X11 initialization if XIM is set and xim_styles is NULL. This patch avoids the crash. * src/xfns.c: Check also if FRAME_X_XIM_STYLES(f) is NULL. (Bug#42676) (Bug#42673) (Bug#42677) Copyright-paperwork-exempt: yes --- src/xfns.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/xfns.c b/src/xfns.c index b89fac1cdac..f9a00a6dafd 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -2658,7 +2658,7 @@ create_frame_xic (struct frame *f) goto out; xim = FRAME_X_XIM (f); - if (!xim) + if (!xim || ! FRAME_X_XIM_STYLES(f)) goto out; /* Determine XIC style. */ From 2ad38b4745bf0203ca9ca0fe2eeb376943d384c6 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 2 Aug 2020 19:44:30 +0200 Subject: [PATCH 016/145] If gnus-visual is nil, don't fontify patches and the like * doc/misc/emacs-mime.texi (Display Customization): Document it. * lisp/gnus/gnus-art.el (gnus-mime-display-single): Bind it. * lisp/gnus/mm-view.el (mm-inline-font-lock): New variable (bug#38421). (mm-display-inline-fontify): Use it. --- doc/misc/emacs-mime.texi | 7 +++++++ etc/NEWS | 6 ++++++ lisp/gnus/gnus-art.el | 1 + lisp/gnus/mm-view.el | 10 ++++++++-- 4 files changed, 22 insertions(+), 2 deletions(-) diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi index 2f38dcd4956..974cc10458d 100644 --- a/doc/misc/emacs-mime.texi +++ b/doc/misc/emacs-mime.texi @@ -472,6 +472,13 @@ the case if you save it to disk and launch it in a different way to launch any external programs, set this variable to @code{nil} or @code{ask}. +@item mm-inline-font-lock +@vindex mm-inline-font-lock +If non-@code{nil}, inlined parts that support font locking (for +instance, patches or code snippets) will be font-locked. This may be +overriden by callers that have their own ways of enabling/inhibiting +font locking. + @end table @node Files and Directories diff --git a/etc/NEWS b/etc/NEWS index aeba96e3811..7221c9cf9e6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -231,6 +231,12 @@ 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 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. + ** Help +++ diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index cb20d7102bd..d33539bc7f7 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -6018,6 +6018,7 @@ If nil, don't show those extra buttons." (defun gnus-mime-display-single (handle) (let ((type (mm-handle-media-type handle)) (ignored gnus-ignored-mime-types) + (mm-inline-font-lock (gnus-visual-p 'article-highlight 'highlight)) (not-attachment t) display text) (catch 'ignored diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index 828ac633dc5..bd5960c18b2 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -59,11 +59,16 @@ "The attributes of renderer types for text/html.") (defcustom mm-fill-flowed t - "If non-nil a format=flowed article will be displayed flowed." + "If non-nil, format=flowed articles will be displayed flowed." :type 'boolean :version "22.1" :group 'mime-display) +;; Not a defcustom, since it's usually overridden by the callers of +;; the mm functions. +(defvar mm-inline-font-lock t + "If non-nil, do font locking of inline media types that support it.") + (defcustom mm-inline-large-images-proportion 0.9 "Maximum proportion large images can occupy in the buffer. This is only used if `mm-inline-large-images' is set to @@ -502,7 +507,8 @@ If MODE is not set, try to find mode automatically." (delay-mode-hooks (set-auto-mode)) (setq mode major-mode))) ;; Do not fontify if the guess mode is fundamental. - (unless (eq major-mode 'fundamental-mode) + (when (and (not (eq major-mode 'fundamental-mode)) + mm-inline-font-lock) (font-lock-ensure)))) (setq text (buffer-string)) (when (eq mode 'diff-mode) From a325584281c4d8552917fcb97caed449acb7ee65 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 2 Aug 2020 22:07:27 +0200 Subject: [PATCH 017/145] Improve Edebug symbols for inlined secondary methods (Bug#42671) * lisp/emacs-lisp/cl-generic.el (cl-defgeneric): Include qualifiers in Edebug symbol name. * test/lisp/emacs-lisp/cl-generic-tests.el (cl-defgeneric/edebug/method): Adapt unit test. --- lisp/emacs-lisp/cl-generic.el | 2 +- test/lisp/emacs-lisp/cl-generic-tests.el | 28 +++++++++++++----------- 2 files changed, 16 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 640eb6b06d4..02da07daaf4 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -220,7 +220,7 @@ DEFAULT-BODY, if present, is used as the body of a default method. ;; requires larger changes to ;; Edebug. :unique "cl-generic-:method@" - [&rest atom] + [&rest cl-generic-method-qualifier] cl-generic-method-args lambda-doc def-body)]] def-body))) diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index fc39e349523..5aa58782f36 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -256,7 +256,8 @@ Edebug symbols (Bug#42672)." (with-temp-buffer (dolist (form '((cl-defgeneric cl-defgeneric/edebug/method/1 (_) (:method ((_ number)) 1) - (:method ((_ string)) 2)) + (:method ((_ string)) 2) + (:method :around ((_ number)) 3)) (cl-defgeneric cl-defgeneric/edebug/method/2 (_) (:method ((_ number)) 3)))) (print form (current-buffer))) @@ -272,18 +273,19 @@ Edebug symbols (Bug#42672)." ;; Make generated symbols reproducible. (gensym-counter 10000)) (eval-buffer) - (should (equal (reverse instrumented-names) - ;; The generic function definitions come after - ;; the method definitions because their body ends - ;; later. - ;; FIXME: We'd rather have names such as - ;; `cl-defgeneric/edebug/method/1 ((_ number))', - ;; but that requires further changes to Edebug. - (list (intern "cl-generic-:method@10000 ((_ number))") - (intern "cl-generic-:method@10001 ((_ string))") - 'cl-defgeneric/edebug/method/1 - (intern "cl-generic-:method@10002 ((_ number))") - 'cl-defgeneric/edebug/method/2)))))) + (should (equal + (reverse instrumented-names) + ;; The generic function definitions come after the + ;; method definitions because their body ends later. + ;; FIXME: We'd rather have names such as + ;; `cl-defgeneric/edebug/method/1 ((_ number))', but + ;; that requires further changes to Edebug. + (list (intern "cl-generic-:method@10000 ((_ number))") + (intern "cl-generic-:method@10001 ((_ string))") + (intern "cl-generic-:method@10002 :around ((_ number))") + 'cl-defgeneric/edebug/method/1 + (intern "cl-generic-:method@10003 ((_ number))") + 'cl-defgeneric/edebug/method/2)))))) (provide 'cl-generic-tests) ;;; cl-generic-tests.el ends here From f921feceb8cd8c52f281447c984d0b67a738a33c Mon Sep 17 00:00:00 2001 From: Derek Zhou Date: Mon, 3 Aug 2020 07:56:22 +0200 Subject: [PATCH 018/145] Fix problem where TLS connections would sometimes hang * src/process.c (wait_reading_process_output): Before the select, check every interesting gnutls stream for available data in the buffer. If some of them hit, and either there is no wait_proc or the wait_proc is one of the gnutls streams with new data, set the select timeout to 0 after the select, and merge the gnutls buffer status into the select returns (bug#40665). This fixes a problem where TLS connections would sometimes hang. --- src/process.c | 97 ++++++++++++++++++++++++--------------------------- 1 file changed, 46 insertions(+), 51 deletions(-) diff --git a/src/process.c b/src/process.c index 6e5bcf307ab..15634e4a8b0 100644 --- a/src/process.c +++ b/src/process.c @@ -5491,6 +5491,10 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } else { +#ifdef HAVE_GNUTLS + int tls_nfds; + fd_set tls_available; +#endif /* Set the timeout for adaptive read buffering if any process has non-zero read_output_skip and non-zero read_output_delay, and we are not reading output for a @@ -5560,7 +5564,36 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } #endif -/* Non-macOS HAVE_GLIB builds call thread_select in xgselect.c. */ +#ifdef HAVE_GNUTLS + /* GnuTLS buffers data internally. We need to check if some + data is available in the buffers manually before the select. + And if so, we need to skip the select which could block. */ + FD_ZERO (&tls_available); + tls_nfds = 0; + for (channel = 0; channel < FD_SETSIZE; ++channel) + if (! NILP (chan_process[channel]) + && FD_ISSET (channel, &Available)) + { + struct Lisp_Process *p = XPROCESS (chan_process[channel]); + if (p + && p->gnutls_p && p->gnutls_state + && emacs_gnutls_record_check_pending (p->gnutls_state) > 0) + { + tls_nfds++; + eassert (p->infd == channel); + FD_SET (p->infd, &tls_available); + } + } + /* If wait_proc is somebody else, we have to wait in select + as usual. Otherwise, clobber the timeout. */ + if (tls_nfds > 0 + && (!wait_proc || + (wait_proc->infd >= 0 + && FD_ISSET (wait_proc->infd, &tls_available)))) + timeout = make_timespec (0, 0); +#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, &Available, (check_write ? &Writeok : 0), @@ -5578,59 +5611,21 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, #endif /* !HAVE_GLIB */ #ifdef HAVE_GNUTLS - /* GnuTLS buffers data internally. In lowat mode it leaves - some data in the TCP buffers so that select works, but - with custom pull/push functions we need to check if some - data is available in the buffers manually. */ - if (nfds == 0) + /* Merge tls_available into Available. */ + if (tls_nfds > 0) { - fd_set tls_available; - int set = 0; - - FD_ZERO (&tls_available); - if (! wait_proc) + if (nfds == 0 || (nfds < 0 && errno == EINTR)) { - /* We're not waiting on a specific process, so loop - through all the channels and check for data. - This is a workaround needed for some versions of - the gnutls library -- 2.12.14 has been confirmed - to need it. */ - for (channel = 0; channel < FD_SETSIZE; ++channel) - if (! NILP (chan_process[channel])) - { - struct Lisp_Process *p = - XPROCESS (chan_process[channel]); - if (p && p->gnutls_p && p->gnutls_state - && ((emacs_gnutls_record_check_pending - (p->gnutls_state)) - > 0)) - { - nfds++; - eassert (p->infd == channel); - FD_SET (p->infd, &tls_available); - set++; - } - } + /* Fast path, just copy. */ + nfds = tls_nfds; + Available = tls_available; } - else - { - /* Check this specific channel. */ - if (wait_proc->gnutls_p /* Check for valid process. */ - && wait_proc->gnutls_state - /* Do we have pending data? */ - && ((emacs_gnutls_record_check_pending - (wait_proc->gnutls_state)) - > 0)) - { - nfds = 1; - eassert (0 <= wait_proc->infd); - /* Set to Available. */ - FD_SET (wait_proc->infd, &tls_available); - set++; - } - } - if (set) - Available = tls_available; + else if (nfds > 0) + /* Slow path, merge one by one. Note: nfds does not need + to be accurate, just positive is enough. */ + for (channel = 0; channel < FD_SETSIZE; ++channel) + if (FD_ISSET(channel, &tls_available)) + FD_SET(channel, &Available); } #endif } From 26b9a1da63bab8c8ee00a484df46db6ed57e2317 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 3 Aug 2020 08:18:39 +0200 Subject: [PATCH 019/145] Adjust error message in image-mode * lisp/image-mode.el (image-mode): Even when `image-user-external-converter' is on, we may get `unknown-image-type' (bug#39994). Adjust the error message in that case. --- lisp/image-mode.el | 32 +++++++++++++++++--------------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 1bb213c2489..129529542ae 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -614,21 +614,23 @@ Key bindings: (if (not (image-get-display-property)) (progn (when (condition-case err - (progn - (image-toggle-display-image) - t) - (unknown-image-type - (image-mode-as-text) - (funcall - (if (called-interactively-p 'any) 'error 'message) - "Unknown image type; consider switching `image-use-external-converter' on") - nil) - (error - (image-mode-as-text) - (funcall - (if (called-interactively-p 'any) 'error 'message) - "Cannot display image: %s" (cdr err)) - nil)) + (progn + (image-toggle-display-image) + t) + (unknown-image-type + (image-mode-as-text) + (funcall + (if (called-interactively-p 'any) 'error 'message) + (if image-use-external-converter + "Unknown image type" + "Unknown image type; consider switching `image-use-external-converter' on")) + nil) + (error + (image-mode-as-text) + (funcall + (if (called-interactively-p 'any) 'error 'message) + "Cannot display image: %s" (cdr err)) + nil)) ;; If attempt to display the image fails. (if (not (image-get-display-property)) (error "Invalid image")) From 79527cd56e9e3f8b5b1630fe18b92f7ea95e87fd Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 3 Aug 2020 09:00:53 +0200 Subject: [PATCH 020/145] Fix problem with viewing .webp files from .zip buffers * lisp/image-mode.el (image-toggle-display-image): Make it possible to view images (via external formatters, like webp) from zip files (and other archive modes) (bug#39994). --- lisp/image-mode.el | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 129529542ae..c417be43da5 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -818,13 +818,21 @@ was inserted." (- (nth 2 edges) (nth 0 edges)))) (max-height (when edges (- (nth 3 edges) (nth 1 edges)))) - (type (if (image--imagemagick-wanted-p filename) - 'imagemagick - (image-type file-or-data nil data-p))) (inhibit-read-only t) (buffer-undo-list t) (modified (buffer-modified-p)) - props image) + props image type) + + ;; If the data in the current buffer isn't from an existing file, + ;; but we have a file name (this happens when visiting images from + ;; a zip file, for instance), provide a type hint based on the + ;; suffix. + (when (and data-p filename) + (setq data-p (intern (format "image/%s" + (file-name-extension filename))))) + (setq type (if (image--imagemagick-wanted-p filename) + 'imagemagick + (image-type file-or-data nil data-p))) ;; Get the rotation data from the file, if any. (when (zerop image-transform-rotation) ; don't reset modified value @@ -841,10 +849,13 @@ was inserted." ;; :scale 1: If we do not set this, create-image will apply ;; default scaling based on font size. (setq image (if (not edges) - (create-image file-or-data type data-p :scale 1) + (create-image file-or-data type data-p :scale 1 + :format (and filename data-p)) (create-image file-or-data type data-p :scale 1 :max-width max-width - :max-height max-height))) + :max-height max-height + ;; Type hint. + :format (and filename data-p)))) ;; Discard any stale image data before looking it up again. (image-flush image) From e1f09607e02eb507b229285ed48b85a3c6a50259 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 3 Aug 2020 09:14:52 +0200 Subject: [PATCH 021/145] Make `n'/`p' in image-mode also find externally converted images * lisp/image-file.el (image-file-name-regexp): Use it to make `n'/`p' in image mode work (bug#39994). * lisp/image/image-converter.el (image-converter-file-name-extensions): New variable to keep track of all suffixes. (image-convert-p): Update. (image-converter--find-converter): Set. --- lisp/image-file.el | 12 ++++++++---- lisp/image/image-converter.el | 14 ++++++++++---- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/lisp/image-file.el b/lisp/image-file.el index 89cd75d50dd..22366c89e6a 100644 --- a/lisp/image-file.el +++ b/lisp/image-file.el @@ -32,6 +32,7 @@ ;;; Code: (require 'image) +(require 'image-converter) ;;;###autoload @@ -80,10 +81,13 @@ the variable is set using \\[customize]." (let ((exts-regexp (and image-file-name-extensions (concat "\\." - (regexp-opt (nconc (mapcar #'upcase - image-file-name-extensions) - image-file-name-extensions) - t) + (regexp-opt + (append (mapcar #'upcase image-file-name-extensions) + image-file-name-extensions + (mapcar #'upcase + image-converter-file-name-extensions) + image-converter-file-name-extensions) + t) "\\'")))) (mapconcat 'identity diff --git a/lisp/image/image-converter.el b/lisp/image/image-converter.el index b694052f5b9..ee1dc845fb5 100644 --- a/lisp/image/image-converter.el +++ b/lisp/image/image-converter.el @@ -42,6 +42,9 @@ installed on the system." (defvar image-converter-regexp nil "A regexp that matches the file name suffixes that can be converted.") +(defvar image-converter-file-name-extensions nil + "A list of file name suffixes that can be converted.") + (defvar image-converter--converters '((graphicsmagick :command ("gm" "convert") :probe ("-list" "format")) (ffmpeg :command "ffmpeg" :probe "-decoders") @@ -58,9 +61,11 @@ is a string, it should be a MIME format string like (unless image-converter (image-converter--find-converter)) ;; When image-converter was customized - (if (and image-converter (not image-converter-regexp)) - (when-let ((formats (image-converter--probe image-converter))) - (setq image-converter-regexp (concat "\\." (regexp-opt formats) "\\'")))) + (when (and image-converter (not image-converter-regexp)) + (when-let ((formats (image-converter--probe image-converter))) + (setq image-converter-regexp + (concat "\\." (regexp-opt formats) "\\'")) + (setq image-converter-file-name-extensions formats))) (and image-converter (or (and (not data-p) (string-match image-converter-regexp source)) @@ -183,7 +188,8 @@ data is returned as a string." (dolist (elem image-converter--converters) (when-let ((formats (image-converter--probe (car elem)))) (setq image-converter (car elem) - image-converter-regexp (concat "\\." (regexp-opt formats) "\\'")) + image-converter-regexp (concat "\\." (regexp-opt formats) "\\'") + image-converter-file-name-extensions formats) (throw 'done image-converter))))) (cl-defmethod image-converter--convert ((type (eql graphicsmagick)) source From 83bc4ad369b3c31abafb7f939711da1ba13416ba Mon Sep 17 00:00:00 2001 From: Phil Sainty Date: Sun, 15 Dec 2019 02:00:05 +1300 Subject: [PATCH 022/145] ; * so-long.el: Documentation and spelling Reverting certain changes from commits b0f20651e3 and d1a791f8ed. Please refer to the comments on spelling at the end of the library. M-x ispell-buffer should find no misspellings in the documentation. See also test/lisp/so-long-tests/spelling-tests.el (The current spelling will persist while so-long.el is maintained in its own Savannah repository, to avoid unnecessary conflicts between the two versions. If in the future it is maintained solely in the Emacs repository, changing the spelling would become an option.) Note that "mitigations" (plural) is intentional -- this library identifies a collection of different performance mitigations, multiple of which will typically be in effect together. --- lisp/so-long.el | 66 ++++++++++++++++++++++++------------------------- 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/lisp/so-long.el b/lisp/so-long.el index dcf7e62ca74..68614ca0023 100644 --- a/lisp/so-long.el +++ b/lisp/so-long.el @@ -38,7 +38,7 @@ ;; compacted into the smallest file size possible, which often entails removing ;; newlines should they not be strictly necessary). This can result in lines ;; which are many thousands of characters long, and most programming modes -;; simply aren't optimized (remotely) for this scenario, so performance can +;; simply aren't optimised (remotely) for this scenario, so performance can ;; suffer significantly. ;; ;; When such files are detected, the command `so-long' is automatically called, @@ -69,7 +69,7 @@ ;; the long lines. In such circumstances you may find that `longlines-mode' is ;; the most helpful facility. ;; -;; Note also that the mitigation is automatically triggered when visiting a +;; Note also that the mitigations are automatically triggered when visiting a ;; file. The library does not automatically detect if long lines are inserted ;; into an existing buffer (although the `so-long' command can be invoked ;; manually in such situations). @@ -90,7 +90,7 @@ ;; * Overview of modes and commands ;; -------------------------------- ;; - `global-so-long-mode' - A global minor mode which enables the automated -;; behavior, causing the user's preferred action to be invoked whenever a +;; behaviour, causing the user's preferred action to be invoked whenever a ;; newly-visited file contains excessively long lines. ;; - `so-long-mode' - A major mode, and the default action. ;; - `so-long-minor-mode' - A minor mode version of the major mode, and an @@ -111,7 +111,7 @@ ;; ;; On rare occasions you may choose to manually invoke the `so-long' command, ;; which invokes your preferred `so-long-action' (exactly as the automatic -;; behavior would do if it had detected long lines). You might use this if a +;; behaviour would do if it had detected long lines). You might use this if a ;; problematic file did not meet your configured criteria, and you wished to ;; trigger the performance improvements manually. ;; @@ -120,7 +120,7 @@ ;; available to `so-long' but, like any other mode, they can be invoked directly ;; if you have a need to do that (see also "Other ways of using so-long" below). ;; -;; If the behavior ever triggers when you did not want it to, you can use the +;; If the behaviour ever triggers when you did not want it to, you can use the ;; `so-long-revert' command to restore the buffer to its original state. ;; * Basic configuration @@ -199,7 +199,7 @@ ;; ;; Note that `so-long-minor-modes' is not useful for other global minor modes ;; (as distinguished from globalized minor modes), but in some cases it will be -;; possible to inhibit or otherwise counter-act the behavior of a global mode +;; possible to inhibit or otherwise counter-act the behaviour of a global mode ;; by overriding variables, or by employing hooks (see below). You would need ;; to inspect the code for a given global mode (on a case by case basis) to ;; determine whether it's possible to inhibit it for a single buffer -- and if @@ -211,7 +211,7 @@ ;; If `so-long-action' is set to either `so-long-mode' or `so-long-minor-mode', ;; the buffer-local value for each variable in the list is set to the associated ;; value in the alist. Use this to enforce values which will improve -;; performance or otherwise avoid undesirable behaviors. If `so-long-revert' +;; performance or otherwise avoid undesirable behaviours. If `so-long-revert' ;; is called, then the original values are restored. ;; * Hooks @@ -325,7 +325,7 @@ ;; meaning you would need to add to `safe-local-variable-values' in order to ;; avoid being queried about them. ;; -;; Finally, the `so-long-predicate' user option enables the automated behavior +;; Finally, the `so-long-predicate' user option enables the automated behaviour ;; to be determined by a custom function, if greater control is needed. ;; * Implementation notes @@ -342,7 +342,7 @@ ;; * Caveats ;; --------- -;; The variables affecting the automated behavior of this library (such as +;; The variables affecting the automated behaviour of this library (such as ;; `so-long-action') can be used as file- or dir-local values in Emacs 26+, but ;; not in previous versions of Emacs. This is on account of improvements made ;; to `normal-mode' in 26.1, which altered the execution order with respect to @@ -386,7 +386,7 @@ ;; - Added sgml-mode and nxml-mode to `so-long-target-modes'. ;; 0.7.4 - Refactored the handling of `whitespace-mode'. ;; 0.7.3 - Added customize group `so-long' with user options. -;; - Added `so-long-original-values' to generalize the storage and +;; - Added `so-long-original-values' to generalise the storage and ;; restoration of values from the original mode upon `so-long-revert'. ;; - Added `so-long-revert-hook'. ;; 0.7.2 - Remember the original major mode even with M-x `so-long-mode'. @@ -399,7 +399,7 @@ ;; 0.6 - Added `so-long-minor-modes' and `so-long-hook'. ;; 0.5 - Renamed library to "so-long.el". ;; - Added explicit `so-long-enable' command to activate our advice. -;; 0.4 - Amended/documented behavior with file-local 'mode' variables. +;; 0.4 - Amended/documented behaviour with file-local 'mode' variables. ;; 0.3 - Defer to a file-local 'mode' variable. ;; 0.2 - Initial release to EmacsWiki. ;; 0.1 - Experimental. @@ -421,7 +421,7 @@ Has no effect if `global-so-long-mode' is not enabled.") (defvar-local so-long--active nil ; internal use - "Non-nil when `so-long' mitigation is in effect.") + "Non-nil when `so-long' mitigations are in effect.") (defvar so-long--set-auto-mode nil ; internal use "Non-nil while `set-auto-mode' is executing.") @@ -500,7 +500,7 @@ files would prevent Emacs from handling them correctly." (defcustom so-long-invisible-buffer-function #'so-long-deferred "Function called in place of `so-long' when the buffer is not displayed. -This affects the behavior of `global-so-long-mode'. +This affects the behaviour of `global-so-long-mode'. We treat invisible buffers differently from displayed buffers because, in cases where a library is using a buffer for behind-the-scenes processing, @@ -548,7 +548,7 @@ Defaults to `so-long-detected-long-line-p'." (defun so-long--action-type () "Generate a :type for `so-long-action' based on `so-long-action-alist'." ;; :type seemingly cannot be a form to be evaluated on demand, so we - ;; endeavor to keep it up-to-date with `so-long-action-alist' by + ;; endeavour to keep it up-to-date with `so-long-action-alist' by ;; calling this from `so-long--action-alist-setter'. `(radio ,@(mapcar (lambda (x) (list 'const :tag (cadr x) (car x))) (assq-delete-all nil so-long-action-alist)) @@ -609,7 +609,7 @@ will be automatically processed; but custom actions can also do these things. The value `longlines-mode' causes that minor mode to be enabled. See longlines.el for more details. -Each action likewise determines the behavior of `so-long-revert'. +Each action likewise determines the behaviour of `so-long-revert'. If the value is nil, or not defined in `so-long-action-alist', then no action will be taken." @@ -740,7 +740,7 @@ was established." ) ;; It's not clear to me whether all of these would be problematic, but they ;; seemed like reasonable targets. Some are certainly excessive in smaller - ;; buffers of minified code, but we should be aiming to maximize performance + ;; buffers of minified code, but we should be aiming to maximise performance ;; by default, so that Emacs is as responsive as we can manage in even very ;; large buffers of minified code. "List of buffer-local minor modes to explicitly disable. @@ -756,7 +756,7 @@ By default this happens if `so-long-action' is set to either `so-long-mode' or `so-long-minor-mode'. If `so-long-revert' is subsequently invoked, then the disabled modes are re-enabled by calling them with the numeric argument 1. -`so-long-hook' can be used where more custom behavior is desired. +`so-long-hook' can be used where more custom behaviour is desired. Please submit bug reports to recommend additional modes for this list, whether they are in Emacs core, GNU ELPA, or elsewhere." @@ -781,7 +781,7 @@ If `so-long-revert' is subsequently invoked, then the variables are restored to their original states. The combination of `line-move-visual' (enabled) and `truncate-lines' (disabled) -is important for maximizing responsiveness when moving vertically within an +is important for maximising responsiveness when moving vertically within an extremely long line, as otherwise the full length of the line may need to be scanned to find the next position." :type '(alist :key-type (variable :tag "Variable") @@ -822,18 +822,18 @@ If nil, no mode line indicator will be displayed." (defface so-long-mode-line-active '((t :inherit mode-line-emphasis)) - "Face for `so-long-mode-line-info' when mitigation is active." + "Face for `so-long-mode-line-info' when mitigations are active." :package-version '(so-long . "1.0")) (defface so-long-mode-line-inactive '((t :inherit mode-line-inactive)) - "Face for `so-long-mode-line-info' when mitigation has been reverted." + "Face for `so-long-mode-line-info' when mitigations have been reverted." :package-version '(so-long . "1.0")) ;; Modes that go slowly and line lengths excessive ;; Font-lock performance becoming oppressive ;; All of my CPU tied up with strings -;; These are a few of my least-favorite things +;; These are a few of my least-favourite things (defvar-local so-long-original-values nil "Alist holding the buffer's original `major-mode' value, and other data. @@ -983,7 +983,7 @@ Displayed as part of `mode-line-misc-info'. `so-long-mode-line-label' defines the text to be displayed (if any). -Face `so-long-mode-line-active' is used while mitigation is active, and +Face `so-long-mode-line-active' is used while mitigations are active, and `so-long-mode-line-inactive' is used if `so-long-revert' is called. Not displayed when `so-long-mode' is enabled, as the major mode construct @@ -1129,7 +1129,7 @@ This minor mode is a standard `so-long-action' option." (if so-long-minor-mode ;; We are enabling the mode. (progn ;; Housekeeping. `so-long-minor-mode' might be invoked directly rather - ;; than via `so-long', so replicate the necessary behaviors. The minor + ;; than via `so-long', so replicate the necessary behaviours. The minor ;; mode also cares about whether `so-long' was already active, as we do ;; not want to remember values which were potentially overridden already. (unless (or so-long--calling so-long--active) @@ -1201,9 +1201,9 @@ values), despite potential performance issues, type \\[so-long-revert]. Use \\[so-long-commentary] for more information. -Use \\[so-long-customize] to configure the behavior." +Use \\[so-long-customize] to configure the behaviour." ;; Housekeeping. `so-long-mode' might be invoked directly rather than via - ;; `so-long', so replicate the necessary behaviors. We could use this same + ;; `so-long', so replicate the necessary behaviours. We could use this same ;; test in `so-long-after-change-major-mode' to run `so-long-hook', but that's ;; not so obviously the right thing to do, so I've omitted it for now. (unless so-long--calling @@ -1249,7 +1249,7 @@ Use \\[so-long-customize] to configure the behavior." This advice acts before `so-long-mode', with the previous mode still active." (unless (derived-mode-p 'so-long-mode) ;; Housekeeping. `so-long-mode' might be invoked directly rather than - ;; via `so-long', so replicate the necessary behaviors. + ;; via `so-long', so replicate the necessary behaviours. (unless so-long--calling (so-long-remember-all :reset)) ;; Remember the original major mode, regardless. @@ -1334,7 +1334,7 @@ This is the `so-long-revert-function' for `so-long-mode'." ;; Emacs 26+ has already called `hack-local-variables' (during ;; `run-mode-hooks'; provided there was a `buffer-file-name'), but for older ;; versions we need to call it here. In Emacs 26+ the revised 'HANDLE-MODE' - ;; argument is set to `no-mode' (being the non-nil-and-non-t behavior), + ;; argument is set to `no-mode' (being the non-nil-and-non-t behaviour), ;; which we mimic here by binding `so-long--hack-local-variables-no-mode', ;; in order to prevent a local 'mode' variable from clobbering the major ;; mode we have just called. @@ -1371,7 +1371,7 @@ because we do not want to downgrade the major mode in that scenario." ;; Act only if `so-long-mode' would be enabled by the current action. (when (and (symbolp (so-long-function)) (provided-mode-derived-p (so-long-function) 'so-long-mode)) - ;; Downgrade from `so-long-mode' to the `so-long-minor-mode' behavior. + ;; Downgrade from `so-long-mode' to the `so-long-minor-mode' behaviour. (setq so-long-function 'turn-on-so-long-minor-mode so-long-revert-function 'turn-off-so-long-minor-mode)))) @@ -1391,7 +1391,7 @@ and cannot be conveniently intercepted, so we are forced to replicate it here. This special-case code will ultimately be removed from Emacs, as it exists to deal with a deprecated feature; but until then we need to replicate it in order -to inhibit our own behavior in the presence of a header comment `mode' +to inhibit our own behaviour in the presence of a header comment `mode' declaration. If a file-local mode is detected in the header comment, then we call the @@ -1526,7 +1526,7 @@ by testing the value against `major-mode'; but as we may have changed the major mode to `so-long-mode' by this point, that protection is insufficient and so we need to perform our own test. -We likewise need to support an equivalent of the `no-mode' behavior in 26.1+ +We likewise need to support an equivalent of the `no-mode' behaviour in 26.1+ to ensure that `so-long-mode-revert' will not restore a file-local mode again after it has already reverted to the original mode. @@ -1659,7 +1659,7 @@ Equivalent to calling (global-so-long-mode 0)" ;;;###autoload (define-minor-mode global-so-long-mode - "Toggle automated performance mitigation for files with long lines. + "Toggle automated performance mitigations for files with long lines. Many Emacs modes struggle with buffers which contain excessively long lines, and may consequently cause unacceptable performance issues. @@ -1673,7 +1673,7 @@ When such files are detected by `so-long-predicate', we invoke the selected Use \\[so-long-commentary] for more information. -Use \\[so-long-customize] to configure the behavior." +Use \\[so-long-customize] to configure the behaviour." :global t :group 'so-long (if global-so-long-mode @@ -1862,7 +1862,7 @@ If it appears in `%s', you should remove it." ; LocalWords: noerror selectable mapc sgml nxml hl flydiff defs arg Phil Sainty ; LocalWords: defadvice nadvice whitespace ie bos eos eobp origmode un Un setq ; LocalWords: docstring auf Wiedersehen longlines alist autoload Refactored Inc -; LocalWords: MERCHANTABILITY RET REGEXP VAR ELPA WS EmacsWiki eval +; LocalWords: MERCHANTABILITY RET REGEXP VAR ELPA WS mitigations EmacsWiki eval ; LocalWords: rx filename filenames ;; So long, farewell, auf Wiedersehen, goodbye From 19f8f36f11cf5ae62a7b92dc1496c72db4d377b3 Mon Sep 17 00:00:00 2001 From: Phil Sainty Date: Sun, 8 Dec 2019 23:35:48 +1300 Subject: [PATCH 023/145] ; * lisp/so-long.el (so-long-variable-overrides): Improve doc --- lisp/so-long.el | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/lisp/so-long.el b/lisp/so-long.el index 68614ca0023..b3596bdab7b 100644 --- a/lisp/so-long.el +++ b/lisp/so-long.el @@ -783,7 +783,18 @@ to their original states. The combination of `line-move-visual' (enabled) and `truncate-lines' (disabled) is important for maximising responsiveness when moving vertically within an extremely long line, as otherwise the full length of the line may need to be -scanned to find the next position." +scanned to find the next position. + +Bidirectional text display -- especially handling the large quantities of +nested parentheses which are liable to occur in minified programming code -- +can be very expensive for extremely long lines, and so this support is disabled +by default (insofar as is supported; in particular `bidi-inhibit-bpa' is not +available in Emacs versions < 27). For more information refer to info node +`(emacs) Bidirectional Editing' and info node `(elisp) Bidirectional Display'. + +Buffers are made read-only by default to prevent potentially-slow editing from +occurring inadvertantly, as buffers with excessively long lines are likely not +intended to be edited manually." :type '(alist :key-type (variable :tag "Variable") :value-type (sexp :tag "Value")) :options '((bidi-inhibit-bpa boolean) @@ -1863,7 +1874,7 @@ If it appears in `%s', you should remove it." ; LocalWords: defadvice nadvice whitespace ie bos eos eobp origmode un Un setq ; LocalWords: docstring auf Wiedersehen longlines alist autoload Refactored Inc ; LocalWords: MERCHANTABILITY RET REGEXP VAR ELPA WS mitigations EmacsWiki eval -; LocalWords: rx filename filenames +; LocalWords: rx filename filenames bidi bpa ;; So long, farewell, auf Wiedersehen, goodbye ;; You have to go, this code is minified From 986c12b20fa29c37f13563846fddf6edcd0b4945 Mon Sep 17 00:00:00 2001 From: Phil Sainty Date: Sat, 4 Jul 2020 01:43:08 +1200 Subject: [PATCH 024/145] ; * lisp/so-long.el: Byte-compilation bug fix As this `require' is not at the top-level (it is only conditionally evaluated, when loading the library over the top of an earlier version), we need `eval-and-compile' to ensure that both macros and functions from advice.el are accounted for. --- lisp/so-long.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/so-long.el b/lisp/so-long.el index b3596bdab7b..21dc7de75c8 100644 --- a/lisp/so-long.el +++ b/lisp/so-long.el @@ -1819,9 +1819,10 @@ If it appears in `%s', you should remove it." ;; Update to version 1.0 from earlier versions: (when (version< so-long-version "1.0") (remove-hook 'change-major-mode-hook 'so-long-change-major-mode) - (require 'advice) + (eval-and-compile (require 'advice)) ;; Both macros and functions. (declare-function ad-find-advice "advice") (declare-function ad-remove-advice "advice") + (declare-function ad-activate "advice") (when (ad-find-advice 'hack-local-variables 'after 'so-long--file-local-mode) (ad-remove-advice 'hack-local-variables 'after 'so-long--file-local-mode) (ad-activate 'hack-local-variables)) From 8576297b2a657d1944b7d824b30a1cb6459685c6 Mon Sep 17 00:00:00 2001 From: Phil Sainty Date: Sat, 11 Jul 2020 19:40:27 +1200 Subject: [PATCH 025/145] ; lisp/so-long.el: Prevent potential error if comment-use-syntax is nil * lisp/so-long.el (so-long-detected-long-line-p): Ensure that `comment-start-skip' and `comment-end-skip' are both set if `comment-use-syntax' is nil, as `comment-forward' requires them to be bound in this scenario. --- lisp/so-long.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/so-long.el b/lisp/so-long.el index 21dc7de75c8..1332ae12633 100644 --- a/lisp/so-long.el +++ b/lisp/so-long.el @@ -1047,7 +1047,9 @@ This is the default value of `so-long-predicate'." (let ((count 0) start) (save-excursion (goto-char (point-min)) - (when so-long-skip-leading-comments + (when (and so-long-skip-leading-comments + (or comment-use-syntax ;; Refer to `comment-forward'. + (and comment-start-skip comment-end-skip))) ;; Skip the shebang line, if any. This is not necessarily comment ;; syntax, so we need to treat it specially. (when (looking-at "#!") From 99275822c6c36ac308a7b77b5271066df5f38dfb Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Mon, 3 Aug 2020 17:56:40 +0300 Subject: [PATCH 026/145] Fix last change in 'try_window' * src/xdisp.c (try_window): Don't modify the logic when EOB is in the viewport. (Bug#42653) --- src/xdisp.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/xdisp.c b/src/xdisp.c index a8cd4dc853c..9f07361d48b 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -19234,9 +19234,8 @@ try_window (Lisp_Object window, struct text_pos pos, int flags) seems to give wrong results. We don't want to recenter when the last line is partly visible, we want to allow that case to be handled in the usual way. */ - || (it_charpos < ZV /* if EOB is visible, disable bottom margin */ - && w->cursor.y > (it.last_visible_y - partial_line_height (&it) - - this_scroll_margin - 1))) + || w->cursor.y > (it.last_visible_y - partial_line_height (&it) + - this_scroll_margin - 1)) { w->cursor.vpos = -1; clear_glyph_matrix (w->desired_matrix); From ca419812d35f252fca2708ffdd132c223d094c0f Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Mon, 3 Aug 2020 21:07:32 +0200 Subject: [PATCH 027/145] Avoid duplicate Edebug symbols when backtracking (Bug#42701) When Edebug backtracks, it nevertheless generates definitions for the non-matching branches, see Bug#41988 and Bug#42701. This should be fixed eventually (probably by deferring the definition until a branch is known to match), but for now add a band-aid to avoid these duplicate symbols, at least for anonymous forms. * lisp/emacs-lisp/edebug.el (edebug-make-enter-wrapper): Regenerate anonymous names. * test/lisp/emacs-lisp/edebug-tests.el (edebug-tests-duplicate-symbol-backtrack): New regression test. --- lisp/emacs-lisp/edebug.el | 7 ++++++ test/lisp/emacs-lisp/edebug-tests.el | 32 ++++++++++++++++++++++++++++ 2 files changed, 39 insertions(+) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index cef97e0fb45..d9bbf6129c6 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1240,6 +1240,13 @@ purpose by adding an entry to this alist, and setting ;; since it wraps the list of forms with a call to `edebug-enter'. ;; Uses the dynamically bound vars edebug-def-name and edebug-def-args. ;; Do this after parsing since that may find a name. + (when (string-match-p (rx bos "edebug-anon" (+ digit) eos) + (symbol-name edebug-old-def-name)) + ;; FIXME: Due to Bug#42701, we reset an anonymous name so that + ;; backtracking doesn't generate duplicate definitions. It would + ;; be better to not define wrappers in the case of a non-matching + ;; specification branch to begin with. + (setq edebug-old-def-name nil)) (setq edebug-def-name (or edebug-def-name edebug-old-def-name (gensym "edebug-anon"))) `(edebug-enter diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 1be68f6ff46..04a7b2f5a0f 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -1000,5 +1000,37 @@ clashes (Bug#41853)." inner@cl-flet@10005 edebug-tests-cl-flet-2)))))) +(ert-deftest edebug-tests-duplicate-symbol-backtrack () + "Check that Edebug doesn't create duplicate symbols when +backtracking (Bug#42701)." + (with-temp-buffer + (dolist (form '((require 'subr-x) + (defun edebug-tests-duplicate-symbol-backtrack () + (if-let (x (funcall (lambda (y) 1) 2)) 3 4)))) + (print form (current-buffer))) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name))) + ;; Make generated symbols reproducible. + (gensym-counter 10000)) + (eval-buffer) + ;; The anonymous symbols are uninterned. Use their names so we + ;; can perform the assertion. The names should still be unique. + (should (equal (mapcar #'symbol-name (reverse instrumented-names)) + ;; The outer definition comes after the inner + ;; ones because its body ends later. + ;; FIXME: There are twice as many inner + ;; definitions as expected due to Bug#42701. + ;; Once that bug is fixed, remove the duplicates. + '("edebug-anon10000" + "edebug-anon10001" + "edebug-tests-duplicate-symbol-backtrack")))))) + (provide 'edebug-tests) ;;; edebug-tests.el ends here From a4ed198e8f3754a59cabbb03ab6bae8a49597ee0 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Mon, 3 Aug 2020 15:21:58 -0700 Subject: [PATCH 028/145] Simplify pointer computation in mark_maybe_object * src/alloc.c (mark_maybe_object): Use simpler way to avoid -fsanitize=undefined false alarms, by converting the word tag to intptr_t first. Omit now-unnecessary runtime overflow check. (mark_memory): Work even if UINTPTR_MAX <= INT_MAX (!). --- src/alloc.c | 24 +++++++----------------- 1 file changed, 7 insertions(+), 17 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index 5220ef84783..3a02ef3f8c4 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -4625,7 +4625,7 @@ mark_maybe_object (Lisp_Object obj) #endif int type_tag = XTYPE (obj); - intptr_t offset; + intptr_t pointer_word_tag = LISP_WORD_TAG (type_tag), offset, ipo; switch (type_tag) { @@ -4641,19 +4641,8 @@ mark_maybe_object (Lisp_Object obj) break; } - bool overflow - = INT_SUBTRACT_WRAPV (offset, LISP_WORD_TAG (type_tag), &offset); -#if !defined WIDE_EMACS_INT || USE_LSB_TAG - /* If we don't use wide integers, then `intptr_t' should always be - large enough to not overflow. Furthermore, when using the least - significant bits as tag bits, the tag is small enough to not - overflow either. */ - eassert (!overflow); -#else - (void) overflow; -#endif - INT_ADD_WRAPV (offset, (intptr_t) (char *) XLP (obj), &offset); - void *po = (char *) offset; + INT_ADD_WRAPV ((intptr_t) XLP (obj), offset - pointer_word_tag, &ipo); + void *po = (void *) ipo; /* If the pointer is in the dump image and the dump has a record of the object starting at the place where the pointer points, we @@ -4856,7 +4845,7 @@ mark_memory (void const *start, void const *end) for (pp = start; (void const *) pp < end; pp += GC_POINTER_ALIGNMENT) { - char *p = *(char *const *) pp; + void *p = *(void *const *) pp; mark_maybe_pointer (p); /* Unmask any struct Lisp_Symbol pointer that make_lisp_symbol @@ -4864,8 +4853,9 @@ mark_memory (void const *start, void const *end) On a host with 32-bit pointers and 64-bit Lisp_Objects, a Lisp_Object might be split into registers saved into non-adjacent words and P might be the low-order word's value. */ - p = (char *) ((uintptr_t) p + (uintptr_t) lispsym); - mark_maybe_pointer (p); + intptr_t ip; + INT_ADD_WRAPV ((intptr_t) p, (intptr_t) lispsym, &ip); + mark_maybe_pointer ((void *) ip); verify (alignof (Lisp_Object) % GC_POINTER_ALIGNMENT == 0); if (alignof (Lisp_Object) == GC_POINTER_ALIGNMENT From a1436544ff826b8c51242f4afb7c5d485c8e2e32 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Mon, 3 Aug 2020 15:21:59 -0700 Subject: [PATCH 029/145] Simplify use of __lsan_ignore_object MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * configure.ac: Use AC_CHECK_FUNCS_ONCE for __lsan_ignore_object. * src/buffer.c, src/data.c, src/emacs-module.c, src/regex-emacs.c: * src/search.c: Use __lsan_ignore_object unconditionally, and don’t include sanitizer/lsan_interface.h. * src/lisp.h (__lsan_ignore_object): Provide a dummy in the typical case where leak sanitization is not available. --- configure.ac | 6 ++++-- src/buffer.c | 6 ------ src/data.c | 6 ------ src/emacs-module.c | 8 -------- src/lisp.h | 11 +++++++++++ src/regex-emacs.c | 6 ------ src/search.c | 6 ------ 7 files changed, 15 insertions(+), 34 deletions(-) diff --git a/configure.ac b/configure.ac index 93463e344ab..4ee4517e11c 100644 --- a/configure.ac +++ b/configure.ac @@ -4512,11 +4512,13 @@ AC_CHECK_HEADERS(valgrind/valgrind.h) AC_CHECK_MEMBERS([struct unipair.unicode], [], [], [[#include ]]) -AC_CHECK_FUNCS_ONCE([sbrk]) +AC_CHECK_FUNCS_ONCE([__lsan_ignore_object sbrk]) AC_FUNC_FORK -AC_CHECK_FUNCS(snprintf __lsan_ignore_object) +dnl AC_CHECK_FUNCS_ONCE wouldn’t be right for snprintf, which needs +dnl the current CFLAGS etc. +AC_CHECK_FUNCS(snprintf) dnl Check for glib. This differs from other library checks in that dnl Emacs need not link to glib unless some other library is already diff --git a/src/buffer.c b/src/buffer.c index e441499aeb0..241f2d43a93 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -28,10 +28,6 @@ along with GNU Emacs. If not, see . */ #include #include -#ifdef HAVE_SANITIZER_LSAN_INTERFACE_H -#include -#endif - #include #include "lisp.h" @@ -5087,9 +5083,7 @@ enlarge_buffer_text (struct buffer *b, ptrdiff_t delta) #else p = xrealloc (b->text->beg, new_nbytes); #endif -#ifdef HAVE___LSAN_IGNORE_OBJECT __lsan_ignore_object (p); -#endif if (p == NULL) { diff --git a/src/data.c b/src/data.c index 5fff52d24c2..59d148166fe 100644 --- a/src/data.c +++ b/src/data.c @@ -23,10 +23,6 @@ along with GNU Emacs. If not, see . */ #include #include -#ifdef HAVE_SANITIZER_LSAN_INTERFACE_H -#include -#endif - #include #include #include @@ -1788,9 +1784,7 @@ make_blv (struct Lisp_Symbol *sym, bool forwarded, set_blv_defcell (blv, tem); set_blv_valcell (blv, tem); set_blv_found (blv, false); -#ifdef HAVE___LSAN_IGNORE_OBJECT __lsan_ignore_object (blv); -#endif return blv; } diff --git a/src/emacs-module.c b/src/emacs-module.c index f57101946b3..a0bab118019 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -84,10 +84,6 @@ To add a new module function, proceed as follows: #include #include -#ifdef HAVE_SANITIZER_LSAN_INTERFACE_H -#include -#endif - #include "lisp.h" #include "bignum.h" #include "dynlib.h" @@ -1103,9 +1099,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, if (module_assertions) { rt = xmalloc (sizeof *rt); -#ifdef HAVE___LSAN_IGNORE_OBJECT __lsan_ignore_object (rt); -#endif } else rt = &rt_pub; @@ -1426,9 +1420,7 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) if (module_assertions) { env = xmalloc (sizeof *env); -#ifdef HAVE___LSAN_IGNORE_OBJECT __lsan_ignore_object (env); -#endif } priv->pending_non_local_exit = emacs_funcall_exit_return; diff --git a/src/lisp.h b/src/lisp.h index fdf69ab7368..22ddf3e5faf 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4789,6 +4789,17 @@ lispstpcpy (char *dest, Lisp_Object string) return dest + len; } +#if (defined HAVE___LSAN_IGNORE_OBJECT \ + && defined HAVE_SANITIZER_LSAN_INTERFACE_H) +# include +#else +/* Treat *P as a non-leak. */ +INLINE void +__lsan_ignore_object (void const *p) +{ +} +#endif + extern void xputenv (const char *); extern char *egetenv_internal (const char *, ptrdiff_t); diff --git a/src/regex-emacs.c b/src/regex-emacs.c index 1ecbc74b96c..c44cce9f787 100644 --- a/src/regex-emacs.c +++ b/src/regex-emacs.c @@ -29,10 +29,6 @@ #include -#ifdef HAVE_SANITIZER_LSAN_INTERFACE_H -#include -#endif - #include "character.h" #include "buffer.h" #include "syntax.h" @@ -1761,9 +1757,7 @@ regex_compile (re_char *pattern, ptrdiff_t size, /* Initialize the compile stack. */ compile_stack.stack = xmalloc (INIT_COMPILE_STACK_SIZE * sizeof *compile_stack.stack); -#ifdef HAVE___LSAN_IGNORE_OBJECT __lsan_ignore_object (compile_stack.stack); -#endif compile_stack.size = INIT_COMPILE_STACK_SIZE; compile_stack.avail = 0; diff --git a/src/search.c b/src/search.c index 7b74ff91480..38c64caf7c0 100644 --- a/src/search.c +++ b/src/search.c @@ -21,10 +21,6 @@ along with GNU Emacs. If not, see . */ #include -#ifdef HAVE_SANITIZER_LSAN_INTERFACE_H -#include -#endif - #include "lisp.h" #include "character.h" #include "buffer.h" @@ -619,9 +615,7 @@ newline_cache_on_off (struct buffer *buf) if (base_buf->newline_cache == 0) { base_buf->newline_cache = new_region_cache (); -#ifdef HAVE___LSAN_IGNORE_OBJECT __lsan_ignore_object (base_buf->newline_cache); -#endif } } return base_buf->newline_cache; From fd50b3fc45d35549b842a3ac4889b10f7fcf574c Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Mon, 3 Aug 2020 15:21:59 -0700 Subject: [PATCH 030/145] Ignore another memory leak * src/pdumper.c (dump_mmap_contiguous_heap): Ignore the heap control block when checking for leaks. --- src/pdumper.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index 865ceff6fff..63ee0fcb7f6 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -4680,15 +4680,15 @@ dump_mmap_contiguous_heap (struct dump_memory_map *maps, int nr_maps, Beware: the simple patch 2019-03-11T15:20:54Z!eggert@cs.ucla.edu is worse, as it sometimes frees this storage twice. */ struct dump_memory_map_heap_control_block *cb = calloc (1, sizeof (*cb)); - - char *mem; if (!cb) goto out; + __lsan_ignore_object (cb); + cb->refcount = 1; cb->mem = malloc (total_size); if (!cb->mem) goto out; - mem = cb->mem; + char *mem = cb->mem; for (int i = 0; i < nr_maps; ++i) { struct dump_memory_map *map = &maps[i]; From 19e76f6190c5c7b939bb15c8ab1137c5db2871c0 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Mon, 3 Aug 2020 15:21:59 -0700 Subject: [PATCH 031/145] Use void * for pointers in with_echo_area_buffer * src/xdisp.c (with_echo_area_buffer): Pass void * instead of ptrdiff_t, since the values are typically pointers and this ports better to (mostly-theoretical) hosts where ptrdiff_t is narrower than intptr_t. All uses changed. --- src/xdisp.c | 45 +++++++++++++++++++++------------------------ 1 file changed, 21 insertions(+), 24 deletions(-) diff --git a/src/xdisp.c b/src/xdisp.c index 9f07361d48b..4fe1c4288af 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -993,12 +993,12 @@ static void handle_line_prefix (struct it *); static void handle_stop_backwards (struct it *, ptrdiff_t); static void unwind_with_echo_area_buffer (Lisp_Object); static Lisp_Object with_echo_area_buffer_unwind_data (struct window *); -static bool current_message_1 (ptrdiff_t, Lisp_Object); -static bool truncate_message_1 (ptrdiff_t, Lisp_Object); +static bool current_message_1 (void *, Lisp_Object); +static bool truncate_message_1 (void *, Lisp_Object); static void set_message (Lisp_Object); -static bool set_message_1 (ptrdiff_t, Lisp_Object); -static bool display_echo_area_1 (ptrdiff_t, Lisp_Object); -static bool resize_mini_window_1 (ptrdiff_t, Lisp_Object); +static bool set_message_1 (void *, Lisp_Object); +static bool display_echo_area_1 (void *, Lisp_Object); +static bool resize_mini_window_1 (void *, Lisp_Object); static void unwind_redisplay (void); static void extend_face_to_end_of_line (struct it *); static intmax_t message_log_check_duplicate (ptrdiff_t, ptrdiff_t); @@ -11278,8 +11278,8 @@ ensure_echo_area_buffers (void) static bool with_echo_area_buffer (struct window *w, int which, - bool (*fn) (ptrdiff_t, Lisp_Object), - ptrdiff_t a1, Lisp_Object a2) + bool (*fn) (void *, Lisp_Object), + void *a1, Lisp_Object a2) { Lisp_Object buffer; bool this_one, the_other, clear_buffer_p, rc; @@ -11550,8 +11550,7 @@ display_echo_area (struct window *w) window_height_changed_p = with_echo_area_buffer (w, display_last_displayed_message_p, - display_echo_area_1, - (intptr_t) w, Qnil); + display_echo_area_1, w, Qnil); if (no_message_p) echo_area_buffer[i] = Qnil; @@ -11568,10 +11567,9 @@ display_echo_area (struct window *w) Value is true if height of W was changed. */ static bool -display_echo_area_1 (ptrdiff_t a1, Lisp_Object a2) +display_echo_area_1 (void *a1, Lisp_Object a2) { - intptr_t i1 = a1; - struct window *w = (struct window *) i1; + struct window *w = a1; Lisp_Object window; struct text_pos start; @@ -11612,7 +11610,7 @@ resize_echo_area_exactly (void) struct window *w = XWINDOW (echo_area_window); Lisp_Object resize_exactly = (minibuf_level == 0 ? Qt : Qnil); bool resized_p = with_echo_area_buffer (w, 0, resize_mini_window_1, - (intptr_t) w, resize_exactly); + w, resize_exactly); if (resized_p) { windows_or_buffers_changed = 42; @@ -11630,10 +11628,9 @@ resize_echo_area_exactly (void) returns. */ static bool -resize_mini_window_1 (ptrdiff_t a1, Lisp_Object exactly) +resize_mini_window_1 (void *a1, Lisp_Object exactly) { - intptr_t i1 = a1; - return resize_mini_window ((struct window *) i1, !NILP (exactly)); + return resize_mini_window (a1, !NILP (exactly)); } @@ -11769,8 +11766,7 @@ current_message (void) msg = Qnil; else { - with_echo_area_buffer (0, 0, current_message_1, - (intptr_t) &msg, Qnil); + with_echo_area_buffer (0, 0, current_message_1, &msg, Qnil); if (NILP (msg)) echo_area_buffer[0] = Qnil; } @@ -11780,10 +11776,9 @@ current_message (void) static bool -current_message_1 (ptrdiff_t a1, Lisp_Object a2) +current_message_1 (void *a1, Lisp_Object a2) { - intptr_t i1 = a1; - Lisp_Object *msg = (Lisp_Object *) i1; + Lisp_Object *msg = a1; if (Z > BEG) *msg = make_buffer_string (BEG, Z, true); @@ -11857,7 +11852,8 @@ truncate_echo_area (ptrdiff_t nchars) just an informative message; if the frame hasn't really been initialized yet, just toss it. */ if (sf->glyphs_initialized_p) - with_echo_area_buffer (0, 0, truncate_message_1, nchars, Qnil); + with_echo_area_buffer (0, 0, truncate_message_1, + (void *) (intptr_t) nchars, Qnil); } } @@ -11866,8 +11862,9 @@ truncate_echo_area (ptrdiff_t nchars) message to at most NCHARS characters. */ static bool -truncate_message_1 (ptrdiff_t nchars, Lisp_Object a2) +truncate_message_1 (void *a1, Lisp_Object a2) { + intptr_t nchars = (intptr_t) a1; if (BEG + nchars < Z) del_range (BEG + nchars, Z); if (Z == BEG) @@ -11919,7 +11916,7 @@ set_message (Lisp_Object string) This function is called with the echo area buffer being current. */ static bool -set_message_1 (ptrdiff_t a1, Lisp_Object string) +set_message_1 (void *a1, Lisp_Object string) { eassert (STRINGP (string)); From b8b25400d544b2178ddc51de05a681ed11d581d6 Mon Sep 17 00:00:00 2001 From: Theodor Thornhill Date: Tue, 4 Aug 2020 12:12:46 +0200 Subject: [PATCH 032/145] Add sass @use rule to css-mode * lisp/textmodes/css-mode.el (scss-at-ids): Add 'use' to scss-at-ids for autocompletion (bug#42700). --- lisp/textmodes/css-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 2cd99787e8a..cc5879880c8 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -67,7 +67,7 @@ (defconst scss-at-ids '("at-root" "content" "debug" "each" "else" "else if" "error" "extend" - "for" "function" "if" "import" "include" "mixin" "return" "warn" + "for" "function" "if" "import" "include" "mixin" "return" "use" "warn" "while") "Additional identifiers that appear in the form @foo in SCSS.") From 83b1db043b44a8efb091ced873eab686e671c5ac Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 4 Aug 2020 14:19:51 +0200 Subject: [PATCH 033/145] Add Tramp support of direct asynchronous process invocation * doc/misc/tramp.texi (Predefined connection information): Add "direct-async-process". (Remote processes): New subsection "Improving performance of asynchronous remote processes". * lisp/net/tramp-adb.el (tramp-methods) : Add `tramp-login-program' and `tramp-login-args'. (tramp-adb-handle-make-process): Use `tramp-handle-make-process'. (tramp-adb-maybe-open-connection): Add "set +o vi +o emacs" command. * lisp/net/tramp-sh.el (tramp-sh-handle-make-process): Use `tramp-handle-make-process'. (tramp-sh-file-name-handler-p, tramp-multi-hop-p): New defuns. (tramp-compute-multi-hops): Use `tramp-multi-hop-p'. * lisp/net/tramp.el (tramp-dissect-file-name, tramp-dissect-hop-name): Use `tramp-multi-hop-p'. (tramp-handle-insert-file-contents, tramp-local-host-p): Use `tramp-sh-file-name-handler-p'. (tramp-handle-make-process): New defun. * test/README: Add another example how to use SELECTOR. * test/lisp/net/tramp-tests.el (tramp-test03-file-name-method-rules): Adapt test. (tramp--test-sh-p): Use `tramp-sh-file-name-handler-p'. --- doc/misc/tramp.texi | 83 ++++++- lisp/net/tramp-adb.el | 315 ++++++++++++------------ lisp/net/tramp-sh.el | 456 ++++++++++++++++++----------------- lisp/net/tramp.el | 165 ++++++++++++- test/README | 5 + test/lisp/net/tramp-tests.el | 18 +- 6 files changed, 644 insertions(+), 398 deletions(-) diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index b4195111d4a..91b1e996f45 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -2053,6 +2053,13 @@ The temporary directory on the remote host. If not specified, the default value is @t{"/data/local/tmp"} for the @option{adb} method, @t{"/C$/Temp"} for the @option{smb} method, and @t{"/tmp"} otherwise. +@item @t{"direct-async-process"} + +When this property is non-@code{nil}, an alternative, more performant +implementation of @code{make-process} and +@code{start-file-process} is applied. @ref{Improving performance of +asynchronous remote processes} for a discussion of constraints. + @item @t{"posix"} Connections using the @option{smb} method check, whether the remote @@ -2458,10 +2465,9 @@ overwrite as follows: @lisp @group -(add-to-list - 'tramp-connection-properties - `(,(regexp-quote "192.168.0.1") - "remote-copy-args" (("-l") ("%r")))) +(add-to-list 'tramp-connection-properties + `(,(regexp-quote "192.168.0.1") + "remote-copy-args" (("-l") ("%r")))) @end group @end lisp @@ -3527,6 +3533,70 @@ To open @command{powershell} as a remote shell, use this: @end lisp +@anchor{Improving performance of asynchronous remote processes} +@subsection Improving performance of asynchronous remote processes +@cindex Asynchronous remote processes +@findex make-process +@findex start-file-process + +@value{tramp}'s implementation of @code{make-process} and +@code{start-file-process} requires a serious overhead for +initialization, every process invocation. This is needed for handling +interactive dialogues when connecting the remote host (like providing +a password), and initial environment setup. + +Sometimes, this is not needed. Instead of starting a remote shell and +running the command afterwards, it is sufficient to run the command +directly. @value{tramp} supports this by an alternative +implementation of @code{make-process} and @code{start-file-process}. +This is triggered by the connection property +@t{"direct-async-process"}, @xref{Predefined connection information}, +which must be set to a non-@code{nil} value. Example: + +@lisp +@group +(add-to-list 'tramp-connection-properties + (list (regexp-quote "@trampfn{ssh,user@@host,}") + "direct-async-process" t)) +@end group +@end lisp + +However, this approach has different limitations: + +@itemize +@item +It works only for connection methods defined in @file{tramp-sh.el} and +@file{tramp-adb.el}. + +@item +It does not support multi-hop methods. + +@item +It does not support interactive user authentication, like password +handling. + +@item +It does not support a separated error stream. + +@item +It cannot be killed via @code{interrupt-process}. + +@item +It does not report the remote terminal name via @code{process-tty-name}. + +@item +It does not use @code{tramp-remote-path} and +@code{tramp-remote-process-environment}. + +@item +It does not set environment variable @env{INSIDE_EMACS}. +@end itemize + +In order to gain even more performance, it is recommended to bind +@code{tramp-verbose} to 0 when running @code{make-process} or +@code{start-file-process}. + + @node Cleanup remote connections @section Cleanup remote connections @cindex cleanup @@ -4555,9 +4625,8 @@ Abbreviation list expansion can be used to reduce typing long file names: @lisp @group -(add-to-list - 'directory-abbrev-alist - '("^/xy" . "@trampfn{ssh,news@@news.my.domain,/opt/news/etc/}")) +(add-to-list 'directory-abbrev-alist + '("^/xy" . "@trampfn{ssh,news@@news.my.domain,/opt/news/etc/}")) @end group @end lisp diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 7e5af6910bb..88f5c2928e3 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -96,8 +96,10 @@ It is used for TCP/IP devices." (tramp--with-startup (add-to-list 'tramp-methods `(,tramp-adb-method - (tramp-tmpdir "/data/local/tmp") - (tramp-default-port 5555))) + (tramp-login-program ,tramp-adb-program) + (tramp-login-args (("shell"))) + (tramp-tmpdir "/data/local/tmp") + (tramp-default-port 5555))) (add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil "")) @@ -885,158 +887,163 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; The complete STDERR buffer is available only when the process has ;; terminated. (defun tramp-adb-handle-make-process (&rest args) - "Like `make-process' for Tramp files." - (when args - (with-parsed-tramp-file-name (expand-file-name default-directory) nil - (let ((name (plist-get args :name)) - (buffer (plist-get args :buffer)) - (command (plist-get args :command)) - (coding (plist-get args :coding)) - (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) - (filter (plist-get args :filter)) - (sentinel (plist-get args :sentinel)) - (stderr (plist-get args :stderr))) - (unless (stringp name) - (signal 'wrong-type-argument (list #'stringp name))) - (unless (or (null buffer) (bufferp buffer) (stringp buffer)) - (signal 'wrong-type-argument (list #'stringp buffer))) - (unless (consp command) - (signal 'wrong-type-argument (list #'consp command))) - (unless (or (null coding) - (and (symbolp coding) (memq coding coding-system-list)) - (and (consp coding) - (memq (car coding) coding-system-list) - (memq (cdr coding) coding-system-list))) - (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) - (signal 'wrong-type-argument (list #'symbolp connection-type))) - (unless (or (null filter) (functionp filter)) - (signal 'wrong-type-argument (list #'functionp filter))) - (unless (or (null sentinel) (functionp sentinel)) - (signal 'wrong-type-argument (list #'functionp sentinel))) - (unless (or (null stderr) (bufferp stderr) (stringp stderr)) - (signal 'wrong-type-argument (list #'stringp stderr))) - (when (and (stringp stderr) (tramp-tramp-file-p stderr) - (not (tramp-equal-remote default-directory stderr))) - (signal 'file-error (list "Wrong stderr" stderr))) + "Like `make-process' for Tramp files. +If connection property \"direct-async-process\" is non-nil, an +alternative implementation will be used." + (if (tramp-get-connection-property + (tramp-dissect-file-name default-directory) "direct-async-process" nil) + (apply #'tramp-handle-make-process args) + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) - (let* ((buffer - (if buffer - (get-buffer-create buffer) - ;; BUFFER can be nil. We use a temporary buffer. - (generate-new-buffer tramp-temp-buffer-name))) - ;; STDERR can also be a file name. - (tmpstderr - (and stderr - (if (and (stringp stderr) (tramp-tramp-file-p stderr)) - (tramp-unquote-file-local-name stderr) - (tramp-make-tramp-temp-file v)))) - (remote-tmpstderr - (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) - (program (car command)) - (args (cdr command)) - (command - (format "cd %s && exec %s %s" - (tramp-shell-quote-argument localname) - (if tmpstderr (format "2>'%s'" tmpstderr) "") - (mapconcat #'tramp-shell-quote-argument - (cons program args) " "))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) - (name1 name) - (i 0)) + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (program (car command)) + (args (cdr command)) + (command + (format "cd %s && exec %s %s" + (tramp-shell-quote-argument localname) + (if tmpstderr (format "2>'%s'" tmpstderr) "") + (mapconcat #'tramp-shell-quote-argument + (cons program args) " "))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0)) - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `make-process' - ;; could be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (inhibit-read-only t)) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-adb-maybe-open-connection', in - ;; order to cleanup the prompt afterwards. - (tramp-adb-maybe-open-connection v) - (delete-region (point-min) (point-max)) - ;; Send the command. - (let* ((p (tramp-get-connection-process v))) - (tramp-adb-send-command v command nil t) ; nooutput - ;; Set sentinel and filter. - (when sentinel - (set-process-sentinel p sentinel)) - (when filter - (set-process-filter p filter)) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the - ;; process could have finished already. - (ignore-errors - (set-process-query-on-exit-flag p (null noquery)) - (set-marker (process-mark p) (point))) - ;; We must flush them here already; otherwise - ;; `rename-file', `delete-file' or - ;; `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - ;; Copy tmpstderr file. - (when (and (stringp stderr) - (not (tramp-tramp-file-p stderr))) - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (rename-file remote-tmpstderr stderr)))) - ;; Read initial output. Remove the first line, - ;; which is the command echo. - (while - (progn - (goto-char (point-min)) - (not (re-search-forward "[\n]" nil t))) - (tramp-accept-process-output p 0)) - (delete-region (point-min) (point)) - ;; Provide error buffer. This shows only - ;; initial error messages; messages arriving - ;; later on will be inserted when the process - ;; is deleted. The temporary file will exist - ;; until the process is deleted. - (when (bufferp stderr) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr 'visit)) - ;; Delete tmpstderr file. - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr 'visit nil nil 'replace)) - (delete-file remote-tmpstderr)))) - ;; Return process. - p)))) + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' + ;; could be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification time; + ;; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t)) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max)) + ;; We call `tramp-adb-maybe-open-connection', + ;; in order to cleanup the prompt afterwards. + (tramp-adb-maybe-open-connection v) + (delete-region (point-min) (point-max)) + ;; Send the command. + (let* ((p (tramp-get-connection-process v))) + (tramp-adb-send-command v command nil t) ; nooutput + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for + ;; this process. We ignore errors, because + ;; the process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; We must flush them here already; + ;; otherwise `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) + ;; Read initial output. Remove the first + ;; line, which is the command echo. + (while + (progn + (goto-char (point-min)) + (not (re-search-forward "[\n]" nil t))) + (tramp-accept-process-output p 0)) + (delete-region (point-min) (point)) + ;; Provide error buffer. This shows only + ;; initial error messages; messages arriving + ;; later on will be inserted when the + ;; process is deleted. The temporary file + ;; will exist until the process is deleted. + (when (bufferp stderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit nil nil 'replace)) + (delete-file remote-tmpstderr)))) + ;; Return process. + p)))) - ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer (tramp-get-connection-process v) nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer")))))))) + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer (tramp-get-connection-process v) nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))))))) (defun tramp-adb-handle-exec-path () "Like `exec-path' for Tramp files." @@ -1253,6 +1260,14 @@ connection if a previous connection has died for some reason." (tramp-adb-send-command vec (format "PS1=\"///\"\"%s\"\"#$\"" prompt)) + ;; Disable line editing. + (tramp-adb-send-command + vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs") + + ;; Dump option settings in the traces. + (when (>= tramp-verbose 9) + (tramp-adb-send-command vec "set -o")) + ;; Check whether the properties have been changed. If ;; yes, this is a strong indication that we must expire all ;; connection properties. We start again. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index f9f0cbcc023..3e2eb023a33 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2787,228 +2787,233 @@ the result will be a local, non-Tramp, file name." ;; terminated. (defun tramp-sh-handle-make-process (&rest args) "Like `make-process' for Tramp files. -STDERR can also be a file name." - (when args - (with-parsed-tramp-file-name (expand-file-name default-directory) nil - (let ((name (plist-get args :name)) - (buffer (plist-get args :buffer)) - (command (plist-get args :command)) - (coding (plist-get args :coding)) - (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) - (filter (plist-get args :filter)) - (sentinel (plist-get args :sentinel)) - (stderr (plist-get args :stderr))) - (unless (stringp name) - (signal 'wrong-type-argument (list #'stringp name))) - (unless (or (null buffer) (bufferp buffer) (stringp buffer)) - (signal 'wrong-type-argument (list #'stringp buffer))) - (unless (consp command) - (signal 'wrong-type-argument (list #'consp command))) - (unless (or (null coding) - (and (symbolp coding) (memq coding coding-system-list)) - (and (consp coding) - (memq (car coding) coding-system-list) - (memq (cdr coding) coding-system-list))) - (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) - (signal 'wrong-type-argument (list #'symbolp connection-type))) - (unless (or (null filter) (functionp filter)) - (signal 'wrong-type-argument (list #'functionp filter))) - (unless (or (null sentinel) (functionp sentinel)) - (signal 'wrong-type-argument (list #'functionp sentinel))) - (unless (or (null stderr) (bufferp stderr) (stringp stderr)) - (signal 'wrong-type-argument (list #'stringp stderr))) - (when (and (stringp stderr) (tramp-tramp-file-p stderr) - (not (tramp-equal-remote default-directory stderr))) - (signal 'file-error (list "Wrong stderr" stderr))) +STDERR can also be a file name. If connection property +\"direct-async-process\" is non-nil, an alternative +implementation will be used." + (if (tramp-get-connection-property + (tramp-dissect-file-name default-directory) "direct-async-process" nil) + (apply #'tramp-handle-make-process args) + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) - (let* ((buffer - (if buffer - (get-buffer-create buffer) - ;; BUFFER can be nil. We use a temporary buffer. - (generate-new-buffer tramp-temp-buffer-name))) - ;; STDERR can also be a file name. - (tmpstderr - (and stderr - (if (and (stringp stderr) (tramp-tramp-file-p stderr)) - (tramp-unquote-file-local-name stderr) - (tramp-make-tramp-temp-file v)))) - (remote-tmpstderr - (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) - (program (car command)) - (args (cdr command)) - ;; When PROGRAM matches "*sh", and the first arg is - ;; "-c", it might be that the arguments exceed the - ;; command line length. Therefore, we modify the - ;; command. - (heredoc (and (stringp program) - (string-match-p "sh$" program) - (string-equal "-c" (car args)) - (= (length args) 2))) - ;; When PROGRAM is nil, we just provide a tty. - (args (if (not heredoc) args - (let ((i 250)) - (while (and (< i (length (cadr args))) - (string-match " " (cadr args) i)) - (setcdr - args - (list - (replace-match " \\\\\n" nil nil (cadr args)))) - (setq i (+ i 250)))) - (cdr args))) - ;; Use a human-friendly prompt, for example for - ;; `shell'. We discard hops, if existing, that's why - ;; we cannot use `file-remote-p'. - (prompt (format "PS1=%s %s" - (tramp-make-tramp-file-name v nil 'nohop) - tramp-initial-end-of-output)) - ;; We use as environment the difference to toplevel - ;; `process-environment'. - env uenv - (env (dolist (elt (cons prompt process-environment) env) - (or (member - elt (default-toplevel-value 'process-environment)) - (if (string-match-p "=" elt) - (setq env (append env `(,elt))) - (if (tramp-get-env-with-u-option v) - (setq env (append `("-u" ,elt) env)) - (setq uenv (cons elt uenv))))))) - (command - (when (stringp program) - (setenv-internal - env "INSIDE_EMACS" - (concat (or (getenv "INSIDE_EMACS") emacs-version) - ",tramp:" tramp-version) - 'keep) - (format "cd %s && %s exec %s %s env %s %s" - (tramp-shell-quote-argument localname) - (if uenv - (format - "unset %s &&" - (mapconcat - #'tramp-shell-quote-argument uenv " ")) - "") - (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "") - (if tmpstderr (format "2>'%s'" tmpstderr) "") - (mapconcat #'tramp-shell-quote-argument env " ") - (if heredoc - (format "%s\n(\n%s\n) '%s'" tmpstderr) "") + (mapconcat #'tramp-shell-quote-argument env " ") + (if heredoc + (format "%s\n(\n%s\n) " name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `make-process' could - ;; be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (inhibit-read-only t) - (mark (point-max))) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-maybe-open-connection', in - ;; order to cleanup the prompt afterwards. - (catch 'suppress - (tramp-maybe-open-connection v) - (setq p (tramp-get-connection-process v)) - ;; Set the pid of the remote shell. This is - ;; needed when sending signals remotely. - (let ((pid (tramp-send-command-and-read v "echo $$"))) - (process-put p 'remote-pid pid) - (tramp-set-connection-property p "remote-pid" pid)) - ;; `tramp-maybe-open-connection' and - ;; `tramp-send-command-and-read' could have - ;; trashed the connection buffer. Remove this. - (widen) - (delete-region mark (point-max)) + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' + ;; could be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification time; + ;; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t) + (mark (point-max))) + (clear-visited-file-modtime) (narrow-to-region (point-max) (point-max)) - ;; Now do it. - (if command - ;; Send the command. - (tramp-send-command v command nil t) ; nooutput - ;; Check, whether a pty is associated. - (unless (process-get p 'remote-tty) - (tramp-error - v 'file-error - "pty association is not supported for `%s'" - name)))) - ;; Set sentinel and filter. - (when sentinel - (set-process-sentinel p sentinel)) - (when filter - (set-process-filter p filter)) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the - ;; process could have finished already. - (ignore-errors - (set-process-query-on-exit-flag p (null noquery)) - (set-marker (process-mark p) (point))) - ;; We must flush them here already; otherwise - ;; `rename-file', `delete-file' or - ;; `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - ;; Copy tmpstderr file. - (when (and (stringp stderr) - (not (tramp-tramp-file-p stderr))) - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (rename-file remote-tmpstderr stderr)))) - ;; Provide error buffer. This shows only - ;; initial error messages; messages arriving - ;; later on will be inserted when the process is - ;; deleted. The temporary file will exist until - ;; the process is deleted. - (when (bufferp stderr) - (with-current-buffer stderr - (insert-file-contents-literally remote-tmpstderr)) - ;; Delete tmpstderr file. - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (when (file-exists-p remote-tmpstderr) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr nil nil nil 'replace)) - (delete-file remote-tmpstderr))))) - ;; Return process. - p))) + ;; We call `tramp-maybe-open-connection', in + ;; order to cleanup the prompt afterwards. + (catch 'suppress + (tramp-maybe-open-connection v) + (setq p (tramp-get-connection-process v)) + ;; Set the pid of the remote shell. This is + ;; needed when sending signals remotely. + (let ((pid (tramp-send-command-and-read v "echo $$"))) + (process-put p 'remote-pid pid) + (tramp-set-connection-property p "remote-pid" pid)) + ;; `tramp-maybe-open-connection' and + ;; `tramp-send-command-and-read' could have + ;; trashed the connection buffer. Remove this. + (widen) + (delete-region mark (point-max)) + (narrow-to-region (point-max) (point-max)) + ;; Now do it. + (if command + ;; Send the command. + (tramp-send-command v command nil t) ; nooutput + ;; Check, whether a pty is associated. + (unless (process-get p 'remote-tty) + (tramp-error + v 'file-error + "pty association is not supported for `%s'" + name)))) + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for this + ;; process. We ignore errors, because the + ;; process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) + ;; Provide error buffer. This shows only + ;; initial error messages; messages arriving + ;; later on will be inserted when the process + ;; is deleted. The temporary file will exist + ;; until the process is deleted. + (when (bufferp stderr) + (with-current-buffer stderr + (insert-file-contents-literally remote-tmpstderr)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (when (file-exists-p remote-tmpstderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr nil nil nil 'replace)) + (delete-file remote-tmpstderr))))) + ;; Return process. + p))) - ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer p nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer")))))))) + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))))))) (defun tramp-sh-get-signal-strings (vec) "Strings to return by `process-file' in case of signals." @@ -3646,6 +3651,14 @@ Fall back to normal file name handler if no Tramp handler exists." (save-match-data (apply (cdr fn) args)) (tramp-run-real-handler operation args))) +;;;###tramp-autoload +(defun tramp-sh-file-name-handler-p (vec) + "Whether VEC uses a method from `tramp-sh-file-name-handler'." + (and (assoc (tramp-file-name-method vec) tramp-methods) + (eq (tramp-find-foreign-file-name-handler + (tramp-make-tramp-file-name vec nil 'nohop)) + 'tramp-sh-file-name-handler))) + ;; This must be the last entry, because `identity' always matches. ;;;###tramp-autoload (tramp--with-startup @@ -4769,6 +4782,12 @@ Goes through the list `tramp-inline-compress-commands'." (tramp-message vec 2 "Couldn't find an inline transfer compress command"))))) +;;;###tramp-autoload +(defun tramp-multi-hop-p (vec) + "Whether the method of VEC is capable of multi-hops." + (and (tramp-sh-file-name-handler-p vec) + (not (tramp-get-method-parameter vec 'tramp-copy-program)))) + (defun tramp-compute-multi-hops (vec) "Expands VEC according to `tramp-default-proxies-alist'." (let ((saved-tdpa tramp-default-proxies-alist) @@ -4832,8 +4851,7 @@ Goes through the list `tramp-inline-compress-commands'." (when (cdr target-alist) (setq choices target-alist) (while (setq item (pop choices)) - (when (or (not (tramp-get-method-parameter item 'tramp-login-program)) - (tramp-get-method-parameter item 'tramp-copy-program)) + (unless (tramp-multi-hop-p item) (setq tramp-default-proxies-alist saved-tdpa) (tramp-user-error vec "Method `%s' is not supported for multi-hops." diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index c169a86f915..d1b2935a3c6 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1482,10 +1482,7 @@ default values are used." (tramp-user-error v "Method `%s' is not known." method)) ;; Only some methods from tramp-sh.el do support multi-hops. - (when (and - hop - (or (not (tramp-get-method-parameter v 'tramp-login-program)) - (tramp-get-method-parameter v 'tramp-copy-program))) + (unless (or (null hop) nodefault non-essential (tramp-multi-hop-p v)) (tramp-user-error v "Method `%s' is not supported for multi-hops." method))))))) @@ -1499,8 +1496,7 @@ See `tramp-dissect-file-name' for details." tramp-postfix-host-format name)) nodefault))) ;; Only some methods from tramp-sh.el do support multi-hops. - (when (or (not (tramp-get-method-parameter v 'tramp-login-program)) - (tramp-get-method-parameter v 'tramp-copy-program)) + (unless (or nodefault non-essential (tramp-multi-hop-p v)) (tramp-user-error v "Method `%s' is not supported for multi-hops." (tramp-file-name-method v))) @@ -3519,13 +3515,10 @@ User is always nil." ;; When we shall insert only a part of the file, we ;; copy this part. This works only for the shell file - ;; name handlers. + ;; name handlers. It doesn't work for crypted files. (when (and (or beg end) - ;; Direct actions aren't possible for - ;; crypted directories. - (null tramp-crypt-enabled) - (tramp-get-method-parameter - v 'tramp-login-program)) + (tramp-sh-file-name-handler-p v) + (null tramp-crypt-enabled)) (setq remote-copy (tramp-make-tramp-temp-file v)) ;; This is defined in tramp-sh.el. Let's assume ;; this is loaded already. @@ -3640,6 +3633,152 @@ User is always nil." (load local-copy noerror t nosuffix must-suffix) (delete-file local-copy))))) t))) +;; We use BUFFER also as connection buffer during setup. Because of +;; this, its original contents must be saved, and restored once +;; connection has been setup. +(defun tramp-handle-make-process (&rest args) + "An alternative `make-process' implementation for Tramp files." + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) + + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + (command (append `("cd" ,localname "&&") + (mapcar #'tramp-shell-quote-argument command))) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0) + ;; We do not want to raise an error when `make-process' + ;; has been started several times in `eshell' and + ;; friends. + tramp-current-connection + p) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + (let* ((login-program + (tramp-get-method-parameter v 'tramp-login-program)) + (login-args + (tramp-get-method-parameter v 'tramp-login-args)) + (async-args + (tramp-get-method-parameter v 'tramp-async-args)) + ;; We don't create the temporary file. In + ;; fact, it is just a prefix for the + ;; ControlPath option of ssh; the real + ;; temporary file has another name, and it is + ;; created and protected by ssh. It is also + ;; removed by ssh when the connection is + ;; closed. The temporary file name is cached + ;; in the main connection process, therefore + ;; we cannot use `tramp-get-connection-process'. + (tmpfile + (when (tramp-sh-file-name-handler-p v) + (with-tramp-connection-property + (tramp-get-process v) "temp-file" + (tramp-compat-make-temp-name)))) + (options + (when (tramp-sh-file-name-handler-p v) + (tramp-compat-funcall + 'tramp-ssh-controlmaster-options v))) + spec) + + ;; Replace `login-args' place holders. + (setq + spec (format-spec-make ?t tmpfile) + options (format-spec (or options "") spec) + spec (format-spec-make + ?h (or host "") ?u (or user "") ?p (or port "") + ?c options ?l "") + ;; Add arguments for asynchronous processes. + login-args (append async-args login-args) + ;; Expand format spec. + login-args + (tramp-compat-flatten-tree + (mapcar + (lambda (x) + (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (unless (member "" x) x)) + login-args)) + ;; Split ControlMaster options. + login-args + (tramp-compat-flatten-tree + (mapcar (lambda (x) (split-string x " ")) login-args)) + p (apply + #'start-process + name buffer login-program (append login-args command))) + + (tramp-message v 6 "%s" (string-join (process-command p) " ")) + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for this + ;; process. We ignore errors, because the + ;; process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Return process. + p) + + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))))) (defun tramp-handle-make-symbolic-link (target linkname &optional ok-if-already-exists) @@ -4706,7 +4845,7 @@ This handles also chrooted environments, which are not regarded as local." ;; The method shall be applied to one of the shell file name ;; handlers. `tramp-local-host-p' is also called for "smb" and ;; alike, where it must fail. - (tramp-get-method-parameter vec 'tramp-login-program) + (tramp-sh-file-name-handler-p vec) ;; Direct actions aren't possible for crypted directories. (null tramp-crypt-enabled) ;; The local temp directory must be writable for the other user. diff --git a/test/README b/test/README index 1f69f7142c1..fe05b5403b1 100644 --- a/test/README +++ b/test/README @@ -64,6 +64,11 @@ protect against "make" variable expansion): make SELECTOR='"foo$$"' +In case you want to use the symbol name of a test as selector, you can +use it directly: + + make SELECTOR='test-foo-remote' + Note that although the test files are always compiled (unless they set no-byte-compile), the source files will be run when expensive or unstable tests are involved, to give nicer backtraces. To run the diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index ac24fcf280a..05196e7e4a6 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2001,12 +2001,13 @@ is greater than 10. (skip-unless (tramp--test-enabled)) ;; Multi hops are allowed for inline methods only. - (should-error - (file-remote-p "/ssh:user1@host1|method:user2@host2:/path/to/file") - :type 'user-error) - (should-error - (file-remote-p "/method:user1@host1|ssh:user2@host2:/path/to/file") - :type 'user-error) + (let (non-essential) + (should-error + (expand-file-name "/ssh:user1@host1|method:user2@host2:/path/to/file") + :type 'user-error) + (should-error + (expand-file-name "/method:user1@host1|ssh:user2@host2:/path/to/file") + :type 'user-error)) ;; Samba does not support file names with periods followed by ;; spaces, and trailing periods or spaces. @@ -5681,9 +5682,8 @@ This does not support special file names." (defun tramp--test-sh-p () "Check, whether the remote host runs a based method from tramp-sh.el." - (eq - (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) - 'tramp-sh-file-name-handler)) + (tramp-sh-file-name-handler-p + (tramp-dissect-file-name tramp-test-temporary-file-directory))) (defun tramp--test-sudoedit-p () "Check, whether the sudoedit method is used." From 3da0d3852923f0a20157f72aba6d8896019559f8 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 4 Aug 2020 14:20:16 +0200 Subject: [PATCH 034/145] * etc/NEWS: Add Tramp support of direct asynchronous process invocation. --- etc/NEWS | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index 7221c9cf9e6..cd5cc2c3397 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -324,6 +324,16 @@ 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 ... ". 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. + ** Tempo --- From e208d67e8401b8e08d697273e6e162b1e4620005 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 14:30:13 +0200 Subject: [PATCH 035/145] Fix wdired test for Macos * test/lisp/wdired-tests.el (wdired-test-bug34915): Macos adds "@" to the end of symlinks (bug#42537). --- test/lisp/wdired-tests.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index 5b01c54cf24..fcd8b626404 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el @@ -132,7 +132,7 @@ wdired-mode." (declare-function dired-smart-shell-command "dired-x" (command &optional output-buffer error-buffer)) -(ert-deftest wdired-test-bug34915 () +(defun wdired-test-bug34915 () "Test editing when dired-listing-switches includes -F. Appended file indicators should not count as part of the file name, either before or after editing. Since @@ -143,6 +143,7 @@ wdired-get-filename before and after editing." (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 From 934585a6498428f60d709e2ec0379f4667554c6b Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 14:31:36 +0200 Subject: [PATCH 036/145] dired-ls-F-marks-symlinks should be set under Macos * lisp/dired.el (dired-ls-F-marks-symlinks): Not that this should be set under Macos (bug#42537). --- lisp/dired.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/dired.el b/lisp/dired.el index 1792250ac90..d19d6d1581d 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -125,7 +125,7 @@ For more details, see Info node `(emacs)ls in Lisp'." "Informs Dired about how `ls -lF' marks symbolic links. Set this to t if `ls' (or whatever program is specified by `insert-directory-program') with `-lF' marks the symbolic link -itself with a trailing @ (usually the case under Ultrix). +itself with a trailing @ (usually the case under Ultrix and macOS). Example: if `ln -s foo bar; ls -F bar' gives `bar -> foo', set it to nil (the default), if it gives `bar@ -> foo', set it to t. From a3c870d7e2426bd401c2de60fa851176cf631f7c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 14:48:33 +0200 Subject: [PATCH 037/145] Fix svn tests on Macos * test/lisp/vc/vc-tests.el (vc-test--svn-enabled): Macos machines may have a dummy svn program that helpfully just outputs "There's no svn program here", so also test for the svnadmin program (bug#42536). --- test/lisp/vc/vc-tests.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 8e5cc95ec94..01d196565dd 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -554,7 +554,8 @@ This checks also `vc-backend' and `vc-responsible-backend'." (defvar vc-svn-program) (defun vc-test--svn-enabled () - (executable-find vc-svn-program)) + (and (executable-find "svnadmin") + (executable-find vc-svn-program))) (defun vc-test--sccs-enabled () (executable-find "sccs")) From 1432cfd485d33bb518ab6ac5667ae4e4faf7f6b5 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 15:15:36 +0200 Subject: [PATCH 038/145] Fix debugging code checked in from wdired-tests --- test/lisp/wdired-tests.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index fcd8b626404..2cfabd1ee2d 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el @@ -132,7 +132,7 @@ wdired-mode." (declare-function dired-smart-shell-command "dired-x" (command &optional output-buffer error-buffer)) -(defun wdired-test-bug34915 () +(ert-deftest wdired-test-bug34915 () "Test editing when dired-listing-switches includes -F. Appended file indicators should not count as part of the file name, either before or after editing. Since From ea9520a7a23dfd66de30b04d0c5ff878fecfd3d2 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 15:56:12 +0200 Subject: [PATCH 039/145] Mark the end of file names correctly on Macos in wdired * lisp/wdired.el (wdired--restore-dired-filename-prop): Fix problem with finding the end of the name on Macos. --- lisp/wdired.el | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/lisp/wdired.el b/lisp/wdired.el index 768b8f597b4..b98becfafe7 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -609,7 +609,10 @@ Optional arguments are ignored." (defun wdired--restore-dired-filename-prop (beg end _len) (save-match-data (save-excursion - (let ((lep (line-end-position))) + (let ((lep (line-end-position)) + (used-F (dired-check-switches + dired-actual-switches + "F" "classify"))) (beginning-of-line) (when (re-search-forward directory-listing-before-filename-regexp lep t) @@ -623,13 +626,17 @@ Optional arguments are ignored." (and (re-search-backward dired-permission-flags-regexp nil t) (looking-at "l") - (search-forward " -> " lep t)) + ;; macOS and Ultrix adds "@" to the end + ;; of symlinks when using -F. + (if (and used-F + dired-ls-F-marks-symlinks) + (re-search-forward "@? -> " lep t) + (search-forward " -> " lep t))) ;; When dired-listing-switches includes "F" ;; or "classify", don't treat appended ;; indicator characters as part of the file ;; name (bug#34915). - (and (dired-check-switches dired-actual-switches - "F" "classify") + (and used-F (re-search-forward "[*/@|=>]$" lep t))) (goto-char (match-beginning 0)) lep)) From 99e9bdcd4105ac70f8f7ee06f2450cdbb15dbf3b Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 17:25:36 +0200 Subject: [PATCH 040/145] Make a network-stream test more robust * test/lisp/net/network-stream-tests.el (network-test--resolve-system-name): New function. (echo-server-with-dns): Skip test if (system-name) doesn't look like it's going to resolve (bug#42535). --- test/lisp/net/network-stream-tests.el | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 7a982548ae1..f44682e1edb 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -136,7 +136,20 @@ (t )))) +(defun network-test--resolve-system-name () + (cl-loop for address in (network-lookup-address-info (system-name)) + when (or (and (= (length address) 5) + ;; IPv4 localhost addresses start with 127. + (= (elt address 0) 127)) + (and (= (length address) 9) + ;; IPv6 localhost addresses start with 0. + (= (elt address 0) 0))) + return t)) + (ert-deftest echo-server-with-dns () + (unless (network-test--resolve-system-name) + (ert-skip "Can't test resolver for (system-name)")) + (let* ((server (make-server (system-name))) (port (aref (process-contact server :local) 4)) (proc (make-network-process :name "foo" From 89dbd0838b980f6ef58fa0f614bd743f86ec1c74 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 17:34:21 +0200 Subject: [PATCH 041/145] Fix previous network stream test * test/lisp/net/network-stream-tests.el (network-test--resolve-system-name): There's only one ipv6 localhost address. --- test/lisp/net/network-stream-tests.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index f44682e1edb..cf416155e50 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -142,8 +142,8 @@ ;; IPv4 localhost addresses start with 127. (= (elt address 0) 127)) (and (= (length address) 9) - ;; IPv6 localhost addresses start with 0. - (= (elt address 0) 0))) + ;; IPv6 localhost address. + (equal address [0 0 0 0 0 0 0 1 0]))) return t)) (ert-deftest echo-server-with-dns () From 0a12d43e84eb5592c39350432c7a3e8fdaa71a06 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 18:08:47 +0200 Subject: [PATCH 042/145] Fix viewing encrypted+signed messages from Outlook * lisp/gnus/mm-decode.el (mm-possibly-verify-or-decrypt): Fix problem with CRLF-encoded encrypted+signed parts (bug#42637). --- lisp/gnus/mm-decode.el | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 587c4e01b92..7f8ab5f9ef5 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -1680,6 +1680,12 @@ If RECURSIVE, search recursively." (t (y-or-n-p (format "Decrypt (S/MIME) part? ")))) (mm-view-pkcs7 parts from)) + (goto-char (point-min)) + ;; The encrypted document is a MIME part, and may use either + ;; CRLF (Outlook and the like) or newlines for end-of-line + ;; markers. Translate from CRLF. + (while (search-forward "\r\n" nil t) + (replace-match "\n")) ;; Normally there will be a Content-type header here, but ;; some mailers don't add that to the encrypted part, which ;; makes the subsequent re-dissection fail here. From b0e828da4f55d0dddcd8f8fc2e21e4b02a12852e Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 31 Jul 2020 06:09:09 +0200 Subject: [PATCH 043/145] Add new cconv-tests (Bug#28557) These tests are all written by Gemini Lasswell . * test/lisp/emacs-lisp/cconv-tests.el (top-level): Add two commented out tests which the byte-compiler can't handle. (cconv-tests-lambda-:documentation) (cconv-tests-pcase-lambda-:documentation) (cconv-tests-defun-:documentation) (cconv-tests-cl-defun-:documentation) (cconv-tests-function-:documentation) (cconv-tests-cl-defgeneric-literal-:documentation) (cconv-tests-defsubst-:documentation) (cconv-tests-cl-defsubst-:documentation): New tests. (cconv-tests-cl-iter-defun-:documentation) (cconv-tests-iter-defun-:documentation) (cconv-tests-iter-lambda-:documentation) (cconv-tests-cl-function-:documentation) (cconv-tests-cl-defgeneric-:documentation): New failing tests. --- test/lisp/emacs-lisp/cconv-tests.el | 158 ++++++++++++++++++++++++++++ 1 file changed, 158 insertions(+) diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index c8d46541ad4..148bcd69be1 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -20,6 +20,164 @@ ;;; Commentary: (require 'ert) +(require 'cl-lib) + +(ert-deftest cconv-tests-lambda-:documentation () + "Docstring for lambda can be specified with :documentation." + (let ((fun (lambda () + (:documentation (concat "lambda" " documentation")) + 'lambda-result))) + (should (string= (documentation fun) "lambda documentation")) + (should (eq (funcall fun) 'lambda-result)))) + +(ert-deftest cconv-tests-pcase-lambda-:documentation () + "Docstring for pcase-lambda can be specified with :documentation." + (let ((fun (pcase-lambda (`(,a ,b)) + (:documentation (concat "pcase-lambda" " documentation")) + (list b a)))) + (should (string= (documentation fun) "pcase-lambda documentation")) + (should (equal '(2 1) (funcall fun '(1 2)))))) + +(defun cconv-tests-defun () + (:documentation (concat "defun" " documentation")) + 'defun-result) +(ert-deftest cconv-tests-defun-:documentation () + "Docstring for defun can be specified with :documentation." + (should (string= (documentation 'cconv-tests-defun) + "defun documentation")) + (should (eq (cconv-tests-defun) 'defun-result))) + +(cl-defun cconv-tests-cl-defun () + (:documentation (concat "cl-defun" " documentation")) + 'cl-defun-result) +(ert-deftest cconv-tests-cl-defun-:documentation () + "Docstring for cl-defun can be specified with :documentation." + (should (string= (documentation 'cconv-tests-cl-defun) + "cl-defun documentation")) + (should (eq (cconv-tests-cl-defun) 'cl-defun-result))) + +;; FIXME: The byte-complier croaks on this. See Bug#28557. +;; (defmacro cconv-tests-defmacro () +;; (:documentation (concat "defmacro" " documentation")) +;; '(quote defmacro-result)) +;; (ert-deftest cconv-tests-defmacro-:documentation () +;; "Docstring for defmacro can be specified with :documentation." +;; (should (string= (documentation 'cconv-tests-defmacro) +;; "defmacro documentation")) +;; (should (eq (cconv-tests-defmacro) 'defmacro-result))) + +;; FIXME: The byte-complier croaks on this. See Bug#28557. +;; (cl-defmacro cconv-tests-cl-defmacro () +;; (:documentation (concat "cl-defmacro" " documentation")) +;; '(quote cl-defmacro-result)) +;; (ert-deftest cconv-tests-cl-defmacro-:documentation () +;; "Docstring for cl-defmacro can be specified with :documentation." +;; (should (string= (documentation 'cconv-tests-cl-defmacro) +;; "cl-defmacro documentation")) +;; (should (eq (cconv-tests-cl-defmacro) 'cl-defmacro-result))) + +(cl-iter-defun cconv-tests-cl-iter-defun () + (:documentation (concat "cl-iter-defun" " documentation")) + (iter-yield 'cl-iter-defun-result)) +(ert-deftest cconv-tests-cl-iter-defun-:documentation () + "Docstring for cl-iter-defun can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (should (string= (documentation 'cconv-tests-cl-iter-defun) + "cl-iter-defun documentation")) + (should (eq (iter-next (cconv-tests-cl-iter-defun)) + 'cl-iter-defun-result))) + +(iter-defun cconv-tests-iter-defun () + (:documentation (concat "iter-defun" " documentation")) + (iter-yield 'iter-defun-result)) +(ert-deftest cconv-tests-iter-defun-:documentation () + "Docstring for iter-defun can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (should (string= (documentation 'cconv-tests-iter-defun) + "iter-defun documentation")) + (should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result))) + +(ert-deftest cconv-tests-iter-lambda-:documentation () + "Docstring for iter-lambda can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (let ((iter-fun + (iter-lambda () + (:documentation (concat "iter-lambda" " documentation")) + (iter-yield 'iter-lambda-result)))) + (should (string= (documentation iter-fun) "iter-lambda documentation")) + (should (eq (iter-next (funcall iter-fun)) 'iter-lambda-result)))) + +(ert-deftest cconv-tests-cl-function-:documentation () + "Docstring for cl-function can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (let ((fun (cl-function (lambda (&key arg) + (:documentation (concat "cl-function" + " documentation")) + (list arg 'cl-function-result))))) + (should (string= (documentation fun) "cl-function documentation")) + (should (equal (funcall fun :arg t) '(t cl-function-result))))) + +(ert-deftest cconv-tests-function-:documentation () + "Docstring for lambda inside function can be specified with :documentation." + (let ((fun #'(lambda (arg) + (:documentation (concat "function" " documentation")) + (list arg 'function-result)))) + (should (string= (documentation fun) "function documentation")) + (should (equal (funcall fun t) '(t function-result))))) + +(fmakunbound 'cconv-tests-cl-defgeneric) +(setplist 'cconv-tests-cl-defgeneric nil) +(cl-defgeneric cconv-tests-cl-defgeneric (n) + (:documentation (concat "cl-defgeneric" " documentation"))) +(cl-defmethod cconv-tests-cl-defgeneric ((n integer)) + (:documentation (concat "cl-defmethod" " documentation")) + (+ 1 n)) +(ert-deftest cconv-tests-cl-defgeneric-:documentation () + "Docstring for cl-defgeneric can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (let ((descr (describe-function 'cconv-tests-cl-defgeneric))) + (set-text-properties 0 (length descr) nil descr) + (should (string-match-p "cl-defgeneric documentation" descr)) + (should (string-match-p "cl-defmethod documentation" descr))) + (should (= 11 (cconv-tests-cl-defgeneric 10)))) + +(fmakunbound 'cconv-tests-cl-defgeneric-literal) +(setplist 'cconv-tests-cl-defgeneric-literal nil) +(cl-defgeneric cconv-tests-cl-defgeneric-literal (n) + (:documentation "cl-defgeneric-literal documentation")) +(cl-defmethod cconv-tests-cl-defgeneric-literal ((n integer)) + (:documentation "cl-defmethod-literal documentation") + (+ 1 n)) +(ert-deftest cconv-tests-cl-defgeneric-literal-:documentation () + "Docstring for cl-defgeneric can be specified with :documentation." + (let ((descr (describe-function 'cconv-tests-cl-defgeneric-literal))) + (set-text-properties 0 (length descr) nil descr) + (should (string-match-p "cl-defgeneric-literal documentation" descr)) + (should (string-match-p "cl-defmethod-literal documentation" descr))) + (should (= 11 (cconv-tests-cl-defgeneric-literal 10)))) + +(defsubst cconv-tests-defsubst () + (:documentation (concat "defsubst" " documentation")) + 'defsubst-result) +(ert-deftest cconv-tests-defsubst-:documentation () + "Docstring for defsubst can be specified with :documentation." + (should (string= (documentation 'cconv-tests-defsubst) + "defsubst documentation")) + (should (eq (cconv-tests-defsubst) 'defsubst-result))) + +(cl-defsubst cconv-tests-cl-defsubst () + (:documentation (concat "cl-defsubst" " documentation")) + 'cl-defsubst-result) +(ert-deftest cconv-tests-cl-defsubst-:documentation () + "Docstring for cl-defsubst can be specified with :documentation." + (should (string= (documentation 'cconv-tests-cl-defsubst) + "cl-defsubst documentation")) + (should (eq (cconv-tests-cl-defsubst) 'cl-defsubst-result))) (ert-deftest cconv-convert-lambda-lifted () "Bug#30872." From 9eb04d87409db48ce63ef5d40201c92bc9e7028c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 18:52:31 +0200 Subject: [PATCH 044/145] Mark unused Gnus util function as obsolete * lisp/gnus/gnus-util.el (gnus-test-list): Mark utility function as obsolete -- there are no in-tree usage. --- lisp/gnus/gnus-util.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 8d8956f1fb9..abe546b8cb6 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1654,6 +1654,7 @@ The first found will be returned if a file has hard or symbolic links." "To each element of LIST apply PREDICATE. Return nil if LIST is no list or is empty or some test returns nil; otherwise, return t." + (declare (obsolete nil "28.1")) (when (and list (listp list)) (let ((result (mapcar predicate list))) (not (memq nil result))))) From fbfa70f486522e1b752ebf3d8590375508ea2a55 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 18:53:47 +0200 Subject: [PATCH 045/145] Add test file lost when merged from Gnus in 2016 --- test/lisp/gnus/gnus-util-tests.el | 76 +++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) create mode 100644 test/lisp/gnus/gnus-util-tests.el diff --git a/test/lisp/gnus/gnus-util-tests.el b/test/lisp/gnus/gnus-util-tests.el new file mode 100644 index 00000000000..b01e2fc2966 --- /dev/null +++ b/test/lisp/gnus/gnus-util-tests.el @@ -0,0 +1,76 @@ +;;; gnus-util-tests.el --- Selectived tests only. +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Jens Lechtenbörger + +;; This file is not 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, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'gnus-util) + +(ert-deftest gnus-subsetp () + ;; False for non-lists. + (should-not (gnus-subsetp "1" "1")) + (should-not (gnus-subsetp "1" '("1"))) + (should-not (gnus-subsetp '("1") "1")) + + ;; Real tests. + (should (gnus-subsetp '() '())) + (should (gnus-subsetp '() '("1"))) + (should (gnus-subsetp '("1") '("1"))) + (should (gnus-subsetp '(42) '("1" 42))) + (should (gnus-subsetp '(42) '(42 "1"))) + (should (gnus-subsetp '(42) '("1" 42 2))) + (should-not (gnus-subsetp '("1") '())) + (should-not (gnus-subsetp '("1") '(2))) + (should-not (gnus-subsetp '("1" 2) '(2))) + (should-not (gnus-subsetp '(2 "1") '(2))) + (should-not (gnus-subsetp '("1" 2) '(2 3))) + + ;; Duplicates don't matter for sets. + (should (gnus-subsetp '("1" "1") '("1"))) + (should (gnus-subsetp '("1" 2 "1") '(2 "1"))) + (should (gnus-subsetp '("1" 2 "1") '(2 "1" "1" 2))) + (should-not (gnus-subsetp '("1" 2 "1" 3) '(2 "1" "1" 2)))) + +(ert-deftest gnus-setdiff () + ;; False for non-lists. + (should-not (gnus-setdiff "1" "1")) + (should-not (gnus-setdiff "1" '())) + (should-not (gnus-setdiff '() "1")) + + ;; Real tests. + (should-not (gnus-setdiff '() '())) + (should-not (gnus-setdiff '() '("1"))) + (should-not (gnus-setdiff '("1") '("1"))) + (should (equal '("1") (gnus-setdiff '("1") '()))) + (should (equal '("1") (gnus-setdiff '("1") '(2)))) + (should (equal '("1") (gnus-setdiff '("1" 2) '(2)))) + (should (equal '("1") (gnus-setdiff '("1" 2 3) '(3 2)))) + (should (equal '("1") (gnus-setdiff '(2 "1" 3) '(3 2)))) + (should (equal '("1") (gnus-setdiff '(2 3 "1") '(3 2)))) + (should (equal '(2 "1") (gnus-setdiff '(2 3 "1") '(3)))) + + ;; Duplicates aren't touched for sets if they are not removed. + (should-not (gnus-setdiff '("1" "1") '("1"))) + (should (equal '("1") (gnus-setdiff '(2 "1" 2) '(2)))) + (should (equal '("1" "1") (gnus-setdiff '(2 "1" 2 "1") '(2))))) + +;;; gnustest-gnus-util.el ends here From 59243e9f18a247bddd91ed704c8e3234383ed414 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 19:26:04 +0200 Subject: [PATCH 046/145] Fix two mml-sec minor bugs revealed by new test harness * lisp/gnus/mml-sec.el (mml-secure-allow-signing-with-unknown-recipient): New variable (bug#18393) (but this should probably be fixed in a different way). (mml-secure-epg-sign): Use it. (mml-secure-check-user-id): Protect against recipients that aren't email addresses, like "No recipient". --- lisp/gnus/mml-sec.el | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 740e1d2b722..69852c381d6 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -665,8 +665,9 @@ The passphrase is read and cached." (epg-user-id-string uid)))) (equal (downcase (car (mail-header-parse-address (epg-user-id-string uid)))) - (downcase (car (mail-header-parse-address - recipient)))) + (downcase (or (car (mail-header-parse-address + recipient)) + recipient))) (not (memq (epg-user-id-validity uid) '(revoked expired)))) (throw 'break t)))))) @@ -937,6 +938,10 @@ If no one is selected, symmetric encryption will be performed. " (signal (car error) (cdr error)))) cipher)) +;; Should probably be removed and the interface should be different. +(defvar mml-secure-allow-signing-with-unknown-recipient nil + "Variable to bind to allow automatic recipient selection.") + (defun mml-secure-epg-sign (protocol mode) ;; Based on code appearing inside mml2015-epg-sign. (let* ((context (epg-make-context protocol)) @@ -953,7 +958,8 @@ If no one is selected, symmetric encryption will be performed. " ;; then there's no point advising the user to examine it. If ;; there are any other variables worth examining, please ;; improve this error message by having it mention them. - (error "Couldn't find any signer names%s" maybe-msg))) + (unless mml-secure-allow-signing-with-unknown-recipient + (error "Couldn't find any signer names%s" maybe-msg)))) (when (eq 'OpenPGP protocol) (setf (epg-context-armor context) t) (setf (epg-context-textmode context) t) From 0c6d2f0ff51eb24938f4af4116855b5facee9d24 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jens=20Lechtenb=C3=B6rger?= Date: Tue, 4 Aug 2020 19:28:41 +0200 Subject: [PATCH 047/145] Add tests for mml-sec.el --- test/data/mml-sec/.gpg-v21-migrated | 0 test/data/mml-sec/gpg-agent.conf | 5 + ...089CDDC6DFE93B8EA10D9E876F983E61FEC476.key | Bin 0 -> 797 bytes ...1B444DE92BEF997229000D9784118A94EEC1C9.key | Bin 0 -> 526 bytes ...FFEBC04DF3E037E16F6A4474DCB7984406975D.key | Bin 0 -> 841 bytes ...36D27DF9DAB96302D35268DADC5CE73EF45A2A.key | Bin 0 -> 797 bytes ...3109315BE584AB2EFEFCFCAD64666221D8B36C.key | Bin 0 -> 526 bytes ...5689599E1C0F66D73ADCF51E03EE36C97D121F.key | Bin 0 -> 797 bytes ...BF94E540E3726CB150A1ADF7C1B514444B3FA6.key | Bin 0 -> 797 bytes ...5D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key | Bin 0 -> 798 bytes ...11B1935C46D0B227A73978DCA1293A85604F1D.key | Bin 0 -> 798 bytes ...643CEBC7AEBE6817577A34399483700D76BD64.key | Bin 0 -> 526 bytes ...0D01F368916A0021C14E3453B27B3C5F900683.key | Bin 0 -> 710 bytes ...F2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key | Bin 0 -> 798 bytes ...C17E134E86E691297F7B719B2F2CDF41976234.key | Bin 0 -> 527 bytes ...714F4D9D9676638214991E96D45704E4FFC409.key | Bin 0 -> 798 bytes ...4752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key | Bin 0 -> 526 bytes ...FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key | Bin 0 -> 709 bytes ...BA94EAE83509CC90DB1B77B54A51959D8DABEA.key | Bin 0 -> 797 bytes ...3E9D01F0465B518E8E7D5AD529077AAC1603B4.key | Bin 0 -> 710 bytes ...6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key | Bin 0 -> 841 bytes ...72AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key | Bin 0 -> 841 bytes ...3E1A079B28DFAEBB39CBA01793BDE11EF4B490.key | Bin 0 -> 527 bytes ...7DAD345455EAD6D51368008FC3A53B8D195B5A.key | Bin 0 -> 710 bytes ...5E00CE582C2645D2573FC16B2F14F85A7F47AA.key | Bin 0 -> 797 bytes ...68630A06B048F5A91136C162C7A3273E20DE6F.key | Bin 0 -> 710 bytes ...E73903E1BF93481DE0E7C9769D6C31E1863CFF.key | Bin 0 -> 797 bytes ...117468BE801ED4B81972E159A98FDD4814DCEC.key | Bin 0 -> 797 bytes ...C5EFD5779BE892CAFD5B721D68DED677C9B151.key | Bin 0 -> 841 bytes test/data/mml-sec/pubring.gpg | Bin 0 -> 13883 bytes test/data/mml-sec/pubring.kbx | Bin 0 -> 3076 bytes test/data/mml-sec/random_seed | Bin 0 -> 600 bytes test/data/mml-sec/secring.gpg | Bin 0 -> 17362 bytes test/data/mml-sec/trustdb.gpg | Bin 0 -> 1880 bytes test/data/mml-sec/trustlist.txt | 26 + test/lisp/gnus/mml-sec-tests.el | 859 ++++++++++++++++++ 36 files changed, 890 insertions(+) create mode 100644 test/data/mml-sec/.gpg-v21-migrated create mode 100644 test/data/mml-sec/gpg-agent.conf create mode 100644 test/data/mml-sec/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key create mode 100644 test/data/mml-sec/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key create mode 100644 test/data/mml-sec/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key create mode 100644 test/data/mml-sec/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key create mode 100644 test/data/mml-sec/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key create mode 100644 test/data/mml-sec/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key create mode 100644 test/data/mml-sec/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key create mode 100644 test/data/mml-sec/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key create mode 100644 test/data/mml-sec/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key create mode 100644 test/data/mml-sec/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key create mode 100644 test/data/mml-sec/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key create mode 100644 test/data/mml-sec/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key create mode 100644 test/data/mml-sec/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key create mode 100644 test/data/mml-sec/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key create mode 100644 test/data/mml-sec/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key create mode 100644 test/data/mml-sec/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key create mode 100644 test/data/mml-sec/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key create mode 100644 test/data/mml-sec/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key create mode 100644 test/data/mml-sec/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key create mode 100644 test/data/mml-sec/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key create mode 100644 test/data/mml-sec/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key create mode 100644 test/data/mml-sec/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key create mode 100644 test/data/mml-sec/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key create mode 100644 test/data/mml-sec/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key create mode 100644 test/data/mml-sec/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key create mode 100644 test/data/mml-sec/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key create mode 100644 test/data/mml-sec/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key create mode 100644 test/data/mml-sec/pubring.gpg create mode 100644 test/data/mml-sec/pubring.kbx create mode 100644 test/data/mml-sec/random_seed create mode 100644 test/data/mml-sec/secring.gpg create mode 100644 test/data/mml-sec/trustdb.gpg create mode 100644 test/data/mml-sec/trustlist.txt create mode 100644 test/lisp/gnus/mml-sec-tests.el diff --git a/test/data/mml-sec/.gpg-v21-migrated b/test/data/mml-sec/.gpg-v21-migrated new file mode 100644 index 00000000000..e69de29bb2d diff --git a/test/data/mml-sec/gpg-agent.conf b/test/data/mml-sec/gpg-agent.conf new file mode 100644 index 00000000000..20192990caf --- /dev/null +++ b/test/data/mml-sec/gpg-agent.conf @@ -0,0 +1,5 @@ +# pinentry-program /usr/bin/pinentry-gtk-2 + +# verbose +# log-file /tmp/gpg-agent.log +# debug-all diff --git a/test/data/mml-sec/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key b/test/data/mml-sec/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key new file mode 100644 index 0000000000000000000000000000000000000000..58fd0b5edbc0fae0642c30d4c807d8cb4eb1cacd GIT binary patch literal 797 zcmdNeGPEiv$}dSxE=f(%Ehx$?ODsv%%}%Ywv|?EPCfa6}^X`A# z_8bczDHp$y{^rxyxQwB*EtEl7(?^+!b@8cpwLFv3EAFWskY%}{rAq?h}4%pUhXjG-KmUy4AbUs(_%YZAF-@Bseh+J z#Il&aIn&d3EXdOGaJ#+qTc2B!r6$lNsm4}}42+r@mIxOcnpou*q~;Z*7wG0CmSmQt zY8YC=MUZ`CZdI0ARGgWgXJ}=jsbON3n3JAwY!wvj2;vk2{cC6yKPWs3bO+d*VE0&9 z2_4(@=JloLLJ9A?)B74%gv|3k!@StKXYv)nT%pG7h5yPQ{aE{ncj`qOq1j9eY`F4Y zUes4TVVusts!CwKAq(H@^R*HCD!+CaDm)a~v}>8l)tqxHJ2$RAviUg6zs_7Mrb9Zj(4>vfzCXb^L=nOMcD~40)wrlg2zTtIp@|F0z zD48iG`{s)mo6Bu8rfA+s^)BDdb8JS;vVbenaf@Qj_1bFK%{JZn`1SYvcG}i6n6@Ccss(pS(PtY~k)Ku-6uKKQW>uDz^@z0kvI-^-| zV9MG%1~PB7io;fzGi0h*DSQVRV`9a*@_$K>cizDVNjvXxo%`qa&7e{K?u1`A1x~-a z60{&?b?vK!=Fe-sOKT+Fvk#~`9W-x_5C4@{T{Gs-u#AytO6~wfd2(@SuBnxYp_!!t VFliaUQWP+Om{{fI=cQ_b006cISnU7+ literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key b/test/data/mml-sec/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key new file mode 100644 index 0000000000000000000000000000000000000000..62f4ab25a69bf2c1c815bb4c2b8d135516a7aeae GIT binary patch literal 526 zcmV+p0`dJQF)=!Da%py9bY(4TWqBwwI&yPiC^0&2F)}$i0OuQPEWQFU{Y#Sar)T{C zgOB-P@YPS?pCA)p7fRoC^Xri#%b4V-w@Sp|*rc@0^qB~Y`3iQj=A5!dSi&Wue7yqL zHrSF5j|Xw&O2-TE>~l?rlisq%O+_9cfE}pe3QE=`yr+b!jgnpjDr2V19kKm+4J z)+ipbU1+`*;muKsgf92TXFe0~c`xs~bb=75X*wVen7*%aZ#jT^YVhdfks&wv|`v1meaue_<}FL zPt4u94Rd(ee%XG1QM7wED}%?q=5~g&E-oI&CmKAt^Ho~d<@J)5o7>w;x2~F~<7Oi` zd(+P)JAWQ!-^bPP%_R59*=paWd%V~EPXO&67#Rm5M1r8)EoWiIE#YdhRK>hm!uk7F)}b}YFHv%Y-nPYUyzztkY1phmspZn zma1WB2^T^3jk#4>YEf}!ex9L~iKd2$RbozhzOhwMup@|54D_#|Rs5jvD9{~XZ-TsQ zVqx{nJmkT~3-_1&PUb9^%Fl4|3!NC7VsgypW$(cao8&lVoYL9)b)V4JNteIAZCDy< z#+?3Po|dGKWm(sRWbRo$j~AbG5_A8(;J2@w>HUd8+u9a{UNAUz;=FI$H192+C+54c zHJmkgZ?RrndqwQmrF{1`pXNJxQn}%pqT2rHap%;P9mO1aTbe}c0>XTYruD9WmUiWU z`|G35x9vB^C6`u+cwD(VK||7OcUo%83%7(e9ha<(nw3twcI?x*?3ifwsjX8<_2HVW z+&=F%#vZ9qpHZgSXqc($`pI3Xace;RiA!fzeG%7K>-lj-Y}c(y-hZ`|{zo@+?crL! zBJ0{sbp@SUC(q1^nX9vR>*0r+*KXMz`It{|e~i`IUD^8=PBZ8YFjSqz`13`fDc>HZ z6}3Y4o1$dTZC|H)!`eZv^Wh)PS(5fsPwezOBdlqC>gm&WuYFPwv|`x%^J`b<4W=yl z$(IVcuHMKB_TOvMCjH&Dr#omt;C z?4*J zwJ!BGNjolX%(M!hB=JtCMCEhJ+?ro3VjmyOuwQWz=nOMcD~7}Gl@5vSTJkP?XNC8( zqv18o8jj{F$3?i(HB^3o*4QQfJ4&IjzudxLotamHy}PN6jQN&UjkYPD}jAVPcAOaHMKG^FgG^@ VCM^S4iUKAO6RW)Zyi`pP0023eS402+ literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key b/test/data/mml-sec/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key new file mode 100644 index 0000000000000000000000000000000000000000..6e4a4e548fdde4735084c0d105afa9438fd68342 GIT binary patch literal 526 zcmV+p0`dJQF)=!Da%py9bY(4TWqBwwI&yPiC^0&2F)}$i0QH;OtrA*l2ay$dPifP} zg7f?1bfZx#n#x7gwqB(*d()JGj+4?8D3}%awS~{A8I6a{q!dac_sB#I7?Tae=m( zDJU^Ia5gnM0QO%Osv2owt&S4|f0uIcF(RoPhgC{AKoxdv_>eaQpiENVgmITu|AFVx z{H*%;GFHMe#VcM7+p_Tpml+6@^(iPZI&n5NIspGQBDoNk1sd~@ya@!{Y*q&KyWq}j zYy@Yj&JX80u)JSMC2bb3)ue5>I`daV$xj+!IBq7#9EekT^l2i~wv|_kpxa=FdE*fW-uQrLT4?5$s zslDy;I*mnITIV;#-`yM$pqIOGs^%vx(Id?HTm%1x8U=L5?$7W3;)QH;wa zPN#j?{Bp;3{+_MBlYhBv+7J}6*;fmH?|52b_8*Xf&MkLiXRjn1-b+5O|W|` ztQ0?gRycl7BJ|O#$rqo$St4?}&aGu{&q>WqPxf!T!WojJvCq%=^udchnTuK9Sej^W z`Eq-&S9YOpNbGbECW%{1RI=wz=ReYDxZXwOvDuO5?iTWq&E-2jDSeQb|516We%bfP zhovj(Q%-JuB;dule?$0usk!=wlDb=y&sSI5a4bHN2y}*-sTIRZlS`fLvLa_zM`Zpj zvQ3-Ho_gvZBkz%Ya-3>I}SOzM;!S8Er|v`bk2cYm>G z%yzeHtXtmn#l=f}J?ipx`4p={kTE7!CaOX2(wA>w{_MhN!7dcIU0PU4q`*CkJjyTOP{hRm8kjakcx@A7S5R966d-{9X1edBH7ElqVOL=9*d=TUwZ! W1Cy2kEJXnmh>2BReqO332mk==r&&V) literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key b/test/data/mml-sec/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key new file mode 100644 index 0000000000000000000000000000000000000000..14af8662f79b75cbf855b2a07a438d59b6f03b64 GIT binary patch literal 797 zcmdNeGPEiv$}dSxE=f(%Ehx$?ODsv%%}%Ywv|@OXD3(3z^Xb=< zZo5m)I9@BT`2Pfy&0rm)?cZ)_EBQN(#2(U0a?mVJyuO#FZ6SH=Aodde>rLI zd*2_(jS)@|diHwygvIxJ`ZxbbwJg0j!?W7#ok*m?uM1t~{=4+A&(_tRpEU26UB7Rn z`Yy4{Oa2(<&EDqFcW&)6i?o{6B9}FRE=e`EVq{>{)UZUj*wDl(zaTZQAiY30FR>)E zELFqM5-x)58*{6&)S}|d{5(S|6HN^htHhl2d}FJiU`G(A80cR^tN20TQJ_1(-UPeH z!b+(kA*Jnsm5G3?<9(au|E`~z{Nv)P&I^Y7Z{0a5c4*53_L4>yhEwm0PCH+_y+HQ6 z-19H9{_&oPS>bYTt?aowTU#fX4vSyiic)_>1B`br1ZwpnuG^#7P zFS7pFvqQfuA2X?n2r9Gu4DHE^Q zeE$kH=Fj6rYSXyFs%_UB8K1dayXnWDe+|JO`z+d(uCG?my;{@zANSSfucOQxHQ+)%EZvp X*Z`Qc3}7h=m_SUd^78XiH9-IXUP)=v literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key b/test/data/mml-sec/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key new file mode 100644 index 0000000000000000000000000000000000000000..207a7237d3abdd001aec142d990e53356df1bcdd GIT binary patch literal 798 zcmdNeGPEiv$}dSxE=f(%Ehx$?ODsv%%}%Ywv|_lvz4-9Q$&HgX zm)AH5teVZ7yB@E;+c%VNS)_AazZkOHz%k7#SEfH7pS>HZ-xyFG$TRNH5UMODxGO zOVu#6go_~i#@wnbwWv5VKhMz0L{r1WDlsQL-`FZB*b&4j2Kv{~Dt=IS6zC4HH^J_) zuu@v^_=n(6om7jM-)4*d+)1&y7Up#$AE!hOZ{h ze0nISxR7twJh`fU=hyAs%OOxI)i=4RpmXtC)}=nbwQtOP%*$^m8rCYq!FA!kIQN5p zq3kS6*0-GW4(FHieg8K+asIK8#R?ws{1IWx8PA5E1vOMm+pR*ID2&_(DwD9iQ?An%zdXhqRX7+hi ze$7y0{-xCl_nhBY{7XZn=f`WEgn1FR#_b1x&0pD|lQQ9FPvcC1HBA~dAGdvE@Q^>6 z@o?_n46o)r3l2`C@!z4Y4ee>g%Ep6s)G#r<`)$SF{qCl{CInp&9{8X6e^ V)0P1&NdZ%ciB(>HUaBSt005eJW#|9^ literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key b/test/data/mml-sec/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key new file mode 100644 index 0000000000000000000000000000000000000000..85ca78da04d8069634542ae7fab0cccba6662362 GIT binary patch literal 798 zcmdNeGPEiv$}dSxE=f(%Ehx$?ODsv%%}%Ywv|`wLrh01Q_EPa^ zVdZn>fh^H0o+VW?WZinYO<#7;Qg!z=d#mkTU0mf`{++k_EtM?eecEH@nZiZyR_O8M z7aeG@72Mq-y+TIDQMN(*)>ik&H)M|l_FL+hz1Wy@jO*0jbi1AWFJIh$>y}%3P;;yE z=N4m`PX2}Sr`MFu@_Z%!Nq%AzvnJ3bsm4}}42+r@mIxOcnpou*q~;Z*7wG0CmSmQt zY8YC=MUZ`CZdI0ARGgWgXJ}=jsbON3n3JAwY!wvj2;vk2{cC6yKPWs3bO+d*VE0&9 zakc$E%G>jl|B1H6gsDmf4>O;q#x-zkVDk1X)JY0|^m)-qcgGbIQxxvx)XutfHXvVJ zJx*fs{D0eDWbJ&Lq33ez{fkeJCs~~~qgRYC zj$|BozSFK}mn@Il4$m8YKc9x~2{uTsb9*qy{%il!=N!#hMdzn+|4A23;F+~6?9nOb zIcuTDy#3xGIh#0Gh&kOE+$Um-fE#;b^_=kHEtG0i+y+M0P-QwpL?rWBp z2&eDu-g5c(Tk}(@6=h!n<#*ZV!;HyTu6L++^WM|zD|Y_Ni&K~w6Qx`F1mx*uN{T=TbU8J?xdgwqV<-HN+NgYlkJ36h<@ALb~|p3<@Z?knx! zr=G@>F3F-(tb9Pc)=wtR>g*QBpt-F2uwTveZ#z+ibwehDZ=bJahm(SdS!m{*afNbJ zeT<=K!+ZbDktrxKI%P9D0RRChC^0%@F)}zh1t(+xb0*AZ#eDIW;u=Nw0u;O=g6+7y z-VJ46kMFn#xlXr24OMPW)Kytz+={J3DX3zAtc}x~@sAmfvW+uO{qq9x0G?S>?ciV3 zGvEdBmY{J2%2RAqzADPuhT76E`$r!pD%T@^=lS9TZg(!F5u%83PEU2Gj4SLrFIoz4EXxXfac1_#fl5xSdi!C+;rAV=r3YA?s6<6 z2ef|cui12=5sZWGx-(tH;n9pmTPY|pI&n5NIsowgx0O#2cHo3Ok@PjERF*_g9OTB922NHS#D|?O88D6{DB*6aMJE;T9Gm Q)vr*t>cfW}F1{%#DO7g*umAu6 literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key b/test/data/mml-sec/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key new file mode 100644 index 0000000000000000000000000000000000000000..776ddf7e9e2f186e3893a1d8753b0e96015d1432 GIT binary patch literal 710 zcmV;%0y+ICGBG-Ea&L5HV{~O?EpT#ac42g7Eo)_YC^I^8b73ekI&LvCIXVEwN8)42 z^!s@xK)&&wZxRfWvQOaUX#^Z!_|wN(jXMRb%thIOXlqrMeCyDbfkl<-GSlMSbxuW} z=`9A1P@M2>kd8huZA3C6Zjxqfue?dcH8O#4Vg6KYTu8tT8bTeu{H?_41PE@wX4dIR zM=B1OFW~Hn9bvd_LB_z+MoXtDC^0%^GdckP0VyasI&gAtbY)|7Wn?lnI&W}gZg6LC zEpsw!Gc9vyVKFUXWpgcKVq+*MG&*x=VKF#5R~4QV1CS}>I65&fG&nUkHZUnMHadwJ zI4K#Djmfv#XM`^rrMxLLFfcm&Hb^2_MB~ixsklEHJEHX{OMoBP{o0|-ZfrwqwjKCa zVAelsGk!ymMl*EZhwegnhGBco=8o70DNBW#>L2PwxWPhwwG7n<+xPccJWlbek`ujP zzV;I~lKcR}%MHs#-oyh{jyq%Ifz>SukJ1K;Hl|6Ha=dyi{x7FSrZ4i{%?>@$)Lx{W zJnu{gxypp)$^+qLlb+i5a^DD)CFZa6w-q@i%|0{-981M>!0J#}dk(uhG@3($Xcsqn z64civORjd5KmDhjW)!VnkQHpZEUKE~NS>&v4Zru(0G3Ngd5GYZ`b(*O>=q)p($xQ3 z`&paGqhWXD#{x`DDqgA6NiUH5XXLe6FvCBj0m;;oi=np1WxLrcHw=l)K=B0iSWn*+@WG!KIF*Q0eFflbSIWjO*F*PwbGc+kFDU0+&GXMYp literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key b/test/data/mml-sec/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key new file mode 100644 index 0000000000000000000000000000000000000000..2b464f0ccbe4b2fe503e513672d8835ae4cbf96b GIT binary patch literal 798 zcmdNeGPEiv$}dSxE=f(%Ehx$?ODsv%%}%Ywv|>2=@oI+1aW2m} zl~F7LRuMCmZl6fFktKU0VZUb}=SlH59kVIv zW~NSvKldu&AM?~rn*=r;IV-!w_oB`DmK~oRa|@k)XRnxkb%D_7pz9J3JSTG+`?w@L z{UH1D$l)*dd4$i#u4oOq`O-Bq>%1n=C8@?%j0}vL8kPtb8=6?<7o_GDq!;MsC6;8C zrD_;j!bOmMV{TQJT2!2wpJ!-gqN!nGm6(&BZ)_D5>#54-s#{_q<_A_vw@vnAIdFT;{*_x*ofb0%?wIqrG4{~*$*cTDRGA-y1Xl0eq@)cf~cAs<;BL8>r-}0*RNh}2sLK)eXZ#SzwV54*s{OGzA$?3ikV0EK0k1QbzgpT z*yoKR*Urstxu>){DJg7?X;0BtE6-fLd7^ z5ZUXgj4-$1`gseoVNO_$i>4J6KkK#sAe+_ z=d7Bdd&uhuhbbsAI%P9D0RRChC^0%@F)}zh79!~M=pMdAm3piq@u6U=)oup5L>rj_ ziq&q;2!rRp$9ysTtBn77I-ePy9h`>qRJDAu=_3D}*Bg)BkwnYq{;MRqCNULKaRsE= zEN`Zi0jKA)_jstRqYIhg!!^(L4&9lK;|!< Rpw6b$yIbP0v^UNvDJjAx{2KrO literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key b/test/data/mml-sec/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key new file mode 100644 index 0000000000000000000000000000000000000000..137659693bd3b69fe3b51aa9916890277865733c GIT binary patch literal 798 zcmdNeGPEiv$}dSxE=f(%Ehx$?ODsv%%}%Ywv|`vVW_U^?`n1Dp zrzg+cwHF3z{k{3#eetAuI`-eIHoE)nt^7N2!7Q12%{DV#k@VZ*0s2xi8*8lGY#;Rp z9g28oRof}PHsHU56-U+l6Bjc~4BBqrIqKb7VR%nqL(NLz#EJO=@+LF$mVWt@*}R!! zo8PYJId^a5yqwZop|C?I>?NPQyC%>jsm4}}42+r@mIxOcnpou*q~;Z*7wG0CmSmQt zY8YC=MUZ`CZdI0ARGgWgXJ}=jsbON3n3JAwY!wvj2;vk2{cC6yKPWs3bO+d*VE0&9 zxtDqd`pBhkza6}1?}g(_|WP*H3K` zU72t#J*v1#lDYhI?lF%Cv!*0@y2bpNKiyjTZB|Xols1n*qb>a6%hqu=nD9!8d|ATA z{=(Sv^Hwvz%U=%8bt)EInVj`}?$MvATeh9!iC*dmbcUI!6~hth-&6nIj0%%qyZXRs zw@EJlTaH)2v)AFDD2tWm669;7MrKOFqN*siu5e zc;x|auN&Jc^dgttYT2{oQA=o;^`>ppS`*DqA7Q+r)u4GU5ftai#ihBXRwf1(W=6oY TWdKW3z!YL)m6xBFstE!BP8C`u literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key b/test/data/mml-sec/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key new file mode 100644 index 0000000000000000000000000000000000000000..c99824ccd43b4c22a344af3c9074d38a736c50ad GIT binary patch literal 526 zcmV+p0`dJQF)=!Da%py9bY(4TWqBwwI&yPiC^0&2F)}$i0M3U=WY|w|OJ759@*5}@ z?M5FrJ%PS827pcfAsNa}+`5FyN8RIa?OwyKzC`#$)B`)jv70hutA_GK5_GMR{@!eT z!k=6aK%)vHSTN!x)tr8{eVD7E(5@%_>PAPwKgUyhVMsTwa2fPH6S~}zib`YPhGgQk z)CnWREJ%@;xhW_yI%P9D0RRChC^0%@F)}zh5LP2N7UVI##EVfQ)q)mcZfS|N6V5l| zi^89)zMg^}bE1u1q3@f&D*w-ty3+(q-aaGf>!G}jW*8g&sn_I zuI!%sBXOap8Wk8^Y2z{i#v%^br70*eI&n5NIsop>l;8k~B>5xWtAya!(bt1lj1SIC zlU<#9Pk1++9u5gTP+w+xNy3S4_AL{l28J=F?<4il@0$ZL+&%7=!i6a)F*piwpcP*j`yT&C#MQzk14c*~_74SR3`cNzBVI760Nft~ zpW^c8enZU~#E!84jdd@V!3$ci%v5n^RfxKW&t0va>BOcd7P?Qlz`IV7Eqp85zCPkx zl0=_W>B8Z+oi6Ql=ppaCfl5?qP|6hgE@D3&ssig)7RHZM9_0}c1sN%w1&A}flKTp-4gr|BGmP( zhP6Dx@{ha7uawAisVg_Su%Xxq57G(5V9kqmIu?aNmhbi% z3&@z(SyirI(b@BK0EBTI*VwO3^j zd&;_lo0uQ@OJ5pr)6rDqfPox?Km`djg32gxZ z^8&|f&T9VJ1r&D~Ut;I6s|$ixlFb>kIbXO#{pU;xu6S3U1*sM)Qw~?14l`te#u>Do rVsI%aF)})Ea&L5HV{~O?En##qH99gdF*PtbGB8vzH8D6eIVmYA&z?I* literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key b/test/data/mml-sec/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key new file mode 100644 index 0000000000000000000000000000000000000000..ca1284089520e7ef6a2e7397685c0902bca3aaf5 GIT binary patch literal 797 zcmdNeGPEiv$}dSxE=f(%Ehx$?ODsv%%}%Ywv|?B##BN!+jzRSM z_S+{LuPyPfNWFC6dn#AN$AAN@KUe7I7lm&+6!hJ}V$OTsZGF3fCUg{MC{|j_2GmcL z-WixXM?+%ED!t_wGZP=K73%AY)cLk7B3eEqK)G>Io@v?cGc|Y58a@$JVAN=TuvBs4 zyb3@0L(w*S{d(#Q138-VCvfd$)&#mF)!2%Wfl*V#65(P)6RZ4!)VzZ90^PjClFYJH z4MR(~2(oX?t;$l1iZk=`46RHwHB77$bJFvTt%8CbL7ZZse+{kT2Zcw0?f`oe>>dj% z=CEMP@AV#2RgcgUR$JHlVCc{FzT3McH`d-{I1!Hd%g zN6$YKntHmzXl1LvgJxUawI+S<)a(0BPw8hhEKmeG!_3r*;Q)6|g8Iu#Uj@^zZ(=_1 z%Xju4F6ydvKMJd-*Eww*P`X?Cm zY@^khD}p~H53i7P2IFfcm4*7FVH$jcX-cu8xBA@H^`li_*hHNOQYmV6(dNLH=2 z>cxTcprhUuBgZIC$h(J2rHouc)pr5?t7;5@%m0PN;8|~2z5bDdiYLx)De6>UWdYA}yr`eV^-ar-??eCDl%!j1u4k zTf{^%yAy;jKKKgyF7J&UCuoztW3tkTk0Erob@S}6pcf*GR)*w}CEhD?C_HZApuzzo s(LbIkC^0fRaB^>SWn*+@WG!KIF*Q0eFflbSIWjO*F*PwcFf%DBDRa>~>Hq)$ literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key b/test/data/mml-sec/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key new file mode 100644 index 0000000000000000000000000000000000000000..06adc06c42781ba133ce6234145c113b040d876e GIT binary patch literal 841 zcmdNeGPEiv$}dSxE=f(%Ehx$?ODsv%%}%Ywv|@PAe7e+s)xKNP z{&QDq@QG}YSe<_UTJe?7mp$hmTJbZY@%Y+Rk79OkZpzuezmI)ZgM{B7d*!Z~HQKj- zuerX}=~?b-(}v{yx`j&@?crbfWWw})9xoVY^+ht(TlGA>o;0a(vNWrbsD`}H^!B}C zJmQx7@5fv7$^P1=s5X7}{fCJ{)UZUj*wDl(zaTZQAiY30FR>)E zELFqM5-x)58*{6&)S}|d{5(S|6HN^htHhl2d}FJiU`G(A80cR^tN20TQJ_1(-UNBq z#KKBz2d{gmY16OsX7NXuy6r+E-lsMwy*&_dxqd?1#ffs4bmGI4#p~W(o~JRV>C5DU zq1!4}il<&?T$dGoXFL@c}JTVJuRDXGzWdoD)nK;bNxNoTyuyII$(hwc0r zz*(2RYR0YRy4%Mu`0#GJT=Ur^MX_AnFvRk{U{Q2glf3pMp6ZGEq0GK zr1rNfKvADuT$*cWWdKZG2C!5GOeDZ0k&$R-K)v_C8~>88d+JIX@UR%wBUB1 literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key b/test/data/mml-sec/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key new file mode 100644 index 0000000000000000000000000000000000000000..cf9a60d233b86ea419e4b616e349bbed1cc0cc1f GIT binary patch literal 841 zcmdNeGPEiv$}dSxE=f(%Ehx$?ODsv%%}%Ywv|`wDV2!4z!scs^ zuKy2iQ)%N~$-VYK(D~p0-&gml<=%Vp;)(Y(*)BobiTv*R>^c5f*8^^{-u$WS_)F{& zi;}%WVEP>vg}A$OLw{9;N*-c~W<2^!?wOPMvdgwJJ)Yk> zJNt0Xs^%^GF1WMROC5iedAQ0bNnaD_l2l_WMg~Sr4NHWJ4Na`_3sUn6(hGF+5=%16 zQZ)=M;UdVsF}Es9Eh^5;&oi_#(bO=pO3X>mH?|52b_8*Xf&MkLiXRjn1-b+5O^|m@ zEUYx1ovHabtD{``W5TcHLX-7dc8R^;5&iI8)L-lD)p}R0CM3QvY|}HgDg5~Fnk3)f zq9WVZ>r*+G&fgtYn%}!^kG+l0+)DX&g^w%xe$6Sred+y=Z5Nz#E9PWXKAy)S-c!lx z_TbRVr_<$2%eS35%)sC6uxRTF-yO|Idmfv9T_{!Z^UCt}SnXwV?o0KYk;qWUF8*av zJax~R$wF_pe^FTOzQ!}nr{d?oxEn`|W9RekJ>&3q+Q*Q<;FtqvJXrU9>uk`tzVf26 z8|#z=;g_7}>YpT=ac%4mo2K-)>UNrMnOaF$quQaOpoXa3?H{LP^|d8@h;ity-ZAYy zkMNE=!D+fbwuh;2dRXTdal%P%^V$_@GZ<#=sh)CVXVizoIu~wrsq%k&?AB&^N8}){ zm;V0<{*3|+*K()KWIdpNYh8i-*Tv>G?$x(N|LiT{;@v*u%Z0{`tG=f`%vt#8UHy*u zr_Ww&7Zd?SeR6SWuA!9yFnJlkQWY?f0Fy*UqM@mkvtw|GsfAT5dqLd$l)X%bR>me) Z!5)r=7FKt!ChwQ1E?#M5Wof1f0s!aOfdBvi literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key b/test/data/mml-sec/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key new file mode 100644 index 0000000000000000000000000000000000000000..0ed35172fe01e0021a8365a11eb0870b3722d474 GIT binary patch literal 527 zcmV+q0`UDPF)=!Da%py9bY(4TWqBwwI&yPiC^0&2F)}$i0MUKpgWQh6p1{630)l*u zku3MiycceiY-DjLWu(cWl~c}6EBaV3YE}z4S%)j`8#-333{AP1yVeBg)E!GS;aXH7 zvFN$y7ax>ZHXZ(U@jwY%y64)L@7)tuiSl|FkWK+h7-p- z51S+$sve#t054y~u$V70o}E!PX(=c%I&n5NIso#=82aW;MkLbotc9JjIX6Tk&8F9u zRGg)$D2Bl*ABOtst8k>V)ZK^sF@kp=a2;>rlK{_olEsW|!Nj-AK@TY?F*=yt4 literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key b/test/data/mml-sec/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key new file mode 100644 index 0000000000000000000000000000000000000000..090059d9e8122e9799b78badef12e555a4541ee8 GIT binary patch literal 710 zcmV;%0y+ICGBG-Ea&L5HV{~O?EpT#ac42g7Eo)_YC^I^8b73ekI&LvCIXVEsBpFuD z!<^sTRa(F~XkcGvt2-(S{cPq$O&qkkqBzd&YAw{~uhm2q1yo4gG{G&E zsIjLJSNbz|G6Y>#jQ&R32p?kY<@NeY6mpt_f_8)^=7*hXo95^?>&k8vHLWT?9(Pt1 zMK|7unyX=3Yf=)2_iLBY6HK`&C^0%^GdckP0VyasI&gAtbY)|7Wn?lnI&W}gZg6LC zEpsw!Gc9vyVKFUXWpgcKVq+*MG&*x=VKF#5vRMrkg|Byq{Vc%~A} z#x<>GJks^Se-DJ=(hw*|mTtWC82=G{Uy`qnf+B?=bhFbX93%(P;rkF+ECjO@JT8=P zBerA%7E?XR7S=cOkTHN%gjM%1P?QrYD- z2LUJ&N*~<)YGwuid@QCd1(u{(tnuy!YxhEcv6IC#JIbC%&TBUKcOLu^^<53W^exK( zX9=qWpz$I+%-NBk1jbne-Xhm5Ukt9b^*+}~{5Jy=?8RQ4I`%9AqfvkFd~$*tf5Id8 zx9t@YJwksX*o4o8Vyz2`^mKguTMlsIX`lx$^7SP zUubbP{6F~1fBBDdlmQ=U;Hg+qngH~6yzz-g$8?)Qg!PEKN3x5hh1$mGj~^`KsR?EN z_V7R_R0yb)#-rpTqCkR$6hc~>705?X;-nk;b#xG)>;GvK)c2Dyf+v?w4c)Ooo$X90 sT9*tdC^0fRaB^>SWn*+@WG!KIF*Q0eFflbSIWjO*F*PwcGBPPCDWOI;_W%F@ literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key b/test/data/mml-sec/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key new file mode 100644 index 0000000000000000000000000000000000000000..9061f67512102ffeb5f7a213a37cfb2b0cbcf07a GIT binary patch literal 797 zcmdNeGPEiv$}dSxE=f(%Ehx$?ODsv%%}%Ywv|`vKpV$1*=RNo5 z)IY)^%qynGuGQVS?Cj0yAFiaCr2npayJoAYbE?%{xd*+!{@m19aE`6_RF;TE$hCK2 zN1Uf`eEznqi-N6t3f0Sk3?{MSD@%=sf z-`%J*W$Xygx8+N?6e@J*+!;RgL}i|GOIQ1)Dm_oi(_UsRJ7-clfyc>h_RIwaOApW3 zllf`uf7ylxmMM&k3Ga-|Zm88S$z87QRHasaopaOD>p*9inOZR%U+ML-Xh&;++5@X? zOq;)Y@<>r#w^#q4%uIueB7Z-5R-Re%*x|Btx7v2I{Pv~M z5n9KsCNy*15@1fyGO-W4&+=7oJ;)dnEBQZ*uk=64mE`n4(i}gL`@+o5yBVj~Z9g!( zJnKf@PBq_+Gpu*yayQ7t+DIMh+wipW&H3VSs*~DoM0HI+XQ4i&{lQiC_9Aa5jd*5>9jZ?ugtQkvtDuQkE2%uk$3QV z75m``j{TfM4&Art^mK$6nxGiLiJsLOV-f)$O0w*!8@ti&Dk(?=#B#`sD>VUjh~oB! z;w_uMkco(@CtV!uzXYG6T?;uWC^0%^GdckP0VyasI&gAtbY)|7Wn?lnI&W}gZg6LC zEpsw!Gc9vyVKFUXWpgcKVq+*MG&*x=VKF#57y=x+>4!`rW0a@lt?7^P0x*dIb#V>xKtKnv z?|d@)<6>el0<~Z^Jd?Uyb6~HTspd3_ZH>z(k`#3o9jM)jJA>S<%6ubq47Zs*o^MvKt(-Tu_maF&whLNgkl>bXn+lwT!A_Q3 z>iGFC5yHNQ^ou+nexYnTyHFn5XT1ozzMZnuYAzi26^=54KX z=n)VP*bG_?iOmKv&rAY5NZd7|-OG@_v__pQ{Nc=o1ZPx0L%8Odw5tCrouqf4wJRcw s*>IjIC^0fRaB^>SWn*+@WG!KIF*Q0eFflbTFflb$F*7wdH8&|KDYo1~Q2+n{ literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key b/test/data/mml-sec/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key new file mode 100644 index 0000000000000000000000000000000000000000..41dac37574e3f714572fc2a70cd5a8dbbd55fcc5 GIT binary patch literal 797 zcmdNeGPEiv$}dSxE=f(%Ehx$?ODsv%%}%Ywv|>2dWjk3<=H|6e z-A|0{_T{P1<~i||*=CK@;G)QGU@EG_Lq87ZrQTDj}rBs8Yl~NhMB1q!=tVBFU*X0_Pgtwx|IAC zms6j9TvqU!hnd;Evz~?v?CiWYA5L_0^=-Lz_4KNlFKy&+cf1O6V6s>g`h8k%TT62| z)R>o+OQtZ-7YbeA8(kZ=>cN4c-Fps7J}aCrs$VL2U&DlVvZqVIj5Q+B&b!2BDy@|_ zHMBU)ykJMfmN_ObRi^$6%>@}_Vr4HQ(A*f_5aQ&c9pdA2?)9ZzfzBQt4>V1h9$Q!~ z?wEAm+0f%~MfDetrRlSGZSZ+pInCy0l53C5#O|4C^RFKD07ZFnacQopm9d49g%L1m T8NgB$FoBp@<>lw4YJva&uMJV; literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key b/test/data/mml-sec/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key new file mode 100644 index 0000000000000000000000000000000000000000..5df7b4a59534892f3eef8aa6c0c29ef5210480c8 GIT binary patch literal 797 zcmdNeGPEiv$}dSxE=f(%Ehx$?ODsv%%}%Ywv|`xj|M{xM^Wf;B z<^H|xfzd~NRa@9TlvlWx-OacAJITZ#O8WH!$F=WIESy`bx@LLWnXS?-+g?YPR*5E7 zzOd)Y4HWzEU3l7zUDf-i__8cImQnG%T#4WG)>ZwPpT5VumH?|52b_8*Xf&MkLiXRjn1-b+5O|W|` ztRn7m<}^>K$?~r6k0=%DI#JJ@$mCR?H~Gt-z?EiQANNg=xzIlEb5lOo=O6w~>rSzV z%Kg51`K)A~{gm#H$+H6eJ#9rlEb|JxK6`twm0I7f*hiP`|Cc;JXRBh9#eL9Ve%YfR z?e5DWi!Q8tzP?Dx?bllKjDXs{-r|tJ0JkU8tyFb^&M-5zVz|-25LIwChT? zP-7nasB98iSn$uYL`na*>1kWf2G%XdbDcO+!WLdq ze9Lp@ysRr4pDUC3*6}2n#fxj}iOq9ko1gE&J7H@Cwv|{*DlKr&(Ze)bB zy~(Z_lg}_MZ;Y0y-TTK_YRx`pk%aZ1)T(wV|L^FZt7fLN_0zTP5F_rg#qxKQ)<0p? z_>%dm%X+2a^V##m>)tZQK8beT(6RT0#iY6q|D zmNLb%_Pu7(a^}R0g|68#f^Ao}Mrs0Gl4@+l$iS$nVTo|Dp@~&~L26z>dVy|UVo7FM zs)nH@Tm;!S=2m5?Ma7x3G%Lq zg%#5~XBpG?egEEAp1LN}y|3`hqYFNzVei>23rqV?sI@)iHg8IA?3%kOCDM4qi!G1k z&DtcZK2NY*^DxCN;fmI8>xoSEXMe9*mB4F|BVg5aO3QB`c-$oyjfgX%8AqZ-)oO{pBDNp-=}*)$u-JX;iq)_9g{sO zn>gqB-i`Wj@FUxV=O5kfaHKIVm9sF3wmVyEmYB1m)#qkM!2PW!l@8>$OCRL;)cAhM zJH_1vi3(a#f4PM`%0BQ-df=0!q;%qd?Mb$4M{acVZMA1+;F+grdg_MNx^~8%wd_16 z>)&&Rax*fE?vy#T#VI&D`Ic=^Lf%n9)r2*z*Z*(bTA*Bf)M1ImvoBB27o1rZsL^zB z&M)=p3aQMV$2;OryC?=(xXnE+dstF$mf_U*Ds^$^j#_LgsCM&qnxs8Ht=u*2lJcY~ z`>CFws822~%{8<#046U3SgHah5@3?ZNHjFHa&`<3F}1MLy=UP1OPq0$p_Q?TRj`Mn Wp@mh_tAhQt*BXu+Sy`HCf&c(Uq;6vX literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/pubring.gpg b/test/data/mml-sec/pubring.gpg new file mode 100644 index 0000000000000000000000000000000000000000..6bd169963df7d73f1c1808ee82925a7e53bd6c18 GIT binary patch literal 13883 zcmchdWmsHY(yoEV-GaNj2X}Xe-~?%05K zJAckEx|@CNtM*fORXuyHl^g-7_!RE~4hdF*4#V@V0_??2UPmh7_QuiyXi6dnd`H3${Pjf`=w@X5#s1U>)? z4$x%|28{p*3j=_FegO*s2af=W1pxquAOeTL_5p*3L+$Ab4IO=Pw-*oqcyb%KJn`;a zx6Y6{Z$m11<*t!yvBWtFrGU*;on>jLZWXe}?BzDiNy81iAJ5Y##9EbfnJ6zq?5?dZ7FsKO&_SY}S{&9H}s8oHm|Y&TWd{dRL8UkXNb{P!%h< zz7b~j(TLez%NKKw(b14mSyhWk3&1dT&;tyszhpbv)V*l-l8f0_Xwh8(g<+>0_Qh_}l^5o$@|9V-UjxCV zs>H;X0zBJjEVzaPEI{rlK7I}q@52h%>$Z|@8soz-TD>z;MlVF*T9qjv^;x;(2uOA7 z#3m50pXK}orkD$neDQy9IkO*hMnI*As2!%Z`0h5g5F6s?T{c?dW_}zDm_poM32l}3 zKhIQ$i_K^!-lZAMoUDF2p+8XA_qfV{C);c-bPuZW90LT;X3Jst!xxxIr`SOgOTA%MmCa0y zUWbB#Ra6n}Wy^fG0XFw)te1n|bF~d3VFzupwQAbvUqvo8VskM1WiD6+3Hnl^#Pfc; z?bpF=buC<>-96yAb#c?_PQ9Ju(DO|bl(JM5?1OBvDJ2Tr^G956c_jb@fA<^H-(v6K zTQjsnus+JgUKE-?Jo!i68lBB3t!I&7yvCMYbH4lyA`&0Mq78W2S;`#(X5*kK z5d%T_!|D_OTn-%76UyVUB)>gr0*U}AS-1&sy$DrMF z7vpE8XIEjk@XlzWr^;UQZMo{f>(%-pgh`KaBd@)eX5#Huo8EI$*v4x;-u;NNvaCQ~ z5$Z?2#v4KN!=qqDSL`>SpuVIJ0<`(F?TDPR2!-Is10Nl2Jk*8nMi$nmKfN0g5gCfkQ4)oUxoiiuwP99qOZ%HrRvoqR~A#vEs zG}mv4lM&_JWFS67R|lv)T0tXkvZgoOl@9cFV_{fl4HucQBkh%?=Dr{J3j5&~pyc9~ zW@bPKpq&$mqqDI!@SP(GKj_21q4YWQ|3+zdO8Pm7yj*@!NU)Gf^EE^E(AsPOeSq|L zU*5%x9gV{1m@boisUBkf;V&XLR-fLDa?&fT;o*C3d^7*{^~5`nUf#dMqE#^UMn8|q z0RJ66jb~el^1PtqMEirXf$UrB#04kKAxrVSmz?9bI(|j z+Jq3`t>kopG=5NnVa*NnVl0{eK%cNe7|0Z-ix?dO7?xc1a31x!)5t z?!2wYxLc( zNzr+0;Ze2UfjrI=$ujRbPcXGv?#4s8lvNVoZjx~sa)-D{#rBsuJO_EW6nPB)I`7t ztUje#0uVsXnLM6;nAHhD$$6IW@5%VABm_QaGJbI!ZLZRPDEQ|{7O zTdMvxRkS(a%O%?N+p4D{-A^OIK?>lj97t=VX2GM7%Z`GnylE@^=5D&R9U_%d@|(OU zVQFHr5P{JeAoKeIsnFU|Tn zDv)yjm|i~*zz;4VNv|9!>r0}#QJpcv$wAZiyZM~MayhkJDminN;LgS2GOu%Yj_c%d z(Zgh`D;LpHDc>Ai+o%%OE)j=l_2eN!(2{Uw$9IW^Rl2)ImLYd?p*{$}v(CRsN(0!H zz99|!1Pt0z`Ho2K;Yapu6)&&c5BfGeaz}xlnzKp)j`Pc3n(>o^G@EO5>^_h4jjiH9 zWiu1qJ*FKav$w66S^J8u;A*7$KsXE=qzA9v%^z#rsf9j`w2==sP~gsMz^V7tmor_X zJN6?oA>`dreBhpQQ*nK@Q!Wb1Smbt0x5UpWWDoYMO#Zuh@&Mr?h8bruP%Y-rw4YtvUV}d*OeDk?k(g`!BH7h zoDB6BvtjCN2rhZV%Vd??;51j3hoOAMq9W28iSBRocTj7$Z zFe>6V>Ws<*-(=1|bU-Zh9es*RoU#g9*59z0Mc7Kal4EpPf;Mf}Dk{v&JoR8OoHT80 zw>Z*t15~$_x8lWWKtx6ENDmFrXMAZ#0?(qW!=(8-am~YaI4gTnd?te}zbz{v`SoPaTq&ZZP=x^8Hl2 zZ)Dsg22Jvd@AZLW#kdh4M)EN=&82Woh%8!5Hk0!$by+Nccl;0W#_#1=*{rslhv;5l z%`F6+z@6+>tga#KKBC|+jJ8W$2=u$!qwdv&q)EIkWk!TsO$eKMp8APiM`#g zcX(wZOOP4+_l{E?6!?E*^ky%$v4VB_tqeRQSjEb*c+tuuwfyM9HnT-3f(mjG58GM$ zL?~md(TdRMjSzKjAEqD{^%bOk#=dSHZrhLs(b%n(HG5ZWt|*XZIh~43dZ$+JJMtY) z5{8X{p>+qNbTi~kzXrVbLa}F=wV+r@*u48L0tHcNFWGl^Ex-Af9-DpHU^TYGmr6!M zroRgD*|k`MRw*3jJJl$h3lFa zewCW|R<46s;W!BX+9H#!NM?R{@6@%%4?6tg;2{xh zmjzST^t9>>F^1X%(b@M7Emmj>wa2&@7CxS5eTy)0{yWX%xv^Ce)Tq<=Va-I^{lLp@ zyfs7-4f9M1{F#;9J$g2a*iV(GPCuCYkH^AB9H`w7QOP51Du#c?Yze5b0@C)!)^-^7099+8~A5!oe60Z0O{QkJh0%kq)91{6rEhsvY#3W!~!^?o4Tn0}f9pMdOINP%@ zpcSU)$^x~7(GN1F^Ga{z48`7D;L~6qOA>Pl__n`<_EC5u#T`;yZV4EYTG@JYY|vfN zF8*D78o<|6oyKNT8gwC!?o=N0W7Wp9D@zYmI1ip&i)E8?Cf%#vGr2Tpyn_1iP*Uo% zP`}!HBWbRRH@H^<7%j`Op|U3HL8hDa({SWH4AL=4&Hvg)f7biYHu|R&aI7K0vN0cB z)ub7^m&_?_wAP5nP~W|6ROu@>QA%&OdP!^9S3{+j$%^*9)48&f*8OwNTp-hRA#1tP z={adz0h~Gwg_fw<1-N;nHdHIXZ9?NScqc^`w`Oq;b<0t;PGKh5`x&$GkpSDGez$FK z0j-Ppv;DmOya^3K-Q~NjJ@<4>f@jS@o`+UcJrZ;29}^Gebp%AY|dLUPTC>VOyG44a+R9yB$ggxBAj+=kSnY`pti%^a7mnCMZ9)=$;o6EbQcS6=r9X zZNCy90#d#|^@Sxc+Hmwx`3E4OrUtd9XM`|cVS;}w zpy^V?_N|ygT2azWHu|vY9L~B-92~p6`0JfB!h@dft2IQ75&fb-)rA8IZL6_=q4YVb z-|sAcG_zy?JiTIDX00>Ed!Rc^%dNXOjmIO+!1vHq&fS7U?;xrMR~^(C3c0IV_~xZ{ zwTt|IqFzu1T&D4p02lNe#a<>FUz4w6F&%6f3wY5JYW;svYOo8Uv|Z_PhGtJq*P&1; z;)9BAj{;=?^qH%hgv*M(;A1QYiw^$Rb&>MZft(Ca%CbVUFZK8V4PSMg-Cr2J+ZTej zRlz#D!AMMQdEXJQ0GZoo;kM^WhVpW8hB@WpM(-FdXMBH62fN|;E0JEmSemU0=hsxL zj9`%-$|SuJ;up7OOQ>=RaZCt;Li?$93x_BOtEw72>|!in4{%D7Yqpv?O6G>inl zpB*uRv=lCV6o4jF>TY+V%KtI+XWq;COONRS2? zIjuZ71XSM8i6>&Lx!WpLCn4lKgQ9GqK@*pfyUVPrk#eedXY;vK^j#UwH7rbu30r~} zhgBV>xARt^aQexRMLSqxRs$V$x3^Y-qj6L-iB^GLWO|Z$Q??bIwB*vqZ;_J5|7uG$ z=AXs<*-!syR(J+@(h7tbtH-9@(^(*&)PymiZ^|Q;q|p7asAvB&0Eei)zl-9d%c@Bv z7h}JS4FSvrW=Z(9Lu{4?F$t$ioV;DmWtztw!=Q_QC);77nKIqhw%By#CJeGA(e!Sq zyg=l@I@#*ZLQMgNm(;+>qNm4TN5}{NJQ1{tz7kk=lX9Iz*#8 zELkZqeAz%a4MA-o5>(_<6bSL@af%SOm-@PH*F9nBc}NhwlXtbimwN+q`+pB zYM0gtuV)B$x$=`RFRXjkz=Q<{OVHACuUw!T>nduMM=^#`j6EtbM~dCYs|QQ}TG$4~ z7Txrfd7Fdy2se@@2F(LxA*tV_{@Ggsxi%1~zc-hjZQK7$>VIPN+0)siJsY~Q{X{VL zPd)>OU4RFK>WQQAeTE|aUeTakEzc>0hL@`xZ?Mn~?OdegUt1qI;AxF;$y*(;M$tt8 zdUbcI@PpO6aB{dux=wS^2#1ojonXaf`;tHPB+r^UibxCWk6m@IV(TPY7TmbStx~Od z%bd}`e(DA|C8bgwv9^+4-G0%vHLSbY3v&*O4a2%Y8D@NIO)*2N$nbyb1X zE!s7H4`#Kv)4)vF_K{ku?9+Q832_PHfFEPL_jo1*a>LRoU*6`P6fq&%J9PR8ptT0z z7ZDJM5c<$B)=O>86ZWV?@i1`iSKIW#4?UU-HlrNuuN_O;I)A3E7rP8#CkR2w$x8BY zPL(;tz95eA`?aGN{MVxWb5y@c{i9g}Jm4NmpK)*~(12C0`Ee?t;fzV8zruCoz5iz# za##+abs;0Rup(QciyVrF*Ty}n%Z~kYnC8pu8?mAgu(ZA20O1kdok^rEYCojZb5lw{ zj;ht%m@SLLHlx&Db532Tx#DGDlo7R7!3UyT9=U;2BHi!XP>Ka+%i#4x>?fDIHaqw5@a#fke$R&#sg{C?>LrzHXtzecO~W2Bpu zhqU%>F&mJG=Aobwsux&-u2>j94Z~3E#G^fi@RQUKaIwEOx7V2exc};Wk-||Mhef9BJJ^yh z>L8Zs!(s9@FU5y5v+MWkA9N3SG{4TEEBstC0oh=Ud232gVrz)){5RxJ5iWrb7?^;f z1pRWx=7N!hq_b%=4)c4jT=@s%-vdA>cyqY#Cjltohf&=_y+$14$@-gxbTEpKj8j;7clQYWsL7E&R(Y68P)fDwkQz2jszuk zL?yG|xTzwk`EyFDiM|li#n&X>hS@C()lw(gaUJ9&D)Z&6Zn)xV?-x00(oOM*Q4WOM zxcU!$_f_&bD{Q?^TRUzj=8Lu+S9u!`z}4_3)IBC~N{X`=Pqyt2^7us)!Nym@HZXbl zohFYF^j{tQmqYlzvlC5(oKB6buC-=I{hBQVYL@19BtLgF_#HtX|Bdx|j`=^0mFIL% zryfDMh?{Hy8KD2bQGOnkPXG)vVC2#{?L$H9)tF%R)0v}0yHjm@|89=IrEb!+@d0d&E1<~h ztz`J5BSGH@-0VBFwnBkPulj!g8xa?m?vG*FUcSc15dWGVu+SLfTwfByAjyxGR&$%* zeA^4t4)61g!*+Y*y@KB=(wx$uinh*FL`y(rRkFL~V;=y9eE!4QRfl4_CCaxJG@Put zWVBK_vIyPHen=9us$Yil?}745%%9fhk7hpOkYKrJU6f*pZv7$;NH0S9O1_VA2XN|! zq+fT-)l4#vhM^Y3zGEQX|2mX9{yLd~ohZr{kn z@23SB?22*~ObMh&?=6m`b=#Eq*R_vJL3`u%A6j<1vl%o0Yu`}>h4oJZ<&Sj#Fi=33 zJcH=L+l#ME{FqF@0P^5Af>Mk2{iu?Z1V)p?gx$d{YP5?;{uWFk5G|IYNc!(fDjJ+d3^tK0IWW&6mKX-iHk9+a6>uU4jlUjTWF0I|kgYMaiEjP(&u5pPbr~u^!n~-W1a}i3_J%aQ? zb=qsB`JmAq~PUUb*C^rer9y;si1+%}Zr?dYU- z>3#6jNNosj-te6{<5=G~d?>OPG{o{rA3k9rV)JyY8S)_$-ZhX?C8e!x7%>d6|4yvH zpED89VSy6+JWBrWls^CSIiGY8E~+=C5?4t2tDd;JTOwjGjlH+a5G-I z(Pyq|xxX<0y(;s1598D^MaT}1nnY=T^4^$!1StGnFG03}(&pv671Yw&#&xwUx-(dP zL%a+d`&REMzt=?u+18H+ESZ@~ThVe(jGy0mZ|FRyGzA<9QpFV31{@Y_uF8cmR8cZj zrs$1eOji?FHGYygt8ypiVhi=4sUCrzb9A1j0AzhZ11qKMCLs}_q+$urA=6mEv~KW} zlwa+nsONCtP|g&dc}8C_ptBKM^j;W`dQ{XEt<21H$Zm=`b_ zVV9fx3q;h!>6 zMFHcr`D{#@jiQc*S=v%`Z_`t6xTZP3qa=13>-t62NAYGIu}=W8_NSO|^<>`Os)y2Ojq(yk1>`!&nh{@3Rz%pA>r z9m)#<=lglk31n&h{ShZ92o)f|A_Ok@Gl`yh&_8lS9|Md-VSZ4542#h@n0#PzGaJ>{ zkvXQIYw}&tx0*#bG)e|%XgRmd{t+L2z~`9fN{r)N7+eyRE+Ni@(%*`j41}7E_Ott} z^)>1f;bjGGIX5l3A*%@g!5K2o$;{i^x+q$3xRJ-yRAc;Flw8ohEMjf-47uhfL~$L= zHEV~?4uN9()m>}cubDHOTpTy{-w;*SGAqvr7LmG&(vt_QRpb04H0_VzQ4BxybAPzc zo>i+x-q_N>#zC$7A?7tK%gDnM)XmRMhF1&lNSDNY=c+N`RrlI*Iveky91ks~{Ayl& z-J&FPsBFkkCCOl@C0stUV31A}+DzB-d@cG|B)-tl3IP`EnZjU6NK~|+eqIHr`*Wv& z(dg-@ly5(XKo2ZCB47xTL?A+i;Oz^IS3BdxXHtRKU>SG^;ISP!Jf-3tiDXc9IUDB% zVBny8f&JsXLIBTdJ49daCpl%91YLq<+1stEBIBo0+Y{PEAV|Krht`g&0LuYwyU{m!D?{*=dDfE55SDoy?rQ!eiI86vR_n+f%AQE2uCszIuk+xA-u&lX(U6Edo z!uR{>f*m-PlhC-dnRg~6m!5<0jw>5Z_7XwCvF2fC#BGl5Ox6fY+}z)nI?K}w_o?s-{VTo%qKr`6xzL}iAQia?RpQCNau1~z(Z>lKnAw9Jd3wo*&w z%iK#2d!=JGYnTj1s%Ay{EMcJEt{#ti0gD$`V7`Oh^ zNRW)0Hr@AQiV9MZwCLQLaG8J!nvihv@ItGvk7{7*?UKz$l`iAS=7UJ>jgJ+R9lL0i zQQg{BVSkWU6HCX;LBInXz*&lnF z2mNm~{AYGf%hzvmjgLPR(1XCq*1vfrQ}UQv5uC`O!kc%y&@lF&5dj*4z(S8UBy&Vg z3cV>%EQ$yy*QA-s14{*XPrX)9T#Bo`SJ2qOwfkPjv%39!ujaoSXrq{wYhjXIK1?VS z`4?ktOc`cUiTZC83)HnW_mwFRuh(xQ?RlIGGeTxV2v=g-+0l5?hkU@^A)u@-5r$>o zF_V!tg(YqCtAARr$-EKISDuRo??C#Lp5*HS>^W;lv&4Bo#6;4!4*{={yrCa@hwrr( z+NDXpaSPFb@^$LX+r`o0u9Wa<--sunjzf&1hKL5VCo!3R9HS4Q>76UrKwx&2Hg+gA z=>H1nKsHzWZS}SFY=uK*fCORyY6X+N9p}jxLa;gJ2t9n#R>bO~P=Oh4`bx(+dKGQi zKpDGv-YGd?YUPUzOXmgPYS~#04ylcE=$*M?DzQWqJH8b?z zY!6BJ+(Sl(C#o;491~ zq;)A&WC(;TS(0@w zt8&QNXx+ULx*H!M_^2`3d38(paWZ;)MIR0Jr6gu=B(5frc;`gA(eXVY5s%*8O)OrB z2#<|CHS3!N{-Op#@Na66R6$k_oc8ZA*{T26dXI`JlInANRNON+)l10LIKGB?dWFED zuy86Pf%Gyndy$pi^Lk6GPE=SA>LpV4dN52kOH2#Ehb=BH=r;XXt%*bYc_) zKyDgz=C4A4DdqE*D_5RgnYdkIKT`ys5oqQGyw7*4=S4br`wdNw!UP8(no!z~= zqx^;%-6w}L#+YF1q4Y+eT?;-07v_B(EUe$Kt90%DBzuKg+Uij7vQY$@@0ngj-YO8C zLmrBJFGc99| zh>^PAA&1yT0al=H_k3tg9Cu0&oA%^{!t< zg^UF%s*Vw)%>qsP6oK7!1V6#djN#oFr0zYh@YPcZ@x)RQ1M-nQ#+oK;1|FN$BpwWe zqJ|_+WwyOa(i$kQ<4(T=yq*>vVgIh4gaLcxJI{F4b?@*NRqNw%3Q&M33=O6l^JfZa+wtj z-tm98Vq~m;X~hBhFc0wG?6PDA}*=jh& zmwh@;G1NlRf~bk~sNf&dKzN~HKo9X*eypWMSBeJ<39n@Rvv8~BH%ZJP z`zLCAn!Jx>m8xjYCIaR5k6fqK2p0!nRP*3T6KwjLWgyn-Yi1E z^6zt5$jmH7d%_cIf6z&W8U66r3E>wLzfd(y@5#-@$L@Wl5oz#NYAj(qgQ*xRq}u!2 zjFYAB1fp5^rYk*m+LKyjxMo zE{&B}{aWIDWY-m-4f&J_qv?K4v*^s}UAC+X5&t6+BMQ$q_AyA-rCXTRCZ$GDP5O}C z2UKt9$q;plT3!X8b0kujVH0GuFxTKeHmRF5ZU-|}E>BQ=KO)^bxO!#2+YXU^Evs_0 l*HhQS+va3m7}k6~btFxa6u{b&;xsPN{%yBXd-R!_{{!{YCg=bF literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/pubring.kbx b/test/data/mml-sec/pubring.kbx new file mode 100644 index 0000000000000000000000000000000000000000..399a0414fd20ced74f3b18a964c2fdb3af1c64a2 GIT binary patch literal 3076 zcmZQzU{GLWWMJ@iib!Jsg3y2Gc7rg84FODVn1S*@u$h5@@h1Z#gA8AU((HzJ##85i zm-zQy)j`{R?y*M@wLp@ixOmEcfBW!f49pBXKz}MOCnw+1PqTrocsSuEuS%fKKQ(T(lkXn(LTac5gmtT}_XVAp>6^P>&Ff%bS zF~Qwqz{|#|)#lOmotKf3o0Y*p%22{UjEy;zg;|&%%@P9zab81H14}~_LvsToL(?b; zej@`jV*?WdQ=kA4MB&xlI3L+AMpg#q#$E=4#!jZjMuz={B6FJkwtb%1s2sX--@4NY zWdR>U7|3E_H2@2s1}8JnZ^DzV+$cUGGx2~{_rnvh!GGk=mDg-Pb!O6A-+yP< zTd&s1VmcRaF06lt{jL*5rju-KR~M=3F1UT);!;Y1oo@8{cC&&_Z2h~1<7|Z&XZ%XP z>MV8QpA~PcOx#lL+0&T3Gb+SBpWt%MwYVU#)Zp9IbEP8X=gyl5=QWrs zPd-F4@~`||a728KNATAz+S1PNbj=A!{gYAPLD3 zLYTIrVb1Zp+fC2cj#UT~Ruycp!+`khVb-*$sAwF%jwHEi^oM$e+GFx^nvN-ql zNw|uCSj7#$EZr;5*I#uJWexGTYjRL`>WYoa1;c+Cmm9IfhV}e&yUih=^!Dl3U)~}` zvznXATGXDk&&`_s?1kCuQ+Xn$Yqjj<%ELrm&F{6(TAdi39VFELJ$w2^VV|9lY!PY@ zY@iFt7HS46jRNRl3l>2MTQYOXN|P0Pbp;L_$m2_SqgBj%eD>Y)w&2Bq3QVf8kG4e$ zYaUwgQhuR>t<&{{PfL#NZ~=C` zZ*TvkZsUA2S1<6&j+rN}0W>wf0t#UBEIy=7O z+05gJ1W?EWmQEFa^0vLV z|LD{6I_I-eNBTDW?=97zevmtA{h5%$w9t-S?dN0H&U<-enY!36|D6YR`%ToX(Z03M z?osq4m-!(t4?WyISMP1<3&lSipmuxOLCz|JS3rGZp)P&y(cy(`TZSH-h2ZGuz}_nY9hI zrR)7-_kvOmDL}?6n`7OZFn&qam_9C!&GNuBe+!!CR{_)f2T+>7khM@E)#h;DT%Pq| zZ>tndA4Vva!|mYEQ14xaz6(%=wTzq0i1B*TqOFZ&F&$`aPaUO^q50690wd#&{gym2#5Z_h;>qmnUO{Z+)j$FrM2QImJFNY*+R|97QSxD(FW+2iigc)*VmgeR*rfc^yZx5W= zvalshbLk?+FY#xVa)h=rt`fN`p%JydX2rQ{1;);X(!0*gotWzMBV5mD{iTkh*_K_W zrf@!0o3Hrn-_;opW1gKdxw&D!^twfI*WR*DPHV+3(KX;rlcE2K#Vx!+6!62^|+QUr#|W$MB|HwzQ>zFB>thZ1e^N4D96K! zqcnxMOV(ZPJdDl|wL;x@X2AK0EmTq?n~=^n0j3NNN0C+-gKw$6aGFMBMJi21hL)y( zg|OwfMoixQzb;hR#I<^`jstzJBAPPx=syt;RzLRcSPm`ojB;KBM?pj2XVx(& zdsj>A;W0MyCBN8Pw@1>;#Qrz3UB^;-f{D0G^w4f)bF}dm2YPU(t22})txSmu^X=vk^1t;r3G5`d_=9;&K{#b8y*S6HMt1mkM literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/secring.gpg b/test/data/mml-sec/secring.gpg new file mode 100644 index 0000000000000000000000000000000000000000..b323c072c04c25591abcabdbc3d801ad61472ce0 GIT binary patch literal 17362 zcmch;V|1q5wyyogwr$&}SQR^|xMHJXRBYR}?WCfLZQC{~PQKKfv-VoMowLr~zrJ62 z@wBw}dB)wZevjV!NB~*{m3@zQ0s;k;B13SwRszuOn^uN==JVxTjHbKpjiA-8fCK~p z0)RY$s48*YdxT>L87%WK4ew+`z|CXanU;0i>OR`?17s73Fqb+$UHDMYpAWWW$2-a74Fn zVjnqS#D%#eKu&-v(0bmNLCR>MVKw}T9yK%8gS~;W%ozYjpwh%`-$ilT&M)% ze4ABiK(A=_Vu%=EIHi~3^RW-{C~N3;hVx`xG?%e&NE-V!+~u=K519D=sinmLJ-CF! zpG1~yOMaWnF%Ns|yAQ}}jWO9i^+cjB-^}cc3<;%-TnTxM{(d8108 zXy`cF(}BM~$h*tn&AC_CrbWi*t2VgOFK#NirYr2@U@{o=HCbj~mCZvA7(88O*(o`V zo+tCP@zB@BoTe(uVYw~HBflnuui)xL#(&`r#M}S6j6#Bvzeh&cGLKt)F0mu}>65nE zHGZ^$XFFD|BwkmZMjP<^H&>Y>>4u>eN$`z~-D)o6sDjsOU;rTFUkYx2ybBFk1U4s# zoBkF$w`i^;*Ul4&vw02E)*2kIKdKmjgkwT|(t(UcfhaJxfo|;J2EGIr&6)~v$!_Vf z;}>3LKc%qMopcHN1T`fwxp|GSI4=ZUCk=?sXmZtyprRc2 z9m||Xn)w2D+YMJu3*p5-3VubaOV10EPG$!c`$oYCdtPqWd|H_^B;p-&Qa+@rgSt)~T9bwsVt!A_hpj}(^6Df5y(H4=*0+;7yl_z)6Py6v84o|)@aQkJ3gM(_ zAck`(gxqz9rK!<6>>=XCqu)GLW5)d@7W16ef%L{O!~F>q{c1Crzjz85&~riDjnBOm^BZK+ zG}(jDQ?MziDLTJUQ}RxpzT6FbZWE^+bS9zs__UNB=-Ub zCkKrCWeuR)R=P{6e;h`obxB0$32U@bZ3vS3TZIW9Dpa;eZ2sWrPboj%8HOS_ADlN1 zN0y_m2(T1ErQ_6ApZ%s*g0GlbH%%5;nFT}sGqAgBp+Cg^t}>OOVlz4j_9@3Rr)%EN zY0fr_GW+A`hjNw5-38j_<;cg6PtgamTgsoRzmDD7d{PK-6ejnx$*M96it`OoH{DOS z4X{)82+uL?`Tjl@^N$Lj!6*y?_T-}`eePF@+t{M_z^HA+zGuzt>u^S2qb`~uT4bAq z;8d*TW>wS;S3@g=sfzWz%OhseuA;CaYa>|XUT=V}0GaAaXPaMVSvJA060>bVhm|aq zJE(`30+**5o<9?iQ!kKs9z1S?SUb}fAms)(6_(vJP{E|VQ2ggOHgOMU${oCrmbUc; zWklG)LTb!?DzYoXmr$2}KyM6H*JKLe_g})2h$Dqb*sdwRoT)PiqU9ysqP#s-r&Xqz zrn)v6kd?gj{SalzV}cp2+CoPso~x2?Jnjj?qwmP~smGVKA^Z!a9~8B=q5A;oe}`!E zUl1h*1O6?54~YIh@d?a9Ei`N;@Qfu7@@|!_hU`v0nWF>a(PB0NeT;^hbb%2#wbB=6 zUe!WR=XuN*P)#1uQNH@=(ckh}iRotOAy-`|5^~5gTdlT@=1b&C69y}tZ|0JDAfFEz zLOl1c#{mtjAI?Qn6)}ZwFpvUyOy1g0S6{9DunzwU-HsTd(bx5ydC;#w*@}mYgTs z!)4G9oDtOFlRmCV0fEZ-1X7k^snDWgvkRM@^hdbhFM(%C zCT(&Pb6h@m3~x8ioeJr#;KM;$7aUev$>Rw>jN$;OC%S~*Z5W#?bbHaMY7%)6nnkVx zAUlHdl=!vUrXA>8V+x`E^!EcMd?=T$3>QBfd=ZPyxCs%GJF4t#xV+uWFAsNPhF9ik4)KBe3%P+LRL{DCK? z0f&wD8~tFyD`pqAt=QL@`1X+GmU2!9iar=0vmrxZpnD^SEHHiLsdVY>qfGALtiR|9 z^+%Vmzq$EGeu~y0k3dX;ja<{fZHDM)_@4$U!)CP71Z7g+$h8B~0>R>(dyJS@SDDlZ zAUDs>ZYMzL>Z&2L>!=4ap1ebFVvwFWOK`H%v#U{@xaU-nQzh>{?Ko>eYt{L}go#gZ z!f$*Rr|0fbnmurk*~R{GwqJm2!5u;Q=3cm_Dg1|tM*{<;Br;1tW~;jgV@#hXffe z>}c+my5`PV9Ng6oZHaE&vNPI}K{1)jRX6Vml3}G?B!GjWYy6d7&B5WfnbI4d$_D#- z&`~V1Mv9GD;10@DbH5LsKnDHE-sr@Kw}<#0A_;Eg#8)}GWpmcxts*!nK%sNijE-ind_+OFPju9_I|Q z(M>;J2Bo24KYQjYuOIFwIeWX~bBlZ3;JBfwK5wK)du}Z%QzNpTQk&)>eQhU}m94H@)H09IER%YyHly z5J9Znw@w>iz)G6Pu-D^}Xv0?Amok0srq20pK!1I0Un%+ zO%KsKk#Jw@IECNM;xAU%GODFEGhjfcrCwtmr9s6Us}Y_2vxqs{uf z;FA%8dG}Zal{45t|HoPrLBC=QfqjOI?D4|cADY|M^&I0RLG>geX2!-wc1G3?g!Yd5 z7Dlf2gghTF{sTOJtKffvXHQD{)dvuBd4xa#Ayp z4e~$t67YcXtXgo7RfOeTrVza z`ET{st4kVL+Y?F~8JId4S?k*v*_jyG5%QRSd`NHk-#!#Dvo^M|v(j@gv#~a^v^1i# zH?q{XchEPocQCWEa;|H#Fi4{;#Z}if^6vzkM+0z##9YO5fF6 zJn!gOPM_fR)gVDqP)J&WbDZ@OgD{7YM*c|cK~&BDJF6^$$^rJ$Kf?M@58Wd5X5=Jx9Zi;g<`Z9(j5 z8S2bGVf{wzqH7qq$<2z0C%C~=^tLb>_b^o&GRf4rygG#5UB3z8;3EPUzOWk+o?pqv zyT?DcO?`tK)hZTQufQ8$g@$NSZWhO?sdR9(aim&ScQ54l^6giKLy4l&3bNY~v!}xb zYE}P!_Y>C+Fc~Tm3FxD$n!QQJEj2j+RML4d9^)$|xAeytJ4&(a!J7B=ePA+*O zwCZ=>DrT0^8IRhBmp5;vt4Piu;)OCodUzbSf?7!NUP)9=`2cIM{`$s^4a=-n%!)IB zmoJdhf`1XvyNi}A7351671*```NXdZrI9w)42AC`sprnwYV-{yqWG;TsZHXYJ2yAt zD-qPW@=CL~yO5*QLnkGqDl#Sb9eKn5GUdM)7#Qcnlml(C{Ixaw6P}F(pn!Nh{oZ0) zx;j6rE-Y*_E`%C&@O}Has-d=)<|m*D(qCzQWXr`Ea|>m@;Xen*cQ6&cJLb3!?aJ>K z8*-M#T9FU5DIzTxv8_;TK32bfi?Ubq|lBy&q}Au#UGh zw52r4AIeEk8kePcQe!Yzh2c~WqB+OmRxO8>X-WPu4|+I@C&jv@p-fbB*m8hD5U;jt z$C1;%N8C^7ovBal>};u#@w{Uy1T0{MK(GO%X(qDVL2NYy(~Uy+y-=~g>gUQS^xP7~ z9~F|Z1H>CAvTH{;I(G3sIjH&2$#%mDJ7IK;WDbAfcy-U2;j^;QHY{xTaqjvpl@^o| zrwD6SH<+n{O%3W*2gQ{wGHQ*Dor1IaNsZYF1u8#GP#0_jN+o-WC}X%QvjWSPAy%nSwgkJNBIfcdm9D@Hnf zTON>6%f%r=I##%lsGMFGn20~!8bgc?Kr@MYiwV*)z99h z5kUlCz`3wQJ3GFxoOzFe@(3uz)exAogO6QhikM<$&Gcr)`sM={bFO`cNCRtOpjFd|D?dZ-@5wC8AAVjS<4;Gk; zkUcxTTR5!B%{j6hzKa9#g%_G>@mo?Fh;`XFqOf+Oz#WALSPFMv;$Q37c@@6kkLi(n zGBgzI)iO}*qyN$$56OrA7MkpPuHt-Rt6345jfM8ls3wSQtQsUXPB3Jg^%P(5Mj!*V zpw)YLV)eV!kZ0kx@&SW|ZrnQTTJQZiv$dKNZ;=ThuBY(<2ae4p4K)tA2nZ9Q+jVmr znybZkL4!4tSnQ?9yLI8W5qR6oe8h>qjJU{kjz#ANN}&SjE@O)Sr9a~Aod={xS|d)a zXZF08Rb$RK`$a~BMae`-(#4%p4vH%F^vsta)aa0pCjssXr=(39^NFq>~G5TN;0{zFn<5b$L#UccyN z^(*HQiW4BHsTKi^seCx&CFGidE?*sGp*|Ki)5zRGv~LpKeX(s2UG12tv3vL!bgroh z9ZZtaW6|-5WhS{fYZVqA{xS4e$b9Vl)^4(Xz<@Vn50vnU8v7?o((s29THQ=FUY4Mr zPgy12w1&}-;XWyd<-U~eSB+Nyae_Y6t&CSwNx!!2uGlRo1sCQxt%wf=`?S!;`0bBx zjym5|IT-$Y1xsYUT5T+xisG{K@Eyg|io|awk4K%Q9fRuMwWy;v@wk71R3_Z*;5&x7 zD?=U5&ixk!%i*$-np~XSfcmbpGgCA5Z)|!!nV$1Tn^6dP=yBo)~Rr_)!eXL|nS$yYv04u*{ zi;jMa*GWs=)(C0=JXnJ%D#Q+_-Q1|OYN4~Q{rHOHXn!EZTyvAIz*@2KTZIWgZy!6n zq^J)S-a1(91+A&83G=hICdZ8e7x`%7dbGc=V3&6Yqv}>&le@K&yaz{Rkh9Y^T+fFo zGs8IL5v&qd?E+EWnjMFJDj_;Z%lhJZ2BN+DVc&z>4>@B!FW<0N>bQ&<7FOyhtK*IW zQlOpW%v3KD4db~yE~xa2K=e#=L@l(C0%sf4|Dxa<2newL@wZNodG7&Tx^+g;Ck&um z;B#SIwu{KOQ?B88+^`PY(d|iTN7V~(E?dW_LGr*o7!F?(pU{j_Lv@zw!}=Wp_CPGR zn`o}`EkiNgS?cFcF~Iy|&*i1MaEz9S+@bRnnCmF$rR{UE=>=8qwCKL7?~F+l-Q&>W z?p3;|whG8|0e5tr1nfFahJzyv_a1#=BgoGLk#v*9q8c)Uk2pcAtZk&VP?<7o8kaw> zz@rbY#8x4VfeP?BSvC2_JlORtivy&Wg5@_FhKRdtf^dF9Ui)0+pA-G~rbkGv@d|@1 z?sN$syD6fKq`00zqrR9j+Hr zvM^ZYRn)caLn6~H4_J6_X!u5A-zSjIxqrJi@oltFfzo#>{fQ!p&v*v2Oec67^*NDquJ`+YqWqh9jF|6s*`tL1-koIcBI@>MSVg!TNOfTVM|fjyxEd)m)nPxxo=N2}0hl|qQK=2(OZ zbh0>28spMN-!d0pI)Rt^Put@XXUqdvwYN;?VRq7PrRbbizzsXpii`3xFWhOrP8&9L zn4YS-fYh{A{J@S?0gj5?6CWO=$r$Z`1InVVN2NTOy5nL#o|il?xsEs3qs2ThGmdBvWfnn%ONNMlg^0r37ZT0DVN+c*8Vss@S0nwWM z@j-f33SO{`HlVKDIrEjL{LGsZTWP z-plD##(dfF9^9Ss(ifqt*7Vubq*4*BfJY<%u6o-@btpjVKulBK^Y4W6U!nYi)`)=H zJ=su*KknsGolu}ST^F-x1=NstQq^&n@{|8Q5@+d;qk2xls?pk#Ivv}SsJt&AG0vB6 zXwO@ak+11O@M}$nw+{Z8so9u6Lo(;E4UmBdBx_GgaDGgkQ&Wk9_Sy}G(XatI1#kZf z+@?$Gj1CDdrO?Jb?F7xr)rR5vKSNnFDwBO9>J$Y6x2so&%r`zE0#&dqT}2O`@?m^u zkW})`xUTCR_*vv_zH}9_waGN`=#wj=KzC}|VimQ8-%7iuT~(Yc2F+-XM|70FM1S2N z9(Tkp!cxm*=Xle!MI}|h>BzvD5*<730oSNf#SDIt7=#-1n9j_hdXF#h8!E0BINAwA zGSsF-fAI#(bKVwx?#9jFi3k-x$M<>g^fpNENtRxgTM9GnK}Ye3uyNd)3vjm1!yBMf z*<6SB%)XM6X8S6yKBI1|_(tos$>D$$71%6Ni(zZY9}LF2pC}b3ZRdJwIzix`ORc;& z${E?#W~6xgJOekw9U8gOORyVRF>oD{w}Q&137m*@@+q?HG@pN}^Q^p2noNI_9TlK5 zxNJOhFWTu2>OcBs?)zeHCin`%2LELqEx{oJ=dGYZ(K`UabO%R`G#0j`PNOo&B=$g7 zvA;}tx0layx^#=Na0(aVU$*D(82!uk{0T+RIFNVwo*rT)AU|>%I51&RAOzA9>r^k* z9uUH>hTN7>{)8{@ToX9NtFqyzwbJ1c*FU+IVZ>3o_=EyGop@O(31yJFCO5S?2KD1{ zl51rZc4=7jAGZr&7KMUl*V1;Bjun{X;{pOM%y3~!>c;Wm5;o56b zs5$-mJK=oP!flk=J`&Dd+DZkohB-tGnyZ}IOuz5V^NvHF0!`|$=xn1-0o(VPc%R6) zX%xz2w1ZRg=${=lG^SO1G2q%`_QJjh=X3;`P5vF)^F(I1W>zp)V}? zpF^D=RIYEp9OSp8m}wV>z+3j<5yZSFY(v%G>o0r;iGo9LLsQoNW4p=wimPrS=Lk2@5j*WApdUM%;p!1crSR)dmH+YN-l-_hWP1 z(h}69bR6M;ySnYGdxQQSs{6u$T;Oz~&;z2%NxzSe8^owb6-xhG>*f&9yUE&w3(Kso zQOixh5c>*5(gI0Uz0drU#>G>M0AejE(Yz2H4D(K`GNK|Qo#NNx6+?}*AM20nW)__8 zTuMuq@2T%$FTgp>(l&Yy9K){1kotsC?)Yx1ib?hnn?RZNn<~6OZN=EZudv zLPnIU>Ey)Xdv#h5@K2aYD3-imEjsDMTR`UqRG__7f=xBIgJwN@iHa(cstf2R>eBPSb+kEW@LnIR#M-QREMK9c2sNFyqXYJC6Oo8%w? z1&k?#t1kXZ!n{~2 z(l<{68+VvIuANGI9%S3a-hdTUG07CgnOn;}pkX$RZLhj;cw-nin+O}TBVX=4ycAZ$ z&yd%oQ!SYAx`Sz{upQ!*BgB|9>i5_5N=kOx7sKyApny7T6xqT>W+i zWJ&W3>Ff4Yggm$n=2wC{YLzbA?~<|+hz3g`RGRisFPYfxc}G-T!0Bl-H4n<&dHHzv zZJ+|o;Q-nr%co9WBv-_Hll-^f9n}V1YXRj&>2CY8?`Pen5Sy7-pzzllfzgqK2L6Lv zo;oxn64;{YFyHXPng7nO|3$9xAPK`oxo=Wmg}+_nP-2{k5peMObg+SY%e)g|4a=^! z`VW6z+xd2;(^J_Y@*pw`@~O8bjoF|q@LB}fp(5sO-O{5wOAApT51K@cahq%|-Lt_X zxh!Y0lH&DP?DJ3l0j2MH;vALVux@!#T32I3B@H$M4YwO+p-6gZ#bc6M{vp>ZqACd| z`Yuy@ZJ>SE^h3$>9%YD+$j73*bT|oKzxD{fE{YI|;t05(uqC9k&1T|8l z>Zr4s%y{ZlrnHu#7@bKSc#Gjj`*qDEFT9tBd46X~a3Ftx5E+e&n5=TKNj{iyH{VpM z$yfD+D}sIebV9vtzVbBlnZ!1y2pbJk%WQ`kxStq)@uQt`J{rFX2qAqWSugY7T$oz$ z`x1^YE*+d180KM;EUf z4W%SKbSHK-4CaM#QAeF)YOeb3ek|& z=trsDnkEpC>_86Nzh%z9u=H2v{6im13s68d>Z`MoIBn0038|&p2EhcPt8J4)e}#cu zdWSh1m05o+xmG3<(nFVHRTq`p&zyw-`nw{g3b~6bqP9XPWlB;tA>(TxlSp;2A0RGM zDnEg`NV7OqOL8b$Pir)aGKs&>8BdP+TNMwu>;mzsUB_P@<_+Xcsqks8KJ6U1rK95h z$($;S8h9U>bCs#}qF~6WxiWRLnoZbf)ywHiJ%+{LK;9tm?OrQbw|xj2;mLS22Ucj)rx9$GJi5B(ajCvz&fVN_Ho?Q!D&9~ zh^Lr;d-xDl?QUnyER?c7Wrr-w$j>Qhvpld@cQ+m&`n3tKv6?Idwv%;kJii;N_M zULU3^5z-y@-hRXP*UWP*r+lZ1-oz-8murnB#u;>~L zCcb~?fy^8H=!P7zPKN~Hp^lcRnZ4Ta8Ye&)4Zi`w_3E#Kn^qzKTm{;iV)}^2jXL;U zprv2c1VP${TD05{_|CeCQXME!(=&hpS4~RBHDj}L4isII2bQ^-i3Pwt3a!m~pUnZB zo`>*-tm8OJgF=iPryD;oFz6Fski$nFF4V~d};K>=asKdVu@nym)pKEc2h-c=%* zL~yiih|!1RfpBRuqZiX8|cEhocCnW!Gk zQtzWJdqVh!p8u$~?`qBzbpTo--Bkk=ky|Z=cx6y`(Hw74w^Kp^Y6#<0Jk0}?a0j9L zCBhV$+?Ou260LR|?@GFg=>*NpDEjO8vHTlILTxQ#ZSNRfzRVQQgn#pmpp~t#Oj>c$ zTsHEE;sWNTL>v^0w21EBCEihQ&+P^*%9wU>fa21TsJi*YKk9uKKZaw_=zQ8Et#eyO zSLWy{!3m6$1?^fX?<{E`6UqZtXimTJ(e7@FE0sen_HWVL6SF>qM2jn&`s&Y|HF7b| z=H+9i)BVXgRO=g`*^bR66u>d4P9uMWFINZ?Z`_eIEi@G; z@cl%kkn^EFjFu<;!Em5ILqtcYJpCK8DZeFq$&^n?m0=5xS6SId$+v8SI_c+Ki;h5j zrvtyOW=3&JU;9DVBv^-yrs_=%>il?y|2pvxeSOt(wouzcO1eRllKpS%?ATfZ^XgqS zjmCv*|Dxyb1^%bp`bU3ev>@+am{*zV^|4>5kJEDNuP@@Ui8659HRW@6K#@D~Yk(Ao zRE9&Is+WFwD&6kGf1hgLQvi}^YUkwuUm!imMEcb1V_!lIqgANHq)O7Z{%TJ7_`2 zO-DC0J=a5iXe$Nu%X^f>S%W3-|=yRdE-DKrKl^wR&Qw4{qyhmh&y|RM5*lrRx8Qq8e zqMFZo4*aE`9kWf914I;k!SCUbK(^Rn$Ze;Qio&h7G+c(M6}FjJky&fM8<~5!szd2W ztn8o+2QyYAE)eqq12!LAeUWp%y-7F_Gd#16@Je`t)teAG)CZae%IJM%BCfEtUC52n zVc|qCVTY2n|2!c-Nci)_>0OJpeDQ5L8v*EzSw!zOD=11Ax>kO^J{~4M#kB{OwFi2z z*8%*CgZ;8ZN~ZZN<&CQWd?l&@GKi~xabBopx!l_7Q;_>Fg8rr8 zqEk(tRN)_QF#M1?+a&gX=JlvvjypvH>F2|y9e~8FMr!aLFSSB@ z{iqf~wL-1P^dyt!Y;$UHv6X^fkz)FP*LMIQugLwarzg_~$hsF{CXqhH%9&E5AbFp{ z<7SbpkbNw2-ki4|Dz4!Yrg)IkfU|j^ZH}fG$Oc(V5K7$;vzS2PPbNInI$ZBUnFzN~ zYg-FR=PbudLTbu->n_z4tlljK%Gy~5Y^)atFcjz=%}s}BslJpZx#U^3)JJ_`94NPj z^Z^D8oA6dx7o5Tg3CUo-<{AJSS}YwN);aT<##1dCNjd+3?N8P!l%K`X$<^kd4|IoM zuU);md(JXYws$b`?s<{}2Fx0CfLaR~Re2;fj5<@4+7dpXw0az@(j$o~v9Xcw(^0fK ze@YyRMaaTq9;N!$6<@K+h-E163R)7Kz4clqB5`dgTP z`OiQ4E4l=ER||lcXuzO4&{!gwR)sL2Y0e`OBh?IA*0N#q$HZ?K=q4?2S~rN~pc{~| z#D%y6wE;FKvVW8lhapHzSg(>h|cdkKnOj13|IYl?Nj?TeXT9b}_yt7iJz zqUBM1gbQIat?Cgx|K~ph{p={AAdPR*w4&73J~@z2aBVZQ3SuXXj_gULh#M1P`xp#K2a$sS&9<4-o-bBOR7YoGs#;RX@Gc{gcLQLx=E9n!?nYp`ve4w}jb3Fn^ zVI`C|D;zfJZ9X`}A&bOK1H0_Z?avG$d!!Nr^Mj1ON2B`2aahd)L0~}dr{{#%B@I=A zin6W|u~?Bef<~>zg=DE7G*HAu=I5|%evFbi)QXv@)?vO%WgZMiI_^`&TibrKO|kEB zrh8Q%!(ig8oy}jmwIEk)_4Mpe9fewFQRWxJOW&z`O!o z?j2*0sKO>Ef`e;yQ*=6OKl*4`5j$9HMvs6&`yWLk6@Zhe1jFk3(Ho4yU%NXuesS%R zl3Z+bp;s?l_HWDI_E%B;RNI&spvOMa3p7jZO*O8Um03^mXBzyYu<=3Af5yRoS2q6d z1pR-p6AV~o(K79K%XQ)~5#ZMDJ$T#=@&Z#cbvk)STddtD6u7VEF$2@cw$Azu9qHKG zNnBdj;>ZqLZHz)vIs&9mbFUgFSh*WBhjXm^A{Pm7I9c5RQbe*pxxF`e-q2o9 zocD0zwr3qfBhjqz-X(6Ge8WrPk`l7L2gD&MmHd?H2hr{0sHWA|`ul@0$FSHi)awrg zgZwoO{`!Y!*&`-!Sv7>+O~BQu9vS|1AM+Nx zqM<=K7G}-$F%6#Zru422c0$X140PCQ+I7&v7v72oE7mNrDEqjl(x${{;3>A5&VLuR zcL3>UZa0w#^J0Rg3!B=ix;-qMUI7d^yA=`7{UvV@+^Mam#T|3-ZS~S-fOOt)9tq=e z9kaCQcBPso-!t!Ea)Zj*0mY;}tbXSCjANM0#pzaopq1a|<3E@d(RWAGwU1P}w7kBK zp285;a!A$z0;dEzx>$|R0;O16cv({-Ty)`Z7k!)YexBh42uq%dZEhHv`!SAEcb6Ie zi=e*|^$$V+=&unP{A1 zDFk=Vt!G51J)7AuRkrMV;o=ZL+CiVcz!>-5G~5n_FI?)CAsI-HqWQvv6{FoQ-RFar zocd4`*_(hUJqoqLApBe|slf|;&8yBqW*xRF{q&Y37YcaO*ML76{Nv}Xd=PXzlsAqZ zcWM4QY?qm@!~pe;UBK($Zf>J8Ng;g&M|3BI)OK7y zWt7RK81yTO;r$e3fKWMg*Wed+tS^$PyJJ_+D`@OyF!VesKfGQeT|T>ut3Q@78{t#F z6gGkN8I>Z-7RAp((3UuGsZYTCL(pdkcYlfH%aHz6@zDtuYtS5$Z9IW&$s<+_Gpp>& ziEY5fn&e9qq6#sHT&@UbMlb`|l^nH-?FI)9IJH`6PLRS^U2Z3_*H#Go*H8Xo4rS3I z#Xx~uijz77V%o(v^y~EXPs4Z} zva_^AeP&=2ad^eRr$`#WLz)+7XI~$aV9Ms>ldS8}6BCv3U!EH&O*!HrSP4E>6aePT zRk=^J3iS8;@=*ie%8v)hLRQI^(ezL)-R!da(e@K--!==4!4YYLk`*paLgZU=IjW{` zD|!lX1pylqXAekrvs!&R>k(Wg%%AWoha0lj&9kVR7+IDpube zPVT(m*a=}K@gA4&x8emRX|2`LXRe7nkNTqFxG`ZV##wWH;t8Q4K*IlZ9N}YyfpLKU znS3h#7X~v3L9u{<0pK4e7CtWd4aoIjc;L2zY*uT}kAn&vCE!D0``Lb%jzyo&weiG8 z5jZ>4H?Ri2^xZ^TP~qd=;o-V6hTpu|1L0|n%ZX+cD??*Eb+f*+WNxbzp_WpJKu&BJ z?b9!i!4h5N${eFsu^vrt`i=UGm3+d)UZLy{iA@xE*;vLJ_lcV#Em{#Y+Pw2lw!o>nUph z!O9R>>8BAtIy}|!Ngt$+h|3B=ApYQ!=Q=q=k2sgaPvr$-GVlA7)^aR3ui$~(t7TGq zbxcNy@&~|*58@EI;mdLI9XDyvrSaYO%^=NVF4dDcWSPHuwZ9>)vS>l}5hS$))_z;k z7ce(QFDR%W#R=LKbS;HrOG%fr#;hjKo@eC^AH^^3HT=zpr~ZjjVRKYY<@s~f zUg4ygi;F?oq-%}nxJ_xJ4!*Cnc&CyAFc+_AOh$!mpo!>Jwighe(dq^PrquDDAbF$Q+#iWI@5QJIx#+gRznY>cO~?>t|0WdjQSV#5osJFSAeIz9?dp+^Gi%q7ZSKpMX5Yk<0Tp_Nm*ITeZ`c0;Mr<(B#rFmS>iZu*MPrQv`JB) zrl*D7K{(090S4^qOCa4BKby-~RXR)`iyM+vwlloprZ7&SzFteXj^^(O%;1EPH?i9U z6=UN^>?} zv~D4nsY(9SYz5vf4!(9-UFD$@q2pAPekzyI}XuK{}m(vAO&y0 z|20T{U-COhA`NBwTf*9GE1y6CQMSa&Fg%MJ;GZ%*V+=)J+$^@lq9ZfGoyXOymx}D} zS><#sKrkt>dLkOSIJOw+?f`gqY22N*H7Q@siG1>d4idVA%VEEBzDmPv4N1zFCgwxf z(jXaE=cW_Sk4yzkz!D-azsuk?g672DZ#Cr80}K9C$i>Xq z`o@p!sK0{b4a5lev#bhGJ+6|Oi8Z0}$K>)y^Y7#3f7pNj{_X!S5BYoDXH!qXoJ0(^ zhd(;kx~HCxxi768c_)YR zF-qT-_%zSRq>_tX3Vy1s5dkOqhZ)2-eW|!mSQ+A3#PJq(V{%kiS=|voXsgNN&(Xld zl2X~(4OXz#9%fjb|c^Q`jfr?dFIWkmfj#clQIa>T5B2J>2Tmr zy!VH8KYoA##Mk|T0AnH|;sY^^yQ_CNC?Y5M{!2}Pjt!+Tv|>C+X|<2}EsuQ=9njvt zSgm%)zRUQo!!5`SDX44AM6~)>RVTZdz4n7ZkSqpm+;+;Qn<4yaMZ(NlNJc7?B9749 z9sngos{T_!dVyPI)%e_ZRv~n|ne@Kdq={gBjKw|P{YJ7goVe(_?XdMm)ncw*G*Y7W zFnQs&`AcE!0cvOrIdMuAQ}_tSxFqS$CG&Qat$u|EQ7)xNz3CV2@Mi&-wR^=t)TGMWNbU3uHWM0X0EXZyf^mCA#w~A z#w?d#@Amf<0*s5^+U>qWe9A7KR}#(j?C9FVhNpBQ>VW zY~hClMR2qYRv3Z}Qf(+v*+ZG{-);q2N)G?!9{(2RU;FPr`tzOy1>_=ilL;rf3<$o! zp@n`beVE|%XV(l#zw42zon{yhLoAGSr6o8#8BU$lO{QhR4{#y6LuC9ay@T1*(0MB3 zFT5l%&gPjp4({H3PYnP5t26)6Wyy(2nOI1jGBq==LQjJ#%`LD+fLRgVBeg-k{(us3 zn4TgXmv=7UMxYV0m;R6bWZ&a%KVrVVtDFjrux?&Z^!;ZeX&_7qOhuRC#Pj>b_Xu*U z_1(i=sYJX`B;FW=&kPWja^?&2OJGZnbb?Rl+n~h!mN_SsgL`2Q9GmsHG3zt@S7Kbd zqn~ex$crZMe>SSGkb6r3-qdp0U5K$XRC#wZQ${UV)O0fO^ax=Tb(bv@M-ffz*|NmW zzbU$yLAE6g-`_7W(MyN@G?bFe(FiLs@oP!xh&Z0(M>A*F;`5#K=EEpMaE_zYATGWD zx?%O`0H&VHLFrOC4(;tTsBlt@i5@Uuzmh(X8#ESy#GLYtE|b#a2_a=hpxOh15T-Ffdbw))Q4%_M{qpELW$C=AV6q+5&o4 z$iN$wJ@*|6j0U2l`K`QACeTCBa5A@Xi~dX6Chh|56$vp2QT%Z zPVMA?_+I_?v0`P_CNgE#jGYcU%gDdK8Hu!ta^2!Ebon{|mge>CS>*Dr#-!xD4#$*3 zZGZZxXTEaBMQoO1QnVS&Uw+9lq(;F+kWBFaH@!%i>JDx(uqA>om6Q1tQ}$1g$Zuob zd<4k_$cUp{X~%NnJB%wOJZd#&naRYw{p`(*L`HY_p zfpk((J31@|SLeppPw;q8jYQ;0X&YO5w1X^vwpd_k7mOy!oa{!BJ>1mAt{0P_MnA>( zZ~&q!*yc5eE_Xt0I@zM~z3LuG%Z3lT4f3lkr7gu{V6sn)c{9B@98);9Vmi2oc5}yS z;T+l+Kd|z$JDU;$t&Y)1O|ST7Fofxri@%N?41H;qay9{%{wV>bTpF5`O|9R%k~PN+ z;=J`SUUbnE3-RuyT?|l4ASgiDewrcyR^{|+?(N<@b`Yz=ic1X@Beb$|@Wp9Nj{6~v z&LD7uEh`$Gy_S28&4=2H1q`?!%D;DQ{D$v6nL)f(A8|dkYzWChl&WL{n=qo*Tj*Yn z2$T$u9;^atL(%ULJ`bTP4>DJuJDcvIP}{U*mQ3>j>BAwT%(@!Wj%#iX)d>NzMEw)> zvz09cK%Rjp>fsQa&Zqoe?eE3p2Vj|Qz;Y;Dj6#Xz8YB>ywwZIaW1_o_~od!5w;StFO+hBKM)T6ap;Nb+j_0R44HtmjGaTNO-Y+3>5$l$?|PKA8S65P zR9>Kfj4*cpqxBte^iw@IUqm3&331Bdu$SeW+k8eJy&_rgaWDPBv0ARVXG#D2$+E3} z6GgMbtwHd03Ecyf3;Ps)YitTaxx?vaeVQ>Nfd{Pw$wo3uHrF-8vbv^Cr7Y@8NbRrK k8J0Fbyk>lLi*>RsUUe8VGv#)or5xyfx_WJC{0@)*56Dhy3;+NC literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/trustdb.gpg b/test/data/mml-sec/trustdb.gpg new file mode 100644 index 0000000000000000000000000000000000000000..09ebd8db114842ac1824a58e0c1c7ed2c80bb98f GIT binary patch literal 1880 zcmZQfFGy!*W@Ke#VqgeU=uQR+-$OciUhfvSU zz_-UsZO&h_wO_5;-Wi3(a`jkV*$Y*NP{zQ^z;a$eG1#|uy~9hl>C<<<*3y0UwH2gJ z0ZA3eUX9ozTl9<8Klh2)d*&0P>i4!KlUB4r)Tkho@-m1npSUyYVov87iyrL`VdE3# zX~)YE@-P-J!<+dRZM&BSz4@BxcAoRfr1MdAnOPuvm0?Q2G!MfI^V5s>XkIL5)!>VN zQ!jo+F=~Sq)E{aHrMwI`nq17T9N5`=EA@z#pIFr!!?{QFpz09Hfc`L9s`h2#n~jgA z3zgs=W;-pz1Uc3V9hCIpbn`T^`Le5&oZe)PX5&kGZobrg^*!3;)czGjHd; zfyHJktwPhya_nY$&aA!(}k&G o0LCvi^RW42wqD=XyS|gkCmfd!yO~t*yW)d^14x}B!Z08U07YlC6951J literal 0 HcmV?d00001 diff --git a/test/data/mml-sec/trustlist.txt b/test/data/mml-sec/trustlist.txt new file mode 100644 index 00000000000..f886572d283 --- /dev/null +++ b/test/data/mml-sec/trustlist.txt @@ -0,0 +1,26 @@ +# This is the list of trusted keys. Comment lines, like this one, as +# well as empty lines are ignored. Lines have a length limit but this +# is not a serious limitation as the format of the entries is fixed and +# checked by gpg-agent. A non-comment line starts with optional white +# space, followed by the SHA-1 fingerpint in hex, followed by a flag +# which may be one of 'P', 'S' or '*' and optionally followed by a list of +# other flags. The fingerprint may be prefixed with a '!' to mark the +# key as not trusted. You should give the gpg-agent a HUP or run the +# command "gpgconf --reload gpg-agent" after changing this file. + + +# Include the default trust list +include-default + + +# CN=No Expiry +D0:6A:A1:18:65:3C:C3:8E:9D:0C:AF:56:ED:7A:21:35:E1:58:21:77 S relax + +# CN=Second Key Pair +0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2 S relax + +# CN=No Expiry two UIDs +D4:CA:78:E1:47:0B:9F:C2:AE:45:D7:84:64:9B:8C:E6:4E:BB:32:0C S relax + +# CN=Different subkeys +4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC S relax diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el new file mode 100644 index 00000000000..28be3b9bd46 --- /dev/null +++ b/test/lisp/gnus/mml-sec-tests.el @@ -0,0 +1,859 @@ +;;; gnustest-mml-sec.el --- Tests mml-sec.el, see README-mml-secure.txt. +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Jens Lechtenbörger + +;; This file is not 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, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(require 'message) +(require 'epa) +(require 'epg) +(require 'mml-sec) +(require 'gnus-sum) + +(defvar with-smime nil + "If nil, exclude S/MIME from tests as passphrases need to entered manually. +Mostly, the empty passphrase is used. However, the keys for + \"No Expiry two UIDs\" have the passphrase \"Passphrase\" (for OpenPGP as well + as S/MIME).") + +(defun enc-standards () + (if with-smime '(enc-pgp enc-pgp-mime enc-smime) + '(enc-pgp enc-pgp-mime))) +(defun enc-sign-standards () + (if with-smime + '(enc-sign-pgp enc-sign-pgp-mime enc-sign-smime) + '(enc-sign-pgp enc-sign-pgp-mime))) +(defun sign-standards () + (if with-smime + '(sign-pgp sign-pgp-mime sign-smime) + '(sign-pgp sign-pgp-mime))) + +(defun mml-secure-test-fixture (body &optional interactive) + "Setup GnuPG home containing test keys and prepare environment for BODY. +If optional INTERACTIVE is non-nil, allow questions to the user in case of +key problems. +This fixture temporarily unsets GPG_AGENT_INFO to enable passphrase tests, +which will neither work with gpgsm nor GnuPG 2.1 any longer, I guess. +Actually, I'm not sure why people would want to cache passwords in Emacs +instead of gpg-agent." + (unwind-protect + (let ((agent-info (getenv "GPG_AGENT_INFO")) + (gpghome (getenv "GNUPGHOME"))) + (condition-case error + (let ((epg-gpg-home-directory + (expand-file-name "test/data/mml-sec" source-directory)) + (mml-secure-allow-signing-with-unknown-recipient t) + (mml-smime-use 'epg) + ;; Create debug output in empty epg-debug-buffer. + (epg-debug t) + (epg-debug-buffer (get-buffer-create " *epg-test*")) + (mml-secure-fail-when-key-problem (not interactive))) + (with-current-buffer epg-debug-buffer + (erase-buffer)) + ;; Unset GPG_AGENT_INFO to enable passphrase caching inside Emacs. + ;; Just for testing. Jens does not recommend this for daily use. + (setenv "GPG_AGENT_INFO") + ;; Set GNUPGHOME as gpg-agent started by gpgsm does + ;; not look in the proper places otherwise, see: + ;; https://bugs.gnupg.org/gnupg/issue2126 + (setenv "GNUPGHOME" epg-gpg-home-directory) + (funcall body)) + (error + (setenv "GPG_AGENT_INFO" agent-info) + (setenv "GNUPGHOME" gpghome) + (signal (car error) (cdr error)))) + (setenv "GPG_AGENT_INFO" agent-info) + (setenv "GNUPGHOME" gpghome)))) + +(defun mml-secure-test-message-setup (method to from &optional text bcc) + "Setup a buffer with MML METHOD, TO, and FROM headers. +Optionally, a message TEXT and BCC header can be passed." + (with-temp-buffer + (when bcc (insert (format "Bcc: %s\n" bcc))) + (insert (format "To: %s +From: %s +Subject: Test +%s\n" to from mail-header-separator)) + (if text + (insert (format "%s" text)) + (spook)) + (cond ((eq method 'enc-pgp-mime) + (mml-secure-message-encrypt-pgpmime 'nosig)) + ((eq method 'enc-sign-pgp-mime) + (mml-secure-message-encrypt-pgpmime)) + ((eq method 'enc-pgp) (mml-secure-message-encrypt-pgp 'nosig)) + ((eq method 'enc-sign-pgp) (mml-secure-message-encrypt-pgp)) + ((eq method 'enc-smime) (mml-secure-message-encrypt-smime 'nosig)) + ((eq method 'enc-sign-smime) (mml-secure-message-encrypt-smime)) + ((eq method 'sign-pgp-mime) (mml-secure-message-sign-pgpmime)) + ((eq method 'sign-pgp) (mml-secure-message-sign-pgp)) + ((eq method 'sign-smime) (mml-secure-message-sign-smime)) + (t (error "Unknown method"))) + (buffer-string))) + +(defun mml-secure-test-mail-fixture (method to from body2 + &optional interactive) + "Setup buffer encrypted using METHOD for TO from FROM, call BODY2. +Pass optional INTERACTIVE to mml-secure-test-fixture." + (mml-secure-test-fixture + (lambda () + (let ((context (if (memq method '(enc-smime enc-sign-smime sign-smime)) + (epg-make-context 'CMS) + (epg-make-context 'OpenPGP))) + ;; Verify and decrypt by default. + (mm-verify-option 'known) + (mm-decrypt-option 'known) + (plaintext "The Magic Words are Squeamish Ossifrage")) + (with-temp-buffer + (insert (mml-secure-test-message-setup method to from plaintext)) + (message-options-set-recipient) + (message-encode-message-body) + ;; Replace separator line with newline. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + ;; The following treatment of handles, plainbuf, and multipart + ;; resulted from trial-and-error. + ;; Someone with more knowledge on how to decrypt messages and verify + ;; signatures might know more appropriate functions to invoke + ;; instead. + (let* ((handles (or (mm-dissect-buffer) + (mm-uu-dissect))) + (isplain (bufferp (car handles))) + (ismultipart (equal (car handles) "multipart/mixed")) + (plainbuf (if isplain + (car handles) + (if ismultipart + (car (cadadr handles)) + (caadr handles)))) + (decrypted + (with-current-buffer plainbuf (buffer-string))) + (gnus-info + (if isplain + nil + (if ismultipart + (or (mm-handle-multipart-ctl-parameter + (cadr handles) 'gnus-details) + (mm-handle-multipart-ctl-parameter + (cadr handles) 'gnus-info)) + (mm-handle-multipart-ctl-parameter + handles 'gnus-info))))) + (funcall body2 gnus-info plaintext decrypted))))) + interactive)) + +;; TODO If the variable BODY3 is renamed to BODY, an infinite recursion +;; occurs. Emacs bug? +(defun mml-secure-test-key-fixture (body3) + "Customize unique keys for sub@example.org and call BODY3. +For OpenPGP, we have: +- 1E6B FA97 3D9E 3103 B77F D399 C399 9CF1 268D BEA2 + uid Different subkeys +- 1463 2ECA B9E2 2736 9C8D D97B F7E7 9AB7 AE31 D471 + uid Second Key Pair + +For S/MIME: + ID: 0x479DC6E2 + Subject: /CN=Second Key Pair + aka: sub@example.org + fingerprint: 0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2 + + ID: 0x5F88E9FC + Subject: /CN=Different subkeys + aka: sub@example.org + fingerprint: 4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC + +In both cases, the first key is customized for signing and encryption." + (mml-secure-test-fixture + (lambda () + (let* ((mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))) + (pcontext (epg-make-context 'OpenPGP)) + (pkey (epg-list-keys pcontext "C3999CF1268DBEA2")) + (scontext (epg-make-context 'CMS)) + (skey (epg-list-keys scontext "0x479DC6E2"))) + (mml-secure-cust-record-keys pcontext 'encrypt "sub@example.org" pkey) + (mml-secure-cust-record-keys pcontext 'sign "sub@example.org" pkey) + (mml-secure-cust-record-keys scontext 'encrypt "sub@example.org" skey) + (mml-secure-cust-record-keys scontext 'sign "sub@example.org" skey) + (funcall body3))))) + +(ert-deftest mml-secure-key-checks () + "Test mml-secure-check-user-id and mml-secure-check-sub-key on sample keys." + (mml-secure-test-fixture + (lambda () + (let* ((context (epg-make-context 'OpenPGP)) + (keys1 (epg-list-keys context "expired@example.org")) + (keys2 (epg-list-keys context "no-exp@example.org")) + (keys3 (epg-list-keys context "sub@example.org")) + (keys4 (epg-list-keys context "revoked-uid@example.org")) + (keys5 (epg-list-keys context "disabled@example.org")) + (keys6 (epg-list-keys context "sign@example.org")) + (keys7 (epg-list-keys context "jens.lechtenboerger@fsfe")) + ) + (should (and (= 1 (length keys1)) (= 1 (length keys2)) + (= 2 (length keys3)) + (= 1 (length keys4)) (= 1 (length keys5)) + )) + ;; key1 is expired + (should-not (mml-secure-check-user-id (car keys1) "expired@example.org")) + (should-not (mml-secure-check-sub-key context (car keys1) 'encrypt)) + (should-not (mml-secure-check-sub-key context (car keys1) 'sign)) + + ;; key2 does not expire, but does not have the UID expired@example.org + (should-not (mml-secure-check-user-id (car keys2) "expired@example.org")) + (should (mml-secure-check-user-id (car keys2) "no-exp@example.org")) + (should (mml-secure-check-sub-key context (car keys2) 'encrypt)) + (should (mml-secure-check-sub-key context (car keys2) 'sign)) + + ;; Two keys exist for sub@example.org. + (should (mml-secure-check-user-id (car keys3) "sub@example.org")) + (should (mml-secure-check-sub-key context (car keys3) 'encrypt)) + (should (mml-secure-check-sub-key context (car keys3) 'sign)) + (should (mml-secure-check-user-id (cadr keys3) "sub@example.org")) + (should (mml-secure-check-sub-key context (cadr keys3) 'encrypt)) + (should (mml-secure-check-sub-key context (cadr keys3) 'sign)) + + ;; The UID revoked-uid@example.org is revoked. The key itself is + ;; usable, though (with the UID sub@example.org). + (should-not + (mml-secure-check-user-id (car keys4) "revoked-uid@example.org")) + (should (mml-secure-check-sub-key context (car keys4) 'encrypt)) + (should (mml-secure-check-sub-key context (car keys4) 'sign)) + (should (mml-secure-check-user-id (car keys4) "sub@example.org")) + + ;; The next key is disabled and, thus, unusable. + (should (mml-secure-check-user-id (car keys5) "disabled@example.org")) + (should-not (mml-secure-check-sub-key context (car keys5) 'encrypt)) + (should-not (mml-secure-check-sub-key context (car keys5) 'sign)) + + ;; The next key has multiple subkeys. + ;; 42466F0F is valid sign subkey, 501FFD98 is expired + (should (mml-secure-check-sub-key context (car keys6) 'sign "42466F0F")) + (should-not + (mml-secure-check-sub-key context (car keys6) 'sign "501FFD98")) + ;; DC7F66E7 is encrypt subkey + (should + (mml-secure-check-sub-key context (car keys6) 'encrypt "DC7F66E7")) + (should-not + (mml-secure-check-sub-key context (car keys6) 'sign "DC7F66E7")) + (should-not + (mml-secure-check-sub-key context (car keys6) 'encrypt "42466F0F")) + + ;; The final key is just a public key. + (should (mml-secure-check-sub-key context (car keys7) 'encrypt)) + (should-not (mml-secure-check-sub-key context (car keys7) 'sign)) + )))) + +(ert-deftest mml-secure-find-usable-keys-1 () + "Make sure that expired and disabled keys and revoked UIDs are not used." + (mml-secure-test-fixture + (lambda () + (let ((context (epg-make-context 'OpenPGP))) + (should-not + (mml-secure-find-usable-keys context "expired@example.org" 'encrypt)) + (should-not + (mml-secure-find-usable-keys context "expired@example.org" 'sign)) + + (should-not + (mml-secure-find-usable-keys context "disabled@example.org" 'encrypt)) + (should-not + (mml-secure-find-usable-keys context "disabled@example.org" 'sign)) + + (should-not + (mml-secure-find-usable-keys + context "" 'encrypt)) + (should-not + (mml-secure-find-usable-keys + context "" 'sign)) + ;; Same test without ankles. Will fail for Ma Gnus v0.14 and earlier. + (should-not + (mml-secure-find-usable-keys + context "revoked-uid@example.org" 'encrypt)) + + ;; Expired key should not be usable. + ;; Will fail for Ma Gnus v0.14 and earlier. + ;; sign@example.org has the expired subkey 0x501FFD98. + (should-not + (mml-secure-find-usable-keys context "0x501FFD98" 'sign)) + + (should + (mml-secure-find-usable-keys context "no-exp@example.org" 'encrypt)) + (should + (mml-secure-find-usable-keys context "no-exp@example.org" 'sign)) + )))) + +(ert-deftest mml-secure-find-usable-keys-2 () + "Test different ways to search for keys." + (mml-secure-test-fixture + (lambda () + (let ((context (epg-make-context 'OpenPGP))) + ;; Plain substring search is not supported. + (should + (= 0 (length + (mml-secure-find-usable-keys context "No Expiry" 'encrypt)))) + (should + (= 0 (length + (mml-secure-find-usable-keys context "No Expiry" 'sign)))) + + ;; Search for e-mail addresses works with and without ankle brackets. + (should + (= 1 (length (mml-secure-find-usable-keys + context "" 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "" 'sign)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "no-exp@example.org" 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "no-exp@example.org" 'sign)))) + + ;; Use full UID string. + (should + (= 1 (length (mml-secure-find-usable-keys + context "No Expiry " 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "No Expiry " 'sign)))) + + ;; If just the public key is present, only encryption is possible. + ;; Search works with key IDs, with and without prefix "0x". + (should + (= 1 (length (mml-secure-find-usable-keys + context "A142FD84" 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "0xA142FD84" 'encrypt)))) + (should + (= 0 (length (mml-secure-find-usable-keys + context "A142FD84" 'sign)))) + (should + (= 0 (length (mml-secure-find-usable-keys + context "0xA142FD84" 'sign)))) + )))) + +(ert-deftest mml-secure-select-preferred-keys-1 () + "If only one key exists for an e-mail address, it is the preferred one." + (mml-secure-test-fixture + (lambda () + (let ((context (epg-make-context 'OpenPGP))) + (should (equal "832F3CC6518D37BC658261B802372A42CA6D40FB" + (mml-secure-fingerprint + (car (mml-secure-select-preferred-keys + context '("no-exp@example.org") 'encrypt))))))))) + +(ert-deftest mml-secure-select-preferred-keys-2 () + "If multiple keys exists for an e-mail address, customization is necessary." + (mml-secure-test-fixture + (lambda () + (let* ((context (epg-make-context 'OpenPGP)) + (mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))) + (pref (car (mml-secure-find-usable-keys + context "sub@example.org" 'encrypt)))) + (should-error (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (mml-secure-cust-record-keys + context 'encrypt "sub@example.org" (list pref)) + (should (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (should-error (mml-secure-select-preferred-keys + context '("sub@example.org") 'sign)) + (should (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (should + (equal (list (mml-secure-fingerprint pref)) + (mml-secure-cust-fpr-lookup context 'encrypt "sub@example.org"))) + (should (mml-secure-cust-remove-keys context 'encrypt "sub@example.org")) + (should-error (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)))))) + +(ert-deftest mml-secure-select-preferred-keys-3 () + "Expired customized keys are removed if multiple keys are available." + (mml-secure-test-fixture + (lambda () + (let ((context (epg-make-context 'OpenPGP)) + (mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))) + ;; sub@example.org has two keys (268DBEA2, AE31D471). + ;; Normal preference works. + (mml-secure-cust-record-keys + context 'encrypt "sub@example.org" (epg-list-keys context "268DBEA2")) + (should (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (mml-secure-cust-remove-keys context 'encrypt "sub@example.org") + + ;; Fake preference for expired (unrelated) key CE15FAE7, + ;; results in error (and automatic removal of outdated preference). + (mml-secure-cust-record-keys + context 'encrypt "sub@example.org" (epg-list-keys context "CE15FAE7")) + (should-error (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (should-not + (mml-secure-cust-remove-keys context 'encrypt "sub@example.org")))))) + +(ert-deftest mml-secure-select-preferred-keys-4 () + "Multiple keys can be recorded per recipient or signature." + (mml-secure-test-fixture + (lambda () + (let ((pcontext (epg-make-context 'OpenPGP)) + (scontext (epg-make-context 'CMS)) + (pkeys '("1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" + "14632ECAB9E227369C8DD97BF7E79AB7AE31D471")) + (skeys '("0x5F88E9FC" "0x479DC6E2")) + (mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))) + + ;; OpenPGP preferences via pcontext + (dolist (key pkeys nil) + (mml-secure-cust-record-keys + pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key)) + (mml-secure-cust-record-keys + pcontext 'sign "sub@example.org" (epg-list-keys pcontext key 'secret))) + (let ((p-e-fprs (mml-secure-cust-fpr-lookup + pcontext 'encrypt "sub@example.org")) + (p-s-fprs (mml-secure-cust-fpr-lookup + pcontext 'sign "sub@example.org"))) + (should (= 2 (length p-e-fprs))) + (should (= 2 (length p-s-fprs))) + (should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-e-fprs)) + (should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-e-fprs)) + (should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-s-fprs)) + (should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-s-fprs))) + ;; Duplicate record does not change anything. + (mml-secure-cust-record-keys + pcontext 'encrypt "sub@example.org" + (epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2")) + (mml-secure-cust-record-keys + pcontext 'sign "sub@example.org" + (epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2")) + (let ((p-e-fprs (mml-secure-cust-fpr-lookup + pcontext 'encrypt "sub@example.org")) + (p-s-fprs (mml-secure-cust-fpr-lookup + pcontext 'sign "sub@example.org"))) + (should (= 2 (length p-e-fprs))) + (should (= 2 (length p-s-fprs)))) + + ;; S/MIME preferences via scontext + (dolist (key skeys nil) + (mml-secure-cust-record-keys + scontext 'encrypt "sub@example.org" + (epg-list-keys scontext key)) + (mml-secure-cust-record-keys + scontext 'sign "sub@example.org" + (epg-list-keys scontext key 'secret))) + (let ((s-e-fprs (mml-secure-cust-fpr-lookup + scontext 'encrypt "sub@example.org")) + (s-s-fprs (mml-secure-cust-fpr-lookup + scontext 'sign "sub@example.org"))) + (should (= 2 (length s-e-fprs))) + (should (= 2 (length s-s-fprs)))) + )))) + +(defun mml-secure-test-en-decrypt + (method to from + &optional checksig checkplain enc-keys expectfail interactive) + "Encrypt message using METHOD, addressed to TO, from FROM. +If optional CHECKSIG is non-nil, it must be a number, and a signature check is +performed; the number indicates how many signatures are expected. +If optional CHECKPLAIN is non-nil, the expected plaintext should be obtained +via decryption. +If optional ENC-KEYS is non-nil, it is a list of pairs of encryption keys (for +OpenPGP and S/SMIME) expected in `epg-debug-buffer'. +If optional EXPECTFAIL is non-nil, a decryption failure is expected. +Pass optional INTERACTIVE to mml-secure-test-mail-fixture." + (mml-secure-test-mail-fixture method to from + (lambda (gnus-info plaintext decrypted) + (if expectfail + (should-not (equal plaintext decrypted)) + (when checkplain + (should (equal plaintext decrypted))) + (let ((protocol (if (memq method + '(enc-smime enc-sign-smime sign-smime)) + 'CMS + 'OpenPGP))) + (when checksig + (let* ((context (epg-make-context protocol)) + (signer-names (mml-secure-signer-names protocol from)) + (signer-keys (mml-secure-signers context signer-names)) + (signer-fprs (mapcar 'mml-secure-fingerprint signer-keys))) + (should (eq checksig (length signer-fprs))) + (if (eq checksig 0) + ;; First key in keyring + (should (string-match-p + (concat "Good signature from " + (if (eq protocol 'CMS) + "0E58229B80EE33959FF718FEEF25402B479DC6E2" + "02372A42CA6D40FB")) + gnus-info))) + (dolist (fpr signer-fprs nil) + ;; OpenPGP: "Good signature from 02372A42CA6D40FB No Expiry (trust undefined) created ..." + ;; S/MIME: "Good signature from D06AA118653CC38E9D0CAF56ED7A2135E1582177 /CN=No Expiry (trust full) ..." + (should (string-match-p + (concat "Good signature from " + (if (eq protocol 'CMS) + fpr + (substring fpr -16 nil))) + gnus-info))))) + (when enc-keys + (with-current-buffer epg-debug-buffer + (goto-char (point-min)) + ;; The following regexp does not necessarily match at the + ;; start of the line as a path may or may not be present. + ;; Also note that gpg.* matches gpg2 and gpgsm as well. + (let* ((line (concat "gpg.*--encrypt.*$")) + (end (re-search-forward line)) + (match (match-string 0))) + (should (and end match)) + (dolist (pair enc-keys nil) + (let ((fpr (if (eq protocol 'OpenPGP) + (car pair) + (cdr pair)))) + (should (string-match-p (concat "-r " fpr) match)))) + (goto-char (point-max)) + )))))) + interactive)) + +(defun mml-secure-test-en-decrypt-with-passphrase + (method to from checksig jl-passphrase do-cache + &optional enc-keys expectfail) + "Call mml-secure-test-en-decrypt with changed passphrase caching. +Args METHOD, TO, FROM, CHECKSIG are passed to mml-secure-test-en-decrypt. +JL-PASSPHRASE is fixed as return value for `read-passwd', +boolean DO-CACHE determines whether to cache the passphrase. +If optional ENC-KEYS is non-nil, it is a list of encryption keys expected +in `epg-debug-buffer'. +If optional EXPECTFAIL is non-nil, a decryption failure is expected." + (let ((mml-secure-cache-passphrase do-cache) + (mml1991-cache-passphrase do-cache) + (mml2015-cache-passphrase do-cache) + (mml-smime-cache-passphrase do-cache) + ) + (cl-letf (((symbol-function 'read-passwd) + (lambda (prompt &optional confirm default) jl-passphrase))) + (mml-secure-test-en-decrypt method to from checksig t enc-keys expectfail) + ))) + +(ert-deftest mml-secure-en-decrypt-1 () + "Encrypt message; then decrypt and test for expected result. +In this test, the single matching key is chosen automatically." + (dolist (method (enc-standards) nil) + ;; no-exp@example.org with single encryption key + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" nil t + (list (cons "02372A42CA6D40FB" "ED7A2135E1582177"))))) + +(ert-deftest mml-secure-en-decrypt-2 () + "Encrypt message; then decrypt and test for expected result. +In this test, the encryption key needs to fixed among multiple ones." + ;; sub@example.org with multiple candidate keys, + ;; fixture customizes preferred ones. + (mml-secure-test-key-fixture + (lambda () + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" nil t + (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2"))))))) + +(ert-deftest mml-secure-en-decrypt-3 () + "Encrypt message; then decrypt and test for expected result. +In this test, encrypt-to-self variables are set to t." + ;; sub@example.org with multiple candidate keys, + ;; fixture customizes preferred ones. + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-openpgp-encrypt-to-self t) + (mml-secure-smime-encrypt-to-self t)) + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" nil t + (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") + (cons "02372A42CA6D40FB" "ED7A2135E1582177")))))))) + +(ert-deftest mml-secure-en-decrypt-4 () + "Encrypt message; then decrypt and test for expected result. +In this test, encrypt-to-self variables are set to lists." + ;; Send from sub@example.org, which has two keys; encrypt to both. + (let ((mml-secure-openpgp-encrypt-to-self + '("C3999CF1268DBEA2" "F7E79AB7AE31D471")) + (mml-secure-smime-encrypt-to-self + '("EF25402B479DC6E2" "4035D59B5F88E9FC"))) + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" nil t + (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") + (cons "F7E79AB7AE31D471" "4035D59B5F88E9FC")))))) + +(ert-deftest mml-secure-en-decrypt-sign-1 () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, just multiple encryption and signing keys may be available." + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) + (dolist (method (enc-sign-standards) nil) + ;; no-exp with just one key + (mml-secure-test-en-decrypt + method "no-exp@example.org" "no-exp@example.org" 1 t) + ;; customized choice for encryption key + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" 1 t) + ;; customized choice for signing key + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 1 t) + ;; customized choice for both keys + (mml-secure-test-en-decrypt + method "sub@example.org" "sub@example.org" 1 t) + ) + + ;; Now use both keys to sign. The customized one via sign-with-sender, + ;; the other one via the following setting. + (let ((mml-secure-openpgp-signers '("F7E79AB7AE31D471")) + (mml-secure-smime-signers '("0x5F88E9FC"))) + (dolist (method (enc-sign-standards) nil) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 2 t) + ))) + + ;; Now use both keys for sub@example.org to sign an e-mail from + ;; a different address (without associated keys). + (let ((mml-secure-openpgp-sign-with-sender nil) + (mml-secure-smime-sign-with-sender nil) + (mml-secure-openpgp-signers + '("F7E79AB7AE31D471" "C3999CF1268DBEA2")) + (mml-secure-smime-signers '("0x5F88E9FC" "0x479DC6E2"))) + (dolist (method (enc-sign-standards) nil) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "no-keys@example.org" 2 t) + ))))) + +(ert-deftest mml-secure-en-decrypt-sign-2 () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, lists of encryption and signing keys are customized." + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))) + (pcontext (epg-make-context 'OpenPGP)) + (scontext (epg-make-context 'CMS)) + (mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) + (dolist (key '("F7E79AB7AE31D471" "C3999CF1268DBEA2") nil) + (mml-secure-cust-record-keys + pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key)) + (mml-secure-cust-record-keys + pcontext 'sign "sub@example.org" (epg-list-keys pcontext key t))) + (dolist (key '("0x5F88E9FC" "0x479DC6E2") nil) + (mml-secure-cust-record-keys + scontext 'encrypt "sub@example.org" (epg-list-keys scontext key)) + (mml-secure-cust-record-keys + scontext 'sign "sub@example.org" (epg-list-keys scontext key t))) + (dolist (method (enc-sign-standards) nil) + ;; customized choice for encryption key + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" 1 t) + ;; customized choice for signing key + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 2 t) + ;; customized choice for both keys + (mml-secure-test-en-decrypt + method "sub@example.org" "sub@example.org" 2 t) + ))))) + +(ert-deftest mml-secure-en-decrypt-sign-3 () + "Sign and encrypt message; then decrypt and test for expected result. +Use sign-with-sender and encrypt-to-self." + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-openpgp-encrypt-to-self t) + (mml-secure-smime-sign-with-sender t) + (mml-secure-smime-encrypt-to-self t)) + (dolist (method (enc-sign-standards) nil) + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" 1 t + (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") + (cons "02372A42CA6D40FB" "ED7A2135E1582177")))) + )))) + +(ert-deftest mml-secure-sign-verify-1 () + "Sign message with sender; then verify and test for expected result." + (mml-secure-test-key-fixture + (lambda () + (dolist (method (sign-standards) nil) + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) + ;; A single signing key for sender sub@example.org is customized + ;; in the fixture. + (mml-secure-test-en-decrypt + method "uid1@example.org" "sub@example.org" 1 nil) + + ;; From sub@example.org, sign with two keys; + ;; sign-with-sender and one from signers-variable: + (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB")) + (mml-secure-smime-signers + '("D06AA118653CC38E9D0CAF56ED7A2135E1582177"))) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 2 nil)) + ))))) + +(ert-deftest mml-secure-sign-verify-2 () + "Sign message without sender; then verify and test for expected result." + (mml-secure-test-key-fixture + (lambda () + (dolist (method (sign-standards) nil) + (let ((mml-secure-openpgp-sign-with-sender nil) + (mml-secure-smime-sign-with-sender nil)) + ;; A single signing key for sender sub@example.org is customized + ;; in the fixture, but not used here. + ;; By default, gpg uses the first secret key in the keyring, which + ;; is 02372A42CA6D40FB (OpenPGP) or + ;; 0E58229B80EE33959FF718FEEF25402B479DC6E2 (S/MIME) here. + (mml-secure-test-en-decrypt + method "uid1@example.org" "sub@example.org" 0 nil) + + ;; From sub@example.org, sign with specified key: + (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB")) + (mml-secure-smime-signers + '("D06AA118653CC38E9D0CAF56ED7A2135E1582177"))) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 1 nil)) + + ;; From sub@example.org, sign with different specified key: + (let ((mml-secure-openpgp-signers '("C3999CF1268DBEA2")) + (mml-secure-smime-signers + '("0E58229B80EE33959FF718FEEF25402B479DC6E2"))) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 1 nil)) + ))))) + +(ert-deftest mml-secure-sign-verify-3 () + "Try to sign message with expired OpenPGP subkey, which raises an error. +With Ma Gnus v0.14 and earlier a signature would be created with a wrong key." + (should-error + (mml-secure-test-key-fixture + (lambda () + (let ((with-smime nil) + (mml-secure-openpgp-sign-with-sender nil) + (mml-secure-openpgp-signers '("501FFD98"))) + (dolist (method (sign-standards) nil) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sign@example.org" 1 nil) + )))))) + +;; TODO Passphrase passing and caching in Emacs does not seem to work +;; with gpgsm at all. +;; Independently of caching settings, a pinentry dialogue is displayed. +;; Thus, the following tests require the user to enter the correct gpgsm +;; passphrases at the correct points in time. (Either empty string or +;; "Passphrase".) +(ert-deftest mml-secure-en-decrypt-passphrase-cache () + "Encrypt message; then decrypt and test for expected result. +In this test, a key is used that requires the passphrase \"Passphrase\". +In the first decryption this passphrase is hardcoded, in the second one it + is taken from a cache." + (ert-skip "Requires passphrase") + (mml-secure-test-key-fixture + (lambda () + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + ;; Beware! For passphrases copy-sequence is necessary, as they may + ;; be erased, which actually changes the function's code and causes + ;; multiple invokations to fail. I was surprised... + (copy-sequence "Passphrase") t) + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + (copy-sequence "Incorrect") t))))) + +(defun mml-secure-en-decrypt-passphrase-no-cache (method) + "Encrypt message with METHOD; then decrypt and test for expected result. +In this test, a key is used that requires the passphrase \"Passphrase\". +In the first decryption this passphrase is hardcoded, but caching disabled. +So the second decryption fails." + (mml-secure-test-key-fixture + (lambda () + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + (copy-sequence "Passphrase") nil) + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + (copy-sequence "Incorrect") nil nil t)))) + +(ert-deftest mml-secure-en-decrypt-passphrase-no-cache-openpgp-todo () + "Passphrase caching with OpenPGP only for GnuPG 1.x." + (skip-unless (string< (cdr (assq 'version (epg-configuration))) "2")) + (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp) + (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp-mime)) + +(ert-deftest mml-secure-en-decrypt-passphrase-no-cache-smime-todo () + "Passphrase caching does not work with S/MIME (and gpgsm)." + :expected-result :failed + (if with-smime + (mml-secure-en-decrypt-passphrase-no-cache 'enc-smime) + (should nil))) + + +;; Test truncation of question in y-or-n-p. +(defun mml-secure-select-preferred-keys-todo () + "Manual customization with truncated question." + (mml-secure-test-key-fixture + (lambda () + (mml-secure-test-en-decrypt + 'enc-pgp-mime + "jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de" + "no-exp@example.org" nil t nil nil t)))) + +(defun mml-secure-select-preferred-keys-ok () + "Manual customization with entire question." + (mml-secure-test-fixture + (lambda () + (mml-secure-select-preferred-keys + (epg-make-context 'OpenPGP) + '("jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de") + 'encrypt)) + t)) + + +;; ERT entry points +(defun mml-secure-run-tests () + "Run all tests with defaults." + (ert-run-tests-batch)) + +(defun mml-secure-run-tests-with-gpg2 () + "Run all tests with gpg2 instead of gpg." + (let* ((epg-gpg-program "gpg2"); ~/local/gnupg-2.1.9/PLAY/inst/bin/gpg2 + (gpg-version (cdr (assq 'version (epg-configuration)))) + ;; Empty passphrases do not seem to work with gpgsm in 2.1.x: + ;; https://lists.gnupg.org/pipermail/gnupg-users/2015-October/054575.html + (with-smime (string< gpg-version "2.1"))) + (ert-run-tests-batch))) + +(defun mml-secure-run-tests-without-smime () + "Skip S/MIME tests (as they require manual passphrase entry)." + (let ((with-smime nil)) + (ert-run-tests-batch))) + +;;; gnustest-mml-sec.el ends here From 34229d3915f3205324eeab1ade37bb5eccc468b1 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 19:47:06 +0200 Subject: [PATCH 048/145] Tweak mml-sec test that sometimes fails * test/lisp/gnus/mml-sec-tests.el (mml-first-secure-en-decrypt-sign-1): mml-secure-en-decrypt-sign-1 fail sometimes, on some machines, unless it's the first test. I'm guessing there's a race condition somewhere in the test, but put it first now to avoid build reports. --- test/lisp/gnus/mml-sec-tests.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el index 28be3b9bd46..50bb6e6b278 100644 --- a/test/lisp/gnus/mml-sec-tests.el +++ b/test/lisp/gnus/mml-sec-tests.el @@ -606,7 +606,7 @@ In this test, encrypt-to-self variables are set to lists." (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") (cons "F7E79AB7AE31D471" "4035D59B5F88E9FC")))))) -(ert-deftest mml-secure-en-decrypt-sign-1 () +(ert-deftest mml-first-secure-en-decrypt-sign-1 () "Sign and encrypt message; then decrypt and test for expected result. In this test, just multiple encryption and signing keys may be available." (mml-secure-test-key-fixture From cc41b36af9372e6396d10198bbf286b49d8a5255 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 19:48:12 +0200 Subject: [PATCH 049/145] Remove mistakenly checked-in random_seed file --- test/data/mml-sec/random_seed | Bin 600 -> 0 bytes 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 test/data/mml-sec/random_seed diff --git a/test/data/mml-sec/random_seed b/test/data/mml-sec/random_seed deleted file mode 100644 index 530fd76c1e569505d2a5fafd75599aae65317ba0..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 600 zcmV-e0;m1NGj8*P=VOgDXFUp8f|@W>HV+3(KX;rlcE2K#Vx!+6!62^|+QUr#|W$MB|HwzQ>zFB>thZ1e^N4D96K! zqcnxMOV(ZPJdDl|wL;x@X2AK0EmTq?n~=^n0j3NNN0C+-gKw$6aGFMBMJi21hL)y( zg|OwfMoixQzb;hR#I<^`jstzJBAPPx=syt;RzLRcSPm`ojB;KBM?pj2XVx(& zdsj>A;W0MyCBN8Pw@1>;#Qrz3UB^;-f{D0G^w4f)bF}dm2YPU(t22})txSmu^X=vk^1t;r3G5`d_=9;&K{#b8y*S6HMt1mkM From 1308587c25cc28248c3d38748f76bb9e6324b929 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 19:50:37 +0200 Subject: [PATCH 050/145] Ignore test/data/mml-sec/random_seed The file is generated when mml-sec-tests is run. --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 890e63a4318..d69a40af8cd 100644 --- a/.gitignore +++ b/.gitignore @@ -152,6 +152,7 @@ test/manual/etags/regexfile test/manual/etags/ETAGS test/manual/etags/CTAGS test/manual/indent/*.new +test/data/mml-sec/random_seed # ctags, etags. TAGS From fe2649528b0b7637e6b6851c41e696a1016d8d53 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Tue, 4 Aug 2020 11:09:55 -0700 Subject: [PATCH 051/145] Drop support for -fcheck-pointer-bounds MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit GCC has removed the -fcheck-pointer bounds option, and the Linux kernel has also removed support for Intel MPX, so there’s no point to keeping this debugging option within Emacs. * src/bytecode.c (BYTE_CODE_THREADED): * src/lisp.h (DEFINE_LISP_SYMBOL, XSYMBOL, make_lisp_symbol): Assume __CHKP__ is not defined. * src/ptr-bounds.h: Remove. All uses of ptr_bounds_clip, ptr_bounds_copy, ptr_bounds_init, ptr_bounds_set removed. --- etc/NEWS | 5 +++ src/alloc.c | 31 +++++++------------ src/bytecode.c | 11 +++---- src/callint.c | 4 --- src/dispnew.c | 7 ----- src/editfns.c | 3 -- src/emacs.c | 1 - src/frame.c | 6 ---- src/fringe.c | 5 +-- src/gmalloc.c | 16 +++------- src/lisp.h | 31 ++++--------------- src/ptr-bounds.h | 79 ------------------------------------------------ 12 files changed, 31 insertions(+), 168 deletions(-) delete mode 100644 src/ptr-bounds.h diff --git a/etc/NEWS b/etc/NEWS index cd5cc2c3397..f135b3f6b3c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -58,6 +58,11 @@ shaping, so 'configure' now recommends that combination. ** The ftx font backend driver has been removed. It was declared obsolete in Emacs 27.1. +--- +** 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. + --- ** Emacs no longer supports old OpenBSD systems. OpenBSD 5.3 and older releases are no longer supported, as they lack diff --git a/src/alloc.c b/src/alloc.c index 3a02ef3f8c4..b16b2f8b93e 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -34,7 +34,6 @@ along with GNU Emacs. If not, see . */ #include "bignum.h" #include "dispextern.h" #include "intervals.h" -#include "ptr-bounds.h" #include "puresize.h" #include "sheap.h" #include "sysstdio.h" @@ -1624,8 +1623,7 @@ static struct Lisp_String *string_free_list; a pointer to the `u.data' member of its sdata structure; the structure starts at a constant offset in front of that. */ -#define SDATA_OF_STRING(S) ((sdata *) ptr_bounds_init ((S)->u.s.data \ - - SDATA_DATA_OFFSET)) +#define SDATA_OF_STRING(S) ((sdata *) ((S)->u.s.data - SDATA_DATA_OFFSET)) #ifdef GC_CHECK_STRING_OVERRUN @@ -1799,7 +1797,7 @@ allocate_string (void) /* Every string on a free list should have NULL data pointer. */ s->u.s.data = NULL; NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = ptr_bounds_clip (s, sizeof *s); + string_free_list = s; } } @@ -1908,7 +1906,7 @@ allocate_string_data (struct Lisp_String *s, MALLOC_UNBLOCK_INPUT; - s->u.s.data = ptr_bounds_clip (SDATA_DATA (data), nbytes + 1); + s->u.s.data = SDATA_DATA (data); #ifdef GC_CHECK_STRING_BYTES SDATA_NBYTES (data) = nbytes; #endif @@ -2036,7 +2034,7 @@ sweep_strings (void) /* Put the string on the free-list. */ NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = ptr_bounds_clip (s, sizeof *s); + string_free_list = s; ++nfree; } } @@ -2044,7 +2042,7 @@ sweep_strings (void) { /* S was on the free-list before. Put it there again. */ NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = ptr_bounds_clip (s, sizeof *s); + string_free_list = s; ++nfree; } } @@ -2171,8 +2169,7 @@ compact_small_strings (void) { eassert (tb != b || to < from); memmove (to, from, size + GC_STRING_EXTRA); - to->string->u.s.data - = ptr_bounds_clip (SDATA_DATA (to), nbytes + 1); + to->string->u.s.data = SDATA_DATA (to); } /* Advance past the sdata we copied to. */ @@ -2959,7 +2956,6 @@ Lisp_Object zero_vector; static void setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes) { - v = ptr_bounds_clip (v, nbytes); eassume (header_size <= nbytes); ptrdiff_t nwords = (nbytes - header_size) / word_size; XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords); @@ -3307,7 +3303,7 @@ allocate_vectorlike (ptrdiff_t len, bool clearit) MALLOC_UNBLOCK_INPUT; - return ptr_bounds_clip (p, nbytes); + return p; } @@ -4461,7 +4457,6 @@ live_string_holding (struct mem_node *m, void *p) must not be on the free-list. */ if (0 <= offset && offset < sizeof b->strings) { - cp = ptr_bounds_copy (cp, b); struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; if (s->u.s.data) return s; @@ -4494,7 +4489,6 @@ live_cons_holding (struct mem_node *m, void *p) && (b != cons_block || offset / sizeof b->conses[0] < cons_block_index)) { - cp = ptr_bounds_copy (cp, b); struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; if (!deadp (s->u.s.car)) return s; @@ -4528,7 +4522,6 @@ live_symbol_holding (struct mem_node *m, void *p) && (b != symbol_block || offset / sizeof b->symbols[0] < symbol_block_index)) { - cp = ptr_bounds_copy (cp, b); struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; if (!deadp (s->u.s.function)) return s; @@ -5234,7 +5227,7 @@ pure_alloc (size_t size, int type) pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp; if (pure_bytes_used <= pure_size) - return ptr_bounds_clip (result, size); + return result; /* Don't allocate a large amount here, because it might get mmap'd and then its address @@ -5325,7 +5318,7 @@ find_string_data_in_pure (const char *data, ptrdiff_t nbytes) /* Check the remaining characters. */ if (memcmp (data, non_lisp_beg + start, nbytes) == 0) /* Found. */ - return ptr_bounds_clip (non_lisp_beg + start, nbytes + 1); + return non_lisp_beg + start; start += last_char_skip; } @@ -6049,7 +6042,6 @@ garbage_collect (void) stack_copy = xrealloc (stack_copy, stack_size); stack_copy_size = stack_size; } - stack = ptr_bounds_set (stack, stack_size); no_sanitize_memcpy (stack_copy, stack, stack_size); } } @@ -6885,8 +6877,7 @@ sweep_conses (void) for (pos = start; pos < stop; pos++) { - struct Lisp_Cons *acons - = ptr_bounds_copy (&cblk->conses[pos], cblk); + struct Lisp_Cons *acons = &cblk->conses[pos]; if (!XCONS_MARKED_P (acons)) { this_free++; @@ -6939,7 +6930,7 @@ sweep_floats (void) int this_free = 0; for (int i = 0; i < lim; i++) { - struct Lisp_Float *afloat = ptr_bounds_copy (&fblk->floats[i], fblk); + struct Lisp_Float *afloat = &fblk->floats[i]; if (!XFLOAT_MARKED_P (afloat)) { this_free++; diff --git a/src/bytecode.c b/src/bytecode.c index 5ac30aa1010..1913a4812a0 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -24,7 +24,6 @@ along with GNU Emacs. If not, see . */ #include "character.h" #include "buffer.h" #include "keyboard.h" -#include "ptr-bounds.h" #include "syntax.h" #include "window.h" @@ -47,7 +46,7 @@ along with GNU Emacs. If not, see . */ indirect threaded, using GCC's computed goto extension. This code, as currently implemented, is incompatible with BYTE_CODE_SAFE and BYTE_CODE_METER. */ -#if (defined __GNUC__ && !defined __STRICT_ANSI__ && !defined __CHKP__ \ +#if (defined __GNUC__ && !defined __STRICT_ANSI__ \ && !BYTE_CODE_SAFE && !defined BYTE_CODE_METER) #define BYTE_CODE_THREADED #endif @@ -368,14 +367,12 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, USE_SAFE_ALLOCA; void *alloc; SAFE_ALLOCA_LISP_EXTRA (alloc, stack_items, bytestr_length); - ptrdiff_t item_bytes = stack_items * word_size; - Lisp_Object *stack_base = ptr_bounds_clip (alloc, item_bytes); + Lisp_Object *stack_base = alloc; Lisp_Object *top = stack_base; *top = vector; /* Ensure VECTOR survives GC (Bug#33014). */ Lisp_Object *stack_lim = stack_base + stack_items; - unsigned char *bytestr_data = alloc; - bytestr_data = ptr_bounds_clip (bytestr_data + item_bytes, bytestr_length); - memcpy (bytestr_data, SDATA (bytestr), bytestr_length); + unsigned char const *bytestr_data = memcpy (stack_lim, + SDATA (bytestr), bytestr_length); unsigned char const *pc = bytestr_data; ptrdiff_t count = SPECPDL_INDEX (); diff --git a/src/callint.c b/src/callint.c index eb916353a0c..f609c96a6fa 100644 --- a/src/callint.c +++ b/src/callint.c @@ -21,7 +21,6 @@ along with GNU Emacs. If not, see . */ #include #include "lisp.h" -#include "ptr-bounds.h" #include "character.h" #include "buffer.h" #include "keyboard.h" @@ -440,9 +439,6 @@ invoke it (via an `interactive' spec that contains, for instance, an signed char *varies = (signed char *) (visargs + nargs); memclear (args, nargs * (2 * word_size + 1)); - args = ptr_bounds_clip (args, nargs * sizeof *args); - visargs = ptr_bounds_clip (visargs, nargs * sizeof *visargs); - varies = ptr_bounds_clip (varies, nargs * sizeof *varies); if (!NILP (enable)) specbind (Qenable_recursive_minibuffers, Qt); diff --git a/src/dispnew.c b/src/dispnew.c index 1ae59e3ff2b..d318e26308e 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -25,7 +25,6 @@ along with GNU Emacs. If not, see . */ #include #include "lisp.h" -#include "ptr-bounds.h" #include "termchar.h" /* cm.h must come after dispextern.h on Windows. */ #include "dispextern.h" @@ -4891,12 +4890,6 @@ scrolling (struct frame *frame) unsigned *new_hash = old_hash + height; int *draw_cost = (int *) (new_hash + height); int *old_draw_cost = draw_cost + height; - old_hash = ptr_bounds_clip (old_hash, height * sizeof *old_hash); - new_hash = ptr_bounds_clip (new_hash, height * sizeof *new_hash); - draw_cost = ptr_bounds_clip (draw_cost, height * sizeof *draw_cost); - old_draw_cost = ptr_bounds_clip (old_draw_cost, - height * sizeof *old_draw_cost); - eassert (current_matrix); /* Compute hash codes of all the lines. Also calculate number of diff --git a/src/editfns.c b/src/editfns.c index 763d95bb8fa..cb09ea8a31a 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -46,7 +46,6 @@ along with GNU Emacs. If not, see . */ #include "composite.h" #include "intervals.h" -#include "ptr-bounds.h" #include "systime.h" #include "character.h" #include "buffer.h" @@ -3131,8 +3130,6 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) string was not copied into the output. It is 2 if byte I was not the first byte of its character. */ char *discarded = (char *) &info[nspec_bound]; - info = ptr_bounds_clip (info, info_size); - discarded = ptr_bounds_clip (discarded, formatlen); memset (discarded, 0, formatlen); /* Try to determine whether the result should be multibyte. diff --git a/src/emacs.c b/src/emacs.c index 8a6bb3ad228..8e5eaf5e43e 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -83,7 +83,6 @@ along with GNU Emacs. If not, see . */ #include "charset.h" #include "composite.h" #include "dispextern.h" -#include "ptr-bounds.h" #include "regex-emacs.h" #include "sheap.h" #include "syntax.h" diff --git a/src/frame.c b/src/frame.c index c871e4fd994..c21d4708f75 100644 --- a/src/frame.c +++ b/src/frame.c @@ -35,7 +35,6 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" /* These help us bind and responding to switch-frame events. */ #include "keyboard.h" -#include "ptr-bounds.h" #include "frame.h" #include "blockinput.h" #include "termchar.h" @@ -5019,8 +5018,6 @@ gui_display_get_resource (Display_Info *dpyinfo, Lisp_Object attribute, USE_SAFE_ALLOCA; char *name_key = SAFE_ALLOCA (name_keysize + class_keysize); char *class_key = name_key + name_keysize; - name_key = ptr_bounds_clip (name_key, name_keysize); - class_key = ptr_bounds_clip (class_key, class_keysize); /* Start with emacs.FRAMENAME for the name (the specific one) and with `Emacs' for the class key (the general one). */ @@ -5091,9 +5088,6 @@ x_get_resource_string (const char *attribute, const char *class) ptrdiff_t class_keysize = sizeof (EMACS_CLASS) - 1 + strlen (class) + 2; char *name_key = SAFE_ALLOCA (name_keysize + class_keysize); char *class_key = name_key + name_keysize; - name_key = ptr_bounds_clip (name_key, name_keysize); - class_key = ptr_bounds_clip (class_key, class_keysize); - esprintf (name_key, "%s.%s", SSDATA (Vinvocation_name), attribute); sprintf (class_key, "%s.%s", EMACS_CLASS, class); diff --git a/src/fringe.c b/src/fringe.c index fc4c738dc2d..c3d64fefc82 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -23,7 +23,6 @@ along with GNU Emacs. If not, see . */ #include "lisp.h" #include "frame.h" -#include "ptr-bounds.h" #include "window.h" #include "dispextern.h" #include "buffer.h" @@ -1607,9 +1606,7 @@ If BITMAP already exists, the existing definition is replaced. */) fb.dynamic = true; xfb = xmalloc (sizeof fb + fb.height * BYTES_PER_BITMAP_ROW); - fb.bits = b = ((unsigned short *) - ptr_bounds_clip (xfb + 1, fb.height * BYTES_PER_BITMAP_ROW)); - xfb = ptr_bounds_clip (xfb, sizeof *xfb); + fb.bits = b = (unsigned short *) (xfb + 1); j = 0; while (j < fb.height) diff --git a/src/gmalloc.c b/src/gmalloc.c index 8450a639e77..3560c744539 100644 --- a/src/gmalloc.c +++ b/src/gmalloc.c @@ -38,8 +38,6 @@ License along with this library. If not, see . #include "lisp.h" -#include "ptr-bounds.h" - #ifdef HAVE_MALLOC_H # if GNUC_PREREQ (4, 2, 0) # pragma GCC diagnostic ignored "-Wdeprecated-declarations" @@ -200,8 +198,7 @@ extern size_t _bytes_free; /* Internal versions of `malloc', `realloc', and `free' used when these functions need to call each other. - They are the same but don't call the hooks - and don't bound the resulting pointers. */ + They are the same but don't call the hooks. */ extern void *_malloc_internal (size_t); extern void *_realloc_internal (void *, size_t); extern void _free_internal (void *); @@ -551,7 +548,7 @@ malloc_initialize_1 (void) _heapinfo[0].free.size = 0; _heapinfo[0].free.next = _heapinfo[0].free.prev = 0; _heapindex = 0; - _heapbase = (char *) ptr_bounds_init (_heapinfo); + _heapbase = (char *) _heapinfo; _heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info)); register_heapinfo (); @@ -912,8 +909,7 @@ malloc (size_t size) among multiple threads. We just leave it for compatibility with glibc malloc (i.e., assignments to gmalloc_hook) for now. */ hook = gmalloc_hook; - void *result = (hook ? hook : _malloc_internal) (size); - return ptr_bounds_clip (result, size); + return (hook ? hook : _malloc_internal) (size); } #if !(defined (_LIBC) || defined (HYBRID_MALLOC)) @@ -991,7 +987,6 @@ _free_internal_nolock (void *ptr) if (ptr == NULL) return; - ptr = ptr_bounds_init (ptr); PROTECT_MALLOC_STATE (0); @@ -1303,7 +1298,6 @@ _realloc_internal_nolock (void *ptr, size_t size) else if (ptr == NULL) return _malloc_internal_nolock (size); - ptr = ptr_bounds_init (ptr); block = BLOCK (ptr); PROTECT_MALLOC_STATE (0); @@ -1426,8 +1420,7 @@ realloc (void *ptr, size_t size) return NULL; hook = grealloc_hook; - void *result = (hook ? hook : _realloc_internal) (ptr, size); - return ptr_bounds_clip (result, size); + return (hook ? hook : _realloc_internal) (ptr, size); } /* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc. @@ -1601,7 +1594,6 @@ aligned_alloc (size_t alignment, size_t size) { l->exact = result; result = l->aligned = (char *) result + adj; - result = ptr_bounds_clip (result, size); } UNLOCK_ALIGNED_BLOCKS (); if (l == NULL) diff --git a/src/lisp.h b/src/lisp.h index 22ddf3e5faf..17b92a04146 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -893,8 +893,8 @@ verify (GCALIGNED (struct Lisp_Symbol)); convert it to a Lisp_Word. */ #if LISP_WORDS_ARE_POINTERS /* untagged_ptr is a pointer so that the compiler knows that TAG_PTR - yields a pointer; this can help with gcc -fcheck-pointer-bounds. - It is char * so that adding a tag uses simple machine addition. */ + yields a pointer. It is char * so that adding a tag uses simple + machine addition. */ typedef char *untagged_ptr; typedef uintptr_t Lisp_Word_tag; #else @@ -922,13 +922,9 @@ typedef EMACS_UINT Lisp_Word_tag; when using a debugger like GDB, on older platforms where the debug format does not represent C macros. However, they are unbounded and would just be asking for trouble if checking pointer bounds. */ -#ifdef __CHKP__ -# define DEFINE_LISP_SYMBOL(name) -#else -# define DEFINE_LISP_SYMBOL(name) \ - DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \ - DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name)) -#endif +#define DEFINE_LISP_SYMBOL(name) \ + DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \ + DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name)) /* The index of the C-defined Lisp symbol SYM. This can be used in a static initializer. */ @@ -1002,30 +998,15 @@ XSYMBOL (Lisp_Object a) eassert (SYMBOLP (a)); intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol); void *p = (char *) lispsym + i; -#ifdef __CHKP__ - /* Bypass pointer checking. Although this could be improved it is - probably not worth the trouble. */ - p = __builtin___bnd_set_ptr_bounds (p, sizeof (struct Lisp_Symbol)); -#endif return p; } INLINE Lisp_Object make_lisp_symbol (struct Lisp_Symbol *sym) { -#ifdef __CHKP__ - /* Although '__builtin___bnd_narrow_ptr_bounds (sym, sym, sizeof *sym)' - should be more efficient, it runs afoul of GCC bug 83251 - . - Also, attempting to call __builtin___bnd_chk_ptr_bounds (sym, sizeof *sym) - here seems to trigger a GCC bug, as yet undiagnosed. */ - char *addr = __builtin___bnd_set_ptr_bounds (sym, sizeof *sym); - char *symoffset = addr - (intptr_t) lispsym; -#else - /* If !__CHKP__, GCC 7 x86-64 generates faster code if lispsym is + /* GCC 7 x86-64 generates faster code if lispsym is cast to char * rather than to intptr_t. */ char *symoffset = (char *) ((char *) sym - (char *) lispsym); -#endif Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset); eassert (XSYMBOL (a) == sym); return a; diff --git a/src/ptr-bounds.h b/src/ptr-bounds.h deleted file mode 100644 index 22d49f25b6c..00000000000 --- a/src/ptr-bounds.h +++ /dev/null @@ -1,79 +0,0 @@ -/* Pointer bounds checking for GNU Emacs - -Copyright 2017-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 . */ - -/* Pointer bounds checking is a no-op unless running on hardware - supporting Intel MPX (Intel Skylake or better). Also, it requires - GCC 5 and Linux kernel 3.19, or later. Configure with - CFLAGS='-fcheck-pointer-bounds -mmpx', perhaps with - -fchkp-first-field-has-own-bounds thrown in. - - Although pointer bounds checking can help during debugging, it is - disabled by default because it hurts performance significantly. - The checking does not detect all pointer errors. For example, a - dumped Emacs might not detect a bounds violation of a pointer that - was created before Emacs was dumped. */ - -#ifndef PTR_BOUNDS_H -#define PTR_BOUNDS_H - -#include - -/* When not checking pointer bounds, the following macros simply - return their first argument. These macros return either void *, or - the same type as their first argument. */ - -INLINE_HEADER_BEGIN - -/* Return a copy of P, with bounds narrowed to [P, P + N). */ -#ifdef __CHKP__ -INLINE void * -ptr_bounds_clip (void const *p, size_t n) -{ - return __builtin___bnd_narrow_ptr_bounds (p, p, n); -} -#else -# define ptr_bounds_clip(p, n) ((void) (size_t) {n}, p) -#endif - -/* Return a copy of P, but with the bounds of Q. */ -#ifdef __CHKP__ -# define ptr_bounds_copy(p, q) __builtin___bnd_copy_ptr_bounds (p, q) -#else -# define ptr_bounds_copy(p, q) ((void) (void const *) {q}, p) -#endif - -/* Return a copy of P, but with infinite bounds. - This is a loophole in pointer bounds checking. */ -#ifdef __CHKP__ -# define ptr_bounds_init(p) __builtin___bnd_init_ptr_bounds (p) -#else -# define ptr_bounds_init(p) (p) -#endif - -/* Return a copy of P, but with bounds [P, P + N). - This is a loophole in pointer bounds checking. */ -#ifdef __CHKP__ -# define ptr_bounds_set(p, n) __builtin___bnd_set_ptr_bounds (p, n) -#else -# define ptr_bounds_set(p, n) ((void) (size_t) {n}, p) -#endif - -INLINE_HEADER_END - -#endif /* PTR_BOUNDS_H */ From 9c967e7298cc4f0e6acbaf9b13755d674d9d460c Mon Sep 17 00:00:00 2001 From: Arik Mitschang Date: Tue, 4 Aug 2020 20:32:13 +0200 Subject: [PATCH 052/145] Add options for mode modern ciphers in smime-encrypt-cipher * lisp/gnus/smime.el (smime-encrypt-cipher): Add support for more modern ciphers (bug#8474). Copyright-paperwork-exempt: yes --- lisp/gnus/smime.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index fe6daf6b037..5500148e518 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -185,6 +185,9 @@ and the files themselves should be in PEM format." :version "22.1" :type '(choice (const :tag "Triple DES" "-des3") (const :tag "DES" "-des") + (const :tag "AES 256 bits" "-aes256") + (const :tag "AES 192 bits" "-aes192") + (const :tag "AES 128 bits" "-aes128") (const :tag "RC2 40 bits" "-rc2-40") (const :tag "RC2 64 bits" "-rc2-64") (const :tag "RC2 128 bits" "-rc2-128")) From 6e70b3793b9cb7730ab8a7132aa6e99f1ca13f98 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 4 Aug 2020 21:42:44 +0200 Subject: [PATCH 053/145] When decrypting non-decrypted files, make epa show the raw files * lisp/epa-file.el (epa-file-insert-file-contents): When trying to decrypt a non-decrypted file, just show the bytes from the file instead (bug#3829). --- lisp/epa-file.el | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/lisp/epa-file.el b/lisp/epa-file.el index 20043a9eae4..bbd9279a9a8 100644 --- a/lisp/epa-file.el +++ b/lisp/epa-file.el @@ -151,17 +151,25 @@ encryption is used." (nth 3 error))) (let ((exists (file-exists-p local-file))) (when exists - ;; Hack to prevent find-file from opening empty buffer - ;; when decryption failed (bug#6568). See the place - ;; where `find-file-not-found-functions' are called in - ;; `find-file-noselect-1'. - (setq-local epa-file-error error) - (add-hook 'find-file-not-found-functions - 'epa-file--find-file-not-found-function - nil t) - (epa-display-error context)) - (signal (if exists 'file-error 'file-missing) - (cons "Opening input file" (cdr error)))))) + (epa-display-error context) + ;; When the .gpg file isn't an encrypted file (e.g., + ;; it's a keyring.gpg file instead), then gpg will + ;; say "Unexpected exit" as the error message. In + ;; that case, just display the bytes. + (if (equal (caddr error) "Unexpected; Exit") + (setq string (with-temp-buffer + (insert-file-contents-literally local-file) + (buffer-string))) + ;; Hack to prevent find-file from opening empty buffer + ;; when decryption failed (bug#6568). See the place + ;; where `find-file-not-found-functions' are called in + ;; `find-file-noselect-1'. + (setq-local epa-file-error error) + (add-hook 'find-file-not-found-functions + 'epa-file--find-file-not-found-function + nil t) + (signal (if exists 'file-error 'file-missing) + (cons "Opening input file" (cdr error)))))))) (set-buffer buf) ;In case timer/filter changed/killed it (bug#16029)! (setq-local epa-file-encrypt-to (mapcar #'car (epg-context-result-for From 519a93e067f459ceddb57573261a52118086b73d Mon Sep 17 00:00:00 2001 From: Alan Third Date: Sun, 2 Aug 2020 20:43:56 +0100 Subject: [PATCH 054/145] Don't smooth images when scaling up (bug#38394) * src/image.c (image_set_transform [HAVE_XRENDER]): Use different filter when scaling up vs scaling down. * src/nsimage.m (ns_image_set_smoothing): ([EmacsImage setSmoothing:]): New functions. * src/nsterm.h: Add definitions. * src/nsterm.m (ns_dumpglyphs_image): Disable smoothing if requested. --- src/image.c | 20 +++++++++++++++++--- src/nsimage.m | 12 ++++++++++++ src/nsterm.h | 3 +++ src/nsterm.m | 12 ++++++++++++ 4 files changed, 44 insertions(+), 3 deletions(-) diff --git a/src/image.c b/src/image.c index e7e0a93313b..e236b389210 100644 --- a/src/image.c +++ b/src/image.c @@ -259,6 +259,8 @@ cr_put_image_to_cr_data (struct image *img) cairo_matrix_t matrix; cairo_pattern_get_matrix (img->cr_data, &matrix); cairo_pattern_set_matrix (pattern, &matrix); + cairo_pattern_set_filter + (pattern, cairo_pattern_get_filter (img->cr_data)); cairo_pattern_destroy (img->cr_data); } cairo_surface_destroy (surface); @@ -2114,6 +2116,15 @@ image_set_transform (struct frame *f, struct image *img) double rotation = 0.0; compute_image_rotation (img, &rotation); +# if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_NS + /* We want scale up operations to use a nearest neighbour filter to + show real pixels instead of munging them, but scale down + operations to use a blended filter, to avoid aliasing and the like. + + TODO: implement for Windows. */ + bool scale_down = (width < img->width) || (height < img->height); +# endif + /* Perform scale transformation. */ matrix3x3 matrix @@ -2225,11 +2236,14 @@ image_set_transform (struct frame *f, struct image *img) /* Under NS the transform is applied to the drawing surface at drawing time, so store it for later. */ ns_image_set_transform (img->pixmap, matrix); + ns_image_set_smoothing (img->pixmap, scale_down); # elif defined USE_CAIRO cairo_matrix_t cr_matrix = {matrix[0][0], matrix[0][1], matrix[1][0], matrix[1][1], matrix[2][0], matrix[2][1]}; cairo_pattern_t *pattern = cairo_pattern_create_rgb (0, 0, 0); cairo_pattern_set_matrix (pattern, &cr_matrix); + cairo_pattern_set_filter (pattern, scale_down + ? CAIRO_FILTER_BEST : CAIRO_FILTER_NEAREST); /* Dummy solid color pattern just to record pattern matrix. */ img->cr_data = pattern; # elif defined (HAVE_XRENDER) @@ -2246,14 +2260,14 @@ image_set_transform (struct frame *f, struct image *img) XDoubleToFixed (matrix[1][2]), XDoubleToFixed (matrix[2][2])}}}; - XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->picture, FilterBest, - 0, 0); + XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->picture, + scale_down ? FilterBest : FilterNearest, 0, 0); XRenderSetPictureTransform (FRAME_X_DISPLAY (f), img->picture, &tmat); if (img->mask_picture) { XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->mask_picture, - FilterBest, 0, 0); + scale_down ? FilterBest : FilterNearest, 0, 0); XRenderSetPictureTransform (FRAME_X_DISPLAY (f), img->mask_picture, &tmat); } diff --git a/src/nsimage.m b/src/nsimage.m index 07750de95fe..966e7044f12 100644 --- a/src/nsimage.m +++ b/src/nsimage.m @@ -199,6 +199,12 @@ Updated by Christian Limpach (chris@nice.ch) [(EmacsImage *)img setTransform:m]; } +void +ns_image_set_smoothing (void *img, bool smooth) +{ + [(EmacsImage *)img setSmoothing:smooth]; +} + unsigned long ns_get_pixel (void *img, int x, int y) { @@ -591,4 +597,10 @@ - (void)setTransform: (double[3][3]) m [transform setTransformStruct:tm]; } +- (void)setSmoothing: (BOOL) s +{ + smoothing = s; +} + + @end diff --git a/src/nsterm.h b/src/nsterm.h index 8d5371c8f24..a511fef5b98 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -640,6 +640,7 @@ typedef id instancetype; unsigned long xbm_fg; @public NSAffineTransform *transform; + BOOL smoothing; } + (instancetype)allocInitFromFile: (Lisp_Object)file; - (void)dealloc; @@ -658,6 +659,7 @@ typedef id instancetype; - (Lisp_Object)getMetadata; - (BOOL)setFrame: (unsigned int) index; - (void)setTransform: (double[3][3]) m; +- (void)setSmoothing: (BOOL)s; @end @@ -1200,6 +1202,7 @@ extern int ns_image_width (void *img); extern int ns_image_height (void *img); extern void ns_image_set_size (void *img, int width, int height); extern void ns_image_set_transform (void *img, double m[3][3]); +extern void ns_image_set_smoothing (void *img, bool smooth); extern unsigned long ns_get_pixel (void *img, int x, int y); extern void ns_put_pixel (void *img, int x, int y, unsigned long argb); extern void ns_set_alpha (void *img, int x, int y, unsigned char a); diff --git a/src/nsterm.m b/src/nsterm.m index df7f716f51e..572b859a982 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -4043,10 +4043,22 @@ Function modeled after x_draw_glyph_string_box (). [doTransform concat]; + /* Smoothing is the default, so if we don't want smoothing we + have to turn it off. */ + if (! img->smoothing) + [[NSGraphicsContext currentContext] + setImageInterpolation:NSImageInterpolationNone]; + [img drawInRect:ir fromRect:ir operation:NSCompositingOperationSourceOver fraction:1.0 respectFlipped:YES hints:nil]; + /* Apparently image interpolation is not reset with + restoreGraphicsState, so we have to manually reset it. */ + if (! img->smoothing) + [[NSGraphicsContext currentContext] + setImageInterpolation:NSImageInterpolationDefault]; + [[NSGraphicsContext currentContext] restoreGraphicsState]; } From cbb5a67effce7ce2923e498be252c7c8ad96ab53 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 5 Aug 2020 02:51:00 +0300 Subject: [PATCH 055/145] * lisp/generic-x.el (ansible-inventory-generic-mode): Fix filename (bug#42703) --- lisp/generic-x.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/generic-x.el b/lisp/generic-x.el index cd24f497c96..48ac1232051 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -643,7 +643,7 @@ like an INI file. You can add this hook to `find-file-hook'." ("\\([^ =\n\r]+\\)=\\([^ \n\r]*\\)" (1 font-lock-variable-name-face) (2 font-lock-keyword-face))) - '("inventory") + '("inventory\\'") (list (function (lambda () From 398242bb3f08db3be4d8f1a7a95ba44f7aea995c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 4 Aug 2020 20:15:41 -0400 Subject: [PATCH 056/145] * lisp/x-dnd.el: Use lexical-scoping --- lisp/x-dnd.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index b22af5cc770..1d49f462531 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -1,4 +1,4 @@ -;;; x-dnd.el --- drag and drop support for X +;;; x-dnd.el --- drag and drop support for X -*- lexical-binding: t; -*- ;; Copyright (C) 2004-2020 Free Software Foundation, Inc. @@ -32,7 +32,7 @@ (require 'dnd) ;;; Customizable variables -(defcustom x-dnd-test-function 'x-dnd-default-test-function +(defcustom x-dnd-test-function #'x-dnd-default-test-function "The function drag and drop uses to determine if to accept or reject a drop. The function takes three arguments, WINDOW, ACTION and TYPES. WINDOW is where the mouse is when the function is called. WINDOW may be a From 1f3e2ac4b62e38af2d9424f2a4fcc1515a4c0b30 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 5 Aug 2020 10:07:13 +0200 Subject: [PATCH 057/145] Add new function decoded-time-period * lisp/calendar/time-date.el (decoded-time-period): New function. --- etc/NEWS | 5 +++++ lisp/calendar/time-date.el | 15 +++++++++++++++ test/lisp/calendar/time-date-tests.el | 14 ++++++++++++++ 3 files changed, 34 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index f135b3f6b3c..c1879169dd6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -731,6 +731,11 @@ optional argument specifying whether to follow symbolic links. ** 'parse-time-string' can now parse ISO 8601 format strings, such as "2020-01-15T16:12:21-08:00". +--- +** The new function 'decoded-time-period' has been added. +It interprets a decoded time structure as a period and returns the +equivalent period in seconds. + +++ ** The new function 'dom-remove-attribute' has been added. diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index eeb09926a6e..125f9acc705 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -527,6 +527,21 @@ TIME is modified and returned." time) +(defun decoded-time-period (time) + "Interpret DECODED as a period and return its length in seconds. +For computational purposes, years are 365 days long and months +are 30 days long." + (+ (if (consp (decoded-time-second time)) + ;; Fractional second. + (/ (float (car (decoded-time-second time))) + (cdr (decoded-time-second time))) + (or (decoded-time-second time) 0)) + (* (or (decoded-time-minute time) 0) 60) + (* (or (decoded-time-hour time) 0) 60 60) + (* (or (decoded-time-day time) 0) 60 60 24) + (* (or (decoded-time-month time) 0) 60 60 24 30) + (* (or (decoded-time-year time) 0) 60 60 24 365))) + (provide 'time-date) ;;; time-date.el ends here diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index 3eecc67eb53..fe1460cf29e 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -109,4 +109,18 @@ (ert-deftest test-time-since () (should (time-equal-p 0 (time-since nil)))) +(ert-deftest test-time-decoded-period () + (should (equal (decoded-time-period '(nil nil 1 nil nil nil nil nil nil)) + 3600)) + + (should (equal (decoded-time-period '(1 0 0 0 0 0 nil nil nil)) 1)) + (should (equal (decoded-time-period '(0 1 0 0 0 0 nil nil nil)) 60)) + (should (equal (decoded-time-period '(0 0 1 0 0 0 nil nil nil)) 3600)) + (should (equal (decoded-time-period '(0 0 0 1 0 0 nil nil nil)) 86400)) + (should (equal (decoded-time-period '(0 0 0 0 1 0 nil nil nil)) 2592000)) + (should (equal (decoded-time-period '(0 0 0 0 0 1 nil nil nil)) 31536000)) + + (should (equal (decoded-time-period '((135 . 10) 0 0 0 0 0 nil nil nil)) + 13.5))) + ;;; time-date-tests.el ends here From a59296d9984023960453322ff7d664ec79250f7a Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 5 Aug 2020 10:27:40 +0200 Subject: [PATCH 058/145] Make the erc /ignore command prompt for a timeout * lisp/erc/erc.el (erc--unignore-user): Separate into own function (bug#40137). (erc-cmd-IGNORE): Ask if the user wants a timeout. (erc--read-time-period): New function. --- etc/NEWS | 6 ++++ lisp/erc/erc.el | 65 ++++++++++++++++++++++++++++++++++---- test/lisp/erc/erc-tests.el | 47 +++++++++++++++++++++++++++ 3 files changed, 112 insertions(+), 6 deletions(-) create mode 100644 test/lisp/erc/erc-tests.el diff --git a/etc/NEWS b/etc/NEWS index c1879169dd6..670e97f52cb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -590,6 +590,12 @@ 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. +** erc + +--- +*** The /ignore command will now ask for a timeout to stop ignoring the user. +Allowed inputs are seconds or ISO8601-like periods like "1h" or "4h30m". + ** Battery --- diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 8830dd4c45e..927546abc30 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -63,6 +63,8 @@ (require 'thingatpt) (require 'auth-source) (require 'erc-compat) +(require 'time-date) +(require 'iso8601) (eval-when-compile (require 'subr-x)) (defvar erc-official-location @@ -2905,6 +2907,44 @@ therefore has to contain the command itself as well." (erc-server-send (substring line 1)) t) +(defvar erc--read-time-period-history nil) + +(defun erc--read-time-period (prompt) + "Read a time period on the \"2h\" format. +If there's no letter spec, the input is interpreted as a number of seconds. + +If input is blank, this function returns nil. Otherwise it +returns the time spec converted to a number of seconds." + (let ((period (string-trim + (read-string prompt nil 'erc--read-time-period-history)))) + (cond + ;; Blank input. + ((zerop (length period)) + nil) + ;; All-number -- interpret as seconds. + ((string-match-p "\\`[0-9]+\\'" period) + (string-to-number period)) + ;; Parse as a time spec. + (t + (let ((time (condition-case nil + (iso8601-parse-duration + (concat (cond + ((string-match-p "\\`P" (upcase period)) + ;; Somebody typed in a full ISO8601 period. + (upcase period)) + ((string-match-p "[YD]" (upcase period)) + ;; If we have a year/day element, + ;; we have a full spec. + "P") + (t + ;; Otherwise it's just a sub-day spec. + "PT")) + (upcase period))) + (wrong-type-argument nil)))) + (unless time + (user-error "%s is not a valid time period" period)) + (decoded-time-period time)))))) + (defun erc-cmd-IGNORE (&optional user) "Ignore USER. This should be a regexp matching nick!user@host. If no USER argument is specified, list the contents of `erc-ignore-list'." @@ -2914,10 +2954,18 @@ If no USER argument is specified, list the contents of `erc-ignore-list'." (y-or-n-p (format "Use regexp-quoted form (%s) instead? " quoted))) (setq user quoted)) - (erc-display-line - (erc-make-notice (format "Now ignoring %s" user)) - 'active) - (erc-with-server-buffer (add-to-list 'erc-ignore-list user))) + (let ((timeout + (erc--read-time-period + "Add a timeout? (Blank for no, or a time spec like 2h): ")) + (buffer (current-buffer))) + (when timeout + (run-at-time timeout nil + (lambda () + (erc--unignore-user user buffer)))) + (erc-display-line + (erc-make-notice (format "Now ignoring %s" user)) + 'active) + (erc-with-server-buffer (add-to-list 'erc-ignore-list user)))) (if (null (erc-with-server-buffer erc-ignore-list)) (erc-display-line (erc-make-notice "Ignore list is empty") 'active) (erc-display-line (erc-make-notice "Ignore list:") 'active) @@ -2941,12 +2989,17 @@ If no USER argument is specified, list the contents of `erc-ignore-list'." (erc-make-notice (format "%s is not currently ignored!" user)) 'active))) (when ignored-nick + (erc--unignore-user user (current-buffer)))) + t) + +(defun erc--unignore-user (user buffer) + (when (buffer-live-p buffer) + (with-current-buffer buffer (erc-display-line (erc-make-notice (format "No longer ignoring %s" user)) 'active) (erc-with-server-buffer - (setq erc-ignore-list (delete ignored-nick erc-ignore-list))))) - t) + (setq erc-ignore-list (delete user erc-ignore-list)))))) (defun erc-cmd-CLEAR () "Clear the window content." diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el new file mode 100644 index 00000000000..27f48fa8131 --- /dev/null +++ b/test/lisp/erc/erc-tests.el @@ -0,0 +1,47 @@ +;;; erc-tests.el --- Tests for erc. -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'erc) + +(ert-deftest erc--read-time-period () + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) ""))) + (should (equal (erc--read-time-period "foo: ") nil))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " "))) + (should (equal (erc--read-time-period "foo: ") nil))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " 432 "))) + (should (equal (erc--read-time-period "foo: ") 432))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "432"))) + (should (equal (erc--read-time-period "foo: ") 432))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1h"))) + (should (equal (erc--read-time-period "foo: ") 3600))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1h10s"))) + (should (equal (erc--read-time-period "foo: ") 3610))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1d"))) + (should (equal (erc--read-time-period "foo: ") 86400)))) From c72b734c917f635fac09f691e91d3391b00b96f2 Mon Sep 17 00:00:00 2001 From: Kevin Brubeck Unhammer Date: Wed, 5 Aug 2020 11:13:51 +0200 Subject: [PATCH 059/145] Further fix for erc-generate-new-buffer-name * lisp/erc/erc.el (erc-generate-new-buffer-name): Fix buffer name generation when there's two networks on the same server:port (bug#40121). --- lisp/erc/erc.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 927546abc30..62aa76d25c8 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1630,9 +1630,10 @@ symbol, it may have these values: (and (erc-server-buffer-p) (not (erc-server-process-alive))))) ;; Channel buffer; check that it's from the right server. - (with-current-buffer (get-buffer candidate) - (and (string= erc-session-server server) - (erc-port-equal erc-session-port port))))) + (and target + (with-current-buffer (get-buffer candidate) + (and (string= erc-session-server server) + (erc-port-equal erc-session-port port)))))) (setq buffer-name candidate))) ;; if buffer-name is unset, neither candidate worked out for us, ;; fallback to the old uniquification method: From 3f358fc172c50868321b0ef246adb66a7ea795c9 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 5 Aug 2020 11:27:54 +0200 Subject: [PATCH 060/145] Mention undo in the doc string of dired-do-kill-lines * lisp/dired-aux.el (dired-do-kill-lines): Mention that this can be undone (bug#42707). --- lisp/dired-aux.el | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index efb214088d8..806a3955e4d 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -952,13 +952,17 @@ With a prefix argument, kill that many lines starting with the current line. "Kill all marked lines (not the files). With a prefix argument, kill that many lines starting with the current line. \(A negative argument kills backward.) + If you use this command with a prefix argument to kill the line for a file that is a directory, which you have inserted in the Dired buffer as a subdirectory, then it deletes that subdirectory from the buffer as well. + To kill an entire subdirectory \(without killing its line in the parent directory), go to its directory header line and use this -command with a prefix argument (the value does not matter)." +command with a prefix argument (the value does not matter). + +To undo the killing, the undo command can be used as normally." ;; Returns count of killed lines. FMT="" suppresses message. (interactive "P") (if arg From c9d550a301d3a5e62b3296804ccf42efc69d0796 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 5 Aug 2020 11:34:56 +0200 Subject: [PATCH 061/145] Fontize $(...) slightly better in bash mode * lisp/progmodes/sh-script.el (sh-font-lock-keywords-var): Fontize $(...) slightly better (bug#42417). Instead of just fontizing the first word in the expression, fontize until the closing parenthesis. This doesn't work well if you have nested $(...) expressions. --- lisp/progmodes/sh-script.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 044d7820ee3..5a47594878e 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -838,7 +838,7 @@ See `sh-feature'.") font-lock-variable-name-face)) (rc sh-append es) - (bash sh-append sh ("\\$(\\(\\sw+\\)" (1 'sh-quoted-exec t) )) + (bash sh-append sh ("\\$(\\([^)\n]+\\)" (1 'sh-quoted-exec t) )) (sh sh-append shell ;; Variable names. ("\\$\\({#?\\)?\\([[:alpha:]_][[:alnum:]_]*\\|[-#?@!]\\)" 2 From a06f41ad2ca786a70940297fd832a649196be9be Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 5 Aug 2020 12:21:35 +0200 Subject: [PATCH 062/145] Implement a screenshot command for Message mode * doc/misc/message.texi (MIME): Document it. * lisp/gnus/message.el (message-screenshot-command): New variable. (message-mode-map): New keystroke and menu item. Also add mml-attach-file to the menu. (message-insert-screenshot): New command. * lisp/gnus/mml.el (mml-parse-1): Allow having content-transfer-encoding already in the part, so that we can have inline base64-encoded binaries in the Message buffers. --- doc/misc/message.texi | 12 ++++++++++ etc/NEWS | 16 +++++++++---- lisp/gnus/message.el | 53 +++++++++++++++++++++++++++++++++++++++++++ lisp/gnus/mml.el | 13 ++++++++++- 4 files changed, 89 insertions(+), 5 deletions(-) diff --git a/doc/misc/message.texi b/doc/misc/message.texi index bdd31b1fe49..7a66422b17e 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -883,6 +883,18 @@ is a list, valid members are @code{type}, @code{description} and @code{nil}, don't ask for options. If it is @code{t}, ask the user whether or not to specify options. +@vindex message-screenshot-command +@findex message-insert-screenshot +@cindex screenshots +@kindex C-c C-p +If your system supports it, you can also insert screenshots directly +into the Message buffer. The @kbd{C-c C-p} +(@code{message-insert-screenshot}) command inserts the image into the +buffer as an @acronym{MML} part, and puts an image text property on +top. The @code{message-screenshot-command} variable says what +external command to use to take the screenshot. It defaults to +@code{"import png:-"}, which is an ImageMagick command. + You can also create arbitrarily complex multiparts using the @acronym{MML} language (@pxref{Composing, , Composing, emacs-mime, The Emacs MIME Manual}). diff --git a/etc/NEWS b/etc/NEWS index 670e97f52cb..8c6e3e78139 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -228,6 +228,14 @@ The names of the commands 'gnus-slave', 'gnus-slave-no-server' and *** 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 + --- *** Change to default value of 'message-draft-headers' user option. The 'Date' symbol has been removed from the default value, meaning that @@ -237,10 +245,10 @@ from when it is first saved or delayed, add the symbol 'Date' back to this user option. +++ -*** 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. +*** 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". ** Help diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index fb560f0eab8..1453cbe643e 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -303,6 +303,13 @@ any confusion." :link '(custom-manual "(message)Message Headers") :type 'regexp) +(defcustom message-screenshot-command '("import" "png:-") + "Command to take a screenshot. +The command should insert a PNG in the current buffer." + :group 'message-various + :type '(list string) + :version "28.1") + ;;; Start of variables adopted from `message-utils.el'. (defcustom message-subject-trailing-was-query t @@ -2810,6 +2817,7 @@ systematically send encrypted emails when possible." (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) @@ -2839,6 +2847,8 @@ systematically send encrypted emails when possible." :active (message-mark-active-p) :help "Mark region with enclosing tags"] ["Insert File Marked..." message-mark-insert-file :help "Insert file at point marked with enclosing tags"] + ["Attach File..." mml-attach-file t] + ["Insert Screenshot" message-insert-screenshot t] "----" ["Send Message" message-send-and-exit :help "Send this message"] ["Postpone Message" message-dont-send @@ -8652,6 +8662,49 @@ Used in `message-simplify-recipients'." (* 0.5 (- (nth 3 edges) (nth 1 edges))))) string))))))) +(defun message-insert-screenshot (delay) + "Take a screenshot and insert in the current buffer. +DELAY (the numeric prefix) says how many seconds to wait before +starting the screenshotting process. + +The `message-screenshot-command' variable says what command is +used to take the screenshot." + (interactive "p") + (unless (executable-find (car message-screenshot-command)) + (error "Can't find %s to take the screenshot" + (car message-screenshot-command))) + (cl-decf delay) + (unless (zerop delay) + (dotimes (i delay) + (message "Sleeping %d second%s..." + (- delay i) + (if (= (- delay i) 1) + "" + "s")) + (sleep-for 1))) + (message "Take screenshot") + (let ((image + (with-temp-buffer + (set-buffer-multibyte nil) + (apply #'call-process + (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 (* (frame-pixel-width) 0.8) + :max-height (* (frame-pixel-height) 0.8)) + (format "<#part type=\"image/png\" disposition=inline content-transfer-encoding=base64 raw=t>\n%s\n<#/part>" + ;; Get a base64 version of the image. + (with-temp-buffer + (set-buffer-multibyte nil) + (insert image) + (base64-encode-region (point-min) (point-max) t) + (buffer-string)))) + (insert "\n\n") + (message ""))) + (provide 'message) (run-hooks 'message-load-hook) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 21491499eb8..1d348f3a6f0 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -295,6 +295,17 @@ part. This is for the internal use, you should never modify the value.") (t (mm-find-mime-charset-region point (point) mm-hack-charsets)))) + ;; We have a part that already has a transfer encoding. Undo + ;; that so that we don't double-encode later. + (when (and raw + (cdr (assq 'content-transfer-encoding tag))) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert contents) + (mm-decode-content-transfer-encoding + (intern (cdr (assq 'content-transfer-encoding tag))) + (cdr (assq 'type tag))) + (setq contents (buffer-string)))) (when (and (not raw) (memq nil charsets)) (if (or (memq 'unknown-encoding mml-confirmation-set) (message-options-get 'unknown-encoding) @@ -313,8 +324,8 @@ Message contains characters with unknown encoding. Really send? ") (eq 'mml (car tag)) (< (length charsets) 2)) (if (or (not no-markup-p) + ;; Don't create blank parts. (string-match "[^ \t\r\n]" contents)) - ;; Don't create blank parts. (push (nconc tag (list (cons 'contents contents))) struct)) (let ((nstruct (mml-parse-singlepart-with-multiple-charsets From 1b7eb828644a13259ff072e3464c6e8493571e6e Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 5 Aug 2020 12:31:44 +0200 Subject: [PATCH 063/145] Tweak the Message screenshot insertion * lisp/gnus/message.el (message-insert-screenshot): Force scaling to 1, since the screenshot image will already be suitable for displaying directly (it's the same resolution). --- lisp/gnus/message.el | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 1453cbe643e..378c3b04673 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -8694,9 +8694,12 @@ used to take the screenshot." (insert-image (create-image image 'png t :max-width (* (frame-pixel-width) 0.8) - :max-height (* (frame-pixel-height) 0.8)) + :max-height (* (frame-pixel-height) 0.8) + :scale 1) (format "<#part type=\"image/png\" disposition=inline content-transfer-encoding=base64 raw=t>\n%s\n<#/part>" - ;; Get a base64 version of the image. + ;; 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) From 38ad404ba58e83292b3b566a64d8c655aa126cf7 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Wed, 5 Aug 2020 11:40:27 +0100 Subject: [PATCH 064/145] ; Silence recent byte-compiler warning in subr.el * lisp/subr.el (save-match-data-internal): Declare before first use. --- lisp/subr.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/subr.el b/lisp/subr.el index 3c8dbd16146..6bd06a0b82c 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -883,6 +883,10 @@ side-effects, and the argument LIST is not modified." ;;;; Keymap support. +;; Declare before first use of `save-match-data', +;; where it is used internally. +(defvar save-match-data-internal) + (defun kbd (keys) "Convert KEYS to the internal Emacs key representation. KEYS should be a string in the format returned by commands such @@ -4105,8 +4109,6 @@ MODES is as for `set-default-file-modes'." ;;; Matching and match data. -(defvar save-match-data-internal) - ;; We use save-match-data-internal as the local variable because ;; that works ok in practice (people should not use that variable elsewhere). ;; We used to use an uninterned symbol; the compiler handles that properly From a937d50a7e039088d493d8f6b8b5be9799b7d7ad Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 5 Aug 2020 12:43:18 +0200 Subject: [PATCH 065/145] Mention C-y in the manual for yanking the primary selection * doc/emacs/killing.texi (Primary Selection): Mention C-y here for yanking the primary selection (bug#41857). --- doc/emacs/killing.texi | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/emacs/killing.texi b/doc/emacs/killing.texi index 6b1f35e6158..bd7dbb6f515 100644 --- a/doc/emacs/killing.texi +++ b/doc/emacs/killing.texi @@ -577,7 +577,9 @@ regions to the primary selection entirely. To insert the primary selection into an Emacs buffer, click @kbd{mouse-2} (@code{mouse-yank-primary}) where you want to insert it. -@xref{Mouse Commands}. +@xref{Mouse Commands}. You can also use the normal Emacs yank command +(@kbd{C-y}) to insert this text if @code{select-enable-primary} is set +(@pxref{Clipboard}). @cindex MS-Windows, and primary selection MS-Windows provides no primary selection, but Emacs emulates it From dc47bc77dc1c9d34c4c1e2830fe2bfd6be6e241a Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 5 Aug 2020 12:49:14 +0200 Subject: [PATCH 066/145] mouse-drag-copy-region doc string clarification * lisp/mouse.el (mouse-drag-copy-region): Clarify that the variable only applies to selections in Emacs (bug#41856). --- lisp/mouse.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/mouse.el b/lisp/mouse.el index 640f10af4e1..d369545f18e 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -49,7 +49,10 @@ "If non-nil, copy to kill-ring upon mouse adjustments of the region. This affects `mouse-save-then-kill' (\\[mouse-save-then-kill]) in -addition to mouse drags." +addition to mouse drags. + +This variable applies only to mouse adjustments in Emacs, not +selecting and adjusting regions in other windows." :type 'boolean :version "24.1") From 4b3f44fc97d3cb29fceb47ec5ba16009b6de7152 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 5 Aug 2020 15:02:28 +0200 Subject: [PATCH 067/145] Fix max-width/height for Message screenshots * lisp/gnus/message.el (message-insert-screenshot): :max-width/height apparently has to be integers. --- lisp/gnus/message.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 378c3b04673..cf2b8eebc30 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -8693,8 +8693,8 @@ used to take the screenshot." (set-mark (point)) (insert-image (create-image image 'png t - :max-width (* (frame-pixel-width) 0.8) - :max-height (* (frame-pixel-height) 0.8) + :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 content-transfer-encoding=base64 raw=t>\n%s\n<#/part>" ;; Get a base64 version of the image -- this avoids later From 9d409746df593a6579bf7fd4d8ecff08e278cdf8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Harald=20J=C3=B6rg?= Date: Wed, 5 Aug 2020 15:37:13 +0200 Subject: [PATCH 068/145] cperl-mode: Workaround for failure of cperl-write-tags * lisp/progmodes/cperl-mode.el (cperl-mode): Accomodate recent changes in etags (bug#42356). --- lisp/progmodes/cperl-mode.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index cdbb59a5add..6755d10f1ab 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -6786,6 +6786,7 @@ Use as (or topdir (setq topdir default-directory)) (let ((tags-file-name "TAGS") + (inhibit-read-only t) (case-fold-search nil) xs rel) (save-excursion From 7389a9ef0954d61bf5a85221da7c919aee3451a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Harald=20J=C3=B6rg?= Date: Wed, 5 Aug 2020 15:55:00 +0200 Subject: [PATCH 069/145] cperl-mode: Fix bad parameter construction in cperl-etags * lisp/progmodes/cperl-mode.el (cperl-etags): This fails with (wrong-type-argument stringp cperl-sub-regexp). The error came with incorporating Jonathan Rockway's work (bug#42355). Copyright-paperwork-exempt: yes --- lisp/progmodes/cperl-mode.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 6755d10f1ab..6fe0c018b1d 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -6499,9 +6499,10 @@ If optional argument ALL is `recursive', will process Perl files in subdirectories too." (interactive) (let ((cmd "etags") - (args '("-l" "none" "-r" + (args `("-l" "none" "-r" ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!) - "/\\<" cperl-sub-regexp "[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/" + ,(concat + "/\\<" cperl-sub-regexp "[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/") "-r" "/\\ Date: Wed, 5 Aug 2020 16:07:41 +0200 Subject: [PATCH 070/145] Wrap skeleton logic in atomic-change-group * lisp/skeleton.el (define-skeleton): Use an atomic change group so that if the user `C-g's in the middle of it, we're not left with half a skeleton in the buffer (bug#42311). --- lisp/skeleton.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/skeleton.el b/lisp/skeleton.el index 8c694c128b5..3609d6ba6a0 100644 --- a/lisp/skeleton.el +++ b/lisp/skeleton.el @@ -135,7 +135,8 @@ A prefix argument of -1 says to wrap around region, even if not highlighted. A prefix argument of zero says to wrap around zero words---that is, nothing. This is a way of overriding the use of a highlighted region.") (interactive "*P\nP") - (skeleton-proxy-new ',skeleton str arg)))) + (atomic-change-group + (skeleton-proxy-new ',skeleton str arg))))) ;;;###autoload (defun skeleton-proxy-new (skeleton &optional str arg) From 283fce4c3cdb89745a62fdeee83dcd7c2189fba3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Harald=20J=C3=B6rg?= Date: Wed, 5 Aug 2020 17:19:06 +0200 Subject: [PATCH 071/145] cperl-mode.el: Correctly terminate HERE-docs * lisp/progmodes/cperl-mode.el (cperl-find-pods-heres): cperl-mode in the master branch wrongly uses the first occurrence of "HERE" to terminate the string, resulting in badly fontified / indented code which follows (bug#42251). --- lisp/progmodes/cperl-mode.el | 37 ++++++++++++++++++------------------ 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 6fe0c018b1d..5ecd5668b34 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -3560,19 +3560,18 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\(\\`\n?\\|^\n\\)=" ; POD "\\|" ;; One extra () before this: - "<<~?" ; HERE-DOC - "\\(" ; 1 + 1 + "<<\\(~?\\)" ; HERE-DOC, indented-p = capture 2 + "\\(" ; 2 + 1 ;; First variant "BLAH" or just ``. "[ \t]*" ; Yes, whitespace is allowed! - "\\([\"'`]\\)" ; 2 + 1 = 3 - "\\([^\"'`\n]*\\)" ; 3 + 1 - "\\3" + "\\([\"'`]\\)" ; 3 + 1 = 4 + "\\([^\"'`\n]*\\)" ; 4 + 1 + "\\4" "\\|" ;; Second variant: Identifier or \ID (same as 'ID') or empty - "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 + "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 5 + 1, 6 + 1 ;; Do not have <<= or << 30 or <<30 or << $blah. ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 - "\\(\\)" ; To preserve count of pars :-( 6 + 1 "\\)" "\\|" ;; 1+6 extra () before this: @@ -3762,11 +3761,11 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 ;; "\\(\\)" ; To preserve count of pars :-( 6 + 1 ;; "\\)" - ((match-beginning 2) ; 1 + 1 + ((match-beginning 3) ; 2 + 1 (setq b (point) tb (match-beginning 0) c (and ; not HERE-DOC - (match-beginning 5) + (match-beginning 6) (save-match-data (or (looking-at "[ \t]*(") ; << function_call() (save-excursion ; 1 << func_name, or $foo << 10 @@ -3793,17 +3792,17 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (looking-at "\\(printf?\\|say\\|system\\|exec\\|sort\\)\\>"))) (error t))))))) (error nil))) ; func(< Date: Wed, 5 Aug 2020 18:01:27 +0200 Subject: [PATCH 072/145] Enable replying to an ical event even when not an attendee * lisp/gnus/gnus-icalendar.el (gnus-icalendar-event--build-reply-event-body): Display a warning instead of barfing when user is missing from attendee list. When the user identity is not present in the attendee list, an error is triggered making replying to such an event impossible (the reply message not being even composed). This replaces it with a warning. This is necessary because one may receive events that the organizer did not set up well and it is up to the user to decide whether or not to reply to them (bug#41723). Copyright-paperwork-exempt: yes --- lisp/gnus/gnus-icalendar.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index 305e17fd8fc..29d3e30780f 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -312,7 +312,8 @@ status will be retrieved from the first matching attendee record." (unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x)) reply-event-lines) - (error "Could not find an event attendee matching given identity")) + (lwarn 'gnus-icalendar :warning + "Could not find an event attendee matching given identity")) (mapconcat #'identity `("BEGIN:VEVENT" ,@(nreverse reply-event-lines) From 1669cf2f286649ea62991371fd19bbc592ca21bb Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 5 Aug 2020 21:17:55 +0200 Subject: [PATCH 073/145] Split sometimes-failing test into three tests to ease debugging --- test/lisp/gnus/mml-sec-tests.el | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el index 50bb6e6b278..d9ed96ff1db 100644 --- a/test/lisp/gnus/mml-sec-tests.el +++ b/test/lisp/gnus/mml-sec-tests.el @@ -606,7 +606,7 @@ In this test, encrypt-to-self variables are set to lists." (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") (cons "F7E79AB7AE31D471" "4035D59B5F88E9FC")))))) -(ert-deftest mml-first-secure-en-decrypt-sign-1 () +(ert-deftest mml-secure-en-decrypt-sign-1-1-single () "Sign and encrypt message; then decrypt and test for expected result. In this test, just multiple encryption and signing keys may be available." (mml-secure-test-key-fixture @@ -626,17 +626,28 @@ In this test, just multiple encryption and signing keys may be available." ;; customized choice for both keys (mml-secure-test-en-decrypt method "sub@example.org" "sub@example.org" 1 t) - ) + ))))) +(ert-deftest mml-secure-en-decrypt-sign-1-2-double () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, just multiple encryption and signing keys may be available." + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) ;; Now use both keys to sign. The customized one via sign-with-sender, ;; the other one via the following setting. (let ((mml-secure-openpgp-signers '("F7E79AB7AE31D471")) (mml-secure-smime-signers '("0x5F88E9FC"))) (dolist (method (enc-sign-standards) nil) (mml-secure-test-en-decrypt - method "no-exp@example.org" "sub@example.org" 2 t) - ))) + method "no-exp@example.org" "sub@example.org" 2 t))))))) +(ert-deftest mml-secure-en-decrypt-sign-1-3-double () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, just multiple encryption and signing keys may be available." + (mml-secure-test-key-fixture + (lambda () ;; Now use both keys for sub@example.org to sign an e-mail from ;; a different address (without associated keys). (let ((mml-secure-openpgp-sign-with-sender nil) @@ -646,8 +657,7 @@ In this test, just multiple encryption and signing keys may be available." (mml-secure-smime-signers '("0x5F88E9FC" "0x479DC6E2"))) (dolist (method (enc-sign-standards) nil) (mml-secure-test-en-decrypt - method "no-exp@example.org" "no-keys@example.org" 2 t) - ))))) + method "no-exp@example.org" "no-keys@example.org" 2 t)))))) (ert-deftest mml-secure-en-decrypt-sign-2 () "Sign and encrypt message; then decrypt and test for expected result. From 1a99697b4d8c11a10d5e6a306103740d92cc08a1 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 5 Aug 2020 21:30:12 +0200 Subject: [PATCH 074/145] Skip epg tests if gpg isn't installed --- test/lisp/gnus/mml-sec-tests.el | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el index d9ed96ff1db..917e627c7ec 100644 --- a/test/lisp/gnus/mml-sec-tests.el +++ b/test/lisp/gnus/mml-sec-tests.el @@ -36,6 +36,9 @@ Mostly, the empty passphrase is used. However, the keys for \"No Expiry two UIDs\" have the passphrase \"Passphrase\" (for OpenPGP as well as S/MIME).") +(defun test-conf () + (ignore-errors (epg-configuration))) + (defun enc-standards () (if with-smime '(enc-pgp enc-pgp-mime enc-smime) '(enc-pgp enc-pgp-mime))) @@ -200,6 +203,7 @@ In both cases, the first key is customized for signing and encryption." (ert-deftest mml-secure-key-checks () "Test mml-secure-check-user-id and mml-secure-check-sub-key on sample keys." + (skip-unless (test-conf)) (mml-secure-test-fixture (lambda () (let* ((context (epg-make-context 'OpenPGP)) @@ -267,6 +271,7 @@ In both cases, the first key is customized for signing and encryption." (ert-deftest mml-secure-find-usable-keys-1 () "Make sure that expired and disabled keys and revoked UIDs are not used." + (skip-unless (test-conf)) (mml-secure-test-fixture (lambda () (let ((context (epg-make-context 'OpenPGP))) @@ -305,6 +310,7 @@ In both cases, the first key is customized for signing and encryption." (ert-deftest mml-secure-find-usable-keys-2 () "Test different ways to search for keys." + (skip-unless (test-conf)) (mml-secure-test-fixture (lambda () (let ((context (epg-make-context 'OpenPGP))) @@ -356,6 +362,7 @@ In both cases, the first key is customized for signing and encryption." (ert-deftest mml-secure-select-preferred-keys-1 () "If only one key exists for an e-mail address, it is the preferred one." + (skip-unless (test-conf)) (mml-secure-test-fixture (lambda () (let ((context (epg-make-context 'OpenPGP))) @@ -366,6 +373,7 @@ In both cases, the first key is customized for signing and encryption." (ert-deftest mml-secure-select-preferred-keys-2 () "If multiple keys exists for an e-mail address, customization is necessary." + (skip-unless (test-conf)) (mml-secure-test-fixture (lambda () (let* ((context (epg-make-context 'OpenPGP)) @@ -392,6 +400,7 @@ In both cases, the first key is customized for signing and encryption." (ert-deftest mml-secure-select-preferred-keys-3 () "Expired customized keys are removed if multiple keys are available." + (skip-unless (test-conf)) (mml-secure-test-fixture (lambda () (let ((context (epg-make-context 'OpenPGP)) @@ -416,6 +425,7 @@ In both cases, the first key is customized for signing and encryption." (ert-deftest mml-secure-select-preferred-keys-4 () "Multiple keys can be recorded per recipient or signature." + (skip-unless (test-conf)) (mml-secure-test-fixture (lambda () (let ((pcontext (epg-make-context 'OpenPGP)) @@ -559,6 +569,7 @@ If optional EXPECTFAIL is non-nil, a decryption failure is expected." (ert-deftest mml-secure-en-decrypt-1 () "Encrypt message; then decrypt and test for expected result. In this test, the single matching key is chosen automatically." + (skip-unless (test-conf)) (dolist (method (enc-standards) nil) ;; no-exp@example.org with single encryption key (mml-secure-test-en-decrypt @@ -568,6 +579,7 @@ In this test, the single matching key is chosen automatically." (ert-deftest mml-secure-en-decrypt-2 () "Encrypt message; then decrypt and test for expected result. In this test, the encryption key needs to fixed among multiple ones." + (skip-unless (test-conf)) ;; sub@example.org with multiple candidate keys, ;; fixture customizes preferred ones. (mml-secure-test-key-fixture @@ -580,6 +592,7 @@ In this test, the encryption key needs to fixed among multiple ones." (ert-deftest mml-secure-en-decrypt-3 () "Encrypt message; then decrypt and test for expected result. In this test, encrypt-to-self variables are set to t." + (skip-unless (test-conf)) ;; sub@example.org with multiple candidate keys, ;; fixture customizes preferred ones. (mml-secure-test-key-fixture @@ -595,6 +608,7 @@ In this test, encrypt-to-self variables are set to t." (ert-deftest mml-secure-en-decrypt-4 () "Encrypt message; then decrypt and test for expected result. In this test, encrypt-to-self variables are set to lists." + (skip-unless (test-conf)) ;; Send from sub@example.org, which has two keys; encrypt to both. (let ((mml-secure-openpgp-encrypt-to-self '("C3999CF1268DBEA2" "F7E79AB7AE31D471")) @@ -609,6 +623,7 @@ In this test, encrypt-to-self variables are set to lists." (ert-deftest mml-secure-en-decrypt-sign-1-1-single () "Sign and encrypt message; then decrypt and test for expected result. In this test, just multiple encryption and signing keys may be available." + (skip-unless (test-conf)) (mml-secure-test-key-fixture (lambda () (let ((mml-secure-openpgp-sign-with-sender t) @@ -631,6 +646,7 @@ In this test, just multiple encryption and signing keys may be available." (ert-deftest mml-secure-en-decrypt-sign-1-2-double () "Sign and encrypt message; then decrypt and test for expected result. In this test, just multiple encryption and signing keys may be available." + (skip-unless (test-conf)) (mml-secure-test-key-fixture (lambda () (let ((mml-secure-openpgp-sign-with-sender t) @@ -646,6 +662,7 @@ In this test, just multiple encryption and signing keys may be available." (ert-deftest mml-secure-en-decrypt-sign-1-3-double () "Sign and encrypt message; then decrypt and test for expected result. In this test, just multiple encryption and signing keys may be available." + (skip-unless (test-conf)) (mml-secure-test-key-fixture (lambda () ;; Now use both keys for sub@example.org to sign an e-mail from @@ -662,6 +679,7 @@ In this test, just multiple encryption and signing keys may be available." (ert-deftest mml-secure-en-decrypt-sign-2 () "Sign and encrypt message; then decrypt and test for expected result. In this test, lists of encryption and signing keys are customized." + (skip-unless (test-conf)) (mml-secure-test-key-fixture (lambda () (let ((mml-secure-key-preferences @@ -695,6 +713,7 @@ In this test, lists of encryption and signing keys are customized." (ert-deftest mml-secure-en-decrypt-sign-3 () "Sign and encrypt message; then decrypt and test for expected result. Use sign-with-sender and encrypt-to-self." + (skip-unless (test-conf)) (mml-secure-test-key-fixture (lambda () (let ((mml-secure-openpgp-sign-with-sender t) @@ -710,6 +729,7 @@ Use sign-with-sender and encrypt-to-self." (ert-deftest mml-secure-sign-verify-1 () "Sign message with sender; then verify and test for expected result." + (skip-unless (test-conf)) (mml-secure-test-key-fixture (lambda () (dolist (method (sign-standards) nil) @@ -731,6 +751,7 @@ Use sign-with-sender and encrypt-to-self." (ert-deftest mml-secure-sign-verify-2 () "Sign message without sender; then verify and test for expected result." + (skip-unless (test-conf)) (mml-secure-test-key-fixture (lambda () (dolist (method (sign-standards) nil) @@ -762,6 +783,7 @@ Use sign-with-sender and encrypt-to-self." (ert-deftest mml-secure-sign-verify-3 () "Try to sign message with expired OpenPGP subkey, which raises an error. With Ma Gnus v0.14 and earlier a signature would be created with a wrong key." + (skip-unless (test-conf)) (should-error (mml-secure-test-key-fixture (lambda () @@ -784,6 +806,7 @@ With Ma Gnus v0.14 and earlier a signature would be created with a wrong key." In this test, a key is used that requires the passphrase \"Passphrase\". In the first decryption this passphrase is hardcoded, in the second one it is taken from a cache." + (skip-unless (test-conf)) (ert-skip "Requires passphrase") (mml-secure-test-key-fixture (lambda () @@ -814,6 +837,7 @@ So the second decryption fails." (ert-deftest mml-secure-en-decrypt-passphrase-no-cache-openpgp-todo () "Passphrase caching with OpenPGP only for GnuPG 1.x." + (skip-unless (test-conf)) (skip-unless (string< (cdr (assq 'version (epg-configuration))) "2")) (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp) (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp-mime)) @@ -821,6 +845,7 @@ So the second decryption fails." (ert-deftest mml-secure-en-decrypt-passphrase-no-cache-smime-todo () "Passphrase caching does not work with S/MIME (and gpgsm)." :expected-result :failed + (skip-unless (test-conf)) (if with-smime (mml-secure-en-decrypt-passphrase-no-cache 'enc-smime) (should nil))) From 155b2c8a8d51a492a8c350b92bd3e83187d72b78 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Wed, 5 Aug 2020 17:36:50 -0700 Subject: [PATCH 075/145] Simplify Solaris port MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This should avoid some configuration confusion as exemplified by Jeffrey Walton’s recent bug report (Bug#42675). * configure.ac (opsys): Simplify Solaris configuration by not worrying about Solaris 9 and earlier, as they are no longer supported by the Solaris developers. This should support Walton’s ‘./configure --build=x86_64-sun-solaris’. Instead of bothering with ‘opsys=sol2-6’ and ‘opsys=sol2-10’, just use ‘opsys=solaris’. All uses changed. (emacs_check_sunpro_c): Remove unused var. * doc/misc/tramp.texi (Remote programs): * etc/MACHINES, etc/PROBLEMS: Modernize PATH for Oracle Developer Studio. * etc/PROBLEMS: Move Solaris-related problems to legacy area, except those that are still relevant. --- configure.ac | 76 ++++++++----------------- doc/misc/tramp.texi | 2 +- etc/MACHINES | 25 ++++---- etc/PROBLEMS | 135 ++++++++++++++++++++++---------------------- lisp/dired-aux.el | 4 +- 5 files changed, 110 insertions(+), 132 deletions(-) diff --git a/configure.ac b/configure.ac index 4ee4517e11c..c9aa076eb3b 100644 --- a/configure.ac +++ b/configure.ac @@ -748,44 +748,21 @@ case "${canonical}" in opsys=aix4-2 ;; - ## Suns - *-sun-solaris* \ - | i[3456]86-*-solaris2* | i[3456]86-*-sunos5* \ - | x86_64-*-solaris2* | x86_64-*-sunos5*) + ## Solaris + *-*-solaris* | *-*-sunos*) case "${canonical}" in i[3456]86-*-* ) ;; amd64-*-*|x86_64-*-*) ;; sparc* ) ;; * ) unported=yes ;; esac - case "${canonical}" in - *-sunos5.[1-9][0-9]* | *-solaris2.[1-9][0-9]* ) - opsys=sol2-10 - emacs_check_sunpro_c=yes - ;; - *-sunos5.[1-5]* | *-solaris2.[1-5]* ) unported=yes ;; - ## Note that Emacs 23.1's NEWS said the following would be dropped. - *-sunos5.6* | *-solaris2.6* ) - opsys=sol2-6 - RANLIB="ar -ts" - ;; - ## 5.7 EOL Aug 2008, 5.8 EOL Mar 2012. - *-sunos5.[7-9]* | *-solaris2.[7-9]* ) - opsys=sol2-6 - emacs_check_sunpro_c=yes - ;; - esac + opsys=solaris ## Watch out for a compiler that we know will not work. - case "${canonical}" in - *-solaris* | *-sunos5* ) - if [ "x$CC" = x/usr/ucb/cc ]; then - ## /usr/ucb/cc doesn't work; - ## we should find some other compiler that does work. - unset CC - fi - ;; - *) ;; - esac + if [ "$CC" = /usr/ucb/cc ]; then + ## /usr/ucb/cc doesn't work; + ## we should find some other compiler that does work. + unset CC + fi ;; ## QNX Neutrino @@ -1476,14 +1453,11 @@ case "$opsys" in mingw32) UNEXEC_OBJ=unexw32.o ;; - sol2-10) + solaris) # Use the Solaris dldump() function, called from unexsol.c, to dump # emacs, instead of the generic ELF dump code found in unexelf.c. # The resulting binary has a complete symbol table, and is better # for debugging and other observability tools (debuggers, pstack, etc). - # - # It is likely that dldump() works with older Solaris too, but this has - # not been tested, so for now this change is for Solaris 10 or newer. UNEXEC_OBJ=unexsol.o ;; *) @@ -1586,7 +1560,7 @@ case "$opsys" in qnxnto) LIBS_SYSTEM="-lsocket" ;; - sol2*) LIBS_SYSTEM="-lsocket -lnsl" ;; + solaris) LIBS_SYSTEM="-lsocket -lnsl" ;; ## Motif needs -lgen. unixware) LIBS_SYSTEM="-lsocket -lnsl -lelf -lgen" ;; @@ -1647,7 +1621,7 @@ case $opsys in SYSTEM_TYPE=berkeley-unix ;; - sol2* | unixware ) + solaris | unixware ) SYSTEM_TYPE=usg-unix-v ;; @@ -2291,7 +2265,7 @@ system_malloc=yes test $with_unexec = yes && case "$opsys" in ## darwin ld insists on the use of malloc routines in the System framework. - darwin | mingw32 | nacl | sol2-10) ;; + darwin | mingw32 | nacl | solaris) ;; cygwin | qnxnto | freebsd) hybrid_malloc=yes system_malloc= ;; @@ -2427,7 +2401,7 @@ if test "$ac_cv_header_pthread_h" && test "$opsys" != "mingw32"; then # need special flags to disable these optimizations. For example, the # definition of 'errno' in . case $opsys in - hpux* | sol*) + hpux* | solaris) AC_DEFINE([_REENTRANT], 1, [Define to 1 if your system requires this in multithreaded code.]);; aix4-2) @@ -2557,7 +2531,7 @@ fail; ## inoue@ainet.or.jp says Solaris has a bug related to X11R6-style ## XIM support. case "$opsys" in - sol2-*) : ;; + solaris) : ;; *) AC_DEFINE(HAVE_X11R6_XIM, 1, [Define if you have usable X11R6-style XIM support.]) ;; @@ -4692,7 +4666,7 @@ if test "$USE_X_TOOLKIT" != "none"; then fi case $opsys in - sol2* | unixware ) + solaris | unixware ) dnl Some SVr4s don't define NSIG in sys/signal.h for ANSI environments; dnl instead, there's a system variable _sys_nsig. Unfortunately, we dnl need the constant to dimension an array. So wire in the appropriate @@ -4705,7 +4679,7 @@ emacs_broken_SIGIO=no case $opsys in dnl SIGIO exists, but the feature doesn't work in the way Emacs needs. - hpux* | nacl | openbsd | sol2* | unixware ) + hpux* | nacl | openbsd | solaris | unixware ) emacs_broken_SIGIO=yes ;; @@ -4754,7 +4728,7 @@ case $opsys in esac case $opsys in - gnu-* | sol2-10 ) + gnu-* | solaris ) dnl FIXME Can't we test if this exists (eg /proc/$$)? AC_DEFINE(HAVE_PROCFS, 1, [Define if you have the /proc filesystem.]) ;; @@ -4883,7 +4857,7 @@ case $opsys in AC_DEFINE(PTY_TTY_NAME_SPRINTF, [sprintf (pty_name, "/dev/pty/tty%c%x", c, i);]) ;; - sol2* ) + solaris ) dnl On SysVr4, grantpt(3) forks a subprocess, so do not use dnl O_CLOEXEC when opening the pty, and keep the SIGCHLD handler dnl from intercepting that death. If any child but grantpt's should die @@ -4893,7 +4867,7 @@ case $opsys in ;; unixware ) - dnl Comments are as per sol2*. + dnl Comments are as per solaris. 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); }]) ;; @@ -4901,7 +4875,7 @@ esac case $opsys in - sol2* | unixware ) + solaris | unixware ) dnl This change means that we don't loop through allocate_pty too dnl many times in the (rare) event of a failure. AC_DEFINE(FIRST_PTY_LETTER, ['z']) @@ -4996,7 +4970,7 @@ if test x$GCC = xyes; then AC_DEFINE(GC_SETJMP_WORKS, 1) else case $opsys in - aix* | dragonfly | freebsd | netbsd | openbsd | sol2* ) + aix* | dragonfly | freebsd | netbsd | openbsd | solaris ) AC_DEFINE(GC_SETJMP_WORKS, 1) ;; esac @@ -5043,7 +5017,7 @@ case $emacs_cv_func_sigsetjmp,$emacs_cv_alternate_stack,$opsys in esac case $opsys in - sol2* | unixware ) + solaris | unixware ) dnl TIOCGPGRP is broken in SysVr4, so we can't send signals to PTY dnl subprocesses the usual way. But TIOCSIGNAL does work for PTYs, dnl and this is all we need. @@ -5053,7 +5027,7 @@ esac case $opsys in - hpux* | sol2* ) + hpux* | solaris ) dnl Used in xfaces.c. AC_DEFINE(XOS_NEEDS_TIME_H, 1, [Compensate for a bug in Xos.h on some systems, where it requires time.h.]) @@ -5108,7 +5082,7 @@ case $opsys in fi ;; - sol2*) + solaris) AC_DEFINE(USG, []) AC_DEFINE(USG5_4, []) AC_DEFINE(SOLARIS2, [], [Define if the system is Solaris.]) @@ -5173,7 +5147,7 @@ case $opsys in reopen it in the child.]) ;; - sol2-10) + solaris) AC_DEFINE(_STRUCTURED_PROC, 1, [Needed for system_process_attributes on Solaris.]) ;; diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 91b1e996f45..56cd220e20e 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -2105,7 +2105,7 @@ To improve performance and accuracy of remote file access, @file{/usr/bin}, which are reasonable for most hosts. To accommodate differences in hosts and paths, for example, @file{/bin:/usr/bin} on Debian GNU/Linux or -@file{/usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin} on +@file{/usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/developerstudio12.6/bin} on Solaris, @value{tramp} queries the remote host with @command{getconf PATH} and updates the symbol @code{tramp-default-remote-path}. diff --git a/etc/MACHINES b/etc/MACHINES index 1bb244b49b0..78e9cef0fd7 100644 --- a/etc/MACHINES +++ b/etc/MACHINES @@ -81,25 +81,26 @@ the list at the end of this file. ** Solaris - On Solaris it is also possible to use either GCC or Solaris Studio - to build Emacs, by pointing ./configure to the right compiler: + On Solaris it is also possible to use either GCC or Oracle Developer + Studio to build Emacs, by pointing ./configure to the right compiler: - ./configure CC='/usr/sfw/bin/gcc' # GCC - ./configure CC='cc' # Solaris Studio + ./configure # Defaults to 'gcc' if available. + ./configure CC='cc' # Oracle Developer Studio - On Solaris, do not use /usr/ucb/cc. Use /opt/SUNWspro/bin/cc. Make - sure that /usr/ccs/bin and /opt/SUNWspro/bin are in your PATH before - /usr/ucb. (Most free software packages have the same requirement on - Solaris.) With this compiler, use '/opt/SUNWspro/bin/cc -E' as the + On Solaris, do not use /usr/ucb/cc. Use Oracle Developer Studio. + Make sure that /usr/ccs/bin and the Oracle Developer Studio bin + directory (e.g., /opt/developerstudio12.6/bin) are in your PATH + before /usr/ucb. (Most free software packages have the same + requirement on Solaris.) With this compiler, use 'cc -E' as the preprocessor. If this inserts extra whitespace into its output (see - the PROBLEMS file) then add the option '-Xs'. + the PROBLEMS file), add the option '-Xs'. To build a 64-bit Emacs (with larger maximum buffer size) on a - Solaris system which supports 64-bit executables, specify the -m64 + Solaris system that defaults to 32-bit executables, specify the -m64 compiler option. For example: - ./configure CC='/usr/sfw/bin/gcc -m64' # GCC - ./configure CC='cc -m64' # Solaris Studio + ./configure CC='gcc -m64' # GCC + ./configure CC='cc -m64' # Oracle Developer Studio * Obsolete platforms diff --git a/etc/PROBLEMS b/etc/PROBLEMS index 4ce738d9a54..598a79f978a 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -2222,6 +2222,7 @@ We list bugs in current versions here. See also the section on legacy systems. *** On Solaris 10, Emacs crashes during the build process. +(This applies only with './configure --with-unexec=yes', which is rare.) This was reported for Emacs 25.2 on i386-pc-solaris2.10 with Sun Studio 12 (Sun C 5.9) and with Oracle Developer Studio 12.6 (Sun C 5.15), and intermittently for sparc-sun-solaris2.10 with Oracle @@ -2239,66 +2240,6 @@ Solaris. See Bug#26638. This is a Solaris feature (at least on Intel x86 cpus). Type C-r C-r C-t, to toggle whether C-x gets through to Emacs. -*** Problem with remote X server on Suns. - -On a Sun, running Emacs on one machine with the X server on another -may not work if you have used the unshared system libraries. This -is because the unshared libraries fail to use YP for host name lookup. -As a result, the host name you specify may not be recognized. - -*** Solaris 2.6: Emacs crashes with SIGBUS or SIGSEGV on Solaris after you delete a frame. - -We suspect that this is a bug in the X libraries provided by -Sun. There is a report that one of these patches fixes the bug and -makes the problem stop: - -105216-01 105393-01 105518-01 105621-01 105665-01 105615-02 105216-02 -105667-01 105401-08 105615-03 105621-02 105686-02 105736-01 105755-03 -106033-01 105379-01 105786-01 105181-04 105379-03 105786-04 105845-01 -105284-05 105669-02 105837-01 105837-02 105558-01 106125-02 105407-01 - -Another person using a newer system (kernel patch level Generic_105181-06) -suspects that the bug was fixed by one of these more recent patches: - -106040-07 SunOS 5.6: X Input & Output Method patch -106222-01 OpenWindows 3.6: filemgr (ff.core) fixes -105284-12 Motif 1.2.7: sparc Runtime library patch - -*** Solaris 7 or 8: Emacs reports a BadAtom error (from X) - -This happens when Emacs was built on some other version of Solaris. -Rebuild it on Solaris 8. - -*** When using M-x dbx with the SparcWorks debugger, the 'up' and 'down' -commands do not move the arrow in Emacs. - -You can fix this by adding the following line to '~/.dbxinit': - - dbxenv output_short_file_name off - -*** On Solaris, CTRL-t is ignored by Emacs when you use -the fr.ISO-8859-15 locale (and maybe other related locales). - -You can fix this by editing the file: - - /usr/openwin/lib/locale/iso8859-15/Compose - -Near the bottom there is a line that reads: - - Ctrl : "\276" threequarters - -while it should read: - - Ctrl : "\276" threequarters - -Note the lower case . Changing this line should make C-t work. - -*** On Solaris, Emacs fails to set menu-bar-update-hook on startup, with error -"Error in menu-bar-update-hook: (error Point before start of properties)". -This seems to be a GCC optimization bug that occurs for GCC 4.1.2 (-g -and -g -O2) and GCC 4.2.3 (-g -O and -g -O2). You can fix this by -compiling with GCC 4.2.3 or CC 5.7, with no optimizations. - * Runtime problems specific to MS-Windows ** Emacs on Windows 9X requires UNICOWS.DLL @@ -2733,13 +2674,13 @@ Libxpm is available for macOS as part of the XQuartz project. This indicates a mismatch between the C compiler and preprocessor that configure is using. For example, on Solaris 10 trying to use -CC=/opt/SUNWspro/bin/cc (the Sun Studio compiler) together with -CPP=/usr/ccs/lib/cpp can result in errors of this form (you may also -see the error '"/usr/include/sys/isa_defs.h", line 500: undefined control'). +CC=/opt/developerstudio12.6/bin/cc (the Oracle Developer Studio +compiler) together with CPP=/usr/lib/cpp can result in errors of +this form. The solution is to tell configure to use the correct C preprocessor -for your C compiler (CPP="/opt/SUNWspro/bin/cc -E" in the above -example). +for your C compiler (CPP="/opt/developerstudio12.6/bin/cc -E" in the +above example). ** Compilation @@ -3110,7 +3051,69 @@ This section covers bugs reported on very old hardware or software. If you are using hardware and an operating system shipped after 2000, it is unlikely you will see any of these. -*** Solaris 2.x +** Solaris + +*** Problem with remote X server on Suns. + +On a Sun, running Emacs on one machine with the X server on another +may not work if you have used the unshared system libraries. This +is because the unshared libraries fail to use YP for host name lookup. +As a result, the host name you specify may not be recognized. + +*** Solaris 2.6: Emacs crashes with SIGBUS or SIGSEGV on Solaris after you delete a frame. + +We suspect that this is a bug in the X libraries provided by +Sun. There is a report that one of these patches fixes the bug and +makes the problem stop: + +105216-01 105393-01 105518-01 105621-01 105665-01 105615-02 105216-02 +105667-01 105401-08 105615-03 105621-02 105686-02 105736-01 105755-03 +106033-01 105379-01 105786-01 105181-04 105379-03 105786-04 105845-01 +105284-05 105669-02 105837-01 105837-02 105558-01 106125-02 105407-01 + +Another person using a newer system (kernel patch level Generic_105181-06) +suspects that the bug was fixed by one of these more recent patches: + +106040-07 SunOS 5.6: X Input & Output Method patch +106222-01 OpenWindows 3.6: filemgr (ff.core) fixes +105284-12 Motif 1.2.7: sparc Runtime library patch + +*** Solaris 7 or 8: Emacs reports a BadAtom error (from X) + +This happens when Emacs was built on some other version of Solaris. +Rebuild it on Solaris 8. + +*** When using M-x dbx with the SparcWorks debugger, the 'up' and 'down' +commands do not move the arrow in Emacs. + +You can fix this by adding the following line to '~/.dbxinit': + + dbxenv output_short_file_name off + +*** On Solaris, CTRL-t is ignored by Emacs when you use +the fr.ISO-8859-15 locale (and maybe other related locales). + +You can fix this by editing the file: + + /usr/openwin/lib/locale/iso8859-15/Compose + +Near the bottom there is a line that reads: + + Ctrl : "\276" threequarters + +while it should read: + + Ctrl : "\276" threequarters + +Note the lower case . Changing this line should make C-t work. + +*** On Solaris, Emacs fails to set menu-bar-update-hook on startup, with error +"Error in menu-bar-update-hook: (error Point before start of properties)". +This seems to be a GCC optimization bug that occurs for GCC 4.1.2 (-g +and -g -O2) and GCC 4.2.3 (-g -O and -g -O2). You can fix this by +compiling with GCC 4.2.3 or CC 5.7, with no optimizations. + +*** Other legacy Solaris problems **** Strange results from format %d in a few cases, on a Sun. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 806a3955e4d..777df79a6ef 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1014,8 +1014,8 @@ To undo the killing, the undo command can be used as normally." (defvar dired-compress-file-suffixes '( ;; "tar -zxf" isn't used because it's not available on the - ;; Solaris10 version of tar. Solaris10 becomes obsolete in 2021. - ;; Same thing on AIX 7.1. + ;; Solaris 10 version of tar (obsolete in 2024?). + ;; Same thing on AIX 7.1 (obsolete 2023?) and 7.2 (obsolete 2022?). ("\\.tar\\.gz\\'" "" "gzip -dc %i | tar -xf -") ("\\.tgz\\'" "" "gzip -dc %i | tar -xf -") ("\\.gz\\'" "" "gunzip") From 7384f194bebb161b8f4ef7617f8c328721cd433f Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 6 Aug 2020 08:12:31 +0200 Subject: [PATCH 076/145] Make 'byte-compile-info*' functions more logical * lisp/emacs-lisp/byte-run.el (byte-compile-info): New function that's more flexible that replaces 'byte-compile-info-string' and 'byte-compile-info-message'. (byte-compile-info-string): Make obsolete. (byte-compile-info-message): Ditto. * lisp/international/ja-dic-cnv.el (skkdic-convert-okuri-ari) (skkdic-convert-postfix, skkdic-convert-prefix) (skkdic-collect-okuri-nasi, skkdic-set-okuri-nasi): * lisp/finder.el (finder-compile-keywords): * lisp/cus-dep.el (custom-make-dependencies): Adjust callers to use the new function. --- lisp/cus-dep.el | 10 +++++----- lisp/emacs-lisp/byte-run.el | 17 +++++++++++++++-- lisp/finder.el | 2 +- lisp/international/ja-dic-cnv.el | 13 ++++++------- 4 files changed, 27 insertions(+), 15 deletions(-) diff --git a/lisp/cus-dep.el b/lisp/cus-dep.el index fd307a5c04e..f1061a8621b 100644 --- a/lisp/cus-dep.el +++ b/lisp/cus-dep.el @@ -70,7 +70,7 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS" (directory-files subdir nil "\\`[^=.].*\\.el\\'")))) (progress (make-progress-reporter - (byte-compile-info-string "Scanning files for custom") + (byte-compile-info "Scanning files for custom") 0 (length files) nil 10))) (with-temp-buffer (dolist (elem files) @@ -127,8 +127,8 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS" type))))))))))) (error nil))))))) (progress-reporter-done progress)) - (byte-compile-info-message "Generating %s..." - generated-custom-dependencies-file) + (byte-compile-info + (format "Generating %s..." generated-custom-dependencies-file) t) (set-buffer (find-file-noselect generated-custom-dependencies-file)) (setq buffer-undo-list t) (erase-buffer) @@ -217,8 +217,8 @@ elements the files that have variables or faces that contain that version. These files should be loaded before showing the customization buffer that `customize-changed-options' generates.\")\n\n")) (save-buffer) - (byte-compile-info-message "Generating %s...done" - generated-custom-dependencies-file)) + (byte-compile-info + (format "Generating %s...done" generated-custom-dependencies-file) t)) (provide 'cus-dep) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 88e21b73fed..5279a57cd0c 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -576,13 +576,26 @@ Otherwise, return nil. For internal use only." (mapconcat (lambda (char) (format "`?\\%c'" char)) sorted ", "))))) +(defun byte-compile-info (string &optional message type) + "Format STRING in a way that looks pleasing in the compilation output. +If MESSAGE, output the message, too. + +If TYPE, it should be a string that says what the information +type is. This defaults to \"INFO\"." + (let ((string (format " %-9s%s" (or type "INFO") string))) + (when message + (message "%s" string)) + string)) + (defun byte-compile-info-string (&rest args) "Format ARGS in a way that looks pleasing in the compilation output." - (format " %-9s%s" "INFO" (apply #'format args))) + (declare (obsolete byte-compile-info "28.1")) + (byte-compile-info (apply #'format args))) (defun byte-compile-info-message (&rest args) "Message format ARGS in a way that looks pleasing in the compilation output." - (message "%s" (apply #'byte-compile-info-string args))) + (declare (obsolete byte-compile-info "28.1")) + (byte-compile-info (apply #'format args) t)) ;; I nuked this because it's not a good idea for users to think of using it. diff --git a/lisp/finder.el b/lisp/finder.el index f04d73e098f..820d6d0a3b9 100644 --- a/lisp/finder.el +++ b/lisp/finder.el @@ -197,7 +197,7 @@ from; the default is `load-path'." (cons d f)) (directory-files d nil el-file-regexp)))) (progress (make-progress-reporter - (byte-compile-info-string "Scanning files for finder") + (byte-compile-info "Scanning files for finder") 0 (length files))) package-override base-name ; processed summary keywords package version entry desc) diff --git a/lisp/international/ja-dic-cnv.el b/lisp/international/ja-dic-cnv.el index 45e13462656..f5e70ce7021 100644 --- a/lisp/international/ja-dic-cnv.el +++ b/lisp/international/ja-dic-cnv.el @@ -48,7 +48,7 @@ (defvar ja-dic-filename "ja-dic.el") (defun skkdic-convert-okuri-ari (skkbuf buf) - (byte-compile-info-message "Processing OKURI-ARI entries") + (byte-compile-info "Processing OKURI-ARI entries" t) (goto-char (point-min)) (with-current-buffer buf (insert ";; Setting okuri-ari entries.\n" @@ -97,7 +97,7 @@ ("ゆき" "行"))) (defun skkdic-convert-postfix (skkbuf buf) - (byte-compile-info-message "Processing POSTFIX entries") + (byte-compile-info "Processing POSTFIX entries" t) (goto-char (point-min)) (with-current-buffer buf (insert ";; Setting postfix entries.\n" @@ -151,7 +151,7 @@ (defconst skkdic-prefix-list '(skkdic-prefix-list)) (defun skkdic-convert-prefix (skkbuf buf) - (byte-compile-info-message "Processing PREFIX entries") + (byte-compile-info "Processing PREFIX entries" t) (goto-char (point-min)) (with-current-buffer buf (insert ";; Setting prefix entries.\n" @@ -273,7 +273,7 @@ (defun skkdic-collect-okuri-nasi () (save-excursion (let ((progress (make-progress-reporter - (byte-compile-info-message "Collecting OKURI-NASI entries") + (byte-compile-info "Collecting OKURI-NASI entries" t) (point) (point-max) nil 10))) (while (re-search-forward "^\\(\\cH+\\) \\(/\\cj.*\\)/$" @@ -301,7 +301,7 @@ "(skkdic-set-okuri-nasi\n") (let ((l (nreverse skkdic-okuri-nasi-entries)) (progress (make-progress-reporter - (byte-compile-info-message "Processing OKURI-NASI entries") + (byte-compile-info "Processing OKURI-NASI entries" t) 0 skkdic-okuri-nasi-entries-count nil 10)) (count 0)) @@ -531,8 +531,7 @@ To get complete usage, invoke: ',(let ((l entries) (map '(skdic-okuri-nasi)) (progress (make-progress-reporter - (byte-compile-info-message - "Extracting OKURI-NASI entries") + (byte-compile-info "Extracting OKURI-NASI entries") 0 (length entries))) (count 0) entry) From 104dd3b641142671669fc52d33cbcf6cf5f29891 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 6 Aug 2020 08:20:09 +0200 Subject: [PATCH 077/145] Make the loaddefs scraping compilation output look more regular * lisp/Makefile.in ($(lisp)/loaddefs.el): Don't output the directories here. * lisp/emacs-lisp/autoload.el (batch-update-autoloads--summary): New function. (batch-update-autoloads): Use it to output the directories we're scraping. This changes the compilation output from: Directories for loaddefs: . ./calc ./calendar ./cedet ./cedet/ede ./cedet/semantic ./cedet/semantic/analyze ./cedet/semantic/bovine ./cedet/semantic/decorate ./cedet/semantic/symref ./cedet/semantic/wisent ./cedet/srecode ./emacs-lisp ./emulation ./erc ./eshell ./gnus ./image ./international ./language ./leim ./leim/ja-dic ./leim/quail ./mail ./mh-e ./net ./nxml ./org ./play ./progmodes ./textmodes ./url ./vc (but all on one long line) To: SCRAPE . ./calc ./calendar ./cedet ./cedet/ede ./cedet/semantic SCRAPE ./cedet/semantic/analyze ./cedet/semantic/bovine SCRAPE ./cedet/semantic/decorate ./cedet/semantic/symref SCRAPE ./cedet/semantic/wisent ./cedet/srecode ./emacs-lisp ./emulation SCRAPE ./erc ./eshell ./gnus ./image ./international ./language ./leim SCRAPE ./leim/ja-dic ./leim/quail ./mail ./mh-e ./net ./nxml ./org ./play SCRAPE ./progmodes ./textmodes ./url ./vc Compilation output with very long lines can be mistaken for errors when they scroll by fast in the compilation output. Making it look more like normal informational output avoids this confusion. --- lisp/Makefile.in | 1 - lisp/emacs-lisp/autoload.el | 16 +++++++++++++++- 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 57527bb5afc..84c5733918a 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -196,7 +196,6 @@ $(lisp)/finder-inf.el: autoloads .PHONY: $(lisp)/loaddefs.el $(lisp)/loaddefs.el: gen-lisp $(LOADDEFS) - @echo Directories for loaddefs: ${SUBDIRS_ALMOST} $(AM_V_GEN)$(emacs) -l autoload \ --eval '(setq autoload-ensure-writable t)' \ --eval '(setq autoload-builtin-package-versions t)' \ diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index ede4edcd57e..222a378566f 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1124,7 +1124,7 @@ write its autoloads into the specified file instead." ;; Elements remaining in FILES have no existing autoload sections yet. (let ((no-autoloads-time (or last-time '(0 0 0 0))) (progress (make-progress-reporter - (byte-compile-info-string + (byte-compile-info (concat "Scraping files for " (file-relative-name generated-autoload-file))) @@ -1167,6 +1167,19 @@ write its autoloads into the specified file instead." ;; file-local autoload-generated-file settings. (autoload-save-buffers)))) +(defun batch-update-autoloads--summary (strings) + (let ((message "")) + (while strings + (when (> (length (concat message " " (car strings))) 68) + (byte-compile-info message t "SCRAPE") + (setq message "")) + (setq message (if (zerop (length message)) + (car strings) + (concat message " " (car strings)))) + (setq strings (cdr strings))) + (when (> (length message) 0) + (byte-compile-info message t "SCRAPE")))) + ;;;###autoload (defun batch-update-autoloads () "Update loaddefs.el autoloads in batch mode. @@ -1190,6 +1203,7 @@ should be non-nil)." (or (string-match "\\`site-" file) (push (expand-file-name file) autoload-excludes))))))) (let ((args command-line-args-left)) + (batch-update-autoloads--summary args) (setq command-line-args-left nil) (apply #'update-directory-autoloads args))) From 47910420c0fd62976ffa075e35da8a8e3398a836 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 6 Aug 2020 08:24:56 +0200 Subject: [PATCH 078/145] Tweak the autoloads scrape output slightly * lisp/emacs-lisp/autoload.el (batch-update-autoloads--summary): Output " ..." at the end of the non-concluding lines to signify that the output continues. --- lisp/emacs-lisp/autoload.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 222a378566f..c76de43be91 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1170,8 +1170,8 @@ write its autoloads into the specified file instead." (defun batch-update-autoloads--summary (strings) (let ((message "")) (while strings - (when (> (length (concat message " " (car strings))) 68) - (byte-compile-info message t "SCRAPE") + (when (> (length (concat message " " (car strings))) 64) + (byte-compile-info (concat message " ...") t "SCRAPE") (setq message "")) (setq message (if (zerop (length message)) (car strings) From 7a56e5a44a390aaa29711d63f125f4b802df07c1 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 6 Aug 2020 09:09:57 +0200 Subject: [PATCH 079/145] Mark two cconv tests as :unstable * test/lisp/emacs-lisp/cconv-tests.el (cconv-tests-cl-iter-defun-:documentation): Mark as unstable (bug#42723). (cconv-tests-iter-defun-:documentation): Ditto. --- test/lisp/emacs-lisp/cconv-tests.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 148bcd69be1..0ea9742be49 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -82,6 +82,7 @@ (ert-deftest cconv-tests-cl-iter-defun-:documentation () "Docstring for cl-iter-defun can be specified with :documentation." ;; FIXME: See Bug#28557. + :tags '(:unstable) :expected-result :failed (should (string= (documentation 'cconv-tests-cl-iter-defun) "cl-iter-defun documentation")) @@ -94,6 +95,7 @@ (ert-deftest cconv-tests-iter-defun-:documentation () "Docstring for iter-defun can be specified with :documentation." ;; FIXME: See Bug#28557. + :tags '(:unstable) :expected-result :failed (should (string= (documentation 'cconv-tests-iter-defun) "iter-defun documentation")) From 361baa451adac7333e1037c3bc73bd95afa9b769 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 6 Aug 2020 11:51:22 +0200 Subject: [PATCH 080/145] Make 'n'/'p' in image mode buffers respect dired sorting The commands now also now work on archive and tar mode parent buffers. * doc/emacs/files.texi (Image Mode): Document it. * lisp/arc-mode.el (archive-goto-file): New function (bug#38647). (archive-next-file-displayer): Ditto. * lisp/image-mode.el (image-next-file): Reimplement to work on displayed dired buffers and the like. This means that `n' and `p' now works on the displayed ordering in the dired buffer, so if you've reversed the sorting, `n' picks the right "next" file. (image-mode--directory-buffers): New function. (image-mode--next-file): Ditto. * lisp/tar-mode.el (tar-goto-file): New function. (tar-next-file-displayer): Ditto. --- doc/emacs/files.texi | 7 +++- etc/NEWS | 9 ++++ lisp/arc-mode.el | 47 +++++++++++++++++++++ lisp/image-mode.el | 98 +++++++++++++++++++++++++++++++++++--------- lisp/tar-mode.el | 50 ++++++++++++++++++++++ 5 files changed, 191 insertions(+), 20 deletions(-) diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index 5998326ffef..2fa1ecc003d 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -2149,7 +2149,12 @@ To reset all transformations to the initial state, use @findex image-previous-file You can press @kbd{n} (@code{image-next-file}) and @kbd{p} (@code{image-previous-file}) to visit the next image file and the -previous image file in the same directory, respectively. +previous image file in the same directory, respectively. These +commands will consult the ``parent'' dired buffer to determine what +the next/previous image file is. These commands also work when +opening a file from archive files (like zip or tar files), and will +then instead consult the archive mode buffer. If neither an archive +nor a dired ``parent'' buffer can be found, a dired buffer is opened. @findex image-mode-mark-file @findex image-mode-unmark-file diff --git a/etc/NEWS b/etc/NEWS index 8c6e3e78139..cbb1842e139 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -538,6 +538,15 @@ 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 respects dired order. +These commands would previously display the next/previous image in +alphabetical 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. + ** EWW +++ diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 6781c292d82..901f09302ef 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -989,6 +989,53 @@ using `make-temp-file', and the generated name is returned." (kill-local-variable 'buffer-file-coding-system) (after-insert-file-set-coding (- (point-max) (point-min)))))) +(defun archive-goto-file (file) + "Go to FILE in the current buffer. +FILE should be a relative file name. If FILE can't be found, +return nil. Otherwise point is returned." + (let ((start (point)) + found) + (goto-char (point-min)) + (while (and (not found) + (not (eobp))) + (forward-line 1) + (when-let ((descr (archive-get-descr t))) + (when (equal (archive--file-desc-ext-file-name descr) file) + (setq found t)))) + (if (not found) + (progn + (goto-char start) + nil) + (point)))) + +(defun archive-next-file-displayer (file regexp n) + "Return a closure to display the next file after FILE that matches REGEXP." + (let ((short (replace-regexp-in-string "\\`.*:" "" file)) + next) + (archive-goto-file short) + (while (and (not next) + ;; Stop if we reach the end/start of the buffer. + (if (> n 0) + (not (eobp)) + (not (save-excursion + (beginning-of-line) + (bobp))))) + (archive-next-line n) + (when-let ((descr (archive-get-descr t))) + (let ((candidate (archive--file-desc-ext-file-name descr)) + (buffer (current-buffer))) + (when (and candidate + (string-match-p regexp candidate)) + (setq next (lambda () + (kill-buffer (current-buffer)) + (switch-to-buffer buffer) + (archive-extract))))))) + (unless next + ;; If we didn't find a next/prev file, then restore + ;; point. + (archive-goto-file short)) + next)) + (defun archive-extract (&optional other-window-p event) "In archive mode, extract this entry of the archive into its own buffer." (interactive (list nil last-input-event)) diff --git a/lisp/image-mode.el b/lisp/image-mode.el index c417be43da5..948e62e10d0 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -40,6 +40,7 @@ (require 'image) (require 'exif) +(require 'dired) (eval-when-compile (require 'cl-lib)) ;;; Image mode window-info management. @@ -1085,28 +1086,87 @@ replacing the current Image mode buffer." (error "The buffer is not in Image mode")) (unless buffer-file-name (error "The current image is not associated with a file")) - (let* ((file (file-name-nondirectory buffer-file-name)) - (images (image-mode--images-in-directory file)) - (idx 0)) - (catch 'image-visit-next-file - (dolist (f images) - (if (string= f file) - (throw 'image-visit-next-file (1+ idx))) - (setq idx (1+ idx)))) - (setq idx (mod (+ idx (or n 1)) (length images))) - (let ((image (nth idx images)) - (dir (file-name-directory buffer-file-name))) - (find-alternate-file image) - ;; If we have dired buffer(s) open to where this image is, then - ;; place point on it. + (let ((next (image-mode--next-file buffer-file-name n))) + (unless next + (user-error "No %s file in this directory" + (if (> n 0) + "next" + "prev"))) + (if (stringp next) + (find-alternate-file next) + (funcall next)))) + +(defun image-mode--directory-buffers (file) + "Return a alist of type/buffer for all \"parent\" buffers to image FILE. +This is normally a list of dired buffers, but can also be archive and +tar mode buffers." + (let ((buffers nil) + (dir (file-name-directory file))) + (cond + ((and (boundp 'tar-superior-buffer) + tar-superior-buffer) + (when (buffer-live-p tar-superior-buffer) + (push (cons 'tar tar-superior-buffer) buffers))) + ((and (boundp 'archive-superior-buffer) + archive-superior-buffer) + (when (buffer-live-p archive-superior-buffer) + (push (cons 'archive archive-superior-buffer) buffers))) + (t + ;; Find a dired buffer. (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (and (derived-mode-p 'dired-mode) + (with-current-buffer buffer + (when (and (derived-mode-p 'dired-mode) (equal (file-truename dir) (file-truename default-directory))) - (save-window-excursion - (switch-to-buffer (current-buffer) t t) - (dired-goto-file (expand-file-name image dir))))))))) + (push (cons 'dired (current-buffer)) buffers)))) + ;; If we can't find any buffers to navigate in, we open a dired + ;; buffer. + (unless buffers + (push (cons 'dired (find-file-noselect dir)) buffers) + (message "Opened a dired buffer on %s" dir)))) + buffers)) + +(declare-function archive-next-file-displayer "arc-mode") +(declare-function tar-next-file-displayer "tar-mode") + +(defun image-mode--next-file (file n) + "Go to the next image file in the parent buffer of FILE. +This is typically a dired buffer, but may also be a tar/archive buffer. +Return the next image file from that buffer. +If N is negative, go to the previous file." + (let ((regexp (image-file-name-regexp)) + (buffers (image-mode--directory-buffers file)) + next) + (dolist (buffer buffers) + ;; We do this traversal for all the dired buffers open on this + ;; directory. There probably is just one, but we want to move + ;; point in all of them. + (save-window-excursion + (switch-to-buffer (cdr buffer) t t) + (cl-case (car buffer) + ('dired + (dired-goto-file file) + (let (found) + (while (and (not found) + ;; Stop if we reach the end/start of the buffer. + (if (> n 0) + (not (eobp)) + (not (bobp)))) + (dired-next-line n) + (let ((candidate (dired-get-filename nil t))) + (when (and candidate + (string-match-p regexp candidate)) + (setq found candidate)))) + (if found + (setq next found) + ;; If we didn't find a next/prev file, then restore + ;; point. + (dired-goto-file file)))) + ('archive + (setq next (archive-next-file-displayer file regexp n))) + ('tar + (setq next (tar-next-file-displayer file regexp n)))))) + next)) (defun image-previous-file (&optional n) "Visit the preceding image in the same directory as the current file. diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 73978ffc4a7..5cf09f9055e 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -922,6 +922,56 @@ actually appear on disk when you save the tar-file's buffer." (setq buffer-undo-list nil)))) buffer)) +(defun tar-goto-file (file) + "Go to FILE in the current buffer. +FILE should be a relative file name. If FILE can't be found, +return nil. Otherwise point is returned." + (let ((start (point)) + found) + (goto-char (point-min)) + (while (and (not found) + (not (eobp))) + (forward-line 1) + (when-let ((descriptor (ignore-errors (tar-get-descriptor)))) + (when (equal (tar-header-name descriptor) file) + (setq found t)))) + (if (not found) + (progn + (goto-char start) + nil) + (point)))) + +(defun tar-next-file-displayer (file regexp n) + "Return a closure to display the next file after FILE that matches REGEXP." + (let ((short (replace-regexp-in-string "\\`.*!" "" file)) + next) + ;; The tar buffer chops off leading "./", so do the same + ;; here. + (setq short (replace-regexp-in-string "\\`\\./" "" file)) + (tar-goto-file short) + (while (and (not next) + ;; Stop if we reach the end/start of the buffer. + (if (> n 0) + (not (eobp)) + (not (save-excursion + (beginning-of-line) + (bobp))))) + (tar-next-line n) + (when-let ((descriptor (ignore-errors (tar-get-descriptor)))) + (let ((candidate (tar-header-name descriptor)) + (buffer (current-buffer))) + (when (and candidate + (string-match-p regexp candidate)) + (setq next (lambda () + (kill-buffer (current-buffer)) + (switch-to-buffer buffer) + (tar-extract))))))) + (unless next + ;; If we didn't find a next/prev file, then restore + ;; point. + (tar-goto-file short)) + next)) + (defun tar-extract (&optional other-window-p) "In Tar mode, extract this entry of the tar file into its own buffer." (interactive) From 66bdf77adfa115ad16ec8557c250f0e5683262b0 Mon Sep 17 00:00:00 2001 From: Nick Helm Date: Thu, 6 Aug 2020 12:11:57 +0200 Subject: [PATCH 081/145] Signal an error in dired when moving to a directory that doesn't exist * lisp/dired-aux.el (dired-do-create-files): Give an error when apparently moving to a directory name, and that directory doesn't exist (bug#38707). --- lisp/dired-aux.el | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 777df79a6ef..6587d039b72 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1978,6 +1978,10 @@ Optional arg HOW-TO determines how to treat the target. (apply (car into-dir) operation rfn-list fn-list target (cdr into-dir)) (if (not (or dired-one-file into-dir)) (error "Marked %s: target must be a directory: %s" operation target)) + (if (and (not (file-directory-p (car fn-list))) + (not (file-directory-p target)) + (directory-name-p target)) + (error "%s: Target directory does not exist: %s" operation target)) ;; rename-file bombs when moving directories unless we do this: (or into-dir (setq target (directory-file-name target))) (dired-create-files From b5ea24cb44a34ee433a6212d9791fe7aff711d3d Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 6 Aug 2020 14:50:40 +0200 Subject: [PATCH 082/145] Make it possible to use Message as a mailto: desktop handler * doc/misc/message.texi (System Mailer Setup): Document the usage. * lisp/gnus/gnus-art.el (gnus-url-mailto): Move most of the code here to 'message-mailto-1' (bug#38314). * lisp/gnus/message.el (message-parse-mailto-url): Mark as obsolete. (message-parse-mailto-url): Rewritten slightly from the above. (message-mailto): New command. (message-mailto-1): New function. --- doc/misc/message.texi | 24 ++++++++++++++++++ etc/NEWS | 10 ++++++++ etc/emacs-mail.desktop | 20 +++++++++++++++ lisp/gnus/gnus-art.el | 28 +++------------------ lisp/gnus/message.el | 57 ++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 114 insertions(+), 25 deletions(-) create mode 100644 etc/emacs-mail.desktop diff --git a/doc/misc/message.texi b/doc/misc/message.texi index 7a66422b17e..c9a466eae9f 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -99,6 +99,7 @@ sending it. * Resending:: Resending a mail message. * Bouncing:: Bouncing a mail message. * Mailing Lists:: Send mail to mailing lists. +* System Mailer Setup:: Using Message as the system mailer. @end menu You can customize the Message Mode tool bar, see @kbd{M-x @@ -529,6 +530,29 @@ It is considered good netiquette to honor MFT, as it is assumed the fellow who posted a message knows where the followups need to go better than you do. + +@node System Mailer Setup +@section System Mailer Setup +@cindex mailto: + +Emacs can be set up as the system mailer, so that Emacs is opened when +you click on @samp{mailto:} links in other programs. + +How this is done varies from system to system, but commonly there's a +way to set the default application for a @acronym{MIME} type, and the +relevant type here is @samp{x-scheme-handler/mailto;}. + +The application to start should be @samp{"emacs -f message-mailto %u"}. +This will start Emacs, and then run the @code{message-mailto} +command. It will parse the given @acronym{URL}, and set up a Message +buffer with the given parameters. + +For instance, @samp{mailto:larsi@@gnus.org;subject=This+is+a+test} +will open a Message buffer with the @samp{To:} header filled in with +@samp{"larsi@@gnus.org"} and the @samp{Subject:} header with +@samp{"This is a test"}. + + @node Commands @chapter Commands diff --git a/etc/NEWS b/etc/NEWS index cbb1842e139..2df7bac9d73 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -236,6 +236,16 @@ not. ** Message ++++ +*** New function 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. 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". + --- *** Change to default value of 'message-draft-headers' user option. The 'Date' symbol has been removed from the default value, meaning that diff --git a/etc/emacs-mail.desktop b/etc/emacs-mail.desktop new file mode 100644 index 00000000000..dec6cdb3459 --- /dev/null +++ b/etc/emacs-mail.desktop @@ -0,0 +1,20 @@ +Desktop Entry] +Categories=Network;Email; +Comment=GNU Emacs is an extensible, customizable text editor - and more +Exec=/home/larsi/src/emacs/trunk/src/emacs -f message-mailto %u +Icon=emacs +Name=Emacs (Mail) +MimeType=x-scheme-handler/mailto; +NoDisplay=false +Terminal=false +Type=Application +Desktop Entry] +Categories=Network;Email; +Comment=GNU Emacs is an extensible, customizable text editor - and more +Exec=emacs -f message-mailto %u +Icon=emacs +Name=Emacs (Mail) +MimeType=x-scheme-handler/mailto; +NoDisplay=false +Terminal=false +Type=Application diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index d33539bc7f7..1be8c48bcfc 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -8341,6 +8341,7 @@ url is put as the `gnus-button-url' overlay property on the button." (and (match-end 6) (list (string-to-number (match-string 6 address)))))))) (defun gnus-url-parse-query-string (query &optional downcase) + (declare (obsolete message-parse-mailto-url "28.1")) (let (retval pairs cur key val) (setq pairs (split-string query "&")) (while pairs @@ -8360,31 +8361,8 @@ url is put as the `gnus-button-url' overlay property on the button." (defun gnus-url-mailto (url) ;; Send mail to someone - (setq url (replace-regexp-in-string "\n" " " url)) - (when (string-match "mailto:/*\\(.*\\)" url) - (setq url (substring url (match-beginning 1) nil))) - (let* ((args (gnus-url-parse-query-string - (if (string-match "^\\?" url) - (substring url 1) - (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url) - (concat "to=" (match-string 1 url) "&" - (match-string 2 url)) - (concat "to=" url))))) - (subject (cdr-safe (assoc "subject" args))) - func) - (gnus-msg-mail) - (while args - (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) - (if (fboundp func) - (funcall func) - (message-position-on-field (caar args))) - (insert (replace-regexp-in-string - "\r\n" "\n" - (mapconcat #'identity (reverse (cdar args)) ", ") nil t)) - (setq args (cdr args))) - (if subject - (message-goto-body) - (message-goto-subject)))) + (gnus-msg-mail) + (message-mailto-1 url)) (defun gnus-button-embedded-url (address) "Activate ADDRESS with `browse-url'." diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index cf2b8eebc30..71ab63de39e 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -8708,6 +8708,63 @@ used to take the screenshot." (insert "\n\n") (message ""))) +(declare-function gnus-url-unhex-string "gnus-util") + +(defun message-parse-mailto-url (url) + "Parse a mailto: url." + (setq url (replace-regexp-in-string "\n" " " url)) + (when (string-match "mailto:/*\\(.*\\)" url) + (setq url (substring url (match-beginning 1) nil))) + (setq url (if (string-match "^\\?" url) + (substring url 1) + (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url) + (concat "to=" (match-string 1 url) "&" + (match-string 2 url)) + (concat "to=" url)))) + (let (retval pairs cur key val) + (setq pairs (split-string url "&")) + (while pairs + (setq cur (car pairs) + pairs (cdr pairs)) + (if (not (string-match "=" cur)) + nil ; Grace + (setq key (downcase (gnus-url-unhex-string + (substring cur 0 (match-beginning 0)))) + val (gnus-url-unhex-string (substring cur (match-end 0) nil) t)) + (setq cur (assoc key retval)) + (if cur + (setcdr cur (cons val (cdr cur))) + (setq retval (cons (list key val) retval))))) + retval)) + +;;;###autoload +(defun message-mailto () + "Function to be run to parse command line mailto: links. +This is meant to be used for MIME handlers: Setting the handler +for \"x-scheme-handler/mailto;\" to \"emacs -fn message-mailto %u\" +will then start up Emacs ready to compose mail." + (interactive) + ;; Send email + (message-mail) + (message-mailto-1 (car command-line-args-left)) + (setq command-line-args-left (cdr command-line-args-left))) + +(defun message-mailto-1 (url) + (let ((args (message-parse-mailto-url url))) + (dolist (arg args) + (unless (equal (car arg) "body") + (message-position-on-field (capitalize (car arg))) + (insert (replace-regexp-in-string + "\r\n" "\n" + (mapconcat #'identity (reverse (cdr arg)) ", ") nil t)))) + (when (assoc "body" args) + (message-goto-body) + (dolist (body (cdr (assoc "body" args))) + (insert body "\n"))) + (if (assoc "subject" args) + (message-goto-body) + (message-goto-subject)))) + (provide 'message) (run-hooks 'message-load-hook) From 51d063e484c185b7e1d9cb4c6bf56d67b9af4781 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 6 Aug 2020 15:11:48 +0200 Subject: [PATCH 083/145] Add a new HTML skeleton for relative (file) URLs * lisp/textmodes/sgml-mode.el (html-href-anchor-file): New skeleton and keystroke (bug#37644). --- etc/NEWS | 7 +++++++ lisp/textmodes/sgml-mode.el | 10 +++++++++- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/etc/NEWS b/etc/NEWS index 2df7bac9d73..c57773922ed 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -659,6 +659,13 @@ 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. + * New Modes and Packages in Emacs 28.1 diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index b5ff6a69671..1672dce4f23 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -1806,6 +1806,7 @@ This takes effect when first loading the library.") (define-key map "\C-c\C-cc" 'html-checkboxes) (define-key map "\C-c\C-cl" 'html-list-item) (define-key map "\C-c\C-ch" 'html-href-anchor) + (define-key map "\C-c\C-cf" 'html-href-anchor-file) (define-key map "\C-c\C-cn" 'html-name-anchor) (define-key map "\C-c\C-c#" 'html-id-anchor) (define-key map "\C-c\C-ci" 'html-image) @@ -1818,6 +1819,7 @@ This takes effect when first loading the library.") (define-key map "\C-cc" 'html-checkboxes) (define-key map "\C-cl" 'html-list-item) (define-key map "\C-ch" 'html-href-anchor) + (define-key map "\C-cf" 'html-href-anchor-file) (define-key map "\C-cn" 'html-name-anchor) (define-key map "\C-c#" 'html-id-anchor) (define-key map "\C-ci" 'html-image) @@ -1845,7 +1847,8 @@ This takes effect when first loading the library.") (define-key menu-map "\n" '("Line Break" . html-line)) (define-key menu-map "\r" '("Paragraph" . html-paragraph)) (define-key menu-map "i" '("Image" . html-image)) - (define-key menu-map "h" '("Href Anchor" . html-href-anchor)) + (define-key menu-map "h" '("Href Anchor URL" . html-href-anchor)) + (define-key menu-map "f" '("Href Anchor File" . html-href-anchor-file)) (define-key menu-map "n" '("Name Anchor" . html-name-anchor)) (define-key menu-map "#" '("ID Anchor" . html-id-anchor)) map) @@ -2453,6 +2456,11 @@ HTML Autoview mode is a buffer-local minor mode for use with ;; '(setq input "http:") "" _ "") +(define-skeleton html-href-anchor-file + "HTML anchor tag with href attribute (from a local file)." + (file-relative-name (read-file-name "File name: ") default-directory) + "" _ "") + (define-skeleton html-name-anchor "HTML anchor tag with name attribute." "Name: " From d3fabff99d4aa74f752956ea5b02be7a977efb94 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 6 Aug 2020 15:53:24 +0200 Subject: [PATCH 084/145] Change how Mail-Copies-To: never is handled in Message * lisp/gnus/message.el (message-get-reply-headers): Change how Mail-Copies-To: never is handled (bug#37591). When that header is present, put all the remaining recipients in the To header, instead of picking an arbitrary recipient to have in the To header, and the rest in the Cc header. --- etc/NEWS | 10 ++++++++++ lisp/gnus/message.el | 31 ++++++++++++++++++++++--------- 2 files changed, 32 insertions(+), 9 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index c57773922ed..185c649186a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -236,6 +236,16 @@ not. ** Message +--- +*** 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 function to start Emacs in Message mode to send an email. Emacs can be defined as a handler for the "x-scheme-handler/mailto" diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 71ab63de39e..6c0f9b5c9ba 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -6998,15 +6998,28 @@ want to get rid of this query permanently."))) ;; Build the header alist. Allow the user to be asked whether ;; or not to reply to all recipients in a wide reply. - (setq follow-to (list (cons 'To (cdr (pop recipients))))) - (when (and recipients - (or (not message-wide-reply-confirm-recipients) - (y-or-n-p "Reply to all recipients? "))) - (setq recipients (mapconcat - (lambda (addr) (cdr addr)) recipients ", ")) - (if (string-match "^ +" recipients) - (setq recipients (substring recipients (match-end 0)))) - (push (cons 'Cc recipients) follow-to))) + (when (or (< (length recipients) 2) + (not message-wide-reply-confirm-recipients) + (y-or-n-p "Reply to all recipients? ")) + (if never-mct + ;; The author has requested never to get a (wide) + ;; response, so put everybody else into the To header. + ;; This avoids looking as if we're To-in somebody else in + ;; specific, and just Cc-in the rest. + (setq follow-to (list + (cons 'To + (mapconcat + (lambda (addr) + (cdr addr)) recipients ", ")))) + ;; Put the first recipient in the To header. + (setq follow-to (list (cons 'To (cdr (pop recipients))))) + ;; Put the rest of the recipients in Cc. + (when recipients + (setq recipients (mapconcat + (lambda (addr) (cdr addr)) recipients ", ")) + (if (string-match "^ +" recipients) + (setq recipients (substring recipients (match-end 0)))) + (push (cons 'Cc recipients) follow-to))))) follow-to)) (defun message-prune-recipients (recipients) From c05f1020cecb4ef7d516e6575c86bf009c2e6f00 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 6 Aug 2020 16:47:21 +0200 Subject: [PATCH 085/145] Tweat how MML specifies the encoding of binary data * lisp/gnus/mml.el (mml-parse-1): Use `data-encoding' to be slightly less confusing than `content-transfer-encoding'. * doc/misc/emacs-mime.texi (MML Definition): Document it. * lisp/gnus/message.el (message-insert-screenshot): Adjust usage. --- doc/misc/emacs-mime.texi | 13 +++++++++++-- lisp/gnus/message.el | 2 +- lisp/gnus/mml.el | 4 ++-- 3 files changed, 14 insertions(+), 5 deletions(-) diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi index 974cc10458d..9180b4ec205 100644 --- a/doc/misc/emacs-mime.texi +++ b/doc/misc/emacs-mime.texi @@ -693,8 +693,17 @@ Valid values are @samp{inline} and @samp{attachment} @item encoding Valid values are @samp{7bit}, @samp{8bit}, @samp{quoted-printable} and -@samp{base64} (@code{Content-Transfer-Encoding}). @xref{Charset -Translation}. +@samp{base64}. @xref{Charset +Translation}. This parameter says what +@code{Content-Transfer-Encoding} to use when sending the part, and is +normally computed automatically. + +@item data-encoding +This parameter says what encoding has been used on the data, and the +data will be decoded before use. Valid values are +@samp{quoted-printable} and @samp{base64}. This is useful when you +have a part with binary data (for instance an image) inserted directly +into the Message buffer inside the @samp{"<#part>...<#/part>"} tags. @item description A description of the part (@code{Content-Description}). diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 6c0f9b5c9ba..819f3e41d3d 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -8709,7 +8709,7 @@ used to take the screenshot." :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 content-transfer-encoding=base64 raw=t>\n%s\n<#/part>" + (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. diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 1d348f3a6f0..ef8aa6ac019 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -298,12 +298,12 @@ part. This is for the internal use, you should never modify the value.") ;; We have a part that already has a transfer encoding. Undo ;; that so that we don't double-encode later. (when (and raw - (cdr (assq 'content-transfer-encoding tag))) + (cdr (assq 'data-encoding tag))) (with-temp-buffer (set-buffer-multibyte nil) (insert contents) (mm-decode-content-transfer-encoding - (intern (cdr (assq 'content-transfer-encoding tag))) + (intern (cdr (assq 'data-encoding tag))) (cdr (assq 'type tag))) (setq contents (buffer-string)))) (when (and (not raw) (memq nil charsets)) From cc365ca6d8ce24b882a39a062ce64f796693f974 Mon Sep 17 00:00:00 2001 From: Philip K Date: Wed, 5 Aug 2020 22:57:01 +0200 Subject: [PATCH 086/145] Remove usages of assoc-delete-all in project.el assoc-delete-all is not available for users who have installed project.el via ELPA on older Emacs versions (bug#42668). * lisp/progmodes/project.el (project-remember-project, project--remove-from-project-list): Replace assoc-delete-all with equivalent alternatives. --- lisp/progmodes/project.el | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 51b9347bb93..b6161351f0b 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1166,7 +1166,9 @@ Save the result in `project-list-file' if the list of projects has changed." (project--ensure-read-project-list) (let ((dir (project-root pr))) (unless (equal (caar project--list) dir) - (setq project--list (assoc-delete-all dir project--list)) + (dolist (ent project--list) + (when (equal dir (car ent)) + (setq project--list (delq ent project--list)))) (push (list dir) project--list) (project--write-project-list)))) @@ -1176,8 +1178,8 @@ If the directory was in the list before the removal, save the result in `project-list-file'. Announce the project's removal from the list." (project--ensure-read-project-list) - (when (assoc pr-dir project--list) - (setq project--list (assoc-delete-all pr-dir project--list)) + (when-let ((ent (assoc pr-dir project--list))) + (setq project--list (delq ent project--list)) (message "Project `%s' not found; removed from list" pr-dir) (project--write-project-list))) From c8b0005bad4779ef4d3a89aabd2011a7e187d8ff Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 6 Aug 2020 17:45:09 +0200 Subject: [PATCH 087/145] Fix broken desktop file Looks like I pasted in the data twice... --- etc/emacs-mail.desktop | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/etc/emacs-mail.desktop b/etc/emacs-mail.desktop index dec6cdb3459..3a96b9ec8c7 100644 --- a/etc/emacs-mail.desktop +++ b/etc/emacs-mail.desktop @@ -1,14 +1,4 @@ -Desktop Entry] -Categories=Network;Email; -Comment=GNU Emacs is an extensible, customizable text editor - and more -Exec=/home/larsi/src/emacs/trunk/src/emacs -f message-mailto %u -Icon=emacs -Name=Emacs (Mail) -MimeType=x-scheme-handler/mailto; -NoDisplay=false -Terminal=false -Type=Application -Desktop Entry] +[Desktop Entry] Categories=Network;Email; Comment=GNU Emacs is an extensible, customizable text editor - and more Exec=emacs -f message-mailto %u From 0aede2d8bfbf04b6c2be12c124f0feda998c2e53 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= Date: Thu, 6 Aug 2020 18:33:54 +0200 Subject: [PATCH 088/145] Fix the mailto: examples in the manual and in NEWS * doc/misc/message.texi (System Mailer Setup): Fix mailto: examples. --- doc/misc/message.texi | 2 +- etc/NEWS | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/misc/message.texi b/doc/misc/message.texi index c9a466eae9f..d8a889e29f3 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -547,7 +547,7 @@ This will start Emacs, and then run the @code{message-mailto} command. It will parse the given @acronym{URL}, and set up a Message buffer with the given parameters. -For instance, @samp{mailto:larsi@@gnus.org;subject=This+is+a+test} +For instance, @samp{mailto:larsi@@gnus.org?subject=This+is+a+test} will open a Message buffer with the @samp{To:} header filled in with @samp{"larsi@@gnus.org"} and the @samp{Subject:} header with @samp{"This is a test"}. diff --git a/etc/NEWS b/etc/NEWS index 185c649186a..81d07c9f325 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -254,7 +254,7 @@ An emacs-mail.desktop file has been included, suitable for installing in desktop directories like /usr/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". +"mailto:larsi@gnus.org?subject=This+is+a+test". --- *** Change to default value of 'message-draft-headers' user option. From 33b50e2fc9d43802e71e708e10605a0b1d04ad83 Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Thu, 6 Aug 2020 21:47:48 +0200 Subject: [PATCH 089/145] Show A C hint for loading complete message only in nnimap groups. * lisp/gnus/gnus-art.el (gnus-insert-mime-button): Show A C hint for loading complete message only in nnimap groups. --- lisp/gnus/gnus-art.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 1be8c48bcfc..09dfb826eb9 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -5849,7 +5849,9 @@ all parts." (concat "; " gnus-tmp-name)))) (unless (equal gnus-tmp-description "") (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) - (when (zerop gnus-tmp-length) + (when (and (zerop gnus-tmp-length) + ;; Only nnimap supports partial fetches so far. + (string-match "^nnimap\\+" gnus-newsgroup-name)) (setq gnus-tmp-type-long (concat gnus-tmp-type-long From 6cb6215cbe65a183e16adf9122280f8a0155ae10 Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Thu, 6 Aug 2020 21:52:18 +0200 Subject: [PATCH 090/145] Show A C hint only if partial fetches are enabled. * lisp/gnus/gnus-art.el (gnus-insert-mime-button): Show A C hint for downloading the complete message only if partial fetches are enabled. --- lisp/gnus/gnus-art.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 09dfb826eb9..e0339cc1f32 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -5851,6 +5851,7 @@ all parts." (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) (when (and (zerop gnus-tmp-length) ;; Only nnimap supports partial fetches so far. + nnimap-fetch-partial-articles (string-match "^nnimap\\+" gnus-newsgroup-name)) (setq gnus-tmp-type-long (concat From 33b293b41b2cc64aa085bad9051507922434ceda Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Thu, 6 Aug 2020 15:24:47 -0700 Subject: [PATCH 091/145] Update from Gnulib This incorporates: 2020-08-06 libgmp: add support 2020-08-06 Consider that clang defines __OPTIMIZE__ like GCC does 2020-08-06 Use __builtin_expect with clang everywhere 2020-08-05 Use __builtin_clz{,l,ll} with clang, also on Windows 2020-08-05 Use __builtin_ctz{,l,ll} and __builtin_ffs{,l,ll} with clang 2020-07-31 _GL_CMP: Improve documentation 2020-07-30 alloca, largefile: sync with Autoconf master * lib/c++defs.h, lib/cdefs.h, lib/count-leading-zeros.h: * lib/count-trailing-zeros.h, m4/alloca.m4, m4/gnulib-common.m4: * m4/largefile.m4, m4/libgmp.m4: Copy from Gnulib. * lib/gnulib.mk.in, m4/gnulib-comp.m4: Regenerate. --- lib/c++defs.h | 4 +- lib/cdefs.h | 2 +- lib/count-leading-zeros.h | 3 +- lib/count-trailing-zeros.h | 3 +- lib/gnulib.mk.in | 13 ++++-- m4/alloca.m4 | 14 +++--- m4/gnulib-common.m4 | 6 ++- m4/gnulib-comp.m4 | 2 +- m4/largefile.m4 | 2 +- m4/libgmp.m4 | 88 ++++++++++++++++++++------------------ 10 files changed, 78 insertions(+), 59 deletions(-) diff --git a/lib/c++defs.h b/lib/c++defs.h index 3e6aaabc9ce..182c2b3a88d 100644 --- a/lib/c++defs.h +++ b/lib/c++defs.h @@ -268,7 +268,7 @@ _GL_CXXALIASWARN_2 (func, namespace) /* To work around GCC bug , we enable the warning only when not optimizing. */ -# if !__OPTIMIZE__ +# if !(defined __GNUC__ && !defined __clang__ && __OPTIMIZE__) # define _GL_CXXALIASWARN_2(func,namespace) \ _GL_WARN_ON_USE (func, \ "The symbol ::" #func " refers to the system function. " \ @@ -296,7 +296,7 @@ _GL_CXXALIASWARN1_2 (func, rettype, parameters_and_attributes, namespace) /* To work around GCC bug , we enable the warning only when not optimizing. */ -# if !__OPTIMIZE__ +# if !(defined __GNUC__ && !defined __clang__ && __OPTIMIZE__) # define _GL_CXXALIASWARN1_2(func,rettype,parameters_and_attributes,namespace) \ _GL_WARN_ON_USE_CXX (func, rettype, parameters_and_attributes, \ "The symbol ::" #func " refers to the system function. " \ diff --git a/lib/cdefs.h b/lib/cdefs.h index d8e4a000333..f6c447ad377 100644 --- a/lib/cdefs.h +++ b/lib/cdefs.h @@ -401,7 +401,7 @@ # endif #endif -#if __GNUC__ >= 3 +#if (__GNUC__ >= 3) || (__clang_major__ >= 4) # define __glibc_unlikely(cond) __builtin_expect ((cond), 0) # define __glibc_likely(cond) __builtin_expect ((cond), 1) #else diff --git a/lib/count-leading-zeros.h b/lib/count-leading-zeros.h index 7e88c8cb9d0..7cf605a5f64 100644 --- a/lib/count-leading-zeros.h +++ b/lib/count-leading-zeros.h @@ -38,7 +38,8 @@ extern "C" { expand to code that computes the number of leading zeros of the local variable 'x' of type TYPE (an unsigned integer type) and return it from the current function. */ -#if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4) +#if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4) \ + || (__clang_major__ >= 4) # define COUNT_LEADING_ZEROS(BUILTIN, MSC_BUILTIN, TYPE) \ return x ? BUILTIN (x) : CHAR_BIT * sizeof x; #elif _MSC_VER diff --git a/lib/count-trailing-zeros.h b/lib/count-trailing-zeros.h index 1eb5fb919f4..727b21dcc56 100644 --- a/lib/count-trailing-zeros.h +++ b/lib/count-trailing-zeros.h @@ -38,7 +38,8 @@ extern "C" { expand to code that computes the number of trailing zeros of the local variable 'x' of type TYPE (an unsigned integer type) and return it from the current function. */ -#if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4) +#if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4) \ + || (__clang_major__ >= 4) # define COUNT_TRAILING_ZEROS(BUILTIN, MSC_BUILTIN, TYPE) \ return x ? BUILTIN (x) : CHAR_BIT * sizeof x; #elif _MSC_VER diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in index 4dc180d2e33..92d0621c61a 100644 --- a/lib/gnulib.mk.in +++ b/lib/gnulib.mk.in @@ -246,9 +246,10 @@ 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_H = @GL_GENERATE_GMP_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@ @@ -1085,7 +1086,6 @@ gamedir = @gamedir@ gamegroup = @gamegroup@ gameuser = @gameuser@ gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7 = @gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7@ -gl_GNULIB_ENABLED_2049e887c7e5308faad27b3f894bb8c9 = @gl_GNULIB_ENABLED_2049e887c7e5308faad27b3f894bb8c9@ gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b = @gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b@ gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31 = @gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31@ gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c = @gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c@ @@ -2021,15 +2021,22 @@ ifeq (,$(OMIT_GNULIB_MODULE_libgmp)) BUILT_SOURCES += $(GMP_H) +ifneq (,$(GL_GENERATE_MINI_GMP_H)) # Build gmp.h as a wrapper for mini-gmp.h when using mini-gmp. -ifneq (,$(GL_GENERATE_GMP_H)) gmp.h: $(top_builddir)/config.status echo '#include "mini-gmp.h"' >$@-t mv $@-t $@ else +ifneq (,$(GL_GENERATE_GMP_GMP_H)) +# Build gmp.h as a wrapper for gmp/gmp.h. +gmp.h: $(top_builddir)/config.status + echo '#include ' >$@-t + mv $@-t $@ +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 diff --git a/m4/alloca.m4 b/m4/alloca.m4 index d3e98c51bf4..b777f8450ce 100644 --- a/m4/alloca.m4 +++ b/m4/alloca.m4 @@ -1,4 +1,4 @@ -# alloca.m4 serial 16 +# alloca.m4 serial 17 dnl Copyright (C) 2002-2004, 2006-2007, 2009-2020 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation @@ -50,10 +50,13 @@ AC_DEFUN([gl_FUNC_ALLOCA], # STACK_DIRECTION is already handled by AC_FUNC_ALLOCA. AC_DEFUN([gl_PREREQ_ALLOCA], [:]) -# This works around a bug in autoconf <= 2.68. -# See and -# . -# Also it has a simplification that is not yet in Autoconf. +m4_version_prereq([2.70], [], [ + +# This works around a bug in autoconf <= 2.68 and has simplifications +# from 2.70. See: +# https://lists.gnu.org/r/bug-gnulib/2011-06/msg00277.html +# https://git.savannah.gnu.org/cgit/autoconf.git/commit/?id=6cd9f12520b0d6f76d3230d7565feba1ecf29497 +# https://git.savannah.gnu.org/cgit/autoconf.git/commit/?id=15edf7fd8094fd14a89d9891dd72a9624762597a # _AC_LIBOBJ_ALLOCA # ----------------- @@ -102,3 +105,4 @@ AH_VERBATIM([STACK_DIRECTION], @%:@undef STACK_DIRECTION])dnl AC_DEFINE_UNQUOTED(STACK_DIRECTION, $ac_cv_c_stack_direction) ]) +]) diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index 57f3a780118..50acc0a474b 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -1,4 +1,4 @@ -# gnulib-common.m4 serial 52 +# gnulib-common.m4 serial 53 dnl Copyright (C) 2007-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -300,7 +300,9 @@ AC_DEFUN([gl_COMMON_BODY], [ #define _GL_ASYNC_SAFE ]) AH_VERBATIM([micro_optimizations], -[/* _GL_CMP (n1, n2) performs a three-valued comparison on n1 vs. n2. +[/* _GL_CMP (n1, n2) performs a three-valued comparison on n1 vs. n2, where + n1 and n2 are expressions without side effects, that evaluate to real + numbers (excluding NaN). It returns 1 if n1 > n2 0 if n1 == n2 diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 4472af81b70..5bfa1473edd 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -346,7 +346,7 @@ AC_DEFUN([gl_INIT], AC_REQUIRE([gl_LARGEFILE]) gl___INLINE gl_LIBGMP - if test -n "$GMP_H"; then + if test $HAVE_LIBGMP != yes; then AC_LIBOBJ([mini-gmp-gnulib]) fi gl_LIMITS_H diff --git a/m4/largefile.m4 b/m4/largefile.m4 index 8017ca70eb4..f7140dd0a3a 100644 --- a/m4/largefile.m4 +++ b/m4/largefile.m4 @@ -35,7 +35,7 @@ m4_define([_AC_SYS_LARGEFILE_TEST_INCLUDES], We can't simply define LARGE_OFF_T to be 9223372036854775807, since some C++ compilers masquerading as C compilers incorrectly reject 9223372036854775807. */ -@%:@define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62)) +@%:@define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31)) int off_t_is_large[[(LARGE_OFF_T % 2147483629 == 721 && LARGE_OFF_T % 2147483647 == 1) ? 1 : -1]];[]dnl diff --git a/m4/libgmp.m4 b/m4/libgmp.m4 index 82c065e2c2c..1025f06a775 100644 --- a/m4/libgmp.m4 +++ b/m4/libgmp.m4 @@ -1,4 +1,4 @@ -# libgmp.m4 serial 4 +# libgmp.m4 serial 5 # Configure the GMP library or a replacement. dnl Copyright 2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation @@ -18,50 +18,54 @@ AC_DEFUN([gl_LIBGMP], [AS_HELP_STRING([--without-libgmp], [do not use the GNU Multiple Precision (GMP) library; this is the default on systems lacking libgmp.])]) - case "$with_libgmp" in - no) - HAVE_LIBGMP=no - LIBGMP= - LTLIBGMP= - ;; - *) - dnl Prefer AC_LIB_HAVE_LINKFLAGS if the havelib module is also in use. - m4_ifdef([gl_HAVE_MODULE_HAVELIB], - [AC_LIB_HAVE_LINKFLAGS([gmp], [], - [#include ], - [static const mp_limb_t x[2] = { 0x73, 0x55 }; - mpz_t tmp; - mpz_roinit_n (tmp, x, 2); - ], - [no])], - [gl_saved_LIBS=$LIBS - AC_SEARCH_LIBS([__gmpz_roinit_n], [gmp]) - LIBS=$gl_saved_LIBS - case $ac_cv_search___gmpz_roinit_n in - 'none needed') - HAVE_LIBGMP=yes LIBGMP=;; - -*) - HAVE_LIBGMP=yes LIBGMP=$ac_cv_search___gmpz_roinit_n;; - *) - HAVE_LIBGMP=no LIBGMP=;; - esac - LTLIBGMP=$LIBGMP - AC_SUBST([HAVE_LIBGMP]) - AC_SUBST([LIBGMP]) - AC_SUBST([LTLIBGMP])]) - if test "$with_libgmp,$HAVE_LIBGMP" = yes,no; then - AC_MSG_ERROR( - [GMP not found, although --with-libgmp was specified.m4_ifdef( - [AC_LIB_HAVE_LINKFLAGS], - [ Try specifying --with-libgmp-prefix=DIR.])]) - fi - ;; - esac - if test $HAVE_LIBGMP = yes; then + HAVE_LIBGMP=no + LIBGMP= + LTLIBGMP= + AS_IF([test "$with_libgmp" != no], + [AC_CHECK_HEADERS([gmp.h gmp/gmp.h], [break]) + dnl Prefer AC_LIB_HAVE_LINKFLAGS if the havelib module is also in use. + AS_IF([test "$ac_cv_header_gmp_h" = yes || + test "$ac_cv_header_gmp_gmp_h" = yes], + [m4_ifdef([gl_HAVE_MODULE_HAVELIB], + [AC_LIB_HAVE_LINKFLAGS([gmp], [], + [#if HAVE_GMP_H + # include + #else + # include + #endif], + [static const mp_limb_t x[2] = { 0x73, 0x55 }; + mpz_t tmp; + mpz_roinit_n (tmp, x, 2); + ], + [no])], + [gl_saved_LIBS=$LIBS + AC_SEARCH_LIBS([__gmpz_roinit_n], [gmp]) + LIBS=$gl_saved_LIBS + case $ac_cv_search___gmpz_roinit_n in + 'none needed') + HAVE_LIBGMP=yes;; + -*) + HAVE_LIBGMP=yes + LIBGMP=$ac_cv_search___gmpz_roinit_n + LTLIBGMP=$LIBGMP;; + esac + AC_SUBST([HAVE_LIBGMP]) + AC_SUBST([LIBGMP]) + AC_SUBST([LTLIBGMP])])]) + if test "$with_libgmp,$HAVE_LIBGMP" = yes,no; then + AC_MSG_ERROR( + [GMP not found, although --with-libgmp was specified.m4_ifdef( + [AC_LIB_HAVE_LINKFLAGS], + [ Try specifying --with-libgmp-prefix=DIR.])]) + fi]) + if test $HAVE_LIBGMP = yes && test "$ac_cv_header_gmp_h" = yes; then GMP_H= else GMP_H=gmp.h fi AC_SUBST([GMP_H]) - AM_CONDITIONAL([GL_GENERATE_GMP_H], [test -n "$GMP_H"]) + AM_CONDITIONAL([GL_GENERATE_MINI_GMP_H], + [test $HAVE_LIBGMP != yes]) + AM_CONDITIONAL([GL_GENERATE_GMP_GMP_H], + [test $HAVE_LIBGMP = yes && test "$ac_cv_header_gmp_h" != yes]) ]) From e038a7571ddb9ec2110533fdd1b359150939c58c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 6 Aug 2020 18:45:33 -0400 Subject: [PATCH 092/145] * lisp/skeleton.el: Use lexical-binding (skeleton-proxy-new): Use `use-region`. --- lisp/skeleton.el | 98 +++++++++++++++++++++++++----------------------- 1 file changed, 51 insertions(+), 47 deletions(-) diff --git a/lisp/skeleton.el b/lisp/skeleton.el index 3609d6ba6a0..ea4e5dbc227 100644 --- a/lisp/skeleton.el +++ b/lisp/skeleton.el @@ -1,4 +1,4 @@ -;;; skeleton.el --- Lisp language extension for writing statement skeletons +;;; skeleton.el --- Lisp language extension for writing statement skeletons -*- lexical-binding: t; -*- ;; Copyright (C) 1993-1996, 2001-2020 Free Software Foundation, Inc. @@ -155,8 +155,7 @@ of `str' whereas the skeleton's interactor is then ignored." (prefix-numeric-value (or arg current-prefix-arg)) (and skeleton-autowrap - (or (eq last-command 'mouse-drag-region) - (and transient-mark-mode mark-active)) + (use-region-p) ;; Deactivate the mark, in case one of the ;; elements of the skeleton is sensitive ;; to such situations (e.g. it is itself a @@ -259,23 +258,25 @@ available: (goto-char (car skeleton-regions)) (setq skeleton-regions (cdr skeleton-regions))) (let ((beg (point)) - skeleton-modified skeleton-point resume: help input v1 v2) - (setq skeleton-positions nil) - (unwind-protect - (cl-progv - (mapcar #'car skeleton-further-elements) - (mapcar (lambda (x) (eval (cadr x))) skeleton-further-elements) - (skeleton-internal-list skeleton str)) - (or (eolp) (not skeleton-end-newline) (newline-and-indent)) - (run-hooks 'skeleton-end-hook) - (sit-for 0) - (or (not (eq (window-buffer) (current-buffer))) - (pos-visible-in-window-p beg) - (progn - (goto-char beg) - (recenter 0))) - (if skeleton-point - (goto-char skeleton-point)))))) + skeleton-modified skeleton-point) ;; resume: + (with-suppressed-warnings ((lexical help input v1 v2)) + (dlet (help input v1 v2) + (setq skeleton-positions nil) + (unwind-protect + (cl-progv + (mapcar #'car skeleton-further-elements) + (mapcar (lambda (x) (eval (cadr x) t)) skeleton-further-elements) + (skeleton-internal-list skeleton str)) + (or (eolp) (not skeleton-end-newline) (newline-and-indent)) + (run-hooks 'skeleton-end-hook) + (sit-for 0) + (or (not (eq (window-buffer) (current-buffer))) + (pos-visible-in-window-p beg) + (progn + (goto-char beg) + (recenter 0))) + (if skeleton-point + (goto-char skeleton-point)))))))) (defun skeleton-read (prompt &optional initial-input recursive) "Function for reading a string from the minibuffer within skeletons. @@ -328,36 +329,39 @@ automatically, and you are prompted to fill in the variable parts."))) (signal 'quit t) prompt)) -(defun skeleton-internal-list (skeleton-il &optional str recursive) +(defun skeleton-internal-list (skeleton &optional str recursive) (let* ((start (line-beginning-position)) (column (current-column)) (line (buffer-substring start (line-end-position))) - opoint) - (or str - (setq str `(setq str - (skeleton-read ',(car skeleton-il) nil ,recursive)))) - (when (and (eq (cadr skeleton-il) '\n) (not recursive) - (save-excursion (skip-chars-backward " \t") (bolp))) - (setq skeleton-il (cons nil (cons '> (cddr skeleton-il))))) - (while (setq skeleton-modified (eq opoint (point)) - opoint (point) - skeleton-il (cdr skeleton-il)) - (condition-case quit - (skeleton-internal-1 (car skeleton-il) nil recursive) - (quit - (if (eq (cdr quit) 'recursive) - (setq recursive 'quit - skeleton-il (memq 'resume: skeleton-il)) - ;; Remove the subskeleton as far as it has been shown - ;; the subskeleton shouldn't have deleted outside current line. - (end-of-line) - (delete-region start (point)) - (insert line) - (move-to-column column) - (if (cdr quit) - (setq skeleton-il () - recursive nil) - (signal 'quit 'recursive))))))) + (skeleton-il skeleton) + opoint) + (with-suppressed-warnings ((lexical str)) + (dlet ((str (or str + `(setq str + (skeleton-read ',(car skeleton-il) + nil ,recursive))))) + (when (and (eq (cadr skeleton-il) '\n) (not recursive) + (save-excursion (skip-chars-backward " \t") (bolp))) + (setq skeleton-il (cons nil (cons '> (cddr skeleton-il))))) + (while (setq skeleton-modified (eq opoint (point)) + opoint (point) + skeleton-il (cdr skeleton-il)) + (condition-case quit + (skeleton-internal-1 (car skeleton-il) nil recursive) + (quit + (if (eq (cdr quit) 'recursive) + (setq recursive 'quit + skeleton-il (memq 'resume: skeleton-il)) + ;; Remove the subskeleton as far as it has been shown + ;; the subskeleton shouldn't have deleted outside current line. + (end-of-line) + (delete-region start (point)) + (insert line) + (move-to-column column) + (if (cdr quit) + (setq skeleton-il () + recursive nil) + (signal 'quit 'recursive))))))))) ;; maybe continue loop or go on to next outer resume: section (if (eq recursive 'quit) (signal 'quit 'recursive) From 874e0e7323631a5da61fa5a7fd35d7a3d9c4af61 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Fri, 7 Aug 2020 02:55:00 +0300 Subject: [PATCH 093/145] * lisp/hi-lock.el (hi-lock-set-pattern): Display warning on narrow (bug#42609) --- lisp/hi-lock.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index a18310322ad..33ca40f8dec 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -812,7 +812,9 @@ SPACES-REGEXP is a regexp to substitute spaces in font-lock search." (setq hi-lock-interactive-patterns (cdr hi-lock-interactive-patterns) hi-lock-interactive-lighters - (cdr hi-lock-interactive-lighters))))))))) + (cdr hi-lock-interactive-lighters)))) + (when (or (> search-start (point-min)) (< search-end (point-max))) + (message "Hi-lock added only in range %d-%d" search-start search-end))))))) (defun hi-lock-set-file-patterns (patterns) "Replace file patterns list with PATTERNS and refontify." From 74606481c2859b843ebf3f744c215447458becc2 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Thu, 6 Aug 2020 19:11:58 -0700 Subject: [PATCH 094/145] Pacify gcc -Wunused-variable * src/frame.c (Fset_mouse_position, Fset_mouse_pixel_position) (Fset_frame_position): Always use xval, yval. Simplify #if nesting. --- src/frame.c | 33 +++++++++++++++------------------ 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/src/frame.c b/src/frame.c index c21d4708f75..c4dfc35a0c5 100644 --- a/src/frame.c +++ b/src/frame.c @@ -2565,21 +2565,18 @@ before calling this function on it, like this. if (FRAME_WINDOW_P (XFRAME (frame))) /* Warping the mouse will cause enternotify and focus events. */ frame_set_mouse_position (XFRAME (frame), xval, yval); -#else -#if defined (MSDOS) +#elif defined MSDOS if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); mouse_moveto (xval, yval); } +#elif defined HAVE_GPM + Fselect_frame (frame, Qnil); + term_mouse_moveto (xval, yval); #else -#ifdef HAVE_GPM - { - Fselect_frame (frame, Qnil); - term_mouse_moveto (xval, yval); - } -#endif -#endif + (void) xval; + (void) yval; #endif return Qnil; @@ -2606,21 +2603,18 @@ before calling this function on it, like this. if (FRAME_WINDOW_P (XFRAME (frame))) /* Warping the mouse will cause enternotify and focus events. */ frame_set_mouse_pixel_position (XFRAME (frame), xval, yval); -#else -#if defined (MSDOS) +#elif defined MSDOS if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); mouse_moveto (xval, yval); } +#elif defined HAVE_GPM + Fselect_frame (frame, Qnil); + term_mouse_moveto (xval, yval); #else -#ifdef HAVE_GPM - { - Fselect_frame (frame, Qnil); - term_mouse_moveto (xval, yval); - } -#endif -#endif + (void) xval; + (void) yval; #endif return Qnil; @@ -3657,6 +3651,9 @@ bottom edge of FRAME's display. */) #ifdef HAVE_WINDOW_SYSTEM if (FRAME_TERMINAL (f)->set_frame_offset_hook) FRAME_TERMINAL (f)->set_frame_offset_hook (f, xval, yval, 1); +#else + (void) xval; + (void) yval; #endif } From 2a35e54bd5644c52dad99dc2597aff2c4165e1e0 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 7 Aug 2020 09:28:14 +0200 Subject: [PATCH 095/145] Make whitespace-mode highlight missing newlines at the end of buffers * lisp/whitespace.el (whitespace-missing-newline-at-eof): New face (bug#34952). (whitespace-report-region): Add a test for end-of-buffer-without-newline. (whitespace-color-on): Ditto. * doc/emacs/display.texi (Useless Whitespace): Document it. --- doc/emacs/display.texi | 4 ++++ etc/NEWS | 7 +++++++ lisp/whitespace.el | 19 +++++++++++++++++-- 3 files changed, 28 insertions(+), 2 deletions(-) diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index e96e43b377d..5778d95b4d4 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -1334,6 +1334,10 @@ customize the variable @code{whitespace-line-column}. @item newline Highlight newlines. +@item missing-newline-at-eof +Highlight the final character in a buffer unless it's a newline +character. + @item empty Highlight empty lines at the beginning and/or end of the buffer. diff --git a/etc/NEWS b/etc/NEWS index 81d07c9f325..ff3aa8445a6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -451,6 +451,13 @@ 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 + +*** A new style has been added: 'missing-newline-at-eof' +If present in 'whitespace-style' (and it is now by default), the final +character in the buffer will be highlighted unless it's a newline +character. + ** Texinfo --- diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 47434bf3d2e..fb5f28c0029 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -283,7 +283,8 @@ '(face tabs spaces trailing lines space-before-tab newline indentation empty space-after-tab - space-mark tab-mark newline-mark) + space-mark tab-mark newline-mark + missing-newline-at-eof) "Specify which kind of blank is visualized. It's a list containing some or all of the following values: @@ -326,6 +327,11 @@ It's a list containing some or all of the following values: It has effect only if `face' (see above) is present in `whitespace-style'. + missing-newline-at-eof Missing newline at the end of the file is + visualized via faces. + It has effect only if `face' (see above) + is present in `whitespace-style'. + empty empty lines at beginning and/or end of buffer are visualized via faces. It has effect only if `face' (see above) @@ -586,6 +592,10 @@ line. Used when `whitespace-style' includes the value `indentation'.") "Face used to visualize big indentation." :group 'whitespace) +(defface whitespace-missing-newline-at-eof + '((((class mono)) :inverse-video t :weight bold :underline t) + (t :background "red" :foreground "firebrick")) + "Face used to visualize missing newline at the end of the file.") (defvar whitespace-empty 'whitespace-empty "Symbol face used to visualize empty lines at beginning and/or end of buffer. @@ -1700,6 +1710,8 @@ cleaning up these problems." (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) @@ -2122,7 +2134,10 @@ resultant list will be returned." ((memq 'space-after-tab::space whitespace-active-style) ;; Show SPACEs after TAB (TABs). (whitespace-space-after-tab-regexp 'space))) - 1 whitespace-space-after-tab t))))) + 1 whitespace-space-after-tab t))) + ,@(when (memq 'missing-newline-at-eof whitespace-active-style) + ;; Show missing newline. + `(("[^\n]\\'" 0 'whitespace-missing-newline-at-eof t))))) (font-lock-add-keywords nil whitespace-font-lock-keywords t) (font-lock-flush))) From b83f274869e60342d978ad7e12c5167f0dc8f2a6 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 7 Aug 2020 09:30:07 +0200 Subject: [PATCH 096/145] Add missing "this is documented" marker to previous checkin --- etc/NEWS | 1 + 1 file changed, 1 insertion(+) diff --git a/etc/NEWS b/etc/NEWS index ff3aa8445a6..64b77feb119 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -453,6 +453,7 @@ The new default value is 2000000 (2 megabytes). ** Whitespace mode ++++ *** A new style has been added: 'missing-newline-at-eof' If present in 'whitespace-style' (and it is now by default), the final character in the buffer will be highlighted unless it's a newline From 204273c3b9f0a77459661790aa929f86067a9ab1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Mon, 3 Aug 2020 15:29:41 +0200 Subject: [PATCH 097/145] Fix byte-compilation of (+ -0.0) (bug#42597) * lisp/emacs-lisp/bytecomp.el (byte-compile-associative): Translate numerical identity expressions, such as (+ x) and (* x), into (* x 1) since the previous translation (+ x 0) gets it wrong for x = -0.0. * test/lisp/emacs-lisp/bytecomp-tests.el (byte-opt-testsuite-arith-data): Add test cases. --- lisp/emacs-lisp/bytecomp.el | 6 +++--- test/lisp/emacs-lisp/bytecomp-tests.el | 5 +++++ 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 22e648e44ba..8f76a3abb99 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3733,7 +3733,7 @@ discarding." ;; Compile a function that accepts one or more args and is right-associative. ;; We do it by left-associativity so that the operations ;; are done in the same order as in interpreted code. -;; We treat the one-arg case, as in (+ x), like (+ x 0). +;; We treat the one-arg case, as in (+ x), like (* x 1). ;; in order to convert markers to numbers, and trigger expected errors. (defun byte-compile-associative (form) (if (cdr form) @@ -3748,8 +3748,8 @@ discarding." (setq args (copy-sequence (cdr form))) (byte-compile-form (car args)) (setq args (cdr args)) - (or args (setq args '(0) - opcode (get '+ 'byte-opcode))) + (or args (setq args '(1) + opcode (get '* 'byte-opcode))) (dolist (arg args) (byte-compile-form arg) (byte-compile-out opcode 0)))) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index c235dd43fcc..894914300ae 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -47,6 +47,11 @@ (let ((a 1.0)) (/ 3 a 2)) (let ((a most-positive-fixnum) (b 2.0)) (* a 2 b)) (let ((a 3) (b 2)) (/ a b 1.0)) + (let ((a -0.0)) (+ a)) + (let ((a -0.0)) (- a)) + (let ((a -0.0)) (* a)) + (let ((a -0.0)) (min a)) + (let ((a -0.0)) (max a)) (/ 3 -1) (+ 4 3 2 1) (+ 4 3 2.0 1) From 0facaeec1a37481536b6cef13c88d9728c2ec29b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Mon, 3 Aug 2020 16:29:06 +0200 Subject: [PATCH 098/145] Clean up and improve compilation of arithmetic (bug#42597) * lisp/emacs-lisp/byte-opt.el (byte-optimize-associative-math) (byte-optimize-min-max): Transform 3-arg min/max call into two 2-arg calls, which is faster. * lisp/emacs-lisp/bytecomp.el (byte-compile-associative): Rename to... (byte-compile-variadic-numeric): ...this function and simplify, fixing incorrect comments. The 3-arg strength reduction is now always done in the optimisers and is no longer needed here. (byte-compile-min-max): New function. (byte-compile-minus): Simplify, remove incorrect comment, and use byte-compile-variadic-numeric. (byte-compile-quo): Simplify and fix comment. --- lisp/emacs-lisp/byte-opt.el | 29 ++++++++---- lisp/emacs-lisp/bytecomp.el | 93 +++++++++++++++++-------------------- 2 files changed, 62 insertions(+), 60 deletions(-) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 0d9c449b3b4..4987596bf95 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -648,14 +648,23 @@ (setq args (cons (car rest) args))) (setq rest (cdr rest))) (if (cdr constants) - (if args - (list (car form) - (apply (car form) constants) - (if (cdr args) - (cons (car form) (nreverse args)) - (car args))) - (apply (car form) constants)) - form))) + (let ((const (apply (car form) (nreverse constants)))) + (if args + (append (list (car form) const) + (nreverse args)) + const)) + form))) + +(defun byte-optimize-min-max (form) + "Optimize `min' and `max'." + (let ((opt (byte-optimize-associative-math form))) + (if (and (consp opt) (memq (car opt) '(min max)) + (= (length opt) 4)) + ;; (OP x y z) -> (OP (OP x y) z), in order to use binary byte ops. + (list (car opt) + (list (car opt) (nth 1 opt) (nth 2 opt)) + (nth 3 opt)) + opt))) ;; Use OP to reduce any leading prefix of constant numbers in the list ;; (cons ACCUM ARGS) down to a single number, and return the @@ -878,8 +887,8 @@ (put '* 'byte-optimizer #'byte-optimize-multiply) (put '- 'byte-optimizer #'byte-optimize-minus) (put '/ 'byte-optimizer #'byte-optimize-divide) -(put 'max 'byte-optimizer #'byte-optimize-associative-math) -(put 'min 'byte-optimizer #'byte-optimize-associative-math) +(put 'max 'byte-optimizer #'byte-optimize-min-max) +(put 'min 'byte-optimizer #'byte-optimize-min-max) (put '= 'byte-optimizer #'byte-optimize-binary-predicate) (put 'eq 'byte-optimizer #'byte-optimize-binary-predicate) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 8f76a3abb99..7ae8749ab40 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3580,10 +3580,10 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler (% byte-rem) 2) (byte-defop-compiler aset 3) -(byte-defop-compiler max byte-compile-associative) -(byte-defop-compiler min byte-compile-associative) -(byte-defop-compiler (+ byte-plus) byte-compile-associative) -(byte-defop-compiler (* byte-mult) byte-compile-associative) +(byte-defop-compiler max byte-compile-min-max) +(byte-defop-compiler min byte-compile-min-max) +(byte-defop-compiler (+ byte-plus) byte-compile-variadic-numeric) +(byte-defop-compiler (* byte-mult) byte-compile-variadic-numeric) ;;####(byte-defop-compiler move-to-column 1) (byte-defop-compiler-1 interactive byte-compile-noop) @@ -3730,30 +3730,36 @@ discarding." (if byte-compile--for-effect (setq byte-compile--for-effect nil) (byte-compile-out 'byte-constant (nth 1 form)))) -;; Compile a function that accepts one or more args and is right-associative. -;; We do it by left-associativity so that the operations -;; are done in the same order as in interpreted code. -;; We treat the one-arg case, as in (+ x), like (* x 1). -;; in order to convert markers to numbers, and trigger expected errors. -(defun byte-compile-associative (form) +;; Compile a pure function that accepts zero or more numeric arguments +;; and has an opcode for the binary case. +;; Single-argument calls are assumed to be numeric identity and are +;; compiled as (* x 1) in order to convert markers to numbers and +;; trigger type errors. +(defun byte-compile-variadic-numeric (form) + (pcase (length form) + (1 + ;; No args: use the identity value for the operation. + (byte-compile-constant (eval form))) + (2 + ;; One arg: compile (OP x) as (* x 1). This is identity for + ;; all numerical values including -0.0, infinities and NaNs. + (byte-compile-form (nth 1 form)) + (byte-compile-constant 1) + (byte-compile-out (get '* 'byte-opcode) 0)) + (3 + (byte-compile-form (nth 1 form)) + (byte-compile-form (nth 2 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0)) + (_ + ;; >2 args: compile as a single function call. + (byte-compile-normal-call form)))) + +(defun byte-compile-min-max (form) + "Byte-compile calls to `min' or `max'." (if (cdr form) - (let ((opcode (get (car form) 'byte-opcode)) - args) - (if (and (< 3 (length form)) - (memq opcode (list (get '+ 'byte-opcode) - (get '* 'byte-opcode)))) - ;; Don't use binary operations for > 2 operands, as that - ;; may cause overflow/truncation in float operations. - (byte-compile-normal-call form) - (setq args (copy-sequence (cdr form))) - (byte-compile-form (car args)) - (setq args (cdr args)) - (or args (setq args '(1) - opcode (get '* 'byte-opcode))) - (dolist (arg args) - (byte-compile-form arg) - (byte-compile-out opcode 0)))) - (byte-compile-constant (eval form)))) + (byte-compile-variadic-numeric form) + ;; No args: warn and emit code that raises an error when executed. + (byte-compile-normal-call form))) ;; more complicated compiler macros @@ -3768,7 +3774,7 @@ discarding." (byte-defop-compiler indent-to) (byte-defop-compiler insert) (byte-defop-compiler-1 function byte-compile-function-form) -(byte-defop-compiler-1 - byte-compile-minus) +(byte-defop-compiler (- byte-diff) byte-compile-minus) (byte-defop-compiler (/ byte-quo) byte-compile-quo) (byte-defop-compiler nconc) @@ -3835,30 +3841,17 @@ discarding." ((byte-compile-normal-call form))))) (defun byte-compile-minus (form) - (let ((len (length form))) - (cond - ((= 1 len) (byte-compile-constant 0)) - ((= 2 len) - (byte-compile-form (cadr form)) - (byte-compile-out 'byte-negate 0)) - ((= 3 len) - (byte-compile-form (nth 1 form)) - (byte-compile-form (nth 2 form)) - (byte-compile-out 'byte-diff 0)) - ;; Don't use binary operations for > 2 operands, as that may - ;; cause overflow/truncation in float operations. - (t (byte-compile-normal-call form))))) + (if (/= (length form) 2) + (byte-compile-variadic-numeric form) + (byte-compile-form (cadr form)) + (byte-compile-out 'byte-negate 0))) (defun byte-compile-quo (form) - (let ((len (length form))) - (cond ((< len 2) - (byte-compile-subr-wrong-args form "1 or more")) - ((= len 3) - (byte-compile-two-args form)) - (t - ;; Don't use binary operations for > 2 operands, as that - ;; may cause overflow/truncation in float operations. - (byte-compile-normal-call form))))) + (if (= (length form) 3) + (byte-compile-two-args form) + ;; N-ary `/' is not the left-reduction of binary `/' because if any + ;; argument is a float, then everything is done in floating-point. + (byte-compile-normal-call form))) (defun byte-compile-nconc (form) (let ((len (length form))) From 8a9b13be10fcb95481b177cf8c873fc41e0eb8dc Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 7 Aug 2020 11:30:55 +0200 Subject: [PATCH 099/145] Allow ffap to do the right thing with 'https://gnu.org' * lisp/thingatpt.el (thing-at-point-bounds-of-url-at-point): Don't include trailing ' in the URL, because it's more likely to be a punctuation character (bug#29410). --- lisp/thingatpt.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 1a15df33e50..483a2c9bd83 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -334,7 +334,7 @@ the bounds of a possible ill-formed URI (one lacking a scheme)." ;; may contain parentheses but may not contain spaces (RFC3986). (let* ((allowed-chars "--:=&?$+@-Z_[:alpha:]~#,%;*()!'") (skip-before "^[0-9a-zA-Z]") - (skip-after ":;.,!?") + (skip-after ":;.,!?'") (pt (point)) (beg (save-excursion (skip-chars-backward allowed-chars) From 9c34b50fa17565311d1868de6a6557d128ed9206 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 7 Aug 2020 11:59:25 +0200 Subject: [PATCH 100/145] Add a new command to copy a file from zip files * lisp/arc-mode.el (archive-copy-file): New command, keystroke and menu bar entry (bug#26192). (archive-extract): Refactored out code from here... (archive--extract-file): ... to here for use in archive-copy-file. --- etc/NEWS | 5 ++++ lisp/arc-mode.el | 66 +++++++++++++++++++++++++++++++++--------------- 2 files changed, 51 insertions(+), 20 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 64b77feb119..002a078f840 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -175,6 +175,11 @@ and variables. 'archive-hideshow-column'. These 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 under point and writes the data to a +file. + ** Emacs Lisp mode *** The mode-line now indicates whether we're using lexical or dynamic scoping. diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 901f09302ef..97213ab9e12 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -391,6 +391,7 @@ file. Archive and member name will be added." (define-key map "e" 'archive-extract) (define-key map "f" 'archive-extract) (define-key map "\C-m" 'archive-extract) + (define-key map "C" 'archive-copy-file) (define-key map "m" 'archive-mark) (define-key map "n" 'archive-next-line) (define-key map "\C-n" 'archive-next-line) @@ -430,6 +431,9 @@ file. Archive and member name will be added." (define-key map [menu-bar immediate view] '(menu-item "View This File" archive-view :help "Display file at cursor in View Mode")) + (define-key map [menu-bar immediate view] + '(menu-item "Copy This File" archive-copy-file + :help "Copy file at cursor to another location")) (define-key map [menu-bar immediate display] '(menu-item "Display in Other Window" archive-display-other-window :help "Display file at cursor in another window")) @@ -1036,6 +1040,26 @@ return nil. Otherwise point is returned." (archive-goto-file short)) next)) +(defun archive-copy-file (file new-name) + "Copy file under point to a different location." + (interactive + (let ((name (archive--file-desc-ext-file-name (archive-get-descr)))) + (list name + (read-file-name (format "Copy %s to: " name))))) + (when (file-directory-p new-name) + (setq new-name (expand-file-name file new-name))) + (when (and (file-exists-p new-name) + (not (yes-or-no-p (format "%s already exists; overwrite? " + new-name)))) + (user-error "Not overwriting %s" new-name)) + (let* ((descr (archive-get-descr)) + (archive (buffer-file-name)) + (extractor (archive-name "extract")) + (ename (archive--file-desc-ext-file-name descr))) + (with-temp-buffer + (archive--extract-file extractor archive ename) + (write-region (point-min) (point-max) new-name)))) + (defun archive-extract (&optional other-window-p event) "In archive mode, extract this entry of the archive into its own buffer." (interactive (list nil last-input-event)) @@ -1077,26 +1101,7 @@ return nil. Otherwise point is returned." (setq archive-subfile-mode descr) (setq archive-file-name-coding-system file-name-coding) (if (and - (null - (let (;; We may have to encode the file name argument for - ;; external programs. - (coding-system-for-write - (and enable-multibyte-characters - archive-file-name-coding-system)) - ;; We read an archive member by no-conversion at - ;; first, then decode appropriately by calling - ;; archive-set-buffer-as-visiting-file later. - (coding-system-for-read 'no-conversion) - ;; Avoid changing dir mtime by lock_file - (create-lockfiles nil)) - (condition-case err - (if (fboundp extractor) - (funcall extractor archive ename) - (archive-*-extract archive ename - (symbol-value extractor))) - (error - (ding (message "%s" (error-message-string err))) - nil)))) + (null (archive--extract-file extractor archive ename)) just-created) (progn (set-buffer-modified-p nil) @@ -1129,6 +1134,27 @@ return nil. Otherwise point is returned." (other-window-p (switch-to-buffer-other-window buffer)) (t (switch-to-buffer buffer)))))) +(defun archive--extract-file (extractor archive ename) + (let (;; We may have to encode the file name argument for + ;; external programs. + (coding-system-for-write + (and enable-multibyte-characters + archive-file-name-coding-system)) + ;; We read an archive member by no-conversion at + ;; first, then decode appropriately by calling + ;; archive-set-buffer-as-visiting-file later. + (coding-system-for-read 'no-conversion) + ;; Avoid changing dir mtime by lock_file + (create-lockfiles nil)) + (condition-case err + (if (fboundp extractor) + (funcall extractor archive ename) + (archive-*-extract archive ename + (symbol-value extractor))) + (error + (ding (message "%s" (error-message-string err))) + nil)))) + (defun archive-*-extract (archive name command) (let* ((default-directory (file-name-as-directory archive-tmpdir)) (tmpfile (expand-file-name (file-name-nondirectory name) From 8c4fe522860e733778531167c7ed6532840f40d4 Mon Sep 17 00:00:00 2001 From: "Peder O. Klingenberg" Date: Thu, 6 Aug 2020 14:32:52 +0200 Subject: [PATCH 101/145] * lisp/play/snake.el (snake-null-map): Quit on `q'. (Bug#42731) --- lisp/play/snake.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/play/snake.el b/lisp/play/snake.el index d7c0683a05f..70d80c464fc 100644 --- a/lisp/play/snake.el +++ b/lisp/play/snake.el @@ -192,6 +192,7 @@ and then start moving it leftwards.") (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.") From 92a0667f6b4c71c12c61206b49c575b24ca991f8 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 7 Aug 2020 13:54:39 +0300 Subject: [PATCH 102/145] ; * lisp/arc-mode.el (archive-copy-file): Doc fix. --- lisp/arc-mode.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 97213ab9e12..ae85fc55add 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1041,7 +1041,9 @@ return nil. Otherwise point is returned." next)) (defun archive-copy-file (file new-name) - "Copy file under point to a different location." + "Copy FILE to a location specified by NEW-NAME. +Interactively, FILE is the file at point, and the function prompts +for NEW-NAME." (interactive (let ((name (archive--file-desc-ext-file-name (archive-get-descr)))) (list name From 2e4c63664d75de46b21d8853f187fc1116cb8240 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 7 Aug 2020 12:56:13 +0200 Subject: [PATCH 103/145] Buffer-menu-select doc string clarification * lisp/buff-menu.el (Buffer-menu-select): Document that it removed the marks (bug#6491). --- lisp/buff-menu.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 655a76a713c..9fe0dbae381 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -488,8 +488,9 @@ Buffers marked with \\`\\[Buffer-menu-delete]' are deleted (defun Buffer-menu-select () "Select this line's buffer; also, display buffers marked with `>'. You can mark buffers with the \\`\\[Buffer-menu-mark]' command. + This command deletes and replaces all the previously existing windows -in the selected frame." +in the selected frame, and will remove any marks." (interactive) (let* ((this-buffer (Buffer-menu-buffer t)) (menu-buffer (current-buffer)) From c32d6b21b81bed54d9738816c9164157ab6165c3 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 7 Aug 2020 14:03:24 +0300 Subject: [PATCH 104/145] Fix documentation of 'missing-newline-at-eof' * doc/emacs/display.texi (Useless Whitespace): * etc/NEWS (missing-newline-at-eof): Improve wording and punctuation. --- doc/emacs/display.texi | 2 +- etc/NEWS | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index 5778d95b4d4..75ef520d62a 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -1335,7 +1335,7 @@ customize the variable @code{whitespace-line-column}. Highlight newlines. @item missing-newline-at-eof -Highlight the final character in a buffer unless it's a newline +Highlight the final character if the buffer doesn't end with a newline character. @item empty diff --git a/etc/NEWS b/etc/NEWS index 002a078f840..7429d392e47 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -459,10 +459,10 @@ The new default value is 2000000 (2 megabytes). ** Whitespace mode +++ -*** A new style has been added: 'missing-newline-at-eof' -If present in 'whitespace-style' (and it is now by default), the final -character in the buffer will be highlighted unless it's a newline -character. +*** 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. ** Texinfo From 95b60c84b3bbed262d0af75bc69d4df9cb2cd9eb Mon Sep 17 00:00:00 2001 From: Mauro Aranda Date: Fri, 7 Aug 2020 13:14:41 +0200 Subject: [PATCH 105/145] Add new commands to describe buttons and widgets * lisp/help-fns.el (describe-widget-functions): New variable, used by describe-widget. (describe-widget): New command, to display information about a widget. * lisp/button.el (button-describe): New command, for describing a button. (button--describe): Helper function for button-describe. * lisp/wid-edit.el (widget-describe): New command, for describing a widget. (widget--resolve-parent-action): Helper function, to allow widget-describe to display more useful information (bug#139). --- etc/NEWS | 5 +++++ lisp/button.el | 45 ++++++++++++++++++++++++++++++++++++++ lisp/help-fns.el | 44 +++++++++++++++++++++++++++++++++++++ lisp/wid-edit.el | 57 ++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 151 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index 7429d392e47..201c0b58cda 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -122,6 +122,11 @@ horizontal movements now stop at the edge of the board. ** Autosaving via 'auto-save-visited-mode' can now be inhibited by setting the variable 'auto-save-visited-mode' buffer-locally to nil. +** New commands to describe buttons and widgets have been added. +'describe-widget' (on a widget) will pop up a help buffer and give a +description of the properties. Likewise 'describe-button' does the +same for a button. + * Changes in Specialized Modes and Packages in Emacs 28.1 diff --git a/lisp/button.el b/lisp/button.el index d9c36a0375c..941b9fe720a 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -555,6 +555,51 @@ Returns the button found." (interactive "p\nd\nd") (forward-button (- n) wrap display-message no-error)) +(defun button--describe (properties) + "Describe a button's PROPERTIES (an alist) in a *Help* buffer. +This is a helper function for `button-describe', in order to be possible to +use `help-setup-xref'. + +Each element of PROPERTIES should be of the form (PROPERTY . VALUE)." + (help-setup-xref (list #'button--describe properties) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (insert (format-message "This button's type is `%s'." + (alist-get 'type properties))) + (dolist (prop '(action mouse-action)) + (let ((name (symbol-name prop)) + (val (alist-get prop properties))) + (when (functionp val) + (insert "\n\n" + (propertize (capitalize name) 'face 'bold) + "\nThe " name " of this button is") + (if (symbolp val) + (progn + (insert (format-message " `%s',\nwhich is " val)) + (describe-function-1 val)) + (insert "\n") + (princ val)))))))) + +(defun button-describe (&optional button-or-pos) + "Display a buffer with information about the button at point. + +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) + (button-at button-or-pos)) + ((null button-or-pos) (button-at (point))) + ((overlayp button-or-pos) button-or-pos))) + (props (and button + (mapcar (lambda (prop) + (cons prop (button-get button prop))) + '(type action mouse-action))))) + (when props + (button--describe props) + t))) + (provide 'button) ;;; button.el ends here diff --git a/lisp/help-fns.el b/lisp/help-fns.el index b9536470631..5a99103f6af 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -1769,6 +1769,50 @@ documentation for the major and minor modes of that buffer." ;; For the sake of IELM and maybe others nil) +;; Widgets. + +(defvar describe-widget-functions + '(button-describe widget-describe) + "A list of functions for `describe-widget' to call. +Each function should take one argument, a buffer position, and return +non-nil if it described a widget at that position.") + +;;;###autoload +(defun describe-widget (&optional pos) + "Display a buffer with information about a widget. +You can use this command to describe buttons (e.g., the links in a *Help* +buffer), editable fields of the customization buffers, etc. + +Interactively, click on a widget to describe it, or hit RET to describe the +widget at point. + +When called from Lisp, POS may be a buffer position or a mouse position list. + +Calls each function of the list `describe-widget-functions' in turn, until +one of them returns non-nil." + (interactive + (list + (let ((key + (read-key + "Click on a widget, or hit RET to describe the widget at point"))) + (cond ((eq key ?\C-m) (point)) + ((and (mouse-event-p key) + (eq (event-basic-type key) 'mouse-1) + (equal (event-modifiers key) '(click))) + (event-end key)) + ((eq key ?\C-g) (signal 'quit nil)) + (t (user-error "You didn't specify a widget")))))) + (let (buf) + ;; Allow describing a widget in a different window. + (when (posnp pos) + (setq buf (window-buffer (posn-window pos)) + pos (posn-point pos))) + (with-current-buffer (or buf (current-buffer)) + (unless (cl-some (lambda (fun) (when (fboundp fun) (funcall fun pos))) + describe-widget-functions) + (message "No widget found at that position"))))) + + ;;; Replacements for old lib-src/ programs. Don't seem especially useful. ;; Replaces lib-src/digest-doc.c. diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 284fd1d6cbd..ea7e266e0d0 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -577,6 +577,63 @@ respectively." (if (and widget (funcall function widget maparg)) (setq overlays nil))))) +(defun widget-describe (&optional widget-or-pos) + "Describe the widget at point. +Displays a buffer with information about the widget (e.g., its actions) as well +as a link to browse all the properties of the widget. + +This command resolves the indirection of widgets running the action of its +parents, so the real action executed can be known. + +When called from Lisp, pass WIDGET-OR-POS as the widget to describe, +or a buffer position where a widget is present. If WIDGET-OR-POS is nil, +the widget at point is the widget to describe." + (interactive "d") + (require 'wid-browse) ; The widget-browse widget. + (let ((widget (if (widgetp widget-or-pos) + widget-or-pos + (widget-at widget-or-pos))) + props) + (when widget + (help-setup-xref (list #'widget-describe widget) + (called-interactively-p 'interactive)) + (setq props (list (cons 'action (widget--resolve-parent-action widget)) + (cons 'mouse-down-action + (widget-get widget :mouse-down-action)))) + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (widget-insert "This widget's type is ") + (widget-create 'widget-browse :format "%[%v%]\n%d" + :doc (get (car widget) 'widget-documentation) + :help-echo "Browse this widget's properties" + widget) + (dolist (action '(action mouse-down-action)) + (let ((name (symbol-name action)) + (val (alist-get action props))) + (when (functionp val) + (widget-insert "\n\n" (propertize (capitalize name) 'face 'bold) + "'\nThe " name " of this widget is") + (if (symbolp val) + (progn (widget-insert " ") + (widget-create 'function-link :value val + :button-prefix "" :button-suffix "" + :help-echo "Describe this function")) + (widget-insert "\n") + (princ val))))))) + (widget-setup) + t))) + +(defun widget--resolve-parent-action (widget) + "Resolve the real action of WIDGET up its inheritance chain. +Follow the WIDGET's parents, until its :action is no longer +`widget-parent-action', and return its value." + (let ((action (widget-get widget :action)) + (parent (widget-get widget :parent))) + (while (eq action 'widget-parent-action) + (setq parent (widget-get parent :parent) + action (widget-get parent :action))) + action)) + ;;; Images. (defcustom widget-image-directory (file-name-as-directory From 1545f28a98e143f027bd9cf69a2f0d323ad49ed3 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 7 Aug 2020 13:36:50 +0200 Subject: [PATCH 106/145] Add some documentation for widget-describe and button-describe * doc/emacs/help.texi (Key Help): Document button-describe and widget-describe. * lisp/button.el (push-button): Mention button-describe. * lisp/cus-edit.el (Custom-newline): Mention widget-describe (bug#139). --- doc/emacs/help.texi | 10 ++++++++++ etc/NEWS | 4 ++-- lisp/button.el | 6 +++++- lisp/cus-edit.el | 5 ++++- 4 files changed, 21 insertions(+), 4 deletions(-) diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi index 167c32c4d21..06ad5a583d2 100644 --- a/doc/emacs/help.texi +++ b/doc/emacs/help.texi @@ -220,6 +220,16 @@ documentation string of the command it runs. command is not on any key, that means you must use @kbd{M-x} to run it. @kbd{C-h w} runs the command @code{where-is}. +@findex button-describe +@findex widget-describe + Some modes in Emacs use various buttons (@pxref{Buttons,,,elisp, The +Emacs Lisp Reference Manual}) and widgets +(@pxref{Introduction,,,widget, Emacs Widgets}) that can be clicked to +perform some action. To find out what function is ultimately invoked +by these buttons, Emacs provides the @code{button-describe} and +@code{widget-describe} commands, that should be run with point over +the button. + @node Name Help @section Help by Command or Variable Name diff --git a/etc/NEWS b/etc/NEWS index 201c0b58cda..dcd8ea6a9b3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -123,8 +123,8 @@ horizontal movements now stop at the edge of the board. setting the variable 'auto-save-visited-mode' buffer-locally to nil. ** New commands to describe buttons and widgets have been added. -'describe-widget' (on a widget) will pop up a help buffer and give a -description of the properties. Likewise 'describe-button' does the +'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. diff --git a/lisp/button.el b/lisp/button.el index 941b9fe720a..03ab59b109c 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -464,8 +464,12 @@ see). POS defaults to point, except when `push-button' is invoked interactively as the result of a mouse-event, in which case, the mouse event is used. + If there's no button at POS, do nothing and return nil, otherwise -return t." +return t. + +To get a description of what function will called when pushing a +butting, use the `button-describe' command." (interactive (list (if (integerp last-command-event) (point) last-command-event))) (if (and (not (integerp pos)) (eventp pos)) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 1942f25e891..16695967dfa 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -4841,7 +4841,10 @@ The format is suitable for use with `easy-menu-define'." (error "You can't edit this part of the Custom buffer")) (defun Custom-newline (pos &optional event) - "Invoke button at POS, or refuse to allow editing of Custom buffer." + "Invoke button at POS, or refuse to allow editing of Custom buffer. + +To see what function the widget will call, use the +`widget-describe' command." (interactive "@d") (let ((button (get-char-property pos 'button))) ;; If there is no button at point, then use the one at the start From b44a5d849e2d29bf91abe9015105cc71da458b1f Mon Sep 17 00:00:00 2001 From: Stephen Leake Date: Fri, 7 Aug 2020 04:43:18 -0700 Subject: [PATCH 107/145] * lisp/files.el (auto-mode-alist): delete ada-mode; now in GNU ELPA only --- lisp/files.el | 2 -- 1 file changed, 2 deletions(-) diff --git a/lisp/files.el b/lisp/files.el index 742fd78df1d..19096693461 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -2683,8 +2683,6 @@ since only a single case-insensitive search through the alist is made." ("\\.p\\'" . pascal-mode) ("\\.pas\\'" . pascal-mode) ("\\.\\(dpr\\|DPR\\)\\'" . delphi-mode) - ("\\.ad[abs]\\'" . ada-mode) - ("\\.ad[bs]\\.dg\\'" . ada-mode) ("\\.\\([pP]\\([Llm]\\|erl\\|od\\)\\|al\\)\\'" . perl-mode) ("Imakefile\\'" . makefile-imake-mode) ("Makeppfile\\(?:\\.mk\\)?\\'" . makefile-makepp-mode) ; Put this before .mk From 7ed61d6193629fa88d348221db3f1df7130a8bd3 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 7 Aug 2020 13:54:50 +0200 Subject: [PATCH 108/145] Make more erc function aliases obsolete * lisp/erc/erc-compat.el (erc-propertize, erc-view-mode-enter) (erc-function-arglist, erc-delete-dups) (erc-replace-regexp-in-string): Make these aliases obsolete. * lisp/erc/erc-capab.el (erc-capab-identify-add-prefix) (erc-capab-identify-remove/set-identified-flag): * lisp/erc/erc-dcc.el (erc-dcc-chat-parse-output) (erc-dcc-unquote-filename, pcomplete/erc-mode/DCC): * lisp/erc/erc-list.el (erc-list-menu-mode, erc-list-button) (erc-list-make-string): * lisp/erc/erc-log.el (erc-log-standardize-name): * lisp/erc/erc-match.el (erc-log-matches-make-buffer): * lisp/erc/erc-networks.el (erc-server-select): * lisp/erc/erc.el (erc-message-english-PART) (erc-update-mode-line-buffer, erc-format-my-nick) (erc-format-@nick, erc-get-user-mode-prefix, erc-display-prompt) (erc-part-reason-zippy, erc-quit-reason-zippy, erc-get-arglist) (erc-toggle-debug-irc-protocol, erc-log-irc-protocol) (erc-migrate-modules): Adjust callers. --- lisp/erc/erc-capab.el | 16 +++++------ lisp/erc/erc-compat.el | 10 +++---- lisp/erc/erc-dcc.el | 10 +++---- lisp/erc/erc-list.el | 28 +++++++++---------- lisp/erc/erc-log.el | 2 +- lisp/erc/erc-match.el | 6 ++-- lisp/erc/erc-networks.el | 2 +- lisp/erc/erc.el | 60 ++++++++++++++++++++-------------------- 8 files changed, 67 insertions(+), 67 deletions(-) diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el index fc45725f789..4afe6a7614b 100644 --- a/lisp/erc/erc-capab.el +++ b/lisp/erc/erc-capab.el @@ -170,11 +170,11 @@ PARSED is an `erc-parsed' response struct." (string-match "^\\([-\\+]\\)\\(.+\\)$" msg)) (setf (erc-response.contents parsed) (if erc-capab-identify-mode - (erc-propertize (match-string 2 msg) - 'erc-identified - (if (string= (match-string 1 msg) "+") - 1 - 0)) + (propertize (match-string 2 msg) + 'erc-identified + (if (string= (match-string 1 msg) "+") + 1 + 0)) (match-string 2 msg))) nil))) @@ -190,9 +190,9 @@ PARSED is an `erc-parsed' response struct." ;; assuming the first use of `nickname' is the sender's nick (re-search-forward (regexp-quote nickname) nil t)) (goto-char (match-beginning 0)) - (insert (erc-propertize erc-capab-identify-prefix - 'font-lock-face - 'erc-capab-identify-unidentified)))))) + (insert (propertize erc-capab-identify-prefix + 'font-lock-face + 'erc-capab-identify-unidentified)))))) (defun erc-capab-identify-get-unidentified-nickname (parsed) "Return the nickname of the user if unidentified. diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 388728b04a0..d71221b2674 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -43,12 +43,12 @@ Return the same string, if the encoding operation is trivial. See `erc-encoding-coding-alist'." (encode-coding-string s coding-system t)) -(defalias 'erc-propertize 'propertize) -(defalias 'erc-view-mode-enter 'view-mode-enter) +(define-obsolete-function-alias 'erc-propertize #'propertize "28.1") +(define-obsolete-function-alias 'erc-view-mode-enter #'view-mode-enter "28.1") (autoload 'help-function-arglist "help-fns") -(defalias 'erc-function-arglist 'help-function-arglist) -(defalias 'erc-delete-dups 'delete-dups) -(defalias 'erc-replace-regexp-in-string 'replace-regexp-in-string) +(define-obsolete-function-alias 'erc-function-arglist #'help-function-arglist "28.1") +(define-obsolete-function-alias 'erc-delete-dups #'delete-dups "28.1") +(define-obsolete-function-alias 'erc-replace-regexp-in-string #'replace-regexp-in-string "28.1") (defun erc-set-write-file-functions (new-val) (set (make-local-variable 'write-file-functions) new-val)) diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 8ccceec4594..bf98eb818f3 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -423,7 +423,7 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." #'(lambda (elt) (eq (plist-get elt :type) 'CHAT)) erc-dcc-list))) - ('close (erc-delete-dups + ('close (delete-dups (mapcar (lambda (elt) (symbol-name (plist-get elt :type))) erc-dcc-list))) ('get (mapcar #'erc-dcc-nick @@ -636,8 +636,8 @@ that subcommand." (define-inline erc-dcc-unquote-filename (filename) (inline-quote - (erc-replace-regexp-in-string "\\\\\\\\" "\\" - (erc-replace-regexp-in-string "\\\\\"" "\"" ,filename t t) t t))) + (replace-regexp-in-string "\\\\\\\\" "\\" + (replace-regexp-in-string "\\\\\"" "\"" ,filename t t) t t))) (defun erc-dcc-handle-ctcp-send (proc query nick login host to) "This is called if a CTCP DCC SEND subcommand is sent to the client. @@ -1193,8 +1193,8 @@ other client." (setq posn (match-end 0)) (erc-display-message nil nil proc - 'dcc-chat-privmsg ?n (erc-propertize erc-dcc-from 'font-lock-face - 'erc-nick-default-face) ?m line)) + 'dcc-chat-privmsg ?n (propertize erc-dcc-from 'font-lock-face + 'erc-nick-default-face) ?m line)) (setq erc-dcc-unprocessed-output (substring str posn))))) (defun erc-dcc-chat-buffer-killed () diff --git a/lisp/erc/erc-list.el b/lisp/erc/erc-list.el index 5faeabb721a..036d7733ed7 100644 --- a/lisp/erc/erc-list.el +++ b/lisp/erc/erc-list.el @@ -71,13 +71,13 @@ (defun erc-list-make-string (channel users topic) (concat channel - (erc-propertize " " - 'display (list 'space :align-to erc-list-nusers-column) - 'face 'fixed-pitch) + (propertize " " + 'display (list 'space :align-to erc-list-nusers-column) + 'face 'fixed-pitch) users - (erc-propertize " " - 'display (list 'space :align-to erc-list-topic-column) - 'face 'fixed-pitch) + (propertize " " + 'display (list 'space :align-to erc-list-topic-column) + 'face 'fixed-pitch) topic)) ;; Insert a record into the list buffer. @@ -143,19 +143,19 @@ ;; Helper function that makes a buttonized column header. (defun erc-list-button (title column) - (erc-propertize title - 'column-number column - 'help-echo "mouse-1: sort by column" - 'mouse-face 'header-line-highlight - 'keymap erc-list-menu-sort-button-map)) + (propertize title + 'column-number column + 'help-echo "mouse-1: sort by column" + 'mouse-face 'header-line-highlight + 'keymap erc-list-menu-sort-button-map)) (define-derived-mode erc-list-menu-mode special-mode "ERC-List" "Major mode for editing a list of irc channels." (setq header-line-format (concat - (erc-propertize " " - 'display '(space :align-to 0) - 'face 'fixed-pitch) + (propertize " " + 'display '(space :align-to 0) + 'face 'fixed-pitch) (erc-list-make-string (erc-list-button "Channel" 1) (erc-list-button "# Users" 2) "Topic"))) diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 1bad6d16c87..e2c066da9b1 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -334,7 +334,7 @@ This will not work with full paths, only names. Any unsafe characters in the name are replaced with \"!\". The filename is downcased." - (downcase (erc-replace-regexp-in-string + (downcase (replace-regexp-in-string "[/\\]" "!" (convert-standard-filename filename)))) (defun erc-current-logfile (&optional buffer) diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 0e98f2bc613..6e87a183fc1 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -577,9 +577,9 @@ See `erc-log-match-format'." (with-current-buffer buffer (unless buffer-already (insert " == Type \"q\" to dismiss messages ==\n") - (erc-view-mode-enter nil (lambda (buffer) - (when (y-or-n-p "Discard messages? ") - (kill-buffer buffer))))) + (view-mode-enter nil (lambda (buffer) + (when (y-or-n-p "Discard messages? ") + (kill-buffer buffer))))) buffer))) (defun erc-log-matches-come-back (proc parsed) diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 415fb53fee0..8551cdd1dee 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -812,7 +812,7 @@ As an example: (let* ((completion-ignore-case t) (net (intern (completing-read "Network: " - (erc-delete-dups + (delete-dups (mapcar (lambda (x) (list (symbol-name (nth 1 x)))) erc-server-alist))))) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 62aa76d25c8..404a4c09975 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1863,7 +1863,7 @@ buffer rather than a server buffer.") ;; modify `transforms' to specify what needs to be changed ;; each item is in the format '(old . new) (let ((transforms '((pcomplete . completion)))) - (erc-delete-dups + (delete-dups (mapcar (lambda (m) (or (cdr (assoc m transforms)) m)) mods)))) @@ -2316,7 +2316,7 @@ and appears in face `erc-input-face' in the buffer." (setq result (concat result network-name " << " line "\n"))) result) - (erc-propertize + (propertize (concat network-name " >> " string (if (/= ?\n (aref string @@ -2339,7 +2339,7 @@ If ARG is non-nil, show the *erc-protocol* buffer." (interactive "P") (let* ((buf (get-buffer-create "*erc-protocol*"))) (with-current-buffer buf - (erc-view-mode-enter) + (view-mode-enter) (when (null (current-local-map)) (let ((inhibit-read-only t)) (insert (erc-make-notice "This buffer displays all IRC protocol traffic exchanged with each server.\n")) @@ -2773,7 +2773,7 @@ See also `erc-server-send'." (defun erc-get-arglist (fun) "Return the argument list of a function without the parens." - (let ((arglist (format "%S" (erc-function-arglist fun)))) + (let ((arglist (format "%S" (help-function-arglist fun)))) (if (string-match "\\`(\\(.*\\))\\'" arglist) (match-string 1 arglist) arglist))) @@ -3558,7 +3558,7 @@ If S is non-nil, it will be used as the quit reason." If S is non-nil, it will be used as the quit reason." (or s (if (fboundp 'yow) - (erc-replace-regexp-in-string "\n" "" (yow)) + (replace-regexp-in-string "\n" "" (yow)) (erc-quit/part-reason-default)))) (make-obsolete 'erc-quit-reason-zippy "it will be removed." "24.4") @@ -3585,7 +3585,7 @@ If S is non-nil, it will be used as the part reason." If S is non-nil, it will be used as the quit reason." (or s (if (fboundp 'yow) - (erc-replace-regexp-in-string "\n" "" (yow)) + (replace-regexp-in-string "\n" "" (yow)) (erc-quit/part-reason-default)))) (make-obsolete 'erc-part-reason-zippy "it will be removed." "24.4") @@ -4001,13 +4001,13 @@ If FACE is non-nil, it will be used to propertize the prompt. If it is nil, ;; Do not extend the text properties when typing at the end ;; of the prompt, but stuff typed in front of the prompt ;; shall remain part of the prompt. - (setq prompt (erc-propertize prompt - 'start-open t ; XEmacs - 'rear-nonsticky t ; Emacs - 'erc-prompt t - 'field t - 'front-sticky t - 'read-only t)) + (setq prompt (propertize prompt + 'start-open t ; XEmacs + 'rear-nonsticky t ; Emacs + 'erc-prompt t + 'field t + 'front-sticky t + 'read-only t)) (erc-put-text-property 0 (1- (length prompt)) 'font-lock-face (or face 'erc-prompt-face) prompt) @@ -4390,15 +4390,15 @@ See also `erc-format-nick-function'." (defun erc-get-user-mode-prefix (user) (when user (cond ((erc-channel-user-owner-p user) - (erc-propertize "~" 'help-echo "owner")) + (propertize "~" 'help-echo "owner")) ((erc-channel-user-admin-p user) - (erc-propertize "&" 'help-echo "admin")) + (propertize "&" 'help-echo "admin")) ((erc-channel-user-op-p user) - (erc-propertize "@" 'help-echo "operator")) + (propertize "@" 'help-echo "operator")) ((erc-channel-user-halfop-p user) - (erc-propertize "%" 'help-echo "half-op")) + (propertize "%" 'help-echo "half-op")) ((erc-channel-user-voice-p user) - (erc-propertize "+" 'help-echo "voice")) + (propertize "+" 'help-echo "voice")) (t "")))) (defun erc-format-@nick (&optional user _channel-data) @@ -4409,7 +4409,7 @@ prefix. Use CHANNEL-DATA to determine op and voice status. See also `erc-format-nick-function'." (when user (let ((nick (erc-server-user-nickname user))) - (concat (erc-propertize + (concat (propertize (erc-get-user-mode-prefix nick) 'font-lock-face 'erc-nick-prefix-face) nick)))) @@ -4422,12 +4422,12 @@ also `erc-format-nick-function'." (nick (erc-current-nick)) (mode (erc-get-user-mode-prefix nick))) (concat - (erc-propertize open 'font-lock-face 'erc-default-face) - (erc-propertize mode 'font-lock-face 'erc-my-nick-prefix-face) - (erc-propertize nick 'font-lock-face 'erc-my-nick-face) - (erc-propertize close 'font-lock-face 'erc-default-face))) + (propertize open 'font-lock-face 'erc-default-face) + (propertize mode 'font-lock-face 'erc-my-nick-prefix-face) + (propertize nick 'font-lock-face 'erc-my-nick-face) + (propertize close 'font-lock-face 'erc-default-face))) (let ((prefix "> ")) - (erc-propertize prefix 'font-lock-face 'erc-default-face)))) + (propertize prefix 'font-lock-face 'erc-default-face)))) (defun erc-echo-notice-in-default-buffer (s parsed buffer _sender) "Echos a private notice in the default buffer, namely the @@ -6489,16 +6489,16 @@ if `erc-away' is non-nil." (fill-region (point-min) (point-max)) (buffer-string)))) (setq header-line-format - (erc-replace-regexp-in-string + (replace-regexp-in-string "%" "%%" (if face - (erc-propertize header 'help-echo help-echo - 'face face) - (erc-propertize header 'help-echo help-echo)))))) + (propertize header 'help-echo help-echo + 'face face) + (propertize header 'help-echo help-echo)))))) (t (setq header-line-format (if face - (erc-propertize header 'face face) + (propertize header 'face face) header))))))) (force-mode-line-update))) @@ -6765,7 +6765,7 @@ functions." nick user host channel (if (not (string= reason "")) (format ": %s" - (erc-replace-regexp-in-string "%" "%%" reason)) + (replace-regexp-in-string "%" "%%" reason)) ""))))) From d0ad6306727067936c9c8717dfc4e3aae5774902 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 7 Aug 2020 14:07:14 +0200 Subject: [PATCH 109/145] Fix fontification of %d in strings in cperl-mode * lisp/progmodes/cperl-mode.el (cperl-init-faces): Don't fontify directives like %d in strings as hashes (bug#22867). --- lisp/progmodes/cperl-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 5ecd5668b34..6122caf5189 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -5753,7 +5753,7 @@ indentation and initial hashes. Behaves usually outside of comment." (if (eq (char-after (match-beginning 2)) ?%) 'cperl-hash-face 'cperl-array-face) - t) ; arrays and hashes + nil) ; arrays and hashes ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" 1 (if (= (- (match-end 2) (match-beginning 2)) 1) From 3e39aa6cfa6822b535d597b3e59abfea38610a48 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 7 Aug 2020 14:42:41 +0200 Subject: [PATCH 110/145] Remove support for Mosaic from browse-url * lisp/net/browse-url.el (browse-url-mosaic-program) (browse-url-mosaic-arguments, browse-url-mosaic-pidfile) (browse-url-CCI-port, browse-url-CCI-host) (browse-url-default-browser, browse-url-mosaic, browse-url-cci): Remove support for the Mosaic browser, which saw its last release in 1997, or 23 years ago. * etc/NEWS: Announce its removal. --- etc/NEWS | 3 + lisp/net/browse-url.el | 124 ----------------------------------------- 2 files changed, 3 insertions(+), 124 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index dcd8ea6a9b3..850b1660690 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -547,6 +547,9 @@ either an internal or external 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. + ** SHR --- diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 8892e800cd6..7c2fde98cc7 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -425,25 +425,6 @@ Passing an interactive argument to \\[browse-url], or specific browser commands reverses the effect of this variable." :type 'boolean) -(defcustom browse-url-mosaic-program "xmosaic" - "The name by which to invoke Mosaic (or mMosaic)." - :type 'string - :version "20.3") - -(make-obsolete-variable 'browse-url-mosaic-program nil "25.1") - -(defcustom browse-url-mosaic-arguments nil - "A list of strings to pass to Mosaic as arguments." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-mosaic-arguments nil "25.1") - -(defcustom browse-url-mosaic-pidfile "~/.mosaicpid" - "The name of the pidfile created by Mosaic." - :type 'string) - -(make-obsolete-variable 'browse-url-mosaic-pidfile nil "25.1") - (defcustom browse-url-conkeror-program "conkeror" "The name by which to invoke Conkeror." :type 'string @@ -498,22 +479,6 @@ Used by the `browse-url-of-file' command." "Hook run after `browse-url-of-file' has asked a browser to load a file." :type 'hook) -(defcustom browse-url-CCI-port 3003 - "Port to access XMosaic via CCI. -This can be any number between 1024 and 65535 but must correspond to -the value set in the browser." - :type 'integer) - -(make-obsolete-variable 'browse-url-CCI-port nil "25.1") - -(defcustom browse-url-CCI-host "localhost" - "Host to access XMosaic via CCI. -This should be the host name of the machine running XMosaic with CCI -enabled. The port number should be set in `browse-url-CCI-port'." - :type 'string) - -(make-obsolete-variable 'browse-url-CCI-host nil "25.1") - (defvar browse-url-temp-file-name nil) (make-variable-buffer-local 'browse-url-temp-file-name) @@ -1075,8 +1040,6 @@ instead of `browse-url-new-window-flag'." ;;; ((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-mosaic-program) 'browse-url-mosaic) -;;; ((executable-find browse-url-conkeror-program) 'browse-url-conkeror) ((executable-find browse-url-chrome-program) 'browse-url-chrome) ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) @@ -1444,93 +1407,6 @@ used instead of `browse-url-new-window-flag'." (function-put 'browse-url-gnome-moz 'browse-url-browser-kind 'external) -;; --- Mosaic --- - -;;;###autoload -(defun browse-url-mosaic (url &optional new-window) - "Ask the XMosaic WWW browser to load URL. - -Default to the URL around or before point. The strings in variable -`browse-url-mosaic-arguments' are also passed to Mosaic and the -program is invoked according to the variable -`browse-url-mosaic-program'. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new Mosaic window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -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 "Mosaic URL: ")) - (let ((pidfile (expand-file-name browse-url-mosaic-pidfile)) - pid) - (if (file-readable-p pidfile) - (with-temp-buffer - (insert-file-contents pidfile) - (setq pid (read (current-buffer))))) - (if (and (integerp pid) (zerop (signal-process pid 0))) ; Mosaic running - (progn - (with-temp-buffer - (insert (if (browse-url-maybe-new-window new-window) - "newwin\n" - "goto\n") - url "\n") - (with-file-modes ?\700 - (if (file-exists-p - (setq pidfile (format "/tmp/Mosaic.%d" pid))) - (delete-file pidfile)) - ;; https://debbugs.gnu.org/17428. Use O_EXCL. - (write-region nil nil pidfile nil 'silent nil 'excl))) - ;; Send signal SIGUSR to Mosaic - (message "Signaling Mosaic...") - (signal-process pid 'SIGUSR1) - ;; Or you could try: - ;; (call-process "kill" nil 0 nil "-USR1" (int-to-string pid)) - (message "Signaling Mosaic...done")) - ;; Mosaic not running - start it - (message "Starting %s..." browse-url-mosaic-program) - (apply 'start-process "xmosaic" nil browse-url-mosaic-program - (append browse-url-mosaic-arguments (list url))) - (message "Starting %s...done" browse-url-mosaic-program)))) - -(function-put 'browse-url-mosaic 'browse-url-browser-kind 'external) - -;; --- Mosaic using CCI --- - -;;;###autoload -(defun browse-url-cci (url &optional new-window) - "Ask the XMosaic WWW browser to load URL. -Default to the URL around or before point. - -This function only works for XMosaic version 2.5 or later. You must -select `CCI' from XMosaic's File menu, set the CCI Port Address to the -value of variable `browse-url-CCI-port', and enable `Accept requests'. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new browser window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -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 "Mosaic URL: ")) - (open-network-stream "browse-url" " *browse-url*" - browse-url-CCI-host browse-url-CCI-port) - ;; Todo: start browser if fails - (process-send-string "browse-url" - (concat "get url (" url ") output " - (if (browse-url-maybe-new-window new-window) - "new" - "current") - "\r\n")) - (process-send-string "browse-url" "disconnect\r\n") - (delete-process "browse-url")) - -(function-put 'browse-url-cci 'browse-url-browser-kind 'external) - ;; --- Conkeror --- ;;;###autoload (defun browse-url-conkeror (url &optional new-window) From 7196abecb5f5c3cc1282280d2d337b6a86761656 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simen=20Heggest=C3=B8yl?= Date: Tue, 16 Jun 2020 21:32:58 +0200 Subject: [PATCH 111/145] Use lexical-binding in browse-url.el and add tests * lisp/net/browse-url.el: Turn on lexical-binding. (browse-url--mailto, browse-url--man, browse-url--browser): Use imperative form in docstrings. (browse-url-delete-temp-file): Turn comment into a proper docstring. * test/lisp/net/browse-url-tests.el: New file with tests for browse-url.el. --- lisp/net/browse-url.el | 12 +-- test/lisp/net/browse-url-tests.el | 119 ++++++++++++++++++++++++++++++ 2 files changed, 125 insertions(+), 6 deletions(-) create mode 100644 test/lisp/net/browse-url-tests.el diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 7c2fde98cc7..2b8d4d0ce62 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -1,4 +1,4 @@ -;;; browse-url.el --- pass a URL to a WWW browser +;;; browse-url.el --- pass a URL to a WWW browser -*- lexical-binding: t; -*- ;; Copyright (C) 1995-2020 Free Software Foundation, Inc. @@ -587,7 +587,7 @@ process), or nil (we don't know)." kind))) (defun browse-url--mailto (url &rest args) - "Calls `browse-url-mailto-function' with URL and ARGS." + "Call `browse-url-mailto-function' with URL and ARGS." (funcall browse-url-mailto-function url args)) (defun browse-url--browser-kind-mailto (url) @@ -596,7 +596,7 @@ process), or nil (we don't know)." #'browse-url--browser-kind-mailto) (defun browse-url--man (url &rest args) - "Calls `browse-url-man-function' with URL and ARGS." + "Call `browse-url-man-function' with URL and ARGS." (funcall browse-url-man-function url args)) (defun browse-url--browser-kind-man (url) @@ -605,7 +605,7 @@ process), or nil (we don't know)." #'browse-url--browser-kind-man) (defun browse-url--browser (url &rest args) - "Calls `browse-url-browser-function' with URL and ARGS." + "Call `browse-url-browser-function' with URL and ARGS." (funcall browse-url-browser-function url args)) (defun browse-url--browser-kind-browser (url) @@ -819,8 +819,8 @@ narrowed." (browse-url-of-file file-name)))) (defun browse-url-delete-temp-file (&optional temp-file-name) - ;; Delete browse-url-temp-file-name from the file system - ;; If optional arg TEMP-FILE-NAME is non-nil, delete it instead + "Delete `browse-url-temp-file-name' from the file system. +If optional arg TEMP-FILE-NAME is non-nil, delete it instead." (let ((file-name (or temp-file-name browse-url-temp-file-name))) (if (and file-name (file-exists-p file-name)) (delete-file file-name)))) diff --git a/test/lisp/net/browse-url-tests.el b/test/lisp/net/browse-url-tests.el new file mode 100644 index 00000000000..b2b27d2ae7b --- /dev/null +++ b/test/lisp/net/browse-url-tests.el @@ -0,0 +1,119 @@ +;;; browse-url-tests.el --- Tests for browse-url.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'browse-url) +(require 'ert) + +(ert-deftest browse-url-tests-browser-kind () + (should (eq (browse-url--browser-kind #'browse-url-w3 "gnu.org") + 'internal)) + (should + (eq (browse-url--browser-kind #'browse-url-firefox "gnu.org") + 'external))) + +(ert-deftest browse-url-tests-non-html-file-url-p () + (should (browse-url--non-html-file-url-p "file://foo.txt")) + (should-not (browse-url--non-html-file-url-p "file://foo.html"))) + +(ert-deftest browse-url-tests-select-handler-mailto () + (should (eq (browse-url-select-handler "mailto:foo@bar.org") + 'browse-url--mailto)) + (should (eq (browse-url-select-handler "mailto:foo@bar.org" + 'internal) + 'browse-url--mailto)) + (should-not (browse-url-select-handler "mailto:foo@bar.org" + 'external))) + +(ert-deftest browse-url-tests-select-handler-man () + (should (eq (browse-url-select-handler "man:ls") 'browse-url--man)) + (should (eq (browse-url-select-handler "man:ls" 'internal) + 'browse-url--man)) + (should-not (browse-url-select-handler "man:ls" 'external))) + +(ert-deftest browse-url-tests-select-handler-file () + (should (eq (browse-url-select-handler "file://foo.txt") + 'browse-url-emacs)) + (should (eq (browse-url-select-handler "file://foo.txt" 'internal) + 'browse-url-emacs)) + (should-not (browse-url-select-handler "file://foo.txt" 'external))) + +(ert-deftest browse-url-tests-url-encode-chars () + (should (equal (browse-url-url-encode-chars "foobar" "[ob]") + "f%6F%6F%62ar"))) + +(ert-deftest browse-url-tests-encode-url () + (should (equal (browse-url-encode-url "") "")) + (should (equal (browse-url-encode-url "a b c") "a b c")) + (should (equal (browse-url-encode-url "\"a\" \"b\"") + "\"a%22\"b\"")) + (should (equal (browse-url-encode-url "(a) (b)") "(a%29(b)")) + (should (equal (browse-url-encode-url "a$ b$") "a%24b$"))) + +(ert-deftest browse-url-tests-url-at-point () + (with-temp-buffer + (insert "gnu.org") + (should (equal (browse-url-url-at-point) "http://gnu.org")))) + +(ert-deftest browse-url-tests-file-url () + (should (equal (browse-url-file-url "/foo") "file:///foo")) + (should (equal (browse-url-file-url "/foo:") "ftp://foo/")) + (should (equal (browse-url-file-url "/ftp@foo:") "ftp://foo/")) + (should (equal (browse-url-file-url "/anonymous@foo:") + "ftp://foo/"))) + +(ert-deftest browse-url-tests-delete-temp-file () + (let ((browse-url-temp-file-name + (make-temp-file "browse-url-tests-"))) + (browse-url-delete-temp-file) + (should-not (file-exists-p browse-url-temp-file-name))) + (let ((file (make-temp-file "browse-url-tests-"))) + (browse-url-delete-temp-file file) + (should-not (file-exists-p file)))) + +(ert-deftest browse-url-tests-add-buttons () + (with-temp-buffer + (insert "Visit https://gnu.org") + (goto-char (point-min)) + (browse-url-add-buttons) + (goto-char (- (point-max) 1)) + (should (eq (get-text-property (point) 'face) + 'browse-url-button)) + (should (get-text-property (point) 'browse-url-data)))) + +(ert-deftest browse-url-tests-button-copy () + (with-temp-buffer + (insert "Visit https://gnu.org") + (goto-char (point-min)) + (browse-url-add-buttons) + (should-error (browse-url-button-copy)) + (goto-char (- (point-max) 1)) + (browse-url-button-copy) + (should (equal (car kill-ring) "https://gnu.org")))) + +(provide 'browse-url-tests) +;;; browse-url-tests.el ends here From 67ffffa66654236ded2cf121cb3139b07d2ac5c8 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 7 Aug 2020 19:40:31 +0200 Subject: [PATCH 112/145] * lisp/scroll-lock.el: Use lexical-binding. --- lisp/scroll-lock.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/scroll-lock.el b/lisp/scroll-lock.el index 3a6d9d36429..f20ea1bcc87 100644 --- a/lisp/scroll-lock.el +++ b/lisp/scroll-lock.el @@ -1,4 +1,4 @@ -;;; scroll-lock.el --- Scroll lock scrolling. +;;; scroll-lock.el --- Scroll lock scrolling. -*- lexical-binding:t -*- ;; Copyright (C) 2005-2020 Free Software Foundation, Inc. From cdbbc2081ed2da3a641926e76341ed413fb5b9f9 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Sat, 8 Aug 2020 01:20:01 +0200 Subject: [PATCH 113/145] Use lexical-binding in saveplace.el and add tests * lisp/saveplace.el: Use lexical-binding. (save-place-to-alist): Doc fix. * test/lisp/saveplace-tests.el: * test/lisp/saveplace-resources/saveplace: New files. --- lisp/saveplace.el | 12 +-- test/lisp/saveplace-resources/saveplace | 4 + test/lisp/saveplace-tests.el | 103 ++++++++++++++++++++++++ 3 files changed, 113 insertions(+), 6 deletions(-) create mode 100644 test/lisp/saveplace-resources/saveplace create mode 100644 test/lisp/saveplace-tests.el diff --git a/lisp/saveplace.el b/lisp/saveplace.el index 46738ab03dc..d420bfb4e9f 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -1,4 +1,4 @@ -;;; saveplace.el --- automatically save place in files +;;; saveplace.el --- automatically save place in files -*- lexical-binding:t -*- ;; Copyright (C) 1993-1994, 2001-2020 Free Software Foundation, Inc. @@ -42,7 +42,6 @@ "Automatically save place in files." :group 'data) - (defvar save-place-alist nil "Alist of saved places to go back to when revisiting files. Each element looks like (FILENAME . POSITION); @@ -175,10 +174,11 @@ file: (declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) (defun save-place-to-alist () - ;; put filename and point in a cons box and then cons that onto the - ;; front of the save-place-alist, if save-place-mode is non-nil. - ;; Otherwise, just delete that file from the alist. - ;; first check to make sure alist has been loaded in from the master + "Add current buffer filename and position to `save-place-alist'. +Put filename and point in a cons box and then cons that onto the +front of the `save-place-alist', if `save-place-mode' is non-nil. +Otherwise, just delete that file from the alist." + ;; First check to make sure alist has been loaded in from the master ;; file. If not, do so, then feel free to modify the alist. It ;; will be saved again when Emacs is killed. (or save-place-loaded (load-save-place-alist-from-file)) diff --git a/test/lisp/saveplace-resources/saveplace b/test/lisp/saveplace-resources/saveplace new file mode 100644 index 00000000000..3f3f6d501d6 --- /dev/null +++ b/test/lisp/saveplace-resources/saveplace @@ -0,0 +1,4 @@ +;;; -*- coding: utf-8 -*- +(("/home/skangas/.emacs.d/cache/recentf" . 1306) + ("/home/skangas/wip/emacs/" + (dired-filename . "/home/skangas/wip/emacs/COPYING"))) diff --git a/test/lisp/saveplace-tests.el b/test/lisp/saveplace-tests.el new file mode 100644 index 00000000000..ae7749fe930 --- /dev/null +++ b/test/lisp/saveplace-tests.el @@ -0,0 +1,103 @@ +;;; saveplace-tests.el --- Tests for saveplace.el -*- lexical-binding:t -*- + +;; Copyright (C) 2019-2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +(require 'ert) +(require 'saveplace) + +(defvar saveplace-tests-dir + (file-truename + (expand-file-name "saveplace-resources" + (file-name-directory (or load-file-name + buffer-file-name))))) + +(ert-deftest saveplace-test-save-place-to-alist/dir () + (save-place-mode) + (let* ((save-place-alist nil) + (save-place-loaded t) + (loc saveplace-tests-dir)) + (save-window-excursion + (dired loc) + (save-place-to-alist) + (should (equal save-place-alist + `((,(concat loc "/") + (dired-filename . ,(concat loc "/saveplace"))))))))) + +(ert-deftest saveplace-test-save-place-to-alist/file () + (save-place-mode) + (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) + (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-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-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-deftest saveplace-test-load-alist-from-file () + (save-place-mode) + (let ((save-place-loaded nil) + (save-place-file + (expand-file-name "saveplace" saveplace-tests-dir)) + (save-place-alist nil)) + (load-save-place-alist-from-file) + (should (equal save-place-alist + '(("/home/skangas/.emacs.d/cache/recentf" . 1306) + ("/home/skangas/wip/emacs/" + (dired-filename . "/home/skangas/wip/emacs/COPYING"))))))) + +(provide 'saveplace-tests) +;;; saveplace-tests.el ends here From 44b31c1ed7f9c6668942ea122c0dd37b825ef29c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 8 Aug 2020 11:37:43 +0200 Subject: [PATCH 114/145] Make the name column in 'list-buffers' have a dynamic width * lisp/buff-menu.el (Buffer-menu--dynamic-name-width): New function (bug#30692). (Buffer-menu-name-width): Default to using it. (list-buffers--refresh): Call it. * lisp/emacs-lisp/seq.el (seq-max): Add autoload cookie. --- etc/NEWS | 8 ++++++ lisp/buff-menu.el | 57 +++++++++++++++++++++++++++--------------- lisp/emacs-lisp/seq.el | 1 + 3 files changed, 46 insertions(+), 20 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 850b1660690..de10b4a6131 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -130,6 +130,14 @@ same for a button. * Changes in Specialized Modes and Packages in Emacs 28.1 +** Miscellaneous + +--- +*** The width of the buffer-name column in 'list-buffers' is now dynamic. +The width now depends of 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. + ** Windows *** The key prefix 'C-x 4 1' displays next command buffer in the same window. diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 9fe0dbae381..359d6381e8b 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -69,11 +69,26 @@ minus `Buffer-menu-size-width'. This use is deprecated." "use `Buffer-menu-name-width' and `Buffer-menu-size-width' instead." "24.3") -(defcustom Buffer-menu-name-width 19 - "Width of buffer name column in the Buffer Menu." - :type 'number +(defun Buffer-menu--dynamic-name-width (buffers) + "Return a name column width based on the current window width. +The width will never exceed the actual width of the buffer names, +but will never be narrower than 19 characters." + (max 19 + ;; This gives 19 on an 80 column window, and take up + ;; proportionally more space as the window widens. + (min (truncate (/ (window-width) 4.2)) + (seq-max (mapcar (lambda (b) + (length (buffer-name b))) + buffers))))) + +(defcustom Buffer-menu-name-width #'Buffer-menu--dynamic-name-width + "Width of buffer name column in the Buffer Menu. +This can either be a number (used directly) or a function that +will be called with the list of buffers and should return a +number." + :type '(choice function number) :group 'Buffer-menu - :version "24.3") + :version "28.1") (defcustom Buffer-menu-size-width 7 "Width of buffer size column in the Buffer Menu." @@ -646,25 +661,11 @@ means list those buffers and no others." (defun list-buffers--refresh (&optional buffer-list old-buffer) ;; Set up `tabulated-list-format'. - (let ((name-width Buffer-menu-name-width) - (size-width Buffer-menu-size-width) + (let ((size-width Buffer-menu-size-width) (marked-buffers (Buffer-menu-marked-buffers)) (buffer-menu-buffer (current-buffer)) (show-non-file (not Buffer-menu-files-only)) - entries) - ;; Handle obsolete variable: - (if Buffer-menu-buffer+size-width - (setq name-width (- Buffer-menu-buffer+size-width size-width))) - (setq tabulated-list-format - (vector '("C" 1 t :pad-right 0) - '("R" 1 t :pad-right 0) - '("M" 1 t) - `("Buffer" ,name-width t) - `("Size" ,size-width tabulated-list-entry-size-> - :right-align t) - `("Mode" ,Buffer-menu-mode-width t) - '("File" 1 t))) - (setq tabulated-list-use-header-line Buffer-menu-use-header-line) + entries name-width) ;; Collect info for each buffer we're interested in. (dolist (buffer (or buffer-list (buffer-list (if Buffer-menu-use-frame-buffer-list @@ -694,6 +695,22 @@ means list those buffers and no others." nil nil buffer))) (Buffer-menu--pretty-file-name file))) entries))))) + (setq name-width (if (functionp Buffer-menu-name-width) + (funcall Buffer-menu-name-width (mapcar #'car entries)) + Buffer-menu-name-width)) + ;; Handle obsolete variable: + (if Buffer-menu-buffer+size-width + (setq name-width (- Buffer-menu-buffer+size-width size-width))) + (setq tabulated-list-format + (vector '("C" 1 t :pad-right 0) + '("R" 1 t :pad-right 0) + '("M" 1 t) + `("Buffer" ,name-width t) + `("Size" ,size-width tabulated-list-entry-size-> + :right-align t) + `("Mode" ,Buffer-menu-mode-width t) + '("File" 1 t))) + (setq tabulated-list-use-header-line Buffer-menu-use-header-line) (setq tabulated-list-entries (nreverse entries))) (tabulated-list-init-header)) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 4c1a1797adc..1cc68e19edd 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -492,6 +492,7 @@ keys. Keys are compared using `equal'." SEQUENCE must be a sequence of numbers or markers." (apply #'min (seq-into sequence 'list))) +;;;###autoload (cl-defgeneric seq-max (sequence) "Return the largest element of SEQUENCE. SEQUENCE must be a sequence of numbers or markers." From 4085a2c15e4f9e162bf8c9b77f4a1a2a84ad9437 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 8 Aug 2020 11:53:09 +0200 Subject: [PATCH 115/145] Tweak how whitespace-mode marks the end of the buffer * lisp/whitespace.el (whitespace-missing-newline-at-eof): Change the colours to not be as angry. (whitespace-color-on): Don't mark the end of the buffer if point is there. --- lisp/whitespace.el | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/lisp/whitespace.el b/lisp/whitespace.el index fb5f28c0029..42c4b61daff 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -594,7 +594,7 @@ line. Used when `whitespace-style' includes the value `indentation'.") (defface whitespace-missing-newline-at-eof '((((class mono)) :inverse-video t :weight bold :underline t) - (t :background "red" :foreground "firebrick")) + (t :background "#d0d040" :foreground "black")) "Face used to visualize missing newline at the end of the file.") (defvar whitespace-empty 'whitespace-empty @@ -2137,7 +2137,13 @@ resultant list will be returned." 1 whitespace-space-after-tab t))) ,@(when (memq 'missing-newline-at-eof whitespace-active-style) ;; Show missing newline. - `(("[^\n]\\'" 0 'whitespace-missing-newline-at-eof t))))) + `(("[^\n]\\'" 0 + ;; Don't mark the end of the buffer is point is there -- + ;; it probably means that the user is typing something + ;; at the end of the buffer. + (and (/= whitespace-point (point-max)) + 'whitespace-missing-newline-at-eof) + t))))) (font-lock-add-keywords nil whitespace-font-lock-keywords t) (font-lock-flush))) From 119c34cc0aa3d7c814dff4f5b78dd589f0e2a75a Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 8 Aug 2020 12:00:57 +0200 Subject: [PATCH 116/145] Mark an mml-sec test as unstable * test/lisp/gnus/mml-sec-tests.el (mml-secure-en-decrypt-sign-1-1-single): Mark the test as unstable (bug#42720). It sometimes fails on some systems (Fedora?) when run with "-j5", so there may be a race condition in the code somewhere. --- test/lisp/gnus/mml-sec-tests.el | 1 + 1 file changed, 1 insertion(+) diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el index 917e627c7ec..8f78a66f616 100644 --- a/test/lisp/gnus/mml-sec-tests.el +++ b/test/lisp/gnus/mml-sec-tests.el @@ -623,6 +623,7 @@ In this test, encrypt-to-self variables are set to lists." (ert-deftest mml-secure-en-decrypt-sign-1-1-single () "Sign and encrypt message; then decrypt and test for expected result. In this test, just multiple encryption and signing keys may be available." + :tags '(:unstable) (skip-unless (test-conf)) (mml-secure-test-key-fixture (lambda () From f07bbb67d16365da2abd288b9993f1938dae4c20 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 8 Aug 2020 13:01:42 +0200 Subject: [PATCH 117/145] Fix up previous list-buffers patch to work when there's no buffer * lisp/buff-menu.el (Buffer-menu--dynamic-name-width): Use apply #'max instead of seq-max since the list may be empty. --- lisp/buff-menu.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 359d6381e8b..aa5c47ca7f4 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -77,9 +77,9 @@ but will never be narrower than 19 characters." ;; This gives 19 on an 80 column window, and take up ;; proportionally more space as the window widens. (min (truncate (/ (window-width) 4.2)) - (seq-max (mapcar (lambda (b) - (length (buffer-name b))) - buffers))))) + (apply #'max 0 (mapcar (lambda (b) + (length (buffer-name b))) + buffers))))) (defcustom Buffer-menu-name-width #'Buffer-menu--dynamic-name-width "Width of buffer name column in the Buffer Menu. From c3a6bcac86fd386a31a3287a9818aa7c3568769c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 8 Aug 2020 13:42:48 +0200 Subject: [PATCH 118/145] Add new utility function custom-add-choice * lisp/custom.el (custom-add-choice): New function (bug#41225). --- etc/NEWS | 5 +++++ lisp/custom.el | 14 ++++++++++++++ 2 files changed, 19 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index de10b4a6131..2b3cc80df15 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -782,6 +782,11 @@ have now been removed. * Lisp Changes in Emacs 28.1 +--- +** 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 'file-modes-number-to-symbolic' to convert a numeric file mode specification into symbolic form. diff --git a/lisp/custom.el b/lisp/custom.el index 885c486c5e4..0cb136330d5 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -1541,6 +1541,20 @@ Each of the arguments ARGS has this form: This means reset VARIABLE. (The argument IGNORED is ignored)." (apply #'custom-theme-reset-variables 'user args)) +(defun custom-add-choice (variable choice) + "Add CHOICE to the custom type of VARIABLE. +If a choice with the same tag already exists, no action is taken." + (let ((choices (get 'tab-bar-new-tab-choice 'custom-type))) + (unless (eq (car choices) 'choice) + (error "Not a choice type: %s" choices)) + (unless (seq-find (lambda (elem) + (equal (caddr (member :tag elem)) + (caddr (member :tag choice)))) + (cdr choices)) + ;; Put the new choice at the end. + (put variable 'custom-type + (append (get variable 'custom-type) (list choice)))))) + ;;; The End. (provide 'custom) From 1b8f9081b9d06575e81cb2b52bf7f62089f844ac Mon Sep 17 00:00:00 2001 From: Matthias Meulien Date: Sat, 8 Aug 2020 13:45:23 +0200 Subject: [PATCH 119/145] lisp/bookmark.el: Customize choice to show bookmark list in a new tab * lisp/bookmark.el (bookmark-bmenu-get-buffer): Add as a choice for new-tab targets (bug#41225). --- etc/NEWS | 4 ++++ lisp/bookmark.el | 13 +++++++++++++ 2 files changed, 17 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index 2b3cc80df15..01245d14f90 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -138,6 +138,10 @@ The width now depends of 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. +*** 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. + ** Windows *** The key prefix 'C-x 4 1' displays next command buffer in the same window. diff --git a/lisp/bookmark.el b/lisp/bookmark.el index de7d60f97eb..fb293adb779 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -1666,6 +1666,19 @@ Don't affect the buffer ring order." (bookmark-bmenu-list))))) +;;;###autoload +(defun bookmark-bmenu-get-buffer () + "Return the Bookmark List, building it if it doesn't exists. +Don't affect the buffer ring order." + (or (get-buffer bookmark-bmenu-buffer) + (save-excursion + (save-window-excursion + (bookmark-bmenu-list) + (get-buffer bookmark-bmenu-buffer))))) + +(custom-add-choice 'tab-bar-new-tab-choice + '(const :tag "Bookmark List" bookmark-bmenu-get-buffer)) + ;;;###autoload (defun bookmark-bmenu-list () "Display a list of existing bookmarks. From 50dd037338784381300f411c64d39a9fbaaa7f5a Mon Sep 17 00:00:00 2001 From: Philip K Date: Sat, 8 Aug 2020 13:52:46 +0200 Subject: [PATCH 120/145] Make Customize changes to outline-minor-mode-prefix happen immediately * lisp/outline.el (outline-minor-mode-prefix): Update the key map after changing the value in Customize (bug#41073). --- lisp/outline.el | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/lisp/outline.el b/lisp/outline.el index 28ea8a86e6f..d2a5d42d74a 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -289,12 +289,18 @@ Turning on outline mode calls the value of `text-mode-hook' and then of (list (list nil (concat "^\\(?:" outline-regexp "\\).*$") 0))) (add-hook 'change-major-mode-hook 'outline-show-all nil t)) +(defvar outline-minor-mode-map) + (defcustom outline-minor-mode-prefix "\C-c@" "Prefix key to use for Outline commands in Outline minor mode. The value of this variable is checked as part of loading Outline mode. After that, changing the prefix key requires manipulating keymaps." :type 'string - :group 'outlines) + :group 'outlines + :set (lambda (sym val) + (define-key outline-minor-mode-map outline-minor-mode-prefix nil) + (define-key outline-minor-mode-map val outline-mode-prefix-map) + (set-default sym val))) ;;;###autoload (define-minor-mode outline-minor-mode From 8264e8deaf6d67492964b63bb729ab6fcc350781 Mon Sep 17 00:00:00 2001 From: Philip K Date: Sat, 8 Aug 2020 13:56:05 +0200 Subject: [PATCH 121/145] outline-minor-mode-prefix is a key sequence, not a string * lisp/outline.el (outline-minor-mode-prefix): Fix the type (bug#41072). --- lisp/outline.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/outline.el b/lisp/outline.el index d2a5d42d74a..aa8ed58ad9c 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -295,7 +295,7 @@ Turning on outline mode calls the value of `text-mode-hook' and then of "Prefix key to use for Outline commands in Outline minor mode. The value of this variable is checked as part of loading Outline mode. After that, changing the prefix key requires manipulating keymaps." - :type 'string + :type 'key-sequence :group 'outlines :set (lambda (sym val) (define-key outline-minor-mode-map outline-minor-mode-prefix nil) From a8e3b29b2b73292c8497fee8932b04fa07a2c08a Mon Sep 17 00:00:00 2001 From: Philip K Date: Sat, 8 Aug 2020 13:59:03 +0200 Subject: [PATCH 122/145] Use write-region when saving recentf file * lisp/recentf.el (recentf-save-list): Don't generate backups for recentf files (bug#41060). --- lisp/recentf.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/recentf.el b/lisp/recentf.el index 27918a9739c..877edd4be1f 100644 --- a/lisp/recentf.el +++ b/lisp/recentf.el @@ -1289,7 +1289,8 @@ Write data into the file specified by `recentf-save-file'." (insert "\n \n;; Local Variables:\n" (format ";; coding: %s\n" recentf-save-file-coding-system) ";; End:\n") - (write-file (expand-file-name recentf-save-file)) + (write-region (point-min) (point-max) + (expand-file-name recentf-save-file)) (when recentf-save-file-modes (set-file-modes recentf-save-file recentf-save-file-modes)) nil) From 99f8a1c91733a8aaa47818e78dfe86c5635ce086 Mon Sep 17 00:00:00 2001 From: Fabrice Niessen Date: Sat, 8 Aug 2020 14:21:38 +0200 Subject: [PATCH 123/145] Update Leuven-theme * etc/themes/leuven-theme.el (class): Update theme (bug#40759). --- etc/themes/leuven-theme.el | 682 ++++++++++++++++++++++++++++--------- 1 file changed, 516 insertions(+), 166 deletions(-) diff --git a/etc/themes/leuven-theme.el b/etc/themes/leuven-theme.el index c298b536d2d..f104c845ff6 100644 --- a/etc/themes/leuven-theme.el +++ b/etc/themes/leuven-theme.el @@ -4,7 +4,7 @@ ;; Author: Fabrice Niessen <(concat "fniessen" at-sign "pirilampo.org")> ;; URL: https://github.com/fniessen/emacs-leuven-theme -;; Version: 20200425.0837 +;; Version: 20200513.1928 ;; Keywords: color theme ;; This file is part of GNU Emacs. @@ -31,42 +31,98 @@ ;; ;; (load-theme 'leuven t) ;; -;; Requirements: Emacs 24. +;; Requirements: Emacs 24+. +;; +;; NOTE -- Would you like implement a version of this for dark backgrounds, +;; please do so! I'm willing to integrate it... ;;; Code: +;;; Options. + +(defgroup leuven nil + "Leuven theme options. +The theme has to be reloaded after changing anything in this group." + :group 'faces) + +(defcustom leuven-scale-outline-headlines t + "Scale `outline' (and `org') level-1 headlines. +This can be nil for unscaled, t for using the theme default, or a scaling +number." + :type '(choice + (const :tag "Unscaled" nil) + (const :tag "Default provided by theme" t) + (number :tag "Set scaling")) + :group 'leuven) + +(defcustom leuven-scale-org-agenda-structure t + "Scale Org agenda structure lines, like dates. +This can be nil for unscaled, t for using the theme default, or a scaling +number." + :type '(choice + (const :tag "Unscaled" nil) + (const :tag "Default provided by theme" t) + (number :tag "Set scaling"))) + +(defun leuven-scale-font (control default-height) + "Function for splicing optional font heights into face descriptions. +CONTROL can be a number, nil, or t. When t, use DEFAULT-HEIGHT." + (cond + ((numberp control) (list :height control)) + ((eq t control) (list :height default-height)) + (t nil))) + +;;; Theme Faces. + (deftheme leuven "Face colors with a light background. -Basic, Font Lock, Isearch, Gnus, Message, Diff, Ediff, Flyspell, -Semantic, and Ansi-Color faces are included -- and much more...") +Basic, Font Lock, Isearch, Gnus, Message, Org mode, Diff, Ediff, +Flyspell, Semantic, and Ansi-Color faces are included -- and much +more...") (let ((class '((class color) (min-colors 89))) - ;; Leuven generic colors - (cancel '(:slant italic :strike-through t :foreground "gray55")) + ;; Leuven generic colors. + (cancel '(:slant italic :strike-through t :foreground "#A9A9A9")) (clock-line '(:box (:line-width 1 :color "#335EA8") :foreground "black" :background "#EEC900")) (code-block '(:foreground "#000088" :background "#FFFFE0")) (code-inline '(:foreground "#006400" :background "#FDFFF7")) (column '(:height 1.0 :weight normal :slant normal :underline nil :strike-through nil :foreground "#E6AD4F" :background "#FFF2DE")) - (diff-added '(:foreground "#008000" :background "#DDFFDD")) + (completion-inline '(:weight normal :foreground "#C0C0C0" :inherit hl-line)) ; Like Google. + (completion-other-candidates '(:weight bold :foreground "black" :background "#EBF4FE")) + (completion-selected-candidate '(:weight bold :foreground "white" :background "#0052A4")) + (diff-added '(:background "#DDFFDD")) (diff-changed '(:foreground "#0000FF" :background "#DDDDFF")) - (diff-header '(:foreground "#800000" :background "#FFFFAF")) + (diff-header '(:weight bold :foreground "#800000" :background "#FFFFAF")) (diff-hunk-header '(:foreground "#990099" :background "#FFEEFF")) - (diff-none '(:foreground "gray33")) - (diff-removed '(:foreground "#A60000" :background "#FFDDDD")) + (diff-none '(:foreground "#888888")) + (diff-refine-added '(:background "#97F295")) + (diff-refine-removed '(:background "#FFB6BA")) + (diff-removed '(:background "#FEE8E9")) (directory '(:weight bold :foreground "blue" :background "#FFFFD2")) - (highlight-line '(:background "#FFFFD7")) ; #F5F5F5 - (highlight-line-gnus '(:background "#DAEAFC")) ; defined in `gnus-leuven.el' + (file '(:foreground "black")) + (function-param '(:foreground "#247284")) + (grep-file-name '(:weight bold :foreground "#2A489E")) ; Used for grep hits. + (grep-line-number '(:weight bold :foreground "#A535AE")) + (highlight-blue '(:background "#E6ECFF")) + (highlight-blue2 '(:background "#E4F1F9")) + (highlight-gray '(:background "#E4E4E3")) + (highlight-green '(:background "#D5F1CF")) + (highlight-red '(:background "#FFC8C8")) + (highlight-yellow '(:background "#F6FECD")) (link '(:weight normal :underline t :foreground "#006DAF")) + (link-no-underline '(:weight normal :foreground "#006DAF")) (mail-header-name '(:family "Sans Serif" :weight normal :foreground "#A3A3A2")) (mail-header-other '(:family "Sans Serif" :slant normal :foreground "#666666")) - (mail-read '(:weight normal :foreground "#86878B")) - (mail-ticked '(:weight bold :background "#FBE6EF")) + (mail-read '(:foreground "#8C8C8C")) + (mail-read-high '(:foreground "#808080")) + (mail-ticked '(:foreground "#FF3300")) (mail-to '(:family "Sans Serif" :underline nil :foreground "#006DAF")) - (mail-unread '(:weight bold :foreground "black")) - (marked-line '(:weight bold :foreground "white" :background "red")) - (match '(:weight bold :background "#FBE448")) ; occur patterns - (ol1 '(:height 1.3 :weight bold :overline "#A7A7A7" :foreground "#3C3C3C" :background "#F0F0F0")) + (mail-unread '(:weight bold :foreground "#000000")) + (mail-unread-high '(:weight bold :foreground "#135985")) + (marked-line '(:foreground "#AA0000" :background "#FFAAAA")) + (match '(:weight bold :background "#FFFF00")) ; occur patterns + match in helm for files + match in Org files. + (ol1 `(,@(leuven-scale-font leuven-scale-outline-headlines 1.3) :weight bold :overline "#A7A7A7" :foreground "#3C3C3C" :background "#F0F0F0")) (ol2 '(:height 1.0 :weight bold :overline "#123555" :foreground "#123555" :background "#E5F4FB")) (ol3 '(:height 1.0 :weight bold :foreground "#005522" :background "#EFFFEF")) (ol4 '(:height 1.0 :weight bold :slant normal :foreground "#EA6300")) @@ -74,15 +130,22 @@ Semantic, and Ansi-Color faces are included -- and much more...") (ol6 '(:height 1.0 :weight bold :slant italic :foreground "#0077CC")) (ol7 '(:height 1.0 :weight bold :slant italic :foreground "#2EAE2C")) (ol8 '(:height 1.0 :weight bold :slant italic :foreground "#FD8008")) - (paren-matched '(:background "#99CCFF")) - (paren-unmatched '(:underline "red" :foreground nil :background "#FFDCDC")) - (region '(:background "#ABDFFA")) + (paren-matched '(:background "#C0E8C3")) ; Or take that green for region? + (paren-unmatched '(:weight bold :underline "red" :foreground "black" :background "#FFA5A5")) + (region '(:background "#8ED3FF")) (shadow '(:foreground "#7F7F7F")) (string '(:foreground "#008000")) ; or #D0372D (subject '(:family "Sans Serif" :weight bold :foreground "black")) - (symlink '(:foreground "deep sky blue")) - (volatile-highlight '(:underline nil :background "#FFF876")) - (vc-branch '(:box (:line-width 1 :color "#00CC33") :foreground "black" :background "#AAFFAA"))) + (symlink '(:foreground "#1F8DD6")) + (tab '(:foreground "#E8E8E8" :background "white")) + (trailing '(:foreground "#E8E8E8" :background "#FFFFAB")) + (volatile-highlight '(:underline nil :foreground "white" :background "#9E3699")) + (volatile-highlight-supersize '(:height 1.1 :underline nil :foreground "white" :background "#9E3699")) ; flash-region + (vc-branch '(:box (:line-width 1 :color "#00CC33") :foreground "black" :background "#AAFFAA")) + (xml-attribute '(:foreground "#F36335")) + (xml-tag '(:foreground "#AE1B9A")) + (highlight-current-tag '(:background "#E8E8FF")) ; #EEF3F6 or #FFEB26 + ) (custom-theme-set-faces 'leuven @@ -91,40 +154,43 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(bold-italic ((,class (:weight bold :slant italic :foreground "black")))) `(italic ((,class (:slant italic :foreground "#1A1A1A")))) `(underline ((,class (:underline t)))) - `(cursor ((,class (:background "#0FB300")))) + `(cursor ((,class (:background "#21BDFF")))) - ;; Highlighting faces - `(fringe ((,class (:foreground "#9B9B9B" :background "#EDEDED")))) - `(highlight ((,class ,volatile-highlight))) + ;; Lucid toolkit emacs menus. + `(menu ((,class (:foreground "#FFFFFF" :background "#333333")))) + + ;; Highlighting faces. + `(fringe ((,class (:foreground "#4C9ED9" :background "white")))) + `(highlight ((,class ,highlight-blue))) `(region ((,class ,region))) - `(secondary-selection ((,class ,match))) ; used by Org-mode for highlighting matched entries and keywords - `(isearch ((,class (:weight bold :underline "#FF9632" :foreground nil :background "#FDBD33")))) - `(isearch-fail ((,class (:weight bold :foreground "black" :background "#FF9999")))) - `(lazy-highlight ((,class (:underline "#FF9632" :background "#FFFF00")))) ; isearch others - `(trailing-whitespace ((,class (:background "#FFFF57")))) - `(whitespace-hspace ((,class (:foreground "#D2D2D2")))) - `(whitespace-indentation ((,class (:foreground "#A1A1A1" :background "white")))) + `(secondary-selection ((,class ,match))) ; Used by Org-mode for highlighting matched entries and keywords. + `(isearch ((,class (:underline "black" :foreground "white" :background "#5974AB")))) + `(isearch-fail ((,class (:weight bold :foreground "black" :background "#FFCCCC")))) + `(lazy-highlight ((,class (:foreground "black" :background "#FFFF00")))) ; Isearch others (see `match'). + `(trailing-whitespace ((,class ,trailing))) + `(query-replace ((,class (:inherit isearch)))) + `(whitespace-hspace ((,class (:foreground "#D2D2D2")))) ; see also `nobreak-space' + `(whitespace-indentation ((,class ,tab))) `(whitespace-line ((,class (:foreground "#CC0000" :background "#FFFF88")))) - `(whitespace-tab ((,class (:foreground "#A1A1A1" :background "white")))) - `(whitespace-trailing ((,class (:foreground "#B3B3B3" :background "#FFFF57")))) + `(whitespace-tab ((,class ,tab))) + `(whitespace-trailing ((,class ,trailing))) - ;; Mode line faces + ;; Mode line faces. `(mode-line ((,class (:box (:line-width 1 :color "#1A2F54") :foreground "#85CEEB" :background "#335EA8")))) `(mode-line-inactive ((,class (:box (:line-width 1 :color "#4E4E4C") :foreground "#F0F0EF" :background "#9B9C97")))) `(mode-line-buffer-id ((,class (:weight bold :foreground "white")))) `(mode-line-emphasis ((,class (:weight bold :foreground "white")))) `(mode-line-highlight ((,class (:foreground "yellow")))) - ;; Escape and prompt faces + ;; Escape and prompt faces. `(minibuffer-prompt ((,class (:weight bold :foreground "black" :background "gold")))) `(minibuffer-noticeable-prompt ((,class (:weight bold :foreground "black" :background "gold")))) `(escape-glyph ((,class (:foreground "#008ED1")))) - `(homoglyph ((,class (:foreground "#008ED1")))) `(error ((,class (:foreground "red")))) `(warning ((,class (:weight bold :foreground "orange")))) `(success ((,class (:foreground "green")))) - ;; Font lock faces + ;; Font lock faces. `(font-lock-builtin-face ((,class (:foreground "#006FE0")))) `(font-lock-comment-delimiter-face ((,class (:foreground "#8D8D84")))) ; #696969 `(font-lock-comment-face ((,class (:slant italic :foreground "#8D8D84")))) ; #696969 @@ -140,32 +206,32 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(font-lock-variable-name-face ((,class (:weight normal :foreground "#BA36A5")))) ; #800080 `(font-lock-warning-face ((,class (:weight bold :foreground "red")))) - ;; Button and link faces + ;; Button and link faces. `(link ((,class ,link))) `(link-visited ((,class (:underline t :foreground "#E5786D")))) `(button ((,class (:underline t :foreground "#006DAF")))) - `(header-line ((,class (:weight bold :underline "black" :overline "black" :foreground "black" :background "#FFFF88")))) + `(header-line ((,class (:box (:line-width 1 :color "black") :foreground "black" :background "#F0F0F0")))) - ;; Gnus faces + ;; Gnus faces. `(gnus-button ((,class (:weight normal)))) `(gnus-cite-attribution-face ((,class (:foreground "#5050B0")))) - `(gnus-cite-face-1 ((,class (:foreground "#5050B0")))) - `(gnus-cite-face-10 ((,class (:foreground "#990000")))) - `(gnus-cite-face-2 ((,class (:foreground "#660066")))) - `(gnus-cite-face-3 ((,class (:foreground "#007777")))) - `(gnus-cite-face-4 ((,class (:foreground "#990000")))) - `(gnus-cite-face-5 ((,class (:foreground "#000099")))) - `(gnus-cite-face-6 ((,class (:foreground "#BB6600")))) - `(gnus-cite-face-7 ((,class (:foreground "#5050B0")))) - `(gnus-cite-face-8 ((,class (:foreground "#660066")))) - `(gnus-cite-face-9 ((,class (:foreground "#007777")))) + `(gnus-cite-1 ((,class (:foreground "#5050B0" :background "#F6F6F6")))) + `(gnus-cite-2 ((,class (:foreground "#660066" :background "#F6F6F6")))) + `(gnus-cite-3 ((,class (:foreground "#007777" :background "#F6F6F6")))) + `(gnus-cite-4 ((,class (:foreground "#990000" :background "#F6F6F6")))) + `(gnus-cite-5 ((,class (:foreground "#000099" :background "#F6F6F6")))) + `(gnus-cite-6 ((,class (:foreground "#BB6600" :background "#F6F6F6")))) + `(gnus-cite-7 ((,class (:foreground "#5050B0" :background "#F6F6F6")))) + `(gnus-cite-8 ((,class (:foreground "#660066" :background "#F6F6F6")))) + `(gnus-cite-9 ((,class (:foreground "#007777" :background "#F6F6F6")))) + `(gnus-cite-10 ((,class (:foreground "#990000" :background "#F6F6F6")))) `(gnus-emphasis-bold ((,class (:weight bold)))) `(gnus-emphasis-highlight-words ((,class (:foreground "yellow" :background "black")))) `(gnus-group-mail-1 ((,class (:weight bold :foreground "#FF50B0")))) `(gnus-group-mail-1-empty ((,class (:foreground "#5050B0")))) `(gnus-group-mail-2 ((,class (:weight bold :foreground "#FF0066")))) `(gnus-group-mail-2-empty ((,class (:foreground "#660066")))) - `(gnus-group-mail-3 ((,class (:weight bold :foreground "black")))) + `(gnus-group-mail-3 ((,class ,mail-unread))) `(gnus-group-mail-3-empty ((,class ,mail-read))) `(gnus-group-mail-low ((,class ,cancel))) `(gnus-group-mail-low-empty ((,class ,cancel))) @@ -173,8 +239,8 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(gnus-group-news-1-empty ((,class (:foreground "#5050B0")))) `(gnus-group-news-2 ((,class (:weight bold :foreground "#FF0066")))) `(gnus-group-news-2-empty ((,class (:foreground "#660066")))) - `(gnus-group-news-3 ((,class (:weight bold :foreground "black")))) - `(gnus-group-news-3-empty ((,class (:foreground "#808080")))) + `(gnus-group-news-3 ((,class ,mail-unread))) + `(gnus-group-news-3-empty ((,class ,mail-read))) `(gnus-group-news-4 ((,class (:weight bold :foreground "#FF0000")))) `(gnus-group-news-4-empty ((,class (:foreground "#990000")))) `(gnus-group-news-5 ((,class (:weight bold :foreground "#FF0099")))) @@ -194,11 +260,11 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(gnus-signature ((,class (:slant italic :foreground "#8B8D8E")))) `(gnus-splash ((,class (:foreground "#FF8C00")))) `(gnus-summary-cancelled ((,class ,cancel))) - `(gnus-summary-high-ancient ((,class (:weight normal :foreground "#808080" :background "#FFFFE6")))) - `(gnus-summary-high-read ((,class (:weight normal :foreground "#999999" :background "#FFFFE6")))) + `(gnus-summary-high-ancient ((,class ,mail-unread-high))) + `(gnus-summary-high-read ((,class ,mail-read-high))) `(gnus-summary-high-ticked ((,class ,mail-ticked))) - `(gnus-summary-high-unread ((,class (:weight bold :foreground "black" :background "#FFFFCC")))) - `(gnus-summary-low-ancient ((,class (:slant italic :foreground "gray55")))) + `(gnus-summary-high-unread ((,class ,mail-unread-high))) + `(gnus-summary-low-ancient ((,class (:slant italic :foreground "black")))) `(gnus-summary-low-read ((,class (:slant italic :foreground "#999999" :background "#E0E0E0")))) `(gnus-summary-low-ticked ((,class ,mail-ticked))) `(gnus-summary-low-unread ((,class (:slant italic :foreground "black")))) @@ -209,82 +275,105 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(gnus-summary-selected ((,class (:foreground "white" :background "#008CD7")))) `(gnus-x-face ((,class (:foreground "black" :background "white")))) - ;; Message faces + ;; Message faces. `(message-header-name ((,class ,mail-header-name))) `(message-header-cc ((,class ,mail-to))) `(message-header-other ((,class ,mail-header-other))) `(message-header-subject ((,class ,subject))) `(message-header-to ((,class ,mail-to))) - `(message-cited-text ((,class (:foreground "#5050B0")))) + `(message-cited-text ((,class (:foreground "#5050B0" :background "#F6F6F6")))) `(message-separator ((,class (:family "Sans Serif" :weight normal :foreground "#BDC2C6")))) `(message-header-newsgroups ((,class (:family "Sans Serif" :foreground "#3399CC")))) `(message-header-xheader ((,class ,mail-header-other))) `(message-mml ((,class (:foreground "forest green")))) - ;; Diff + ;; Diff. `(diff-added ((,class ,diff-added))) `(diff-changed ((,class ,diff-changed))) `(diff-context ((,class ,diff-none))) `(diff-file-header ((,class ,diff-header))) `(diff-file1-hunk-header ((,class (:foreground "dark magenta" :background "#EAF2F5")))) `(diff-file2-hunk-header ((,class (:foreground "#2B7E2A" :background "#EAF2F5")))) - `(diff-function ((,class (:foreground "darkgray")))) + `(diff-function ((,class (:foreground "#CC99CC")))) `(diff-header ((,class ,diff-header))) `(diff-hunk-header ((,class ,diff-hunk-header))) `(diff-index ((,class ,diff-header))) - `(diff-indicator-added ((,class (:background "#AAFFAA")))) - `(diff-indicator-changed ((,class (:background "#8080FF")))) - `(diff-indicator-removed ((,class (:background "#FFBBBB")))) + `(diff-indicator-added ((,class (:foreground "#3A993A" :background "#CDFFD8")))) + `(diff-indicator-changed ((,class (:background "#DBEDFF")))) + `(diff-indicator-removed ((,class (:foreground "#CC3333" :background "#FFDCE0")))) + `(diff-refine-added ((,class ,diff-refine-added))) `(diff-refine-change ((,class (:background "#DDDDFF")))) + `(diff-refine-removed ((,class ,diff-refine-removed))) `(diff-removed ((,class ,diff-removed))) - ;; SMerge + ;; SMerge. + `(smerge-mine ((,class ,diff-changed))) + `(smerge-other ((,class ,diff-added))) + `(smerge-base ((,class ,diff-removed))) + `(smerge-markers ((,class (:background "#FFE5CC")))) `(smerge-refined-change ((,class (:background "#AAAAFF")))) - ;; Ediff - `(ediff-current-diff-A ((,class (:foreground "gray33" :background "#FFDDDD")))) - `(ediff-current-diff-B ((,class (:foreground "gray33" :background "#DDFFDD")))) - `(ediff-current-diff-C ((,class (:foreground "black" :background "cyan")))) - `(ediff-even-diff-A ((,class (:foreground "black" :background "light grey")))) - `(ediff-even-diff-B ((,class (:foreground "black" :background "light grey")))) - `(ediff-fine-diff-A ((,class (:foreground "#A60000" :background "#FFAAAA")))) - `(ediff-fine-diff-B ((,class (:foreground "#008000" :background "#55FF55")))) - `(ediff-odd-diff-A ((,class (:foreground "black" :background "light grey")))) - `(ediff-odd-diff-B ((,class (:foreground "black" :background "light grey")))) + ;; Ediff. + `(ediff-current-diff-A ((,class (:background "#FFDDDD")))) + `(ediff-current-diff-B ((,class (:background "#DDFFDD")))) + `(ediff-current-diff-C ((,class (:background "cyan")))) + `(ediff-even-diff-A ((,class (:background "light grey")))) + `(ediff-even-diff-B ((,class (:background "light grey")))) + `(ediff-fine-diff-A ((,class (:background "#FFAAAA")))) + `(ediff-fine-diff-B ((,class (:background "#55FF55")))) + `(ediff-odd-diff-A ((,class (:background "light grey")))) + `(ediff-odd-diff-B ((,class (:background "light grey")))) - ;; Flyspell -;; (when (version< emacs-version "24.XXX") - `(flyspell-duplicate ((,class (:underline "#008000" :inherit nil)))) - `(flyspell-incorrect ((,class (:underline "red" :inherit nil)))) -;; `(flyspell-duplicate ((,class (:underline (:style wave :color "#008000") :inherit nil)))) -;; `(flyspell-incorrect ((,class (:underline (:style wave :color "red") :inherit nil)))) + ;; Flyspell. + (if (version< emacs-version "24.4") + `(flyspell-duplicate ((,class (:underline "#F4EB80" :inherit nil)))) + `(flyspell-duplicate ((,class (:underline (:style wave :color "#F4EB80") :background "#FAF7CC" :inherit nil))))) + (if (version< emacs-version "24.4") + `(flyspell-incorrect ((,class (:underline "#FAA7A5" :inherit nil)))) + `(flyspell-incorrect ((,class (:underline (:style wave :color "#FAA7A5") :background "#F4D7DA":inherit nil))))) - ;; ;; Semantic faces + ;; ;; Semantic faces. ;; `(semantic-decoration-on-includes ((,class (:underline ,cham-4)))) ;; `(semantic-decoration-on-private-members-face ((,class (:background ,alum-2)))) ;; `(semantic-decoration-on-protected-members-face ((,class (:background ,alum-2)))) - ;; `(semantic-decoration-on-unknown-includes ((,class (:background ,choc-3)))) + `(semantic-decoration-on-unknown-includes ((,class (:background "#FFF8F8")))) ;; `(semantic-decoration-on-unparsed-includes ((,class (:underline ,orange-3)))) - ;; `(semantic-tag-boundary-face ((,class (:overline ,blue-1)))) + `(semantic-highlight-func-current-tag-face ((,class ,highlight-current-tag))) + `(semantic-tag-boundary-face ((,class (:overline "#777777")))) ; Method separator. ;; `(semantic-unmatched-syntax-face ((,class (:underline ,red-1)))) `(Info-title-1-face ((,class ,ol1))) `(Info-title-2-face ((,class ,ol2))) `(Info-title-3-face ((,class ,ol3))) `(Info-title-4-face ((,class ,ol4))) - `(ac-completion-face ((,class (:underline nil :foreground "#C0C0C0")))) ; like Google - `(ace-jump-face-foreground ((,class (:foreground "black" :background "#FBE448")))) + `(ace-jump-face-foreground ((,class (:weight bold :foreground "black" :background "#FEA500")))) + `(ahs-face ((,class (:background "#E4E4FF")))) + `(ahs-definition-face ((,class (:background "#FFB6C6")))) + `(ahs-plugin-defalt-face ((,class (:background "#FFE4FF")))) ; Current. + `(anzu-match-1 ((,class (:foreground "black" :background "aquamarine")))) + `(anzu-match-2 ((,class (:foreground "black" :background "springgreen")))) + `(anzu-match-3 ((,class (:foreground "black" :background "red")))) + `(anzu-mode-line ((,class (:foreground "black" :background "#80FF80")))) + `(anzu-mode-line-no-match ((,class (:foreground "black" :background "#FF8080")))) + `(anzu-replace-highlight ((,class (:inherit query-replace)))) + `(anzu-replace-to ((,class (:weight bold :foreground "#BD33FD" :background "#FDBD33")))) `(auto-dim-other-buffers-face ((,class (:background "#F7F7F7")))) + `(avy-background-face ((,class (:background "#A9A9A9")))) + `(avy-lead-face ((,class (:weight bold :foreground "black" :background "#FEA500")))) `(bbdb-company ((,class (:slant italic :foreground "steel blue")))) `(bbdb-field-name ((,class (:weight bold :foreground "steel blue")))) `(bbdb-field-value ((,class (:foreground "steel blue")))) `(bbdb-name ((,class (:underline t :foreground "#FF6633")))) - `(bmkp-light-autonamed ((,class (:background "#C2DDFD")))) - `(bmkp-light-fringe-autonamed ((,class (:background "#90AFD5")))) - `(bmkp-light-fringe-non-autonamed ((,class (:background "#D5FFD5")))) - `(bmkp-light-non-autonamed ((,class (:background "#C4FFC4")))) - `(browse-kill-ring-separator-face ((,class (:weight bold :foreground "slate gray")))) + `(bmkp-light-autonamed ((,class (:background "#F0F0F0")))) + `(bmkp-light-fringe-autonamed ((,class (:foreground "#5A5A5A" :background "#D4D4D4")))) + `(bmkp-light-fringe-non-autonamed ((,class (:foreground "#FFFFCC" :background "#01FFFB")))) ; default + `(bmkp-light-non-autonamed ((,class (:background "#BFFFFE")))) + `(bmkp-no-local ((,class (:background "pink")))) + `(browse-kill-ring-separator-face ((,class (:foreground "red")))) + `(calendar-month-header ((,class (:weight bold :foreground "#4F4A3D" :background "#FFFFCC")))) `(calendar-today ((,class (:weight bold :foreground "#4F4A3D" :background "#FFFFCC")))) + `(calendar-weekday-header ((,class (:weight bold :foreground "#1662AF")))) + `(calendar-weekend-header ((,class (:weight bold :foreground "#4E4E4E")))) `(cfw:face-annotation ((,class (:foreground "green" :background "red")))) `(cfw:face-day-title ((,class (:foreground "#C9C9C9")))) `(cfw:face-default-content ((,class (:foreground "#2952A3")))) @@ -299,12 +388,14 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(cfw:face-sunday ((,class (:foreground "#4E4E4E" :background "white" :weight bold)))) `(cfw:face-title ((,class (:height 2.0 :foreground "#676767" :weight bold :inherit variable-pitch)))) `(cfw:face-today ((,class (:foreground "#4F4A3D" :background "#FFFFCC")))) - `(cfw:face-today-title ((,class (:foreground "#4A95EB" :background "#FFFFCC")))) + `(cfw:face-today-title ((,class (:foreground "white" :background "#1766B1")))) `(cfw:face-toolbar ((,class (:background "white")))) `(cfw:face-toolbar-button-off ((,class (:foreground "#CFCFCF" :background "white")))) `(cfw:face-toolbar-button-on ((,class (:foreground "#5E5E5E" :background "#F6F6F6")))) - `(change-log-date-face ((,class (:foreground "purple")))) + `(change-log-date ((,class (:foreground "purple")))) `(change-log-file ((,class (:weight bold :foreground "#4183C4")))) + `(change-log-list ((,class (:foreground "black" :background "#75EEC7")))) + `(change-log-name ((,class (:foreground "#008000")))) `(circe-highlight-all-nicks-face ((,class (:foreground "blue" :background "#F0F0F0")))) ; other nick names `(circe-highlight-nick-face ((,class (:foreground "#009300" :background "#F0F0F0")))) ; messages with my nick cited `(circe-my-message-face ((,class (:foreground "#8B8B8B" :background "#F0F0F0")))) @@ -314,15 +405,38 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(comint-highlight-input ((,class (:weight bold :foreground "#0000FF" :inherit nil)))) ;; `(comint-highlight-prompt ((,class (:weight bold :foreground "black" :background "gold")))) `(comint-highlight-prompt ((,class (:weight bold :foreground "#0000FF" :inherit nil)))) - `(company-preview-common ((,class (:foreground "#C0C0C0" :background "#FFFFD7")))) ; same background as highlight-line - `(company-tooltip-annotation ((,class (:foreground "#999999" :background "cornsilk")))) - `(company-tooltip-common ((,class (:weight bold :inherit company-tooltip)))) - `(company-tooltip-common-selection ((,class (:weight bold :inherit company-tooltip-selection)))) + + ;; `(ac-selection-face ((,class ,completion-selected-candidate))) + `(ac-selection-face ((,class (:weight bold :foreground "white" :background "orange")))) ; TEMP For diff'ing AC from Comp. + `(ac-candidate-face ((,class ,completion-other-candidates))) + `(ac-completion-face ((,class ,completion-inline))) + `(ac-candidate-mouse-face ((,class (:inherit highlight)))) + `(popup-scroll-bar-background-face ((,class (:background "#EBF4FE")))) + `(popup-scroll-bar-foreground-face ((,class (:background "#D1DAE4")))) ; Scrollbar (visible). + + `(company-tooltip-common-selection ((,class (:weight normal :foreground "#F9ECCC" :inherit company-tooltip-selection)))) ; Prefix + common part in tooltip (for selection). + `(company-tooltip-selection ((,class ,completion-selected-candidate))) ; Suffix in tooltip (for selection). + `(company-tooltip-annotation-selection ((,class (:weight normal :foreground "#F9ECCC")))) ; Annotation (for selection). + + `(company-tooltip-common ((,class (:weight normal :foreground "#B000B0" :inherit company-tooltip)))) ; Prefix + common part in tooltip. + `(company-tooltip ((,class ,completion-other-candidates))) ; Suffix in tooltip. + `(company-tooltip-annotation ((,class (:weight normal :foreground "#2415FF")))) ; Annotation. + + `(company-preview-common ((,class ,completion-inline))) + + `(company-scrollbar-bg ((,class (:background "#EBF4FE")))) + `(company-scrollbar-fg ((,class (:background "#D1DAE4")))) ; Scrollbar (visible). + `(compare-windows ((,class (:background "#FFFF00")))) - `(compilation-error ((,class (:weight bold :foreground "red")))) - `(compilation-info ((,class (:weight bold :foreground "#2A489E")))) ; used for grep - `(compilation-line-number ((,class (:weight bold :foreground "#A535AE")))) + ;; `(completions-common-part ((,class (:foreground "red" :weight bold)))) + ;; `(completions-first-difference ((,class (:foreground "green" :weight bold)))) + `(compilation-error ((,class (:weight bold :foreground "red")))) ; Used for grep error messages. + `(compilation-info ((,class (:weight bold :foreground "#6784d7")))) + `(compilation-line-number ((,class ,grep-line-number))) `(compilation-warning ((,class (:weight bold :foreground "orange")))) + `(compilation-mode-line-exit ((,class (:weight bold :foreground "green")))) ; :exit[matched] + `(compilation-mode-line-fail ((,class (:weight bold :foreground "violet")))) ; :exit[no match] + `(compilation-mode-line-run ((,class (:weight bold :foreground "orange")))) ; :run `(css-property ((,class (:foreground "#00AA00")))) `(css-selector ((,class (:weight bold :foreground "blue")))) `(custom-button ((,class (:box (:line-width 2 :style released-button) :foreground "black" :background "lightgrey")))) @@ -348,11 +462,14 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(custom-variable-button ((,class (:weight bold :underline t)))) `(custom-variable-tag ((,class (:family "Sans Serif" :height 1.2 :weight bold :foreground "blue1")))) `(custom-visibility ((,class ,link))) - `(diff-hl-change ((,class (:foreground "blue3" :inherit diff-changed)))) - `(diff-hl-delete ((,class (:foreground "red3" :inherit diff-removed)))) - `(diff-hl-dired-change ((,class (:background "#FFA335" :foreground "black" :weight bold)))) + `(diff-hl-change ((,class (:foreground "blue3" :background "#DBEDFF")))) + `(diff-hl-delete ((,class (:foreground "red3" :background "#FFDCE0")))) + `(diff-hl-dired-change ((,class (:weight bold :foreground "black" :background "#FFA335")))) + `(diff-hl-dired-delete ((,class (:weight bold :foreground "#D73915")))) + `(diff-hl-dired-ignored ((,class (:weight bold :foreground "white" :background "#C0BBAB")))) + `(diff-hl-dired-insert ((,class (:weight bold :foreground "#B9B9BA")))) `(diff-hl-dired-unknown ((,class (:foreground "white" :background "#3F3BB4")))) - `(diff-hl-insert ((,class (:foreground "green4" :inherit diff-added)))) + `(diff-hl-insert ((,class (:foreground "green4" :background "#CDFFD8")))) `(diff-hl-unknown ((,class (:foreground "white" :background "#3F3BB4")))) `(diary-face ((,class (:foreground "#87C9FC")))) `(dircolors-face-asm ((,class (:foreground "black")))) @@ -385,17 +502,36 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(diredp-compressed-file-suffix ((,class (:foreground "red")))) `(diredp-date-time ((,class (:foreground "purple")))) `(diredp-dir-heading ((,class ,directory))) + `(diredp-dir-name ((,class ,directory))) `(diredp-dir-priv ((,class ,directory))) `(diredp-exec-priv ((,class (:background "#03C03C")))) `(diredp-executable-tag ((,class (:foreground "ForestGreen" :background "white")))) - `(diredp-file-name ((,class (:foreground "black")))) + `(diredp-file-name ((,class ,file))) `(diredp-file-suffix ((,class (:foreground "#C0C0C0")))) `(diredp-flag-mark-line ((,class ,marked-line))) `(diredp-ignored-file-name ((,class ,shadow))) `(diredp-read-priv ((,class (:background "#0A99FF")))) `(diredp-write-priv ((,class (:foreground "white" :background "#FF4040")))) + `(eldoc-highlight-function-argument ((,class (:weight bold :foreground "red" :background "#FFE4FF")))) + `(elfeed-search-filter-face ((,class (:foreground "gray")))) + ;; `(eww-form-checkbox ((,class ()))) + ;; `(eww-form-select ((,class ()))) + ;; `(eww-form-submit ((,class ()))) + `(eww-form-text ((,class (:weight bold :foreground "#40586F" :background "#A7CDF1")))) + ;; `(eww-form-textarea ((,class ()))) `(file-name-shadow ((,class ,shadow))) + `(flycheck-error ((,class (:underline (:color "#FE251E" :style wave) :weight bold :background "#FFE1E1")))) + `(flycheck-error-list-line-number ((,class (:foreground "#A535AE")))) + `(flycheck-fringe-error ((,class (:foreground "#FE251E")))) + `(flycheck-fringe-info ((,class (:foreground "#158A15")))) + `(flycheck-fringe-warning ((,class (:foreground "#F4A939")))) + `(flycheck-info ((,class (:underline (:color "#158A15" :style wave) :weight bold)))) + `(flycheck-warning ((,class (:underline (:color "#F4A939" :style wave) :weight bold :background "#FFFFBE")))) `(font-latex-bold-face ((,class (:weight bold :foreground "black")))) + `(fancy-narrow-blocked-face ((,class (:foreground "#9998A4")))) + `(flycheck-color-mode-line-error-face ((, class (:background "#CF5B56")))) + `(flycheck-color-mode-line-warning-face ((, class (:background "#EBC700")))) + `(flycheck-color-mode-line-info-face ((, class (:background "yellow")))) `(font-latex-italic-face ((,class (:slant italic :foreground "#1A1A1A")))) `(font-latex-math-face ((,class (:foreground "blue")))) `(font-latex-sectioning-1-face ((,class (:family "Sans Serif" :height 2.7 :weight bold :foreground "cornflower blue")))) @@ -408,36 +544,65 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(font-latex-verbatim-face ((,class (:foreground "#000088" :background "#FFFFE0" :inherit nil)))) `(git-commit-summary-face ((,class (:foreground "#000000")))) `(git-commit-comment-face ((,class (:slant italic :foreground "#696969")))) + `(git-timemachine-commit ((,class ,diff-removed))) + `(git-timemachine-minibuffer-author-face ((,class ,diff-added))) + `(git-timemachine-minibuffer-detail-face ((,class ,diff-header))) + `(google-translate-text-face ((,class (:foreground "#777777" :background "#F5F5F5")))) + `(google-translate-phonetic-face ((,class (:inherit shadow)))) + `(google-translate-translation-face ((,class (:weight normal :foreground "#3079ED" :background "#E3EAF2")))) + `(google-translate-suggestion-label-face ((,class (:foreground "red")))) + `(google-translate-suggestion-face ((,class (:slant italic :underline t)))) + `(google-translate-listen-button-face ((,class (:height 0.8)))) `(helm-action ((,class (:foreground "black")))) + `(helm-bookmark-file ((,class ,file))) `(helm-bookmarks-su-face ((,class (:foreground "red")))) + `(helm-buffer-directory ((,class ,directory))) + ;; `(helm-non-file-buffer ((,class (:slant italic :foreground "blue")))) + ;; `(helm-buffer-file ((,class (:foreground "#333333")))) + `(helm-buffer-modified ((,class (:slant italic :foreground "#BA36A5")))) `(helm-buffer-process ((,class (:foreground "#008200")))) `(helm-candidate-number ((,class (:foreground "black" :background "#FFFF66")))) `(helm-dir-heading ((,class (:foreground "blue" :background "pink")))) `(helm-dir-priv ((,class (:foreground "dark red" :background "light grey")))) `(helm-ff-directory ((,class ,directory))) + `(helm-ff-dotted-directory ((,class ,directory))) `(helm-ff-executable ((,class (:foreground "green3" :background "white")))) `(helm-ff-file ((,class (:foreground "black")))) `(helm-ff-invalid-symlink ((,class (:foreground "yellow" :background "red")))) `(helm-ff-symlink ((,class ,symlink))) `(helm-file-name ((,class (:foreground "blue")))) `(helm-gentoo-match-face ((,class (:foreground "red")))) + `(helm-grep-file ((,class ,grep-file-name))) + `(helm-grep-lineno ((,class ,grep-line-number))) `(helm-grep-match ((,class ,match))) `(helm-grep-running ((,class (:weight bold :foreground "white")))) - `(helm-grep-lineno ((,class ,shadow))) `(helm-isearch-match ((,class (:background "#CCFFCC")))) + `(helm-lisp-show-completion ((,class ,volatile-highlight-supersize))) ; See `helm-dabbrev'. + ;; `(helm-ls-git-added-copied-face ((,class (:foreground "")))) + ;; `(helm-ls-git-added-modified-face ((,class (:foreground "")))) + ;; `(helm-ls-git-conflict-face ((,class (:foreground "")))) + ;; `(helm-ls-git-deleted-and-staged-face ((,class (:foreground "")))) + ;; `(helm-ls-git-deleted-not-staged-face ((,class (:foreground "")))) + ;; `(helm-ls-git-modified-and-staged-face ((,class (:foreground "")))) + `(helm-ls-git-modified-not-staged-face ((,class (:foreground "#BA36A5")))) + ;; `(helm-ls-git-renamed-modified-face ((,class (:foreground "")))) + ;; `(helm-ls-git-untracked-face ((,class (:foreground "")))) `(helm-match ((,class ,match))) `(helm-moccur-buffer ((,class (:foreground "#0066CC")))) - `(helm-selection ((,class ,volatile-highlight))) - `(helm-selection-line ((,class ,volatile-highlight))) - `(helm-source-header ((,class (:family "Sans Serif" :height 1.3 :weight bold :foreground "white" :background "#2F69BF")))) - `(helm-swoop-target-line-face ((,class ,volatile-highlight))) + `(helm-selection ((,class (:background "#3875D6" :foreground "white")))) + `(helm-selection-line ((,class ,highlight-gray))) ; ??? + `(helm-separator ((,class (:foreground "red")))) + `(helm-source-header ((,class (:weight bold :box (:line-width 1 :color "#C7C7C7") :background "#DEDEDE" :foreground "black")))) `(helm-swoop-target-line-block-face ((,class (:background "#CCCC00" :foreground "#222222")))) + `(helm-swoop-target-line-face ((,class (:background "#CCCCFF")))) `(helm-swoop-target-word-face ((,class (:weight bold :foreground nil :background "#FDBD33")))) `(helm-visible-mark ((,class ,marked-line))) `(helm-w3m-bookmarks-face ((,class (:underline t :foreground "cyan1")))) + `(highlight-changes ((,class (:foreground nil)))) ;; blue "#2E08B5" + `(highlight-changes-delete ((,class (:strike-through nil :foreground nil)))) ;; red "#B5082E" `(highlight-symbol-face ((,class (:background "#FFFFA0")))) - `(hl-line ((,class ,highlight-line))) - `(hl-tags-face ((,class (:background "#FEFCAE")))) + `(hl-line ((,class ,highlight-yellow))) ; Highlight current line. + `(hl-tags-face ((,class ,highlight-current-tag))) ; ~ Pair highlighting (matching tags). `(holiday-face ((,class (:foreground "#777777" :background "#E4EBFE")))) `(html-helper-bold-face ((,class (:weight bold :foreground "black")))) `(html-helper-italic-face ((,class (:slant italic :foreground "black")))) @@ -448,9 +613,11 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(ilog-echo-face ((,class (:height 2.0 :foreground "#006FE0")))) `(ilog-load-face ((,class (:foreground "#BA36A5")))) `(ilog-message-face ((,class (:foreground "#808080")))) + `(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 `(info-header-xref ((,class (:underline t :foreground "dodger blue")))) ; cross references in header + `(info-index-match ((,class (:weight bold :foreground nil :background "#FDBD33")))) ; when using `i' `(info-menu-header ((,class ,ol2))) ; menu titles (headers) -- major topics `(info-menu-star ((,class (:foreground "black")))) ; every 3rd menu item `(info-node ((,class (:underline t :foreground "blue")))) ; node names @@ -459,16 +626,49 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(info-title-1 ((,class ,ol1))) `(info-xref ((,class (:underline t :foreground "#006DAF")))) ; unvisited cross-references `(info-xref-visited ((,class (:underline t :foreground "magenta4")))) ; previously visited cross-references + ;; js2-highlight-vars-face (~ auto-highlight-symbol) + `(js2-error ((,class (:box (:line-width 1 :color "#FF3737") :background "#FFC8C8")))) ; DONE. + `(js2-external-variable ((,class (:foreground "#FF0000" :background "#FFF8F8")))) ; DONE. + `(js2-function-param ((,class ,function-param))) + `(js2-instance-member ((,class (:foreground "DarkOrchid")))) + `(js2-jsdoc-html-tag-delimiter ((,class (:foreground "#D0372D")))) + `(js2-jsdoc-html-tag-name ((,class (:foreground "#D0372D")))) + `(js2-jsdoc-tag ((,class (:weight normal :foreground "#6434A3")))) + `(js2-jsdoc-type ((,class (:foreground "SteelBlue")))) + `(js2-jsdoc-value ((,class (:weight normal :foreground "#BA36A5")))) ; #800080 + `(js2-magic-paren ((,class (:underline t)))) + `(js2-private-function-call ((,class (:foreground "goldenrod")))) + `(js2-private-member ((,class (:foreground "PeachPuff3")))) + `(js2-warning ((,class (:underline "orange")))) + + ;; Org non-standard faces. + `(leuven-org-deadline-overdue ((,class (:foreground "#F22659")))) + `(leuven-org-deadline-today ((,class (:weight bold :foreground "#4F4A3D" :background "#FFFFCC")))) + `(leuven-org-deadline-tomorrow ((,class (:foreground "#40A80B")))) + `(leuven-org-deadline-future ((,class (:foreground "#40A80B")))) + `(leuven-gnus-unseen ((,class (:weight bold :foreground "#FC7202")))) + `(leuven-gnus-date ((,class (:foreground "#FF80BF")))) + `(leuven-gnus-size ((,class (:foreground "#8FBF60")))) + `(leuven-todo-items-face ((,class (:weight bold :foreground "#FF3125" :background "#FFFF88")))) + `(light-symbol-face ((,class (:background "#FFFFA0")))) - `(linum ((,class (:inherit (default shadow) :foreground "#9A9A9A" :background "#EDEDED")))) + `(linum ((,class (:foreground "#9A9A9A" :background "#EDEDED")))) `(log-view-file ((,class (:foreground "#0000CC" :background "#EAF2F5")))) + `(log-view-message ((,class (:foreground "black" :background "#EDEA74")))) + `(lsp-ui-doc-background ((,class (:background "#F6FECD")))) `(lui-button-face ((,class ,link))) `(lui-highlight-face ((,class (:box '(:line-width 1 :color "#CC0000") :foreground "#CC0000" :background "#FFFF88")))) ; my nickname `(lui-time-stamp-face ((,class (:foreground "purple")))) + `(magit-blame-header ((,class (:inherit magit-diff-file-header)))) + `(magit-blame-heading ((,class (:overline "#A7A7A7" :foreground "red" :background "#E6E6E6")))) + `(magit-blame-hash ((,class (:overline "#A7A7A7" :foreground "red" :background "#E6E6E6")))) + `(magit-blame-name ((,class (:overline "#A7A7A7" :foreground "#036A07" :background "#E6E6E6")))) + `(magit-blame-date ((,class (:overline "#A7A7A7" :foreground "blue" :background "#E6E6E6")))) + `(magit-blame-summary ((,class (:overline "#A7A7A7" :weight bold :foreground "#707070" :background "#E6E6E6")))) `(magit-branch ((,class ,vc-branch))) `(magit-diff-add ((,class ,diff-added))) `(magit-diff-del ((,class ,diff-removed))) - `(magit-diff-file-header ((,class (:family "Sans Serif" :height 1.1 :weight bold :foreground "#4183C4")))) + `(magit-diff-file-header ((,class (:height 1.1 :weight bold :foreground "#4183C4")))) `(magit-diff-hunk-header ((,class ,diff-hunk-header))) `(magit-diff-none ((,class ,diff-none))) `(magit-header ((,class (:foreground "white" :background "#FF4040")))) @@ -476,48 +676,82 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(magit-item-mark ((,class ,marked-line))) `(magit-log-head-label ((,class (:box (:line-width 1 :color "blue" :style nil))))) `(magit-log-tag-label ((,class (:box (:line-width 1 :color "#00CC00" :style nil))))) + `(magit-section-highlight ((,class (:background "#F6FECD")))) `(magit-section-title ((,class (:family "Sans Serif" :height 1.8 :weight bold :foreground "cornflower blue" :inherit nil)))) `(makefile-space-face ((,class (:background "hot pink")))) `(makefile-targets ((,class (:weight bold :foreground "blue")))) - `(match ((,class ,match))) + ;; `(markdown-blockquote-face ((,class ()))) + `(markdown-bold-face ((,class (:inherit bold)))) + ;; `(markdown-comment-face ((,class ()))) + ;; `(markdown-footnote-face ((,class ()))) + ;; `(markdown-header-delimiter-face ((,class ()))) + ;; `(markdown-header-face ((,class ()))) + `(markdown-header-face-1 ((,class ,ol1))) + `(markdown-header-face-2 ((,class ,ol2))) + `(markdown-header-face-3 ((,class ,ol3))) + `(markdown-header-face-4 ((,class ,ol4))) + `(markdown-header-face-5 ((,class ,ol5))) + `(markdown-header-face-6 ((,class ,ol6))) + ;; `(markdown-header-rule-face ((,class ()))) + `(markdown-inline-code-face ((,class ,code-inline))) + `(markdown-italic-face ((,class (:inherit italic)))) + `(markdown-language-keyword-face ((,class (:inherit org-block-begin-line)))) + ;; `(markdown-line-break-face ((,class ()))) + `(markdown-link-face ((,class ,link-no-underline))) + ;; `(markdown-link-title-face ((,class ()))) + ;; `(markdown-list-face ((,class ()))) + ;; `(markdown-math-face ((,class ()))) + ;; `(markdown-metadata-key-face ((,class ()))) + ;; `(markdown-metadata-value-face ((,class ()))) + ;; `(markdown-missing-link-face ((,class ()))) + `(markdown-pre-face ((,class (:inherit org-block-background)))) + ;; `(markdown-reference-face ((,class ()))) + ;; `(markdown-strike-through-face ((,class ()))) + `(markdown-url-face ((,class ,link))) + `(match ((,class ,match))) ; Used for grep matches. + `(mc/cursor-bar-face ((,class (:height 1.0 :foreground "#1664C4" :background "#1664C4")))) + `(mc/cursor-face ((,class (:inverse-video t)))) + `(mc/region-face ((,class (:inherit region)))) `(mm-uu-extract ((,class ,code-block))) `(moccur-current-line-face ((,class (:foreground "black" :background "#FFFFCC")))) `(moccur-face ((,class (:foreground "black" :background "#FFFF99")))) - `(next-error ((,class ,volatile-highlight))) + `(next-error ((,class ,volatile-highlight-supersize))) `(nobreak-space ((,class (:background "#CCE8F6")))) - `(nxml-attribute-local-name-face ((,class (:foreground "magenta")))) + `(nxml-attribute-local-name-face ((,class ,xml-attribute))) `(nxml-attribute-value-delimiter-face ((,class (:foreground "green4")))) `(nxml-attribute-value-face ((,class (:foreground "green4")))) `(nxml-comment-content-face ((,class (:slant italic :foreground "red")))) `(nxml-comment-delimiter-face ((,class (:foreground "red")))) - `(nxml-element-local-name ((,class (:box (:line-width 1 :color "#999999") :foreground "#000088" :background "#DEDEDE")))) + `(nxml-element-local-name ((,class ,xml-tag))) `(nxml-element-local-name-face ((,class (:foreground "blue")))) `(nxml-processing-instruction-target-face ((,class (:foreground "purple1")))) `(nxml-tag-delimiter-face ((,class (:foreground "blue")))) `(nxml-tag-slash-face ((,class (:foreground "blue")))) `(org-agenda-block-count ((,class (:weight bold :foreground "#A5A5A5")))) - `(org-agenda-calendar-event ((,class (:weight bold :foreground "#3774CC" :background "#A8C5EF")))) - `(org-agenda-calendar-sexp ((,class (:foreground "#777777" :background "#E4EBFE")))) + `(org-agenda-calendar-event ((,class (:weight bold :foreground "#3774CC" :background "#E4EBFE")))) + `(org-agenda-calendar-sexp ((,class (:foreground "#327ACD" :background "#F3F7FC")))) `(org-agenda-clocking ((,class (:foreground "black" :background "#EEC900")))) `(org-agenda-column-dateline ((,class ,column))) `(org-agenda-current-time ((,class (:underline t :foreground "#1662AF")))) - `(org-agenda-date ((,class (:height 1.6 :weight bold :foreground "#1662AF")))) - `(org-agenda-date-today ((,class (:height 1.6 :weight bold :foreground "#4F4A3D" :background "#FFFFCC")))) - `(org-agenda-date-weekend ((,class (:height 1.6 :weight bold :foreground "#4E4E4E")))) + `(org-agenda-date ((,class (,@(leuven-scale-font leuven-scale-org-agenda-structure 1.6) :weight bold :foreground "#1662AF")))) + `(org-agenda-date-today ((,class (,@(leuven-scale-font leuven-scale-org-agenda-structure 1.6) :weight bold :foreground "#4F4A3D" :background "#FFFFCC")))) + `(org-agenda-date-weekend ((,class (,@(leuven-scale-font leuven-scale-org-agenda-structure 1.6) :weight bold :foreground "#4E4E4E")))) `(org-agenda-diary ((,class (:weight bold :foreground "green4" :background "light blue")))) `(org-agenda-dimmed-todo-face ((,class (:foreground "gold2")))) `(org-agenda-done ((,class (:foreground "#555555")))) `(org-agenda-filter-category ((,class (:weight bold :foreground "orange")))) + `(org-agenda-filter-effort ((,class (:weight bold :foreground "orange")))) + `(org-agenda-filter-regexp ((,class (:weight bold :foreground "orange")))) `(org-agenda-filter-tags ((,class (:weight bold :foreground "orange")))) `(org-agenda-restriction-lock ((,class (:background "#E77D63")))) - `(org-agenda-structure ((,class (:height 1.6 :weight bold :foreground "#1F8DD6")))) + `(org-agenda-structure ((,class (,@(leuven-scale-font leuven-scale-org-agenda-structure 1.6) :weight bold :foreground "#1F8DD6")))) `(org-archived ((,class (:foreground "gray70")))) `(org-beamer-tag ((,class (:box (:line-width 1 :color "#FABC18") :foreground "#2C2C2C" :background "#FFF8D0")))) `(org-block ((,class ,code-block))) - `(org-block-background ((,class (:background "#FFFFE0")))) + `(org-block-background ((,class (:background "#FFFFE0")))) ;; :inherit fixed-pitch)))) `(org-block-begin-line ((,class (:underline "#A7A6AA" :foreground "#555555" :background "#E2E1D5")))) `(org-block-end-line ((,class (:overline "#A7A6AA" :foreground "#555555" :background "#E2E1D5")))) - `(org-checkbox ((,class (:weight bold :box (:line-width 1 :style pressed-button) :foreground "white" :background "#777777")))) + `(org-checkbox ((,class (:weight bold :box (:line-width 1 :style pressed-button) :foreground "#123555" :background "#A3A3A3")))) `(org-clock-overlay ((,class (:foreground "white" :background "SkyBlue4")))) `(org-code ((,class ,code-inline))) `(org-column ((,class ,column))) @@ -527,14 +761,14 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(org-dim ((,class (:foreground "#AAAAAA")))) `(org-document-info ((,class (:foreground "#484848")))) `(org-document-info-keyword ((,class (:foreground "#008ED1" :background "#EAEAFF")))) - `(org-document-title ((,class (:family "Sans Serif" :height 1.8 :weight bold :foreground "black")))) + `(org-document-title ((,class (:height 1.8 :weight bold :foreground "black")))) `(org-done ((,class (:weight bold :box (:line-width 1 :color "#BBBBBB") :foreground "#BBBBBB" :background "#F0F0F0")))) - `(org-drawer ((,class (:foreground "light sky blue")))) - `(org-ellipsis ((,class (:underline nil :box (:line-width 1 :color "#999999") :foreground "#999999" :background "#FFF8C0")))) ; #FFEE62 + `(org-drawer ((,class (:weight bold :foreground "#00BB00" :background "#EAFFEA" :extend nil)))) + `(org-ellipsis ((,class (:underline nil :foreground "#999999")))) ; #FFEE62 `(org-example ((,class (:foreground "blue" :background "#EAFFEA")))) `(org-footnote ((,class (:underline t :foreground "#008ED1")))) `(org-formula ((,class (:foreground "chocolate1")))) - `(org-headline-done ((,class (:height 1.0 :weight normal :strike-through t :foreground "#ADADAD")))) + `(org-headline-done ((,class (:height 1.0 :weight normal :foreground "#ADADAD")))) `(org-hide ((,class (:foreground "#E2E2E2")))) `(org-inlinetask ((,class (:box (:line-width 1 :color "#EBEBEB") :foreground "#777777" :background "#FFFFD6")))) `(org-latex-and-related ((,class (:foreground "#336699" :background "white")))) @@ -548,25 +782,25 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(org-level-8 ((,class ,ol8))) `(org-link ((,class ,link))) `(org-list-dt ((,class (:weight bold :foreground "#335EA8")))) - `(org-macro ((,class (:foreground "white" :background "#EDB802")))) + `(org-macro ((,class (:weight bold :foreground "#EDB802")))) `(org-meta-line ((,class (:slant normal :foreground "#008ED1" :background "#EAEAFF")))) - `(org-mode-line-clock ((,class ,clock-line))) + `(org-mode-line-clock ((,class (:box (:line-width 1 :color "#335EA8") :foreground "black" :background "#FFA335")))) `(org-mode-line-clock-overrun ((,class (:weight bold :box (:line-width 1 :color "#335EA8") :foreground "white" :background "#FF4040")))) `(org-number-of-items ((,class (:weight bold :foreground "white" :background "#79BA79")))) `(org-property-value ((,class (:foreground "#00A000")))) `(org-quote ((,class (:slant italic :foreground "dim gray" :background "#FFFFE0")))) `(org-scheduled ((,class (:foreground "#333333")))) - `(org-scheduled-previously ((,class (:foreground "#F22659")))) + `(org-scheduled-previously ((,class (:foreground "#1466C6")))) `(org-scheduled-today ((,class (:weight bold :foreground "#4F4A3D" :background "#FFFFCC")))) `(org-sexp-date ((,class (:foreground "#3774CC")))) `(org-special-keyword ((,class (:weight bold :foreground "#00BB00" :background "#EAFFEA")))) - `(org-table ((,class (:foreground "dark green" :background "#EAFFEA")))) + `(org-table ((,class (:foreground "dark green" :background "#EAFFEA")))) ;; :inherit fixed-pitch)))) `(org-tag ((,class (:weight normal :slant italic :foreground "#9A9FA4" :background "white")))) - `(org-target ((,class ,link))) + `(org-target ((,class (:foreground "#FF6DAF")))) `(org-time-grid ((,class (:foreground "#CFCFCF")))) `(org-todo ((,class (:weight bold :box (:line-width 1 :color "#D8ABA7") :foreground "#D8ABA7" :background "#FFE6E4")))) `(org-upcoming-deadline ((,class (:foreground "#FF5555")))) - `(org-verbatim ((,class (:foreground "#0066CC")))) + `(org-verbatim ((,class (:foreground "#0066CC" :background "#F7FDFF")))) `(org-verse ((,class (:slant italic :foreground "dim gray" :background "#EEEEEE")))) `(org-warning ((,class (:weight bold :foreground "black" :background "#CCE7FF")))) `(outline-1 ((,class ,ol1))) @@ -577,17 +811,17 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(outline-6 ((,class ,ol6))) `(outline-7 ((,class ,ol7))) `(outline-8 ((,class ,ol8))) - `(pabbrev-debug-display-label-face ((,class (:background "chartreuse")))) + `(pabbrev-debug-display-label-face ((,class (:foreground "white" :background "#A62154")))) `(pabbrev-suggestions-face ((,class (:weight bold :foreground "white" :background "red")))) `(pabbrev-suggestions-label-face ((,class (:weight bold :foreground "white" :background "purple")))) `(paren-face-match ((,class ,paren-matched))) `(paren-face-mismatch ((,class ,paren-unmatched))) `(paren-face-no-match ((,class ,paren-unmatched))) `(persp-selected-face ((,class (:weight bold :foreground "#EEF5FE")))) - `(powerline-active1 ((,class (:background "grey22" :inherit mode-line)))) - `(powerline-active2 ((,class (:background "#4070B6" :inherit mode-line)))) - `(powerline-inactive1 ((,class (:background "#686868" :inherit mode-line-inactive)))) - `(powerline-inactive2 ((,class (:background "#A9A9A9" :inherit mode-line-inactive)))) + `(powerline-active1 ((,class (:foreground "#85CEEB" :background "#383838" :inherit mode-line)))) + `(powerline-active2 ((,class (:foreground "#85CEEB" :background "#4070B6" :inherit mode-line)))) + `(powerline-inactive1 ((,class (:foreground "#F0F0EF" :background "#686868" :inherit mode-line-inactive)))) + `(powerline-inactive2 ((,class (:foreground "#F0F0EF" :background "#A9A9A9" :inherit mode-line-inactive)))) `(rainbow-delimiters-depth-1-face ((,class (:foreground "#707183")))) `(rainbow-delimiters-depth-2-face ((,class (:foreground "#7388D6")))) `(rainbow-delimiters-depth-3-face ((,class (:foreground "#909183")))) @@ -599,29 +833,33 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(rainbow-delimiters-depth-9-face ((,class (:foreground "#887070")))) `(rainbow-delimiters-mismatched-face ((,class ,paren-unmatched))) `(rainbow-delimiters-unmatched-face ((,class ,paren-unmatched))) - `(realgud-overlay-arrow1 ((,class (:foreground "#005522")))) - `(realgud-overlay-arrow2 ((,class (:foreground "#c18401")))) - `(realgud-overlay-arrow3 ((,class (:foreground "#909183")))) - `(realgud-bp-disabled-face ((,class (:foreground "#909183")))) - `(realgud-bp-line-enabled-face ((,class (:underline "red")))) - `(realgud-bp-line-disabled-face ((,class (:underline "#909183")))) - `(realgud-file-name ((,class :foreground "#005522"))) - `(realgud-line-number ((,class :foreground "#A535AE"))) - `(realgud-backtrace-number ((,class :foreground "#A535AE" :weight bold))) `(recover-this-file ((,class (:weight bold :background "#FF3F3F")))) `(rng-error ((,class (:weight bold :foreground "red" :background "#FBE3E4")))) `(sh-heredoc ((,class (:foreground "blue" :background "#EEF5FE")))) `(sh-quoted-exec ((,class (:foreground "#FF1493")))) - `(shadow ((,class ,shadow))) + `(shadow ((,class ,shadow))) ; Used for grep context lines. `(shell-option-face ((,class (:foreground "forest green")))) `(shell-output-2-face ((,class (:foreground "blue")))) `(shell-output-3-face ((,class (:foreground "purple")))) `(shell-output-face ((,class (:foreground "black")))) ;; `(shell-prompt-face ((,class (:weight bold :foreground "yellow")))) + `(shm-current-face ((,class (:background "#EEE8D5")))) + `(shm-quarantine-face ((,class (:background "lemonchiffon")))) `(show-paren-match ((,class ,paren-matched))) `(show-paren-mismatch ((,class ,paren-unmatched))) `(sml-modeline-end-face ((,class (:background "#6BADF6")))) ; #335EA8 `(sml-modeline-vis-face ((,class (:background "#1979CA")))) + `(term ((,class (:foreground "#333333" :background "#FFFFFF")))) + + ;; `(sp-pair-overlay-face ((,class ()))) + ;; `(sp-show-pair-enclosing ((,class ()))) + ;; `(sp-show-pair-match-face ((,class ()))) ; ~ Pair highlighting (matching tags). + ;; `(sp-show-pair-mismatch-face ((,class ()))) + ;; `(sp-wrap-overlay-closing-pair ((,class ()))) + ;; `(sp-wrap-overlay-face ((,class ()))) + ;; `(sp-wrap-overlay-opening-pair ((,class ()))) + ;; `(sp-wrap-tag-overlay-face ((,class ()))) + `(speedbar-button-face ((,class (:foreground "green4")))) `(speedbar-directory-face ((,class (:foreground "blue4")))) `(speedbar-file-face ((,class (:foreground "cyan4")))) @@ -639,7 +877,6 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(tex-verbatim ((,class (:foreground "blue")))) `(tool-bar ((,class (:box (:line-width 1 :style released-button) :foreground "black" :background "gray75")))) `(tooltip ((,class (:foreground "black" :background "light yellow")))) - `(trailing-whitespace ((,class (:background "#F6EBFE")))) `(traverse-match-face ((,class (:weight bold :foreground "blue violet")))) `(vc-annotate-face-3F3FFF ((,class (:foreground "#3F3FFF" :background "black")))) `(vc-annotate-face-3F6CFF ((,class (:foreground "#3F3FFF" :background "black")))) @@ -654,11 +891,24 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(vc-annotate-face-83FF3F ((,class (:foreground "#B0FF3F" :background "black")))) `(vc-annotate-face-B0FF3F ((,class (:foreground "#B0FF3F" :background "black")))) `(vc-annotate-face-DDFF3F ((,class (:foreground "#FFF33F" :background "black")))) + `(vc-annotate-face-F6FFCC ((,class (:foreground "black" :background "#FFFFC0")))) `(vc-annotate-face-FF3F3F ((,class (:foreground "#FF3F3F" :background "black")))) `(vc-annotate-face-FF6C3F ((,class (:foreground "#FF3F3F" :background "black")))) `(vc-annotate-face-FF993F ((,class (:foreground "#FF993F" :background "black")))) `(vc-annotate-face-FFC63F ((,class (:foreground "#FF993F" :background "black")))) `(vc-annotate-face-FFF33F ((,class (:foreground "#FFF33F" :background "black")))) + + ;; ;; vc + ;; (vc-up-to-date-state ((,c :foreground ,(gc 'green-1)))) + ;; (vc-edited-state ((,c :foreground ,(gc 'yellow+1)))) + ;; (vc-missing-state ((,c :foreground ,(gc 'red)))) + ;; (vc-conflict-state ((,c :foreground ,(gc 'red+2) :weight bold))) + ;; (vc-locked-state ((,c :foreground ,(gc 'cyan-1)))) + ;; (vc-locally-added-state ((,c :foreground ,(gc 'blue)))) + ;; (vc-needs-update-state ((,c :foreground ,(gc 'magenta)))) + ;; (vc-removed-state ((,c :foreground ,(gc 'red-1)))) + + `(vhl/default-face ((,class ,volatile-highlight))) ; `volatile-highlights.el' (for undo, yank). `(w3m-anchor ((,class ,link))) `(w3m-arrived-anchor ((,class (:foreground "purple1")))) `(w3m-bitmap-image-face ((,class (:foreground "gray4" :background "green")))) @@ -675,38 +925,138 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(w3m-link-numbering ((,class (:foreground "#B4C7EB")))) ; mouseless browsing `(w3m-strike-through-face ((,class (:strike-through t)))) `(w3m-underline-face ((,class (:underline t)))) - `(which-func ((,class (:weight bold :foreground "white")))) + + ;; `(web-mode-block-attr-name-face ((,class ()))) + ;; `(web-mode-block-attr-value-face ((,class ()))) + ;; `(web-mode-block-comment-face ((,class ()))) + ;; `(web-mode-block-control-face ((,class ()))) + ;; `(web-mode-block-delimiter-face ((,class ()))) + ;; `(web-mode-block-face ((,class ()))) + ;; `(web-mode-block-string-face ((,class ()))) + ;; `(web-mode-bold-face ((,class ()))) + ;; `(web-mode-builtin-face ((,class ()))) + ;; `(web-mode-comment-face ((,class ()))) + ;; `(web-mode-comment-keyword-face ((,class ()))) + ;; `(web-mode-constant-face ((,class ()))) + ;; `(web-mode-css-at-rule-face ((,class ()))) + ;; `(web-mode-css-color-face ((,class ()))) + ;; `(web-mode-css-comment-face ((,class ()))) + ;; `(web-mode-css-function-face ((,class ()))) + ;; `(web-mode-css-priority-face ((,class ()))) + ;; `(web-mode-css-property-name-face ((,class ()))) + ;; `(web-mode-css-pseudo-class-face ((,class ()))) + ;; `(web-mode-css-selector-face ((,class ()))) + ;; `(web-mode-css-string-face ((,class ()))) + ;; `(web-mode-css-variable-face ((,class ()))) + ;; `(web-mode-current-column-highlight-face ((,class ()))) + `(web-mode-current-element-highlight-face ((,class (:background "#99CCFF")))) ; #FFEE80 + ;; `(web-mode-doctype-face ((,class ()))) + ;; `(web-mode-error-face ((,class ()))) + ;; `(web-mode-filter-face ((,class ()))) + `(web-mode-folded-face ((,class (:box (:line-width 1 :color "#777777") :foreground "#9A9A6A" :background "#F3F349")))) + ;; `(web-mode-function-call-face ((,class ()))) + ;; `(web-mode-function-name-face ((,class ()))) + ;; `(web-mode-html-attr-custom-face ((,class ()))) + ;; `(web-mode-html-attr-engine-face ((,class ()))) + ;; `(web-mode-html-attr-equal-face ((,class ()))) + `(web-mode-html-attr-name-face ((,class ,xml-attribute))) + ;; `(web-mode-html-attr-value-face ((,class ()))) + ;; `(web-mode-html-entity-face ((,class ()))) + `(web-mode-html-tag-bracket-face ((,class ,xml-tag))) + ;; `(web-mode-html-tag-custom-face ((,class ()))) + `(web-mode-html-tag-face ((,class ,xml-tag))) + ;; `(web-mode-html-tag-namespaced-face ((,class ()))) + ;; `(web-mode-inlay-face ((,class ()))) + ;; `(web-mode-italic-face ((,class ()))) + ;; `(web-mode-javascript-comment-face ((,class ()))) + ;; `(web-mode-javascript-string-face ((,class ()))) + ;; `(web-mode-json-comment-face ((,class ()))) + ;; `(web-mode-json-context-face ((,class ()))) + ;; `(web-mode-json-key-face ((,class ()))) + ;; `(web-mode-json-string-face ((,class ()))) + ;; `(web-mode-jsx-depth-1-face ((,class ()))) + ;; `(web-mode-jsx-depth-2-face ((,class ()))) + ;; `(web-mode-jsx-depth-3-face ((,class ()))) + ;; `(web-mode-jsx-depth-4-face ((,class ()))) + ;; `(web-mode-keyword-face ((,class ()))) + ;; `(web-mode-param-name-face ((,class ()))) + ;; `(web-mode-part-comment-face ((,class ()))) + `(web-mode-part-face ((,class (:background "#FFFFE0")))) + ;; `(web-mode-part-string-face ((,class ()))) + ;; `(web-mode-preprocessor-face ((,class ()))) + `(web-mode-script-face ((,class (:background "#EFF0F1")))) + ;; `(web-mode-sql-keyword-face ((,class ()))) + ;; `(web-mode-string-face ((,class ()))) + ;; `(web-mode-style-face ((,class ()))) + ;; `(web-mode-symbol-face ((,class ()))) + ;; `(web-mode-type-face ((,class ()))) + ;; `(web-mode-underline-face ((,class ()))) + ;; `(web-mode-variable-name-face ((,class ()))) + ;; `(web-mode-warning-face ((,class ()))) + ;; `(web-mode-whitespace-face ((,class ()))) + + `(which-func ((,class (:weight bold :slant italic :foreground "white")))) + ;; `(which-key-command-description-face) + ;; `(which-key-group-description-face) + ;; `(which-key-highlighted-command-face) + ;; `(which-key-key-face) + `(which-key-local-map-description-face ((,class (:weight bold :background "#F3F7FC" :inherit which-key-command-description-face)))) + ;; `(which-key-note-face) + ;; `(which-key-separator-face) + ;; `(which-key-special-key-face) `(widget-button ((,class ,link))) `(widget-button-pressed ((,class (:foreground "red")))) `(widget-documentation ((,class (:foreground "green4")))) `(widget-field ((,class (:background "gray85")))) `(widget-inactive ((,class (:foreground "dim gray")))) `(widget-single-line-field ((,class (:background "gray85")))) - `(yas/field-debug-face ((,class (:background "ivory2")))) - `(yas/field-highlight-face ((,class (:background "DarkSeaGreen1")))) + `(woman-bold ((,class (:weight bold :foreground "#F13D3D")))) + `(woman-italic ((,class (:weight bold :slant italic :foreground "#46BE1B")))) + `(woman-symbol ((,class (:weight bold :foreground "purple")))) + `(yas-field-debug-face ((,class (:foreground "white" :background "#A62154")))) + `(yas-field-highlight-face ((,class (:box (:line-width 1 :color "#838383") :foreground "black" :background "#D4DCD8")))) + + ;; `(ztreep-arrow-face ((,class ()))) + ;; `(ztreep-diff-header-face ((,class ()))) + ;; `(ztreep-diff-header-small-face ((,class ()))) + `(ztreep-diff-model-add-face ((,class (:weight bold :foreground "#008800")))) + `(ztreep-diff-model-diff-face ((,class (:weight bold :foreground "#0044DD")))) + `(ztreep-diff-model-ignored-face ((,class (:strike-through t :foreground "#9E9E9E")))) + `(ztreep-diff-model-normal-face ((,class (:foreground "#000000")))) + ;; `(ztreep-expand-sign-face ((,class ()))) + ;; `(ztreep-header-face ((,class ()))) + ;; `(ztreep-leaf-face ((,class ()))) + ;; `(ztreep-node-face ((,class ()))) + )) (custom-theme-set-variables 'leuven - '(ansi-color-faces-vector - [default default default italic underline success warning error]) - '(ansi-color-names-vector - ["black" "red3" "ForestGreen" "yellow3" "blue" "magenta3" "DeepSkyBlue" "gray50"]) - ; colors used in Shell mode + + ;; highlight-sexp-mode. + '(hl-sexp-background-color "#efebe9") + + '(ansi-color-faces-vector + [default default default italic underline success warning error]) + + ;; Colors used in Shell mode. + '(ansi-color-names-vector + ["black" "red3" "ForestGreen" "yellow3" "blue" "magenta3" "DeepSkyBlue" "gray50"]) ) ;;;###autoload (when (and (boundp 'custom-theme-load-path) load-file-name) - ;; add theme folder to `custom-theme-load-path' when installing over MELPA + ;; Add theme folder to `custom-theme-load-path' when installing over MELPA. (add-to-list 'custom-theme-load-path (file-name-as-directory (file-name-directory load-file-name)))) (provide-theme 'leuven) +;; This is for the sake of Emacs. ;; Local Variables: +;; time-stamp-end: "$" ;; time-stamp-format: "%:y%02m%02d.%02H%02M" ;; time-stamp-start: "Version: " -;; time-stamp-end: "$" ;; End: ;;; leuven-theme.el ends here From 2e669305fca1d20e9224dfe0146cef8267c47071 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 8 Aug 2020 16:07:16 +0300 Subject: [PATCH 124/145] ; * etc/NEWS: Rearrange some entries and add entry for recentf change. --- etc/NEWS | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 01245d14f90..5cef0eb4c87 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -130,18 +130,6 @@ same for a button. * Changes in Specialized Modes and Packages in Emacs 28.1 -** Miscellaneous - ---- -*** The width of the buffer-name column in 'list-buffers' is now dynamic. -The width now depends of 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. - -*** 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. - ** Windows *** The key prefix 'C-x 4 1' displays next command buffer in the same window. @@ -709,6 +697,23 @@ custom rules, see the variables 'bug-reference-setup-from-vc-alist', It's bound to the 'C-c C-c f' keystroke, and prompts for a local file name. +--- +** Recentf +The recentf files are no longer backed up. + + +** Miscellaneous + +--- +*** The width of the buffer-name column in 'list-buffers' is now dynamic. +The width now depends of 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. + +*** 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 Modes and Packages in Emacs 28.1 From 527b8a807143253ed8e52de004fb3cc9a17123c0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bruno=20F=C3=A9lix=20Rezende=20Ribeiro?= Date: Sat, 8 Aug 2020 15:13:57 +0200 Subject: [PATCH 125/145] * doc/lispref/os.texi (Session Management): Make example homoiconic * doc/lispref/os.texi (Session Management): Don't insert Lisp as strings, but use format (bug#40341). Copyright-paperwork-exempt: yes --- doc/lispref/os.texi | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 942bda105f7..a7f353407ce 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -2687,9 +2687,10 @@ Emacs is restarted by the session manager. @group (defun save-yourself-test () - (insert "(save-current-buffer - (switch-to-buffer \"*scratch*\") - (insert \"I am restored\"))") + (insert + (format "%S" '(save-current-buffer + (switch-to-buffer "*scratch*") + (insert "I am restored")))) nil) @end group @end example From b42df36757e7c86f33730090a8a0789e957f8fba Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 8 Aug 2020 15:17:33 +0200 Subject: [PATCH 126/145] Modernise a code example in os.texi * doc/lispref/os.texi (Session Management): Use with-current-buffer in the example instead of save+switch (bug#40341). --- doc/lispref/os.texi | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index a7f353407ce..504f0dfb23e 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -2688,9 +2688,8 @@ Emacs is restarted by the session manager. @group (defun save-yourself-test () (insert - (format "%S" '(save-current-buffer - (switch-to-buffer "*scratch*") - (insert "I am restored")))) + (format "%S" '(with-current-buffer "*scratch*" + (insert "I am restored")))) nil) @end group @end example From 289d6b2265e19822ed5ad44e5c62e9bf3750f606 Mon Sep 17 00:00:00 2001 From: "Florian v. Savigny" Date: Sat, 8 Aug 2020 15:33:58 +0200 Subject: [PATCH 127/145] Handle '' in strings in SQL Mode * lisp/progmodes/sql.el (sql--syntax-propertize-escaped-apostrophe): Handle '' in strings (bug#40231). (sql-mode): Use it. --- lisp/progmodes/sql.el | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index c86fc59ac16..8e3191c9b41 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -1508,6 +1508,22 @@ Based on `comint-mode-map'.") table) "Syntax table used in `sql-mode' and `sql-interactive-mode'.") +;;; Syntax Properties + +;; `sql--syntax-propertize-escaped-apostrophe', as follows, was +;; (analysed and) adapted from `pascal--syntax-propertize' in +;; pascal.el because basic syntax parsing cannot handle the SQL '' +;; construct within strings. + +(defconst sql--syntax-propertize-escaped-apostrophe + (syntax-propertize-rules + ("''" + (0 + (if (save-excursion (nth 3 (syntax-ppss (match-beginning 0)))) + (string-to-syntax ".") + (forward-char -1) + nil))))) + ;; Font lock support (defvar sql-mode-font-lock-object-name @@ -4210,6 +4226,11 @@ must tell Emacs. Here's how to do that in your init file: (setq-local abbrev-all-caps 1) ;; Contains the name of database objects (set (make-local-variable 'sql-contains-names) t) + ;; Activate punctuation syntax table property for + ;; escaped apostrophes within strings: + (setq-local syntax-propertize-function + sql--syntax-propertize-escaped-apostrophe) + (setq-local parse-sexp-lookup-properties t) ; just to make sure it is used ;; Set syntax and font-face highlighting ;; Catch changes to sql-product and highlight accordingly (sql-set-product (or sql-product 'ansi)) ; Fixes bug#13591 From b799cc271d69fc494da1fe04ca8ec6c529a19a19 Mon Sep 17 00:00:00 2001 From: Philip K Date: Sat, 8 Aug 2020 15:40:32 +0200 Subject: [PATCH 128/145] Add support for the OpenPGP header to Emacs * lisp/gnus/message.el (message-openpgp-header): New variable (bug#39964). (messasge-add-openpgp-header): New function to use it. --- etc/NEWS | 5 ++++ lisp/gnus/message.el | 58 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index 5cef0eb4c87..d2903449bed 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -246,6 +246,11 @@ not. ** Message +*** Message now supports the OpenPGP header. +To generate these headers, add the new function +'messasge-add-openpgp-header' to 'message-send-hook'. The header will +be generated according to the new 'message-openpgp-header' variable. + --- *** A change to how Mail-Copies-To: never is handled. If a user has specified Mail-Copies-To: never, and Message was asked diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 819f3e41d3d..e5ddfcffffc 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -2737,6 +2737,64 @@ systematically send encrypted emails when possible." (when (message-all-epg-keys-available-p) (mml-secure-message-sign-encrypt))) +(defcustom message-openpgp-header nil + "Specification for \"OpenPGP\" header. + +Otherwise, the variable must be a +list with three elements, all strings: +- Key ID, in hexadecimal form +- Key URL or ASCII armoured key. +- Protection preference, one of: \"unprotected\", \"sign\", + \"encrypt\" or \"signencrypt\". + +Each value may be nil, in which case it won't be inserted. If all +the values are nil, or `message-openpgp-header' is nil itself, +don't insert any header." + :type '(choice + (const nil :tag "Don't add OpenPGP header") + (list (choice (string :tag "ID") + (const nil :tag "No ID")) + (choice (string :tag "Key") + (const nil :tag "No Key")) + (choice (other nil :tag "None") + (const "unprotected" :tag "Unprotected") + (const "sign" :tag "Sign") + (const "encrypt" :tag "Encrypt") + (const "signencrypt" :tag "Sign and Encrypt")))) + :version "28.1") + +(defun messasge-add-openpgp-header () + "Add OpenPGP header to point to public key. + +Header will be constructed as specified in `message-openpgp-header'. + +Consider adding this function to `message-send-hook'." + ;; See https://tools.ietf.org/html/draft-josefsson-openpgp-mailnews-header + (when (and message-openpgp-header + (or (nth 0 message-openpgp-header) + (nth 1 message-openpgp-header) + (nth 2 message-openpgp-header))) + (with-temp-buffer + (insert "OpenPGP: ") + ;; add ID + (let (need-sep) + (when (nth 0 message-openpgp-header) + (insert "id=" (nth 0 message-openpgp-header)) + (setq need-sep t)) + ;; add URL + (when (nth 1 message-openpgp-header) + (when need-sep (insert "; ")) + (if (string-match-p ";") + (insert "url=\"" (nth 1 message-openpgp-header) "\"") + (insert "url=\"" (nth 1 message-openpgp-header) "\"")) + (setq need-sep t)) + ;; add preference + (when (nth 2 message-openpgp-header) + (when need-sep (insert "; ")) + (insert "preference=" (nth 2 message-openpgp-header)))) + ;; insert header + (message-add-header (buffer-string))))) + ;;; From ed943db794987cb6fc87b55d68d6164190ba9a24 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 8 Aug 2020 15:49:48 +0200 Subject: [PATCH 129/145] Document the OpenPGP header * doc/misc/message.texi (Using the OpenPGP Header): Document the OpenPGP header (bug#39964). --- doc/misc/message.texi | 23 +++++++++++++++++++++++ etc/NEWS | 1 + 2 files changed, 24 insertions(+) diff --git a/doc/misc/message.texi b/doc/misc/message.texi index d8a889e29f3..d6df1a62cfd 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -1042,6 +1042,7 @@ and/or encrypted messages as explained in the following. * Signing and encryption:: Signing and encrypting commands. * Using S/MIME:: Using S/MIME * Using OpenPGP:: Using OpenPGP +* OpenPGP Header:: Adding OpenPGP headers to messages. * Passphrase caching:: How to cache passphrases * PGP Compatibility:: Compatibility with older implementations * Encrypt-to-self:: Reading your own encrypted messages @@ -1251,6 +1252,28 @@ according to two different standards, namely @acronym{PGP} or @code{mml-default-sign-method} determine which variant to prefer, @acronym{PGP/MIME} by default. +@node OpenPGP Header +@subsection OpenPGP Header + +The @samp{OpenPGP} header can be used to provide information about the +sender's OpenPGP key. This is a formalisation and modernisation of +the non-standard @samp{X-PGP-Key} (etc.) headers that have been in use +for a long time. For more details, see +@uref{https://tools.ietf.org/html/draft-josefsson-openpgp-mailnews-header}. + +@vindex message-openpgp-header +To use this in Message, say: + +@lisp +(add-hook 'message-send-hook 'messasge-add-openpgp-header) +@end lisp + +Then customize the @code{message-openpgp-header} variable according to +your PGP setup. The variable is a list of the key ID, the key URL or +ASCII armoured, and the protection preference, one of +@samp{"unprotected"}, @samp{"sign"}, @samp{"encrypt"} or +@samp{"signencrypt"}. + @node Passphrase caching @subsection Passphrase caching diff --git a/etc/NEWS b/etc/NEWS index d2903449bed..269b07610a5 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -246,6 +246,7 @@ not. ** Message ++++ *** Message now supports the OpenPGP header. To generate these headers, add the new function 'messasge-add-openpgp-header' to 'message-send-hook'. The header will From 843b55f6822bc1e8b97b91222e7bc03b5caa9919 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 8 Aug 2020 17:06:45 +0300 Subject: [PATCH 130/145] ; Fix recent message.el-related changes * lisp/gnus/message.el (message-openpgp-header): * doc/misc/message.texi (OpenPGP Header): Fix the documentation added in recent commits. --- doc/misc/message.texi | 7 ++++--- lisp/gnus/message.el | 16 ++++++++-------- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/doc/misc/message.texi b/doc/misc/message.texi index d6df1a62cfd..687ee1f9702 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -1256,7 +1256,7 @@ according to two different standards, namely @acronym{PGP} or @subsection OpenPGP Header The @samp{OpenPGP} header can be used to provide information about the -sender's OpenPGP key. This is a formalisation and modernisation of +sender's OpenPGP key. This is a formalization and modernization of the non-standard @samp{X-PGP-Key} (etc.) headers that have been in use for a long time. For more details, see @uref{https://tools.ietf.org/html/draft-josefsson-openpgp-mailnews-header}. @@ -1268,9 +1268,10 @@ To use this in Message, say: (add-hook 'message-send-hook 'messasge-add-openpgp-header) @end lisp -Then customize the @code{message-openpgp-header} variable according to +@noindent +then customize the @code{message-openpgp-header} variable according to your PGP setup. The variable is a list of the key ID, the key URL or -ASCII armoured, and the protection preference, one of +ASCII armored key, and the protection preference, one of @samp{"unprotected"}, @samp{"sign"}, @samp{"encrypt"} or @samp{"signencrypt"}. diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index e5ddfcffffc..d8fef67de20 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -2738,18 +2738,18 @@ systematically send encrypted emails when possible." (mml-secure-message-sign-encrypt))) (defcustom message-openpgp-header nil - "Specification for \"OpenPGP\" header. + "Specification for the \"OpenPGP\" header of outgoing messages. -Otherwise, the variable must be a -list with three elements, all strings: -- Key ID, in hexadecimal form -- Key URL or ASCII armoured key. +The value must be a list of three elements, all strings: +- Key ID, in hexadecimal form; +- Key URL or ASCII armoured key; and - Protection preference, one of: \"unprotected\", \"sign\", \"encrypt\" or \"signencrypt\". -Each value may be nil, in which case it won't be inserted. If all -the values are nil, or `message-openpgp-header' is nil itself, -don't insert any header." +Each of the elements may be nil, in which case its part in the +OpenPGP header will be left out. If all the values are nil, +or `message-openpgp-header' is itself nil, the OpenPGP header +will not be inserted." :type '(choice (const nil :tag "Don't add OpenPGP header") (list (choice (string :tag "ID") From 878924e881528f8b87216f571db91a960c733d9a Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Sat, 8 Aug 2020 08:35:34 -0700 Subject: [PATCH 131/145] * lisp/outline.el (outline-minor-mode-prefix): Fix compilation. --- lisp/outline.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/outline.el b/lisp/outline.el index aa8ed58ad9c..6158ed594e9 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -297,6 +297,7 @@ The value of this variable is checked as part of loading Outline mode. After that, changing the prefix key requires manipulating keymaps." :type 'key-sequence :group 'outlines + :initialize 'custom-initialize-default :set (lambda (sym val) (define-key outline-minor-mode-map outline-minor-mode-prefix nil) (define-key outline-minor-mode-map val outline-mode-prefix-map) From 444e404325e5ea7f3caf93d348fd283f6246ad24 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 8 Aug 2020 23:53:14 +0100 Subject: [PATCH 132/145] ; Fix typos in recent message.el changes * doc/misc/message.texi (OpenPGP Header): * etc/NEWS: * lisp/gnus/message.el (message-add-openpgp-header): Fix spelling of function name. --- doc/misc/message.texi | 2 +- etc/NEWS | 2 +- lisp/gnus/message.el | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/misc/message.texi b/doc/misc/message.texi index 687ee1f9702..204a6386e01 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -1265,7 +1265,7 @@ for a long time. For more details, see To use this in Message, say: @lisp -(add-hook 'message-send-hook 'messasge-add-openpgp-header) +(add-hook 'message-send-hook 'message-add-openpgp-header) @end lisp @noindent diff --git a/etc/NEWS b/etc/NEWS index 269b07610a5..71c037631af 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -249,7 +249,7 @@ not. +++ *** Message now supports the OpenPGP header. To generate these headers, add the new function -'messasge-add-openpgp-header' to 'message-send-hook'. The header will +'message-add-openpgp-header' to 'message-send-hook'. The header will be generated according to the new 'message-openpgp-header' variable. --- diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index d8fef67de20..0aca31ac88a 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -2763,7 +2763,7 @@ will not be inserted." (const "signencrypt" :tag "Sign and Encrypt")))) :version "28.1") -(defun messasge-add-openpgp-header () +(defun message-add-openpgp-header () "Add OpenPGP header to point to public key. Header will be constructed as specified in `message-openpgp-header'. From 3b04d39c3c13d91a4cfbc314b0d10a71e75348fb Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Sun, 9 Aug 2020 02:48:14 +0300 Subject: [PATCH 133/145] * lisp/custom.el (custom-add-choice): Fix previous commit. --- lisp/custom.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/custom.el b/lisp/custom.el index 0cb136330d5..db7f6a056d4 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -1544,7 +1544,7 @@ This means reset VARIABLE. (The argument IGNORED is ignored)." (defun custom-add-choice (variable choice) "Add CHOICE to the custom type of VARIABLE. If a choice with the same tag already exists, no action is taken." - (let ((choices (get 'tab-bar-new-tab-choice 'custom-type))) + (let ((choices (get variable 'custom-type))) (unless (eq (car choices) 'choice) (error "Not a choice type: %s" choices)) (unless (seq-find (lambda (elem) @@ -1553,7 +1553,7 @@ If a choice with the same tag already exists, no action is taken." (cdr choices)) ;; Put the new choice at the end. (put variable 'custom-type - (append (get variable 'custom-type) (list choice)))))) + (append choices (list choice)))))) ;;; The End. From f3e0da29a248a2dc7dd7d640f8280b10bfc288f9 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 9 Aug 2020 10:41:59 +0200 Subject: [PATCH 134/145] Remove superfluous code from the previous '' sql string fix * lisp/progmodes/sql.el (sql-mode): Remove setting that's now superfluous from previous check-in. --- lisp/progmodes/sql.el | 1 - 1 file changed, 1 deletion(-) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 8e3191c9b41..a70b5ed60d6 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -4230,7 +4230,6 @@ must tell Emacs. Here's how to do that in your init file: ;; escaped apostrophes within strings: (setq-local syntax-propertize-function sql--syntax-propertize-escaped-apostrophe) - (setq-local parse-sexp-lookup-properties t) ; just to make sure it is used ;; Set syntax and font-face highlighting ;; Catch changes to sql-product and highlight accordingly (sql-set-product (or sql-product 'ansi)) ; Fixes bug#13591 From 3c728d4c69f2abe991ef84787ae1014ad1cd29d2 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 9 Aug 2020 12:34:23 +0200 Subject: [PATCH 135/145] Add a variable to allow displaying numeric time zones * lisp/calendar/calendar.el (calendar-use-numeric-time-zones): New variable. * doc/emacs/calendar.texi (Sunrise/Sunset): Document it (bug#33149). * lisp/calendar/cal-dst.el (calendar-standard-time-zone-name): Use it. (calendar-daylight-time-zone-name): Ditto. * lisp/calendar/solar.el (sunrise-sunset): Adjust usage. (solar-equinoxes-solstices): Ditto. --- doc/emacs/calendar.texi | 5 +++++ etc/NEWS | 7 +++++++ lisp/calendar/cal-dst.el | 16 ++++++++++++++-- lisp/calendar/calendar.el | 7 +++++++ lisp/calendar/solar.el | 9 +++++++-- 5 files changed, 40 insertions(+), 4 deletions(-) diff --git a/doc/emacs/calendar.texi b/doc/emacs/calendar.texi index fe51ad35d77..31db815df70 100644 --- a/doc/emacs/calendar.texi +++ b/doc/emacs/calendar.texi @@ -625,6 +625,11 @@ your time zone. Emacs displays the times of sunrise and sunset @emph{corrected for daylight saving time}. @xref{Daylight Saving}, for how daylight saving time is determined. +@vindex calendar-use-numeric-time-zones + If you want to display numerical time zones (like @samp{"+0100"}) +instead of symbolic time zones (like @samp{"CET"}), set the +@code{calendar-use-numeric-time-zones} variable to non-@code{nil}. + As a user, you might find it convenient to set the calendar location variables for your usual physical location in your @file{.emacs} file. If you are a system administrator, you may want to set these variables diff --git a/etc/NEWS b/etc/NEWS index 71c037631af..2f204a5b4bc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -194,6 +194,13 @@ 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. +** Calendar + +*** New variable 'calendar-use-numeric-time-zones' to use numeric time zones. +If non-nil, functions that display time zones (like the 'S' command in +calendar mode that displays the sunrise time) will display time zones +like "+0100" instead of "CET". + ** Dired *** New user option 'dired-mark-region' affects all Dired commands diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el index 3db12e668ab..af6acaf09ad 100644 --- a/lisp/calendar/cal-dst.el +++ b/lisp/calendar/cal-dst.el @@ -350,17 +350,29 @@ If the locale never uses daylight saving time, set this to 0." :group 'calendar-dst) (defcustom calendar-standard-time-zone-name - (or (nth 2 calendar-current-time-zone-cache) "EST") + (if calendar-use-numeric-time-zones + (if calendar-current-time-zone-cache + (format-time-string + "%z" 0 (* 60 (car calendar-current-time-zone-cache))) + "+0000") + (or (nth 2 calendar-current-time-zone-cache) "EST")) "Abbreviated name of standard time zone at `calendar-location-name'. For example, \"EST\" in New York City, \"PST\" for Los Angeles." :type 'string + :version "28.1" :group 'calendar-dst) (defcustom calendar-daylight-time-zone-name - (or (nth 3 calendar-current-time-zone-cache) "EDT") + (if calendar-use-numeric-time-zones + (if calendar-current-time-zone-cache + (format-time-string + "%z" 0 (* 60 (cadr calendar-current-time-zone-cache))) + "+0000") + (or (nth 3 calendar-current-time-zone-cache) "EDT")) "Abbreviated name of daylight saving time zone at `calendar-location-name'. For example, \"EDT\" in New York City, \"PDT\" for Los Angeles." :type 'string + :version "28.1" :group 'calendar-dst) (defcustom calendar-daylight-savings-starts-time diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 1d5b9479e2b..9a6c78a50eb 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1061,6 +1061,13 @@ calendar." :type 'boolean :group 'holidays) +(defcustom calendar-use-numeric-time-zones nil + "If nil, use symbolic time zones like \"CET\" when displaying dates. +If non-nil, use numeric time zines like \"+0100\"." + :type 'boolean + :version "28.1" + :group 'calendar) + ;;; End of user options. (calendar-recompute-layout-variables) diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el index 6a813e9ee82..20a20df4603 100644 --- a/lisp/calendar/solar.el +++ b/lisp/calendar/solar.el @@ -840,7 +840,9 @@ This function is suitable for execution in an init file." "E" "W")))))) (calendar-standard-time-zone-name (if (< arg 16) calendar-standard-time-zone-name - (cond ((zerop calendar-time-zone) "UTC") + (cond ((zerop calendar-time-zone) + (if calendar-use-numeric-time-zones + "+0100" "UTC")) ((< calendar-time-zone 0) (format "UTC%dmin" calendar-time-zone)) (t (format "UTC+%dmin" calendar-time-zone))))) @@ -1013,7 +1015,10 @@ Requires floating point." (let* ((m displayed-month) (y displayed-year) (calendar-standard-time-zone-name - (if calendar-time-zone calendar-standard-time-zone-name "UTC")) + (cond + (calendar-time-zone calendar-standard-time-zone-name) + (calendar-use-numeric-time-zones "+0100") + (t "UTC"))) (calendar-daylight-savings-starts (if calendar-time-zone calendar-daylight-savings-starts)) (calendar-daylight-savings-ends From 5732d8ee9a23900d697d76eac07db1ac89ba4fbf Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 9 Aug 2020 12:52:02 +0200 Subject: [PATCH 136/145] Slight code clean-up in message-mailto * lisp/gnus/message.el (message-mailto): Clean up code slightly. --- lisp/gnus/message.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 0aca31ac88a..61d9c602470 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -8817,8 +8817,7 @@ will then start up Emacs ready to compose mail." (interactive) ;; Send email (message-mail) - (message-mailto-1 (car command-line-args-left)) - (setq command-line-args-left (cdr command-line-args-left))) + (message-mailto-1 (pop command-line-args-left))) (defun message-mailto-1 (url) (let ((args (message-parse-mailto-url url))) From 1888c6cb96309bd1fd359f19b25c734ab5d4f224 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 9 Aug 2020 12:55:15 +0200 Subject: [PATCH 137/145] Doc string fix for message-mailto * lisp/gnus/message.el (message-mailto): Doc string fix. --- lisp/gnus/message.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 61d9c602470..ab625be9e37 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -8810,9 +8810,9 @@ used to take the screenshot." ;;;###autoload (defun message-mailto () - "Function to be run to parse command line mailto: links. + "Command to parse command line mailto: links. This is meant to be used for MIME handlers: Setting the handler -for \"x-scheme-handler/mailto;\" to \"emacs -fn message-mailto %u\" +for \"x-scheme-handler/mailto;\" to \"emacs -f message-mailto %u\" will then start up Emacs ready to compose mail." (interactive) ;; Send email From 54770707ad7bbb6ef9ad636ee71e08bea5347715 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 9 Aug 2020 13:05:37 +0200 Subject: [PATCH 138/145] Add a command line (and MIME handler) function to start eww * lisp/net/eww.el (eww-browse): New command (bug#42768) to be used from the command line. * doc/misc/eww.texi (Command Line): Document it. --- doc/misc/eww.texi | 16 ++++++++++++++++ etc/NEWS | 6 ++++++ lisp/net/eww.el | 18 ++++++++++++++++++ 3 files changed, 40 insertions(+) diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi index f9901b6fd78..85be112402c 100644 --- a/doc/misc/eww.texi +++ b/doc/misc/eww.texi @@ -52,6 +52,7 @@ modify this GNU manual.'' * Overview:: * Basics:: * Advanced:: +* Command Line:: Appendices * History and Acknowledgments:: @@ -337,6 +338,21 @@ 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. +@node Command Line +@chapter Command Line Usage + +It can be convenient to start eww directly from the command line. The +@code{eww-browse} function can be used for that: + +@example +emacs -f eww-browse https://gnu.org +@end example + +This also allows registering Emacs as a @acronym{MIME} handler for the +@samp{"text/x-uri"} media type. How to do that varies between +systems, but typically you'd register the handler to call @samp{"emacs +-f eww-browse %u"}. + @node History and Acknowledgments @appendix History and Acknowledgments diff --git a/etc/NEWS b/etc/NEWS index 2f204a5b4bc..9dffd0f714c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -603,6 +603,12 @@ mode buffer. ** EWW ++++ +*** New Emacs command line convenience function. +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 diff --git a/lisp/net/eww.el b/lisp/net/eww.el index edb2f729c8b..e7170b3e6d1 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -276,6 +276,24 @@ This list can be customized via `eww-suggest-uris'." (push uri uris))))) (nreverse uris))) +;;;###autoload +(defun eww-browse () + "Function to be run to parse command line URLs. +This is meant to be used for MIME handlers or command line use. + +Setting the handler for \"text/x-uri;\" to +\"emacs -f eww-browse %u\" will then start up Emacs and call eww +to browse the url. + +This can also be used on the command line directly: + + emacs -f eww-browse https://gnu.org + +will start Emacs and browse the GNU web site." + (interactive) + (eww (pop command-line-args-left))) + + ;;;###autoload (defun eww (url &optional arg buffer) "Fetch URL and render the page. From 71a79f755113aa9fc11315873c5038933ba7ac2a Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sun, 9 Aug 2020 11:53:44 +0100 Subject: [PATCH 139/145] ; Fix typo in last change to calendar.el * lisp/calendar/calendar.el (calendar-use-numeric-time-zones): Fix typo in docstring. --- lisp/calendar/calendar.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 9a6c78a50eb..0efb2bc6607 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1063,7 +1063,7 @@ calendar." (defcustom calendar-use-numeric-time-zones nil "If nil, use symbolic time zones like \"CET\" when displaying dates. -If non-nil, use numeric time zines like \"+0100\"." +If non-nil, use numeric time zones like \"+0100\"." :type 'boolean :version "28.1" :group 'calendar) From 55bcb3f7e05c01d86778f1a2b7caccf72124614d Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 9 Aug 2020 13:12:27 +0200 Subject: [PATCH 140/145] Make solar commands in Calendar less beepy * lisp/calendar/solar.el (solar-setup): Remove a (beep) that's been in this code since 1992 (bug#42774). --- lisp/calendar/solar.el | 1 - 1 file changed, 1 deletion(-) diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el index 20a20df4603..635bdd8f11c 100644 --- a/lisp/calendar/solar.el +++ b/lisp/calendar/solar.el @@ -209,7 +209,6 @@ Returns nil if nothing was entered." (defun solar-setup () "Prompt for `calendar-longitude', `calendar-latitude', `calendar-time-zone'." - (beep) (or calendar-longitude (setq calendar-longitude (solar-get-number From db77e9a0da934ba40950bc1306df61b6785843e0 Mon Sep 17 00:00:00 2001 From: "Jorge P. de Morais Neto" Date: Sun, 9 Aug 2020 13:47:13 +0200 Subject: [PATCH 141/145] TUTORIAL: "buffer" vs "file" consistency; capitalize Dired * etc/tutorials/TUTORIAL: For consistency with C-x s ("save some buffers") and for accuracy, describe C-x C-s as "Save buffer to file"), and then C-x s as "Save some buffers to their files" (bug#39359). Also capitalize "Dired". Copyright-paperwork-exempt: yes --- etc/tutorials/TUTORIAL | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/etc/tutorials/TUTORIAL b/etc/tutorials/TUTORIAL index eb3acde9c01..227c13f3e3a 100644 --- a/etc/tutorials/TUTORIAL +++ b/etc/tutorials/TUTORIAL @@ -612,11 +612,11 @@ but it also means that you need a convenient way to save the first file's buffer. Having to switch back to that buffer, in order to save it with C-x C-s, would be a nuisance. So we have - C-x s Save some buffers + C-x s Save some buffers to their files -C-x s asks you about each buffer which contains changes that you have -not saved. It asks you, for each such buffer, whether to save the -buffer. +C-x s asks you about each file-visiting buffer which contains changes +that you have not saved. It asks you, for each such buffer, whether +to save the buffer to its file. >> Insert a line of text, then type C-x s. It should ask you whether to save the buffer named TUTORIAL. @@ -660,8 +660,8 @@ as by a mail handling utility. There are many C-x commands. Here is a list of the ones you have learned: C-x C-f Find file - C-x C-s Save file - C-x s Save some buffers + C-x C-s Save buffer to file + C-x s Save some buffers to their files C-x C-b List buffers C-x b Switch buffer C-x C-c Quit Emacs @@ -1081,7 +1081,7 @@ corresponding command names (such as C-x C-f beside find-file). You can learn more about Emacs by reading its manual, either as a printed book, or inside Emacs (use the Help menu or type C-h r). Two features that you may like especially are completion, which saves -typing, and dired, which simplifies file handling. +typing, and Dired, which simplifies file handling. Completion is a way to avoid unnecessary typing. For instance, if you want to switch to the *Messages* buffer, you can type C-x b *M From 2ed502d2a76e93ecd5366a6ec3926894e4fbe827 Mon Sep 17 00:00:00 2001 From: Tino Calancha Date: Sun, 9 Aug 2020 14:18:09 +0200 Subject: [PATCH 142/145] Add constants for shell command output buffer names Buffers `*Shell Command Output*' and `*Async Shell Command*' have been around since a long time; used across several libraries, they are de facto output buffers for shell commands. * lisp/simple.el (shell-command-buffer-name) (shell-command-buffer-name-async): New variables. * lisp/dired-aux.el * lisp/gnus/gnus-sum.el * lisp/gnus/gnus-win.el * lisp/ibuf-ext.el * lisp/net/tramp.el: Use them. * etc/NEWS (Changes in Emacs 28.1): Announce this change. * doc/emacs/misc.texi (Single Shell) * doc/misc/tramp.texi (Remote processes): Update manual (bug#39138). --- doc/emacs/misc.texi | 19 +++++++++++-------- doc/misc/tramp.texi | 2 +- etc/NEWS | 5 +++++ lisp/dired-aux.el | 6 +++--- lisp/gnus/gnus-sum.el | 2 +- lisp/gnus/gnus-win.el | 2 +- lisp/ibuf-ext.el | 6 +++--- lisp/net/tramp.el | 4 ++-- lisp/simple.el | 37 +++++++++++++++++++++++-------------- 9 files changed, 50 insertions(+), 33 deletions(-) diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index e7547ebff7c..cb9fc61f327 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -724,13 +724,15 @@ See the Eshell Info manual, which is distributed with Emacs. @kindex M-! @findex shell-command +@vindex shell-command-buffer-name @kbd{M-!} (@code{shell-command}) reads a line of text using the minibuffer and executes it as a shell command, in a subshell made just for that command. Standard input for the command comes from the null device. If the shell command produces any output, the output appears -either in the echo area (if it is short), or in an Emacs buffer named -@file{*Shell Command Output*}, displayed in another window (if the -output is long). The variables @code{resize-mini-windows} and +either in the echo area (if it is short), or in an Emacs buffer, +displayed in another window (if the output is long). The name of +this buffer is taken from the constant @code{shell-command-buffer-name}. +The variables @code{resize-mini-windows} and @code{max-mini-window-height} (@pxref{Minibuffer Edit}) control when Emacs should consider the output to be too long for the echo area. @@ -758,15 +760,16 @@ which is impossible to ignore. @kindex M-& @findex async-shell-command +@vindex shell-command-buffer-name-async A shell command that ends in @samp{&} is executed @dfn{asynchronously}, and you can continue to use Emacs as it runs. You can also type @kbd{M-&} (@code{async-shell-command}) to execute a shell command asynchronously; this is exactly like calling @kbd{M-!} with a trailing @samp{&}, except that you do not need the @samp{&}. -The default output buffer for asynchronous shell commands is named -@samp{*Async Shell Command*}. Emacs inserts the output into this -buffer as it comes in, whether or not the buffer is visible in a -window. +The constant @code{shell-command-buffer-name-async} stores the name +of the default output buffer for asynchronous shell commands. +Emacs inserts the output into this buffer as it comes in, +whether or not the buffer is visible in a window. @vindex async-shell-command-buffer If you want to run more than one asynchronous shell command at the @@ -804,7 +807,7 @@ old region and replaces it with the output from the shell command. see what keys are in the buffer. If the buffer contains a GnuPG key, type @kbd{C-x h M-| gpg @key{RET}} to feed the entire buffer contents to @command{gpg}. This will output the list of keys to the -@file{*Shell Command Output*} buffer. +buffer named @code{shell-command-buffer-name}. @vindex shell-file-name The above commands use the shell specified by the variable diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 56cd220e20e..ae6fe3d9ea0 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -3379,7 +3379,7 @@ host. Example: @end example @command{tail} command outputs continuously to the local buffer, -@file{*Async Shell Command*} +named @code{shell-command-buffer-name-async} @kbd{M-x auto-revert-tail-mode @key{RET}} runs similarly showing continuous output. diff --git a/etc/NEWS b/etc/NEWS index 9dffd0f714c..1e4fe47c59d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -80,6 +80,11 @@ useful on systems such as FreeBSD which ships only with "etc/termcap". * Changes in Emacs 28.1 ++++ +** The new constants 'shell-command-buffer-name' and +'shell-command-buffer-name-async' store the default buffer names +for the output of shell commands. + ** 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 diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 6587d039b72..84d8c36f45f 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -688,7 +688,7 @@ are executed in the background on each file sequentially waiting for each command to terminate before running the next command. In shell syntax this means separating the individual commands with `;'. -The output appears in the buffer `*Async Shell Command*'." +The output appears in the buffer `shell-command-buffer-name-async'." (interactive (let ((files (dired-get-marked-files t current-prefix-arg nil nil t))) (list @@ -727,7 +727,7 @@ it, write `*\"\"' in place of just `*'. This is equivalent to just If COMMAND ends in `&', `;', or `;&', it is executed in the background asynchronously, and the output appears in the buffer -`*Async Shell Command*'. When operating on multiple files and COMMAND +`shell-command-buffer-name-async'. When operating on multiple files and COMMAND ends in `&', the shell command is executed on each file in parallel. However, when COMMAND ends in `;' or `;&' then commands are executed in the background on each file sequentially waiting for each command @@ -735,7 +735,7 @@ to terminate before running the next command. You can also use `dired-do-async-shell-command' that automatically adds `&'. Otherwise, COMMAND is executed synchronously, and the output -appears in the buffer `*Shell Command Output*'. +appears in the buffer `shell-command-buffer-name'. This feature does not try to redisplay Dired buffers afterward, as there's no telling what files COMMAND may have changed. diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 719498a0337..4363860eac8 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -12284,7 +12284,7 @@ no matter what the properties `:decode' and `:headers' are." (interactive (gnus-interactive "P\ny")) (require 'gnus-art) (let* ((articles (gnus-summary-work-articles n)) - (result-buffer "*Shell Command Output*") + (result-buffer shell-command-buffer-name) (all-headers (not (memq sym '(nil r)))) (gnus-save-all-headers (or all-headers gnus-save-all-headers)) (raw (eq sym 'r)) diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 36b28350362..baa3146e64e 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -142,7 +142,7 @@ used to display Gnus windows." (pipe (vertical 1.0 (summary 0.25 point) - ("*Shell Command Output*" 1.0))) + (shell-command-buffer-name 1.0))) (bug (vertical 1.0 (if gnus-bug-create-help-buffer '("*Gnus Help Bug*" 0.5)) diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index bfb9787a96d..c9ca1f87424 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -504,7 +504,7 @@ format. See `ibuffer-update-saved-filters-format' and (ibuffer-forward-line 0)) (defun ibuffer--maybe-erase-shell-cmd-output () - (let ((buf (get-buffer "*Shell Command Output*"))) + (let ((buf (get-buffer shell-command-buffer-name))) (when (and (buffer-live-p buf) (not shell-command-dont-erase-buffer) (not (zerop (buffer-size buf)))) @@ -517,7 +517,7 @@ format. See `ibuffer-update-saved-filters-format' and :opstring "Shell command executed on" :before (ibuffer--maybe-erase-shell-cmd-output) :modifier-p nil) - (let ((out-buf (get-buffer-create "*Shell Command Output*"))) + (let ((out-buf (get-buffer-create shell-command-buffer-name))) (with-current-buffer out-buf (goto-char (point-max))) (call-shell-region (point-min) (point-max) command nil out-buf))) @@ -542,7 +542,7 @@ format. See `ibuffer-update-saved-filters-format' and :modifier-p nil) (let ((file (and (not (buffer-modified-p)) buffer-file-name)) - (out-buf (get-buffer-create "*Shell Command Output*"))) + (out-buf (get-buffer-create shell-command-buffer-name))) (unless (and file (file-exists-p file)) (setq file (make-temp-file diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index d1b2935a3c6..fdf26f6b782 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3815,8 +3815,8 @@ support symbolic links." (current-buffer)) (t (get-buffer-create (if asynchronous - "*Async Shell Command*" - "*Shell Command Output*"))))) + shell-command-buffer-name-async + shell-command-buffer-name))))) (error-buffer (cond ((bufferp error-buffer) error-buffer) diff --git a/lisp/simple.el b/lisp/simple.el index 2f92238e640..6c9584aaa39 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -3369,6 +3369,14 @@ which is defined in the `warnings' library.\n") (setq buffer-undo-list nil) t)) +;;;; Shell commands + +(defconst shell-command-buffer-name "*Shell Command Output*" + "Name of the output buffer for shell commands.") + +(defconst shell-command-buffer-name-async "*Async Shell Command*" + "Name of the output buffer for asynchronous shell commands.") + (defvar shell-command-history nil "History list for some commands that read shell commands. @@ -3433,7 +3441,7 @@ to `shell-command-history'." (defcustom async-shell-command-buffer 'confirm-new-buffer "What to do when the output buffer is used by another shell command. This option specifies how to resolve the conflict where a new command -wants to direct its output to the buffer `*Async Shell Command*', +wants to direct its output to the buffer `shell-command-buffer-name-async', but this buffer is already taken by another running shell command. The value `confirm-kill-process' is used to ask for confirmation before @@ -3585,14 +3593,14 @@ whose `car' is BUFFER." Like `shell-command', but adds `&' at the end of COMMAND to execute it asynchronously. -The output appears in the buffer `*Async Shell Command*'. +The output appears in the buffer `shell-command-buffer-name-async'. That buffer is in shell mode. You can configure `async-shell-command-buffer' to specify what to do -when the `*Async Shell Command*' buffer is already taken by another +when the `shell-command-buffer-name-async' buffer is already taken by another running shell command. To run COMMAND without displaying the output in a window you can configure `display-buffer-alist' to use the action -`display-buffer-no-window' for the buffer `*Async Shell Command*'. +`display-buffer-no-window' for the buffer `shell-command-buffer-name-async'. In Elisp, you will often be better served by calling `start-process' directly, since it offers more control and does not impose the use of @@ -3628,12 +3636,12 @@ If `shell-command-prompt-show-cwd' is non-nil, show the current directory in the prompt. If COMMAND ends in `&', execute it asynchronously. -The output appears in the buffer `*Async Shell Command*'. +The output appears in the buffer `shell-command-buffer-name-async'. That buffer is in shell mode. You can also use `async-shell-command' that automatically adds `&'. Otherwise, COMMAND is executed synchronously. The output appears in -the buffer `*Shell Command Output*'. If the output is short enough to +the buffer `shell-command-buffer-name'. If the output is short enough to display in the echo area (which is determined by the variables `resize-mini-windows' and `max-mini-window-height'), it is shown there, but it is nonetheless available in buffer `*Shell Command @@ -3756,7 +3764,7 @@ impose the use of a shell (with its need to quote arguments)." (if (string-match "[ \t]*&[ \t]*\\'" command) ;; Command ending with ampersand means asynchronous. (let* ((buffer (get-buffer-create - (or output-buffer "*Async Shell Command*"))) + (or output-buffer shell-command-buffer-name-async))) (bname (buffer-name buffer)) (proc (get-buffer-process buffer)) (directory default-directory)) @@ -3908,7 +3916,7 @@ and are used only if a pop-up buffer is displayed." error-buffer display-error-buffer region-noncontiguous-p) "Execute string COMMAND in inferior shell with region as input. -Normally display output (if any) in temp buffer `*Shell Command Output*'; +Normally display output (if any) in temp buffer `shell-command-buffer-name'; Prefix arg means replace the region with it. Return the exit code of COMMAND. @@ -3927,7 +3935,7 @@ in the echo area or in a buffer. If the output is short enough to display in the echo area \(determined by the variable `max-mini-window-height' if `resize-mini-windows' is non-nil), it is shown there. -Otherwise it is displayed in the buffer `*Shell Command Output*'. +Otherwise it is displayed in the buffer `shell-command-buffer-name'. The output is available in that buffer in both cases. If there is output and an error, a message about the error @@ -3937,7 +3945,7 @@ Optional fourth arg OUTPUT-BUFFER specifies where to put the command's output. If the value is a buffer or buffer name, erase that buffer and insert the output there; a non-nil value of `shell-command-dont-erase-buffer' prevent to erase the buffer. -If the value is nil, use the buffer `*Shell Command Output*'. +If the value is nil, use the buffer `shell-command-buffer-name'. Any other non-nil value means to insert the output in the current buffer after START. @@ -4006,7 +4014,7 @@ characters." (funcall region-insert-function output)) (t (let ((buffer (get-buffer-create - (or output-buffer "*Shell Command Output*")))) + (or output-buffer shell-command-buffer-name)))) (with-current-buffer buffer (erase-buffer) (funcall region-insert-function output)) @@ -4025,7 +4033,7 @@ characters." (list t error-file) t))) ;; It is rude to delete a buffer that the command is not using. - ;; (let ((shell-buffer (get-buffer "*Shell Command Output*"))) + ;; (let ((shell-buffer (get-buffer shell-command-buffer-name))) ;; (and shell-buffer (not (eq shell-buffer (current-buffer))) ;; (kill-buffer shell-buffer))) ;; Don't muck with mark unless REPLACE says we should. @@ -4033,12 +4041,13 @@ characters." ;; No prefix argument: put the output in a temp buffer, ;; replacing its entire contents. (let ((buffer (get-buffer-create - (or output-buffer "*Shell Command Output*")))) + (or output-buffer shell-command-buffer-name)))) (set-buffer-major-mode buffer) ; Enable globalized modes (bug#38111) (unwind-protect (if (and (eq buffer (current-buffer)) (or (memq shell-command-dont-erase-buffer '(nil erase)) - (and (not (eq buffer (get-buffer "*Shell Command Output*"))) + (and (not (eq buffer (get-buffer + shell-command-buffer-name))) (not (region-active-p))))) ;; If the input is the same buffer as the output, ;; delete everything but the specified region, From c789c3aac66943497f771896ec13bae618f86a01 Mon Sep 17 00:00:00 2001 From: Andrii Kolomoiets Date: Sun, 9 Aug 2020 14:30:55 +0200 Subject: [PATCH 143/145] vc-hg-create-tag: Possibility to create a branch * lisp/vc/vc-hg.el (vc-hg-create-bookmark): New user option. (vc-hg-create-tag): Use it (bug#38425). --- etc/NEWS | 4 ++++ lisp/vc/vc-hg.el | 24 +++++++++++++++++++++--- 2 files changed, 25 insertions(+), 3 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 1e4fe47c59d..25ee6e11236 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -232,6 +232,10 @@ their 'default-directory' under VC. *** Support for bookmark.el. Bookmark locations can refer to VC directory buffers. +--- +*** New user option 'vc-hg-create-bookmark' controls whether a bookmark +or branch will be created when you invoke 'C-u C-x v s' ('vc-create-tag'). + ** Gnus --- diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 95ced7b8d09..09f804357e0 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -186,6 +186,16 @@ highlighting the Log View buffer." :group 'vc-hg :version "24.5") +(defcustom vc-hg-create-bookmark t + "This controls whether `vc-create-tag' will create a bookmark or branch. +If nil, named branch will be created. +If t, bookmark will be created. +If `ask', you will be prompted for a branch type." + :type '(choice (const :tag "No" nil) + (const :tag "Yes" t) + (const :tag "Ask" ask)) + :version "28.1") + ;; Clear up the cache to force vc-call to check again and discover ;; new functions when we reload this file. @@ -625,10 +635,18 @@ Optional arg REVISION is a revision to annotate from." ;;; Tag system (defun vc-hg-create-tag (dir name branchp) - "Attach the tag NAME to the state of the working copy." + "Create tag NAME in repo in DIR. Create branch if BRANCHP. +Variable `vc-hg-create-bookmark' controls what kind of branch will be created." (let ((default-directory dir)) - (and (vc-hg-command nil 0 nil "status") - (vc-hg-command nil 0 nil (if branchp "bookmark" "tag") name)))) + (vc-hg-command nil 0 nil + (if branchp + (if (if (eq vc-hg-create-bookmark 'ask) + (yes-or-no-p "Create bookmark instead of branch? ") + vc-hg-create-bookmark) + "bookmark" + "branch") + "tag") + name))) (defun vc-hg-retrieve-tag (dir name _update) "Retrieve the version tagged by NAME of all registered files at or below DIR." From d586bae501a3d6ec8e6a8088d05b0abfa541dece Mon Sep 17 00:00:00 2001 From: Andrii Kolomoiets Date: Sun, 9 Aug 2020 14:35:26 +0200 Subject: [PATCH 144/145] vc-hg: use 'hg summary' to populate vc-dir headers * lisp/vc/vc-hg.el (vc-hg-dir-extra-headers): Use 'hg summary' command. (vc-hg-dir-extra-header): Remove unused function. * etc/NEWS: Mention changes to vc-hg.el (bug#38387). --- etc/NEWS | 5 +++++ lisp/vc/vc-hg.el | 37 ++++++++++++++++++++----------------- 2 files changed, 25 insertions(+), 17 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 25ee6e11236..b983b290d72 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -236,6 +236,11 @@ Bookmark locations can refer to VC directory buffers. *** New user option 'vc-hg-create-bookmark' 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' command to populate extra 'vc-dir' +headers. + + ** Gnus --- diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 09f804357e0..cb0657e70a0 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1384,25 +1384,28 @@ REV is the revision to check out into WORKFILE." (vc-run-delayed (vc-hg-after-dir-status update-function))) -(defun vc-hg-dir-extra-header (name &rest commands) - (concat (propertize name 'face 'font-lock-type-face) - (propertize - (with-temp-buffer - (apply 'vc-hg-command (current-buffer) 0 nil commands) - (buffer-substring-no-properties (point-min) (1- (point-max)))) - 'face 'font-lock-variable-name-face))) - (defun vc-hg-dir-extra-headers (dir) - "Generate extra status headers for a Mercurial tree." + "Generate extra status headers for a repository in DIR. +This runs the command \"hg summary\"." (let ((default-directory dir)) - (concat - (vc-hg-dir-extra-header "Root : " "root") "\n" - (vc-hg-dir-extra-header "Branch : " "id" "-b") "\n" - (vc-hg-dir-extra-header "Tags : " "id" "-t") ; "\n" - ;; these change after each commit - ;; (vc-hg-dir-extra-header "Local num : " "id" "-n") "\n" - ;; (vc-hg-dir-extra-header "Global id : " "id" "-i") - ))) + (with-temp-buffer + (vc-hg-command t 0 nil "summary") + (goto-char (point-min)) + (mapconcat + #'identity + (let (result) + (while (not (eobp)) + (push + (let ((entry (if (looking-at "\\([^ ].*\\): \\(.*\\)") + (cons (capitalize (match-string 1)) (match-string 2)) + (cons "" (buffer-substring (point) (line-end-position)))))) + (concat + (propertize (format "%-11s: " (car entry)) 'face 'font-lock-type-face) + (propertize (cdr entry) 'face 'font-lock-variable-name-face))) + result) + (forward-line)) + (nreverse result)) + "\n")))) (defun vc-hg-log-incoming (buffer remote-location) (vc-setup-buffer buffer) From 8e82baf5a730ff542118ddba5b76afdc1db643f6 Mon Sep 17 00:00:00 2001 From: Damien Cassou Date: Sun, 9 Aug 2020 14:48:22 +0200 Subject: [PATCH 145/145] Add the new library hierarchy.el * lisp/emacs-lisp/hierarchy.el: New file. --- etc/NEWS | 4 + lisp/emacs-lisp/hierarchy.el | 579 ++++++++++++++++++++++++ test/lisp/emacs-lisp/hierarchy-tests.el | 556 +++++++++++++++++++++++ 3 files changed, 1139 insertions(+) create mode 100644 lisp/emacs-lisp/hierarchy.el create mode 100644 test/lisp/emacs-lisp/hierarchy-tests.el diff --git a/etc/NEWS b/etc/NEWS index b983b290d72..8118272070e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -737,6 +737,10 @@ The recentf files are no longer backed up. ** Miscellaneous +*** The new library hierarchy.el has been added. +It's a library to create, query, navigate and display hierarchy +structures. + --- *** The width of the buffer-name column in 'list-buffers' is now dynamic. The width now depends of the width of the window, but will never be diff --git a/lisp/emacs-lisp/hierarchy.el b/lisp/emacs-lisp/hierarchy.el new file mode 100644 index 00000000000..8cef029c4cf --- /dev/null +++ b/lisp/emacs-lisp/hierarchy.el @@ -0,0 +1,579 @@ +;;; hierarchy.el --- Library to create and display hierarchy structures -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Damien Cassou +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Library to create, query, navigate and display hierarchy structures. + +;; Creation: After having created a hierarchy with `hierarchy-new', +;; populate it by calling `hierarchy-add-tree' or +;; `hierarchy-add-trees'. You can then optionally sort its element +;; with `hierarchy-sort'. + +;; Querying: You can learn more about your hierarchy by using +;; functions such as `hierarchy-roots', `hierarchy-has-item', +;; `hierarchy-length', `hierarchy-parent', `hierarchy-descendant-p'. + +;; Navigation: When your hierarchy is ready, you can use +;; `hierarchy-map-item', `hierarchy-map', and `map-tree' to apply +;; functions to elements of the hierarchy. + +;; Display: You can display a hierarchy as a tabulated list using +;; `hierarchy-tabulated-display' and as an expandable/foldable tree +;; using `hierarchy-convert-to-tree-widget'. The +;; `hierarchy-labelfn-*' functions will help you display each item of +;; the hierarchy the way you want it. + +;;; Limitation: + +;; - Current implementation uses #'equal to find and distinguish +;; elements. Support for user-provided equality definition is +;; desired but not yet implemented; +;; +;; - nil can't be added to a hierarchy; +;; +;; - the hierarchy is computed eagerly. + +;;; Code: + +(require 'seq) +(require 'map) +(require 'subr-x) +(require 'cl-lib) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helpers +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(cl-defstruct (hierarchy + (:constructor hierarchy--make) + (:conc-name hierarchy--)) + (roots (list)) ; list of the hierarchy roots (no parent) + (parents (make-hash-table :test 'equal)) ; map an item to its parent + (children (make-hash-table :test 'equal)) ; map an item to its childre + ;; cache containing the set of all items in the hierarchy + (seen-items (make-hash-table :test 'equal))) ; map an item to t + +(defun hierarchy--seen-items-add (hierarchy item) + "In HIERARCHY, add ITEM to seen items." + (map-put! (hierarchy--seen-items hierarchy) item t)) + +(defun hierarchy--compute-roots (hierarchy) + "Search roots of HIERARCHY and return them." + (cl-set-difference + (map-keys (hierarchy--seen-items hierarchy)) + (map-keys (hierarchy--parents hierarchy)) + :test #'equal)) + +(defun hierarchy--sort-roots (hierarchy sortfn) + "Compute, sort and store the roots of HIERARCHY. + +SORTFN is a function taking two items of the hierarchy as parameter and +returning non-nil if the first parameter is lower than the second." + (setf (hierarchy--roots hierarchy) + (sort (hierarchy--compute-roots hierarchy) + sortfn))) + +(defun hierarchy--add-relation (hierarchy item parent acceptfn) + "In HIERARCHY, add ITEM as child of PARENT. + +ACCEPTFN is a function returning non-nil if its parameter (any object) +should be an item of the hierarchy." + (let* ((existing-parent (hierarchy-parent hierarchy item)) + (has-parent-p (funcall acceptfn existing-parent))) + (cond + ((and has-parent-p (not (equal existing-parent parent))) + (error "An item (%s) can only have one parent: '%s' vs '%s'" + item existing-parent parent)) + ((not has-parent-p) + (let ((existing-children (map-elt (hierarchy--children hierarchy) + parent (list)))) + (map-put! (hierarchy--children hierarchy) + parent (append existing-children (list item)))) + (map-put! (hierarchy--parents hierarchy) item parent))))) + +(defun hierarchy--set-equal (list1 list2 &rest cl-keys) + "Return non-nil if LIST1 and LIST2 have same elements. + +I.e., if every element of LIST1 also appears in LIST2 and if +every element of LIST2 also appears in LIST1. + +CL-KEYS are key-value pairs just like in `cl-subsetp'. Supported +keys are :key and :test." + (and (apply 'cl-subsetp list1 list2 cl-keys) + (apply 'cl-subsetp list2 list1 cl-keys))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Creation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hierarchy-new () + "Create a hierarchy and return it." + (hierarchy--make)) + +(defun hierarchy-add-tree (hierarchy item parentfn &optional childrenfn acceptfn) + "In HIERARCHY, add ITEM. + +PARENTFN is either nil or a function defining the child-to-parent +relationship: this function takes an item as parameter and should return +the parent of this item in the hierarchy. If the item has no parent in the +hierarchy (i.e., it should be a root), the function should return an object +not accepted by acceptfn (i.e., nil for the default value of acceptfn). + +CHILDRENFN is either nil or a function defining the parent-to-children +relationship: this function takes an item as parameter and should return a +list of children of this item in the hierarchy. + +If both PARENTFN and CHILDRENFN are non-nil, the results of PARENTFN and +CHILDRENFN are expected to be coherent with each other. + +ACCEPTFN is a function returning non-nil if its parameter (any object) +should be an item of the hierarchy. By default, ACCEPTFN returns non-nil +if its parameter is non-nil." + (unless (hierarchy-has-item hierarchy item) + (let ((acceptfn (or acceptfn #'identity))) + (hierarchy--seen-items-add hierarchy item) + (let ((parent (and parentfn (funcall parentfn item)))) + (when (funcall acceptfn parent) + (hierarchy--add-relation hierarchy item parent acceptfn) + (hierarchy-add-tree hierarchy parent parentfn childrenfn))) + (let ((children (and childrenfn (funcall childrenfn item)))) + (mapc (lambda (child) + (when (funcall acceptfn child) + (hierarchy--add-relation hierarchy child item acceptfn) + (hierarchy-add-tree hierarchy child parentfn childrenfn))) + children))))) + +(defun hierarchy-add-trees (hierarchy items parentfn &optional childrenfn acceptfn) + "Call `hierarchy-add-tree' on HIERARCHY and each element of ITEMS. + +PARENTFN, CHILDRENFN and ACCEPTFN have the same meaning as in `hierarchy-add'." + (seq-map (lambda (item) + (hierarchy-add-tree hierarchy item parentfn childrenfn acceptfn)) + items)) + +(defun hierarchy-add-list (hierarchy list &optional wrap childrenfn) + "Add to HIERARCHY the sub-lists in LIST. + +If WRAP is non-nil, allow duplicate items in LIST by wraping each +item in a cons (id . item). The root's id is 1. + +CHILDRENFN is a function (defaults to `cdr') taking LIST as a +parameter which should return LIST's children (a list). Each +child is (recursively) passed as a parameter to CHILDRENFN to get +its own children. Because of this parameter, LIST can be +anything, not necessarily a list." + (let* ((childrenfn (or childrenfn #'cdr)) + (id 0) + (wrapfn (lambda (item) + (if wrap + (cons (setq id (1+ id)) item) + item))) + (unwrapfn (if wrap #'cdr #'identity))) + (hierarchy-add-tree + hierarchy (funcall wrapfn list) nil + (lambda (item) + (mapcar wrapfn (funcall childrenfn + (funcall unwrapfn item))))) + hierarchy)) + +(defun hierarchy-from-list (list &optional wrap childrenfn) + "Create and return a hierarchy built from LIST. + +This function passes LIST, WRAP and CHILDRENFN unchanged to +`hierarchy-add-list'." + (hierarchy-add-list (hierarchy-new) list wrap childrenfn)) + +(defun hierarchy-sort (hierarchy &optional sortfn) + "Modify HIERARCHY so that its roots and item's children are sorted. + +SORTFN is a function taking two items of the hierarchy as parameter and +returning non-nil if the first parameter is lower than the second. By +default, SORTFN is `string-lessp'." + (let ((sortfn (or sortfn #'string-lessp))) + (hierarchy--sort-roots hierarchy sortfn) + (mapc (lambda (parent) + (setf + (map-elt (hierarchy--children hierarchy) parent) + (sort (map-elt (hierarchy--children hierarchy) parent) sortfn))) + (map-keys (hierarchy--children hierarchy))))) + +(defun hierarchy-extract-tree (hierarchy item) + "Return a copy of HIERARCHY with ITEM's descendants and parents." + (if (not (hierarchy-has-item hierarchy item)) + nil + (let ((tree (hierarchy-new))) + (hierarchy-add-tree tree item + (lambda (each) (hierarchy-parent hierarchy each)) + (lambda (each) + (when (or (equal each item) + (hierarchy-descendant-p hierarchy each item)) + (hierarchy-children hierarchy each)))) + tree))) + +(defun hierarchy-copy (hierarchy) + "Return a copy of HIERARCHY. + +Items in HIERARCHY are shared, but structure is not." + (hierarchy-map-hierarchy (lambda (item _) (identity item)) hierarchy)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Querying +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hierarchy-items (hierarchy) + "Return a list of all items of HIERARCHY." + (map-keys (hierarchy--seen-items hierarchy))) + +(defun hierarchy-has-item (hierarchy item) + "Return t if HIERARCHY includes ITEM." + (map-contains-key (hierarchy--seen-items hierarchy) item)) + +(defun hierarchy-empty-p (hierarchy) + "Return t if HIERARCHY is empty." + (= 0 (hierarchy-length hierarchy))) + +(defun hierarchy-length (hierarchy) + "Return the number of items in HIERARCHY." + (hash-table-count (hierarchy--seen-items hierarchy))) + +(defun hierarchy-has-root (hierarchy item) + "Return t if one of HIERARCHY's roots is ITEM. + +A root is an item with no parent." + (seq-contains-p (hierarchy-roots hierarchy) item)) + +(defun hierarchy-roots (hierarchy) + "Return all roots of HIERARCHY. + +A root is an item with no parent." + (let ((roots (hierarchy--roots hierarchy))) + (or roots + (hierarchy--compute-roots hierarchy)))) + +(defun hierarchy-leafs (hierarchy &optional node) + "Return all leafs of HIERARCHY. + +A leaf is an item with no child. + +If NODE is an item of HIERARCHY, only return leafs under NODE." + (let ((leafs (cl-set-difference + (map-keys (hierarchy--seen-items hierarchy)) + (map-keys (hierarchy--children hierarchy))))) + (if (hierarchy-has-item hierarchy node) + (seq-filter (lambda (item) + (hierarchy-descendant-p hierarchy item node)) + leafs) + leafs))) + +(defun hierarchy-parent (hierarchy item) + "In HIERARCHY, return parent of ITEM." + (map-elt (hierarchy--parents hierarchy) item)) + +(defun hierarchy-children (hierarchy parent) + "In HIERARCHY, return children of PARENT." + (map-elt (hierarchy--children hierarchy) parent (list))) + +(defun hierarchy-child-p (hierarchy item1 item2) + "In HIERARCHY, return non-nil if and only if ITEM1 is a child of ITEM2." + (equal (hierarchy-parent hierarchy item1) item2)) + +(defun hierarchy-descendant-p (hierarchy item1 item2) + "In HIERARCHY, return non-nil if and only if ITEM1 is a descendant of ITEM2. + +ITEM1 is a descendant of ITEM2 if and only if both are items of HIERARCHY +and either: + +- ITEM1 is child of ITEM2, or +- ITEM1's parent is a descendant of ITEM2." + (and + (hierarchy-has-item hierarchy item1) + (hierarchy-has-item hierarchy item2) + (or + (hierarchy-child-p hierarchy item1 item2) + (hierarchy-descendant-p + hierarchy (hierarchy-parent hierarchy item1) item2)))) + +(defun hierarchy-equal (hierarchy1 hierarchy2) + "Return t if HIERARCHY1 and HIERARCHY2 are equal. + +Two equal hierarchies share the same items and the same +relationships among them." + (and (hierarchy-p hierarchy1) + (hierarchy-p hierarchy2) + (= (hierarchy-length hierarchy1) (hierarchy-length hierarchy2)) + ;; parents are the same + (seq-every-p (lambda (child) + (equal (hierarchy-parent hierarchy1 child) + (hierarchy-parent hierarchy2 child))) + (map-keys (hierarchy--parents hierarchy1))) + ;; children are the same + (seq-every-p (lambda (parent) + (hierarchy--set-equal + (hierarchy-children hierarchy1 parent) + (hierarchy-children hierarchy2 parent) + :test #'equal)) + (map-keys (hierarchy--children hierarchy1))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Navigation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hierarchy-map-item (func item hierarchy &optional indent) + "Return the result of applying FUNC to ITEM and its descendants in HIERARCHY. + +This function navigates the tree top-down: FUNCTION is first called on item +and then on each of its children. Results are concatenated in a list. + +INDENT is a number (default 0) representing the indentation of ITEM in +HIERARCHY. FUNC should take 2 argument: the item and its indentation +level." + (let ((indent (or indent 0))) + (cons + (funcall func item indent) + (seq-mapcat (lambda (child) (hierarchy-map-item func child + hierarchy (1+ indent))) + (hierarchy-children hierarchy item))))) + +(defun hierarchy-map (func hierarchy &optional indent) + "Return the result of applying FUNC to each element of HIERARCHY. + +This function navigates the tree top-down: FUNCTION is first called on each +root. To do so, it calls `hierarchy-map-item' on each root +sequentially. Results are concatenated in a list. + +FUNC should take 2 arguments: the item and its indentation level. + +INDENT is a number (default 0) representing the indentation of HIERARCHY's +roots." + (let ((indent (or indent 0))) + (seq-mapcat (lambda (root) (hierarchy-map-item func root hierarchy indent)) + (hierarchy-roots hierarchy)))) + +(defun hierarchy-map-tree (function hierarchy &optional item indent) + "Apply FUNCTION on each item of HIERARCHY under ITEM. + +This function navigates the tree bottom-up: FUNCTION is first called on +leafs and the result is passed as parameter when calling FUNCTION on +parents. + +FUNCTION should take 3 parameters: the current item, its indentation +level (a number), and a list representing the result of applying +`hierarchy-map-tree' to each child of the item. + +INDENT is 0 by default and is passed as second parameter to FUNCTION. +INDENT is incremented by 1 at each level of the tree. + +This function returns the result of applying FUNCTION to ITEM (the first +root if nil)." + (let ((item (or item (car (hierarchy-roots hierarchy)))) + (indent (or indent 0))) + (funcall function item indent + (mapcar (lambda (child) + (hierarchy-map-tree function hierarchy + child (1+ indent))) + (hierarchy-children hierarchy item))))) + +(defun hierarchy-map-hierarchy (function hierarchy) + "Apply FUNCTION to each item of HIERARCHY in a new hierarchy. + +FUNCTION should take 2 parameters, the current item and its +indentation level (a number), and should return an item to be +added to the new hierarchy." + (let* ((items (make-hash-table :test #'equal)) + (transform (lambda (item) (map-elt items item)))) + ;; Make 'items', a table mapping original items to their + ;; transformation + (hierarchy-map (lambda (item indent) + (map-put! items item (funcall function item indent))) + hierarchy) + (hierarchy--make + :roots (mapcar transform (hierarchy-roots hierarchy)) + :parents (let ((result (make-hash-table :test #'equal))) + (map-apply (lambda (child parent) + (map-put! result + (funcall transform child) + (funcall transform parent))) + (hierarchy--parents hierarchy)) + result) + :children (let ((result (make-hash-table :test #'equal))) + (map-apply (lambda (parent children) + (map-put! result + (funcall transform parent) + (seq-map transform children))) + (hierarchy--children hierarchy)) + result) + :seen-items (let ((result (make-hash-table :test #'equal))) + (map-apply (lambda (item v) + (map-put! result + (funcall transform item) + v)) + (hierarchy--seen-items hierarchy)) + result)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Display +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hierarchy-labelfn-indent (labelfn &optional indent-string) + "Return a function rendering LABELFN indented with INDENT-STRING. + +INDENT-STRING defaults to a 2-space string. Indentation is +multiplied by the depth of the displayed item." + (let ((indent-string (or indent-string " "))) + (lambda (item indent) + (dotimes (_ indent) (insert indent-string)) + (funcall labelfn item indent)))) + +(defun hierarchy-labelfn-button (labelfn actionfn) + "Return a function rendering LABELFN in a button. + +Clicking the button triggers ACTIONFN. ACTIONFN is a function +taking an item of HIERARCHY and an indentation value (a number) +as input. This function is called when an item is clicked. The +return value of ACTIONFN is ignored." + (lambda (item indent) + (let ((start (point))) + (funcall labelfn item indent) + (make-text-button start (point) + 'action (lambda (_) (funcall actionfn item indent)))))) + +(defun hierarchy-labelfn-button-if (labelfn buttonp actionfn) + "Return a function rendering LABELFN as a button if BUTTONP. + +Pass LABELFN and ACTIONFN to `hierarchy-labelfn-button' if +BUTTONP is non-nil. Otherwise, render LABELFN without making it +a button. + +BUTTONP is a function taking an item of HIERARCHY and an +indentation value (a number) as input." + (lambda (item indent) + (if (funcall buttonp item indent) + (funcall (hierarchy-labelfn-button labelfn actionfn) item indent) + (funcall labelfn item indent)))) + +(defun hierarchy-labelfn-to-string (labelfn item indent) + "Execute LABELFN on ITEM and INDENT. Return result as a string." + (with-temp-buffer + (funcall labelfn item indent) + (buffer-substring (point-min) (point-max)))) + +(defun hierarchy-print (hierarchy &optional to-string) + "Insert HIERARCHY in current buffer as plain text. + +Use TO-STRING to convert each element to a string. TO-STRING is +a function taking an item of HIERARCHY as input and returning a +string. If nil, TO-STRING defaults to a call to `format' with \"%s\"." + (let ((to-string (or to-string (lambda (item) (format "%s" item))))) + (hierarchy-map + (hierarchy-labelfn-indent (lambda (item _) + (insert (funcall to-string item) "\n"))) + hierarchy))) + +(defun hierarchy-to-string (hierarchy &optional to-string) + "Return a string representing HIERARCHY. + +TO-STRING is passed unchanged to `hierarchy-print'." + (with-temp-buffer + (hierarchy-print hierarchy to-string) + (buffer-substring (point-min) (point-max)))) + +(defun hierarchy-tabulated-imenu-action (_item-name position) + "Move to ITEM-NAME at POSITION in current buffer." + (goto-char position) + (back-to-indentation)) + +(define-derived-mode hierarchy-tabulated-mode tabulated-list-mode "Hierarchy tabulated" + "Major mode to display a hierarchy as a tabulated list." + (setq-local imenu-generic-expression + ;; debbugs: 26457 - Cannot pass a function to + ;; imenu-generic-expression. Add + ;; `hierarchy-tabulated-imenu-action' to the end of the + ;; list when bug is fixed + '(("Item" "^[[:space:]]+\\(?1:.+\\)$" 1)))) + +(defun hierarchy-tabulated-display (hierarchy labelfn &optional buffer) + "Display HIERARCHY as a tabulated list in `hierarchy-tabulated-mode'. + +LABELFN is a function taking an item of HIERARCHY and an indentation +level (a number) as input and inserting a string to be displayed in the +table. + +The tabulated list is displayed in BUFFER, or a newly created buffer if +nil. The buffer is returned." + (let ((buffer (or buffer (generate-new-buffer "hierarchy-tabulated")))) + (with-current-buffer buffer + (hierarchy-tabulated-mode) + (setq tabulated-list-format + (vector '("Item name" 0 nil))) + (setq tabulated-list-entries + (hierarchy-map (lambda (item indent) + (list item (vector (hierarchy-labelfn-to-string + labelfn item indent)))) + hierarchy)) + (tabulated-list-init-header) + (tabulated-list-print)) + buffer)) + +(declare-function widget-convert "wid-edit") +(defun hierarchy-convert-to-tree-widget (hierarchy labelfn) + "Return a tree-widget for HIERARCHY. + +LABELFN is a function taking an item of HIERARCHY and an indentation +value (a number) as parameter and inserting a string to be displayed as a +node label." + (require 'wid-edit) + (require 'tree-widget) + (hierarchy-map-tree (lambda (item indent children) + (widget-convert + 'tree-widget + :tag (hierarchy-labelfn-to-string labelfn item indent) + :args children)) + hierarchy)) + +(defun hierarchy-tree-display (hierarchy labelfn &optional buffer) + "Display HIERARCHY as a tree widget in a new buffer. + +HIERARCHY and LABELFN are passed unchanged to +`hierarchy-convert-to-tree-widget'. + +The tree widget is displayed in BUFFER, or a newly created buffer if +nil. The buffer is returned." + (let ((buffer (or buffer (generate-new-buffer "*hierarchy-tree*"))) + (tree-widget (hierarchy-convert-to-tree-widget hierarchy labelfn))) + (with-current-buffer buffer + (setq-local buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer) + (widget-create tree-widget) + (goto-char (point-min)) + (special-mode))) + buffer)) + +(provide 'hierarchy) + +;;; hierarchy.el ends here diff --git a/test/lisp/emacs-lisp/hierarchy-tests.el b/test/lisp/emacs-lisp/hierarchy-tests.el new file mode 100644 index 00000000000..23cfc79d848 --- /dev/null +++ b/test/lisp/emacs-lisp/hierarchy-tests.el @@ -0,0 +1,556 @@ +;;; hierarchy-tests.el --- Tests for hierarchy.el + +;; Copyright (C) 2017-2019 Damien Cassou + +;; Author: Damien Cassou +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Tests for hierarchy.el + +;;; Code: + +(require 'ert) +(require 'hierarchy) + +(defun hierarchy-animals () + "Create a sorted animal hierarchy." + (let ((parentfn (lambda (item) (cl-case item + (dove 'bird) + (pigeon 'bird) + (bird 'animal) + (dolphin 'animal) + (cow 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (hierarchy-add-tree hierarchy 'dolphin parentfn) + (hierarchy-add-tree hierarchy 'cow parentfn) + (hierarchy-sort hierarchy) + hierarchy)) + +(ert-deftest hierarchy-add-one-root () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))))) + +(ert-deftest hierarchy-add-one-item-with-parent () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-one-item-with-parent-and-grand-parent () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove))))) + +(ert-deftest hierarchy-add-same-root-twice () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal parentfn) + (hierarchy-add-tree hierarchy 'animal parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))))) + +(ert-deftest hierarchy-add-same-child-twice () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-item-and-its-parent () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (hierarchy-add-tree hierarchy 'animal parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-item-and-its-child () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal parentfn) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-two-items-sharing-parent () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (pigeon 'bird)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (should (equal (hierarchy-roots hierarchy) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-add-two-hierarchies () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (circle 'shape)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'circle parentfn) + (should (equal (hierarchy-roots hierarchy) '(bird shape))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove))) + (should (equal (hierarchy-children hierarchy 'shape) '(circle))))) + +(ert-deftest hierarchy-add-with-childrenfn () + (let ((childrenfn (lambda (item) + (cl-case item + (animal '(bird)) + (bird '(dove pigeon))))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal nil childrenfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-add-with-parentfn-and-childrenfn () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal) + (animal 'life-form)))) + (childrenfn (lambda (item) + (cl-case item + (bird '(dove pigeon)) + (pigeon '(ashy-wood-pigeon))))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn childrenfn) + (should (equal (hierarchy-roots hierarchy) '(life-form))) + (should (equal (hierarchy-children hierarchy 'life-form) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))) + (should (equal (hierarchy-children hierarchy 'pigeon) '(ashy-wood-pigeon))))) + +(ert-deftest hierarchy-add-twice-with-parentfn-and-childrenfn () + (let* ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (bird 'animal)))) + (childrenfn (lambda (item) + (cl-case item + (animal '(bird)) + (bird '(dove))))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn childrenfn) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove))))) + +(ert-deftest hierarchy-add-trees () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (pigeon 'bird) + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-trees hierarchy '(dove pigeon) parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-from-list () + (let ((hierarchy (hierarchy-from-list + '(animal (bird (dove) + (pigeon)) + (cow) + (dolphin))))) + (hierarchy-sort hierarchy (lambda (item1 item2) + (string< (car item1) + (car item2)))) + (should (equal (hierarchy-to-string hierarchy (lambda (item) (symbol-name (car item)))) + "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) + +(ert-deftest hierarchy-from-list-with-duplicates () + (let ((hierarchy (hierarchy-from-list + '(a (b) (b)) + t))) + (hierarchy-sort hierarchy (lambda (item1 item2) + ;; sort by ID + (< (car item1) (car item2)))) + (should (equal (hierarchy-length hierarchy) 3)) + (should (equal (hierarchy-to-string + hierarchy + (lambda (item) + (format "%s(%s)" + (cadr item) + (car item)))) + "a(1)\n b(2)\n b(3)\n")))) + +(ert-deftest hierarchy-from-list-with-childrenfn () + (let ((hierarchy (hierarchy-from-list + "abc" + nil + (lambda (item) + (when (string= item "abc") + (split-string item "" t)))))) + (hierarchy-sort hierarchy (lambda (item1 item2) (string< item1 item2))) + (should (equal (hierarchy-length hierarchy) 4)) + (should (equal (hierarchy-to-string hierarchy) + "abc\n a\n b\n c\n")))) + +(ert-deftest hierarchy-add-relation-check-error-when-different-parent () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should-error + (hierarchy--add-relation hierarchy 'bird 'cow #'identity)))) + +(ert-deftest hierarchy-empty-p-return-non-nil-for-empty () + (should (hierarchy-empty-p (hierarchy-new)))) + +(ert-deftest hierarchy-empty-p-return-nil-for-non-empty () + (should-not (hierarchy-empty-p (hierarchy-animals)))) + +(ert-deftest hierarchy-length-of-empty-is-0 () + (should (equal (hierarchy-length (hierarchy-new)) 0))) + +(ert-deftest hierarchy-length-of-non-empty-counts-items () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal) + (dove 'bird) + (pigeon 'bird)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (should (equal (hierarchy-length hierarchy) 4)))) + +(ert-deftest hierarchy-has-root () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal) + (dove 'bird) + (pigeon 'bird)))) + (hierarchy (hierarchy-new))) + (should-not (hierarchy-has-root hierarchy 'animal)) + (should-not (hierarchy-has-root hierarchy 'bird)) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (should (hierarchy-has-root hierarchy 'animal)) + (should-not (hierarchy-has-root hierarchy 'bird)))) + +(ert-deftest hierarchy-leafs () + (let ((animals (hierarchy-animals))) + (should (equal (hierarchy-leafs animals) + '(dove pigeon dolphin cow))))) + +(ert-deftest hierarchy-leafs-includes-lonely-roots () + (let ((parentfn (lambda (item) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'foo parentfn) + (should (equal (hierarchy-leafs hierarchy) + '(foo))))) + +(ert-deftest hierarchy-leafs-of-node () + (let ((animals (hierarchy-animals))) + (should (equal (hierarchy-leafs animals 'cow) '())) + (should (equal (hierarchy-leafs animals 'animal) '(dove pigeon dolphin cow))) + (should (equal (hierarchy-leafs animals 'bird) '(dove pigeon))) + (should (equal (hierarchy-leafs animals 'dove) '())))) + +(ert-deftest hierarchy-child-p () + (let ((animals (hierarchy-animals))) + (should (hierarchy-child-p animals 'dove 'bird)) + (should (hierarchy-child-p animals 'bird 'animal)) + (should (hierarchy-child-p animals 'cow 'animal)) + (should-not (hierarchy-child-p animals 'cow 'bird)) + (should-not (hierarchy-child-p animals 'bird 'cow)) + (should-not (hierarchy-child-p animals 'animal 'dove)) + (should-not (hierarchy-child-p animals 'animal 'bird)))) + +(ert-deftest hierarchy-descendant () + (let ((animals (hierarchy-animals))) + (should (hierarchy-descendant-p animals 'dove 'animal)) + (should (hierarchy-descendant-p animals 'dove 'bird)) + (should (hierarchy-descendant-p animals 'bird 'animal)) + (should (hierarchy-descendant-p animals 'cow 'animal)) + (should-not (hierarchy-descendant-p animals 'cow 'bird)) + (should-not (hierarchy-descendant-p animals 'bird 'cow)) + (should-not (hierarchy-descendant-p animals 'animal 'dove)) + (should-not (hierarchy-descendant-p animals 'animal 'bird)))) + +(ert-deftest hierarchy-descendant-if-not-same () + (let ((animals (hierarchy-animals))) + (should-not (hierarchy-descendant-p animals 'cow 'cow)) + (should-not (hierarchy-descendant-p animals 'dove 'dove)) + (should-not (hierarchy-descendant-p animals 'bird 'bird)) + (should-not (hierarchy-descendant-p animals 'animal 'animal)))) + +;; keywords supported: :test :key +(ert-deftest hierarchy--set-equal () + (should (hierarchy--set-equal '(1 2 3) '(1 2 3))) + (should (hierarchy--set-equal '(1 2 3) '(3 2 1))) + (should (hierarchy--set-equal '(3 2 1) '(1 2 3))) + (should-not (hierarchy--set-equal '(2 3) '(3 2 1))) + (should-not (hierarchy--set-equal '(1 2 3) '(2 3))) + (should-not (hierarchy--set-equal '("1" "2") '("2" "1") :test #'eq)) + (should (hierarchy--set-equal '("1" "2") '("2" "1") :test #'equal)) + (should-not (hierarchy--set-equal '(1 2) '(-1 -2))) + (should (hierarchy--set-equal '(1 2) '(-1 -2) :key #'abs)) + (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)))) + (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car)) + (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :test #'equal)) + (should (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car :test #'equal))) + +(ert-deftest hierarchy-equal-returns-true-for-same-hierarchy () + (let ((animals (hierarchy-animals))) + (should (hierarchy-equal animals animals)) + (should (hierarchy-equal (hierarchy-animals) animals)))) + +(ert-deftest hierarchy-equal-returns-true-for-hierarchy-copies () + (let ((animals (hierarchy-animals))) + (should (hierarchy-equal animals (hierarchy-copy animals))))) + +(ert-deftest hierarchy-map-item-on-leaf () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'cow + animals))) + (should (equal result '((cow . 0)))))) + +(ert-deftest hierarchy-map-item-on-leaf-with-indent () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'cow + animals + 2))) + (should (equal result '((cow . 2)))))) + +(ert-deftest hierarchy-map-item-on-parent () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'bird + animals))) + (should (equal result '((bird . 0) (dove . 1) (pigeon . 1)))))) + +(ert-deftest hierarchy-map-item-on-grand-parent () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'animal + animals))) + (should (equal result '((animal . 0) (bird . 1) (dove . 2) (pigeon . 2) + (cow . 1) (dolphin . 1)))))) + +(ert-deftest hierarchy-map-conses () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map (lambda (item indent) + (cons item indent)) + animals))) + (should (equal result '((animal . 0) + (bird . 1) + (dove . 2) + (pigeon . 2) + (cow . 1) + (dolphin . 1)))))) + +(ert-deftest hierarchy-map-tree () + (let ((animals (hierarchy-animals))) + (should (equal (hierarchy-map-tree (lambda (item indent children) + (list item indent children)) + animals) + '(animal + 0 + ((bird 1 ((dove 2 nil) (pigeon 2 nil))) + (cow 1 nil) + (dolphin 1 nil))))))) + +(ert-deftest hierarchy-map-hierarchy-keeps-hierarchy () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-hierarchy (lambda (item _) (identity item)) + animals))) + (should (hierarchy-equal animals result)))) + +(ert-deftest hierarchy-map-applies-function () + (let* ((animals (hierarchy-animals)) + (parentfn (lambda (item) + (cond + ((equal item "bird") "animal") + ((equal item "dove") "bird") + ((equal item "pigeon") "bird") + ((equal item "cow") "animal") + ((equal item "dolphin") "animal")))) + (expected (hierarchy-new))) + (hierarchy-add-tree expected "dove" parentfn) + (hierarchy-add-tree expected "pigeon" parentfn) + (hierarchy-add-tree expected "cow" parentfn) + (hierarchy-add-tree expected "dolphin" parentfn) + (should (hierarchy-equal + (hierarchy-map-hierarchy (lambda (item _) (symbol-name item)) animals) + expected)))) + +(ert-deftest hierarchy-extract-tree () + (let* ((animals (hierarchy-animals)) + (birds (hierarchy-extract-tree animals 'bird))) + (hierarchy-sort birds) + (should (equal (hierarchy-roots birds) '(animal))) + (should (equal (hierarchy-children birds 'animal) '(bird))) + (should (equal (hierarchy-children birds 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-extract-tree-nil-if-not-in-hierarchy () + (let* ((animals (hierarchy-animals))) + (should-not (hierarchy-extract-tree animals 'foobar)))) + +(ert-deftest hierarchy-items-of-empty-hierarchy-is-empty () + (should (seq-empty-p (hierarchy-items (hierarchy-new))))) + +(ert-deftest hierarchy-items-returns-sequence-of-same-length () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-items animals))) + (should (= (seq-length result) (hierarchy-length animals))))) + +(ert-deftest hierarchy-items-return-all-elements-of-hierarchy () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-items animals))) + (should (equal (seq-sort #'string< result) '(animal bird cow dolphin dove pigeon))))) + +(ert-deftest hierarchy-labelfn-indent-no-indent-if-0 () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base))) + (should (equal + (with-temp-buffer + (funcall labelfn "bar" 0) + (buffer-substring (point-min) (point-max))) + "foo")))) + +(ert-deftest hierarchy-labelfn-indent-three-times-if-3 () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base))) + (should (equal + (with-temp-buffer + (funcall labelfn "bar" 3) + (buffer-substring (point-min) (point-max))) + " foo")))) + +(ert-deftest hierarchy-labelfn-indent-default-indent-string () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base))) + (should (equal + (with-temp-buffer + (funcall labelfn "bar" 1) + (buffer-substring (point-min) (point-max))) + " foo")))) + +(ert-deftest hierarchy-labelfn-indent-custom-indent-string () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base "###")) + (content (with-temp-buffer + (funcall labelfn "bar" 1) + (buffer-substring (point-min) (point-max))))) + (should (equal content "###foo")))) + +(ert-deftest hierarchy-labelfn-button-propertize () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (actionfn #'identity) + (labelfn (hierarchy-labelfn-button labelfn-base actionfn)) + (properties (with-temp-buffer + (funcall labelfn "bar" 1) + (text-properties-at 1)))) + (should (equal (car properties) 'action)))) + +(ert-deftest hierarchy-labelfn-button-execute-labelfn () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (actionfn #'identity) + (labelfn (hierarchy-labelfn-button labelfn-base actionfn)) + (content (with-temp-buffer + (funcall labelfn "bar" 1) + (buffer-substring-no-properties (point-min) (point-max))))) + (should (equal content "foo")))) + +(ert-deftest hierarchy-labelfn-button-if-does-not-button-unless-condition () + (let ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (spy-count 0) + (condition (lambda (_item _indent) nil))) + (cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count))))) + (funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil) + (should (equal spy-count 0))))) + +(ert-deftest hierarchy-labelfn-button-if-does-button-when-condition () + (let ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (spy-count 0) + (condition (lambda (_item _indent) t))) + (cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count))))) + (funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil) + (should (equal spy-count 1))))) + +(ert-deftest hierarchy-labelfn-to-string () + (let ((labelfn (lambda (item _indent) (insert item)))) + (should (equal (hierarchy-labelfn-to-string labelfn "foo" 1) "foo")))) + +(ert-deftest hierarchy-print () + (let* ((animals (hierarchy-animals)) + (result (with-temp-buffer + (hierarchy-print animals) + (buffer-substring-no-properties (point-min) (point-max))))) + (should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) + +(ert-deftest hierarchy-to-string () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-to-string animals))) + (should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) + +(ert-deftest hierarchy-tabulated-display () + (let* ((animals (hierarchy-animals)) + (labelfn (lambda (item _indent) (insert (symbol-name item)))) + (contents (with-temp-buffer + (hierarchy-tabulated-display animals labelfn (current-buffer)) + (buffer-substring-no-properties (point-min) (point-max))))) + (should (equal contents "animal\nbird\ndove\npigeon\ncow\ndolphin\n")))) + +(ert-deftest hierarchy-sort-non-root-nodes () + (let* ((animals (hierarchy-animals))) + (should (equal (hierarchy-roots animals) '(animal))) + (should (equal (hierarchy-children animals 'animal) '(bird cow dolphin))) + (should (equal (hierarchy-children animals 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-sort-roots () + (let* ((organisms (hierarchy-new)) + (parentfn (lambda (item) + (cl-case item + (oak 'plant) + (bird 'animal))))) + (hierarchy-add-tree organisms 'oak parentfn) + (hierarchy-add-tree organisms 'bird parentfn) + (hierarchy-sort organisms) + (should (equal (hierarchy-roots organisms) '(animal plant))))) + +(provide 'hierarchy-tests) +;;; hierarchy-tests.el ends here