comparison lisp/tar-mode.el @ 8023:f29df49c6e53

(tar-extract): Set file name by hand before calling set-visited-file-name. Various renamings; all callers changed. (tar-header-block-tokenize): Renamed from tokenize-tar-header-block. (tar-header-block-checksum): Renamed from checksum-tar-header-block. (tar-header-block-check-checksum): Renamed from check-tar-header-block-checksum. (tar-header-block-recompute-checksum): Renamed from recompute-tar-header-block-checksum. (tar-header-block-summarize): Renamed from summarize-tar-header-block.

8022:fcf805b27bc5

(defconst tar-gname-offset (+ tar-uname-offset 32))
(defconst tar-dmaj-offset (+ tar-gname-offset 32))
(defconst tar-dmin-offset (+ tar-dmaj-offset 8))
(defconst tar-end-offset (+ tar-dmin-offset 8))

(defun tokenize-tar-header-block (string)
  "Return a `tar-header' structure.
This is a list of name, mode, uid, gid, size, 
write-date, checksum, link-type, and link-name."
  (cond ((< (length string) 512) nil)
	(;(some 'plusp string)		 ; <-- oops, massive cycle hog!

	       (> (aref string i) ?7))
	   (error "'%c' is not an octal digit"))))
  (tar-parse-octal-integer string))


(defun checksum-tar-header-block (string)
  "Compute and return a tar-acceptable checksum for this block."
  (let* ((chk-field-start tar-chk-offset)
	 (chk-field-end (+ chk-field-start 8))
	 (sum 0)
	 (i 0))

    (while (< i 512)
      (setq sum (+ sum (aref string i))
	    i (1+ i)))
    (+ sum (* 32 8))))

(defun check-tar-header-block-checksum (hblock desired-checksum file-name)
  "Beep and print a warning if the checksum doesn't match."
  (if (not (= desired-checksum (checksum-tar-header-block hblock)))
      (progn (beep) (message "Invalid checksum for file %s!" file-name))))

(defun recompute-tar-header-block-checksum (hblock)
  "Modifies the given string to have a valid checksum field."
  (let* ((chk (checksum-tar-header-block hblock))
	 (chk-string (format "%6o" chk))
	 (l (length chk-string)))
    (aset hblock 154 0)
    (aset hblock 155 32)
    (tar-dotimes (i l) (aset hblock (- 153 i) (aref chk-string (- l i 1)))))

  (aset string (+ start 8) (if (zerop (logand   1 mode)) ?- ?x))
  (if (zerop (logand 1024 mode)) nil (aset string (+ start 2) ?s))
  (if (zerop (logand 2048 mode)) nil (aset string (+ start 5) ?s))
  string)

(defun summarize-tar-header-block (tar-hblock &optional mod-p)
  "Returns a line similar to the output of `tar -vtf'."
  (let ((name (tar-header-name tar-hblock))
	(mode (tar-header-mode tar-hblock))
	(uid (tar-header-uid tar-hblock))
	(gid (tar-header-gid tar-hblock))

	 (bs (max 1 (- (buffer-size) 1024))) ; always 2+ empty blocks at end.
	 (bs100 (max 1 (/ bs 100)))
	(tokens nil))
    (while (not (eq tokens 'empty-tar-block))
      (let* ((hblock (buffer-substring pos (+ pos 512))))
	(setq tokens (tokenize-tar-header-block hblock))
	(setq pos (+ pos 512))
	(message "parsing tar file...%s%%"
		 ;(/ (* pos 100) bs)   ; this gets round-off lossage
		 (/ pos bs100)         ; this doesn't
		 )

	    (if (< size 0)
		(error "%s has size %s - corrupted"
		       (tar-header-name tokens) size))
	    ;
	    ; This is just too slow.  Don't really need it anyway....
	    ;(check-tar-header-block-checksum
	    ;  hblock (checksum-tar-header-block hblock)
	    ;  (tar-header-name tokens))
	    
	    (setq result (cons (make-tar-desc pos tokens) result))
	    
	    (if (and (null (tar-header-link-type tokens))

  (save-excursion
    (goto-char (point-min))
    (let ((buffer-read-only nil))
      (tar-dolist (tar-desc tar-parse-info)
	(insert-string
	  (summarize-tar-header-block (tar-desc-tokens tar-desc)))
	(insert-string "\n"))
      (make-local-variable 'tar-header-offset)
      (setq tar-header-offset (point))
      (narrow-to-region 1 tar-header-offset)
      (set-buffer-modified-p nil)))

	      (widen)
	      (save-excursion
		(set-buffer buffer)
		(insert-buffer-substring tar-buffer start end)
		(goto-char 0)
		;; Give it a name for lit-buffers and to decide mode.
		(set-visited-file-name (concat tarname ":" name))
		(normal-mode)  ; pick a mode.
;;; Without a file name, save-buffer doesn't work.
;;;		(set-visited-file-name nil)  ; nuke the name - not meaningful.
		(rename-buffer bufname)
		

	  ;; update the header-line.
	  (beginning-of-line)
	  (let ((p (point)))
	    (forward-line 1)
	    (delete-region p (point))
	    (insert (summarize-tar-header-block tokens) "\n")
	    (setq tar-header-offset (point-max)))
	  
	  (widen)
	  (let* ((start (+ (tar-desc-data-start descriptor) tar-header-offset -513)))
	    ;;

	    (goto-char (+ start data-position))
	    (delete-region (point) (+ (point) (length new-data-string))) ; <--
	    (insert new-data-string) ; <--
	    ;;
	    ;; compute a new checksum and insert it.
	    (let ((chk (checksum-tar-header-block
			(buffer-substring start (+ start 512)))))
	      (goto-char (+ start tar-chk-offset))
	      (delete-region (point) (+ (point) 8))
	      (insert (format "%6o" chk))
	      (insert 0)

		(delete-region (point) (+ (point) 12))
		(insert (tar-octal-time (current-time)))
		(insert ? ))
	      ;;
	      ;; compute a new checksum and insert it.
	      (let ((chk (checksum-tar-header-block
			  (buffer-substring header-start data-start))))
		(goto-char (+ header-start tar-chk-offset))
		(delete-region (point) (+ (point) 8))
		(insert (format "%6o" chk))
		(insert 0)

		    (m (set-marker (make-marker) tar-header-offset)))
		(forward-line 1)
		(setq after (point))
		;; Insert the new text after the old, before deleting,
		;; to preserve the window start.
		(insert-before-markers (summarize-tar-header-block tokens t) "\n")
		(delete-region p after)
		(setq tar-header-offset (marker-position m)))
	      )))
	;; after doing the insertion, add any final padding that may be necessary.
	(tar-pad-to-blocksize))

8023:f29df49c6e53

(defconst tar-gname-offset (+ tar-uname-offset 32))
(defconst tar-dmaj-offset (+ tar-gname-offset 32))
(defconst tar-dmin-offset (+ tar-dmaj-offset 8))
(defconst tar-end-offset (+ tar-dmin-offset 8))

(defun tar-header-block-tokenize (string)
  "Return a `tar-header' structure.
This is a list of name, mode, uid, gid, size, 
write-date, checksum, link-type, and link-name."
  (cond ((< (length string) 512) nil)
	(;(some 'plusp string)		 ; <-- oops, massive cycle hog!

	       (> (aref string i) ?7))
	   (error "'%c' is not an octal digit"))))
  (tar-parse-octal-integer string))


(defun tar-header-block-checksum (string)
  "Compute and return a tar-acceptable checksum for this block."
  (let* ((chk-field-start tar-chk-offset)
	 (chk-field-end (+ chk-field-start 8))
	 (sum 0)
	 (i 0))

    (while (< i 512)
      (setq sum (+ sum (aref string i))
	    i (1+ i)))
    (+ sum (* 32 8))))

(defun tar-header-block-check-checksum (hblock desired-checksum file-name)
  "Beep and print a warning if the checksum doesn't match."
  (if (not (= desired-checksum (tar-header-block-checksum hblock)))
      (progn (beep) (message "Invalid checksum for file %s!" file-name))))

(defun tar-header-block-recompute-checksum (hblock)
  "Modifies the given string to have a valid checksum field."
  (let* ((chk (tar-header-block-checksum hblock))
	 (chk-string (format "%6o" chk))
	 (l (length chk-string)))
    (aset hblock 154 0)
    (aset hblock 155 32)
    (tar-dotimes (i l) (aset hblock (- 153 i) (aref chk-string (- l i 1)))))

  (aset string (+ start 8) (if (zerop (logand   1 mode)) ?- ?x))
  (if (zerop (logand 1024 mode)) nil (aset string (+ start 2) ?s))
  (if (zerop (logand 2048 mode)) nil (aset string (+ start 5) ?s))
  string)

(defun tar-header-block-summarize (tar-hblock &optional mod-p)
  "Returns a line similar to the output of `tar -vtf'."
  (let ((name (tar-header-name tar-hblock))
	(mode (tar-header-mode tar-hblock))
	(uid (tar-header-uid tar-hblock))
	(gid (tar-header-gid tar-hblock))

	 (bs (max 1 (- (buffer-size) 1024))) ; always 2+ empty blocks at end.
	 (bs100 (max 1 (/ bs 100)))
	(tokens nil))
    (while (not (eq tokens 'empty-tar-block))
      (let* ((hblock (buffer-substring pos (+ pos 512))))
	(setq tokens (tar-header-block-tokenize hblock))
	(setq pos (+ pos 512))
	(message "parsing tar file...%s%%"
		 ;(/ (* pos 100) bs)   ; this gets round-off lossage
		 (/ pos bs100)         ; this doesn't
		 )

	    (if (< size 0)
		(error "%s has size %s - corrupted"
		       (tar-header-name tokens) size))
	    ;
	    ; This is just too slow.  Don't really need it anyway....
	    ;(tar-header-block-check-checksum
	    ;  hblock (tar-header-block-checksum hblock)
	    ;  (tar-header-name tokens))
	    
	    (setq result (cons (make-tar-desc pos tokens) result))
	    
	    (if (and (null (tar-header-link-type tokens))

  (save-excursion
    (goto-char (point-min))
    (let ((buffer-read-only nil))
      (tar-dolist (tar-desc tar-parse-info)
	(insert-string
	  (tar-header-block-summarize (tar-desc-tokens tar-desc)))
	(insert-string "\n"))
      (make-local-variable 'tar-header-offset)
      (setq tar-header-offset (point))
      (narrow-to-region 1 tar-header-offset)
      (set-buffer-modified-p nil)))

	      (widen)
	      (save-excursion
		(set-buffer buffer)
		(insert-buffer-substring tar-buffer start end)
		(goto-char 0)
		;; Give it a name for list-buffers and to decide mode.
		;; Set buffer-file-name by hand first
		;; so that set-visited-file-name won't lock the filename.
		(setq buffer-file-name
		      (expand-file-name (concat tarname ":" name)))
		(set-visited-file-name buffer-file-name)
		(normal-mode)  ; pick a mode.
;;; Without a file name, save-buffer doesn't work.
;;;		(set-visited-file-name nil)  ; nuke the name - not meaningful.
		(rename-buffer bufname)
		

	  ;; update the header-line.
	  (beginning-of-line)
	  (let ((p (point)))
	    (forward-line 1)
	    (delete-region p (point))
	    (insert (tar-header-block-summarize tokens) "\n")
	    (setq tar-header-offset (point-max)))
	  
	  (widen)
	  (let* ((start (+ (tar-desc-data-start descriptor) tar-header-offset -513)))
	    ;;

	    (goto-char (+ start data-position))
	    (delete-region (point) (+ (point) (length new-data-string))) ; <--
	    (insert new-data-string) ; <--
	    ;;
	    ;; compute a new checksum and insert it.
	    (let ((chk (tar-header-block-checksum
			(buffer-substring start (+ start 512)))))
	      (goto-char (+ start tar-chk-offset))
	      (delete-region (point) (+ (point) 8))
	      (insert (format "%6o" chk))
	      (insert 0)

		(delete-region (point) (+ (point) 12))
		(insert (tar-octal-time (current-time)))
		(insert ? ))
	      ;;
	      ;; compute a new checksum and insert it.
	      (let ((chk (tar-header-block-checksum
			  (buffer-substring header-start data-start))))
		(goto-char (+ header-start tar-chk-offset))
		(delete-region (point) (+ (point) 8))
		(insert (format "%6o" chk))
		(insert 0)

		    (m (set-marker (make-marker) tar-header-offset)))
		(forward-line 1)
		(setq after (point))
		;; Insert the new text after the old, before deleting,
		;; to preserve the window start.
		(insert-before-markers (tar-header-block-summarize tokens t) "\n")
		(delete-region p after)
		(setq tar-header-offset (marker-position m)))
	      )))
	;; after doing the insertion, add any final padding that may be necessary.
	(tar-pad-to-blocksize))