X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/fdc9061358d3654e14bfc1419632e1d6c6c5c13e..cb625535b532afa1017ed5b6ff7ca0b25f1e3b0a:/lisp/tar-mode.el diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 80e642d666..4589127e26 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -1,7 +1,7 @@ ;;; tar-mode.el --- simple editing of tar files from GNU emacs ;; Copyright (C) 1990, 1991, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Jamie Zawinski ;; Maintainer: FSF @@ -129,16 +129,17 @@ This information is useful, but it takes screen space away from file names." :group 'tar) (defvar tar-parse-info nil) -;; Be sure that this variable holds byte position, not char position. (defvar tar-header-offset nil) (defvar tar-superior-buffer nil) (defvar tar-superior-descriptor nil) (defvar tar-subfile-mode nil) +(defvar tar-file-name-coding-system nil) (put 'tar-parse-info 'permanent-local t) (put 'tar-header-offset 'permanent-local t) (put 'tar-superior-buffer 'permanent-local t) (put 'tar-superior-descriptor 'permanent-local t) +(put 'tar-file-name-coding-system 'permanent-local t) (defmacro tar-setf (form val) "A mind-numbingly simple implementation of setf." @@ -197,23 +198,26 @@ This information is useful, but it takes screen space away from file names." (defconst tar-gname-offset (+ tar-uname-offset 32)) (defconst tar-dmaj-offset (+ tar-gname-offset 32)) (defconst tar-dmin-offset (+ tar-dmaj-offset 8)) -(defconst tar-end-offset (+ tar-dmin-offset 8)) +(defconst tar-prefix-offset (+ tar-dmin-offset 8)) +(defconst tar-end-offset (+ tar-prefix-offset 155)) (defun tar-header-block-tokenize (string) "Return a `tar-header' structure. This is a list of name, mode, uid, gid, size, write-date, checksum, link-type, and link-name." + (setq string (string-as-unibyte string)) (cond ((< (length string) 512) nil) (;(some 'plusp string) ; <-- oops, massive cycle hog! (or (not (= 0 (aref string 0))) ; This will do. (not (= 0 (aref string 101)))) - (let* ((name-end (1- tar-mode-offset)) + (let* ((name-end tar-mode-offset) (link-end (1- tar-magic-offset)) (uname-end (1- tar-gname-offset)) (gname-end (1- tar-dmaj-offset)) (link-p (aref string tar-linkp-offset)) (magic-str (substring string tar-magic-offset (1- tar-uname-offset))) - (uname-valid-p (or (string= "ustar " magic-str) (string= "GNUtar " magic-str))) + (uname-valid-p (or (string= "ustar " magic-str) (string= "GNUtar " magic-str) + (string= "ustar\0000" magic-str))) name linkname (nulsexp "[^\000]*\000")) (when (string-match nulsexp string tar-name-offset) @@ -229,17 +233,18 @@ write-date, checksum, link-type, and link-name." nil (- link-p ?0))) (setq linkname (substring string tar-link-offset link-end)) + (when (and uname-valid-p + (string-match nulsexp string tar-prefix-offset) + (> (match-end 0) (1+ tar-prefix-offset))) + (setq name (concat (substring string tar-prefix-offset + (1- (match-end 0))) + "/" name))) (if default-enable-multibyte-characters (setq name - (decode-coding-string name - (or file-name-coding-system - default-file-name-coding-system - 'undecided)) + (decode-coding-string name tar-file-name-coding-system) linkname (decode-coding-string linkname - (or file-name-coding-system - default-file-name-coding-system - 'undecided)))) + tar-file-name-coding-system))) (if (and (null link-p) (string-match "/\\'" name)) (setq link-p 5)) ; directory (make-tar-header name @@ -255,7 +260,7 @@ write-date, checksum, link-type, and link-name." (and uname-valid-p (substring string tar-uname-offset uname-end)) (and uname-valid-p (substring string tar-gname-offset gname-end)) (tar-parse-octal-integer string tar-dmaj-offset tar-dmin-offset) - (tar-parse-octal-integer string tar-dmin-offset tar-end-offset) + (tar-parse-octal-integer string tar-dmin-offset tar-prefix-offset) ))) (t 'empty-tar-block))) @@ -298,6 +303,7 @@ write-date, checksum, link-type, and link-name." (defun tar-header-block-checksum (string) "Compute and return a tar-acceptable checksum for this block." + (setq string (string-as-unibyte string)) (let* ((chk-field-start tar-chk-offset) (chk-field-end (+ chk-field-start 8)) (sum 0) @@ -389,7 +395,9 @@ MODE should be an integer which is a file mode value." (dolist (descriptor tar-parse-info) (let* ((tokens (tar-desc-tokens descriptor)) (name (tar-header-name tokens)) - (dir (file-name-directory name)) + (dir (if (eq (tar-header-link-type tokens) 5) + name + (file-name-directory name))) (start (+ (tar-desc-data-start descriptor) (- tar-header-offset (point-min)))) (end (+ start (tar-header-size tokens)))) @@ -400,7 +408,8 @@ MODE should be an integer which is a file mode value." (unless (file-directory-p name) (write-region start end name)) (set-file-modes name (tar-header-mode tokens)))))) - (set-buffer-multibyte multibyte)))) + (if multibyte + (set-buffer-multibyte 'to))))) (defun tar-summarize-buffer () "Parse the contents of the tar file in the current buffer. @@ -429,11 +438,11 @@ is visible (and the real data of the buffer is hidden)." (if (< size 0) (error "%s has size %s - corrupted" (tar-header-name tokens) size)) - ; - ; This is just too slow. Don't really need it anyway.... - ;(tar-header-block-check-checksum - ; hblock (tar-header-block-checksum hblock) - ; (tar-header-name tokens)) + ;; + ;; This is just too slow. Don't really need it anyway.... + ;;(tar-header-block-check-checksum + ;; hblock (tar-header-block-checksum hblock) + ;; (tar-header-name tokens)) (push (make-tar-desc pos tokens) result) @@ -441,7 +450,7 @@ is visible (and the real data of the buffer is hidden)." (> size 0) (setq pos (+ pos 512 (ash (ash (1- size) -9) 9)) ; this works - ;(+ pos (+ size (- 512 (rem (1- size) 512)))) ; this doesn't + ;;(+ pos (+ size (- 512 (rem (1- size) 512)))) ; this doesn't )))) (make-local-variable 'tar-parse-info) (setq tar-parse-info (nreverse result)) @@ -450,22 +459,24 @@ is visible (and the real data of the buffer is hidden)." (if (eq tokens 'empty-tar-block) (progress-reporter-done progress-reporter) (message "Warning: premature EOF parsing tar file"))) - (set-buffer-multibyte default-enable-multibyte-characters) + ;; Obey the user's preference for the use of uni/multibytes. + (if default-enable-multibyte-characters + (set-buffer-multibyte 'to)) (goto-char (point-min)) - (let ((inhibit-read-only t)) - ;; Collect summary lines and insert them all at once since tar files - ;; can be pretty big. - (let ((total-summaries - (mapconcat - (lambda (tar-desc) - (tar-header-block-summarize (tar-desc-tokens tar-desc))) - tar-parse-info - "\n"))) - (insert total-summaries "\n")) - (narrow-to-region (point-min) (point)) - (set (make-local-variable 'tar-header-offset) (position-bytes (point))) - (goto-char (point-min)) - (restore-buffer-modified-p modified)))) + (let ((inhibit-read-only t) + ;; Collect summary lines and insert them all at once since tar files + ;; can be pretty big. + (total-summaries + (mapconcat + (lambda (tar-desc) + (tar-header-block-summarize (tar-desc-tokens tar-desc))) + tar-parse-info + "\n"))) + (insert total-summaries "\n")) + (narrow-to-region (point-min) (point)) + (set (make-local-variable 'tar-header-offset) (position-bytes (point))) + (goto-char (point-min)) + (restore-buffer-modified-p modified))) (defvar tar-mode-map (let ((map (make-keymap))) @@ -497,6 +508,8 @@ is visible (and the real data of the buffer is hidden)." (define-key map "M" 'tar-chmod-entry) (define-key map "G" 'tar-chgrp-entry) (define-key map "O" 'tar-chown-entry) + ;; Let mouse-1 follow the link. + (define-key map [follow-link] 'mouse-face) ;; Make menu bar items. @@ -540,7 +553,7 @@ is visible (and the real data of the buffer is hidden)." '("Copy to..." . tar-copy)) (define-key map [menu-bar operate expunge] '("Expunge Marked Files" . tar-expunge)) - + map) "Local keymap for Tar mode listings.") @@ -575,6 +588,10 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'. (set (make-local-variable 'revert-buffer-function) 'tar-mode-revert) (set (make-local-variable 'local-enable-local-variables) nil) (set (make-local-variable 'next-line-add-newlines) nil) + (set (make-local-variable 'tar-file-name-coding-system) + (or file-name-coding-system + default-file-name-coding-system + locale-coding-system)) ;; Prevent loss of data when saving the file. (set (make-local-variable 'file-precious-flag) t) (auto-save-mode 0) @@ -582,7 +599,7 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'. (buffer-disable-undo) (widen) (if (and (boundp 'tar-header-offset) tar-header-offset) - (narrow-to-region (point-min) (byte-to-position tar-header-offset)) + (narrow-to-region (point-min) tar-header-offset) (tar-summarize-buffer) (tar-next-line 0))) @@ -673,8 +690,7 @@ appear on disk when you save the tar-file's buffer." (defun tar-mouse-extract (event) "Extract a file whose tar directory line you click on." (interactive "e") - (save-excursion - (set-buffer (window-buffer (posn-window (event-end event)))) + (with-current-buffer (window-buffer (posn-window (event-end event))) (save-excursion (goto-char (posn-point (event-end event))) ;; Just make sure this doesn't get an error. @@ -701,7 +717,6 @@ appear on disk when you save the tar-file's buffer." (- tar-header-offset (point-min)))) (end (+ start size))) (let* ((tar-buffer (current-buffer)) - (tar-buffer-multibyte enable-multibyte-characters) (tarname (buffer-name)) (bufname (concat (file-name-nondirectory name) " (" @@ -712,91 +727,73 @@ appear on disk when you save the tar-file's buffer." ;; `:' is not allowed on Windows (concat tarname "!" name))) (buffer (get-file-buffer new-buffer-file-name)) - (just-created nil)) + (just-created nil) + (pos (point)) + 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) (unwind-protect - (progn - (widen) - (set-buffer-multibyte nil) - (save-excursion - (set-buffer buffer) - (let ((buffer-undo-list t)) - (if enable-multibyte-characters - (progn - ;; We must avoid unibyte->multibyte conversion. - (set-buffer-multibyte nil) - (insert-buffer-substring tar-buffer start end) - (set-buffer-multibyte t)) - (insert-buffer-substring tar-buffer start end)) - (goto-char (point-min)) - (setq buffer-file-name new-buffer-file-name) - (setq buffer-file-truename - (abbreviate-file-name buffer-file-name)) - ;; We need to mimic the parts of insert-file-contents - ;; which determine the coding-system and decode the text. - (let ((coding - (or coding-system-for-read - (and set-auto-coding-function - (save-excursion + (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 (- (point-max) (point))))) - ;; 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))))) - (multibyte enable-multibyte-characters) - (detected (detect-coding-region - (point-min) - (min (+ (point-min) 16384) (point-max)) t))) - (if coding - (or (numberp (coding-system-eol-type coding)) - (vectorp (coding-system-eol-type detected)) - (setq coding (coding-system-change-eol-conversion - coding - (coding-system-eol-type detected)))) - (setq coding - (find-new-buffer-file-coding-system detected))) - (if (or (eq coding 'no-conversion) - (eq (coding-system-type coding) 5)) - (setq multibyte (set-buffer-multibyte nil))) - (or multibyte - (setq coding - (coding-system-change-text-conversion - coding 'raw-text))) - (decode-coding-region (point-min) (point-max) coding) - ;; 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 - (save-excursion - (set-buffer tar-buffer) - default-directory)) - (normal-mode) ; pick a mode. - (rename-buffer bufname) - (make-local-variable 'tar-superior-buffer) - (make-local-variable 'tar-superior-descriptor) - (setq tar-superior-buffer tar-buffer) - (setq tar-superior-descriptor descriptor) - (setq buffer-read-only read-only-p) - (set-buffer-modified-p nil)) + 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-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)) + (normal-mode) ; pick a mode. + (rename-buffer bufname) + (make-local-variable 'tar-superior-buffer) + (make-local-variable 'tar-superior-descriptor) + (setq tar-superior-buffer tar-buffer) + (setq tar-superior-descriptor descriptor) + (setq buffer-read-only read-only-p) + (set-buffer-modified-p nil) + (setq buffer-undo-list undo-list) (tar-subfile-mode 1)) (set-buffer tar-buffer)) (narrow-to-region (point-min) tar-header-offset) - (set-buffer-multibyte tar-buffer-multibyte))) + (goto-char pos))) (if view-p - (view-buffer buffer (and just-created 'kill-buffer)) + (view-buffer + buffer (and just-created 'kill-buffer-if-not-modified)) (if (eq other-window-p 'display) (display-buffer buffer) (if other-window-p @@ -852,7 +849,6 @@ the current tar-entry." (start (+ (tar-desc-data-start descriptor) (- tar-header-offset (point-min)))) (end (+ start size)) - (multibyte enable-multibyte-characters) (inhibit-file-name-handlers inhibit-file-name-handlers) (inhibit-file-name-operation inhibit-file-name-operation)) (save-restriction @@ -866,11 +862,8 @@ the current tar-entry." (and (eq inhibit-file-name-operation 'write-region) inhibit-file-name-handlers)) inhibit-file-name-operation 'write-region)) - (unwind-protect - (let ((coding-system-for-write 'no-conversion)) - (set-buffer-multibyte nil) - (write-region start end to-file nil nil nil t)) - (set-buffer-multibyte multibyte))) + (let ((coding-system-for-write 'no-conversion)) + (write-region start end to-file nil nil nil t))) (message "Copied tar entry %s to %s" name to-file))) (defun tar-flag-deleted (p &optional unflag) @@ -899,7 +892,6 @@ With a prefix argument, un-mark that many files backward." (tar-flag-deleted (- p) t)) -;; When this function is called, it is sure that the buffer is unibyte. (defun tar-expunge-internal () "Expunge the tar-entry specified by the current line." (let* ((descriptor (tar-current-descriptor)) @@ -949,11 +941,8 @@ for this to be permanent." (interactive) (if (or noconfirm (y-or-n-p "Expunge files marked for deletion? ")) - (let ((n 0) - (multibyte enable-multibyte-characters)) + (let ((n 0)) (save-excursion - (widen) - (set-buffer-multibyte nil) (goto-char (point-min)) (while (not (eobp)) (if (looking-at "D") @@ -962,8 +951,6 @@ for this to be permanent." (forward-line 1))) ;; after doing the deletions, add any padding that may be necessary. (tar-pad-to-blocksize) - (widen) - (set-buffer-multibyte multibyte) (narrow-to-region (point-min) tar-header-offset)) (if (zerop n) (message "Nothing to expunge.") @@ -975,7 +962,7 @@ for this to be permanent." (interactive) (save-excursion (goto-char (point-min)) - (while (< (position-bytes (point)) tar-header-offset) + (while (< (point) tar-header-offset) (if (not (eq (following-char) ?\s)) (progn (delete-char 1) (insert " "))) (forward-line 1)))) @@ -1045,15 +1032,13 @@ for this to be permanent." (list (read-string "New name: " (tar-header-name (tar-desc-tokens (tar-current-descriptor)))))) (if (string= "" new-name) (error "zero length name")) - (if (> (length new-name) 98) (error "name too long")) - (tar-setf (tar-header-name (tar-desc-tokens (tar-current-descriptor))) - new-name) - (if (multibyte-string-p new-name) - (setq new-name (encode-coding-string new-name - (or file-name-coding-system - default-file-name-coding-system)))) - (tar-alter-one-field 0 - (substring (concat new-name (make-string 99 0)) 0 99))) + (let ((encoded-new-name (encode-coding-string new-name + tar-file-name-coding-system))) + (if (> (length encoded-new-name) 98) (error "name too long")) + (tar-setf (tar-header-name (tar-desc-tokens (tar-current-descriptor))) + new-name) + (tar-alter-one-field 0 + (substring (concat encoded-new-name (make-string 99 0)) 0 99)))) (defun tar-chmod-entry (new-mode) @@ -1070,8 +1055,7 @@ for this to be permanent." (defun tar-alter-one-field (data-position new-data-string) (let* ((descriptor (tar-current-descriptor)) - (tokens (tar-desc-tokens descriptor)) - (multibyte enable-multibyte-characters)) + (tokens (tar-desc-tokens descriptor))) (unwind-protect (save-excursion ;; @@ -1081,10 +1065,9 @@ for this to be permanent." (forward-line 1) (delete-region p (point)) (insert (tar-header-block-summarize tokens) "\n") - (setq tar-header-offset (position-bytes (point-max)))) + (setq tar-header-offset (point-max))) (widen) - (set-buffer-multibyte nil) (let* ((start (+ (tar-desc-data-start descriptor) (- tar-header-offset (point-min)) -512))) @@ -1092,7 +1075,13 @@ for this to be permanent." ;; delete the old field and insert a new one. (goto-char (+ start data-position)) (delete-region (point) (+ (point) (length new-data-string))) ; <-- - (insert new-data-string) ; <-- + + ;; As new-data-string is unibyte, just inserting it will + ;; make eight-bit chars to the corresponding multibyte + ;; chars. This avoid that conversion, i.e., eight-bit + ;; chars are converted to multibyte form of eight-bit + ;; chars. + (insert (string-to-multibyte new-data-string)) ;; ;; compute a new checksum and insert it. (let ((chk (tar-header-block-checksum @@ -1110,7 +1099,6 @@ for this to be permanent." chk (tar-header-name tokens)) ))) (narrow-to-region (point-min) tar-header-offset) - (set-buffer-multibyte multibyte) (tar-next-line 0)))) @@ -1135,14 +1123,9 @@ to make your changes permanent." (error "This buffer doesn't have an index into its superior tar file!")) (save-excursion (let ((subfile (current-buffer)) - (subfile-multibyte enable-multibyte-characters) (coding buffer-file-coding-system) (descriptor tar-superior-descriptor) subfile-size) - ;; We must make the current buffer unibyte temporarily to avoid - ;; multibyte->unibyte conversion in `insert-buffer-substring'. - (set-buffer-multibyte nil) - (setq subfile-size (buffer-size)) (set-buffer tar-superior-buffer) (let* ((tokens (tar-desc-tokens descriptor)) (start (tar-desc-data-start descriptor)) @@ -1150,28 +1133,27 @@ to make your changes permanent." (size (tar-header-size tokens)) (size-pad (ash (ash (+ size 511) -9) 9)) (head (memq descriptor tar-parse-info)) - (following-descs (cdr head)) - (tar-buffer-multibyte enable-multibyte-characters)) + (following-descs (cdr head))) (if (not head) (error "Can't find this tar file entry in its parent tar file!")) (unwind-protect (save-excursion - (widen) - (set-buffer-multibyte nil) ;; delete the old data... (let* ((data-start (+ start (- tar-header-offset (point-min)))) (data-end (+ data-start (ash (ash (+ size 511) -9) 9)))) - (delete-region data-start data-end) + (narrow-to-region data-start data-end) + (delete-region (point-min) (point-max)) ;; insert the new data... (goto-char data-start) - (insert-buffer-substring subfile) - (setq subfile-size - (encode-coding-region - data-start (+ data-start subfile-size) coding)) + (with-current-buffer subfile + (save-restriction + (widen) + (encode-coding-region 1 (point-max) coding tar-superior-buffer))) + (setq subfile-size (- (point-max) (point-min))) ;; ;; pad the new data out to a multiple of 512... (let ((subfile-size-pad (ash (ash (+ subfile-size 511) -9) 9))) - (goto-char (+ data-start subfile-size)) + (goto-char (point-max)) (insert (make-string (- subfile-size-pad subfile-size) 0)) ;; ;; update the data pointer of this and all following files... @@ -1182,6 +1164,7 @@ to make your changes permanent." (+ (tar-desc-data-start desc) difference)))) ;; ;; Update the size field in the header block. + (widen) (let ((header-start (- data-start 512))) (goto-char (+ header-start tar-size-offset)) (delete-region (point) (+ (point) 12)) @@ -1220,19 +1203,16 @@ to make your changes permanent." ;; Insert the new text after the old, before deleting, ;; to preserve the window start. (let ((line (tar-header-block-summarize tokens t))) - (insert-before-markers (string-as-unibyte line) "\n")) + (insert-before-markers line "\n")) (delete-region p after) (setq tar-header-offset (marker-position m))) ))) ;; after doing the insertion, add any final padding that may be necessary. (tar-pad-to-blocksize)) - (narrow-to-region (point-min) tar-header-offset) - (set-buffer-multibyte tar-buffer-multibyte))) + (narrow-to-region (point-min) tar-header-offset))) (set-buffer-modified-p t) ; mark the tar file as modified (tar-next-line 0) (set-buffer subfile) - ;; Restore the buffer multibyteness. - (set-buffer-multibyte subfile-multibyte) (set-buffer-modified-p nil) ; mark the tar subfile as unmodified (message "Saved into tar-buffer `%s'. Be sure to save that buffer!" (buffer-name tar-superior-buffer)) @@ -1280,14 +1260,13 @@ Leaves the region wide." ;; tar-header-offset turns out to be null for files fetched with W3, ;; at least. (let ((coding-system-for-write 'no-conversion)) - (write-region (if tar-header-offset - (byte-to-position tar-header-offset) - (point-min)) + (write-region (or tar-header-offset + (point-min)) (point-max) buffer-file-name nil t)) (tar-clear-modification-flags) (set-buffer-modified-p nil)) - (narrow-to-region (point-min) (byte-to-position tar-header-offset))) + (narrow-to-region (point-min) tar-header-offset)) ;; Return t because we've written the file. t)