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