mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-30 04:10:54 -08:00
Code Issues Projects Releases Wiki Activity

* lisp/emacs-lisp/package.el: Use tar-mode rather than tar executable.

Browse source 
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.
* lisp/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.
* lisp/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.
This commit is contained in:
Stefan Monnier 2013-06-20 23:08:47 -04:00
parent d1f7f5a0d9
commit fd846ab406
4 changed files with 284 additions and 262 deletions
Download patch file Download diff file Expand all files Collapse all files

46
lisp/ChangeLog
View file

@ -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>

5
lisp/emacs-lisp/package-x.el
View file

@ -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))))))

302
lisp/emacs-lisp/package.el
View file

@ -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))
(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-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--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)))
(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)))
(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))

193
lisp/tar-mode.el
View file

@ -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 ()