From 3c94d7a636863b61de68199e5767bb093503551a Mon Sep 17 00:00:00 2001
From: Chong Yidong <cyd@gnu.org>
Date: Sat, 29 Dec 2012 19:06:10 +0800
Subject: [PATCH] * emacs-lisp/package.el (package-untar-buffer): Improve
 integrity check for tarball contents.

---
 lisp/ChangeLog             |  5 +++++
 lisp/emacs-lisp/package.el | 18 +++++++++++-------
 2 files changed, 16 insertions(+), 7 deletions(-)

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 4ed7103270e..5907f5ef7ec 100644
--- 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 54d133b166c..96435e52f11 100644
--- 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)
-- 
2.11.4.GIT