diff options
| -rw-r--r-- | lisp/ChangeLog | 46 | ||||
| -rw-r--r-- | lisp/emacs-lisp/package-x.el | 5 | ||||
| -rw-r--r-- | lisp/emacs-lisp/package.el | 302 | ||||
| -rw-r--r-- | lisp/tar-mode.el | 193 |
4 files changed, 284 insertions, 262 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e4c67dde1d9..39013982477 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,7 +1,45 @@ +2013-06-21 Stefan Monnier <monnier@iro.umontreal.ca> + Daniel Hackney <dan@haxney.org> + + * emacs-lisp/package.el: Use tar-mode rather than tar executable. + Consolidate the single-file vs tarball code. + (package-desc-suffix): New function. + (package-desc-full-name): Don't bother inlining it. + (package-load-descriptor): Return the new package-desc. + (package-mark-obsolete): Remove unused arg `package'. + (package-unpack): Make it work for single files as well. + Make it update package-alist. + (package--make-autoloads-and-stuff): Rename from + package--make-autoloads-and-compile. Don't compile any more. + (package--compile): New function. + (package-generate-description-file): New function, extracted from + package-unpack-single. + (package-unpack-single): Remove. + (package--with-work-buffer): Add indentation and debugging info. + (package-download-single): Remove. + (package-install-from-archive): Rename from package-download-tar, make + it take a pkg-desc, and make it work for single files as well. + (package-download-transaction): Simplify. + (package-tar-file-info): Remove `file' arg. Rewrite not to use an + external tar program. + (package-install-from-buffer): Remove `pkg-desc' argument. + Use package-tar-file-info for tar-mode buffers. + (package-install-file): Simplify accordingly. + (package-archive-base): Change to take a pkg-desc. + * tar-mode.el (tar--check-descriptor): New function, extracted from + tar-get-descriptor. + (tar-get-descriptor): Use it. + (tar-get-file-descriptor): New function. + (tar--extract): New function, extracted from tar-extract. + (tar--extract): Use it. + * emacs-lisp/package-x.el (package-upload-file): Decode the file, in + case the summary uses non-ascii. Adjust to new calling convention of + package-tar-file-info. + 2013-06-21 Leo Liu <sdl.web@gmail.com> - * comint.el (comint-redirect-results-list-from-process): Fix - random delay. (Bug#14681) + * comint.el (comint-redirect-results-list-from-process): + Fix random delay. (Bug#14681) 2013-06-21 Juanma Barranquero <lekktu@gmail.com> @@ -135,8 +173,8 @@ 2013-06-19 Michael Albinus <michael.albinus@gmx.de> * net/secrets.el (secrets-struct-secret-content-type): Replace - check of introspection data by a test call of "CreateItem". Some - servers do not offer introspection. + check of introspection data by a test call of "CreateItem". + Some servers do not offer introspection. 2013-06-19 Stefan Monnier <monnier@iro.umontreal.ca> diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index 3300e89ec1e..7d0d75f7cee 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -291,10 +291,11 @@ If `package-archive-upload-base' does not specify a valid upload destination, prompt for one." (interactive "fPackage file name: ") (with-temp-buffer - (insert-file-contents-literally file) + (insert-file-contents file) (let ((pkg-desc (cond - ((string-match "\\.tar\\'" file) (package-tar-file-info file)) + ((string-match "\\.tar\\'" file) + (tar-mode) (package-tar-file-info)) ((string-match "\\.el\\'" file) (package-buffer-info)) (t (error "Unrecognized extension `%s'" (file-name-extension file)))))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ae4ebb87ee2..1bf1e6027e2 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -340,11 +340,17 @@ package came. dir) ;; Pseudo fields. -(defsubst package-desc-full-name (pkg-desc) +(defun package-desc-full-name (pkg-desc) (format "%s-%s" (package-desc-name pkg-desc) (package-version-join (package-desc-version pkg-desc)))) +(defun package-desc-suffix (pkg-desc) + (pcase (package-desc-kind pkg-desc) + (`single ".el") + (`tar ".tar") + (kind (error "Unknown package kind: %s" kind)))) + ;; Package descriptor format used in finder-inf.el and package--builtins. (cl-defstruct (package--bi-desc (:constructor package-make-builtin (version summary)) @@ -422,7 +428,8 @@ This is, approximately, the inverse of `version-to-list'. (goto-char (point-min)) (let ((pkg-desc (package-process-define-package (read (current-buffer)) pkg-file))) - (setf (package-desc-dir pkg-desc) pkg-dir)))))) + (setf (package-desc-dir pkg-desc) pkg-dir) + pkg-desc))))) (defun package-load-all-descriptors () "Load descriptors for installed Emacs Lisp packages. @@ -529,13 +536,13 @@ Required package `%s-%s' is unavailable" ;; If all goes well, activate the package itself. (package-activate-1 pkg-vec))))))) -(defun package-mark-obsolete (package pkg-vec) - "Put package on the obsolete list, if not already there." - (push pkg-vec package-obsolete-list)) +(defun package-mark-obsolete (pkg-desc) + "Put PKG-DESC on the obsolete list, if not already there." + (push pkg-desc package-obsolete-list)) -(defun define-package (name-string version-string - &optional docstring requirements - &rest _extra-properties) +(defun define-package (_name-string _version-string + &optional _docstring _requirements + &rest _extra-properties) "Define a new package. NAME-STRING is the name of the package, as a string. VERSION-STRING is the version of the package, as a string. @@ -559,13 +566,13 @@ EXTRA-PROPERTIES is currently unused." ;; If it's not newer than a builtin version, mark it obsolete. ((let ((bi (assq name package--builtin-versions))) (and bi (version-list-<= version (cdr bi)))) - (package-mark-obsolete name new-pkg-desc)) + (package-mark-obsolete new-pkg-desc)) ;; If there's no old package, just add this to `package-alist'. ((null old-pkg) (push (cons name new-pkg-desc) package-alist)) ((version-list-< (package-desc-version (cdr old-pkg)) version) ;; Remove the old package and declare it obsolete. - (package-mark-obsolete name (cdr old-pkg)) + (package-mark-obsolete (cdr old-pkg)) (setq package-alist (cons (cons name new-pkg-desc) (delq old-pkg package-alist)))) ;; You can have two packages with the same version, e.g. one in @@ -573,10 +580,10 @@ EXTRA-PROPERTIES is currently unused." ;; directory. We just let the first one win. ((not (version-list-= (package-desc-version (cdr old-pkg)) version)) ;; The package is born obsolete. - (package-mark-obsolete name new-pkg-desc))) + (package-mark-obsolete new-pkg-desc))) new-pkg-desc)) -;; From Emacs 22. +;; From Emacs 22, but changed so it adds to load-path. (defun package-autoload-ensure-default-file (file) "Make sure that the autoload file FILE exists and if not create it." (unless (file-exists-p file) @@ -632,74 +639,79 @@ untar into a directory named DIR; otherwise, signal an error." (error "Package does not untar cleanly into directory %s/" dir))))) (tar-untar-buffer)) -(defun package-unpack (package version) - (let* ((name (symbol-name package)) - (dirname (concat name "-" version)) +(defun package-generate-description-file (pkg-desc pkg-dir) + "Create the foo-pkg.el file for single-file packages." + (let* ((name (package-desc-name pkg-desc)) + (pkg-file (expand-file-name (package--description-file pkg-dir) + pkg-dir))) + (let ((print-level nil) + (print-quoted t) + (print-length nil)) + (write-region + (concat + (prin1-to-string + (list 'define-package + (symbol-name name) + (package-version-join (package-desc-version pkg-desc)) + (package-desc-summary pkg-desc) + (let ((requires (package-desc-reqs pkg-desc))) + (list 'quote + ;; Turn version lists into string form. + (mapcar + (lambda (elt) + (list (car elt) + (package-version-join (cadr elt)))) + requires))))) + "\n") + nil + pkg-file)))) + +(defun package-unpack (pkg-desc) + "Install the contents of the current buffer as a package." + (let* ((name (package-desc-name pkg-desc)) + (dirname (package-desc-full-name pkg-desc)) (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 dirname) - (package--make-autoloads-and-compile package pkg-dir) - pkg-dir))) - -(defun package--make-autoloads-and-compile (name pkg-dir) - "Generate autoloads and do byte-compilation for package named NAME. -PKG-DIR is the name of the package directory." - (let ((auto-name (package-generate-autoloads name pkg-dir)) - (load-path (cons pkg-dir load-path))) - ;; We must load the autoloads file before byte compiling, in - ;; case there are magic cookies to set up non-trivial paths. - (load auto-name nil t) - ;; FIXME: Compilation should be done as a separate, optional, step. - ;; E.g. for multi-package installs, we should first install all packages - ;; and then compile them. - (byte-recompile-directory pkg-dir 0 t))) + (pcase (package-desc-kind pkg-desc) + (`tar + (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 dirname))) + (`single + (let ((el-file (expand-file-name (format "%s.el" name) pkg-dir))) + (make-directory pkg-dir t) + (package--write-file-no-coding el-file))) + (kind (error "Unknown package kind: %S" kind))) + (package--make-autoloads-and-stuff pkg-desc pkg-dir) + ;; Update package-alist. + (let ((new-desc (package-load-descriptor pkg-dir))) + ;; FIXME: Check that `new-desc' matches `desc'! + ;; FIXME: Compilation should be done as a separate, optional, step. + ;; E.g. for multi-package installs, we should first install all packages + ;; and then compile them. + (package--compile new-desc)) + ;; Try to activate it. + (package-activate name (package-desc-version pkg-desc)) + pkg-dir)) + +(defun package--make-autoloads-and-stuff (pkg-desc pkg-dir) + "Generate autoloads, description file, etc.. for PKG-DESC installed at PKG-DIR." + (package-generate-autoloads (package-desc-name pkg-desc) pkg-dir) + (let ((desc-file (package--description-file pkg-dir))) + (unless (file-exists-p desc-file) + (package-generate-description-file pkg-desc pkg-dir))) + ;; FIXME: Create foo.info and dir file from foo.texi? + ) + +(defun package--compile (pkg-desc) + "Byte-compile installed package PKG-DESC." + (package-activate-1 pkg-desc) + (byte-recompile-directory (package-desc-dir pkg-desc) 0 t)) (defun package--write-file-no-coding (file-name) (let ((buffer-file-coding-system 'no-conversion)) (write-region (point-min) (point-max) file-name))) -(defun package-unpack-single (name version desc requires) - "Install the contents of the current buffer as a package." - ;; Special case "package". FIXME: Should this still be supported? - (if (eq name 'package) - (package--write-file-no-coding - (expand-file-name (format "%s.el" name) package-user-dir)) - (let* ((pkg-dir (expand-file-name (format "%s-%s" name - (package-version-join - (version-to-list version))) - package-user-dir)) - (el-file (expand-file-name (format "%s.el" name) pkg-dir)) - (pkg-file (expand-file-name (package--description-file pkg-dir) - pkg-dir))) - (make-directory pkg-dir t) - (package--write-file-no-coding el-file) - (let ((print-level nil) - (print-quoted t) - (print-length nil)) - (write-region - (concat - (prin1-to-string - (list 'define-package - (symbol-name name) - version - desc - (when requires ;Don't bother quoting nil. - (list 'quote - ;; Turn version lists into string form. - (mapcar - (lambda (elt) - (list (car elt) - (package-version-join (cadr elt)))) - requires))))) - "\n") - nil - pkg-file - nil nil nil 'excl)) - (package--make-autoloads-and-compile name pkg-dir) - pkg-dir))) - (defmacro package--with-work-buffer (location file &rest body) "Run BODY in a buffer containing the contents of FILE at LOCATION. LOCATION is the base location of a package archive, and should be @@ -709,6 +721,7 @@ FILE is the name of a file relative to that base location. This macro retrieves FILE from LOCATION into a temporary buffer, and evaluates BODY while that buffer is current. This work buffer is killed afterwards. Return the last value in BODY." + (declare (indent 2) (debug t)) `(let* ((http (string-match "\\`https?:" ,location)) (buffer (if http @@ -741,19 +754,13 @@ It will move point to somewhere in the headers." (error "Error during download request:%s" (buffer-substring-no-properties (point) (line-end-position)))))) -(defun package-download-single (name version desc requires) - "Download and install a single-file package." - (let ((location (package-archive-base name)) - (file (concat (symbol-name name) "-" version ".el"))) - (package--with-work-buffer location file - (package-unpack-single name version desc requires)))) - -(defun package-download-tar (name version) +(defun package-install-from-archive (pkg-desc) "Download and install a tar package." - (let ((location (package-archive-base name)) - (file (concat (symbol-name name) "-" version ".tar"))) + (let ((location (package-archive-base pkg-desc)) + (file (concat (package-desc-full-name pkg-desc) + (package-desc-suffix pkg-desc)))) (package--with-work-buffer location file - (package-unpack name version)))) + (package-unpack pkg-desc)))) (defvar package--initialized nil) @@ -918,30 +925,8 @@ PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed using `package-compute-transaction'." ;; FIXME: make package-list a list of pkg-desc. (dolist (elt package-list) - (let* ((desc (cdr (assq elt package-archive-contents))) - ;; As an exception, if package is "held" in - ;; `package-load-list', download the held version. - (hold (cadr (assq elt package-load-list))) - (v-string (or (and (stringp hold) hold) - (package-version-join (package-desc-version desc)))) - (kind (package-desc-kind desc)) - (pkg-dir - (cond - ((eq kind 'tar) - (package-download-tar elt v-string)) - ((eq kind 'single) - (package-download-single elt v-string - (package-desc-summary desc) - (package-desc-reqs desc))) - (t - (error "Unknown package kind: %s" (symbol-name kind)))))) - ;; Update package-alist. - ;; FIXME: Check that the installed package's descriptor matches `desc'! - (package-load-descriptor pkg-dir) - ;; If package A depends on package B, then A may `require' B - ;; during byte compilation. So we need to activate B before - ;; unpacking A. - (package-activate elt (version-to-list v-string))))) + (let ((desc (cdr (assq elt package-archive-contents)))) + (package-install-from-archive desc)))) ;;;###autoload (defun package-install (pkg-desc) @@ -1018,60 +1003,48 @@ boundaries." (if requires-str (package-read-from-string requires-str)) :kind 'single)))) -(defun package-tar-file-info (file) +(defun package-tar-file-info () "Find package information for a tar file. -FILE is the name of the tar file to examine. -The return result is a vector like `package-buffer-info'." - (let* ((default-directory (file-name-directory file)) - (file (file-name-nondirectory file)) - (dir-name - (if (string-match "\\.tar\\'" file) - (substring file 0 (match-beginning 0)) - (error "Invalid package name `%s'" file))) +The return result is a `package-desc'." + (cl-assert (derived-mode-p 'tar-mode)) + (let* ((dir-name (file-name-directory + (tar-header-name (car tar-parse-info)))) (desc-file (package--description-file dir-name)) - ;; Extract the package descriptor. - (pkg-def-contents (shell-command-to-string - ;; Requires GNU tar. - (concat "tar -xOf " file " " - dir-name "/" desc-file))) - (pkg-def-parsed (package-read-from-string pkg-def-contents))) - (unless (eq (car pkg-def-parsed) 'define-package) - (error "Can't find define-package in %s" desc-file)) - (let ((pkg-desc - (apply #'package-desc-from-define (append (cdr pkg-def-parsed) - '(:kind tar))))) - (unless (equal dir-name (package-desc-full-name pkg-desc)) - ;; FIXME: Shouldn't this just be a message/warning? - (error "Package has inconsistent name")) - pkg-desc))) + (tar-desc (tar-get-file-descriptor (concat dir-name desc-file)))) + (unless tar-desc + (error "No package descriptor file found")) + (with-current-buffer (tar--extract tar-desc) + (goto-char (point-min)) + (unwind-protect + (let* ((pkg-def-parsed (read (current-buffer))) + (pkg-desc + (if (not (eq (car pkg-def-parsed) 'define-package)) + (error "Can't find define-package in %s" + (tar-header-name tar-desc)) + (apply #'package-desc-from-define + (append (cdr pkg-def-parsed)))))) + (setf (package-desc-kind pkg-desc) 'tar) + pkg-desc) + (kill-buffer (current-buffer)))))) ;;;###autoload -(defun package-install-from-buffer (pkg-desc) +(defun package-install-from-buffer () "Install a package from the current buffer. -When called interactively, the current buffer is assumed to be a -single .el file that follows the packaging guidelines; see info -node `(elisp)Packaging'. - -When called from Lisp, PKG-DESC is a `package-desc' describing the -information)." - (interactive (list (package-buffer-info))) - (save-excursion - (save-restriction - (let* ((name (package-desc-name pkg-desc)) - (requires (package-desc-reqs pkg-desc)) - (desc (package-desc-summary pkg-desc)) - (pkg-version (package-desc-version pkg-desc))) - ;; Download and install the dependencies. - (let ((transaction (package-compute-transaction nil requires))) - (package-download-transaction transaction)) - ;; Install the package itself. - (pcase (package-desc-kind pkg-desc) - (`single (package-unpack-single name pkg-version desc requires)) - (`tar (package-unpack name pkg-version)) - (type (error "Unknown type: %S" type))) - ;; Try to activate it. - (package-initialize))))) +The current buffer is assumed to be a single .el or .tar file that follows the +packaging guidelines; see info node `(elisp)Packaging'. +Downloads and installs required packages as needed." + (interactive) + (let ((pkg-desc (if (derived-mode-p 'tar-mode) + (package-tar-file-info) + (package-buffer-info)))) + ;; Download and install the dependencies. + (let* ((requires (package-desc-reqs pkg-desc)) + (transaction (package-compute-transaction nil requires))) + (package-download-transaction transaction)) + ;; Install the package itself. + (package-unpack pkg-desc) + pkg-desc)) ;;;###autoload (defun package-install-file (file) @@ -1080,12 +1053,8 @@ The file can either be a tar file or an Emacs Lisp file." (interactive "fPackage file name: ") (with-temp-buffer (insert-file-contents-literally file) - (cond - ((string-match "\\.el\\'" file) - (package-install-from-buffer (package-buffer-info))) - ((string-match "\\.tar\\'" file) - (package-install-from-buffer (package-tar-file-info file))) - (t (error "Unrecognized extension `%s'" (file-name-extension file)))))) + (when (string-match "\\.tar\\'" file) (tar-mode)) + (package-install-from-buffer))) (defun package-delete (pkg-desc) (let ((dir (package-desc-dir pkg-desc))) @@ -1099,10 +1068,9 @@ The file can either be a tar file or an Emacs Lisp file." (error "Package `%s' is a system package, not deleting" (package-desc-full-name pkg-desc))))) -(defun package-archive-base (name) +(defun package-archive-base (desc) "Return the archive containing the package NAME." - (let ((desc (cdr (assq (intern-soft name) package-archive-contents)))) - (cdr (assoc (package-desc-archive desc) package-archives)))) + (cdr (assoc (package-desc-archive desc) package-archives))) (defun package--download-one-archive (archive file) "Retrieve an archive file FILE from ARCHIVE, and cache it. @@ -1292,7 +1260,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." ;; For elpa packages, try downloading the commentary. If that ;; fails, try an existing readme file in `package-user-dir'. (cond ((condition-case nil - (package--with-work-buffer (package-archive-base package) + (package--with-work-buffer (package-archive-base desc) (concat package-name "-readme.txt") (setq buffer-file-name (expand-file-name readme package-user-dir)) diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 109107e857f..be7bdb25d26 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -740,10 +740,8 @@ tar-file's buffer." nil (error "This line does not describe a tar-file entry")))) -(defun tar-get-descriptor () - (let* ((descriptor (tar-current-descriptor)) - (size (tar-header-size descriptor)) - (link-p (tar-header-link-type descriptor))) +(defun tar--check-descriptor (descriptor) + (let ((link-p (tar-header-link-type descriptor))) (if link-p (error "This is %s, not a real file" (cond ((eq link-p 5) "a directory") @@ -754,10 +752,24 @@ tar-file's buffer." ((eq link-p 38) "a volume header") ((eq link-p 55) "a pax global extended header") ((eq link-p 72) "a pax extended header") - (t "a link")))) + (t "a link")))))) + +(defun tar-get-descriptor () + (let* ((descriptor (tar-current-descriptor)) + (size (tar-header-size descriptor))) + (tar--check-descriptor descriptor) (if (zerop size) (message "This is a zero-length file")) descriptor)) +(defun tar-get-file-descriptor (file) + ;; Used by package.el. + (let ((desc ())) + (dolist (hdr tar-parse-info) + (when (equal file (tar-header-name hdr)) + (setq desc hdr))) + (tar--check-descriptor desc) + desc)) + (defun tar-mouse-extract (event) "Extract a file whose tar directory line you click on." (interactive "e") @@ -776,96 +788,99 @@ tar-file's buffer." (let ((file-name-handler-alist nil)) (apply op args)))) +(defun tar--extract (descriptor) + "Extract this entry of the tar file into its own buffer." + (let* ((name (tar-header-name descriptor)) + (size (tar-header-size descriptor)) + (start (tar-header-data-start descriptor)) + (end (+ start size)) + (tarname (buffer-name)) + (bufname (concat (file-name-nondirectory name) + " (" + tarname + ")")) + (buffer (generate-new-buffer bufname))) + (with-current-buffer buffer + (setq buffer-undo-list t)) + (with-current-buffer tar-data-buffer + (let (coding) + (narrow-to-region start end) + (goto-char start) + (setq coding (or coding-system-for-read + (and set-auto-coding-function + (funcall set-auto-coding-function + name (- end start))) + ;; The following binding causes + ;; find-buffer-file-type-coding-system + ;; (defined on dos-w32.el) to act as if + ;; the file being extracted existed, so + ;; that the file's contents' encoding and + ;; EOL format are auto-detected. + (let ((file-name-handler-alist + '(("" . tar-file-name-handler)))) + (car (find-operation-coding-system + 'insert-file-contents + (cons name (current-buffer)) t))))) + (if (or (not coding) + (eq (coding-system-type coding) 'undecided)) + (setq coding (detect-coding-region start end t))) + (if (and (default-value 'enable-multibyte-characters) + (coding-system-get coding :for-unibyte)) + (with-current-buffer buffer + (set-buffer-multibyte nil))) + (widen) + (decode-coding-region start end coding buffer))) + buffer)) + (defun tar-extract (&optional other-window-p) "In Tar mode, extract this entry of the tar file into its own buffer." (interactive) (let* ((view-p (eq other-window-p 'view)) (descriptor (tar-get-descriptor)) (name (tar-header-name descriptor)) - (size (tar-header-size descriptor)) - (start (tar-header-data-start descriptor)) - (end (+ start size))) - (let* ((tar-buffer (current-buffer)) - (tarname (buffer-name)) - (bufname (concat (file-name-nondirectory name) - " (" - tarname - ")")) - (read-only-p (or buffer-read-only view-p)) - (new-buffer-file-name (expand-file-name - ;; `:' is not allowed on Windows - (concat tarname "!" - (if (string-match "/" name) - name - ;; Make sure `name' contains a / - ;; so set-auto-mode doesn't try - ;; to look at `tarname' for hints. - (concat "./" name))))) - (buffer (get-file-buffer new-buffer-file-name)) - (just-created nil) - undo-list) - (unless buffer - (setq buffer (generate-new-buffer bufname)) - (with-current-buffer buffer - (setq undo-list buffer-undo-list - buffer-undo-list t)) - (setq bufname (buffer-name buffer)) - (setq just-created t) - (with-current-buffer tar-data-buffer - (let (coding) - (narrow-to-region start end) - (goto-char start) - (setq coding (or coding-system-for-read - (and set-auto-coding-function - (funcall set-auto-coding-function - name (- end start))) - ;; The following binding causes - ;; find-buffer-file-type-coding-system - ;; (defined on dos-w32.el) to act as if - ;; the file being extracted existed, so - ;; that the file's contents' encoding and - ;; EOL format are auto-detected. - (let ((file-name-handler-alist - '(("" . tar-file-name-handler)))) - (car (find-operation-coding-system - 'insert-file-contents - (cons name (current-buffer)) t))))) - (if (or (not coding) - (eq (coding-system-type coding) 'undecided)) - (setq coding (detect-coding-region start end t))) - (if (and (default-value 'enable-multibyte-characters) - (coding-system-get coding :for-unibyte)) - (with-current-buffer buffer - (set-buffer-multibyte nil))) - (widen) - (decode-coding-region start end coding buffer))) - (with-current-buffer buffer - (goto-char (point-min)) - (setq buffer-file-name new-buffer-file-name) - (setq buffer-file-truename - (abbreviate-file-name buffer-file-name)) - ;; Force buffer-file-coding-system to what - ;; decode-coding-region actually used. - (set-buffer-file-coding-system last-coding-system-used t) - ;; Set the default-directory to the dir of the - ;; superior buffer. - (setq default-directory - (with-current-buffer tar-buffer - default-directory)) - (rename-buffer bufname) - (set-buffer-modified-p nil) - (setq buffer-undo-list undo-list) - (normal-mode) ; pick a mode. - (set (make-local-variable 'tar-superior-buffer) tar-buffer) - (set (make-local-variable 'tar-superior-descriptor) descriptor) - (setq buffer-read-only read-only-p) - (tar-subfile-mode 1))) - (cond - (view-p - (view-buffer buffer (and just-created 'kill-buffer-if-not-modified))) - ((eq other-window-p 'display) (display-buffer buffer)) - (other-window-p (switch-to-buffer-other-window buffer)) - (t (switch-to-buffer buffer)))))) + (tar-buffer (current-buffer)) + (tarname (buffer-name)) + (read-only-p (or buffer-read-only view-p)) + (new-buffer-file-name (expand-file-name + ;; `:' is not allowed on Windows + (concat tarname "!" + (if (string-match "/" name) + name + ;; Make sure `name' contains a / + ;; so set-auto-mode doesn't try + ;; to look at `tarname' for hints. + (concat "./" name))))) + (buffer (get-file-buffer new-buffer-file-name)) + (just-created nil)) + (unless buffer + (setq buffer (tar--extract descriptor)) + (setq just-created t) + (with-current-buffer buffer + (goto-char (point-min)) + (setq buffer-file-name new-buffer-file-name) + (setq buffer-file-truename + (abbreviate-file-name buffer-file-name)) + ;; Force buffer-file-coding-system to what + ;; decode-coding-region actually used. + (set-buffer-file-coding-system last-coding-system-used t) + ;; Set the default-directory to the dir of the + ;; superior buffer. + (setq default-directory + (with-current-buffer tar-buffer + default-directory)) + (set-buffer-modified-p nil) + (setq buffer-undo-list t) + (normal-mode) ; pick a mode. + (set (make-local-variable 'tar-superior-buffer) tar-buffer) + (set (make-local-variable 'tar-superior-descriptor) descriptor) + (setq buffer-read-only read-only-p) + (tar-subfile-mode 1))) + (cond + (view-p + (view-buffer buffer (and just-created 'kill-buffer-if-not-modified))) + ((eq other-window-p 'display) (display-buffer buffer)) + (other-window-p (switch-to-buffer-other-window buffer)) + (t (switch-to-buffer buffer))))) (defun tar-extract-other-window () |