--- a/lisp/code-process.el	Thu Oct 02 10:19:00 2014 +0200
+++ b/lisp/code-process.el	Tue Oct 07 21:16:10 2014 -0600
@@ -271,9 +271,169 @@
 
 See also the function `find-operation-coding-system'.")
 
-(defun open-network-stream (name buffer host service &optional protocol)
+(defun network-stream-get-response (stream start end-of-command)
+  (when end-of-command
+    (with-current-buffer (process-buffer stream)
+      (save-excursion
+	(goto-char start)
+	(while (and (memq (process-status stream) '(open run))
+		    (not (re-search-forward end-of-command nil t)))
+	  (accept-process-output stream 0 50)
+	  (goto-char start))
+	;; Return the data we got back, or nil if the process died.
+	(unless (= start (point))
+	  (buffer-substring start (point)))))))
+
+(defun network-stream-command (stream command eoc)
+  (when command
+    (let ((start (point-max (process-buffer stream))))
+      (process-send-string stream command)
+      (network-stream-get-response stream start eoc))))
+
+(defun network-stream-open-plain (name buffer host service parameters)
+  (let ((start (point buffer))
+	(stream
+	 (open-network-stream-internal name buffer host service
+				       (plist-get parameters :protocol))))
+    (list stream
+	  (network-stream-get-response stream start
+				       (plist-get parameters :end-of-command))
+	  nil
+	  'plain)))
+
+(defun network-stream-open-tls (name buffer host service parameters)
+  (with-current-buffer buffer
+    (let* ((start (point-max))
+	   (stream
+	    (open-network-stream-internal name buffer host service
+					  (plist-get parameters :protocol) t)))
+      (if (null stream)
+	  (list nil nil nil 'plain)
+	(let ((eoc (plist-get parameters :end-of-command))
+	      (capability-command (plist-get parameters :capability-command)))
+	  (list stream
+		(network-stream-get-response stream start eoc)
+		(network-stream-command stream capability-command eoc)
+		'tls))))))
+
+(defun network-stream-certificate (host service parameters)
+  (let ((spec (plist-get :client-certificate parameters)))
+    (cond
+     ((listp spec)
+      ;; Either nil or a list with a key/certificate pair.
+      spec)
+     ((eq spec t)
+      (when (fboundp 'auth-source-search)
+	(let* ((auth-info
+		(car (auth-source-search :max 1
+					 :host host
+					 :port service)))
+	       (key (plist-get auth-info :key))
+	       (cert (plist-get auth-info :cert)))
+	  (and key cert
+	       (list key cert))))))))
+
+(defun network-stream-open-starttls (name buffer host service parameters)
+  (let* ((start (point buffer))
+	 (require-tls    (eq (plist-get parameters :type) 'starttls))
+	 (starttls-function  (plist-get parameters :starttls-function))
+	 (success-string     (plist-get parameters :success))
+	 (capability-command (plist-get parameters :capability-command))
+	 (eoc                (plist-get parameters :end-of-command))
+	 (eo-capa        (or (plist-get parameters :end-of-capability) eoc))
+	 (protocol           (plist-get parameters :protocol))
+	 ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE)
+	 (stream (open-network-stream-internal name buffer host service
+					       protocol))
+	 (greeting (and (not (plist-get parameters :nogreeting))
+			(network-stream-get-response stream start eoc)))
+	 (capabilities (network-stream-command stream capability-command
+					       eo-capa))
+	 (resulting-type 'plain)
+	 starttls-available starttls-command error)
+
+    ;; First check whether the server supports STARTTLS at all.
+    (when (and capabilities success-string starttls-function)
+      (setq starttls-command
+	    (funcall starttls-function capabilities)))
+    ;; If we have built-in STARTTLS support, try to upgrade the
+    ;; connection.
+    (when (and starttls-command
+	       (setq starttls-available t)
+	       (not (eq (plist-get parameters :type) 'plain)))
+      (when (let ((response
+		   (network-stream-command stream starttls-command eoc)))
+	      (and response (string-match success-string response)))
+	;; The server said it was OK to begin STARTTLS negotiations.
+	(let ((cert (network-stream-certificate host service parameters)))
+	  (condition-case nil
+	      (tls-negotiate stream host (and cert (list cert)))
+	    ;; If we get a tls-specific error (for instance if the
+	    ;; certificate the server gives us is completely syntactically
+	    ;; invalid), then close the connection and possibly (further
+	    ;; down) try to create a non-encrypted connection.
+	    (gnutls-error (delete-process stream))))
+	(if (memq (process-status stream) '(open run))
+	    (setq resulting-type 'tls)
+	  ;; We didn't successfully negotiate STARTTLS; if TLS
+	  ;; isn't demanded, reopen an unencrypted connection.
+	  (unless require-tls
+	    (setq stream
+		  (make-network-process :name name :buffer buffer
+					:host host :service service))
+	    (network-stream-get-response stream start eoc)))
+	;; Re-get the capabilities, which may have now changed.
+	(setq capabilities
+	      (network-stream-command stream capability-command eo-capa))))
+
+    ;; If TLS is mandatory, close the connection if it's unencrypted.
+    (when (and require-tls
+	       ;; ... but Emacs wasn't able to -- either no built-in
+	       ;; support, or no gnutls-cli installed.
+	       (eq resulting-type 'plain))
+      (setq error
+	    (if (or (null starttls-command)
+		    starttls-available)
+		"Server does not support TLS"
+	      ;; See `starttls-available-p'.  If this predicate
+	      ;; changes to allow running under Windows, the error
+	      ;; message below should be amended.
+	      (if (memq system-type '(windows-nt ms-dos))
+		  (concat "Emacs does not support TLS")
+		(concat "Emacs does not support TLS, and no external `"
+			(if starttls-use-gnutls
+			    starttls-gnutls-program
+			  starttls-program)
+			"' program was found"))))
+      (delete-process stream)
+      (setq stream nil))
+    ;; Return value:
+    (list stream greeting capabilities resulting-type error)))
+
+;; Requires that format-spec.el from gnus be loaded
+(defun network-stream-open-shell (name buffer host service parameters)
+  (require 'format-spec)
+  (let* ((capability-command (plist-get parameters :capability-command))
+	 (eo-capa            (plist-get parameters :end-of-capability))
+	 (eoc                (plist-get parameters :end-of-command))
+	 (start (point buffer))
+	 (stream (let ((process-connection-type nil))
+		   (start-process name buffer shell-file-name
+				  shell-command-switch
+				  (format-spec
+				   (plist-get parameters :shell-command)
+				   (format-spec-make
+				    ?s host
+				    ?p service))))))
+    (list stream
+	  (network-stream-get-response stream start eoc)
+	  (network-stream-command stream capability-command (or eo-capa eoc))
+	  'plain)))
+
+(defun open-network-stream (name buffer host service &rest parameters)
   "Open a TCP connection for a service to a host.
-Return a process object to represent the connection.
+Normally, return a process object to represent the connection.  If the
+:return-list parameter is non-NIL, instead return a list; see below.
 Input and output work as for subprocesses; `delete-process' closes it.
 NAME is name for process.  It is modified if necessary to make it unique.
 BUFFER is the buffer (or buffer-name) to associate with the process.
@@ -284,9 +444,64 @@
 Third arg is name of the host to connect to, or its IP address.
 Fourth arg SERVICE is name of the service desired, or an integer
  specifying a port number to connect to.
-Fifth argument PROTOCOL is a network protocol.  Currently 'tcp
- (Transmission Control Protocol) and 'udp (User Datagram Protocol) are
- supported.  When omitted, 'tcp is assumed.
+
+The remaining PARAMETERS should be a sequence of keywords and values:
+- :protocol is a network protocol.  Currently 'tcp (Transmission Control
+   Protocol) and 'udp (User Datagram Protocol) are supported.  When
+   omitted, 'tcp is assumed.
+- :type specifies the connection type; it is one of the following:
+  nil or `network': begin with an ordinary network connection, and if
+              the parameters :success and :capability-command are also
+              supplied, try to upgrade to an encrypted connection via
+              STARTTLS.  If that fails (e.g., HOST does not support TLS),
+              retain an unencrypted connection.
+  `plain': an ordinary, unencrypted network connection.
+  `starttls': begin with an ordinary network connection and try to
+              upgrade via STARTTLS.  If that fails, drop the connection
+              and return a killed process object.
+  `tls': a TLS connection.
+  `ssl': a synonym for `tls'.
+  `shell': a shell connection.
+- :return-list specifies this function's return value.
+  If omitted or nil, return a process object as usual.  Otherwise, return
+  (PROC . PROPS), where PROC is a process object and PROPS is a plist of
+  connection properties, with these keywords:
+  :greeting: the greeting returned by HOST (a string), or nil.
+  :capabilities: a string representing HOST's capabilities, or nil if none
+              could be found.
+  :type: the resulting connection type, `plain' (unencrypted) or `tls'
+              (encrypted).
+- :end-of-command specifies a regexp matching the end of a command.
+- :end-of-capability specifies a regexp matching the end of the response
+  to the command specified for :capability-command.  It defaults to the
+  regexp specified for :end-of-command.
+- :success specifies a regexp matching a message indicating a successful
+  STARTTLS negotiation.  For example, the default should be \"^3\" for an
+  NNTP connection.
+- :capability-command specifies a command used to query HOST for its
+  capabilities.  For example, this should be \"1 CAPABILITY\\r\\n\" for
+  IMAP.
+- :starttls-function specifies a function for handling STARTTLS.  This
+  function should take one parameter, the response to the capability
+  command, and should return the command to switch on STARTTLS if the
+  server supports it, or nil otherwise.
+- :always-query-capabilities, if non-nil, indicates that the server should
+  be queried for capabilities even if constructing a `plain' network
+  connection.
+- :client-certificate is either a list (certificate-key-filename
+  certificate-filename), or `t', meaning that `auth-source' will be
+  queried for the key and certificate.  This parameter is used only when
+  constructing a TLS or STARTTLS connection.
+- :use-starttls-if-possible, if non-nil, indicates that STARTTLS should
+  be used even if TLS support is not compiled in to XEmacs.
+- :nogreeting, if non-nil, indicates that we should not wait for a
+  greeting from the server.
+- :nowait, if non-nil, indicates that an asynchronous connection should be
+  made, if possible.  NOTE: this is currently unimplemented.
+
+For backwards compatibility, if exactly five arguments are given, the fifth
+must be one of nil, 'tcp, or 'udp.  Both nil and 'tcp select TCP (Transmission
+Control Protocol) and 'udp selects UDP (User Datagram Protocol).
 
 Output via `process-send-string' and input via buffer or filter (see
 `set-process-filter') are stream-oriented.  That means UDP datagrams are
@@ -315,6 +530,8 @@
 You can change the coding systems later on using
 `set-process-coding-system', `set-process-input-coding-system', or
 `set-process-output-coding-system'."
+  (when (and (car parameters) (not (cdr parameters)))
+    (setq parameters (list :protocol (car parameters))))
   (let (cs-r cs-w)
     (let (ret)
       (catch 'found
@@ -351,8 +568,44 @@
 	  (coding-system-for-write
 	   (or coding-system-for-write cs-w
 	       (cdr default-network-coding-system)
-	       'raw-text)))
-      (open-network-stream-internal name buffer host service protocol))))
+	       'raw-text))
+	  (type (plist-get parameters :type))
+	  (return-list (plist-get parameters :return-list))
+	  (capability-command (plist-get parameters :capability-command)))
+      (if (and (not return-list)
+	       (or (eq type 'plain)
+		   (and (or (null type) (eq type 'network))
+			(not (and (plist-get parameters :success)
+				  capability-command)))))
+	  ;; The simplest case: a plain connection
+	  (open-network-stream-internal name buffer host service
+					(plist-get parameters :protocol))
+	(let ((work-buffer (or buffer
+			       (generate-new-buffer " *stream buffer*")))
+	      (fun (cond ((and (eq type 'plain)
+			       (not (plist-get parameters
+					       :always-query-capabilities)))
+			  #'network-stream-open-plain)
+			 ((memq type '(nil network starttls plain))
+			  #'network-stream-open-starttls)
+			 ((memq type '(tls ssl)) #'network-stream-open-tls)
+			 ((eq type 'shell) 'network-stream-open-shell)
+			 (t (error "Invalid connection type" type))))
+	      result)
+	  (unwind-protect
+	      (setq result
+		    (funcall fun name work-buffer host service parameters))
+	    (unless buffer
+	      (and (processp (car result))
+		   (set-process-buffer (car result) nil))
+	      (kill-buffer work-buffer)))
+	  (if return-list
+	      (list (car result)
+		    :greeting     (nth 1 result)
+		    :capabilities (nth 2 result)
+		    :type         (nth 3 result)
+		    :error        (nth 4 result))
+	    (car result)))))))
 
 (defun set-buffer-process-coding-system (decoding encoding)
   "Set coding systems for the process associated with the current buffer.