From: Po Lu Date: Mon, 24 Feb 2025 13:06:30 +0000 (+0800) Subject: ; Begin integrating facilities for executing ERT tests on Android X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=2fc114b71395957ee2cc2941817ae4fe8587392c;p=emacs.git ; 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. (cherry picked from commit 08077788dbcc535e8840495d62cee79434766b3d) --- 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: