commit c37370a7a0f329d13cf00a06e446514be09a7bab (HEAD, refs/remotes/origin/master) Author: Eli Zaretskii Date: Sun Sep 27 08:57:17 2020 +0300 Improve documentation of the 'abbrev-suggest' feature * lisp/abbrev.el (abbrev-suggest, abbrev-suggest-hint-threshold) (abbrev-suggest-show-report): Improve wording of the doc strings. * doc/emacs/abbrevs.texi (Abbrevs Suggestions): Fix the typo in the node name. Improve wording. * doc/emacs/emacs.texi (Top): Add the new node in the @detailmenu section. * etc/NEWS: Improve wording of the NEWS entry for 'abbrev-suggest'. diff --git a/doc/emacs/abbrevs.texi b/doc/emacs/abbrevs.texi index 0dda977833..e3766aae9e 100644 --- a/doc/emacs/abbrevs.texi +++ b/doc/emacs/abbrevs.texi @@ -28,7 +28,7 @@ Automatic Typing}. * Abbrev Concepts:: Fundamentals of defined abbrevs. * Defining Abbrevs:: Defining an abbrev, so it will expand when typed. * Expanding Abbrevs:: Controlling expansion: prefixes, canceling expansion. -* Abbrevs Suggestions:: Get suggestions about defined abbrevs. +* Abbrevs Suggestions:: Get automatic suggestions about defined abbrevs. * Editing Abbrevs:: Viewing or editing the entire list of defined abbrevs. * Saving Abbrevs:: Saving the entire list of abbrevs for another session. * Dynamic Abbrevs:: Abbreviations for words already in the buffer. @@ -224,34 +224,35 @@ changing this function you can make arbitrary changes to the abbrev expansion. @xref{Abbrev Expansion,,, elisp, The Emacs Lisp Reference Manual}. -@node Abbrev Suggestions -@section Abbrev Suggestions +@node Abbrevs Suggestions +@section Abbrevs Suggestions You can get abbrev suggestions when you manually type text for which there is currently an active defined abbrev. For example, if there is an abbrev @samp{foo} with the expansion @samp{find outer otter}, and -you manually type @samp{find outer otter}, the abbrev suggestion -feature will notice this and show a hint in the echo area when you -have stopped typing. +you manually type @samp{find outer otter}, Emacs can notice this and +show a hint in the echo area when you have stopped typing. @vindex abbrev-suggest - Enable the abbrev suggestion feature by setting -@code{abbrev-suggest} to @code{t}. + To enable the abbrev suggestion feature, customize the option +@code{abbrev-suggest} to a non-@code{nil} value. @vindex abbrev-suggest-hint-threshold - Controls when to suggest an abbrev to the user. The variable -defines the number of characters that the user must save in order to -get a suggestion. For example, if the user types @samp{foo bar} -(seven characters) and there is an abbrev @samp{fubar} defined (five -characters), the user will not get any suggestion unless the threshold -is set to the number 2 or lower. With the default value 3, the user -would not get any suggestion, because the savings in using the abbrev -are not above the threshold. If you always want to get abbrev -suggestions, set this variable to 0. + The variable @code{abbrev-suggest-hint-threshold} controls when to +suggest an abbrev to the user. This variable defines the minimum +savings (in terms of the number of characters the user will not have +to type) required for Emacs to suggest using an abbrev. For example, +if the user types @samp{foo bar} (seven characters) and there is an +abbrev @samp{fubar} defined (five characters), the user will not get +any suggestion unless the threshold is set to the number 2 or lower. +With the default value 3, the user would not get any suggestion in +this example, because the savings in using the abbrev are below +the threshold. If you always want to get abbrev suggestions, set this +variable's value to zero. @findex abbrev-suggest-show-report - The command @code{abbrev-suggest-show-report} can be used to show a -buffer with all abbrev suggestions from the current editing session. + The command @code{abbrev-suggest-show-report} displays a buffer with +all the abbrev suggestions shown during the current editing session. This can be useful if you get several abbrev suggestions and don't remember them all. diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi index 6aed7bd92a..566229b2f3 100644 --- a/doc/emacs/emacs.texi +++ b/doc/emacs/emacs.texi @@ -908,6 +908,7 @@ Abbrevs * Abbrev Concepts:: Fundamentals of defined abbrevs. * Defining Abbrevs:: Defining an abbrev, so it will expand when typed. * Expanding Abbrevs:: Controlling expansion: prefixes, canceling expansion. +* Abbrevs Suggestions:: Get automatic suggestions about defined abbrevs. * Editing Abbrevs:: Viewing or editing the entire list of defined abbrevs. * Saving Abbrevs:: Saving the entire list of abbrevs for another session. * Dynamic Abbrevs:: Abbreviations for words already in the buffer. diff --git a/etc/NEWS b/etc/NEWS index 0cbbae4186..202cd689d3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1274,12 +1274,12 @@ of conditionals. ** Abbrev mode +++ -*** Abbrev can now suggest pre-existing abbrevs based on typed text. +*** Emacs can now suggest to use an abbrev based on text you type. A new user option, 'abbrev-suggest', enables the new abbrev suggestion -feature. When enabled, if a user manually type a piece of text that -could have been written by using an abbrev, a hint will be displayed -in the echo area, mentioning the abbrev that could have been used -instead. +feature. When enabled, if a user manually types a piece of text that +could have saved enough typing by using an abbrev, a hint will be +displayed in the echo area, mentioning the abbrev that could have been +used instead. * New Modes and Packages in Emacs 28.1 diff --git a/lisp/abbrev.el b/lisp/abbrev.el index 75cc43941f..dc52a22012 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -825,22 +825,23 @@ see `define-abbrev' for details." Takes no argument and should return the abbrev symbol if expansion took place.") (defcustom abbrev-suggest nil - "Non-nil means suggest abbrevs to the user. -By enabling this option, if abbrev mode is enabled and if the -user has typed some text that exists as an abbrev, suggest to the -user to use the abbrev by displaying a message in the echo area." + "Non-nil means suggest using abbrevs to save typing. +When abbrev mode is active and this option is non-nil, Emacs will +suggest in the echo area to use an existing abbrev if doing so +will save enough typing. See `abbrev-suggest-hint-threshold' for +the definition of \"enough typing\"." :type 'boolean :version "28.1") (defcustom abbrev-suggest-hint-threshold 3 - "Threshold for when to inform the user that there is an abbrev. -The threshold is the number of characters that differ between the -length of the abbrev and the length of the expansion. The -thinking is that if the expansion is only one or a few characters + "Threshold for when to suggest to use an abbrev to save typing. +The threshold is the amount of typing, in terms of the number of +characters, that would be saved by using the abbrev. The +thinking is that if the expansion is only a few characters longer than the abbrev, the benefit of informing the user is not -that big. If you always want to be informed, set this value to -`0' or less. This setting only applies if `abbrev-suggest' is -non-nil." +significant. If you always want to be informed about existing +abbrevs for the text you type, set this value to zero or less. +This setting only applies if `abbrev-suggest' is non-nil." :type 'number :version "28.1") @@ -945,7 +946,9 @@ typed." total)) (defun abbrev-suggest-show-report () - "Show the user a report of abbrevs he could have used." + "Show a buffer with the list of abbrevs you could have used. +This shows the abbrevs you've \"missed\" because you typed the +full text instead of the abbrevs that expand into that text." (interactive) (let ((totals (abbrev--suggest-get-totals)) (buf (get-buffer-create "*abbrev-suggest*"))) commit 768676f74f093e75e2d7e04e18e1fd1836d1e7e9 Author: Eli Zaretskii Date: Sun Sep 27 08:26:56 2020 +0300 Improve display of raw bytes in the echo-area * src/print.c (print_object): When printing a unibyte string, convert non-ASCII bytes to their character code, before sending them to 'printchar'. (Bug#43632) diff --git a/src/print.c b/src/print.c index 0ecc98f37b..dca095f281 100644 --- a/src/print.c +++ b/src/print.c @@ -1929,7 +1929,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) ptrdiff_t i, i_byte; ptrdiff_t size_byte; /* True means we must ensure that the next character we output - cannot be taken as part of a hex character escape. */ + cannot be taken as part of a hex character escape. */ bool need_nonhex = false; bool multibyte = STRING_MULTIBYTE (obj); @@ -1976,25 +1976,29 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) /* If we just had a hex escape, and this character could be taken as part of it, output `\ ' to prevent that. */ - if (c_isxdigit (c)) - { - if (need_nonhex) - print_c_string ("\\ ", printcharfun); - printchar (c, printcharfun); - } - else if (c == '\n' && print_escape_newlines - ? (c = 'n', true) - : c == '\f' && print_escape_newlines - ? (c = 'f', true) - : c == '\"' || c == '\\') - { - printchar ('\\', printcharfun); - printchar (c, printcharfun); - } - else if (print_escape_control_characters && c_iscntrl (c)) + if (c_isxdigit (c)) + { + if (need_nonhex) + print_c_string ("\\ ", printcharfun); + printchar (c, printcharfun); + } + else if (c == '\n' && print_escape_newlines + ? (c = 'n', true) + : c == '\f' && print_escape_newlines + ? (c = 'f', true) + : c == '\"' || c == '\\') + { + printchar ('\\', printcharfun); + printchar (c, printcharfun); + } + else if (print_escape_control_characters && c_iscntrl (c)) octalout (c, SDATA (obj), i_byte, size_byte, printcharfun); - else - printchar (c, printcharfun); + else if (!multibyte + && SINGLE_BYTE_CHAR_P (c) + && !ASCII_CHAR_P (c)) + printchar (BYTE8_TO_CHAR (c), printcharfun); + else + printchar (c, printcharfun); need_nonhex = false; } } @@ -2024,7 +2028,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) && len == size_byte); if (! NILP (Vprint_gensym) - && !SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (obj)) + && !SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (obj)) print_c_string ("#:", printcharfun); else if (size_byte == 0) { @@ -2047,7 +2051,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) || c == ',' || c == '.' || c == '`' || c == '[' || c == ']' || c == '?' || c <= 040 || c == NO_BREAK_SPACE - || confusing) + || confusing) { printchar ('\\', printcharfun); confusing = false; @@ -2112,7 +2116,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) if (!NILP (Vprint_circle)) { - /* With the print-circle feature. */ + /* With the print-circle feature. */ Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil); if (FIXNUMP (num)) @@ -2164,7 +2168,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { int len; /* We're in trouble if this happens! - Probably should just emacs_abort (). */ + Probably should just emacs_abort (). */ print_c_string ("# Date: Sun Sep 27 02:01:03 2020 +0200 Fix searching for multibyte needles in unibyte haystacks * src/fns.c (Fstring_search): Make this work better when searching unibyte haystacks for multibyte needles (bug#43598). diff --git a/src/fns.c b/src/fns.c index 2fcc282dcb..0f76871154 100644 --- a/src/fns.c +++ b/src/fns.c @@ -5454,6 +5454,21 @@ It should not be used for anything security-related. See return make_digest_string (digest, SHA1_DIGEST_SIZE); } +static bool +string_ascii_p (Lisp_Object string) +{ + if (STRING_MULTIBYTE (string)) + return SBYTES (string) == SCHARS (string); + else + { + ptrdiff_t nbytes = SBYTES (string); + for (ptrdiff_t i = 0; i < nbytes; i++) + if (SREF (string, i) > 127) + return false; + return true; + } +} + DEFUN ("string-search", Fstring_search, Sstring_search, 2, 3, 0, doc: /* Search for the string NEEDLE in the string HAYSTACK. The return value is the position of the first occurrence of NEEDLE in @@ -5490,7 +5505,9 @@ Case is always significant and text properties are ignored. */) haystart = SSDATA (haystack) + start_byte; haybytes = SBYTES (haystack) - start_byte; - if (STRING_MULTIBYTE (haystack) == STRING_MULTIBYTE (needle)) + if (STRING_MULTIBYTE (haystack) == STRING_MULTIBYTE (needle) + || string_ascii_p (needle) + || string_ascii_p (haystack)) res = memmem (haystart, haybytes, SSDATA (needle), SBYTES (needle)); else if (STRING_MULTIBYTE (haystack)) /* unibyte needle */ @@ -5501,9 +5518,29 @@ Case is always significant and text properties are ignored. */) } else /* unibyte haystack, multibyte needle */ { - Lisp_Object uni_needle = Fstring_as_unibyte (needle); - res = memmem (haystart, haybytes, - SSDATA (uni_needle), SBYTES (uni_needle)); + /* The only possible way we can find the multibyte needle in the + unibyte stack (since we know that neither are pure-ASCII) is + if they contain "raw bytes" (and no other non-ASCII chars.) */ + ptrdiff_t chars = SCHARS (needle); + const unsigned char *src = SDATA (needle); + + for (ptrdiff_t i = 0; i < chars; i++) + { + int c = string_char_advance (&src); + + if (!CHAR_BYTE8_P (c) + && !ASCII_CHAR_P (c)) + /* Found a char that can't be in the haystack. */ + return Qnil; + } + + { + /* "Raw bytes" (aka eighth-bit) are represented differently in + multibyte and unibyte strings. */ + Lisp_Object uni_needle = Fstring_to_unibyte (needle); + res = memmem (haystart, haybytes, + SSDATA (uni_needle), SBYTES (uni_needle)); + } } if (! res) diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index f2e1a268b0..41969f2af2 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -953,4 +953,8 @@ (should (equal (string-search "" "abc" 3) 3)) (should-error (string-search "" "abc" 4)) (should-error (string-search "" "abc" -1)) - ) + + (should-not (string-search "ø" "foo\303\270")) + (should (equal (string-search (string-to-multibyte "o\303\270") "foo\303\270") + 2)) + (should (equal (string-search "\303\270" "foo\303\270") 3))) commit 8a148c5976e3fad53d540ce5aa52a36c6b658f85 Author: Lars Ingebrigtsen Date: Sun Sep 27 00:50:39 2020 +0200 Make dired-replace-in-string obsolete * lisp/dired.el (dired-insert-directory): * lisp/dired-aux.el (dired-rename-subdir, dired-rename-subdir-2) (dired-insert-subdir): Adjust callers. * lisp/dired.el (dired-replace-in-string): Make obsolete. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index df25a6418f..6034d12f32 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1802,7 +1802,7 @@ unless OK-IF-ALREADY-EXISTS is non-nil." (if (and buffer-file-name (dired-in-this-tree-p buffer-file-name expanded-from-dir)) (let ((modflag (buffer-modified-p)) - (to-file (dired-replace-in-string + (to-file (replace-regexp-in-string (concat "^" (regexp-quote from-dir)) to-dir buffer-file-name))) @@ -1866,7 +1866,7 @@ unless OK-IF-ALREADY-EXISTS is non-nil." ;; Update buffer-local dired-subdir-alist and dired-switches-alist (let ((cons (assoc-string (car elt) dired-switches-alist)) (cur-dir (dired-normalize-subdir - (dired-replace-in-string regexp newtext (car elt))))) + (replace-regexp-in-string regexp newtext (car elt))))) (setcar elt cur-dir) (when cons (setcar cons cur-dir)))))) @@ -2612,7 +2612,7 @@ This function takes some pains to conform to `ls -lR' output." (push (cons dirname switches) dired-switches-alist))) (when switches-have-R (dired-build-subdir-alist switches) - (setq switches (dired-replace-in-string "R" "" switches)) + (setq switches (string-replace "R" "" switches)) (dolist (cur-ass dired-subdir-alist) (let ((cur-dir (car cur-ass))) (and (dired-in-this-tree-p cur-dir dirname) @@ -2713,7 +2713,7 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well." (let ((dired-actual-switches (or switches dired-subdir-switches - (dired-replace-in-string "R" "" dired-actual-switches)))) + (string-replace "R" "" dired-actual-switches)))) (if (equal dirname (car (car (last dired-subdir-alist)))) ;; If doing the top level directory of the buffer, ;; redo it as specified in dired-directory. diff --git a/lisp/dired.el b/lisp/dired.el index 1ed949d5db..b4b3368a5b 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1504,7 +1504,7 @@ see `dired-use-ls-dired' for more details.") ;; "--dired", so we cannot add it to the `process-file' ;; call for wildcards. (when (file-remote-p dir) - (setq switches (dired-replace-in-string "--dired" "" switches))) + (setq switches (string-replace "--dired" "" switches))) (let* ((default-directory (car dir-wildcard)) (script (format "ls %s %s" switches (cdr dir-wildcard))) (remotep (file-remote-p dir)) @@ -4290,11 +4290,10 @@ With a prefix argument, edit the current listing switches instead." (dired-sort-set-mode-line) (revert-buffer)) -;; Some user code loads dired especially for this. -;; Don't do that--use replace-regexp-in-string instead. (defun dired-replace-in-string (regexp newtext string) ;; Replace REGEXP with NEWTEXT everywhere in STRING and return result. ;; NEWTEXT is taken literally---no \\DIGIT escapes will be recognized. + (declare (obsolete replace-regexp-in-string "28.1")) (let ((result "") (start 0) mb me) (while (string-match regexp string start) (setq mb (match-beginning 0) commit 104688feb45dde126199ce277edc27c85e1b0faf Author: Lars Ingebrigtsen Date: Sun Sep 27 00:35:11 2020 +0200 Add tiny optimization for string-search * src/fns.c (Fstring_search): Add tiny optimization for needles that are longer than the haystack (bug#43598). diff --git a/src/fns.c b/src/fns.c index 2f64d95576..2fcc282dcb 100644 --- a/src/fns.c +++ b/src/fns.c @@ -5468,6 +5468,7 @@ Case is always significant and text properties are ignored. */) { ptrdiff_t start_byte = 0, haybytes; char *res, *haystart; + EMACS_INT start = 0; CHECK_STRING (needle); CHECK_STRING (haystack); @@ -5475,12 +5476,17 @@ Case is always significant and text properties are ignored. */) if (!NILP (start_pos)) { CHECK_FIXNUM (start_pos); - EMACS_INT start = XFIXNUM (start_pos); + start = XFIXNUM (start_pos); if (start < 0 || start > SCHARS (haystack)) xsignal1 (Qargs_out_of_range, start_pos); start_byte = string_char_to_byte (haystack, start); } + /* If NEEDLE is longer than (the remaining length of) haystack, then + we can't have a match, and return early. */ + if (SCHARS (needle) > SCHARS (haystack) - start) + return Qnil; + haystart = SSDATA (haystack) + start_byte; haybytes = SBYTES (haystack) - start_byte; diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index a3e9c426db..42dcf382e4 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -461,6 +461,9 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (should (equal (string-replace "azot" "bar" "foozotbar") "foozotbar")) + (should (equal (string-replace "fo" "bar" "lafofofozot") + "labarbarbarzot")) + (should (equal (string-replace "\377" "x" "a\377b") "axb")) (should (equal (string-replace "\377" "x" "a\377ø") commit baf331e40c08155082e255372d7cc3c9d63aa3c8 Author: Lars Ingebrigtsen Date: Sun Sep 27 00:24:50 2020 +0200 Rename replace-in-string to string-replace * doc/lispref/searching.texi (Search and Replace): Update. * lisp/bindings.el (mode-line-position): Update callers. * lisp/subr.el (string-replace): Rename from replace-in-string since that clashes with XEmacs' replace-in-string which is equivalent to the Emacs replace-regexp-in-string (bug#43598). diff --git a/doc/lispref/searching.texi b/doc/lispref/searching.texi index a217c6e935..451283b4aa 100644 --- a/doc/lispref/searching.texi +++ b/doc/lispref/searching.texi @@ -2566,7 +2566,7 @@ replacement string. The match data at this point are the result of matching @var{regexp} against a substring of @var{string}. @end defun -@defun replace-in-string fromstring tostring instring +@defun string-replace fromstring tostring instring This function copies @var{instring} and replaces any occurrences of @var{fromstring} with @var{tostring}. @end defun diff --git a/etc/NEWS b/etc/NEWS index 9cd3559323..0cbbae4186 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1455,7 +1455,7 @@ return status is non-zero. 'process-lines-handling-status' has also been added, and takes a callback to handle the return status. +++ -*** New function 'replace-in-string'. +*** New function 'string-replace'. This function works along the line of 'replace-regexp-in-string', but matching on strings instead of regexps, and does not change the global match state. diff --git a/lisp/bindings.el b/lisp/bindings.el index f31c6cc336..3930f5b52c 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -493,7 +493,7 @@ mouse-1: Display Line and Column Mode Menu"))) ,@mode-line-position--column-line-properties)) (10 (:propertize - (:eval (replace-in-string + (:eval (string-replace "%c" "%C" (car mode-line-position-column-line-format))) ,@mode-line-position--column-line-properties))) (6 @@ -508,7 +508,7 @@ mouse-1: Display Line and Column Mode Menu"))) (,@mode-line-position--column-line-properties))) (6 (:propertize - (:eval (replace-in-string + (:eval (string-replace "%c" "%C" (car mode-line-position-column-format))) ,@mode-line-position--column-line-properties)))))) "Mode line construct for displaying the position in the buffer. diff --git a/lisp/subr.el b/lisp/subr.el index 357eae0f50..6f164ae694 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4429,7 +4429,7 @@ Unless optional argument INPLACE is non-nil, return a new string." (aset newstr i tochar))) newstr)) -(defun replace-in-string (fromstring tostring instring) +(defun string-replace (fromstring tostring instring) "Replace FROMSTRING with TOSTRING in INSTRING each time it occurs." (declare (pure t)) (when (equal fromstring "") diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 505408fa11..a3e9c426db 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -440,33 +440,33 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (should-error (ignore-error foo (read "")))) -(ert-deftest replace-in-string () - (should (equal (replace-in-string "foo" "bar" "zot") +(ert-deftest string-replace () + (should (equal (string-replace "foo" "bar" "zot") "zot")) - (should (equal (replace-in-string "foo" "bar" "foozot") + (should (equal (string-replace "foo" "bar" "foozot") "barzot")) - (should (equal (replace-in-string "foo" "bar" "barfoozot") + (should (equal (string-replace "foo" "bar" "barfoozot") "barbarzot")) - (should (equal (replace-in-string "zot" "bar" "barfoozot") + (should (equal (string-replace "zot" "bar" "barfoozot") "barfoobar")) - (should (equal (replace-in-string "z" "bar" "barfoozot") + (should (equal (string-replace "z" "bar" "barfoozot") "barfoobarot")) - (should (equal (replace-in-string "zot" "bar" "zat") + (should (equal (string-replace "zot" "bar" "zat") "zat")) - (should (equal (replace-in-string "azot" "bar" "zat") + (should (equal (string-replace "azot" "bar" "zat") "zat")) - (should (equal (replace-in-string "azot" "bar" "azot") + (should (equal (string-replace "azot" "bar" "azot") "bar")) - (should (equal (replace-in-string "azot" "bar" "foozotbar") + (should (equal (string-replace "azot" "bar" "foozotbar") "foozotbar")) - (should (equal (replace-in-string "\377" "x" "a\377b") + (should (equal (string-replace "\377" "x" "a\377b") "axb")) - (should (equal (replace-in-string "\377" "x" "a\377ø") + (should (equal (string-replace "\377" "x" "a\377ø") "axø")) - (should-error (replace-in-string "" "x" "abc"))) + (should-error (string-replace "" "x" "abc"))) (provide 'subr-tests) ;;; subr-tests.el ends here commit 13e75e620b84fda6c951005bf6c80aea854ee58a Author: Lars Ingebrigtsen Date: Sun Sep 27 00:20:03 2020 +0200 Fix gnus-faq example * doc/misc/gnus-faq.texi (FAQ 6-2): replace-in-string was the XEmacs name for the function. diff --git a/doc/misc/gnus-faq.texi b/doc/misc/gnus-faq.texi index 9c1d2d0160..6e2aedae71 100644 --- a/doc/misc/gnus-faq.texi +++ b/doc/misc/gnus-faq.texi @@ -1757,7 +1757,7 @@ more then one article." (let ((archive-name (format "nnml:1.%s" - (replace-in-string gnus-newsgroup-name "^.*:" "")))) + (replace-regexp-in-string "^.*:" "" gnus-newsgroup-name)))) (gnus-summary-copy-article n archive-name))) @end example @noindent commit 53cf5936c19a6c7352483323666c3915de6f7746 Author: Lars Ingebrigtsen Date: Sun Sep 27 00:17:58 2020 +0200 Slight replace-in-string optimization * lisp/subr.el (replace-in-string): Optimize to return the original string if nothing was replaced (bug#43598). diff --git a/lisp/subr.el b/lisp/subr.el index dd797021f1..357eae0f50 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4442,10 +4442,13 @@ Unless optional argument INPLACE is non-nil, return a new string." (push (substring instring start pos) result)) (push tostring result) (setq start (+ pos (length fromstring)))) - ;; Get any remaining bit. - (unless (= start (length instring)) - (push (substring instring start) result)) - (apply #'concat (nreverse result)))) + (if (null result) + ;; No replacements were done, so just return the original string. + instring + ;; Get any remaining bit. + (unless (= start (length instring)) + (push (substring instring start) result)) + (apply #'concat (nreverse result))))) (defun replace-regexp-in-string (regexp rep string &optional fixedcase literal subexp start) commit f43d9d94aafcdfbcc5a10498333a28b3f8220fcf Author: Mathias Dahl Date: Sat Sep 26 15:03:58 2020 -0400 Abbrev suggestions helps users remember to use defined abbrevs * lisp/abbrev.el (abbrev-suggest): New defcustom. (abbrev-suggest-hint-threshold): New defcustom. (abbrev--suggest-get-active-tables-including-parents): New defun. (abbrev--suggest-get-active-abbrev-expansions): New defun. (abbrev--suggest-count-words): New defun. (abbrev--suggest-get-previous-words): New defun. (abbrev--suggest-above-threshold): New defun. (abbrev--suggest-saved-recommendations): New defvar. (abbrev--suggest-inform-user): New defun. (abbrev--suggest-shortest-abbrev): New defun. (abbrev--suggest-maybe-suggest): New defun. (abbrev--suggest-get-totals): New defun. (abbrev-suggest-show-report): New defun. (expand-abbrev): If the previous word was not an abbrev, maybe suggest an abbrev to the user. * doc/emacs/abbrevs.texi (Abbrev suggestions): New section. * etc/NEWS: Announce abbrev suggestions. diff --git a/doc/emacs/abbrevs.texi b/doc/emacs/abbrevs.texi index 21bf8c5332..0dda977833 100644 --- a/doc/emacs/abbrevs.texi +++ b/doc/emacs/abbrevs.texi @@ -28,6 +28,7 @@ Automatic Typing}. * Abbrev Concepts:: Fundamentals of defined abbrevs. * Defining Abbrevs:: Defining an abbrev, so it will expand when typed. * Expanding Abbrevs:: Controlling expansion: prefixes, canceling expansion. +* Abbrevs Suggestions:: Get suggestions about defined abbrevs. * Editing Abbrevs:: Viewing or editing the entire list of defined abbrevs. * Saving Abbrevs:: Saving the entire list of abbrevs for another session. * Dynamic Abbrevs:: Abbreviations for words already in the buffer. @@ -223,6 +224,37 @@ changing this function you can make arbitrary changes to the abbrev expansion. @xref{Abbrev Expansion,,, elisp, The Emacs Lisp Reference Manual}. +@node Abbrev Suggestions +@section Abbrev Suggestions + + You can get abbrev suggestions when you manually type text for which +there is currently an active defined abbrev. For example, if there is +an abbrev @samp{foo} with the expansion @samp{find outer otter}, and +you manually type @samp{find outer otter}, the abbrev suggestion +feature will notice this and show a hint in the echo area when you +have stopped typing. + +@vindex abbrev-suggest + Enable the abbrev suggestion feature by setting +@code{abbrev-suggest} to @code{t}. + +@vindex abbrev-suggest-hint-threshold + Controls when to suggest an abbrev to the user. The variable +defines the number of characters that the user must save in order to +get a suggestion. For example, if the user types @samp{foo bar} +(seven characters) and there is an abbrev @samp{fubar} defined (five +characters), the user will not get any suggestion unless the threshold +is set to the number 2 or lower. With the default value 3, the user +would not get any suggestion, because the savings in using the abbrev +are not above the threshold. If you always want to get abbrev +suggestions, set this variable to 0. + +@findex abbrev-suggest-show-report + The command @code{abbrev-suggest-show-report} can be used to show a +buffer with all abbrev suggestions from the current editing session. +This can be useful if you get several abbrev suggestions and don't +remember them all. + @node Editing Abbrevs @section Examining and Editing Abbrevs diff --git a/etc/NEWS b/etc/NEWS index d3a97489d4..9cd3559323 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1271,6 +1271,16 @@ This value customizes Emacs to use the style recommended in Damian Conway's book "Perl Best Practices" for indentation and formatting of conditionals. +** Abbrev mode + ++++ +*** Abbrev can now suggest pre-existing abbrevs based on typed text. +A new user option, 'abbrev-suggest', enables the new abbrev suggestion +feature. When enabled, if a user manually type a piece of text that +could have been written by using an abbrev, a hint will be displayed +in the echo area, mentioning the abbrev that could have been used +instead. + * New Modes and Packages in Emacs 28.1 diff --git a/lisp/abbrev.el b/lisp/abbrev.el index be6f9ee343..75cc43941f 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -824,6 +824,142 @@ see `define-abbrev' for details." "Function that `expand-abbrev' uses to perform abbrev expansion. Takes no argument and should return the abbrev symbol if expansion took place.") +(defcustom abbrev-suggest nil + "Non-nil means suggest abbrevs to the user. +By enabling this option, if abbrev mode is enabled and if the +user has typed some text that exists as an abbrev, suggest to the +user to use the abbrev by displaying a message in the echo area." + :type 'boolean + :version "28.1") + +(defcustom abbrev-suggest-hint-threshold 3 + "Threshold for when to inform the user that there is an abbrev. +The threshold is the number of characters that differ between the +length of the abbrev and the length of the expansion. The +thinking is that if the expansion is only one or a few characters +longer than the abbrev, the benefit of informing the user is not +that big. If you always want to be informed, set this value to +`0' or less. This setting only applies if `abbrev-suggest' is +non-nil." + :type 'number + :version "28.1") + +(defun abbrev--suggest-get-active-tables-including-parents () + "Return a list of all active abbrev tables, including parent tables." + (let* ((tables (abbrev--active-tables)) + (all tables)) + (dolist (table tables) + (setq all (append (abbrev-table-get table :parents) all))) + all)) + +(defun abbrev--suggest-get-active-abbrev-expansions () + "Return a list of all the active abbrev expansions. +Includes expansions from parent abbrev tables." + (let (expansions) + (dolist (table (abbrev--suggest-get-active-tables-including-parents)) + (mapatoms (lambda (e) + (let ((value (symbol-value (abbrev--symbol e table)))) + (when value + (push (cons value (symbol-name e)) expansions)))) + table)) + expansions)) + +(defun abbrev--suggest-count-words (expansion) + "Return the number of words in EXPANSION. +Expansion is a string of one or more words." + (length (split-string expansion " " t))) + +(defun abbrev--suggest-get-previous-words (n) + "Return the N words before point, spaces included." + (let ((end (point))) + (save-excursion + (backward-word n) + (replace-regexp-in-string + "\\s " " " + (buffer-substring-no-properties (point) end))))) + +(defun abbrev--suggest-above-threshold (expansion) + "Return non-nil if the abbrev in EXPANSION provides significant savings. +A significant saving, here, is the difference in length between +the abbrev and the abbrev expansion. EXPANSION is a cons cell +where the car is the expansion and the cdr is the abbrev." + (>= (- (length (car expansion)) + (length (cdr expansion))) + abbrev-suggest-hint-threshold)) + +(defvar abbrev--suggest-saved-recommendations nil + "Keeps a list of expansions that have abbrevs defined. +The user can show this list by calling +`abbrev-suggest-show-report'.") + +(defun abbrev--suggest-inform-user (expansion) + "Display a message to the user about the existing abbrev. +EXPANSION is a cons cell where the `car' is the expansion and the +`cdr' is the abbrev." + (run-with-idle-timer + 1 nil + (lambda () + (message "You can write `%s' using the abbrev `%s'." + (car expansion) (cdr expansion)))) + (push expansion abbrev--suggest-saved-recommendations)) + +(defun abbrev--suggest-shortest-abbrev (new current) + "Return the shortest abbrev of NEW and CURRENT. +NEW and CURRENT are cons cells where the `car' is the expansion +and the `cdr' is the abbrev." + (if (not current) + new + (if (< (length (cdr new)) + (length (cdr current))) + new + current))) + +(defun abbrev--suggest-maybe-suggest () + "Suggest an abbrev to the user based on the word(s) before point. +Uses `abbrev-suggest-hint-threshold' to find out if the user should be +informed about the existing abbrev." + (let (words abbrev-found word-count) + (dolist (expansion (abbrev--suggest-get-active-abbrev-expansions)) + (setq word-count (abbrev--suggest-count-words (car expansion)) + words (abbrev--suggest-get-previous-words word-count)) + (let ((case-fold-search t)) + (when (and (> word-count 0) + (string-match (car expansion) words) + (abbrev--suggest-above-threshold expansion)) + (setq abbrev-found (abbrev--suggest-shortest-abbrev + expansion abbrev-found))))) + (when abbrev-found + (abbrev--suggest-inform-user abbrev-found)))) + +(defun abbrev--suggest-get-totals () + "Return a list of all expansions and how many times they were used. +Each expansion is a cons cell where the `car' is the expansion +and the `cdr' is the number of times the expansion has been +typed." + (let (total cell) + (dolist (expansion abbrev--suggest-saved-recommendations) + (if (not (assoc (car expansion) total)) + (push (cons (car expansion) 1) total) + (setq cell (assoc (car expansion) total)) + (setcdr cell (1+ (cdr cell))))) + total)) + +(defun abbrev-suggest-show-report () + "Show the user a report of abbrevs he could have used." + (interactive) + (let ((totals (abbrev--suggest-get-totals)) + (buf (get-buffer-create "*abbrev-suggest*"))) + (set-buffer buf) + (erase-buffer) + (insert "** Abbrev expansion usage ** + +Below is a list of expansions for which abbrevs are defined, and +the number of times the expansion was typed manually. To display +and edit all abbrevs, type `M-x edit-abbrevs RET'\n\n") + (dolist (expansion totals) + (insert (format " %s: %d\n" (car expansion) (cdr expansion)))) + (display-buffer buf))) + (defun expand-abbrev () "Expand the abbrev before point, if there is an abbrev there. Effective when explicitly called even when `abbrev-mode' is nil. @@ -831,7 +967,9 @@ Calls the value of `abbrev-expand-function' with no argument to do the work, and returns whatever it does. (That return value should be the abbrev symbol if expansion occurred, else nil.)" (interactive) - (funcall abbrev-expand-function)) + (or (funcall abbrev-expand-function) + (if abbrev-suggest + (abbrev--suggest-maybe-suggest)))) (defun abbrev--default-expand () "Default function to use for `abbrev-expand-function'. commit e7012148c0d0e0b0aa87add75ed1e1c6f7eb4d32 Author: Lars Ingebrigtsen Date: Sat Sep 26 17:38:38 2020 +0200 Fix the patch tagging in submit-emacs-patch * lisp/mail/emacsbug.el (submit-emacs-patch): Put the tags in the debbugs pseudo-headers because X-Debbugs-Tags is not a thing that exists. diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index 36d1dc7cac..e48c25436e 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -514,9 +514,13 @@ Message buffer where you can explain more about the patch." (insert "\n\n\n") (emacs-bug--system-description) (mml-attach-file file "text/patch" nil "attachment") - (message-add-header "X-Debbugs-Tags: patch") (message-goto-body) (message "Write a description of the patch and use `C-c C-c' to send it") + (add-hook 'message-send-hook + (lambda () + (message-goto-body) + (insert "Tags: patch\nthanks\n\n")) + t) (message-add-action (lambda () ;; Bury the help buffer (if it's shown). commit 20da487d8b240074f22c145762f0ac9edce20a08 Author: Lars Ingebrigtsen Date: Sat Sep 26 17:33:08 2020 +0200 message-add-action doc string fix * lisp/gnus/message.el (message-add-action): Document types. diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 2ad479b59d..ef010d6e9c 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -4568,7 +4568,8 @@ This function could be useful in `message-setup-hook'." (custom-add-option 'message-setup-hook 'message-check-recipients) (defun message-add-action (action &rest types) - "Add ACTION to be performed when doing an exit of type TYPES." + "Add ACTION to be performed when doing an exit of type TYPES. +Valid types are `send', `return', `exit', `kill' and `postpone'." (while types (add-to-list (intern (format "message-%s-actions" (pop types))) action))) commit 6cc0ff19ddeadeb47d475da1c38490497488355b Author: Mauro Aranda Date: Sat Sep 26 17:09:22 2020 +0200 Display some character widget values in a more user-friendly way * lisp/wid-edit.el (widget-character--escape-sequences-alist): New variable. (widget-character--change-character-display): New function. Use the new variable. (widget-character-notify): New function, to keep track of the changes in the character widget, and display characters like tab, newline and spaces better. (character widget): Use widget-character-notify as the notify function. Use widget-character--change-character-display for the internal representation of value (bug#15925). diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 8e2055f918..0a2ddb0ea1 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1369,7 +1369,8 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." (signal 'text-read-only '("Attempt to change text outside editable field"))) (widget-field-use-before-change - (widget-apply from-field :notify from-field)))))) + (widget-apply from-field :notify + from-field (list 'before-change from to))))))) (defun widget-add-change () (remove-hook 'post-command-hook 'widget-add-change t) @@ -1406,7 +1407,7 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." (> (point) begin)) (delete-char -1))))))) (widget-specify-secret field)) - (widget-apply field :notify field)))) + (widget-apply field :notify field (list 'after-change from to))))) ;;; Widget Functions ;; @@ -3532,13 +3533,70 @@ To use this type, you must define :match or :match-alternatives." :value-to-internal (lambda (_widget value) (if (stringp value) value - (char-to-string value))) + (let ((disp + (widget-character--change-character-display + value))) + (if disp + (propertize (char-to-string value) 'display disp) + (char-to-string value))))) :value-to-external (lambda (_widget value) (if (stringp value) (aref value 0) value)) :match (lambda (_widget value) - (characterp value))) + (characterp value)) + :notify #'widget-character-notify) + +;; Only some escape sequences, not all of them. (Bug#15925) +(defvar widget-character--escape-sequences-alist + '((?\t . ?t) + (?\n . ?n) + (?\s . ?s)) + "Alist that associates escape sequences to a character. +Each element has the form (ESCAPE-SEQUENCE . CHARACTER). + +The character widget uses this alist to display the +non-printable character represented by ESCAPE-SEQUENCE as \\CHARACTER, +since that makes it easier to see what's in the widget.") + +(defun widget-character--change-character-display (c) + "Return a string to represent the character C, or nil. + +The character widget represents some characters (e.g., the newline character +or the tab character) specially, to make it easier for the user to see what's +in it. For those characters, return a string to display that character in a +more user-friendly way. + +For the caller, nil should mean that it is good enough to use the return value +of `char-to-string' for the representation of C." + (let ((char (alist-get c widget-character--escape-sequences-alist))) + (and char (propertize (format "\\%c" char) 'face 'escape-glyph)))) + +(defun widget-character-notify (widget child &optional event) + "Notify function for the character widget. + +This function allows the widget character to better display some characters, +like the newline character or the tab character." + (when (eq (car-safe event) 'after-change) + (let* ((start (nth 1 event)) + (end (nth 2 event)) + str) + (if (eql start end) + (when (char-equal (widget-value widget) ?\s) + ;; The character widget is not really empty: + ;; its value is a single space character. + ;; We need to propertize it again, if it became empty for a while. + (let ((ov (widget-get widget :field-overlay))) + (put-text-property + (overlay-start ov) (overlay-end ov) + 'display (widget-character--change-character-display ?\s)))) + (setq str (buffer-substring-no-properties start end)) + ;; This assumes the user enters one character at a time, + ;; and does nothing crazy, like yanking a long string. + (let ((disp (widget-character--change-character-display (aref str 0)))) + (when disp + (put-text-property start end 'display disp)))))) + (widget-default-notify widget child event)) (define-widget 'list 'group "A Lisp list." commit 9b6f5642274b5b9ca0ad1b2e0e673d92b01fab6e Author: Lars Ingebrigtsen Date: Sat Sep 26 17:05:17 2020 +0200 Make macroexpand of `push' slightly less confusing * lisp/subr.el (push): Use a symbol with a different name to make macroexpand look slightly less confusing (bug#43601). diff --git a/lisp/subr.el b/lisp/subr.el index fba31b7cf7..dd797021f1 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -193,9 +193,9 @@ except that PLACE is evaluated only once (after NEWELT)." (list 'setq place (list 'cons newelt place)) (require 'macroexp) - (macroexp-let2 macroexp-copyable-p v newelt + (macroexp-let2 macroexp-copyable-p x newelt (gv-letplace (getter setter) place - (funcall setter `(cons ,v ,getter)))))) + (funcall setter `(cons ,x ,getter)))))) (defmacro pop (place) "Return the first element of PLACE's value, and remove it from the list. commit 6a067829600b7b2f780d53202cdd618b4dc81fd9 Author: Lars Ingebrigtsen Date: Sat Sep 26 17:02:52 2020 +0200 Fix defcustom types of some variables defined in C * lisp/cus-start.el (standard): Fix the defcustom type of a number of variables defined in C (bug#43611). diff --git a/lisp/cus-start.el b/lisp/cus-start.el index f5b70e082a..3fd6ac031c 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -73,9 +73,11 @@ '(choice (const :tag "Frame default" t) (const :tag "Filled box" box) + (cons :tag "Box with specified size" + (const box) integer) (const :tag "Hollow cursor" hollow) (const :tag "Vertical bar" bar) - (cons :tag "Vertical bar with specified width" + (cons :tag "Vertical bar with specified height" (const bar) integer) (const :tag "Horizontal bar" hbar) (cons :tag "Horizontal bar with specified width" @@ -627,7 +629,9 @@ since it could result in memory overflow and make Emacs crash." (scroll-margin windows integer) (maximum-scroll-margin windows float "26.1") (hscroll-margin windows integer "22.1") - (hscroll-step windows number "22.1") + (hscroll-step windows + (choice (const :tag "Center horizontally" nil) + number) "22.1") (truncate-partial-width-windows display (choice (integer :tag "Truncate if narrower than") @@ -787,7 +791,11 @@ since it could result in memory overflow and make Emacs crash." "27.1" :safe (lambda (value) (or (characterp value) (null value)))) ;; xfaces.c - (scalable-fonts-allowed display boolean "22.1") + (scalable-fonts-allowed + display (choice (const :tag "Don't allow scalable fonts" nil) + (const :tag "Allow any scalable font" t) + (repeat regexp)) + "22.1") ;; xfns.c (x-bitmap-file-path installation (repeat (directory :format "%v"))) commit 18718fee7222dc32b30b7be2e443022db5d82f67 Author: Lars Ingebrigtsen Date: Sat Sep 26 16:36:31 2020 +0200 Fix mouse highlighting in Customize buffers * lisp/wid-edit.el (widget-button-click): Remove a newly-introduced check that made mouse highlights no longer work (bug#43612). It's unclear what the check was trying to fix. diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 8ad99f49aa..8e2055f918 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1057,9 +1057,8 @@ If nothing was called, return non-nil." pos 'button (and (windowp (posn-window start)) (window-buffer (posn-window start)))))) - (when (and (widget-get button :button-overlay) - (or (null button) - (widget-button--check-and-call-button event button))) + (when (or (null button) + (widget-button--check-and-call-button event button)) (let ((up t) command) ;; Mouse click not on a widget button. Find the global commit 2de618ed5d3a160d54c7b5bb69f961e4ff6cc2f7 Author: Harald Jörg Date: Sat Sep 26 15:51:15 2020 +0200 cperl-mode: Delete conditional code where conditions evaluate to nil * lisp/progmodes/cperl-mode.el (cperl-force-face): This macro's single effect is now inlined, and the macro is gone. (cperl-problems): The reference to choose-color.el, which is no longer available for download, is deleted. (no function): A list of unnecessary empty variable definitions is gone. They were needed for Emacs v19 and below. (cperl-init-faces-weak): This function does no longer do anything and is therefore deleted. (cperl-init-faces): Some bodies of conditional code is deleted because as of today the conditions evaluate to constants. The face cperl-nonoverridable-face is no longer available as variable and needs to be doubly-quoted in one place (bug#43622). diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 468ffc949a..6313d015e9 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -82,13 +82,6 @@ (defvar vc-rcs-header) (defvar vc-sccs-header) -(defmacro cperl-force-face (arg descr) ; Takes unquoted arg - `(progn - (or (facep (quote ,arg)) - (make-face ,arg)) - (or (boundp (quote ,arg)) ; We use unquoted variants too - (defvar ,arg (quote ,arg) ,descr)))) - (defun cperl-choose-color (&rest list) (let (answer) (while list @@ -663,10 +656,6 @@ micro-docs on what I know about CPerl problems.") (defvar cperl-problems 'please-ignore-this-line "Description of problems in CPerl mode. -Some faces will not be shown on some versions of Emacs unless you -install choose-color.el, available from - http://ilyaz.org/software/emacs - `fill-paragraph' on a comment may leave the point behind the paragraph. It also triggers a bug in some versions of Emacs (CPerl tries to detect it and bulk out). @@ -1715,10 +1704,9 @@ or as help on variables `cperl-tips', `cperl-problems', (if cperl-hook-after-change (add-hook 'after-change-functions #'cperl-after-change-function nil t)) ;; After hooks since fontification will break this - (if cperl-pod-here-scan - (or cperl-syntaxify-by-font-lock - (progn (or cperl-faces-init (cperl-init-faces-weak)) - (cperl-find-pods-heres)))) + (when (and cperl-pod-here-scan + (not cperl-syntaxify-by-font-lock)) + (cperl-find-pods-heres)) ;; Setup Flymake (add-hook 'flymake-diagnostic-functions #'perl-flymake nil t)) @@ -3262,9 +3250,6 @@ Works before syntax recognition is done." result)) -(defvar font-lock-string-face) -;;(defvar font-lock-reference-face) -(defvar font-lock-constant-face) (defsubst cperl-postpone-fontification (b e type val &optional now) ;; Do after syntactic fontification? (if cperl-syntaxify-by-font-lock @@ -3330,16 +3315,6 @@ Works before syntax recognition is done." (setq end (point))))) (or end pos))))) -;; These are needed for byte-compile (at least with v19) -(defvar cperl-nonoverridable-face) -(defvar font-lock-variable-name-face) -(defvar font-lock-function-name-face) -(defvar font-lock-keyword-face) -(defvar font-lock-builtin-face) -(defvar font-lock-type-face) -(defvar font-lock-comment-face) -(defvar font-lock-warning-face) - (defun cperl-find-sub-attrs (&optional st-l b-fname e-fname pos) "Syntactically mark (and fontify) attributes of a subroutine. Should be called with the point before leading colon of an attribute." @@ -5474,17 +5449,6 @@ indentation and initial hashes. Behaves usually outside of comment." (or cperl-faces-init (cperl-init-faces)) cperl-font-lock-keywords-2) -(defun cperl-init-faces-weak () - ;; Allow `cperl-find-pods-heres' to run. - (or (boundp 'font-lock-constant-face) - (cperl-force-face font-lock-constant-face - "Face for constant and label names")) - (or (boundp 'font-lock-warning-face) - (cperl-force-face font-lock-warning-face - "Face for things which should stand out")) - ;;(setq font-lock-constant-face 'font-lock-constant-face) - ) - (defun cperl-init-faces () (condition-case errs (progn @@ -5612,7 +5576,7 @@ indentation and initial hashes. Behaves usually outside of comment." "wh\\(en\\|ile\\)\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually "\\|[sm]" ; Added manually "\\)\\>") - 2 'cperl-nonoverridable-face) + 2 ''cperl-nonoverridable-face) ; unbound as var, so: doubly quoted ;; (mapconcat #'identity ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" ;; "#include" "#define" "#undef") @@ -5648,11 +5612,7 @@ indentation and initial hashes. Behaves usually outside of comment." 2 font-lock-function-name-face) '("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$" 1 font-lock-function-name-face) - (cond ((featurep 'font-lock-extra) - '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" - (2 font-lock-string-face t) - (0 '(restart 2 t)))) ; To highlight $a{bc}{ef} - (font-lock-anchored + (cond (font-lock-anchored '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" (2 font-lock-string-face t) ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" @@ -5670,15 +5630,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face) ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)" ;;; (2 (cons font-lock-variable-name-face '(underline)))) - (cond ((featurep 'font-lock-extra) - '("^[ \t]*\\(state\\|my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" - (3 font-lock-variable-name-face) - (4 '(another 4 nil - ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" - (1 font-lock-variable-name-face) - (2 '(restart 2 nil) nil t))) - nil t))) ; local variables, multiple - (font-lock-anchored + (cond (font-lock-anchored ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var `(,(concat "\\<\\(state\\|my\\|local\\|our\\)" cperl-maybe-white-and-comment-rex @@ -5780,164 +5732,6 @@ indentation and initial hashes. Behaves usually outside of comment." t-font-lock-keywords-1 cperl-font-lock-keywords-1))) (if (fboundp 'ps-print-buffer) (cperl-ps-print-init)) - (if (or (featurep 'choose-color) (featurep 'font-lock-extra)) - (eval ; Avoid a warning - '(font-lock-require-faces - (list - ;; Color-light Color-dark Gray-light Gray-dark Mono - (list 'font-lock-comment-face - ["Firebrick" "OrangeRed" "DimGray" "Gray80"] - nil - [nil nil t t t] - [nil nil t t t] - nil) - (list 'font-lock-string-face - ["RosyBrown" "LightSalmon" "Gray50" "LightGray"] - nil - nil - [nil nil t t t] - nil) - (list 'font-lock-function-name-face - (vector - "Blue" "LightSkyBlue" "Gray50" "LightGray" - (cdr (assq 'background-color ; if mono - (frame-parameters)))) - (vector - nil nil nil nil - (cdr (assq 'foreground-color ; if mono - (frame-parameters)))) - [nil nil t t t] - nil - nil) - (list 'font-lock-variable-name-face - ["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"] - nil - [nil nil t t t] - [nil nil t t t] - nil) - (list 'font-lock-type-face - ["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"] - nil - [nil nil t t t] - nil - [nil nil t t t]) - (list 'font-lock-warning-face - ["Pink" "Red" "Gray50" "LightGray"] - ["gray20" "gray90" - "gray80" "gray20"] - [nil nil t t t] - nil - [nil nil t t t] - ) - (list 'font-lock-constant-face - ["CadetBlue" "Aquamarine" "Gray50" "LightGray"] - nil - [nil nil t t t] - nil - [nil nil t t t]) - (list 'cperl-nonoverridable-face - ["chartreuse3" ("orchid1" "orange") - nil "Gray80"] - [nil nil "gray90"] - [nil nil nil t t] - [nil nil t t] - [nil nil t t t]) - (list 'cperl-array-face - ["blue" "yellow" nil "Gray80"] - ["lightyellow2" ("navy" "os2blue" "darkgreen") - "gray90"] - t - nil - nil) - (list 'cperl-hash-face - ["red" "red" nil "Gray80"] - ["lightyellow2" ("navy" "os2blue" "darkgreen") - "gray90"] - t - t - nil)))) - ;; Do it the dull way, without choose-color - (cperl-force-face font-lock-constant-face - "Face for constant and label names") - (cperl-force-face font-lock-variable-name-face - "Face for variable names") - (cperl-force-face font-lock-type-face - "Face for data types") - (cperl-force-face cperl-nonoverridable-face - "Face for data types from another group") - (cperl-force-face font-lock-warning-face - "Face for things which should stand out") - (cperl-force-face font-lock-comment-face - "Face for comments") - (cperl-force-face font-lock-function-name-face - "Face for function names") - ;;(defvar font-lock-constant-face 'font-lock-constant-face) - ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face) - ;;(or (boundp 'font-lock-type-face) - ;; (defconst font-lock-type-face - ;; 'font-lock-type-face - ;; "Face to use for data types.")) - ;;(or (boundp 'cperl-nonoverridable-face) - ;; (defconst cperl-nonoverridable-face - ;; 'cperl-nonoverridable-face - ;; "Face to use for data types from another group.")) - (if (and - (not (facep 'cperl-array-face)) - (facep 'font-lock-emphasized-face)) - (copy-face 'font-lock-emphasized-face 'cperl-array-face)) - (if (and - (not (facep 'cperl-hash-face)) - (facep 'font-lock-other-emphasized-face)) - (copy-face 'font-lock-other-emphasized-face 'cperl-hash-face)) - (if (and - (not (facep 'cperl-nonoverridable-face)) - (facep 'font-lock-other-type-face)) - (copy-face 'font-lock-other-type-face 'cperl-nonoverridable-face)) - ;;(or (boundp 'cperl-hash-face) - ;; (defconst cperl-hash-face - ;; 'cperl-hash-face - ;; "Face to use for hashes.")) - ;;(or (boundp 'cperl-array-face) - ;; (defconst cperl-array-face - ;; 'cperl-array-face - ;; "Face to use for arrays.")) - (let ((background 'light)) - (and (not (facep 'font-lock-constant-face)) - (facep 'font-lock-reference-face) - (copy-face 'font-lock-reference-face 'font-lock-constant-face)) - (if (facep 'font-lock-type-face) nil - (copy-face 'default 'font-lock-type-face) - (cond - ((eq background 'light) - (set-face-foreground 'font-lock-type-face - (if (x-color-defined-p "seagreen") - "seagreen" - "sea green"))) - ((eq background 'dark) - (set-face-foreground 'font-lock-type-face - (if (x-color-defined-p "os2pink") - "os2pink" - "pink"))) - (t - (set-face-background 'font-lock-type-face "gray90")))) - (if (facep 'cperl-nonoverridable-face) - nil - (copy-face 'font-lock-type-face 'cperl-nonoverridable-face) - (cond - ((eq background 'light) - (set-face-foreground 'cperl-nonoverridable-face - (if (x-color-defined-p "chartreuse3") - "chartreuse3" - "chartreuse"))) - ((eq background 'dark) - (set-face-foreground 'cperl-nonoverridable-face - (if (x-color-defined-p "orchid1") - "orchid1" - "orange"))))) - (if (facep 'font-lock-variable-name-face) nil - (copy-face 'italic 'font-lock-variable-name-face)) - (if (facep 'font-lock-constant-face) nil - (copy-face 'italic 'font-lock-constant-face)))) (setq cperl-faces-init t)) (error (message "cperl-init-faces (ignored): %s" errs)))) commit e00936bf9f10cf44e1df71a7a11afd770e8a122a Author: Stefan Kangas Date: Sat Sep 26 11:34:20 2020 +0200 Silence some byte-compiler warnings * test/lisp/arc-mode-tests.el (arc-mode-test-archive-int-to-mode): * test/lisp/custom-tests.el (cus-test-opts): * test/lisp/help-fns-tests.el (foo-test-map) (help-fns-test--describe-keymap-foo): * test/src/fns-tests.el (w32-collate-ignore-punctuation) (fns-tests-func-arity): Silence byte-compiler warnings. diff --git a/test/lisp/arc-mode-tests.el b/test/lisp/arc-mode-tests.el index 22ca7e2ec5..e92a4d28c6 100644 --- a/test/lisp/arc-mode-tests.el +++ b/test/lisp/arc-mode-tests.el @@ -32,7 +32,7 @@ (cons 1024 "------S---") ; Bug#28092 (cons 2048 "---S------")))) (dolist (x alist) - (should (equal (cdr x) (archive-int-to-mode (car x))))))) + (should (equal (cdr x) (file-modes-number-to-symbolic (car x))))))) (ert-deftest arc-mode-test-zip-extract-gz () (skip-unless (and archive-zip-extract (executable-find (car archive-zip-extract)))) diff --git a/test/lisp/custom-tests.el b/test/lisp/custom-tests.el index 07f626fd65..76661dc13b 100644 --- a/test/lisp/custom-tests.el +++ b/test/lisp/custom-tests.el @@ -150,6 +150,8 @@ (defconst custom-test-admin-cus-test (expand-file-name "admin/cus-test.el" source-directory)) +(declare-function cus-test-opts custom-test-admin-cus-test) + (ert-deftest check-for-wrong-custom-types () :tags '(:expensive-test) (skip-unless (file-readable-p custom-test-admin-cus-test)) diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index da2b49e6b8..811b367791 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -123,6 +123,9 @@ Return first line of the output of (describe-function-1 FUNC)." (goto-char (point-min)) (should (looking-at "^font-lock-comment-face is ")))) +(defvar foo-test-map) +(defvar help-fns-test--describe-keymap-foo) + ;;; Tests for describe-keymap (ert-deftest help-fns-test-find-keymap-name () diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 323743d842..f2e1a268b0 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -166,6 +166,8 @@ (should (equal (should-error (sort "cba" #'<) :type 'wrong-type-argument) '(wrong-type-argument list-or-vector-p "cba")))) +(defvar w32-collate-ignore-punctuation) + (ert-deftest fns-tests-collate-sort () (skip-unless (fns-tests--collate-enabled-p)) @@ -228,9 +230,9 @@ (should (equal (func-arity 'format) '(1 . many))) (require 'info) (should (equal (func-arity 'Info-goto-node) '(1 . 3))) - (should (equal (func-arity (lambda (&rest x))) '(0 . many))) - (should (equal (func-arity (eval '(lambda (x &optional y)) nil)) '(1 . 2))) - (should (equal (func-arity (eval '(lambda (x &optional y)) t)) '(1 . 2))) + (should (equal (func-arity (lambda (&rest _x))) '(0 . many))) + (should (equal (func-arity (eval '(lambda (_x &optional y)) nil)) '(1 . 2))) + (should (equal (func-arity (eval '(lambda (_x &optional y)) t)) '(1 . 2))) (should (equal (func-arity 'let) '(1 . unevalled)))) (defun fns-tests--string-repeat (s o) commit 2dff3ea073c4118d79308178dcb3bd7bb1bb8237 Author: Stefan Kangas Date: Sat Sep 26 11:27:48 2020 +0200 Repurpose libxml test for obsolete argument * test/src/xml-tests.el (libxml-tests): Move half this test for the recently obsoleted fourth argument to libxml-parse-xml-region... * test/lisp/xml-tests.el (xml-tests--remove-comments): ...to a new test here for xml-remove-comments. * test/src/xml-tests.el (libxml-tests--data-comments-discarded): Move test data from here... * test/lisp/xml-tests.el (xml-tests--data-with-comments): ...to here. diff --git a/test/lisp/xml-tests.el b/test/lisp/xml-tests.el index 72c78d00e3..d09336c008 100644 --- a/test/lisp/xml-tests.el +++ b/test/lisp/xml-tests.el @@ -174,6 +174,27 @@ Parser is called with and without 'symbol-qnames argument.") :type 'xml-invalid-character) '(xml-invalid-character #x3FFFFF 3))))) +(defvar xml-tests--data-with-comments + `(;; simple case + ("bar" + . ((foo ((baz . "true")) "bar"))) + ;; toplevel comments -- first document child must not get lost + (,(concat "bar" + "") + . ((foo nil "bar"))) + (,(concat "" + "blub") + . ((foo ((a . "b")) (bar nil "blub"))))) + "Alist of XML strings and their expected parse trees for discarded comments.") + +(ert-deftest xml-remove-comments () + (dolist (test xml-tests--data-with-comments) + (erase-buffer) + (insert (car test)) + (xml-remove-comments (point-min) (point-max)) + (should (equal (cdr test) + (xml-parse-region (point-min) (point-max)))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/src/xml-tests.el b/test/src/xml-tests.el index d758c8868c..800f400b3c 100644 --- a/test/src/xml-tests.el +++ b/test/src/xml-tests.el @@ -42,20 +42,6 @@ (comment nil "comment-b") (comment nil "comment-c")))) "Alist of XML strings and their expected parse trees for preserved comments.") -(defvar libxml-tests--data-comments-discarded - `(;; simple case - ("bar" - . (foo ((baz . "true")) "bar")) - ;; toplevel comments -- first document child must not get lost - (,(concat "bar" - "") - . (foo nil "bar")) - (,(concat "" - "blub") - . (foo ((a . "b")) (bar nil "blub")))) - "Alist of XML strings and their expected parse trees for discarded comments.") - - (ert-deftest libxml-tests () "Test libxml." (when (fboundp 'libxml-parse-xml-region) @@ -64,11 +50,6 @@ (erase-buffer) (insert (car test)) (should (equal (cdr test) - (libxml-parse-xml-region (point-min) (point-max))))) - (dolist (test libxml-tests--data-comments-discarded) - (erase-buffer) - (insert (car test)) - (should (equal (cdr test) - (libxml-parse-xml-region (point-min) (point-max) nil t))))))) + (libxml-parse-xml-region (point-min) (point-max)))))))) ;;; libxml-tests.el ends here commit a3a845b0e00bbdd1bcf05882560bca15e57488cc Author: Michael Albinus Date: Sat Sep 26 11:38:53 2020 +0200 * etc/NEWS: Add new D-Bus monitor functionality. Fix typos. diff --git a/etc/NEWS b/etc/NEWS index 4cd40c3657..d3a97489d4 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -219,9 +219,10 @@ trying to be non-destructive. * Changes in Specialized Modes and Packages in Emacs 28.1 ** Ruby mode -*** 'ruby-use-smie' is declared obsolete -SMIE is now always enabled and only 'ruby-use-smie' only controls -whether indentation is done using SMIE or with the old ad-hoc code. + +*** 'ruby-use-smie' is declared obsolete. +SMIE is now always enabled and 'ruby-use-smie' only controls whether +indentation is done using SMIE or with the old ad-hoc code. --- ** Specific warnings can now be disabled from the warning buffer. @@ -487,7 +488,7 @@ 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. +*** New command to start Emacs in Message mode to send an email. Emacs can be defined as a handler for the "x-scheme-handler/mailto" MIME type with the following command: "emacs -f message-mailto %u". An "emacs-mail.desktop" file has been included, suitable for @@ -570,7 +571,7 @@ definition. *** New user option 'eldoc-display-truncation-message'. If non-nil (the default), eldoc will display a message saying something like "(Documentation truncated. Use `M-x eldoc-doc-buffer' -to see rest" when a message has been truncated. If nil, truncated +to see rest)" when a message has been truncated. If nil, truncated messages will be marked with just "..." at the end. +++ @@ -652,7 +653,7 @@ equivalent to '(map (:sym sym))'. ** Package +++ -*** New functions to filter the package list. +*** New commands to filter the package list. The filter command key bindings are as follows: key binding @@ -812,12 +813,12 @@ Formerly, one could do the same by setting 'browse-url-browser-function' to such an alist. This usage is still supported but deprecated. -*** Categorization of browsing functions in internal vs. external. -All standard browsing functions such as 'browse-url-firefox', +*** Categorization of browsing commands in internal vs. external. +All standard browsing commands such as 'browse-url-firefox', 'browse-url-mail', or 'eww' have been categorized into internal (URL is browsed in Emacs) or external (an external application is spawned with the URL). This is done by adding a 'browse-url-browser-kind' -symbol property to the browsing functions. With a new command +symbol property to the browsing commands. With a new command 'browse-url-with-browser-kind', an URL can explicitly be browsed with either an internal or external browser. @@ -896,7 +897,7 @@ This can be used to download data via an external command. If nil (the default), then 'url-retrieve' is used. +++ -*** New Emacs command line convenience function. +*** New Emacs command line convenience command. The 'eww-browse' command has been added, which allows you to register Emacs as a MIME handler for "text/x-uri", and will call 'eww' on the supplied URL. Usage example: "emacs -f eww-browse https://gnu.org". @@ -1075,7 +1076,7 @@ keystrokes. *** Interactive regular expression search now uses faces for sub-groups. E.g., 'C-M-s foo-\([0-9]+\)' will now use the 'isearch-group-1' face on the part of the regexp that matches the sub-expression "[0-9]+". -This is controlled by the 'search-highlight-submatches' variable. +This is controlled by the 'search-highlight-submatches' user option. --- *** New user option 'reveal-auto-hide'. @@ -1177,7 +1178,7 @@ to 'tab-bar-new-tab-choice' for new tabs to show the bookmark list. ** xwidget-webkit mode -*** New xwidget functions. +*** New xwidget commands. 'xwidget-webkit-uri' (return the current URL), 'xwidget-webkit-title' (return the current title), and 'xwidget-webkit-goto-history' (goto a point in history). @@ -1219,7 +1220,7 @@ Clicking the dictionary name changes the current dictionary. several time zones. It is hoped that the new names are more discoverable. -The following functions have been renamed: +The following commands have been renamed: 'display-time-world' to 'world-clock' 'display-time-world-mode' to 'world-clock-mode' @@ -1254,7 +1255,13 @@ type symbols. Both functions propagate D-Bus errors. messages, contain the error name of that message now. --- -*** D-Bus events keep the type information of their arguments. +*** D-Bus messages can be monitored with new function 'dbus-register-monitor'. + +--- +*** D-Bus events have changed their internal structure. +They carry now the destination and the error-name of an event. They +also keep the type information of their arguments. Use the +'dbus-event-*' accessor functions. ** CPerl Mode @@ -1296,7 +1303,6 @@ directory instead of the default directory. * Incompatible Lisp Changes in Emacs 28.1 - ** 'set-process-buffer' now updates the process mark. The mark will be set to point to the end of the new buffer. commit c540f3323da96eadf41ccfa4e23ec2a5124343b8 Author: Michael Albinus Date: Sat Sep 26 11:38:23 2020 +0200 Add D-Bus monitor * lisp/net/dbus.el (dbus-interface-monitoring): New defconst. (dbus-call-method, dbus-call-method-asynchronously) (dbus-send-signal, dbus-method-return-internal) (dbus-method-error-internal, dbus-check-arguments): Accept also :system-private and :session-private. (dbus-check-event, dbus-event-path-name) (dbus-event-interface-name) (dbus-event-member-name, dbus-property-handler) (dbus-handle-bus-disconnect): Adapt according to new structure. (dbus-handle-event): Handle also monitor events. (dbus-event-destination-name, dbus-event-handler) (dbus-event-arguments, dbus-register-monitor, dbus-monitor-handler): New defuns. * src/dbusbind.c (XD_DBUS_VALIDATE_BUS_ADDRESS, xd_remove_watch) (Fdbus__init_bus): Accept also :system-private and :session-private. (xd_read_message_1): Add destination and error_name to dbus-event. Handle monitor events. (syms_of_dbusbind): Declare QCsystem_private, QCsession_private and QCmonitor. (dbus-registered-objects-table): Fix docstring. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 86db7cbf18..da47e5bc7f 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -144,6 +144,17 @@ See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter ;; ;; +(defconst dbus-interface-monitoring (concat dbus-interface-dbus ".Monitoring") + "The monitoring interface. +See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#bus-messages-become-monitor'.") + +;; +;; +;; +;; ;; Not used, must be 0. +;; +;; + (defconst dbus-interface-local (concat dbus-interface-dbus ".Local") "An interface whose methods can only be invoked by the local implementation.") @@ -336,7 +347,8 @@ object is returned instead of a list containing this single Lisp object. (or (featurep 'dbusbind) (signal 'dbus-error (list "Emacs not compiled with dbus support"))) - (or (memq bus '(:system :session)) (stringp bus) + (or (memq bus '(:system :session :system-private :session-private)) + (stringp bus) (signal 'wrong-type-argument (list 'keywordp bus))) (or (stringp service) (signal 'wrong-type-argument (list 'stringp service))) @@ -440,7 +452,8 @@ Example: (or (featurep 'dbusbind) (signal 'dbus-error (list "Emacs not compiled with dbus support"))) - (or (memq bus '(:system :session)) (stringp bus) + (or (memq bus '(:system :session :system-private :session-private)) + (stringp bus) (signal 'wrong-type-argument (list 'keywordp bus))) (or (stringp service) (signal 'wrong-type-argument (list 'stringp service))) @@ -490,7 +503,8 @@ Example: (or (featurep 'dbusbind) (signal 'dbus-error (list "Emacs not compiled with dbus support"))) - (or (memq bus '(:system :session)) (stringp bus) + (or (memq bus '(:system :session :system-private :session-private)) + (stringp bus) (signal 'wrong-type-argument (list 'keywordp bus))) (or (null service) (stringp service) (signal 'wrong-type-argument (list 'stringp service))) @@ -510,7 +524,8 @@ This is an internal function, it shall not be used outside dbus.el." (or (featurep 'dbusbind) (signal 'dbus-error (list "Emacs not compiled with dbus support"))) - (or (memq bus '(:system :session)) (stringp bus) + (or (memq bus '(:system :session :system-private :session-private)) + (stringp bus) (signal 'wrong-type-argument (list 'keywordp bus))) (or (stringp service) (signal 'wrong-type-argument (list 'stringp service))) @@ -527,7 +542,8 @@ This is an internal function, it shall not be used outside dbus.el." (or (featurep 'dbusbind) (signal 'dbus-error (list "Emacs not compiled with dbus support"))) - (or (memq bus '(:system :session)) (stringp bus) + (or (memq bus '(:system :session :system-private :session-private)) + (stringp bus) (signal 'wrong-type-argument (list 'keywordp bus))) (or (stringp service) (signal 'wrong-type-argument (list 'stringp service))) @@ -545,7 +561,8 @@ This is an internal function, it shall not be used outside dbus.el." (or (featurep 'dbusbind) (signal 'dbus-error (list "Emacs not compiled with dbus support"))) - (or (memq bus '(:system :session)) (stringp bus) + (or (memq bus '(:system :session :system-private :session-private)) + (stringp bus) (signal 'wrong-type-argument (list 'keywordp bus))) (or (stringp service) (signal 'wrong-type-argument (list 'stringp service))) @@ -1018,19 +1035,29 @@ STRING must have been encoded with `dbus-escape-as-identifier'." "Check whether EVENT is a well formed D-Bus event. EVENT is a list which starts with symbol `dbus-event': - (dbus-event BUS TYPE SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS) + (dbus-event BUS TYPE SERIAL SERVICE DESTINATION PATH + INTERFACE MEMBER HANDLER &rest ARGS) BUS identifies the D-Bus the message is coming from. It is -either a Lisp symbol, `:system' or `:session', or a string -denoting the bus address. TYPE is the D-Bus message type which -has caused the event, SERIAL is the serial number of the received -D-Bus message. SERVICE and PATH are the unique name and the -object path of the D-Bus object emitting the message. INTERFACE -and MEMBER denote the message which has been sent. HANDLER is -the function which has been registered for this message. ARGS -are the typed arguments as returned from the message. They are -passed to HANDLER without type information, when it is called -during event handling in `dbus-handle-event'. +either a Lisp symbol, `:system', `:session', `:systemp-private' +or `:session-private', or a string denoting the bus address. + +TYPE is the D-Bus message type which has caused the event, SERIAL +is the serial number of the received D-Bus message when TYPE is +equal `dbus-message-type-method-return' or `dbus-message-type-error'. + +SERVICE and PATH are the unique name and the object path of the +D-Bus object emitting the message. DESTINATION is the D-Bus name +the message is dedicated to, or nil in case thje message is a +broadcast signal. + +INTERFACE and MEMBER denote the message which has been sent. +When TYPE is `dbus-message-type-error', MEMBER is the error name. + +HANDLER is the function which has been registered for this +message. ARGS are the typed arguments as returned from the +message. They are passed to HANDLER without type information, +when it is called during event handling in `dbus-handle-event'. This function signals a `dbus-error' if the event is not well formed." @@ -1038,7 +1065,7 @@ formed." (unless (and (listp event) (eq (car event) 'dbus-event) ;; Bus symbol. - (or (symbolp (nth 1 event)) + (or (keywordp (nth 1 event)) (stringp (nth 1 event))) ;; Type. (and (natnump (nth 2 event)) @@ -1050,20 +1077,26 @@ formed." (= dbus-message-type-error (nth 2 event)) (or (stringp (nth 4 event)) (null (nth 4 event)))) - ;; Object path. + ;; Destination. (or (= dbus-message-type-method-return (nth 2 event)) (= dbus-message-type-error (nth 2 event)) - (stringp (nth 5 event))) - ;; Interface. + (or (stringp (nth 5 event)) + (null (nth 5 event)))) + ;; Object path. (or (= dbus-message-type-method-return (nth 2 event)) (= dbus-message-type-error (nth 2 event)) (stringp (nth 6 event))) - ;; Member. + ;; Interface. (or (= dbus-message-type-method-return (nth 2 event)) (= dbus-message-type-error (nth 2 event)) (stringp (nth 7 event))) + ;; Member. + (or (= dbus-message-type-method-return (nth 2 event)) + (stringp (nth 8 event))) ;; Handler. - (functionp (nth 8 event))) + (functionp (nth 9 event)) + ;; Arguments. + (listp (nthcdr 10 event))) (signal 'dbus-error (list "Not a valid D-Bus event" event)))) (defun dbus-delete-types (&rest args) @@ -1103,28 +1136,36 @@ part of the event, is called with arguments ARGS (without type information). If the HANDLER returns a `dbus-error', it is propagated as return message." (interactive "e") (condition-case err - (let (args result) + (let (monitor args result) ;; We ignore not well-formed events. (dbus-check-event event) ;; Remove type information. - (setq args (mapcar #'dbus-delete-types (nthcdr 9 event))) - ;; Error messages must be propagated. - (when (= dbus-message-type-error (nth 2 event)) - (signal 'dbus-error args)) - ;; Apply the handler. - (setq result (apply (nth 8 event) args)) - ;; Return an (error) message when it is a message call. - (when (= dbus-message-type-method-call (nth 2 event)) - (dbus-ignore-errors - (if (eq (car-safe result) :error) - (apply #'dbus-method-error-internal - (nth 1 event) (nth 4 event) (nth 3 event) (cdr result)) - (if (eq result :ignore) - (dbus-method-return-internal - (nth 1 event) (nth 4 event) (nth 3 event)) - (apply #'dbus-method-return-internal - (nth 1 event) (nth 4 event) (nth 3 event) - (if (consp result) result (list result)))))))) + (setq args (mapcar #'dbus-delete-types (nthcdr 10 event))) + (setq monitor + (gethash + (list :monitor (nth 1 event)) dbus-registered-objects-table)) + (if monitor + ;; A monitor event shall not trigger other operations, and + ;; it shall not trigger D-Bus errors. + (setq result (dbus-ignore-errors (apply (nth 9 event) args))) + ;; Error messages must be propagated. The error name is in + ;; the member slot. + (when (= dbus-message-type-error (nth 2 event)) + (signal 'dbus-error (cons (nth 8 event) args))) + ;; Apply the handler. + (setq result (apply (nth 9 event) args)) + ;; Return an (error) message when it is a message call. + (when (= dbus-message-type-method-call (nth 2 event)) + (dbus-ignore-errors + (if (eq (car-safe result) :error) + (apply #'dbus-method-error-internal + (nth 1 event) (nth 4 event) (nth 3 event) (cdr result)) + (if (eq result :ignore) + (dbus-method-return-internal + (nth 1 event) (nth 4 event) (nth 3 event)) + (apply #'dbus-method-return-internal + (nth 1 event) (nth 4 event) (nth 3 event) + (if (consp result) result (list result))))))))) ;; Error handling. (dbus-error ;; Return an error message when it is a message call. @@ -1172,13 +1213,21 @@ formed." (dbus-check-event event) (nth 4 event)) +(defun dbus-event-destination-name (event) + "Return the name of the D-Bus object the event is dedicated to. +The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. +This function signals a `dbus-error' if the event is not well +formed." + (dbus-check-event event) + (nth 5 event)) + (defun dbus-event-path-name (event) "Return the object path of the D-Bus object the event is coming from. The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. This function signals a `dbus-error' if the event is not well formed." (dbus-check-event event) - (nth 5 event)) + (nth 6 event)) (defun dbus-event-interface-name (event) "Return the interface name of the D-Bus object the event is coming from. @@ -1186,15 +1235,32 @@ The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. This function signals a `dbus-error' if the event is not well formed." (dbus-check-event event) - (nth 6 event)) + (nth 7 event)) (defun dbus-event-member-name (event) "Return the member name the event is coming from. -It is either a signal name or a method name. The result is a -string. EVENT is a D-Bus event, see `dbus-check-event'. This -function signals a `dbus-error' if the event is not well formed." +It is either a signal name, a method name or an error name. The +result is a string. EVENT is a D-Bus event, see +`dbus-check-event'. This function signals a `dbus-error' if the +event is not well formed." (dbus-check-event event) - (nth 7 event)) + (nth 8 event)) + +(defun dbus-event-handler (event) + "Return the handler the event is applied with. +The result is a function. EVENT is a D-Bus event, see +`dbus-check-event'. This function signals a `dbus-error' if the +event is not well formed." + (dbus-check-event event) + (nth 9 event)) + +(defun dbus-event-arguments (event) + "Return the arguments the event is carrying on. +The result is a list of arguments. EVENT is a D-Bus event, see +`dbus-check-event'. This function signals a `dbus-error' if the +event is not well formed." + (dbus-check-event event) + (nthcdr 10 event)) ;;; D-Bus registered names. @@ -1717,7 +1783,7 @@ It will be registered for all objects created by `dbus-register-property'." ;; "Set" needs the third typed argument from `last-input-event'. ((string-equal method "Set") - (let* ((value (dbus-flatten-types (nth 11 last-input-event))) + (let* ((value (dbus-flatten-types (nth 12 last-input-event))) (entry (dbus-get-this-registered-property bus service path interface property)) (object (car (last (car entry))))) @@ -1907,13 +1973,123 @@ It will be registered for all objects created by `dbus-register-service'." result) '(:signature "{oa{sa{sv}}}")))))) +(defun dbus-register-monitor + (bus &optional service path interface member handler &rest args) + "Register HANDLER for monitor events on the D-Bus BUS. + +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. + +SERVICE is the D-Bus service name of the D-Bus. It must be a +known name (see discussion of DONT-REGISTER-SERVICE below). + +PATH is the D-Bus object path SERVICE is registered at (see +discussion of DONT-REGISTER-SERVICE below). INTERFACE is the +name of the interface used at PATH. MEMBER is either a method +name, a signal name, or an error name. + +HANDLER is the function to be called when a monitor event +arrives. If nil, the default handler `dbus-monitor-handler' is +applied. It is called with ARGS as arguments." + + (let ((bus-private (if (eq bus :system) :system-private + (if (eq bus :session) :session-private bus))) + keyword type rule1 rule2 key key1 value) + (unless handler (setq handler #'dbus-monitor-handler)) + ;; Read arguments. + (while args + (when (keywordp (setq keyword (pop args))) + (cond + ((eq :type keyword) + ;; Must be "signal", "method_call", "method_return", or "error". + (setq type (pop args)))))) + ;; Compose rules. + (setq rule1 + (or + (string-join + (delq nil + (list (when service (format "sender='%s'" service)) + (when path (format "path='%s'" path)) + (when interface (format "interface='%s'" interface)) + (when member (format "member='%s'" member)) + (when type (format "type='%s'" type)))) + ",") + "") + rule2 + (when service + (string-join + (delq nil + (list (format "destination='%s'" service) + (when path (format "path='%s'" path)) + (when interface (format "interface='%s'" interface)) + (when member (format "member='%s'" member)) + (when type (format "type='%s'" type)))) + ","))) + + (unless (ignore-errors (dbus-get-unique-name bus-private)) + (dbus-init-bus bus 'private)) + (dbus-call-method + bus-private dbus-service-dbus dbus-path-dbus dbus-interface-monitoring + "BecomeMonitor" + (append `(:array :string ,rule1) (when rule2 `(:string ,rule2))) + :uint32 0) + + (when dbus-debug (message "Matching rule \"%s\" created" rule1)) + + ;; Create a hash table entry. + (setq key (list :monitor bus-private) + key1 (list nil nil nil handler) + value (gethash key dbus-registered-objects-table)) + (unless (member key1 value) + (puthash key (cons key1 value) dbus-registered-objects-table)) + + (when dbus-debug (message "%s" dbus-registered-objects-table)) + + ;; Return the object. + (list key (list service path handler)))) + +(defun dbus-monitor-handler (&rest _args) + "Default handler for the \"org.freedesktop.DBus.Monitoring.BecomeMonitor\" interface. +It will be applied all objects created by `dbus-register-monitor'." + (with-current-buffer (get-buffer-create "*D-Bus Monitor*") + (special-mode) + (let* ((inhibit-read-only t) + (eobp (eobp)) + (event last-input-event) + (type (dbus-event-message-type event)) + (sender (dbus-event-service-name event)) + (destination (dbus-event-destination-name event)) + (serial (dbus-event-serial-number event)) + (path (dbus-event-path-name event)) + (interface (dbus-event-interface-name event)) + (member (dbus-event-member-name event)) + (arguments (dbus-event-arguments event))) + (save-excursion + (goto-char (point-max)) + (insert + (format + (concat + "%s sender=%s -> destination=%s serial=%s " + "path=%s interface=%s member=%s\n") + (cond + ((= type dbus-message-type-method-call) "method-call") + ((= type dbus-message-type-method-return) "method-return") + ((= type dbus-message-type-error) "error") + ((= type dbus-message-type-signal) "signal")) + sender destination serial path interface member)) + (dolist (arg arguments) + (pp (dbus-flatten-types arg) (current-buffer))) + (insert "\n")) + (when eobp + (goto-char (point-max)))))) + (defun dbus-handle-bus-disconnect () "React to a bus disconnection. BUS is the bus that disconnected. This routine unregisters all handlers on the given bus and causes all synchronous calls pending at the time of disconnect to fail." (let ((bus (dbus-event-bus-name last-input-event)) - (keys-to-remove)) + keys-to-remove) (maphash (lambda (key value) (when (and (eq (nth 0 key) :serial) @@ -1923,13 +2099,14 @@ pending at the time of disconnect to fail." (list 'dbus-event bus dbus-message-type-error - (nth 2 key) - nil - nil - nil - nil - value) - (list 'dbus-error "Bus disconnected" bus)) + (nth 2 key) ; serial + nil ; service + nil ; destination + nil ; path + nil ; interface + nil ; member + value) ; handler + (list 'dbus-error dbus-error-disconnected "Bus disconnected" bus)) (push key keys-to-remove))) dbus-registered-objects-table) (dolist (key keys-to-remove) @@ -1980,13 +2157,9 @@ this connection to those buses." ;;; TODO: -;; * Check property type in org.freedesktop.DBus.Properties.Set. -;; ;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and ;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved. ;; -;; * Implement org.freedesktop.DBus.Monitoring.BecomeMonitor. -;; ;; * Cache introspection data. ;; ;; * Run handlers in own threads. diff --git a/src/dbusbind.c b/src/dbusbind.c index 4c5ab48580..09f0317be9 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -44,7 +44,10 @@ along with GNU Emacs. If not, see . */ /* Alist of D-Bus buses we are polling for messages. The key is the symbol or string of the bus, and the value is the - connection address. */ + connection address. For every bus, just one connection is counted. + If there shall be a second connection to the same bus, a different + symbol or string for the bus must be chosen. On Lisp level, a bus + stands for the associated connection. */ static Lisp_Object xd_registered_buses; /* Whether we are reading a D-Bus event. */ @@ -279,10 +282,13 @@ XD_OBJECT_TO_STRING (Lisp_Object object) else \ { \ CHECK_SYMBOL (bus); \ - if (!(EQ (bus, QCsystem) || EQ (bus, QCsession))) \ + if (!(EQ (bus, QCsystem) || EQ (bus, QCsession) \ + || EQ (bus, QCsystem_private) \ + || EQ (bus, QCsession_private))) \ XD_SIGNAL2 (build_string ("Wrong bus name"), bus); \ /* We do not want to have an autolaunch for the session bus. */ \ - if (EQ (bus, QCsession) && session_bus_address == NULL) \ + if ((EQ (bus, QCsession) || EQ (bus, QCsession_private)) \ + && session_bus_address == NULL) \ XD_SIGNAL2 (build_string ("No connection to bus"), bus); \ } \ } while (0) @@ -968,8 +974,9 @@ xd_lisp_dbus_to_dbus (Lisp_Object bus) return xmint_pointer (bus); } -/* Return D-Bus connection address. BUS is either a Lisp symbol, - :system or :session, or a string denoting the bus address. */ +/* Return D-Bus connection address. + BUS is either a Lisp symbol, :system, :session, :system-private or + :session-private, or a string denoting the bus address. */ static DBusConnection * xd_get_connection_address (Lisp_Object bus) { @@ -1031,7 +1038,8 @@ xd_add_watch (DBusWatch *watch, void *data) } /* Stop monitoring WATCH for possible I/O. - DATA is the used bus, either a string or QCsystem or QCsession. */ + DATA is the used bus, either a string or QCsystem, QCsession, + QCsystem_private or QCsession_private. */ static void xd_remove_watch (DBusWatch *watch, void *data) { @@ -1046,7 +1054,7 @@ xd_remove_watch (DBusWatch *watch, void *data) /* Unset session environment. */ #if 0 /* This is buggy, since unsetenv is not thread-safe. */ - if (XSYMBOL (QCsession) == data) + if (XSYMBOL (QCsession) == data) || (XSYMBOL (QCsession_private) == data) { XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS"); unsetenv ("DBUS_SESSION_BUS_ADDRESS"); @@ -1120,6 +1128,11 @@ can be a string denoting the address of the corresponding bus. For the system and session buses, this function is called when loading `dbus.el', there is no need to call it again. +A special case is BUS being the symbol `:system-private' or +`:session-private'. These symbols still denote the system or session +bus, but using a private connection. They should not be used outside +dbus.el. + The function returns a number, which counts the connections this Emacs session has established to the BUS under the same unique name (see `dbus-get-unique-name'). It depends on the libraries Emacs is linked @@ -1142,6 +1155,10 @@ this connection to those buses. */) ptrdiff_t refcount; /* Check parameter. */ + if (!NILP (private)) + bus = EQ (bus, QCsystem) + ? QCsystem_private + : EQ (bus, QCsession) ? QCsession_private : bus; XD_DBUS_VALIDATE_BUS_ADDRESS (bus); /* Close bus if it is already open. */ @@ -1169,8 +1186,9 @@ this connection to those buses. */) else { - DBusBusType bustype = (EQ (bus, QCsystem) - ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION); + DBusBusType bustype + = EQ (bus, QCsystem) || EQ (bus, QCsystem_private) + ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION; if (NILP (private)) connection = dbus_bus_get (bustype, &derror); else @@ -1184,9 +1202,9 @@ this connection to those buses. */) XD_SIGNAL2 (build_string ("No connection to bus"), bus); /* If it is not the system or session bus, we must register - ourselves. Otherwise, we have called dbus_bus_get, which has - configured us to exit if the connection closes - we undo this - setting. */ + ourselves. Otherwise, we have called dbus_bus_get{_private}, + which has configured us to exit if the connection closes - we + undo this setting. */ if (STRINGP (bus)) dbus_bus_register (connection, &derror); else @@ -1215,6 +1233,9 @@ this connection to those buses. */) dbus_error_free (&derror); } + XD_DEBUG_MESSAGE ("Registered buses: %s", + XD_OBJECT_TO_STRING (xd_registered_buses)); + /* Return reference counter. */ refcount = xd_get_connection_references (connection); XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD"d", @@ -1533,8 +1554,8 @@ usage: (dbus-message-internal &rest REST) */) } /* Read one queued incoming message of the D-Bus BUS. - BUS is either a Lisp symbol, :system or :session, or a string denoting - the bus address. */ + BUS is either a Lisp symbol, :system, :session, :system-private or + :session-private, or a string denoting the bus address. */ static void xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) { @@ -1546,7 +1567,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) int mtype; dbus_uint32_t serial; unsigned int ui_serial; - const char *uname, *path, *interface, *member, *error_name; + const char *uname, *destination, *path, *interface, *member, *error_name; dmessage = dbus_connection_pop_message (connection); @@ -1579,6 +1600,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) ? dbus_message_get_reply_serial (dmessage) : dbus_message_get_serial (dmessage); uname = dbus_message_get_sender (dmessage); + destination = dbus_message_get_destination (dmessage); path = dbus_message_get_path (dmessage); interface = dbus_message_get_interface (dmessage); member = dbus_message_get_member (dmessage); @@ -1586,7 +1608,8 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s %s", XD_MESSAGE_TYPE_TO_STRING (mtype), - ui_serial, uname, path, interface, member, error_name, + ui_serial, uname, destination, path, interface, + mtype == DBUS_MESSAGE_TYPE_ERROR ? error_name : member, XD_OBJECT_TO_STRING (args)); if (mtype == DBUS_MESSAGE_TYPE_INVALID) @@ -1601,7 +1624,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) /* There shall be exactly one entry. Construct an event. */ if (NILP (value)) - goto cleanup; + goto monitor; /* Remove the entry. */ Fremhash (key, Vdbus_registered_objects_table); @@ -1610,11 +1633,8 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) EVENT_INIT (event); event.kind = DBUS_EVENT; event.frame_or_window = Qnil; - event.arg = - Fcons (value, - (mtype == DBUS_MESSAGE_TYPE_ERROR) - ? Fcons (list2 (QCstring, build_string (error_name)), args) - : args); + /* Handler. */ + event.arg = Fcons (value, args); } else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */ @@ -1622,7 +1642,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) /* Vdbus_registered_objects_table requires non-nil interface and member. */ if ((interface == NULL) || (member == NULL)) - goto cleanup; + goto monitor; /* Search for a registered function of the message. */ key = list4 (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL ? QCmethod : QCsignal, @@ -1647,6 +1667,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) EVENT_INIT (event); event.kind = DBUS_EVENT; event.frame_or_window = Qnil; + /* Handler. */ event.arg = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))), args); break; @@ -1655,16 +1676,22 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) } if (NILP (value)) - goto cleanup; + goto monitor; } - /* Add type, serial, uname, path, interface and member to the event. */ - event.arg = Fcons ((member == NULL ? Qnil : build_string (member)), - event.arg); + /* Add type, serial, uname, destination, path, interface and member + or error_name to the event. */ + event.arg + = Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR + ? error_name == NULL ? Qnil : build_string (error_name) + : member == NULL ? Qnil : build_string (member), + event.arg); event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)), event.arg); event.arg = Fcons ((path == NULL ? Qnil : build_string (path)), event.arg); + event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)), + event.arg); event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)), event.arg); event.arg = Fcons (INT_TO_INTEGER (serial), event.arg); @@ -1678,14 +1705,58 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg)); + /* Monitor. */ + monitor: + /* Search for a registered function of the message. */ + key = list2 (QCmonitor, bus); + value = Fgethash (key, Vdbus_registered_objects_table, Qnil); + + /* There shall be exactly one entry. Construct an event. */ + if (NILP (value)) + goto cleanup; + + /* Construct an event. */ + EVENT_INIT (event); + event.kind = DBUS_EVENT; + event.frame_or_window = Qnil; + + /* Add type, serial, uname, destination, path, interface, member + or error_name and handler to the event. */ + event.arg + = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (CAR_SAFE (value))))), + args); + event.arg + = Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR + ? error_name == NULL ? Qnil : build_string (error_name) + : member == NULL ? Qnil : build_string (member), + event.arg); + event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)), + event.arg); + event.arg = Fcons ((path == NULL ? Qnil : build_string (path)), + event.arg); + event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)), + event.arg); + event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)), + event.arg); + event.arg = Fcons (INT_TO_INTEGER (serial), event.arg); + event.arg = Fcons (make_fixnum (mtype), event.arg); + + /* Add the bus symbol to the event. */ + event.arg = Fcons (bus, event.arg); + + /* Store it into the input event queue. */ + kbd_buffer_store_event (&event); + + XD_DEBUG_MESSAGE ("Monitor event stored: %s", XD_OBJECT_TO_STRING (event.arg)); + /* Cleanup. */ cleanup: dbus_message_unref (dmessage); } /* Read queued incoming messages of the D-Bus BUS. - BUS is either a Lisp symbol, :system or :session, or a string denoting - the bus address. */ + BUS is either a Lisp symbol, :system, :session, :system-private or + :session-private, or a string denoting the bus address. */ static Lisp_Object xd_read_message (Lisp_Object bus) { @@ -1762,6 +1833,8 @@ syms_of_dbusbind (void) /* Lisp symbols of the system and session buses. */ DEFSYM (QCsystem, ":system"); DEFSYM (QCsession, ":session"); + DEFSYM (QCsystem_private, ":system-private"); + DEFSYM (QCsession_private, ":session-private"); /* Lisp symbol for method call timeout. */ DEFSYM (QCtimeout, ":timeout"); @@ -1788,10 +1861,11 @@ syms_of_dbusbind (void) DEFSYM (QCdict_entry, ":dict-entry"); /* Lisp symbols of objects in `dbus-registered-objects-table'. - `:property', which does exist there as well, is not used here. */ + `:property', which does exist there as well, is not declared here. */ DEFSYM (QCserial, ":serial"); DEFSYM (QCmethod, ":method"); DEFSYM (QCsignal, ":signal"); + DEFSYM (QCmonitor, ":monitor"); DEFVAR_LISP ("dbus-compiled-version", Vdbus_compiled_version, @@ -1867,8 +1941,9 @@ path of the sending object. All of them can be nil, which means a wildcard then. OBJECT is either the handler to be called when a D-Bus message, which -matches the key criteria, arrives (TYPE `:method' and `:signal'), or a -list (ACCESS EMITS-SIGNAL VALUE) for TYPE `:property'. +matches the key criteria, arrives (TYPE `:method', `:signal' and +`:monitor'), or a list (ACCESS EMITS-SIGNAL VALUE) for TYPE +`:property'. For entries of type `:signal', there is also a fifth element RULE, which keeps the match string the signal is registered with. commit c98c7def046c5f6b1ac50fda46e32545b5e2ba37 Author: Stefan Kangas Date: Sat Sep 26 10:50:12 2020 +0200 Fix byte-compiler warning in CEDET * lisp/cedet/semantic/lex.el (semantic-lex-catch-errors): Fix byte-compiler warning by removing obsolete variable. diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el index 799aa45a82..809271ddcc 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -1701,9 +1701,6 @@ If there is no error, then the last value of FORMS is returned." `(let* ((semantic-lex-unterminated-syntax-end-function (lambda (,syntax ,start ,end) (throw ',symbol ,syntax))) - ;; Delete the below when semantic-flex is fully retired. - (semantic-flex-unterminated-syntax-end-function - semantic-lex-unterminated-syntax-end-function) (,ret (catch ',symbol (save-excursion ,@forms