[elpa] externals/async 5e57e7ff25 6/6: Merge pull request #170 from Fuco1/fix/robust-message-parsing

[ELPA Syncer]

branch: externals/async
commit 5e57e7ff257e2986491275d09383d6773555af57
Merge: 2fa8184141 9783eb44e4
Author: Thierry Volpiatto <thievol@posteo.net>
Commit: GitHub <noreply@github.com>

    Merge pull request #170 from Fuco1/fix/robust-message-parsing
    
    fix: make reading of child message packets more robust
---
 .github/workflows/test.yml |  62 ++++++++++++
 .gitignore                 |   1 +
 Eask                       |  20 ++++
 async.el                   | 131 ++++++++++++++++----------
 tests/test-async.el        | 229 +++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 395 insertions(+), 48 deletions(-)

diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml
new file mode 100644
index 0000000000..823502a960
--- /dev/null
+++ b/.github/workflows/test.yml
@@ -0,0 +1,62 @@
+name: CI
+
+on:
+  push:
+    branches:
+      - master
+  pull_request:
+  workflow_dispatch:
+
+concurrency:
+  group: ${{ github.workflow }}-${{ github.ref }}
+  cancel-in-progress: true
+
+jobs:
+  test:
+    runs-on: ${{ matrix.os }}
+    strategy:
+      fail-fast: false
+      matrix:
+        os: [ubuntu-latest, macos-latest, windows-latest]
+        emacs-version:
+          - '26.1'
+          - '26.2'
+          - '26.3'
+          - '27.1'
+          - '27.2'
+          - '28.1'
+          - '28.2'
+          - snapshot
+
+    steps:
+    - uses: actions/checkout@v3
+
+    - uses: jcs090218/setup-emacs@master
+      with:
+        version: ${{ matrix.emacs-version }}
+
+    - uses: emacs-eask/setup-eask@master
+      with:
+        version: 'snapshot'
+
+    - name: Workaround for Emacs 27.2's Windows build from GNU FTP
+      if: ${{ runner.os == 'Windows' && contains(fromJson('["26.1", "26.2", 
"26.3", "27.1", "27.2"]'), matrix.emacs-version) }}
+      run: |
+        gci cert:\LocalMachine\Root\DAC9024F54D8F6DF94935FB1732638CA6AD77C13
+        gci cert:\LocalMachine\Root\DAC9024F54D8F6DF94935FB1732638CA6AD77C13 | 
Remove-Item
+
+    - name: Install dependencies
+      run: |
+        eask install-deps --dev
+
+    - name: Run buttercup
+      timeout-minutes: 1
+      run: |
+        eask test buttercup
+
+    - name: Run tests
+      run: |
+        eask clean all
+        eask package
+        eask install
+        eask compile
diff --git a/.gitignore b/.gitignore
index bb6d27f575..cc2266d847 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,4 @@
 *.elc
 *~
 async-autoloads.el
+/.eask
diff --git a/Eask b/Eask
new file mode 100644
index 0000000000..e6c61085b4
--- /dev/null
+++ b/Eask
@@ -0,0 +1,20 @@
+(package "async"
+         "1.9.7"
+         "Asynchronous processing in Emacs")
+
+(website-url "https://github.com/jwiegley/emacs-async";)
+(keywords "async")
+
+(package-file "async.el")
+
+(files "async.el" "async-bytecomp.el" "*-async.el")
+
+(script "test" "echo \"Error: no test specified\" && exit 1")
+
+(source "gnu")
+(source "nongnu")
+
+(depends-on "emacs" "24.4")
+
+(development
+ (depends-on "buttercup"))
diff --git a/async.el b/async.el
index e4a2854590..ad76c27ac1 100644
--- a/async.el
+++ b/async.el
@@ -46,11 +46,17 @@
 (defvar async-send-over-pipe t)
 (defvar async-in-child-emacs nil)
 (defvar async-callback nil)
-(defvar async-callback-for-process nil)
+(defvar async-callback-for-process nil
+  "Non-nil if the subprocess is not Emacs executing a lisp form.")
 (defvar async-callback-value nil)
 (defvar async-callback-value-set nil)
 (defvar async-current-process nil)
 (defvar async--procvar nil)
+(defvar async-read-marker nil
+  "Position from which we read the last message packet.
+
+Message packets are delivered from client line-by-line as base64
+encoded strings.")
 (defvar async-child-init nil
   "Initialisation file for async child Emacs.
 
@@ -180,6 +186,7 @@ It is intended to be used as follows:
               ;; Maybe strip out unreadable "#"; They are replaced by
               ;; empty string unless they are prefixing a special
               ;; object like a marker. See issue #145.
+              (widen)
               (goto-char (point-min))
               (save-excursion
                 ;; Transform markers in list like
@@ -192,52 +199,57 @@ It is intended to be used as follows:
                 (replace-match "(" t t))
               (goto-char (point-max))
               (backward-sexp)
-              (async-handle-result async-callback (read (current-buffer))
-                                   (current-buffer)))
+              (let ((value (read (current-buffer))))
+                (async-handle-result async-callback value (current-buffer))))
           (set (make-local-variable 'async-callback-value)
                (list 'error
                      (format "Async process '%s' failed with exit code %d"
                              (process-name proc) (process-exit-status proc))))
           (set (make-local-variable 'async-callback-value-set) t))))))
 
-(defun async--process-filter-line-buffering-decorator (filter)
-  "Decorate a process FILTER with line-buffering logic.
-
-Return a new process filter based on FILTER.
-
-FILTER is a function which could be used with `set-process-filter'.
-
-This decorator buffers input until it can pass a complete line
-further to the supplied FILTER.  It is useful as a buffer between
-a process producing data and an Emacs function operating on the
-data which expects to get complete lines as input."
-  (let ((data ""))
-    (lambda (process string)
-      (with-current-buffer (process-buffer process)
-        (insert string))
-
-      (let* ((line-data (split-string (concat data string) "\n")))
-        (while (cdr line-data)
-          (funcall filter process (car line-data))
-          (pop line-data))
-        (setq data (car line-data))))))
-
 (defun async-read-from-client (proc string)
-  ;; parse message
-  (with-temp-buffer
-    (insert string)
-    (goto-char (point-min))
-    (let (msg)
-      (condition-case nil
-          (while (setq msg (read (current-buffer)))
-            (when-let ((msg-decoded (ignore-errors (base64-decode-string 
msg))))
-              (setq msg-decoded (car (read-from-string msg-decoded)))
-              (with-current-buffer (process-buffer proc)
-                (when async-callback
-                  (funcall async-callback msg-decoded)))))
-        ;; This is OK, we reached the end of the chunk subprocess sent
-        ;; at this time.
-        (end-of-file t)))))
+  "Process text from client process.
+
+The string chunks usually arrive in maximum of 4096 bytes, so a
+long client message might be split into multiple calls of this
+function.
+
+We use a marker `async-read-marker' to track the position of the
+lasts complete line.  Every time we get new input, we try to look
+for newline, and if found, process the entire line and bump the
+marker position to the end of this next line."
+  (with-current-buffer (process-buffer proc)
+    (goto-char (point-max))
+    (save-excursion
+      (insert string))
+
+    (while (search-forward "\n" nil t)
+      (save-excursion
+        (save-restriction
+          (widen)
+          (narrow-to-region async-read-marker (point))
+          (goto-char (point-min))
+          (let (msg)
+            (condition-case nil
+                ;; It is safe to throw errors in the read because we
+                ;; send messages always on their own line, and they
+                ;; are always a base64 encoded string, so a message
+                ;; will always read.  We will also ignore the rest
+                ;; of this line since there won't be anything
+                ;; interesting.
+                (while (setq msg (read (current-buffer)))
+                  (when-let ((msg-decoded (ignore-errors (base64-decode-string 
msg))))
+                    (setq msg-decoded (car (read-from-string msg-decoded)))
+                    (when (and (listp msg-decoded)
+                               (async-message-p msg-decoded)
+                               async-callback)
+                      (funcall async-callback msg-decoded))))
+              ;; This is OK, we reached the end of the chunk subprocess sent
+              ;; at this time.
+              (invalid-read-syntax t)
+              (end-of-file t)))
+          (goto-char (point-max))
+          (move-marker async-read-marker (point)))))))
 
 (defun async--receive-sexp (&optional stream)
   ;; FIXME: Why use `utf-8-auto' instead of `utf-8-unix'?  This is
@@ -288,11 +300,21 @@ data which expects to get complete lines as input."
           debug-on-error async-debug
           command-line-args-left nil)
     (condition-case-unless-debug err
-        (prin1 (funcall
-                (async--receive-sexp (unless async-send-over-pipe
-                                       args-left))))
+        (let ((ret (funcall
+                    (async--receive-sexp (unless async-send-over-pipe
+                                           args-left)))))
+          ;; The newlines makes client messages more robust and also
+          ;; handle some weird line-buffering issues on windows.
+          ;; Sometimes, the last "chunk" was not read by the filter,
+          ;; so a newline here should force a buffer flush.
+          (princ "\n")
+          (prin1 ret)
+          (princ "\n"))
       (error
-       (prin1 (list 'async-signal err))))))
+       (progn
+         (princ "\n")
+         (prin1 (list 'async-signal err))
+         (princ "\n"))))))
 
 (defun async-ready (future)
   "Query a FUTURE to see if it is ready.
@@ -341,10 +363,14 @@ optionally more key-value pairs.  Example:
   (async-send :status \"finished\" :file-size 123)"
   (let ((args (append args '(:async-message t))))
     (if async-in-child-emacs
+        ;; `princ' because async--insert-sexp already quotes everything.
         (princ
          (with-temp-buffer
            (async--insert-sexp (cons process-or-key args))
-           (buffer-string)))
+           ;; always make sure that one message package has its own
+           ;; line as there can be any random debug garbage printed
+           ;; above it.
+           (concat "\n" (buffer-string))))
       (async--transmit-sexp process-or-key (list 'quote args)))))
 
 (defun async-receive ()
@@ -374,13 +400,22 @@ object will return the process object when the program is
 finished.  Set DEFAULT-DIRECTORY to change PROGRAM's current
 working directory."
   (let* ((buf (generate-new-buffer (concat "*" name "*")))
+         (buf-err (generate-new-buffer (concat "*" name "*:err")))
          (proc (let ((process-connection-type nil))
-                 (apply #'start-process name buf program program-args))))
+                 (make-process
+                  :name name
+                  :buffer buf
+                  :stderr buf-err
+                  :command (cons program program-args)))))
     (with-current-buffer buf
       (set (make-local-variable 'async-callback) finish-func)
+
+      (set (make-local-variable 'async-read-marker)
+           (set-marker (make-marker) (point-min) buf))
+      (set-marker-insertion-type async-read-marker nil)
+
       (set-process-sentinel proc #'async-when-done)
-      (set-process-filter proc (async--process-filter-line-buffering-decorator
-                                #'async-read-from-client))
+      (set-process-filter proc #'async-read-from-client)
       (unless (string= name "emacs")
         (set (make-local-variable 'async-callback-for-process) t))
       proc)))
diff --git a/tests/test-async.el b/tests/test-async.el
new file mode 100644
index 0000000000..7bc9ef0e4c
--- /dev/null
+++ b/tests/test-async.el
@@ -0,0 +1,229 @@
+;; -*- lexical-binding: t -*-
+
+(require 'buttercup)
+(require 'async)
+
+(describe "Async Core"
+
+  (describe "Running emacs lisp in a subprocess"
+
+    (it "should execute function in subprocess and pass result back to parent 
through a callback"
+
+      (let ((messages nil))
+        (push "Starting async-test-1..." messages)
+
+        (async-start
+         ;; What to do in the child process
+         (lambda ()
+           (message "This is a test")
+           (sleep-for 0.5)
+           222)
+
+         ;; What to do when it finishes
+         (lambda (result)
+           (push (format "Async process done, result should be 222: %s" 
result) messages)))
+
+        (push "Starting async-test-1...done" messages)
+        (sleep-for 1)
+
+        (expect (string-join (nreverse messages) "\n")
+                :to-equal "Starting async-test-1...\nStarting 
async-test-1...done\nAsync process done, result should be 222: 222")))
+
+    (it "should let the user do work while subprocess runs and then wait for 
the result"
+
+      (let ((messages nil))
+        (push "Starting async-test-2..." messages)
+        (let ((proc (async-start
+                     ;; What to do in the child process
+                     (lambda ()
+                       (message "This is a test")
+                       (sleep-for 0.5)
+                       222))))
+          (push "I'm going to do some work here" messages)
+          ;; ....
+          (push (format "Async process done, result should be 222: %s" 
(async-get proc)) messages))
+
+        (expect (string-join (nreverse messages) "\n")
+                :to-equal "Starting async-test-2...\nI'm going to do some work 
here\nAsync process done, result should be 222: 222")))
+
+    (xit "should allow both a callback and async-get for the same future"
+      (let ((messages nil))
+        (push "Starting async-test..." messages)
+        (let ((proc (async-start
+                     ;; What to do in the child process
+                     (lambda ()
+                       (sleep-for 0.5)
+                       222)
+
+                     (lambda (result)
+                       (push (format "%s" result) messages)))))
+          (push "I'm going to do some work here" messages)
+
+          (push (format "async-get: %s" (async-get proc)) messages))
+
+        (expect (string-join (nreverse messages) "\n")
+                :to-equal "Starting async-test...\nI'm going to do some work 
here\n222\nasync-get: 222")))
+
+    (it "should handle errors in the child process"
+
+      (expect (progn
+                (let ((messages nil))
+                  (push "Starting async-test-3..." messages)
+                  (async-start
+                   ;; What to do in the child process
+                   (lambda ()
+                     (message "This is a test")
+                     (sleep-for 0.5)
+                     (error "Error in child process")
+                     222)
+
+                   ;; What to do when it finishes
+                   (lambda (result)
+                     (push (format "Async process done, result should be 222: 
%s" result) messages)))
+                  (push "Starting async-test-3...done" messages)
+
+                  (expect (string-join (nreverse messages) "\n")
+                          :to-equal "Starting async-test-3...\nStarting 
async-test-3...done"))
+
+                (sleep-for 1))
+              :to-throw 'error))
+
+    (it "should handle unreadable forms in the return value"
+
+      (let ((messages nil))
+        (let ((proc (async-start
+                     ;; What to do in the child process
+                     (lambda ()
+                       (message "This is a test")
+                       (sleep-for 0.1)
+                       (current-buffer))
+
+                     ;; What to do when it finishes
+                     (lambda (result)
+                       (push (format "Async process done, result should be 
222: %s" result) messages)))))
+
+          (async-get proc)
+
+          (expect (string-join (nreverse messages) "\n")
+                  :to-equal "Async process done, result should be 222: (buffer 
*scratch*)")))))
+
+  (describe "Starting non-emacs process"
+
+    (it "should start a process and return a process object"
+
+      (let ((messages nil))
+        (push "Starting async-test-4..." messages)
+        (async-start-process "sleep" "sleep"
+                             ;; What to do when it finishes
+                             (lambda (proc)
+                               (push (format "Sleep done, exit code was %d"
+                                             (process-exit-status proc))
+                                     messages))
+                             "1")
+        (push "Starting async-test-4...done" messages)
+
+        (sleep-for 1.5)
+
+        (expect (string-join (nreverse messages) "\n")
+                :to-equal "Starting async-test-4...\nStarting 
async-test-4...done\nSleep done, exit code was 0"))))
+
+  (describe "Interprocess communication"
+
+    (it "should be possible to send and receive messages between parent and 
child"
+
+      (let ((messages nil))
+        (push "Starting async-test-5..." messages)
+        (let ((proc
+               (async-start
+                ;; What to do in the child process
+                (lambda ()
+                  (message "This is a test, sending message")
+                  (async-send :hello "world")
+                  ;; wait for a message
+                  (let ((msg (async-receive)))
+                    (message "Child got message: %s"
+                             (plist-get msg :goodbye)))
+                  (sleep-for 0.5)
+                  222)
+
+                ;; What to do when it finishes
+                (lambda (result)
+                  (if (async-message-p result)
+                      (push (format "Got hello from child process: %s" 
(plist-get result :hello))
+                            messages)
+                    (push (format "Async process done, result should be 222: 
%s" result)
+                          messages))))))
+          (async-send proc :goodbye "everyone"))
+        (push "Starting async-test-5...done" messages)
+
+        (sleep-for 1)
+
+        (expect (string-join (nreverse messages) "\n")
+                :to-equal "Starting async-test-5...\nStarting 
async-test-5...done\nGot hello from child process: world\nAsync process done, 
result should be 222: 222")))
+
+    (it "child should be able to send really long messages to the parent (1 
MB)"
+
+      (let ((messages nil))
+        (let ((proc (async-start
+                     ;; What to do in the child process
+                     (lambda ()
+                       (async-send :hello (make-string 1048576 ?x))
+                       t)
+
+                     ;; What to do when it finishes
+                     (lambda (result)
+                       (if (async-message-p result)
+                           (push (plist-get result :hello) messages)
+                         (push result messages))))))
+
+          ;;(sleep-for 0.5)
+          (async-wait proc)
+          )
+
+        (expect (car messages) :to-equal t)
+        (expect (cadr messages) :to-equal (make-string 1048576 ?x))))
+
+    ;; windows process performance is horrible so we need to skip
+    ;; this as it takes too much time.
+    (unless (and (eq system-type 'windows-nt)
+                 (version< emacs-version "27"))
+      (it "child should be able to send really long messages to the parent (10 
MB)"
+
+        (let ((messages nil))
+          (let ((proc (async-start
+                       ;; What to do in the child process
+                       (lambda ()
+                         (async-send :hello (make-string 10485760 ?x))
+                         t)
+
+                       ;; What to do when it finishes
+                       (lambda (result)
+                         (if (async-message-p result)
+                             (push (plist-get result :hello) messages)
+                           (push result messages))))))
+            (async-wait proc))
+
+          (expect (car messages) :to-equal t)
+          (expect (cadr messages) :to-equal (make-string 10485760 ?x))))))
+
+  (describe "Injecting environment"
+
+    (it "should construct a form for injecting the current environment"
+      (with-temp-buffer
+        (setq-local user-mail-address "hello@gnu.org")
+
+        (let ((messages nil))
+          (push "Starting async-test-6..." messages)
+          (let ((proc (async-start
+                       ;; What to do in the child process
+                       `(lambda ()
+                          ,(async-inject-variables "\\`user-mail-address\\'")
+                          (format "user-mail-address = %s" user-mail-address))
+
+                       ;; What to do when it finishes
+                       (lambda (result)
+                         (push (format "Async process done: %s" result) 
messages)))))
+            (async-get proc))
+
+          (expect (string-join (nreverse messages) "\n")
+                  :to-equal "Starting async-test-6...\nAsync process done: 
user-mail-address = hello@gnu.org"))))))