Merge from mainline.

4 files changed, 110 insertions, 80 deletions

diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el
index 910eff3c78f..73af3a5708f 100644
--- a/lisp/emacs-lisp/elp.el
+++ b/lisp/emacs-lisp/elp.el
@@ -630,7 +630,7 @@ displayed."
                                    'display (list 'space :align-to column)
                                    'face 'fixed-pitch)
                        title)
-                    (setq column (+ column 1
+                    (setq column (+ column 2
                                     (if (= column 0)
                                         elp-field-len
                                       (length title))))))
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index b3c95fcc78f..5bd8fd01b1e 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -219,7 +219,7 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'."
   ;; This implementation is inefficient.  Rather than making it
   ;; efficient, let's hope bug 6581 gets fixed so that we can delete
   ;; it altogether.
-  (not (ert--explain-not-equal-including-properties a b)))
+  (not (ert--explain-equal-including-properties a b)))
 
 
 ;;; Defining and locating tests.
@@ -571,16 +571,15 @@ failed."
    (when (and (not firstp) (eq fast slow)) (return nil))))
 
 (defun ert--explain-format-atom (x)
-  "Format the atom X for `ert--explain-not-equal'."
+  "Format the atom X for `ert--explain-equal'."
   (typecase x
     (fixnum (list x (format "#x%x" x) (format "?%c" x)))
     (t x)))
 
-(defun ert--explain-not-equal (a b)
-  "Explainer function for `equal'.
+(defun ert--explain-equal-rec (a b)
+  "Returns a programmer-readable explanation of why A and B are not `equal'.
 
-Returns a programmer-readable explanation of why A and B are not
-`equal', or nil if they are."
+Returns nil if they are."
   (if (not (equal (type-of a) (type-of b)))
       `(different-types ,a ,b)
     (etypecase a
@@ -598,13 +597,13 @@ Returns a programmer-readable explanation of why A and B are not
                  (loop for i from 0
                        for ai in a
                        for bi in b
-                       for xi = (ert--explain-not-equal ai bi)
+                       for xi = (ert--explain-equal-rec ai bi)
                        do (when xi (return `(list-elt ,i ,xi)))
                        finally (assert (equal a b) t)))
-             (let ((car-x (ert--explain-not-equal (car a) (car b))))
+             (let ((car-x (ert--explain-equal-rec (car a) (car b))))
                (if car-x
                    `(car ,car-x)
-                 (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b))))
+                 (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b))))
                    (if cdr-x
                        `(cdr ,cdr-x)
                      (assert (equal a b) t)
@@ -618,7 +617,7 @@ Returns a programmer-readable explanation of why A and B are not
                (loop for i from 0
                      for ai across a
                      for bi across b
-                     for xi = (ert--explain-not-equal ai bi)
+                     for xi = (ert--explain-equal-rec ai bi)
                      do (when xi (return `(array-elt ,i ,xi)))
                      finally (assert (equal a b) t))))
       (atom (if (not (equal a b))
@@ -627,7 +626,15 @@ Returns a programmer-readable explanation of why A and B are not
                   `(different-atoms ,(ert--explain-format-atom a)
                                     ,(ert--explain-format-atom b)))
               nil)))))
-(put 'equal 'ert-explainer 'ert--explain-not-equal)
+
+(defun ert--explain-equal (a b)
+  "Explainer function for `equal'."
+  ;; Do a quick comparison in C to avoid running our expensive
+  ;; comparison when possible.
+  (if (equal a b)
+      nil
+    (ert--explain-equal-rec a b)))
+(put 'equal 'ert-explainer 'ert--explain-equal)
 
 (defun ert--significant-plist-keys (plist)
   "Return the keys of PLIST that have non-null values, in order."
@@ -658,8 +665,8 @@ key/value pairs in each list does not matter."
                    (value-b (plist-get b key)))
                (assert (not (equal value-a value-b)) t)
                `(different-properties-for-key
-                 ,key ,(ert--explain-not-equal-including-properties value-a
-                                                                    value-b)))))
+                 ,key ,(ert--explain-equal-including-properties value-a
+                                                                value-b)))))
       (cond (keys-in-a-not-in-b
              (explain-with-key (first keys-in-a-not-in-b)))
             (keys-in-b-not-in-a
@@ -681,13 +688,16 @@ If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix."
           (t
            (substring s 0 len)))))
 
-(defun ert--explain-not-equal-including-properties (a b)
+;; TODO(ohler): Once bug 6581 is fixed, rename this to
+;; `ert--explain-equal-including-properties-rec' and add a fast-path
+;; wrapper like `ert--explain-equal'.
+(defun ert--explain-equal-including-properties (a b)
   "Explainer function for `ert-equal-including-properties'.
 
 Returns a programmer-readable explanation of why A and B are not
 `ert-equal-including-properties', or nil if they are."
   (if (not (equal a b))
-      (ert--explain-not-equal a b)
+      (ert--explain-equal a b)
     (assert (stringp a) t)
     (assert (stringp b) t)
     (assert (eql (length a) (length b)) t)
@@ -713,7 +723,7 @@ Returns a programmer-readable explanation of why A and B are not
           )))
 (put 'ert-equal-including-properties
      'ert-explainer
-     'ert--explain-not-equal-including-properties)
+     'ert--explain-equal-including-properties)
 
 
 ;;; Implementation of `ert-info'.
@@ -1244,12 +1254,14 @@ Also changes the counters in STATS to match."
                    (ert-test-passed (incf (ert--stats-passed-expected stats) d))
                    (ert-test-failed (incf (ert--stats-failed-expected stats) d))
                    (null)
-                   (ert-test-aborted-with-non-local-exit))
+                   (ert-test-aborted-with-non-local-exit)
+                   (ert-test-quit))
                (etypecase (aref results pos)
                  (ert-test-passed (incf (ert--stats-passed-unexpected stats) d))
                  (ert-test-failed (incf (ert--stats-failed-unexpected stats) d))
                  (null)
-                 (ert-test-aborted-with-non-local-exit)))))
+                 (ert-test-aborted-with-non-local-exit)
+                 (ert-test-quit)))))
       ;; Adjust counters to remove the result that is currently in stats.
       (update -1)
       ;; Put new test and result into stats.
@@ -1342,7 +1354,8 @@ EXPECTEDP specifies whether the result was expected."
              (ert-test-passed ".P")
              (ert-test-failed "fF")
              (null "--")
-             (ert-test-aborted-with-non-local-exit "aA"))))
+             (ert-test-aborted-with-non-local-exit "aA")
+             (ert-test-quit "qQ"))))
     (elt s (if expectedp 0 1))))
 
 (defun ert-string-for-test-result (result expectedp)
@@ -1353,7 +1366,8 @@ EXPECTEDP specifies whether the result was expected."
              (ert-test-passed '("passed" "PASSED"))
              (ert-test-failed '("failed" "FAILED"))
              (null '("unknown" "UNKNOWN"))
-             (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")))))
+             (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))
+             (ert-test-quit '("quit" "QUIT")))))
     (elt s (if expectedp 0 1))))
 
 (defun ert--pp-with-indentation-and-newline (object)
@@ -1478,7 +1492,9 @@ Returns the stats object."
                  (message "%s" (buffer-string))))
               (ert-test-aborted-with-non-local-exit
                (message "Test %S aborted with non-local exit"
-                        (ert-test-name test)))))
+                        (ert-test-name test)))
+              (ert-test-quit
+               (message "Quit during %S" (ert-test-name test)))))
           (let* ((max (prin1-to-string (length (ert--stats-tests stats))))
                  (format-string (concat "%9s  %"
                                         (prin1-to-string (length max))
@@ -1853,7 +1869,9 @@ non-nil, returns the face for expected results.."
                      (ert-test-result-with-condition-condition result))
                     (ert--make-xrefs-region begin (point)))))
                (ert-test-aborted-with-non-local-exit
-                (insert "    aborted\n")))
+                (insert "    aborted\n"))
+               (ert-test-quit
+                (insert "    quit\n")))
              (insert "\n")))))
   nil)
 
diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el
index bf9998695ee..a71f3c7244c 100644
--- a/lisp/emacs-lisp/ewoc.el
+++ b/lisp/emacs-lisp/ewoc.el
@@ -495,6 +495,8 @@ Return the node (or nil if we just passed the last node)."
     ;; Never step below the first element.
     ;; (unless (ewoc--filter-hf-nodes ewoc node)
     ;;   (setq node (ewoc--node-nth dll -2)))
+    (unless node
+      (error "No next"))
     (ewoc-goto-node ewoc node)))
 
 (defun ewoc-goto-node (ewoc node)
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index ab5ba1bea56..2552ad4eb68 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -220,10 +220,15 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")."
 (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/"))
   "An alist of archives from which to fetch.
 The default value points to the GNU Emacs package repository.
-Each element has the form (ID . URL), where ID is an identifier
-string for an archive and URL is a http: URL (a string)."
+
+Each element has the form (ID . LOCATION).
+ ID is an archive name, as a string.
+ LOCATION specifies the base location for the archive.
+  If it starts with \"http:\", it is treated as a HTTP URL;
+  otherwise it should be an absolute directory name.
+  (Other types of URL are currently not supported.)"
   :type '(alist :key-type (string :tag "Archive name")
-                :value-type (string :tag "Archive URL"))
+                :value-type (string :tag "URL or directory name"))
   :risky t
   :group 'package
   :version "24.1")
@@ -617,8 +622,36 @@ Otherwise it uses an external `tar' program.
       (let ((load-path (cons pkg-dir load-path)))
 	(byte-recompile-directory pkg-dir 0 t)))))
 
+(defmacro package--with-work-buffer (location file &rest body)
+  "Run BODY in a buffer containing the contents of FILE at LOCATION.
+LOCATION is the base location of a package archive, and should be
+one of the URLs (or file names) specified in `package-archives'.
+FILE is the name of a file relative to that base location.
+
+This macro retrieves FILE from LOCATION into a temporary buffer,
+and evaluates BODY while that buffer is current.  This work
+buffer is killed afterwards.  Return the last value in BODY."
+  `(let* ((http (string-match "\\`http:" ,location))
+	  (buffer
+	   (if http
+	       (url-retrieve-synchronously (concat ,location ,file))
+	     (generate-new-buffer "*package work buffer*"))))
+     (prog1
+	 (with-current-buffer buffer
+	   (if http
+	       (progn (package-handle-response)
+		      (re-search-forward "^$" nil 'move)
+		      (forward-char)
+		      (delete-region (point-min) (point)))
+	     (unless (file-name-absolute-p ,location)
+	       (error "Archive location %s is not an absolute file name"
+		      ,location))
+	     (insert-file-contents (expand-file-name ,file ,location)))
+	   ,@body)
+       (kill-buffer buffer))))
+
 (defun package-handle-response ()
-  "Handle the response from the server.
+  "Handle the response from a `url-retrieve-synchronously' call.
 Parse the HTTP response and throw if an error occurred.
 The url package seems to require extra processing for this.
 This should be called in a `save-excursion', in the download buffer.
@@ -627,7 +660,6 @@ It will move point to somewhere in the headers."
   (require 'url-http)
   (let ((response (url-http-parse-response)))
     (when (or (< response 200) (>= response 300))
-      (display-buffer (current-buffer))
       (error "Error during download request:%s"
 	     (buffer-substring-no-properties (point) (progn
 						       (end-of-line)
@@ -635,28 +667,17 @@ It will move point to somewhere in the headers."
 
 (defun package-download-single (name version desc requires)
   "Download and install a single-file package."
-  (let ((buffer (url-retrieve-synchronously
-		 (concat (package-archive-url name)
-			 (symbol-name name) "-" version ".el"))))
-    (with-current-buffer buffer
-      (package-handle-response)
-      (re-search-forward "^$" nil 'move)
-      (forward-char)
-      (delete-region (point-min) (point))
-      (package-unpack-single (symbol-name name) version desc requires)
-      (kill-buffer buffer))))
+  (let ((location (package-archive-base name))
+	(file (concat (symbol-name name) "-" version ".el")))
+    (package--with-work-buffer location file
+      (package-unpack-single (symbol-name name) version desc requires))))
 
 (defun package-download-tar (name version)
   "Download and install a tar package."
-  (let ((tar-buffer (url-retrieve-synchronously
-		     (concat (package-archive-url name)
-			     (symbol-name name) "-" version ".tar"))))
-    (with-current-buffer tar-buffer
-      (package-handle-response)
-      (re-search-forward "^$" nil 'move)
-      (forward-char)
-      (package-unpack name version)
-      (kill-buffer tar-buffer))))
+  (let ((location (package-archive-base name))
+	(file (concat (symbol-name name) "-" version ".tar")))
+    (package--with-work-buffer location file
+      (package-unpack name version))))
 
 (defun package-installed-p (package &optional min-version)
   "Return true if PACKAGE, of VERSION or newer, is installed.
@@ -987,31 +1008,26 @@ The file can either be a tar file or an Emacs Lisp file."
       (error "Package `%s-%s' is a system package, not deleting"
 	     name version))))
 
-(defun package-archive-url (name)
+(defun package-archive-base (name)
   "Return the archive containing the package NAME."
   (let ((desc (cdr (assq (intern-soft name) package-archive-contents))))
     (cdr (assoc (aref desc (- (length desc) 1)) package-archives))))
 
 (defun package--download-one-archive (archive file)
-  "Download an archive file FILE from ARCHIVE, and cache it locally."
-  (let* ((archive-name (car archive))
-         (archive-url  (cdr archive))
-	 (dir (expand-file-name "archives" package-user-dir))
-	 (dir (expand-file-name archive-name dir))
-         (buffer (url-retrieve-synchronously (concat archive-url file))))
-    (with-current-buffer buffer
-      (package-handle-response)
-      (re-search-forward "^$" nil 'move)
-      (forward-char)
-      (delete-region (point-min) (point))
+  "Retrieve an archive file FILE from ARCHIVE, and cache it.
+ARCHIVE should be a cons cell of the form (NAME . LOCATION),
+similar to an entry in `package-alist'.  Save the cached copy to
+\"archives/NAME/archive-contents\" in `package-user-dir'."
+  (let* ((dir (expand-file-name "archives" package-user-dir))
+	 (dir (expand-file-name (car archive) dir)))
+    (package--with-work-buffer (cdr archive) file
       ;; Read the retrieved buffer to make sure it is valid (e.g. it
       ;; may fetch a URL redirect page).
       (when (listp (read buffer))
 	(make-directory dir t)
 	(setq buffer-file-name (expand-file-name file dir))
 	(let ((version-control 'never))
-	  (save-buffer))))
-    (kill-buffer buffer)))
+	  (save-buffer))))))
 
 (defun package-refresh-contents ()
   "Download the ELPA archive description if needed.
@@ -1176,27 +1192,21 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages."
 	    (while (re-search-forward "^\\(;+ ?\\)" nil t)
 	      (replace-match ""))))
       (let ((readme (expand-file-name (concat package-name "-readme.txt")
-				      package-user-dir)))
+				      package-user-dir))
+	    readme-string)
 	;; For elpa packages, try downloading the commentary.  If that
 	;; fails, try an existing readme file in `package-user-dir'.
-	(cond ((let ((buffer (ignore-errors
-			       (url-retrieve-synchronously
-				(concat (package-archive-url package)
-					package-name "-readme.txt"))))
-		     response)
-		 (when buffer
-		   (with-current-buffer buffer
-		     (setq response (url-http-parse-response))
-		     (if (or (< response 200) (>= response 300))
-			 (setq response nil)
-		       (setq buffer-file-name
-			     (expand-file-name readme package-user-dir))
-		       (delete-region (point-min) (1+ url-http-end-of-headers))
-		       (save-buffer)))
-		   (when response
-		     (insert-buffer-substring buffer)
-		     (kill-buffer buffer)
-		     t))))
+	(cond ((condition-case nil
+		   (package--with-work-buffer (package-archive-base package)
+					      (concat package-name "-readme.txt")
+		     (setq buffer-file-name
+			   (expand-file-name readme package-user-dir))
+		     (let ((version-control 'never))
+		       (save-buffer))
+		     (setq readme-string (buffer-string))
+		     t)
+		 (error nil))
+	       (insert readme-string))
 	      ((file-readable-p readme)
 	       (insert-file-contents readme)
 	       (goto-char (point-max))))))))