comparison lisp/tar-mode.el @ 6611:a5f180172ff3

Fix error message syntax. (tar-mode): Doc fix. (tar-mouse-extract): New command. (tar-mode-map): Bind mouse-2. (tar-get-descriptor): New function. (tar-extract, tar-copy): Use that. (tar-mode-maybe-write-tar-file): Renamed from maybe-write-tar-file.

6610:35e857d14d40

  (let ((L (length string)))
    (if (= L 0) (error "empty string"))
    (tar-dotimes (i L)
       (if (or (< (aref string i) ?0)
	       (> (aref string i) ?7))
	   (error "'%c' is not an octal digit."))))
  (tar-parse-octal-integer string))


(defun checksum-tar-header-block (string)
  "Compute and return a tar-acceptable checksum for this block."

		 ;(/ (* pos 100) bs)   ; this gets round-off lossage
		 (/ pos bs100)         ; this doesn't
		 )
	(if (eq tokens 'empty-tar-block)
	    nil
	  (if (null tokens) (error "premature EOF parsing tar file."))
	  (if (eq (tar-header-link-type tokens) 20)
	      ;; Foo.  There's an extra empty block after these.
	      (setq pos (+ pos 512)))
	  (let ((size (tar-header-size tokens)))
	    (if (< size 0)
		(error "%s has size %s - corrupted."
		       (tar-header-name tokens) size))
	    ;
	    ; This is just too slow.  Don't really need it anyway....
	    ;(check-tar-header-block-checksum
	    ;  hblock (checksum-tar-header-block hblock)

      (setq tar-header-offset (point))
      (narrow-to-region 1 tar-header-offset)
      (set-buffer-modified-p nil)))
  (message "parsing tar file...done."))

(defvar tar-mode-map nil "*Local keymap for tar-mode listings.")

(if tar-mode-map
    nil
  (setq tar-mode-map (make-keymap))
  (suppress-keymap tar-mode-map)

  (define-key tar-mode-map "c" 'tar-copy)
  (define-key tar-mode-map "d" 'tar-flag-deleted)
  (define-key tar-mode-map "\^D" 'tar-flag-deleted)
  (define-key tar-mode-map "e" 'tar-extract)
  (define-key tar-mode-map "f" 'tar-extract)
  (define-key tar-mode-map "g" 'revert-buffer)
  (define-key tar-mode-map "h" 'describe-mode)
  (define-key tar-mode-map "n" 'tar-next-line)
  (define-key tar-mode-map "\^N" 'tar-next-line)
  (define-key tar-mode-map "o" 'tar-extract-other-window)

;;;###autoload
(defun tar-mode ()
  "Major mode for viewing a tar file as a dired-like listing of its contents.
You can move around using the usual cursor motion commands. 
Letters no longer insert themselves.
Type `e' to pull a file out of the tar file and into its own buffer.
Type `c' to copy an entry from the tar file into another file on disk.

If you edit a sub-file of this archive (as with the `e' command) and 
save it with Control-x Control-s, the contents of that buffer will be 
saved back into the tar-file buffer; in this way you can edit a file 

  (or (nth (count-lines (point-min)
			(save-excursion (beginning-of-line) (point)))
	   tar-parse-info)
      (if noerror
	  nil
	  (error "This line does not describe a tar-file entry."))))


(defun tar-extract (&optional other-window-p)
  "In Tar mode, extract this entry of the tar file into its own buffer."
  (interactive)
  (let* ((view-p (eq other-window-p 'view))
	 (descriptor (tar-current-descriptor))
	 (tokens (tar-desc-tokens descriptor))
	 (name (tar-header-name tokens))
	 (size (tar-header-size tokens))
	 (link-p (tar-header-link-type tokens))
	 (start (+ (tar-desc-data-start descriptor) tar-header-offset -1))
	 (end (+ start size)))
    (if link-p
	(error "This is a %s, not a real file."
	       (cond ((eq link-p 5) "directory")
		     ((eq link-p 20) "tar directory header")
		     ((eq link-p 29) "multivolume-continuation")
		     ((eq link-p 35) "sparse entry")
		     ((eq link-p 38) "volume header")
		     (t "link"))))
    (if (zerop size) (error "This is a zero-length file."))
    (let* ((tar-buffer (current-buffer))
	   (bufname (concat (file-name-nondirectory name)
			    " (" name " in "
			    (file-name-nondirectory (buffer-file-name))
			    ")"))

(defun tar-copy (&optional to-file)
  "*In Tar mode, extract this entry of the tar file into a file on disk.
If TO-FILE is not supplied, it is prompted for, defaulting to the name of
the current tar-entry."
  (interactive (list (tar-read-file-name)))
  (let* ((descriptor (tar-current-descriptor))
	 (tokens (tar-desc-tokens descriptor))
	 (name (tar-header-name tokens))
	 (size (tar-header-size tokens))
	 (link-p (tar-header-link-type tokens))
	 (start (+ (tar-desc-data-start descriptor) tar-header-offset -1))
	 (end (+ start size)))
    (if link-p (error "This is a link, not a real file."))
    (if (zerop size) (error "This is a zero-length file."))
    (let* ((tar-buffer (current-buffer))
	   buffer)
      (unwind-protect
	  (progn
	    (setq buffer (generate-new-buffer "*tar-copy-tmp*"))

This does not modify the disk image; you must save the tar file itself
for this to be permanent."
  (interactive
    (list (read-string "New name: "
	    (tar-header-name (tar-desc-tokens (tar-current-descriptor))))))
  (if (string= "" new-name) (error "zero length name."))
  (if (> (length new-name) 98) (error "name too long."))
  (tar-setf (tar-header-name (tar-desc-tokens (tar-current-descriptor)))
	    new-name)
  (tar-alter-one-field 0
    (substring (concat new-name (make-string 99 0)) 0 99)))

  "In tar subfile mode, save this buffer into its parent tar-file buffer.
This doesn't write anything to disk; you must save the parent tar-file buffer
to make your changes permanent."
  (interactive)
  (if (not (and (boundp 'tar-superior-buffer) tar-superior-buffer))
    (error "this buffer has no superior tar file buffer."))
  (if (not (and (boundp 'tar-superior-descriptor) tar-superior-descriptor))
    (error "this buffer doesn't have an index into its superior tar file!"))
  (save-excursion
  (let ((subfile (current-buffer))
	(subfile-size (buffer-size))
	(descriptor tar-superior-descriptor))
    (set-buffer tar-superior-buffer)

				  (1+ (buffer-size)))
			       0)))
      )))


(defun maybe-write-tar-file ()
  "Used as a write-file-hook to write tar-files out correctly."
  ;;
  ;; If the current buffer is in Tar mode and has its header-offset set,
  ;; only write out the part of the file after the header-offset.
  ;;
  (if (and (eq major-mode 'tar-mode)

      nil))


;;; Patch it in.

(or (memq 'maybe-write-tar-file write-file-hooks)
    (setq write-file-hooks
	  (cons 'maybe-write-tar-file write-file-hooks)))

(provide 'tar-mode)

;;; tar-mode.el ends here

6611:a5f180172ff3

  (let ((L (length string)))
    (if (= L 0) (error "empty string"))
    (tar-dotimes (i L)
       (if (or (< (aref string i) ?0)
	       (> (aref string i) ?7))
	   (error "'%c' is not an octal digit"))))
  (tar-parse-octal-integer string))


(defun checksum-tar-header-block (string)
  "Compute and return a tar-acceptable checksum for this block."

		 ;(/ (* pos 100) bs)   ; this gets round-off lossage
		 (/ pos bs100)         ; this doesn't
		 )
	(if (eq tokens 'empty-tar-block)
	    nil
	  (if (null tokens) (error "premature EOF parsing tar file"))
	  (if (eq (tar-header-link-type tokens) 20)
	      ;; Foo.  There's an extra empty block after these.
	      (setq pos (+ pos 512)))
	  (let ((size (tar-header-size tokens)))
	    (if (< size 0)
		(error "%s has size %s - corrupted"
		       (tar-header-name tokens) size))
	    ;
	    ; This is just too slow.  Don't really need it anyway....
	    ;(check-tar-header-block-checksum
	    ;  hblock (checksum-tar-header-block hblock)

      (setq tar-header-offset (point))
      (narrow-to-region 1 tar-header-offset)
      (set-buffer-modified-p nil)))
  (message "parsing tar file...done."))

(defvar tar-mode-map nil "*Local keymap for Tar mode listings.")

(if tar-mode-map
    nil
  (setq tar-mode-map (make-keymap))
  (suppress-keymap tar-mode-map)

  (define-key tar-mode-map "c" 'tar-copy)
  (define-key tar-mode-map "d" 'tar-flag-deleted)
  (define-key tar-mode-map "\^D" 'tar-flag-deleted)
  (define-key tar-mode-map "e" 'tar-extract)
  (define-key tar-mode-map "f" 'tar-extract)
  (define-key tar-mode-map [mouse-2] 'tar-mouse-extract)
  (define-key tar-mode-map "g" 'revert-buffer)
  (define-key tar-mode-map "h" 'describe-mode)
  (define-key tar-mode-map "n" 'tar-next-line)
  (define-key tar-mode-map "\^N" 'tar-next-line)
  (define-key tar-mode-map "o" 'tar-extract-other-window)

;;;###autoload
(defun tar-mode ()
  "Major mode for viewing a tar file as a dired-like listing of its contents.
You can move around using the usual cursor motion commands. 
Letters no longer insert themselves.
Type `e' to pull a file out of the tar file and into its own buffer;
or click mouse-2 on the file's line in the Tar mode buffer.
Type `c' to copy an entry from the tar file into another file on disk.

If you edit a sub-file of this archive (as with the `e' command) and 
save it with Control-x Control-s, the contents of that buffer will be 
saved back into the tar-file buffer; in this way you can edit a file 

  (or (nth (count-lines (point-min)
			(save-excursion (beginning-of-line) (point)))
	   tar-parse-info)
      (if noerror
	  nil
	  (error "This line does not describe a tar-file entry"))))

(defun tar-get-descriptor ()
  (let* ((descriptor (tar-current-descriptor))
	 (tokens (tar-desc-tokens descriptor))
	 (size (tar-header-size tokens))
	 (link-p (tar-header-link-type tokens)))
    (if link-p
	(error "This is a %s, not a real file"
	       (cond ((eq link-p 5) "directory")
		     ((eq link-p 20) "tar directory header")
		     ((eq link-p 29) "multivolume-continuation")
		     ((eq link-p 35) "sparse entry")
		     ((eq link-p 38) "volume header")
		     (t "link"))))
    (if (zerop size) (error "This is a zero-length file"))
    descriptor))

(defun tar-mouse-extract (event)
  "Extract a file whose tar directory line you click on."
  (interactive "e")
  (save-excursion
    (set-buffer (window-buffer (posn-window (event-end event))))
    (save-excursion
      (goto-char (posn-point (event-end event)))
      ;; Just make sure this doesn't get an error.
      (tar-get-descriptor)))
  (select-window (posn-window (event-end event)))
  (goto-char (posn-point (event-end event)))
  (tar-extract))

(defun tar-extract (&optional other-window-p)
  "In Tar mode, extract this entry of the tar file into its own buffer."
  (interactive)
  (let* ((view-p (eq other-window-p 'view))
	 (descriptor (tar-get-descriptor))
	 (tokens (tar-desc-tokens descriptor))
	 (name (tar-header-name tokens))
	 (size (tar-header-size tokens))
	 (start (+ (tar-desc-data-start descriptor) tar-header-offset -1))
	 (end (+ start size)))
    (let* ((tar-buffer (current-buffer))
	   (bufname (concat (file-name-nondirectory name)
			    " (" name " in "
			    (file-name-nondirectory (buffer-file-name))
			    ")"))

(defun tar-copy (&optional to-file)
  "*In Tar mode, extract this entry of the tar file into a file on disk.
If TO-FILE is not supplied, it is prompted for, defaulting to the name of
the current tar-entry."
  (interactive (list (tar-read-file-name)))
  (let* ((descriptor (tar-get-descriptor))
	 (tokens (tar-desc-tokens descriptor))
	 (name (tar-header-name tokens))
	 (size (tar-header-size tokens))
	 (start (+ (tar-desc-data-start descriptor) tar-header-offset -1))
	 (end (+ start size)))
    (let* ((tar-buffer (current-buffer))
	   buffer)
      (unwind-protect
	  (progn
	    (setq buffer (generate-new-buffer "*tar-copy-tmp*"))

This does not modify the disk image; you must save the tar file itself
for this to be permanent."
  (interactive
    (list (read-string "New name: "
	    (tar-header-name (tar-desc-tokens (tar-current-descriptor))))))
  (if (string= "" new-name) (error "zero length name"))
  (if (> (length new-name) 98) (error "name too long"))
  (tar-setf (tar-header-name (tar-desc-tokens (tar-current-descriptor)))
	    new-name)
  (tar-alter-one-field 0
    (substring (concat new-name (make-string 99 0)) 0 99)))

  "In tar subfile mode, save this buffer into its parent tar-file buffer.
This doesn't write anything to disk; you must save the parent tar-file buffer
to make your changes permanent."
  (interactive)
  (if (not (and (boundp 'tar-superior-buffer) tar-superior-buffer))
    (error "This buffer has no superior tar file buffer"))
  (if (not (and (boundp 'tar-superior-descriptor) tar-superior-descriptor))
    (error "This buffer doesn't have an index into its superior tar file!"))
  (save-excursion
  (let ((subfile (current-buffer))
	(subfile-size (buffer-size))
	(descriptor tar-superior-descriptor))
    (set-buffer tar-superior-buffer)

				  (1+ (buffer-size)))
			       0)))
      )))


;; Used in write-file-hook to write tar-files out correctly.
(defun tar-mode-maybe-write-tar-file ()
  ;;
  ;; If the current buffer is in Tar mode and has its header-offset set,
  ;; only write out the part of the file after the header-offset.
  ;;
  (if (and (eq major-mode 'tar-mode)

      nil))


;;; Patch it in.

(or (memq 'tar-mode-maybe-write-tar-file write-file-hooks)
    (setq write-file-hooks
	  (cons 'tar-mode-maybe-write-tar-file write-file-hooks)))

(provide 'tar-mode)

;;; tar-mode.el ends here