Mercurial > hg > xemacs-beta

comparison lisp/packages/tar-mode.el @ 187:b405438285a2 r20-3b20

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b20
author cvs
date Mon, 13 Aug 2007 09:56:28 +0200
parents 2d532a89d707
children 41ff10fd062f
comparison
equal deleted inserted replaced
186:24ac94803b48 187:b405438285a2
88 ;; o When using crypt-mode, you can't save a compressed or encrypted subfile 88 ;; o When using crypt-mode, you can't save a compressed or encrypted subfile
89 ;; of a tar file back into the tar file: it is saved uncompressed. 89 ;; of a tar file back into the tar file: it is saved uncompressed.
90 90
91 ;;; Code: 91 ;;; Code:
92 92
93 (defvar tar-anal-blocksize 20 93 (defgroup tar ()
94 "Simple editing of tar files from GNU emacs."
95 :group 'unix
96 :group 'data)
97
98
99 (defcustom tar-anal-blocksize 20
94 "*The blocksize of tar files written by Emacs, or nil, meaning don't care. 100 "*The blocksize of tar files written by Emacs, or nil, meaning don't care.
95 The blocksize of a tar file is not really the size of the blocks; rather, it is 101 The blocksize of a tar file is not really the size of the blocks; rather, it is
96 the number of blocks written with one system call. When tarring to a tape, 102 the number of blocks written with one system call. When tarring to a tape,
97 this is the size of the *tape* blocks, but when writing to a file, it doesn't 103 this is the size of the *tape* blocks, but when writing to a file, it doesn't
98 matter much. The only noticeable difference is that if a tar file does not 104 matter much. The only noticeable difference is that if a tar file does not
99 have a blocksize of 20, the tar program will issue a warning; all this really 105 have a blocksize of 20, the tar program will issue a warning; all this really
100 controls is how many null padding bytes go on the end of the tar file.") 106 controls is how many null padding bytes go on the end of the tar file."
101 107 :type 'integer
102 (defvar tar-update-datestamp (or (fboundp 'current-time) 108 :group 'tar)
103 (fboundp 'current-time-seconds)) 109
110 (defcustom tar-update-datestamp t
104 "*Whether tar-mode should play fast and loose with sub-file datestamps; 111 "*Whether tar-mode should play fast and loose with sub-file datestamps;
105 if this is true, then editing and saving a tar file entry back into its 112 if this is true, then editing and saving a tar file entry back into its
106 tar file will update its datestamp. If false, the datestamp is unchanged. 113 tar file will update its datestamp. If false, the datestamp is unchanged.
107 You may or may not want this - it is good in that you can tell when a file 114 You may or may not want this - it is good in that you can tell when a file
108 in a tar archive has been changed, but it is bad for the same reason that 115 in a tar archive has been changed, but it is bad for the same reason that
109 editing a file in the tar archive at all is bad - the changed version of 116 editing a file in the tar archive at all is bad - the changed version of
110 the file never exists on disk. 117 the file never exists on disk.
111 118
112 This does not work in Emacs 18, because there's no way to get the current 119 This does not work in Emacs 18, because there's no way to get the current
113 time as an integer - if this var is true, then editing a file sets its date 120 time as an integer - if this var is true, then editing a file sets its date
114 to midnight, Jan 1 1970 GMT, which happens to be what 0 encodes.") 121 to midnight, Jan 1 1970 GMT, which happens to be what 0 encodes."
122 :type 'boolean
123 :group 'tar)
115 124
116 125
117 ;;; First, duplicate some Common Lisp functions; I used to just (require 'cl) 126 ;;; First, duplicate some Common Lisp functions; I used to just (require 'cl)
118 ;;; but "cl.el" was messing some people up (also it's really big). 127 ;;; but "cl.el" was messing some people up (also it's really big).
119 128
120 (defmacro tar-setf (form val) 129 ;; No need for that stuff anymore -- XEmacs preloads cl.el anyway.
121 "A mind-numbingly simple implementation of setf."
122 (let ((mform (macroexpand form (and (boundp 'byte-compile-macro-environment)
123 byte-compile-macro-environment))))
124 (cond ((symbolp mform) (list 'setq mform val))
125 ((not (consp mform)) (error "can't setf %s" form))
126 ((eq (car mform) 'aref)
127 (list 'aset (nth 1 mform) (nth 2 mform) val))
128 ((eq (car mform) 'car)
129 (list 'setcar (nth 1 mform) val))
130 ((eq (car mform) 'cdr)
131 (list 'setcdr (nth 1 mform) val))
132 (t (error "don't know how to setf %s" form)))))
133
134 (defmacro tar-dolist (control &rest body)
135 "syntax: (dolist (var-name list-expr &optional return-value) &body body)"
136 (let ((var (car control))
137 (init (car (cdr control)))
138 (val (car (cdr (cdr control)))))
139 (list 'let (list (list '_dolist_iterator_ init))
140 (list 'while '_dolist_iterator_
141 (cons 'let
142 (cons (list (list var '(car _dolist_iterator_)))
143 (append body
144 (list (list 'setq '_dolist_iterator_
145 (list 'cdr '_dolist_iterator_)))))))
146 val)))
147
148 (defmacro tar-dotimes (control &rest body)
149 "syntax: (dotimes (var-name count-expr &optional return-value) &body body)"
150 (let ((var (car control))
151 (n (car (cdr control)))
152 (val (car (cdr (cdr control)))))
153 (list 'let (list (list '_dotimes_end_ n)
154 (list var 0))
155 (cons 'while
156 (cons (list '< var '_dotimes_end_)
157 (append body
158 (list (list 'setq var (list '1+ var))))))
159 val)))
160 130
161 131
162 ;;; down to business. 132 ;;; down to business.
163 133
164 (defmacro make-tar-header (name mode uid git size date ck lt ln 134 (defmacro make-tar-header (name mode uid git size date ck lt ln
165 magic uname gname devmaj devmin) 135 magic uname gname devmaj devmin)
166 (list 'vector name mode uid git size date ck lt ln 136 (list 'vector name mode uid git size date ck lt ln
167 magic uname gname devmaj devmin)) 137 magic uname gname devmaj devmin))
168 138
169 (defmacro tar-header-name (x) (list 'aref x 0)) 139 (defmacro tar-header-name (x) (list 'aref x 0))
170 (defmacro tar-header-mode (x) (list 'aref x 1)) 140 (defmacro tar-header-mode (x) (list 'aref x 1))
206 176
207 (defun tokenize-tar-header-block (string) 177 (defun tokenize-tar-header-block (string)
208 "Returns a 'tar-header' structure (a list of name, mode, uid, gid, size, 178 "Returns a 'tar-header' structure (a list of name, mode, uid, gid, size,
209 write-date, checksum, link-type, and link-name)." 179 write-date, checksum, link-type, and link-name)."
210 (cond ((< (length string) 512) nil) 180 (cond ((< (length string) 512) nil)
211 (;(some 'plusp string) ; <-- oops, massive cycle hog! 181 ( ;(some 'plusp string) ; <-- oops, massive cycle hog!
212 (or (not (= 0 (aref string 0))) ; This will do. 182 (or (not (= 0 (aref string 0))) ; This will do.
213 (not (= 0 (aref string 101)))) 183 (not (= 0 (aref string 101))))
214 (let* ((name-end (1- tar-mode-offset)) 184 (let* ((name-end (1- tar-mode-offset))
215 (link-end (1- tar-magic-offset)) 185 (link-end (1- tar-magic-offset))
216 (uname-end (1- tar-gname-offset)) 186 (uname-end (1- tar-gname-offset))
228 link-p (if (or (= link-p 0) (= link-p ?0)) 198 link-p (if (or (= link-p 0) (= link-p ?0))
229 nil 199 nil
230 (- link-p ?0))) 200 (- link-p ?0)))
231 (if (and (null link-p) (string-match "/$" name)) (setq link-p 5)) ; directory 201 (if (and (null link-p) (string-match "/$" name)) (setq link-p 5)) ; directory
232 (make-tar-header 202 (make-tar-header
233 name 203 name
234 (tar-parse-octal-integer string tar-mode-offset (1- tar-uid-offset)) 204 (tar-parse-octal-integer string tar-mode-offset (1- tar-uid-offset))
235 (tar-parse-octal-integer string tar-uid-offset (1- tar-gid-offset)) 205 (tar-parse-octal-integer string tar-uid-offset (1- tar-gid-offset))
236 (tar-parse-octal-integer string tar-gid-offset (1- tar-size-offset)) 206 (tar-parse-octal-integer string tar-gid-offset (1- tar-size-offset))
237 (tar-parse-octal-integer string tar-size-offset (1- tar-time-offset)) 207 (tar-parse-octal-integer string tar-size-offset (1- tar-time-offset))
238 (tar-parse-octal-integer-32 string tar-time-offset (1- tar-chk-offset)) 208 (tar-parse-octal-integer-32 string tar-time-offset (1- tar-chk-offset))
239 (tar-parse-octal-integer string tar-chk-offset (1- tar-linkp-offset)) 209 (tar-parse-octal-integer string tar-chk-offset (1- tar-linkp-offset))
240 link-p 210 link-p
241 (substring string tar-link-offset link-end) 211 (substring string tar-link-offset link-end)
242 uname-valid-p 212 uname-valid-p
243 (and uname-valid-p (substring string tar-uname-offset uname-end)) 213 (and uname-valid-p (substring string tar-uname-offset uname-end))
244 (and uname-valid-p (substring string tar-gname-offset gname-end)) 214 (and uname-valid-p (substring string tar-gname-offset gname-end))
245 (tar-parse-octal-integer string tar-dmaj-offset (1- tar-dmin-offset)) 215 (tar-parse-octal-integer string tar-dmaj-offset (1- tar-dmin-offset))
246 (tar-parse-octal-integer string tar-dmin-offset (1- tar-end-offset)) 216 (tar-parse-octal-integer string tar-dmin-offset (1- tar-end-offset))
247 ))) 217 )))
248 (t 'empty-tar-block))) 218 (t 'empty-tar-block)))
249 219
250 220
251 (defun tar-parse-octal-integer (string &optional start end) 221 (defun tar-parse-octal-integer (string &optional start end)
252 "deletes all your files, and then reboots." 222 "deletes all your files, and then reboots."
273 (cons top bot))) 243 (cons top bot)))
274 244
275 (defun tar-parse-octal-integer-safe (string) 245 (defun tar-parse-octal-integer-safe (string)
276 (let ((L (length string))) 246 (let ((L (length string)))
277 (if (= L 0) (error "empty string")) 247 (if (= L 0) (error "empty string"))
278 (tar-dotimes (i L) 248 (dotimes (i L)
279 (if (or (< (aref string i) ?0) 249 (if (or (< (aref string i) ?0)
280 (> (aref string i) ?7)) 250 (> (aref string i) ?7))
281 (error "'%c' is not an octal digit.")))) 251 (error "'%c' is not an octal digit."))))
282 (tar-parse-octal-integer string)) 252 (tar-parse-octal-integer string))
283 253
284 254
285 (defun checksum-tar-header-block (string) 255 (defun checksum-tar-header-block (string)
286 "Computes and returns a tar-acceptable checksum for this block." 256 "Computes and returns a tar-acceptable checksum for this block."
309 (let* ((chk (checksum-tar-header-block hblock)) 279 (let* ((chk (checksum-tar-header-block hblock))
310 (chk-string (format "%6o" chk)) 280 (chk-string (format "%6o" chk))
311 (l (length chk-string))) 281 (l (length chk-string)))
312 (aset hblock 154 0) 282 (aset hblock 154 0)
313 (aset hblock 155 32) 283 (aset hblock 155 32)
314 (tar-dotimes (i l) (aset hblock (- 153 i) (aref chk-string (- l i 1))))) 284 (dotimes (i l) (aset hblock (- 153 i) (aref chk-string (- l i 1)))))
315 hblock) 285 hblock)
316 286
317 287
318 (defun tar-grind-file-mode (mode string start) 288 (defun tar-grind-file-mode (mode string start)
319 "Write a \"-rw--r--r-\" representing MODE into STRING beginning at START." 289 "Write a \"-rw--r--r-\" representing MODE into STRING beginning at START."
360 (string (make-string (+ namestart (length name) (if link-p (+ 5 (length link-name)) 0)) 32)) 330 (string (make-string (+ namestart (length name) (if link-p (+ 5 (length link-name)) 0)) 32))
361 (type (tar-header-link-type tar-hblock))) 331 (type (tar-header-link-type tar-hblock)))
362 (aset string 0 (if mod-p ?* ? )) 332 (aset string 0 (if mod-p ?* ? ))
363 (aset string 1 333 (aset string 1
364 (cond ((or (eq type nil) (eq type 0)) ?-) 334 (cond ((or (eq type nil) (eq type 0)) ?-)
365 ((eq type 1) ?l) ; link 335 ((eq type 1) ?l) ; link
366 ((eq type 2) ?s) ; symlink 336 ((eq type 2) ?s) ; symlink
367 ((eq type 3) ?c) ; char special 337 ((eq type 3) ?c) ; char special
368 ((eq type 4) ?b) ; block special 338 ((eq type 4) ?b) ; block special
369 ((eq type 5) ?d) ; directory 339 ((eq type 5) ?d) ; directory
370 ((eq type 6) ?p) ; FIFO/pipe 340 ((eq type 6) ?p) ; FIFO/pipe
371 ((eq type 20) ?*) ; directory listing 341 ((eq type 20) ?*) ; directory listing
372 ((eq type 29) ?M) ; multivolume continuation 342 ((eq type 29) ?M) ; multivolume continuation
373 ((eq type 35) ?S) ; sparse 343 ((eq type 35) ?S) ; sparse
374 ((eq type 38) ?V) ; volume header 344 ((eq type 38) ?V) ; volume header
375 )) 345 ))
376 (tar-grind-file-mode mode string 2) 346 (tar-grind-file-mode mode string 2)
377 (setq uid (if (= 0 (length uname)) (int-to-string uid) uname)) 347 (setq uid (if (= 0 (length uname)) (int-to-string uid) uname))
378 (setq gid (if (= 0 (length gname)) (int-to-string gid) gname)) 348 (setq gid (if (= 0 (length gname)) (int-to-string gid) gname))
379 (setq size (int-to-string size)) 349 (setq size (int-to-string size))
380 (tar-dotimes (i (min (1- namew) (length uid))) (aset string (- slash i) (aref uid (- (length uid) i 1)))) 350 (dotimes (i (min (1- namew) (length uid))) (aset string (- slash i) (aref uid (- (length uid) i 1))))
381 (aset string (1+ slash) ?/) 351 (aset string (1+ slash) ?/)
382 (tar-dotimes (i (min (1- groupw) (length gid))) (aset string (+ (+ slash 2) i) (aref gid i))) 352 (dotimes (i (min (1- groupw) (length gid))) (aset string (+ (+ slash 2) i) (aref gid i)))
383 (tar-dotimes (i (min sizew (length size))) (aset string (- lastdigit i) (aref size (- (length size) i 1)))) 353 (dotimes (i (min sizew (length size))) (aset string (- lastdigit i) (aref size (- (length size) i 1))))
384 354
385 (if tar-can-print-dates 355 (if tar-can-print-dates
386 (let* ((year (substring (current-time-string) -4)) 356 (let* ((year (substring (current-time-string) -4))
387 ;; in v18, current-time-string doesn't take an argument 357 ;; in v18, current-time-string doesn't take an argument
388 (file (current-time-string time)) 358 (file (current-time-string time))
389 (file-year (substring file -4)) 359 (file-year (substring file -4))
390 (str (if (equal year file-year) 360 (str (if (equal year file-year)
391 (substring file 4 16) 361 (substring file 4 16)
392 (concat (substring file 4 11) " " file-year)))) 362 (concat (substring file 4 11) " " file-year))))
393 (tar-dotimes (i 12) (aset string (- namestart (- 13 i)) (aref str i))))) 363 (dotimes (i 12) (aset string (- namestart (- 13 i)) (aref str i)))))
394 364
395 (tar-dotimes (i (length name)) (aset string (+ namestart i) (aref name i))) 365 (dotimes (i (length name)) (aset string (+ namestart i) (aref name i)))
396 (if (or (eq link-p 1) (eq link-p 2)) 366 (if (or (eq link-p 1) (eq link-p 2))
397 (progn 367 (progn
398 (tar-dotimes (i 3) (aset string (+ namestart 1 (length name) i) (aref (if (= link-p 1) "==>" "-->") i))) 368 (dotimes (i 3) (aset string (+ namestart 1 (length name) i) (aref (if (= link-p 1) "==>" "-->") i)))
399 (tar-dotimes (i (length link-name)) (aset string (+ namestart 5 (length name) i) (aref link-name i))))) 369 (dotimes (i (length link-name)) (aset string (+ namestart 5 (length name) i) (aref link-name i)))))
400 string))) 370 string)))
401 371
402 372
403 ;; buffer-local variables in the tar file's buffer: 373 ;; buffer-local variables in the tar file's buffer:
404 ;; 374 ;;
405 (defvar tar-parse-info) ; the header structures 375 (defvar tar-parse-info) ; the header structures
406 (defvar tar-header-offset) ; the end of the "pretty" data 376 (defvar tar-header-offset) ; the end of the "pretty" data
407 377
408 (defun tar-summarize-buffer () 378 (defun tar-summarize-buffer ()
409 "Parse the contents of the tar file in the current buffer, and place a 379 "Parse the contents of the tar file in the current buffer, and place a
410 dired-like listing on the front; then narrow to it, so that only that listing 380 dired-like listing on the front; then narrow to it, so that only that listing
411 is visible (and the real data of the buffer is hidden)." 381 is visible (and the real data of the buffer is hidden)."
412 (message "parsing tar file...") 382 (message "parsing tar file...")
413 (let* ((result '()) 383 (let* ((result '())
414 (pos 1) 384 (pos 1)
415 (bs (max 1 (- (buffer-size) 1024))) ; always 2+ empty blocks at end. 385 (bs (max 1 (- (buffer-size) 1024))) ; always 2+ empty blocks at end.
416 (bs100 (max 1 (/ bs 100))) 386 (bs100 (max 1 (/ bs 100)))
417 (tokens nil)) 387 (tokens nil))
418 (while (not (eq tokens 'empty-tar-block)) 388 (while (not (eq tokens 'empty-tar-block))
419 (if (> (+ pos 512) (point-max)) 389 (if (> (+ pos 512) (point-max))
420 (error "truncated tar file")) 390 (error "truncated tar file"))
421 (let* ((hblock (buffer-substring pos (+ pos 512)))) 391 (let* ((hblock (buffer-substring pos (+ pos 512))))
422 (setq tokens (tokenize-tar-header-block hblock)) 392 (setq tokens (tokenize-tar-header-block hblock))
423 (setq pos (+ pos 512)) 393 (setq pos (+ pos 512))
424 (message "parsing tar file...%s%%" 394 (message "parsing tar file...%s%%"
425 ;(/ (* pos 100) bs) ; this gets round-off lossage 395 ;(/ (* pos 100) bs) ; this gets round-off lossage
426 (/ pos bs100) ; this doesn't 396 (/ pos bs100) ; this doesn't
427 ) 397 )
428 (if (eq tokens 'empty-tar-block) 398 (if (eq tokens 'empty-tar-block)
429 nil 399 nil
430 (if (null tokens) (error "premature EOF parsing tar file.")) 400 (if (null tokens) (error "premature EOF parsing tar file."))
431 (if (eq (tar-header-link-type tokens) 20) 401 (if (eq (tar-header-link-type tokens) 20)
433 (setq pos (+ pos 512))) 403 (setq pos (+ pos 512)))
434 (let ((size (tar-header-size tokens))) 404 (let ((size (tar-header-size tokens)))
435 (if (< size 0) 405 (if (< size 0)
436 (error "%s has size %s - corrupted." 406 (error "%s has size %s - corrupted."
437 (tar-header-name tokens) size)) 407 (tar-header-name tokens) size))
438 ; 408 ;
439 ; This is just too slow. Don't really need it anyway.... 409 ; This is just too slow. Don't really need it anyway....
440 ;(check-tar-header-block-checksum 410 ;(check-tar-header-block-checksum
441 ; hblock (checksum-tar-header-block hblock) 411 ; hblock (checksum-tar-header-block hblock)
442 ; (tar-header-name tokens)) 412 ; (tar-header-name tokens))
443 413
444 (setq result (cons (make-tar-desc pos tokens) result)) 414 (setq result (cons (make-tar-desc pos tokens) result))
445 415
446 (if (and (null (tar-header-link-type tokens)) 416 (if (and (null (tar-header-link-type tokens))
447 (> size 0)) 417 (> size 0))
448 (setq pos 418 (setq pos
449 (+ pos 512 (ash (ash (1- size) -9) 9)) ; this works 419 (+ pos 512 (ash (ash (1- size) -9) 9)) ; this works
450 ;(+ pos (+ size (- 512 (rem (1- size) 512)))) ; this doesn't 420 ;(+ pos (+ size (- 512 (rem (1- size) 512)))) ; this doesn't
451 )) 421 ))
452 )))) 422 ))))
453 (make-local-variable 'tar-parse-info) 423 (make-local-variable 'tar-parse-info)
454 (setq tar-parse-info (nreverse result))) 424 (setq tar-parse-info (nreverse result)))
455 (message "parsing tar file...formatting...") 425 (message "parsing tar file...formatting...")
456 (save-excursion 426 (save-excursion
457 (goto-char (point-min)) 427 (goto-char (point-min))
458 (let ((buffer-read-only nil)) 428 (let ((buffer-read-only nil))
459 (tar-dolist (tar-desc tar-parse-info) 429 (dolist (tar-desc tar-parse-info)
460 (insert 430 (insert
461 (summarize-tar-header-block (tar-desc-tokens tar-desc)) 431 (summarize-tar-header-block (tar-desc-tokens tar-desc))
462 "\n")) 432 "\n"))
463 (make-local-variable 'tar-header-offset) 433 (make-local-variable 'tar-header-offset)
464 (setq tar-header-offset (point)) 434 (setq tar-header-offset (point))
465 (narrow-to-region 1 tar-header-offset) 435 (narrow-to-region 1 tar-header-offset)
466 (set-buffer-modified-p nil))) 436 (set-buffer-modified-p nil)))
467 (message "parsing tar file...done.")) 437 (message "parsing tar file...done."))
575 ;; this is not interactive because you shouldn't be turning this 545 ;; this is not interactive because you shouldn't be turning this
576 ;; mode on and off. You can corrupt things that way. 546 ;; mode on and off. You can corrupt things that way.
577 (make-local-variable 'tar-header-offset) 547 (make-local-variable 'tar-header-offset)
578 (make-local-variable 'tar-parse-info) 548 (make-local-variable 'tar-parse-info)
579 (make-local-variable 'require-final-newline) 549 (make-local-variable 'require-final-newline)
580 (setq require-final-newline nil) ; binary data, dude... 550 (setq require-final-newline nil) ; binary data, dude...
581 (make-local-variable 'revert-buffer-function) 551 (make-local-variable 'revert-buffer-function)
582 (setq revert-buffer-function 'tar-mode-revert) 552 (setq revert-buffer-function 'tar-mode-revert)
583 (setq major-mode 'tar-mode) 553 (setq major-mode 'tar-mode)
584 (setq mode-name "Tar") 554 (setq mode-name "Tar")
585 (use-local-map tar-mode-map) 555 (use-local-map tar-mode-map)
586 (auto-save-mode 0) 556 (auto-save-mode 0)
587 (widen) 557 (widen)
588 (if (and (boundp 'tar-header-offset) tar-header-offset) 558 (if (and (boundp 'tar-header-offset) tar-header-offset)
589 (narrow-to-region 1 tar-header-offset) 559 (narrow-to-region 1 tar-header-offset)
590 (tar-summarize-buffer)) 560 (tar-summarize-buffer))
591 561
592 (cond ((string-match "XEmacs" emacs-version) 562 (cond ((string-match "XEmacs" emacs-version)
593 (require 'mode-motion) 563 (require 'mode-motion)
594 (setq mode-motion-hook 'mode-motion-highlight-line) 564 (setq mode-motion-hook 'mode-motion-highlight-line)
595 (if (and current-menubar (not (assoc "Tar" current-menubar))) 565 (if (and current-menubar (not (assoc "Tar" current-menubar)))
621 (list '(tar-subfile-mode " TarFile"))))) 591 (list '(tar-subfile-mode " TarFile")))))
622 (make-local-variable 'tar-subfile-mode) 592 (make-local-variable 'tar-subfile-mode)
623 (setq tar-subfile-mode 593 (setq tar-subfile-mode
624 (if (null p) 594 (if (null p)
625 (not tar-subfile-mode) 595 (not tar-subfile-mode)
626 (> (prefix-numeric-value p) 0))) 596 (> (prefix-numeric-value p) 0)))
627 (cond (tar-subfile-mode 597 (cond (tar-subfile-mode
628 ;; copy the local keymap so that we don't accidentally 598 ;; copy the local keymap so that we don't accidentally
629 ;; alter a keymap like 'lisp-mode-map' which is shared 599 ;; alter a keymap like 'lisp-mode-map' which is shared
630 ;; by all buffers in that mode. 600 ;; by all buffers in that mode.
631 (let ((m (current-local-map))) 601 (let ((m (current-local-map)))
678 (or (nth (count-lines (point-min) 648 (or (nth (count-lines (point-min)
679 (save-excursion (beginning-of-line) (point))) 649 (save-excursion (beginning-of-line) (point)))
680 tar-parse-info) 650 tar-parse-info)
681 (if noerror 651 (if noerror
682 nil 652 nil
683 (error "This line does not describe a tar-file entry.")))) 653 (error "This line does not describe a tar-file entry."))))
684 654
685 655
686 (defun tar-extract (&optional other-window-p) 656 (defun tar-extract (&optional other-window-p)
687 "*In tar-mode, extract this entry of the tar file into its own buffer." 657 "*In tar-mode, extract this entry of the tar file into its own buffer."
688 (interactive) 658 (interactive)
703 ((eq link-p 38) "volume header") 673 ((eq link-p 38) "volume header")
704 (t "link")))) 674 (t "link"))))
705 (if (zerop size) (error "This is a zero-length file.")) 675 (if (zerop size) (error "This is a zero-length file."))
706 (let* ((tar-buffer (current-buffer)) 676 (let* ((tar-buffer (current-buffer))
707 (bufname (file-name-nondirectory name)) 677 (bufname (file-name-nondirectory name))
708 (bufid (concat ;" (" name " in " 678 (bufid (concat ;" (" name " in "
709 " (in " 679 " (in "
710 (file-name-nondirectory (buffer-file-name)) 680 (file-name-nondirectory (buffer-file-name))
711 ")")) 681 ")"))
712 (read-only-p (or buffer-read-only view-p)) 682 (read-only-p (or buffer-read-only view-p))
713 (buffer nil) 683 (buffer nil)
714 (buffers (buffer-list)) 684 (buffers (buffer-list))
715 (just-created nil)) 685 (just-created nil))
716 ;; find a buffer visiting this subfile from this tar file. 686 ;; find a buffer visiting this subfile from this tar file.
718 (set-buffer (car buffers)) 688 (set-buffer (car buffers))
719 (if (and (null (buffer-file-name (car buffers))) 689 (if (and (null (buffer-file-name (car buffers)))
720 (boundp 'superior-tar-descriptor) 690 (boundp 'superior-tar-descriptor)
721 (eq superior-tar-descriptor descriptor)) 691 (eq superior-tar-descriptor descriptor))
722 (setq buffer (car buffers)) 692 (setq buffer (car buffers))
723 (setq buffers (cdr buffers)))) 693 (setq buffers (cdr buffers))))
724 (set-buffer tar-buffer) 694 (set-buffer tar-buffer)
725 (if buffer 695 (if buffer
726 nil 696 nil
727 (setq buffer (generate-new-buffer bufname)) 697 (setq buffer (generate-new-buffer bufname))
728 (setq just-created t) 698 (setq just-created t)
733 (set-buffer buffer) 703 (set-buffer buffer)
734 (insert-buffer-substring tar-buffer start end) 704 (insert-buffer-substring tar-buffer start end)
735 (goto-char 0) 705 (goto-char 0)
736 (let ((lock-directory nil)) ; disable locking 706 (let ((lock-directory nil)) ; disable locking
737 (set-visited-file-name name) ; give it a name to decide mode. 707 (set-visited-file-name name) ; give it a name to decide mode.
738 ;; (normal-mode) ; pick a mode. 708 ;; (normal-mode) ; pick a mode.
739 ;; (after-find-file nil nil) ; pick a mode; works with crypt.el 709 ;; (after-find-file nil nil) ; pick a mode; works with crypt.el
740 ;; Ok, instead of running after-find-file, just invoke the 710 ;; Ok, instead of running after-find-file, just invoke the
741 ;; find-file-hooks instead. This does everything we want 711 ;; find-file-hooks instead. This does everything we want
742 ;; from after-find-file, without losing when visiting .tar 712 ;; from after-find-file, without losing when visiting .tar
743 ;; files via ange-ftp: doesn't probe the ftp site for the 713 ;; files via ange-ftp: doesn't probe the ftp site for the
744 ;; name of the subfile. 714 ;; name of the subfile.
821 default-file nil)))) 791 default-file nil))))
822 (if (or (string= "" (file-name-nondirectory target)) 792 (if (or (string= "" (file-name-nondirectory target))
823 (file-directory-p target)) 793 (file-directory-p target))
824 (setq target (concat (if (string-match "/$" target) 794 (setq target (concat (if (string-match "/$" target)
825 (substring target 0 (1- (match-end 0))) 795 (substring target 0 (1- (match-end 0)))
826 target) 796 target)
827 "/" 797 "/"
828 (file-name-nondirectory default-file)))) 798 (file-name-nondirectory default-file))))
829 target)) 799 target))
830 800
831 801
864 (defun tar-flag-deleted (p &optional unflag) 834 (defun tar-flag-deleted (p &optional unflag)
865 "*In tar mode, mark this sub-file to be deleted from the tar file. 835 "*In tar mode, mark this sub-file to be deleted from the tar file.
866 With a prefix argument, mark that many files." 836 With a prefix argument, mark that many files."
867 (interactive "p") 837 (interactive "p")
868 (beginning-of-line) 838 (beginning-of-line)
869 (tar-dotimes (i (if (< p 0) (- p) p)) 839 (dotimes (i (if (< p 0) (- p) p))
870 (if (tar-current-descriptor unflag) ; barf if we're not on an entry-line. 840 (if (tar-current-descriptor unflag) ; barf if we're not on an entry-line.
871 (progn 841 (progn
872 (delete-char 1) 842 (delete-char 1)
873 (insert (if unflag " " "D")))) 843 (insert (if unflag " " "D"))))
874 (forward-line (if (< p 0) -1 1))) 844 (forward-line (if (< p 0) -1 1)))
895 (name (tar-header-name tokens)) 865 (name (tar-header-name tokens))
896 (size (tar-header-size tokens)) 866 (size (tar-header-size tokens))
897 (link-p (tar-header-link-type tokens)) 867 (link-p (tar-header-link-type tokens))
898 (start (tar-desc-data-start descriptor)) 868 (start (tar-desc-data-start descriptor))
899 (following-descs (cdr (memq descriptor tar-parse-info)))) 869 (following-descs (cdr (memq descriptor tar-parse-info))))
900 (if link-p (setq size 0)) ; size lies for hard-links. 870 (if link-p (setq size 0)) ; size lies for hard-links.
901 ;; 871 ;;
902 ;; delete the current line... 872 ;; delete the current line...
903 (beginning-of-line) 873 (beginning-of-line)
904 (let ((line-start (point))) 874 (let ((line-start (point)))
905 (end-of-line) (forward-char) 875 (end-of-line) (forward-char)
922 ;; entries in the archive. This is a pig when deleting a bunch 892 ;; entries in the archive. This is a pig when deleting a bunch
923 ;; of files at once - we could optimize this to only do the 893 ;; of files at once - we could optimize this to only do the
924 ;; iteration over the files that remain, or only iterate up to 894 ;; iteration over the files that remain, or only iterate up to
925 ;; the next file to be deleted. 895 ;; the next file to be deleted.
926 (let ((data-length (- data-end data-start))) 896 (let ((data-length (- data-end data-start)))
927 (tar-dolist (desc following-descs) 897 (dolist (desc following-descs)
928 (tar-setf (tar-desc-data-start desc) 898 (setf (tar-desc-data-start desc)
929 (- (tar-desc-data-start desc) data-length)))) 899 (- (tar-desc-data-start desc) data-length))))
930 )) 900 ))
931 (narrow-to-region 1 tar-header-offset)) 901 (narrow-to-region 1 tar-header-offset))
932 902
933 903
934 (defun tar-expunge (&optional noconfirm) 904 (defun tar-expunge (&optional noconfirm)
943 (goto-char 0) 913 (goto-char 0)
944 (while (not (eobp)) 914 (while (not (eobp))
945 (if (looking-at "D") 915 (if (looking-at "D")
946 (progn (tar-expunge-internal) 916 (progn (tar-expunge-internal)
947 (setq n (1+ n))) 917 (setq n (1+ n)))
948 (forward-line 1))) 918 (forward-line 1)))
949 ;; after doing the deletions, add any padding that may be necessary. 919 ;; after doing the deletions, add any padding that may be necessary.
950 (tar-pad-to-blocksize) 920 (tar-pad-to-blocksize)
951 (narrow-to-region 1 tar-header-offset) 921 (narrow-to-region 1 tar-header-offset)
952 ) 922 )
953 (if (zerop n) 923 (if (zerop n)
954 (message "nothing to expunge.") 924 (message "nothing to expunge.")
955 (message "%s expunged. Be sure to save this buffer." n))))) 925 (message "%s expunged. Be sure to save this buffer." n)))))
956 926
957 927
958 (defun tar-clear-modification-flags () 928 (defun tar-clear-modification-flags ()
959 "remove the stars at the beginning of each line." 929 "remove the stars at the beginning of each line."
960 (save-excursion 930 (save-excursion
971 the user id as a string; otherwise, you must edit it as a number. 941 the user id as a string; otherwise, you must edit it as a number.
972 You can force editing as a number by calling this with a prefix arg. 942 You can force editing as a number by calling this with a prefix arg.
973 This does not modify the disk image; you must save the tar file itself 943 This does not modify the disk image; you must save the tar file itself
974 for this to be permanent." 944 for this to be permanent."
975 (interactive (list 945 (interactive (list
976 (let ((tokens (tar-desc-tokens (tar-current-descriptor)))) 946 (let ((tokens (tar-desc-tokens (tar-current-descriptor))))
977 (if (or current-prefix-arg 947 (if (or current-prefix-arg
978 (not (tar-header-magic tokens))) 948 (not (tar-header-magic tokens)))
979 (let (n) 949 (let (n)
980 (while (not (numberp (setq n (read-minibuffer 950 (while (not (numberp (setq n (read-minibuffer
981 "New UID number: " 951 "New UID number: "
982 (format "%s" (tar-header-uid tokens))))))) 952 (format "%s" (tar-header-uid tokens)))))))
983 n) 953 n)
984 (read-string "New UID string: " (tar-header-uname tokens)))))) 954 (read-string "New UID string: " (tar-header-uname tokens))))))
985 (cond ((stringp new-uid) 955 (cond ((stringp new-uid)
986 (tar-setf (tar-header-uname (tar-desc-tokens (tar-current-descriptor))) 956 (setf (tar-header-uname (tar-desc-tokens (tar-current-descriptor)))
987 new-uid) 957 new-uid)
988 (tar-alter-one-field tar-uname-offset (concat new-uid "\000"))) 958 (tar-alter-one-field tar-uname-offset (concat new-uid "\000")))
989 (t 959 (t
990 (tar-setf (tar-header-uid (tar-desc-tokens (tar-current-descriptor))) 960 (setf (tar-header-uid (tar-desc-tokens (tar-current-descriptor)))
991 new-uid) 961 new-uid)
992 (tar-alter-one-field tar-uid-offset 962 (tar-alter-one-field tar-uid-offset
993 (concat (substring (format "%6o" new-uid) 0 6) "\000 "))))) 963 (concat (substring (format "%6o" new-uid) 0 6) "\000 ")))))
994 964
995 965
996 (defun tar-chgrp-entry (new-gid) 966 (defun tar-chgrp-entry (new-gid)
997 "*Change the group-id associated with this entry in the tar file. 967 "*Change the group-id associated with this entry in the tar file.
998 If this tar file was written by GNU tar, then you will be able to edit 968 If this tar file was written by GNU tar, then you will be able to edit
999 the group id as a string; otherwise, you must edit it as a number. 969 the group id as a string; otherwise, you must edit it as a number.
1000 You can force editing as a number by calling this with a prefix arg. 970 You can force editing as a number by calling this with a prefix arg.
1001 This does not modify the disk image; you must save the tar file itself 971 This does not modify the disk image; you must save the tar file itself
1002 for this to be permanent." 972 for this to be permanent."
1003 (interactive (list 973 (interactive (list
1004 (let ((tokens (tar-desc-tokens (tar-current-descriptor)))) 974 (let ((tokens (tar-desc-tokens (tar-current-descriptor))))
1005 (if (or current-prefix-arg 975 (if (or current-prefix-arg
1006 (not (tar-header-magic tokens))) 976 (not (tar-header-magic tokens)))
1007 (let (n) 977 (let (n)
1008 (while (not (numberp (setq n (read-minibuffer 978 (while (not (numberp (setq n (read-minibuffer
1009 "New GID number: " 979 "New GID number: "
1010 (format "%s" (tar-header-gid tokens))))))) 980 (format "%s" (tar-header-gid tokens)))))))
1011 n) 981 n)
1012 (read-string "New GID string: " (tar-header-gname tokens)))))) 982 (read-string "New GID string: " (tar-header-gname tokens))))))
1013 (cond ((stringp new-gid) 983 (cond ((stringp new-gid)
1014 (tar-setf (tar-header-gname (tar-desc-tokens (tar-current-descriptor))) 984 (setf (tar-header-gname (tar-desc-tokens (tar-current-descriptor)))
1015 new-gid) 985 new-gid)
1016 (tar-alter-one-field tar-gname-offset 986 (tar-alter-one-field tar-gname-offset
1017 (concat new-gid "\000"))) 987 (concat new-gid "\000")))
1018 (t 988 (t
1019 (tar-setf (tar-header-gid (tar-desc-tokens (tar-current-descriptor))) 989 (setf (tar-header-gid (tar-desc-tokens (tar-current-descriptor)))
1020 new-gid) 990 new-gid)
1021 (tar-alter-one-field tar-gid-offset 991 (tar-alter-one-field tar-gid-offset
1022 (concat (substring (format "%6o" new-gid) 0 6) "\000 "))))) 992 (concat (substring (format "%6o" new-gid) 0 6) "\000 ")))))
1023 993
1024 (defun tar-rename-entry (new-name) 994 (defun tar-rename-entry (new-name)
1025 "*Change the name associated with this entry in the tar file. 995 "*Change the name associated with this entry in the tar file.
1026 This does not modify the disk image; you must save the tar file itself 996 This does not modify the disk image; you must save the tar file itself
1027 for this to be permanent." 997 for this to be permanent."
1028 (interactive 998 (interactive
1029 (list (read-string "New name: " 999 (list (read-string "New name: "
1030 (tar-header-name (tar-desc-tokens (tar-current-descriptor)))))) 1000 (tar-header-name (tar-desc-tokens (tar-current-descriptor))))))
1031 (if (string= "" new-name) (error "zero length name.")) 1001 (if (string= "" new-name) (error "zero length name."))
1032 (if (> (length new-name) 98) (error "name too long.")) 1002 (if (> (length new-name) 98) (error "name too long."))
1033 (tar-setf (tar-header-name (tar-desc-tokens (tar-current-descriptor))) 1003 (setf (tar-header-name (tar-desc-tokens (tar-current-descriptor)))
1034 new-name) 1004 new-name)
1035 (tar-alter-one-field 0 1005 (tar-alter-one-field 0
1036 (substring (concat new-name (make-string 99 0)) 0 99))) 1006 (substring (concat new-name (make-string 99 0)) 0 99)))
1037 1007
1038 1008
1039 (defun tar-chmod-entry (new-mode) 1009 (defun tar-chmod-entry (new-mode)
1040 "*Change the protection bits associated with this entry in the tar file. 1010 "*Change the protection bits associated with this entry in the tar file.
1041 This does not modify the disk image; you must save the tar file itself 1011 This does not modify the disk image; you must save the tar file itself
1042 for this to be permanent." 1012 for this to be permanent."
1043 (interactive (list (tar-parse-octal-integer-safe 1013 (interactive (list (tar-parse-octal-integer-safe
1044 (read-string "New protection (octal): ")))) 1014 (read-string "New protection (octal): "))))
1045 (tar-setf (tar-header-mode (tar-desc-tokens (tar-current-descriptor))) 1015 (setf (tar-header-mode (tar-desc-tokens (tar-current-descriptor)))
1046 new-mode) 1016 new-mode)
1047 (tar-alter-one-field tar-mode-offset 1017 (tar-alter-one-field tar-mode-offset
1048 (concat (substring (format "%6o" new-mode) 0 6) "\000 "))) 1018 (concat (substring (format "%6o" new-mode) 0 6) "\000 ")))
1049 1019
1050 1020
1051 (defun tar-alter-one-field (data-position new-data-string) 1021 (defun tar-alter-one-field (data-position new-data-string)
1052 (let* ((descriptor (tar-current-descriptor)) 1022 (let* ((descriptor (tar-current-descriptor))
1053 (tokens (tar-desc-tokens descriptor))) 1023 (tokens (tar-desc-tokens descriptor)))
1066 (let* ((start (+ (tar-desc-data-start descriptor) tar-header-offset -513))) 1036 (let* ((start (+ (tar-desc-data-start descriptor) tar-header-offset -513)))
1067 ;; 1037 ;;
1068 ;; delete the old field and insert a new one. 1038 ;; delete the old field and insert a new one.
1069 (goto-char (+ start data-position)) 1039 (goto-char (+ start data-position))
1070 (delete-region (point) (+ (point) (length new-data-string))) ; <-- 1040 (delete-region (point) (+ (point) (length new-data-string))) ; <--
1071 (insert new-data-string) ; <-- 1041 (insert new-data-string) ; <--
1072 ;; 1042 ;;
1073 ;; compute a new checksum and insert it. 1043 ;; compute a new checksum and insert it.
1074 (let ((chk (checksum-tar-header-block 1044 (let ((chk (checksum-tar-header-block
1075 (buffer-substring start (+ start 512))))) 1045 (buffer-substring start (+ start 512)))))
1076 (goto-char (+ start tar-chk-offset)) 1046 (goto-char (+ start tar-chk-offset))
1077 (delete-region (point) (+ (point) 8)) 1047 (delete-region (point) (+ (point) 8))
1078 (insert (format "%6o" chk)) 1048 (insert (format "%6o" chk))
1079 (insert 0) 1049 (insert 0)
1080 (insert ? ) 1050 (insert ? )
1081 (tar-setf (tar-header-checksum tokens) chk) 1051 (setf (tar-header-checksum tokens) chk)
1082 ;; 1052 ;;
1083 ;; ok, make sure we didn't botch it. 1053 ;; ok, make sure we didn't botch it.
1084 (check-tar-header-block-checksum 1054 (check-tar-header-block-checksum
1085 (buffer-substring start (+ start 512)) 1055 (buffer-substring start (+ start 512))
1086 chk (tar-header-name tokens)) 1056 chk (tar-header-name tokens))
1087 ))) 1057 )))
1088 (narrow-to-region 1 tar-header-offset)))) 1058 (narrow-to-region 1 tar-header-offset))))
1089 1059
1090 1060
1091 (defun tar-subfile-save-buffer () 1061 (defun tar-subfile-save-buffer ()
1113 ;; Notice when crypt.el has uncompressed while reading the subfile, and 1083 ;; Notice when crypt.el has uncompressed while reading the subfile, and
1114 ;; signal an error if the user tries to save back into the parent file 1084 ;; signal an error if the user tries to save back into the parent file
1115 ;; (because it won't work - the .Z subfile it writes won't really be 1085 ;; (because it won't work - the .Z subfile it writes won't really be
1116 ;; compressed.) 1086 ;; compressed.)
1117 ;; 1087 ;;
1118 ; ;; These are for the old crypt.el 1088 ; ;; These are for the old crypt.el
1119 ; (if (and (boundp 'buffer-save-encrypted) buffer-save-encrypted) 1089 ; (if (and (boundp 'buffer-save-encrypted) buffer-save-encrypted)
1120 ; (error "Don't know how to encrypt back into a tar file.")) 1090 ; (error "Don't know how to encrypt back into a tar file."))
1121 ; (if (and (boundp 'buffer-save-compacted) buffer-save-compacted) 1091 ; (if (and (boundp 'buffer-save-compacted) buffer-save-compacted)
1122 ; (error "Don't know how to compact back into a tar file.")) 1092 ; (error "Don't know how to compact back into a tar file."))
1123 ; (if (and (boundp 'buffer-save-compressed) buffer-save-compressed) 1093 ; (if (and (boundp 'buffer-save-compressed) buffer-save-compressed)
1124 ; (error "Don't know how to compress back into a tar file.")) 1094 ; (error "Don't know how to compress back into a tar file."))
1125 ; (if (and (boundp 'buffer-save-gzipped) buffer-save-gzipped) 1095 ; (if (and (boundp 'buffer-save-gzipped) buffer-save-gzipped)
1126 ; (error "Don't know how to gzip back into a tar file.")) 1096 ; (error "Don't know how to gzip back into a tar file."))
1127 1097
1128 ;; These are for the new crypt++.el 1098 ;; These are for the new crypt++.el
1129 (if (and (boundp 'crypt-buffer-save-encrypted) crypt-buffer-save-encrypted) 1099 (if (and (boundp 'crypt-buffer-save-encrypted) crypt-buffer-save-encrypted)
1130 (error "Don't know how to encrypt back into a tar file.")) 1100 (error "Don't know how to encrypt back into a tar file."))
1131 (if (and (boundp 'crypt-buffer-save-compact) crypt-buffer-save-compact) 1101 (if (and (boundp 'crypt-buffer-save-compact) crypt-buffer-save-compact)
1136 (error "Don't know how to gzip back into a tar file.")) 1106 (error "Don't know how to gzip back into a tar file."))
1137 (if (and (boundp 'crypt-buffer-save-freeze) crypt-buffer-save-freeze) 1107 (if (and (boundp 'crypt-buffer-save-freeze) crypt-buffer-save-freeze)
1138 (error "Don't know how to freeze back into a tar file.")) 1108 (error "Don't know how to freeze back into a tar file."))
1139 1109
1140 (save-excursion 1110 (save-excursion
1141 (let ((subfile (current-buffer)) 1111 (let ((subfile (current-buffer))
1142 (subfile-size (buffer-size)) 1112 (subfile-size (buffer-size))
1143 (descriptor superior-tar-descriptor)) 1113 (descriptor superior-tar-descriptor))
1144 (set-buffer superior-tar-buffer) 1114 (set-buffer superior-tar-buffer)
1145 (let* ((tokens (tar-desc-tokens descriptor)) 1115 (let* ((tokens (tar-desc-tokens descriptor))
1146 (start (tar-desc-data-start descriptor)) 1116 (start (tar-desc-data-start descriptor))
1147 (name (tar-header-name tokens)) 1117 (name (tar-header-name tokens))
1148 (size (tar-header-size tokens)) 1118 (size (tar-header-size tokens))
1149 (size-pad (ash (ash (+ size 511) -9) 9)) 1119 (size-pad (ash (ash (+ size 511) -9) 9))
1150 (head (memq descriptor tar-parse-info)) 1120 (head (memq descriptor tar-parse-info))
1151 (following-descs (cdr head))) 1121 (following-descs (cdr head)))
1152 (if (not head) 1122 (if (not head)
1153 (error "Can't find this tar file entry in its parent tar file!")) 1123 (error "Can't find this tar file entry in its parent tar file!"))
1154 (unwind-protect 1124 (unwind-protect
1155 (save-excursion 1125 (save-excursion
1156 (widen) 1126 (widen)
1157 ;; delete the old data... 1127 ;; delete the old data...
1158 (let* ((data-start (+ start tar-header-offset -1)) 1128 (let* ((data-start (+ start tar-header-offset -1))
1159 (data-end (+ data-start (ash (ash (+ size 511) -9) 9)))) 1129 (data-end (+ data-start (ash (ash (+ size 511) -9) 9))))
1160 (delete-region data-start data-end) 1130 (delete-region data-start data-end)
1161 ;; insert the new data... 1131 ;; insert the new data...
1162 (goto-char data-start) 1132 (goto-char data-start)
1163 (insert-buffer subfile) 1133 (insert-buffer subfile)
1164 ;; 1134 ;;
1165 ;; pad the new data out to a multiple of 512... 1135 ;; pad the new data out to a multiple of 512...
1166 (let ((subfile-size-pad (ash (ash (+ subfile-size 511) -9) 9))) 1136 (let ((subfile-size-pad (ash (ash (+ subfile-size 511) -9) 9)))
1167 (goto-char (+ data-start subfile-size)) 1137 (goto-char (+ data-start subfile-size))
1168 (insert (make-string (- subfile-size-pad subfile-size) 0)) 1138 (insert (make-string (- subfile-size-pad subfile-size) 0))
1169 ;; 1139 ;;
1170 ;; update the data pointer of this and all following files... 1140 ;; update the data pointer of this and all following files...
1171 (tar-setf (tar-header-size tokens) subfile-size) 1141 (setf (tar-header-size tokens) subfile-size)
1172 (let ((difference (- subfile-size-pad size-pad))) 1142 (let ((difference (- subfile-size-pad size-pad)))
1173 (tar-dolist (desc following-descs) 1143 (dolist (desc following-descs)
1174 (tar-setf (tar-desc-data-start desc) 1144 (setf (tar-desc-data-start desc)
1175 (+ (tar-desc-data-start desc) difference)))) 1145 (+ (tar-desc-data-start desc) difference))))
1176 ;; 1146 ;;
1177 ;; Update the size field in the header block. 1147 ;; Update the size field in the header block.
1178 (let ((header-start (- data-start 512))) 1148 (let ((header-start (- data-start 512)))
1179 (goto-char (+ header-start tar-size-offset)) 1149 (goto-char (+ header-start tar-size-offset))
1180 (delete-region (point) (+ (point) 12)) 1150 (delete-region (point) (+ (point) 12))
1181 (insert (format "%11o" subfile-size)) 1151 (insert (format "%11o" subfile-size))
1182 (insert ? ) 1152 (insert ? )
1183 ;; 1153 ;;
1184 ;; Maybe update the datestamp. 1154 ;; Maybe update the datestamp.
1185 (if (not tar-update-datestamp) 1155 (if (not tar-update-datestamp)
1186 nil 1156 nil
1187 (goto-char (+ header-start tar-time-offset)) 1157 (goto-char (+ header-start tar-time-offset))
1188 (delete-region (point) (+ (point) 12)) 1158 (delete-region (point) (+ (point) 12))
1189 (let (now top bot) 1159 (let (now top bot)
1190 (cond ((fboundp 'current-time) 1160 (cond ((fboundp 'current-time)
1191 (setq now (current-time)) 1161 (setq now (current-time))
1192 (setcdr now (car (cdr now)))) 1162 (setcdr now (car (cdr now))))
1193 ; ((fboundp 'current-time-seconds) 1163 ; ((fboundp 'current-time-seconds)
1194 ; (setq now (current-time-seconds))) 1164 ; (setq now (current-time-seconds)))
1195 ) 1165 )
1196 (setq top (car now) 1166 (setq top (car now)
1197 bot (cdr now)) 1167 bot (cdr now))
1198 (cond 1168 (cond
1199 (now 1169 (now
1200 (tar-setf (tar-header-date tokens) now) 1170 (setf (tar-header-date tokens) now)
1201 ;; hair to print two 16-bit numbers as one octal number. 1171 ;; hair to print two 16-bit numbers as one octal number.
1202 (setq bot (logior (ash (logand top 3) 16) bot)) 1172 (setq bot (logior (ash (logand top 3) 16) bot))
1203 (setq top (ash top -2)) 1173 (setq top (ash top -2))
1204 (insert (format "%5o" top)) 1174 (insert (format "%5o" top))
1205 (insert (format "%06o " bot))) 1175 (insert (format "%06o " bot)))
1206 (t 1176 (t
1207 ;; otherwise, set it to the epoch. 1177 ;; otherwise, set it to the epoch.
1208 (insert (format "%11o " 0)) 1178 (insert (format "%11o " 0))
1209 (tar-setf (tar-header-date tokens) (cons 0 0)) 1179 (setf (tar-header-date tokens) (cons 0 0))
1210 )))) 1180 ))))
1211 ;; 1181 ;;
1212 ;; compute a new checksum and insert it. 1182 ;; compute a new checksum and insert it.
1213 (let ((chk (checksum-tar-header-block 1183 (let ((chk (checksum-tar-header-block
1214 (buffer-substring header-start data-start)))) 1184 (buffer-substring header-start data-start))))
1215 (goto-char (+ header-start tar-chk-offset)) 1185 (goto-char (+ header-start tar-chk-offset))
1216 (delete-region (point) (+ (point) 8)) 1186 (delete-region (point) (+ (point) 8))
1217 (insert (format "%6o" chk)) 1187 (insert (format "%6o" chk))
1218 (insert 0) 1188 (insert 0)
1219 (insert ? ) 1189 (insert ? )
1220 (tar-setf (tar-header-checksum tokens) chk))) 1190 (setf (tar-header-checksum tokens) chk)))
1221 ;; 1191 ;;
1222 ;; alter the descriptor-line... 1192 ;; alter the descriptor-line...
1223 ;; 1193 ;;
1224 (let ((position (- (length tar-parse-info) (length head)))) 1194 (let ((position (- (length tar-parse-info) (length head))))
1225 (goto-char 1) 1195 (goto-char 1)
1226 (next-line position) 1196 (next-line position)
1227 (beginning-of-line) 1197 (beginning-of-line)
1228 (let ((p (point)) 1198 (let ((p (point))
1229 (m (set-marker (make-marker) tar-header-offset))) 1199 (m (set-marker (make-marker) tar-header-offset)))
1230 (forward-line 1) 1200 (forward-line 1)
1231 (delete-region p (point)) 1201 (delete-region p (point))
1232 (insert-before-markers (summarize-tar-header-block tokens t) "\n") 1202 (insert-before-markers (summarize-tar-header-block tokens t) "\n")
1233 (setq tar-header-offset (marker-position m))) 1203 (setq tar-header-offset (marker-position m)))
1234 ))) 1204 )))
1235 ;; after doing the insertion, add any final padding that may be necessary. 1205 ;; after doing the insertion, add any final padding that may be necessary.
1236 (tar-pad-to-blocksize)) 1206 (tar-pad-to-blocksize))
1237 (narrow-to-region 1 tar-header-offset))) 1207 (narrow-to-region 1 tar-header-offset)))
1238 (set-buffer-modified-p t) ; mark the tar file as modified 1208 (set-buffer-modified-p t) ; mark the tar file as modified
1239 (set-buffer subfile) 1209 (set-buffer subfile)
1240 (set-buffer-modified-p nil) ; mark the tar subfile as unmodified 1210 (set-buffer-modified-p nil) ; mark the tar subfile as unmodified
1241 (message "saved into tar-buffer \"%s\" - remember to save that buffer!" 1211 (message "saved into tar-buffer \"%s\" - remember to save that buffer!"
1242 (buffer-name superior-tar-buffer)) 1212 (buffer-name superior-tar-buffer))
1243 ))) 1213 )))
1244 1214
1245 1215
1246 (defun tar-pad-to-blocksize () 1216 (defun tar-pad-to-blocksize ()
1247 "If we are being anal about tar file blocksizes, fix up the current buffer. 1217 "If we are being anal about tar file blocksizes, fix up the current buffer.
1248 Leaves the region wide." 1218 Leaves the region wide."
1255 (link-p (tar-header-link-type tokens)) 1225 (link-p (tar-header-link-type tokens))
1256 (size (if link-p 0 (tar-header-size tokens))) 1226 (size (if link-p 0 (tar-header-size tokens)))
1257 (data-end (+ start size)) 1227 (data-end (+ start size))
1258 (bbytes (ash tar-anal-blocksize 9)) 1228 (bbytes (ash tar-anal-blocksize 9))
1259 (pad-to (+ bbytes (* bbytes (/ (1- data-end) bbytes)))) 1229 (pad-to (+ bbytes (* bbytes (/ (1- data-end) bbytes))))
1260 (buffer-read-only nil) ; ## 1230 (buffer-read-only nil) ; ##
1261 ) 1231 )
1262 ;; If the padding after the last data is too long, delete some; 1232 ;; If the padding after the last data is too long, delete some;
1263 ;; else insert some until we are padded out to the right number of blocks. 1233 ;; else insert some until we are padded out to the right number of blocks.
1264 ;; 1234 ;;
1265 (goto-char (+ (or tar-header-offset 0) data-end)) 1235 (goto-char (+ (or tar-header-offset 0) data-end))
1266 (if (> (1+ (buffer-size)) (+ (or tar-header-offset 0) pad-to)) 1236 (if (> (1+ (buffer-size)) (+ (or tar-header-offset 0) pad-to))
1267 (delete-region (+ (or tar-header-offset 0) pad-to) (1+ (buffer-size))) 1237 (delete-region (+ (or tar-header-offset 0) pad-to) (1+ (buffer-size)))
1268 (insert (make-string (- (+ (or tar-header-offset 0) pad-to) 1238 (insert (make-string (- (+ (or tar-header-offset 0) pad-to)
1269 (1+ (buffer-size))) 1239 (1+ (buffer-size)))
1270 0))) 1240 0)))
1271 ))) 1241 )))
1272 1242
1273 1243
1274 (defun maybe-write-tar-file () 1244 (defun maybe-write-tar-file ()
1275 "Used as a write-file-hook to write tar-files out correctly." 1245 "Used as a write-file-hook to write tar-files out correctly."
1300 write-file-hooks))) 1270 write-file-hooks)))
1301 (remaining-hooks (cdr (memq 'maybe-write-tar-file hooks))) 1271 (remaining-hooks (cdr (memq 'maybe-write-tar-file hooks)))
1302 header-string 1272 header-string
1303 done) 1273 done)
1304 (save-excursion 1274 (save-excursion
1305 (save-restriction 1275 (save-restriction
1306 (widen) 1276 (widen)
1307 (tar-clear-modification-flags) 1277 (tar-clear-modification-flags)
1308 (setq header-string (buffer-substring 1 tar-header-offset)) 1278 (setq header-string (buffer-substring 1 tar-header-offset))
1309 (delete-region 1 tar-header-offset) 1279 (delete-region 1 tar-header-offset)
1310 (unwind-protect 1280 (unwind-protect
1311 (progn 1281 (progn
1312 (while (and remaining-hooks 1282 (while (and remaining-hooks
1313 (not (setq done (funcall (car remaining-hooks))))) 1283 (not (setq done (funcall (car remaining-hooks)))))
1314 (setq remaining-hooks (cdr remaining-hooks))) 1284 (setq remaining-hooks (cdr remaining-hooks)))
1315 (cond ((not done) 1285 (cond ((not done)
1316 (write-region 1 (1+ (buffer-size)) 1286 (write-region 1 (1+ (buffer-size))
1317 buffer-file-name nil t) 1287 buffer-file-name nil t)
1318 (setq done t)))) 1288 (setq done t))))
1319 (goto-char 1) 1289 (goto-char 1)
1320 (insert header-string) 1290 (insert header-string)
1321 (set-buffer-modified-p nil)))) 1291 (set-buffer-modified-p nil))))
1322 done))) 1292 done)))
1323 1293
1324 1294
1325 ;;; Patch it in. 1295 ;;; Patch it in.
1326 1296
1332 1302
1333 ;; Note: the tar write-file-hook should go on the list *before* any other 1303 ;; Note: the tar write-file-hook should go on the list *before* any other
1334 ;; hooks which might write the file. Since things like crypt-mode add things 1304 ;; hooks which might write the file. Since things like crypt-mode add things
1335 ;; to the end of the write-file-hooks, this will normally be the case. 1305 ;; to the end of the write-file-hooks, this will normally be the case.
1336 1306
1337 ;(or (boundp 'write-file-hooks) (setq write-file-hooks nil)) 1307 ;(or (boundp 'write-file-hooks) (setq write-file-hooks nil))
1338 ;(or (listp write-file-hooks) 1308 ;(or (listp write-file-hooks)
1339 ; (setq write-file-hooks (list write-file-hooks))) 1309 ; (setq write-file-hooks (list write-file-hooks)))
1340 ;(or (memq 'maybe-write-tar-file write-file-hooks) 1310 ;(or (memq 'maybe-write-tar-file write-file-hooks)
1341 ; (setq write-file-hooks 1311 ; (setq write-file-hooks
1342 ; (cons 'maybe-write-tar-file write-file-hooks))) 1312 ; (cons 'maybe-write-tar-file write-file-hooks)))
1343 1313
1344 (add-hook 'write-file-hooks 'maybe-write-tar-file); ####write-contents-hooks?? 1314 (add-hook 'write-file-hooks 'maybe-write-tar-file) ; ####write-contents-hooks??
1345 (cond ((boundp 'after-save-hook) 1315 (cond ((boundp 'after-save-hook)
1346 (add-hook 'after-save-hook 'tar-subfile-after-write-file-hook)) 1316 (add-hook 'after-save-hook 'tar-subfile-after-write-file-hook))
1347 ((boundp 'after-write-file-hooks) 1317 ((boundp 'after-write-file-hooks)
1348 (add-hook 'after-write-file-hooks 'tar-subfile-after-write-file-hook)) 1318 (add-hook 'after-write-file-hooks 'tar-subfile-after-write-file-hook))
1349 (t (error "neither after-save-hook nor after-write-file-hooks?"))) 1319 (t (error "neither after-save-hook nor after-write-file-hooks?")))
1371 itself." 1341 itself."
1372 (interactive) 1342 (interactive)
1373 (if (and buffer-file-name 1343 (if (and buffer-file-name
1374 (string-match tar-regexp buffer-file-name)) 1344 (string-match tar-regexp buffer-file-name))
1375 (tar-mode) 1345 (tar-mode)
1376 (tar-real-normal-mode find-file))) 1346 (tar-real-normal-mode find-file)))
1377 1347
1378 ;; We have to shadow this as well to get along with crypt.el. 1348 ;; We have to shadow this as well to get along with crypt.el.
1379 ;; Shadowing this alone isn't enough, though; we need to shadow 1349 ;; Shadowing this alone isn't enough, though; we need to shadow
1380 ;; tar-normal-mode in order to inhibit the local variables of the 1350 ;; tar-normal-mode in order to inhibit the local variables of the
1381 ;; last file in the tar archive. 1351 ;; last file in the tar archive.
1393 itself." 1363 itself."
1394 (interactive) 1364 (interactive)
1395 (if (and buffer-file-name 1365 (if (and buffer-file-name
1396 (string-match tar-regexp buffer-file-name)) 1366 (string-match tar-regexp buffer-file-name))
1397 (tar-mode) 1367 (tar-mode)
1398 (tar-real-set-auto-mode))) 1368 (tar-real-set-auto-mode)))
1399 1369
1400 (if (not (fboundp 'tar-real-normal-mode)) 1370 (if (not (fboundp 'tar-real-normal-mode))
1401 (fset 'tar-real-normal-mode (symbol-function 'normal-mode))) 1371 (fset 'tar-real-normal-mode (symbol-function 'normal-mode)))
1402 (fset 'normal-mode 'tar-normal-mode) 1372 (fset 'normal-mode 'tar-normal-mode)
1403 1373