diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/elp.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 62 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ewoc.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/package.el | 124 |
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)))))))) |