changeset 73501:437fb645afb4

* url-http.el (url-http-mark-connection-as-free): Verify that connection is open before saving it. (url-http-handle-authentication): Use url-retrieve-internal instead of url-retrieve. (url-http-parse-headers): Adapt to new callback interface. (url-http): Handle non-blocking connections. (url-http-async-sentinel): Create. * url.el (url-retrieve): Update docstring for new callback interface. Remove all code. (url-retrieve-internal): Move code from url-retrieve here. * url-gw.el (url-open-stream): Use a non-blocking socket for `native' gateway method, if available.

--- a/lisp/url/ChangeLog	Fri Oct 27 14:39:43 2006 +0000
+++ b/lisp/url/ChangeLog	Fri Oct 27 14:44:25 2006 +0000
@@ -1,3 +1,20 @@
[phone]  Magnus Henoch  <[e-mail]>
+
+	* url-http.el (url-http-mark-connection-as-free): Verify that
+	connection is open before saving it.
+	(url-http-handle-authentication): Use url-retrieve-internal
+	instead of url-retrieve.
+	(url-http-parse-headers): Adapt to new callback interface.
+	(url-http): Handle non-blocking connections.
+	(url-http-async-sentinel): Create.
+
+	* url.el (url-retrieve): Update docstring for new callback interface.
+	Remove all code.
+	(url-retrieve-internal): Move code from url-retrieve here.
+
+	* url-gw.el (url-open-stream): Use a non-blocking socket for
+	`native' gateway method, if available.
+
 2006-10-16  Magnus Henoch  <[e-mail]>
 
 	* url-http.el (url-https-create-secure-wrapper): Always use tls

--- a/lisp/url/url-gw.el	Fri Oct 27 14:39:43 2006 +0000
+++ b/lisp/url/url-gw.el	Fri Oct 27 14:44:25 2006 +0000
@@ -210,7 +210,8 @@
 (defun url-open-stream (name buffer host service)
   "Open a stream to HOST, possibly via a gateway.
 Args per `open-network-stream'.
-Will not make a connection if `url-gateway-unplugged' is non-nil."
+Will not make a connection if `url-gateway-unplugged' is non-nil.
+Might do a non-blocking connection; use `process-status' to check."
   (unless url-gateway-unplugged
     (let ((gw-method (if (and url-gateway-local-host-regexp
 			      (not (eq 'tls url-gateway-method))
@@ -249,7 +250,11 @@
 			 (ssl
 			  (open-ssl-stream name buffer host service))
 			 ((native)
-			  (open-network-stream name buffer host service))
+			  ;; Use non-blocking socket if we can.
+			  (make-network-process :name name :buffer buffer
+						:host host :service service
+						:nowait 
+						(and nil (featurep 'make-network-process '(:nowait t)))))
 			 (socks
 			  (socks-open-network-stream name buffer host service))
 			 (telnet

--- a/lisp/url/url-http.el	Fri Oct 27 14:39:43 2006 +0000
+++ b/lisp/url/url-http.el	Fri Oct 27 14:44:25 2006 +0000
@@ -92,11 +92,12 @@
 
 (defun url-http-mark-connection-as-free (host port proc)
   (url-http-debug "Marking connection as free: %s:%d %S" host port proc)
-  (set-process-buffer proc nil)
-  (set-process-sentinel proc 'url-http-idle-sentinel)
-  (puthash (cons host port)
-	      (cons proc (gethash (cons host port) url-http-open-connections))
-	      url-http-open-connections)
+  (when (memq (process-status proc) '(open run))
+    (set-process-buffer proc nil)
+    (set-process-sentinel proc 'url-http-idle-sentinel)
+    (puthash (cons host port)
+	     (cons proc (gethash (cons host port) url-http-open-connections))
+	     url-http-open-connections))
   nil)
 
 (defun url-http-find-free-connection (host port)
@@ -336,8 +337,8 @@
 	  (let ((url-request-method url-http-method)
 		(url-request-data url-http-data)
 		(url-request-extra-headers url-http-extra-headers))
-	    (url-retrieve url url-callback-function
-                          url-callback-arguments)))))))
+	    (url-retrieve-internal url url-callback-function
+				   url-callback-arguments)))))))
 
 (defun url-http-parse-response ()
   "Parse just the response code."
@@ -520,18 +521,21 @@
            (let ((url-request-method url-http-method)
 		 (url-request-data url-http-data)
 		 (url-request-extra-headers url-http-extra-headers))
-             ;; Put in the current buffer a forwarding pointer to the new
-             ;; destination buffer.
-             ;; FIXME: This is a hack to fix url-retrieve-synchronously
-             ;; without changing the API.  Instead url-retrieve should
-             ;; either simply not return the "destination" buffer, or it
-             ;; should take an optional `dest-buf' argument.
-             (set (make-local-variable 'url-redirect-buffer)
-                  (url-retrieve redirect-uri url-callback-function
-                                (cons :redirect
-                                      (cons redirect-uri
-                                            url-callback-arguments))))
-	     (url-mark-buffer-as-dead (current-buffer))))))
+	     ;; Remember that the request was redirected.
+	     (setf (car url-callback-arguments)
+		   (nconc (list :redirect redirect-uri)
+			  (car url-callback-arguments)))
+              ;; Put in the current buffer a forwarding pointer to the new
+              ;; destination buffer.
+              ;; FIXME: This is a hack to fix url-retrieve-synchronously
+              ;; without changing the API.  Instead url-retrieve should
+              ;; either simply not return the "destination" buffer, or it
+              ;; should take an optional `dest-buf' argument.
+              (set (make-local-variable 'url-redirect-buffer)
+		   (url-retrieve-internal
+		    redirect-uri url-callback-function
+		    url-callback-arguments)
+		   (url-mark-buffer-as-dead (current-buffer)))))))
       (4				; Client error
        ;; 400 Bad Request
        ;; 401 Unauthorized
@@ -653,7 +657,13 @@
 	  ;; The request could not be understood by the server due to
 	  ;; malformed syntax.  The client SHOULD NOT repeat the
 	  ;; request without modifications.
-	  (setq success t))))
+	  (setq success t)))
+       ;; Tell the callback that an error occurred, and what the
+       ;; status code was.
+       (when success
+	 (setf (car url-callback-arguments)
+	       (nconc (list :error (list 'error 'http url-http-response-status))
+		      (car url-callback-arguments)))))
       (5
        ;; 500 Internal server error
        ;; 501 Not implemented
@@ -702,7 +712,13 @@
 	  ;; which received this status code was the result of a user
 	  ;; action, the request MUST NOT be repeated until it is
 	  ;; requested by a separate user action.
-	  nil)))
+	  nil))
+       ;; Tell the callback that an error occurred, and what the
+       ;; status code was.
+       (when success
+	 (setf (car url-callback-arguments)
+	       (nconc (list :error (list 'error 'http url-http-response-status))
+		      (car url-callback-arguments)))))
       (otherwise
        (error "Unknown class of HTTP response code: %d (%d)"
 	      class url-http-response-status)))
@@ -1089,11 +1105,38 @@
                                     url-current-object))
 
 	(set-process-buffer connection buffer)
-	(set-process-sentinel connection 'url-http-end-of-document-sentinel)
 	(set-process-filter connection 'url-http-generic-filter)
-	(process-send-string connection (url-http-create-request url))))
+	(let ((status (process-status connection)))
+	  (cond
+	   ((eq status 'connect)
+	    ;; Asynchronous connection
+	    (set-process-sentinel connection 'url-http-async-sentinel))
+	   ((eq status 'failed)
+	    ;; Asynchronous connection failed
+	    (error "Could not create connection to %s:%d" (url-host url)
+		   (url-port url)))
+	   (t
+	    (set-process-sentinel connection 'url-http-end-of-document-sentinel)
+	    (process-send-string connection (url-http-create-request url)))))))
     buffer))
 
+(defun url-http-async-sentinel (proc why)
+  (declare (special url-callback-arguments))
+  ;; We are performing an asynchronous connection, and a status change
+  ;; has occurred.
+  (with-current-buffer (process-buffer proc)
+    (cond
+     ((string= (substring why 0 4) "open")
+      (set-process-sentinel proc 'url-http-end-of-document-sentinel)
+      (process-send-string proc (url-http-create-request url-current-object)))
+     (t
+      (setf (car url-callback-arguments)
+	    (nconc (list :error (list 'error 'connection-failed why
+				      :host (url-host url-current-object)
+				      :service (url-port url-current-object)))
+		   (car url-callback-arguments)))
+      (url-http-activate-callback)))))
+
 ;; Since Emacs 19/20 does not allow you to change the
 ;; `after-change-functions' hook in the midst of running them, we fake
 ;; an after change by hooking into the process filter and inserting

--- a/lisp/url/url.el	Fri Oct 27 14:39:43 2006 +0000
+++ b/lisp/url/url.el	Fri Oct 27 14:44:25 2006 +0000
@@ -128,13 +128,39 @@
 
 CALLBACK is called when the object has been completely retrieved, with
 the current buffer containing the object, and any MIME headers associated
-with it.  Normally it gets the arguments in the list CBARGS.
-However, if what we find is a redirect, CALLBACK is given
-two additional args, `:redirect' and the redirected URL,
-followed by CBARGS.
+with it.  It is called as (apply CALLBACK STATUS CBARGS), where STATUS
+is a list with an even number of elements representing what happened
+during the request, with most recent events first.  Each pair is one
+of:
+
+\(:redirect REDIRECTED-TO) - the request was redirected to this URL
+\(:error (ERROR-SYMBOL . DATA)) - an error occurred.  The error can be
+signaled with (signal ERROR-SYMBOL DATA).
 
 Return the buffer URL will load into, or nil if the process has
-already completed."
+already completed (i.e. URL was a mailto URL or similar; in this case
+the callback is not called).
+
+The variables `url-request-data', `url-request-method' and
+`url-request-extra-headers' can be dynamically bound around the
+request; dynamic binding of other variables doesn't necessarily
+take effect."
+;;; XXX: There is code in Emacs that does dynamic binding
+;;; of the following variables around url-retrieve:
+;;; url-standalone-mode, url-gateway-unplugged, w3-honor-stylesheets,
+;;; url-confirmation-func, url-cookie-multiple-line,
+;;; url-cookie-{{,secure-}storage,confirmation}
+;;; url-standalone-mode and url-gateway-unplugged should work as
+;;; usual.  url-confirmation-func is only used in nnwarchive.el and
+;;; webmail.el; the latter should be updated.  Is
+;;; url-cookie-multiple-line needed anymore?  The other url-cookie-*
+;;; are (for now) only used in synchronous retrievals.
+  (url-retrieve-internal url callback (cons nil cbargs)))
+
+(defun url-retrieve-internal (url callback cbargs)
+  "Internal function; external interface is `url-retrieve'.
+CBARGS is what the callback will actually receive - the first item is
+the list of events, as described in the docstring of `url-retrieve'."
   (url-do-setup)
   (url-gc-dead-buffers)
   (if (stringp url)
@@ -211,6 +237,9 @@
                 ;; clear that it's a bug, but even then we need to decide how
                 ;; url-http can then warn us that the download has completed.
                 ;; In the mean time, we use this here workaround.
+		;; XXX: The callback must always be called.  Any
+		;; exception is a bug that should be fixed, not worked
+		;; around.
                 (setq retrieval-done t))
             ;; We used to use `sit-for' here, but in some cases it wouldn't
             ;; work because apparently pending keyboard input would always