diff options
Diffstat (limited to 'lisp/tar-mode.el')
| -rw-r--r-- | lisp/tar-mode.el | 1117 |
1 files changed, 0 insertions, 1117 deletions
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el deleted file mode 100644 index c690385064a..00000000000 --- a/lisp/tar-mode.el +++ /dev/null @@ -1,1117 +0,0 @@ -;;; -*- Mode: Emacs-Lisp -*- - -;;; File: tar-mode.el -;;; Description: simple editing of tar files from GNU emacs -;;; Author: Jamie Zawinski <jwz@lucid.com> -;;; Created: 4 Apr 1990 -;;; Version: 1.21, 10 Mar 91 - -;;; Copyright (C) 1990, 1991 Free Software Foundation, Inc. -;;; -;;; This file is part of GNU Emacs. -;;; -;;; GNU Emacs is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) -;;; any later version. -;;; -;;; GNU Emacs is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Emacs; see the file COPYING. If not, write to -;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; This package attempts to make dealing with Unix 'tar' archives easier. -;;; When this code is loaded, visiting a file whose name ends in '.tar' will -;;; cause the contents of that archive file to be displayed in a Dired-like -;;; listing. It is then possible to use the customary Dired keybindings to -;;; extract sub-files from that archive, either by reading them into their own -;;; editor buffers, or by copying them directly to arbitrary files on disk. -;;; It is also possible to delete sub-files from within the tar file and write -;;; the modified archive back to disk, or to edit sub-files within the archive -;;; and re-insert the modified files into the archive. See the documentation -;;; string of tar-mode for more info. - -;;; To autoload, add this to your .emacs file: -;;; -;;; (setq auto-mode-alist (cons '("\\.tar$" . tar-mode) auto-mode-alist)) -;;; (autoload 'tar-mode "tar-mode") -;;; -;;; But beware: for certain tar files - those whose very first file has -;;; a -*- property line - autoloading won't work. See the function -;;; "tar-normal-mode" to understand why. - -;;; This code now understands the extra fields that GNU tar adds to tar files. - -;;; This interacts correctly with "uncompress.el" in the Emacs library, -;;; which you get with -;;; -;;; (autoload 'uncompress-while-visiting "uncompress") -;;; (setq auto-mode-alist (cons '("\\.Z$" . uncompress-while-visiting) -;;; auto-mode-alist)) -;;; -;;; Do not attempt to use tar-mode.el with crypt.el, you will lose. - -;;; *************** TO DO *************** -;;; -;;; o chmod should understand "a+x,og-w". -;;; -;;; o It's not possible to add a NEW file to a tar archive; not that -;;; important, but still... -;;; -;;; o In the directory listing, we don't show creation times because I don't -;;; know how to print an arbitrary date, and I don't really want to have to -;;; implement decode-universal-time. -;;; -;;; o There's code to update the datestamp of edited subfiles, but we set it -;;; to zero because I don't know how to get the current time as an integer. -;;; -;;; o The code is less efficient that it could be - in a lot of places, I -;;; pull a 512-character string out of the buffer and parse it, when I could -;;; be parsing it in place, not garbaging a string. Should redo that. -;;; -;;; o I'd like a command that searches for a string/regexp in every subfile -;;; of an archive, where <esc> would leave you in a subfile-edit buffer. -;;; (Like the Meta-R command of the Zmacs mail reader.) -;;; -;;; o Sometimes (but not always) reverting the tar-file buffer does not -;;; re-grind the listing, and you are staring at the binary tar data. -;;; Typing 'g' again immediately after that will always revert and re-grind -;;; it, though. I have no idea why this happens. -;;; -;;; o Tar-mode interacts poorly with crypt.el and zcat.el because the tar -;;; write-file-hook actually writes the file. Instead it should remove the -;;; header (and conspire to put it back afterwards) so that other write-file -;;; hooks which frob the buffer have a chance to do their dirty work. There -;;; might be a problem if the tar write-file-hook does not come *first* on -;;; the list. -;;; -;;; o Block files, sparse files, continuation files, and the various header -;;; types aren't editable. Actually I don't know that they work at all. - -(defvar tar-anal-blocksize 20 - "*The blocksize of tar files written by Emacs, or nil, meaning don't care. -The blocksize of a tar file is not really the size of the blocks; rather, it is -the number of blocks written with one system call. When tarring to a tape, -this is the size of the *tape* blocks, but when writing to a file, it doesn't -matter much. The only noticeable difference is that if a tar file does not -have a blocksize of 20, tar will tell you that; all this really controls is -how many null padding bytes go on the end of the tar file.") - -(defvar tar-update-datestamp nil - "*Whether tar-mode should play fast and loose with sub-file datestamps; -if this is true, then editing and saving a tar file entry back into its -tar file will update its datestamp. If false, the datestamp is unchanged. -You may or may not want this - it is good in that you can tell when a file -in a tar archive has been changed, but it is bad for the same reason that -editing a file in the tar archive at all is bad - the changed version of -the file never exists on disk. - -## This doesn't work yet because there's no way to get the current time as -## an integer - if this var is true, then editing a file sets its date to -## December 31, 1969 (which happens to be what 0 encodes).") - - - -;;; First, duplicate some Common Lisp functions; I used to just (require 'cl) -;;; but "cl.el" was messing some people up (also it's really big). - -(defmacro tar-setf (form val) - "A mind-numbingly simple implementation of setf." - (let ((mform (macroexpand form (and (boundp 'byte-compile-macro-environment) - byte-compile-macro-environment)))) - (cond ((symbolp mform) (list 'setq mform val)) - ((not (consp mform)) (error "can't setf %s" form)) - ((eq (car mform) 'aref) - (list 'aset (nth 1 mform) (nth 2 mform) val)) - ((eq (car mform) 'car) - (list 'setcar (nth 1 mform) val)) - ((eq (car mform) 'cdr) - (list 'setcdr (nth 1 mform) val)) - (t (error "don't know how to setf %s" form))))) - -(defmacro tar-dolist (control &rest body) - "syntax: (dolist (var-name list-expr &optional return-value) &body body)" - (let ((var (car control)) - (init (car (cdr control))) - (val (car (cdr (cdr control))))) - (list 'let (list (list '_dolist_iterator_ init)) - (list 'while '_dolist_iterator_ - (cons 'let - (cons (list (list var '(car _dolist_iterator_))) - (append body - (list (list 'setq '_dolist_iterator_ - (list 'cdr '_dolist_iterator_))))))) - val))) - -(defmacro tar-dotimes (control &rest body) - "syntax: (dolist (var-name count-expr &optional return-value) &body body)" - (let ((var (car control)) - (n (car (cdr control))) - (val (car (cdr (cdr control))))) - (list 'let (list (list '_dotimes_end_ n) - (list var 0)) - (cons 'while - (cons (list '< var '_dotimes_end_) - (append body - (list (list 'setq var (list '1+ var)))))) - val))) - - -;;; down to business. - -(defmacro make-tar-header (name mode uid git size date ck lt ln - magic uname gname devmaj devmin) - (list 'vector name mode uid git size date ck lt ln - magic uname gname devmaj devmin)) - -(defmacro tar-header-name (x) (list 'aref x 0)) -(defmacro tar-header-mode (x) (list 'aref x 1)) -(defmacro tar-header-uid (x) (list 'aref x 2)) -(defmacro tar-header-gid (x) (list 'aref x 3)) -(defmacro tar-header-size (x) (list 'aref x 4)) -(defmacro tar-header-date (x) (list 'aref x 5)) -(defmacro tar-header-checksum (x) (list 'aref x 6)) -(defmacro tar-header-link-type (x) (list 'aref x 7)) -(defmacro tar-header-link-name (x) (list 'aref x 8)) -(defmacro tar-header-magic (x) (list 'aref x 9)) -(defmacro tar-header-uname (x) (list 'aref x 10)) -(defmacro tar-header-gname (x) (list 'aref x 11)) -(defmacro tar-header-dmaj (x) (list 'aref x 12)) -(defmacro tar-header-dmin (x) (list 'aref x 13)) - -(defmacro make-tar-desc (data-start tokens) - (list 'cons data-start tokens)) - -(defmacro tar-desc-data-start (x) (list 'car x)) -(defmacro tar-desc-tokens (x) (list 'cdr x)) - -(defconst tar-name-offset 0) -(defconst tar-mode-offset (+ tar-name-offset 100)) -(defconst tar-uid-offset (+ tar-mode-offset 8)) -(defconst tar-gid-offset (+ tar-uid-offset 8)) -(defconst tar-size-offset (+ tar-gid-offset 8)) -(defconst tar-time-offset (+ tar-size-offset 12)) -(defconst tar-chk-offset (+ tar-time-offset 12)) -(defconst tar-linkp-offset (+ tar-chk-offset 8)) -(defconst tar-link-offset (+ tar-linkp-offset 1)) -;;; GNU-tar specific slots. -(defconst tar-magic-offset (+ tar-link-offset 100)) -(defconst tar-uname-offset (+ tar-magic-offset 8)) -(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)) - -(defun tokenize-tar-header-block (string) - "Returns a 'tar-header' structure (a list of name, mode, uid, gid, size, -write-date, checksum, link-type, and link-name)." - (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)) - (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))) - name - (nulsexp "[^\000]*\000")) - (and (string-match nulsexp string tar-name-offset) (setq name-end (min name-end (1- (match-end 0))))) - (and (string-match nulsexp string tar-link-offset) (setq link-end (min link-end (1- (match-end 0))))) - (and (string-match nulsexp string tar-uname-offset) (setq uname-end (min uname-end (1- (match-end 0))))) - (and (string-match nulsexp string tar-gname-offset) (setq gname-end (min gname-end (1- (match-end 0))))) - (setq name (substring string tar-name-offset name-end) - link-p (if (or (= link-p 0) (= link-p ?0)) - nil - (- link-p ?0))) - (if (and (null link-p) (string-match "/$" name)) (setq link-p 5)) ; directory - (make-tar-header - name - (tar-parse-octal-integer string tar-mode-offset (1- tar-uid-offset)) - (tar-parse-octal-integer string tar-uid-offset (1- tar-gid-offset)) - (tar-parse-octal-integer string tar-gid-offset (1- tar-size-offset)) - (tar-parse-octal-integer string tar-size-offset (1- tar-time-offset)) - (tar-parse-octal-integer string tar-time-offset (1- tar-chk-offset)) - (tar-parse-octal-integer string tar-chk-offset (1- tar-linkp-offset)) - link-p - (substring string tar-link-offset link-end) - uname-valid-p - (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 (1- tar-dmin-offset)) - (tar-parse-octal-integer string tar-dmin-offset (1- tar-end-offset)) - ))) - (t 'empty-tar-block))) - - -(defun tar-parse-octal-integer (string &optional start end) - "deletes all your files, and then reboots." - (if (null start) (setq start 0)) - (if (null end) (setq end (length string))) - (if (= (aref string start) 0) - 0 - (let ((n 0)) - (while (< start end) - (setq n (if (< (aref string start) ?0) n - (+ (* n 8) (- (aref string start) 48))) - start (1+ start))) - n))) - -(defun tar-parse-octal-integer-safe (string) - (let ((L (length string))) - (if (= L 0) (error "empty string")) - (tar-dotimes (i L) - (if (or (< (aref string i) ?0) - (> (aref string i) ?7)) - (error "'%c' is not an octal digit.")))) - (tar-parse-octal-integer string)) - - -(defun checksum-tar-header-block (string) - "Computes and returns a tar-acceptable checksum for this block." - (let* ((chk-field-start tar-chk-offset) - (chk-field-end (+ chk-field-start 8)) - (sum 0) - (i 0)) - ;; Add up all of the characters except the ones in the checksum field. - ;; Add that field as if it were filled with spaces. - (while (< i chk-field-start) - (setq sum (+ sum (aref string i)) - i (1+ i))) - (setq i chk-field-end) - (while (< i 512) - (setq sum (+ sum (aref string i)) - i (1+ i))) - (+ sum (* 32 8)))) - -(defun check-tar-header-block-checksum (hblock desired-checksum file-name) - "Beep and print a warning if the checksum doesn't match." - (if (not (= desired-checksum (checksum-tar-header-block hblock))) - (progn (beep) (message "Invalid checksum for file %s!" file-name)))) - -(defun recompute-tar-header-block-checksum (hblock) - "Modifies the given string to have a valid checksum field." - (let* ((chk (checksum-tar-header-block hblock)) - (chk-string (format "%6o" chk)) - (l (length chk-string))) - (aset hblock 154 0) - (aset hblock 155 32) - (tar-dotimes (i l) (aset hblock (- 153 i) (aref chk-string (- l i 1))))) - hblock) - - -(defun tar-grind-file-mode (mode string start) - "Write a \"-rw--r--r-\" representing MODE into STRING beginning at START." - (aset string start (if (zerop (logand 256 mode)) ?- ?r)) - (aset string (+ start 1) (if (zerop (logand 128 mode)) ?- ?w)) - (aset string (+ start 2) (if (zerop (logand 64 mode)) ?- ?x)) - (aset string (+ start 3) (if (zerop (logand 32 mode)) ?- ?r)) - (aset string (+ start 4) (if (zerop (logand 16 mode)) ?- ?w)) - (aset string (+ start 5) (if (zerop (logand 8 mode)) ?- ?x)) - (aset string (+ start 6) (if (zerop (logand 4 mode)) ?- ?r)) - (aset string (+ start 7) (if (zerop (logand 2 mode)) ?- ?w)) - (aset string (+ start 8) (if (zerop (logand 1 mode)) ?- ?x)) - (if (zerop (logand 1024 mode)) nil (aset string (+ start 2) ?s)) - (if (zerop (logand 2048 mode)) nil (aset string (+ start 5) ?s)) - string) - -(defun summarize-tar-header-block (tar-hblock &optional mod-p) - "Returns a line similar to the output of 'tar -vtf'." - (let ((name (tar-header-name tar-hblock)) - (mode (tar-header-mode tar-hblock)) - (uid (tar-header-uid tar-hblock)) - (gid (tar-header-gid tar-hblock)) - (uname (tar-header-uname tar-hblock)) - (gname (tar-header-gname tar-hblock)) - (size (tar-header-size tar-hblock)) - (time (tar-header-date tar-hblock)) - (ck (tar-header-checksum tar-hblock)) - (link-p (tar-header-link-type tar-hblock)) - (link-name (tar-header-link-name tar-hblock)) - ) - (let* ((left 11) - (namew 8) - (groupw 8) - (sizew 8) - (datew 2) - (slash (1- (+ left namew))) - (lastdigit (+ slash groupw sizew)) - (namestart (+ lastdigit datew)) - (string (make-string (+ namestart (length name) (if link-p (+ 5 (length link-name)) 0)) 32)) - (type (tar-header-link-type tar-hblock))) - (aset string 0 (if mod-p ?* ? )) - (aset string 1 - (cond ((or (eq type nil) (eq type 0)) ?-) - ((eq type 1) ?l) ; link - ((eq type 2) ?s) ; symlink - ((eq type 3) ?c) ; char special - ((eq type 4) ?b) ; block special - ((eq type 5) ?d) ; directory - ((eq type 6) ?p) ; FIFO/pipe - ((eq type 20) ?*) ; directory listing - ((eq type 29) ?M) ; multivolume continuation - ((eq type 35) ?S) ; sparse - ((eq type 38) ?V) ; volume header - )) - (tar-grind-file-mode mode string 2) - (setq uid (if (= 0 (length uname)) (int-to-string uid) uname)) - (setq gid (if (= 0 (length gname)) (int-to-string gid) gname)) - (setq size (int-to-string size)) - (tar-dotimes (i (min (1- namew) (length uid))) (aset string (- slash i) (aref uid (- (length uid) i 1)))) - (aset string (1+ slash) ?/) - (tar-dotimes (i (min (1- groupw) (length gid))) (aset string (+ (+ slash 2) i) (aref gid i))) - (tar-dotimes (i (min sizew (length size))) (aset string (- lastdigit i) (aref size (- (length size) i 1)))) - ;; ## bloody hell, how do I print an arbitrary date?? - (tar-dotimes (i (length name)) (aset string (+ namestart i) (aref name i))) - (if (or (eq link-p 1) (eq link-p 2)) - (progn - (tar-dotimes (i 3) (aset string (+ namestart 1 (length name) i) (aref (if (= link-p 1) "==>" "-->") i))) - (tar-dotimes (i (length link-name)) (aset string (+ namestart 5 (length name) i) (aref link-name i))))) - string))) - - -(defun tar-summarize-buffer () - "Parse the contents of the tar file in the current buffer, and place a -dired-like listing on the front; then narrow to it, so that only that listing -is visible (and the real data of the buffer is hidden)." - (message "parsing tar file...") - (let* ((result '()) - (pos 1) - (bs (max 1 (- (buffer-size) 1024))) ; always 2+ empty blocks at end. - (bs100 (max 1 (/ bs 100))) - (tokens nil)) - (while (not (eq tokens 'empty-tar-block)) - (let* ((hblock (buffer-substring pos (+ pos 512)))) - (setq tokens (tokenize-tar-header-block hblock)) - (setq pos (+ pos 512)) - (message "parsing tar file...%s%%" - ;(/ (* pos 100) bs) ; this gets round-off lossage - (/ pos bs100) ; this doesn't - ) - (if (eq tokens 'empty-tar-block) - nil - (if (null tokens) (error "premature EOF parsing tar file.")) - (if (eq (tar-header-link-type tokens) 20) - ;; Foo. There's an extra empty block after these. - (setq pos (+ pos 512))) - (let ((size (tar-header-size tokens))) - (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.... - ;(check-tar-header-block-checksum - ; hblock (checksum-tar-header-block hblock) - ; (tar-header-name tokens)) - - (setq result (cons (make-tar-desc pos tokens) result)) - - (if (and (null (tar-header-link-type tokens)) - (> size 0)) - (setq pos - (+ pos 512 (ash (ash (1- size) -9) 9)) ; this works - ;(+ pos (+ size (- 512 (rem (1- size) 512)))) ; this doesn't - )) - )))) - (make-local-variable 'tar-parse-info) - (setq tar-parse-info (nreverse result))) - (save-excursion - (goto-char (point-min)) - (let ((buffer-read-only nil)) - (tar-dolist (tar-desc tar-parse-info) - (insert-string - (summarize-tar-header-block (tar-desc-tokens tar-desc))) - (insert-string "\n")) - (make-local-variable 'tar-header-offset) - (setq tar-header-offset (point)) - (narrow-to-region 1 tar-header-offset) - (set-buffer-modified-p nil))) - (message "parsing tar file...done.")) - - -(defvar tar-mode-map nil "*Local keymap for tar-mode listings.") - -(if tar-mode-map - nil - (setq tar-mode-map (make-keymap)) - (suppress-keymap tar-mode-map) - (define-key tar-mode-map " " 'tar-next-line) - (define-key tar-mode-map "c" 'tar-copy) - (define-key tar-mode-map "d" 'tar-flag-deleted) - (define-key tar-mode-map "\^D" 'tar-flag-deleted) - (define-key tar-mode-map "e" 'tar-extract) - (define-key tar-mode-map "f" 'tar-extract) - (define-key tar-mode-map "g" 'revert-buffer) - (define-key tar-mode-map "h" 'describe-mode) - (define-key tar-mode-map "n" 'tar-next-line) - (define-key tar-mode-map "\^N" 'tar-next-line) - (define-key tar-mode-map "o" 'tar-extract-other-window) - (define-key tar-mode-map "\^C" 'tar-copy) - (define-key tar-mode-map "p" 'tar-previous-line) - (define-key tar-mode-map "\^P" 'tar-previous-line) - (define-key tar-mode-map "r" 'tar-rename-entry) - (define-key tar-mode-map "u" 'tar-unflag) - (define-key tar-mode-map "v" 'tar-view) - (define-key tar-mode-map "x" 'tar-expunge) - (define-key tar-mode-map "\177" 'tar-unflag-backwards) - (define-key tar-mode-map "E" 'tar-extract-other-window) - (define-key tar-mode-map "M" 'tar-chmod-entry) - (define-key tar-mode-map "G" 'tar-chgrp-entry) - (define-key tar-mode-map "O" 'tar-chown-entry) - ) - -;; tar mode is suitable only for specially formatted data. -(put 'tar-mode 'mode-class 'special) -(put 'tar-subfile-mode 'mode-class 'special) - -(defun tar-mode () - "Major mode for viewing a tar file as a dired-like listing of its contents. -You can move around using the usual cursor motion commands. -Letters no longer insert themselves. -Type 'e' to pull a file out of the tar file and into its own buffer. -Type 'c' to copy an entry from the tar file into another file on disk. - -If you edit a sub-file of this archive (as with the 'e' command) and -save it with Control-X Control-S, the contents of that buffer will be -saved back into the tar-file buffer; in this way you can edit a file -inside of a tar archive without extracting it and re-archiving it. - -See also: variables tar-update-datestamp and tar-anal-blocksize. -\\{tar-mode-map}" - ;; this is not interactive because you shouldn't be turning this - ;; mode on and off. You can corrupt things that way. - (make-local-variable 'tar-header-offset) - (make-local-variable 'tar-parse-info) - (make-local-variable 'require-final-newline) - (setq require-final-newline nil) ; binary data, dude... - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'tar-mode-revert) - (setq major-mode 'tar-mode) - (setq mode-name "Tar") - (use-local-map tar-mode-map) - (auto-save-mode 0) - (widen) - (if (and (boundp 'tar-header-offset) tar-header-offset) - (narrow-to-region 1 tar-header-offset) - (tar-summarize-buffer)) - (run-hooks 'tar-mode-hook) - ) - - -(defun tar-subfile-mode (p) - "Minor mode for editing an element of a tar-file. -This mode redefines ^X^S to save the current buffer back into its -associated tar-file buffer. You must save that buffer to actually -save your changes to disk." - (interactive "P") - (or (and (boundp 'superior-tar-buffer) superior-tar-buffer) - (error "This buffer is not an element of a tar file.")) - (or (assq 'tar-subfile-mode minor-mode-alist) - (setq minor-mode-alist (append minor-mode-alist - (list '(tar-subfile-mode - " TarFile"))))) - (make-local-variable 'tar-subfile-mode) - (setq tar-subfile-mode - (if (null p) - (not tar-subfile-mode) - (> (prefix-numeric-value p) 0))) - (cond (tar-subfile-mode - ;; copy the local keymap so that we don't accidentally - ;; alter a keymap like 'lisp-mode-map' which is shared - ;; by all buffers in that mode. - (let ((m (current-local-map))) - (if m (use-local-map (copy-keymap m)))) - (local-set-key "\^X\^S" 'tar-subfile-save-buffer) - ;; turn off auto-save. - (auto-save-mode nil) - (setq buffer-auto-save-file-name nil) - (run-hooks 'tar-subfile-mode-hook)) - (t (local-set-key "\^X\^S" 'save-buffer))) - ) - - -(defun tar-mode-revert (&optional no-autosave no-confirm) - "Revert this buffer and turn on tar mode again, to re-compute the -directory listing." - (setq tar-header-offset nil) - (let ((revert-buffer-function nil)) - (revert-buffer t no-confirm) - (widen)) - (tar-mode)) - - -(defun tar-next-line (p) - (interactive "p") - (forward-line p) - (if (eobp) nil (forward-char 36))) - -(defun tar-previous-line (p) - (interactive "p") - (tar-next-line (- p))) - -(defun tar-current-descriptor (&optional noerror) - "Returns the tar-descriptor of the current line, or signals an error." - ;; I wish lines had plists, like in ZMACS... - (or (nth (count-lines (point-min) - (save-excursion (beginning-of-line) (point))) - tar-parse-info) - (if noerror - nil - (error "This line does not describe a tar-file entry.")))) - - -(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-current-descriptor)) - (tokens (tar-desc-tokens descriptor)) - (name (tar-header-name tokens)) - (size (tar-header-size tokens)) - (link-p (tar-header-link-type tokens)) - (start (+ (tar-desc-data-start descriptor) tar-header-offset -1)) - (end (+ start size))) - (if link-p - (error "This is a %s, not a real file." - (cond ((eq link-p 5) "directory") - ((eq link-p 20) "tar directory header") - ((eq link-p 29) "multivolume-continuation") - ((eq link-p 35) "sparse entry") - ((eq link-p 38) "volume header") - (t "link")))) - (if (zerop size) (error "This is a zero-length file.")) - (let* ((tar-buffer (current-buffer)) - (bufname (concat (file-name-nondirectory name) - " (" name " in " - (file-name-nondirectory (buffer-file-name)) - ")")) - (read-only-p (or buffer-read-only view-p)) - (buffer (get-buffer bufname)) - (just-created nil)) - (if buffer - nil - (setq buffer (get-buffer-create bufname)) - (setq just-created t) - (unwind-protect - (progn - (widen) - (save-excursion - (set-buffer buffer) - (insert-buffer-substring tar-buffer start end) - (goto-char 0) - (set-visited-file-name name) ; give it a name to decide mode. - (normal-mode) ; pick a mode. - (set-visited-file-name nil) ; nuke the name - not meaningful. - (rename-buffer bufname) - - (make-local-variable 'superior-tar-buffer) - (make-local-variable 'superior-tar-descriptor) - (setq superior-tar-buffer tar-buffer) - (setq superior-tar-descriptor descriptor) - (tar-subfile-mode 1) - - (setq buffer-read-only read-only-p) - (set-buffer-modified-p nil)) - (set-buffer tar-buffer)) - (narrow-to-region 1 tar-header-offset))) - (if view-p - (progn - (view-buffer buffer) - (and just-created (kill-buffer buffer))) - (if other-window-p - (switch-to-buffer-other-window buffer) - (switch-to-buffer buffer)))))) - - -(defun tar-extract-other-window () - "*In tar-mode, extract this entry of the tar file into its own buffer." - (interactive) - (tar-extract t)) - -(defun tar-view () - "*In tar-mode, view the tar file entry on this line." - (interactive) - (tar-extract 'view)) - - -(defun tar-read-file-name (&optional prompt) - "Calls read-file-name, with the default being the file of the current -tar-file descriptor." - (or prompt (setq prompt "Copy to: ")) - (let* ((default-file (expand-file-name - (tar-header-name (tar-desc-tokens - (tar-current-descriptor))))) - (target (expand-file-name - (read-file-name prompt - (file-name-directory default-file) - default-file nil)))) - (if (or (string= "" (file-name-nondirectory target)) - (file-directory-p target)) - (setq target (concat (if (string-match "/$" target) - (substring target 0 (1- (match-end 0))) - target) - "/" - (file-name-nondirectory default-file)))) - target)) - - -(defun tar-copy (&optional to-file) - "*In tar-mode, extract this entry of the tar file into a file on disk. -If TO-FILE is not supplied, it is prompted for, defaulting to the name of -the current tar-entry." - (interactive (list (tar-read-file-name))) - (let* ((descriptor (tar-current-descriptor)) - (tokens (tar-desc-tokens descriptor)) - (name (tar-header-name tokens)) - (size (tar-header-size tokens)) - (link-p (tar-header-link-type tokens)) - (start (+ (tar-desc-data-start descriptor) tar-header-offset -1)) - (end (+ start size))) - (if link-p (error "This is a link, not a real file.")) - (if (zerop size) (error "This is a zero-length file.")) - (let* ((tar-buffer (current-buffer)) - buffer) - (unwind-protect - (progn - (setq buffer (generate-new-buffer "*tar-copy-tmp*")) - (widen) - (save-excursion - (set-buffer buffer) - (insert-buffer-substring tar-buffer start end) - (set-buffer-modified-p nil) ; in case we abort - (write-file to-file) - (message "Copied tar entry %s to %s" name to-file) - (set-buffer tar-buffer))) - (narrow-to-region 1 tar-header-offset) - (if buffer (kill-buffer buffer))) - ))) - - -(defun tar-flag-deleted (p &optional unflag) - "*In tar mode, mark this sub-file to be deleted from the tar file. -With a prefix argument, mark that many files." - (interactive "p") - (beginning-of-line) - (tar-dotimes (i (if (< p 0) (- p) p)) - (if (tar-current-descriptor unflag) ; barf if we're not on an entry-line. - (progn - (delete-char 1) - (insert (if unflag " " "D")))) - (forward-line (if (< p 0) -1 1))) - (if (eobp) nil (forward-char 36))) - -(defun tar-unflag (p) - "*In tar mode, un-mark this sub-file if it is marked to be deleted. -With a prefix argument, un-mark that many files forward." - (interactive "p") - (tar-flag-deleted p t)) - -(defun tar-unflag-backwards (p) - "*In tar mode, un-mark this sub-file if it is marked to be deleted. -With a prefix argument, un-mark that many files backward." - (interactive "p") - (tar-flag-deleted (- p) t)) - - -(defun tar-expunge-internal () - "Expunge the tar-entry specified by the current line." - (let* ((descriptor (tar-current-descriptor)) - (tokens (tar-desc-tokens descriptor)) - (line (tar-desc-data-start descriptor)) - (name (tar-header-name tokens)) - (size (tar-header-size tokens)) - (link-p (tar-header-link-type tokens)) - (start (tar-desc-data-start descriptor)) - (following-descs (cdr (memq descriptor tar-parse-info)))) - (if link-p (setq size 0)) ; size lies for hard-links. - ;; - ;; delete the current line... - (beginning-of-line) - (let ((line-start (point))) - (end-of-line) (forward-char) - (let ((line-len (- (point) line-start))) - (delete-region line-start (point)) - ;; - ;; decrement the header-pointer to be in synch... - (setq tar-header-offset (- tar-header-offset line-len)))) - ;; - ;; delete the data pointer... - (setq tar-parse-info (delq descriptor tar-parse-info)) - ;; - ;; delete the data from inside the file... - (widen) - (let* ((data-start (+ start tar-header-offset -513)) - (data-end (+ data-start 512 (ash (ash (+ size 511) -9) 9)))) - (delete-region data-start data-end) - ;; - ;; and finally, decrement the start-pointers of all following - ;; entries in the archive. This is a pig when deleting a bunch - ;; of files at once - we could optimize this to only do the - ;; iteration over the files that remain, or only iterate up to - ;; the next file to be deleted. - (let ((data-length (- data-end data-start))) - (tar-dolist (desc following-descs) - (tar-setf (tar-desc-data-start desc) - (- (tar-desc-data-start desc) data-length)))) - )) - (narrow-to-region 1 tar-header-offset)) - - -(defun tar-expunge (&optional noconfirm) - "*In tar-mode, delete all the archived files flagged for deletion. -This does not modify the disk image; you must save the tar file itself -for this to be permanent." - (interactive) - (if (or noconfirm - (y-or-n-p "expunge files marked for deletion? ")) - (let ((n 0)) - (save-excursion - (goto-char 0) - (while (not (eobp)) - (if (looking-at "D") - (progn (tar-expunge-internal) - (setq n (1+ n))) - (forward-line 1))) - ;; after doing the deletions, add any padding that may be necessary. - (tar-pad-to-blocksize) - (narrow-to-region 1 tar-header-offset) - ) - (if (zerop n) - (message "nothing to expunge.") - (message "%s expunged. Be sure to save this buffer." n))))) - - -(defun tar-clear-modification-flags () - "remove the stars at the beginning of each line." - (save-excursion - (goto-char 0) - (while (< (point) tar-header-offset) - (if (looking-at "*") - (progn (delete-char 1) (insert " "))) - (forward-line 1)))) - - -(defun tar-chown-entry (new-uid) - "*Change the user-id associated with this entry in the tar file. -If this tar file was written by GNU tar, then you will be able to edit -the user id as a string; otherwise, you must edit it as a number. -You can force editing as a number by calling this with a prefix arg. -This does not modify the disk image; you must save the tar file itself -for this to be permanent." - (interactive (list - (let ((tokens (tar-desc-tokens (tar-current-descriptor)))) - (if (or current-prefix-arg - (not (tar-header-magic tokens))) - (let (n) - (while (not (numberp (setq n (read-minibuffer - "New UID number: " - (format "%s" (tar-header-uid tokens))))))) - n) - (read-string "New UID string: " (tar-header-uname tokens)))))) - (cond ((stringp new-uid) - (tar-setf (tar-header-uname (tar-desc-tokens (tar-current-descriptor))) - new-uid) - (tar-alter-one-field tar-uname-offset (concat new-uid "\000"))) - (t - (tar-setf (tar-header-uid (tar-desc-tokens (tar-current-descriptor))) - new-uid) - (tar-alter-one-field tar-uid-offset - (concat (substring (format "%6o" new-uid) 0 6) "\000 "))))) - - -(defun tar-chgrp-entry (new-gid) - "*Change the group-id associated with this entry in the tar file. -If this tar file was written by GNU tar, then you will be able to edit -the group id as a string; otherwise, you must edit it as a number. -You can force editing as a number by calling this with a prefix arg. -This does not modify the disk image; you must save the tar file itself -for this to be permanent." - (interactive (list - (let ((tokens (tar-desc-tokens (tar-current-descriptor)))) - (if (or current-prefix-arg - (not (tar-header-magic tokens))) - (let (n) - (while (not (numberp (setq n (read-minibuffer - "New GID number: " - (format "%s" (tar-header-gid tokens))))))) - n) - (read-string "New GID string: " (tar-header-gname tokens)))))) - (cond ((stringp new-gid) - (tar-setf (tar-header-gname (tar-desc-tokens (tar-current-descriptor))) - new-gid) - (tar-alter-one-field tar-gname-offset - (concat new-gid "\000"))) - (t - (tar-setf (tar-header-gid (tar-desc-tokens (tar-current-descriptor))) - new-gid) - (tar-alter-one-field tar-gid-offset - (concat (substring (format "%6o" new-gid) 0 6) "\000 "))))) - -(defun tar-rename-entry (new-name) - "*Change the name associated with this entry in the tar file. -This does not modify the disk image; you must save the tar file itself -for this to be permanent." - (interactive - (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) - (tar-alter-one-field 0 - (substring (concat new-name (make-string 99 0)) 0 99))) - - -(defun tar-chmod-entry (new-mode) - "*Change the protection bits associated with this entry in the tar file. -This does not modify the disk image; you must save the tar file itself -for this to be permanent." - (interactive (list (tar-parse-octal-integer-safe - (read-string "New protection (octal): ")))) - (tar-setf (tar-header-mode (tar-desc-tokens (tar-current-descriptor))) - new-mode) - (tar-alter-one-field tar-mode-offset - (concat (substring (format "%6o" new-mode) 0 6) "\000 "))) - - -(defun tar-alter-one-field (data-position new-data-string) - (let* ((descriptor (tar-current-descriptor)) - (tokens (tar-desc-tokens descriptor))) - (unwind-protect - (save-excursion - ;; - ;; update the header-line. - (beginning-of-line) - (let ((p (point))) - (forward-line 1) - (delete-region p (point)) - (insert (summarize-tar-header-block tokens) "\n") - (setq tar-header-offset (point-max))) - - (widen) - (let* ((start (+ (tar-desc-data-start descriptor) tar-header-offset -513))) - ;; - ;; 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) ; <-- - ;; - ;; compute a new checksum and insert it. - (let ((chk (checksum-tar-header-block - (buffer-substring start (+ start 512))))) - (goto-char (+ start tar-chk-offset)) - (delete-region (point) (+ (point) 8)) - (insert (format "%6o" chk)) - (insert 0) - (insert ? ) - (tar-setf (tar-header-checksum tokens) chk) - ;; - ;; ok, make sure we didn't botch it. - (check-tar-header-block-checksum - (buffer-substring start (+ start 512)) - chk (tar-header-name tokens)) - ))) - (narrow-to-region 1 tar-header-offset)))) - - -(defun tar-subfile-save-buffer () - "In tar subfile mode, write this buffer back into its parent tar-file buffer. -This doesn't write anything to disk - you must save the parent tar-file buffer -to make your changes permanent." - (interactive) - (if (not (and (boundp 'superior-tar-buffer) superior-tar-buffer)) - (error "this buffer has no superior tar file buffer.")) - (if (not (and (boundp 'superior-tar-descriptor) superior-tar-descriptor)) - (error "this buffer doesn't have an index into its superior tar file!")) - (save-excursion - (let ((subfile (current-buffer)) - (subfile-size (buffer-size)) - (descriptor superior-tar-descriptor)) - (set-buffer superior-tar-buffer) - (let* ((tokens (tar-desc-tokens descriptor)) - (start (tar-desc-data-start descriptor)) - (name (tar-header-name tokens)) - (size (tar-header-size tokens)) - (size-pad (ash (ash (+ size 511) -9) 9)) - (head (memq descriptor tar-parse-info)) - (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) - ;; delete the old data... - (let* ((data-start (+ start tar-header-offset -1)) - (data-end (+ data-start (ash (ash (+ size 511) -9) 9)))) - (delete-region data-start data-end) - ;; insert the new data... - (goto-char data-start) - (insert-buffer subfile) - ;; - ;; 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)) - (insert (make-string (- subfile-size-pad subfile-size) 0)) - ;; - ;; update the data pointer of this and all following files... - (tar-setf (tar-header-size tokens) subfile-size) - (let ((difference (- subfile-size-pad size-pad))) - (tar-dolist (desc following-descs) - (tar-setf (tar-desc-data-start desc) - (+ (tar-desc-data-start desc) difference)))) - ;; - ;; Update the size field in the header block. - (let ((header-start (- data-start 512))) - (goto-char (+ header-start tar-size-offset)) - (delete-region (point) (+ (point) 12)) - (insert (format "%11o" subfile-size)) - (insert ? ) - ;; - ;; Maybe update the datestamp. - (if (not tar-update-datestamp) - nil - (goto-char (+ header-start tar-time-offset)) - (delete-region (point) (+ (point) 12)) - (insert (format "%11o" 0)) ; ## oops - how to get it?? - (insert ? )) - ;; - ;; compute a new checksum and insert it. - (let ((chk (checksum-tar-header-block - (buffer-substring header-start data-start)))) - (goto-char (+ header-start tar-chk-offset)) - (delete-region (point) (+ (point) 8)) - (insert (format "%6o" chk)) - (insert 0) - (insert ? ) - (tar-setf (tar-header-checksum tokens) chk))) - ;; - ;; alter the descriptor-line... - ;; - (let ((position (- (length tar-parse-info) (length head)))) - (goto-char 1) - (next-line position) - (beginning-of-line) - (let ((p (point)) - (m (set-marker (make-marker) tar-header-offset))) - (forward-line 1) - (delete-region p (point)) - (insert-before-markers (summarize-tar-header-block tokens t) "\n") - (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 1 tar-header-offset))) - (set-buffer-modified-p t) ; mark the tar file as modified - (set-buffer subfile) - (set-buffer-modified-p nil) ; mark the tar subfile as unmodified - (message "saved into tar-buffer \"%s\" - remember to save that buffer!" - (buffer-name superior-tar-buffer)) - ))) - - -(defun tar-pad-to-blocksize () - "If we are being anal about tar file blocksizes, fix up the current buffer. -Leaves the region wide." - (if (null tar-anal-blocksize) - nil - (widen) - (let* ((last-desc (nth (1- (length tar-parse-info)) tar-parse-info)) - (start (tar-desc-data-start last-desc)) - (tokens (tar-desc-tokens last-desc)) - (link-p (tar-header-link-type tokens)) - (size (if link-p 0 (tar-header-size tokens))) - (data-end (+ start size)) - (bbytes (ash tar-anal-blocksize 9)) - (pad-to (+ bbytes (* bbytes (/ (1- data-end) bbytes)))) - (buffer-read-only nil) ; ## - ) - ;; If the padding after the last data is too long, delete some; - ;; else insert some until we are padded out to the right number of blocks. - ;; - (goto-char (+ (or tar-header-offset 0) data-end)) - (if (> (1+ (buffer-size)) (+ (or tar-header-offset 0) pad-to)) - (delete-region (+ (or tar-header-offset 0) pad-to) (1+ (buffer-size))) - (insert (make-string (- (+ (or tar-header-offset 0) pad-to) - (1+ (buffer-size))) - 0))) - ))) - - -(defun maybe-write-tar-file () - "Used as a write-file-hook to write tar-files out correctly." - ;; - ;; If the current buffer is in tar-mode and has its header-offset set, - ;; only write out the part of the file after the header-offset. - ;; - (if (and (eq major-mode 'tar-mode) - (and (boundp 'tar-header-offset) tar-header-offset)) - (unwind-protect - (save-excursion - (tar-clear-modification-flags) - (widen) - ;; Doing this here confuses things - the region gets left too wide! - ;; I suppose this is run in a context where changing the buffer is bad. - ;; (tar-pad-to-blocksize) - (write-region tar-header-offset (1+ (buffer-size)) buffer-file-name nil t) - ;; return T because we've written the file. - t) - (narrow-to-region 1 tar-header-offset) - t) - ;; return NIL because we haven't. - nil)) - - -;;; Patch it in. - -(defvar tar-regexp "\\.tar$" - "The regular expression used to identify tar file names.") - -(setq auto-mode-alist - (cons (cons tar-regexp 'tar-mode) auto-mode-alist)) - -(or (boundp 'write-file-hooks) (setq write-file-hooks nil)) -(or (listp write-file-hooks) - (setq write-file-hooks (list write-file-hooks))) -(or (memq 'maybe-write-tar-file write-file-hooks) - (setq write-file-hooks - (cons 'maybe-write-tar-file write-file-hooks))) - - -;;; This is a hack. For files ending in .tar, we want -*- lines to be -;;; completely ignored - if there is one, it applies to the first file -;;; in the archive, and not the archive itself! - -(defun tar-normal-mode (&optional find-file) - "Choose the major mode for this buffer automatically. -Also sets up any specified local variables of the file. -Uses the visited file name, the -*- line, and the local variables spec. - -This function is called automatically from `find-file'. In that case, -if `inhibit-local-variables' is non-`nil' we require confirmation before -processing a local variables spec. If you run `normal-mode' explicitly, -confirmation is never required. - -Note that this version of this function has been hacked to interact -correctly with tar files - when visiting a file which matches -'tar-regexp', the -*- line and local-variables are not examined, -as they would apply to a file within the archive rather than the archive -itself." - (interactive) - (if (and buffer-file-name - (string-match tar-regexp buffer-file-name)) - (tar-mode) - (tar-real-normal-mode find-file))) - - -(if (not (fboundp 'tar-real-normal-mode)) - (fset 'tar-real-normal-mode (symbol-function 'normal-mode))) -(fset 'normal-mode 'tar-normal-mode) - -(provide 'tar-mode) - |