upstream

4 files changed, 94 insertions, 2 deletions

diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog
index 7c92fc33490..f4cca618b49 100644
--- a/lisp/url/ChangeLog
+++ b/lisp/url/ChangeLog
@@ -1,3 +1,19 @@
+2012-02-06  Lars Ingebrigtsen  <larsi@gnus.org>
+
+        * url-cache.el (url-cache-prune-cache): New function.
+        (url-cache-prune-cache): Check that the directory exists before
+        trying to delete it.
+
+        * url.el (url-retrieve-number-of-calls): New variable.
+        (url-retrieve-internal): Use it to expire the cache once in a
+        while.
+
+        * url-queue.el (url-queue-setup-runners): New function that uses
+        `run-with-idle-timer' for extra asynchronicity.
+        (url-queue-remove-jobs-from-host): New function.
+        (url-queue-callback-function): Remove jobs from the same host if
+        connection failed.
+
 2012-01-12  Glenn Morris  <rgm@gnu.org>
 
         * url-auth.el (url-basic-auth, url-digest-auth):
diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el
index 20602a2f8ef..6559de4deb7 100644
--- a/lisp/url/url-cache.el
+++ b/lisp/url/url-cache.el
@@ -209,6 +209,34 @@ If `url-standalone-mode' is non-nil, cached items never expire."
             (seconds-to-time (or expire-time url-cache-expire-time)))
            (current-time))))))
 
+(defun url-cache-prune-cache (&optional directory)
+  "Remove all expired files from the cache.
+`url-cache-expire-time' says how old a file has to be to be
+considered \"expired\"."
+  (let ((current-time (current-time))
+        (total-files 0)
+        (deleted-files 0))
+    (setq directory (or directory url-cache-directory))
+    (when (file-exists-p directory)
+      (dolist (file (directory-files directory t))
+        (unless (member (file-name-nondirectory file) '("." ".."))
+          (setq total-files (1+ total-files))
+          (cond
+           ((file-directory-p file)
+            (when (url-cache-prune-cache file)
+              (setq deleted-files (1+ deleted-files))))
+           ((time-less-p
+             (time-add
+              (nth 5 (file-attributes file))
+              (seconds-to-time url-cache-expire-time))
+             current-time)
+            (delete-file file)
+            (setq deleted-files (1+ deleted-files))))))
+      (if (< deleted-files total-files)
+          nil
+        (delete-directory directory)
+        t))))
+
 (provide 'url-cache)
 
 ;;; url-cache.el ends here
diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el
index 534c94b4d52..976a26635cd 100644
--- a/lisp/url/url-queue.el
+++ b/lisp/url/url-queue.el
@@ -30,6 +30,7 @@
 
 (eval-when-compile (require 'cl))
 (require 'browse-url)
+(require 'url-parse)
 
 (defcustom url-queue-parallel-processes 6
   "The number of concurrent processes."
@@ -49,7 +50,7 @@
 
 (defstruct url-queue
   url callback cbargs silentp
-  buffer start-time)
+  buffer start-time pre-triggered)
 
 ;;;###autoload
 (defun url-queue-retrieve (url callback &optional cbargs silent)
@@ -63,7 +64,30 @@ controls the level of parallelism via the
                                       :callback callback
                                       :cbargs cbargs
                                       :silentp silent))))
-  (url-queue-run-queue))
+  (url-queue-setup-runners))
+
+;; To ensure asynch behaviour, we start the required number of queue
+;; runners from `run-with-idle-timer'.  So we're basically going
+;; through the queue in two ways: 1) synchronously when a program
+;; calls `url-queue-retrieve' (which will then start the required
+;; number of queue runners), and 2) at the exit of each job, which
+;; will then not start any further threads, but just reuse the
+;; previous "slot".
+
+(defun url-queue-setup-runners ()
+  (let ((running 0)
+        waiting)
+    (dolist (entry url-queue)
+      (cond
+       ((or (url-queue-start-time entry)
+            (url-queue-pre-triggered entry))
+        (incf running))
+       ((not waiting)
+        (setq waiting entry))))
+    (when (and waiting
+               (< running url-queue-parallel-processes))
+      (setf (url-queue-pre-triggered waiting) t)
+      (run-with-idle-timer 0.01 nil 'url-queue-run-queue))))
 
 (defun url-queue-run-queue ()
   (url-queue-prune-old-entries)
@@ -81,10 +105,27 @@ controls the level of parallelism via the
       (url-queue-start-retrieve waiting))))
 
 (defun url-queue-callback-function (status job)
+  (when (and (eq (car status) :error)
+             (eq (cadr (cadr status)) 'connection-failed))
+    ;; If we get a connection error, then flush all other jobs from
+    ;; the host from the queue.  This particularly makes sense if the
+    ;; error really is a DNS resolver issue, which happens
+    ;; synchronously and totally halts Emacs.
+    (url-queue-remove-jobs-from-host
+     (plist-get (nthcdr 3 (cadr status)) :host)))
   (setq url-queue (delq job url-queue))
   (url-queue-run-queue)
   (apply (url-queue-callback job) (cons status (url-queue-cbargs job))))
 
+(defun url-queue-remove-jobs-from-host (host)
+  (let ((jobs nil))
+    (dolist (job url-queue)
+      (when (equal (url-host (url-generic-parse-url (url-queue-url job)))
+                   host)
+        (push job jobs)))
+    (dolist (job jobs)
+      (setq url-queue (delq job url-queue)))))
+  
 (defun url-queue-start-retrieve (job)
   (setf (url-queue-buffer job)
         (ignore-errors
diff --git a/lisp/url/url.el b/lisp/url/url.el
index 883e1a0c765..03b66b15232 100644
--- a/lisp/url/url.el
+++ b/lisp/url/url.el
@@ -119,6 +119,9 @@ Sometimes while retrieving a URL, the URL library needs to use another buffer
 than the one returned initially by `url-retrieve'.  In this case, it sets this
 variable in the original buffer as a forwarding pointer.")
 
+(defvar url-retrieve-number-of-calls 0)
+(autoload 'url-cache-prune-cache "url-cache")
+
 ;;;###autoload
 (defun url-retrieve (url callback &optional cbargs silent)
   "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
@@ -174,6 +177,10 @@ If SILENT, don't message progress reports and the like."
   (unless (url-type url)
     (error "Bad url: %s" (url-recreate-url url)))
   (setf (url-silent url) silent)
+  ;; Once in a while, remove old entries from the URL cache.
+  (when (zerop (% url-retrieve-number-of-calls 1000))
+    (url-cache-prune-cache))
+  (setq url-retrieve-number-of-calls (1+ url-retrieve-number-of-calls))
   (let ((loader (url-scheme-get-property (url-type url) 'loader))
         (url-using-proxy (if (url-host url)
                              (url-find-proxy-for-url url (url-host url))))