commit d1d85e0f35d4cb22f2cdfda0672ca33f5bb87b21 (HEAD, refs/remotes/origin/master) Author: Stefan Kangas Date: Tue Feb 25 08:28:30 2025 +0100 Prefer incf to cl-incf in progmodes/*.el * lisp/progmodes/bug-reference.el (bug-reference--overlay-bounds): * lisp/progmodes/c-ts-common.el (c-ts-common-statement-offset): * lisp/progmodes/compile.el (compilation--note-type): * lisp/progmodes/ebrowse.el (ebrowse-files-table) (ebrowse-fill-member-table, ebrowse-find-pattern) (ebrowse-draw-member-short-fn, ebrowse-gather-statistics): * lisp/progmodes/elixir-ts-mode.el (elixir-ts--electric-pair-string-delimiter): * lisp/progmodes/gdb-mi.el (gdb-thread-list-handler-custom): * lisp/progmodes/grep.el (grep-filter): * lisp/progmodes/hideif.el (hif-backward-comment, hif-__COUNTER__) (hif-token-concatenation, hif-find-define): * lisp/progmodes/js.el (js--pstate-is-toplevel-defun) (js-beginning-of-defun, js-end-of-defun, js--pitems-to-imenu) (js--imenu-to-flat, js-ts--syntax-propertize): * lisp/progmodes/tcl.el (tcl--syntax-of-quote): * lisp/progmodes/typescript-ts-mode.el (tsx-ts--syntax-propertize-captures): Prefer incf to cl-incf. diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index a4147bca05e..5c03c949049 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -138,7 +138,7 @@ to the highlighted and clickable region." (or (< (match-beginning i) m-b1) (> (match-end i) m-e1))) (throw 'within-bounds nil)) - (cl-incf i)) + (incf i)) t))) ;; All groups 2..10 are within bounds. (cons m-b1 m-e1) diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index 6e36b64f02a..66e7fad015d 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -503,7 +503,7 @@ characters on the current line." (let ((parent (treesit-node-parent node))) ;; Increment level for every bracket (with exception). (when (c-ts-common--node-is node 'block) - (cl-incf level) + (incf level) (save-excursion (goto-char (treesit-node-start node)) ;; Add an extra level if the opening bracket is on its own @@ -515,12 +515,12 @@ characters on the current line." ;; Add a level. ((looking-back (rx bol (* whitespace)) (line-beginning-position)) - (cl-incf level))))) + (incf level))))) ;; Fix bracketless statements. (when (and (c-ts-common--node-is parent 'if 'do 'while 'for) (not (c-ts-common--node-is node 'block))) - (cl-incf level)) + (incf level)) ;; Flatten "else if" statements. (when (and (c-ts-common--node-is node 'else) (c-ts-common--node-is node 'if) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 3d6ffd1fbe4..a1264d8d7b0 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -1641,9 +1641,9 @@ RULE is the name (symbol) of the rule used or nil if anonymous. "Note that a new message with severity TYPE was seen. This updates the appropriate variable used by the mode-line." (cl-case type - (0 (cl-incf compilation-num-infos-found)) - (1 (cl-incf compilation-num-warnings-found)) - (2 (cl-incf compilation-num-errors-found)))) + (0 (incf compilation-num-infos-found)) + (1 (incf compilation-num-warnings-found)) + (2 (incf compilation-num-errors-found)))) (defun compilation-parse-errors (start end &rest rules) "Parse errors between START and END. diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index 70e1a1e5904..72e80811fb5 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -593,7 +593,7 @@ MARKED-ONLY non-nil means include marked classes only." (ebrowse-for-all-trees (tree ebrowse--tree-table) (when (or (not marked-only) (ebrowse-ts-mark tree)) (let ((class (ebrowse-ts-class tree))) - (when (zerop (% (cl-incf i) 20)) + (when (zerop (% (incf i) 20)) (ebrowse-show-progress "Preparing file list" (zerop i))) ;; Add files mentioned in class description (let ((source-file (ebrowse-cs-source-file class)) @@ -864,7 +864,7 @@ type `ebrowse-hs' is set to the resulting table." (garbage-collect) ;; For all classes... (ebrowse-for-all-trees (c ebrowse--tree-table) - (when (zerop (% (cl-incf i) 10)) + (when (zerop (% (incf i) 10)) (ebrowse-show-progress "Preparing member lookup" (zerop i))) (dolist (f ebrowse-member-list-accessors) (dolist (m (funcall f c)) @@ -1649,7 +1649,7 @@ INFO is a list (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST)." when (re-search-forward pattern (+ start offset) t) return t never (bobp) - do (cl-incf offset offset))) + do (incf offset offset))) (cond (found (beginning-of-line) (run-hooks 'ebrowse-view/find-hook)) @@ -2689,7 +2689,7 @@ TREE is the class tree in which the members are found." mouse-face highlight ebrowse-tree ,tree help-echo "mouse-2: view definition; mouse-3: menu")) - (cl-incf i) + (incf i) (when (>= i ebrowse--n-columns) (setf i 0) (insert "\n"))))) @@ -4032,11 +4032,11 @@ NUMBER-OF-STATIC-VARIABLES:" (let ((classes 0) (member-functions 0) (member-variables 0) (static-functions 0) (static-variables 0)) (ebrowse-for-all-trees (tree ebrowse--tree-table) - (cl-incf classes) - (cl-incf member-functions (length (ebrowse-ts-member-functions tree))) - (cl-incf member-variables (length (ebrowse-ts-member-variables tree))) - (cl-incf static-functions (length (ebrowse-ts-static-functions tree))) - (cl-incf static-variables (length (ebrowse-ts-static-variables tree)))) + (incf classes) + (incf member-functions (length (ebrowse-ts-member-functions tree))) + (incf member-variables (length (ebrowse-ts-member-variables tree))) + (incf static-functions (length (ebrowse-ts-static-functions tree))) + (incf static-variables (length (ebrowse-ts-static-variables tree)))) (list classes member-functions member-variables static-functions static-variables))) diff --git a/lisp/progmodes/elixir-ts-mode.el b/lisp/progmodes/elixir-ts-mode.el index a0d503632d9..d50692d87c0 100644 --- a/lisp/progmodes/elixir-ts-mode.el +++ b/lisp/progmodes/elixir-ts-mode.el @@ -658,7 +658,7 @@ Return nil if NODE is not a defun node or doesn't have a name." (eq last-command-event ?\") (let ((count 0)) (while (eq (char-before (- (point) count)) last-command-event) - (cl-incf count)) + (incf count)) (= count 3)) (eq (char-after) last-command-event)) (save-excursion diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 040d4b7e9af..74dff3217ff 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -3545,9 +3545,9 @@ corresponding to the mode line clicked." (add-to-list 'gdb-threads-list (cons (gdb-mi--field thread 'id) thread)) - (cl-incf (if running - gdb-running-threads-count - gdb-stopped-threads-count)) + (incf (if running + gdb-running-threads-count + gdb-stopped-threads-count)) (gdb-table-add-row table diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index d04e9945b0d..951663e049a 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -648,7 +648,7 @@ This function is called from `compilation-filter-hook'." (replace-match (propertize (match-string 1) 'face nil 'font-lock-face grep-match-face) t t) - (cl-incf grep-num-matches-found)) + (incf grep-num-matches-found)) ;; Delete all remaining escape sequences (goto-char beg) (while (re-search-forward "\033\\[[0-9;]*[mK]" end 1) diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 0d5797bb303..0ddaf513a02 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -888,7 +888,7 @@ Assuming we've just performed a `hif-token-regexp' lookup." ;; merge whites immediately ahead (setq ce (if (and we (= (1- p) we)) ws p)) ;; scan for end of line - (while (and (< (cl-incf p) end) + (while (and (< (incf p) end) (not (char-equal ?\n (char-after p))) (not (char-equal ?\r (char-after p))))) ;; Merge with previous comment if immediately followed @@ -913,7 +913,7 @@ Assuming we've just performed a `hif-token-regexp' lookup." (while (< (1+ p) end) (if (not (and (char-equal ?* (char-after p)) (char-equal ?/ (char-after (1+ p))))) - (cl-incf p) + (incf p) ;; found `*/', mark end pos (push (cons cmt (1+ (setq p (1+ p)))) cmtlist) (throw 'break nil))) @@ -927,7 +927,7 @@ Assuming we've just performed a `hif-token-regexp' lookup." we p)) (setq ws nil we nil))) - (cl-incf p)) + (incf p)) ;; Goto beginning of the last comment, if we're within (setq cmt (car cmtlist)) ;; last cmt (setq cmt (if (and cmt @@ -1531,7 +1531,7 @@ and `+='...)." (defvar hif-__COUNTER__ 0) (defun hif-__COUNTER__ () - (prog1 hif-__COUNTER__ (cl-incf hif-__COUNTER__))) + (prog1 hif-__COUNTER__ (incf hif-__COUNTER__))) (defun hif-__cplusplus () (and (string-match @@ -1604,7 +1604,7 @@ and `+='...)." (push tk items) ; first item, in reverse order (setq tk 'hif-token-concat)) (while (eq tk 'hif-token-concat) - (cl-incf count) + (incf count) ;; 2+ item (setq l (cdr l) tk (car l)) @@ -2477,7 +2477,7 @@ first arg will be `hif-etc'." (tokens (and name (prog1 t - (cl-incf hif-verbose-define-count) + (incf hif-verbose-define-count) ;; only show 1/50 to not slow down to much (if (and hide-ifdef-verbose (= (% hif-verbose-define-count 50) 1)) diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index bb91eea93f2..1142786ffaa 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -982,7 +982,7 @@ top-most pitem. Otherwise, return nil." with func-depth = 0 with func-pitem if (eq 'function (js--pitem-type pitem)) - do (cl-incf func-depth) + do (incf func-depth) and do (setq func-pitem pitem) finally return (if (eq func-depth 1) func-pitem))) @@ -1017,7 +1017,7 @@ Return the pitem of the function we went to the beginning of." (setq arg (or arg 1)) (let ((found)) (while (and (not (eobp)) (< arg 0)) - (cl-incf arg) + (incf arg) (when (and (not js-flat-functions) (or (eq (js-syntactic-context) 'function) (js--function-prologue-beginning))) @@ -1360,7 +1360,7 @@ LIMIT defaults to point." "Value of `end-of-defun-function' for `js-mode'." (setq arg (or arg 1)) (while (and (not (bobp)) (< arg 0)) - (cl-incf arg) + (incf arg) (js-beginning-of-defun) (js-beginning-of-defun) (unless (bobp) @@ -3180,7 +3180,7 @@ the broken-down class name of the item to insert." (setq pitem-name (js--pitem-strname pitem)) (when (eq pitem-name t) (setq pitem-name (format "[unknown %s]" - (cl-incf (car unknown-ctr))))) + (incf (car unknown-ctr))))) (cond ((memq pitem-type '(function macro)) @@ -3255,7 +3255,7 @@ the broken-down class name of the item to insert." (ctr 0)) (while (gethash name2 symbols) - (setq name2 (format "%s<%d>" name (cl-incf ctr)))) + (setq name2 (format "%s<%d>" name (incf ctr)))) (puthash name2 (cdr item) symbols)))) @@ -4037,7 +4037,7 @@ See `treesit-thing-settings' for more information.") (syntax (pcase-exhaustive name ('regexp (decf ns) - (cl-incf ne) + (incf ne) (string-to-syntax "\"/")) ('jsx (string-to-syntax "|"))))) diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el index c4b40f4a170..e1efade517d 100644 --- a/lisp/progmodes/tcl.el +++ b/lisp/progmodes/tcl.el @@ -432,9 +432,9 @@ This variable is generally set from `tcl-proc-regexp', (pcase (char-after (match-beginning 0)) (?\\ (forward-char 1)) (?\" (setq type 'matched)) - (?\{ (cl-incf depth)) + (?\{ (incf depth)) (?\} (if (zerop depth) (setq type 'unmatched) - (cl-incf depth))))) + (incf depth))))) (when (> (line-beginning-position) pos) ;; The quote is not on the same line as the deciding ;; factor, so make sure we revisit this choice later. diff --git a/lisp/progmodes/typescript-ts-mode.el b/lisp/progmodes/typescript-ts-mode.el index 34d9e8636d1..759578d7b9d 100644 --- a/lisp/progmodes/typescript-ts-mode.el +++ b/lisp/progmodes/typescript-ts-mode.el @@ -680,7 +680,7 @@ at least 3 (which is the default value)." ('regexp (let ((syntax (string-to-syntax "\"/"))) (decf ns) - (cl-incf ne) + (incf ne) (put-text-property ns (1+ ns) 'syntax-table syntax) (put-text-property (1- ne) ne 'syntax-table syntax))) ;; We put punctuation syntax on all the balanced pair commit 99d116a8f41c29193cb41d0cde24a7051237ecf4 Author: Po Lu Date: Mon Feb 24 21:06:41 2025 +0800 ; * .gitignore: Add new VCS ignores. diff --git a/.gitignore b/.gitignore index e6309ed0b1f..ea942b86f80 100644 --- a/.gitignore +++ b/.gitignore @@ -203,6 +203,11 @@ test/manual/indent/*.new test/lisp/gnus/mml-sec-resources/random_seed test/lisp/play/fortune-resources/fortunes.dat test/**/*.xml +test/infra/android/**/*.class +test/infra/android/**/*.dex +test/infra/android/**/*.zip +test/infra/android/**/*.jar +test/infra/android/bin/build.sh # ctags, etags. TAGS commit 08077788dbcc535e8840495d62cee79434766b3d Author: Po Lu Date: Mon Feb 24 21:06:30 2025 +0800 ; Begin integrating facilities for executing ERT tests on Android * test/infra/android/README: * test/infra/android/bin/AtsStub.java (AtsStub): * test/infra/android/bin/README: * test/infra/android/test-controller.el (tramp) (ats-adb-executable, ats-adb-host, ats-adb-infile, ats-cache) (ats-adb-disable-stderr, ats-adb-device-regexp, ats-adb) (ats-adb-process-filter, ats-start-adb, ats-enumerate-devices) (ats-online-devices, ats-memoize, ats-ps-device, ats-getprop) (ats-get-sdk-version, ats-package-list-regexp) (ats-is-package-debuggable, ats-list-users, ats-get-package-aid) (ats-aid-user-offset, ats-aid-isolated-start, ats-aid-app-start) (ats-aid-to-uid, ats-uid-to-username, ats-verify-directory) (ats-get-package-data-directory) (ats-get-user-external-storage-directory, ats-transfer-padding) (ats-exec-script, ats-exec-script-checked) (ats-use-private-staging-directory, ats-get-staging-directory) (ats-base64-available, ats-echo-n-e, ats-echo-c, ats-octab, c) (ats-upload-encode-binary, ats-upload, ats-download) (ats-create-empty-temporary, ats-run-jar) (ats-supports-am-force-stop, ats-supports-am-force-stop-user) (ats-kill-process-by-username-and-name) (ats-portforward-local-type-regexp) (ats-portforward-remote-type-regexp, ats-portforward-list-regexp) (ats-portreverse-type-regexp, ats-portreverse-list-regexp) (ats-reverse-list, ats-reverse-tcp, ats-forward-list) (ats-forward-tcp, ats-is-tail-available, ats-java-int-min) (ats-java-int-max, ats-java-long-min, ats-java-long-max) (ats-intent-array-type, ats-fmt-array-element, ats-build-intent) (ats-working-stub-file, ats-file-directory, ats-am-start-intent) (ats-create-commfile, ats-watch-commfile, ats-server) (ats-default-port, ats-accepting-connection) (ats-address-to-hostname, ats-is-localhost-p) (ats-server-sentinel, ats-server-log, ats-server-exists-p) (ats-start-server, ats-await-connection-timeout) (ats-await-connection, ats-forward-server-sentinel) (ats-forward-server-filter, ats-reverse-server) (ats-forward-server, ats-cancel-forward-server, ats-remote-port) (ats-in-connection-context, ats-outstanding-reverse-connection) (ats-terminate-reverse-safely, ats-disconnect-internal) (ats-read-connection, ats-disconnect, ats-establish-connection) (ats-connect, ats-eval, test-controller): * test/infra/android/test-driver.el (ats-process) (ats-connection-established, ats-header, ats-in-eval) (ats-eval-as-printed, ats-eval-serial, ats-process-filter) (ats-display-status-buffer, ats-establish-connection) (ats-driver-log, ats-initiate-connection, test-driver): New files. diff --git a/test/infra/android/README b/test/infra/android/README new file mode 100644 index 00000000000..c3bda37f2d4 --- /dev/null +++ b/test/infra/android/README @@ -0,0 +1,26 @@ +Copyright (C) 2025 Free Software Foundation, Inc. -*- coding: utf-8 -*- +See the end of the file for license conditions. + +In this directory is a collection of scripts which arrange to upload +tests (or rather arbitrary Lisp forms) from an Emacs source repository +into an Android device, execute them "in vivo", so to speak, and +retrieve the results of their execution. While there is an automatic +testing system built around another version of these scripts, the +versions in the Emacs repository are engineered for interactive +execution only. + + +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 . diff --git a/test/infra/android/bin/AtsStub.java b/test/infra/android/bin/AtsStub.java new file mode 100644 index 00000000000..8fab87f1298 --- /dev/null +++ b/test/infra/android/bin/AtsStub.java @@ -0,0 +1,332 @@ +/* Launch an intent stated on the command line as an activity. -*- c-file-style: "GNU" -*- + +Copyright (C) 2025 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 . */ + +package ats; + +import android.app.ActivityManagerNative; +import android.app.ActivityThread; +import android.app.IActivityManager; +import android.app.IApplicationThread; + +import android.content.ComponentName; +import android.content.Context; +import android.content.Intent; + +import android.os.Build; +import android.os.Bundle; +import android.os.IBinder; +import android.os.Looper; +import android.os.ParcelFileDescriptor; +import android.os.RemoteException; + +import android.net.Uri; + +import java.lang.IllegalArgumentException; + +import java.lang.reflect.Field; +import java.lang.reflect.InvocationTargetException; +import java.lang.reflect.Method; + +public final class AtsStub +{ + public static final String IDENT = "$Id: AtsStub.java,v 1.4 2024/06/30 04:24:39 jw Exp $"; + + private static void + neutralizeApplicationThread (ActivityThread thread) + { + Field field; + + try + { + field = ActivityThread.class.getDeclaredField ("mAppThread"); + field.setAccessible (true); + field.set (thread, null); + } + catch (NoSuchFieldException x) + { + x.printStackTrace (); + } + catch (IllegalAccessException x) + { + x.printStackTrace (); + } + } + + private static int + main1 (String[] argv) + throws NoSuchMethodException, IllegalAccessException, + InvocationTargetException + { + ActivityThread thread; + Context context; + + Looper.prepare (); + + thread = ActivityThread.systemMain (); + context = thread.getSystemContext (); + if (argv.length < 1 || argv[0].equals ("--help")) + { + System.out.println ("AtsStub [start] [--user ] "); + System.out.println (" where INTENT is a series of arguments defining an Intent,"); + System.out.println (" namely,"); + System.out.println (" -a "); + System.out.println (" -d "); + System.out.println (" -t "); + System.out.println (" -c "); + System.out.println (" -n "); + System.out.println (" -e or --es "); + System.out.println (" --esn "); + System.out.println (" --ei "); + System.out.println (" --eu "); + System.out.println (" --ecn "); + System.out.println (" --eia , ..."); + System.out.println (" --el "); + System.out.println (" --ela , ..."); + System.out.println (" --ef "); + System.out.println (" --efa "); + System.out.println (" --esa , ..."); + System.out.println (" --ez "); + System.out.println (" -f "); + return 0; + } + else if (argv[0].equals ("start")) + { + Intent intent; + int i, userID = 0; + String token, type; + Uri data; + boolean debug; + + intent = new Intent (); + debug = false; + data = null; + type = null; + + for (i = 1; i < argv.length; ++i) + { + int j; + + token = argv[i]; + + if (token.equals ("-a")) + intent.setAction (argv[++i]); + else if (token.equals ("-d")) + data = Uri.parse (argv[++i]); + else if (token.equals ("-t")) + type = argv[++i]; + else if (token.equals ("-c")) + intent.addCategory (argv[++i]); + else if (token.equals ("-e") || token.equals ("--es")) + { + intent.putExtra (argv[i + 1], argv[i + 2]); + i += 2; + } + else if (token.equals ("--esn")) + intent.putExtra (argv[++i], (String) null); + else if (token.equals ("--ei")) + { + int value = Integer.valueOf (argv[i + 2]); + intent.putExtra (argv[i + 1], value); + i += 2; + } + else if (token.equals ("--eu")) + { + Uri value = Uri.parse (argv[i + 2]); + intent.putExtra (argv[i + 1], value); + i += 2; + } + else if (token.equals ("--ecn")) + { + ComponentName value + = ComponentName.unflattenFromString (argv[i + 2]); + intent.putExtra (argv[i + 1], value); + i += 2; + } + else if (token.equals ("--eia")) + { + String values[] = argv[i + 2].split (","); + int array[] = new int[values.length]; + + for (j = 0; j < values.length; ++j) + array[j] = Integer.valueOf (values[j]); + intent.putExtra (argv[i + 1], array); + i += 2; + } + else if (token.equals ("--el")) + { + long value = Long.valueOf (argv[i + 2]); + intent.putExtra (argv[i + 1], value); + i += 2; + } + else if (token.equals ("--ela")) + { + String values[] = argv[i + 2].split (","); + long array[] = new long[values.length]; + + for (j = 0; j < values.length; ++j) + array[j] = Long.valueOf (values[j]); + intent.putExtra (argv[i + 1], array); + i += 2; + } + else if (token.equals ("--ef")) + { + float value = Float.valueOf (argv[i + 2]); + intent.putExtra (argv[i + 1], value); + i += 2; + } + else if (token.equals ("--efa")) + { + String values[] = argv[i + 2].split (","); + float array[] = new float[values.length]; + + for (j = 0; j < values.length; ++j) + array[j] = Float.valueOf (values[j]); + intent.putExtra (argv[i + 1], array); + i += 2; + } + else if (token.equals ("--esa")) + { + String[] strings; + + strings = argv[i + 2].split ("(? ./core-dex2jar.jar + dex2jar framework.jar -> ./framework-dex2jar.jar + $ javac AtsStub.java -source 1.6 -classpath "core-dex2jar.jar:framework-dex2jar.jar" + $ d8 AtsStub.class && zip stub.zip classes.dex + + +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 . diff --git a/test/infra/android/test-controller.el b/test/infra/android/test-controller.el new file mode 100644 index 00000000000..e82b05d036f --- /dev/null +++ b/test/infra/android/test-controller.el @@ -0,0 +1,1936 @@ +;;; Submit code to a connected Android device -*- lexical-binding: t; -*- + +;; Copyright (C) 2025 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: +;; +;; This file establishes connections to devices attached over `adb' and +;; arranges to execute the test driver and submit code to the same. + +;;; Code: + +(require 'tramp) ;; Only for a number of regexps. + + + +;; Device management. + +(defvar ats-adb-executable nil + "Name of the `adb' executable on this system, or nil if uninitialized.") + +(defvar ats-adb-host nil + "Hostname and port on which the ADB server resides. +If nil, this value defaults to localhost and an ADB server will +automatically be started if none is currently executing.") + +(defvar ats-adb-infile nil + "File providing the stdin of `adb' subprocesses.") + +(defvar ats-cache nil + "Cache recording facts predicated of a device and its contents.") + +(defvar ats-adb-disable-stderr t + "Whether not to print error output from subprocesses invoked by `ats-adb'.") + +(defconst ats-adb-device-regexp + "\\([^[:space:]]+\\)[[:space:]]+\\([[:alnum:]]+\\)$" + "Regexp with which to extract devices from `adb devices' output.") + +(defun ats-adb (&rest commands) + "Execute `adb COMMANDS' and insert its output into the current buffer. +Command output is inserted before point." + (unless ats-adb-executable + (setq ats-adb-executable + (or (executable-find "adb") + (progn + (message "Could not locate a suitable `adb' binary. +Please arrange that a version of the Android debugging bridge be present +in `exec-path' and be permitted to access connected USB devices. +For more information, visit https://developer.android.com/tools/adb.") + (error "Could not locate a suitable `adb' binary"))))) + (let ((point (point)) (coding-system-for-read 'utf-8-unix)) + (save-excursion + (when ats-adb-host + (setq commands (append (list "-H" ats-adb-host) commands))) + (let ((rc (apply #'call-process ats-adb-executable + ats-adb-infile + (or (and ats-adb-disable-stderr '(t nil)) t) + nil commands))) + (when (not (zerop rc)) + (error "%s exited with %s" + (mapconcat #'shell-quote-argument + (cons ats-adb-executable commands) + " ") + rc)) + ;; Undo misguided EOL format conversion performed by the ADB + ;; daemon on older releases of Android. + (let ((end (point))) + (goto-char point) + (while (re-search-forward "\r+$" end t) + (replace-match ""))))))) + +(defun ats-adb-process-filter (proc string) + "Insert STRING and update PROC's mark as the default filter does. +Remove all CR characters preceding newlines in STRING." + (when (buffer-live-p (process-buffer proc)) + (with-current-buffer (process-buffer proc) + (let ((new-string (replace-regexp-in-string "\r$" "" string))) + (save-excursion + (goto-char (process-mark proc)) + (insert new-string) + (set-marker (process-mark proc) (point))))))) + +(defun ats-start-adb (&rest commands) + "Execute `adb COMMANDS' in an asynchronous subprocess. +Apply a process filter to delete errant carriage return +characters." + (unless ats-adb-executable + (setq ats-adb-executable + (or (executable-find "adb") + (progn + (message "Could not locate a suitable `adb' binary. +Please arrange that a version of the Android debugging bridge be present +in `exec-path' and be permitted to access connected USB devices. +For more information, visit https://developer.android.com/tools/adb.") + (error "Could not locate a suitable `adb' binary"))))) + (let ((coding-system-for-read 'utf-8-unix)) + (save-excursion + (when ats-adb-host + (setq commands (append (list "-H" ats-adb-host) commands))) + (let ((process (apply #'start-process " *ats adb*" + " *ats adb*" + ats-adb-executable commands))) + (prog1 process + (set-process-filter process #'ats-adb-process-filter)))))) + +(defun ats-enumerate-devices (&optional pred arg) + "Return a list of connected devices as an alist indiced by serial number. +Value is an alist of device serial numbers that may be provided +as the `-s' argument to `adb' and the state of the device, which +is a string that is either \"device\" for a fully available +device, or another value if the connection to the device is +defective. + +If PRED is specified, invoke it on each device with ARG and its +serial number and state, and only return devices for which it +returns non-nil." + (with-temp-buffer + (ats-adb "devices") + (re-search-forward "List of devices attached\n" nil t) + (let ((devices nil)) + (while (re-search-forward ats-adb-device-regexp + nil t nil) + (let ((name (match-string 1)) + (state (match-string 2))) + (when (or (not pred) (funcall pred name state arg)) + (push (cons name state) devices)))) + (nreverse devices)))) + +(defun ats-online-devices () + "Like `ats-enumerate-devices', but only return devices which are available." + (ats-enumerate-devices (lambda (_ state _) + (equal state "device")))) + + + +;; Device introspection. + +(defmacro ats-memoize (device key &rest bodyforms) + "Return the result of executing BODYFORMS with memoization. +Cache such result and avoid executing BODYFORMS more than once +with the same DEVICE and KEY." + (declare (indent 2)) + (let ((device-key (gensym)) + (cache (gensym)) + (value (gensym))) + `(let* ((,device-key (concat (or ats-adb-host "localhost") + "/" ,device)) + (,cache (or (cdr-safe (assoc ,device-key ats-cache)) + (setf (alist-get ,device-key ats-cache + :testfn #'equal) + (make-hash-table :test #'equal)))) + (,value (gethash ,key ,cache))) + (if ,value (car ,value) + (setq ,value (progn ,@bodyforms)) + (prog1 ,value + (puthash ,key (list ,value) ,cache)))))) + +(defun ats-ps-device (device &optional predicate arg) + "Return a list of running processes on DEVICE. +Return a list each of whose elements is an alist between the names +of columns returned by `ps' and their values. +If PREDICATE is non-nil, accept only those processes for which +it returns true, with ARG provided as a second argument." + (with-temp-buffer + (ats-adb "-s" device "shell" "ps") + ;; Examples: + ;; USER PID PPID VSIZE RSS WCHAN PC NAME + ;; USER PID PPID VSZ RSS WCHAN ADDR S NAME + (end-of-line) + (let* ((substr (buffer-substring (point-min) (point))) + (legend (mapcar #'intern + (string-split substr "[ \t]" + t "[[:space:]]"))) + (state-present (memq 'S legend)) + (last (car (last legend))) + (processes nil) + process) + (while (re-search-forward "[[:alnum:]]" nil t) + (backward-char) + (setq process nil) + (dolist (column legend) + (let ((beg (point))) + (re-search-forward (if (eq column last) + "[[:space:]]*$" + "\\([[:space:]]+\\|$\\)")) + ;; The `S' column is on certain older systems not listed in + ;; the legend but printed anyway before NAME. + (when (and (not state-present) (eq column 'NAME)) + (save-excursion + (goto-char beg) + (save-match-data + (when (re-search-forward "\\([RSDZTtWXxKWPI]\\) " nil t) + (setq beg (point)) + (push (cons 'S (match-string 1)) process))))) + (push (cons column (buffer-substring beg (match-beginning 0))) + process))) + (when (or (not predicate) (funcall predicate process arg)) + (push (nreverse process) processes))) + (nreverse processes)))) + +(defun ats-getprop (device prop) + "Return the value of the system property PROP on DEVICE. +Among such properties are: + + - `ro.build.version.sdk': The version of Android present on + the device." + (ats-memoize device (concat "ats-getprop/" prop) + (with-temp-buffer + (ats-adb "-s" device "shell" "getprop" prop) + (goto-char (point-max)) + (when (eq (char-before) ?\n) + (delete-char -1)) + (buffer-string)))) + +(defun ats-get-sdk-version (device) + "Return the version of Android installed on DEVICE." + (or (string-to-number (ats-getprop device "ro.build.version.sdk")) 0)) + +(defconst ats-package-list-regexp + "^\\([[:alnum:]\\.]+\\) \\([[:digit:]]+\\) \\([[:digit:]]\\).*/.*$" + "Regexp with which to validate the format of packages.list.") + +(defun ats-is-package-debuggable (device pkg) + "Return whether the package identified by PKG is debuggable on DEVICE." + (ats-memoize device (concat "ats-is-package-debuggable/" pkg) + (with-temp-buffer + (if (ignore-errors + (ats-adb "-s" device "shell" "cat" "/data/system/packages.list") + (re-search-forward ats-package-list-regexp nil nil)) + ;; packages.list is readable. Search for an entry matching + ;; PKG. + (progn + (goto-char (point-min)) + (unless (re-search-forward (rx bol + (literal pkg) + " " + ;; UID of package. + (group (+ (or alnum "."))) + " " + ;; Package debuggability. + (group (or "0" "1")) + ;; Package home directory. + (+ nonl) + "/" + (+ nonl) + eol) + nil t) + (error "No package on device: %s" pkg)) + (equal (match-string 2) "1")) + ;; If packages.list is unreadable (as when adbd is not executing + ;; as root on recent OS releases), call run-as to establish + ;; whether this package is debuggable. + (ignore-errors + (ats-adb "-s" device "shell" "run-as" pkg "echo" "emacs_token")) + (when (re-search-forward "run-as:" nil t) + ;; Was an error message printed? Does it indicate that the + ;; package is not present? + (when (re-search-forward "unknown" nil t) + (error "No package on device: %s" pkg)) + nil) + (goto-char (point-min)) + (re-search-forward "emacs_token" nil t))))) + +(defun ats-list-users (device) + "Return a list of user IDs present on DEVICE. +Each element of the list produced is a list of the form: + + (ID NAME EXTERNAL-STORAGE-DIRECTORY)" + (if (< (ats-get-sdk-version device) 17) + '((0 "Android user" "/sdcard")) + (ats-memoize device "ats-list-users" + (let ((users nil)) + (with-temp-buffer + (ats-adb "-s" device "shell" "pm" "list" "users") + (while (re-search-forward + "^\tUserInfo{\\([[:digit:]]+\\):\\(.*?\\):.*$" nil t) + (push (list (string-to-number (match-string 1)) + (match-string 2) + (if (equal (match-string 1) "0") + (or (ignore-errors + (ats-verify-directory + device "/storage/emulated/0")) + "/sdcard") + (or (ignore-errors + (ats-verify-directory + device + (format "/mnt/shell/emulated/%s" (match-string 1)))) + (format "/storage/emulated/%s" (match-string 1))))) + users))) + (sort users :lessp (lambda (a b) + (< (car a) (car b))) + :in-place t))))) + +(defun ats-get-package-aid (device package) + "Return the base AID of the provided PACKAGE on DEVICE. +This value may be treated as-is as the UID of PACKAGE running as +the default Android user, or provided to `ats-get-package-uid' +to derive the UID assigned to instances of it that are executing +as another user." + (ats-memoize device (concat "ats-get-package-aid/" package) + (with-temp-buffer + (ats-adb "-s" device "shell" "dumpsys" "package" package) + (re-search-forward (rx bol (+ space) + "Package [" (literal package) "]" + (+ nonl) ":" eol)) + (re-search-forward "\\(userId\\|appId\\)=\\([[:digit:]]+\\)") + (string-to-number (match-string 2))))) + +;; Ref: +;; https://android.googlesource.com/platform/system/core/+/master/libcutils/include/private/android_filesystem_config.h +;; https://android.googlesource.com/platform/system/core/+/master/libcutils/multiuser.cpp + +(defconst ats-aid-user-offset 100000 + "Value of `AID_USER_OFFSET' in `android_filesystem_config.h'.") +(defconst ats-aid-isolated-start 90000 + "Value of `AID_ISOLATED_START' in `android_filesystem_config.h'.") +(defconst ats-aid-app-start 10000 + "Value of `AID_APP_START' in `android_filesystem_config.h'.") + +(defun ats-aid-to-uid (aid user) + "Derive a UID from an application ID and a user ID. +Return the UID that will be assigned to instances of that +application which is identified by AID when executing as the +Android user USER. AID should be a value returned by +`ats-get-package-uid', which see." + (+ (% aid ats-aid-user-offset) (* user ats-aid-user-offset))) + +;; Ref: +;; https://android.googlesource.com/platform/bionic/+/master/libc/bionic/grp_pwd.cpp + +(defun ats-uid-to-username (device uid) + "Return the name of an application user UID on DEVICE. +Signal if UID is not a valid application user ID." + (let ((appid (% uid ats-aid-user-offset)) + (userid (/ uid ats-aid-user-offset))) + (if (>= (ats-get-sdk-version device) 16) + ;; "New style" IDs with isolated environments. + (cond + ((>= appid ats-aid-isolated-start) + (format "u%d_i%d" userid (- appid ats-aid-isolated-start))) + ((>= appid ats-aid-app-start) + (format "u%d_a%d" userid (- appid ats-aid-app-start))) + (t + (error "UID is not representable: %d" uid))) + (cond + ;; Old style IDs. + ((>= appid ats-aid-app-start) + (format "app_%d" (- appid ats-aid-app-start))) + (t + (error "UID is not representable: %d" uid)))))) + +(defun ats-verify-directory (device dir) + "Verify whether DIR exists on DEVICE, and signal if not. +Value is DIR otherwise." + (with-temp-buffer + (ignore-errors + (ats-adb "-s" device "shell" "test" "-d" dir "&&" "echo" "ATS_OK")) + ;; There are Android systems where `test' is neither installed to + ;; /system/bin nor available as a shell builtin. On these systems, + ;; this command prints an error message and exits. + (prog1 dir + (if (looking-at ".*\\btest\\b.*$") + ;; Call `mkdir' and test whether it reports that the directory + ;; already exists. + (progn + (erase-buffer) + (ignore-errors + (ats-adb "-s" device "shell" "mkdir" dir "||" "echo" "ATS_EXISTS")) + (goto-char (point-max)) + (forward-line -1) + (unless (and (looking-at "ATS_EXISTS$") + (progn + (goto-char (point-min)) + ;; Skip any instance of `dir' in the error + ;; message. + (search-forward dir nil t) + (looking-at ".*File exists.*"))) + (error "Directory `%s' does not appear to exist" dir))) + (goto-char (point-max)) + (forward-line -1) + (unless (looking-at "ATS_OK$") + (error "Directory `%s' does not exist" dir)))))) + +(defun ats-get-package-data-directory (device package user) + "Return PACKAGE's data directory on DEVICE. +Return PACKAGE's data directory when executing as that user +which is identified by the user ID USER." + (ats-memoize device (concat "ats-get-package-data-directory/" + package "/" (number-to-string user)) + (with-temp-buffer + (ats-adb "-s" device "shell" "dumpsys" "package" package) + (re-search-forward (rx bol (+ space) + "Package [" (literal package) "]" + (+ nonl) ":" eol)) + (if (eq user 0) + (progn + (or (save-excursion + ;; Attempt to parse a dataDir= specification under a + ;; User: heading. This line may be absent or not fall + ;; under this heading on older Android systems. + (when (and (re-search-forward "^[[:space:]]+User 0: " nil t) + (re-search-forward "dataDir=\\(/.*$\\)" nil t)) + (match-string 1))) + ;; Resort to any dataDir= specification, as this is user + ;; 0. + (and (re-search-forward "dataDir=\\(/.*$\\)" nil t) + (match-string 1)) + ;; Signal failure. + (error "Could not extract data directory of package `%s'" package))) + ;; Attempt to extract a dataDir= specification printed under a + ;; User heading. + (or (save-excursion + (when (and (re-search-forward (format "^[[:space:]]+User %d: " + user) + nil t) + (re-search-forward "dataDir=\\(/.*$\\)" nil t)) + (match-string 1))) + ;; If this fails (as on Android systems where "dumpsys + ;; package" has not yet been revised to print user-specific + ;; data directories), return "/data/user/%d/%s", but verify + ;; that it exists. + (ats-verify-directory device (format "/data/user/%d/%s" + user package))))))) + +(defun ats-get-user-external-storage-directory (device user) + "Return the external storage directory visible to USER on DEVICE." + (caddr (assq user (ats-list-users device)))) + +(defvar ats-transfer-padding (make-string 300 ?\n) + "Padding delivered before attempting to transfer shell scripts.") + +(defun ats-exec-script (device script &optional package user) + "Execute SCRIPT on DEVICE and return its exit code. +Insert its output into the current buffer in the manner of +`ats-adb'. If PACKAGE and USER are specified, run this script +as PACKAGE, provided that it is debuggable." + (save-restriction + (narrow-to-region (point) (point)) + (let* ((name (format "%s.sh" (make-temp-name "ats-"))) + (fullname (concat (file-name-as-directory "/tmp") name))) + (with-temp-buffer + (insert script) + (write-region (point-min) (point-max) fullname)) + (unwind-protect + (let ((targetname (format "/data/local/tmp/%s" name))) + (with-temp-buffer + (ats-adb "-s" device "push" fullname targetname)) + (if (not package) + (progn + (ats-adb "-s" device "shell" "sh" "-c" + (shell-quote-argument + (let ((arg (shell-quote-argument targetname t))) + (format + "sh %s; echo ats_exit: $?; (rm %s &> /dev/null)" + arg arg)) + t))) + ;; targetname names a script that will reconstruct SCRIPT + ;; in the `files' subdirectory of the current working + ;; directory. + ;; + ;; It is not possible reliably to transfer data through + ;; `adb shell', as the device may allocate a + ;; pseudoterminal, which imposes restrictions on both line + ;; length and transfer size, and to compensate, this + ;; script is first transferred to /data/local/tmp, and + ;; piped into run-as on-device in a single concise + ;; command. + (unless (ats-is-package-debuggable device package) + (error "Package is not debuggable: `%s'" package)) + (let* ((pkgname (format "files/%s" name)) + (src (shell-quote-argument targetname t)) + (arg (shell-quote-argument pkgname t)) + (version (ats-get-sdk-version device))) + (if (eq user 0) + (progn + (ats-adb + "-s" device "shell" "sh" + "-c" (shell-quote-argument + (format "run-as %s sh -c %s < %s" + package + (shell-quote-argument + (format "cat > %s" arg) t) + src) + t)) + (ats-adb + "-s" device "shell" "run-as" package "sh" + "-c" + (shell-quote-argument + (format + "sh %s; echo ats_exit: $?; (rm %s &> /dev/null)" + arg arg) + t))) + (if (< version 23) + (error (concat "Cannot execute script as package and" + "non-default user on Android <= 5.1.")) + (progn + (ats-adb + "-s" device "shell" "sh" + "-c" (shell-quote-argument + (format "run-as %s --user %d sh -c %s < %s" + package + user + (shell-quote-argument + (format "cat > %s" arg) t) + src) + t)) + (ats-adb + "-s" device "shell" "run-as" package + "--user" (number-to-string user) + "sh" "-c" + (shell-quote-argument + (format + "sh %s; echo ats_exit: $?; (rm %s &> /dev/null)" + arg arg) + t)))))))) + (with-demoted-errors "Deleting temporary script: %S" + (delete-file fullname)))) + (goto-char (point-max)) + (re-search-backward "ats_exit: \\([[:digit:]]+\\)$") + (prog1 (string-to-number (match-string 1)) + (delete-region (point) (point-max))))) + +(defsubst ats-exec-script-checked (device script &optional package user) + "Execute SCRIPT on DEVICE as PACKAGE and USER, as with `ats-exec-script'. +But signal an error if its exit code is non-zero." + (let ((rc (ats-exec-script device script package user))) + (when (/= rc 0) + (error "Script exited with return code %d:\n%s" rc script)))) + +(defun ats-use-private-staging-directory (device package user) + "Return whether PACKAGE running as USER admits of a private staging directory. +DEVICE is the device to which the test pertains. + +A private staging directory is a staging directory within +PACKAGE's application data directory, enabling packages to be +debugged without holding external storage permissions." + (and (or (eq user 0) + ;; `run-as --user' requires Android 6.0 or better. + (>= (ats-get-sdk-version device) 23)) + (ats-is-package-debuggable device package))) + +(defun ats-get-staging-directory (device package user) + "Create and return a staging directory for communication with PACKAGE. +Create and return a directory which is accessible both to this +instance of Emacs and to PACKAGE executing on DEVICE as USER." + ;; Prefer invoking `run-as' to transfer files into a local directory. + (ats-memoize device (concat "ats-get-staging-directory/" + package "/" (number-to-string user)) + (if (ats-use-private-staging-directory device package user) + (progn + (with-temp-buffer + ;; The return value of mkdir is not tested and neither is + ;; any attempt made to supply such flags as `-p', as no + ;; flags to `mkdir' can be relied upon on Android. + (ats-exec-script device "mkdir files/ats-staging" + package user) + (erase-buffer) + (ats-exec-script-checked device "cd files/ats-staging && pwd" + package user) + (when (eq (char-before) ?\n) + (delete-char -1)) + (buffer-string))) + ;; Locate the external storage directory visible to USER. + (let* ((external-storage (ats-get-user-external-storage-directory + device user)) + (subdirectory (format "%s/ats-staging" external-storage))) + (with-temp-buffer + (ats-exec-script device (format "mkdir %s" subdirectory)) + (erase-buffer) + (ats-exec-script-checked device + (format "cd %s && pwd" + (shell-quote-argument + subdirectory t))) + (when (eq (char-before) ?\n) + (delete-char -1)) + (buffer-string)))))) + +(defun ats-base64-available (device) + "Return whether a `base64' binary is available on DEVICE." + (ats-memoize device "ats-base64-available" + (with-temp-buffer + (ats-exec-script + device + (format "export TMPDIR=/data/local/tmp\n +base64 -d <<'_ATS_BASE64_EOF'\n%s\n_ATS_BASE64_EOF" + (base64-encode-string "Emacs_Hello"))) + (equal (buffer-string) "Emacs_Hello")))) + +(defun ats-echo-n-e (device) + "Return whether `echo -n -e' is understood by DEVICE." + (ats-memoize device "ats-proper-echo-flags" + (with-temp-buffer + ;; The Almquist shell distributed with old Android releases treats + ;; flags subsequent to the first as additional strings to be + ;; printed. + (ats-exec-script device "echo -n -e '\\077'") + (equal (buffer-string) "?")))) + +(defun ats-echo-c (device) + "Return whether \"echo -e '...\\c'\" is understood by DEVICE." + (ats-memoize device "ats-almquist-echo-flags" + (with-temp-buffer + (ats-exec-script device "echo -e '\\077\\c'") + (equal (buffer-string) "?")))) + +(defvar ats-octab (make-vector 256 0) + "Vector of numbers between 0 and 255 and their octal representations.") +(dotimes (c 256) + (aset ats-octab c (format "\\0%o" c))) + +(defun ats-upload-encode-binary (device file quoted) + "Generate an script that will echo the contents of FILE into QUOTED. +QUOTED must have been processed by `shell-quote-argument'. +The script will be suitable for execution on DEVICE." + ;; We would prefer to use uuencode rather than echo, but it appears + ;; even scarcer than base64. + (cond ((ats-base64-available device) + (with-temp-buffer + (set-buffer-multibyte nil) + (let ((coding-system-for-read 'no-conversion)) + (insert-file-contents file)) + (let ((encoded (base64-encode-string (buffer-string) nil))) + (erase-buffer) + (insert encoded) + (goto-char (point-min)) + (insert "export TMPDIR=`pwd`\n" + "base64 -d <<_ATS_UPLOAD_EOF >" + quoted "\n") + (goto-char (point-max)) + (insert "\n_ATS_UPLOAD_EOF\n")) + (buffer-string))) + ((or (ats-echo-n-e device) + (ats-echo-c device)) + (let* ((is-echo-c (not (ats-echo-n-e device))) + (echo-prefix (if is-echo-c "echo -e '" "echo -n -e '")) + (echo-suffix (if is-echo-c "\\c'\n" "'\n")) + (ats-upload-script + (shell-quote-argument + (concat (make-temp-name "ats-upload-") ".sh") t))) + (with-temp-buffer + (set-buffer-multibyte nil) + (let ((coding-system-for-read 'no-conversion)) + (insert-file-contents file)) + (with-output-to-string + (princ "export TMPDIR=`pwd`; cat <<_ATS_UPLOAD_EOF >") + (princ ats-upload-script) + (terpri) + (let ((point (point)) + (point-max (point-max))) + (while (< point point-max) + (princ echo-prefix) + (let ((i (min 128 (- point-max point)))) + (dotimes (idx i) + (princ (aref ats-octab (char-after (+ point idx))))) + (setq point (goto-char (+ point i)))) + (princ echo-suffix))) + (princ "_ATS_UPLOAD_EOF\nsh ") + (princ ats-upload-script) + (princ (concat " > " quoted " && rm " ats-upload-script)))))) + (t (error "Cannot decide by what means to encode a binary file")))) + +(defun ats-upload (device file package user) + "Upload FILE to PACKAGE's staging directory on DEVICE. +Value is the file name on the device. USER is the numerical ID +of the Android user as which PACKAGE will execute." + (setq file (expand-file-name file)) + (let ((staging-dir (ats-get-staging-directory device package user))) + (if (ats-use-private-staging-directory device package user) + ;; Upload by way of `run-as'. + (let ((dst-file (concat staging-dir "/" + (file-name-nondirectory file)))) + (with-temp-buffer + (ats-exec-script-checked + device + (let ((quoted (shell-quote-argument dst-file t))) + (ats-upload-encode-binary device file quoted)) + package user)) + dst-file) + (let ((dest-file-name + (concat staging-dir "/" (file-name-nondirectory file)))) + (with-temp-buffer + (ats-adb "-s" device "push" file dest-file-name)) + dest-file-name)))) + +(defun ats-download (device file package user) + "Download FILE from PACKAGE's staging directory on DEVICE. +FILE's contents should be UTF-8 text with Unix line endings. +Insert its contents at point in the current buffer. PACKAGE and +USER are as in `ats-upload'." + (let* ((dir-private-p + (ats-use-private-staging-directory device package user)) + (exec-package (and dir-private-p package)) + (exec-user (and dir-private-p user))) + (insert (with-temp-buffer + ;; It is not reliable to cat binary data through adb, nor + ;; possible to copy binary data as a package user to a + ;; location where the `adb shell' user may access it, or + ;; to transfer binary data over a `run-as' connection... + (ats-exec-script-checked device + (format "cat %s/%s" + (shell-quote-argument + (ats-get-staging-directory + device package user) + t) + (shell-quote-argument file t)) + exec-package exec-user) + (buffer-string))))) + +(defun ats-create-empty-temporary (device name package user) + "Create an empty temporary file NAME in PACKAGE's staging directory. +DEVICE is the device where this temporary file is to be created. +USER is the user as which PACKAGE is expected to execute, and +value is the name of the said file." + (let* ((staging-dir (ats-get-staging-directory device package user)) + (name (concat staging-dir "/" name))) + (unless (ats-use-private-staging-directory device package user) + (setq package nil user nil)) + (with-temp-buffer + (ats-exec-script-checked device + (format "cat %s" + (shell-quote-argument name t)) + package user)) + name)) + +(defun ats-run-jar (device jar class &rest params) + "Upload and execute the Dalvik archive JAR on DEVICE. +CLASS must be the name of the archive file's main class. Value +is the exit code of the `app_process' process, and its output is +inserted in the manner of `ats-exec-script'." + (let* ((jar (expand-file-name jar)) + (name (file-name-nondirectory jar)) + (tempname (concat "/data/local/tmp/" name))) + (with-temp-buffer + (ats-adb "-s" device "push" jar tempname)) + (ats-exec-script device (concat + "export ANDROID_DATA=/data/local/tmp;\n" + ;; `dalvik-cache' must be a writable + ;; directory in which dalvikvm is + ;; able to store optimized dex code. + "mkdir /data/local/tmp/dalvik-cache" + " &> /dev/null\n" + "app_process -Djava.class.path=" + (shell-quote-argument tempname t) + " /data/local/tmp " + (shell-quote-argument class t) + " " + (mapconcat (lambda (arg) + (shell-quote-argument arg t)) + params " "))))) + +(defun ats-supports-am-force-stop (device) + "Return whether DEVICE supports the command `am force-stop'." + (ats-memoize device "ats-supports-am-force-stop" + (with-temp-buffer + (ignore-errors + (ats-adb "-s" device "shell" "am")) + (not (null (re-search-forward "\\bforce-stop\\b" nil t)))))) + +(defun ats-supports-am-force-stop-user (device) + "Return whether DEVICE supports the command `am force-stop --user'." + (ats-memoize device "ats-supports-am-force-stop-user" + (with-temp-buffer + (ignore-errors + (ats-adb "-s" device "shell" "am")) + (not (null (re-search-forward + "^.*\\bforce-stop\\b[^[:alnum:]]+--user.*$" + nil t)))))) + +(defun ats-kill-process-by-username-and-name (device username name + &optional pkgname user) + "Kill any process with NAME running with the username USERNAME. +If PKGNAME is a debuggable package, do so as that package's user +and as the Android user USER. DEVICE is the device on which to +operate." + (let ((any-killed nil)) + (with-temp-buffer + (dolist (proc (ats-ps-device device + (lambda (item _) + (and (equal (cdr (assq 'NAME item)) + name) + (equal (cdr (assq 'USER item)) + username))))) + (let* ((debuggable (and pkgname + (ats-is-package-debuggable device pkgname))) + (run-as (and debuggable pkgname)) + (user (and debuggable user)) + (rc (ats-exec-script device (format "kill -9 %s" + (cdr (assq 'PID proc))) + run-as user))) + (unless (eq rc 0) + (error "Could not terminate an existing instance of `%s' (PID %s). +Please attempt to terminate this package by hand (as from the +App Info Settings page) before invoking this command" + name (assq 'PID proc))) + (setq any-killed t)))) + any-killed)) + +(defconst ats-portforward-local-type-regexp + (concat "\\(tcp\\|localabstract\\|localreserved\\|localfilesystem" + "\\|dev\\)") + "Regexp matching valid ADB port forwarding types.") + +(defconst ats-portforward-remote-type-regexp + (concat "\\(tcp\\|localabstract\\|localreserved\\|localfilesystem" + "\\|dev\\|jdwp\\|vsock\\|acceptfd\\)") + "Regexp matching valid ADB port forwarding types.") + +(defconst ats-portforward-list-regexp (concat + "^" + ;; Type & whitespace. + "\\(.*\\)[[:space:]]+" + ;; Local port type and name. + ats-portforward-local-type-regexp ":" + "\\(.*\\)[[:space:]]" + ;; Local port type and name. + ats-portforward-remote-type-regexp ":" + "\\(.*\\)$") + "Regexp with which to parse port forwarding lists printed by ADB.") + +(defconst ats-portreverse-type-regexp + "\\(tcp\\|localabstract\\|localreserved\\|localfilesystem\\)" + "Regexp matching valid ADB port forwarding types.") + +(defconst ats-portreverse-list-regexp (concat + "^" + ;; Type & whitespace. + "\\(.*\\)[[:space:]]+" + ;; Remote port type and name. + ats-portreverse-type-regexp ":" + "\\(.*\\)[[:space:]]" + ;; Local port type and name. + ats-portreverse-type-regexp ":" + "\\(.*\\)$") + "Regexp with which to parse port forwarding lists printed by ADB.") + +(defun ats-reverse-list (device) + "List connections being reverse-proxied from DEVICE. +Value is a list each of whose elements partakes of the form: + + (TYPE REMOTE-PROTO REMOTE-PORT LOCAL-PROTO LOCAL-PORT)" + (let ((regexp ats-portreverse-list-regexp) + (connections nil)) + (with-temp-buffer + (ats-adb "-s" device "reverse" "--list") + (while (re-search-forward regexp nil t) + (push (list (match-string 1) (match-string 2) + (match-string 3) (match-string 4) + (match-string 5)) + connections))) + (nreverse connections))) + +(defun ats-reverse-tcp (device local port) + "Proxy to the local TCP port LOCAL from PORT on DEVICE. +If PORT is 0, select a suitable free port on DEVICE or that of +an existing forwarding session. Return PORT or the selected +port as the case may be. + +This is not supported by all versions of Android." + (when (and (eq port 0) (< (ats-get-sdk-version device) 26)) + (error "Automatic port selection is unavailable < Android 8.0")) + (or (let ((str (number-to-string local)) + (port-str (number-to-string port)) + (value nil)) + ;; Is the local port already being forwarded to PORT (or any + ;; port if that be zero)? + (dolist (conn (ats-reverse-list device) value) + (when (and (equal (nth 3 conn) "tcp") + (equal (nth 4 conn) str) + (equal (nth 1 conn) "tcp") + (or (eq port 0) + (equal (nth 2 conn) port-str))) + (setq value (string-to-number (nth 2 conn)))))) + (with-temp-buffer + (ats-adb "-s" device "reverse" (format "tcp:%d" port) + (format "tcp:%d" local)) + (let ((num (string-to-number (buffer-string)))) + (if (zerop num) + (if (and (not (eq port 0)) (eq (point-min) (point-max))) + port + (error "Failed to establish reverse proxy \ +to `localhost:%d' from `tcp:%d':\n%s" local port (buffer-string))) + num))))) + +(defun ats-forward-list (device) + "List connections being proxied to DEVICE. +Value is a list each of whose elements partakes of the form: + + (DEVICE LOCAL-PROTO LOCAL-PORT REMOTE-PROTO REMOTE-PORT) + +DEVICE is only returned in the interests of consistency with +`ats-reverse-list'." + (let ((regexp ats-portforward-list-regexp) + (connections nil)) + (with-temp-buffer + (ats-adb "forward" "--list") + (while (re-search-forward regexp nil t) + (when (equal (match-string 1) device) + (push (list (match-string 1) (match-string 2) + (match-string 3) (match-string 4) + (match-string 5)) + connections)))) + (nreverse connections))) + +(defun ats-forward-tcp (device port local) + "Proxy to the remote TCP port PORT on DEVICE from LOCAL. +If LOCAL is 0, select a suitable local free port or that of an +existing forwarding session. Return LOCAL or the selected port +as the case may be." + (or (let ((str (number-to-string port)) + (local-str (number-to-string local)) + (value nil)) + ;; Is the local port already being forwarded? + (dolist (conn (ats-forward-list device) value) + (when (and (equal (nth 3 conn) "tcp") + (equal (nth 4 conn) str) + (equal (nth 1 conn) "tcp") + (or (eq local 0) + (equal (nth 2 conn) local-str))) + (setq value (string-to-number (nth 2 conn)))))) + (with-temp-buffer + (ats-adb "-s" device "forward" (format "tcp:%d" local) + (format "tcp:%d" port)) + (let ((num (string-to-number (buffer-string)))) + (if (zerop num) + (if (and (not (eq local 0)) (eq (point-min) (point-max))) + local + (error "Failed to establish proxy \ +from `localhost:%d' to `tcp:%d':\n%s" local port (buffer-string))) + num))))) + +(defun ats-is-tail-available (device) + "Return whether `tail is available on DEVICE and functional." + (ats-memoize device "ats-is-tail-available" + (with-temp-buffer + (when (eq (ats-exec-script device "tail < /dev/null\n") 0) + (erase-buffer) + ;; Now run `tail --help' and search for any lines indicating + ;; that `tail -f' is unimplemented, e.g.: + ;; usage: tail [-n|c NUMBER] [-f] [FILE...] + + ;; Copy last lines from files to stdout. If no files listed, copy from + ;; stdin. Filename "-" is a synonym for stdin. + + ;; -n output the last NUMBER lines (default 10), +X counts from start. + ;; -c output the last NUMBER bytes, +NUMBER counts from start + ;; #-f follow FILE(s), waiting for more data to be appended [TODO] + ;; + ;; This may fail if tail does not implement `--help'. + (ignore-errors + (ats-adb "-s" device "shell" "tail" "--help")) + (not (re-search-forward "^#?-f.*follow.+TODO.*$" nil t)))))) + + + +;; Component management. + +(defconst ats-java-int-min (- (expt 2 31)) + "Value of `Integer.MIN_VALUE' in Java.") + +(defconst ats-java-int-max (1- (expt 2 31)) + "Value of `Integer.MAX_VALUE' in Java.") + +(defconst ats-java-long-min (- (expt 2 63)) + "Value of `Long.MIN_VALUE' in Java.") + +(defconst ats-java-long-max (1- (expt 2 63)) + "Value of `Long.MAX_VALUE' in Java.") + +(defun ats-intent-array-type (element) + "Return the type of an Intent array from its first element ELEMENT." + (cond ((stringp element) "--esa") + ((integerp element) "--eia") + ((and (consp element) (eq (car element) 'long)) "--ela") + ((floatp element) "--efa") + (t (error "Invalid Intent array element: %s" element)))) + +(defun ats-fmt-array-element (atype element) + "Format an array ELEMENT appropriately for an array of type ATYPE." + (cond ((equal atype "--esa") + (if (stringp element) + (replace-regexp-in-string "," "\\\\," element) + (error "Array elements are not uniform of type"))) + ((equal atype "--eia") + (if (integerp element) + (progn + (if (or (< element ats-java-int-min) + (> element ats-java-int-max)) + (error "Integer not representable by Java `int': %d" + element) + (format "%d" element))) + (error "Array elements are not uniform of type"))) + ((equal atype "--ela") + (if (and (consp element) (eq (car element) 'long)) + (let ((element (cdr element))) + (if (or (< element ats-java-long-min) + (> element ats-java-long-max)) + (error "Integer not representable by Java `long': %d" + element) + (format "%d" element))) + (error "Array elements are not uniform of type"))) + ((equal atype "--efa") + (if (floatp element) + (format "%f" element) + (error "Array elements are not uniform of type"))))) + +(defun ats-build-intent (data) + "Construct an intent arg list from an alist DATA. +DATA's keys must either be one of the annexed keywords, or a +string property name. The value of each element with a string +key must be: + + - A string. + - A cons of the form `(uri . URI)', where URI is an Android URI. + - A fixnum or bignum, which is treated as an integer and + mustn't exceed the limits of Java's `int' type's + representation. + - A cons of the form `(long . LONG)', where LONG is a fixnum + or a bignum. + - A float. + - A boolean t or nil. + - A list of any single type of item listed above, excluding + `(uri . URI)' and booleans. + +That which follows is a list of keywords that may appear as keys +juxtaposed with the meaning of their values. + + :action ACTION + The action taken by this intent, e.g. `android.intent.action.VIEW'. + + :data URI + URI data to be attached to this intent. + + :type TYPE + The MIME type of this intent's data. + + :category CATEGORY + This intent's category, e.g. `android.intent.category.DEFAULT'. + + :component COMPONENT + This intent's target component, e.g. `org.gnu.emacs/.EmacsActivity'. + + :flags FLAGS + A fixnum or bignum specifying integer flags affecting the intent. + +Value is a list of command line arguments fit to be provided to +`am' commands, or to `AtsStub.class'." + (let ((directives nil)) + (dolist (element data) + (let ((key (car element))) + (cond + ((eq key :action) + (push "-a" directives) + (push (cdr element) directives)) + ((eq key :data) + (push "-d" directives) + (push (cdr element) directives)) + ((eq key :type) + (push "-t" directives) + (push (cdr element) directives)) + ((eq key :category) + (push "-c" directives) + (push (cdr element) directives)) + ((eq key :component) + (push "-n" directives) + (push (cdr element) directives)) + ((eq key :flags) + (push "-f" directives) + (push (format "%d" (cdr element)) directives)) + ((stringp key) + (let ((value (cdr element))) + (cond ((stringp value) + (push "-e" directives) + (push key directives) + (push value directives)) + ((and (consp value) (eq (car value) 'uri)) + (push "--eu" directives) + (push key directives) + (push (cdr value) directives)) + ((integerp value) + (when (or (< value ats-java-int-min) + (> value ats-java-int-max)) + (error "Integer not representable by Java `int': %d" + value)) + (push "--ei" directives) + (push key directives) + (push (format "%d" value) directives)) + ((and (consp value) (eq (car value) 'long)) + (when (or (< (cdr value) ats-java-long-min) + (> (cdr value) ats-java-long-max)) + (error "Integer not representable by Java `long': %d" + (cdr value))) + (push "--el" directives) + (push key directives) + (push (format "%d" (cdr value)) directives)) + ((floatp value) + (push "--ef" directives) + (push key directives) + (push (format "%f" value) directives)) + ((or (eq value t) (null value)) + (push "--ez" directives) + (push key directives) + (push (or (and value "true") "false") directives)) + ((listp value) + (let ((atype (ats-intent-array-type (car value)))) + (push atype directives) + (push key directives) + (push (mapconcat (lambda (element) + (ats-fmt-array-element atype element)) + value ",") + directives))) + (t (error "Invalid property value: %s" value))))) + (t (error "Invalid key: %s" key))))) + (nreverse directives))) + +(defvar ats-working-stub-file nil + "Name of a functioning AtsStub Java archive.") + +(defvar ats-file-directory) +(defun ats-am-start-intent (device user data) + "Start an activity identified by the Intent DATA on DEVICE. +DATA should be provided in such a format as `ats-build-intent' +accepts. +USER should identify the Android user for whom DATA will be +started." + (let ((args (ats-build-intent data))) + (when (not (eq user 0)) + (push (number-to-string user) args) + (push "--user" args)) + ;; If the device is running Android 5.0 or later, whose `am' command + ;; supports array parameter construction, simply invoke `am start'. + (if (>= (ats-get-sdk-version device) 21) + (with-temp-buffer + (ignore-errors + (let ((ats-adb-disable-stderr nil)) + (ats-adb "-s" device "shell" "sh" "-c" + (shell-quote-argument + (format "am start %s && echo ats_success" + (mapconcat (lambda (arg) + (shell-quote-argument arg t)) + args " ")) + t)))) + (goto-char (point-max)) + (unless (re-search-backward "^ats_success$" nil t) + (error "`am start' failed with the following output:\n%s" + (buffer-string)))) + ;; Otherwise, invoke a short Java stub class that invokes the + ;; ActivityManager. + (let ((stub-file (or ats-working-stub-file + (expand-file-name + (read-file-name "stub.zip file: " + (concat + (file-name-as-directory + ats-file-directory) + (file-name-as-directory "bin")) + "stub.zip" t nil + (lambda (filename) + (member + (file-name-extension filename) + '("zip" "jar" "dex")))))))) + (unless (file-regular-p stub-file) + (error "Invalid or nonexistent ActivityManager stub: %s" + stub-file)) + (with-temp-buffer + (unless (zerop (apply #'ats-run-jar device + stub-file "ats.AtsStub" + "start" args)) + (error "ActivityManager stub failed with the following output:\n%s" + (buffer-string)))) + ;; Save the stub file upon success. + (setq ats-working-stub-file stub-file)))) + nil) + +(defun ats-create-commfile (device package user) + "Create a file to which a remote program may write data. +DEVICE, PACKAGE, and USER, identify the device and environment +from which the file must be available, in the same sense as in +`ats-get-staging-directory'. + +The data written to the file must be exceedingly minuscule (just +adequate to enable a connection to be established between +controller and driver), and such a file ought to be provided to +`ats-watch-commfile', which see." + (let ((tempname (make-temp-name "ats-commfile-"))) + (ats-create-empty-temporary device tempname package user))) + +(defun ats-watch-commfile (device commfile package user) + "Poll the contents of COMMFILE as PACKAGE and as USER. +Return the contents of the first line written to the file and +delete the same once a newline is written. +DEVICE is the device where COMMFILE resides." + (unless (ats-use-private-staging-directory device package user) + (setq package nil user nil)) + (prog1 + (cond ((and (ats-is-tail-available device) + ;; `tail -f' is defective on Android <= 8.1. + (> (ats-get-sdk-version device) 28)) + ;; Excellent, tail -f exists. Collect process output into a + ;; buffer till the first newline is received. + (let* ((command-line (cond + ((eq user 0) + (list "-s" device "shell" + "run-as" package + "tail" "-f" "-c1300" commfile)) + (user + (list "-s" device "shell" + "run-as" package + "--user" (number-to-string user) + "tail" "-f" "-c1300" commfile)) + (t (list "-s" device "shell" + "tail" "-f" "-c1300" commfile)))) + (process (apply #'ats-start-adb command-line)) + (time (float-time)) + (data nil)) + (set-process-query-on-exit-flag process nil) + (with-current-buffer (process-buffer process) + (unwind-protect + (while (not data) + (when (accept-process-output process 1 nil) + (when (search-forward "\n" nil t) + (setq data (buffer-substring (point-min) + (1- (point)))))) + (when (not (eq (process-status process) 'run)) + (error "`adb' died unexpectedly...")) + (message + "Waiting for response from remote process... (%d s)" + (floor (- (float-time) time)))) + (kill-buffer))) + data)) + (t ;; Periodic polling must be resorted to instead. + (let ((value nil) + (command-line (cond + ((eq user 0) + (list "-s" device "shell" + "run-as" package + "cat" commfile)) + (user + (list "-s" device "shell" + "run-as" package + "--user" (number-to-string user) + "cat" commfile)) + (t (list "-s" device "shell" + "cat" commfile)))) + (time (float-time))) + ;; I would rather have exercised sticky broadcasts, but + ;; it's impossible to post them from Emacs Lisp on the + ;; driver's side... + (with-temp-buffer + (while (not value) + (sleep-for 1.0) + (message + "Waiting for response from remote process... (%d s)" + (floor (- (float-time) time))) + (erase-buffer) + ;; XXX: how ought errors reliably be separated from + ;; this command's ordinary output? + (apply #'ats-adb command-line) + (when (search-forward "\n" nil t) + (setq value (buffer-substring (point-min) + (1- (point)))))) + value)))) + (with-temp-buffer + (ats-exec-script-checked + device (format "rm %s" (shell-quote-argument commfile t)) + package user)))) + + + +;; Connection management. + +(defvar ats-file-directory (and load-file-name + (file-name-directory load-file-name)) + "Directory holding `test-controller.el'.") + +(defvar ats-server nil + "ATS server process or nil if yet unavailable.") + +(defvar ats-default-port 45419 + "Port on which ATS servers listen if auto selection is unavailable.") + +(defvar ats-accepting-connection nil + "UUID of connections being established.") + +(defun ats-address-to-hostname (address) + "Return the hostname component of the address ADDRESS." + (progn + (string-match "\\[?\\(.+?\\)\\]?\\(:[[:alnum:]]+\\)?$" address) + (match-string 1 address))) + +(defun ats-is-localhost-p (address) + "Return whether the hostname in ADDRESS identifies this machine or is nil." + (or (not address) + (let ((host (ats-address-to-hostname address))) + (let ((address-info (network-lookup-address-info host)) + (localhost-info (network-lookup-address-info "localhost"))) + (catch 'result + (dolist (addr address-info) + (dolist (addr-1 localhost-info) + (when (equal addr addr-1) + (throw 'result t))))))))) + +(defun ats-server-sentinel (process _) + "Sentinel function for ATS connections. +PROCESS is the connection at hand." + (when (process-get process 'ats-connection-details) + (ats-disconnect-internal process) + (kill-buffer (process-buffer process)))) + +(defun ats-server-log (_ connection _) + "Log function for `ats-server' processes. +If `ats-accepting-connection' is non-nil, read a string from +CONNECTION identifying the process, and, if in agreement with +the former variable, establish a connection and throw. +Otherwise, terminate the connection." + (if (not ats-accepting-connection) + (progn + (process-send-string connection "-not-accepting-connections\n") + (delete-process connection)) + (with-current-buffer (process-buffer connection) + (while connection + (let ((beg (point))) + (message "Device connected...") + (when (accept-process-output connection) + (goto-char beg) + (when (search-forward "\n" (process-mark connection) t) + (let ((uuid (buffer-substring (point-min) (1- (point))))) + (if (equal uuid ats-accepting-connection) + (progn + (process-send-string connection "-ok\n") + (delete-region (point-min) (point)) + (throw 'connection-established connection)) + (process-send-string connection + (concat "-incorrect-uuid " + uuid + " " + ats-accepting-connection + "\n")) + (delete-process connection) + (setq connection nil)))))))))) + +(defsubst ats-server-exists-p () + "Return whether the ATS server is alive and well. +Value, if non-nil, is the port on which it listens." + (and ats-server + (eq (process-status ats-server) 'listen) + (process-contact ats-server :service))) + +(defun ats-start-server () + "Start a server to which remote devices may connect. +Alternatively, return a value pertaining to an existing server. +Value is the port on which it will listen." + (if (ats-server-exists-p) + (process-contact ats-server :service) + (let ((process + (make-network-process :name " *ats server*" + :server t + :host 'local + :service (if (featurep 'make-network-process + '(:service t)) + t + ats-default-port) + :family 'ipv4 + :coding 'utf-8-emacs + :sentinel #'ats-server-sentinel + :log #'ats-server-log))) + (setq ats-server process) + (process-contact process :service)))) + +(defvar ats-await-connection-timeout 180 + "Timeout after which to declare a connection failure.") + +(defun ats-await-connection (uuid device) + "Await a connection by a client identifying as UUID. +DEVICE should be the name of the device to which the connection +is to be established, to be printed in timeout methods. +Value is the connection established between the ATS server, +which must already have been started, and the client. +Signal an error if connection establishment times out." + (unless (ats-server-exists-p) + (error "The ATS server is off-line. Please call `ats-start-server'")) + (let ((ats-accepting-connection uuid)) + (prog1 (catch 'connection-established + (with-timeout (ats-await-connection-timeout + (error "Connection to `%s' timed out..." + device)) + (let ((time (float-time))) + (while t + (message "Connecting... (%s s)" + (let* ((current-time (float-time)) + (elapsed (- current-time time))) + (floor elapsed))) + (accept-process-output nil 1))))) + (message "")))) + +(defun ats-forward-server-sentinel (process _) + "Terminate PROCESS's buffer after it completes." + (when (not (memq (process-status process) '(run stop))) + (when (and (process-buffer process) + (buffer-live-p (process-buffer process))) + (kill-buffer (process-buffer process))))) + +(defun ats-forward-server-filter (process string) + "Prompt for a password or other details if requested by PROCESS. +Set the process property `ats-connection-established' to t if a +string indicating success is read, and insert STRING." + (when (buffer-live-p (process-buffer process)) + (with-current-buffer (process-buffer process) + (let ((string (string-replace "\r" "" string))) + (insert string) + (cond + ((string-prefix-p "ATS_CONNECTION_ESTABLISHED" string) + (process-put process 'ats-connection-established t)) + ((string-match comint-password-prompt-regexp string) + (process-send-string + process (concat (read-passwd string) "\n"))) + ((string-match tramp-yesno-prompt-regexp string) + (process-send-string + process (concat + (or (and (yes-or-no-p string) "yes") "no") "\n"))) + ((string-match tramp-yn-prompt-regexp string) + (process-send-string + process (concat + (or (and (y-or-n-p string) "yes") "no") "\n")))))))) + +(defun ats-reverse-server (address port) + "Proxy to port PORT here from the server at ADDRESS, over SSH. +Value is the port at the destination." + (if (ats-is-localhost-p address) + port + (let* ((host (ats-address-to-hostname address)) + (name (format " *ats-reverse-server %s:%d*" host port)) + (existing-process (get-process name))) + ;; Is that connection available? + (if (and existing-process + (process-get existing-process 'ats-connection-established)) + port + ;; Kill it. + (when existing-process + (kill-process existing-process)) + (let ((process (start-process name name "ssh" "-o" + "ExitOnForwardFailure=yes" + "-R" + (format "%d:localhost:%d" port port) + host + (concat + "echo ATS_CONNECTION_ESTABLISHED; " + "while :; do sleep 10; done")))) + (set-process-sentinel process #'ats-forward-server-sentinel) + (set-process-filter process #'ats-forward-server-filter) + (save-window-excursion + (pop-to-buffer (process-buffer process)) + (while (not (process-get process 'ats-connection-established)) + (if (not (eq (process-status process) 'run)) + (error "ssh forwarding failed with exit code: %d" + (process-exit-status process)) + (accept-process-output process)))) + port))))) + +(defun ats-forward-server (address port) + "Forward from hence to the service at PORT on server ADDRESS over SSH. +Value is the local port which being forwarded to the destination." + (if (ats-is-localhost-p address) + port + (let* ((host (ats-address-to-hostname address)) + (name (format " *ats-forward-server %s:%d*" host port)) + (existing-process (get-process name))) + ;; Is that connection available? + (if (and existing-process + (process-get existing-process 'ats-connection-established)) + port + ;; Kill it. + (when existing-process + (kill-process existing-process)) + (let ((process (start-process name name "ssh" "-o" + "ExitOnForwardFailure=yes" + "-L" + (format "%d:localhost:%d" port port) + host + (concat + "echo ATS_CONNECTION_ESTABLISHED; " + "while :; do sleep 10; done")))) + (set-process-sentinel process #'ats-forward-server-sentinel) + (set-process-filter process #'ats-forward-server-filter) + (save-window-excursion + (pop-to-buffer (process-buffer process)) + (while (not (process-get process 'ats-connection-established)) + (if (not (eq (process-status process) 'run)) + (error "ssh forwarding failed with exit code: %d" + (process-exit-status process)) + (accept-process-output process)))) + port))))) + +(defun ats-cancel-forward-server (address port) + "Cease forwarding to PORT at ADDRESS over SSH." + (unless (ats-is-localhost-p address) + (let* ((host (ats-address-to-hostname address)) + (name (format " *ats-forward-server %s:%d*" host port)) + (process (get-process name))) + (with-local-quit + (when (and process + (memq (process-status process) '(run stop))) + (interrupt-process process) + (while (memq (process-status process) '(run stop)) + (accept-process-output process nil nil t))))))) + +(defconst ats-remote-port 10053 + "ATS port on devices with reverse forwarding but no auto port selection. +This is offset by the user ID.") + +(defmacro ats-in-connection-context (process details &rest bodyforms) + "Evaluate BODYFORMS in PROCESS's context. +Bind PROCESS's connection details to DETAILS, bind +`ats-adb-host' to the value under which PROCESS was created, and +select PROCESS's buffer." + (declare (indent 2)) + (let ((old-proc process) (process (gensym))) + `(let* ((,process ,old-proc) + (,details (process-get ,process 'ats-connection-details))) + (with-current-buffer (process-buffer ,process) + (unless ,details + (error "Not an ATS process: %S" ,process)) + (let ((ats-adb-host (cdr (assq 'host ,details)))) + ,@bodyforms))))) + +(defvar ats-outstanding-reverse-connection nil + "If non-nil, a list of (HOST DEVICE REMOTE-PORT). +Which elements are, respectively, the hostname, device, and +remote port of a reverse proxy connection reserved for a +connection still being established that mustn't be terminated.") + +(defun ats-terminate-reverse-safely (device remote-port &optional process) + "Terminate a reverse forwarding connection from DEVICE:REMOTE-PORT if unused. +Call `adb -s DEVICE reverse --remove tcp:REMOTE-PORT' safely. +That is to say, unless REMOTE-PORT on DEVICE is reserved by any +connection presently established or being established, with the +exception of PROCESS, if specified." + (let ((canon-host (or ats-adb-host "localhost"))) + (catch 'abort + ;; Cancel reverse forwarding, but only after guaranteeing that no + ;; other connections exist with the same remote port and device. + (dolist (proc (process-list)) + (let ((details (and (not (eq process proc)) + (process-get proc 'ats-connection-details)))) + (when details + (let ((other-host (or (cdr (assq 'host details)) "localhost")) + (other-device (cdr (assq 'device details))) + (other-remote-port (cdr (assq 'remote-port details)))) + (when (and (equal canon-host other-host) + (equal device other-device) + (eq remote-port other-remote-port)) + (throw 'abort nil)))))) + ;; And that the port is not reserved for any connection in + ;; the making. + (when ats-outstanding-reverse-connection + (let ((other-host (nth 0 ats-outstanding-reverse-connection)) + (other-device (nth 1 ats-outstanding-reverse-connection)) + (other-port (nth 2 ats-outstanding-reverse-connection))) + (when (and (equal canon-host other-host) + (equal device other-device) + (eq remote-port other-port)) + (throw 'abort nil)))) + (message + "Canceling reverse forwarding to `%s:%d' from `localhost'" + device remote-port) + (ats-adb "-s" device "reverse" "--remove" + (format "tcp:%d" remote-port))))) + +(defun ats-disconnect-internal (process) + "Clean up the ATS connection represented by PROCESS. +If the connection was initiated by forwarding to the device, +terminate the local forwarding process if any, and remove the +port forward from the destination. If initialization was +effected by reverse forwarding from the device, terminate this +reverse forwarding session if no other process is forwarding on +the same port." + (ats-in-connection-context (get-process process) details + (let ((device (cdr (assq 'device details))) + (method (cdr (assq 'connection-method details)))) + (when (eq method 'forward) + (with-demoted-errors "Error in disconnecting device: %S" + ;; It is necessary to cancel port forwarding from the device + ;; to this host. + (let ((host-port (cdr (assq 'host-port details)))) + (message "Canceling port forwarding from `localhost' to `%s:%d'" + ats-adb-host host-port) + (ats-cancel-forward-server ats-adb-host host-port))) + (with-demoted-errors "Error in disconnecting device: %S" + ;; It is necessary to cancel port forwarding from the device + ;; to this host. + (let ((host-port (cdr (assq 'host-port details)))) + (message "Canceling port forwarding from the device to `%s:%d'" + ats-adb-host host-port) + (ats-adb "-s" device "forward" "--remove" + (format "tcp:%d" host-port))))) + (when (eq method 'reverse) + (with-demoted-errors "Error in disconnecting device: %S" + (let ((remote-port (cdr (assq 'remote-port details)))) + (ats-terminate-reverse-safely device remote-port process))))))) + +(defun ats-read-connection (prompt) + "Read an ATS connection from the user, with completion. +PROMPT is the prompt displayed by `completing-read'. +Value is a process representing such a connection." + (let ((procs)) + (dolist (proc (process-list)) + (when (process-get proc 'ats-connection-details) + (push (buffer-name (process-buffer proc)) procs))) + (let ((buffer (completing-read prompt procs + nil t nil 'ats-read-processes))) + (get-buffer-process buffer)))) + +(defun ats-disconnect (process) + "Disconnect from the ATS connection represented by PROCESS. +Interactively, prompt for a process to disconnect. + +Close PROCESS's connection if appropriate and remove any port +forwarding currently in place." + (interactive (list (ats-read-connection "Disconnect from: "))) + (ats-in-connection-context (get-process process) details + (delete-process process))) + +(defun ats-establish-connection (process details) + "Finalize a connection represented by PROCESS. +DETAILS should be an alist of connection information to which +`ats-adb-host' is appended, with the following keys: + + - `connection-method' + Either `forward' or `reverse', indicating respectively that + the connection was established by forwarding to the remote + device and by forwarding from the local device. + + - `device' + Serial number of the device, identifying it to ADB. + + - `user' + ID of the user on the device as which the remote process + executes. + + - `local-port' + That port from which `host-port' on the ADB host system is + being forwarded to, if `connection-method' is `forward'. + + - `remote-port' + That port to which `host-port' is being forwarded from, + if `connection-method' is `reverse'. + + - `host-port' + The port on the ADB host system mediating between the local + and the remote system. + +Value is PROCESS itself." + (process-put process 'ats-connection-details + (append `((host . ,ats-adb-host) + (eval-serial . 0)) + details)) + (let ((device (cdr (assq 'device details))) + (user (cdr (assq 'user details))) + (host (or ats-adb-host "localhost"))) + (with-current-buffer (process-buffer process) + (if (eq user 0) + (rename-buffer (format " *ats connection for %s (on %s)*" + device host) + t) + (rename-buffer (format " *ats connection for %s (on %s, as %d)*" + device host user) + t))) + (message "Connection established to %s (on %s)" + (cdr (assq 'device details)) host)) + process) + +;;;###autoload +(defun ats-connect (device user &optional host) + "Establish a connection to DEVICE on HOST executing as USER. +HOST, if nil, defaults to `ats-adb-host'. +If an instance of Emacs is already executing on DEVICE and the +test driver is available, connect to this test driver. +Otherwise, terminate any existing Emacs sessions, upload the +test driver, load it into a new Emacs session, and establish a +connection. + +Interactively, prompt for a device and a user on the device to +which to connect. With a prefix argument, also prompt for the +address of an ADB daemon on a host machine whose devices are to +be connected to (which requires that OpenSSH be installed on +this machine and an SSH daemon be executing on the host)." + (interactive (let* ((host (or (and current-prefix-arg + (read-string "ADB hostname: ")) + ats-adb-host)) + (ats-adb-host host) + (device + (completing-read "Connect to device: " + (mapcar #'car + (ats-online-devices)) + nil t nil 'ats-connect-device)) + (user-alist + (mapcar (lambda (user) + (cons (format "%s (%d)" + (cadr user) (car user)) + (car user))) + (ats-list-users device))) + (user + (let ((completions-sort nil)) + (completing-read "Select a user: " + user-alist nil t)))) + (list device (or (cdr (assoc user user-alist)) + (error "Unknown user: %s" user)) + host))) + ;; Terminate any existing instances of Emacs executing as this user. + (let* ((ats-adb-host host) + (emacs-aid (ats-get-package-aid device "org.gnu.emacs")) + (emacs-uid (ats-aid-to-uid emacs-aid user)) + (emacs-username (ats-uid-to-username device emacs-uid))) + ;; Start Emacs and arrange to load the test driver. + (cond + ((ats-supports-am-force-stop-user device) + (with-temp-buffer + (ats-adb "-s" device "shell" "am" "force-stop" "--user" + (number-to-string user) "org.gnu.emacs"))) + ((and (ats-supports-am-force-stop device) + (eq user 0)) + (with-temp-buffer + (ats-adb "-s" device "shell" "am" "force-stop" + "org.gnu.emacs"))) + (t (when (ats-kill-process-by-username-and-name + device emacs-username "org.gnu.emacs" "org.gnu.emacs" user) + (dotimes (_ 3) + ;; This must be repeated several times or the ActivityManager + ;; may attempt to restart Emacs with the previous intent's + ;; parameters. + (sleep-for 0.25) + (ats-kill-process-by-username-and-name + device emacs-username "org.gnu.emacs" "org.gnu.emacs" user)))))) + ;; Upload the test driver. + (let* ((ats-adb-host host) + (ats-file (let ((file (and ats-file-directory + (concat (file-name-as-directory + ats-file-directory) + "test-driver.el")))) + (or (and file (file-exists-p file) file) + (read-file-name "ATS test driver file: ")))) + (file (ats-upload device ats-file "org.gnu.emacs" user)) + ;; Start the server. + (server-port (ats-start-server)) + ;; Forward the server to the ADB host. + (host-port (ats-reverse-server ats-adb-host server-port)) + ;; Forward the server to the device. + (remote-port (ignore-errors + (if (>= (ats-get-sdk-version device) 26) + ;; Automatically select a port to open on + ;; the device. + (ats-reverse-tcp device host-port 0) + ;; Derive a fixed port from the user ID. + (ats-reverse-tcp device host-port + (+ ats-remote-port user))))) + (uuid (if (executable-find "uuidgen") + (string-trim + (shell-command-to-string "uuidgen")) + (format "%x" (random most-positive-fixnum)))) + process) + (if remote-port + (progn + ;; Launch Emacs with arguments directing it to load the test + ;; driver file and connect to the local port, and begin to + ;; wait. + ;; + ;; Care must be exercised that process sentinels are not + ;; executed before `ats-outstanding-reverse-connection' is + ;; bound or after a connection is established! + (unwind-protect + (let ((ats-outstanding-reverse-connection + (list (or ats-adb-host "localhost") + device remote-port))) + (ats-am-start-intent + device user + `((:component . "org.gnu.emacs/.EmacsActivity") + ("org.gnu.emacs.STARTUP_ARGUMENTS" + "-q" "--load" ,file "--eval" + ,(format "(ats-establish-connection \"localhost\" %d \"%s\")" + remote-port uuid)))) + (setq process + (let* ((process (ats-await-connection uuid device))) + (ats-establish-connection + process `((connection-method . reverse) + (remote-port . ,remote-port) + (host-port . ,host-port) + (user . ,user) + (device . ,device)))))) + ;; On failure, cease forwarding to this device, but permit + ;; the connection to the host to remain. + (unless process + (with-demoted-errors "Winding up failed connection: %S" + (ats-terminate-reverse-safely device remote-port)))) + process) + (message "Reverse forwarding is unsupported by this device.") + (sit-for 1 t) + (message "Instructing the device to establish a proxy connection instead.") + (sit-for 1 t) + ;; Since there are no alternative means by which to communicate + ;; with a non-debuggable Emacs instance, create a file accessible + ;; both to ADB and to Emacs, and arrange to store Emacs's server + ;; port there. + (let ((commfile (ats-create-commfile device "org.gnu.emacs" user))) + (ats-am-start-intent + device user + `((:component . "org.gnu.emacs/.EmacsActivity") + ("org.gnu.emacs.STARTUP_ARGUMENTS" + "-q" "--load" ,file "--eval" + ,(format "(ats-initiate-connection %S)" commfile)))) + (let* ((portno (with-timeout + (ats-await-connection-timeout + (error "Connection to `%s' timed out..." device)) + (ats-watch-commfile device commfile + "org.gnu.emacs" user))) + (remote-port (string-to-number portno))) + (when (zerop remote-port) + (error "Failed to read port number from device")) + ;; Forward it. + (let* ((host-port (ats-forward-tcp device remote-port 0)) + (name (format " *ats connection for %s (on %s)*" + device (or ats-adb-host "localhost"))) + local-port process) + (condition-case err + (progn + (setq local-port (ats-forward-server ats-adb-host host-port)) + (setq process (make-network-process + :name name + :buffer name + :host 'local + :service local-port + :coding 'utf-8-emacs + :sentinel #'ats-server-sentinel)) + (process-send-string process "-ok\n") + (ats-establish-connection process + `((connection-method . forward) + (local-port . ,local-port) + (host-port . ,host-port) + (user . ,user) + (device . ,device)))) + (error + (when process + ;; Finalize the failed process as best as can be + ;; managed. + (with-demoted-errors "Winding up failed connection: %S" + (ats-disconnect-internal process))) + (when local-port + (with-demoted-errors "Winding up failed connection: %S" + ;; Though local-port serves to attest whether a + ;; forwarding connection has been established, yet it + ;; is the destination port that identifies such a + ;; connection to `ats-cancel-forward-server', which + ;; is not consistent with `adb forward --remove'. + (ats-cancel-forward-server ats-adb-host host-port))) + (with-demoted-errors "Winding up failed connection: %S" + (ats-adb "-s" device "forward" "--remove" + (format "tcp:%d" host-port))) + (signal (car err) (cdr err)))))))))) + + + +;; Command submission and execution. + +;; (defvar ats-eval-tm 0) + +(defun ats-eval (process form &optional as-printed) + "Evaluate FORM in PROCESS, which form must be printable. +Form should evaluate to a value that must be printable, or +signal an error. Value is (ok . VALUE) if no error was +signaled, or (error . VALUE) otherwise. + +Set AS-PRINTED to insist that the value be returned as a string; +this enables non-printable values to be returned in a meaningful +manner." + (ats-in-connection-context process details + (save-restriction + (let* ((str (prin1-to-string form)) + (length (length str)) + (serial (setf (alist-get 'eval-serial details) + (1+ (alist-get 'eval-serial details)))) + (serial-str (number-to-string serial)) + (request-regexp (rx bol "\fats-request:" + (literal serial-str) + " " (group (+ digit)) "\n")) + (point (point)) + size form) + (process-send-string process + (format "-eval %d %d %s\n" serial + length + (if as-printed "t" "nil"))) + (process-send-string process str) + ;; Read the resultant form. + (while (not form) + (when (not (eq (process-status process) 'open)) + (error "Connection terminated unexpectedly...")) + ;; (let ((t1 (float-time))) + ;; (prog1 (accept-process-output process nil nil 1) + ;; (setq ats-eval-tm (+ (- (float-time) t1) + ;; ats-eval-tm)))) + (when (accept-process-output process nil nil 1) + (when (not size) + ;; First skip all output till the header is read. + (save-excursion + (goto-char point) + (when-let* ((start (re-search-forward + request-regexp nil t))) + (setq size (string-to-number (match-string 1))) + (delete-region (point-min) (point))))) + (when size + ;; Read SIZE bytes from the process. + (when (>= (- (point-max) (point-min)) size) + (narrow-to-region (point-min) (+ (point-min) size)) + (goto-char (point-min)) + (setq form (read (current-buffer))))))) + form)))) + +(provide 'test-controller) + +;;; test-controller.el ends here + +;; Local Variables: +;; emacs-lisp-docstring-fill-column: 64 +;; indent-tabs-mode: t +;; End: diff --git a/test/infra/android/test-driver.el b/test/infra/android/test-driver.el new file mode 100644 index 00000000000..cebe5f032d7 --- /dev/null +++ b/test/infra/android/test-driver.el @@ -0,0 +1,210 @@ +;;; Receive and execute Lisp code submitted by a test controller. -*- lexical-binding: t; -*- +;;; $Id: ats-driver.el,v 1.6 2025/02/19 01:56:55 jw Exp $ + +;; Copyright (C) 2025 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: +;; +;; This file establishes a connection to a controlling device, executes +;; Lisp expressions received from the same, and responds with any +;; results available. +;; +;; There were anciently many more facilities in this file but they are +;; in the process of being moved to `test-controller.el' (now in Lisp). + +;;; Code: + + + +;; Connection establishment and management. + +(defvar ats-process nil + "Connection to the test controller.") + +(defvar ats-connection-established nil + "Whether `ats-process' has been initialized.") + +(defface ats-header '((t :height 1.3 :weight bold + :inherit variable-pitch)) + "Face of ATS header elements.") + +(defvar-local ats-in-eval nil + "Whether an `-eval' command is being processed and form's size.") + +(defvar-local ats-eval-as-printed nil + "Whether to return the values of the submitted form as a string.") + +(defvar-local ats-eval-serial nil + "Serial number identifying this result.") + +(defun ats-process-filter (process string) + "Filter input from `ats-process'. +Insert STRING into the connection buffer, till a full command is +read." + (when (buffer-live-p (process-buffer process)) + (with-current-buffer (process-buffer process) + (let ((marker (process-mark process))) + (unless (marker-position marker) + (set-marker marker (point))) + (save-excursion + (goto-char marker) + (insert string) + (set-marker marker (point)))) + (let ((firstchar (char-after (point-min))) + (inhibit-quit nil) + (in-eval ats-in-eval)) + (while (or (eq firstchar ?-) in-eval) + (unless ats-in-eval + (when (eq firstchar ?-) + ;; A command is being delivered. Search for a newline. + (save-excursion + (when-let* ((newline (search-forward "\n" nil t)) + (command (buffer-substring + (point-min) (1- newline)))) + (delete-region (point-min) newline) + (cond + ((equal command "-ok") + (setq ats-connection-established t) + (ats-display-status-buffer)) + ((equal command "-not-accepting-connections") + (error + "The server is not accepting connections")) + ((string-match + "^-incorrect-uuid \\([[:alnum:]-]\\) \\([[:alnum:]-]\\)$" + command) + (error "Connection rejected; wanted ID=%s, received ID=%s" + (match-string 2 command) (match-string 1 command))) + ((string-match + "^-eval \\([[:digit:]]+\\) \\([[:digit:]]+\\) \\(t\\|nil\\)$" + command) + (setq ats-eval-serial (string-to-number + (match-string 1 command)) + ats-in-eval (string-to-number + (match-string 2 command)) + ats-eval-as-printed (equal + (match-string 3 command) + "t"))) + (t (error (concat "Unknown command: " command)))))))) + (when ats-in-eval + ;; Proceed till `ats-in-eval' characters are read. + (when (>= (- (point-max) (point-min)) ats-in-eval) + (let ((value + (save-restriction + (narrow-to-region (point-min) (1+ ats-in-eval)) + (condition-case err + (let* ((str (buffer-string))) + (with-current-buffer "*ATS*" + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (insert "--> " (truncate-string-to-width + str 72) + "\n"))) + (let* ((expr (car (read-from-string str))) + (value (eval expr))) + (cons 'ok value))) + (error (cons 'error err)))))) + (let* ((print-escape-control-characters t) + (print-escape-newlines t) + (str (prin1-to-string value))) + (if ats-eval-as-printed + (let* ((quoted (prin1-to-string str))) + (process-send-string + process (format "\fats-request:%d %d\n" + ats-eval-serial + (length quoted))) + (process-send-string process quoted)) + (process-send-string + process (format "\fats-request:%d %d\n" + ats-eval-serial + (length str))) + (process-send-string process str))) + (process-send-string process "\n")) + (delete-region (point-min) + (+ (point-min) ats-in-eval)) + (setq ats-in-eval nil))) + ;; Don't loop if the form data is yet to arrive. + (setq firstchar (char-after (point-min)) + in-eval nil)))))) + +(defun ats-display-status-buffer () + "Replace the splash screen with text announcing connection establishment." + (with-current-buffer (get-buffer-create "*ATS*") + (setq buffer-read-only nil) + (erase-buffer) + (insert (propertize "ATS ready\n" 'face 'ats-header)) + (insert (propertize " +If you are reading this message, this instance of Emacs has\ + successfully established a connection with a controlling\ + machine and is patiently awaiting instructions. +" + 'face 'variable-pitch)) + (special-mode) + (setq-local truncate-lines nil) + (visual-line-mode 1)) + (pop-to-buffer "*ATS*" '(display-buffer-full-frame))) + +(defun ats-establish-connection (host port id) + "Connect to the test controller instance at HOST:PORT. +ID is the identifier assigned to this client. Establish a +connection to a test controller instance through an address or a +Unix domain socket provided as aforesaid. Signal an error upon +failure." + (message "; Connecting to %s:%d..." host port) + (setq ats-process (make-network-process + :name (format "*ats connection to %s:%d*" host port) + :buffer "*ats connection*" + :host host + :service port + :coding 'utf-8-emacs + :filter #'ats-process-filter)) + (process-send-string ats-process (concat id "\n"))) + +(defun ats-driver-log (_ connection _) + "Log function for ATS driver processes." + (if ats-process + (delete-process connection) + (setq ats-process connection) + (set-process-filter connection #'ats-process-filter) + (pop-to-buffer (process-buffer connection)))) + +(defun ats-initiate-connection (commfile) + "Open a network server locally to which the controller may connect. +Write its port number to COMMFILE, and await a connection from +the controller." + (let* ((process (make-network-process :name " *ats driver*" + :server t + :host 'local + :service t + :family 'ipv4 + :coding 'utf-8-emacs + :log #'ats-driver-log)) + (service (process-contact process :service))) + (with-temp-buffer + (insert (format "%d\n" service)) + (write-region (point-min) (point-max) commfile t)) + (message "; Listening for connection from controller at localhost:%d" + service))) + +(provide 'test-driver) + +;;; test-driver.el ends here + +;; Local Variables: +;; emacs-lisp-docstring-fill-column: 64 +;; indent-tabs-mode: t +;; End: commit ae5674c758a26ce598cdca37d83d268b51fe53dd Author: john muhl Date: Mon Feb 24 17:31:15 2025 -0600 ; Re-enable 'typescript-ts-mode' indentation tests * test/lisp/progmodes/typescript-ts-mode-tests.el (typescript-ts-mode-test-indentation): Remove unstable tag. (Bug#76536) diff --git a/test/lisp/progmodes/typescript-ts-mode-tests.el b/test/lisp/progmodes/typescript-ts-mode-tests.el index b6dd65b9512..fe5d2c7ccae 100644 --- a/test/lisp/progmodes/typescript-ts-mode-tests.el +++ b/test/lisp/progmodes/typescript-ts-mode-tests.el @@ -24,7 +24,6 @@ (require 'treesit) (ert-deftest typescript-ts-mode-test-indentation () - :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (and (treesit-ready-p 'typescript) (treesit-ready-p 'tsx))) (ert-test-erts-file (ert-resource-file "indent.erts"))) commit 60b071e224136207f7fa24983037522e637e7efa Author: Stefan Kangas Date: Tue Feb 25 00:12:00 2025 +0100 Make cl-gensym obsolete in favor of built-in gensym * lisp/emacs-lisp/cl-macs.el (cl-gensym): Declare function obsolete in favor of gensym, added in Emacs 26.1. The only reason for its existence is that it allows an integer argument, but that's not really useful, so it's better to remove this complexity. Ref: https://lists.gnu.org/r/emacs-devel/2017-09/msg00313.html * doc/misc/cl.texi (Symbols, Creating Symbols, Efficiency Concerns) (Obsolete Setf Customization): Don't document above obsolete function. * lisp/emacs-lisp/cl-macs.el (cl--parse-loop-clause): * lisp/emacs-lisp/edebug.el (edebug-make-form-wrapper): * lisp/obsolete/cl.el (cl--function-convert, lexical-let): * lisp/obsolete/thumbs.el (thumbs-temp-file): * lisp/progmodes/eglot.el (eglot--lambda) (eglot--when-live-buffer, eglot--when-buffer-window) (eglot--collecting-xrefs, eglot--glob-parse): * lisp/progmodes/flymake.el (flymake--run-backend): * test/lisp/emacs-lisp/package-tests.el (with-package-test): * test/lisp/progmodes/eglot-tests.el (eglot--guessing-contact): * test/lisp/progmodes/elisp-mode-tests.el (elisp-shorthand-read-buffer, elisp-shorthand-read-from-string): Prefer plain gensym to cl-gensym in files that can depend on Emacs 26.1. * lisp/jsonrpc.el (jsonrpc-lambda, jsonrpc-request): Prefer gensym to cl-gensym only when defined, as this file supports Emacs 25.1 * test/lisp/emacs-lisp/cl-macs-tests.el (cl-lib-test-gensym): Simplify test as 'should' no longer uses cl-gensym. diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index b4c1f29f47f..df67478a5aa 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -2804,7 +2804,7 @@ missing from Emacs Lisp. @menu * Property Lists:: @code{cl-get}, @code{cl-remprop}, @code{cl-getf}, @code{cl-remf}. -* Creating Symbols:: @code{cl-gensym}, @code{cl-gentemp}. +* Creating Symbols:: @code{cl-gentemp}. @end menu @node Property Lists @@ -2892,30 +2892,10 @@ out the property and value cells. @section Creating Symbols @cindex gensym -@noindent -These functions create unique symbols, typically for use as -temporary variables. - -@defun cl-gensym &optional x -This function creates a new, uninterned symbol (using @code{make-symbol}) -with a unique name. (The name of an uninterned symbol is relevant -only if the symbol is printed.) By default, the name is generated -from an increasing sequence of numbers, @samp{G1000}, @samp{G1001}, -@samp{G1002}, etc. If the optional argument @var{x} is a string, that -string is used as a prefix instead of @samp{G}. Uninterned symbols -are used in macro expansions for temporary variables, to ensure that -their names will not conflict with ``real'' variables in the user's -code. - -(Internally, the variable @code{cl--gensym-counter} holds the counter -used to generate names. It is initialized with zero and incremented -after each use.) -@end defun - @defun cl-gentemp &optional x -This function is like @code{cl-gensym}, except that it produces a new -@emph{interned} symbol. If the symbol that is generated already -exists, the function keeps incrementing the counter and trying +This function is like the built-in @code{gensym}, except that it +produces a new @emph{interned} symbol. If the symbol that is generated +already exists, the function keeps incrementing the counter and trying again until a new symbol is generated. @end defun @@ -4419,18 +4399,18 @@ an expansion similar to: @example (cl-block nil (let* ((x 0) - (G1004 nil)) + (g1004 nil)) (while (< x 10) - (setq G1004 (cons x G1004)) + (setq g1004 (cons x g1004)) (setq x (+ x 1))) - (nreverse G1004))) + (nreverse g1004))) @end example @noindent will be inserted into the buffer. (The @code{cl-block} macro is expanded differently in the interpreter and compiler, so @code{cl-prettyexpand} just leaves it alone. The temporary -variable @code{G1004} was created by @code{cl-gensym}.) +variable @code{g1004} was created by @code{gensym}.) If the optional argument @var{full} is true, then @emph{all} macros are expanded, including @code{cl-block}, @code{cl-eval-when}, @@ -5157,7 +5137,7 @@ temporary variables. In the setf-methods generated by @code{defsetf}, the second return value is simply the list of arguments in the place form, and the first return value is a list of a corresponding number of temporary variables generated -by @code{cl-gensym}. +by @code{gensym}. @end defmac @node GNU Free Documentation License diff --git a/etc/NEWS b/etc/NEWS index ed4c09f1274..a86c2ca2409 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -540,6 +540,9 @@ It is an alias for the 'progn' special-form. +++ *** 'cl-declare' is now obsolete; use 'defvar' instead. ++++ +*** 'cl-gensym' is now obsolete; use 'gensym' instead. + ** Whitespace --- diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index dbaa0d9bcb8..c3c8361b38e 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -166,6 +166,7 @@ whether X is known at compile time, macroexpand it completely in (defun cl-gensym (&optional prefix) "Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\"." + (declare (obsolete gensym "31.1")) (let ((pfix (if (stringp prefix) prefix "G")) (num (if (integerp prefix) prefix (prog1 cl--gensym-counter @@ -1270,10 +1271,10 @@ For more details, see Info node `(cl)Loop Facility'. (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) (ands nil)) (while - ;; Use `cl-gensym' rather than `make-symbol'. It's important that + ;; Use `gensym' rather than `make-symbol'. It's important that ;; (not (eq (symbol-name var1) (symbol-name var2))) because ;; these vars get added to the macro-environment. - (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--")))) + (let ((var (or (pop cl--loop-args) (gensym "--cl-var--")))) (setq word (pop cl--loop-args)) (if (eq word 'being) (setq word (pop cl--loop-args))) (if (memq word '(the each)) (setq word (pop cl--loop-args))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 3ecc287da14..8a10f26a7b4 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1369,7 +1369,7 @@ infinite loops when the code/environment contains a circular object.") ;; Set the name here if it was not set by edebug-make-enter-wrapper. (setq edebug-def-name - (or edebug-def-name edebug-old-def-name (cl-gensym "edebug-anon"))) + (or edebug-def-name edebug-old-def-name (gensym "edebug-anon"))) ;; Add this def as a dependent of containing def. Buggy. '(if (and edebug-containing-def-name diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index c5a099af8ec..6c969120926 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -204,7 +204,8 @@ JSONRPC message." ;;; (cl-defmacro jsonrpc-lambda (cl-lambda-list &body body) (declare (indent 1) (debug (sexp &rest form))) - (let ((e (cl-gensym "jsonrpc-lambda-elem"))) + (let ((e (funcall (if (fboundp 'gensym) 'gensym 'cl-gensym) + "jsonrpc-lambda-elem"))) `(lambda (,e) (apply (cl-function (lambda ,cl-lambda-list ,@body)) ,e)))) (defun jsonrpc-events-buffer (connection) @@ -405,7 +406,9 @@ remote endpoint (normal or error) are ignored and the function exits returning CANCEL-ON-INPUT-RETVAL. If CANCEL-ON-INPUT is a function, it is invoked with one argument, an integer identifying the canceled request as specified in the JSONRPC 2.0 spec." - (let* ((tag (cl-gensym "jsonrpc-request-catch-tag")) id-and-timer + (let* ((tag (funcall (if (fboundp 'gensym) 'gensym 'cl-gensym) + "jsonrpc-request-catch-tag")) + id-and-timer canceled (throw-on-input nil) (retval diff --git a/lisp/obsolete/cl.el b/lisp/obsolete/cl.el index 5fbfbb7899e..8a7e54a981c 100644 --- a/lisp/obsolete/cl.el +++ b/lisp/obsolete/cl.el @@ -325,7 +325,7 @@ The two cases that are handled are: (cddr f)))) (if (and cl-closure-vars (cl--expr-contains-any body cl-closure-vars)) - (let* ((new (mapcar #'cl-gensym cl-closure-vars)) + (let* ((new (mapcar #'gensym cl-closure-vars)) (sub (cl-pairlis cl-closure-vars new)) (decls nil)) (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) @@ -372,7 +372,7 @@ lexical closures as in Common Lisp. (cons (cons 'function #'cl--function-convert) macroexpand-all-environment)))) (if (not (get (car (last cl-closure-vars)) 'used)) - ;; Turn (let ((foo (cl-gensym))) + ;; Turn (let ((foo (gensym))) ;; (set foo ) ...(symbol-value foo)...) ;; into (let ((foo )) ...(symbol-value 'foo)...). ;; This is good because it's more efficient but it only works with diff --git a/lisp/obsolete/thumbs.el b/lisp/obsolete/thumbs.el index a4f28ce97c5..ac8f9c5fad6 100644 --- a/lisp/obsolete/thumbs.el +++ b/lisp/obsolete/thumbs.el @@ -60,7 +60,7 @@ ;;; Code: (require 'dired) -(require 'cl-lib) ; for cl-gensym +(require 'cl-lib) ;; CUSTOMIZATIONS @@ -176,7 +176,7 @@ this value can let another user see some of your images." (format "%s%s-%s.jpg" (thumbs-temp-dir) thumbs-temp-prefix - (cl-gensym "T"))) + (gensym "T"))) (defun thumbs-thumbsdir () "Return the current thumbnails directory (from `thumbs-thumbsdir'). diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index a380e352a15..1920d835cc3 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -881,7 +881,7 @@ Honor `eglot-strict-mode'." "Function of args CL-LAMBDA-LIST for processing INTERFACE objects. Honor `eglot-strict-mode'." (declare (indent 1) (debug (sexp &rest form))) - (let ((e (cl-gensym "jsonrpc-lambda-elem"))) + (let ((e (gensym "jsonrpc-lambda-elem"))) `(lambda (,e) (cl-block nil (eglot--dbind ,cl-lambda-list ,e ,@body))))) (cl-defmacro eglot--dcase (obj &rest clauses) @@ -927,12 +927,12 @@ treated as in `eglot--dbind'." (cl-defmacro eglot--when-live-buffer (buf &rest body) "Check BUF live, then do BODY in it." (declare (indent 1) (debug t)) - (let ((b (cl-gensym))) + (let ((b (gensym))) `(let ((,b ,buf)) (if (buffer-live-p ,b) (with-current-buffer ,b ,@body))))) (cl-defmacro eglot--when-buffer-window (buf &body body) "Check BUF showing somewhere, then do BODY in it." (declare (indent 1) (debug t)) - (let ((b (cl-gensym))) + (let ((b (gensym))) `(let ((,b ,buf)) ;;notice the exception when testing with `ert' (when (or (get-buffer-window ,b) (ert-running-test)) @@ -3142,7 +3142,7 @@ may be called multiple times (respecting the protocol of (cl-defmacro eglot--collecting-xrefs ((collector) &rest body) "Sort and handle xrefs collected with COLLECTOR in BODY." (declare (indent 1) (debug (sexp &rest form))) - (let ((collected (cl-gensym "collected"))) + (let ((collected (gensym "collected"))) `(unwind-protect (let (,collected) (cl-flet ((,collector (xref) (push xref ,collected))) @@ -4221,7 +4221,7 @@ at point. With prefix argument, prompt for ACTION-KIND." collect (cl-loop for (_token regexp emitter) in grammar thereis (and (re-search-forward (concat "\\=" regexp) nil t) - (list (cl-gensym "state-") emitter (match-string 0))) + (list (gensym "state-") emitter (match-string 0))) finally (error "Glob '%s' invalid at %s" (buffer-string) (point)))))) (cl-defun eglot--glob-fsm (states &key (exit 'eobp) noerror) diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 9dda53713f5..75ba3efeb65 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -1247,7 +1247,7 @@ If it is running also stop it." ARGS is a keyword-value plist passed to the backend along with a report function." (flymake-log :debug "Running backend %s" backend) - (let ((run-token (cl-gensym "backend-token"))) + (let ((run-token (gensym "backend-token"))) (flymake--with-backend-state backend state (setf (flymake--state-running state) run-token (flymake--state-disabled state) nil diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index a3118c9b556..64ccdd2d1ce 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -961,21 +961,14 @@ See Bug#57915." :b 1))) (ert-deftest cl-lib-test-gensym () - ;; Since the expansion of `should' calls `cl-gensym' and thus has a - ;; side-effect on `cl--gensym-counter', we have to make sure all - ;; macros in our test body are expanded before we rebind - ;; `cl--gensym-counter' and run the body. Otherwise, the test would - ;; fail if run interpreted. - (let ((body (byte-compile - '(lambda () - (should (equal (symbol-name (cl-gensym)) "G0")) - (should (equal (symbol-name (cl-gensym)) "G1")) - (should (equal (symbol-name (cl-gensym)) "G2")) - (should (equal (symbol-name (cl-gensym "foo")) "foo3")) - (should (equal (symbol-name (cl-gensym "bar")) "bar4")) - (should (equal cl--gensym-counter 5)))))) + (with-suppressed-warnings ((obsolete cl-gensym)) (let ((cl--gensym-counter 0)) - (funcall body)))) + (should (equal (symbol-name (cl-gensym)) "G0")) + (should (equal (symbol-name (cl-gensym)) "G1")) + (should (equal (symbol-name (cl-gensym)) "G2")) + (should (equal (symbol-name (cl-gensym "foo")) "foo3")) + (should (equal (symbol-name (cl-gensym "bar")) "bar4")) + (should (equal cl--gensym-counter 5))))) (ert-deftest cl-the () (should (eql (cl-the integer 42) 42)) diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index b779dcee393..d8e260319bd 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -128,11 +128,11 @@ package-selected-packages ,@(if update-news '(package-update-news-on-upload t) - (list (cl-gensym))) + (list (gensym))) ,@(if upload-base '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) (package-archive-upload-base package-test-archive-upload-base)) - (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil + (list (gensym)))) ;; Dummy value so `let' doesn't try to bind nil (let ((buf (get-buffer "*Packages*"))) (when (buffer-live-p buf) (kill-buffer buf))) diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index eec076da723..2b6e09a4d16 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -1236,7 +1236,7 @@ GUESSED-MAJOR-MODES-SYM are bound to the useful return values of `eglot--guess-contact'. Unless the server program evaluates to \"a-missing-executable.exe\", this macro will assume it exists." (declare (indent 1) (debug t)) - (let ((i-sym (cl-gensym))) + (let ((i-sym (gensym))) `(dolist (,i-sym '(nil t)) (let ((,interactive-sym ,i-sym) (buffer-file-name "_") diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index b9fc2327f1b..7f635b8e88b 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -1050,7 +1050,7 @@ evaluation of BODY." (ert-deftest elisp-shorthand-read-buffer () - (let* ((gsym (downcase (symbol-name (cl-gensym "sh-")))) + (let* ((gsym (downcase (symbol-name (gensym "sh-")))) (shorthand-sname (format "s-%s" gsym)) (expected (intern (format "shorthand-longhand-%s" gsym)))) (cl-assert (not (intern-soft shorthand-sname))) @@ -1064,7 +1064,7 @@ evaluation of BODY." (should (not (intern-soft shorthand-sname))))) (ert-deftest elisp-shorthand-read-from-string () - (let* ((gsym (downcase (symbol-name (cl-gensym "sh-")))) + (let* ((gsym (downcase (symbol-name (gensym "sh-")))) (shorthand-sname (format "s-%s" gsym)) (expected (intern (format "shorthand-longhand-%s" gsym)))) (cl-assert (not (intern-soft shorthand-sname))) commit 1a22bc0fd672e2c71955faf81ff2cfd1c0c76be9 Author: Stefan Kangas Date: Mon Feb 24 23:02:20 2025 +0100 Use cl-with-gensyms in a few more cases * doc/misc/cl.texi (Macro Bindings): * lisp/emacs-lisp/comp.el (comp--with-sp): * lisp/emacs-lisp/subr-x.el (with-buffer-unmodified-if-unchanged): * lisp/eshell/em-extpipe.el (eshell-extpipe--or-with-catch): * lisp/international/mule-cmds.el (with-locale-environment): * lisp/kmacro.el (kmacro-menu--marks-exist-p): * test/lisp/emacs-lisp/cl-extra-tests.el (cl-lib-test-remprop): * test/lisp/emacs-lisp/edebug-tests.el (edebug-tests-deduplicate): * test/lisp/emacs-lisp/ert-tests.el (ert-test-special-operator-p): * test/lisp/kmacro-tests.el (kmacro-tests-should-insert) (kmacro-tests-should-match-message): * test/lisp/replace-tests.el (replace-tests-with-undo): Use cl-with-gensyms instead of bare gensym call. diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index 862b8f4a1c4..b4c1f29f47f 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -1370,7 +1370,7 @@ expansion of another macro: @example (cl-defmacro my-dolist ((x list) &rest body) - (let ((var (cl-gensym))) + (cl-with-gensyms (var) (list 'cl-loop 'for var 'on list 'do (cl-list* 'cl-symbol-macrolet (list (list x (list 'car var))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e7ccbbf12c7..6ad00f63971 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -953,7 +953,7 @@ Points to the next slot to be filled.") Restore the original value afterwards." (declare (debug (form body)) (indent defun)) - (let ((sym (gensym))) + (cl-with-gensyms (sym) `(let ((,sym (comp--sp))) (setf (comp--sp) ,sp) (progn ,@body) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 27e039eff9b..4ce7bd00f31 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -551,8 +551,7 @@ as changes in text properties, `buffer-file-coding-system', buffer multibyteness, etc. -- will not be noticed, and the buffer will still be marked unmodified, effectively ignoring those changes." (declare (debug t) (indent 0)) - (let ((hash (gensym)) - (buffer (gensym))) + (cl-with-gensyms (hash buffer) `(let ((,hash (and (not (buffer-modified-p)) (buffer-hash))) (,buffer (current-buffer))) diff --git a/lisp/eshell/em-extpipe.el b/lisp/eshell/em-extpipe.el index 6a061dad89e..c5170fed830 100644 --- a/lisp/eshell/em-extpipe.el +++ b/lisp/eshell/em-extpipe.el @@ -69,7 +69,7 @@ again." If `eshell-incomplete' is thrown during the evaluation of a disjunct, that disjunct yields nil." - (let ((result (gensym))) + (cl-with-gensyms (result) `(let (,result) (or ,@(cl-loop for disjunct in disjuncts collect `(if (catch 'eshell-incomplete diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 991fa589782..8b373ec11a5 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -2668,7 +2668,7 @@ but this macro does not by itself perform redisplay. If BODY needs to display something with LOCALE-NAME's settings, include a call to `redraw-frame' in BODY." (declare (indent 1) (debug (sexp def-body))) - (let ((current (gensym))) + (cl-with-gensyms (current) `(let ((,current current-locale-environment)) (unwind-protect (progn diff --git a/lisp/kmacro.el b/lisp/kmacro.el index 5092429afa3..43d0bfa23aa 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -1678,7 +1678,7 @@ line after applying FUNCTION." (defun kmacro-menu--marks-exist-p () "Return non-nil if markers exist for any table entries." - (let ((tag (gensym))) + (cl-with-gensyms (tag) (catch tag (kmacro-menu--map-ids (lambda (id) (when (alist-get (kmacro-menu--id-position id) diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el index 41753194c1b..20d1e532a6f 100644 --- a/test/lisp/emacs-lisp/cl-extra-tests.el +++ b/test/lisp/emacs-lisp/cl-extra-tests.el @@ -23,7 +23,7 @@ (require 'ert) (ert-deftest cl-lib-test-remprop () - (let ((x (cl-gensym))) + (cl-with-gensyms (x) (should (equal (symbol-plist x) '())) ;; Remove nonexistent property on empty plist. (cl-remprop x 'b) diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 02eadd34c8d..7daacea7925 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -321,8 +321,7 @@ NAME should be a string and NAMES-AND-NUMBERS an alist which can be used by this macro to retain state. If NAME for example is \"symbol\" then the first and subsequent uses of this macro will evaluate to \"symbol\", \"symbol-1\", \"symbol-2\", etc." - (let ((g-name (gensym)) - (g-duplicate (gensym))) + (cl-with-gensyms (g-name g-duplicate) `(let* ((,g-name ,name) (,g-duplicate (assoc ,g-name ,names-and-numbers))) (if (null ,g-duplicate) diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index d4370366b39..aec2c92ba81 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -617,7 +617,7 @@ This macro is used to test if macroexpansion in `should' works." (should (ert--special-operator-p 'if)) (should-not (ert--special-operator-p 'car)) (should-not (ert--special-operator-p 'ert--special-operator-p)) - (let ((b (cl-gensym))) + (cl-with-gensyms (b) (should-not (ert--special-operator-p b)) (fset b 'if) (should (ert--special-operator-p b)))) diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el index e4641cfc4e5..86adcbf3a30 100644 --- a/test/lisp/kmacro-tests.el +++ b/test/lisp/kmacro-tests.el @@ -24,6 +24,7 @@ ;;; Code: (require 'kmacro) +(require 'cl-lib) (require 'seq) (require 'ert) (require 'ert-x) @@ -157,8 +158,7 @@ Execute BODY, then check that the string VALUE was inserted into the current buffer at point." (declare (debug (stringp body)) (indent 1)) - (let ((g-p (cl-gensym)) - (g-bsize (cl-gensym))) + (cl-with-gensyms (g-p g-bsize) `(let ((,g-p (point)) (,g-bsize (buffer-size))) ,@body @@ -172,7 +172,7 @@ VALUE and any text written to *Messages* during the execution, cause the current test to fail." (declare (debug (form body)) (indent 1)) - (let ((g-captured-messages (cl-gensym))) + (cl-with-gensyms (g-captured-messages) `(ert-with-message-capture ,g-captured-messages ,@body (should (string-match-p ,value ,g-captured-messages))))) diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index 51f7ddb25f0..fd3ecda2b72 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -528,8 +528,7 @@ then replace 3 matches of FROM with TO, and undo the last replacement. Return the last evalled form in BODY." (declare (indent 5) (debug (stringp stringp stringp form characterp body))) - (let ((text (gensym "text")) - (count (gensym "count"))) + (cl-with-gensyms (text count) `(let* ((,text ,input) (,count 0) (inhibit-message t)) commit 7bb53815d2bcc7af8bc613e67e2aeb4ec01db901 Author: João Távora Date: Mon Feb 24 19:12:21 2025 +0000 Eglot: add out-of-box support for neocmakelsp * lisp/progmodes/eglot.el (eglot-server-programs): Add neocmakelsp. diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index f0891e700a8..a380e352a15 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -243,7 +243,8 @@ automatically)." ;; those entries can be simplified, but we keep them for when ;; `eglot.el' is installed via GNU ELPA in an older Emacs. `(((rust-ts-mode rust-mode) . ("rust-analyzer")) - ((cmake-mode cmake-ts-mode) . ("cmake-language-server")) + ((cmake-mode cmake-ts-mode) + . ,(eglot-alternatives '(("neocmakelsp" "cmake-language-server")))) (vimrc-mode . ("vim-language-server" "--stdio")) ((python-mode python-ts-mode) . ,(eglot-alternatives commit e4c911adeaa679a92fab58b196b27c502aaed2f3 Author: João Távora Date: Sun Feb 16 18:27:48 2025 +0000 Eglot: use eglot-advertise-cancellation in more situations The async requests frequently issued by ElDoc are a significant source of request pile-up on the server side (for some servers). With this change, Eglot will issue additional LSP $/cancelRequest notifications for in-flight requests of certain kinds in the pre-command hook. This required a small change to the 'jsonrpc-async-request' entrypoint. This feature is experimental. * lisp/jsonrpc.el (jsonrpc-async-request): No longer returns nil. * lisp/progmodes/eglot.el (eglot--inflight-async-requests): New variable. (eglot--cancel-inflight-async-requests): New function. (eglot--async-request): New function. (eglot--pre-command-hook): Call eglot--cancel-inflight-async-requests. (eglot-signature-eldoc-function, eglot-hover-eldoc-function) (eglot-highlight-eldoc-function, eglot-code-action-suggestion): Use eglot--async-request. diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index be9f4917e80..c5a099af8ec 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -377,9 +377,9 @@ never be sent at all, in case it is overridden in the meantime by a new request with identical DEFERRED and for the same buffer. However, in that situation, the original timeout is kept. -Returns nil." - (apply #'jsonrpc--async-request-1 connection method params args) - nil) +Returns a list whose first element is an integer identifying the request +as specified in the JSONRPC 2.0 spec." + (apply #'jsonrpc--async-request-1 connection method params args)) (cl-defun jsonrpc-request (connection method params &key diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index df93f899069..f0891e700a8 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -1832,6 +1832,62 @@ Unless IMMEDIATE, send pending changes before making request." (cancel-on-input)) :cancel-on-input-retval cancel-on-input-retval)) +(defvar-local eglot--inflight-async-requests nil + "An plist of symbols to lists of JSONRPC ids. +The ids designate in-flight asynchronous requests that may be cancelled +according to `eglot-advertise-cancellation'.") + +(cl-defun eglot--cancel-inflight-async-requests + (&optional (hints '(:textDocument/signatureHelp + :textDocument/hover + :textDocument/documentHighlight + :textDocument/codeAction))) + (when-let* ((server (and hints + eglot-advertise-cancellation + (eglot-current-server)))) + (dolist (hint hints) + (dolist (id (plist-get eglot--inflight-async-requests hint)) + ;; FIXME: in theory, as `jsonrpc-async-request' explains, this + ;; request may never have been sent at all. But that's rare, and + ;; it's only a problem if the server borks on cancellation of + ;; never-sent requests. + (jsonrpc-notify server '$/cancelRequest `(:id ,id))) + (cl-remf eglot--inflight-async-requests hint)))) + +(cl-defun eglot--async-request (server + method + params + &key + (success-fn nil success-fn-supplied-p) + (error-fn nil error-fn-supplied-p) + (timeout-fn nil timeout-fn-supplied-p) + (timeout nil timeout-supplied-p) + hint + &aux moreargs) + "Like `jsonrpc-async-request', but for Eglot LSP requests. +HINT argument is a symbol passed as DEFERRED to `jsonrpc-async-request' +and also used as a hint of the request cancellation mechanism (see +`eglot-advertise-cancellation')." + (cl-labels ((clearing-fn (fn) + (lambda (&rest args) + (when fn (apply fn args)) + (cl-remf eglot--inflight-async-requests hint)))) + (eglot--cancel-inflight-async-requests (list hint)) + (when timeout-supplied-p + (setq moreargs (nconc `(:timeout ,timeout) moreargs))) + (when hint + (setq moreargs (nconc `(:deferred ,hint) moreargs))) + (let ((id + (car (apply #'jsonrpc-async-request + server method params + :success-fn (clearing-fn success-fn) + :error-fn (clearing-fn error-fn) + :timeout-fn (clearing-fn timeout-fn) + moreargs)))) + (when (and hint eglot-advertise-cancellation) + (push id + (plist-get eglot--inflight-async-requests hint)))))) + ;;; Encoding fever ;;; @@ -2799,8 +2855,9 @@ buffer." "Cache of `workspace/Symbol' results used by `xref-find-definitions'.") (defun eglot--pre-command-hook () - "Reset some temporary variables." + "Reset some state." (clrhash eglot--workspace-symbols-cache) + (eglot--cancel-inflight-async-requests) (setq eglot--last-inserted-char nil)) (defun eglot--CompletionParams () @@ -3644,7 +3701,7 @@ for which LSP on-type-formatting should be requested." "A member of `eldoc-documentation-functions', for signatures." (when (eglot-server-capable :signatureHelpProvider) (let ((buf (current-buffer))) - (jsonrpc-async-request + (eglot--async-request (eglot--current-server-or-lose) :textDocument/signatureHelp (eglot--TextDocumentPositionParams) :success-fn @@ -3661,14 +3718,14 @@ for which LSP on-type-formatting should be requested." nil)) signatures "\n") :echo (eglot--sig-info active-sig activeParameter t)))))) - :deferred :textDocument/signatureHelp)) + :hint :textDocument/signatureHelp)) t)) (defun eglot-hover-eldoc-function (cb &rest _ignored) "A member of `eldoc-documentation-functions', for hover." (when (eglot-server-capable :hoverProvider) (let ((buf (current-buffer))) - (jsonrpc-async-request + (eglot--async-request (eglot--current-server-or-lose) :textDocument/hover (eglot--TextDocumentPositionParams) :success-fn (eglot--lambda ((Hover) contents range) @@ -3677,7 +3734,7 @@ for which LSP on-type-formatting should be requested." (eglot--hover-info contents range)))) (funcall cb info :echo (and info (string-match "\n" info)))))) - :deferred :textDocument/hover)) + :hint :textDocument/hover)) t)) (defun eglot-highlight-eldoc-function (_cb &rest _ignored) @@ -3687,7 +3744,7 @@ for which LSP on-type-formatting should be requested." ;; ignore cb and return nil to say "no doc". (when (eglot-server-capable :documentHighlightProvider) (let ((buf (current-buffer))) - (jsonrpc-async-request + (eglot--async-request (eglot--current-server-or-lose) :textDocument/documentHighlight (eglot--TextDocumentPositionParams) :success-fn @@ -3705,7 +3762,7 @@ for which LSP on-type-formatting should be requested." `(,(lambda (o &rest _) (delete-overlay o)))) ov))) highlights)))) - :deferred :textDocument/documentHighlight) + :hint :textDocument/documentHighlight) nil))) (defun eglot--imenu-SymbolInformation (res) @@ -4031,7 +4088,7 @@ at point. With prefix argument, prompt for ACTION-KIND." (bounds (eglot--code-action-bounds)) (use-text-p (memq 'eldoc-hint eglot-code-action-indications)) tooltip blurb) - (jsonrpc-async-request + (eglot--async-request (eglot--current-server-or-lose) :textDocument/codeAction (eglot--code-action-params :beg (car bounds) :end (cadr bounds) @@ -4071,7 +4128,7 @@ at point. With prefix argument, prompt for ACTION-KIND." ,tooltip))))) (setq eglot--suggestion-overlay ov))))) (when use-text-p (funcall cb blurb))) - :deferred :textDocument/codeAction) + :hint :textDocument/codeAction) (and use-text-p t)))) commit 0ac0f355e50639fb2cdacb6cbfca696d5592a89e Author: F. Jason Park Date: Sun Feb 23 21:00:57 2025 -0800 ; Tag all erc-nicks-track-faces tests as :unstable * test/lisp/erc/erc-nicks-tests.el (erc-nicks-track-faces/prioritize): Tag as :unstable, regardless of environment, pending further investigation. This has reportedly failed on Emacs 31 and Emacs 28. (erc-nicks-track-faces/defer, erc-nicks-track-faces/nil): Tag as :unstable even though there haven't been any reported failures as yet. (erc-nicks-track-faces/t): Likewise. This test has failed on Emacs 31 on a GitLab.com runner. (Bug#76188) diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index 805c41e7023..92960d79d6f 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -615,7 +615,7 @@ (erc-tests-common-kill-buffers)) (ert-deftest erc-nicks-track-faces/prioritize () - :tags (and (null (getenv "CI")) '(:unstable)) + :tags '(:unstable) (should (eq erc-nicks-track-faces 'prioritize)) (erc-nicks-tests--track-faces @@ -683,6 +683,7 @@ (funcall assert-result '(7 . erc-notice-face))))) (ert-deftest erc-nicks-track-faces/defer () + :tags '(:unstable) (when (< emacs-major-version 28) (ert-skip "Possible intermittent failures on 27")) @@ -751,6 +752,8 @@ (funcall assert-result '(7 . erc-notice-face)))))) (ert-deftest erc-nicks-track-faces/nil () + :tags '(:unstable) + (should (eq erc-nicks-track-faces 'prioritize)) (let (erc-nicks-track-faces) (erc-nicks-tests--track-faces @@ -795,6 +798,8 @@ (funcall assert-result '(5 . erc-notice-face)))))) (ert-deftest erc-nicks-track-faces/t () + :tags '(:unstable) + (should (eq erc-nicks-track-faces 'prioritize)) (let ((erc-nicks-track-faces t)) (erc-nicks-tests--track-faces commit 363adcc69d322bdede1934b47e9dd1fbc3148ab9 Author: Mauro Aranda Date: Mon Feb 24 19:39:43 2025 -0300 Fix bad fontification of inactive widgets * lisp/wid-edit.el (widget-specify-inactive): When a widget is already inactive, still move the overlay to the desired positions. Improve docstring. (Bug#69941) * doc/misc/widget.texi (default): Document the need to call the :deactivate function when modifying an inactive widget. * test/lisp/wid-edit-tests.el (widget-test-modification-of-inactive-widget): New test diff --git a/doc/misc/widget.texi b/doc/misc/widget.texi index 68d53a42025..f84e81bce77 100644 --- a/doc/misc/widget.texi +++ b/doc/misc/widget.texi @@ -1333,6 +1333,9 @@ modifications. Function that takes a widget and makes it inactive for user modifications. +If you modify a widget that is not active, you should make sure the +:deactivate function gets called again after the modifications. + @vindex action@r{ keyword} @item :action Function that takes a widget and optionally an event, and handles a diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 38d065a7d65..38c8d34792a 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -549,8 +549,15 @@ With CHECK-AFTER non-nil, considers also the content after point, if needed." :group 'widget-faces) (defun widget-specify-inactive (widget from to) - "Make WIDGET inactive for user modifications." - (unless (widget-get widget :inactive) + "Make WIDGET inactive for user modifications. + +If WIDGET is already inactive, moves the :inactive overlay to the positions +indicated by FROM and TO, either numbers or markers. + +If WIDGET is not inactive, creates an overlay that spans from FROM to TO, +and saves that overlay under the :inactive property for WIDGET." + (if (widget-get widget :inactive) + (move-overlay (widget-get widget :inactive) from to) (let ((overlay (make-overlay from to nil t nil))) (overlay-put overlay 'face 'widget-inactive) ;; This is disabled, as it makes the mouse cursor change shape. diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el index e34aa64f8d1..755bd12201f 100644 --- a/test/lisp/wid-edit-tests.el +++ b/test/lisp/wid-edit-tests.el @@ -481,4 +481,18 @@ markers (and so on) as well." (should (= ofrom2 (widget-get group2 :from))) (should (= oto2 (widget-get group2 :to)))))) +(ert-deftest widget-test-modification-of-inactive-widget () + "Test that modifications to an inactive widget keep all of it inactive." + (with-temp-buffer + (let* ((radio (widget-create 'radio-button-choice + '(item "One") '(item "Two") '(item "Confirm"))) + (from (widget-get radio :from)) + (to (widget-get radio :to)) + (ov (progn (widget-apply radio :deactivate) + (widget-get radio :inactive)))) + (widget-value-set radio "") + (widget-apply radio :deactivate) + (should (= (overlay-start ov) from)) + (should (= (overlay-end ov) to))))) + ;;; wid-edit-tests.el ends here commit 60232a30e360c00fb303cb033d4aec15a9e41342 Author: Stefan Kangas Date: Mon Feb 24 22:37:17 2025 +0100 ; Set :version on recently changed user option * lisp/vc/vc-hooks.el (vc-directory-exclusion-list): Set :version. diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index d6dcf9d421b..e1513eed33a 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -127,7 +127,8 @@ An empty list disables VC altogether." ".jj") "List of directory names to be ignored when walking directory trees." :type '(repeat string) - :group 'vc) + :group 'vc + :version "31.1") (defcustom vc-make-backup-files nil "If non-nil, backups of registered files are made as with other files. commit 706970fc25de34fd63c21bed13e31e96ae258a28 Author: Stefan Kangas Date: Tue Feb 11 18:51:43 2025 +0100 Add Obsolete-since header to hashcash.el * lisp/obsolete/hashcash.el: Add Obsolete-since header. (Bug#76195) diff --git a/etc/NEWS b/etc/NEWS index 59daecba5d3..ed4c09f1274 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1320,6 +1320,10 @@ change the selection rules. *** cdl.el is now obsolete. Use 'shell-command' and 'shell-command-on-region' instead. +--- +*** hashcash.el is now obsolete. +It is believed to no longer be useful as a method to fight spam. + --- *** kermit.el is now obsolete. diff --git a/lisp/obsolete/hashcash.el b/lisp/obsolete/hashcash.el index fac336bb6cc..cd111b8d8c5 100644 --- a/lisp/obsolete/hashcash.el +++ b/lisp/obsolete/hashcash.el @@ -5,6 +5,7 @@ ;; Written by: Paul Foley (1997-2002) ;; Maintainer: emacs-devel@gnu.org ;; Keywords: mail, hashcash +;; Obsolete-since: 31.1 ;; This file is part of GNU Emacs. commit 074b32d53f7a8c590895d49faf0f157aa800544e Author: Stefan Kangas Date: Tue Feb 11 18:49:25 2025 +0100 Move hashcash.el to lisp/obsolete * lisp/mail/hashcash.el: Move from here... * lisp/obsolete/hashcash.el: ...to here. (Bug#76195) diff --git a/lisp/mail/hashcash.el b/lisp/obsolete/hashcash.el similarity index 100% rename from lisp/mail/hashcash.el rename to lisp/obsolete/hashcash.el commit 250f4214752d223981259e453c55a8c5cabb111a Author: Stefan Kangas Date: Tue Feb 11 18:47:27 2025 +0100 Drop hashcash support from Gnus and Message mode * lisp/gnus/gnus.el (gnus-install-group-spam-parameters): Remove 'spam-use-hashcash' option. * lisp/gnus/message.el (message-generate-hashcash): Mark as obsolete, default to nil unconditionally. (message-send-mail, message-setup-1, message-resend): Don't generate hashcash headers. * lisp/gnus/spam.el (hashcash): Don't require. (spam-use-hashcash): (spam-check-hashcash): Mark as obsolete. (spam-install-hooks): Don't install 'spam-use-hashcash' hook. * doc/misc/message.texi (Mail Headers): Don't document above obsoleted variable 'message-generate-hashcash'. * doc/misc/gnus.texi (Hashcash): Delete section. (Anti-spam Hashcash Payments): Delete subsection. (Extending the Spam package): Don't mention Hashcash. (Bug#76195) diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 239aa43703f..a239a8a628b 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -874,7 +874,6 @@ Thwarting Email Spam * The problem of spam:: Some background, and some solutions * Anti-Spam Basics:: Simple steps to reduce the amount of spam. * SpamAssassin:: How to use external anti-spam tools. -* Hashcash:: Reduce spam by burning CPU time. Spam Package @@ -892,7 +891,6 @@ Spam Back Ends * Blacklists and Whitelists:: * BBDB Whitelists:: * Gmane Spam Reporting:: -* Anti-spam Hashcash Payments:: * Blackholes:: * Regular Expressions Header Matching:: * Bogofilter:: @@ -24318,7 +24316,6 @@ This is annoying. Here's what you can do about it. * The problem of spam:: Some background, and some solutions * Anti-Spam Basics:: Simple steps to reduce the amount of spam. * SpamAssassin:: How to use external anti-spam tools. -* Hashcash:: Reduce spam by burning CPU time. @end menu @node The problem of spam @@ -24540,81 +24537,6 @@ spam. And here is the nifty function: (gnus-summary-mark-as-expirable 1)) @end lisp -@node Hashcash -@subsection Hashcash -@cindex hashcash - -One technique to fight spam is to require senders to do something -costly and demonstrably unique for each message they send. This has -the obvious drawback that you cannot rely on everyone in the world -using this technique, since it is not part of the Internet standards, -but it may be useful in smaller communities. - -While the tools in the previous section work well in practice, they -work only because the tools are constantly maintained and updated as -new form of spam appears. This means that a small percentage of spam -will always get through. It also means that somewhere, someone needs -to read lots of spam to update these tools. Hashcash avoids that, but -instead prefers that everyone you contact through e-mail supports the -scheme. You can view the two approaches as pragmatic vs dogmatic. -The approaches have their own advantages and disadvantages, but as -often in the real world, a combination of them is stronger than either -one of them separately. - -@cindex X-Hashcash -The ``something costly'' is to burn CPU time, more specifically to -compute a hash collision up to a certain number of bits. The -resulting hashcash cookie is inserted in a @samp{X-Hashcash:} header. -For more details, and for the external application @code{hashcash} you -need to install to use this feature, see -@uref{http://www.hashcash.org/}. - -If you wish to generate hashcash for each message you send, you can -customize @code{message-generate-hashcash} (@pxref{Mail Headers, ,Mail -Headers,message, The Message Manual}), as in: - -@lisp -(setq message-generate-hashcash t) -@end lisp - -You will need to set up some additional variables as well: - -@table @code - -@item hashcash-default-payment -@vindex hashcash-default-payment -This variable indicates the default number of bits the hash collision -should consist of. By default this is 20. Suggested useful values -include 17 to 29. - -@item hashcash-payment-alist -@vindex hashcash-payment-alist -Some receivers may require you to spend burn more CPU time than the -default. This variable contains a list of @samp{(@var{addr} -@var{amount})} cells, where @var{addr} is the receiver (email address -or newsgroup) and @var{amount} is the number of bits in the collision -that is needed. It can also contain @samp{(@var{addr} @var{string} -@var{amount})} cells, where the @var{string} is the string to use -(normally the email address or newsgroup name is used). - -@item hashcash-program -@vindex hashcash-program -Where the @code{hashcash} binary is installed. This variable should -be automatically set by @code{executable-find}, but if it's @code{nil} -(usually because the @code{hashcash} binary is not in your path) -you'll get a warning when you check hashcash payments and an error -when you generate hashcash payments. - -@end table - -Gnus can verify hashcash cookies, although this can also be done by -hand customized mail filtering scripts. To verify a hashcash cookie -in a message, use the @code{mail-check-payment} function in the -@code{hashcash.el} library. You can also use the @code{spam.el} -package with the @code{spam-use-hashcash} back end to validate hashcash -cookies in incoming mail and filter mail accordingly (@pxref{Anti-spam -Hashcash Payments}). - @node Spam Package @section Spam Package @cindex spam filtering @@ -25245,7 +25167,6 @@ Processors}). * Blacklists and Whitelists:: * BBDB Whitelists:: * Gmane Spam Reporting:: -* Anti-spam Hashcash Payments:: * Blackholes:: * Regular Expressions Header Matching:: * Bogofilter:: @@ -25441,23 +25362,6 @@ default is @code{user-mail-address}. @end defvar -@node Anti-spam Hashcash Payments -@subsubsection Anti-spam Hashcash Payments -@cindex spam filtering -@cindex hashcash, spam filtering -@cindex spam - -@defvar spam-use-hashcash - -Similar to @code{spam-use-whitelist} (@pxref{Blacklists and -Whitelists}), but uses hashcash tokens for whitelisting messages -instead of the sender address. Messages without a hashcash payment -token will be sent to the next spam-split rule. This is an explicit -filter, meaning that unless a hashcash token is found, the messages -are not assumed to be spam or ham. - -@end defvar - @node Blackholes @subsubsection Blackholes @cindex spam filtering @@ -26008,8 +25912,7 @@ such a back end. This function will install a back end that can only check incoming mail for spam contents. It can't register or unregister messages. -@code{spam-use-blackholes} and @code{spam-use-hashcash} are such -back ends. +@code{spam-use-blackholes} is such a back end. @item @code{spam-install-statistical-checkonly-backend} @@ -29060,8 +28963,6 @@ that are accessible from the article buffer. nnfolder archives. @item Gnus now supports the ``hashcash'' client puzzle anti-spam mechanism. -Use @code{(setq message-generate-hashcash t)} to enable. -@xref{Hashcash}. @item You can now drag and drop attachments to the Message buffer. See @code{mml-dnd-protocol-alist} and @code{mml-dnd-attach-options}. diff --git a/doc/misc/message.texi b/doc/misc/message.texi index 5cad78b4c48..1f8b04853e9 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -1908,13 +1908,6 @@ Regexp of headers to be removed before mailing. The default is@* This string is inserted at the end of the headers in all message buffers that are initialized as mail. -@item message-generate-hashcash -@vindex message-generate-hashcash -Variable that indicates whether @samp{X-Hashcash} headers -should be computed for the message. @xref{Hashcash, ,Hashcash,gnus, -The Gnus Manual}. If @code{opportunistic}, only generate the headers -when it doesn't lead to the user having to wait. - @end table diff --git a/etc/NEWS b/etc/NEWS index 763ff2206ac..59daecba5d3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -606,6 +606,11 @@ behavior included additional information about the originating message. The new variable 'message-header-use-obsolete-in-reply-to', nil by default, can be set to a non-nil value to restore the previous behavior. ++++ +*** Hashcash support has been removed. +It is believed to no longer be useful as a method to fight spam. The +'message-generate-hashcash' option is now obsolete and has no effect. + ** Gnus --- @@ -614,6 +619,11 @@ When called with a prefix argument, accepting, declining, or tentatively accepting an icalendar event will prompt for a comment to add to the response. ++++ +*** Hashcash support has been removed. +It is believed to no longer be useful as a method to fight spam. The +'spam-use-hashcash' hook is now obsolete and has no effect. + ** Sieve +++ diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 37db8a96fa1..6fad088a6c9 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1925,7 +1925,6 @@ spam-autodetect-recheck-messages is set.") (variable-item spam-use-bsfilter-headers) (variable-item spam-use-stat) (variable-item spam-use-blackholes) - (variable-item spam-use-hashcash) (variable-item spam-use-bogofilter-headers) (variable-item spam-use-bogofilter))) :function-document @@ -1958,7 +1957,6 @@ set." (variable-item spam-use-crm114) (variable-item spam-use-stat) (variable-item spam-use-blackholes) - (variable-item spam-use-hashcash) (variable-item spam-use-spamassassin) (variable-item spam-use-spamassassin-headers) (variable-item spam-use-bsfilter) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index cbb892f84cb..a7f27fe1021 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -1945,7 +1945,7 @@ no, only reply back to the author." (const :tag "Never" nil) (const :tag "Always" t))) -(defcustom message-generate-hashcash (if (executable-find "hashcash") 'opportunistic) +(defcustom message-generate-hashcash nil "Whether to generate X-Hashcash: headers. If t, always generate hashcash headers. If `opportunistic', only generate hashcash headers if it can be done without the user @@ -1959,6 +1959,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-program'." :type '(choice (const :tag "Always" t) (const :tag "Never" nil) (const :tag "Opportunistic" opportunistic))) +(make-obsolete-variable 'message-generate-hashcash "it does nothing." "31.1") ;;; Internal variables. @@ -4834,8 +4835,6 @@ Valid types are `send', `return', `exit', `kill' and `postpone'." (erase-buffer))) (kill-buffer tembuf)))) -(declare-function hashcash-wait-async "hashcash" (&optional buffer)) - (defun message--check-continuation-headers () (message-check 'continuation-headers (goto-char (point-min)) @@ -4905,16 +4904,6 @@ If you always want Gnus to send messages in one piece, set message-posting-charset)) (headers message-required-mail-headers) options) - (when (and message-generate-hashcash - (not (eq message-generate-hashcash 'opportunistic))) - (message "Generating hashcash...") - (require 'hashcash) - ;; Wait for calculations already started to finish... - (hashcash-wait-async) - ;; ...and do calculations not already done. mail-add-payment - ;; will leave existing X-Hashcash headers alone. - (mail-add-payment) - (message "Generating hashcash...done")) (save-restriction (message-narrow-to-headers) ;; Generate the Mail-Followup-To header if the header is not there... @@ -6967,9 +6956,6 @@ are not included." (message-narrow-to-headers) (run-hooks 'message-header-setup-hook)) (setq buffer-undo-list nil) - (when message-generate-hashcash - ;; Generate hashcash headers for recipients already known - (mail-add-payment-async)) ;; Gnus posting styles are applied via buffer-local `message-setup-hook' ;; values. (run-hooks 'message-setup-hook) @@ -8023,7 +8009,6 @@ is for the internal use." (let ((inhibit-read-only t)) (erase-buffer))) (let ((message-this-is-mail t) - message-generate-hashcash message-setup-hook) (message-setup `((To . ,address)))) ;; Insert our usual headers. @@ -8072,7 +8057,6 @@ is for the internal use." (sendmail-coding-system 'raw-text) (select-safe-coding-system-function nil) message-required-mail-headers - message-generate-hashcash rfc2047-encode-encoded-words ;; If `message-sendmail-envelope-from' is `header' then ;; the envelope-from will be the original sender's diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 983e82cb028..14abaf83ff2 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -4,7 +4,7 @@ ;; Author: Lars Magne Ingebrigtsen ;; Maintainer: Ted Zlatanov -;; Keywords: network, spam, mail, bogofilter, BBDB, dspam, dig, whitelist, blacklist, gmane, hashcash, spamassassin, bsfilter, ifile, stat, crm114, spamoracle +;; Keywords: network, spam, mail, bogofilter, BBDB, dspam, dig, whitelist, blacklist, gmane, spamassassin, bsfilter, ifile, stat, crm114, spamoracle ;; This file is part of GNU Emacs. @@ -46,8 +46,7 @@ (require 'dig) (eval-when-compile - (require 'cl-lib) - (require 'hashcash)) + (require 'cl-lib)) ;; autoload spam-report (autoload 'spam-report-gmane "spam-report") @@ -205,6 +204,7 @@ are considered spam." "Whether hashcash payments should be detected by `spam-split'." :type 'boolean :group 'spam) +(make-obsolete-variable 'spam-use-hashcash "it does nothing." "31.1") (defcustom spam-use-regex-headers nil "Whether a header regular expression match should be used by `spam-split'. @@ -294,7 +294,6 @@ them." spam-use-whitelist spam-use-whitelist-exclusive spam-use-blackholes - spam-use-hashcash spam-use-regex-headers spam-use-regex-body spam-use-bogofilter @@ -1014,9 +1013,6 @@ backends)." (spam-install-checkonly-backend 'spam-use-blackholes #'spam-check-blackholes) -(spam-install-checkonly-backend 'spam-use-hashcash - #'spam-check-hashcash) - (spam-install-checkonly-backend 'spam-use-spamassassin-headers #'spam-check-spamassassin-headers) @@ -2022,8 +2018,11 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;;{{{ Hashcash. +(declare-function mail-check-payment "hashcash") (defun spam-check-hashcash () "Check the headers for hashcash payments." + (declare (obsolete nil "31.1")) + (require 'hashcash) (ignore-errors (mail-check-payment))) ;mail-check-payment returns a boolean ;;}}} commit 7d5fe06e79defb0669ef2ba34d644e0836e54a38 Author: Stefan Kangas Date: Mon Feb 24 22:21:46 2025 +0100 Make cl-declare obsolete * lisp/emacs-lisp/cl-macs.el (cl-declare): Make obsolete. * doc/misc/cl.texi (Declarations): Don't document above obsolete macro. (Bug#63288) diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index 8fb308e64a5..862b8f4a1c4 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -60,7 +60,7 @@ modify this GNU manual.'' * Predicates:: Type predicates and equality predicates. * Control Structure:: Assignment, conditionals, blocks, looping. * Macros:: Destructuring, compiler macros. -* Declarations:: @code{cl-proclaim}, @code{cl-declare}, etc. +* Declarations:: @code{cl-proclaim}, @code{cl-declaim}, etc. * Symbols:: Property lists, creating symbols. * Numbers:: Predicates, functions, random numbers. * Sequences:: Mapping, functions, searching, sorting. @@ -2652,8 +2652,7 @@ mechanism that allows you to give the compiler special hints about the types of data that will be stored in particular variables, and about the ways those variables and functions will be used. This package defines versions of all the Common Lisp declaration forms: -@code{declare}, @code{locally}, @code{proclaim}, @code{declaim}, -and @code{the}. +@code{proclaim}, @code{declaim}, and @code{the}. Most of the Common Lisp declarations are not currently useful in Emacs Lisp. For example, the byte-code system provides little @@ -2683,15 +2682,6 @@ compiler treats the rest of the file that contains the @code{cl-declaim} form.) @end defmac -@defmac cl-declare decl-specs@dots{} -This macro is used to make declarations within functions and other -code. Common Lisp allows declarations in various locations, generally -at the beginning of any of the many ``implicit @code{progn}s'' -throughout Lisp syntax, such as function bodies, @code{let} bodies, -etc. Currently the only declaration understood by @code{cl-declare} -is @code{special}. -@end defmac - @defmac cl-the type form @code{cl-the} returns the value of @code{form}, first checking (if optimization settings permit) that it is of type @code{type}. Future @@ -2707,8 +2697,8 @@ For now, Emacs Lisp will treat the above code as exactly equivalent to @code{(mapcar 'car foo)}. @end defmac -Each @var{decl-spec} in a @code{cl-proclaim}, @code{cl-declaim}, or -@code{cl-declare} should be a list beginning with a symbol that says +Each @var{decl-spec} in a @code{cl-proclaim} or @code{cl-declaim} +should be a list beginning with a symbol that says what kind of declaration it is. This package currently understands @code{special}, @code{inline}, @code{notinline}, @code{optimize}, and @code{warn} declarations. (The @code{warn} declaration is an @@ -2726,9 +2716,6 @@ bound in the body of the function. The compiler normally emits warnings for such references, since they could be typographical errors for references to local variables. -The declaration @code{(cl-declare (special @var{var1} @var{var2}))} is -equivalent to @code{(defvar @var{var1}) (defvar @var{var2})}. - In top-level contexts, it is generally better to write @code{(defvar @var{var})} than @code{(cl-declaim (special @var{var}))}, since @code{defvar} makes your intentions clearer. @@ -2760,12 +2747,6 @@ request that a function you have defined should be inlined, but it is impolite to use it to request inlining of an external function. -In Common Lisp, it is possible to use @code{(declare (inline @dots{}))} -before a particular call to a function to cause just that call to -be inlined; the current byte compilers provide no way to implement -this, so @code{(cl-declare (inline @dots{}))} is currently ignored by -this package. - @item notinline The @code{notinline} declaration lists functions which should not be inlined after all; it cancels a previous @code{inline} @@ -2800,12 +2781,7 @@ Emacs itself, Emacs will not crash with a segmentation fault just because of an error in a fully-optimized Lisp program. The @code{optimize} declaration is normally used in a top-level -@code{cl-proclaim} or @code{cl-declaim} in a file; Common Lisp allows -it to be used with @code{declare} to set the level of optimization -locally for a given form, but this will not work correctly with the -current byte-compiler. (The @code{cl-declare} -will set the new optimization level, but that level will not -automatically be unset after the enclosing form is done.) +@code{cl-proclaim} or @code{cl-declaim} in a file. @item warn This declaration controls what sorts of warnings are generated diff --git a/etc/NEWS b/etc/NEWS index 4c0cff8ac7c..763ff2206ac 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -537,6 +537,9 @@ Such bindings make it possible to compute which function to bind to FUNC. *** 'cl-locally' is now obsolete. It is an alias for the 'progn' special-form. ++++ +*** 'cl-declare' is now obsolete; use 'defvar' instead. + ** Whitespace --- diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 1578603cedd..dbaa0d9bcb8 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2728,6 +2728,7 @@ For instance will turn off byte-compile warnings in the function. See Info node `(cl)Declarations' for details." + (declare (obsolete defvar "31.1")) (if (macroexp-compiling-p) (while specs (if (listp cl--declare-stack) (push (car specs) cl--declare-stack)) commit c9e681aa0c75feaf1c0a5495b0d475698cbdb653 Author: Stefan Kangas Date: Mon Feb 24 20:25:01 2025 +0100 Move buffer related functions from ert-x.el to ert.el * lisp/emacs-lisp/ert-x.el (ert--text-button) (ert--format-test-buffer-name, ert--test-buffers) (ert--test-buffer-button, ert--test-buffer-button-action) (ert--call-with-test-buffer, ert-with-test-buffer) (ert-with-buffer-selected, ert-kill-all-test-buffers) (ert-call-with-buffer-renamed, ert-buffer-string-reindented): Move from here... * lisp/emacs-lisp/ert.el (ert--text-button) (ert--format-test-buffer-name, ert--test-buffers) (ert--test-buffer-button, ert--test-buffer-button-action) (ert--call-with-test-buffer, ert-with-test-buffer) (ert-kill-all-test-buffers, ert-with-buffer-selected) (ert-call-with-buffer-renamed, ert-with-buffer-renamed): ...to here. * doc/misc/ert.texi (Helpers for Buffers): Break out new section... (Helper Functions): ...from here. * lisp/emacs-lisp/ert-x.el (ert-with-test-buffer-selected): Move obsolete definition to the end of the file. * test/lisp/emacs-lisp/ert-x-tests.el (ert--hash-table-to-alist, ert-test-test-buffers) (ert-test-with-buffer-selected/current) (ert-test-with-buffer-selected/selected) (ert-test-with-buffer-selected/nil-buffer) (ert-test-with-buffer-selected/modification-hooks) (ert-test-with-buffer-selected/read-only) (ert-test-with-buffer-selected/return-value) (ert-test-with-test-buffer-selected/modification-hooks) (ert-test-with-test-buffer-selected/read-only) (ert-test-with-test-buffer-selected/return-value) (ert-test-with-test-buffer-selected/buffer-name): Move tests from here... * test/lisp/emacs-lisp/ert-tests.el (ert--hash-table-to-alist, ert-test-test-buffers) (ert-test-with-buffer-selected/current) (ert-test-with-buffer-selected/selected) (ert-test-with-buffer-selected/nil-buffer) (ert-test-with-buffer-selected/modification-hooks) (ert-test-with-buffer-selected/read-only) (ert-test-with-buffer-selected/return-value) (ert-test-with-test-buffer-selected/selected) (ert-test-with-test-buffer-selected/modification-hooks) (ert-test-with-test-buffer-selected/read-only) (ert-test-with-test-buffer-selected/return-value) (ert-test-with-test-buffer-selected/buffer-name): ...to here. * test/lisp/progmodes/hideshow-tests.el (ert-x): * test/lisp/simple-tests.el (ert-x): * test/lisp/whitespace-tests.el (ert-x): Don't require. diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi index c15df506089..116631ce727 100644 --- a/doc/misc/ert.texi +++ b/doc/misc/ert.texi @@ -535,6 +535,7 @@ help ERT find the defining call to the macro by putting the property * Useful Techniques:: Some examples. * erts files:: Files containing many buffer tests. * Syntax Highlighting Tests:: Tests for face assignment. +* Helpers for Buffers:: Dealing with buffers during tests. * Helper Functions:: Various helper functions. @end menu @@ -1085,13 +1086,20 @@ macros accept the same keyword parameters as @code{ert-deftest} i.e., @code{:tag} and @code{:expected-result}. -@node Helper Functions -@section Various Helper Functions +@node Helpers for Buffers +@section Handling Buffers during tests -The package @file{ert-x.el} contains some macros and functions useful -for writing tests. +ERT comes with some macros for dealing with buffers used when testing. -@subsection Test Buffers +@subsection Creating temporary buffers + +@findex ert-kill-all-test-buffers +The @code{ert-with-test-buffer} macro can be used to create a temporary +buffer during a test, which is cleaned up automatically if the test is +successful. But if the test fails, the buffer stays around so that you +can more easily investigate the test failure. When you are done, you +can use the command @code{ert-kill-all-test-buffers} to kill all test +buffers that have been created by this macro. @defmac ert-with-test-buffer ((&key ((:name name-form :selected select-form))) &body body) This macro creates a test buffer and runs @var{body} in that buffer. If @@ -1144,9 +1152,7 @@ value is the last form in @var{body}. Example: This displays a temporary buffer like @file{ *temp*-739785*}. @end defmac -@defun ert-kill-all-test-buffers () -It kills all test buffers that are still live. -@end defun +@subsection Protecting buffers @defmac ert-with-buffer-renamed ((buffer-name-form) &body body) This macro protects the buffer @var{buffer-name} from side-effects and @@ -1163,6 +1169,13 @@ buffer with a fixed name such as @file{*Messages*}. Example: @end lisp @end defmac + +@node Helper Functions +@section Various Helper Functions + +The package @file{ert-x.el} contains some macros and functions useful +for writing tests. + @defmac ert-with-message-capture (var &rest body) This macro executes @var{body} while collecting messages in @var{var}. It captures messages issued by Lisp code and concatenates them separated diff --git a/etc/NEWS b/etc/NEWS index 29abfaf1126..4c0cff8ac7c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1408,6 +1408,17 @@ and signal an error if they are given a non-number. They return non-nil if an integer is odd or even, respectively, and signal an error if they are given a non-integer. +** ERT + +*** Some experimental ERT macros are now considered stable. +The following macros, previously only available in the experimental +'ert-x' module, are now considered stable and have been moved to 'ert': +- ert-with-test-buffer +- ert-with-buffer-selected +- ert-with-buffer-renamed + +See the ERT manual for more information. + ** Time & Date +++ diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 1c189a7c5ed..38f98029891 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -32,135 +32,6 @@ (require 'ert) (require 'subr-x) - -;;; Test buffers. - -(defun ert--text-button (string &rest properties) - "Return a string containing STRING as a text button with PROPERTIES. - -See `make-text-button'." - (with-temp-buffer - (insert string) - (apply #'make-text-button (point-min) (point-max) properties) - (buffer-string))) - -(defun ert--format-test-buffer-name (base-name) - "Compute a test buffer name based on BASE-NAME. - -Helper function for `ert--test-buffers'." - (format "*Test buffer (%s)%s*" - (or (and (ert-running-test) - (ert-test-name (ert-running-test))) - "") - (if base-name - (format ": %s" base-name) - ""))) - -(defvar ert--test-buffers (make-hash-table :weakness t) - "Table of all test buffers. Keys are the buffer objects, values are t. - -The main use of this table is for `ert-kill-all-test-buffers'. -Not all buffers in this table are necessarily live, but all live -test buffers are in this table.") - -(define-button-type 'ert--test-buffer-button - 'action #'ert--test-buffer-button-action - 'help-echo "mouse-2, RET: Pop to test buffer") - -(defun ert--test-buffer-button-action (button) - "Pop to the test buffer that BUTTON is associated with." - (pop-to-buffer (button-get button 'ert--test-buffer))) - -(defun ert--call-with-test-buffer (ert--base-name ert--thunk) - "Helper function for `ert-with-test-buffer'. - -Create a test buffer with a name based on ERT--BASE-NAME and run -ERT--THUNK with that buffer as current." - (let* ((ert--buffer (generate-new-buffer - (ert--format-test-buffer-name ert--base-name))) - (ert--button (ert--text-button (buffer-name ert--buffer) - :type 'ert--test-buffer-button - 'ert--test-buffer ert--buffer))) - (puthash ert--buffer 't ert--test-buffers) - ;; We don't use `unwind-protect' here since we want to kill the - ;; buffer only on success. - (prog1 (with-current-buffer ert--buffer - (ert-info (ert--button :prefix "Buffer: ") - (funcall ert--thunk))) - (kill-buffer ert--buffer) - (remhash ert--buffer ert--test-buffers)))) - -(cl-defmacro ert-with-test-buffer ((&key ((:name name-form)) - ((:selected select-form))) - &body body) - "Create a test buffer and run BODY in that buffer. - -To be used in ERT tests. If BODY finishes successfully, the test buffer -is killed; if there is an error, the test buffer is kept around for -further inspection. The name of the buffer is derived from the name of -the test and the result of NAME-FORM. - -If SELECT-FORM is non-nil, switch to the test buffer before running -BODY, as if body was in `ert-with-buffer-selected'. - -The return value is the last form in BODY." - (declare (debug ((":name" form) (":selected" form) def-body)) - (indent 1)) - `(ert--call-with-test-buffer - ,name-form - ,(if select-form - `(lambda () (ert-with-buffer-selected (current-buffer) - ,@body)) - `(lambda () ,@body)))) - -(cl-defmacro ert-with-buffer-selected (buffer-or-name &body body) - "Display a buffer in a temporary selected window and run BODY. - -If BUFFER-OR-NAME is nil, the current buffer is used. - -The buffer is made the current buffer, and the temporary window -becomes the `selected-window', before BODY is evaluated. The -modification hooks `before-change-functions' and -`after-change-functions' are not inhibited during the evaluation -of BODY, which makes it easier to use `execute-kbd-macro' to -simulate user interaction. The window configuration is restored -before returning, even if BODY exits nonlocally. The return -value is the last form in BODY." - (declare (debug (form body)) (indent 1)) - `(save-window-excursion - (with-current-buffer (or ,buffer-or-name (current-buffer)) - (with-selected-window (display-buffer (current-buffer)) - ,@body)))) - -(cl-defmacro ert-with-test-buffer-selected ((&key name) &body body) - "Create a test buffer, switch to it, and run BODY. - -This combines `ert-with-test-buffer' and `ert-with-buffer-selected'. -The return value is the last form in BODY." - (declare (obsolete ert-with-test-buffer "31.1") - (debug ((":name" form) body)) (indent 1)) - `(ert-with-test-buffer (:name ,name :selected t) - ,@body)) - -;;;###autoload -(defun ert-kill-all-test-buffers () - "Kill all test buffers that are still live." - (interactive) - (let ((count 0)) - (maphash (lambda (buffer _dummy) - (when (or (not (buffer-live-p buffer)) - (kill-buffer buffer)) - (incf count))) - ert--test-buffers) - (message "%s out of %s test buffers killed" - count (hash-table-count ert--test-buffers))) - ;; It could be that some test buffers were actually kept alive - ;; (e.g., due to `kill-buffer-query-functions'). I'm not sure what - ;; to do about this. For now, let's just forget them. - (clrhash ert--test-buffers) - nil) - - ;;; Simulate commands. (defun ert-simulate-command (command) @@ -275,37 +146,6 @@ structure with the plists in ARGS." (setq current-plist x)))) (buffer-string))) - -(defun ert-call-with-buffer-renamed (buffer-name thunk) - "Protect the buffer named BUFFER-NAME from side-effects and run THUNK. - -Renames the buffer BUFFER-NAME to a new temporary name, creates a -new buffer named BUFFER-NAME, executes THUNK, kills the new -buffer, and renames the original buffer back to BUFFER-NAME. - -This is useful if THUNK has undesirable side-effects on an Emacs -buffer with a fixed name such as *Messages*." - (let ((new-buffer-name (generate-new-buffer-name - (format "%s orig buffer" buffer-name)))) - (with-current-buffer (get-buffer-create buffer-name) - (rename-buffer new-buffer-name)) - (unwind-protect - (progn - (get-buffer-create buffer-name) - (funcall thunk)) - (when (get-buffer buffer-name) - (kill-buffer buffer-name)) - (with-current-buffer new-buffer-name - (rename-buffer buffer-name))))) - -(cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body) - "Protect the buffer named BUFFER-NAME from side-effects and run BODY. - -See `ert-call-with-buffer-renamed' for details." - (declare (indent 1)) - `(ert-call-with-buffer-renamed ,buffer-name-form (lambda () ,@body))) - - (defun ert-buffer-string-reindented (&optional buffer) "Return the contents of BUFFER after reindentation. @@ -571,6 +411,19 @@ The same keyword arguments are supported as in (format "/mock::%s" temporary-file-directory)))) "Temporary directory for remote file tests.") + +;;;; Obsolete + +(cl-defmacro ert-with-test-buffer-selected ((&key name) &body body) + "Create a test buffer, switch to it, and run BODY. + +This combines `ert-with-test-buffer' and `ert-with-buffer-selected'. +The return value is the last form in BODY." + (declare (obsolete ert-with-test-buffer "31.1") + (debug ((":name" form) body)) (indent 1)) + `(ert-with-test-buffer (:name ,name :selected t) + ,@body)) + (provide 'ert-x) ;;; ert-x.el ends here diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 178a29d073b..c57bd0a69e2 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -2992,6 +2992,152 @@ write erts files." (forward-line 1))) (nreverse specs)))) + +;;; Buffer related helpers + +(defun ert--text-button (string &rest properties) + "Return a string containing STRING as a text button with PROPERTIES. + +See `make-text-button'." + (with-temp-buffer + (insert string) + (apply #'make-text-button (point-min) (point-max) properties) + (buffer-string))) + +(defun ert--format-test-buffer-name (base-name) + "Compute a test buffer name based on BASE-NAME. + +Helper function for `ert--test-buffers'." + (format "*Test buffer (%s)%s*" + (or (and (ert-running-test) + (ert-test-name (ert-running-test))) + "") + (if base-name + (format ": %s" base-name) + ""))) + +(defvar ert--test-buffers (make-hash-table :weakness t) + "Table of all test buffers. Keys are the buffer objects, values are t. + +The main use of this table is for `ert-kill-all-test-buffers'. +Not all buffers in this table are necessarily live, but all live +test buffers are in this table.") + +(define-button-type 'ert--test-buffer-button + 'action #'ert--test-buffer-button-action + 'help-echo "mouse-2, RET: Pop to test buffer") + +(defun ert--test-buffer-button-action (button) + "Pop to the test buffer that BUTTON is associated with." + (pop-to-buffer (button-get button 'ert--test-buffer))) + +(defun ert--call-with-test-buffer (ert--base-name ert--thunk) + "Helper function for `ert-with-test-buffer'. + +Create a test buffer with a name based on ERT--BASE-NAME and run +ERT--THUNK with that buffer as current." + (let* ((ert--buffer (generate-new-buffer + (ert--format-test-buffer-name ert--base-name))) + (ert--button (ert--text-button (buffer-name ert--buffer) + :type 'ert--test-buffer-button + 'ert--test-buffer ert--buffer))) + (puthash ert--buffer 't ert--test-buffers) + ;; We don't use `unwind-protect' here since we want to kill the + ;; buffer only on success. + (prog1 (with-current-buffer ert--buffer + (ert-info (ert--button :prefix "Buffer: ") + (funcall ert--thunk))) + (kill-buffer ert--buffer) + (remhash ert--buffer ert--test-buffers)))) + +(cl-defmacro ert-with-test-buffer ((&key ((:name name-form)) + ((:selected select-form))) + &body body) + "Create a test buffer and run BODY in that buffer. + +To be used in ERT tests. If BODY finishes successfully, the test buffer +is killed; if there is an error, the test buffer is kept around for +further inspection. The name of the buffer is derived from the name of +the test and the result of NAME-FORM. + +If SELECT-FORM is non-nil, switch to the test buffer before running +BODY, as if body was in `ert-with-buffer-selected'. + +The return value is the last form in BODY." + (declare (debug ((":name" form) (":selected" form) def-body)) + (indent 1)) + `(ert--call-with-test-buffer + ,name-form + ,(if select-form + `(lambda () (ert-with-buffer-selected (current-buffer) + ,@body)) + `(lambda () ,@body)))) + +(defun ert-kill-all-test-buffers () + "Kill all test buffers that are still live." + (interactive) + (let ((count 0)) + (maphash (lambda (buffer _dummy) + (when (or (not (buffer-live-p buffer)) + (kill-buffer buffer)) + (incf count))) + ert--test-buffers) + (message "%s out of %s test buffers killed" + count (hash-table-count ert--test-buffers))) + ;; It could be that some test buffers were actually kept alive + ;; (e.g., due to `kill-buffer-query-functions'). I'm not sure what + ;; to do about this. For now, let's just forget them. + (clrhash ert--test-buffers) + nil) + +(cl-defmacro ert-with-buffer-selected (buffer-or-name &body body) + "Display a buffer in a temporary selected window and run BODY. + +If BUFFER-OR-NAME is nil, the current buffer is used. + +The buffer is made the current buffer, and the temporary window +becomes the `selected-window', before BODY is evaluated. The +modification hooks `before-change-functions' and +`after-change-functions' are not inhibited during the evaluation +of BODY, which makes it easier to use `execute-kbd-macro' to +simulate user interaction. The window configuration is restored +before returning, even if BODY exits nonlocally. The return +value is the last form in BODY." + (declare (debug (form body)) (indent 1)) + `(save-window-excursion + (with-current-buffer (or ,buffer-or-name (current-buffer)) + (with-selected-window (display-buffer (current-buffer)) + ,@body)))) + +(defun ert-call-with-buffer-renamed (buffer-name thunk) + "Protect the buffer named BUFFER-NAME from side-effects and run THUNK. + +Renames the buffer BUFFER-NAME to a new temporary name, creates a +new buffer named BUFFER-NAME, executes THUNK, kills the new +buffer, and renames the original buffer back to BUFFER-NAME. + +This is useful if THUNK has undesirable side-effects on an Emacs +buffer with a fixed name such as *Messages*." + (let ((new-buffer-name (generate-new-buffer-name + (format "%s orig buffer" buffer-name)))) + (with-current-buffer (get-buffer-create buffer-name) + (rename-buffer new-buffer-name)) + (unwind-protect + (progn + (get-buffer-create buffer-name) + (funcall thunk)) + (when (get-buffer buffer-name) + (kill-buffer buffer-name)) + (with-current-buffer new-buffer-name + (rename-buffer buffer-name))))) + +(cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body) + "Protect the buffer named BUFFER-NAME from side-effects and run BODY. + +See `ert-call-with-buffer-renamed' for details." + (declare (indent 1)) + `(ert-call-with-buffer-renamed ,buffer-name-form (lambda () ,@body))) + ;;; Obsolete (define-obsolete-function-alias 'ert-equal-including-properties diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index cd89536f6a0..d4370366b39 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -930,6 +930,97 @@ F failing-test (when noninteractive (kill-buffer buffer-name))))))) +(defun ert--hash-table-to-alist (table) + (let ((accu nil)) + (maphash (lambda (key value) + (push (cons key value) accu)) + table) + (nreverse accu))) + +(ert-deftest ert-test-test-buffers () + (let (buffer-1 + buffer-2) + (let ((test-1 + (make-ert-test + :name 'test-1 + :body (lambda () + (ert-with-test-buffer (:name "foo") + (should (string-match + "[*]Test buffer (ert-test-test-buffers): foo[*]" + (buffer-name))) + (setq buffer-1 (current-buffer)))))) + (test-2 + (make-ert-test + :name 'test-2 + :body (lambda () + (ert-with-test-buffer (:name "bar") + (should (string-match + "[*]Test buffer (ert-test-test-buffers): bar[*]" + (buffer-name))) + (setq buffer-2 (current-buffer)) + (ert-fail "fail for test")))))) + (let ((ert--test-buffers (make-hash-table :weakness t))) + (ert-run-tests `(member ,test-1 ,test-2) #'ignore) + (should (equal (ert--hash-table-to-alist ert--test-buffers) + `((,buffer-2 . t)))) + (should-not (buffer-live-p buffer-1)) + (should (buffer-live-p buffer-2)))))) + +(ert-deftest ert-test-with-buffer-selected/current () + (let ((origbuf (current-buffer))) + (ert-with-test-buffer () + (let ((buf (current-buffer))) + (should (not (eq buf origbuf))) + (with-current-buffer origbuf + (ert-with-buffer-selected buf + (should (eq (current-buffer) buf)))))))) + +(ert-deftest ert-test-with-buffer-selected/selected () + (ert-with-test-buffer () + (ert-with-buffer-selected (current-buffer) + (should (eq (window-buffer) (current-buffer)))))) + +(ert-deftest ert-test-with-buffer-selected/nil-buffer () + (ert-with-test-buffer () + (let ((buf (current-buffer))) + (ert-with-buffer-selected nil + (should (eq (window-buffer) buf)))))) + +(ert-deftest ert-test-with-buffer-selected/modification-hooks () + (ert-with-test-buffer () + (ert-with-buffer-selected (current-buffer) + (should (null inhibit-modification-hooks))))) + +(ert-deftest ert-test-with-buffer-selected/read-only () + (ert-with-test-buffer () + (ert-with-buffer-selected (current-buffer) + (should (null inhibit-read-only)) + (should (null buffer-read-only))))) + +(ert-deftest ert-test-with-buffer-selected/return-value () + (should (equal (ert-with-buffer-selected nil "foo") "foo"))) + +(ert-deftest ert-test-with-test-buffer-selected/selected () + (ert-with-test-buffer (:selected t) + (should (eq (window-buffer) (current-buffer))))) + +(ert-deftest ert-test-with-test-buffer-selected/modification-hooks () + (ert-with-test-buffer (:selected t) + (should (null inhibit-modification-hooks)))) + +(ert-deftest ert-test-with-test-buffer-selected/read-only () + (ert-with-test-buffer (:selected t) + (should (null inhibit-read-only)) + (should (null buffer-read-only)))) + +(ert-deftest ert-test-with-test-buffer-selected/return-value () + (should (equal (ert-with-test-buffer (:selected t) "foo") "foo"))) + +(ert-deftest ert-test-with-test-buffer-selected/buffer-name () + (should (equal (ert-with-test-buffer (:name "foo") (buffer-name)) + (ert-with-test-buffer (:name "foo" :selected t) + (buffer-name))))) + (provide 'ert-tests) ;;; ert-tests.el ends here diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index aa0edf47059..7b7abf1ba7e 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -46,97 +46,6 @@ (emacs-lisp-mode) (should-not (equal (ert-buffer-string-reindented) (buffer-string))))) -(defun ert--hash-table-to-alist (table) - (let ((accu nil)) - (maphash (lambda (key value) - (push (cons key value) accu)) - table) - (nreverse accu))) - -(ert-deftest ert-test-test-buffers () - (let (buffer-1 - buffer-2) - (let ((test-1 - (make-ert-test - :name 'test-1 - :body (lambda () - (ert-with-test-buffer (:name "foo") - (should (string-match - "[*]Test buffer (ert-test-test-buffers): foo[*]" - (buffer-name))) - (setq buffer-1 (current-buffer)))))) - (test-2 - (make-ert-test - :name 'test-2 - :body (lambda () - (ert-with-test-buffer (:name "bar") - (should (string-match - "[*]Test buffer (ert-test-test-buffers): bar[*]" - (buffer-name))) - (setq buffer-2 (current-buffer)) - (ert-fail "fail for test")))))) - (let ((ert--test-buffers (make-hash-table :weakness t))) - (ert-run-tests `(member ,test-1 ,test-2) #'ignore) - (should (equal (ert--hash-table-to-alist ert--test-buffers) - `((,buffer-2 . t)))) - (should-not (buffer-live-p buffer-1)) - (should (buffer-live-p buffer-2)))))) - -(ert-deftest ert-test-with-buffer-selected/current () - (let ((origbuf (current-buffer))) - (ert-with-test-buffer () - (let ((buf (current-buffer))) - (should (not (eq buf origbuf))) - (with-current-buffer origbuf - (ert-with-buffer-selected buf - (should (eq (current-buffer) buf)))))))) - -(ert-deftest ert-test-with-buffer-selected/selected () - (ert-with-test-buffer () - (ert-with-buffer-selected (current-buffer) - (should (eq (window-buffer) (current-buffer)))))) - -(ert-deftest ert-test-with-buffer-selected/nil-buffer () - (ert-with-test-buffer () - (let ((buf (current-buffer))) - (ert-with-buffer-selected nil - (should (eq (window-buffer) buf)))))) - -(ert-deftest ert-test-with-buffer-selected/modification-hooks () - (ert-with-test-buffer () - (ert-with-buffer-selected (current-buffer) - (should (null inhibit-modification-hooks))))) - -(ert-deftest ert-test-with-buffer-selected/read-only () - (ert-with-test-buffer () - (ert-with-buffer-selected (current-buffer) - (should (null inhibit-read-only)) - (should (null buffer-read-only))))) - -(ert-deftest ert-test-with-buffer-selected/return-value () - (should (equal (ert-with-buffer-selected nil "foo") "foo"))) - -(ert-deftest ert-test-with-test-buffer-selected/selected () - (ert-with-test-buffer (:selected t) - (should (eq (window-buffer) (current-buffer))))) - -(ert-deftest ert-test-with-test-buffer-selected/modification-hooks () - (ert-with-test-buffer (:selected t) - (should (null inhibit-modification-hooks)))) - -(ert-deftest ert-test-with-test-buffer-selected/read-only () - (ert-with-test-buffer (:selected t) - (should (null inhibit-read-only)) - (should (null buffer-read-only)))) - -(ert-deftest ert-test-with-test-buffer-selected/return-value () - (should (equal (ert-with-test-buffer (:selected t) "foo") "foo"))) - -(ert-deftest ert-test-with-test-buffer-selected/buffer-name () - (should (equal (ert-with-test-buffer (:name "foo") (buffer-name)) - (ert-with-test-buffer (:name "foo" :selected t) - (buffer-name))))) - (ert-deftest ert-filter-string () (should (equal (ert-filter-string "foo bar baz" "quux") "foo bar baz")) diff --git a/test/lisp/progmodes/hideshow-tests.el b/test/lisp/progmodes/hideshow-tests.el index 59b8522d614..a6b3ecfbd3d 100644 --- a/test/lisp/progmodes/hideshow-tests.el +++ b/test/lisp/progmodes/hideshow-tests.el @@ -22,7 +22,6 @@ ;;; Code: (require 'ert) -(require 'ert-x) (require 'hideshow) ;; Dependencies for testing: diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el index b07e693f927..e638f8cb3f5 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -22,7 +22,6 @@ ;;; Code: (require 'ert) -(require 'ert-x) (eval-when-compile (require 'cl-lib)) (defun simple-test--buffer-substrings () diff --git a/test/lisp/whitespace-tests.el b/test/lisp/whitespace-tests.el index a33338c660f..ed347d04be1 100644 --- a/test/lisp/whitespace-tests.el +++ b/test/lisp/whitespace-tests.el @@ -19,7 +19,6 @@ ;;; Code: (require 'ert) -(require 'ert-x) (require 'faceup) (require 'whitespace) commit d9f165b129f5c9c94a78bd4237be6c7171085d35 Author: Stefan Kangas Date: Mon Feb 24 20:00:49 2025 +0100 ; Delete outdated comment from ert-x.el diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 5d124197d19..1c189a7c5ed 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -30,7 +30,7 @@ (eval-when-compile (require 'cl-lib)) (require 'ert) -(require 'subr-x) ; string-trim +(require 'subr-x) ;;; Test buffers. commit 13ca18e1f79f9c02ac46735b58bc5126f77f0a77 Author: Stefan Kangas Date: Mon Feb 24 18:54:23 2025 +0100 Support selecting buffer in ert-with-test-buffer * lisp/emacs-lisp/ert-x.el (ert-with-test-buffer): Add new keyword argument :selected to make the buffer current and selected. (ert-with-test-buffer-selected): Make obsolete and redefine in terms of ert-with-test-buffer. * doc/misc/ert.texi (Helper Functions): Document above new :selected keyword argument, and remove documentation of ert-with-test-buffer-selected. * test/lisp/emacs-lisp/ert-x-tests.el (ert-test-with-test-buffer-selected/selected) (ert-test-with-test-buffer-selected/modification-hooks) (ert-test-with-test-buffer-selected/read-only) (ert-test-with-test-buffer-selected/return-value) (ert-test-with-test-buffer-selected/buffer-name): * test/lisp/progmodes/hideshow-tests.el (hideshow-tests-with-temp-buffer-selected): * test/lisp/simple-tests.el (kill-whole-line-invisible) (kill-whole-line-read-only, kill-whole-line-after-other-kill) (kill-whole-line-buffer-boundaries) (kill-whole-line-line-boundaries): * test/lisp/whitespace-tests.el (whitespace-tests--with-test-buffer, whitespace-tests--global): Use ert-with-test-buffer instead of ert-with-test-buffer-selected. diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi index 566fa03bf3f..c15df506089 100644 --- a/doc/misc/ert.texi +++ b/doc/misc/ert.texi @@ -1093,10 +1093,11 @@ for writing tests. @subsection Test Buffers -@defmac ert-with-test-buffer ((&key ((:name name-form))) &body body) +@defmac ert-with-test-buffer ((&key ((:name name-form :selected select-form))) &body body) This macro creates a test buffer and runs @var{body} in that buffer. If @var{body} finishes successfully, the test buffer is killed; if there is -an error, the test buffer is kept around for further inspection. +an error, the test buffer is kept around for further inspection. The +return value is the last form in @var{body}. The test buffer name is derived from the name of the ERT test and the result of @var{NAME-FORM}. Example: @@ -1109,6 +1110,16 @@ result of @var{NAME-FORM}. Example: This uses the test buffer @file{*Test buffer (backtrace-tests--variables): variables*}. + +If @var{select-form} is non-nil, select the buffer after creating it. +This has the same effect as combining @code{ert-with-test-buffer} with +@code{ert-with-buffer-selected}. Example: + +@lisp +(ert-deftest whitespace-tests--global () + (ert-with-test-buffer-selected (:name "global" :selected t) + @dots{})) +@end lisp @end defmac @defmac ert-with-buffer-selected (buffer &body body) @@ -1133,23 +1144,6 @@ value is the last form in @var{body}. Example: This displays a temporary buffer like @file{ *temp*-739785*}. @end defmac -@defmac ert-with-test-buffer-selected ((&key name) &body body) -This creates a test buffer, switches to it, and runs @var{body}. - -It combines @code{ert-with-test-buffer} and -@code{ert-with-buffer-selected}. The return value is the last form in -@var{body}. Example: - -@lisp -(ert-deftest whitespace-tests--global () - (ert-with-test-buffer-selected (:name "global") - @dots{})) -@end lisp - -This displays the test buffer @file{*Test buffer -(whitespace-tests--global): global*}. -@end defmac - @defun ert-kill-all-test-buffers () It kills all test buffers that are still live. @end defun diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 524f02bb36d..5d124197d19 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -90,17 +90,28 @@ ERT--THUNK with that buffer as current." (kill-buffer ert--buffer) (remhash ert--buffer ert--test-buffers)))) -(cl-defmacro ert-with-test-buffer ((&key ((:name name-form))) +(cl-defmacro ert-with-test-buffer ((&key ((:name name-form)) + ((:selected select-form))) &body body) "Create a test buffer and run BODY in that buffer. -To be used in ERT tests. If BODY finishes successfully, the test -buffer is killed; if there is an error, the test buffer is kept -around for further inspection. Its name is derived from -the name of the test and the result of NAME-FORM." - (declare (debug ((":name" form) def-body)) +To be used in ERT tests. If BODY finishes successfully, the test buffer +is killed; if there is an error, the test buffer is kept around for +further inspection. The name of the buffer is derived from the name of +the test and the result of NAME-FORM. + +If SELECT-FORM is non-nil, switch to the test buffer before running +BODY, as if body was in `ert-with-buffer-selected'. + +The return value is the last form in BODY." + (declare (debug ((":name" form) (":selected" form) def-body)) (indent 1)) - `(ert--call-with-test-buffer ,name-form (lambda () ,@body))) + `(ert--call-with-test-buffer + ,name-form + ,(if select-form + `(lambda () (ert-with-buffer-selected (current-buffer) + ,@body)) + `(lambda () ,@body)))) (cl-defmacro ert-with-buffer-selected (buffer-or-name &body body) "Display a buffer in a temporary selected window and run BODY. @@ -124,13 +135,12 @@ value is the last form in BODY." (cl-defmacro ert-with-test-buffer-selected ((&key name) &body body) "Create a test buffer, switch to it, and run BODY. -This combines `ert-with-test-buffer' and -`ert-with-buffer-selected'. The return value is the last form in -BODY." - (declare (debug ((":name" form) body)) (indent 1)) - `(ert-with-test-buffer (:name ,name) - (ert-with-buffer-selected (current-buffer) - ,@body))) +This combines `ert-with-test-buffer' and `ert-with-buffer-selected'. +The return value is the last form in BODY." + (declare (obsolete ert-with-test-buffer "31.1") + (debug ((":name" form) body)) (indent 1)) + `(ert-with-test-buffer (:name ,name :selected t) + ,@body)) ;;;###autoload (defun ert-kill-all-test-buffers () diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index 5d471951409..aa0edf47059 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -117,24 +117,24 @@ (should (equal (ert-with-buffer-selected nil "foo") "foo"))) (ert-deftest ert-test-with-test-buffer-selected/selected () - (ert-with-test-buffer-selected () + (ert-with-test-buffer (:selected t) (should (eq (window-buffer) (current-buffer))))) (ert-deftest ert-test-with-test-buffer-selected/modification-hooks () - (ert-with-test-buffer-selected () + (ert-with-test-buffer (:selected t) (should (null inhibit-modification-hooks)))) (ert-deftest ert-test-with-test-buffer-selected/read-only () - (ert-with-test-buffer-selected () + (ert-with-test-buffer (:selected t) (should (null inhibit-read-only)) (should (null buffer-read-only)))) (ert-deftest ert-test-with-test-buffer-selected/return-value () - (should (equal (ert-with-test-buffer-selected () "foo") "foo"))) + (should (equal (ert-with-test-buffer (:selected t) "foo") "foo"))) (ert-deftest ert-test-with-test-buffer-selected/buffer-name () (should (equal (ert-with-test-buffer (:name "foo") (buffer-name)) - (ert-with-test-buffer-selected (:name "foo") + (ert-with-test-buffer (:name "foo" :selected t) (buffer-name))))) (ert-deftest ert-filter-string () diff --git a/test/lisp/progmodes/hideshow-tests.el b/test/lisp/progmodes/hideshow-tests.el index 8768ab79eed..59b8522d614 100644 --- a/test/lisp/progmodes/hideshow-tests.el +++ b/test/lisp/progmodes/hideshow-tests.el @@ -46,7 +46,7 @@ always located at the beginning of buffer." BODY is code to be executed within the temp buffer. Point is always located at the beginning of buffer." (declare (indent 1) (debug t)) - `(ert-with-test-buffer-selected () + `(ert-with-test-buffer (:selected t) (,mode) (hs-minor-mode 1) (insert ,contents) diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el index a9b43d319a3..b07e693f927 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -1148,7 +1148,7 @@ See Bug#21722." (ert-deftest kill-whole-line-invisible () (cl-flet ((test (kill-whole-line-arg &rest expected-lines) (ert-info ((format "%s" kill-whole-line-arg) :prefix "Subtest: ") - (ert-with-test-buffer-selected nil + (ert-with-test-buffer (:selected t) (simple-test--set-buffer-text-point-mark (string-join '("* -2" "hidden" @@ -1216,7 +1216,7 @@ See Bug#21722." (cl-flet ((test (kill-whole-line-arg expected-kill-lines expected-buffer-lines) (ert-info ((format "%s" kill-whole-line-arg) :prefix "Subtest: ") - (ert-with-test-buffer-selected nil + (ert-with-test-buffer (:selected t) (simple-test--set-buffer-text-point-mark (string-join '("-2" "-1" "AB" "1" "2" "") "\n")) (read-only-mode 1) @@ -1238,7 +1238,7 @@ See Bug#21722." (test -9 '("-2" "-1" "AB") '("-2" "-1" "AB" "1" "2" "")))) (ert-deftest kill-whole-line-after-other-kill () - (ert-with-test-buffer-selected nil + (ert-with-test-buffer (:selected t) (simple-test--set-buffer-text-point-mark "AXB") (setq last-command #'ignore) (kill-region (point) (mark)) @@ -1250,7 +1250,7 @@ See Bug#21722." (simple-test--get-buffer-text-point-mark))))) (ert-deftest kill-whole-line-buffer-boundaries () - (ert-with-test-buffer-selected nil + (ert-with-test-buffer (:selected t) (ert-info ("0" :prefix "Subtest: ") (simple-test--set-buffer-text-point-mark "") (should-error (kill-whole-line -1) @@ -1281,7 +1281,7 @@ See Bug#21722." (should (equal "A\n" (car kill-ring)))))) (ert-deftest kill-whole-line-line-boundaries () - (ert-with-test-buffer-selected nil + (ert-with-test-buffer (:selected t) (ert-info ("1a" :prefix "Subtest: ") (simple-test--set-buffer-text-point-mark "-1\n\n1\n") (setq last-command #'ignore) diff --git a/test/lisp/whitespace-tests.el b/test/lisp/whitespace-tests.el index 4bd87325104..a33338c660f 100644 --- a/test/lisp/whitespace-tests.el +++ b/test/lisp/whitespace-tests.el @@ -30,7 +30,7 @@ The buffer is displayed in `selected-window', and nil, `whitespace-mode' is left disabled." (declare (debug ((style form) def-body)) (indent 1)) - `(ert-with-test-buffer-selected () + `(ert-with-test-buffer (:selected t) ;; In case global-*-mode is enabled. (whitespace-mode -1) (font-lock-mode -1) @@ -63,7 +63,7 @@ buffer's content." (unwind-protect (progn (global-whitespace-mode 1) - (ert-with-test-buffer-selected () + (ert-with-test-buffer (:selected t) (normal-mode) (should whitespace-mode) (global-whitespace-mode -1) commit 637c73d3a804f7e64736b87994e8974892529b00 Author: Stefan Kangas Date: Mon Feb 24 00:55:16 2025 +0100 Use cl-with-gensyms in with-sqlite-transaction * lisp/sqlite.el (cl-lib): Require at compile-time. (with-sqlite-transaction): Use cl-with-gensyms. diff --git a/lisp/sqlite.el b/lisp/sqlite.el index 140b79ced0a..f4840d46f07 100644 --- a/lisp/sqlite.el +++ b/lisp/sqlite.el @@ -23,6 +23,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (declare-function sqlite-transaction "sqlite.c") (declare-function sqlite-commit "sqlite.c") (declare-function sqlite-rollback "sqlite.c") @@ -35,10 +37,7 @@ If BODY signals an error, or transaction commit fails, roll back the transaction changes before allowing the signal to propagate." (declare (indent 1) (debug (form body))) - (let ((db-var (gensym)) - (func-var (gensym)) - (res-var (gensym)) - (commit-var (gensym))) + (cl-with-gensyms (db-var func-var res-var commit-var) `(let ((,db-var ,db) (,func-var (lambda () ,@body)) ,res-var ,commit-var) commit 0eada9e1d30b9072cdc1bf8388205773cd23986f Author: Stefan Kangas Date: Mon Feb 24 19:27:21 2025 +0100 Prefer incf to cl-incf in textmodes/*.el * lisp/textmodes/css-mode.el (css--rgb-color): * lisp/textmodes/reftex-dcr.el (reftex-view-regexp-match): * lisp/textmodes/reftex-global.el (reftex-find-duplicate-labels) (reftex-renumber-simple-labels, reftex-translate): * lisp/textmodes/reftex-index.el (reftex-index-select-tag) (reftex-index-phrases-info, reftex-query-index-phrase): * lisp/textmodes/reftex-parse.el (reftex-where-am-I) (reftex-what-macro, reftex-nth-arg, reftex-section-number): * lisp/textmodes/reftex-ref.el (reftex-uniquify-label): * lisp/textmodes/reftex-sel.el (reftex-insert-docstruct): * lisp/textmodes/reftex.el (reftex-next-multifile-index) (reftex-compile-variables, reftex-parse-args) (reftex-select-external-document): * lisp/textmodes/rst.el (rst-display-hdr-hierarchy) (rst-toc-insert-children, rst-apply-indented-blocks) (rst-enumerate-region, rst-convert-bullets-to-enumeration): * lisp/textmodes/tex-mode.el (tex-count-words): Prefer incf to cl-incf. diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 35c61e4f66d..41fffbe6a60 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -1080,12 +1080,12 @@ the returned hex string." (push (min (max 0 (round number)) 255) result) (goto-char (match-end 0)) (css--color-skip-blanks) - (cl-incf iter) + (incf iter) ;; Accept a superset of the CSS syntax since I'm feeling lazy. (when (and (= (skip-chars-forward ",/") 0) (= iter 3)) ;; The alpha is optional. - (cl-incf iter)) + (incf iter)) (css--color-skip-blanks))) (when (looking-at ")") (forward-char) diff --git a/lisp/textmodes/reftex-dcr.el b/lisp/textmodes/reftex-dcr.el index 3b02b550913..77516ca840a 100644 --- a/lisp/textmodes/reftex-dcr.el +++ b/lisp/textmodes/reftex-dcr.el @@ -415,7 +415,7 @@ Calling this function several times find successive citation locations." (if match (progn (put 'reftex-view-regexp-match :props newprop) - (put 'reftex-view-regexp-match :cnt (cl-incf cnt)) + (put 'reftex-view-regexp-match :cnt (incf cnt)) (reftex-highlight 0 (match-beginning highlight-group) (match-end highlight-group)) (add-hook 'pre-command-hook #'reftex-highlight-shall-die) diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el index 20af2d72837..20abd36192d 100644 --- a/lisp/textmodes/reftex-global.el +++ b/lisp/textmodes/reftex-global.el @@ -169,7 +169,7 @@ No active TAGS table is required." (while dlist (when (and (car (car dlist)) (cdr (car dlist))) - (cl-incf cnt) + (incf cnt) (insert (mapconcat #'identity (car dlist) "\n ") "\n")) (pop dlist)) (goto-char (point-min)) @@ -238,7 +238,7 @@ one with the `xr' package." (if (assoc label translate-alist) (error "Duplicate label %s" label)) (setq new-label (concat (match-string 1 (car entry)) - (int-to-string (cl-incf (cdr nr-cell))))) + (int-to-string (incf (cdr nr-cell))))) (push (cons label new-label) translate-alist) (or (string= label new-label) (setq changed-sequence t)))) @@ -350,7 +350,7 @@ one with the `xr' package." (error "Abort"))) (reftex-unhighlight 1))) ((and test cell) - (cl-incf n)) + (incf n)) ((and (not test) cell) ;; Replace (goto-char (match-beginning 1)) diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el index 5d4b1f38236..db6ebb4caf8 100644 --- a/lisp/textmodes/reftex-index.el +++ b/lisp/textmodes/reftex-index.el @@ -210,16 +210,16 @@ will prompt for other arguments." i -1 val nil) (catch 'exit - (while (and (< (cl-incf i) len) (null val)) + (while (and (< (incf i) len) (null val)) (unless (assq (aref tag i) tag-alist) (push (list (aref tag i) tag (concat (substring tag 0 i) - "[" (substring tag i (cl-incf i)) "]" + "[" (substring tag i (incf i)) "]" (substring tag i))) tag-alist) (throw 'exit t))) - (push (list (+ ?0 (cl-incf cnt)) tag + (push (list (+ ?0 (incf cnt)) tag (concat "[" (int-to-string cnt) "]:" tag)) tag-alist))) (setq tag-alist (nreverse tag-alist)) @@ -1622,11 +1622,11 @@ this function repeatedly." (widen) (goto-char (point-min)) (while (re-search-forward re1 nil t) - (cl-incf ntimes1)) + (incf ntimes1)) (goto-char (point-min)) (while (re-search-forward re2 nil t) (push (cons (count-lines 1 (point)) (match-string 1)) superphrases) - (cl-incf ntimes2)))) + (incf ntimes2)))) (save-current-buffer (while (setq file (pop files)) (setq buf (reftex-get-file-buffer-force file)) @@ -1639,7 +1639,7 @@ this function repeatedly." (let ((case-fold-search reftex-index-phrases-case-fold-search)) (while (re-search-forward re nil t) (or (reftex-in-comment) - (cl-incf nmatches))))))))) + (incf nmatches))))))))) (with-output-to-temp-buffer "*Help*" (princ (format " Phrase: %s\n" phrase)) (princ (format " Macro key: %s\n" char)) @@ -1649,7 +1649,7 @@ this function repeatedly." (index-key (let ((iks index-keys) (cnt 0) ik) (while (setq ik (pop iks)) - (princ (format "Index entry %d: %s\n" (cl-incf cnt) ik))))) + (princ (format "Index entry %d: %s\n" (incf cnt) ik))))) (repeat (princ (format " Index entry: %s\n" phrase))) (t @@ -1911,7 +1911,7 @@ both ends." (cond ((member char '(?y ?Y ?\ )) ;; Yes! (replace-match rpl t t) - (cl-incf replace-count) + (incf replace-count) ;; See if we should insert newlines to shorten lines (and reftex-index-phrases-wrap-long-lines (reftex-index-phrases-fixup-line beg end)) diff --git a/lisp/textmodes/reftex-parse.el b/lisp/textmodes/reftex-parse.el index d66b0b9064e..0acf91ebe20 100644 --- a/lisp/textmodes/reftex-parse.el +++ b/lisp/textmodes/reftex-parse.el @@ -629,7 +629,7 @@ if the information is exact (t) or approximate (nil)." found) (save-excursion (while (not rtn) - (cl-incf cnt) + (incf cnt) (setq found (re-search-backward (reftex-everything-regexp) nil t)) (setq rtn (cond @@ -693,7 +693,7 @@ if the information is exact (t) or approximate (nil)." (when (and (eq (car (car list)) 'index) (string= (nth 2 index-info) (nth 2 (car list)))) - (cl-incf n) + (incf n) (setq dist (abs (- (point) (nth 4 (car list))))) (if (or (not last-dist) (< dist last-dist)) (setq last-dist dist last (car list)))) @@ -875,8 +875,8 @@ considered an argument of macro \\macro." (backward-sexp)) t) (error nil))) - (if (memq (following-char) '(?\( ?\[)) (cl-incf cnt-opt)) - (cl-incf cnt)) + (if (memq (following-char) '(?\( ?\[)) (incf cnt-opt)) + (incf cnt)) (setq pos (point)) (when (and (memq (following-char) '(?\[ ?\( ?\{)) (re-search-backward "\\\\[*a-zA-Z]+\\=" nil t)) @@ -1017,18 +1017,18 @@ OPT-ARGS is a list of argument numbers which are optional." (while (< cnt n) (while (and (member cnt opt-args) (eq (following-char) ?\{)) - (cl-incf cnt)) + (incf cnt)) (when (< cnt n) (unless (and (condition-case nil (or (forward-list 1) t) (error nil)) (reftex-move-to-next-arg) - (cl-incf cnt)) + (incf cnt)) (setq cnt 1000)))) (while (and (memq cnt opt-args) (eq (following-char) ?\{)) - (cl-incf cnt))) + (incf cnt))) (if (and (= n cnt) (> (skip-chars-forward "{[") 0)) (reftex-context-substring) @@ -1114,7 +1114,7 @@ When LEVEL is non-nil, increase section numbers on that level." (if (or (not partspecial) (not (= idx 1))) (aset reftex-section-numbers idx 0)) - (cl-incf idx)))) + (incf idx)))) (if partspecial (setq string (concat "Part " (reftex-roman-number (aref reftex-section-numbers 0)))) @@ -1124,7 +1124,7 @@ When LEVEL is non-nil, increase section numbers on that level." (if (not (and partspecial (not (equal string "")))) (setq string (concat string (if (not (string= string "")) "." "") (int-to-string n)))) - (cl-incf idx)) + (incf idx)) (save-match-data (if (string-match "\\`\\([@0]\\.\\)+" string) (setq string (replace-match "" nil nil string))) diff --git a/lisp/textmodes/reftex-ref.el b/lisp/textmodes/reftex-ref.el index 4a4c4df4c58..30e9968a8e5 100644 --- a/lisp/textmodes/reftex-ref.el +++ b/lisp/textmodes/reftex-ref.el @@ -374,7 +374,7 @@ also applies `reftex-translate-to-ascii-function' to the string." (sep (or separator ""))) (while (assoc (concat label sep (int-to-string num)) (symbol-value reftex-docstruct-symbol)) - (cl-incf num)) + (incf num)) (setcdr cell num) (concat label sep (int-to-string num)))))) diff --git a/lisp/textmodes/reftex-sel.el b/lisp/textmodes/reftex-sel.el index 7286c214f7a..1f1c74550a5 100644 --- a/lisp/textmodes/reftex-sel.el +++ b/lisp/textmodes/reftex-sel.el @@ -244,7 +244,7 @@ During a selection process, these are the local bindings. ;; Walk the docstruct and insert the appropriate stuff (while (setq cell (pop all)) - (cl-incf index) + (incf index) (setq from (point)) (cond @@ -314,7 +314,7 @@ During a selection process, these are the local bindings. (or show-commented (null comment))) ;; Yes we want this one - (cl-incf cnt) + (incf cnt) (setq prev-inserted cell) ; (if (eq offset 'attention) (setq offset cell)) diff --git a/lisp/textmodes/reftex.el b/lisp/textmodes/reftex.el index 54085f7f9e3..fda506a6d87 100644 --- a/lisp/textmodes/reftex.el +++ b/lisp/textmodes/reftex.el @@ -277,7 +277,7 @@ on the menu bar. (defun reftex-next-multifile-index () ;; Return the next free index for multifile symbols. - (cl-incf reftex-multifile-index)) + (incf reftex-multifile-index)) (defun reftex-tie-multifile-symbols () "Tie the buffer-local symbols to globals connected with the master file. @@ -937,7 +937,7 @@ This enforces rescanning the buffer on next use." (not (member (aref fmt i) '(?%)))) (setq word (concat word "\\|" (regexp-quote (substring fmt 0 (1+ i))))) - (cl-incf i)) + (incf i)) (cons (concat word "\\)\\=") typekey)) (nreverse reftex-words-to-typekey-alist))) @@ -990,7 +990,7 @@ This enforces rescanning the buffer on next use." (mapconcat (lambda(x) (format "[%c] %-20.20s%s" (car x) (nth 1 x) - (if (= 0 (mod (cl-incf i) 3)) "\n" ""))) + (if (= 0 (mod (incf i) 3)) "\n" ""))) reftex-key-to-index-macro-alist ""))) ;; Make the full list of section levels @@ -1084,7 +1084,7 @@ This enforces rescanning the buffer on next use." (args (substring macro (match-beginning 0))) opt-list nlabel (cnt 0)) (while (string-match "\\`[[{]\\(\\*\\)?[]}]" args) - (cl-incf cnt) + (incf cnt) (when (eq ?\[ (string-to-char args)) (push cnt opt-list)) (when (and (match-end 1) @@ -1280,7 +1280,7 @@ Valid actions are: readable, restore, read, kill, write." "SELECT EXTERNAL DOCUMENT\n------------------------\n" (mapconcat (lambda (x) - (format fmt (cl-incf n) (or (car x) "") + (format fmt (incf n) (or (car x) "") (abbreviate-file-name (cdr x)))) xr-alist "")) nil t)) diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el index ba4ff5cf7b6..1e3151dce03 100644 --- a/lisp/textmodes/rst.el +++ b/lisp/textmodes/rst.el @@ -2199,7 +2199,7 @@ Hierarchy is displayed in a temporary buffer." (rst-update-section hdr) (goto-char (point-max)) (insert "\n") - (cl-incf level)))))) + (incf level)))))) (define-obsolete-function-alias 'rst-display-adornments-hierarchy #'rst-display-hdr-hierarchy "29.1") @@ -2752,7 +2752,7 @@ See `rst-toc-insert-tree' for STYLE, DEPTH and TGT-STN. See (or (rst-toc-insert-stn child buf style depth indent (concat numbering (format num-fmt count)) keymap tgt-stn) fnd)) - (cl-incf count)))) + (incf count)))) ;; FIXME refactoring: Use `rst-Stn-buffer' instead of `buf'. (defun rst-toc-insert-stn (stn buf style depth indent numbering keymap tgt-stn) @@ -3466,7 +3466,7 @@ Otherwise return nil." (t ; Non-empty line in indented block. (when (or broken in-sub in-super) (setq in-first t) - (cl-incf count)) + (incf count)) (setq in-sub nil) (setq in-super nil))) (save-excursion @@ -3494,7 +3494,7 @@ do all lines instead of just paragraphs." (in-sub (insert indent)) ((or in-first all) - (let ((tag (format "%d. " (cl-incf enum)))) + (let ((tag (format "%d. " (incf enum)))) (setq indent (make-string (length tag) ? )) (insert tag))) (t @@ -3546,7 +3546,7 @@ Renumber as necessary. Region is from BEG to END." (goto-char marker) nil) (looking-at (rst-re 'itmany-beg-1)) (replace-match (format "%d." count) nil nil nil 1) - (cl-incf count)))))) + (incf count)))))) (defun rst-line-block-region (beg end &optional with-empty) "Add line block prefixes for a region. diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 476ea3ec26f..0eb686ce35d 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -1945,7 +1945,7 @@ Mark is left at original location." (if (not (eq (char-syntax (preceding-char)) ?/)) (progn ;; Don't count single-char words. - (unless (looking-at ".\\>") (cl-incf count)) + (unless (looking-at ".\\>") (incf count)) (forward-char 1)) (let ((cmd (buffer-substring-no-properties commit ee04b7da8059acb230fe32f508947ecb6a24b7e2 Author: Robert Pluim Date: Thu Feb 20 17:40:43 2025 +0100 * lisp/msb.el (msb-mode-map): Use 'defvar-keymap'. diff --git a/lisp/msb.el b/lisp/msb.el index e6b29bd7eee..6d8f976ee37 100644 --- a/lisp/msb.el +++ b/lisp/msb.el @@ -1113,10 +1113,8 @@ variable `msb-menu-cond'." ;; Snarf current bindings of `mouse-buffer-menu' (normally ;; C-down-mouse-1). -(defvar msb-mode-map - (let ((map (make-sparse-keymap "Msb"))) - (define-key map [remap mouse-buffer-menu] #'msb) - map)) +(defvar-keymap msb-mode-map + " " #'msb) ;;;###autoload (define-minor-mode msb-mode commit 24e8477aa2f5ef228107707078735ade31e5d1c3 Author: Juri Linkov Date: Mon Feb 24 19:51:13 2025 +0200 Better support for nil enable-local-variables in vc-find-revision-no-save * lisp/vc/diff-mode.el (diff-syntax-fontify-props): * lisp/vc/vc.el (vc-find-revision-no-save): Use enable-local-variables as is only when it's one of these values: :safe, :all, or nil. Otherwise, for all remaining values that query, use :safe. Also use non-nil 'find-file' arg of 'normal-mode'. https://lists.gnu.org/archive/html/emacs-devel/2025-02/msg00897.html diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index cbdb721e8fa..21a036bd139 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -3182,7 +3182,12 @@ hunk text is not found in the source file." (cl-assert (null buffer-file-name)) ;; Use `:safe' to find `mode:'. In case of hunk-only, use nil because ;; Local Variables list might be incomplete when context is truncated. - (let ((enable-local-variables (unless hunk-only :safe)) + (let ((enable-local-variables + (unless hunk-only + (if (memq enable-local-variables '(:safe :all nil)) + enable-local-variables + ;; Ignore other values that query. + :safe))) (buffer-file-name file)) ;; Don't run hooks that might assume buffer-file-name ;; really associates buffer with a file (bug#39190). diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index d66f95578fa..dc03bad3bcf 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -2461,12 +2461,19 @@ Unlike `vc-find-revision-save', doesn't save the buffer to the file." (goto-char (point-min)) (if buffer ;; For non-interactive, skip any questions - (let ((enable-local-variables :safe) ;; to find `mode:' + (let ((enable-local-variables + (if (memq enable-local-variables '(:safe :all nil)) + enable-local-variables + ;; Ignore other values that query, + ;; use `:safe' to find `mode:'. + :safe)) (buffer-file-name file)) ;; Don't run hooks that might assume buffer-file-name ;; really associates buffer with a file (bug#39190). (ignore-errors (delay-mode-hooks (set-auto-mode)))) - (normal-mode)) + ;; Use non-nil 'find-file' arg of 'normal-mode' + ;; to not ignore 'enable-local-variables' when nil. + (normal-mode (not enable-local-variables))) (set-buffer-modified-p nil) (setq buffer-read-only t) (setq failed nil)) commit 3f72af997308db3160f05ace47602f1f2b8afd9c Author: Stefan Kangas Date: Mon Feb 24 18:38:28 2025 +0100 ; Fix thinko in subr-test-zerop * test/lisp/subr-tests.el (subr-test-zerop): Fix test. Reported by Pip Cet . diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 5684a08254d..702502627f2 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -39,8 +39,8 @@ (should-not (zerop 0.0e+NaN)) (should-not (zerop float-pi)) (should-not (zerop 1.0e+INF)) - (should-not (zerop (random most-positive-fixnum))) - (should-not (zerop (- (random (- most-negative-fixnum))))) + (should-not (zerop (1+ (random most-positive-fixnum)))) + (should-not (zerop (- (1- (random (- most-negative-fixnum)))))) (should-not (zerop (1+ most-positive-fixnum))) (should-not (zerop (1- most-negative-fixnum))) (should-error (zerop "-5") :type 'wrong-type-argument)) commit 0c8ec155f60bdebaf2f7a86e57e7c559c5552821 Author: Robert Pluim Date: Fri Feb 14 16:26:49 2025 +0100 Use 'password-colon-equivalents' when matching "Re" variants * lisp/mail/mail-utils.el (mail--wrap-re-regexp): Use 'password-colon-equivalents'. diff --git a/lisp/mail/mail-utils.el b/lisp/mail/mail-utils.el index d7748ffe6aa..d51e2747ba3 100644 --- a/lisp/mail/mail-utils.el +++ b/lisp/mail/mail-utils.el @@ -52,8 +52,10 @@ also the To field, unless this would leave an empty To field." re ; Re(1) or Re[1] or Re^1 "\\(([0-9]+)\\|\\[[0-9]+\\]\\|\\^[0-9]+\\)?" - ; SPC/NBSP followed by colon and TAB/SPC - " ?\u00a0*[:：][ \t]*" + ; SPC/NBSP followed by various colon variants and TAB/SPC + " ?\u00a0*" + "[" password-colon-equivalents "]" + "[ \t]*" ; Handle repetition, eg "Re[1]: Re[2]:" "\\)*" "[ \t]*")) commit bca04d3c580e3bd3d787274973d33ce95098d423 Author: Rudi Schlatte Date: Mon Feb 24 18:04:46 2025 +0100 Add ".jj" to vc-directory-exclusion-list * lisp/vc/vc-hooks.el (vc-directory-exclusion-list): Add ".jj", a directory used by the jujutsu version control system. (Bug#76524) diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index 1b628bf0c16..d6dcf9d421b 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -123,7 +123,8 @@ An empty list disables VC altogether." ;; The Arch back end will be retrieved and fixed if it is ever required. (defcustom vc-directory-exclusion-list '("SCCS" "RCS" "CVS" "MCVS" ".src" ".svn" ".git" ".hg" ".bzr" - "_MTN" "_darcs" "{arch}" ".repo") + "_MTN" "_darcs" "{arch}" ".repo" + ".jj") "List of directory names to be ignored when walking directory trees." :type '(repeat string) :group 'vc) commit a205d554522340e23540bdda63c80965ddd64951 Author: Martin Rudalics Date: Mon Feb 24 10:17:10 2025 +0100 Optionally have 'display-buffer' reuse windows of indirect buffers * lisp/window.el (window-indirect-buffer-p): New function. (get-buffer-window-list): New argument INDIRECT. (display-buffer-reuse-window): New alist entry 'reuse-indirect' to reuse a window indirectly related to the BUFFER argument. * doc/lispref/windows.texi (Buffers and Windows): Describe new function 'window-indirect-buffer-p' and new argument INDIRECT of 'get-buffer-window-list'. (Buffer Display Action Functions): Describe new action alist entry 'reuse-indirect'. * etc/NEWS: Announce new argument for 'get-buffer-window-list' and new 'display-buffer' action alist entry 'reuse-indirect'. diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index 6c4e59d448f..5c0db6d4877 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -2697,7 +2697,37 @@ Ordering}). This function may be changed in a future version of Emacs to eliminate this discrepancy. @end defun -@defun get-buffer-window-list &optional buffer-or-name minibuf all-frames +The following function can tell for a specific window whether its buffer +shares the text of some other buffer (@pxref{Indirect Buffers}). + +@defun window-indirect-buffer-p &optional window buffer-or-name +This function returns non-@code{nil} if @var{window} is indirectly +related to @var{buffer-or-name}. @var{window} must be a live window and +defaults to the selected window. @var{buffer-or-name} may be a buffer +or the name of an existing buffer and defaults to the current buffer. + +@var{window} is indirectly related to @var{buffer-or-name} if one of the +following conditions hold: + +@itemize @bullet +@item +@var{buffer-or-name} specifies an indirect buffer and @var{window}'s +buffer is its base buffer. + +@item +@var{window}'s buffer is an indirect buffer whose base buffer is the +buffer specified by @var{buffer-or-name}. + +@item +Both, @var{window}'s buffer and the buffer specified by +@var{buffer-or-name}, are indirect buffer's sharing the same base +buffer. +@end itemize + +It returns @code{nil} if none of the above holds. +@end defun + +@defun get-buffer-window-list &optional buffer-or-name minibuf all-frames indirect This function returns a list of all windows currently displaying @var{buffer-or-name}. @var{buffer-or-name} should be a buffer or the name of an existing buffer. If omitted or @code{nil}, it defaults to @@ -2709,6 +2739,13 @@ The arguments @var{minibuf} and @var{all-frames} have the same meanings as in the function @code{next-window} (@pxref{Cyclic Window Ordering}). Note that the @var{all-frames} argument does @emph{not} behave exactly like in @code{get-buffer-window}. + +The optional argument @var{indirect} non-@code{nil} means to append to +the list of windows showing @var{buffer-or-name} a list of all windows +that are indirectly related to @var{buffer-or-name}, that is, windows +for which @code{window-indirect-buffer-p} (see above) with the window +and the buffer specified by @var{buffer-or-name} as arguments returns +non-@code{nil}. @end defun @deffn Command replace-buffer-in-windows &optional buffer-or-name @@ -3165,6 +3202,17 @@ searches just the selected frame. If this function chooses a window on another frame, it makes that frame visible and, unless @var{alist} contains an @code{inhibit-switch-frame} entry, raises that frame if necessary. + +If @var{alist} has a non-@code{nil} @code{reuse-indirect} entry and no +window showing @var{buffer} has been found, this function tries to find +a window that is indirectly related to @var{buffer}---a window for which +@code{window-indirect-buffer-p} (@pxref{Buffers and Windows}) with the +window and @var{buffer} as arguments returns non-@code{nil}. If such a +window has been found and the @sc{cdr} of the @code{reuse-indirect} +entry equals the symbol @code{buffer}, it does not replace the buffer of +that window with @var{buffer} but returns the window with its old buffer +in place. Otherwise, it puts @var{buffer} into that window and returns +that window. @end defun @defun display-buffer-reuse-mode-window buffer alist diff --git a/etc/NEWS b/etc/NEWS index 4a89b9abe6f..29abfaf1126 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -247,6 +247,17 @@ landscape shape for instance, Emacs could split horizontally before splitting vertically. The default setting preserves Emacs historical behavior to try to split vertically first. ++++ +*** New argument INDIRECT for 'get-buffer-window-list'. +With this argument non-nil, 'get-buffer-window-list' will include in the +return value windows whose buffers share their text with BUFFER-OR-NAME. + ++++ +*** New 'display-buffer' action alist entry 'reuse-indirect'. +With such an entry, 'display-buffer-reuse-window' may also choose a +window whose buffer shares text with the buffer to display. + + ** Frames +++ diff --git a/lisp/window.el b/lisp/window.el index f94558c6850..7fdde3ee18c 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -2616,7 +2616,36 @@ selected frame and no others." (setq best-window window)))) best-window)) -(defun get-buffer-window-list (&optional buffer-or-name minibuf all-frames) +(defun window-indirect-buffer-p (&optional window buffer-or-name) + "Return non-nil if specified WINDOW is indirectly related to BUFFER-OR-NAME. +WINDOW must be a live window and defaults to the selected window. +BUFFER-OR-NAME may be a buffer or the name of an existing buffer and +defaults to the current buffer. + +WINODW is indirectly related to BUFFER-OR-NAME if one of the following +conditions hold: + +- BUFFER-OR-NAME specifies an indirect buffer and WINDOW's buffer is its + base buffer. + +- WINDOW's buffer is an indirect buffer whose base buffer is the buffer + specified by BUFFER-OR-NAME. + +- Both, WINDOW's buffer and the buffer specified by BUFFER-OR-NAME, are + indirect buffer's sharing the same base buffer. + +Return nil if none of the above holds." + (let* ((window (window-normalize-window window t)) + (window-buffer (window-buffer window)) + (window-base-buffer (buffer-base-buffer window-buffer)) + (buffer (window-normalize-buffer buffer-or-name)) + (buffer-base-buffer (buffer-base-buffer buffer))) + (or (eq buffer-base-buffer window-buffer) + (eq window-base-buffer buffer) + (and buffer-base-buffer + (eq buffer-base-buffer window-base-buffer))))) + +(defun get-buffer-window-list (&optional buffer-or-name minibuf all-frames indirect) "Return list of all windows displaying BUFFER-OR-NAME, or nil if none. BUFFER-OR-NAME may be a buffer or the name of an existing buffer and defaults to the current buffer. If the selected window displays @@ -2645,12 +2674,23 @@ non-nil values of ALL-FRAMES have special meanings: - A frame means consider all windows on that frame only. Anything else means consider all windows on the selected frame -and no others." +and no others. + +INDIRECT non-nil means to append to the list of windows showing +BUFFER-OR-NAME a list of all windows that are indirectly related to +BUFFER-OR-NAME, that is, windows for which `window-indirect-buffer-p' +with the window and the buffer specified by BUFFER-OR-NAME as arguments +returns non-nil." (let ((buffer (window-normalize-buffer buffer-or-name)) + (window-list (window-list-1 (selected-window) minibuf all-frames)) windows) - (dolist (window (window-list-1 (selected-window) minibuf all-frames)) + (dolist (window window-list) (when (eq (window-buffer window) buffer) (setq windows (cons window windows)))) + (when indirect + (dolist (window window-list) + (when (window-indirect-buffer-p window buffer) + (setq windows (cons window windows))))) (nreverse windows))) (defun minibuffer-window-active-p (window) @@ -8348,35 +8388,56 @@ If ALIST has a non-nil `inhibit-switch-frame' entry, then in the event that a window on another frame is chosen, avoid raising that frame. +If ALIST has a non-nil `reuse-indirect' entry and no window showing +BUFFER has been found, try to find a window that is indirectly related +to BUFFER and return that window. This would be a window for which +`window-indirect-buffer-p' with the window and BUFFER as arguments +returns non-nil. If a suitable window has been found and the cdr of the +entry equals the symbol `buffer', do not replace the buffer of that +window with BUFFER but return the window with its old buffer in place. +Otherwise, put BUFFER into that window and return the window. + This is an action function for buffer display, see Info node `(elisp) Buffer Display Action Functions'. It should be called only by `display-buffer' or a function directly or indirectly called by the latter." - (let* ((alist-entry (assq 'reusable-frames alist)) - (frames (cond (alist-entry (cdr alist-entry)) + (let* ((reusable-frames (assq 'reusable-frames alist)) + (reuse-indirect (assq 'reuse-indirect alist)) + (frames (cond (reusable-frames (cdr reusable-frames)) ((window--pop-up-frames alist) 0) (display-buffer-reuse-frames 0) (t (last-nonminibuffer-frame)))) - (window (if (and (eq buffer (window-buffer)) - (not (cdr (assq 'inhibit-same-window alist)))) - (selected-window) - ;; Preferably use a window on the selected frame, - ;; if such a window exists (Bug#36680). - (let* ((windows (delq (selected-window) - (get-buffer-window-list - buffer 'nomini frames))) - (first (car windows)) - (this-frame (selected-frame))) - (cond - ((eq (window-frame first) this-frame) - first) - ((catch 'found - (dolist (next (cdr windows)) - (when (eq (window-frame next) this-frame) - (throw 'found next))))) - (t first)))))) + (inhibit-same (cdr (assq 'inhibit-same-window alist))) + (window + ;; Avoid calling 'get-buffer-window-list' if the selected + ;; window already shows BUFFER and can be used. + (if (and (eq buffer (window-buffer)) (not inhibit-same)) + (selected-window) + ;; Preferably use a window on the selected frame, + ;; if such a window exists (Bug#36680). + (let* ((windows-raw + (get-buffer-window-list + buffer 'nomini frames reuse-indirect)) + (windows (if inhibit-same + (delq (selected-window) windows-raw) + windows-raw)) + (first (car windows)) + (this-frame (selected-frame))) + (cond + ((eq (window-frame first) this-frame) + first) + ((catch 'found + (dolist (next (cdr windows)) + (when (eq (window-frame next) this-frame) + (throw 'found next))))) + (t first)))))) (when (window-live-p window) + (when (and (eq (cdr reuse-indirect) 'buffer) + (not (eq (window-buffer window) buffer))) + ;; Pretend we were asking for a window showing the buffer of + ;; that window. + (setq buffer (window-buffer window))) (prog1 (window--display-buffer buffer window 'reuse alist) (unless (cdr (assq 'inhibit-switch-frame alist)) (window--maybe-raise-frame (window-frame window))))))) commit be60601ae884214503c4f958a74cebc27e8381b6 Author: Martin Rudalics Date: Mon Feb 24 09:47:30 2025 +0100 Clarify semantics of 'frame-inhibit-implied-resize' * src/frame.c (frame_inhibit_implied_resize): * doc/lispref/frames.texi (Implied Frame Resizing): Clarify semantics of 'frame-inhibit-implied-resize'. diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 8afb2c75ff2..32d6ffc48ed 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -1234,11 +1234,22 @@ immediately after running @code{window-size-change-functions} for @cindex implied resizing of frame By default, Emacs tries to keep the number of lines and columns of a -frame's text area unaltered when, for example, toggling its menu or -tool bar, changing its default font or setting the width of any of its -scroll bars. This means that in such case Emacs must ask the window -manager to resize the frame's window in order to accommodate the size -change. +frame's text area (@pxref{Frame Layout}) unaltered when, for example, +toggling the menu or tool bar, changing the default font or setting the +default width of scroll bars on that frame. When any of these +decorations is drawn by a toolkit, this usually means that Emacs has to +work against that toolkit because the latter usually tries to keep the +outer frame size unaltered when the size of a decoration changes, thus +implicitly changing the size of the frame's text area. + + In practice this means that whenever Emacs issues a request to add or +remove such a decoration, it will issue a second request with the +intention to restore the original size of the frame's text area. When +any of these decorations is drawn by Emacs itself (like the tool bar +with the Lucid or MS-Windows builds or the tab bar), Emacs may still +have to alter the size of the native frame accordingly and issue a +resize request because these decorations should not be accounted for by +the text area of the frame. Occasionally, such @dfn{implied frame resizing} may be unwanted, for example, when a frame has been maximized or made full-screen (where @@ -1249,16 +1260,29 @@ resizing with the following option: If this option is @code{nil}, changing a frame's font, menu bar, tool bar, internal borders, fringes or scroll bars may resize its outer frame in order to keep the number of columns or lines of its text area -unaltered. If this option is @code{t}, no such resizing happens once a -frame has obtained its initial size. If the value is the symbol -@code{force}, no implicit resizing happens whenever a new frame is made. -The latter can be useful with tiling window managers where the initial -size of a frame is determined by external means. +unaltered. + +If this option is @code{t}, Emacs will not resize a frame in any of +these cases once it has agreed with the window manager on the final +initial size of that frame. More precisely, this means that Emacs may +resize a frame implicitly until all of its decorations have been taken +into account and it has been given the initial size requested by the +user. Any further changes of decorations will not cause an implied +resizing of the frame. + +If this option equals the symbol @code{force}, Emacs will not perform +any implied resizing of a frame even before it has agreed with the +window manager on the final initial size of that frame. As a +consequence, the initial size of a frame's text area may not necessarily +reflect the one specified by the user. This value can be useful with +tiling window managers where the initial size of a frame is determined +by external means. The value of this option can be also a list of frame parameters. In -that case, implied resizing is inhibited for the change of the -parameters that appear in this list. Parameters currently handled by -this option are @code{font}, @code{font-backend}, +that case, implied resizing of a frame is inhibited for the change of +any parameters that appears in this list once Emacs has agreed with the +window manager on the final initial size of that frame. Parameters +currently handled by this option are @code{font}, @code{font-backend}, @code{internal-border-width}, @code{menu-bar-lines} and @code{tool-bar-lines}. @@ -1288,11 +1312,11 @@ even if this option is non-@code{nil}. Note also that window managers usually do not ask for resizing a frame when they change the number of lines occupied by an external menu or tool bar. Typically, such ``wrappings'' occur when a user shrinks a -frame horizontally, making it impossible to display all elements of -its menu or tool bar. They may also result from a change of the major -mode altering the number of items of a menu or tool bar. Any such -wrappings may implicitly alter the number of lines of a frame's text -area and are unaffected by the setting of this option. +frame horizontally, making it impossible to display all elements of its +menu or tool bar. They may also result from a change of the major mode +altering the number of items of a menu or tool bar. Any such wrappings +may implicitly alter the number of lines of a frame's text area and are +unaffected by the setting of this option. @end defopt diff --git a/src/frame.c b/src/frame.c index 29f1f6ea208..895caed5513 100644 --- a/src/frame.c +++ b/src/frame.c @@ -7113,17 +7113,25 @@ a non-nil value in your init file. */); If this option is nil, setting font, menu bar, tool bar, tab bar, internal borders, fringes or scroll bars of a specific frame may resize the frame in order to preserve the number of columns or lines it -displays. If this option is t, no such resizing happens once a frame -has got its initial size. If this is the symbol `force', no implicit -resizing happens whenever a new frame is made. This can be useful with -tiling window managers where the initial size of a frame is determined -by external means. +displays. + +If this option is t, no such resizing happens once Emacs has agreed with +the window manager on the final initial size of a frame. That size will +have taken into account the size of the text area requested by the user +and the size of all decorations initially present on the frame. + +If this is the symbol `force', no implicit resizing happens even before +a frame has obtained its final initial size. As a consequence, the +initial frame size may not necessarily be the one requested by the user. +This value can be useful with tiling window managers where the initial +size of a frame is determined by external means. The value of this option can be also a list of frame parameters. In -this case, resizing is inhibited when changing a parameter that -appears in that list. The parameters currently handled by this option -include `font', `font-backend', `internal-border-width', -`menu-bar-lines', `tool-bar-lines' and `tab-bar-lines'. +this case, resizing is inhibited once a frame has obtained its final +initial size when changing a parameter that appears in that list. The +parameters currently handled by this option include `font', +`font-backend', `internal-border-width', `menu-bar-lines', +`tool-bar-lines' and `tab-bar-lines'. Changing any of the parameters `scroll-bar-width', `scroll-bar-height', `vertical-scroll-bars', `horizontal-scroll-bars', `left-fringe' and