commit d8a9588034119435beb1f5a005bdee7204093793 (HEAD, refs/remotes/origin/master) Author: Michael Albinus Date: Thu Oct 1 10:32:50 2020 +0200 Revert last change in dbusbind.c * src/dbusbind.c (XD_DBUS_TYPE_P, Fdbus__init_bus) (xd_read_queued_messages): Revert last change. (Bug#43724) diff --git a/src/dbusbind.c b/src/dbusbind.c index 36f8655694..54130be685 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -211,7 +211,7 @@ xd_dbus_type_to_symbol (int type) /* Check whether a Lisp symbol is a predefined D-Bus type symbol. */ #define XD_DBUS_TYPE_P(object) \ - Fkeywordp (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID)) + SYMBOLP (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID)) /* Determine the DBusType of a given Lisp OBJECT. It is used to convert Lisp objects, being arguments of `dbus-call-method' or @@ -1231,7 +1231,7 @@ this connection to those buses. */) xd_add_watch, xd_remove_watch, xd_toggle_watch, - Fkeywordp (bus) + SYMBOLP (bus) ? (void *) XSYMBOL (bus) : (void *) XSTRING (bus), NULL)) @@ -1797,7 +1797,7 @@ xd_read_queued_messages (int fd, void *data) while (!NILP (busp)) { key = CAR_SAFE (CAR_SAFE (busp)); - if ((Fkeywordp (key) && XSYMBOL (key) == data) + if ((SYMBOLP (key) && XSYMBOL (key) == data) || (STRINGP (key) && XSTRING (key) == data)) bus = key; busp = CDR_SAFE (busp); commit 648de09e71d0ee28d00204548e98613aac2a2a60 Author: Lars Ingebrigtsen Date: Thu Oct 1 05:19:49 2020 +0200 Remove mml-sec-test that assumes the first signature This is no longer supported; the user is asked for what signature to use. diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el index 51083acdaa..427018520c 100644 --- a/test/lisp/gnus/mml-sec-tests.el +++ b/test/lisp/gnus/mml-sec-tests.el @@ -761,37 +761,6 @@ Use sign-with-sender and encrypt-to-self." method "no-exp@example.org" "sub@example.org" 2 nil)) ))))) -(ert-deftest mml-secure-sign-verify-2 () - "Sign message without sender; then verify and test for expected result." - (skip-unless (test-conf)) - (mml-secure-test-key-fixture - (lambda () - (dolist (method (sign-standards) nil) - (let ((mml-secure-openpgp-sign-with-sender nil) - (mml-secure-smime-sign-with-sender nil)) - ;; A single signing key for sender sub@example.org is customized - ;; in the fixture, but not used here. - ;; By default, gpg uses the first secret key in the keyring, which - ;; is 02372A42CA6D40FB (OpenPGP) or - ;; 0E58229B80EE33959FF718FEEF25402B479DC6E2 (S/MIME) here. - (mml-secure-test-en-decrypt - method "uid1@example.org" "sub@example.org" 0 nil) - - ;; From sub@example.org, sign with specified key: - (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB")) - (mml-secure-smime-signers - '("D06AA118653CC38E9D0CAF56ED7A2135E1582177"))) - (mml-secure-test-en-decrypt - method "no-exp@example.org" "sub@example.org" 1 nil)) - - ;; From sub@example.org, sign with different specified key: - (let ((mml-secure-openpgp-signers '("C3999CF1268DBEA2")) - (mml-secure-smime-signers - '("0E58229B80EE33959FF718FEEF25402B479DC6E2"))) - (mml-secure-test-en-decrypt - method "no-exp@example.org" "sub@example.org" 1 nil)) - ))))) - (ert-deftest mml-secure-sign-verify-3 () "Try to sign message with expired OpenPGP subkey, which raises an error. With Ma Gnus v0.14 and earlier a signature would be created with a wrong key." commit 26a882125009d58311de2b2636460cfe2b046c60 Author: Lars Ingebrigtsen Date: Thu Oct 1 05:17:01 2020 +0200 Make mml-sec-tests not hang waiting for input * lisp/gnus/mml-sec.el (mml-secure-epg-sign): Only query if we're running interactively. This makes a test not hang. diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 0a842061b3..74af99da7e 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -988,7 +988,8 @@ Returns non-nil if the user has chosen to use SENDER." (signers (mml-secure-signers context signer-names)) signature micalg) (unless signers - (if (mml-secure-sender-sign-query protocol sender) + (if (and (not noninteractive) + (mml-secure-sender-sign-query protocol sender)) (setq signer-names (mml-secure-signer-names protocol sender) signers (mml-secure-signers context signer-names))) (unless signers commit 59c343ba0d0a760e01892c980ec8e427d42ed3cc Author: Pip Cet Date: Thu Oct 1 05:06:41 2020 +0200 Don't optimize away star patterns in minibuffer file name completion * lisp/minibuffer.el (completion-pcm--optimize-pattern): Keep 'star in the pattern (bug#41705). diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 3e23c05bb0..427636e866 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -3110,12 +3110,12 @@ or a symbol, see `completion-pcm--merge-completions'." (while p (pcase p (`(,(or 'any 'any-delim) point . ,rest) (setq p `(point . ,rest))) - ;; This is not just a performance improvement: it also turns - ;; a terminating `point' into an implicit `any', which - ;; affects the final position of point (because `point' gets - ;; turned into a non-greedy ".*?" regexp whereas we need - ;; it the be greedy when it's at the end, see bug#38458). - (`(,(pred symbolp)) (setq p nil)) ;Implicit terminating `any'. + ;; This is not just a performance improvement: it turns a + ;; terminating `point' into an implicit `any', which affects + ;; the final position of point (because `point' gets turned + ;; into a non-greedy ".*?" regexp whereas we need it to be + ;; greedy when it's at the end, see bug#38458). + (`(point) (setq p nil)) ;Implicit terminating `any'. (_ (push (pop p) n)))) (nreverse n))) commit c150b9a24421adca146ada6c5166e3bf974c7c94 Author: Lars Ingebrigtsen Date: Thu Oct 1 03:01:33 2020 +0200 Fix the end-of-query prompt in multi-occur and multi-isearch when fido * lisp/misearch.el (multi-isearch-read-buffers): Ditto. * lisp/replace.el (multi-occur--prompt): New function (bug#41633). (multi-occur): Use it. diff --git a/lisp/misearch.el b/lisp/misearch.el index 958c10a1bf..6ec10fe2c2 100644 --- a/lisp/misearch.el +++ b/lisp/misearch.el @@ -236,11 +236,7 @@ set in `multi-isearch-buffers' or `multi-isearch-buffers-regexp'." (buf nil) (ido-ignore-item-temp-list bufs)) (while (not (string-equal - (setq buf (read-buffer - (if (eq read-buffer-function #'ido-read-buffer) - "Next buffer to search (C-j to end): " - "Next buffer to search (RET to end): ") - nil t)) + (setq buf (read-buffer (multi-occur--prompt) nil t)) "")) (add-to-list 'bufs buf) (setq ido-ignore-item-temp-list bufs)) diff --git a/lisp/replace.el b/lisp/replace.el index 035031ac93..2d17ec9097 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -1572,6 +1572,18 @@ is not modified." (defvar ido-ignore-item-temp-list) +(defun multi-occur--prompt () + (concat + "Next buffer to search " + (cond + ((eq read-buffer-function #'ido-read-buffer) + (substitute-command-keys + "(\\\\[ido-select-text] to end): ")) + ((bound-and-true-p fido-mode) + (substitute-command-keys + "(\\\\[icomplete-fido-exit] to end): ")) + (t "(RET to end): ")))) + (defun multi-occur (bufs regexp &optional nlines) "Show all lines in buffers BUFS containing a match for REGEXP. Optional argument NLINES specifies the number of context lines to show @@ -1587,11 +1599,7 @@ See also `multi-occur-in-matching-buffers'." (buf nil) (ido-ignore-item-temp-list bufs)) (while (not (string-equal - (setq buf (read-buffer - (if (eq read-buffer-function #'ido-read-buffer) - "Next buffer to search (C-j to end): " - "Next buffer to search (RET to end): ") - nil t)) + (setq buf (read-buffer (multi-occur--prompt) nil t)) "")) (cl-pushnew buf bufs) (setq ido-ignore-item-temp-list bufs)) commit d11627a7cadfe7db9415269135a8f4bec543ccd7 Author: Alex Bochannek Date: Thu Oct 1 02:44:58 2020 +0200 Make gnus-base64-repad a bit stricter again * lisp/gnus/gnus-util.el (gnus-base64-repad): Make the code a bit stricter again. diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 0e15ebce6c..1cf6bb7053 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1368,7 +1368,11 @@ CRLF (RFC 5321 SMTP)." ;; input (3.1, 3.3) ;; - if line-length is set, error on input exceeding the limit (3.1) ;; - reject characters outside base encoding (3.3, also section 12) - (let ((splitstr (split-string str "[\n\r \t]+" t))) + ;; + ;; RFC 5322 section 2.2.3 consideration: + ;; Because base 64-encoded strings can appear in long header fields, remove + ;; folding whitespace while still observing the RFC 4648 decisions above. + (let ((splitstr (split-string str "[ \t]*[\r\n]+[ \t]?" t))) (when (and reject-newlines (> (length splitstr) 1)) (error "Invalid Base64 string")) (dolist (substr splitstr) diff --git a/test/lisp/gnus/gnus-util-tests.el b/test/lisp/gnus/gnus-util-tests.el index ec58032e84..47f0a9cf76 100644 --- a/test/lisp/gnus/gnus-util-tests.el +++ b/test/lisp/gnus/gnus-util-tests.el @@ -151,8 +151,10 @@ (should (equal "Zg==" (gnus-base64-repad "Zg"))) (should (equal "Zg==" (gnus-base64-repad "Zg===="))) - (should (equal (gnus-base64-repad " ") "")) - (should (equal (gnus-base64-repad "Zg== ") "Zg==")) + (should-error (gnus-base64-repad " ") + :type 'error) + (should-error (gnus-base64-repad "Zg== ") + :type 'error) (should-error (gnus-base64-repad "Z?\x00g==") :type 'error) ;; line-length @@ -162,9 +164,10 @@ (should-error (gnus-base64-repad "Zm9v\r\nYmFy" t) :type 'error) (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9vYmFy" t))) - (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy" nil))) - (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy\n" nil))) - (should (equal (gnus-base64-repad "Zm9v\r\n YmFy\r\n" nil) "Zm9vYmFy")) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy"))) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy\n"))) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\n YmFy\r\n"))) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v \r\n\tYmFy"))) (should-error (gnus-base64-repad "Zm9v\r\nYmFy" nil 3) :type 'error)) commit 75185968578cbbd806274d9dfd984aff7a1b02c9 Author: Robert Pluim Date: Thu Oct 1 02:14:17 2020 +0200 Query for the signer when sending signed mail (with unknown signer) * lisp/gnus/mml-sec.el (mml-secure-sender-sign-query): New function (bug#40118). (mml-secure-epg-sign): Use it to determine the signer (bug#40118). * lisp/gnus/mml-sec.el (mml-secure-allow-signing-with-unknown-recipient): Remove. diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 69852c381d..0a842061b3 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -938,9 +938,47 @@ If no one is selected, symmetric encryption will be performed. " (signal (car error) (cdr error)))) cipher)) -;; Should probably be removed and the interface should be different. -(defvar mml-secure-allow-signing-with-unknown-recipient nil - "Variable to bind to allow automatic recipient selection.") +(defun mml-secure-sender-sign-query (protocol sender) + "Query whether to use SENDER to sign when using PROTOCOL. +PROTOCOL will be `OpenPGP' or `CMS' (smime). +This can also save the resulting value of +`mml-secure-smime-sign-with-sender' or +`mml-secure-openpgp-sign-with-sender' via Customize. +Returns non-nil if the user has chosen to use SENDER." + (let ((buffer (get-buffer-create "*MML sender signing options*")) + (options '((?a "always" "Sign using this sender now and sign with message sender in future.") + (?s "session only" "Sign using this sender now, and sign with message sender for this session only.") + (?n "no" "Do not sign this message (and error out)"))) + answer done val) + (save-window-excursion + (pop-to-buffer buffer) + (erase-buffer) + (insert (format "No %s signing key was found for this message.\nThe sender of this message is \"%s\".\nWould you like to attempt looking up a signing key based on it?" + (if (eq protocol 'OpenPGP) + "openpgp" "smime") + sender)) + (while (not done) + (setq answer (read-multiple-choice "Sign this message using the sender?" options)) + (cl-case (car answer) + (?a + (if (eq protocol 'OpenPGP) + (progn + (setq mml-secure-openpgp-sign-with-sender t) + (customize-save-variable + 'mml-secure-openpgp-sign-with-sender t)) + (setq mml-secure-smime-sign-with-sender t) + (customize-save-variable 'mml-secure-smime-sign-with-sender t)) + (setq done t + val t)) + (?s + (if (eq protocol 'OpenPGP) + (setq mml-secure-openpgp-sign-with-sender t) + (setq mml-secure-smime-sign-with-sender t)) + (setq done t + val t)) + (?n + (setq done t))))) + val)) (defun mml-secure-epg-sign (protocol mode) ;; Based on code appearing inside mml2015-epg-sign. @@ -950,15 +988,20 @@ If no one is selected, symmetric encryption will be performed. " (signers (mml-secure-signers context signer-names)) signature micalg) (unless signers - (let ((maybe-msg - (if mml-secure-smime-sign-with-sender - "." - "; try setting `mml-secure-smime-sign-with-sender'."))) - ;; If `mml-secure-smime-sign-with-sender' is already non-nil - ;; then there's no point advising the user to examine it. If - ;; there are any other variables worth examining, please - ;; improve this error message by having it mention them. - (unless mml-secure-allow-signing-with-unknown-recipient + (if (mml-secure-sender-sign-query protocol sender) + (setq signer-names (mml-secure-signer-names protocol sender) + signers (mml-secure-signers context signer-names))) + (unless signers + (let ((maybe-msg + (if (or mml-secure-smime-sign-with-sender + mml-secure-openpgp-sign-with-sender) + "." + "; try setting `mml-secure-smime-sign-with-sender' or 'mml-secure-openpgp-sign-with-sender'."))) + ;; If `mml-secure-smime-sign-with-sender' or + ;; `mml-secure-openpgp-sign-with-sender' are already non-nil + ;; then there's no point advising the user to examine them. + ;; If there are any other variables worth examining, please + ;; improve this error message by having it mention them. (error "Couldn't find any signer names%s" maybe-msg)))) (when (eq 'OpenPGP protocol) (setf (epg-context-armor context) t) diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el index 4c745ea6d7..51083acdaa 100644 --- a/test/lisp/gnus/mml-sec-tests.el +++ b/test/lisp/gnus/mml-sec-tests.el @@ -67,7 +67,6 @@ instead of gpg-agent." (condition-case error (let ((epg-gpg-home-directory (expand-file-name "test/data/mml-sec" source-directory)) - (mml-secure-allow-signing-with-unknown-recipient t) (mml-smime-use 'epg) ;; Create debug output in empty epg-debug-buffer. (epg-debug t) commit aea7788b925a179518d6affc7683d29f9ec39ca3 Author: martin rudalics Date: Thu Oct 1 02:00:06 2020 +0200 Fix segfault in some cases when restoring a selected window * src/xdisp.c (restore_selected_window): Fix the more grave problems caused by a function deleting the previously selected frame or window (bug#39977). diff --git a/src/xdisp.c b/src/xdisp.c index 152946363e..d9101592b2 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -12400,12 +12400,12 @@ unwind_format_mode_line (Lisp_Object vector) mode_line_string_face_prop = AREF (vector, 5); /* Select window before buffer, since it may change the buffer. */ - if (!NILP (old_window)) + if (WINDOW_LIVE_P (old_window)) { /* If the operation that we are unwinding had selected a window on a different frame, reset its frame-selected-window. For a text terminal, reset its top-frame if necessary. */ - if (!NILP (target_frame_window)) + if (WINDOW_LIVE_P (target_frame_window)) { Lisp_Object frame = WINDOW_FRAME (XWINDOW (target_frame_window)); @@ -12422,7 +12422,7 @@ unwind_format_mode_line (Lisp_Object vector) /* Restore point of target_frame_window's buffer (Bug#32777). But do this only after old_window has been reselected to avoid that the window point of target_frame_window moves. */ - if (!NILP (target_frame_window)) + if (WINDOW_LIVE_P (target_frame_window)) { Lisp_Object buffer = AREF (vector, 10); @@ -12850,23 +12850,68 @@ update_menu_bar (struct frame *f, bool save_match_data, bool hooks_run) Tab-bars ***********************************************************************/ -#ifdef HAVE_WINDOW_SYSTEM - -/* Select `frame' temporarily without running all the code in - do_switch_frame. - FIXME: Maybe do_switch_frame should be trimmed down similarly - when `norecord' is set. */ +/* Restore WINDOW as the selected window and its frame as the selected + frame. If WINDOW is dead but the selected frame is live, make the + latter's selected window the selected window. If both, WINDOW and + the selected frame, are dead, assign selected frame and window from + some arbitrary live frame. Abort if no such frame can be found. */ static void -fast_set_selected_frame (Lisp_Object frame) +restore_selected_window (Lisp_Object window) { - if (!EQ (selected_frame, frame)) + if (WINDOW_LIVE_P (window)) + /* If WINDOW is live, make it the selected window and its frame's + selected window and set the selected frame to its frame. */ { - selected_frame = frame; - selected_window = XFRAME (frame)->selected_window; + selected_window = window; + selected_frame = XWINDOW (window)->frame; + FRAME_SELECTED_WINDOW (XFRAME (selected_frame)) = window; + } + else if (FRAMEP (selected_frame) && FRAME_LIVE_P (XFRAME (selected_frame))) + /* If WINDOW is dead but the selected frame is still live, make the + latter's selected window the selected one. */ + selected_window = FRAME_SELECTED_WINDOW (XFRAME (selected_frame)); + else + /* If WINDOW and the selected frame are dead, choose some live, + non-child and non-tooltip frame as the new selected frame and + make its selected window the selected window. */ + { + Lisp_Object tail; + Lisp_Object frame UNINIT; + + FOR_EACH_FRAME (tail, frame) + { + struct frame *f = XFRAME (frame); + + if (!FRAME_PARENT_FRAME (f) && !FRAME_TOOLTIP_P (f)) + { + selected_frame = frame; + selected_window = FRAME_SELECTED_WINDOW (f); + + return; + } + } + + /* Abort if we cannot find a live frame. */ + emacs_abort (); } } -#endif /* HAVE_WINDOW_SYSTEM */ +/* Restore WINDOW, if live, as its frame's selected window. */ +static void +restore_frame_selected_window (Lisp_Object window) +{ + if (WINDOW_LIVE_P (window)) + /* If WINDOW is live, make it its frame's selected window. If that + frame is the selected frame, make WINDOW the selected window as + well. */ + { + Lisp_Object frame = XWINDOW (window)->frame; + + FRAME_SELECTED_WINDOW (XFRAME (frame)) = window; + if (EQ (frame, selected_frame)) + selected_window = window; + } +} /* Update the tab-bar item list for frame F. This has to be done before we start to fill in any display lines. Called from @@ -12939,9 +12984,10 @@ update_tab_bar (struct frame *f, bool save_match_data) XFRAME (selected_frame)->selected_window)); #ifdef HAVE_WINDOW_SYSTEM Lisp_Object frame; - record_unwind_protect (fast_set_selected_frame, selected_frame); + record_unwind_protect (restore_selected_window, selected_window); XSETFRAME (frame, f); - fast_set_selected_frame (frame); + selected_frame = frame; + selected_window = FRAME_SELECTED_WINDOW (f); #endif /* Build desired tab-bar items from keymaps. */ @@ -13873,9 +13919,10 @@ update_tool_bar (struct frame *f, bool save_match_data) /* Since we only explicitly preserve selected_frame, check that selected_window would be redundant. */ XFRAME (selected_frame)->selected_window)); - record_unwind_protect (fast_set_selected_frame, selected_frame); + record_unwind_protect (restore_selected_window, selected_window); XSETFRAME (frame, f); - fast_set_selected_frame (frame); + selected_frame = frame; + selected_window = FRAME_SELECTED_WINDOW (f); /* Build desired tool-bar items from keymaps. */ new_tool_bar @@ -25217,11 +25264,14 @@ static int display_mode_lines (struct window *w) { Lisp_Object old_selected_window = selected_window; - Lisp_Object old_selected_frame = selected_frame; Lisp_Object new_frame = w->frame; - Lisp_Object old_frame_selected_window = XFRAME (new_frame)->selected_window; + ptrdiff_t count = SPECPDL_INDEX (); int n = 0; + record_unwind_protect (restore_selected_window, selected_window); + record_unwind_protect + (restore_frame_selected_window, XFRAME (new_frame)->selected_window); + if (window_wants_mode_line (w)) { Lisp_Object window; @@ -25287,9 +25337,8 @@ display_mode_lines (struct window *w) ++n; } - XFRAME (new_frame)->selected_window = old_frame_selected_window; - selected_frame = old_selected_frame; - selected_window = old_selected_window; + unbind_to (count, Qnil); + if (n > 0) w->must_be_updated_p = true; return n; commit 5d6e65d57a7c7f18bfb181fdee28b7c5bd75356d Author: Boruch Baum Date: Thu Oct 1 01:53:30 2020 +0200 Split auto-revert-buffers into several functions * lisp/autorevert.el (auto-revert--buffer-candidates) (auto-revert-buffer): Refactor out... (auto-revert-buffers): ... from here. diff --git a/lisp/autorevert.el b/lisp/autorevert.el index 6e08176f5f..046ea2b5d6 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el @@ -871,6 +871,62 @@ This is an internal function used by Auto-Revert Mode." (restore-buffer-modified-p modified))) (set-visited-file-modtime)) +(defun auto-revert--buffer-candidates () + "Return a prioritized list of buffers to maybe auto-revert. +The differences between this return value and the reference +variable `auto-revert-buffer-list' include: 1) this has more +entries when in global-auto-revert-mode; 2) this prioritizes +buffers not reverted last time due to user interruption. " + (let ((bufs (delq nil + ;; Buffers with remote contents shall be reverted only + ;; if the connection is established already. + (mapcar + (lambda (buf) + (and (buffer-live-p buf) + (with-current-buffer buf + (and + (or (not (file-remote-p default-directory)) + (file-remote-p default-directory nil t)) + buf)))) + (auto-revert--polled-buffers)))) + remaining new) + ;; Partition `bufs' into two halves depending on whether or not + ;; the buffers are in `auto-revert-remaining-buffers'. The two + ;; halves are then re-joined with the "remaining" buffers at the + ;; head of the list. + (dolist (buf auto-revert-remaining-buffers) + (when (memq buf bufs) + (push buf remaining))) + (dolist (buf bufs) + (unless (memq buf remaining) + (push buf new))) + (nreverse (nconc new remaining)))) + +(defun auto-revert-buffer (buf) + "Revert a single buffer. + +This is performed as specified by Auto-Revert and Global +Auto-Revert Modes." + (if (not (buffer-live-p buf)) + (auto-revert-remove-current-buffer buf) + (with-current-buffer buf + ;; Test if someone has turned off Auto-Revert Mode + ;; in a non-standard way, for example by changing + ;; major mode. + (when (and (not auto-revert-mode) + (not auto-revert-tail-mode)) + (auto-revert-remove-current-buffer)) + (when (auto-revert-active-p) + ;; Enable file notification. + ;; Don't bother creating a notifier for non-file buffers + ;; unless it explicitly indicates that this works. + (when (and auto-revert-use-notify + (not auto-revert-notify-watch-descriptor) + (or buffer-file-name + buffer-auto-revert-by-notification)) + (auto-revert-notify-add-watch)) + (auto-revert-handler))))) + (defun auto-revert-buffers () "Revert buffers as specified by Auto-Revert and Global Auto-Revert Mode. @@ -894,67 +950,19 @@ are checked first the next time this function is called. This function is also responsible for removing buffers no longer in Auto-Revert Mode from `auto-revert-buffer-list', and for canceling the timer when no buffers need to be checked." - (save-match-data - (let ((bufs (auto-revert--polled-buffers)) - remaining new) - ;; Buffers with remote contents shall be reverted only if the - ;; connection is established already. - (setq bufs (delq nil - (mapcar - (lambda (buf) - (and (buffer-live-p buf) - (with-current-buffer buf - (and - (or (not (file-remote-p default-directory)) - (file-remote-p default-directory nil t)) - buf)))) - bufs))) - ;; Partition `bufs' into two halves depending on whether or not - ;; the buffers are in `auto-revert-remaining-buffers'. The two - ;; halves are then re-joined with the "remaining" buffers at the - ;; head of the list. - (dolist (buf auto-revert-remaining-buffers) - (if (memq buf bufs) - (push buf remaining))) - (dolist (buf bufs) - (if (not (memq buf remaining)) - (push buf new))) - (setq bufs (nreverse (nconc new remaining))) + (let ((bufs (auto-revert--buffer-candidates))) (while (and bufs (not (and auto-revert-stop-on-user-input (input-pending-p)))) - (let ((buf (car bufs))) - (if (not (buffer-live-p buf)) - ;; Remove dead buffer from `auto-revert-buffer-list'. - (auto-revert-remove-current-buffer buf) - (with-current-buffer buf - ;; Test if someone has turned off Auto-Revert Mode - ;; in a non-standard way, for example by changing - ;; major mode. - (if (and (not auto-revert-mode) - (not auto-revert-tail-mode) - (memq buf auto-revert-buffer-list)) - (auto-revert-remove-current-buffer)) - (when (auto-revert-active-p) - ;; Enable file notification. - ;; Don't bother creating a notifier for non-file buffers - ;; unless it explicitly indicates that this works. - (when (and auto-revert-use-notify - (not auto-revert-notify-watch-descriptor) - (or buffer-file-name - buffer-auto-revert-by-notification)) - (auto-revert-notify-add-watch)) - (auto-revert-handler))))) - (setq bufs (cdr bufs))) + (auto-revert-buffer (pop bufs))) (setq auto-revert-remaining-buffers bufs) ;; Check if we should cancel the timer. (unless (auto-revert--need-polling-p) - (if (timerp auto-revert-timer) - (cancel-timer auto-revert-timer)) + (when (timerp auto-revert-timer) + (cancel-timer auto-revert-timer)) (setq auto-revert-timer nil))))) - ;; The end: (provide 'autorevert) commit af32299331d79e5b8427a41f8dcf82ac083dc5c6 Author: Lars Ingebrigtsen Date: Thu Oct 1 01:44:05 2020 +0200 Fix up previous window excursion patch in epa--select-keys * lisp/epa.el (epa--select-keys): Use save-window-excursion instead of open-coding the macro. diff --git a/lisp/epa.el b/lisp/epa.el index a2fb7f2bd1..25e055c201 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -435,7 +435,7 @@ q trust status questionable. - trust status unspecified. (unless (and epa-keys-buffer (buffer-live-p epa-keys-buffer)) (setq epa-keys-buffer (generate-new-buffer "*Keys*"))) - (let ((conf (current-window-configuration))) + (save-window-excursion (with-current-buffer epa-keys-buffer (epa-key-list-mode) ;; C-c C-c is the usual way to finish the selection (bug#11159). @@ -462,8 +462,7 @@ q trust status questionable. - trust status unspecified. (progn (recursive-edit) (epa--marked-keys)) - (kill-buffer epa-keys-buffer) - (set-window-configuration conf))))) + (kill-buffer epa-keys-buffer))))) ;;;###autoload (defun epa-select-keys (context prompt &optional names secret) commit fdaceeb8b49cb4d5c83df08167a2ee8e6125897e Author: Stefan Monnier Date: Wed Sep 30 19:17:26 2020 -0400 * lisp/term.el: Make C-/ undo in a nested Emacs subprocess (term-send-C-_): New function. (term-raw-map): Use it for `C-/`, as is done in xterm and friends. diff --git a/lisp/term.el b/lisp/term.el index f0470d806c..69681f706c 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -860,6 +860,7 @@ is buffer-local." (define-key map [prior] 'term-send-prior) (define-key map [next] 'term-send-next) (define-key map [xterm-paste] #'term--xterm-paste) + (define-key map [?\C-/] #'term-send-C-_) map) "Keyboard map for sending characters directly to the inferior process.") @@ -1282,6 +1283,7 @@ without any interpretation." (defun term-send-next () (interactive) (term-send-raw-string "\e[6~")) (defun term-send-del () (interactive) (term-send-raw-string "\e[3~")) (defun term-send-backspace () (interactive) (term-send-raw-string "\C-?")) +(defun term-send-C-_ () (interactive) (term-send-raw-string "\C-_")) (defun term-char-mode () "Switch to char (\"raw\") sub-mode of term mode. commit 8f6bde637151d980dca49d97f1b6a8803347c974 Author: Stefan Monnier Date: Wed Sep 30 19:08:47 2020 -0400 * doc/emacs/basic.texi (Basic Undo): Explain the C-/ situation in xterm AFAICT, in ttys you can send a `C-_` to Emacs either by pressing `C-/` (e.g. xterm, uxterm, rxvt, xfce4-terminal, gnome-terminal) or by pressing `C--` (e.g. rxvt, Linux console). diff --git a/doc/emacs/basic.texi b/doc/emacs/basic.texi index fc856a3acb..2e03d0c04a 100644 --- a/doc/emacs/basic.texi +++ b/doc/emacs/basic.texi @@ -467,10 +467,11 @@ changes in the buffer; you can't use it to undo cursor motion. On a terminal that supports the @key{Control} modifier on all other keys, the easiest way to invoke @code{undo} is with @kbd{C-/}, since that doesn't need the @key{Shift} modifier. On terminals which allow -only the ASCII control characters, @kbd{C-/} does not exist, but many -of them allow you to omit the @key{Shift} modifier when you type -@kbd{C-_} (in effect pressing @kbd{C--}), making that the most -convenient way to invoke @code{undo}. +only the ASCII control characters, @kbd{C-/} does not exist, but for +many of them @kbd{C-/} still works because it actually sends @kbd{C-_} +to Emacs, while many others allow you to omit the @key{Shift} modifier +when you type @kbd{C-_} (in effect pressing @kbd{C--}), making that +the most convenient way to invoke @code{undo}. Although each editing command usually makes a separate entry in the undo records, very simple commands may be grouped together. commit dc3a59f7a17aa8a643d688a10ab175430decb544 Author: Richard M Stallman Date: Wed Sep 30 18:44:42 2020 -0400 When recipient has no public key, make offer to skip it optional. * epa-mail.el (epa-mail-offer-skip): New option. (epa-mail-encrypt): If epa-mail-offer-skip is nil, don't offer to skip a keyless recipient, just cause error. diff --git a/lisp/epa-mail.el b/lisp/epa-mail.el index 6e6c0a498d..3ad4da16c8 100644 --- a/lisp/epa-mail.el +++ b/lisp/epa-mail.el @@ -49,6 +49,13 @@ (defvar epa-mail-mode-on-hook nil) (defvar epa-mail-mode-off-hook nil) +(defcustom epa-mail-offer-skip t + "If non-nil, when a recipient has no key, ask whether to skip it. +Otherwise, signal an error." + :type 'boolean + :version "28.1" + :group 'epa-mail) + ;;;###autoload (define-minor-mode epa-mail-mode "A minor-mode for composing encrypted/clearsigned mails." @@ -218,10 +225,12 @@ If no one is selected, symmetric encryption will be performed. " recipient)) 'encrypt))) (unless (or recipient-key - (y-or-n-p - (format - "No public key for %s; skip it? " - recipient))) + (and epa-mail-offer-skip + (y-or-n-p + (format + "No public key for %s; skip it? " + recipient))) + ) (error "No public key for %s" recipient)) (if recipient-key (list recipient-key)))) default-recipients))))) commit 0434c1a9a66a3521348cbca9c1f3bba7765df2d6 Author: Richard M Stallman Date: Wed Sep 30 18:15:43 2020 -0400 Clarify previous undo keys change Clarify which terminals allow C-/ and which make C-_ easy to type. diff --git a/doc/emacs/basic.texi b/doc/emacs/basic.texi index cde7b475d9..fc856a3acb 100644 --- a/doc/emacs/basic.texi +++ b/doc/emacs/basic.texi @@ -464,13 +464,13 @@ Normally, this command undoes the last change, moving point back to where it was before the change. The undo command applies only to changes in the buffer; you can't use it to undo cursor motion. - On a graphics terminal (including text-mode frames displayed by a -terminal emulator, such as @command{xterm}), the easiest way to invoke -@code{undo} is with @kbd{C-/}; that doesn't need the Shift key. On a -text terminal, @kbd{C-/} does not exist, but in many cases you can type -@kbd{C-_} without the Shift key (in effect pressing @kbd{C--}) and it -will work anyway, at least with keyboards that produce the US ASCII -character set. + On a terminal that supports the @key{Control} modifier on all other +keys, the easiest way to invoke @code{undo} is with @kbd{C-/}, since +that doesn't need the @key{Shift} modifier. On terminals which allow +only the ASCII control characters, @kbd{C-/} does not exist, but many +of them allow you to omit the @key{Shift} modifier when you type +@kbd{C-_} (in effect pressing @kbd{C--}), making that the most +convenient way to invoke @code{undo}. Although each editing command usually makes a separate entry in the undo records, very simple commands may be grouped together. commit 5b0d8d0f288fd505ca90bd30df709a5e7ab540d6 Author: Lars Ingebrigtsen Date: Wed Sep 30 20:29:16 2020 +0200 Further doc fixes for dotimes about RESULT * lisp/subr.el (dotimes): Be even more explicit about RESULT (bug#16206). diff --git a/lisp/subr.el b/lisp/subr.el index 6f164ae694..2dc23a479e 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -279,8 +279,11 @@ Then evaluate RESULT to get return value, default nil. (defmacro dotimes (spec &rest body) "Loop a certain number of times. Evaluate BODY with VAR bound to successive integers running from 0, -inclusive, to COUNT, exclusive. Then evaluate RESULT to get -the return value (nil if RESULT is omitted). Its use is deprecated. +inclusive, to COUNT, exclusive. + +Finally RESULT is evaluated to get the return value (nil if +RESULT is omitted). Using RESULT is deprecated, and may result +in compilation warnings about unused variables. \(fn (VAR COUNT [RESULT]) BODY...)" (declare (indent 1) (debug dolist)) commit 19042966f2ddab190936154ca67c41db1c36a9f6 Author: Eli Zaretskii Date: Wed Sep 30 19:38:55 2020 +0300 Minor documentation copyedits * etc/NEWS: * doc/emacs/dired.texi (Dired Enter): Fix wording, punctuation, and typos in doc of 'dired-switches-in-mode-line'. diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi index 22fec134ba..fdc4703e86 100644 --- a/doc/emacs/dired.texi +++ b/doc/emacs/dired.texi @@ -130,15 +130,15 @@ options (starting with @samp{--}) whose arguments are specified with @samp{=}. @vindex dired-switches-in-mode-line - Dired will display an indication of what the @command{ls} switches -are in the mode line. By default, Dired will try to determine whether -the switches indicate sorting by name or date, and say so in the mode -line. If the @code{dired-switches-in-mode-line} variable is -@code{as-is}, the switches will be shown verbatim. If this variable -in an integer, the switch display will be truncated to that length. -This variable can also be a function, which will be passed -@code{dired-actual-switches} as the only parameter and should return a -string. + Dired displays in the mode line an indication of what were the +switches used to invoke @command{ls}. By default, Dired will try to +determine whether the switches indicate sorting by name or date, and +will say so in the mode line. If the @code{dired-switches-in-mode-line} +variable is @code{as-is}, the switches will be shown verbatim. If +this variable's value is an integer, the switch display will be +truncated to that length. This variable can also be a function, which +will be called with @code{dired-actual-switches} as the only +parameter, and should return a string to display in the mode line. @vindex dired-use-ls-dired If your @command{ls} program supports the @samp{--dired} option, diff --git a/etc/NEWS b/etc/NEWS index 975207c877..b4f29ab783 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -320,9 +320,10 @@ time zones will use a form like "+0100" instead of "CET". +++ *** New user option 'dired-switches-in-mode-line'. -This variable controls how "ls" switches is displayed, and allows -truncating or showing them as they are, in addition to "by name" and -"by date". +This variable controls how 'ls' switches are displayed in the mode +line, and allows truncating them (to preserve space on the mode line) +or showing them literally, either instead of, or in addition to, +displaying "by name" or "by date" sort order. --- *** Broken and circular links are shown with the 'dired-broken-symlink' face. commit d923370551b82a457aa14e4358a015bb3a8340b0 Author: Vladimir Nikishkin Date: Wed Sep 30 18:32:32 2020 +0200 Fix problem with parsing . as a symbol in bovine * lisp/cedet/semantic/bovine/scm.el (semantic-lex-scheme-symbol): Symbols do not have to start with a word-constituent character (bug#40034). In particular, symbols like : and . are valid. Copyright-paperwork-exempt: yes diff --git a/lisp/cedet/semantic/bovine/scm.el b/lisp/cedet/semantic/bovine/scm.el index 93ad27586e..b2a25bf8ee 100644 --- a/lisp/cedet/semantic/bovine/scm.el +++ b/lisp/cedet/semantic/bovine/scm.el @@ -69,7 +69,7 @@ Attempts a simple prototype for calling or using TAG." ;; Note: Analyzer from Henry S. Thompson (define-lex-regex-analyzer semantic-lex-scheme-symbol "Detect and create symbol and keyword tokens." - "\\(\\sw\\([:]\\|\\sw\\|\\s_\\)*\\)" + "\\(\\sw\\|\\s_\\)+" ;; (message "symbol: %s" (match-string 0)) (semantic-lex-push-token (semantic-lex-token commit cc3e369ab00524b63aa407018be91a2a1a0cc052 Author: Drew Adams Date: Wed Sep 30 17:59:59 2020 +0200 Allow controlling the Dired switches shown in the mode line * doc/emacs/dired.texi (Dired Enter): Document it (bug#41250). * lisp/dired.el (dired-switches-in-mode-line): New variable (bug#41250). (dired-sort-set-mode-line): Use it. diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi index 24fd02aac1..22fec134ba 100644 --- a/doc/emacs/dired.texi +++ b/doc/emacs/dired.texi @@ -129,6 +129,17 @@ options (that is, single characters) requiring no arguments, and long options (starting with @samp{--}) whose arguments are specified with @samp{=}. +@vindex dired-switches-in-mode-line + Dired will display an indication of what the @command{ls} switches +are in the mode line. By default, Dired will try to determine whether +the switches indicate sorting by name or date, and say so in the mode +line. If the @code{dired-switches-in-mode-line} variable is +@code{as-is}, the switches will be shown verbatim. If this variable +in an integer, the switch display will be truncated to that length. +This variable can also be a function, which will be passed +@code{dired-actual-switches} as the only parameter and should return a +string. + @vindex dired-use-ls-dired If your @command{ls} program supports the @samp{--dired} option, Dired automatically passes it that option; this causes @command{ls} to diff --git a/etc/NEWS b/etc/NEWS index 7be793e01a..975207c877 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -318,6 +318,12 @@ time zones will use a form like "+0100" instead of "CET". ** Dired ++++ +*** New user option 'dired-switches-in-mode-line'. +This variable controls how "ls" switches is displayed, and allows +truncating or showing them as they are, in addition to "by name" and +"by date". + --- *** Broken and circular links are shown with the 'dired-broken-symlink' face. diff --git a/lisp/dired.el b/lisp/dired.el index b4b3368a5b..08b19a0225 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -4227,22 +4227,50 @@ format, use `\\[universal-argument] \\[dired]'.") "Non-nil means the Dired sort command is disabled. The idea is to set this buffer-locally in special Dired buffers.") +(defcustom dired-switches-in-mode-line nil + "How to indicate `dired-actual-switches' in mode-line. +Possible values: + * `nil': Indicate name-or-date sort order, if possible. + Else show full switches. + * `as-is': Show full switches. + * Integer: Show only the first N chars of full switches. + * Function: Pass `dired-actual-switches' as arg and show result." + :group 'Dired-Plus + :type '(choice + (const :tag "Indicate by name or date, else full" nil) + (const :tag "Show full switches" as-is) + (integer :tag "Show first N chars of switches" :value 10) + (function :tag "Format with function" :value identity))) + (defun dired-sort-set-mode-line () - ;; Set mode line display according to dired-actual-switches. - ;; Mode line display of "by name" or "by date" guarantees the user a - ;; match with the corresponding regexps. Non-matching switches are - ;; shown literally. + "Set mode-line according to option `dired-switches-in-mode-line'." (when (eq major-mode 'dired-mode) (setq mode-name - (let (case-fold-search) - (cond ((string-match-p - dired-sort-by-name-regexp dired-actual-switches) - "Dired by name") - ((string-match-p - dired-sort-by-date-regexp dired-actual-switches) - "Dired by date") - (t - (concat "Dired " dired-actual-switches))))) + (let ((case-fold-search nil)) + (if dired-switches-in-mode-line + (concat + "Dired" + (cond ((integerp dired-switches-in-mode-line) + (let* ((l1 (length dired-actual-switches)) + (xs (substring + dired-actual-switches + 0 (min l1 dired-switches-in-mode-line))) + (l2 (length xs))) + (if (zerop l2) + xs + (concat " " xs (and (< l2 l1) "…"))))) + ((functionp dired-switches-in-mode-line) + (format " %s" (funcall + dired-switches-in-mode-line + dired-actual-switches))) + (t (concat " " dired-actual-switches)))) + (cond ((string-match-p dired-sort-by-name-regexp + dired-actual-switches) + "Dired by name") + ((string-match-p dired-sort-by-date-regexp + dired-actual-switches) + "Dired by date") + (t (concat "Dired " dired-actual-switches)))))) (force-mode-line-update))) (define-obsolete-function-alias 'dired-sort-set-modeline commit 0bd221b29fa29ebcd4b168d9abc67745ef5f85c2 Author: Lars Ingebrigtsen Date: Wed Sep 30 17:36:39 2020 +0200 Fix problem of having the wrong window selected after saving foo.gpg * lisp/epa.el (epa--select-keys): Restore the window configuration after selecting the key to use (bug#43703). This also ensures that the buffer we were editing ends up as the current buffer after saving it, instead of selecting a different window. diff --git a/lisp/epa.el b/lisp/epa.el index 609ac5d191..a2fb7f2bd1 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -435,33 +435,35 @@ q trust status questionable. - trust status unspecified. (unless (and epa-keys-buffer (buffer-live-p epa-keys-buffer)) (setq epa-keys-buffer (generate-new-buffer "*Keys*"))) - (with-current-buffer epa-keys-buffer - (epa-key-list-mode) - ;; C-c C-c is the usual way to finish the selection (bug#11159). - (define-key (current-local-map) "\C-c\C-c" 'exit-recursive-edit) - (let ((inhibit-read-only t) - buffer-read-only) - (erase-buffer) - (insert prompt "\n" - (substitute-command-keys "\ + (let ((conf (current-window-configuration))) + (with-current-buffer epa-keys-buffer + (epa-key-list-mode) + ;; C-c C-c is the usual way to finish the selection (bug#11159). + (define-key (current-local-map) "\C-c\C-c" 'exit-recursive-edit) + (let ((inhibit-read-only t) + buffer-read-only) + (erase-buffer) + (insert prompt "\n" + (substitute-command-keys "\ - `\\[epa-mark-key]' to mark a key on the line - `\\[epa-unmark-key]' to unmark a key on the line\n")) - (insert-button "[Cancel]" - 'action (lambda (_button) (abort-recursive-edit))) - (insert " ") - (insert-button "[OK]" - 'action (lambda (_button) (exit-recursive-edit))) - (insert "\n\n") - (epa--insert-keys keys) - (setq epa-exit-buffer-function #'abort-recursive-edit) - (goto-char (point-min)) - (let ((display-buffer-mark-dedicated 'soft)) - (pop-to-buffer (current-buffer)))) - (unwind-protect - (progn - (recursive-edit) - (epa--marked-keys)) - (kill-buffer epa-keys-buffer)))) + (insert-button "[Cancel]" + 'action (lambda (_button) (abort-recursive-edit))) + (insert " ") + (insert-button "[OK]" + 'action (lambda (_button) (exit-recursive-edit))) + (insert "\n\n") + (epa--insert-keys keys) + (setq epa-exit-buffer-function #'abort-recursive-edit) + (goto-char (point-min)) + (let ((display-buffer-mark-dedicated 'soft)) + (pop-to-buffer (current-buffer)))) + (unwind-protect + (progn + (recursive-edit) + (epa--marked-keys)) + (kill-buffer epa-keys-buffer) + (set-window-configuration conf))))) ;;;###autoload (defun epa-select-keys (context prompt &optional names secret) commit a190a446ee2be283dbd48351af507d7c64b1af9e Author: Eli Zaretskii Date: Wed Sep 30 17:33:58 2020 +0300 Fix 'move-to-column' when invisible text follows a TAB * src/indent.c (scan_for_column): Accept 2 more arguments, and report through them the position corresponding to PREVCOL. All callers changed. (Fmove_to_column): Use the prev_col's position to test for a TAB instead of assuming that the TAB is just before point (which is false when there's invisible text around). (Bug#43587) * test/src/indent-tests.el: New file. diff --git a/src/indent.c b/src/indent.c index 581323b91e..4ecf02b6b9 100644 --- a/src/indent.c +++ b/src/indent.c @@ -524,9 +524,11 @@ check_display_width (ptrdiff_t pos, ptrdiff_t col, ptrdiff_t *endpos) comes first. Return the resulting buffer position and column in ENDPOS and GOALCOL. PREVCOL gets set to the column of the previous position (it's always - strictly smaller than the goal column). */ + strictly smaller than the goal column), and PREVPOS and PREVBPOS get set + to the corresponding buffer character and byte positions. */ static void -scan_for_column (ptrdiff_t *endpos, EMACS_INT *goalcol, ptrdiff_t *prevcol) +scan_for_column (ptrdiff_t *endpos, EMACS_INT *goalcol, + ptrdiff_t *prevpos, ptrdiff_t *prevbpos, ptrdiff_t *prevcol) { int tab_width = SANE_TAB_WIDTH (current_buffer); bool ctl_arrow = !NILP (BVAR (current_buffer, ctl_arrow)); @@ -540,10 +542,12 @@ scan_for_column (ptrdiff_t *endpos, EMACS_INT *goalcol, ptrdiff_t *prevcol) register ptrdiff_t col = 0, prev_col = 0; EMACS_INT goal = goalcol ? *goalcol : MOST_POSITIVE_FIXNUM; ptrdiff_t end = endpos ? *endpos : PT; - ptrdiff_t scan, scan_byte, next_boundary; + ptrdiff_t scan, scan_byte, next_boundary, prev_pos, prev_bpos; scan = find_newline (PT, PT_BYTE, BEGV, BEGV_BYTE, -1, NULL, &scan_byte, 1); next_boundary = scan; + prev_pos = scan; + prev_bpos = scan_byte; window = Fget_buffer_window (Fcurrent_buffer (), Qnil); w = ! NILP (window) ? XWINDOW (window) : NULL; @@ -576,6 +580,8 @@ scan_for_column (ptrdiff_t *endpos, EMACS_INT *goalcol, ptrdiff_t *prevcol) if (col >= goal) break; prev_col = col; + prev_pos = scan; + prev_bpos = scan_byte; { /* Check display property. */ ptrdiff_t endp; @@ -705,6 +711,10 @@ scan_for_column (ptrdiff_t *endpos, EMACS_INT *goalcol, ptrdiff_t *prevcol) *goalcol = col; if (endpos) *endpos = scan; + if (prevpos) + *prevpos = prev_pos; + if (prevbpos) + *prevbpos = prev_bpos; if (prevcol) *prevcol = prev_col; } @@ -720,7 +730,7 @@ current_column_1 (void) EMACS_INT col = MOST_POSITIVE_FIXNUM; ptrdiff_t opoint = PT; - scan_for_column (&opoint, &col, NULL); + scan_for_column (&opoint, &col, NULL, NULL, NULL); return col; } @@ -988,7 +998,7 @@ to reach COLUMN, add spaces/tabs to get there. The return value is the current column. */) (Lisp_Object column, Lisp_Object force) { - ptrdiff_t pos, prev_col; + ptrdiff_t pos, prev_pos, prev_bpos, prev_col; EMACS_INT col; EMACS_INT goal; @@ -997,7 +1007,7 @@ The return value is the current column. */) col = goal; pos = ZV; - scan_for_column (&pos, &col, &prev_col); + scan_for_column (&pos, &col, &prev_pos, &prev_bpos, &prev_col); SET_PT (pos); @@ -1006,18 +1016,16 @@ The return value is the current column. */) if (!NILP (force) && col > goal) { int c; - ptrdiff_t pos_byte = PT_BYTE; - pos_byte -= prev_char_len (pos_byte); - c = FETCH_CHAR (pos_byte); - if (c == '\t' && prev_col < goal) + c = FETCH_CHAR (prev_bpos); + if (c == '\t' && prev_col < goal && prev_bpos < PT_BYTE) { ptrdiff_t goal_pt, goal_pt_byte; /* Insert spaces in front of the tab to reach GOAL. Do this first so that a marker at the end of the tab gets adjusted. */ - SET_PT_BOTH (PT - 1, PT_BYTE - 1); + SET_PT_BOTH (prev_pos, prev_bpos); Finsert_char (make_fixnum (' '), make_fixnum (goal - prev_col), Qt); /* Now delete the tab, and indent to COL. */ diff --git a/test/src/indent-tests.el b/test/src/indent-tests.el new file mode 100644 index 0000000000..7d1a6ce6dc --- /dev/null +++ b/test/src/indent-tests.el @@ -0,0 +1,59 @@ +;;; indent-tests.el --- tests for src/indent.c -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `https://www.gnu.org/licenses/'. + +;;; Commentary: + +;;; Code: + +(ert-deftest indent-tests-move-to-column-invis-1tab () + "Test `move-to-column' when a TAB is followed by invisible text." + (should + (string= + (with-temp-buffer + (insert "\tLine starting with INVISIBLE text after TAB\n") + (add-text-properties 2 21 '(invisible t)) + (goto-char (point-min)) + (move-to-column 7 t) + (buffer-substring-no-properties 1 8)) + " "))) + +(ert-deftest indent-tests-move-to-column-invis-2tabs () + "Test `move-to-column' when 2 TABs are followed by invisible text." + (should + (string= + (with-temp-buffer + (insert "\t\tLine starting with INVISIBLE text after TAB\n") + (add-text-properties 3 22 '(invisible t)) + (goto-char (point-min)) + (move-to-column 12 t) + (buffer-substring-no-properties 1 11)) + "\t \tLine"))) + +(ert-deftest indent-tests-move-to-column-invis-between-tabs () + "Test `move-to-column' when 2 TABs are mixed with invisible text." + (should + (string= + (with-temp-buffer + (insert "\txxx\tLine starting with INVISIBLE text after TAB\n") + (add-text-properties 6 25 '(invisible t)) + (add-text-properties 2 5 '(invisible t)) + (goto-char (point-min)) + (move-to-column 12 t) + (buffer-substring-no-properties 1 14)) + "\txxx \tLine"))) commit 56d6e29d8063552b6a293f67f91ce6967913d928 Author: Lars Ingebrigtsen Date: Wed Sep 30 16:12:27 2020 +0200 Clarify the "Forgot to expand macro" message * lisp/emacs-lisp/bytecomp.el (byte-compile-form): Make the define-after-use warning for macros clearer (bug#43678). diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 966990bac9..7c95c91800 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3174,7 +3174,8 @@ for symbols generated by the byte compiler itself." (t ".")))) (if (eq (car-safe (symbol-function (car form))) 'macro) (byte-compile-report-error - (format "Forgot to expand macro %s in %S" (car form) form))) + (format "`%s' defined after use in %S (missing `require' of a library file?)" + (car form) form))) (if (and handler ;; Make sure that function exists. (and (functionp handler) commit ed99a1eb894ab2e02cb3126aacff9e61eb1e473b Author: Eli Zaretskii Date: Wed Sep 30 16:56:08 2020 +0300 Minor fixes of recent changes * lisp/emacs-lisp/generic.el (define-generic-mode): Fix typos. * etc/NEWS: Adjust an entry due to recent changes. diff --git a/etc/NEWS b/etc/NEWS index 10b99f413b..7be793e01a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1086,6 +1086,8 @@ keystrokes. 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' user option. +This feature is available only on terminals that have enough colors to +distinguish between sub-expression highlighting. --- *** New user option 'reveal-auto-hide'. diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index a9328a6903..3bc6d021dc 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -117,7 +117,7 @@ instead (which see).") "Create a new generic mode MODE. A \"generic\" mode is a simple major mode with basic support for -comment syntax and Font Lock mode, but otherwise do not have a +comment syntax and Font Lock mode, but otherwise does not have any special keystrokes or functionality available. MODE is the name of the command for the generic mode; don't quote it. commit b7224f9629ce549806ae3b4c974ce937bb20e840 Author: Michael Albinus Date: Wed Sep 30 15:28:53 2020 +0200 Stricter checks for D-Bus compound types. * src/dbusbind.c (XD_DBUS_TYPE_P, Fdbus__init_bus) (xd_read_queued_messages): Use Fkeywordp instead of SYMBOLP. (xd_signature): Stricter checks for compound types. * test/lisp/net/dbus-tests.el (dbus-test01-compound-types): Extend test. diff --git a/src/dbusbind.c b/src/dbusbind.c index b06077d3b5..36f8655694 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -211,7 +211,7 @@ xd_dbus_type_to_symbol (int type) /* Check whether a Lisp symbol is a predefined D-Bus type symbol. */ #define XD_DBUS_TYPE_P(object) \ - (SYMBOLP (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID))) + Fkeywordp (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID)) /* Determine the DBusType of a given Lisp OBJECT. It is used to convert Lisp objects, being arguments of `dbus-call-method' or @@ -463,6 +463,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) CHECK_CONS (object); elt = XD_NEXT_VALUE (elt); + CHECK_CONS (elt); subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)); xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt))); @@ -474,11 +475,12 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) break; case DBUS_TYPE_STRUCT: - /* A struct list might contain any number of elements with - different types. No further check needed. */ + /* A struct list might contain any (but zero) number of elements + with different types. No further check needed. */ CHECK_CONS (object); elt = XD_NEXT_VALUE (elt); + CHECK_CONS (elt); /* Compose the signature from the elements. It is enclosed by parentheses. */ @@ -509,6 +511,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) /* First element. */ elt = XD_NEXT_VALUE (elt); + CHECK_CONS (elt); subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)); xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt))); xd_signature_cat (signature, x); @@ -518,6 +521,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) /* Second element. */ elt = CDR_SAFE (XD_NEXT_VALUE (elt)); + CHECK_CONS (elt); subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)); xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt))); xd_signature_cat (signature, x); @@ -1227,7 +1231,7 @@ this connection to those buses. */) xd_add_watch, xd_remove_watch, xd_toggle_watch, - SYMBOLP (bus) + Fkeywordp (bus) ? (void *) XSYMBOL (bus) : (void *) XSTRING (bus), NULL)) @@ -1793,7 +1797,7 @@ xd_read_queued_messages (int fd, void *data) while (!NILP (busp)) { key = CAR_SAFE (CAR_SAFE (busp)); - if ((SYMBOLP (key) && XSYMBOL (key) == data) + if ((Fkeywordp (key) && XSYMBOL (key) == data) || (STRINGP (key) && XSTRING (key) == data)) bus = key; busp = CDR_SAFE (busp); diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 6c77f60ec9..759cd10289 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -366,11 +366,11 @@ (should (dbus-check-arguments :session dbus--test-service '(:variant (:array "string")))) - ;; No or more than one element. - ;; FIXME. - ;; (should-error - ;; (dbus-check-arguments :session dbus--test-service '(:variant)) - ;; :type 'wrong-type-argument) + ;; Empty variant. + (should-error + (dbus-check-arguments :session dbus--test-service '(:variant)) + :type 'wrong-type-argument) + ;; More than one element. (should-error (dbus-check-arguments :session dbus--test-service @@ -382,20 +382,22 @@ (should (dbus-check-arguments :session dbus--test-service - '(:array (:dict-entry :string "string" :boolean t)))) + '(:array (:dict-entry :string "string" :boolean nil)))) ;; This is an alternative syntax. FIXME: Shall this be supported? (should (dbus-check-arguments :session dbus--test-service '(:array :dict-entry (:string "string" :boolean t)))) - ;; FIXME: Must be errors. - ;; (should - ;; (dbus-check-arguments - ;; :session dbus--test-service '(:array (:dict-entry)))) - ;; (should - ;; (dbus-check-arguments - ;; :session dbus--test-service '(:array (:dict-entry :string "string")))) - ;; Not two elements. + ;; Empty dict-entry. + (should-error + (dbus-check-arguments + :session dbus--test-service '(:array (:dict-entry))) + :type 'wrong-type-argument) + ;; One element. + (should-error + (dbus-check-arguments + :session dbus--test-service '(:array (:dict-entry :string "string"))) + :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service @@ -412,25 +414,27 @@ (dbus-check-arguments :session dbus--test-service '(:dict-entry :string "string" :boolean t)) :type 'wrong-type-argument) - ;; FIXME:! This doesn't look right. - ;; Different dict entry types can be part of an array ??? - (should - (dbus-check-arguments - :session dbus--test-service - '(:array - (:dict-entry :string "string1" :boolean t) - (:dict-entry :string "string2" :object-path "/object/path")))) + ;; Different dict entry types are not ched. FIXME: Add check. + ;; (should-error + ;; (dbus-check-arguments + ;; :session dbus--test-service + ;; '(:array + ;; (:dict-entry :string "string1" :boolean t) + ;; (:dict-entry :string "string2" :object-path "/object/path"))) + ;; :type 'wrong-type-argument) ;; `:struct'. There is no restriction what could be an element of a struct. - ;; Empty struct. FIXME: Is this right? - ;; (should (dbus-check-arguments :session dbus--test-service '(:struct))) (should (dbus-check-arguments :session dbus--test-service '(:struct :string "string" :object-path "/object/path" - (:variant (:array :unix-fd 1 :unix-fd 2 :unix-fd 3 :unix-fd 4)))))) + (:variant (:array :unix-fd 1 :unix-fd 2 :unix-fd 3 :unix-fd 4))))) + ;; Empty struct. + (should-error + (dbus-check-arguments :session dbus--test-service '(:struct)) + :type 'wrong-type-argument)) (defun dbus--test-register-service (bus) "Check service registration at BUS." commit 17ecfa8698096deb0cbd43889c6f0ded2584cce0 Author: Michael Albinus Date: Wed Sep 30 12:40:08 2020 +0200 Minor code cleanup in dbus-tests.el * test/lisp/net/dbus-tests.el (dbus--tests-dir): Make it a defconst. (dbus--test-method-reentry-handler): Mark args as unused. (dbus-test04-method-reentry): Tag it :expensive-test. Fix typo. (dbus-test06-property-types): Remove duplicate test. (dbus--test-introspect): Use `insert-file-contents-literally'. (dbus--test-validate-property): Mark expected-annotations as unused. (dbus--test-validate-m-or-s): Remove superfluous le-clause. diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 3e70475a47..6c77f60ec9 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -46,7 +46,7 @@ (defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface" "Test interface.") -(defvar dbus--tests-dir +(defconst dbus--tests-dir (file-truename (expand-file-name "dbus-resources" (file-name-directory (or load-file-name @@ -632,7 +632,7 @@ This includes initialization and closing the bus." ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) -(defun dbus--test-method-reentry-handler (&rest args) +(defun dbus--test-method-reentry-handler (&rest _args) "Method handler for `dbus-test04-method-reentry'." (dbus-get-all-managed-objects :session dbus--test-service dbus--test-path) 42) @@ -641,12 +641,13 @@ This includes initialization and closing the bus." "Check receiving method call while awaiting response. Ensure that incoming method calls are handled when call to `dbus-call-method' is in progress." - ;; Simulate application registration (Bug#43251) + :tags '(:expensive-test) + ;; Simulate application registration. (Bug#43251) (skip-unless dbus--test-enabled-session-bus) (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) (unwind-protect - (let ((method "Rentry")) + (let ((method "Reentry")) (should (equal (dbus-register-method @@ -685,8 +686,8 @@ is in progress." (should (< 2.4 (float-time (time-since start)) 2.7))) - (dbus-unregister-service :session dbus--test-service))) - + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) (defvar dbus--test-signal-received nil "Received signal value in `dbus--test-signal-handler'.") @@ -1180,7 +1181,6 @@ form `dbus-get-property' should return." (should (setq result1 (cadr (assoc dbus--test-interface result1)))) (should (equal (cdr (assoc name result1)) expected)))) - (defsubst dbus--test-property (name &rest value-list) "Test a D-Bus property named by string argument NAME. The argument VALUE-LIST is a sequence of pairs, where each pair @@ -1238,7 +1238,8 @@ Subsequent pairs of the list are tested with `dbus-set-property'." ("six" ((4 5 6))))) '((:array - :dict-entry (:string "key0" (:variant (:array :byte 7 :byte 8 :byte 9))) + :dict-entry + (:string "key0" (:variant (:array :byte 7 :byte 8 :byte 9))) :dict-entry ("key1" (:variant :string "value")) :dict-entry ("key2" (:variant :object-path "/node0/node1"))) . (("key0" @@ -1261,7 +1262,8 @@ Subsequent pairs of the list are tested with `dbus-set-property'." ("nine" ((9 27 81))))) '((:array - (:dict-entry :string "key4" (:variant (:array :byte 7 :byte 49 :byte 125))) + (:dict-entry + :string "key4" (:variant (:array :byte 7 :byte 49 :byte 125))) (:dict-entry "key5" (:variant :string "obsolete")) (:dict-entry "key6" (:variant :object-path "/node6/node7"))) . (("key4" @@ -1274,10 +1276,10 @@ Subsequent pairs of the list are tested with `dbus-set-property'." (dbus--test-property "ByteDictionary" '((:array - (:dict-entry :byte 8 (:variant :string "byte-eight")) + (:dict-entry :byte 8 (:variant :string "byte-eight")) (:dict-entry :byte 16 (:variant :object-path "/byte/sixteen")) (:dict-entry :byte 48 (:variant (:array :byte 8 :byte 9 :byte 10)))) - . ((8 ("byte-eight")) + . (( 8 ("byte-eight")) (16 ("/byte/sixteen")) (48 ((8 9 10)))))) @@ -1288,8 +1290,10 @@ Subsequent pairs of the list are tested with `dbus-set-property'." '((:variant :uint32 1000000) . (1000000)) '((:variant :object-path "/variant/path") . ("/variant/path")) '((:variant :signature "a{sa{sv}}") . ("a{sa{sv}}")) - '((:variant (:struct 42 "string" (:object-path "/structure/path") (:variant "last"))) - . ((42 "string" ("/structure/path") ("last"))))) + '((:variant + (:struct + 42 "string" (:object-path "/structure/path") (:variant "last"))) + . ((42 "string" ("/structure/path") ("last"))))) ;; Test that :read prevents writes. (should @@ -1313,13 +1317,6 @@ Subsequent pairs of the list are tested with `dbus-set-property'." "StringArray") '("one" "two" "three"))) - (should ; Verify property has registered value. - (equal - (dbus-get-property - :session dbus--test-service dbus--test-path dbus--test-interface - "StringArray") - '("one" "two" "three"))) - ;; Test mismatched types in array. (should-error (dbus-register-property @@ -1503,7 +1500,6 @@ Subsequent pairs of the list are tested with `dbus-set-property'." "ByteValue") 1024)) - (should ; Another change property type test. (equal (dbus-set-property @@ -1532,7 +1528,8 @@ Subsequent pairs of the list are tested with `dbus-set-property'." "Return test introspection string." (when (string-equal dbus--test-path (dbus-event-path-name last-input-event)) (with-temp-buffer - (insert-file (expand-file-name "org.gnu.Emacs.TestDBus.xml" dbus--tests-dir)) + (insert-file-contents-literally + (expand-file-name "org.gnu.Emacs.TestDBus.xml" dbus--tests-dir)) (buffer-string)))) (defsubst dbus--test-validate-interface @@ -1595,7 +1592,7 @@ And ensure each ANNOTATIONS has a value attribute marked \"true\"." annotations)) (defsubst dbus--test-validate-property - (interface property-name expected-annotations &rest expected-args) + (interface property-name _expected-annotations &rest expected-args) "Validate a property definition for `dbus-test07-introspection'. The argument INTERFACE is a string naming the interface owning PROPERTY-NAME. @@ -1640,10 +1637,9 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method or signal." (let (args annotations) (mapc (lambda (elem) - (let ((name (dbus-introspect-get-attribute elem "name"))) - (cond - ((eq 'arg (car elem)) (push elem args)) - ((eq 'annotation (car elem)) (push elem annotations))))) + (cond + ((eq 'arg (car elem)) (push elem args)) + ((eq 'annotation (car elem)) (push elem annotations)))) tree) (should (equal @@ -1670,7 +1666,6 @@ The argument EXPECTED-ARGS is a list of expected arguments for the signal." (string-equal name (dbus-introspect-get-attribute signal "name"))) (dbus--test-validate-m-or-s rest expected-annotations expected-args)))) - (defsubst dbus--test-validate-method (interface method-name expected-annotations &rest expected-args) "Validate a method definition for `dbus-test07-introspection'. @@ -1741,7 +1736,7 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." (dbus--test-validate-interface dbus-interface-introspectable nil '("Introspect") nil nil) - ;; dbus-introspect-get-interface via `dbus--test-validate-interface' + ;; dbus-introspect-get-interface via `dbus--test-validate-interface'. (dbus--test-validate-interface dbus-interface-properties nil '("Get" "Set" "GetAll") '("PropertiesChanged") nil) @@ -1761,7 +1756,7 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." methods '("Connect" "DeprecatedMethod0" "DeprecatedMethod1"))) - ;; dbus-introspect-get-method via 'dbus--test-validate-method + ;; dbus-introspect-get-method via `dbus--test-validate-method'. (dbus--test-validate-method dbus--test-interface "Connect" nil '(arg ((name . "uuid") (type . "s") (direction . "in"))) @@ -1787,7 +1782,7 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." signals '("PropertiesChanged"))) - ;; dbus-introspect-get-signal via 'dbus--test-validate-signal + ;; dbus-introspect-get-signal via `dbus--test-validate-signal'. (dbus--test-validate-signal dbus-interface-properties "PropertiesChanged" nil '(arg ((name . "interface") (type . "s"))) @@ -1804,7 +1799,7 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." properties '("Connected" "Player"))) - ;; dbus-introspect-get-property via 'dbus--test-validate-property + ;; dbus-introspect-get-property via `dbus--test-validate-property'. (dbus--test-validate-property dbus--test-interface "Connected" nil '("Connected" "b" "read") @@ -1814,6 +1809,7 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." (should (< 0.0 (float-time (time-since start)) 1.0))) + ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) (ert-deftest dbus-test07-introspection-timeout () @@ -1830,7 +1826,8 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." (should (< 1.0 (float-time (time-since start))))) - (dbus-unregister-service :session dbus--test-service))) + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." commit d5f9a07862b941a53f89e6016594daee6560ff84 Author: Hugh Daschbach Date: Wed Sep 30 11:27:22 2020 +0200 Add D-Bus method-call reentrant test * test/lisp/net/dbus-tests.el (dbus--tests-method-reentry-handler): New defun. (dbus-test04-method-reentry): New test. (Bug#43251) diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index e0c63b2af4..3e70475a47 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -632,6 +632,40 @@ This includes initialization and closing the bus." ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) +(defun dbus--test-method-reentry-handler (&rest args) + "Method handler for `dbus-test04-method-reentry'." + (dbus-get-all-managed-objects :session dbus--test-service dbus--test-path) + 42) + +(ert-deftest dbus-test04-method-reentry () + "Check receiving method call while awaiting response. +Ensure that incoming method calls are handled when call to `dbus-call-method' +is in progress." + ;; Simulate application registration (Bug#43251) + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((method "Rentry")) + (should + (equal + (dbus-register-method + :session dbus--test-service dbus--test-path + dbus--test-interface method #'dbus--test-method-reentry-handler) + `((:method :session ,dbus--test-interface ,method) + (,dbus--test-service ,dbus--test-path + dbus--test-method-reentry-handler)))) + + (should + (= + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method) + 42))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + (ert-deftest dbus-test04-call-method-timeout () "Verify `dbus-call-method' request timeout." :tags '(:expensive-test) commit 2018090987896a547440575b28b2fc6dc6df81fb Author: Hugh Daschbach Date: Wed Sep 30 11:23:24 2020 +0200 * test/lisp/net/dbus-tests.el: Add timeout tests. (dbus-test04-call-method-timeout, dbus-test07-introspection-timeout): New tests. diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index bb153f0af8..e0c63b2af4 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -632,6 +632,28 @@ This includes initialization and closing the bus." ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) +(ert-deftest dbus-test04-call-method-timeout () + "Verify `dbus-call-method' request timeout." + :tags '(:expensive-test) + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + (unwind-protect + (let ((start (current-time))) + ;; Test timeout override for method call. + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus-interface-introspectable "Introspect" :timeout 2500) + :type 'dbus-error) + + (should + (< 2.4 (float-time (time-since start)) 2.7))) + + (dbus-unregister-service :session dbus--test-service))) + + (defvar dbus--test-signal-received nil "Received signal value in `dbus--test-signal-handler'.") @@ -1760,6 +1782,22 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." (dbus-unregister-service :session dbus--test-service))) +(ert-deftest dbus-test07-introspection-timeout () + "Verify introspection request timeouts." + :tags '(:expensive-test) + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + (unwind-protect + (let ((start (current-time))) + (dbus-introspect-xml :session dbus--test-service dbus--test-path) + ;; Introspection internal timeout is one second. + (should + (< 1.0 (float-time (time-since start))))) + + (dbus-unregister-service :session dbus--test-service))) + (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." (interactive "p") commit 0bc19c17fd003655c28656cffe73fa5b2a36d11f Author: Hugh Daschbach Date: Wed Sep 30 11:19:41 2020 +0200 Add D-Bus introspection tests * lisp/net/dbus.el (dbus-annotation-deprecated): New defconst. * test/lisp/net/dbus-tests.el (dbus--tests-dir): New defvar. (dbus--test-introspect, dbus--test-validate-interface) (dbus--test-validate-annotations, dbus--test-validate-property) (dbus--test-validate-m-or-s, dbus--test-validate-signal) (dbus--test-validate-method): New defuns. (dbus-test07-introspection): New test. * test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml: New test data. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 23ba191e3c..48712a9c3d 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -165,6 +165,9 @@ See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#bus-messages-b ;; ;; +(defconst dbus-annotation-deprecated (concat dbus-interface-dbus ".Deprecated") + "An annotation indicating a deprecated interface, method, signal, or property.") + ;;; Default D-Bus errors. diff --git a/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml b/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml new file mode 100644 index 0000000000..620f10510f --- /dev/null +++ b/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml @@ -0,0 +1,49 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index b88b257dfe..bb153f0af8 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -46,6 +46,13 @@ (defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface" "Test interface.") +(defvar dbus--tests-dir + (file-truename + (expand-file-name "dbus-resources" + (file-name-directory (or load-file-name + buffer-file-name)))) + "Directory containing introspection test data file.") + (defun dbus--test-availability (bus) "Test availability of D-Bus BUS." (should (dbus-list-names bus)) @@ -1465,6 +1472,294 @@ Subsequent pairs of the list are tested with `dbus-set-property'." ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) +(defun dbus--test-introspect () + "Return test introspection string." + (when (string-equal dbus--test-path (dbus-event-path-name last-input-event)) + (with-temp-buffer + (insert-file (expand-file-name "org.gnu.Emacs.TestDBus.xml" dbus--tests-dir)) + (buffer-string)))) + +(defsubst dbus--test-validate-interface + (iface-name expected-properties expected-methods expected-signals + expected-annotations) + "Validate an interface definition for `dbus-test07-introspection'. +The argument IFACE-NAME is a string naming the interface to validate. +The arguments EXPECTED-PROPERTIES, EXPECTED-METHODS, EXPECTED-SIGNALS, and +EXPECTED-ANNOTATIONS represent the names of the interface's properties, +methods, signals, and annotations, respectively." + + (let ((interface + (dbus-introspect-get-interface + :session dbus--test-service dbus--test-path iface-name))) + (pcase-let ((`(interface ((name . ,name)) . ,rest) interface)) + (should + (string-equal name iface-name)) + (should + (string-equal name (dbus-introspect-get-attribute interface "name"))) + + (let (properties methods signals annotations) + (mapc (lambda (x) + (let ((name (dbus-introspect-get-attribute x "name"))) + (cond + ((eq 'property (car x)) (push name properties)) + ((eq 'method (car x)) (push name methods)) + ((eq 'signal (car x)) (push name signals)) + ((eq 'annotation (car x)) (push name annotations))))) + rest) + + (should + (equal + (nreverse properties) + expected-properties)) + (should + (equal + (nreverse methods) + expected-methods)) + (should + (equal + (nreverse signals) + expected-signals)) + (should + (equal + (nreverse annotations) + expected-annotations)))))) + +(defsubst dbus--test-validate-annotations (annotations expected-annotations) + "Validate a list of D-Bus ANNOTATIONS. +Ensure each string in EXPECTED-ANNOTATIONS names an element of ANNOTATIONS. +And ensure each ANNOTATIONS has a value attribute marked \"true\"." + (mapc + (lambda (annotation) + (let ((name (dbus-introspect-get-attribute annotation "name")) + (value (dbus-introspect-get-attribute annotation "value"))) + (should + (member name expected-annotations)) + (should + (equal value "true")))) + annotations)) + +(defsubst dbus--test-validate-property + (interface property-name expected-annotations &rest expected-args) + "Validate a property definition for `dbus-test07-introspection'. + +The argument INTERFACE is a string naming the interface owning PROPERTY-NAME. +The argument PROPERTY-NAME is a string naming the property to validate. +The arguments EXPECTED-ANNOTATIONS is a list of strings matching +the annotation names defined for the method or signal. +The argument EXPECTED-ARGS is a list of expected arguments for the property." + (let* ((property + (dbus-introspect-get-property + :session dbus--test-service dbus--test-path interface property-name)) + (name (dbus-introspect-get-attribute property "name")) + (type (dbus-introspect-get-attribute property "type")) + (access (dbus-introspect-get-attribute property "access")) + (expected (assoc-string name expected-args))) + (should expected) + + (should + (string-equal name property-name)) + + (should + (string-equal + (nth 0 expected) + name)) + + (should + (string-equal + (nth 1 expected) + type)) + + (should + (string-equal + (nth 2 expected) + access)))) + +(defsubst dbus--test-validate-m-or-s (tree expected-annotations expected-args) + "Validate a method or signal definition for `dbus-test07-introspection'. +The argument TREE is an sexp returned from either `dbus-introspect-get-method' +or `dbus-introspect-get-signal' +The arguments EXPECTED-ANNOTATIONS is a list of strings matching +the annotation names defined for the method or signal. +The argument EXPECTED-ARGS is a list of expected arguments for +the method or signal." + (let (args annotations) + (mapc (lambda (elem) + (let ((name (dbus-introspect-get-attribute elem "name"))) + (cond + ((eq 'arg (car elem)) (push elem args)) + ((eq 'annotation (car elem)) (push elem annotations))))) + tree) + (should + (equal + (nreverse args) + expected-args)) + (dbus--test-validate-annotations annotations expected-annotations))) + +(defsubst dbus--test-validate-signal + (interface signal-name expected-annotations &rest expected-args) + "Validate a signal definition for `dbus-test07-introspection'. + +The argument INTERFACE is a string naming the interface owning SIGNAL-NAME. +The argument SIGNAL-NAME is a string naming the signal to validate. +The arguments EXPECTED-ANNOTATIONS is a list of strings matching +the annotation names defined for the signal. +The argument EXPECTED-ARGS is a list of expected arguments for the signal." + (let ((signal + (dbus-introspect-get-signal + :session dbus--test-service dbus--test-path interface signal-name))) + (pcase-let ((`(signal ((name . ,name)) . ,rest) signal)) + (should + (string-equal name signal-name)) + (should + (string-equal name (dbus-introspect-get-attribute signal "name"))) + (dbus--test-validate-m-or-s rest expected-annotations expected-args)))) + + +(defsubst dbus--test-validate-method + (interface method-name expected-annotations &rest expected-args) + "Validate a method definition for `dbus-test07-introspection'. + +The argument INTERFACE is a string naming the interface owning METHOD-NAME. +The argument METHOD-NAME is a string naming the method to validate. +The arguments EXPECTED-ANNOTATIONS is a list of strings matching +the annotation names defined for the method. +The argument EXPECTED-ARGS is a list of expected arguments for the method." + (let ((method + (dbus-introspect-get-method + :session dbus--test-service dbus--test-path interface method-name))) + (pcase-let ((`(method ((name . ,name)) . ,rest) method)) + (should + (string-equal name method-name)) + (should + (string-equal name (dbus-introspect-get-attribute method "name"))) + (dbus--test-validate-m-or-s rest expected-annotations expected-args)))) + +(ert-deftest dbus-test07-introspection () + "Register an Introspection interface then query it." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + ;; Prepare introspection response. + (dbus-register-method + :session dbus--test-service dbus--test-path dbus-interface-introspectable + "Introspect" 'dbus--test-introspect) + (dbus-register-method + :session dbus--test-service (concat dbus--test-path "/node0") + dbus-interface-introspectable + "Introspect" 'dbus--test-introspect) + (dbus-register-method + :session dbus--test-service (concat dbus--test-path "/node1") + dbus-interface-introspectable + "Introspect" 'dbus--test-introspect) + (unwind-protect + (let ((start (current-time))) + ;; dbus-introspect-get-node-names + (should + (equal + (dbus-introspect-get-node-names + :session dbus--test-service dbus--test-path) + '("node0" "node1"))) + + ;; dbus-introspect-get-all-nodes + (should + (equal + (dbus-introspect-get-all-nodes + :session dbus--test-service dbus--test-path) + (list dbus--test-path + (concat dbus--test-path "/node0") + (concat dbus--test-path "/node1")))) + + ;; dbus-introspect-get-interface-names + (let ((interfaces + (dbus-introspect-get-interface-names + :session dbus--test-service dbus--test-path))) + + (should + (equal + interfaces + `(,dbus-interface-introspectable + ,dbus-interface-properties + ,dbus--test-interface))) + + (dbus--test-validate-interface + dbus-interface-introspectable nil '("Introspect") nil nil) + + ;; dbus-introspect-get-interface via `dbus--test-validate-interface' + (dbus--test-validate-interface + dbus-interface-properties nil + '("Get" "Set" "GetAll") '("PropertiesChanged") nil) + + (dbus--test-validate-interface + dbus--test-interface '("Connected" "Player") + '("Connect" "DeprecatedMethod0" "DeprecatedMethod1") nil + `(,dbus-annotation-deprecated))) + + ;; dbus-introspect-get-method-names + (let ((methods + (dbus-introspect-get-method-names + :session dbus--test-service dbus--test-path + dbus--test-interface))) + (should + (equal + methods + '("Connect" "DeprecatedMethod0" "DeprecatedMethod1"))) + + ;; dbus-introspect-get-method via 'dbus--test-validate-method + (dbus--test-validate-method + dbus--test-interface "Connect" nil + '(arg ((name . "uuid") (type . "s") (direction . "in"))) + '(arg ((name . "mode") (type . "y") (direction . "in"))) + '(arg ((name . "options") (type . "a{sv}") (direction . "in"))) + '(arg ((name . "interface") (type . "s") (direction . "out")))) + + (dbus--test-validate-method + dbus--test-interface "DeprecatedMethod0" + `(,dbus-annotation-deprecated)) + + (dbus--test-validate-method + dbus--test-interface "DeprecatedMethod1" + `(,dbus-annotation-deprecated))) + + ;; dbus-introspect-get-signal-names + (let ((signals + (dbus-introspect-get-signal-names + :session dbus--test-service dbus--test-path + dbus-interface-properties))) + (should + (equal + signals + '("PropertiesChanged"))) + + ;; dbus-introspect-get-signal via 'dbus--test-validate-signal + (dbus--test-validate-signal + dbus-interface-properties "PropertiesChanged" nil + '(arg ((name . "interface") (type . "s"))) + '(arg ((name . "changed_properties") (type . "a{sv}"))) + '(arg ((name . "invalidated_properties") (type . "as"))))) + + ;; dbus-intropct-get-property-names + (let ((properties + (dbus-introspect-get-property-names + :session dbus--test-service dbus--test-path + dbus--test-interface))) + (should + (equal + properties + '("Connected" "Player"))) + + ;; dbus-introspect-get-property via 'dbus--test-validate-property + (dbus--test-validate-property + dbus--test-interface "Connected" nil + '("Connected" "b" "read") + '("Player" "o" "read"))) + + ;; Elapsed time over a second suggests timeouts. + (should + (< 0.0 (float-time (time-since start)) 1.0))) + + (dbus-unregister-service :session dbus--test-service))) + (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." (interactive "p") commit 7e581607e7aa592c38a694c74a4ce427fb06c49f Author: Hugh Daschbach Date: Wed Sep 30 11:09:17 2020 +0200 * test/lisp/net/dbus-tests.el: Add property tests. (Bug#43252) (dbus--test-run-property-test, dbus--test-property): New defuns. (dbus-test06-property-types): New test for property registration, set, get. diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 74c0dddcf5..b88b257dfe 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -1069,6 +1069,402 @@ This includes initialization and closing the bus." ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) +(defsubst dbus--test-run-property-test (selector name value expected) + "Generate a property test: register, set, get, getall sequence. +This is a helper function for the macro `dbus--test-property'. +The argument SELECTOR indicates whether the test should expand to +`dbus-register-property' (if SELECTOR is `register') or +`dbus-set-property' (if SELECTOR is `set'). +The argument NAME is the property name. +The argument VALUE is the value to register or set. +The argument EXPECTED is a transformed VALUE representing the +form `dbus-get-property' should return." + (cond + ((eq selector 'register) + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface name + :readwrite value) + `((:property :session ,dbus--test-interface ,name) + (,dbus--test-service ,dbus--test-path))))) + + ((eq selector 'set) + (should + (equal + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface name + value) + expected))) + + (t (signal 'wrong-type-argument "Selector should be 'register or 'set."))) + + (should + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface name) + expected)) + + (let ((result + (dbus-get-all-properties + :session dbus--test-service dbus--test-path dbus--test-interface))) + (should (equal (cdr (assoc name result)) expected))) + + (let ((result + (dbus-get-all-managed-objects :session dbus--test-service "/")) + result1) + (should (setq result1 (cadr (assoc dbus--test-path result)))) + (should (setq result1 (cadr (assoc dbus--test-interface result1)))) + (should (equal (cdr (assoc name result1)) expected)))) + + +(defsubst dbus--test-property (name &rest value-list) + "Test a D-Bus property named by string argument NAME. +The argument VALUE-LIST is a sequence of pairs, where each pair +represents a value form and an expected returned value form. The +first pair in VALUES is used for `dbus-register-property'. +Subsequent pairs of the list are tested with `dbus-set-property'." + (let ((values (car value-list))) + (dbus--test-run-property-test + 'register name (car values) (cdr values))) + (dolist (values (cdr value-list)) + (dbus--test-run-property-test + 'set name (car values) (cdr values)))) + +(ert-deftest dbus-test06-property-types () + "Check property access and mutation for an own service." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + (unwind-protect + (progn + (dbus--test-property + "ByteArray" + '((:array :byte 1 :byte 2 :byte 3) . (1 2 3)) + '((:array :byte 4 :byte 5 :byte 6) . (4 5 6))) + + (dbus--test-property + "StringArray" + '((:array "one" "two" :string "three") . ("one" "two" "three")) + '((:array :string "four" :string "five" "six") . ("four" "five" "six"))) + + (dbus--test-property + "ObjectArray" + '((:array + :object-path "/node00" + :object-path "/node01" + :object-path "/node0/node02") + . ("/node00" "/node01" "/node0/node02")) + '((:array + :object-path "/node10" + :object-path "/node11" + :object-path "/node0/node12") + . ("/node10" "/node11" "/node0/node12"))) + + (dbus--test-property + "Dictionary" + '((:array + :dict-entry (:string "four" (:variant :string "value of four")) + :dict-entry ("five" (:variant :object-path "/node0")) + :dict-entry ("six" (:variant (:array :byte 4 :byte 5 :byte 6)))) + . (("four" + ("value of four")) + ("five" + ("/node0")) + ("six" + ((4 5 6))))) + '((:array + :dict-entry (:string "key0" (:variant (:array :byte 7 :byte 8 :byte 9))) + :dict-entry ("key1" (:variant :string "value")) + :dict-entry ("key2" (:variant :object-path "/node0/node1"))) + . (("key0" + ((7 8 9))) + ("key1" + ("value")) + ("key2" + ("/node0/node1"))))) + + (dbus--test-property ; Syntax emphasizing :dict compound type. + "Dictionary" + '((:array + (:dict-entry :string "seven" (:variant :string "value of seven")) + (:dict-entry "eight" (:variant :object-path "/node8")) + (:dict-entry "nine" (:variant (:array :byte 9 :byte 27 :byte 81)))) + . (("seven" + ("value of seven")) + ("eight" + ("/node8")) + ("nine" + ((9 27 81))))) + '((:array + (:dict-entry :string "key4" (:variant (:array :byte 7 :byte 49 :byte 125))) + (:dict-entry "key5" (:variant :string "obsolete")) + (:dict-entry "key6" (:variant :object-path "/node6/node7"))) + . (("key4" + ((7 49 125))) + ("key5" + ("obsolete")) + ("key6" + ("/node6/node7"))))) + + (dbus--test-property + "ByteDictionary" + '((:array + (:dict-entry :byte 8 (:variant :string "byte-eight")) + (:dict-entry :byte 16 (:variant :object-path "/byte/sixteen")) + (:dict-entry :byte 48 (:variant (:array :byte 8 :byte 9 :byte 10)))) + . ((8 ("byte-eight")) + (16 ("/byte/sixteen")) + (48 ((8 9 10)))))) + + (dbus--test-property + "Variant" + '((:variant "Variant string") . ("Variant string")) + '((:variant :byte 42) . (42)) + '((:variant :uint32 1000000) . (1000000)) + '((:variant :object-path "/variant/path") . ("/variant/path")) + '((:variant :signature "a{sa{sv}}") . ("a{sa{sv}}")) + '((:variant (:struct 42 "string" (:object-path "/structure/path") (:variant "last"))) + . ((42 "string" ("/structure/path") ("last"))))) + + ;; Test that :read prevents writes. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "StringArray" :read '(:array "one" "two" :string "three")) + `((:property :session ,dbus--test-interface "StringArray") + (,dbus--test-service ,dbus--test-path)))) + + (should-error ; Cannot set property with :read access. + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface + "StringArray" '(:array "seven" "eight" :string "nine")) + :type 'dbus-error) + + (should ; Property value preserved on error. + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "StringArray") + '("one" "two" "three"))) + + (should ; Verify property has registered value. + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "StringArray") + '("one" "two" "three"))) + + ;; Test mismatched types in array. + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "MixedArray" :readwrite + '(:array + :object-path "/node00" + :string "/node01" + :object-path "/node0/node02")) + :type 'wrong-type-argument) + + ;; Test in-range integer values. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue" :readwrite :byte 255) + `((:property :session ,dbus--test-interface "ByteValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue") + 255)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ShortValue" :readwrite :int16 32767) + `((:property :session ,dbus--test-interface "ShortValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ShortValue") + 32767)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UShortValue" :readwrite :uint16 65535) + `((:property :session ,dbus--test-interface "UShortValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UShortValue") + 65535)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "IntValue" :readwrite :int32 2147483647) + `((:property :session ,dbus--test-interface "IntValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "IntValue") + 2147483647)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UIntValue" :readwrite :uint32 4294967295) + `((:property :session ,dbus--test-interface "UIntValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UIntValue") + 4294967295)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "LongValue" :readwrite :int64 9223372036854775807) + `((:property :session ,dbus--test-interface "LongValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "LongValue") + 9223372036854775807)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ULongValue" :readwrite :uint64 18446744073709551615) + `((:property :session ,dbus--test-interface "ULongValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ULongValue") + 18446744073709551615)) + + ;; Test integer overflow. + (should + (= + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue" :byte 520) + 8)) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue") + 8)) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ShortValue" :readwrite :int16 32800) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UShortValue" :readwrite :uint16 65600) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "IntValue" :readwrite :int32 2147483700) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UIntValue" :readwrite :uint32 4294967300) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "LongValue" :readwrite :int64 9223372036854775900) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ULongValue" :readwrite :uint64 18446744073709551700) + :type 'args-out-of-range) + + ;; dbus-set-property may change property type. + (should + (= + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue" 1024) + 1024)) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue") + 1024)) + + + (should ; Another change property type test. + (equal + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue" :boolean t) + t)) + + (should + (eq + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue") + t)) + + ;; Test invalid type specification. + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "InvalidType" :readwrite :keyword 128) + :type 'wrong-type-argument)) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." (interactive "p")