[Emacs-diffs] /srv/bzr/emacs/trunk r103688: Fix tar package handling, and clean up package-subdirectory-regexp usage.

[Chong Yidong]

------------------------------------------------------------
revno: 103688
committer: Chong Yidong <address@hidden>
branch nick: trunk
timestamp: Sat 2011-03-19 14:27:55 -0400
message:
  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.
modified:
  lisp/ChangeLog
  lisp/emacs-lisp/package.el
  lisp/startup.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2011-03-18 19:52:05 +0000
+++ b/lisp/ChangeLog    2011-03-19 18:27:55 +0000
@@ -1,3 +1,16 @@
+2011-03-19  Chong Yidong  <address@hidden>
+
+       * 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  <address@hidden>
 
        * vc/diff-mode.el (diff-mode-map): Shadow problematic bindings from

=== modified file 'lisp/emacs-lisp/package.el'
--- a/lisp/emacs-lisp/package.el        2011-03-10 23:40:46 +0000
+++ b/lisp/emacs-lisp/package.el        2011-03-19 18:27:55 +0000
@@ -319,12 +319,6 @@
 The inner alist is keyed by version.")
 (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)
   "Return the version string corresponding to the list VLIST.
 This is, approximately, the inverse of `version-to-list'.
@@ -357,7 +351,7 @@
 (defun package-strip-version (dirname)
   "Strip the version from a combined package name and version.
 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)))
 
 (defun package-load-descriptor (dir package)
@@ -382,12 +376,13 @@
 description file containing a call to `define-package', which
 updates `package-alist' and `package-obsolete-alist'."
   (let ((all (memq 'all package-load-list))
+       (regexp (concat "\\`" package-subdirectory-regexp "\\'"))
        name version force)
     (dolist (dir (cons package-user-dir package-directory-list))
       (when (file-directory-p dir)
        (dolist (subdir (directory-files 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))
                  version (match-string 2 subdir)
                  force   (assq name package-load-list))
@@ -579,30 +574,29 @@
       (package-autoload-ensure-default-file generated-autoload-file))
     (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.
-This uses `tar-untar-buffer' if it is available.
-Otherwise it uses an external `tar' program.
-`default-directory' should be set by the caller."
+This uses `tar-untar-buffer' from Tar mode.  All files should
+untar into a directory named DIR; otherwise, signal an error."
   (require 'tar-mode)
-  (if (fboundp 'tar-untar-buffer)
-      (progn
-       ;; tar-mode messes with narrowing, so we just let it have the
-       ;; whole buffer to play with.
-       (delete-region (point-min) (point))
-       (tar-mode)
-       (tar-untar-buffer))
-    ;; FIXME: check the result.
-    (call-process-region (point) (point-max) "tar" nil '(nil nil) nil
-                        "xf" "-")))
+  (tar-mode)
+  ;; Make sure everything extracts into DIR.
+  (let ((regexp (concat "\\`" (regexp-quote dir) "/")))
+    (dolist (tar-data tar-parse-info)
+      (unless (string-match regexp (aref tar-data 2))
+       (error "Package does not untar cleanly into directory %s/" dir))))
+  (tar-untar-buffer))
 
 (defun package-unpack (name version)
-  (let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version)
-                                  package-user-dir)))
+  (let* ((dirname (concat (symbol-name name) "-" version))
+        (pkg-dir (expand-file-name dirname package-user-dir)))
     (make-directory package-user-dir t)
     ;; FIXME: should we delete PKG-DIR if it exists?
     (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)
       (let ((load-path (cons pkg-dir load-path)))
        (byte-recompile-directory pkg-dir 0 t)))))
@@ -942,7 +936,8 @@
 The return result is a vector like `package-buffer-info'."
   (let ((default-directory (file-name-directory 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))
     (let* ((pkg-name (match-string-no-properties 1 file))
           (pkg-version (match-string-no-properties 2 file))

=== modified file 'lisp/startup.el'
--- a/lisp/startup.el   2011-03-16 02:13:31 +0000
+++ b/lisp/startup.el   2011-03-19 18:27:55 +0000
@@ -392,6 +392,15 @@
   :type 'directory
   :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 ()
   "Add all subdirectories of current directory to `load-path'.
 More precisely, this uses only the subdirectories whose names
@@ -1194,9 +1203,9 @@
             (when (file-directory-p dir)
               (dolist (subdir (directory-files dir))
                 (when (and (file-directory-p (expand-file-name subdir dir))
-                           ;; package-subdirectory-regexp from package.el
-                           (string-match 
"\\`\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)\\'"
-                                         subdir))
+                           (string-match
+                            (concat "\\`" package-subdirectory-regexp "\\'")
+                            subdir))
                   (throw 'package-dir-found t)))))))
        (package-initialize))