commit de54cd6f0edb3619777c17fe75560c5c84fed8a4 (HEAD, refs/remotes/origin/master) Author: Michael Albinus Date: Thu Sep 24 10:17:03 2020 +0200 Minor Tramp cleanup * doc/misc/tramp.texi: Some stylistic changes. (Frequently Asked Questions): Mention ProxyCommand and ProxyJump. * lisp/net/tramp-sh.el (tramp-use-ssh-controlmaster-options): Fix docstring. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 538f85f35d..806a1ddf68 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -1622,7 +1622,7 @@ support this command. @subsection Tunneling with ssh -With ssh, you could use the @code{ProxyCommand} entry in +With @command{ssh}, you could use the @option{ProxyCommand} entry in @file{~/.ssh/config}: @example @@ -1802,8 +1802,8 @@ in such files, it can return host names only. @item @code{tramp-parse-sconfig} @findex tramp-parse-sconfig -This function returns the host nicknames defined by @code{Host} entries -in @file{~/.ssh/config} style files. +This function returns the host nicknames defined by @option{Host} +entries in @file{~/.ssh/config} style files. @item @code{tramp-parse-shostkeys} @findex tramp-parse-shostkeys @@ -2281,10 +2281,10 @@ example below: @end lisp @vindex password-word-equivalents -This variable is, by default, initialised from +This user option is, by default, initialised from @code{password-word-equivalents} when @value{tramp} is loaded, and it -is usually more convenient to add new passphrases to that variable -instead of altering this variable. +is usually more convenient to add new passphrases to that user option +instead of altering this user option. Similar localization may be necessary for handling wrong password prompts, for which @value{tramp} uses @code{tramp-wrong-passwd-regexp}. @@ -2725,7 +2725,7 @@ corresponding password; otherwise there is no way to decrypt your encrypted files. @defopt tramp-crypt-save-encfs-config-remote -If this user option is non-nil (the default), the @option{encfs} +If this user option is non-@code{nil} (the default), the @option{encfs} configuration file @file{.encfs6.xml} is also kept in the encrypted remote directory. It depends on you, whether you regard the password protection of this file as sufficient. The advantage would be, that @@ -3186,7 +3186,7 @@ or a string describing the signal, when the process has been interrupted. Since it cannot be determined reliably whether a remote process has been interrupted, @code{process-file} returns always the exit code. When the user option -@code{process-file-return-signal-string} is non-nil, +@code{process-file-return-signal-string} is non-@code{nil}, @code{process-file} regards all exit codes greater than 128 as an indication that the process has been interrupted, and returns a respective string. @@ -3317,8 +3317,8 @@ whatever reason, then replace @code{(getenv "DISPLAY")} with a hard-coded, fixed name. Note that using @code{:0} for X11 display name here will not work as expected. -An alternate approach is specify @code{ForwardX11 yes} or -@code{ForwardX11Trusted yes} in @file{~/.ssh/config} on the local +An alternate approach is specify @option{ForwardX11 yes} or +@option{ForwardX11Trusted yes} in @file{~/.ssh/config} on the local host. @@ -3392,22 +3392,22 @@ continuous output. @vindex shell-file-name @vindex shell-command-switch -@code{shell-command} uses the variables @code{shell-file-name} and -@code{shell-command-switch} in order to determine which shell to run. -For remote hosts, their default values are @file{/bin/sh} and -@option{-c}, respectively (except for the @option{adb} method, which -uses @file{/system/bin/sh}). Like the variables in the previous -section, these variables can be changed via connection-local -variables. +@code{shell-command} uses the user option @code{shell-file-name} and +the variable @code{shell-command-switch} in order to determine which +shell to run. For remote hosts, their default values are +@file{/bin/sh} and @option{-c}, respectively (except for the +@option{adb} method, which uses @file{/system/bin/sh}). Like the +variables in the previous section, these variables can be changed via +connection-local variables. @vindex async-shell-command-width @vindex COLUMNS@r{, environment variable} -If Emacs supports the variable @code{async-shell-command-width} (since -@w{Emacs 27}), @value{tramp} cares about its value for asynchronous -shell commands. It specifies the number of display columns for -command output. For synchronous shell commands, a similar effect can -be achieved by adding the environment variable @env{COLUMNS} to -@code{tramp-remote-process-environment}. +If Emacs supports the user option @code{async-shell-command-width} +(since @w{Emacs 27}), @value{tramp} cares about its value for +asynchronous shell commands. It specifies the number of display +columns for command output. For synchronous shell commands, a similar +effect can be achieved by adding the environment variable +@env{COLUMNS} to @code{tramp-remote-process-environment}. @subsection Running @code{eshell} on a remote host @@ -3583,7 +3583,7 @@ It works only for connection methods defined in @file{tramp-sh.el} and It does not support interactive user authentication. With @option{ssh}-based methods, this can be avoided by using a password agent like @command{ssh-agent}, using public key authentication, or -using @code{ControlMaster} options. +using @option{ControlMaster} options. @item It cannot be killed via @code{interrupt-process}. @@ -3606,7 +3606,7 @@ In order to gain even more performance, it is recommended to bind @code{tramp-verbose} to 0 when running @code{make-process} or @code{start-file-process}. Furthermore, you might set @code{tramp-use-ssh-controlmaster-options} to @code{nil} in order to -bypass @value{tramp}'s handling of the @code{ControlMaster} options, +bypass @value{tramp}'s handling of the @option{ControlMaster} options, and use your own settings in @file{~/.ssh/config}. @@ -3681,8 +3681,8 @@ On all buffers, which have a @code{buffer-file-name} matching prompted for modification in the minibuffer. The buffers are marked modified, and must be saved explicitly. -If user option @code{tramp-confirm-rename-file-names} is nil, changing -the file name happens without confirmation. This requires a +If user option @code{tramp-confirm-rename-file-names} is @code{nil}, +changing the file name happens without confirmation. This requires a matching entry in @code{tramp-default-rename-alist}. Remote buffers related to the remote connection identified by @@ -3721,8 +3721,8 @@ Tramp infers by default, such as @samp{@trampfn{method,user@@host,}}). name of @code{source} when calling @code{tramp-rename-files}. @code{source} could also be a Lisp form, which will be evaluated. The -result must be a string or nil, which is interpreted as a regular -expression which always matches. +result must be a string or @code{nil}, which is interpreted as a +regular expression which always matches. Example entries: @@ -4302,17 +4302,17 @@ Host * @item -@value{tramp} does not use default @command{ssh} @code{ControlPath} +@value{tramp} does not use default @command{ssh} @option{ControlPath} -@value{tramp} overwrites @code{ControlPath} settings when initiating +@value{tramp} overwrites @option{ControlPath} settings when initiating @command{ssh} sessions. @value{tramp} does this to fend off a stall if a master session opened outside the Emacs session is no longer open. That is why @value{tramp} prompts for the password again even if there is an @command{ssh} already open. @vindex tramp-ssh-controlmaster-options -Some @command{ssh} versions support a @code{ControlPersist} option, -which allows you to set the @code{ControlPath} provided the variable +Some @command{ssh} versions support a @option{ControlPersist} option, +which allows you to set the @option{ControlPath} provided the variable @code{tramp-ssh-controlmaster-options} is customized as follows: @lisp @@ -4337,12 +4337,16 @@ this @code{nil} setting: (customize-set-variable 'tramp-use-ssh-controlmaster-options nil) @end lisp +This shall also be set to @code{nil} if you use the +@option{ProxyCommand} or @option{ProxyJump} options in your +@command{ssh} configuration. + @item On multi-hop connections, @value{tramp} does not use @command{ssh} -@code{ControlMaster} +@option{ControlMaster} -In order to use the @code{ControlMaster} option, @value{tramp} must +In order to use the @option{ControlMaster} option, @value{tramp} must check whether the @command{ssh} client supports this option. This is only possible on the local host, for the first hop. @value{tramp} does not use this option on proxy hosts. @@ -4365,7 +4369,7 @@ supported on your proxy host. @item @value{tramp} does not connect to Samba or MS Windows hosts running -SMB1 connection protocol. +SMB1 connection protocol @vindex tramp-smb-options Recent versions of @command{smbclient} do not support old connection @@ -4592,7 +4596,7 @@ completion can further reduce key strokes: @kbd{C-x C-f @value{prefix}ssh@value{postfixhop}x @key{TAB}}. @item -Use environment variables to expand long strings +Use environment variables to expand long strings: For long file names, set up environment variables that are expanded in the minibuffer. Environment variables are set either outside Emacs or diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 7a3f3fe8f0..a51edae148 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -118,7 +118,9 @@ detected as prompt when being sent on echoing hosts, therefore.") ;;;###tramp-autoload (defcustom tramp-use-ssh-controlmaster-options t - "Whether to use `tramp-ssh-controlmaster-options'." + "Whether to use `tramp-ssh-controlmaster-options'. +Set it to nil, if you use Control* or Proxy* options in your ssh +configuration." :group 'tramp :version "24.4" :type 'boolean) commit e542b4b785b1646ba7a801090a6e937645b6b330 Author: Eric Abrahamsen Date: Wed Sep 23 16:01:38 2020 -0700 Write Gnus active files with quotes around group names * lisp/gnus/gnus-util.el (gnus-write-active-file): In case of group names with spaces in them (see Bug#42823). Names are later read with `read', so this should be quite robust. diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 4876715ae6..aa9f137e20 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1177,7 +1177,7 @@ ARG is passed to the first function." (maphash (lambda (group active) (when active - (insert (format "%s %d %d y\n" + (insert (format "%S %d %d y\n" (if full-names group (gnus-group-real-name group)) commit dc86c4cc0ba230c632b10cefb22b9fec1cd1d046 Author: Juri Linkov Date: Wed Sep 23 22:39:32 2020 +0300 New command goto-line-relative (bug#5042, bug#9917) * lisp/simple.el (goto-line-read-args): New function with code from goto-line. (goto-line): New arg RELATIVE. Also use 'widen-automatically' to leave all lines accessible in the narrowed buffer. (goto-line-relative): New command. * lisp/info.el (Info-mode-map): Remap 'goto-line' to 'goto-line-relative'. * doc/emacs/basic.texi (Moving Point): * doc/emacs/display.texi (Optional Mode Line): Mention goto-line-relative. diff --git a/doc/emacs/basic.texi b/doc/emacs/basic.texi index 444b2469cf..cde7b475d9 100644 --- a/doc/emacs/basic.texi +++ b/doc/emacs/basic.texi @@ -311,13 +311,16 @@ Position 1 is the beginning of the buffer. @kindex M-g M-g @kindex M-g g @findex goto-line +@findex goto-line-relative Read a number @var{n} and move point to the beginning of line number @var{n} (@code{goto-line}). Line 1 is the beginning of the buffer. If point is on or just after a number in the buffer, that is the default for @var{n}. Just type @key{RET} in the minibuffer to use it. You can also specify @var{n} by giving @kbd{M-g M-g} a numeric prefix argument. @xref{Select Buffer}, for the behavior of @kbd{M-g M-g} when you give it -a plain prefix argument. +a plain prefix argument. Alternatively, you can use the command +@code{goto-line-relative} to move point to the line relative to the +accessible portion of the narrowed buffer. @item M-g @key{TAB} @kindex M-g TAB diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index e7b8745a04..6f1bc802b8 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -1452,9 +1452,10 @@ the displayed column number to count from one, you may set @cindex narrowing, and line number display If you have narrowed the buffer (@pxref{Narrowing}), the displayed line number is relative to the accessible portion of the buffer. -Thus, it isn't suitable as an argument to @code{goto-line}. (Use -@code{what-line} command to see the line number relative to the whole -file.) +Thus, it isn't suitable as an argument to @code{goto-line}. (The +command @code{what-line} shows the line number relative to the whole +file.) You can use @code{goto-line-relative} command to move point to +the line relative to the accessible portion of the narrowed buffer. @vindex line-number-display-limit If the buffer is very large (larger than the value of diff --git a/etc/NEWS b/etc/NEWS index a4c823072c..fe2f5c3782 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -171,6 +171,13 @@ Each buffer will keep a separate history of line numbers used with 'goto-line'. This should help making faster the process of finding line numbers that were previously jumped to. ++++ +** New command 'goto-line-relative' to use in a narrowed buffer. +It moves point to the line relative to the accessible portion of the +narrowed buffer. 'M-g M-g' in Info is rebound to this command. +When 'widen-automatically' is non-nil, 'goto-line' widens the narrowed +buffer to be able to move point to the inaccessible portion. + +++ ** When 'suggest-key-bindings' is non-nil, the completion list of 'M-x' shows equivalent key bindings for all commands that have them. diff --git a/lisp/info.el b/lisp/info.el index e4f75b481f..20633fd059 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -4053,6 +4053,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'." (define-key map "^" 'Info-up) (define-key map "," 'Info-index-next) (define-key map "\177" 'Info-scroll-down) + (define-key map [remap goto-line] 'goto-line-relative) (define-key map [mouse-2] 'Info-mouse-follow-nearest-node) (define-key map [follow-link] 'mouse-face) (define-key map [XF86Back] 'Info-history-back) diff --git a/lisp/simple.el b/lisp/simple.el index d7486e51dd..825fec380c 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1231,7 +1231,39 @@ that uses or sets the mark." "History of values entered with `goto-line'.") (make-variable-buffer-local 'goto-line-history) -(defun goto-line (line &optional buffer) +(defun goto-line-read-args (&optional relative) + "Read arguments for `goto-line' related commands." + (if (and current-prefix-arg (not (consp current-prefix-arg))) + (list (prefix-numeric-value current-prefix-arg)) + ;; Look for a default, a number in the buffer at point. + (let* ((default + (save-excursion + (skip-chars-backward "0-9") + (if (looking-at "[0-9]") + (string-to-number + (buffer-substring-no-properties + (point) + (progn (skip-chars-forward "0-9") + (point))))))) + ;; Decide if we're switching buffers. + (buffer + (if (consp current-prefix-arg) + (other-buffer (current-buffer) t))) + (buffer-prompt + (if buffer + (concat " in " (buffer-name buffer)) + ""))) + ;; Read the argument, offering that number (if any) as default. + (list (read-number (format "Goto%s line%s: " + (if (= (point-min) 1) "" + ;; In a narrowed buffer. + (if relative " relative" " absolute")) + buffer-prompt) + (list default (line-number-at-pos)) + 'goto-line-history) + buffer)))) + +(defun goto-line (line &optional buffer relative) "Go to LINE, counting from line 1 at beginning of buffer. If called interactively, a numeric prefix argument specifies LINE; without a numeric prefix argument, read LINE from the @@ -1241,6 +1273,13 @@ If optional argument BUFFER is non-nil, switch to that buffer and move to line LINE there. If called interactively with \\[universal-argument] as argument, BUFFER is the most recently selected other buffer. +If optional argument RELATIVE is non-nil, counting starts at the beginning +of the accessible portion of the (potentially narrowed) buffer. + +If the variable `widen-automatically' is non-nil, cancel narrowing and +leave all lines accessible. If `widen-automatically' is nil, just move +point to the edge of visible portion and don't change the buffer bounds. + Prior to moving point, this function sets the mark (without activating it), unless Transient Mark mode is enabled and the mark is already active. @@ -1252,32 +1291,7 @@ What you probably want instead is something like: If at all possible, an even better solution is to use char counts rather than line counts." (declare (interactive-only forward-line)) - (interactive - (if (and current-prefix-arg (not (consp current-prefix-arg))) - (list (prefix-numeric-value current-prefix-arg)) - ;; Look for a default, a number in the buffer at point. - (let* ((default - (save-excursion - (skip-chars-backward "0-9") - (if (looking-at "[0-9]") - (string-to-number - (buffer-substring-no-properties - (point) - (progn (skip-chars-forward "0-9") - (point))))))) - ;; Decide if we're switching buffers. - (buffer - (if (consp current-prefix-arg) - (other-buffer (current-buffer) t))) - (buffer-prompt - (if buffer - (concat " in " (buffer-name buffer)) - ""))) - ;; Read the argument, offering that number (if any) as default. - (list (read-number (format "Goto line%s: " buffer-prompt) - (list default (line-number-at-pos)) - 'goto-line-history) - buffer)))) + (interactive (goto-line-read-args)) ;; Switch to the desired buffer, one way or another. (if buffer (let ((window (get-buffer-window buffer))) @@ -1286,13 +1300,27 @@ rather than line counts." ;; Leave mark at previous position (or (region-active-p) (push-mark)) ;; Move to the specified line number in that buffer. - (save-restriction - (widen) + (if (and (not relative) (not widen-automatically)) + (save-restriction + (widen) + (goto-char (point-min)) + (if (eq selective-display t) + (re-search-forward "[\n\C-m]" nil 'end (1- line)) + (forward-line (1- line)))) + (unless relative (widen)) (goto-char (point-min)) (if (eq selective-display t) (re-search-forward "[\n\C-m]" nil 'end (1- line)) (forward-line (1- line))))) +(defun goto-line-relative (line &optional buffer) + "Go to LINE, counting from line at (point-min). +The line number is relative to the accessible portion of the narrowed +buffer. The argument BUFFER is the same as in the function `goto-line'." + (declare (interactive-only forward-line)) + (interactive (goto-line-read-args t)) + (goto-line line buffer t)) + (defun count-words-region (start end &optional arg) "Count the number of words in the region. If called interactively, print a message reporting the number of commit ad285e0eb8ae18f41a4d94b1a57a5ee118f6814f Author: Stefan Kangas Date: Wed Sep 23 20:53:06 2020 +0200 Remove TODO to convert files to unit tests * test/lisp/textmodes/css-mode-tests.el: * test/lisp/progmodes/ruby-mode-tests.el: Remove TODO to convert test files into unit tests. The files are still useful for debugging. Ref: https://lists.gnu.org/r/emacs-devel/2020-09/msg01906.html diff --git a/test/lisp/progmodes/ruby-mode-tests.el b/test/lisp/progmodes/ruby-mode-tests.el index fb3b42b30d..5988a49523 100644 --- a/test/lisp/progmodes/ruby-mode-tests.el +++ b/test/lisp/progmodes/ruby-mode-tests.el @@ -848,8 +848,6 @@ VALUES-PLIST is a list with alternating index and value elements." (ruby--insert-coding-comment "utf-8") (should (string= "# encoding: utf-8\n\n" (buffer-string)))))) -;; TODO: Convert these into unit proper tests instead of using an -;; external file. (ert-deftest ruby--indent/converted-from-manual-test () :tags '(:expensive-test) ;; Converted from manual test. diff --git a/test/lisp/textmodes/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el index 02bd2aca30..f627d1c02c 100644 --- a/test/lisp/textmodes/css-mode-tests.el +++ b/test/lisp/textmodes/css-mode-tests.el @@ -417,8 +417,6 @@ (point)) "black"))))) -;; TODO: Convert these into unit proper tests instead of using an -;; external file. (ert-deftest css-mode-test-indent () (with-current-buffer (find-file-noselect (expand-file-name "test-indent.css" commit 37a2a427e4afaab963ba9753d11d7b665ac67ea0 Author: Stefan Kangas Date: Wed Sep 23 19:41:59 2020 +0200 Convert some completion.el tests to ERT * test/lisp/completion-tests.el: New file. * lisp/completion.el: Move commented out tests to completion-tests.el. diff --git a/lisp/completion.el b/lisp/completion.el index ed13455b71..e4a004f190 100644 --- a/lisp/completion.el +++ b/lisp/completion.el @@ -399,13 +399,6 @@ Used to decide whether to save completions.") :up) (t :neither)))))) -;; Tests - -;; (cmpl-string-case-type "123ABCDEF456") --> :up -;; (cmpl-string-case-type "123abcdef456") --> :down -;; (cmpl-string-case-type "123aBcDeF456") --> :mixed -;; (cmpl-string-case-type "123456") --> :neither -;; (cmpl-string-case-type "Abcde123") --> :capitalized - (defun cmpl-coerce-string-case (string case-type) (cond ((eq case-type :down) (downcase string)) ((eq case-type :up) (upcase string)) @@ -424,12 +417,6 @@ Used to decide whether to save completions.") ;; as is string-to-coerce)))) -;; Tests - -;; (cmpl-merge-string-cases "AbCdEf456" "abc") --> AbCdEf456 -;; (cmpl-merge-string-cases "abcdef456" "ABC") --> ABCDEF456 -;; (cmpl-merge-string-cases "ABCDEF456" "Abc") --> Abcdef456 -;; (cmpl-merge-string-cases "ABCDEF456" "abc") --> abcdef456 - (defun cmpl-hours-since-origin () (floor (time-convert nil 'integer) 3600)) @@ -1226,45 +1213,6 @@ String must be longer than `completion-prefix-min-length'." (set cmpl-db-prefix-symbol nil))))) (error "Unknown completion `%s'" completion-string)))) -;; Tests -- -;; - Add and Find - -;; (add-completion-to-head "banana") --> ("banana" 0 nil 0) -;; (find-exact-completion "banana") --> ("banana" 0 nil 0) -;; (find-exact-completion "bana") --> nil -;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...)) -;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...)) -;; (add-completion-to-head "banish") --> ("banish" 0 nil 0) -;; (find-exact-completion "banish") --> ("banish" 0 nil 0) -;; (car (find-cmpl-prefix-entry "ban")) --> (("banish" ...) ("banana" ...)) -;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...)) -;; (add-completion-to-head "banana") --> ("banana" 0 nil 0) -;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...)) -;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...)) -;; -;; - Deleting - -;; (add-completion-to-head "banner") --> ("banner" 0 nil 0) -;; (delete-completion "banner") -;; (find-exact-completion "banner") --> nil -;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...)) -;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...)) -;; (add-completion-to-head "banner") --> ("banner" 0 nil 0) -;; (delete-completion "banana") -;; (car (find-cmpl-prefix-entry "ban")) --> (("banner" ...) ("banish" ...)) -;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...)) -;; (delete-completion "banner") -;; (delete-completion "banish") -;; (find-cmpl-prefix-entry "ban") --> nil -;; (delete-completion "banner") --> error -;; -;; - Tail - -;; (add-completion-to-tail-if-new "banana") --> ("banana" 0 nil 0) -;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...)) -;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...)) -;; (add-completion-to-tail-if-new "banish") --> ("banish" 0 nil 0) -;; (car (find-cmpl-prefix-entry "ban")) -->(("banana" ...) ("banish" ...)) -;; (cdr (find-cmpl-prefix-entry "ban")) -->(("banish" ...)) -;; - ;;--------------------------------------------------------------------------- ;; Database Update :: Interface level routines @@ -1361,29 +1309,6 @@ Completions added this way will automatically be saved if (set-completion-num-uses entry 1) (setq cmpl-completions-accepted-p t))))))) -;; Tests -- -;; - Add and Find - -;; (add-completion "banana" 5 10) -;; (find-exact-completion "banana") --> ("banana" 5 10 0) -;; (add-completion "banana" 6) -;; (find-exact-completion "banana") --> ("banana" 6 10 0) -;; (add-completion "banish") -;; (car (find-cmpl-prefix-entry "ban")) --> (("banish" ...) ("banana" ...)) -;; -;; - Accepting - -;; (setq completion-to-accept "banana") -;; (accept-completion) -;; (find-exact-completion "banana") --> ("banana" 7 10) -;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...)) -;; (setq completion-to-accept "banish") -;; (add-completion "banner") -;; (car (find-cmpl-prefix-entry "ban")) -;; --> (("banner" ...) ("banish" 1 ...) ("banana" 7 ...)) -;; -;; - Deleting - -;; (kill-completion "banish") -;; (car (find-cmpl-prefix-entry "ban")) --> (("banner" ...) ("banana" ...)) - ;;--------------------------------------------------------------------------- ;; Searching the database @@ -1505,46 +1430,6 @@ If there are no more entries, try cdabbrev and then return only a string." ;; Completely unsuccessful, return nil )) -;; Tests -- -;; - Add and Find - -;; (add-completion "banana") -;; (completion-search-reset "ban") -;; (completion-search-next 0) --> "banana" -;; -;; - Discrimination - -;; (add-completion "cumberland") -;; (add-completion "cumberbund") -;; cumbering -;; (completion-search-reset "cumb") -;; (completion-search-peek t) --> "cumberbund" -;; (completion-search-next 0) --> "cumberbund" -;; (completion-search-peek t) --> "cumberland" -;; (completion-search-next 1) --> "cumberland" -;; (completion-search-peek nil) --> nil -;; (completion-search-next 2) --> "cumbering" {cdabbrev} -;; (completion-search-next 3) --> nil or "cumming"{depends on context} -;; (completion-search-next 1) --> "cumberland" -;; (completion-search-peek t) --> "cumbering" {cdabbrev} -;; -;; - Accepting - -;; (completion-search-next 1) --> "cumberland" -;; (setq completion-to-accept "cumberland") -;; (completion-search-reset "foo") -;; (completion-search-reset "cum") -;; (completion-search-next 0) --> "cumberland" -;; -;; - Deleting - -;; (kill-completion "cumberland") -;; cummings -;; (completion-search-reset "cum") -;; (completion-search-next 0) --> "cumberbund" -;; (completion-search-next 1) --> "cummings" -;; -;; - Ignoring Capitalization - -;; (completion-search-reset "CuMb") -;; (completion-search-next 0) --> "cumberbund" - - ;;----------------------------------------------- ;; COMPLETE @@ -1733,12 +1618,6 @@ Prefix args :: "\n(\\(\\w*:\\)?def\\(\\w\\|\\s_\\)*\\s +(*" "A regexp that searches for Lisp definition form.") -;; Tests - -;; (and (string-match *lisp-def-regexp* "\n(defun foo") (match-end 0)) -> 8 -;; (and (string-match *lisp-def-regexp* "\n(si:def foo") (match-end 0)) -> 9 -;; (and (string-match *lisp-def-regexp* "\n(def-bar foo")(match-end 0)) -> 10 -;; (and (string-match *lisp-def-regexp* "\n(defun (foo") (match-end 0)) -> 9 - ;; Parses all the definition names from a Lisp mode buffer and adds them to ;; the completion database. (defun add-completions-from-lisp-buffer () diff --git a/test/lisp/completion-tests.el b/test/lisp/completion-tests.el new file mode 100644 index 0000000000..7473bbbb0c --- /dev/null +++ b/test/lisp/completion-tests.el @@ -0,0 +1,170 @@ +;;; completion-tests.el --- Tests for completion.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'completion) + +(ert-deftest completion-test-cmpl-string-case-type () + (should (eq (cmpl-string-case-type "123ABCDEF456") :up)) + (should (eq (cmpl-string-case-type "123abcdef456") :down)) + (should (eq (cmpl-string-case-type "123aBcDeF456") :mixed)) + (should (eq (cmpl-string-case-type "123456") :neither)) + (should (eq (cmpl-string-case-type "Abcde123") :capitalized))) + +(ert-deftest completion-test-cmpl-merge-string-cases () + (should (equal (cmpl-merge-string-cases "AbCdEf456" "abc") "AbCdEf456")) + (should (equal (cmpl-merge-string-cases "abcdef456" "ABC") "ABCDEF456")) + (should (equal (cmpl-merge-string-cases "ABCDEF456" "Abc") "Abcdef456")) + (should (equal (cmpl-merge-string-cases "ABCDEF456" "abc") "abcdef456"))) + +(ert-deftest completion-test-add-find-delete-tail () + (unwind-protect + (progn + ;; - Add and Find - + (should (equal (add-completion-to-head "banana") '("banana" 0 nil 0))) + (should (equal (find-exact-completion "banana") '("banana" 0 nil 0))) + (should (equal (find-exact-completion "bana") nil)) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0)))) + + (should (equal (add-completion-to-head "banish") '("banish" 0 nil 0))) + (should (equal (find-exact-completion "banish") '("banish" 0 nil 0))) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0) ("banana" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0)))) + + (should (equal (add-completion-to-head "banana") '("banana" 0 nil 0))) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0) ("banish" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0)))) + + ;; - Deleting - + (should (equal (add-completion-to-head "banner") '("banner" 0 nil 0))) + (delete-completion "banner") + (should-not (find-exact-completion "banner")) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0) ("banish" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0)))) + (should (equal (add-completion-to-head "banner") '("banner" 0 nil 0))) + (delete-completion "banana") + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banner" 0 nil 0) ("banish" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0)))) + (delete-completion "banner") + (delete-completion "banish") + (should-not (find-cmpl-prefix-entry "ban")) + (should-error (delete-completion "banner")) + + ;; - Tail - + (should (equal (add-completion-to-tail-if-new "banana") '("banana" 0 nil 0))) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0)))) + (add-completion-to-tail-if-new "banish") '("banish" 0 nil 0) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0) ("banish" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0))))) + (ignore-errors (kill-completion "banana")) + (ignore-errors (kill-completion "banner")) + (ignore-errors (kill-completion "banish")))) + +(ert-deftest completion-test-add-find-accept-delete () + (unwind-protect + (progn + ;; - Add and Find - + (add-completion "banana" 5 10) + (should (equal (find-exact-completion "banana") '("banana" 5 10 0))) + (add-completion "banana" 6) + (should (equal (find-exact-completion "banana") '("banana" 6 10 0))) + (add-completion "banish") + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0) ("banana" 6 10 0)))) + + ;; - Accepting - + (setq completion-to-accept "banana") + (accept-completion) + (should (equal (find-exact-completion "banana") '("banana" 7 10 0))) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 7 10 0) ("banish" 0 nil 0)))) + (setq completion-to-accept "banish") + (add-completion "banner") + (should (equal (car (find-cmpl-prefix-entry "ban")) + '(("banner" 0 nil 0) ("banish" 1 nil 0) ("banana" 7 10 0)))) + + ;; - Deleting - + (kill-completion "banish") + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banner" 0 nil 0) ("banana" 7 10 0))))) + (ignore-errors (kill-completion "banish")) + (ignore-errors (kill-completion "banana")) + (ignore-errors (kill-completion "banner")))) + +(ert-deftest completion-test-search () + (unwind-protect + (progn + ;; - Add and Find - + (add-completion "banana") + (completion-search-reset "ban") + (should (equal (car (completion-search-next 0)) "banana")) + + ;; - Discrimination - + (add-completion "cumberland") + (add-completion "cumberbund") + ;; cumbering + (completion-search-reset "cumb") + (should (equal (car (completion-search-peek t)) "cumberbund")) + (should (equal (car (completion-search-next 0)) "cumberbund")) + (should (equal (car (completion-search-peek t)) "cumberland")) + (should (equal (car (completion-search-next 1)) "cumberland")) + (should-not (completion-search-peek nil)) + + ;; FIXME + ;; (should (equal (completion-search-next 2) "cumbering")) ; {cdabbrev} + ;;(completion-search-next 3) --> nil or "cumming" {depends on context} + + (should (equal (car (completion-search-next 1)) "cumberland")) + + ;; FIXME + ;; (should (equal (completion-search-peek t) "cumbering")) ; {cdabbrev} + + ;; - Accepting - + (should (equal (car (completion-search-next 1)) "cumberland")) + (setq completion-to-accept "cumberland") + (completion-search-reset "foo") + (completion-search-reset "cum") + (should (equal (car (completion-search-next 0)) "cumberland")) + + ;; - Deleting - + (kill-completion "cumberland") + (add-completion "cummings") + (completion-search-reset "cum") + (should (equal (car (completion-search-next 0)) "cummings")) + (should (equal (car (completion-search-next 1)) "cumberbund")) + + ;; - Ignoring Capitalization - + (completion-search-reset "CuMb") + (should (equal (car (completion-search-next 0)) "cumberbund"))) + (ignore-errors (kill-completion "banana")) + (ignore-errors (kill-completion "cumberland")) + (ignore-errors (kill-completion "cumberbund")) + (ignore-errors (kill-completion "cummings")))) + +(ert-deftest completion-test-lisp-def-regexp () + (should (= (and (string-match *lisp-def-regexp* "\n(defun foo") (match-end 0)) 8)) + (should (= (and (string-match *lisp-def-regexp* "\n(si:def foo") (match-end 0)) 9)) + (should (= (and (string-match *lisp-def-regexp* "\n(def-bar foo")(match-end 0)) 10)) + (should (= (and (string-match *lisp-def-regexp* "\n(defun (foo") (match-end 0)) 9))) + +(provide 'completion-tests) +;;; completion-tests.el ends here commit 610b771d4a7fcb9d704bbd31032dc51009670e8f Author: Stefan Kangas Date: Wed Sep 23 18:14:54 2020 +0200 Convert allout unit tests to ERT * test/lisp/allout-tests.el: New file. * lisp/allout.el (allout-run-unit-tests-on-load) (allout-run-unit-tests): Remove. (allout-tests-obliterate-variable) (allout-tests-globally-unbound, allout-tests-globally-true) (allout-tests-locally-true, allout-test-resumptions): Move to allout-tests.el * test/lisp/allout-widgets-tests.el: New file. * lisp/allout-widgets.el (allout-widgets-run-unit-tests-on-load) (allout-widgets-run-unit-tests): Remove. (allout-test-range-overlaps): Move to allout-widgets-tests.el. diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el index 03fc3e2f0e..ac49d3bf06 100644 --- a/lisp/allout-widgets.el +++ b/lisp/allout-widgets.el @@ -209,21 +209,6 @@ See `allout-widgets-mode' for allout widgets mode features." :group 'allout-widgets) (make-obsolete-variable 'allout-widgets-item-image-properties-xemacs nil "28.1") ;;;_ . Developer -;;;_ = allout-widgets-run-unit-tests-on-load -(defcustom allout-widgets-run-unit-tests-on-load nil - "When non-nil, unit tests will be run at end of loading allout-widgets. - -Generally, allout widgets code developers are the only ones who'll want to -set this. - -\(If set, this makes it an even better practice to exercise changes by -doing byte-compilation with a repeat count, so the file is loaded after -compilation.) - -See `allout-widgets-run-unit-tests' to see what's run." - :version "24.1" - :type 'boolean - :group 'allout-widgets-developer) ;;;_ = allout-widgets-time-decoration-activity (defcustom allout-widgets-time-decoration-activity nil "Retain timing info of the last cooperative redecoration. @@ -1353,64 +1338,6 @@ FROM and TO must be in increasing order, as must be the pairs in RANGES." (setq new-ranges (nreverse new-ranges)) (if ranges (setq new-ranges (append new-ranges ranges))) (list (if included-from t) new-ranges))) -;;;_ > allout-test-range-overlaps () -(defun allout-test-range-overlaps () - "`allout-range-overlaps' unit tests." - (let* (ranges - got - (try (lambda (from to) - (setq got (allout-range-overlaps from to ranges)) - (setq ranges (cadr got)) - got))) -;; ;; biggie: -;; (setq ranges nil) -;; ;; ~ .02 to .1 seconds for just repeated listing args instead of funcall -;; ;; ~ 13 seconds for doing repeated funcall -;; (message "time-trial: %s, resulting size %s" -;; (time-trial -;; '(let ((size 10000) -;; doing) -;; (dotimes (count size) -;; (setq doing (random size)) -;; (funcall try doing (+ doing (random 5))) -;; ;;(list doing (+ doing (random 5))) -;; ))) -;; (length ranges)) -;; (sit-for 2) - - ;; fresh: - (setq ranges nil) - (cl-assert (equal (funcall try 3 5) '(nil ((3 5))))) - ;; add range at end: - (cl-assert (equal (funcall try 10 12) '(nil ((3 5) (10 12))))) - ;; add range at beginning: - (cl-assert (equal (funcall try 1 2) '(nil ((1 2) (3 5) (10 12))))) - ;; insert range somewhere in the middle: - (cl-assert (equal (funcall try 7 9) '(nil ((1 2) (3 5) (7 9) (10 12))))) - ;; consolidate some: - (cl-assert (equal (funcall try 5 8) '(t ((1 2) (3 9) (10 12))))) - ;; add more: - (cl-assert (equal (funcall try 15 17) '(nil ((1 2) (3 9) (10 12) (15 17))))) - ;; add more: - (cl-assert (equal (funcall try 20 22) - '(nil ((1 2) (3 9) (10 12) (15 17) (20 22))))) - ;; encompass more: - (cl-assert (equal (funcall try 4 11) '(t ((1 2) (3 12) (15 17) (20 22))))) - ;; encompass all: - (cl-assert (equal (funcall try 2 25) '(t ((1 25))))) - - ;; fresh slate: - (setq ranges nil) - (cl-assert (equal (funcall try 20 25) '(nil ((20 25))))) - (cl-assert (equal (funcall try 30 35) '(nil ((20 25) (30 35))))) - (cl-assert (equal (funcall try 26 28) '(nil ((20 25) (26 28) (30 35))))) - (cl-assert (equal (funcall try 15 20) '(t ((15 25) (26 28) (30 35))))) - (cl-assert (equal (funcall try 10 30) '(t ((10 35))))) - (cl-assert (equal (funcall try 5 6) '(nil ((5 6) (10 35))))) - (cl-assert (equal (funcall try 2 100) '(t ((2 100))))) - - (setq ranges nil) - )) ;;;_ > allout-widgetize-buffer (&optional doing) (defun allout-widgetize-buffer (&optional doing) "EXAMPLE FUNCTION. Widgetize items in buffer using allout-chart-subtree. @@ -2380,18 +2307,6 @@ The elements of LIST are not copied, just the list structure itself." (overlays-in start end))))) (length button-overlays))) -;;;_ : Run unit tests: -(defun allout-widgets-run-unit-tests () - (message "Running allout-widget tests...") - - (allout-test-range-overlaps) - - (message "Running allout-widget tests... Done.") - (sit-for .5)) - -(when allout-widgets-run-unit-tests-on-load - (allout-widgets-run-unit-tests)) - ;;;_ : provide (provide 'allout-widgets) diff --git a/lisp/allout.el b/lisp/allout.el index 955b7000cb..044c82afb2 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -77,7 +77,6 @@ ;;;_* Dependency loads (require 'overlay) -(eval-when-compile (require 'cl-lib)) ;;;_* USER CUSTOMIZATION VARIABLES: @@ -840,20 +839,6 @@ for restoring when all encryptions are established.") (defgroup allout-developer nil "Allout settings developers care about, including topic encryption and more." :group 'allout) -;;;_ = allout-run-unit-tests-on-load -(defcustom allout-run-unit-tests-on-load nil - "When non-nil, unit tests will be run at end of loading the allout module. - -Generally, allout code developers are the only ones who'll want to set this. - -\(If set, this makes it an even better practice to exercise changes by -doing byte-compilation with a repeat count, so the file is loaded after -compilation.) - -See `allout-run-unit-tests' to see what's run." - :type 'boolean - :group 'allout-developer) - ;;;_ + Miscellaneous customization ;;;_ = allout-enable-file-variable-adjustment @@ -6518,136 +6503,7 @@ If BEG is bigger than END we return 0." (isearch-repeat 'forward) (isearch-mode t))) -;;;_ #11 Unit tests -- this should be last item before "Provide" -;;;_ > allout-run-unit-tests () -(defun allout-run-unit-tests () - "Run the various allout unit tests." - (message "Running allout tests...") - (allout-test-resumptions) - (message "Running allout tests... Done.") - (sit-for .5)) -;;;_ : test resumptions: -;;;_ > allout-tests-obliterate-variable (name) -(defun allout-tests-obliterate-variable (name) - "Completely unbind variable with NAME." - (if (local-variable-p name (current-buffer)) (kill-local-variable name)) - (while (boundp name) (makunbound name))) -;;;_ > allout-test-resumptions () -(defvar allout-tests-globally-unbound nil - "Fodder for allout resumptions tests -- defvar just for byte compiler.") -(defvar allout-tests-globally-true nil - "Fodder for allout resumptions tests -- defvar just for byte compiler.") -(defvar allout-tests-locally-true nil - "Fodder for allout resumptions tests -- defvar just for byte compiler.") -(defun allout-test-resumptions () - ;; FIXME: Use ERT. - "Exercise allout resumptions." - ;; for each resumption case, we also test that the right local/global - ;; scopes are affected during resumption effects: - - ;; ensure that previously unbound variables return to the unbound state. - (with-temp-buffer - (allout-tests-obliterate-variable 'allout-tests-globally-unbound) - (allout-add-resumptions '(allout-tests-globally-unbound t)) - (cl-assert (not (default-boundp 'allout-tests-globally-unbound))) - (cl-assert (local-variable-p 'allout-tests-globally-unbound (current-buffer))) - (cl-assert (boundp 'allout-tests-globally-unbound)) - (cl-assert (equal allout-tests-globally-unbound t)) - (allout-do-resumptions) - (cl-assert (not (local-variable-p 'allout-tests-globally-unbound - (current-buffer)))) - (cl-assert (not (boundp 'allout-tests-globally-unbound)))) - - ;; ensure that variable with prior global value is resumed - (with-temp-buffer - (allout-tests-obliterate-variable 'allout-tests-globally-true) - (setq allout-tests-globally-true t) - (allout-add-resumptions '(allout-tests-globally-true nil)) - (cl-assert (equal (default-value 'allout-tests-globally-true) t)) - (cl-assert (local-variable-p 'allout-tests-globally-true (current-buffer))) - (cl-assert (equal allout-tests-globally-true nil)) - (allout-do-resumptions) - (cl-assert (not (local-variable-p 'allout-tests-globally-true - (current-buffer)))) - (cl-assert (boundp 'allout-tests-globally-true)) - (cl-assert (equal allout-tests-globally-true t))) - - ;; ensure that prior local value is resumed - (with-temp-buffer - (allout-tests-obliterate-variable 'allout-tests-locally-true) - (set (make-local-variable 'allout-tests-locally-true) t) - (cl-assert (not (default-boundp 'allout-tests-locally-true)) - nil (concat "Test setup mistake -- variable supposed to" - " not have global binding, but it does.")) - (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)) - nil (concat "Test setup mistake -- variable supposed to have" - " local binding, but it lacks one.")) - (allout-add-resumptions '(allout-tests-locally-true nil)) - (cl-assert (not (default-boundp 'allout-tests-locally-true))) - (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))) - (cl-assert (equal allout-tests-locally-true nil)) - (allout-do-resumptions) - (cl-assert (boundp 'allout-tests-locally-true)) - (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))) - (cl-assert (equal allout-tests-locally-true t)) - (cl-assert (not (default-boundp 'allout-tests-locally-true)))) - - ;; ensure that last of multiple resumptions holds, for various scopes. - (with-temp-buffer - (allout-tests-obliterate-variable 'allout-tests-globally-unbound) - (allout-tests-obliterate-variable 'allout-tests-globally-true) - (setq allout-tests-globally-true t) - (allout-tests-obliterate-variable 'allout-tests-locally-true) - (set (make-local-variable 'allout-tests-locally-true) t) - (allout-add-resumptions '(allout-tests-globally-unbound t) - '(allout-tests-globally-true nil) - '(allout-tests-locally-true nil)) - (allout-add-resumptions '(allout-tests-globally-unbound 2) - '(allout-tests-globally-true 3) - '(allout-tests-locally-true 4)) - ;; reestablish many of the basic conditions are maintained after re-add: - (cl-assert (not (default-boundp 'allout-tests-globally-unbound))) - (cl-assert (local-variable-p 'allout-tests-globally-unbound (current-buffer))) - (cl-assert (equal allout-tests-globally-unbound 2)) - (cl-assert (default-boundp 'allout-tests-globally-true)) - (cl-assert (local-variable-p 'allout-tests-globally-true (current-buffer))) - (cl-assert (equal allout-tests-globally-true 3)) - (cl-assert (not (default-boundp 'allout-tests-locally-true))) - (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))) - (cl-assert (equal allout-tests-locally-true 4)) - (allout-do-resumptions) - (cl-assert (not (local-variable-p 'allout-tests-globally-unbound - (current-buffer)))) - (cl-assert (not (boundp 'allout-tests-globally-unbound))) - (cl-assert (not (local-variable-p 'allout-tests-globally-true - (current-buffer)))) - (cl-assert (boundp 'allout-tests-globally-true)) - (cl-assert (equal allout-tests-globally-true t)) - (cl-assert (boundp 'allout-tests-locally-true)) - (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))) - (cl-assert (equal allout-tests-locally-true t)) - (cl-assert (not (default-boundp 'allout-tests-locally-true)))) - - ;; ensure that deliberately unbinding registered variables doesn't foul things - (with-temp-buffer - (allout-tests-obliterate-variable 'allout-tests-globally-unbound) - (allout-tests-obliterate-variable 'allout-tests-globally-true) - (setq allout-tests-globally-true t) - (allout-tests-obliterate-variable 'allout-tests-locally-true) - (set (make-local-variable 'allout-tests-locally-true) t) - (allout-add-resumptions '(allout-tests-globally-unbound t) - '(allout-tests-globally-true nil) - '(allout-tests-locally-true nil)) - (allout-tests-obliterate-variable 'allout-tests-globally-unbound) - (allout-tests-obliterate-variable 'allout-tests-globally-true) - (allout-tests-obliterate-variable 'allout-tests-locally-true) - (allout-do-resumptions)) - ) -;;;_ % Run unit tests if `allout-run-unit-tests-after-load' is true: -(when allout-run-unit-tests-on-load - (allout-run-unit-tests)) - -;;;_ #12 Provide +;;;_ #11 Provide (provide 'allout) ;;;_* Local emacs vars. diff --git a/test/lisp/allout-tests.el b/test/lisp/allout-tests.el new file mode 100644 index 0000000000..f7cd6db9cd --- /dev/null +++ b/test/lisp/allout-tests.el @@ -0,0 +1,148 @@ +;;; allout-tests.el --- Tests for allout.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'allout) + +(require 'cl-lib) + +(defun allout-tests-obliterate-variable (name) + "Completely unbind variable with NAME." + (if (local-variable-p name (current-buffer)) (kill-local-variable name)) + (while (boundp name) (makunbound name))) + +(defvar allout-tests-globally-unbound nil + "Fodder for allout resumptions tests -- defvar just for byte compiler.") +(defvar allout-tests-globally-true nil + "Fodder for allout resumptions tests -- defvar just for byte compiler.") +(defvar allout-tests-locally-true nil + "Fodder for allout resumptions tests -- defvar just for byte compiler.") + +;; For each resumption case, we also test that the right local/global +;; scopes are affected during resumption effects. + +(ert-deftest allout-test-resumption-unbound-return-to-unbound () + "Previously unbound variables return to the unbound state." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-globally-unbound) + (allout-add-resumptions '(allout-tests-globally-unbound t)) + (should (not (default-boundp 'allout-tests-globally-unbound))) + (should (local-variable-p 'allout-tests-globally-unbound (current-buffer))) + (should (boundp 'allout-tests-globally-unbound)) + (should (equal allout-tests-globally-unbound t)) + (allout-do-resumptions) + (should (not (local-variable-p 'allout-tests-globally-unbound + (current-buffer)))) + (should (not (boundp 'allout-tests-globally-unbound))))) + +(ert-deftest allout-test-resumption-variable-resumed () + "Ensure that variable with prior global value is resumed." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-globally-true) + (setq allout-tests-globally-true t) + (allout-add-resumptions '(allout-tests-globally-true nil)) + (should (equal (default-value 'allout-tests-globally-true) t)) + (should (local-variable-p 'allout-tests-globally-true (current-buffer))) + (should (equal allout-tests-globally-true nil)) + (allout-do-resumptions) + (should (not (local-variable-p 'allout-tests-globally-true + (current-buffer)))) + (should (boundp 'allout-tests-globally-true)) + (should (equal allout-tests-globally-true t)))) + +(ert-deftest allout-test-resumption-prior-value-resumed () + "Ensure that prior local value is resumed." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-locally-true) + (set (make-local-variable 'allout-tests-locally-true) t) + (cl-assert (not (default-boundp 'allout-tests-locally-true)) + nil (concat "Test setup mistake -- variable supposed to" + " not have global binding, but it does.")) + (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)) + nil (concat "Test setup mistake -- variable supposed to have" + " local binding, but it lacks one.")) + (allout-add-resumptions '(allout-tests-locally-true nil)) + (should (not (default-boundp 'allout-tests-locally-true))) + (should (local-variable-p 'allout-tests-locally-true (current-buffer))) + (should (equal allout-tests-locally-true nil)) + (allout-do-resumptions) + (should (boundp 'allout-tests-locally-true)) + (should (local-variable-p 'allout-tests-locally-true (current-buffer))) + (should (equal allout-tests-locally-true t)) + (should (not (default-boundp 'allout-tests-locally-true))))) + +(ert-deftest allout-test-resumption-multiple-holds () + "Ensure that last of multiple resumptions holds, for various scopes." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-globally-unbound) + (allout-tests-obliterate-variable 'allout-tests-globally-true) + (setq allout-tests-globally-true t) + (allout-tests-obliterate-variable 'allout-tests-locally-true) + (set (make-local-variable 'allout-tests-locally-true) t) + (allout-add-resumptions '(allout-tests-globally-unbound t) + '(allout-tests-globally-true nil) + '(allout-tests-locally-true nil)) + (allout-add-resumptions '(allout-tests-globally-unbound 2) + '(allout-tests-globally-true 3) + '(allout-tests-locally-true 4)) + ;; reestablish many of the basic conditions are maintained after re-add: + (should (not (default-boundp 'allout-tests-globally-unbound))) + (should (local-variable-p 'allout-tests-globally-unbound (current-buffer))) + (should (equal allout-tests-globally-unbound 2)) + (should (default-boundp 'allout-tests-globally-true)) + (should (local-variable-p 'allout-tests-globally-true (current-buffer))) + (should (equal allout-tests-globally-true 3)) + (should (not (default-boundp 'allout-tests-locally-true))) + (should (local-variable-p 'allout-tests-locally-true (current-buffer))) + (should (equal allout-tests-locally-true 4)) + (allout-do-resumptions) + (should (not (local-variable-p 'allout-tests-globally-unbound + (current-buffer)))) + (should (not (boundp 'allout-tests-globally-unbound))) + (should (not (local-variable-p 'allout-tests-globally-true + (current-buffer)))) + (should (boundp 'allout-tests-globally-true)) + (should (equal allout-tests-globally-true t)) + (should (boundp 'allout-tests-locally-true)) + (should (local-variable-p 'allout-tests-locally-true (current-buffer))) + (should (equal allout-tests-locally-true t)) + (should (not (default-boundp 'allout-tests-locally-true))))) + +(ert-deftest allout-test-resumption-unbinding () + "Ensure that deliberately unbinding registered variables doesn't foul things." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-globally-unbound) + (allout-tests-obliterate-variable 'allout-tests-globally-true) + (setq allout-tests-globally-true t) + (allout-tests-obliterate-variable 'allout-tests-locally-true) + (set (make-local-variable 'allout-tests-locally-true) t) + (allout-add-resumptions '(allout-tests-globally-unbound t) + '(allout-tests-globally-true nil) + '(allout-tests-locally-true nil)) + (allout-tests-obliterate-variable 'allout-tests-globally-unbound) + (allout-tests-obliterate-variable 'allout-tests-globally-true) + (allout-tests-obliterate-variable 'allout-tests-locally-true) + (allout-do-resumptions))) + +(provide 'allout-tests) +;;; allout-tests.el ends here diff --git a/test/lisp/allout-widgets-tests.el b/test/lisp/allout-widgets-tests.el new file mode 100644 index 0000000000..2b1bcaa6de --- /dev/null +++ b/test/lisp/allout-widgets-tests.el @@ -0,0 +1,87 @@ +;;; allout-widgets-tests.el --- Tests for allout-widgets.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'allout-widgets) + +(require 'cl-lib) + +(ert-deftest allout-test-range-overlaps () + "`allout-range-overlaps' unit tests." + (let* (ranges + got + (try (lambda (from to) + (setq got (allout-range-overlaps from to ranges)) + (setq ranges (cadr got)) + got))) +;; ;; biggie: +;; (setq ranges nil) +;; ;; ~ .02 to .1 seconds for just repeated listing args instead of funcall +;; ;; ~ 13 seconds for doing repeated funcall +;; (message "time-trial: %s, resulting size %s" +;; (time-trial +;; '(let ((size 10000) +;; doing) +;; (dotimes (count size) +;; (setq doing (random size)) +;; (funcall try doing (+ doing (random 5))) +;; ;;(list doing (+ doing (random 5))) +;; ))) +;; (length ranges)) +;; (sit-for 2) + + ;; fresh: + (setq ranges nil) + (should (equal (funcall try 3 5) '(nil ((3 5))))) + ;; add range at end: + (should (equal (funcall try 10 12) '(nil ((3 5) (10 12))))) + ;; add range at beginning: + (should (equal (funcall try 1 2) '(nil ((1 2) (3 5) (10 12))))) + ;; insert range somewhere in the middle: + (should (equal (funcall try 7 9) '(nil ((1 2) (3 5) (7 9) (10 12))))) + ;; consolidate some: + (should (equal (funcall try 5 8) '(t ((1 2) (3 9) (10 12))))) + ;; add more: + (should (equal (funcall try 15 17) '(nil ((1 2) (3 9) (10 12) (15 17))))) + ;; add more: + (should (equal (funcall try 20 22) + '(nil ((1 2) (3 9) (10 12) (15 17) (20 22))))) + ;; encompass more: + (should (equal (funcall try 4 11) '(t ((1 2) (3 12) (15 17) (20 22))))) + ;; encompass all: + (should (equal (funcall try 2 25) '(t ((1 25))))) + + ;; fresh slate: + (setq ranges nil) + (should (equal (funcall try 20 25) '(nil ((20 25))))) + (should (equal (funcall try 30 35) '(nil ((20 25) (30 35))))) + (should (equal (funcall try 26 28) '(nil ((20 25) (26 28) (30 35))))) + (should (equal (funcall try 15 20) '(t ((15 25) (26 28) (30 35))))) + (should (equal (funcall try 10 30) '(t ((10 35))))) + (should (equal (funcall try 5 6) '(nil ((5 6) (10 35))))) + (should (equal (funcall try 2 100) '(t ((2 100))))) + + (setq ranges nil))) + +(provide 'allout-widgets-tests) +;;; allout-widgets-tests.el ends here commit acf958667bfb0b0bb42a78b3d2fc0bbcd9810e8e Author: Stefan Kangas Date: Wed Sep 23 16:22:49 2020 +0200 * lisp/repeat.el: Remove obsolete comment. diff --git a/lisp/repeat.el b/lisp/repeat.el index f275db6fdd..1dabd76e07 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -85,10 +85,6 @@ ;; C-x { shrink-window-horizontally ;; C-x } enlarge-window-horizontally -;; This command was first called `vi-dot', because -;; it was inspired by the `.' command in the vi editor, -;; but it was renamed to make its name more meaningful. - ;;; Code: ;;;;; ************************* USER OPTIONS ************************** ;;;;; commit 441e8750198fc68e4b20281c3ee0d76fd8328839 Author: Michael Albinus Date: Wed Sep 23 19:57:03 2020 +0200 * test/lisp/net/dbus-tests.el (dbus-test01-basic-types): Adapt test. diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 62ed3f2bfb..2f20fcc1e6 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -265,12 +265,13 @@ (dbus-check-arguments :session dbus--test-service :double "string") :type 'wrong-type-argument) - ;; `:unix-fd'. Value range 0 .. 9. + ;; `:unix-fd'. UNIX file descriptors are transfered out-of-band. + ;; We do not support this, and so we cannot do much testing here for + ;; `:unix-fd' being an argument (which is an index to the file + ;; descriptor in the array of file descriptors that accompany the + ;; D-Bus message). Mainly testing, that values out of `:uint32' + ;; type range fail. (should (dbus-check-arguments :session dbus--test-service :unix-fd 0)) - (should (dbus-check-arguments :session dbus--test-service :unix-fd 9)) - (should-error - (dbus-check-arguments :session dbus--test-service :unix-fd 10) - :type 'dbus-error) (should-error (dbus-check-arguments :session dbus--test-service :unix-fd -1) :type 'args-out-of-range) commit 3bfddaec3ac6e545350d30a6db80188537b845ad Author: Mattias Engdegård Date: Wed Sep 23 18:08:32 2020 +0200 ; * lisp/emacs-lisp/lisp.el: rename parameter in last change diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index ba78d7f9b3..35590123ee 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -55,7 +55,7 @@ This affects `insert-parentheses' and `insert-pair'." "If non-nil, `forward-sexp' delegates to this function. Should take the same arguments and behave similarly to `forward-sexp'.") -(defun forward-sexp (&optional arg user-error) +(defun forward-sexp (&optional arg interactive) "Move forward across one balanced expression (sexp). With ARG, do it that many times. Negative arg -N means move backward across N balanced expressions. This command assumes @@ -64,10 +64,10 @@ point is not in a string or comment. Calls If unable to move over a sexp, signal `scan-error' with three arguments: a message, the start of the obstacle (usually a parenthesis or list marker of some kind), and end of the -obstacle. If USER-ERROR is non-nil, as it is interactively, -report errors as appropriate for an interactive command." +obstacle. If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." (interactive "^p\nd") - (if user-error + (if interactive (condition-case _ (forward-sexp arg nil) (scan-error (user-error (if (> arg 0) @@ -79,17 +79,17 @@ report errors as appropriate for an interactive command." (goto-char (or (scan-sexps (point) arg) (buffer-end arg))) (if (< arg 0) (backward-prefix-chars))))) -(defun backward-sexp (&optional arg user-error) +(defun backward-sexp (&optional arg interactive) "Move backward across one balanced expression (sexp). With ARG, do it that many times. Negative arg -N means move forward across N balanced expressions. This command assumes point is not in a string or comment. Uses `forward-sexp' to do the work. -If USER-ERROR is non-nil, as it is interactively, -report errors as appropriate for an interactive command." +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." (interactive "^p\nd") (or arg (setq arg 1)) - (forward-sexp (- arg) user-error)) + (forward-sexp (- arg) interactive)) (defun mark-sexp (&optional arg allow-extend) "Set mark ARG sexps from point. @@ -129,17 +129,17 @@ This command assumes point is not in a string or comment." (point)) nil t)))) -(defun forward-list (&optional arg user-error) +(defun forward-list (&optional arg interactive) "Move forward across one balanced group of parentheses. This command will also work on other parentheses-like expressions defined by the current language mode. With ARG, do it that many times. Negative arg -N means move backward across N groups of parentheses. This command assumes point is not in a string or comment. -If USER-ERROR is non-nil, as it is interactively, -report errors as appropriate for an interactive command." +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." (interactive "^p\nd") - (if user-error + (if interactive (condition-case _ (forward-list arg nil) (scan-error (user-error (if (> arg 0) @@ -148,30 +148,30 @@ report errors as appropriate for an interactive command." (or arg (setq arg 1)) (goto-char (or (scan-lists (point) arg 0) (buffer-end arg))))) -(defun backward-list (&optional arg user-error) +(defun backward-list (&optional arg interactive) "Move backward across one balanced group of parentheses. This command will also work on other parentheses-like expressions defined by the current language mode. With ARG, do it that many times. Negative arg -N means move forward across N groups of parentheses. This command assumes point is not in a string or comment. -If USER-ERROR is non-nil, as it is interactively, -report errors as appropriate for an interactive command." +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." (interactive "^p\nd") (or arg (setq arg 1)) - (forward-list (- arg) user-error)) + (forward-list (- arg) interactive)) -(defun down-list (&optional arg user-error) +(defun down-list (&optional arg interactive) "Move forward down one level of parentheses. This command will also work on other parentheses-like expressions defined by the current language mode. With ARG, do this that many times. A negative argument means move backward but still go down a level. This command assumes point is not in a string or comment. -If USER-ERROR is non-nil, as it is interactively, -report errors as appropriate for an interactive command." +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." (interactive "^p\nd") - (if user-error + (if interactive (condition-case _ (down-list arg nil) (scan-error (user-error "At bottom level"))) @@ -272,15 +272,15 @@ point is unspecified." (signal (car err) (cdr err))))))) (setq arg (- arg inc))))) -(defun kill-sexp (&optional arg user-error) +(defun kill-sexp (&optional arg interactive) "Kill the sexp (balanced expression) following point. With ARG, kill that many sexps after point. Negative arg -N means kill N sexps before point. This command assumes point is not in a string or comment. -If USER-ERROR is non-nil, as it is interactively, -report errors as appropriate for an interactive command." +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." (interactive "p\nd") - (if user-error + (if interactive (condition-case _ (kill-sexp arg nil) (scan-error (user-error (if (> arg 0) @@ -290,15 +290,15 @@ report errors as appropriate for an interactive command." (forward-sexp (or arg 1)) (kill-region opoint (point))))) -(defun backward-kill-sexp (&optional arg user-error) +(defun backward-kill-sexp (&optional arg interactive) "Kill the sexp (balanced expression) preceding point. With ARG, kill that many sexps before point. Negative arg -N means kill N sexps after point. This command assumes point is not in a string or comment. -If USER-ERROR is non-nil, as it is interactively, -report errors as appropriate for an interactive command." +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." (interactive "p\nd") - (kill-sexp (- (or arg 1)) user-error)) + (kill-sexp (- (or arg 1)) interactive)) ;; After Zmacs: (defun kill-backward-up-list (&optional arg) commit df0f32f04850e7ed106a225addfa82f1b5b91f45 Author: Mattias Engdegård Date: Fri Sep 18 12:49:33 2020 +0200 Don't signal scan-error when moving by sexp interactively * lisp/emacs-lisp/lisp.el (forward-sexp, backward-sexp, forward-list) (backward-list, down-list, up-list, mark-sexp, kill-sexp) (backward-kill-sexp): Remove unsightly scan-error when running interactively and no further movement by sexp can be made (bug#43489). diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index ac4ba78897..ba78d7f9b3 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -55,7 +55,7 @@ This affects `insert-parentheses' and `insert-pair'." "If non-nil, `forward-sexp' delegates to this function. Should take the same arguments and behave similarly to `forward-sexp'.") -(defun forward-sexp (&optional arg) +(defun forward-sexp (&optional arg user-error) "Move forward across one balanced expression (sexp). With ARG, do it that many times. Negative arg -N means move backward across N balanced expressions. This command assumes @@ -64,23 +64,32 @@ point is not in a string or comment. Calls If unable to move over a sexp, signal `scan-error' with three arguments: a message, the start of the obstacle (usually a parenthesis or list marker of some kind), and end of the -obstacle." - (interactive "^p") - (or arg (setq arg 1)) - (if forward-sexp-function - (funcall forward-sexp-function arg) - (goto-char (or (scan-sexps (point) arg) (buffer-end arg))) - (if (< arg 0) (backward-prefix-chars)))) - -(defun backward-sexp (&optional arg) +obstacle. If USER-ERROR is non-nil, as it is interactively, +report errors as appropriate for an interactive command." + (interactive "^p\nd") + (if user-error + (condition-case _ + (forward-sexp arg nil) + (scan-error (user-error (if (> arg 0) + "No next sexp" + "No previous sexp")))) + (or arg (setq arg 1)) + (if forward-sexp-function + (funcall forward-sexp-function arg) + (goto-char (or (scan-sexps (point) arg) (buffer-end arg))) + (if (< arg 0) (backward-prefix-chars))))) + +(defun backward-sexp (&optional arg user-error) "Move backward across one balanced expression (sexp). With ARG, do it that many times. Negative arg -N means move forward across N balanced expressions. This command assumes point is not in a string or comment. -Uses `forward-sexp' to do the work." - (interactive "^p") +Uses `forward-sexp' to do the work. +If USER-ERROR is non-nil, as it is interactively, +report errors as appropriate for an interactive command." + (interactive "^p\nd") (or arg (setq arg 1)) - (forward-sexp (- arg))) + (forward-sexp (- arg) user-error)) (defun mark-sexp (&optional arg allow-extend) "Set mark ARG sexps from point. @@ -99,50 +108,78 @@ This command assumes point is not in a string or comment." (set-mark (save-excursion (goto-char (mark)) - (forward-sexp arg) + (condition-case error + (forward-sexp arg) + (scan-error + (user-error (if (equal (cadr error) + "Containing expression ends prematurely") + "No more sexp to select" + (cadr error))))) (point)))) (t (push-mark (save-excursion - (forward-sexp (prefix-numeric-value arg)) + (condition-case error + (forward-sexp (prefix-numeric-value arg)) + (scan-error + (user-error (if (equal (cadr error) + "Containing expression ends prematurely") + "No sexp to select" + (cadr error))))) (point)) nil t)))) -(defun forward-list (&optional arg) +(defun forward-list (&optional arg user-error) "Move forward across one balanced group of parentheses. This command will also work on other parentheses-like expressions defined by the current language mode. With ARG, do it that many times. Negative arg -N means move backward across N groups of parentheses. -This command assumes point is not in a string or comment." - (interactive "^p") - (or arg (setq arg 1)) - (goto-char (or (scan-lists (point) arg 0) (buffer-end arg)))) - -(defun backward-list (&optional arg) +This command assumes point is not in a string or comment. +If USER-ERROR is non-nil, as it is interactively, +report errors as appropriate for an interactive command." + (interactive "^p\nd") + (if user-error + (condition-case _ + (forward-list arg nil) + (scan-error (user-error (if (> arg 0) + "No next group" + "No previous group")))) + (or arg (setq arg 1)) + (goto-char (or (scan-lists (point) arg 0) (buffer-end arg))))) + +(defun backward-list (&optional arg user-error) "Move backward across one balanced group of parentheses. This command will also work on other parentheses-like expressions defined by the current language mode. With ARG, do it that many times. Negative arg -N means move forward across N groups of parentheses. -This command assumes point is not in a string or comment." - (interactive "^p") +This command assumes point is not in a string or comment. +If USER-ERROR is non-nil, as it is interactively, +report errors as appropriate for an interactive command." + (interactive "^p\nd") (or arg (setq arg 1)) - (forward-list (- arg))) + (forward-list (- arg) user-error)) -(defun down-list (&optional arg) +(defun down-list (&optional arg user-error) "Move forward down one level of parentheses. This command will also work on other parentheses-like expressions defined by the current language mode. With ARG, do this that many times. A negative argument means move backward but still go down a level. -This command assumes point is not in a string or comment." - (interactive "^p") - (or arg (setq arg 1)) - (let ((inc (if (> arg 0) 1 -1))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) inc -1) (buffer-end arg))) - (setq arg (- arg inc))))) +This command assumes point is not in a string or comment. +If USER-ERROR is non-nil, as it is interactively, +report errors as appropriate for an interactive command." + (interactive "^p\nd") + (if user-error + (condition-case _ + (down-list arg nil) + (scan-error (user-error "At bottom level"))) + (or arg (setq arg 1)) + (let ((inc (if (> arg 0) 1 -1))) + (while (/= arg 0) + (goto-char (or (scan-lists (point) inc -1) (buffer-end arg))) + (setq arg (- arg inc)))))) (defun backward-up-list (&optional arg escape-strings no-syntax-crossing) "Move backward out of one level of parentheses. @@ -229,26 +266,39 @@ point is unspecified." (or (< inc 0) (forward-comment 1)) (setf arg (+ arg inc))) - (signal (car err) (cdr err)))))) + (if no-syntax-crossing + ;; Assume called interactively; don't signal an error. + (user-error "At top level") + (signal (car err) (cdr err))))))) (setq arg (- arg inc))))) -(defun kill-sexp (&optional arg) +(defun kill-sexp (&optional arg user-error) "Kill the sexp (balanced expression) following point. With ARG, kill that many sexps after point. Negative arg -N means kill N sexps before point. -This command assumes point is not in a string or comment." - (interactive "p") - (let ((opoint (point))) - (forward-sexp (or arg 1)) - (kill-region opoint (point)))) - -(defun backward-kill-sexp (&optional arg) +This command assumes point is not in a string or comment. +If USER-ERROR is non-nil, as it is interactively, +report errors as appropriate for an interactive command." + (interactive "p\nd") + (if user-error + (condition-case _ + (kill-sexp arg nil) + (scan-error (user-error (if (> arg 0) + "No next sexp" + "No previous sexp")))) + (let ((opoint (point))) + (forward-sexp (or arg 1)) + (kill-region opoint (point))))) + +(defun backward-kill-sexp (&optional arg user-error) "Kill the sexp (balanced expression) preceding point. With ARG, kill that many sexps before point. Negative arg -N means kill N sexps after point. -This command assumes point is not in a string or comment." - (interactive "p") - (kill-sexp (- (or arg 1)))) +This command assumes point is not in a string or comment. +If USER-ERROR is non-nil, as it is interactively, +report errors as appropriate for an interactive command." + (interactive "p\nd") + (kill-sexp (- (or arg 1)) user-error)) ;; After Zmacs: (defun kill-backward-up-list (&optional arg) commit b252e09ae4fc816ecee1971e8f0b7f207fb4a507 Author: Mauro Aranda Date: Wed Sep 23 15:45:29 2020 +0200 Allow the newline character in the character widget (Bug#15925) * lisp/wid-edit.el (widget-specify-field): Extend check for adding the boundary overlay. Plus, a minor comment indentation fix. (character widget): Tweak the valid-regexp to allow the newline character. * test/lisp/wid-edit-tests.el (widget-test-character-widget-value) (widget-test-editable-field-widget-value): New tests (bug#15925). diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 13d850a57f..8ad99f49aa 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -303,12 +303,15 @@ the :notify function can't know the new value.") (or (not widget-field-add-space) (widget-get widget :size)))) (if (functionp help-echo) (setq help-echo 'widget-mouse-help)) - (when (= (char-before to) ?\n) + (when (and (or (> to (1+ from)) (null (widget-get widget :size))) + (= (char-before to) ?\n)) ;; When the last character in the field is a newline, we want to ;; give it a `field' char-property of `boundary', which helps the ;; C-n/C-p act more naturally when entering/leaving the field. We - ;; do this by making a small secondary overlay to contain just that - ;; one character. + ;; do this by making a small secondary overlay to contain just that + ;; one character. BUT we only do this if there is more than one + ;; character (so we don't do this for the character widget), + ;; or if the size of the editable field isn't specified. (let ((overlay (make-overlay (1- to) to nil t nil))) (overlay-put overlay 'field 'boundary) ;; We need the real field for tabbing. @@ -3524,7 +3527,7 @@ To use this type, you must define :match or :match-alternatives." :value 0 :size 1 :format "%{%t%}: %v\n" - :valid-regexp "\\`.\\'" + :valid-regexp "\\`\\(.\\|\n\\)\\'" :error "This field should contain a single character" :value-get (lambda (w) (widget-field-value-get w t)) :value-to-internal (lambda (_widget value) diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el index 2ddb656fa9..df49ffc822 100644 --- a/test/lisp/wid-edit-tests.el +++ b/test/lisp/wid-edit-tests.el @@ -113,4 +113,20 @@ (should (eq (current-column) (widget-get grandchild :indent))))))) +(ert-deftest widget-test-character-widget-value () + "Check that we get the character widget's value correctly." + (with-temp-buffer + (let ((wid (widget-create '(character :value ?\n)))) + (goto-char (widget-get wid :from)) + (should (string= (widget-apply wid :value-get) "\n")) + (should (char-equal (widget-value wid) ?\n)) + (should-not (widget-apply wid :validate))))) + +(ert-deftest widget-test-editable-field-widget-value () + "Test that we get the editable field widget's value correctly." + (with-temp-buffer + (let ((wid (widget-create '(editable-field :value "")))) + (widget-insert "And some non-widget text.") + (should (string= (widget-apply wid :value-get) ""))))) + ;;; wid-edit-tests.el ends here commit 6037051f49ab5f96b406461490dba56faa2a5f35 Author: Andrew G Cohen Date: Wed Sep 23 19:47:15 2020 +0800 Improve mark handling in gnus nnselect * lisp/gnus/nnselect.el (numbers-by-group, nnselect-request-update-info, nnselect-push-info): Handle all three mark types ('tuple, 'range, 'list) and general speedups. diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index c6f2ffae9c..8cd658100f 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -203,11 +203,22 @@ as `(keyfunc member)' and the corresponding element is just (nnselect-categorize ,articles 'nnselect-article-group 'nnselect-article-id))) -(define-inline numbers-by-group (articles) +(define-inline numbers-by-group (articles &optional type) (inline-quote - (nnselect-categorize - ,articles 'nnselect-article-group 'nnselect-article-number))) - + (cond + ((eq ,type 'range) + (nnselect-categorize (gnus-uncompress-range ,articles) + 'nnselect-article-group 'nnselect-article-number)) + ((eq ,type 'tuple) + (nnselect-categorize ,articles + #'(lambda (elem) + (nnselect-article-group (car elem))) + #'(lambda (elem) + (cons (nnselect-article-number + (car elem)) (cdr elem))))) + (t + (nnselect-categorize ,articles + 'nnselect-article-group 'nnselect-article-number))))) (defmacro nnselect-add-prefix (group) "Ensures that the GROUP has an nnselect prefix." @@ -504,15 +515,15 @@ If this variable is nil, or if the provided function returns nil, (list (car artgroup) (gnus-compress-sequence (sort (cdr artgroup) '<)) action marks)) - (numbers-by-group - (gnus-uncompress-range range))))) + (numbers-by-group range 'range)))) actions) 'car 'cdr))) (deffoo nnselect-request-update-info (group info &optional _server) - (let* ((group (nnselect-add-prefix group)) - (gnus-newsgroup-selection (or gnus-newsgroup-selection - (nnselect-get-artlist group)))) + (let* ((group (nnselect-add-prefix group)) + (gnus-newsgroup-selection + (or gnus-newsgroup-selection (nnselect-get-artlist group))) + newmarks) (gnus-info-set-marks info nil) (setf (gnus-info-read info) nil) (pcase-dolist (`(,artgroup . ,nartids) @@ -520,30 +531,56 @@ If this variable is nil, or if the provided function returns nil, (number-sequence 1 (nnselect-artlist-length gnus-newsgroup-selection)))) (let* ((gnus-newsgroup-active nil) - (artids (cl-sort nartids '< :key 'car)) + (artids (cl-sort nartids #'< :key 'car)) (group-info (gnus-get-info artgroup)) (marks (gnus-info-marks group-info)) (unread (gnus-uncompress-sequence (gnus-range-difference (gnus-active artgroup) (gnus-info-read group-info))))) - (gnus-atomic-progn - (setf (gnus-info-read info) - (gnus-add-to-range - (gnus-info-read info) - (delq nil - (mapcar - #'(lambda (art) - (unless (memq (cdr art) unread) (car art))) - artids)))) - (pcase-dolist (`(,type . ,range) marks) - (setq range (gnus-uncompress-sequence range)) - (gnus-add-marked-articles - group type - (delq nil - (mapcar - #'(lambda (art) - (when (memq (cdr art) range) - (car art))) artids))))))) + (setf (gnus-info-read info) + (gnus-add-to-range + (gnus-info-read info) + (delq nil (mapcar + #'(lambda (art) + (unless (memq (cdr art) unread) (car art))) + artids)))) + (pcase-dolist (`(,type . ,mark-list) marks) + (let ((mark-type (gnus-article-mark-to-type type)) new) + (when + (setq new + (delq nil + (cond + ((eq mark-type 'tuple) + (mapcar + #'(lambda (id) + (let (mark) + (when + (setq mark (assq (cdr id) mark-list)) + (cons (car id) (cdr mark))))) + artids)) + (t + (setq mark-list + (gnus-uncompress-range mark-list)) + (mapcar + #'(lambda (id) + (when (memq (cdr id) mark-list) + (car id))) artids))))) + (let ((previous (alist-get type newmarks))) + (if previous + (nconc previous new) + (push (cons type new) newmarks)))))))) + + ;; Clean up the marks: compress lists; + (pcase-dolist (`(,type . ,mark-list) newmarks) + (let ((mark-type (gnus-article-mark-to-type type))) + (unless (eq mark-type 'tuple) + (setf (alist-get type newmarks) + (gnus-compress-sequence mark-list))))) + ;; and ensure an unexist key. + (unless (assq 'unexist newmarks) + (push (cons 'unexist nil) newmarks)) + + (gnus-info-set-marks info newmarks) (gnus-set-active group (cons 1 (nnselect-artlist-length gnus-newsgroup-selection))))) @@ -769,42 +806,61 @@ article came from is also searched." "Copy mark-lists from GROUP to the originating groups." (let ((select-unreads (numbers-by-group gnus-newsgroup-unreads)) (select-reads (numbers-by-group - (gnus-uncompress-range - (gnus-info-read (gnus-get-info group))))) + (gnus-info-read (gnus-get-info group)) 'range)) (select-unseen (numbers-by-group gnus-newsgroup-unseen)) - (gnus-newsgroup-active nil) - mark-list type-list) + (gnus-newsgroup-active nil) mark-list) + ;; collect the set of marked article lists categorized by + ;; originating groups (pcase-dolist (`(,mark . ,type) gnus-article-mark-lists) - (when (setq type-list - (symbol-value (intern (format "gnus-newsgroup-%s" mark)))) - (push (cons type - (numbers-by-group - (gnus-uncompress-range type-list))) mark-list))) + (let (type-list) + (when (setq type-list + (symbol-value (intern (format "gnus-newsgroup-%s" mark)))) + (push (cons + type + (numbers-by-group type-list (gnus-article-mark-to-type type))) + mark-list)))) + ;; now work on each originating group one at a time (pcase-dolist (`(,artgroup . ,artlist) (numbers-by-group gnus-newsgroup-articles)) (let* ((group-info (gnus-get-info artgroup)) (old-unread (gnus-list-of-unread-articles artgroup)) - newmarked) + newmarked delta-marks) (when group-info + ;; iterate over mark lists for this group (pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists) - (let ((select-type - (sort - (cdr (assoc artgroup (alist-get type mark-list))) - '<)) list) - (setq list - (gnus-uncompress-range - (gnus-add-to-range - (gnus-remove-from-range - (alist-get type (gnus-info-marks group-info)) - artlist) - select-type))) - - (when list - ;; Get rid of the entries of the articles that have the - ;; default score. - (when (and (eq type 'score) - gnus-save-score - list) + (let ((list (cdr (assoc artgroup (alist-get type mark-list)))) + (mark-type (gnus-article-mark-to-type type))) + + ;; When the backend can store marks we collect any + ;; changes. Unlike a normal group the mark lists only + ;; include marks for articles we retrieved. + (when (and (gnus-check-backend-function + 'request-set-mark artgroup) + (not (gnus-article-unpropagatable-p type))) + (let* ((old (gnus-list-range-intersection + artlist + (alist-get type (gnus-info-marks group-info)))) + (del (gnus-remove-from-range (copy-tree old) list)) + (add (gnus-remove-from-range (copy-tree list) old))) + (when add (push (list add 'add (list type)) delta-marks)) + (when del + ;; Don't delete marks from outside the active range. + ;; This shouldn't happen, but is a sanity check. + (setq del (gnus-sorted-range-intersection + (gnus-active artgroup) del)) + (push (list del 'del (list type)) delta-marks)))) + + ;; Marked sets are of mark-type 'tuple, 'list, or + ;; 'range. We merge the lists with what is already in + ;; the original info to get full list of new marks. We + ;; do this by removing all the articles we retrieved + ;; from the full list, and then add back in the newly + ;; marked ones. + (cond + ((eq mark-type 'tuple) + ;; Get rid of the entries that have the default + ;; score. + (when (and list (eq type 'score) gnus-save-score) (let* ((arts list) (prev (cons nil list)) (all prev)) @@ -814,30 +870,41 @@ article came from is also searched." (setcdr prev (cdr arts)) (setq prev arts)) (setq arts (cdr arts))) - (setq list (cdr all))))) - - (when (or (eq (gnus-article-mark-to-type type) 'list) - (eq (gnus-article-mark-to-type type) 'range)) + (setq list (cdr all)))) + ;; now merge with the original list and sort just to + ;; make sure (setq list - (gnus-compress-sequence (sort list '<) t))) - - ;; When exiting the group, everything that's previously been - ;; unseen is now seen. - (when (eq type 'seen) - (setq list (gnus-range-add - list (cdr (assoc artgroup select-unseen))))) + (sort (map-merge + 'list list + (alist-get type (gnus-info-marks group-info))) + (lambda (elt1 elt2) + (< (car elt1) (car elt2)))))) + (t + (setq list + (gnus-compress-sequence + (gnus-sorted-union + (gnus-sorted-difference + (gnus-uncompress-sequence + (alist-get type (gnus-info-marks group-info))) + artlist) + (sort list #'<)) t))) + + ;; When exiting the group, everything that's previously been + ;; unseen is now seen. + (when (eq type 'seen) + (setq list (gnus-range-add + list (cdr (assoc artgroup select-unseen)))))) (when (or list (eq type 'unexist)) - (push (cons type list) newmarked)))) + (push (cons type list) newmarked)))) ;; end of mark-type loop - (gnus-atomic-progn - ;; Enter these new marks into the info of the group. - (if (nthcdr 3 group-info) - (setcar (nthcdr 3 group-info) newmarked) - ;; Add the marks lists to the end of the info. - (when newmarked - (setcdr (nthcdr 2 group-info) (list newmarked)))) + (when delta-marks + (unless (gnus-check-group artgroup) + (error "Can't open server for %s" artgroup)) + (gnus-request-set-mark artgroup delta-marks)) + (gnus-atomic-progn + (gnus-info-set-marks group-info newmarked) ;; Cut off the end of the info if there's nothing else there. (let ((i 5)) (while (and (> i 2) commit e4831151c2b746564319018105a17fbde4b553c6 Author: Alan Mackenzie Date: Wed Sep 23 08:50:11 2020 +0000 Handle escaped comment enders correctly in syntax.c, fixing bug #43558 This fixes forward-comment, scan-lists, and parse-partial-sexp. * src/syntax.c (forw_comment): Detect and skip an escaped comment ender (e.g. \*/ in C) when comment-end-can-be-escaped is non-nil. diff --git a/src/syntax.c b/src/syntax.c index e6af8a377b..066972e6d8 100644 --- a/src/syntax.c +++ b/src/syntax.c @@ -2354,6 +2354,13 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, /* We have encountered a nested comment of the same style as the comment sequence which began this comment section. */ nesting++; + if (comment_end_can_be_escaped + && (code == Sescape || code == Scharquote)) + { + inc_both (&from, &from_byte); + UPDATE_SYNTAX_TABLE_FORWARD (from); + if (from == stop) continue; /* Failure */ + } inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); commit 80b0a69b606c9beb738fe797a13d23ca28c4f09d Author: Andrew G Cohen Date: Wed Sep 23 16:46:36 2020 +0800 Run gnus-parse-headers-hook when retrieving nnselect headers * lisp/gnus/nnselect.el (nnselect-retrieve-headers): Run the gnus-parse-headers-hook when retrieving headers in nnselect, just like in a real group. diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 9bff9fdd0c..c6f2ffae9c 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -328,6 +328,7 @@ If this variable is nil, or if the provided function returns nil, (nnheader-parse-nov)) (forward-line 1))) ('headers + (gnus-run-hooks 'gnus-parse-headers-hook) (let ((nnmail-extra-headers gnus-extra-headers)) (goto-char (point-min)) (while (not (eobp))