From 53cfe624fc93b0f8aea0747f4d3493881404e77f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 23 Feb 2011 10:22:28 -0500 Subject: * lisp/emacs-lisp/bytecomp.el (byte-compile-disable-print-circle): Obsolete. --- lisp/emacs-lisp/bytecomp.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 199927d536e..2f113dfb479 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -227,6 +227,7 @@ the functions you loaded will not be able to run.") (defvar byte-compile-disable-print-circle nil "If non-nil, disable `print-circle' on printing a byte-compiled code.") +(make-obsolete-variable 'byte-compile-disable-print-circle nil "24.1") ;;;###autoload(put 'byte-compile-disable-print-circle 'safe-local-variable 'booleanp) (defcustom byte-compile-dynamic-docstrings t -- cgit v1.2.3 From 2d8a57efcb7f5c2b39dd4319bc4f17c6bff20635 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Wed, 23 Feb 2011 19:53:27 -0800 Subject: Avoid some possible prompts from autoloads.el. * lisp/emacs-lisp/autoload.el (autoload-save-buffers) (autoload-find-destination, update-directory-autoloads): Avoid prompts when updating autoloads. --- lisp/ChangeLog | 6 ++++++ lisp/emacs-lisp/autoload.el | 16 ++++++++++------ 2 files changed, 16 insertions(+), 6 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 33f39c00a60..28d09e7b2c8 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2011-02-24 Glenn Morris + + * emacs-lisp/autoload.el (autoload-save-buffers) + (autoload-find-destination, update-directory-autoloads): + Avoid prompts when updating autoloads. + 2011-02-23 Stefan Monnier * emacs-lisp/bytecomp.el (byte-compile-disable-print-circle): Obsolete. diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 7b610d11b0f..d6e7ee9e3cb 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -537,7 +537,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (defun autoload-save-buffers () (while autoload-modified-buffers (with-current-buffer (pop autoload-modified-buffers) - (save-buffer)))) + (let ((version-control 'never)) + (save-buffer))))) ;;;###autoload (defun update-file-autoloads (file &optional save-after) @@ -569,8 +570,9 @@ removes any prior now out-of-date autoload entries." (with-current-buffer ;; We used to use `raw-text' to read this file, but this causes ;; problems when the file contains non-ASCII characters. - (find-file-noselect - (autoload-ensure-default-file (autoload-generated-file))) + (let ((enable-local-variables :safe)) + (find-file-noselect + (autoload-ensure-default-file (autoload-generated-file)))) ;; This is to make generated-autoload-file have Unix EOLs, so ;; that it is portable to all platforms. (or (eq 0 (coding-system-eol-type buffer-file-coding-system)) @@ -656,8 +658,9 @@ directory or directories specified." (autoload-modified-buffers nil)) (with-current-buffer - (find-file-noselect - (autoload-ensure-default-file (autoload-generated-file))) + (let ((enable-local-variables :safe)) + (find-file-noselect + (autoload-ensure-default-file (autoload-generated-file)))) (save-excursion ;; Canonicalize file names and remove the autoload file itself. @@ -721,7 +724,8 @@ directory or directories specified." (current-buffer) nil nil no-autoloads this-time) (insert generate-autoload-section-trailer)) - (save-buffer) + (let ((version-control 'never)) + (save-buffer)) ;; In case autoload entries were added to other files because of ;; file-local autoload-generated-file settings. (autoload-save-buffers)))) -- cgit v1.2.3 From 7fe42546dd03801d190684ae29ced8e13b192156 Mon Sep 17 00:00:00 2001 From: Jambunathan K Date: Fri, 25 Feb 2011 13:30:00 -0500 Subject: Fix package uploading for newly made or local archives. * emacs-lisp/package-x.el (package--archive-contents-from-url) (package--archive-contents-from-file): New functions. (package-update-news-on-upload): New var. (package-upload-buffer-internal): Extract archive-contents from package-archive-upload-base if it is not found at archive-url. Obey package-update-news-on-upload. (package-upload-buffer, package-upload-file): Doc fix. --- lisp/ChangeLog | 10 +++++ lisp/emacs-lisp/package-x.el | 89 +++++++++++++++++++++++++++++++++----------- 2 files changed, 77 insertions(+), 22 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c44c491cad0..b59b11590d0 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,13 @@ +2011-02-25 Jambunathan K + + * emacs-lisp/package-x.el (package--archive-contents-from-url) + (package--archive-contents-from-file): New functions. + (package-update-news-on-upload): New var. + (package-upload-buffer-internal): Extract archive-contents from + package-archive-upload-base if it is not found at archive-url. + Obey package-update-news-on-upload. + (package-upload-buffer, package-upload-file): Doc fix. + 2011-02-24 Glenn Morris * files-x.el (modify-dir-local-variable): Handle dir-locals from diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index b9994be3d39..61f23abf0a7 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -40,6 +40,9 @@ (defvar package-archive-upload-base nil "Base location for uploading to package archive.") +(defvar package-update-news-on-upload nil + "Whether package upload should also update NEWS and RSS feeds.") + (defun package--encode (string) "Encode a string by replacing some characters with XML entities." ;; We need a special case for translating "&" to "&". @@ -86,6 +89,36 @@ (unless old-buffer (kill-buffer (current-buffer))))))) +(defun package--archive-contents-from-url (archive-url) + "Parse archive-contents file at ARCHIVE-URL. +Return the file contents, as a string, or nil if unsuccessful." + (ignore-errors + (when archive-url + (let* ((buffer (url-retrieve-synchronously + (concat archive-url "archive-contents")))) + (set-buffer buffer) + (package-handle-response) + (re-search-forward "^$" nil 'move) + (forward-char) + (delete-region (point-min) (point)) + (prog1 (package-read-from-string + (buffer-substring-no-properties (point-min) (point-max))) + (kill-buffer buffer)))))) + +(defun package--archive-contents-from-file (file) + "Parse the given archive-contents file." + (if (not (file-exists-p file)) + ;; no existing archive-contents, possibly a new ELPA repo. + (list package-archive-version) + (let ((dont-kill (find-buffer-visiting file))) + (with-current-buffer (let ((find-file-visit-truename t)) + (find-file-noselect file)) + (prog1 + (package-read-from-string + (buffer-substring-no-properties (point-min) (point-max))) + (unless dont-kill + (kill-buffer (current-buffer)))))))) + (defun package-maint-add-news-item (title description archive-url) "Add a news item to the ELPA web pages. TITLE is the title of the news item. @@ -111,11 +144,20 @@ PKG-INFO is the package info, see `package-buffer-info'. EXTENSION is the file extension, a string. It can be either \"el\" or \"tar\". +The variable `package-archive-upload-base' specifies the upload +destination. If this is nil, signal an error. + Optional arg ARCHIVE-URL is the URL of the destination archive. -If nil, the \"gnu\" archive is used." - (unless archive-url - (or (setq archive-url (cdr (assoc "gnu" package-archives))) - (error "No destination URL"))) +If it is non-nil, compute the new \"archive-contents\" file +starting from the existing \"archive-contents\" at that URL. In +addition, if `package-update-news-on-upload' is non-nil, call +`package--update-news' to add a news item at that URL. + +If ARCHIVE-URL is nil, compute the new \"archive-contents\" file +from the \"archive-contents\" at `package-archive-upload-base', +if it exists." + (unless package-archive-upload-base + (error "No destination specified in `package-archive-upload-base'")) (save-excursion (save-restriction (let* ((file-type (cond @@ -131,21 +173,14 @@ If nil, the \"gnu\" archive is used." (pkg-version (aref pkg-info 3)) (commentary (aref pkg-info 4)) (split-version (version-to-list pkg-version)) - (pkg-buffer (current-buffer)) + (pkg-buffer (current-buffer))) - ;; Download latest archive-contents. - (buffer (url-retrieve-synchronously - (concat archive-url "archive-contents")))) - - ;; Parse archive-contents. - (set-buffer buffer) - (package-handle-response) - (re-search-forward "^$" nil 'move) - (forward-char) - (delete-region (point-min) (point)) - (let ((contents (package-read-from-string - (buffer-substring-no-properties (point-min) - (point-max)))) + ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or + ;; from `package-archive-upload-base' otherwise. + (let ((contents (or (package--archive-contents-from-url archive-url) + (package--archive-contents-from-file + (concat package-archive-upload-base + "archive-contents")))) (new-desc (vector split-version requires desc file-type))) (if (> (car contents) package-archive-version) (error "Unrecognized archive version %d" (car contents))) @@ -176,7 +211,6 @@ If nil, the \"gnu\" archive is used." (symbol-name pkg-name) "-readme.txt"))) (set-buffer pkg-buffer) - (kill-buffer buffer) (write-region (point-min) (point-max) (concat package-archive-upload-base file-name "-" pkg-version @@ -184,8 +218,10 @@ If nil, the \"gnu\" archive is used." nil nil nil 'excl) ;; Write a news entry. - (package--update-news (concat file-name "." extension) - pkg-version desc archive-url) + (and package-update-news-on-upload + archive-url + (package--update-news (concat file-name "." extension) + pkg-version desc archive-url)) ;; special-case "package": write a second copy so that the ;; installer can easily find the latest version. @@ -196,7 +232,9 @@ If nil, the \"gnu\" archive is used." nil nil nil 'ask))))))) (defun package-upload-buffer () - "Upload a single .el file to ELPA from the current buffer." + "Upload the current buffer as a single-file Emacs Lisp package. +The variable `package-archive-upload-base' specifies the upload +destination." (interactive) (save-excursion (save-restriction @@ -205,6 +243,13 @@ If nil, the \"gnu\" archive is used." (package-upload-buffer-internal pkg-info "el"))))) (defun package-upload-file (file) + "Upload the Emacs Lisp package FILE to the package archive. +Interactively, prompt for FILE. The package is considered a +single-file package if FILE ends in \".el\", and a multi-file +package if FILE ends in \".tar\". + +The variable `package-archive-upload-base' specifies the upload +destination." (interactive "fPackage file name: ") (with-temp-buffer (insert-file-contents-literally file) -- cgit v1.2.3 From e573299d40e5825584ed9e8bd58f5a8c2deee6fd Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 26 Feb 2011 16:09:03 -0500 Subject: * lisp/emacs-lisp/assoc.el: Remove misleading `sort'. (aput, adelete, amake): Replace `eval' -> `symbol-value'. Suggested by Michael Heerdegen . Fixes: debbugs:8126 --- lisp/ChangeLog | 6 ++++++ lisp/emacs-lisp/assoc.el | 10 +++++----- 2 files changed, 11 insertions(+), 5 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index f5df9a26c37..8d4ccfbf652 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2011-02-26 Stefan Monnier + + * emacs-lisp/assoc.el: Remove misleading `sort' (bug#8126). + (aput, adelete, amake): Replace `eval' -> `symbol-value'. + Suggested by Michael Heerdegen . + 2011-02-25 Teodor Zlatanov * password-cache.el (password-in-cache-p): Convenience function to diff --git a/lisp/emacs-lisp/assoc.el b/lisp/emacs-lisp/assoc.el index aa85916cc3f..31be851f2dd 100644 --- a/lisp/emacs-lisp/assoc.el +++ b/lisp/emacs-lisp/assoc.el @@ -1,4 +1,4 @@ -;;; assoc.el --- insert/delete/sort functions on association lists +;;; assoc.el --- insert/delete functions on association lists ;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc. @@ -35,7 +35,7 @@ head is one matching KEY. Returns the sorted list and doesn't affect the order of any other key-value pair. Side effect sets alist to new sorted list." (set alist-symbol - (sort (copy-alist (eval alist-symbol)) + (sort (copy-alist (symbol-value alist-symbol)) (function (lambda (a b) (equal (car a) key)))))) @@ -75,7 +75,7 @@ of the alist (with value nil if VALUE is nil or not supplied)." (lexical-let ((elem (aelement key value)) alist) (asort alist-symbol key) - (setq alist (eval alist-symbol)) + (setq alist (symbol-value alist-symbol)) (cond ((null alist) (set alist-symbol elem)) ((anot-head-p alist key) (set alist-symbol (nconc elem alist))) (value (setcar alist (car elem))) @@ -87,7 +87,7 @@ of the alist (with value nil if VALUE is nil or not supplied)." Alist is referenced by ALIST-SYMBOL and the key-value pair to remove is pair matching KEY. Returns the altered alist." (asort alist-symbol key) - (lexical-let ((alist (eval alist-symbol))) + (lexical-let ((alist (symbol-value alist-symbol))) (cond ((null alist) nil) ((anot-head-p alist key) alist) (t (set alist-symbol (cdr alist)))))) @@ -133,7 +133,7 @@ extra values are ignored. Returns the created alist." (t (amake alist-symbol keycdr valcdr) (aput alist-symbol keycar valcar)))) - (eval alist-symbol)) + (symbol-value alist-symbol)) (provide 'assoc) -- cgit v1.2.3 From 1f0816b69dfdbda486bf0329bbfb2e8ccee63d39 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 26 Feb 2011 21:50:38 -0500 Subject: * lisp/emacs-lisp/pcase.el (pcase--if): Try to invert test to reduce depth. (pcase-mutually-exclusive-predicates): New var. (pcase--split-consp, pcase--split-pred): Use it. (pcase--split-equal, pcase--split-member): When splitting against a pure predicate, run it to know the outcome. (pcase--u1): Mark vars that are actually used. (pcase--q1): Avoid introducing unused vars. --- lisp/ChangeLog | 10 +++++ lisp/emacs-lisp/pcase.el | 101 ++++++++++++++++++++++++++++++++++++++++------- 2 files changed, 97 insertions(+), 14 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d9f4c3c3ea2..c2731530e57 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,13 @@ +2011-02-27 Stefan Monnier + + * emacs-lisp/pcase.el (pcase--if): Try to invert test to reduce depth. + (pcase-mutually-exclusive-predicates): New var. + (pcase--split-consp, pcase--split-pred): Use it. + (pcase--split-equal, pcase--split-member): When splitting against + a pure predicate, run it to know the outcome. + (pcase--u1): Mark vars that are actually used. + (pcase--q1): Avoid introducing unused vars. + 2011-02-27 Jay Belanger * calc/calc-ext.el (calc-init-extensions): diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 3179672a3ec..0d5fd99db5d 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -32,6 +32,14 @@ ;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). ;; But better would be if we could define new ways to match by having the ;; extension provide its own `pcase--split-' thingy. +;; - provide something like (setq VAR) so a var can be set rather than +;; let-bound. +;; - provide a way to fallthrough to other cases. +;; - try and be more clever to reduce the size of the decision tree, and +;; to reduce the number of leafs that need to be turned into function: +;; - first, do the tests shared by all remaining branches (it will have +;; to be performed anyway, so better so it first so it's shared). +;; - then choose the test that discriminates more (?). ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to ;; generate a lex-style DFA to decide whether to run E1 or E2. @@ -209,6 +217,7 @@ of the form (UPAT EXP)." (defun pcase--if (test then else) (cond ((eq else :pcase--dontcare) then) + ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen? ((eq (car-safe else) 'if) (if (equal test (nth 1 else)) ;; Doing a test a second time: get rid of the redundancy. @@ -223,6 +232,8 @@ of the form (UPAT EXP)." `(cond (,test ,then) ;; Doing a test a second time: get rid of the redundancy, as above. ,@(remove (assoc test else) (cdr else)))) + ;; Invert the test if that lets us reduce the depth of the tree. + ((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then)) (t `(if ,test ,then ,else)))) (defun pcase--upat (qpattern) @@ -264,6 +275,22 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase--and (match matches) (if matches `(and ,match ,@matches) match)) +(defconst pcase-mutually-exclusive-predicates + '((symbolp . integerp) + (symbolp . numberp) + (symbolp . consp) + (symbolp . arrayp) + (symbolp . stringp) + (integerp . consp) + (integerp . arrayp) + (integerp . stringp) + (numberp . consp) + (numberp . arrayp) + (numberp . stringp) + (consp . arrayp) + (consp . stringp) + (arrayp . stringp))) + (defun pcase--split-match (sym splitter match) (case (car match) ((match) @@ -324,8 +351,14 @@ MATCH is the pattern that needs to be matched, of the form: (cons `(and (match ,syma . ,(pcase--upat (car qpat))) (match ,symd . ,(pcase--upat (cdr qpat)))) :pcase--fail))) - ;; A QPattern but not for a cons, can only go the `else' side. - ((eq (car-safe pat) '\`) (cons :pcase--fail nil)))) + ;; A QPattern but not for a cons, can only go to the `else' side. + ((eq (car-safe pat) '\`) (cons :pcase--fail nil)) + ((and (eq (car-safe pat) 'pred) + (or (member (cons 'consp (cadr pat)) + pcase-mutually-exclusive-predicates) + (member (cons (cadr pat) 'consp) + pcase-mutually-exclusive-predicates))) + (cons :pcase--fail nil)))) (defun pcase--split-equal (elem pat) (cond @@ -337,7 +370,12 @@ MATCH is the pattern that needs to be matched, of the form: ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) - (cons :pcase--fail nil)))) + (cons :pcase--fail nil)) + ((and (eq (car-safe pat) 'pred) + (symbolp (cadr pat)) + (get (cadr pat) 'side-effect-free) + (funcall (cadr pat) elem)) + (cons :pcase--succeed nil)))) (defun pcase--split-member (elems pat) ;; Based on pcase--split-equal. @@ -354,13 +392,39 @@ MATCH is the pattern that needs to be matched, of the form: ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) - (cons :pcase--fail nil)))) + (cons :pcase--fail nil)) + ((and (eq (car-safe pat) 'pred) + (symbolp (cadr pat)) + (get (cadr pat) 'side-effect-free) + (let ((p (cadr pat)) (all t)) + (dolist (elem elems) + (unless (funcall p elem) (setq all nil))) + all)) + (cons :pcase--succeed nil)))) (defun pcase--split-pred (upat pat) ;; FIXME: For predicates like (pred (> a)), two such predicates may ;; actually refer to different variables `a'. - (if (equal upat pat) - (cons :pcase--succeed :pcase--fail))) + (cond + ((equal upat pat) (cons :pcase--succeed :pcase--fail)) + ((and (eq 'pred (car upat)) + (eq 'pred (car-safe pat)) + (or (member (cons (cadr upat) (cadr pat)) + pcase-mutually-exclusive-predicates) + (member (cons (cadr pat) (cadr upat)) + pcase-mutually-exclusive-predicates))) + (cons :pcase--fail nil)) + ;; ((and (eq 'pred (car upat)) + ;; (eq '\` (car-safe pat)) + ;; (symbolp (cadr upat)) + ;; (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat))) + ;; (get (cadr upat) 'side-effect-free) + ;; (progn (message "Trying predicate %S" (cadr upat)) + ;; (ignore-errors + ;; (funcall (cadr upat) (cadr pat))))) + ;; (message "Simplify pred %S against %S" upat pat) + ;; (cons nil :pcase--fail)) + )) (defun pcase--fgrep (vars sexp) "Check which of the symbols VARS appear in SEXP." @@ -433,6 +497,7 @@ and otherwise defers to REST which is a list of branches of the form ((eq upat 'dontcare) :pcase--dontcare) ((functionp upat) (error "Feature removed, use (pred %s)" upat)) ((memq (car-safe upat) '(guard pred)) + (if (eq (car upat) 'pred) (put sym 'pcase-used t)) (destructuring-bind (then-rest &rest else-rest) (pcase--split-rest sym (apply-partially #'pcase--split-pred upat) rest) @@ -459,6 +524,7 @@ and otherwise defers to REST which is a list of branches of the form (pcase--u1 matches code vars then-rest) (pcase--u else-rest)))) ((symbolp upat) + (put sym 'pcase-used t) (if (not (assq upat vars)) (pcase--u1 matches code (cons (cons upat sym) vars) rest) ;; Non-linear pattern. Turn it into an `eq' test. @@ -466,6 +532,7 @@ and otherwise defers to REST which is a list of branches of the form matches) code vars rest))) ((eq (car-safe upat) '\`) + (put sym 'pcase-used t) (pcase--q1 sym (cadr upat) matches code vars rest)) ((eq (car-safe upat) 'or) (let ((all (> (length (cdr upat)) 1)) @@ -539,14 +606,20 @@ and if not, defers to REST which is a list of branches of the form (pcase--split-rest sym (apply-partially #'pcase--split-consp syma symd) rest) - (pcase--if `(consp ,sym) - `(let ((,syma (car ,sym)) - (,symd (cdr ,sym))) - ,(pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) - (match ,symd . ,(pcase--upat (cdr qpat))) - ,@matches) - code vars then-rest)) - (pcase--u else-rest))))) + (let ((then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) + (match ,symd . ,(pcase--upat (cdr qpat))) + ,@matches) + code vars then-rest))) + (pcase--if + `(consp ,sym) + ;; We want to be careful to only add bindings that are used. + ;; The byte-compiler could do that for us, but it would have to pay + ;; attention to the `consp' test in order to figure out that car/cdr + ;; can't signal errors and our byte-compiler is not that clever. + `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) + ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) + ,then-body) + (pcase--u else-rest)))))) ((or (integerp qpat) (symbolp qpat) (stringp qpat)) (destructuring-bind (then-rest &rest else-rest) (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest) -- cgit v1.2.3 From ca3afb79d0530a7f100e40d263cf9a3912f597b8 Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Mon, 28 Feb 2011 05:24:40 +0100 Subject: lisp/emacs-lisp/pcase.el (pcase, pcase--u1, pcase--q1): Fix typos in docstrings. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/pcase.el | 10 +++++----- 2 files changed, 10 insertions(+), 5 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a7201a5c399..4fe7b7883f3 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2011-02-28 Juanma Barranquero + + * emacs-lisp/pcase.el (pcase, pcase--u1, pcase--q1): + Fix typos in docstrings. + 2011-02-28 Stephen Berman * dired-aux.el (dired-update-file-line): diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 0d5fd99db5d..916dcd4785c 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. ;; Author: Stefan Monnier -;; Keywords: +;; Keywords: ;; This file is part of GNU Emacs. @@ -75,12 +75,12 @@ If a SYMBOL is used twice in the same pattern (i.e. the pattern is QPatterns can take the following forms: (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. ,UPAT matches if the UPattern UPAT matches. - STRING matches if the object is `equal' to STRING. + STRING matches if the object is `equal' to STRING. ATOM matches if the object is `eq' to ATOM. QPatterns for vectors are not implemented yet. PRED can take the form - FUNCTION in which case it gets called with one argument. + FUNCTION in which case it gets called with one argument. (FUN ARG1 .. ARGN) in which case it gets called with N+1 arguments. A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION). PRED patterns can refer to variables bound earlier in the pattern. @@ -439,7 +439,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; bootstrapping problems. (defun pcase--u1 (matches code vars rest) "Return code that runs CODE (with VARS) if MATCHES match. -and otherwise defers to REST which is a list of branches of the form +Otherwise, it defers to REST which is a list of branches of the form \(ELSE-MATCH ELSE-CODE . ELSE-VARS)." ;; Depending on the order in which we choose to check each of the MATCHES, ;; the resulting tree may be smaller or bigger. So in general, we'd want @@ -591,7 +591,7 @@ and otherwise defers to REST which is a list of branches of the form (defun pcase--q1 (sym qpat matches code vars rest) "Return code that runs CODE if SYM matches QPAT and if MATCHES match. -and if not, defers to REST which is a list of branches of the form +Otherwise, it defers to REST which is a list of branches of the form \(OTHER_MATCH OTHER-CODE . OTHER-VARS)." (cond ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN")) -- cgit v1.2.3 From f6132e5a3cc01b3deb9894cbf2b3462c6c70b1c7 Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Tue, 1 Mar 2011 04:59:31 +0100 Subject: lisp/emacs-lisp/cl-macs.el (lexical-let*): Fix argument name in docstring. --- lisp/ChangeLog | 4 ++++ lisp/emacs-lisp/cl-loaddefs.el | 4 ++-- lisp/emacs-lisp/cl-macs.el | 2 +- 3 files changed, 7 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e841238524c..b4d62f105e9 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2011-03-01 Juanma Barranquero + + * emacs-lisp/cl-macs.el (lexical-let*): Fix argument name in docstring. + 2011-03-01 Glenn Morris * calendar/cal-hebrew.el (calendar-hebrew-birthday, diary-hebrew-date): diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 8e192a18459..08001171ed1 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -282,7 +282,7 @@ Not documented ;;;;;; do-all-symbols do-symbols dotimes dolist do* do loop return-from ;;;;;; return block etypecase typecase ecase case load-time-value ;;;;;; eval-when destructuring-bind function* defmacro* defun* gentemp -;;;;;; gensym) "cl-macs" "cl-macs.el" "0904b956872432ae7cc5fa9abcefce63") +;;;;;; gensym) "cl-macs" "cl-macs.el" "b3031039e82679e5b013ce1cbf174ee8") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ @@ -505,7 +505,7 @@ lexical closures as in Common Lisp. (autoload 'lexical-let* "cl-macs" "\ Like `let*', but lexically scoped. The main visible difference is that lambdas inside BODY, and in -successive bindings within BINDINGS, will create lexical closures +successive bindings within VARLIST, will create lexical closures as in Common Lisp. This is similar to the behavior of `let*' in Common Lisp. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 80e95724f1f..c57d37703b0 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1470,7 +1470,7 @@ lexical closures as in Common Lisp. (defmacro lexical-let* (bindings &rest body) "Like `let*', but lexically scoped. The main visible difference is that lambdas inside BODY, and in -successive bindings within BINDINGS, will create lexical closures +successive bindings within VARLIST, will create lexical closures as in Common Lisp. This is similar to the behavior of `let*' in Common Lisp. \n(fn VARLIST BODY)" -- cgit v1.2.3 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/ChangeLog | 7 +++++++ lisp/emacs-lisp/ert.el | 20 ++++++++++++++------ 2 files changed, 21 insertions(+), 6 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d933a2ea696..b4b7525872b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,10 @@ +2011-03-03 Christian Ohler + + * 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'. + 2011-03-03 Bob Rogers * vc/vc-dir.el (vc-dir-mode-map): Bind vc-dir-find-file to e. (Bug#7349) 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