* emacs-lisp/package.el (package-untar-buffer): Improve integrity check for tarball...

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 4ed7103270e7e81faa953231f1b1ca184120a0d4..5907f5ef7ec892a2da57a975d43bf76094e3b2df 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,8 @@
+2012-12-29  Chong Yidong  <cyd@gnu.org>
+
+       * emacs-lisp/package.el (package-untar-buffer): Improve integrity
+       check for the tarball contents.
+
 2012-12-29  Matt Fidler  <matt.fidler@alcon.com>  (tiny change)
 
        * emacs-lisp/package.el (package-untar-buffer): Handle problematic

diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 54d133b166c40d1171a79356eb41855eee5a3cc6..96435e52f11b4f1ca10965c8929c850783ee449f 100644 (file)
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -596,6 +596,8 @@ EXTRA-PROPERTIES is currently unused."
 
 (defvar tar-parse-info)
 (declare-function tar-untar-buffer "tar-mode" ())
+(declare-function tar-header-name "tar-mode" (tar-header))
+(declare-function tar-header-link-type "tar-mode" (tar-header))
 
 (defun package-untar-buffer (dir)
   "Untar the current buffer.
@@ -604,14 +606,16 @@ untar into a directory named DIR; otherwise, signal an error."
   (require 'tar-mode)
   (tar-mode)
   ;; Make sure everything extracts into DIR.
-  (let ((regexp (concat "\\`" (regexp-quote dir)
-                       ;; Tarballs created by some utilities don't
-                       ;; list directories with a trailing slash
-                       ;; (Bug#13136).
-                       "\\(/\\|\\'\\)")))
+  (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/"))
+       (case-fold-search (memq system-type '(windows-nt ms-dos cygwin))))
     (dolist (tar-data tar-parse-info)
-      (unless (string-match regexp (aref tar-data 2))
-       (error "Package does not untar cleanly into directory %s/" dir))))
+      (let ((name (expand-file-name (tar-header-name tar-data))))
+       (or (string-match regexp name)
+           ;; Tarballs created by some utilities don't list
+           ;; directories with a trailing slash (Bug#13136).
+           (and (string-equal dir name)
+                (eq (tar-header-link-type tar-data) 5))
+           (error "Package does not untar cleanly into directory %s/" dir)))))
   (tar-untar-buffer))
 
 (defun package-unpack (package version)