Ensure correct ordering of process writes.

* process.c (make_process): Initialize write_queue.
(write_queue_push, write_queue_pop): New functions.
(send_process): Use them to maintain correct ordering of process writes.

Fixes: debbugs:10815

3 files changed, 113 insertions, 30 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 84be53f43d6..ba029611cdb 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,10 @@
+2012-06-17  Troels Nielsen  <bn.troels@gmail.com>
+
+        * process.c (make_process): Initialize write_queue.
+        (write_queue_push, write_queue_pop): New functions.
+        (send_process): Use them to maintain correct ordering of process
+        writes (Bug#10815).
+
 2012-06-17  Paul Eggert  <eggert@cs.ucla.edu>
 
         * lisp.h (eassert): Assume C89 or later.
diff --git a/src/process.c b/src/process.c
index 6e454db6b4c..0434caf7574 100644
--- a/src/process.c
+++ b/src/process.c
@@ -638,6 +638,7 @@ make_process (Lisp_Object name)
   p->status = Qrun;
   p->mark = Fmake_marker ();
   p->kill_without_query = 0;
+  p->write_queue = Qnil;
 
 #ifdef ADAPTIVE_READ_BUFFERING
   p->adaptive_read_buffering = 0;
@@ -5371,6 +5372,78 @@ send_process_trap (int ignore)
   longjmp (send_process_frame, 1);
 }
 
+/* In send_process, when a write fails temporarily,
+   wait_reading_process_output is called.  It may execute user code,
+   e.g. timers, that attempts to write new data to the same process.
+   We must ensure that data is sent in the right order, and not
+   interspersed half-completed with other writes (Bug#10815).  This is
+   handled by the write_queue element of struct process.  It is a list
+   with each entry having the form
+
+   (string . (offset . length))
+
+   where STRING is a lisp string, OFFSET is the offset into the
+   string's byte sequence from which we should begin to send, and
+   LENGTH is the number of bytes left to send.  */
+
+/* Create a new entry in write_queue.
+   INPUT_OBJ should be a buffer, string Qt, or Qnil.
+   BUF is a pointer to the string sequence of the input_obj or a C
+   string in case of Qt or Qnil.  */
+
+static void
+write_queue_push (struct Lisp_Process *p, Lisp_Object input_obj,
+                  const char *buf, int len, int front)
+{
+  EMACS_INT offset;
+  Lisp_Object entry, obj;
+
+  if (STRINGP (input_obj))
+    {
+      offset = buf - SSDATA (input_obj);
+      obj = input_obj;
+    }
+  else
+    {
+      offset = 0;
+      obj = make_unibyte_string (buf, len);
+    }
+
+  entry = Fcons (obj, Fcons (make_number (offset), make_number (len)));
+
+  if (front)
+    p->write_queue = Fcons (entry, p->write_queue);
+  else
+    p->write_queue = nconc2 (p->write_queue, Fcons (entry, Qnil));
+}
+
+/* Remove the first element in the write_queue of process P, put its
+   contents in OBJ, BUF and LEN, and return non-zero.  If the
+   write_queue is empty, return zero.  */
+
+static int
+write_queue_pop (struct Lisp_Process *p, Lisp_Object *obj,
+                 const char **buf, EMACS_INT *len)
+{
+  Lisp_Object entry, offset_length;
+  EMACS_INT offset;
+
+  if (NILP (p->write_queue))
+    return 0;
+
+  entry = XCAR (p->write_queue);
+  p->write_queue = XCDR (p->write_queue);
+
+  *obj = XCAR (entry);
+  offset_length = XCDR (entry);
+
+  *len = XINT (XCDR (offset_length));
+  offset = XINT (XCAR (offset_length));
+  *buf = SDATA (*obj) + offset;
+
+  return 1;
+}
+
 /* Send some data to process PROC.
    BUF is the beginning of the data; LEN is the number of characters.
    OBJECT is the Lisp object that the data comes from.  If OBJECT is
@@ -5389,11 +5462,8 @@ send_process (volatile Lisp_Object proc, const char *volatile buf,
   struct Lisp_Process *p = XPROCESS (proc);
   ssize_t rv;
   struct coding_system *coding;
-  struct gcpro gcpro1;
   void (*volatile old_sigpipe) (int);
 
-  GCPRO1 (object);
-
   if (p->raw_status_new)
     update_status (p);
   if (! EQ (p->status, Qrun))
@@ -5505,22 +5575,37 @@ send_process (volatile Lisp_Object proc, const char *volatile buf,
   if (!setjmp (send_process_frame))
     {
       p = XPROCESS (proc);  /* Repair any setjmp clobbering.  */
-
       process_sent_to = proc;
-      while (len > 0)
+
+      /* If there is already data in the write_queue, put the new data
+         in the back of queue.  Otherwise, ignore it.  */
+      if (!NILP (p->write_queue))
+        write_queue_push (p, object, buf, len, 0);
+
+      do   /* while !NILP (p->write_queue) */
         {
-          ptrdiff_t this = len;
+          EMACS_INT cur_len = -1;
+          const char *cur_buf;
+          Lisp_Object cur_object;
+
+          /* If write_queue is empty, ignore it.  */
+          if (!write_queue_pop (p, &cur_object, &cur_buf, &cur_len))
+            {
+              cur_len = len;
+              cur_buf = buf;
+              cur_object = object;
+            }
 
-          /* Send this batch, using one or more write calls.  */
-          while (this > 0)
+          while (cur_len > 0)
             {
+              /* Send this batch, using one or more write calls.  */
               ptrdiff_t written = 0;
               int outfd = p->outfd;
               old_sigpipe = (void (*) (int)) signal (SIGPIPE, send_process_trap);
 #ifdef DATAGRAM_SOCKETS
               if (DATAGRAM_CHAN_P (outfd))
                 {
-                  rv = sendto (outfd, buf, this,
+                  rv = sendto (outfd, cur_buf, cur_len,
                                0, datagram_address[outfd].sa,
                                datagram_address[outfd].len);
                   if (0 <= rv)
@@ -5537,10 +5622,10 @@ send_process (volatile Lisp_Object proc, const char *volatile buf,
                 {
 #ifdef HAVE_GNUTLS
                   if (p->gnutls_p)
-                    written = emacs_gnutls_write (p, buf, this);
+                    written = emacs_gnutls_write (p, cur_buf, cur_len);
                   else
 #endif
-                    written = emacs_write (outfd, buf, this);
+                    written = emacs_write (outfd, cur_buf, cur_len);
                   rv = (written ? 0 : -1);
 #ifdef ADAPTIVE_READ_BUFFERING
                   if (p->read_output_delay > 0
@@ -5595,35 +5680,26 @@ send_process (volatile Lisp_Object proc, const char *volatile buf,
                         }
 #endif /* BROKEN_PTY_READ_AFTER_EAGAIN */
 
-                      /* Running filters might relocate buffers or strings.
-                         Arrange to relocate BUF.  */
-                      if (BUFFERP (object))
-                        offset = BUF_PTR_BYTE_POS (XBUFFER (object),
-                                                   (unsigned char *) buf);
-                      else if (STRINGP (object))
-                        offset = buf - SSDATA (object);
-
+                      /* Put what we should have written in
+                         wait_queue */
+                      write_queue_push (p, cur_object, cur_buf, cur_len, 1);
 #ifdef EMACS_HAS_USECS
                       wait_reading_process_output (0, 20000, 0, 0, Qnil, NULL, 0);
 #else
                       wait_reading_process_output (1, 0, 0, 0, Qnil, NULL, 0);
 #endif
-
-                      if (BUFFERP (object))
-                        buf = (char *) BUF_BYTE_ADDRESS (XBUFFER (object),
-                                                         offset);
-                      else if (STRINGP (object))
-                        buf = offset + SSDATA (object);
+                      /* reread queue, to see what is left */
+                      break;
                     }
                   else
                     /* This is a real error.  */
                     report_file_error ("writing to process", Fcons (proc, Qnil));
                 }
-              buf += written;
-              len -= written;
-              this -= written;
+              cur_buf += written;
+              cur_len -= written;
             }
         }
+      while (!NILP (p->write_queue));
     }
   else
     {
@@ -5636,8 +5712,6 @@ send_process (volatile Lisp_Object proc, const char *volatile buf,
       deactivate_process (proc);
       error ("SIGPIPE raised on process %s; closed it", SDATA (p->name));
     }
-
-  UNGCPRO;
 }
 
 DEFUN ("process-send-region", Fprocess_send_region, Sprocess_send_region,
diff --git a/src/process.h b/src/process.h
index edb937893b0..ae4b6b61c94 100644
--- a/src/process.h
+++ b/src/process.h
@@ -77,6 +77,8 @@ struct Lisp_Process
     Lisp_Object encode_coding_system;
     /* Working buffer for encoding.  */
     Lisp_Object encoding_buf;
+    /* Queue for storing waiting writes */
+    Lisp_Object write_queue;
 
 #ifdef HAVE_GNUTLS
     Lisp_Object gnutls_cred_type;