Commit 4525ce3e authored by Chong Yidong's avatar Chong Yidong

Fix tar package handling, and clean up package-subdirectory-regexp usage.

* lisp/startup.el (package-subdirectory-regexp): Move from package.el.
Omit \\` and \\', and let callers add them.

* lisp/emacs-lisp/package.el (package-strip-version)
(package-load-all-descriptors): Add \\` and \\' to
package-subdirectory-regexp before using it.
(package-untar-buffer): New arg DIR; ensure that file untars only
into this expected directory.  Remove superfluous delete-region.
(package-unpack): Caller changed.
(package-tar-file-info): Use package-subdirectory-regexp.
parent 0a19a6f8
2011-03-19 Chong Yidong <cyd@stupidchicken.com>
* startup.el (package-subdirectory-regexp): Move from package.el.
Omit \\` and \\', and let callers add them.
* emacs-lisp/package.el (package-strip-version)
(package-load-all-descriptors): Add \\` and \\' to
package-subdirectory-regexp before using it.
(package-untar-buffer): New arg DIR; ensure that file untars only
into this expected directory. Remove superfluous delete-region.
(package-unpack): Caller changed.
(package-tar-file-info): Use package-subdirectory-regexp.
2011-03-18 Stefan Monnier <monnier@iro.umontreal.ca> 2011-03-18 Stefan Monnier <monnier@iro.umontreal.ca>
* vc/diff-mode.el (diff-mode-map): Shadow problematic bindings from * vc/diff-mode.el (diff-mode-map): Shadow problematic bindings from
......
...@@ -319,12 +319,6 @@ Like `package-alist', but maps package name to a second alist. ...@@ -319,12 +319,6 @@ Like `package-alist', but maps package name to a second alist.
The inner alist is keyed by version.") The inner alist is keyed by version.")
(put 'package-obsolete-alist 'risky-local-variable t) (put 'package-obsolete-alist 'risky-local-variable t)
(defconst package-subdirectory-regexp
"\\`\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)\\'"
"Regular expression matching the name of a package subdirectory.
The first subexpression is the package name.
The second subexpression is the version string.")
(defun package-version-join (vlist) (defun package-version-join (vlist)
"Return the version string corresponding to the list VLIST. "Return the version string corresponding to the list VLIST.
This is, approximately, the inverse of `version-to-list'. This is, approximately, the inverse of `version-to-list'.
...@@ -357,7 +351,7 @@ This is, approximately, the inverse of `version-to-list'. ...@@ -357,7 +351,7 @@ This is, approximately, the inverse of `version-to-list'.
(defun package-strip-version (dirname) (defun package-strip-version (dirname)
"Strip the version from a combined package name and version. "Strip the version from a combined package name and version.
E.g., if given \"quux-23.0\", will return \"quux\"" E.g., if given \"quux-23.0\", will return \"quux\""
(if (string-match package-subdirectory-regexp dirname) (if (string-match (concat "\\`" package-subdirectory-regexp "\\'") dirname)
(match-string 1 dirname))) (match-string 1 dirname)))
(defun package-load-descriptor (dir package) (defun package-load-descriptor (dir package)
...@@ -382,12 +376,13 @@ In each valid package subdirectory, this function loads the ...@@ -382,12 +376,13 @@ In each valid package subdirectory, this function loads the
description file containing a call to `define-package', which description file containing a call to `define-package', which
updates `package-alist' and `package-obsolete-alist'." updates `package-alist' and `package-obsolete-alist'."
(let ((all (memq 'all package-load-list)) (let ((all (memq 'all package-load-list))
(regexp (concat "\\`" package-subdirectory-regexp "\\'"))
name version force) name version force)
(dolist (dir (cons package-user-dir package-directory-list)) (dolist (dir (cons package-user-dir package-directory-list))
(when (file-directory-p dir) (when (file-directory-p dir)
(dolist (subdir (directory-files dir)) (dolist (subdir (directory-files dir))
(when (and (file-directory-p (expand-file-name subdir dir)) (when (and (file-directory-p (expand-file-name subdir dir))
(string-match package-subdirectory-regexp subdir)) (string-match regexp subdir))
(setq name (intern (match-string 1 subdir)) (setq name (intern (match-string 1 subdir))
version (match-string 2 subdir) version (match-string 2 subdir)
force (assq name package-load-list)) force (assq name package-load-list))
...@@ -579,30 +574,29 @@ EXTRA-PROPERTIES is currently unused." ...@@ -579,30 +574,29 @@ EXTRA-PROPERTIES is currently unused."
(package-autoload-ensure-default-file generated-autoload-file)) (package-autoload-ensure-default-file generated-autoload-file))
(update-directory-autoloads pkg-dir))) (update-directory-autoloads pkg-dir)))
(defun package-untar-buffer () (defvar tar-parse-info)
(declare-function tar-untar-buffer "tar-mode" ())
(defun package-untar-buffer (dir)
"Untar the current buffer. "Untar the current buffer.
This uses `tar-untar-buffer' if it is available. This uses `tar-untar-buffer' from Tar mode. All files should
Otherwise it uses an external `tar' program. untar into a directory named DIR; otherwise, signal an error."
`default-directory' should be set by the caller."
(require 'tar-mode) (require 'tar-mode)
(if (fboundp 'tar-untar-buffer) (tar-mode)
(progn ;; Make sure everything extracts into DIR.
;; tar-mode messes with narrowing, so we just let it have the (let ((regexp (concat "\\`" (regexp-quote dir) "/")))
;; whole buffer to play with. (dolist (tar-data tar-parse-info)
(delete-region (point-min) (point)) (unless (string-match regexp (aref tar-data 2))
(tar-mode) (error "Package does not untar cleanly into directory %s/" dir))))
(tar-untar-buffer)) (tar-untar-buffer))
;; FIXME: check the result.
(call-process-region (point) (point-max) "tar" nil '(nil nil) nil
"xf" "-")))
(defun package-unpack (name version) (defun package-unpack (name version)
(let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version) (let* ((dirname (concat (symbol-name name) "-" version))
package-user-dir))) (pkg-dir (expand-file-name dirname package-user-dir)))
(make-directory package-user-dir t) (make-directory package-user-dir t)
;; FIXME: should we delete PKG-DIR if it exists? ;; FIXME: should we delete PKG-DIR if it exists?
(let* ((default-directory (file-name-as-directory package-user-dir))) (let* ((default-directory (file-name-as-directory package-user-dir)))
(package-untar-buffer) (package-untar-buffer dirname)
(package-generate-autoloads (symbol-name name) pkg-dir) (package-generate-autoloads (symbol-name name) pkg-dir)
(let ((load-path (cons pkg-dir load-path))) (let ((load-path (cons pkg-dir load-path)))
(byte-recompile-directory pkg-dir 0 t))))) (byte-recompile-directory pkg-dir 0 t)))))
...@@ -942,7 +936,8 @@ FILE is the name of the tar file to examine. ...@@ -942,7 +936,8 @@ FILE is the name of the tar file to examine.
The return result is a vector like `package-buffer-info'." The return result is a vector like `package-buffer-info'."
(let ((default-directory (file-name-directory file)) (let ((default-directory (file-name-directory file))
(file (file-name-nondirectory file))) (file (file-name-nondirectory file)))
(unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file) (unless (string-match (concat "\\`" package-subdirectory-regexp "\\.tar\\'")
file)
(error "Invalid package name `%s'" file)) (error "Invalid package name `%s'" file))
(let* ((pkg-name (match-string-no-properties 1 file)) (let* ((pkg-name (match-string-no-properties 1 file))
(pkg-version (match-string-no-properties 2 file)) (pkg-version (match-string-no-properties 2 file))
......
...@@ -392,6 +392,15 @@ Warning Warning!!! Pure space overflow !!!Warning Warning ...@@ -392,6 +392,15 @@ Warning Warning!!! Pure space overflow !!!Warning Warning
:type 'directory :type 'directory
:initialize 'custom-initialize-delay) :initialize 'custom-initialize-delay)
(defconst package-subdirectory-regexp
"\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)"
"Regular expression matching the name of a package subdirectory.
The first subexpression is the package name.
The second subexpression is the version string.
The regexp should not contain a starting \"\\`\" or a trailing
\"\\'\"; those are added automatically by callers.")
(defun normal-top-level-add-subdirs-to-load-path () (defun normal-top-level-add-subdirs-to-load-path ()
"Add all subdirectories of current directory to `load-path'. "Add all subdirectories of current directory to `load-path'.
More precisely, this uses only the subdirectories whose names More precisely, this uses only the subdirectories whose names
...@@ -1194,9 +1203,9 @@ the `--debug-init' option to view a complete error backtrace." ...@@ -1194,9 +1203,9 @@ the `--debug-init' option to view a complete error backtrace."
(when (file-directory-p dir) (when (file-directory-p dir)
(dolist (subdir (directory-files dir)) (dolist (subdir (directory-files dir))
(when (and (file-directory-p (expand-file-name subdir dir)) (when (and (file-directory-p (expand-file-name subdir dir))
;; package-subdirectory-regexp from package.el (string-match
(string-match "\\`\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)\\'" (concat "\\`" package-subdirectory-regexp "\\'")
subdir)) subdir))
(throw 'package-dir-found t))))))) (throw 'package-dir-found t)))))))
(package-initialize)) (package-initialize))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment