[Emacs-diffs] /srv/bzr/emacs/emacs-24 r111094: * emacs-lisp/package.el (package-untar-buffer): Improve integrity check for tarball contents.

[Chong Yidong]

------------------------------------------------------------
revno: 111094
committer: Chong Yidong <address@hidden>
branch nick: emacs-24
timestamp: Sat 2012-12-29 19:06:10 +0800
message:
  * emacs-lisp/package.el (package-untar-buffer): Improve integrity check for 
tarball contents.
modified:
  lisp/ChangeLog
  lisp/emacs-lisp/package.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2012-12-29 10:26:14 +0000
+++ b/lisp/ChangeLog    2012-12-29 11:06:10 +0000
@@ -1,3 +1,8 @@
+2012-12-29  Chong Yidong  <address@hidden>
+
+       * emacs-lisp/package.el (package-untar-buffer): Improve integrity
+       check for the tarball contents.
+
 2012-12-29  Matt Fidler  <address@hidden>  (tiny change)
 
        * emacs-lisp/package.el (package-untar-buffer): Handle problematic

=== modified file 'lisp/emacs-lisp/package.el'
--- a/lisp/emacs-lisp/package.el        2012-12-29 10:26:14 +0000
+++ b/lisp/emacs-lisp/package.el        2012-12-29 11:06:10 +0000
@@ -596,6 +596,8 @@
 
 (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 @@
   (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)