From 7c0d14414fd20b67f52cec2df87ca0601acf2c90 Mon Sep 17 00:00:00 2001 From: Christian Ohler Date: Thu, 3 Mar 2011 01:16:58 -0700 Subject: Fix ERT bug related to quit handling. * emacs-lisp/ert.el (ert--stats-set-test-and-result) (ert-char-for-test-result, ert-string-for-test-result) (ert-run-tests-batch, ert--print-test-for-ewoc): Handle `ert-test-quit'. --- lisp/emacs-lisp/ert.el | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index b3c95fcc78f..9767ae7549e 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1244,12 +1244,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 +1344,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 +1356,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 +1482,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 +1859,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) -- cgit v1.2.3 From de69c0a8d1ff21a0bd5663a555e47285aa1c70e1 Mon Sep 17 00:00:00 2001 From: Christian Ohler Date: Thu, 3 Mar 2011 02:01:51 -0700 Subject: Added fast path to ERT explanation of `equal'. * emacs-lisp/ert.el (ert--explain-equal): New function. (ert--explain-equal-rec): Renamed from `ert--explain-not-equal'. All callers changed. (ert--explain-equal-including-properties): Renamed from `ert--explain-not-equal-including-properties'. All callers changed. * automated/ert-tests.el (ert-test-explain-not-equal-keymaps): New test. --- lisp/ChangeLog | 9 +++++++++ lisp/emacs-lisp/ert.el | 42 ++++++++++++++++++++++++++---------------- test/ChangeLog | 5 +++++ test/automated/ert-tests.el | 33 +++++++++++++++++++-------------- 4 files changed, 59 insertions(+), 30 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b4b7525872b..9602bf20af6 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2011-03-03 Christian Ohler + + * emacs-lisp/ert.el (ert--explain-equal): New function. + (ert--explain-equal-rec): Renamed from `ert--explain-not-equal'. + All callers changed. + (ert--explain-equal-including-properties): Renamed from + `ert--explain-not-equal-including-properties'. All callers + changed. + 2011-03-03 Christian Ohler * emacs-lisp/ert.el (ert--stats-set-test-and-result) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 9767ae7549e..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'. diff --git a/test/ChangeLog b/test/ChangeLog index dbfc6c6cefe..8b7feaddf62 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,8 @@ +2011-03-03 Christian Ohler + + * automated/ert-tests.el (ert-test-explain-not-equal-keymaps): + New test. + 2011-02-20 Ulf Jasper * automated/icalendar-tests.el: Move from icalendar-testsuite.el; diff --git a/test/automated/ert-tests.el b/test/automated/ert-tests.el index b6d70dee7e2..cea994f64b8 100644 --- a/test/automated/ert-tests.el +++ b/test/automated/ert-tests.el @@ -796,27 +796,32 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert--string-first-line "foo\nbar") "foo")) (should (equal (ert--string-first-line " foo\nbar\nbaz\n") " foo"))) -(ert-deftest ert-test-explain-not-equal () - (should (equal (ert--explain-not-equal nil 'foo) +(ert-deftest ert-test-explain-equal () + (should (equal (ert--explain-equal nil 'foo) '(different-atoms nil foo))) - (should (equal (ert--explain-not-equal '(a a) '(a b)) + (should (equal (ert--explain-equal '(a a) '(a b)) '(list-elt 1 (different-atoms a b)))) - (should (equal (ert--explain-not-equal '(1 48) '(1 49)) + (should (equal (ert--explain-equal '(1 48) '(1 49)) '(list-elt 1 (different-atoms (48 "#x30" "?0") (49 "#x31" "?1"))))) - (should (equal (ert--explain-not-equal 'nil '(a)) + (should (equal (ert--explain-equal 'nil '(a)) '(different-types nil (a)))) - (should (equal (ert--explain-not-equal '(a b c) '(a b c d)) + (should (equal (ert--explain-equal '(a b c) '(a b c d)) '(proper-lists-of-different-length 3 4 (a b c) (a b c d) first-mismatch-at 3))) (let ((sym (make-symbol "a"))) - (should (equal (ert--explain-not-equal 'a sym) + (should (equal (ert--explain-equal 'a sym) `(different-symbols-with-the-same-name a ,sym))))) -(ert-deftest ert-test-explain-not-equal-improper-list () - (should (equal (ert--explain-not-equal '(a . b) '(a . c)) +(ert-deftest ert-test-explain-equal-improper-list () + (should (equal (ert--explain-equal '(a . b) '(a . c)) '(cdr (different-atoms b c))))) +(ert-deftest ert-test-explain-equal-keymaps () + ;; This used to be very slow. + (should (equal (make-keymap) (make-keymap))) + (should (equal (make-sparse-keymap) (make-sparse-keymap)))) + (ert-deftest ert-test-significant-plist-keys () (should (equal (ert--significant-plist-keys '()) '())) (should (equal (ert--significant-plist-keys '(a b c d e f c g p q r nil s t)) @@ -852,21 +857,21 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert--abbreviate-string "bar" 1 t) "r")) (should (equal (ert--abbreviate-string "bar" 0 t) ""))) -(ert-deftest ert-test-explain-not-equal-string-properties () +(ert-deftest ert-test-explain-equal-string-properties () (should - (equal (ert--explain-not-equal-including-properties #("foo" 0 1 (a b)) - "foo") + (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b)) + "foo") '(char 0 "f" (different-properties-for-key a (different-atoms b nil)) context-before "" context-after "oo"))) - (should (equal (ert--explain-not-equal-including-properties + (should (equal (ert--explain-equal-including-properties #("foo" 1 3 (a b)) #("goo" 0 1 (c d))) '(array-elt 0 (different-atoms (?f "#x66" "?f") (?g "#x67" "?g"))))) (should - (equal (ert--explain-not-equal-including-properties + (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b c d) 1 3 (a b)) #("foo" 0 1 (c d a b) 1 2 (a foo))) '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) -- cgit v1.2.3 From a918ed9b8ec6fcfc3e88747b07651549cdbe1e32 Mon Sep 17 00:00:00 2001 From: Bob Rogers Date: Thu, 3 Mar 2011 21:16:56 -0800 Subject: Minor ewoc fix for bug#3261. * lisp/emacs-lisp/ewoc.el (ewoc-goto-next): Give a more explicit error if there is no node. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/ewoc.el | 2 ++ 2 files changed, 7 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 04710d6bcf1..477361b9493 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2011-03-04 Bob Rogers + + * emacs-lisp/ewoc.el (ewoc-goto-next): Give a more explicit error + if there is no node. (Bug#3261) + 2011-03-04 Leo * time.el (display-time-world-list): Fix typo. (Bug#7571) 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) -- cgit v1.2.3 From 509742cc29a0878b7b1decbc5afc94e29813d630 Mon Sep 17 00:00:00 2001 From: Nikolaj Schumacher Date: Sat, 5 Mar 2011 18:38:48 -0800 Subject: * lisp/emacs-lisp/elp.el (elp-results): Fix off-by-one in header. (Bug#2746) --- lisp/ChangeLog | 4 ++++ lisp/emacs-lisp/elp.el | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b2788dd6899..ff365579ec0 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2011-03-06 Nikolaj Schumacher (tiny change) + + * emacs-lisp/elp.el (elp-results): Fix off-by-one in header. (Bug#2746) + 2011-03-06 Kevin Ryde * textmodes/sgml-mode.el (sgml-fill-nobreak): Give it a doc. (Bug#5326) 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)))))) -- cgit v1.2.3 From f561e49a25cace5e6d3cf3b222d87fa483226f76 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Sat, 5 Mar 2011 22:22:06 -0500 Subject: Allow specifying local ELPA mirrors in package-archives. * emacs-lisp/package.el (package-archives): Accept either ordinary directory names, in addition to HTTP URLs. (package--with-work-buffer): New macro. Handle normal directories. (package-handle-response): Don't display the failing buffer. (package-download-single, package-download-tar) (package--download-one-archive): Use package--with-work-buffer. (package-archive-base): Rename from package-archive-url. --- lisp/ChangeLog | 10 ++++ lisp/emacs-lisp/package.el | 124 ++++++++++++++++++++++++--------------------- 2 files changed, 77 insertions(+), 57 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a3646cc5a47..380d12443da 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,13 @@ +2011-03-06 Chong Yidong + + * emacs-lisp/package.el (package-archives): Accept either ordinary + directory names, in addition to HTTP URLs. + (package--with-work-buffer): New macro. Handle normal directories. + (package-handle-response): Don't display the failing buffer. + (package-download-single, package-download-tar) + (package--download-one-archive): Use package--with-work-buffer. + (package-archive-base): Rename from package-archive-url. + 2011-03-06 Glenn Morris * generic-x.el (generic-unix-modes): Add xmodmap-generic-mode. 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)))))))) -- cgit v1.2.3