Newsgroups: fj.editor.mule,fj.editor.emacs
Path: galaxy.trc.rwcp.or.jp!jaist-news!cs.titech!nirvana.cs.titech!wnoc-tyo-news!sh.wide!wnoc-kyo-news!aist-nara!newspost.aist-nara.ac.jp!kazusi-m
From: "Kazushi (Jam) Marukawa" <kazusi-m@is.aist-nara.ac.jp>
Subject: patch for tar-mode 1.26
Message-ID: <KAZUSI-M.94Apr21160630@alpha511.is.aist-nara.ac.jp>
Sender: news@newspost.aist-nara.ac.jp (USENET News System)
Nntp-Posting-Host: alpha511.aist-nara.ac.jp
Organization: NAra Institute of Science and Technology
Date: Thu, 21 Apr 1994 07:06:30 GMT
Lines: 405
Xref: galaxy.trc.rwcp.or.jp fj.editor.mule:159 fj.editor.emacs:4615
X-originally-archived-at: http://galaxy.rwcp.or.jp/text/cgi-bin/newsarticle2?ng=fj.editor.emacs&nb=4615&hd=a
X-reformat-date: Mon, 18 Oct 2004 15:18:22 +0900
X-reformat-comment: Tabs were expanded into 4 column tabstops by the Galaxy's archiver. See http://katsu.watanabe.name/ancientfj/galaxy-format.html for more info.


tar-mode 1.26$B$r(BNEmacs$B$d(BMule$B>e$G;H$C$F!"(B
tar$B%U%!%$%kCf$N%U%!%$%k$r8+$?$j=q$$$?$j$9$k;~$K(B
$BF|K\8l$r07$($k$h$&$K$9$k$?$a$N%Q%C%A$G$9!#(B

$B0JA0$K$b(BNEmacs$BMQ$H$7$FN.$7$^$7$?$,!"(BMule 1.1 p4$B$KBP1~$7$?$N(B
$B$H!"%U%!%$%k$r$A$c$s$H%3%T!<$G$-$k$h$&$KJQ99$5$l$F$$$^$9!#(B


$B$G$b!"%a%b%j$,BgNL$K;H$($J$$(BEmacs$B$+$i;H$&$N$O$*A&$a$7$^$;$s!#(B
$B%a%b%j$,L5$/$J$C$F@5>o=*N;$b$G$-$J$/$J$C$A$c$&$3$H$b$"$k$s$G!"(B
$B9M$($F;H$C$F2<$5$$!#(B

$B;H$$J}$O(B

;; Requirement:  tar-mode version 1.26 by Jamie Zawinski <jwz@lucid.com>

$B$rMQ0U$7$F!"$+$D0J2<$N%U%!%$%k$r(B

;; File:         jam-tar-mode-patch.el

$B$C$F$$$&L>A0$G%;!<%V$7$F!"(B

;;;  (setq auto-mode-alist (cons '("\\.tar$" . tar-mode) auto-mode-alist))
;;;  (autoload 'tar-mode "jam-tar-mode-patch")

$B$r(B~/.emacs$B$K=q$1$P;H$($k$h$&$K$J$j$^$9!#(B


$B$^$?(Btar$B%U%!%$%k$rFI$_9~$`;~$K%3!<%IJQ49$5$l$?$/$J$$$J$i(B($BIaDL(B
$B$=$&$@$1$I(B :-)$B!"(B

;;;  (cond ((boundp 'NEMACS)
;;;         (load "jam-binary"))
;;;        ((boundp 'MULE)
;;;         (load "guess-coding")
;;;         (insert-new-coding-from-filename
;;;          "\\.tar$\\|\\.taz$\\|\\.tar\\.Z\\|\\.tar\\.gz\\|\\.tar\\.z$"
;;;          *noconv*)
;;;         (setq insert-file-contents-pre-hook
;;;               'coding-from-filename)
;;;         ))

$B$H$+$7$F2<$5$$!#(B

$B$"$H!"(B.tar.gz$B$H$+05=L$5$l$?(Btar$B%U%!%$%k$r8+$?$$$J$i!"(B

;;;  (load "jam-zcat")

$B$H$G$b$7$F2<$5$$!#(B

--- $B$+$:$7(B
;; -*-Emacs-Lisp-*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; File:         jam-tar-mode-patch.el
;; RCS:          $Id: jam-tar-mode-patch.el,v 1.1 1994/04/20 12:32:07 kazusi-m Exp $
;; Description:  patch for tar-mode.el to use on MULE and NEmacs.
;; Requirement:  tar-mode version 1.26 by Jamie Zawinski <jwz@lucid.com>
;; Author:       Kazushi (Jam) Marukawa, kazusi-m@is.aist-nara.ac.jp
;; Created:      Wed Apr 20 21:18:47 1994
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Copyright (C) 1994 Kazushi Marukawa.
;;;
;;; Author: Kazushi (Jam) Marukawa (kazusi-m@is.aist-nara.ac.jp)
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; To autoload, add followings to your .emacs file:
;;;
;;;  (setq auto-mode-alist (cons '("\\.tar$" . tar-mode) auto-mode-alist))
;;;  (autoload 'tar-mode "jam-tar-mode-patch")

;;; This patch does only convert the code when reading from
;;; and writing to files which is contained in a tar file.
;;; You must read and write it without code conversion.  To
;;; does so, add followings to your .emacs file:
;;;
;;;  (cond ((boundp 'NEMACS)
;;;         (load "jam-binary"))
;;;        ((boundp 'MULE)
;;;         (load "guess-coding")
;;;         (insert-new-coding-from-filename
;;;          "\\.tar$\\|\\.taz$\\|\\.tar\\.Z\\|\\.tar\\.gz\\|\\.tar\\.z$"
;;;          *noconv*)
;;;         (setq insert-file-contents-pre-hook
;;;               'coding-from-filename)
;;;         ))

;;; If you want to read and write a compressed tar file, add
;;; followings to your .emacs file:
;;;
;;;  (load "jam-zcat")

(require 'tar-mode)

(setq tar-subfile-mode-hook
      (function
       (lambda ()
 (let (buffer-read-only)
   (local-set-key "\^X\^S" 'jam-tar-subfile-save-buffer)
   (if (and (boundp 'NEMACS) (boundp 'kanji-flag) kanji-flag)
       (let ((code (funcall find-kanji-file-input-code
    (tar-header-name
     (tar-desc-tokens superior-tar-descriptor))
    t
    (point-min) (point-max))))
 (if (or (eq code 1) (eq code 2))
     (convert-region-kanji-code (point-min) (point-max)
code 3))
 (setq kanji-fileio-code code))
     (if (and (boundp 'MULE) mc-flag)
 (let ((code (jam-tar-category-detect-region (point-min)
     (point-max))))
   (if (eq t code) (setq code nil))
   (cond (code
  (code-convert-region (point-min) (point-max)
       code *internal*)
  (set-file-coding-system code))))))))))

(defun jam-tar-category-detect-region (start end)
  "Detect a category of buffer string with algorithm like original
insert-file-contents function."
  (if (string-match "^1.0 " mule-version)
      (detect-code-category start end 1)
    (let ((code (code-detect-region start end)))
      (cond ((listp code) (car code))
    (t code)))))

(defun jam-tar-subfile-save-buffer ()
  "In tar subfile mode, write this buffer back 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)
  (cond (buffer-file-name
 ;; tar-subfile buffers should have nil as buffer-file-name.  If they
 ;; ever gain a buffer-file-name, that means they have been written to
 ;; a real disk file, as with ^X^W.  If this happens, behave just like
 ;; `save-buffer.'
 (call-interactively 'save-buffer))
(t
 (let ((code (if (and (boundp 'NEMACS) (boundp 'kanji-flag) kanji-flag)
 (funcall find-kanji-file-output-code
  (point-min) (point-max)
  (tar-header-name
   (tar-desc-tokens superior-tar-descriptor))
  nil t)
       (if (and (boundp 'MULE) mc-flag)
   file-coding-system))))
   (if (and (boundp 'NEMACS) (or (eq code 1) (eq code 2)))
       (convert-region-kanji-code (point-min) (point-max)
  3 code)
     (if (and (boundp 'MULE) code)
 (code-convert-region (point-min) (point-max)
      *internal* code)))
   (tar-subfile-save-buffer-internal)
   (if (and (boundp 'NEMACS) (or (eq code 1) (eq code 2)))
       (convert-region-kanji-code (point-min) (point-max)
  code 3)
     (if (and (boundp 'MULE) code)
 (code-convert-region (point-min) (point-max)
      code *internal*)))
   (set-buffer-modified-p nil)))))

(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*"))
    (widen)
    (save-excursion
      (set-buffer buffer)
      (insert-buffer-substring tar-buffer start end)
      (set-buffer-modified-p nil) ; in case we abort
      (if (and (boundp 'MULE) mc-flag)
  (write-file to-file *noconv*)
(if (boundp 'NEMACS)
    (let (kanji-flag selective-display)
      (write-file to-file))
  (write-file to-file)))
      (message "Copied tar entry %s to %s" name to-file)
      (set-buffer tar-buffer)))
(narrow-to-region 1 tar-header-offset)
(if buffer (kill-buffer buffer)))
      )))

(cond ((boundp 'MULE)
       ;; Re-defun 3 finctions.  Because the goto-char
       ;; function on MULE, move to a boundary between
       ;; two characters around the POSITION when the
       ;; mc-flag variable is equal to not-nil.
(defun tar-alter-one-field (data-position new-data-string)
  (let* ((descriptor (tar-current-descriptor))
 (tokens (tar-desc-tokens descriptor))
 mc-flag)
    (unwind-protect
(save-excursion
  ;;
  ;; 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)))
    ;;
    ;; delete the old field and insert a new one.
    (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)
      (insert ? )
      (tar-setf (tar-header-checksum tokens) chk)
      ;;
      ;; ok, make sure we didn't botch it.
      (check-tar-header-block-checksum
        (buffer-substring start (+ start 512))
        chk (tar-header-name tokens))
      )))
      (narrow-to-region 1 tar-header-offset))))

(defun tar-subfile-save-buffer-internal ()
  (if (not (and (boundp 'superior-tar-buffer) superior-tar-buffer))
      (error "this buffer has no superior tar file buffer."))
  (or (buffer-name superior-tar-buffer)
      (error "the superior tar file's buffer has been killed."))
  (if (not (and (boundp 'superior-tar-descriptor) superior-tar-descriptor))
      (error "this buffer doesn't have an index into its superior tar file!"))

  ;; Notice when crypt.el has uncompressed while reading the file, and signal
  ;; an error if the user tries to save back into the parent file (because
  ;; it won't work - the .Z subfile it writes won't really be compressed.)
  ;;
  (if (and (boundp 'buffer-save-encrypted) buffer-save-encrypted)
      (error "Don't know how to encrypt back into a tar file."))
  (if (and (boundp 'buffer-save-compacted) buffer-save-compacted)
      (error "Don't know how to compact back into a tar file."))
  (if (and (boundp 'buffer-save-compressed) buffer-save-compressed)
      (error "Don't know how to compress back into a tar file."))
  (if (and (boundp 'buffer-save-gzipped) buffer-save-gzipped)
      (error "Don't know how to gzip back into a tar file."))

  (save-excursion
  (let ((subfile (current-buffer))
(subfile-size (buffer-size))
(descriptor superior-tar-descriptor))
    (set-buffer superior-tar-buffer)
    (let* ((tokens (tar-desc-tokens descriptor))
   (start (tar-desc-data-start descriptor))
   (name (tar-header-name tokens))
   (size (tar-header-size tokens))
   (size-pad (ash (ash (+ size 511) -9) 9))
   (head (memq descriptor tar-parse-info))
   (following-descs (cdr head))
   mc-flag)
      (if (not head)
(error "Can't find this tar file entry in its parent tar file!"))
      (unwind-protect
       (save-excursion
(widen)
;; delete the old data...
(let* ((data-start (+ start tar-header-offset -1))
       (data-end (+ data-start (ash (ash (+ size 511) -9) 9))))
  (delete-region data-start data-end)
  ;; insert the new data...
  (goto-char data-start)
  (insert-buffer subfile)
  ;;
  ;; pad the new data out to a multiple of 512...
  (let ((subfile-size-pad (ash (ash (+ subfile-size 511) -9) 9)))
    (goto-char (+ data-start subfile-size))
    (insert (make-string (- subfile-size-pad subfile-size) 0))
    ;;
    ;; update the data pointer of this and all following files...
    (tar-setf (tar-header-size tokens) subfile-size)
    (let ((difference (- subfile-size-pad size-pad)))
      (tar-dolist (desc following-descs)
(tar-setf (tar-desc-data-start desc)
  (+ (tar-desc-data-start desc) difference))))
    ;;
    ;; Update the size field in the header block.
    (let ((header-start (- data-start 512)))
      (goto-char (+ header-start tar-size-offset))
      (delete-region (point) (+ (point) 12))
      (insert (format "%11o" subfile-size))
      (insert ? )
      ;;
      ;; Maybe update the datestamp.
      (if (not tar-update-datestamp)
  nil
(goto-char (+ header-start tar-time-offset))
(delete-region (point) (+ (point) 12))
(if tar-can-print-dates
    (let* ((now (current-time-seconds)) ; not defined in v18
 (top (car now))
 (bot (cdr now)))
    (tar-setf (tar-header-date tokens) now)
    ;; hair to print two 16-bit numbers as one octal number.
    (setq bot (logior (ash (logand top 3) 16) bot))
    (setq top (ash top -2))
    (insert (format "%5o" top))
    (insert (format "%06o " bot)))
  ;; otherwise, set it to the epoch.
  (insert (format "%11o " 0))
  (tar-setf (tar-header-date tokens) (cons 0 0))
  ))
      ;;
      ;; 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)
(insert ? )
(tar-setf (tar-header-checksum tokens) chk)))
    ;;
    ;; alter the descriptor-line...
    ;;
    (let ((position (- (length tar-parse-info) (length head))))
      (goto-char 1)
      (next-line position)
      (beginning-of-line)
      (let ((p (point))
    (m (set-marker (make-marker) tar-header-offset)))
(forward-line 1)
(delete-region p (point))
(insert-before-markers (summarize-tar-header-block tokens t) "\n")
(setq tar-header-offset (marker-position m)))
      )))
;; after doing the insertion, add any final padding that may be necessary.
(tar-pad-to-blocksize))
       (narrow-to-region 1 tar-header-offset)))
    (set-buffer-modified-p t)   ; mark the tar file as modified
    (set-buffer subfile)
    (set-buffer-modified-p nil) ; mark the tar subfile as unmodified
    (message "saved into tar-buffer \"%s\" - remember to save that buffer!"
     (buffer-name superior-tar-buffer))
    )))

(defun tar-pad-to-blocksize ()
  "If we are being anal about tar file blocksizes, fix up the current buffer.
Leaves the region wide."
  (if (null tar-anal-blocksize)
      nil
    (widen)
    (let* ((last-desc (nth (1- (length tar-parse-info)) tar-parse-info))
   (start (tar-desc-data-start last-desc))
   (tokens (tar-desc-tokens last-desc))
   (link-p (tar-header-link-type tokens))
   (size (if link-p 0 (tar-header-size tokens)))
   (data-end (+ start size))
   (bbytes (ash tar-anal-blocksize 9))
   (pad-to (+ bbytes (* bbytes (/ (1- data-end) bbytes))))
   (buffer-read-only nil) ; ##
   mc-flag)
      ;; If the padding after the last data is too long, delete some;
      ;; else insert some until we are padded out to the right number of blocks.
      ;;
      (goto-char (+ (or tar-header-offset 0) data-end))
      (if (> (1+ (buffer-size)) (+ (or tar-header-offset 0) pad-to))
  (delete-region (+ (or tar-header-offset 0) pad-to) (1+ (buffer-size)))
  (insert (make-string (- (+ (or tar-header-offset 0) pad-to)
  (1+ (buffer-size)))
       0)))
      )))
))
