summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ChangeLog26
-rw-r--r--lisp/emacs-lisp/debug.el18
-rw-r--r--lisp/gnus/ChangeLog21
-rw-r--r--lisp/gnus/gnus-registry.el15
-rw-r--r--lisp/gnus/gnus-sum.el8
-rw-r--r--lisp/gnus/shr.el32
-rw-r--r--lisp/minibuffer.el99
-rw-r--r--lisp/subr.el7
-rw-r--r--lisp/url/ChangeLog9
-rw-r--r--lisp/url/url-future.el126
-rw-r--r--lisp/url/url-queue.el2
11 files changed, 302 insertions, 61 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 07f700f6987..8f96a838cc5 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,31 @@
2011-05-31 Stefan Monnier <monnier@iro.umontreal.ca>
+ * minibuffer.el (complete-with-action): Return nil for the metadata and
+ boundaries of non-functional tables.
+ (completion-table-dynamic): Return nil for the metadata.
+ (completion-table-with-terminator): Add default case, using
+ complete-with-action.
+ (completion--metadata): New function.
+ (completion-all-sorted-completions, minibuffer-completion-help): Use it
+ to try and avoid pathological performance problems.
+ (completion--embedded-envvar-table): Return `category' metadata.
+
+2011-05-31 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * subr.el (process-alive-p): New tiny convenience function.
+
+2011-05-31 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/debug.el (debug): Save&restore not just the buffer's
+ content but also its previous major mode.
+
+2011-05-31 Helmut Eller <eller.helmut@gmail.com>
+
+ * debug.el (debug): Restore the previous content of the
+ *Backtrace* buffer when we exit with C-M-c.
+
+2011-05-31 Stefan Monnier <monnier@iro.umontreal.ca>
+
* minibuffer.el: Add metadata method to completion tables.
(completion-category-overrides): New defcustom.
(completion-metadata, completion--field-metadata)
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 88633eaaa46..28962595ace 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -118,6 +118,10 @@ first will be printed into the backtrace buffer."
(let (debugger-value
(debug-on-error nil)
(debug-on-quit nil)
+ (debugger-previous-state
+ (if (get-buffer "*Backtrace*")
+ (with-current-buffer (get-buffer "*Backtrace*")
+ (list major-mode (buffer-string)))))
(debugger-buffer (get-buffer-create "*Backtrace*"))
(debugger-old-buffer (current-buffer))
(debugger-step-after-exit nil)
@@ -214,8 +218,6 @@ first will be printed into the backtrace buffer."
;; recreate it every time the debugger stops, so instead we'll
;; erase it (and maybe hide it) but keep it alive.
(with-current-buffer debugger-buffer
- (erase-buffer)
- (fundamental-mode)
(with-selected-window (get-buffer-window debugger-buffer 0)
(when (and (window-dedicated-p (selected-window))
(not debugger-will-be-back))
@@ -232,7 +234,17 @@ first will be printed into the backtrace buffer."
;; to be left at the top-level, still working on how
;; best to do that.
(bury-buffer))))
- (kill-buffer debugger-buffer))
+ (unless debugger-previous-state
+ (kill-buffer debugger-buffer)))
+ ;; Restore the previous state of the debugger-buffer, in case we were
+ ;; in a recursive invocation of the debugger.
+ (when (and debugger-previous-state
+ (buffer-live-p debugger-buffer))
+ (with-current-buffer debugger-buffer
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert (nth 1 debugger-previous-state))
+ (funcall (nth 0 debugger-previous-state)))))
(with-timeout-unsuspend debugger-with-timeout-suspend)
(set-match-data debugger-outer-match-data)))
;; Put into effect the modified values of these variables
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index dcbc647950f..4cf21f65597 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,24 @@
+2011-05-31 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-rescale-image): Add an :ascent of 100 to images so that
+ the underline comes at the bottom.
+
+2011-05-31 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el (gnus-registry-article-marks-to-chars): Rename from
+ `gnus-registry-user-format-function-M' and declare the latter obsolete.
+ (gnus-registry-article-marks-to-names): Rename from
+ `gnus-registry-user-format-function-M2'.
+
+2011-05-31 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-sum.el (gnus-summary-exit): Make sure to kill article buffer in
+ ephemeral group.
+
+2011-05-31 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-browse-image): Copy the URL if called interactively.
+
2011-05-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
* gnus-group.el (gnus-group-mark-article-read): It's possible that we
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index e0efbaf4f30..f6c0daaaa93 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -62,10 +62,10 @@
;; show the marks as single characters (see the :char property in
;; `gnus-registry-marks'):
-;; (defalias 'gnus-user-format-function-M 'gnus-registry-user-format-function-M)
+;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
;; show the marks by name (see `gnus-registry-marks'):
-;; (defalias 'gnus-user-format-function-M 'gnus-registry-user-format-function-M2)
+;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
;; TODO:
@@ -897,9 +897,12 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
nil
(cons "Registry Marks" gnus-registry-misc-menus))))))
+(make-obsolete 'gnus-registry-user-format-function-M
+ 'gnus-registry-article-marks-to-chars "24.1") ?
+
;; use like this:
-;; (defalias 'gnus-user-format-function-M 'gnus-registry-user-format-function-M)
-(defun gnus-registry-user-format-function-M (headers)
+;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
+(defun gnus-registry-article-marks-to-chars (headers)
"Show the marks for an article by the :char property"
(let* ((id (mail-header-message-id headers))
(marks (when id (gnus-registry-get-id-key id 'mark))))
@@ -911,8 +914,8 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
marks "")))
;; use like this:
-;; (defalias 'gnus-user-format-function-M 'gnus-registry-user-format-function-M2)
-(defun gnus-registry-user-format-function-M2 (headers)
+;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
+(defun gnus-registry-article-marks-to-names (headers)
"Show the marks for an article by name"
(let* ((id (mail-header-message-id headers))
(marks (when id (gnus-registry-get-id-key id 'mark))))
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 2d75c35158a..1c4382b24a6 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -7194,7 +7194,11 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(article-buffer gnus-article-buffer)
(mode major-mode)
(group-point nil)
- (buf (current-buffer)))
+ (buf (current-buffer))
+ ;; `gnus-single-article-buffer' is nil buffer-locally in
+ ;; ephemeral group of which summary buffer will be killed,
+ ;; but the global value may be non-nil.
+ (single-article-buffer gnus-single-article-buffer))
(unless quit-config
;; Do adaptive scoring, and possibly save score files.
(when gnus-newsgroup-adaptive
@@ -7257,7 +7261,7 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(gnus-configure-windows 'group 'force)))
;; If we have several article buffers, we kill them at exit.
- (unless gnus-single-article-buffer
+ (unless single-article-buffer
(when (gnus-buffer-live-p article-buffer)
(with-current-buffer article-buffer
;; Don't kill sticky article buffers
diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el
index ebd854930df..67effc07ee2 100644
--- a/lisp/gnus/shr.el
+++ b/lisp/gnus/shr.el
@@ -183,14 +183,23 @@ redirects somewhere else."
(message "No image under point")
(message "%s" text))))
-(defun shr-browse-image ()
- "Browse the image under point."
- (interactive)
+(defun shr-browse-image (&optional copy-url)
+ "Browse the image under point.
+If COPY-URL (the prefix if called interactively) is non-nil, copy
+the URL of the image to the kill buffer instead."
+ (interactive "P")
(let ((url (get-text-property (point) 'image-url)))
- (if (not url)
- (message "No image under point")
+ (cond
+ ((not url)
+ (message "No image under point"))
+ (copy-url
+ (with-temp-buffer
+ (insert url)
+ (copy-region-as-kill (point-min) (point-max))
+ (message "Copied %s" url)))
+ (t
(message "Browsing %s..." url)
- (browse-url url))))
+ (browse-url url)))))
(defun shr-insert-image ()
"Insert the image under point into the buffer."
@@ -524,8 +533,9 @@ redirects somewhere else."
(defun shr-rescale-image (data)
(if (or (not (fboundp 'imagemagick-types))
(not (get-buffer-window (current-buffer))))
- (create-image data nil t)
- (let* ((image (create-image data nil t))
+ (create-image data nil t
+ :ascent 100)
+ (let* ((image (create-image data nil t :ascent 100))
(size (image-size image t))
(width (car size))
(height (cdr size))
@@ -544,11 +554,13 @@ redirects somewhere else."
(when (> (car size) window-width)
(setq image (or
(create-image data 'imagemagick t
- :width window-width)
+ :width window-width
+ :ascent 100)
image)))
(when (and (fboundp 'create-animated-image)
(eq (image-type data nil t) 'gif))
- (setq image (create-animated-image data 'gif t)))
+ (setq image (create-animated-image data 'gif t
+ :ascent 100)))
image)))
;; url-cache-extract autoloads url-cache.
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 0f96f7905eb..972c65f62e3 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -26,11 +26,15 @@
;; internal use only.
;; Functional completion tables have an extended calling conventions:
-;; - The `action' can be (additionally to nil, t, and lambda) of the form
-;; (boundaries . SUFFIX) in which case it should return
+;; The `action' can be (additionally to nil, t, and lambda) of the form
+;; - (boundaries . SUFFIX) in which case it should return
;; (boundaries START . END). See `completion-boundaries'.
;; Any other return value should be ignored (so we ignore values returned
;; from completion tables that don't know about this new `action' form).
+;; - `metadata' in which case it should return (metadata . ALIST) where
+;; ALIST is the metadata of this table. See `completion-metadata'.
+;; Any other return value should be ignored (so we ignore values returned
+;; from completion tables that don't know about this new `action' form).
;;; Bugs:
@@ -107,7 +111,8 @@ E.g. for simple completion tables, the result is always (0 . (length SUFFIX))
and for file names the result is the positions delimited by
the closest directory separators."
(let ((boundaries (if (functionp table)
- (funcall table string pred (cons 'boundaries suffix)))))
+ (funcall table string pred
+ (cons 'boundaries suffix)))))
(if (not (eq (car-safe boundaries) 'boundaries))
(setq boundaries nil))
(cons (or (cadr boundaries) 0)
@@ -125,7 +130,8 @@ This metadata is an alist. Currently understood keys are:
Takes one argument (COMPLETIONS) and should return a new list
of completions. Can operate destructively.
- `cycle-sort-function': function to sort entries when cycling.
- Works like `display-sort-function'."
+ Works like `display-sort-function'.
+The metadata of a completion table should be constant between two boundaries."
(let ((metadata (if (functionp table)
(funcall table string pred 'metadata))))
(if (eq (car-safe metadata) 'metadata)
@@ -160,8 +166,8 @@ PRED is a completion predicate.
ACTION can be one of nil, t or `lambda'."
(cond
((functionp table) (funcall table string pred action))
- ((eq (car-safe action) 'boundaries)
- (cons 'boundaries (completion-boundaries string table pred (cdr action))))
+ ((eq (car-safe action) 'boundaries) nil)
+ ((eq action 'metadata) nil)
(t
(funcall
(cond
@@ -182,7 +188,7 @@ The result of the `completion-table-dynamic' form is a function
that can be used as the COLLECTION argument to `try-completion' and
`all-completions'. See Info node `(elisp)Programmed Completion'."
(lambda (string pred action)
- (if (eq (car-safe action) 'boundaries)
+ (if (or (eq (car-safe action) 'boundaries) (eq action 'metadata))
;; `fun' is not supposed to return another function but a plain old
;; completion table, whose boundaries are always trivial.
nil
@@ -287,18 +293,18 @@ instead of a string, a function that takes the completion and returns the
(funcall terminator comp)
(concat comp terminator))
comp))))
- ((eq action t)
+ ;; completion-table-with-terminator is always used for
+ ;; "sub-completions" so it's only called if the terminator is missing,
+ ;; in which case `test-completion' should return nil.
+ ((eq action 'lambda) nil)
+ (t
;; FIXME: We generally want the `try' and `all' behaviors to be
;; consistent so pcm can merge the `all' output to get the `try' output,
;; but that sometimes clashes with the need for `all' output to look
;; good in *Completions*.
;; (mapcar (lambda (s) (concat s terminator))
;; (all-completions string table pred))))
- (all-completions string table pred))
- ;; completion-table-with-terminator is always used for
- ;; "sub-completions" so it's only called if the terminator is missing,
- ;; in which case `test-completion' should return nil.
- ((eq action 'lambda) nil)))
+ (complete-with-action action table string pred))))
(defun completion-table-with-predicate (table pred1 strict string pred2 action)
"Make a completion table equivalent to TABLE but filtered through PRED1.
@@ -769,22 +775,33 @@ scroll the window of possible completions."
(setq completion-cycling nil)
(setq completion-all-sorted-completions nil))
+(defun completion--metadata (string base md-at-point table pred)
+ ;; Like completion-metadata, but for the specific case of getting the
+ ;; metadata at `base', which tends to trigger pathological behavior for old
+ ;; completion tables which don't understand `metadata'.
+ (let ((bounds (completion-boundaries string table pred "")))
+ (if (eq (car bounds) base) md-at-point
+ (completion-metadata (substring string 0 base) table pred))))
+
(defun completion-all-sorted-completions ()
(or completion-all-sorted-completions
(let* ((start (field-beginning))
(end (field-end))
(string (buffer-substring start end))
+ (md (completion--field-metadata start))
(all (completion-all-completions
string
minibuffer-completion-table
minibuffer-completion-predicate
(- (point) start)
- (completion--field-metadata start)))
+ md))
(last (last all))
(base-size (or (cdr last) 0))
- (all-md (completion-metadata (substring string 0 base-size)
- minibuffer-completion-table
- minibuffer-completion-predicate))
+ (all-md (completion--metadata (buffer-substring-no-properties
+ start (point))
+ base-size md
+ minibuffer-completion-table
+ minibuffer-completion-predicate))
(sort-fun (completion-metadata-get all-md 'cycle-sort-function)))
(when last
(setcdr last nil)
@@ -1272,12 +1289,13 @@ variables.")
(let* ((start (field-beginning))
(end (field-end))
(string (field-string))
+ (md (completion--field-metadata start))
(completions (completion-all-completions
string
minibuffer-completion-table
minibuffer-completion-predicate
(- (point) (field-beginning))
- (completion--field-metadata start))))
+ md)))
(message nil)
(if (or (null completions)
(and (not (consp (cdr completions)))
@@ -1293,12 +1311,11 @@ variables.")
(let* ((last (last completions))
(base-size (cdr last))
(prefix (unless (zerop base-size) (substring string 0 base-size)))
- ;; FIXME: This function is for the output of all-completions,
- ;; not completion-all-completions. Often it's the same, but
- ;; not always.
- (all-md (completion-metadata (substring string 0 base-size)
- minibuffer-completion-table
- minibuffer-completion-predicate))
+ (all-md (completion--metadata (buffer-substring-no-properties
+ start (point))
+ base-size md
+ minibuffer-completion-table
+ minibuffer-completion-predicate))
(afun (or (completion-metadata-get all-md 'annotation-function)
(plist-get completion-extra-properties
:annotation-function)
@@ -1673,8 +1690,8 @@ same as `substitute-in-file-name'."
;; other table that provides the "main" completion. Let the
;; other table handle the test-completion case.
nil)
- ((eq (car-safe action) 'boundaries)
- ;; Only return boundaries if there's something to complete,
+ ((or (eq (car-safe action) 'boundaries) (eq action 'metadata))
+ ;; Only return boundaries/metadata if there's something to complete,
;; since otherwise when we're used in
;; completion-table-in-turn, we could return boundaries and
;; let some subsequent table return a list of completions.
@@ -1684,11 +1701,13 @@ same as `substitute-in-file-name'."
(when (try-completion (substring string beg) table nil)
;; Compute the boundaries of the subfield to which this
;; completion applies.
- (let ((suffix (cdr action)))
- (list* 'boundaries
- (or (match-beginning 2) (match-beginning 1))
- (when (string-match "[^[:alnum:]_]" suffix)
- (match-beginning 0))))))
+ (if (eq action 'metadata)
+ '(metadata (category . environment-variable))
+ (let ((suffix (cdr action)))
+ (list* 'boundaries
+ (or (match-beginning 2) (match-beginning 1))
+ (when (string-match "[^[:alnum:]_]" suffix)
+ (match-beginning 0)))))))
(t
(if (eq (aref string (1- beg)) ?{)
(setq table (apply-partially 'completion-table-with-terminator
@@ -2299,7 +2318,8 @@ PATTERN is as returned by `completion-pcm--string->pattern'."
(case-fold-search completion-ignore-case)
(completion-regexp-list (cons regex completion-regexp-list))
(compl (all-completions
- (concat prefix (if (stringp (car pattern)) (car pattern) ""))
+ (concat prefix
+ (if (stringp (car pattern)) (car pattern) ""))
table pred)))
(if (not (functionp table))
;; The internal functions already obeyed completion-regexp-list.
@@ -2397,13 +2417,14 @@ filter out additional entries (because TABLE migth not obey PRED)."
(- (length newbeforepoint)
(car newbounds)))))
(dolist (submatch suball)
- (setq all (nconc (mapcar
- (lambda (s) (concat submatch between s))
- (funcall filter
- (completion-pcm--all-completions
- (concat subprefix submatch between)
- pattern table pred)))
- all)))
+ (setq all (nconc
+ (mapcar
+ (lambda (s) (concat submatch between s))
+ (funcall filter
+ (completion-pcm--all-completions
+ (concat subprefix submatch between)
+ pattern table pred)))
+ all)))
;; FIXME: This can come in handy for try-completion,
;; but isn't right for all-completions, since it lists
;; invalid completions.
diff --git a/lisp/subr.el b/lisp/subr.el
index 4fe9987b95b..08099dc1fdd 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1805,6 +1805,13 @@ Signal an error if the program returns with a non-zero exit status."
(forward-line 1))
(nreverse lines)))))
+(defun process-alive-p (process)
+ "Returns non-nil if PROCESS is alive.
+A process is considered alive if its status is `run', `open',
+`listen', `connect' or `stop'."
+ (memq (process-status process)
+ '(run open listen connect stop)))
+
;; compatibility
(make-obsolete
diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog
index 37a9fb8ffe2..1f2784fe656 100644
--- a/lisp/url/ChangeLog
+++ b/lisp/url/ChangeLog
@@ -1,3 +1,12 @@
+2011-05-31 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * url-queue.el (url-queue-parallel-processes): Increase the
+ default to 6, since 2 seems too conservative for normal usage.
+
+2011-05-31 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * url-future.el: Add general futures facility.
+
2011-05-29 Leo Liu <sdl.web@gmail.com>
* url-cookie.el (url-cookie): Add option :named so that
diff --git a/lisp/url/url-future.el b/lisp/url/url-future.el
new file mode 100644
index 00000000000..334c4fa9126
--- /dev/null
+++ b/lisp/url/url-future.el
@@ -0,0 +1,126 @@
+;;; url-future.el --- general futures facility for url.el
+
+;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;; Author: Teodor Zlatanov <tzz@lifelogs.com>
+;; Keywords: data
+
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Make a url-future (basically a defstruct):
+;; (make-url-future :value (lambda () (calculation goes here))
+;; :callback (lambda (future) (use future on success))
+;; :errorback (lambda (future &rest error) (error handler)))
+
+;; Then either call it with `url-future-call' or cancel it with
+;; `url-future-cancel'. Generally the functions will return the
+;; future itself, not the value it holds. Also the functions will
+;; throw a url-future-already-done error if you try to call or cancel
+;; a future more than once.
+
+;; So, to get the value:
+;; (when (url-future-completed-p future) (url-future-value future))
+
+;; See the ERT tests and the code for futher details.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(eval-when-compile (require 'ert))
+
+(defstruct url-future callback errorback status value)
+
+(defmacro url-future-done-p (url-future)
+ `(url-future-status ,url-future))
+
+(defmacro url-future-completed-p (url-future)
+ `(eq (url-future-status ,url-future) t))
+
+(defmacro url-future-errored-p (url-future)
+ `(eq (url-future-status ,url-future) 'error))
+
+(defmacro url-future-cancelled-p (url-future)
+ `(eq (url-future-status ,url-future) 'cancel))
+
+(defun url-future-finish (url-future &optional status)
+ (if (url-future-done-p url-future)
+ (signal 'error 'url-future-already-done)
+ (setf (url-future-status url-future) (or status t))
+ ;; the status must be such that the future was completed
+ ;; to run the callback
+ (when (url-future-completed-p url-future)
+ (funcall (or (url-future-callback url-future) 'ignore)
+ url-future))
+ url-future))
+
+(defun url-future-errored (url-future errorcons)
+ (if (url-future-done-p url-future)
+ (signal 'error 'url-future-already-done)
+ (setf (url-future-status url-future) 'error)
+ (setf (url-future-value url-future) errorcons)
+ (funcall (or (url-future-errorback url-future) 'ignore)
+ url-future errorcons)))
+
+(defun url-future-call (url-future)
+ (if (url-future-done-p url-future)
+ (signal 'error 'url-future-already-done)
+ (let ((ff (url-future-value url-future)))
+ (when (functionp ff)
+ (condition-case catcher
+ (setf (url-future-value url-future)
+ (funcall ff))
+ (error (url-future-errored url-future catcher)))
+ (url-future-value url-future)))
+ (if (url-future-errored-p url-future)
+ url-future
+ (url-future-finish url-future))))
+
+(defun url-future-cancel (url-future)
+ (if (url-future-done-p url-future)
+ (signal 'error 'url-future-already-done)
+ (url-future-finish url-future 'cancel)))
+
+(ert-deftest url-future-test ()
+ (let* ((text "running future")
+ (good (make-url-future :value (lambda () (format text))
+ :callback (lambda (f) (set 'saver f))))
+ (bad (make-url-future :value (lambda () (/ 1 0))
+ :errorback (lambda (&rest d) (set 'saver d))))
+ (tocancel (make-url-future :value (lambda () (/ 1 0))
+ :callback (lambda (f) (set 'saver f))
+ :errorback (lambda (&rest d)
+ (set 'saver d))))
+ saver)
+ (should (equal good (url-future-call good)))
+ (should (equal good saver))
+ (should (equal text (url-future-value good)))
+ (should (url-future-completed-p good))
+ (should-error (url-future-call good))
+ (setq saver nil)
+ (should (equal bad (url-future-call bad)))
+ (should-error (url-future-call bad))
+ (should (equal saver (list bad '(arith-error))))
+ (should (url-future-errored-p bad))
+ (setq saver nil)
+ (should (equal (url-future-cancel tocancel) tocancel))
+ (should-error (url-future-call tocancel))
+ (should (null saver))
+ (should (url-future-cancelled-p tocancel))))
+
+(provide 'url-future)
+;;; url-future.el ends here
diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el
index 08496ad5afb..e6c8537c469 100644
--- a/lisp/url/url-queue.el
+++ b/lisp/url/url-queue.el
@@ -31,7 +31,7 @@
(eval-when-compile (require 'cl))
(require 'browse-url)
-(defcustom url-queue-parallel-processes 2
+(defcustom url-queue-parallel-processes 6
"The number of concurrent processes."
:type 'integer
:group 'url)
View Lorry Controller Status