diff options
| author | Richard M. Stallman | 1991-03-11 01:37:34 +0000 |
|---|---|---|
| committer | Richard M. Stallman | 1991-03-11 01:37:34 +0000 |
| commit | aa73f29c5c62d6ba69fe7b85196eac94e566164c (patch) | |
| tree | 0f64addca6740690e10f00cb7647a954b0fd1936 | |
| parent | 7b863bd51ae685c82574063f2a68fa7f603a5bdc (diff) | |
| download | emacs-aa73f29c5c62d6ba69fe7b85196eac94e566164c.tar.gz emacs-aa73f29c5c62d6ba69fe7b85196eac94e566164c.zip | |
Initial revision
| -rw-r--r-- | lisp/tar-mode.el | 1117 |
1 files changed, 1117 insertions, 0 deletions
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el new file mode 100644 index 00000000000..c690385064a --- /dev/null +++ b/lisp/tar-mode.el | |||
| @@ -0,0 +1,1117 @@ | |||
| 1 | ;;; -*- Mode: Emacs-Lisp -*- | ||
| 2 | |||
| 3 | ;;; File: tar-mode.el | ||
| 4 | ;;; Description: simple editing of tar files from GNU emacs | ||
| 5 | ;;; Author: Jamie Zawinski <jwz@lucid.com> | ||
| 6 | ;;; Created: 4 Apr 1990 | ||
| 7 | ;;; Version: 1.21, 10 Mar 91 | ||
| 8 | |||
| 9 | ;;; Copyright (C) 1990, 1991 Free Software Foundation, Inc. | ||
| 10 | ;;; | ||
| 11 | ;;; This file is part of GNU Emacs. | ||
| 12 | ;;; | ||
| 13 | ;;; GNU Emacs is free software; you can redistribute it and/or modify | ||
| 14 | ;;; it under the terms of the GNU General Public License as published by | ||
| 15 | ;;; the Free Software Foundation; either version 1, or (at your option) | ||
| 16 | ;;; any later version. | ||
| 17 | ;;; | ||
| 18 | ;;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 19 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 20 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 21 | ;;; GNU General Public License for more details. | ||
| 22 | ;;; | ||
| 23 | ;;; You should have received a copy of the GNU General Public License | ||
| 24 | ;;; along with GNU Emacs; see the file COPYING. If not, write to | ||
| 25 | ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | ||
| 26 | |||
| 27 | ;;; This package attempts to make dealing with Unix 'tar' archives easier. | ||
| 28 | ;;; When this code is loaded, visiting a file whose name ends in '.tar' will | ||
| 29 | ;;; cause the contents of that archive file to be displayed in a Dired-like | ||
| 30 | ;;; listing. It is then possible to use the customary Dired keybindings to | ||
| 31 | ;;; extract sub-files from that archive, either by reading them into their own | ||
| 32 | ;;; editor buffers, or by copying them directly to arbitrary files on disk. | ||
| 33 | ;;; It is also possible to delete sub-files from within the tar file and write | ||
| 34 | ;;; the modified archive back to disk, or to edit sub-files within the archive | ||
| 35 | ;;; and re-insert the modified files into the archive. See the documentation | ||
| 36 | ;;; string of tar-mode for more info. | ||
| 37 | |||
| 38 | ;;; To autoload, add this to your .emacs file: | ||
| 39 | ;;; | ||
| 40 | ;;; (setq auto-mode-alist (cons '("\\.tar$" . tar-mode) auto-mode-alist)) | ||
| 41 | ;;; (autoload 'tar-mode "tar-mode") | ||
| 42 | ;;; | ||
| 43 | ;;; But beware: for certain tar files - those whose very first file has | ||
| 44 | ;;; a -*- property line - autoloading won't work. See the function | ||
| 45 | ;;; "tar-normal-mode" to understand why. | ||
| 46 | |||
| 47 | ;;; This code now understands the extra fields that GNU tar adds to tar files. | ||
| 48 | |||
| 49 | ;;; This interacts correctly with "uncompress.el" in the Emacs library, | ||
| 50 | ;;; which you get with | ||
| 51 | ;;; | ||
| 52 | ;;; (autoload 'uncompress-while-visiting "uncompress") | ||
| 53 | ;;; (setq auto-mode-alist (cons '("\\.Z$" . uncompress-while-visiting) | ||
| 54 | ;;; auto-mode-alist)) | ||
| 55 | ;;; | ||
| 56 | ;;; Do not attempt to use tar-mode.el with crypt.el, you will lose. | ||
| 57 | |||
| 58 | ;;; *************** TO DO *************** | ||
| 59 | ;;; | ||
| 60 | ;;; o chmod should understand "a+x,og-w". | ||
| 61 | ;;; | ||
| 62 | ;;; o It's not possible to add a NEW file to a tar archive; not that | ||
| 63 | ;;; important, but still... | ||
| 64 | ;;; | ||
| 65 | ;;; o In the directory listing, we don't show creation times because I don't | ||
| 66 | ;;; know how to print an arbitrary date, and I don't really want to have to | ||
| 67 | ;;; implement decode-universal-time. | ||
| 68 | ;;; | ||
| 69 | ;;; o There's code to update the datestamp of edited subfiles, but we set it | ||
| 70 | ;;; to zero because I don't know how to get the current time as an integer. | ||
| 71 | ;;; | ||
| 72 | ;;; o The code is less efficient that it could be - in a lot of places, I | ||
| 73 | ;;; pull a 512-character string out of the buffer and parse it, when I could | ||
| 74 | ;;; be parsing it in place, not garbaging a string. Should redo that. | ||
| 75 | ;;; | ||
| 76 | ;;; o I'd like a command that searches for a string/regexp in every subfile | ||
| 77 | ;;; of an archive, where <esc> would leave you in a subfile-edit buffer. | ||
| 78 | ;;; (Like the Meta-R command of the Zmacs mail reader.) | ||
| 79 | ;;; | ||
| 80 | ;;; o Sometimes (but not always) reverting the tar-file buffer does not | ||
| 81 | ;;; re-grind the listing, and you are staring at the binary tar data. | ||
| 82 | ;;; Typing 'g' again immediately after that will always revert and re-grind | ||
| 83 | ;;; it, though. I have no idea why this happens. | ||
| 84 | ;;; | ||
| 85 | ;;; o Tar-mode interacts poorly with crypt.el and zcat.el because the tar | ||
| 86 | ;;; write-file-hook actually writes the file. Instead it should remove the | ||
| 87 | ;;; header (and conspire to put it back afterwards) so that other write-file | ||
| 88 | ;;; hooks which frob the buffer have a chance to do their dirty work. There | ||
| 89 | ;;; might be a problem if the tar write-file-hook does not come *first* on | ||
| 90 | ;;; the list. | ||
| 91 | ;;; | ||
| 92 | ;;; o Block files, sparse files, continuation files, and the various header | ||
| 93 | ;;; types aren't editable. Actually I don't know that they work at all. | ||
| 94 | |||
| 95 | (defvar tar-anal-blocksize 20 | ||
| 96 | "*The blocksize of tar files written by Emacs, or nil, meaning don't care. | ||
| 97 | The blocksize of a tar file is not really the size of the blocks; rather, it is | ||
| 98 | the number of blocks written with one system call. When tarring to a tape, | ||
| 99 | this is the size of the *tape* blocks, but when writing to a file, it doesn't | ||
| 100 | matter much. The only noticeable difference is that if a tar file does not | ||
| 101 | have a blocksize of 20, tar will tell you that; all this really controls is | ||
| 102 | how many null padding bytes go on the end of the tar file.") | ||
| 103 | |||
| 104 | (defvar tar-update-datestamp nil | ||
| 105 | "*Whether tar-mode should play fast and loose with sub-file datestamps; | ||
| 106 | if this is true, then editing and saving a tar file entry back into its | ||
| 107 | tar file will update its datestamp. If false, the datestamp is unchanged. | ||
| 108 | You may or may not want this - it is good in that you can tell when a file | ||
| 109 | in a tar archive has been changed, but it is bad for the same reason that | ||
| 110 | editing a file in the tar archive at all is bad - the changed version of | ||
| 111 | the file never exists on disk. | ||
| 112 | |||
| 113 | ## This doesn't work yet because there's no way to get the current time as | ||
| 114 | ## an integer - if this var is true, then editing a file sets its date to | ||
| 115 | ## December 31, 1969 (which happens to be what 0 encodes).") | ||
| 116 | |||
| 117 | |||
| 118 | |||
| 119 | ;;; First, duplicate some Common Lisp functions; I used to just (require 'cl) | ||
| 120 | ;;; but "cl.el" was messing some people up (also it's really big). | ||
| 121 | |||
| 122 | (defmacro tar-setf (form val) | ||
| 123 | "A mind-numbingly simple implementation of setf." | ||
| 124 | (let ((mform (macroexpand form (and (boundp 'byte-compile-macro-environment) | ||
| 125 | byte-compile-macro-environment)))) | ||
| 126 | (cond ((symbolp mform) (list 'setq mform val)) | ||
| 127 | ((not (consp mform)) (error "can't setf %s" form)) | ||
| 128 | ((eq (car mform) 'aref) | ||
| 129 | (list 'aset (nth 1 mform) (nth 2 mform) val)) | ||
| 130 | ((eq (car mform) 'car) | ||
| 131 | (list 'setcar (nth 1 mform) val)) | ||
| 132 | ((eq (car mform) 'cdr) | ||
| 133 | (list 'setcdr (nth 1 mform) val)) | ||
| 134 | (t (error "don't know how to setf %s" form))))) | ||
| 135 | |||
| 136 | (defmacro tar-dolist (control &rest body) | ||
| 137 | "syntax: (dolist (var-name list-expr &optional return-value) &body body)" | ||
| 138 | (let ((var (car control)) | ||
| 139 | (init (car (cdr control))) | ||
| 140 | (val (car (cdr (cdr control))))) | ||
| 141 | (list 'let (list (list '_dolist_iterator_ init)) | ||
| 142 | (list 'while '_dolist_iterator_ | ||
| 143 | (cons 'let | ||
| 144 | (cons (list (list var '(car _dolist_iterator_))) | ||
| 145 | (append body | ||
| 146 | (list (list 'setq '_dolist_iterator_ | ||
| 147 | (list 'cdr '_dolist_iterator_))))))) | ||
| 148 | val))) | ||
| 149 | |||
| 150 | (defmacro tar-dotimes (control &rest body) | ||
| 151 | "syntax: (dolist (var-name count-expr &optional return-value) &body body)" | ||
| 152 | (let ((var (car control)) | ||
| 153 | (n (car (cdr control))) | ||
| 154 | (val (car (cdr (cdr control))))) | ||
| 155 | (list 'let (list (list '_dotimes_end_ n) | ||
| 156 | (list var 0)) | ||
| 157 | (cons 'while | ||
| 158 | (cons (list '< var '_dotimes_end_) | ||
| 159 | (append body | ||
| 160 | (list (list 'setq var (list '1+ var)))))) | ||
| 161 | val))) | ||
| 162 | |||
| 163 | |||
| 164 | ;;; down to business. | ||
| 165 | |||
| 166 | (defmacro make-tar-header (name mode uid git size date ck lt ln | ||
| 167 | magic uname gname devmaj devmin) | ||
| 168 | (list 'vector name mode uid git size date ck lt ln | ||
| 169 | magic uname gname devmaj devmin)) | ||
| 170 | |||
| 171 | (defmacro tar-header-name (x) (list 'aref x 0)) | ||
| 172 | (defmacro tar-header-mode (x) (list 'aref x 1)) | ||
| 173 | (defmacro tar-header-uid (x) (list 'aref x 2)) | ||
| 174 | (defmacro tar-header-gid (x) (list 'aref x 3)) | ||
| 175 | (defmacro tar-header-size (x) (list 'aref x 4)) | ||
| 176 | (defmacro tar-header-date (x) (list 'aref x 5)) | ||
| 177 | (defmacro tar-header-checksum (x) (list 'aref x 6)) | ||
| 178 | (defmacro tar-header-link-type (x) (list 'aref x 7)) | ||
| 179 | (defmacro tar-header-link-name (x) (list 'aref x 8)) | ||
| 180 | (defmacro tar-header-magic (x) (list 'aref x 9)) | ||
| 181 | (defmacro tar-header-uname (x) (list 'aref x 10)) | ||
| 182 | (defmacro tar-header-gname (x) (list 'aref x 11)) | ||
| 183 | (defmacro tar-header-dmaj (x) (list 'aref x 12)) | ||
| 184 | (defmacro tar-header-dmin (x) (list 'aref x 13)) | ||
| 185 | |||
| 186 | (defmacro make-tar-desc (data-start tokens) | ||
| 187 | (list 'cons data-start tokens)) | ||
| 188 | |||
| 189 | (defmacro tar-desc-data-start (x) (list 'car x)) | ||
| 190 | (defmacro tar-desc-tokens (x) (list 'cdr x)) | ||
| 191 | |||
| 192 | (defconst tar-name-offset 0) | ||
| 193 | (defconst tar-mode-offset (+ tar-name-offset 100)) | ||
| 194 | (defconst tar-uid-offset (+ tar-mode-offset 8)) | ||
| 195 | (defconst tar-gid-offset (+ tar-uid-offset 8)) | ||
| 196 | (defconst tar-size-offset (+ tar-gid-offset 8)) | ||
| 197 | (defconst tar-time-offset (+ tar-size-offset 12)) | ||
| 198 | (defconst tar-chk-offset (+ tar-time-offset 12)) | ||
| 199 | (defconst tar-linkp-offset (+ tar-chk-offset 8)) | ||
| 200 | (defconst tar-link-offset (+ tar-linkp-offset 1)) | ||
| 201 | ;;; GNU-tar specific slots. | ||
| 202 | (defconst tar-magic-offset (+ tar-link-offset 100)) | ||
| 203 | (defconst tar-uname-offset (+ tar-magic-offset 8)) | ||
| 204 | (defconst tar-gname-offset (+ tar-uname-offset 32)) | ||
| 205 | (defconst tar-dmaj-offset (+ tar-gname-offset 32)) | ||
| 206 | (defconst tar-dmin-offset (+ tar-dmaj-offset 8)) | ||
| 207 | (defconst tar-end-offset (+ tar-dmin-offset 8)) | ||
| 208 | |||
| 209 | (defun tokenize-tar-header-block (string) | ||
| 210 | "Returns a 'tar-header' structure (a list of name, mode, uid, gid, size, | ||
| 211 | write-date, checksum, link-type, and link-name)." | ||
| 212 | (cond ((< (length string) 512) nil) | ||
| 213 | (;(some 'plusp string) ; <-- oops, massive cycle hog! | ||
| 214 | (or (not (= 0 (aref string 0))) ; This will do. | ||
| 215 | (not (= 0 (aref string 101)))) | ||
| 216 | (let* ((name-end (1- tar-mode-offset)) | ||
| 217 | (link-end (1- tar-magic-offset)) | ||
| 218 | (uname-end (1- tar-gname-offset)) | ||
| 219 | (gname-end (1- tar-dmaj-offset)) | ||
| 220 | (link-p (aref string tar-linkp-offset)) | ||
| 221 | (magic-str (substring string tar-magic-offset (1- tar-uname-offset))) | ||
| 222 | (uname-valid-p (or (string= "ustar " magic-str) (string= "GNUtar " magic-str))) | ||
| 223 | name | ||
| 224 | (nulsexp "[^\000]*\000")) | ||
| 225 | (and (string-match nulsexp string tar-name-offset) (setq name-end (min name-end (1- (match-end 0))))) | ||
| 226 | (and (string-match nulsexp string tar-link-offset) (setq link-end (min link-end (1- (match-end 0))))) | ||
| 227 | (and (string-match nulsexp string tar-uname-offset) (setq uname-end (min uname-end (1- (match-end 0))))) | ||
| 228 | (and (string-match nulsexp string tar-gname-offset) (setq gname-end (min gname-end (1- (match-end 0))))) | ||
| 229 | (setq name (substring string tar-name-offset name-end) | ||
| 230 | link-p (if (or (= link-p 0) (= link-p ?0)) | ||
| 231 | nil | ||
| 232 | (- link-p ?0))) | ||
| 233 | (if (and (null link-p) (string-match "/$" name)) (setq link-p 5)) ; directory | ||
| 234 | (make-tar-header | ||
| 235 | name | ||
| 236 | (tar-parse-octal-integer string tar-mode-offset (1- tar-uid-offset)) | ||
| 237 | (tar-parse-octal-integer string tar-uid-offset (1- tar-gid-offset)) | ||
| 238 | (tar-parse-octal-integer string tar-gid-offset (1- tar-size-offset)) | ||
| 239 | (tar-parse-octal-integer string tar-size-offset (1- tar-time-offset)) | ||
| 240 | (tar-parse-octal-integer string tar-time-offset (1- tar-chk-offset)) | ||
| 241 | (tar-parse-octal-integer string tar-chk-offset (1- tar-linkp-offset)) | ||
| 242 | link-p | ||
| 243 | (substring string tar-link-offset link-end) | ||
| 244 | uname-valid-p | ||
| 245 | (and uname-valid-p (substring string tar-uname-offset uname-end)) | ||
| 246 | (and uname-valid-p (substring string tar-gname-offset gname-end)) | ||
| 247 | (tar-parse-octal-integer string tar-dmaj-offset (1- tar-dmin-offset)) | ||
| 248 | (tar-parse-octal-integer string tar-dmin-offset (1- tar-end-offset)) | ||
| 249 | ))) | ||
| 250 | (t 'empty-tar-block))) | ||
| 251 | |||
| 252 | |||
| 253 | (defun tar-parse-octal-integer (string &optional start end) | ||
| 254 | "deletes all your files, and then reboots." | ||
| 255 | (if (null start) (setq start 0)) | ||
| 256 | (if (null end) (setq end (length string))) | ||
| 257 | (if (= (aref string start) 0) | ||
| 258 | 0 | ||
| 259 | (let ((n 0)) | ||
| 260 | (while (< start end) | ||
| 261 | (setq n (if (< (aref string start) ?0) n | ||
| 262 | (+ (* n 8) (- (aref string start) 48))) | ||
| 263 | start (1+ start))) | ||
| 264 | n))) | ||
| 265 | |||
| 266 | (defun tar-parse-octal-integer-safe (string) | ||
| 267 | (let ((L (length string))) | ||
| 268 | (if (= L 0) (error "empty string")) | ||
| 269 | (tar-dotimes (i L) | ||
| 270 | (if (or (< (aref string i) ?0) | ||
| 271 | (> (aref string i) ?7)) | ||
| 272 | (error "'%c' is not an octal digit.")))) | ||
| 273 | (tar-parse-octal-integer string)) | ||
| 274 | |||
| 275 | |||
| 276 | (defun checksum-tar-header-block (string) | ||
| 277 | "Computes and returns a tar-acceptable checksum for this block." | ||
| 278 | (let* ((chk-field-start tar-chk-offset) | ||
| 279 | (chk-field-end (+ chk-field-start 8)) | ||
| 280 | (sum 0) | ||
| 281 | (i 0)) | ||
| 282 | ;; Add up all of the characters except the ones in the checksum field. | ||
| 283 | ;; Add that field as if it were filled with spaces. | ||
| 284 | (while (< i chk-field-start) | ||
| 285 | (setq sum (+ sum (aref string i)) | ||
| 286 | i (1+ i))) | ||
| 287 | (setq i chk-field-end) | ||
| 288 | (while (< i 512) | ||
| 289 | (setq sum (+ sum (aref string i)) | ||
| 290 | i (1+ i))) | ||
| 291 | (+ sum (* 32 8)))) | ||
| 292 | |||
| 293 | (defun check-tar-header-block-checksum (hblock desired-checksum file-name) | ||
| 294 | "Beep and print a warning if the checksum doesn't match." | ||
| 295 | (if (not (= desired-checksum (checksum-tar-header-block hblock))) | ||
| 296 | (progn (beep) (message "Invalid checksum for file %s!" file-name)))) | ||
| 297 | |||
| 298 | (defun recompute-tar-header-block-checksum (hblock) | ||
| 299 | "Modifies the given string to have a valid checksum field." | ||
| 300 | (let* ((chk (checksum-tar-header-block hblock)) | ||
| 301 | (chk-string (format "%6o" chk)) | ||
| 302 | (l (length chk-string))) | ||
| 303 | (aset hblock 154 0) | ||
| 304 | (aset hblock 155 32) | ||
| 305 | (tar-dotimes (i l) (aset hblock (- 153 i) (aref chk-string (- l i 1))))) | ||
| 306 | hblock) | ||
| 307 | |||
| 308 | |||
| 309 | (defun tar-grind-file-mode (mode string start) | ||
| 310 | "Write a \"-rw--r--r-\" representing MODE into STRING beginning at START." | ||
| 311 | (aset string start (if (zerop (logand 256 mode)) ?- ?r)) | ||
| 312 | (aset string (+ start 1) (if (zerop (logand 128 mode)) ?- ?w)) | ||
| 313 | (aset string (+ start 2) (if (zerop (logand 64 mode)) ?- ?x)) | ||
| 314 | (aset string (+ start 3) (if (zerop (logand 32 mode)) ?- ?r)) | ||
| 315 | (aset string (+ start 4) (if (zerop (logand 16 mode)) ?- ?w)) | ||
| 316 | (aset string (+ start 5) (if (zerop (logand 8 mode)) ?- ?x)) | ||
| 317 | (aset string (+ start 6) (if (zerop (logand 4 mode)) ?- ?r)) | ||
| 318 | (aset string (+ start 7) (if (zerop (logand 2 mode)) ?- ?w)) | ||
| 319 | (aset string (+ start 8) (if (zerop (logand 1 mode)) ?- ?x)) | ||
| 320 | (if (zerop (logand 1024 mode)) nil (aset string (+ start 2) ?s)) | ||
| 321 | (if (zerop (logand 2048 mode)) nil (aset string (+ start 5) ?s)) | ||
| 322 | string) | ||
| 323 | |||
| 324 | (defun summarize-tar-header-block (tar-hblock &optional mod-p) | ||
| 325 | "Returns a line similar to the output of 'tar -vtf'." | ||
| 326 | (let ((name (tar-header-name tar-hblock)) | ||
| 327 | (mode (tar-header-mode tar-hblock)) | ||
| 328 | (uid (tar-header-uid tar-hblock)) | ||
| 329 | (gid (tar-header-gid tar-hblock)) | ||
| 330 | (uname (tar-header-uname tar-hblock)) | ||
| 331 | (gname (tar-header-gname tar-hblock)) | ||
| 332 | (size (tar-header-size tar-hblock)) | ||
| 333 | (time (tar-header-date tar-hblock)) | ||
| 334 | (ck (tar-header-checksum tar-hblock)) | ||
| 335 | (link-p (tar-header-link-type tar-hblock)) | ||
| 336 | (link-name (tar-header-link-name tar-hblock)) | ||
| 337 | ) | ||
| 338 | (let* ((left 11) | ||
| 339 | (namew 8) | ||
| 340 | (groupw 8) | ||
| 341 | (sizew 8) | ||
| 342 | (datew 2) | ||
| 343 | (slash (1- (+ left namew))) | ||
| 344 | (lastdigit (+ slash groupw sizew)) | ||
| 345 | (namestart (+ lastdigit datew)) | ||
| 346 | (string (make-string (+ namestart (length name) (if link-p (+ 5 (length link-name)) 0)) 32)) | ||
| 347 | (type (tar-header-link-type tar-hblock))) | ||
| 348 | (aset string 0 (if mod-p ?* ? )) | ||
| 349 | (aset string 1 | ||
| 350 | (cond ((or (eq type nil) (eq type 0)) ?-) | ||
| 351 | ((eq type 1) ?l) ; link | ||
| 352 | ((eq type 2) ?s) ; symlink | ||
| 353 | ((eq type 3) ?c) ; char special | ||
| 354 | ((eq type 4) ?b) ; block special | ||
| 355 | ((eq type 5) ?d) ; directory | ||
| 356 | ((eq type 6) ?p) ; FIFO/pipe | ||
| 357 | ((eq type 20) ?*) ; directory listing | ||
| 358 | ((eq type 29) ?M) ; multivolume continuation | ||
| 359 | ((eq type 35) ?S) ; sparse | ||
| 360 | ((eq type 38) ?V) ; volume header | ||
| 361 | )) | ||
| 362 | (tar-grind-file-mode mode string 2) | ||
| 363 | (setq uid (if (= 0 (length uname)) (int-to-string uid) uname)) | ||
| 364 | (setq gid (if (= 0 (length gname)) (int-to-string gid) gname)) | ||
| 365 | (setq size (int-to-string size)) | ||
| 366 | (tar-dotimes (i (min (1- namew) (length uid))) (aset string (- slash i) (aref uid (- (length uid) i 1)))) | ||
| 367 | (aset string (1+ slash) ?/) | ||
| 368 | (tar-dotimes (i (min (1- groupw) (length gid))) (aset string (+ (+ slash 2) i) (aref gid i))) | ||
| 369 | (tar-dotimes (i (min sizew (length size))) (aset string (- lastdigit i) (aref size (- (length size) i 1)))) | ||
| 370 | ;; ## bloody hell, how do I print an arbitrary date?? | ||
| 371 | (tar-dotimes (i (length name)) (aset string (+ namestart i) (aref name i))) | ||
| 372 | (if (or (eq link-p 1) (eq link-p 2)) | ||
| 373 | (progn | ||
| 374 | (tar-dotimes (i 3) (aset string (+ namestart 1 (length name) i) (aref (if (= link-p 1) "==>" "-->") i))) | ||
| 375 | (tar-dotimes (i (length link-name)) (aset string (+ namestart 5 (length name) i) (aref link-name i))))) | ||
| 376 | string))) | ||
| 377 | |||
| 378 | |||
| 379 | (defun tar-summarize-buffer () | ||
| 380 | "Parse the contents of the tar file in the current buffer, and place a | ||
| 381 | dired-like listing on the front; then narrow to it, so that only that listing | ||
| 382 | is visible (and the real data of the buffer is hidden)." | ||
| 383 | (message "parsing tar file...") | ||
| 384 | (let* ((result '()) | ||
| 385 | (pos 1) | ||
| 386 | (bs (max 1 (- (buffer-size) 1024))) ; always 2+ empty blocks at end. | ||
| 387 | (bs100 (max 1 (/ bs 100))) | ||
| 388 | (tokens nil)) | ||
| 389 | (while (not (eq tokens 'empty-tar-block)) | ||
| 390 | (let* ((hblock (buffer-substring pos (+ pos 512)))) | ||
| 391 | (setq tokens (tokenize-tar-header-block hblock)) | ||
| 392 | (setq pos (+ pos 512)) | ||
| 393 | (message "parsing tar file...%s%%" | ||
| 394 | ;(/ (* pos 100) bs) ; this gets round-off lossage | ||
| 395 | (/ pos bs100) ; this doesn't | ||
| 396 | ) | ||
| 397 | (if (eq tokens 'empty-tar-block) | ||
| 398 | nil | ||
| 399 | (if (null tokens) (error "premature EOF parsing tar file.")) | ||
| 400 | (if (eq (tar-header-link-type tokens) 20) | ||
| 401 | ;; Foo. There's an extra empty block after these. | ||
| 402 | (setq pos (+ pos 512))) | ||
| 403 | (let ((size (tar-header-size tokens))) | ||
| 404 | (if (< size 0) | ||
| 405 | (error "%s has size %s - corrupted." | ||
| 406 | (tar-header-name tokens) size)) | ||
| 407 | ; | ||
| 408 | ; This is just too slow. Don't really need it anyway.... | ||
| 409 | ;(check-tar-header-block-checksum | ||
| 410 | ; hblock (checksum-tar-header-block hblock) | ||
| 411 | ; (tar-header-name tokens)) | ||
| 412 | |||
| 413 | (setq result (cons (make-tar-desc pos tokens) result)) | ||
| 414 | |||
| 415 | (if (and (null (tar-header-link-type tokens)) | ||
| 416 | (> size 0)) | ||
| 417 | (setq pos | ||
| 418 | (+ pos 512 (ash (ash (1- size) -9) 9)) ; this works | ||
| 419 | ;(+ pos (+ size (- 512 (rem (1- size) 512)))) ; this doesn't | ||
| 420 | )) | ||
| 421 | )))) | ||
| 422 | (make-local-variable 'tar-parse-info) | ||
| 423 | (setq tar-parse-info (nreverse result))) | ||
| 424 | (save-excursion | ||
| 425 | (goto-char (point-min)) | ||
| 426 | (let ((buffer-read-only nil)) | ||
| 427 | (tar-dolist (tar-desc tar-parse-info) | ||
| 428 | (insert-string | ||
| 429 | (summarize-tar-header-block (tar-desc-tokens tar-desc))) | ||
| 430 | (insert-string "\n")) | ||
| 431 | (make-local-variable 'tar-header-offset) | ||
| 432 | (setq tar-header-offset (point)) | ||
| 433 | (narrow-to-region 1 tar-header-offset) | ||
| 434 | (set-buffer-modified-p nil))) | ||
| 435 | (message "parsing tar file...done.")) | ||
| 436 | |||
| 437 | |||
| 438 | (defvar tar-mode-map nil "*Local keymap for tar-mode listings.") | ||
| 439 | |||
| 440 | (if tar-mode-map | ||
| 441 | nil | ||
| 442 | (setq tar-mode-map (make-keymap)) | ||
| 443 | (suppress-keymap tar-mode-map) | ||
| 444 | (define-key tar-mode-map " " 'tar-next-line) | ||
| 445 | (define-key tar-mode-map "c" 'tar-copy) | ||
| 446 | (define-key tar-mode-map "d" 'tar-flag-deleted) | ||
| 447 | (define-key tar-mode-map "\^D" 'tar-flag-deleted) | ||
| 448 | (define-key tar-mode-map "e" 'tar-extract) | ||
| 449 | (define-key tar-mode-map "f" 'tar-extract) | ||
| 450 | (define-key tar-mode-map "g" 'revert-buffer) | ||
| 451 | (define-key tar-mode-map "h" 'describe-mode) | ||
| 452 | (define-key tar-mode-map "n" 'tar-next-line) | ||
| 453 | (define-key tar-mode-map "\^N" 'tar-next-line) | ||
| 454 | (define-key tar-mode-map "o" 'tar-extract-other-window) | ||
| 455 | (define-key tar-mode-map "\^C" 'tar-copy) | ||
| 456 | (define-key tar-mode-map "p" 'tar-previous-line) | ||
| 457 | (define-key tar-mode-map "\^P" 'tar-previous-line) | ||
| 458 | (define-key tar-mode-map "r" 'tar-rename-entry) | ||
| 459 | (define-key tar-mode-map "u" 'tar-unflag) | ||
| 460 | (define-key tar-mode-map "v" 'tar-view) | ||
| 461 | (define-key tar-mode-map "x" 'tar-expunge) | ||
| 462 | (define-key tar-mode-map "\177" 'tar-unflag-backwards) | ||
| 463 | (define-key tar-mode-map "E" 'tar-extract-other-window) | ||
| 464 | (define-key tar-mode-map "M" 'tar-chmod-entry) | ||
| 465 | (define-key tar-mode-map "G" 'tar-chgrp-entry) | ||
| 466 | (define-key tar-mode-map "O" 'tar-chown-entry) | ||
| 467 | ) | ||
| 468 | |||
| 469 | ;; tar mode is suitable only for specially formatted data. | ||
| 470 | (put 'tar-mode 'mode-class 'special) | ||
| 471 | (put 'tar-subfile-mode 'mode-class 'special) | ||
| 472 | |||
| 473 | (defun tar-mode () | ||
| 474 | "Major mode for viewing a tar file as a dired-like listing of its contents. | ||
| 475 | You can move around using the usual cursor motion commands. | ||
| 476 | Letters no longer insert themselves. | ||
| 477 | Type 'e' to pull a file out of the tar file and into its own buffer. | ||
| 478 | Type 'c' to copy an entry from the tar file into another file on disk. | ||
| 479 | |||
| 480 | If you edit a sub-file of this archive (as with the 'e' command) and | ||
| 481 | save it with Control-X Control-S, the contents of that buffer will be | ||
| 482 | saved back into the tar-file buffer; in this way you can edit a file | ||
| 483 | inside of a tar archive without extracting it and re-archiving it. | ||
| 484 | |||
| 485 | See also: variables tar-update-datestamp and tar-anal-blocksize. | ||
| 486 | \\{tar-mode-map}" | ||
| 487 | ;; this is not interactive because you shouldn't be turning this | ||
| 488 | ;; mode on and off. You can corrupt things that way. | ||
| 489 | (make-local-variable 'tar-header-offset) | ||
| 490 | (make-local-variable 'tar-parse-info) | ||
| 491 | (make-local-variable 'require-final-newline) | ||
| 492 | (setq require-final-newline nil) ; binary data, dude... | ||
| 493 | (make-local-variable 'revert-buffer-function) | ||
| 494 | (setq revert-buffer-function 'tar-mode-revert) | ||
| 495 | (setq major-mode 'tar-mode) | ||
| 496 | (setq mode-name "Tar") | ||
| 497 | (use-local-map tar-mode-map) | ||
| 498 | (auto-save-mode 0) | ||
| 499 | (widen) | ||
| 500 | (if (and (boundp 'tar-header-offset) tar-header-offset) | ||
| 501 | (narrow-to-region 1 tar-header-offset) | ||
| 502 | (tar-summarize-buffer)) | ||
| 503 | (run-hooks 'tar-mode-hook) | ||
| 504 | ) | ||
| 505 | |||
| 506 | |||
| 507 | (defun tar-subfile-mode (p) | ||
| 508 | "Minor mode for editing an element of a tar-file. | ||
| 509 | This mode redefines ^X^S to save the current buffer back into its | ||
| 510 | associated tar-file buffer. You must save that buffer to actually | ||
| 511 | save your changes to disk." | ||
| 512 | (interactive "P") | ||
| 513 | (or (and (boundp 'superior-tar-buffer) superior-tar-buffer) | ||
| 514 | (error "This buffer is not an element of a tar file.")) | ||
| 515 | (or (assq 'tar-subfile-mode minor-mode-alist) | ||
| 516 | (setq minor-mode-alist (append minor-mode-alist | ||
| 517 | (list '(tar-subfile-mode | ||
| 518 | " TarFile"))))) | ||
| 519 | (make-local-variable 'tar-subfile-mode) | ||
| 520 | (setq tar-subfile-mode | ||
| 521 | (if (null p) | ||
| 522 | (not tar-subfile-mode) | ||
| 523 | (> (prefix-numeric-value p) 0))) | ||
| 524 | (cond (tar-subfile-mode | ||
| 525 | ;; copy the local keymap so that we don't accidentally | ||
| 526 | ;; alter a keymap like 'lisp-mode-map' which is shared | ||
| 527 | ;; by all buffers in that mode. | ||
| 528 | (let ((m (current-local-map))) | ||
| 529 | (if m (use-local-map (copy-keymap m)))) | ||
| 530 | (local-set-key "\^X\^S" 'tar-subfile-save-buffer) | ||
| 531 | ;; turn off auto-save. | ||
| 532 | (auto-save-mode nil) | ||
| 533 | (setq buffer-auto-save-file-name nil) | ||
| 534 | (run-hooks 'tar-subfile-mode-hook)) | ||
| 535 | (t (local-set-key "\^X\^S" 'save-buffer))) | ||
| 536 | ) | ||
| 537 | |||
| 538 | |||
| 539 | (defun tar-mode-revert (&optional no-autosave no-confirm) | ||
| 540 | "Revert this buffer and turn on tar mode again, to re-compute the | ||
| 541 | directory listing." | ||
| 542 | (setq tar-header-offset nil) | ||
| 543 | (let ((revert-buffer-function nil)) | ||
| 544 | (revert-buffer t no-confirm) | ||
| 545 | (widen)) | ||
| 546 | (tar-mode)) | ||
| 547 | |||
| 548 | |||
| 549 | (defun tar-next-line (p) | ||
| 550 | (interactive "p") | ||
| 551 | (forward-line p) | ||
| 552 | (if (eobp) nil (forward-char 36))) | ||
| 553 | |||
| 554 | (defun tar-previous-line (p) | ||
| 555 | (interactive "p") | ||
| 556 | (tar-next-line (- p))) | ||
| 557 | |||
| 558 | (defun tar-current-descriptor (&optional noerror) | ||
| 559 | "Returns the tar-descriptor of the current line, or signals an error." | ||
| 560 | ;; I wish lines had plists, like in ZMACS... | ||
| 561 | (or (nth (count-lines (point-min) | ||
| 562 | (save-excursion (beginning-of-line) (point))) | ||
| 563 | tar-parse-info) | ||
| 564 | (if noerror | ||
| 565 | nil | ||
| 566 | (error "This line does not describe a tar-file entry.")))) | ||
| 567 | |||
| 568 | |||
| 569 | (defun tar-extract (&optional other-window-p) | ||
| 570 | "*In tar-mode, extract this entry of the tar file into its own buffer." | ||
| 571 | (interactive) | ||
| 572 | (let* ((view-p (eq other-window-p 'view)) | ||
| 573 | (descriptor (tar-current-descriptor)) | ||
| 574 | (tokens (tar-desc-tokens descriptor)) | ||
| 575 | (name (tar-header-name tokens)) | ||
| 576 | (size (tar-header-size tokens)) | ||
| 577 | (link-p (tar-header-link-type tokens)) | ||
| 578 | (start (+ (tar-desc-data-start descriptor) tar-header-offset -1)) | ||
| 579 | (end (+ start size))) | ||
| 580 | (if link-p | ||
| 581 | (error "This is a %s, not a real file." | ||
| 582 | (cond ((eq link-p 5) "directory") | ||
| 583 | ((eq link-p 20) "tar directory header") | ||
| 584 | ((eq link-p 29) "multivolume-continuation") | ||
| 585 | ((eq link-p 35) "sparse entry") | ||
| 586 | ((eq link-p 38) "volume header") | ||
| 587 | (t "link")))) | ||
| 588 | (if (zerop size) (error "This is a zero-length file.")) | ||
| 589 | (let* ((tar-buffer (current-buffer)) | ||
| 590 | (bufname (concat (file-name-nondirectory name) | ||
| 591 | " (" name " in " | ||
| 592 | (file-name-nondirectory (buffer-file-name)) | ||
| 593 | ")")) | ||
| 594 | (read-only-p (or buffer-read-only view-p)) | ||
| 595 | (buffer (get-buffer bufname)) | ||
| 596 | (just-created nil)) | ||
| 597 | (if buffer | ||
| 598 | nil | ||
| 599 | (setq buffer (get-buffer-create bufname)) | ||
| 600 | (setq just-created t) | ||
| 601 | (unwind-protect | ||
| 602 | (progn | ||
| 603 | (widen) | ||
| 604 | (save-excursion | ||
| 605 | (set-buffer buffer) | ||
| 606 | (insert-buffer-substring tar-buffer start end) | ||
| 607 | (goto-char 0) | ||
| 608 | (set-visited-file-name name) ; give it a name to decide mode. | ||
| 609 | (normal-mode) ; pick a mode. | ||
| 610 | (set-visited-file-name nil) ; nuke the name - not meaningful. | ||
| 611 | (rename-buffer bufname) | ||
| 612 | |||
| 613 | (make-local-variable 'superior-tar-buffer) | ||
| 614 | (make-local-variable 'superior-tar-descriptor) | ||
| 615 | (setq superior-tar-buffer tar-buffer) | ||
| 616 | (setq superior-tar-descriptor descriptor) | ||
| 617 | (tar-subfile-mode 1) | ||
| 618 | |||
| 619 | (setq buffer-read-only read-only-p) | ||
| 620 | (set-buffer-modified-p nil)) | ||
| 621 | (set-buffer tar-buffer)) | ||
| 622 | (narrow-to-region 1 tar-header-offset))) | ||
| 623 | (if view-p | ||
| 624 | (progn | ||
| 625 | (view-buffer buffer) | ||
| 626 | (and just-created (kill-buffer buffer))) | ||
| 627 | (if other-window-p | ||
| 628 | (switch-to-buffer-other-window buffer) | ||
| 629 | (switch-to-buffer buffer)))))) | ||
| 630 | |||
| 631 | |||
| 632 | (defun tar-extract-other-window () | ||
| 633 | "*In tar-mode, extract this entry of the tar file into its own buffer." | ||
| 634 | (interactive) | ||
| 635 | (tar-extract t)) | ||
| 636 | |||
| 637 | (defun tar-view () | ||
| 638 | "*In tar-mode, view the tar file entry on this line." | ||
| 639 | (interactive) | ||
| 640 | (tar-extract 'view)) | ||
| 641 | |||
| 642 | |||
| 643 | (defun tar-read-file-name (&optional prompt) | ||
| 644 | "Calls read-file-name, with the default being the file of the current | ||
| 645 | tar-file descriptor." | ||
| 646 | (or prompt (setq prompt "Copy to: ")) | ||
| 647 | (let* ((default-file (expand-file-name | ||
| 648 | (tar-header-name (tar-desc-tokens | ||
| 649 | (tar-current-descriptor))))) | ||
| 650 | (target (expand-file-name | ||
| 651 | (read-file-name prompt | ||
| 652 | (file-name-directory default-file) | ||
| 653 | default-file nil)))) | ||
| 654 | (if (or (string= "" (file-name-nondirectory target)) | ||
| 655 | (file-directory-p target)) | ||
| 656 | (setq target (concat (if (string-match "/$" target) | ||
| 657 | (substring target 0 (1- (match-end 0))) | ||
| 658 | target) | ||
| 659 | "/" | ||
| 660 | (file-name-nondirectory default-file)))) | ||
| 661 | target)) | ||
| 662 | |||
| 663 | |||
| 664 | (defun tar-copy (&optional to-file) | ||
| 665 | "*In tar-mode, extract this entry of the tar file into a file on disk. | ||
| 666 | If TO-FILE is not supplied, it is prompted for, defaulting to the name of | ||
| 667 | the current tar-entry." | ||
| 668 | (interactive (list (tar-read-file-name))) | ||
| 669 | (let* ((descriptor (tar-current-descriptor)) | ||
| 670 | (tokens (tar-desc-tokens descriptor)) | ||
| 671 | (name (tar-header-name tokens)) | ||
| 672 | (size (tar-header-size tokens)) | ||
| 673 | (link-p (tar-header-link-type tokens)) | ||
| 674 | (start (+ (tar-desc-data-start descriptor) tar-header-offset -1)) | ||
| 675 | (end (+ start size))) | ||
| 676 | (if link-p (error "This is a link, not a real file.")) | ||
| 677 | (if (zerop size) (error "This is a zero-length file.")) | ||
| 678 | (let* ((tar-buffer (current-buffer)) | ||
| 679 | buffer) | ||
| 680 | (unwind-protect | ||
| 681 | (progn | ||
| 682 | (setq buffer (generate-new-buffer "*tar-copy-tmp*")) | ||
| 683 | (widen) | ||
| 684 | (save-excursion | ||
| 685 | (set-buffer buffer) | ||
| 686 | (insert-buffer-substring tar-buffer start end) | ||
| 687 | (set-buffer-modified-p nil) ; in case we abort | ||
| 688 | (write-file to-file) | ||
| 689 | (message "Copied tar entry %s to %s" name to-file) | ||
| 690 | (set-buffer tar-buffer))) | ||
| 691 | (narrow-to-region 1 tar-header-offset) | ||
| 692 | (if buffer (kill-buffer buffer))) | ||
| 693 | ))) | ||
| 694 | |||
| 695 | |||
| 696 | (defun tar-flag-deleted (p &optional unflag) | ||
| 697 | "*In tar mode, mark this sub-file to be deleted from the tar file. | ||
| 698 | With a prefix argument, mark that many files." | ||
| 699 | (interactive "p") | ||
| 700 | (beginning-of-line) | ||
| 701 | (tar-dotimes (i (if (< p 0) (- p) p)) | ||
| 702 | (if (tar-current-descriptor unflag) ; barf if we're not on an entry-line. | ||
| 703 | (progn | ||
| 704 | (delete-char 1) | ||
| 705 | (insert (if unflag " " "D")))) | ||
| 706 | (forward-line (if (< p 0) -1 1))) | ||
| 707 | (if (eobp) nil (forward-char 36))) | ||
| 708 | |||
| 709 | (defun tar-unflag (p) | ||
| 710 | "*In tar mode, un-mark this sub-file if it is marked to be deleted. | ||
| 711 | With a prefix argument, un-mark that many files forward." | ||
| 712 | (interactive "p") | ||
| 713 | (tar-flag-deleted p t)) | ||
| 714 | |||
| 715 | (defun tar-unflag-backwards (p) | ||
| 716 | "*In tar mode, un-mark this sub-file if it is marked to be deleted. | ||
| 717 | With a prefix argument, un-mark that many files backward." | ||
| 718 | (interactive "p") | ||
| 719 | (tar-flag-deleted (- p) t)) | ||
| 720 | |||
| 721 | |||
| 722 | (defun tar-expunge-internal () | ||
| 723 | "Expunge the tar-entry specified by the current line." | ||
| 724 | (let* ((descriptor (tar-current-descriptor)) | ||
| 725 | (tokens (tar-desc-tokens descriptor)) | ||
| 726 | (line (tar-desc-data-start descriptor)) | ||
| 727 | (name (tar-header-name tokens)) | ||
| 728 | (size (tar-header-size tokens)) | ||
| 729 | (link-p (tar-header-link-type tokens)) | ||
| 730 | (start (tar-desc-data-start descriptor)) | ||
| 731 | (following-descs (cdr (memq descriptor tar-parse-info)))) | ||
| 732 | (if link-p (setq size 0)) ; size lies for hard-links. | ||
| 733 | ;; | ||
| 734 | ;; delete the current line... | ||
| 735 | (beginning-of-line) | ||
| 736 | (let ((line-start (point))) | ||
| 737 | (end-of-line) (forward-char) | ||
| 738 | (let ((line-len (- (point) line-start))) | ||
| 739 | (delete-region line-start (point)) | ||
| 740 | ;; | ||
| 741 | ;; decrement the header-pointer to be in synch... | ||
| 742 | (setq tar-header-offset (- tar-header-offset line-len)))) | ||
| 743 | ;; | ||
| 744 | ;; delete the data pointer... | ||
| 745 | (setq tar-parse-info (delq descriptor tar-parse-info)) | ||
| 746 | ;; | ||
| 747 | ;; delete the data from inside the file... | ||
| 748 | (widen) | ||
| 749 | (let* ((data-start (+ start tar-header-offset -513)) | ||
| 750 | (data-end (+ data-start 512 (ash (ash (+ size 511) -9) 9)))) | ||
| 751 | (delete-region data-start data-end) | ||
| 752 | ;; | ||
| 753 | ;; and finally, decrement the start-pointers of all following | ||
| 754 | ;; entries in the archive. This is a pig when deleting a bunch | ||
| 755 | ;; of files at once - we could optimize this to only do the | ||
| 756 | ;; iteration over the files that remain, or only iterate up to | ||
| 757 | ;; the next file to be deleted. | ||
| 758 | (let ((data-length (- data-end data-start))) | ||
| 759 | (tar-dolist (desc following-descs) | ||
| 760 | (tar-setf (tar-desc-data-start desc) | ||
| 761 | (- (tar-desc-data-start desc) data-length)))) | ||
| 762 | )) | ||
| 763 | (narrow-to-region 1 tar-header-offset)) | ||
| 764 | |||
| 765 | |||
| 766 | (defun tar-expunge (&optional noconfirm) | ||
| 767 | "*In tar-mode, delete all the archived files flagged for deletion. | ||
| 768 | This does not modify the disk image; you must save the tar file itself | ||
| 769 | for this to be permanent." | ||
| 770 | (interactive) | ||
| 771 | (if (or noconfirm | ||
| 772 | (y-or-n-p "expunge files marked for deletion? ")) | ||
| 773 | (let ((n 0)) | ||
| 774 | (save-excursion | ||
| 775 | (goto-char 0) | ||
| 776 | (while (not (eobp)) | ||
| 777 | (if (looking-at "D") | ||
| 778 | (progn (tar-expunge-internal) | ||
| 779 | (setq n (1+ n))) | ||
| 780 | (forward-line 1))) | ||
| 781 | ;; after doing the deletions, add any padding that may be necessary. | ||
| 782 | (tar-pad-to-blocksize) | ||
| 783 | (narrow-to-region 1 tar-header-offset) | ||
| 784 | ) | ||
| 785 | (if (zerop n) | ||
| 786 | (message "nothing to expunge.") | ||
| 787 | (message "%s expunged. Be sure to save this buffer." n))))) | ||
| 788 | |||
| 789 | |||
| 790 | (defun tar-clear-modification-flags () | ||
| 791 | "remove the stars at the beginning of each line." | ||
| 792 | (save-excursion | ||
| 793 | (goto-char 0) | ||
| 794 | (while (< (point) tar-header-offset) | ||
| 795 | (if (looking-at "*") | ||
| 796 | (progn (delete-char 1) (insert " "))) | ||
| 797 | (forward-line 1)))) | ||
| 798 | |||
| 799 | |||
| 800 | (defun tar-chown-entry (new-uid) | ||
| 801 | "*Change the user-id associated with this entry in the tar file. | ||
| 802 | If this tar file was written by GNU tar, then you will be able to edit | ||
| 803 | the user id as a string; otherwise, you must edit it as a number. | ||
| 804 | You can force editing as a number by calling this with a prefix arg. | ||
| 805 | This does not modify the disk image; you must save the tar file itself | ||
| 806 | for this to be permanent." | ||
| 807 | (interactive (list | ||
| 808 | (let ((tokens (tar-desc-tokens (tar-current-descriptor)))) | ||
| 809 | (if (or current-prefix-arg | ||
| 810 | (not (tar-header-magic tokens))) | ||
| 811 | (let (n) | ||
| 812 | (while (not (numberp (setq n (read-minibuffer | ||
| 813 | "New UID number: " | ||
| 814 | (format "%s" (tar-header-uid tokens))))))) | ||
| 815 | n) | ||
| 816 | (read-string "New UID string: " (tar-header-uname tokens)))))) | ||
| 817 | (cond ((stringp new-uid) | ||
| 818 | (tar-setf (tar-header-uname (tar-desc-tokens (tar-current-descriptor))) | ||
| 819 | new-uid) | ||
| 820 | (tar-alter-one-field tar-uname-offset (concat new-uid "\000"))) | ||
| 821 | (t | ||
| 822 | (tar-setf (tar-header-uid (tar-desc-tokens (tar-current-descriptor))) | ||
| 823 | new-uid) | ||
| 824 | (tar-alter-one-field tar-uid-offset | ||
| 825 | (concat (substring (format "%6o" new-uid) 0 6) "\000 "))))) | ||
| 826 | |||
| 827 | |||
| 828 | (defun tar-chgrp-entry (new-gid) | ||
| 829 | "*Change the group-id associated with this entry in the tar file. | ||
| 830 | If this tar file was written by GNU tar, then you will be able to edit | ||
| 831 | the group id as a string; otherwise, you must edit it as a number. | ||
| 832 | You can force editing as a number by calling this with a prefix arg. | ||
| 833 | This does not modify the disk image; you must save the tar file itself | ||
| 834 | for this to be permanent." | ||
| 835 | (interactive (list | ||
| 836 | (let ((tokens (tar-desc-tokens (tar-current-descriptor)))) | ||
| 837 | (if (or current-prefix-arg | ||
| 838 | (not (tar-header-magic tokens))) | ||
| 839 | (let (n) | ||
| 840 | (while (not (numberp (setq n (read-minibuffer | ||
| 841 | "New GID number: " | ||
| 842 | (format "%s" (tar-header-gid tokens))))))) | ||
| 843 | n) | ||
| 844 | (read-string "New GID string: " (tar-header-gname tokens)))))) | ||
| 845 | (cond ((stringp new-gid) | ||
| 846 | (tar-setf (tar-header-gname (tar-desc-tokens (tar-current-descriptor))) | ||
| 847 | new-gid) | ||
| 848 | (tar-alter-one-field tar-gname-offset | ||
| 849 | (concat new-gid "\000"))) | ||
| 850 | (t | ||
| 851 | (tar-setf (tar-header-gid (tar-desc-tokens (tar-current-descriptor))) | ||
| 852 | new-gid) | ||
| 853 | (tar-alter-one-field tar-gid-offset | ||
| 854 | (concat (substring (format "%6o" new-gid) 0 6) "\000 "))))) | ||
| 855 | |||
| 856 | (defun tar-rename-entry (new-name) | ||
| 857 | "*Change the name associated with this entry in the tar file. | ||
| 858 | This does not modify the disk image; you must save the tar file itself | ||
| 859 | for this to be permanent." | ||
| 860 | (interactive | ||
| 861 | (list (read-string "New name: " | ||
| 862 | (tar-header-name (tar-desc-tokens (tar-current-descriptor)))))) | ||
| 863 | (if (string= "" new-name) (error "zero length name.")) | ||
| 864 | (if (> (length new-name) 98) (error "name too long.")) | ||
| 865 | (tar-setf (tar-header-name (tar-desc-tokens (tar-current-descriptor))) | ||
| 866 | new-name) | ||
| 867 | (tar-alter-one-field 0 | ||
| 868 | (substring (concat new-name (make-string 99 0)) 0 99))) | ||
| 869 | |||
| 870 | |||
| 871 | (defun tar-chmod-entry (new-mode) | ||
| 872 | "*Change the protection bits associated with this entry in the tar file. | ||
| 873 | This does not modify the disk image; you must save the tar file itself | ||
| 874 | for this to be permanent." | ||
| 875 | (interactive (list (tar-parse-octal-integer-safe | ||
| 876 | (read-string "New protection (octal): ")))) | ||
| 877 | (tar-setf (tar-header-mode (tar-desc-tokens (tar-current-descriptor))) | ||
| 878 | new-mode) | ||
| 879 | (tar-alter-one-field tar-mode-offset | ||
| 880 | (concat (substring (format "%6o" new-mode) 0 6) "\000 "))) | ||
| 881 | |||
| 882 | |||
| 883 | (defun tar-alter-one-field (data-position new-data-string) | ||
| 884 | (let* ((descriptor (tar-current-descriptor)) | ||
| 885 | (tokens (tar-desc-tokens descriptor))) | ||
| 886 | (unwind-protect | ||
| 887 | (save-excursion | ||
| 888 | ;; | ||
| 889 | ;; update the header-line. | ||
| 890 | (beginning-of-line) | ||
| 891 | (let ((p (point))) | ||
| 892 | (forward-line 1) | ||
| 893 | (delete-region p (point)) | ||
| 894 | (insert (summarize-tar-header-block tokens) "\n") | ||
| 895 | (setq tar-header-offset (point-max))) | ||
| 896 | |||
| 897 | (widen) | ||
| 898 | (let* ((start (+ (tar-desc-data-start descriptor) tar-header-offset -513))) | ||
| 899 | ;; | ||
| 900 | ;; delete the old field and insert a new one. | ||
| 901 | (goto-char (+ start data-position)) | ||
| 902 | (delete-region (point) (+ (point) (length new-data-string))) ; <-- | ||
| 903 | (insert new-data-string) ; <-- | ||
| 904 | ;; | ||
| 905 | ;; compute a new checksum and insert it. | ||
| 906 | (let ((chk (checksum-tar-header-block | ||
| 907 | (buffer-substring start (+ start 512))))) | ||
| 908 | (goto-char (+ start tar-chk-offset)) | ||
| 909 | (delete-region (point) (+ (point) 8)) | ||
| 910 | (insert (format "%6o" chk)) | ||
| 911 | (insert 0) | ||
| 912 | (insert ? ) | ||
| 913 | (tar-setf (tar-header-checksum tokens) chk) | ||
| 914 | ;; | ||
| 915 | ;; ok, make sure we didn't botch it. | ||
| 916 | (check-tar-header-block-checksum | ||
| 917 | (buffer-substring start (+ start 512)) | ||
| 918 | chk (tar-header-name tokens)) | ||
| 919 | ))) | ||
| 920 | (narrow-to-region 1 tar-header-offset)))) | ||
| 921 | |||
| 922 | |||
| 923 | (defun tar-subfile-save-buffer () | ||
| 924 | "In tar subfile mode, write this buffer back into its parent tar-file buffer. | ||
| 925 | This doesn't write anything to disk - you must save the parent tar-file buffer | ||
| 926 | to make your changes permanent." | ||
| 927 | (interactive) | ||
| 928 | (if (not (and (boundp 'superior-tar-buffer) superior-tar-buffer)) | ||
| 929 | (error "this buffer has no superior tar file buffer.")) | ||
| 930 | (if (not (and (boundp 'superior-tar-descriptor) superior-tar-descriptor)) | ||
| 931 | (error "this buffer doesn't have an index into its superior tar file!")) | ||
| 932 | (save-excursion | ||
| 933 | (let ((subfile (current-buffer)) | ||
| 934 | (subfile-size (buffer-size)) | ||
| 935 | (descriptor superior-tar-descriptor)) | ||
| 936 | (set-buffer superior-tar-buffer) | ||
| 937 | (let* ((tokens (tar-desc-tokens descriptor)) | ||
| 938 | (start (tar-desc-data-start descriptor)) | ||
| 939 | (name (tar-header-name tokens)) | ||
| 940 | (size (tar-header-size tokens)) | ||
| 941 | (size-pad (ash (ash (+ size 511) -9) 9)) | ||
| 942 | (head (memq descriptor tar-parse-info)) | ||
| 943 | (following-descs (cdr head))) | ||
| 944 | (if (not head) | ||
| 945 | (error "Can't find this tar file entry in its parent tar file!")) | ||
| 946 | (unwind-protect | ||
| 947 | (save-excursion | ||
| 948 | (widen) | ||
| 949 | ;; delete the old data... | ||
| 950 | (let* ((data-start (+ start tar-header-offset -1)) | ||
| 951 | (data-end (+ data-start (ash (ash (+ size 511) -9) 9)))) | ||
| 952 | (delete-region data-start data-end) | ||
| 953 | ;; insert the new data... | ||
| 954 | (goto-char data-start) | ||
| 955 | (insert-buffer subfile) | ||
| 956 | ;; | ||
| 957 | ;; pad the new data out to a multiple of 512... | ||
| 958 | (let ((subfile-size-pad (ash (ash (+ subfile-size 511) -9) 9))) | ||
| 959 | (goto-char (+ data-start subfile-size)) | ||
| 960 | (insert (make-string (- subfile-size-pad subfile-size) 0)) | ||
| 961 | ;; | ||
| 962 | ;; update the data pointer of this and all following files... | ||
| 963 | (tar-setf (tar-header-size tokens) subfile-size) | ||
| 964 | (let ((difference (- subfile-size-pad size-pad))) | ||
| 965 | (tar-dolist (desc following-descs) | ||
| 966 | (tar-setf (tar-desc-data-start desc) | ||
| 967 | (+ (tar-desc-data-start desc) difference)))) | ||
| 968 | ;; | ||
| 969 | ;; Update the size field in the header block. | ||
| 970 | (let ((header-start (- data-start 512))) | ||
| 971 | (goto-char (+ header-start tar-size-offset)) | ||
| 972 | (delete-region (point) (+ (point) 12)) | ||
| 973 | (insert (format "%11o" subfile-size)) | ||
| 974 | (insert ? ) | ||
| 975 | ;; | ||
| 976 | ;; Maybe update the datestamp. | ||
| 977 | (if (not tar-update-datestamp) | ||
| 978 | nil | ||
| 979 | (goto-char (+ header-start tar-time-offset)) | ||
| 980 | (delete-region (point) (+ (point) 12)) | ||
| 981 | (insert (format "%11o" 0)) ; ## oops - how to get it?? | ||
| 982 | (insert ? )) | ||
| 983 | ;; | ||
| 984 | ;; compute a new checksum and insert it. | ||
| 985 | (let ((chk (checksum-tar-header-block | ||
| 986 | (buffer-substring header-start data-start)))) | ||
| 987 | (goto-char (+ header-start tar-chk-offset)) | ||
| 988 | (delete-region (point) (+ (point) 8)) | ||
| 989 | (insert (format "%6o" chk)) | ||
| 990 | (insert 0) | ||
| 991 | (insert ? ) | ||
| 992 | (tar-setf (tar-header-checksum tokens) chk))) | ||
| 993 | ;; | ||
| 994 | ;; alter the descriptor-line... | ||
| 995 | ;; | ||
| 996 | (let ((position (- (length tar-parse-info) (length head)))) | ||
| 997 | (goto-char 1) | ||
| 998 | (next-line position) | ||
| 999 | (beginning-of-line) | ||
| 1000 | (let ((p (point)) | ||
| 1001 | (m (set-marker (make-marker) tar-header-offset))) | ||
| 1002 | (forward-line 1) | ||
| 1003 | (delete-region p (point)) | ||
| 1004 | (insert-before-markers (summarize-tar-header-block tokens t) "\n") | ||
| 1005 | (setq tar-header-offset (marker-position m))) | ||
| 1006 | ))) | ||
| 1007 | ;; after doing the insertion, add any final padding that may be necessary. | ||
| 1008 | (tar-pad-to-blocksize)) | ||
| 1009 | (narrow-to-region 1 tar-header-offset))) | ||
| 1010 | (set-buffer-modified-p t) ; mark the tar file as modified | ||
| 1011 | (set-buffer subfile) | ||
| 1012 | (set-buffer-modified-p nil) ; mark the tar subfile as unmodified | ||
| 1013 | (message "saved into tar-buffer \"%s\" - remember to save that buffer!" | ||
| 1014 | (buffer-name superior-tar-buffer)) | ||
| 1015 | ))) | ||
| 1016 | |||
| 1017 | |||
| 1018 | (defun tar-pad-to-blocksize () | ||
| 1019 | "If we are being anal about tar file blocksizes, fix up the current buffer. | ||
| 1020 | Leaves the region wide." | ||
| 1021 | (if (null tar-anal-blocksize) | ||
| 1022 | nil | ||
| 1023 | (widen) | ||
| 1024 | (let* ((last-desc (nth (1- (length tar-parse-info)) tar-parse-info)) | ||
| 1025 | (start (tar-desc-data-start last-desc)) | ||
| 1026 | (tokens (tar-desc-tokens last-desc)) | ||
| 1027 | (link-p (tar-header-link-type tokens)) | ||
| 1028 | (size (if link-p 0 (tar-header-size tokens))) | ||
| 1029 | (data-end (+ start size)) | ||
| 1030 | (bbytes (ash tar-anal-blocksize 9)) | ||
| 1031 | (pad-to (+ bbytes (* bbytes (/ (1- data-end) bbytes)))) | ||
| 1032 | (buffer-read-only nil) ; ## | ||
| 1033 | ) | ||
| 1034 | ;; If the padding after the last data is too long, delete some; | ||
| 1035 | ;; else insert some until we are padded out to the right number of blocks. | ||
| 1036 | ;; | ||
| 1037 | (goto-char (+ (or tar-header-offset 0) data-end)) | ||
| 1038 | (if (> (1+ (buffer-size)) (+ (or tar-header-offset 0) pad-to)) | ||
| 1039 | (delete-region (+ (or tar-header-offset 0) pad-to) (1+ (buffer-size))) | ||
| 1040 | (insert (make-string (- (+ (or tar-header-offset 0) pad-to) | ||
| 1041 | (1+ (buffer-size))) | ||
| 1042 | 0))) | ||
| 1043 | ))) | ||
| 1044 | |||
| 1045 | |||
| 1046 | (defun maybe-write-tar-file () | ||
| 1047 | "Used as a write-file-hook to write tar-files out correctly." | ||
| 1048 | ;; | ||
| 1049 | ;; If the current buffer is in tar-mode and has its header-offset set, | ||
| 1050 | ;; only write out the part of the file after the header-offset. | ||
| 1051 | ;; | ||
| 1052 | (if (and (eq major-mode 'tar-mode) | ||
| 1053 | (and (boundp 'tar-header-offset) tar-header-offset)) | ||
| 1054 | (unwind-protect | ||
| 1055 | (save-excursion | ||
| 1056 | (tar-clear-modification-flags) | ||
| 1057 | (widen) | ||
| 1058 | ;; Doing this here confuses things - the region gets left too wide! | ||
| 1059 | ;; I suppose this is run in a context where changing the buffer is bad. | ||
| 1060 | ;; (tar-pad-to-blocksize) | ||
| 1061 | (write-region tar-header-offset (1+ (buffer-size)) buffer-file-name nil t) | ||
| 1062 | ;; return T because we've written the file. | ||
| 1063 | t) | ||
| 1064 | (narrow-to-region 1 tar-header-offset) | ||
| 1065 | t) | ||
| 1066 | ;; return NIL because we haven't. | ||
| 1067 | nil)) | ||
| 1068 | |||
| 1069 | |||
| 1070 | ;;; Patch it in. | ||
| 1071 | |||
| 1072 | (defvar tar-regexp "\\.tar$" | ||
| 1073 | "The regular expression used to identify tar file names.") | ||
| 1074 | |||
| 1075 | (setq auto-mode-alist | ||
| 1076 | (cons (cons tar-regexp 'tar-mode) auto-mode-alist)) | ||
| 1077 | |||
| 1078 | (or (boundp 'write-file-hooks) (setq write-file-hooks nil)) | ||
| 1079 | (or (listp write-file-hooks) | ||
| 1080 | (setq write-file-hooks (list write-file-hooks))) | ||
| 1081 | (or (memq 'maybe-write-tar-file write-file-hooks) | ||
| 1082 | (setq write-file-hooks | ||
| 1083 | (cons 'maybe-write-tar-file write-file-hooks))) | ||
| 1084 | |||
| 1085 | |||
| 1086 | ;;; This is a hack. For files ending in .tar, we want -*- lines to be | ||
| 1087 | ;;; completely ignored - if there is one, it applies to the first file | ||
| 1088 | ;;; in the archive, and not the archive itself! | ||
| 1089 | |||
| 1090 | (defun tar-normal-mode (&optional find-file) | ||
| 1091 | "Choose the major mode for this buffer automatically. | ||
| 1092 | Also sets up any specified local variables of the file. | ||
| 1093 | Uses the visited file name, the -*- line, and the local variables spec. | ||
| 1094 | |||
| 1095 | This function is called automatically from `find-file'. In that case, | ||
| 1096 | if `inhibit-local-variables' is non-`nil' we require confirmation before | ||
| 1097 | processing a local variables spec. If you run `normal-mode' explicitly, | ||
| 1098 | confirmation is never required. | ||
| 1099 | |||
| 1100 | Note that this version of this function has been hacked to interact | ||
| 1101 | correctly with tar files - when visiting a file which matches | ||
| 1102 | 'tar-regexp', the -*- line and local-variables are not examined, | ||
| 1103 | as they would apply to a file within the archive rather than the archive | ||
| 1104 | itself." | ||
| 1105 | (interactive) | ||
| 1106 | (if (and buffer-file-name | ||
| 1107 | (string-match tar-regexp buffer-file-name)) | ||
| 1108 | (tar-mode) | ||
| 1109 | (tar-real-normal-mode find-file))) | ||
| 1110 | |||
| 1111 | |||
| 1112 | (if (not (fboundp 'tar-real-normal-mode)) | ||
| 1113 | (fset 'tar-real-normal-mode (symbol-function 'normal-mode))) | ||
| 1114 | (fset 'normal-mode 'tar-normal-mode) | ||
| 1115 | |||
| 1116 | (provide 'tar-mode) | ||
| 1117 | |||