Mercurial > hg > xemacs-beta
comparison lisp/packages/tar-mode.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | 0293115a14e9 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; tar-mode.el --- simple editing of tar files from GNU emacs | |
| 2 ;; Keywords: unix | |
| 3 | |
| 4 ;;; File: tar-mode.el | |
| 5 ;;; Description: simple editing of tar files from GNU emacs | |
| 6 ;;; Author: Jamie Zawinski <jwz@lucid.com> | |
| 7 ;;; Created: 4 Apr 1990 | |
| 8 ;;; Version: 1.31, 15 Dec 93 | |
| 9 | |
| 10 ;;; Copyright (C) 1990-1993 Free Software Foundation, Inc. | |
| 11 ;;; | |
| 12 ;; This file is part of XEmacs. | |
| 13 | |
| 14 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 15 ;; under the terms of the GNU General Public License as published by | |
| 16 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 17 ;; any later version. | |
| 18 | |
| 19 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 22 ;; General Public License for more details. | |
| 23 | |
| 24 ;; You should have received a copy of the GNU General Public License | |
| 25 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 26 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
| 27 | |
| 28 ;;; Synched up with: Not synched with FSF. | |
| 29 | |
| 30 ;;; This package attempts to make dealing with Unix 'tar' archives easier. | |
| 31 ;;; When this code is loaded, visiting a file whose name ends in '.tar' will | |
| 32 ;;; cause the contents of that archive file to be displayed in a Dired-like | |
| 33 ;;; listing. It is then possible to use the customary Dired keybindings to | |
| 34 ;;; extract sub-files from that archive, either by reading them into their own | |
| 35 ;;; editor buffers, or by copying them directly to arbitrary files on disk. | |
| 36 ;;; It is also possible to delete sub-files from within the tar file and write | |
| 37 ;;; the modified archive back to disk, or to edit sub-files within the archive | |
| 38 ;;; and re-insert the modified files into the archive. See the documentation | |
| 39 ;;; string of tar-mode for more info. | |
| 40 | |
| 41 ;;; To autoload, add this to your .emacs file: | |
| 42 ;;; | |
| 43 ;;; (setq auto-mode-alist (cons '("\\.tar$" . tar-mode) auto-mode-alist)) | |
| 44 ;;; (autoload 'tar-mode "tar-mode") | |
| 45 ;;; | |
| 46 ;;; But beware: for certain tar files - those whose very first file has | |
| 47 ;;; a -*- property line - autoloading won't work. See the function | |
| 48 ;;; "tar-normal-mode" to understand why. | |
| 49 | |
| 50 ;;; This code now understands the extra fields that GNU tar adds to tar files. | |
| 51 | |
| 52 ;;; This interacts correctly with "uncompress.el" in the Emacs library, | |
| 53 ;;; and with sufficiently recent versions of "crypt.el" by Kyle Jones. | |
| 54 | |
| 55 ;;; *************** TO DO *************** | |
| 56 ;;; | |
| 57 ;;; o There should be a command to extract the whole current buffer into files | |
| 58 ;;; on disk (right now you have to do the subfiles one at a time.) | |
| 59 ;;; | |
| 60 ;;; o chmod should understand "a+x,og-w". | |
| 61 ;;; | |
| 62 ;;; o It's not possible to add a NEW file to a tar archive; not that | |
| 63 ;;; important, but still... | |
| 64 ;;; | |
| 65 ;;; o The code is less efficient that it could be - in a lot of places, I | |
| 66 ;;; pull a 512-character string out of the buffer and parse it, when I could | |
| 67 ;;; be parsing it in place, not garbaging a string. Should redo that. | |
| 68 ;;; | |
| 69 ;;; o I'd like a command that searches for a string/regexp in every subfile | |
| 70 ;;; of an archive, where <esc> would leave you in a subfile-edit buffer. | |
| 71 ;;; (Like M-s in VM and M-r in the Zmacs mail reader.) | |
| 72 ;;; | |
| 73 ;;; o Sometimes (but not always) reverting the tar-file buffer does not | |
| 74 ;;; re-grind the listing, and you are staring at the binary tar data. | |
| 75 ;;; Typing 'g' again immediately after that will always revert and re-grind | |
| 76 ;;; it, though. I have no idea why this happens. | |
| 77 ;;; | |
| 78 ;;; o If you edit a subfile, and selective-display gets set to t, then when | |
| 79 ;;; we save the subfile, we should map ^M -> ^J. | |
| 80 ;;; | |
| 81 ;;; o Block files, sparse files, continuation files, and the various header | |
| 82 ;;; types aren't editable. Actually I don't know that they work at all. | |
| 83 ;;; If you know that they work, or know that they don't, please let me know. | |
| 84 ;;; | |
| 85 ;;; o Tar files inside of tar files don't work. | |
| 86 ;;; | |
| 87 ;;; o When using crypt-mode, you can't save a compressed or encrypted subfile | |
| 88 ;;; of a tar file back into the tar file: it is saved uncompressed. | |
| 89 | |
| 90 (defvar tar-anal-blocksize 20 | |
| 91 "*The blocksize of tar files written by Emacs, or nil, meaning don't care. | |
| 92 The blocksize of a tar file is not really the size of the blocks; rather, it is | |
| 93 the number of blocks written with one system call. When tarring to a tape, | |
| 94 this is the size of the *tape* blocks, but when writing to a file, it doesn't | |
| 95 matter much. The only noticeable difference is that if a tar file does not | |
| 96 have a blocksize of 20, the tar program will issue a warning; all this really | |
| 97 controls is how many null padding bytes go on the end of the tar file.") | |
| 98 | |
| 99 (defvar tar-update-datestamp (or (fboundp 'current-time) | |
| 100 (fboundp 'current-time-seconds)) | |
| 101 "*Whether tar-mode should play fast and loose with sub-file datestamps; | |
| 102 if this is true, then editing and saving a tar file entry back into its | |
| 103 tar file will update its datestamp. If false, the datestamp is unchanged. | |
| 104 You may or may not want this - it is good in that you can tell when a file | |
| 105 in a tar archive has been changed, but it is bad for the same reason that | |
| 106 editing a file in the tar archive at all is bad - the changed version of | |
| 107 the file never exists on disk. | |
| 108 | |
| 109 This does not work in Emacs 18, because there's no way to get the current | |
| 110 time as an integer - if this var is true, then editing a file sets its date | |
| 111 to midnight, Jan 1 1970 GMT, which happens to be what 0 encodes.") | |
| 112 | |
| 113 | |
| 114 ;;; First, duplicate some Common Lisp functions; I used to just (require 'cl) | |
| 115 ;;; but "cl.el" was messing some people up (also it's really big). | |
| 116 | |
| 117 (defmacro tar-setf (form val) | |
| 118 "A mind-numbingly simple implementation of setf." | |
| 119 (let ((mform (macroexpand form (and (boundp 'byte-compile-macro-environment) | |
| 120 byte-compile-macro-environment)))) | |
| 121 (cond ((symbolp mform) (list 'setq mform val)) | |
| 122 ((not (consp mform)) (error "can't setf %s" form)) | |
| 123 ((eq (car mform) 'aref) | |
| 124 (list 'aset (nth 1 mform) (nth 2 mform) val)) | |
| 125 ((eq (car mform) 'car) | |
| 126 (list 'setcar (nth 1 mform) val)) | |
| 127 ((eq (car mform) 'cdr) | |
| 128 (list 'setcdr (nth 1 mform) val)) | |
| 129 (t (error "don't know how to setf %s" form))))) | |
| 130 | |
| 131 (defmacro tar-dolist (control &rest body) | |
| 132 "syntax: (dolist (var-name list-expr &optional return-value) &body body)" | |
| 133 (let ((var (car control)) | |
| 134 (init (car (cdr control))) | |
| 135 (val (car (cdr (cdr control))))) | |
| 136 (list 'let (list (list '_dolist_iterator_ init)) | |
| 137 (list 'while '_dolist_iterator_ | |
| 138 (cons 'let | |
| 139 (cons (list (list var '(car _dolist_iterator_))) | |
| 140 (append body | |
| 141 (list (list 'setq '_dolist_iterator_ | |
| 142 (list 'cdr '_dolist_iterator_))))))) | |
| 143 val))) | |
| 144 | |
| 145 (defmacro tar-dotimes (control &rest body) | |
| 146 "syntax: (dotimes (var-name count-expr &optional return-value) &body body)" | |
| 147 (let ((var (car control)) | |
| 148 (n (car (cdr control))) | |
| 149 (val (car (cdr (cdr control))))) | |
| 150 (list 'let (list (list '_dotimes_end_ n) | |
| 151 (list var 0)) | |
| 152 (cons 'while | |
| 153 (cons (list '< var '_dotimes_end_) | |
| 154 (append body | |
| 155 (list (list 'setq var (list '1+ var)))))) | |
| 156 val))) | |
| 157 | |
| 158 | |
| 159 ;;; down to business. | |
| 160 | |
| 161 (defmacro make-tar-header (name mode uid git size date ck lt ln | |
| 162 magic uname gname devmaj devmin) | |
| 163 (list 'vector name mode uid git size date ck lt ln | |
| 164 magic uname gname devmaj devmin)) | |
| 165 | |
| 166 (defmacro tar-header-name (x) (list 'aref x 0)) | |
| 167 (defmacro tar-header-mode (x) (list 'aref x 1)) | |
| 168 (defmacro tar-header-uid (x) (list 'aref x 2)) | |
| 169 (defmacro tar-header-gid (x) (list 'aref x 3)) | |
| 170 (defmacro tar-header-size (x) (list 'aref x 4)) | |
| 171 (defmacro tar-header-date (x) (list 'aref x 5)) | |
| 172 (defmacro tar-header-checksum (x) (list 'aref x 6)) | |
| 173 (defmacro tar-header-link-type (x) (list 'aref x 7)) | |
| 174 (defmacro tar-header-link-name (x) (list 'aref x 8)) | |
| 175 (defmacro tar-header-magic (x) (list 'aref x 9)) | |
| 176 (defmacro tar-header-uname (x) (list 'aref x 10)) | |
| 177 (defmacro tar-header-gname (x) (list 'aref x 11)) | |
| 178 (defmacro tar-header-dmaj (x) (list 'aref x 12)) | |
| 179 (defmacro tar-header-dmin (x) (list 'aref x 13)) | |
| 180 | |
| 181 (defmacro make-tar-desc (data-start tokens) | |
| 182 (list 'cons data-start tokens)) | |
| 183 | |
| 184 (defmacro tar-desc-data-start (x) (list 'car x)) | |
| 185 (defmacro tar-desc-tokens (x) (list 'cdr x)) | |
| 186 | |
| 187 (defconst tar-name-offset 0) | |
| 188 (defconst tar-mode-offset (+ tar-name-offset 100)) | |
| 189 (defconst tar-uid-offset (+ tar-mode-offset 8)) | |
| 190 (defconst tar-gid-offset (+ tar-uid-offset 8)) | |
| 191 (defconst tar-size-offset (+ tar-gid-offset 8)) | |
| 192 (defconst tar-time-offset (+ tar-size-offset 12)) | |
| 193 (defconst tar-chk-offset (+ tar-time-offset 12)) | |
| 194 (defconst tar-linkp-offset (+ tar-chk-offset 8)) | |
| 195 (defconst tar-link-offset (+ tar-linkp-offset 1)) | |
| 196 ;;; GNU-tar specific slots. | |
| 197 (defconst tar-magic-offset (+ tar-link-offset 100)) | |
| 198 (defconst tar-uname-offset (+ tar-magic-offset 8)) | |
| 199 (defconst tar-gname-offset (+ tar-uname-offset 32)) | |
| 200 (defconst tar-dmaj-offset (+ tar-gname-offset 32)) | |
| 201 (defconst tar-dmin-offset (+ tar-dmaj-offset 8)) | |
| 202 (defconst tar-end-offset (+ tar-dmin-offset 8)) | |
| 203 | |
| 204 (defun tokenize-tar-header-block (string) | |
| 205 "Returns a 'tar-header' structure (a list of name, mode, uid, gid, size, | |
| 206 write-date, checksum, link-type, and link-name)." | |
| 207 (cond ((< (length string) 512) nil) | |
| 208 (;(some 'plusp string) ; <-- oops, massive cycle hog! | |
| 209 (or (not (= 0 (aref string 0))) ; This will do. | |
| 210 (not (= 0 (aref string 101)))) | |
| 211 (let* ((name-end (1- tar-mode-offset)) | |
| 212 (link-end (1- tar-magic-offset)) | |
| 213 (uname-end (1- tar-gname-offset)) | |
| 214 (gname-end (1- tar-dmaj-offset)) | |
| 215 (link-p (aref string tar-linkp-offset)) | |
| 216 (magic-str (substring string tar-magic-offset (1- tar-uname-offset))) | |
| 217 (uname-valid-p (or (string= "ustar " magic-str) (string= "GNUtar " magic-str))) | |
| 218 name | |
| 219 (nulsexp "[^\000]*\000")) | |
| 220 (and (string-match nulsexp string tar-name-offset) (setq name-end (min name-end (1- (match-end 0))))) | |
| 221 (and (string-match nulsexp string tar-link-offset) (setq link-end (min link-end (1- (match-end 0))))) | |
| 222 (and (string-match nulsexp string tar-uname-offset) (setq uname-end (min uname-end (1- (match-end 0))))) | |
| 223 (and (string-match nulsexp string tar-gname-offset) (setq gname-end (min gname-end (1- (match-end 0))))) | |
| 224 (setq name (substring string tar-name-offset name-end) | |
| 225 link-p (if (or (= link-p 0) (= link-p ?0)) | |
| 226 nil | |
| 227 (- link-p ?0))) | |
| 228 (if (and (null link-p) (string-match "/$" name)) (setq link-p 5)) ; directory | |
| 229 (make-tar-header | |
| 230 name | |
| 231 (tar-parse-octal-integer string tar-mode-offset (1- tar-uid-offset)) | |
| 232 (tar-parse-octal-integer string tar-uid-offset (1- tar-gid-offset)) | |
| 233 (tar-parse-octal-integer string tar-gid-offset (1- tar-size-offset)) | |
| 234 (tar-parse-octal-integer string tar-size-offset (1- tar-time-offset)) | |
| 235 (tar-parse-octal-integer-32 string tar-time-offset (1- tar-chk-offset)) | |
| 236 (tar-parse-octal-integer string tar-chk-offset (1- tar-linkp-offset)) | |
| 237 link-p | |
| 238 (substring string tar-link-offset link-end) | |
| 239 uname-valid-p | |
| 240 (and uname-valid-p (substring string tar-uname-offset uname-end)) | |
| 241 (and uname-valid-p (substring string tar-gname-offset gname-end)) | |
| 242 (tar-parse-octal-integer string tar-dmaj-offset (1- tar-dmin-offset)) | |
| 243 (tar-parse-octal-integer string tar-dmin-offset (1- tar-end-offset)) | |
| 244 ))) | |
| 245 (t 'empty-tar-block))) | |
| 246 | |
| 247 | |
| 248 (defun tar-parse-octal-integer (string &optional start end) | |
| 249 "deletes all your files, and then reboots." | |
| 250 (if (null start) (setq start 0)) | |
| 251 (if (null end) (setq end (length string))) | |
| 252 (if (= (aref string start) 0) | |
| 253 0 | |
| 254 (let ((n 0)) | |
| 255 (while (< start end) | |
| 256 (setq n (if (< (aref string start) ?0) n | |
| 257 (+ (* n 8) (- (aref string start) 48))) | |
| 258 start (1+ start))) | |
| 259 n))) | |
| 260 | |
| 261 (defun tar-parse-octal-integer-32 (string &optional start end) | |
| 262 ;; like tar-parse-octal-integer, but returns a cons of two 16-bit numbers, | |
| 263 ;; since elisp can't handle integers of that magnitude. | |
| 264 (or start (setq start 0)) | |
| 265 (or end (setq end (length string))) | |
| 266 (let ((top (tar-parse-octal-integer string start (- end 6))) | |
| 267 (bot (tar-parse-octal-integer string (- end 6) end))) | |
| 268 (setq top (logior (ash top 2) (ash bot -16))) | |
| 269 (setq bot (logand bot 65535)) | |
| 270 (cons top bot))) | |
| 271 | |
| 272 (defun tar-parse-octal-integer-safe (string) | |
| 273 (let ((L (length string))) | |
| 274 (if (= L 0) (error "empty string")) | |
| 275 (tar-dotimes (i L) | |
| 276 (if (or (< (aref string i) ?0) | |
| 277 (> (aref string i) ?7)) | |
| 278 (error "'%c' is not an octal digit.")))) | |
| 279 (tar-parse-octal-integer string)) | |
| 280 | |
| 281 | |
| 282 (defun checksum-tar-header-block (string) | |
| 283 "Computes and returns a tar-acceptable checksum for this block." | |
| 284 (let* ((chk-field-start tar-chk-offset) | |
| 285 (chk-field-end (+ chk-field-start 8)) | |
| 286 (sum 0) | |
| 287 (i 0)) | |
| 288 ;; Add up all of the characters except the ones in the checksum field. | |
| 289 ;; Add that field as if it were filled with spaces. | |
| 290 (while (< i chk-field-start) | |
| 291 (setq sum (+ sum (aref string i)) | |
| 292 i (1+ i))) | |
| 293 (setq i chk-field-end) | |
| 294 (while (< i 512) | |
| 295 (setq sum (+ sum (aref string i)) | |
| 296 i (1+ i))) | |
| 297 (+ sum (* 32 8)))) | |
| 298 | |
| 299 (defun check-tar-header-block-checksum (hblock desired-checksum file-name) | |
| 300 "Beep and print a warning if the checksum doesn't match." | |
| 301 (if (not (= desired-checksum (checksum-tar-header-block hblock))) | |
| 302 (progn (beep) (message "Invalid checksum for file %s!" file-name)))) | |
| 303 | |
| 304 (defun recompute-tar-header-block-checksum (hblock) | |
| 305 "Modifies the given string to have a valid checksum field." | |
| 306 (let* ((chk (checksum-tar-header-block hblock)) | |
| 307 (chk-string (format "%6o" chk)) | |
| 308 (l (length chk-string))) | |
| 309 (aset hblock 154 0) | |
| 310 (aset hblock 155 32) | |
| 311 (tar-dotimes (i l) (aset hblock (- 153 i) (aref chk-string (- l i 1))))) | |
| 312 hblock) | |
| 313 | |
| 314 | |
| 315 (defun tar-grind-file-mode (mode string start) | |
| 316 "Write a \"-rw--r--r-\" representing MODE into STRING beginning at START." | |
| 317 (aset string start (if (zerop (logand 256 mode)) ?- ?r)) | |
| 318 (aset string (+ start 1) (if (zerop (logand 128 mode)) ?- ?w)) | |
| 319 (aset string (+ start 2) (if (zerop (logand 64 mode)) ?- ?x)) | |
| 320 (aset string (+ start 3) (if (zerop (logand 32 mode)) ?- ?r)) | |
| 321 (aset string (+ start 4) (if (zerop (logand 16 mode)) ?- ?w)) | |
| 322 (aset string (+ start 5) (if (zerop (logand 8 mode)) ?- ?x)) | |
| 323 (aset string (+ start 6) (if (zerop (logand 4 mode)) ?- ?r)) | |
| 324 (aset string (+ start 7) (if (zerop (logand 2 mode)) ?- ?w)) | |
| 325 (aset string (+ start 8) (if (zerop (logand 1 mode)) ?- ?x)) | |
| 326 (if (zerop (logand 1024 mode)) nil (aset string (+ start 2) ?s)) | |
| 327 (if (zerop (logand 2048 mode)) nil (aset string (+ start 5) ?s)) | |
| 328 string) | |
| 329 | |
| 330 | |
| 331 (defconst tar-can-print-dates (or (fboundp 'current-time) | |
| 332 (fboundp 'current-time-seconds)) | |
| 333 "true if this emacs has been built with time-printing support") | |
| 334 | |
| 335 (defun summarize-tar-header-block (tar-hblock &optional mod-p) | |
| 336 "Returns a line similar to the output of 'tar -vtf'." | |
| 337 (let ((name (tar-header-name tar-hblock)) | |
| 338 (mode (tar-header-mode tar-hblock)) | |
| 339 (uid (tar-header-uid tar-hblock)) | |
| 340 (gid (tar-header-gid tar-hblock)) | |
| 341 (uname (tar-header-uname tar-hblock)) | |
| 342 (gname (tar-header-gname tar-hblock)) | |
| 343 (size (tar-header-size tar-hblock)) | |
| 344 (time (tar-header-date tar-hblock)) | |
| 345 (ck (tar-header-checksum tar-hblock)) | |
| 346 (link-p (tar-header-link-type tar-hblock)) | |
| 347 (link-name (tar-header-link-name tar-hblock)) | |
| 348 ) | |
| 349 (let* ((left 11) | |
| 350 (namew 8) | |
| 351 (groupw 8) | |
| 352 (sizew 8) | |
| 353 (datew (if tar-can-print-dates 15 2)) | |
| 354 (slash (1- (+ left namew))) | |
| 355 (lastdigit (+ slash groupw sizew)) | |
| 356 (namestart (+ lastdigit datew)) | |
| 357 (string (make-string (+ namestart (length name) (if link-p (+ 5 (length link-name)) 0)) 32)) | |
| 358 (type (tar-header-link-type tar-hblock))) | |
| 359 (aset string 0 (if mod-p ?* ? )) | |
| 360 (aset string 1 | |
| 361 (cond ((or (eq type nil) (eq type 0)) ?-) | |
| 362 ((eq type 1) ?l) ; link | |
| 363 ((eq type 2) ?s) ; symlink | |
| 364 ((eq type 3) ?c) ; char special | |
| 365 ((eq type 4) ?b) ; block special | |
| 366 ((eq type 5) ?d) ; directory | |
| 367 ((eq type 6) ?p) ; FIFO/pipe | |
| 368 ((eq type 20) ?*) ; directory listing | |
| 369 ((eq type 29) ?M) ; multivolume continuation | |
| 370 ((eq type 35) ?S) ; sparse | |
| 371 ((eq type 38) ?V) ; volume header | |
| 372 )) | |
| 373 (tar-grind-file-mode mode string 2) | |
| 374 (setq uid (if (= 0 (length uname)) (int-to-string uid) uname)) | |
| 375 (setq gid (if (= 0 (length gname)) (int-to-string gid) gname)) | |
| 376 (setq size (int-to-string size)) | |
| 377 (tar-dotimes (i (min (1- namew) (length uid))) (aset string (- slash i) (aref uid (- (length uid) i 1)))) | |
| 378 (aset string (1+ slash) ?/) | |
| 379 (tar-dotimes (i (min (1- groupw) (length gid))) (aset string (+ (+ slash 2) i) (aref gid i))) | |
| 380 (tar-dotimes (i (min sizew (length size))) (aset string (- lastdigit i) (aref size (- (length size) i 1)))) | |
| 381 | |
| 382 (if tar-can-print-dates | |
| 383 (let* ((year (substring (current-time-string) -4)) | |
| 384 ;; in v18, current-time-string doesn't take an argument | |
| 385 (file (current-time-string time)) | |
| 386 (file-year (substring file -4)) | |
| 387 (str (if (equal year file-year) | |
| 388 (substring file 4 16) | |
| 389 (concat (substring file 4 11) " " file-year)))) | |
| 390 (tar-dotimes (i 12) (aset string (- namestart (- 13 i)) (aref str i))))) | |
| 391 | |
| 392 (tar-dotimes (i (length name)) (aset string (+ namestart i) (aref name i))) | |
| 393 (if (or (eq link-p 1) (eq link-p 2)) | |
| 394 (progn | |
| 395 (tar-dotimes (i 3) (aset string (+ namestart 1 (length name) i) (aref (if (= link-p 1) "==>" "-->") i))) | |
| 396 (tar-dotimes (i (length link-name)) (aset string (+ namestart 5 (length name) i) (aref link-name i))))) | |
| 397 string))) | |
| 398 | |
| 399 | |
| 400 ;; buffer-local variables in the tar file's buffer: | |
| 401 ;; | |
| 402 (defvar tar-parse-info) ; the header structures | |
| 403 (defvar tar-header-offset) ; the end of the "pretty" data | |
| 404 | |
| 405 (defun tar-summarize-buffer () | |
| 406 "Parse the contents of the tar file in the current buffer, and place a | |
| 407 dired-like listing on the front; then narrow to it, so that only that listing | |
| 408 is visible (and the real data of the buffer is hidden)." | |
| 409 (message "parsing tar file...") | |
| 410 (let* ((result '()) | |
| 411 (pos 1) | |
| 412 (bs (max 1 (- (buffer-size) 1024))) ; always 2+ empty blocks at end. | |
| 413 (bs100 (max 1 (/ bs 100))) | |
| 414 (tokens nil)) | |
| 415 (while (not (eq tokens 'empty-tar-block)) | |
| 416 (if (> (+ pos 512) (point-max)) | |
| 417 (error "truncated tar file")) | |
| 418 (let* ((hblock (buffer-substring pos (+ pos 512)))) | |
| 419 (setq tokens (tokenize-tar-header-block hblock)) | |
| 420 (setq pos (+ pos 512)) | |
| 421 (message "parsing tar file...%s%%" | |
| 422 ;(/ (* pos 100) bs) ; this gets round-off lossage | |
| 423 (/ pos bs100) ; this doesn't | |
| 424 ) | |
| 425 (if (eq tokens 'empty-tar-block) | |
| 426 nil | |
| 427 (if (null tokens) (error "premature EOF parsing tar file.")) | |
| 428 (if (eq (tar-header-link-type tokens) 20) | |
| 429 ;; Foo. There's an extra empty block after these. | |
| 430 (setq pos (+ pos 512))) | |
| 431 (let ((size (tar-header-size tokens))) | |
| 432 (if (< size 0) | |
| 433 (error "%s has size %s - corrupted." | |
| 434 (tar-header-name tokens) size)) | |
| 435 ; | |
| 436 ; This is just too slow. Don't really need it anyway.... | |
| 437 ;(check-tar-header-block-checksum | |
| 438 ; hblock (checksum-tar-header-block hblock) | |
| 439 ; (tar-header-name tokens)) | |
| 440 | |
| 441 (setq result (cons (make-tar-desc pos tokens) result)) | |
| 442 | |
| 443 (if (and (null (tar-header-link-type tokens)) | |
| 444 (> size 0)) | |
| 445 (setq pos | |
| 446 (+ pos 512 (ash (ash (1- size) -9) 9)) ; this works | |
| 447 ;(+ pos (+ size (- 512 (rem (1- size) 512)))) ; this doesn't | |
| 448 )) | |
| 449 )))) | |
| 450 (make-local-variable 'tar-parse-info) | |
| 451 (setq tar-parse-info (nreverse result))) | |
| 452 (message "parsing tar file...formatting...") | |
| 453 (save-excursion | |
| 454 (goto-char (point-min)) | |
| 455 (let ((buffer-read-only nil)) | |
| 456 (tar-dolist (tar-desc tar-parse-info) | |
| 457 (insert | |
| 458 (summarize-tar-header-block (tar-desc-tokens tar-desc)) | |
| 459 "\n")) | |
| 460 (make-local-variable 'tar-header-offset) | |
| 461 (setq tar-header-offset (point)) | |
| 462 (narrow-to-region 1 tar-header-offset) | |
| 463 (set-buffer-modified-p nil))) | |
| 464 (message "parsing tar file...done.")) | |
| 465 | |
| 466 | |
| 467 (defvar tar-mode-map nil "*Local keymap for tar-mode listings.") | |
| 468 | |
| 469 (if tar-mode-map | |
| 470 nil | |
| 471 (setq tar-mode-map (make-keymap)) | |
| 472 (suppress-keymap tar-mode-map) | |
| 473 (define-key tar-mode-map " " 'tar-next-line) | |
| 474 (define-key tar-mode-map "c" 'tar-copy) | |
| 475 (define-key tar-mode-map "d" 'tar-flag-deleted) | |
| 476 (define-key tar-mode-map "\^D" 'tar-flag-deleted) | |
| 477 (define-key tar-mode-map "e" 'tar-extract) | |
| 478 (define-key tar-mode-map "f" 'tar-extract) | |
| 479 (define-key tar-mode-map "g" 'revert-buffer) | |
| 480 (define-key tar-mode-map "h" 'describe-mode) | |
| 481 (define-key tar-mode-map "n" 'tar-next-line) | |
| 482 (define-key tar-mode-map "\^N" 'tar-next-line) | |
| 483 (define-key tar-mode-map "o" 'tar-extract-other-window) | |
| 484 (define-key tar-mode-map "\^C" 'tar-copy) | |
| 485 (define-key tar-mode-map "p" 'tar-previous-line) | |
| 486 (define-key tar-mode-map "\^P" 'tar-previous-line) | |
| 487 (define-key tar-mode-map "r" 'tar-rename-entry) | |
| 488 (define-key tar-mode-map "u" 'tar-unflag) | |
| 489 (define-key tar-mode-map "v" 'tar-view) | |
| 490 (define-key tar-mode-map "x" 'tar-expunge) | |
| 491 (define-key tar-mode-map "\177" 'tar-unflag-backwards) | |
| 492 (define-key tar-mode-map "E" 'tar-extract-other-window) | |
| 493 (define-key tar-mode-map "M" 'tar-chmod-entry) | |
| 494 (define-key tar-mode-map "G" 'tar-chgrp-entry) | |
| 495 (define-key tar-mode-map "O" 'tar-chown-entry) | |
| 496 | |
| 497 (cond ((string-match "XEmacs" emacs-version) | |
| 498 (define-key tar-mode-map 'button2 'tar-track-mouse-and-extract-file) | |
| 499 (define-key tar-mode-map 'button3 'tar-popup-menu))) | |
| 500 ) | |
| 501 | |
| 502 | |
| 503 ;; XEmacs menu mouse/support added by Heiko Muenkel | |
| 504 ;; muenkel@tnt.uni-hannover.de | |
| 505 | |
| 506 (autoload 'dired-mark-region "dired-xemacs-menu") | |
| 507 | |
| 508 (defvar tar-menu | |
| 509 '("Tar Mode Commands" | |
| 510 ["Copy Subfile to Disk" tar-copy t] | |
| 511 ["Rename Subfile" tar-rename-entry t] | |
| 512 "----" | |
| 513 ["Delete Flaged Subfiles" tar-expunge t] | |
| 514 ["Flag Subfile for Deletion" tar-flag-deleted t] | |
| 515 ["Flag Subfiles in Region for Deletion" | |
| 516 (dired-mark-region '(tar-flag-deleted 1)) | |
| 517 (mark)] | |
| 518 ["Unflag Subfile" tar-unflag t] | |
| 519 ["Unflag Subfiles in Region" | |
| 520 (dired-mark-region '(tar-flag-deleted 1 t)) | |
| 521 (mark)] | |
| 522 "----" | |
| 523 ["Change Permissions of Subfile..." tar-chmod-entry t] | |
| 524 ["Change Group of Subfile..." tar-chgrp-entry t] | |
| 525 ["Change Owner of Subfile..." tar-chown-entry t] | |
| 526 "----" | |
| 527 ["Edit Subfile Other Window" tar-extract-other-window t] | |
| 528 ["Edit Subfile" tar-extract t] | |
| 529 ["View Subfile" tar-view t] | |
| 530 )) | |
| 531 | |
| 532 | |
| 533 (defun tar-track-mouse-and-extract-file (event) | |
| 534 "Visit the tar-file-entry upon which the mouse is clicked." | |
| 535 (interactive "e") | |
| 536 (mouse-set-point event) | |
| 537 (tar-next-line 0) | |
| 538 (let (buffer) | |
| 539 (save-excursion | |
| 540 (tar-extract) | |
| 541 (setq buffer (current-buffer))) | |
| 542 (switch-to-buffer buffer))) | |
| 543 | |
| 544 (defun tar-popup-menu (event) | |
| 545 "Display the tar-mode menu." | |
| 546 (interactive "@e") | |
| 547 (mouse-set-point event) | |
| 548 (tar-next-line 0) | |
| 549 (popup-menu tar-menu)) | |
| 550 | |
| 551 | |
| 552 ;; tar mode is suitable only for specially formatted data. | |
| 553 (put 'tar-mode 'mode-class 'special) | |
| 554 (put 'tar-subfile-mode 'mode-class 'special) | |
| 555 | |
| 556 ;;;###autoload | |
| 557 (defun tar-mode () | |
| 558 "Major mode for viewing a tar file as a dired-like listing of its contents. | |
| 559 You can move around using the usual cursor motion commands. | |
| 560 Letters no longer insert themselves. | |
| 561 Type 'e' to pull a file out of the tar file and into its own buffer. | |
| 562 Type 'c' to copy an entry from the tar file into another file on disk. | |
| 563 | |
| 564 If you edit a sub-file of this archive (as with the 'e' command) and | |
| 565 save it with Control-X Control-S, the contents of that buffer will be | |
| 566 saved back into the tar-file buffer; in this way you can edit a file | |
| 567 inside of a tar archive without extracting it and re-archiving it. | |
| 568 | |
| 569 See also: variables tar-update-datestamp and tar-anal-blocksize. | |
| 570 \\{tar-mode-map}" | |
| 571 ;; this is not interactive because you shouldn't be turning this | |
| 572 ;; mode on and off. You can corrupt things that way. | |
| 573 (make-local-variable 'tar-header-offset) | |
| 574 (make-local-variable 'tar-parse-info) | |
| 575 (make-local-variable 'require-final-newline) | |
| 576 (setq require-final-newline nil) ; binary data, dude... | |
| 577 (make-local-variable 'revert-buffer-function) | |
| 578 (setq revert-buffer-function 'tar-mode-revert) | |
| 579 (setq major-mode 'tar-mode) | |
| 580 (setq mode-name "Tar") | |
| 581 (use-local-map tar-mode-map) | |
| 582 (auto-save-mode 0) | |
| 583 (widen) | |
| 584 (if (and (boundp 'tar-header-offset) tar-header-offset) | |
| 585 (narrow-to-region 1 tar-header-offset) | |
| 586 (tar-summarize-buffer)) | |
| 587 | |
| 588 (cond ((string-match "XEmacs" emacs-version) | |
| 589 (require 'mode-motion) | |
| 590 (setq mode-motion-hook 'mode-motion-highlight-line) | |
| 591 (if (and current-menubar (not (assoc "Tar" current-menubar))) | |
| 592 (progn | |
| 593 (set-buffer-menubar (copy-sequence current-menubar)) | |
| 594 (add-menu nil "Tar" (cdr tar-menu)))) | |
| 595 )) | |
| 596 (run-hooks 'tar-mode-hook) | |
| 597 ) | |
| 598 | |
| 599 ;; buffer-local variables in subfile mode. | |
| 600 ;; | |
| 601 (defvar tar-subfile-mode nil) ; whether the minor-mode is on | |
| 602 (defvar superior-tar-buffer) ; parent buffer | |
| 603 (defvar superior-tar-descriptor) ; header object of this file | |
| 604 (defvar tar-subfile-buffer-id) ; pretty name-string | |
| 605 (defvar subfile-orig-mlbid) ; orig mode-line-buffer-identification | |
| 606 | |
| 607 (defun tar-subfile-mode (p) | |
| 608 "Minor mode for editing an element of a tar-file. | |
| 609 This mode redefines ^X^S to save the current buffer back into its | |
| 610 associated tar-file buffer. You must save that buffer to actually | |
| 611 save your changes to disk." | |
| 612 (interactive "P") | |
| 613 (or (and (boundp 'superior-tar-buffer) superior-tar-buffer) | |
| 614 (error "This buffer is not an element of a tar file.")) | |
| 615 (or (assq 'tar-subfile-mode minor-mode-alist) | |
| 616 (setq minor-mode-alist (append minor-mode-alist | |
| 617 (list '(tar-subfile-mode " TarFile"))))) | |
| 618 (make-local-variable 'tar-subfile-mode) | |
| 619 (setq tar-subfile-mode | |
| 620 (if (null p) | |
| 621 (not tar-subfile-mode) | |
| 622 (> (prefix-numeric-value p) 0))) | |
| 623 (cond (tar-subfile-mode | |
| 624 ;; copy the local keymap so that we don't accidentally | |
| 625 ;; alter a keymap like 'lisp-mode-map' which is shared | |
| 626 ;; by all buffers in that mode. | |
| 627 (let ((m (current-local-map))) | |
| 628 (if m (use-local-map (copy-keymap m)))) | |
| 629 (local-set-key "\^X\^S" 'tar-subfile-save-buffer) | |
| 630 ;; turn off auto-save. | |
| 631 (auto-save-mode nil) | |
| 632 (setq buffer-auto-save-file-name nil) | |
| 633 (run-hooks 'tar-subfile-mode-hook)) | |
| 634 (t | |
| 635 ;; remove the local binding for C-x C-s. | |
| 636 (local-unset-key "\^X\^S") | |
| 637 (if subfile-orig-mlbid | |
| 638 (set (make-local-variable 'mode-line-buffer-identification) | |
| 639 subfile-orig-mlbid)) | |
| 640 (setq superior-tar-buffer nil | |
| 641 superior-tar-descriptor nil | |
| 642 subfile-orig-mlbid nil) | |
| 643 )) | |
| 644 ) | |
| 645 | |
| 646 (defun tar-subfile-after-write-file-hook () | |
| 647 ;; if the buffer has a filename, then it is no longer associated with | |
| 648 ;; the tar file. Turn off subfile mode. | |
| 649 (if (and buffer-file-name tar-subfile-mode) | |
| 650 (tar-subfile-mode -1))) | |
| 651 | |
| 652 (defun tar-mode-revert (&optional no-autosave no-confirm) | |
| 653 "Revert this buffer and turn on tar mode again, to re-compute the | |
| 654 directory listing." | |
| 655 (setq tar-header-offset nil) | |
| 656 (let ((revert-buffer-function nil)) | |
| 657 (revert-buffer t no-confirm) | |
| 658 (widen)) | |
| 659 (tar-mode)) | |
| 660 | |
| 661 | |
| 662 (defun tar-next-line (p) | |
| 663 (interactive "p") | |
| 664 (forward-line p) | |
| 665 (if (eobp) nil (forward-char (if tar-can-print-dates 48 36)))) | |
| 666 | |
| 667 (defun tar-previous-line (p) | |
| 668 (interactive "p") | |
| 669 (tar-next-line (- p))) | |
| 670 | |
| 671 (defun tar-current-descriptor (&optional noerror) | |
| 672 "Returns the tar-descriptor of the current line, or signals an error." | |
| 673 ;; I wish lines had plists, like in ZMACS... | |
| 674 (or (nth (count-lines (point-min) | |
| 675 (save-excursion (beginning-of-line) (point))) | |
| 676 tar-parse-info) | |
| 677 (if noerror | |
| 678 nil | |
| 679 (error "This line does not describe a tar-file entry.")))) | |
| 680 | |
| 681 | |
| 682 (defun tar-extract (&optional other-window-p) | |
| 683 "*In tar-mode, extract this entry of the tar file into its own buffer." | |
| 684 (interactive) | |
| 685 (let* ((view-p (eq other-window-p 'view)) | |
| 686 (descriptor (tar-current-descriptor)) | |
| 687 (tokens (tar-desc-tokens descriptor)) | |
| 688 (name (tar-header-name tokens)) | |
| 689 (size (tar-header-size tokens)) | |
| 690 (link-p (tar-header-link-type tokens)) | |
| 691 (start (+ (tar-desc-data-start descriptor) tar-header-offset -1)) | |
| 692 (end (+ start size))) | |
| 693 (if link-p | |
| 694 (error "This is a %s, not a real file." | |
| 695 (cond ((eq link-p 5) "directory") | |
| 696 ((eq link-p 20) "tar directory header") | |
| 697 ((eq link-p 29) "multivolume-continuation") | |
| 698 ((eq link-p 35) "sparse entry") | |
| 699 ((eq link-p 38) "volume header") | |
| 700 (t "link")))) | |
| 701 (if (zerop size) (error "This is a zero-length file.")) | |
| 702 (let* ((tar-buffer (current-buffer)) | |
| 703 (bufname (file-name-nondirectory name)) | |
| 704 (bufid (concat ;" (" name " in " | |
| 705 " (in " | |
| 706 (file-name-nondirectory (buffer-file-name)) | |
| 707 ")")) | |
| 708 (read-only-p (or buffer-read-only view-p)) | |
| 709 (buffer nil) | |
| 710 (buffers (buffer-list)) | |
| 711 (just-created nil)) | |
| 712 ;; find a buffer visiting this subfile from this tar file. | |
| 713 (while (and buffers (not buffer)) | |
| 714 (set-buffer (car buffers)) | |
| 715 (if (and (null (buffer-file-name (car buffers))) | |
| 716 (boundp 'superior-tar-descriptor) | |
| 717 (eq superior-tar-descriptor descriptor)) | |
| 718 (setq buffer (car buffers)) | |
| 719 (setq buffers (cdr buffers)))) | |
| 720 (set-buffer tar-buffer) | |
| 721 (if buffer | |
| 722 nil | |
| 723 (setq buffer (generate-new-buffer bufname)) | |
| 724 (setq just-created t) | |
| 725 (unwind-protect | |
| 726 (progn | |
| 727 (widen) | |
| 728 (save-excursion | |
| 729 (set-buffer buffer) | |
| 730 (insert-buffer-substring tar-buffer start end) | |
| 731 (goto-char 0) | |
| 732 (let ((lock-directory nil)) ; disable locking | |
| 733 (set-visited-file-name name) ; give it a name to decide mode. | |
| 734 ;; (normal-mode) ; pick a mode. | |
| 735 ;; (after-find-file nil nil) ; pick a mode; works with crypt.el | |
| 736 ;; Ok, instead of running after-find-file, just invoke the | |
| 737 ;; find-file-hooks instead. This does everything we want | |
| 738 ;; from after-find-file, without losing when visiting .tar | |
| 739 ;; files via ange-ftp: doesn't probe the ftp site for the | |
| 740 ;; name of the subfile. | |
| 741 (normal-mode t) | |
| 742 (run-hooks 'find-file-hooks) | |
| 743 (set-visited-file-name nil) ; nuke the name - not meaningful. | |
| 744 ) | |
| 745 (make-local-variable 'superior-tar-buffer) | |
| 746 (make-local-variable 'superior-tar-descriptor) | |
| 747 (make-local-variable 'mode-line-buffer-identification) | |
| 748 (make-local-variable 'tar-subfile-buffer-id) | |
| 749 (make-local-variable 'subfile-orig-mlbid) | |
| 750 (setq superior-tar-buffer tar-buffer) | |
| 751 (setq superior-tar-descriptor descriptor) | |
| 752 (setq tar-subfile-buffer-id bufid) | |
| 753 (setq subfile-orig-mlbid mode-line-buffer-identification) | |
| 754 (cond ((stringp mode-line-buffer-identification) | |
| 755 (setq mode-line-buffer-identification | |
| 756 (list mode-line-buffer-identification)))) | |
| 757 (let ((ms (car mode-line-buffer-identification)) | |
| 758 n) | |
| 759 (cond ((and (stringp ms) | |
| 760 (string-match "%\\([0-9]+\\)b\\'" ms)) | |
| 761 (setq mode-line-buffer-identification | |
| 762 (cons | |
| 763 (concat (substring ms 0 | |
| 764 (1- (match-beginning 1))) | |
| 765 (substring ms (1+ (match-end 1)))) | |
| 766 (cons | |
| 767 (list (car (read-from-string | |
| 768 (substring ms (match-beginning 1) | |
| 769 (match-end 1)))) | |
| 770 (concat "%b" tar-subfile-buffer-id)) | |
| 771 (cdr mode-line-buffer-identification))))) | |
| 772 (t | |
| 773 (setq mode-line-buffer-identification | |
| 774 (list "Emacs: " | |
| 775 (list 17 | |
| 776 (concat "%b" | |
| 777 tar-subfile-buffer-id))))))) | |
| 778 (tar-subfile-mode 1) | |
| 779 | |
| 780 (setq buffer-read-only read-only-p) | |
| 781 (set-buffer-modified-p nil)) | |
| 782 (set-buffer tar-buffer)) | |
| 783 (narrow-to-region 1 tar-header-offset))) | |
| 784 (if view-p | |
| 785 (progn | |
| 786 (view-buffer-other-window buffer) | |
| 787 (save-excursion | |
| 788 (set-buffer buffer) | |
| 789 ;; for view-less.el; view.el can't do this. | |
| 790 (set (make-local-variable 'view-kill-on-exit) t))) | |
| 791 (if other-window-p | |
| 792 (switch-to-buffer-other-window buffer) | |
| 793 (switch-to-buffer buffer)))))) | |
| 794 | |
| 795 | |
| 796 (defun tar-extract-other-window () | |
| 797 "*In tar-mode, extract this entry of the tar file into its own buffer." | |
| 798 (interactive) | |
| 799 (tar-extract t)) | |
| 800 | |
| 801 (defun tar-view () | |
| 802 "*In tar-mode, view the tar file entry on this line." | |
| 803 (interactive) | |
| 804 (tar-extract 'view)) | |
| 805 | |
| 806 | |
| 807 (defun tar-read-file-name (&optional prompt) | |
| 808 "Calls read-file-name, with the default being the file of the current | |
| 809 tar-file descriptor." | |
| 810 (or prompt (setq prompt "Copy to: ")) | |
| 811 (let* ((default-file (expand-file-name | |
| 812 (tar-header-name (tar-desc-tokens | |
| 813 (tar-current-descriptor))))) | |
| 814 (target (expand-file-name | |
| 815 (read-file-name prompt | |
| 816 (file-name-directory default-file) | |
| 817 default-file nil)))) | |
| 818 (if (or (string= "" (file-name-nondirectory target)) | |
| 819 (file-directory-p target)) | |
| 820 (setq target (concat (if (string-match "/$" target) | |
| 821 (substring target 0 (1- (match-end 0))) | |
| 822 target) | |
| 823 "/" | |
| 824 (file-name-nondirectory default-file)))) | |
| 825 target)) | |
| 826 | |
| 827 | |
| 828 (defun tar-copy (&optional to-file) | |
| 829 "*In tar-mode, extract this entry of the tar file into a file on disk. | |
| 830 If TO-FILE is not supplied, it is prompted for, defaulting to the name of | |
| 831 the current tar-entry." | |
| 832 (interactive (list (tar-read-file-name))) | |
| 833 (let* ((descriptor (tar-current-descriptor)) | |
| 834 (tokens (tar-desc-tokens descriptor)) | |
| 835 (name (tar-header-name tokens)) | |
| 836 (size (tar-header-size tokens)) | |
| 837 (link-p (tar-header-link-type tokens)) | |
| 838 (start (+ (tar-desc-data-start descriptor) tar-header-offset -1)) | |
| 839 (end (+ start size))) | |
| 840 (if link-p (error "This is a link, not a real file.")) | |
| 841 (if (zerop size) (error "This is a zero-length file.")) | |
| 842 (let* ((tar-buffer (current-buffer)) | |
| 843 buffer) | |
| 844 (unwind-protect | |
| 845 (progn | |
| 846 (setq buffer (generate-new-buffer "*tar-copy-tmp*")) | |
| 847 (widen) | |
| 848 (save-excursion | |
| 849 (set-buffer buffer) | |
| 850 (insert-buffer-substring tar-buffer start end) | |
| 851 (set-buffer-modified-p nil) ; in case we abort | |
| 852 (write-file to-file) | |
| 853 (message "Copied tar entry %s to %s" name to-file) | |
| 854 (set-buffer tar-buffer))) | |
| 855 (narrow-to-region 1 tar-header-offset) | |
| 856 (if buffer (kill-buffer buffer))) | |
| 857 ))) | |
| 858 | |
| 859 | |
| 860 (defun tar-flag-deleted (p &optional unflag) | |
| 861 "*In tar mode, mark this sub-file to be deleted from the tar file. | |
| 862 With a prefix argument, mark that many files." | |
| 863 (interactive "p") | |
| 864 (beginning-of-line) | |
| 865 (tar-dotimes (i (if (< p 0) (- p) p)) | |
| 866 (if (tar-current-descriptor unflag) ; barf if we're not on an entry-line. | |
| 867 (progn | |
| 868 (delete-char 1) | |
| 869 (insert (if unflag " " "D")))) | |
| 870 (forward-line (if (< p 0) -1 1))) | |
| 871 (if (eobp) nil (forward-char 36))) | |
| 872 | |
| 873 (defun tar-unflag (p) | |
| 874 "*In tar mode, un-mark this sub-file if it is marked to be deleted. | |
| 875 With a prefix argument, un-mark that many files forward." | |
| 876 (interactive "p") | |
| 877 (tar-flag-deleted p t)) | |
| 878 | |
| 879 (defun tar-unflag-backwards (p) | |
| 880 "*In tar mode, un-mark this sub-file if it is marked to be deleted. | |
| 881 With a prefix argument, un-mark that many files backward." | |
| 882 (interactive "p") | |
| 883 (tar-flag-deleted (- p) t)) | |
| 884 | |
| 885 | |
| 886 (defun tar-expunge-internal () | |
| 887 "Expunge the tar-entry specified by the current line." | |
| 888 (let* ((descriptor (tar-current-descriptor)) | |
| 889 (tokens (tar-desc-tokens descriptor)) | |
| 890 (line (tar-desc-data-start descriptor)) | |
| 891 (name (tar-header-name tokens)) | |
| 892 (size (tar-header-size tokens)) | |
| 893 (link-p (tar-header-link-type tokens)) | |
| 894 (start (tar-desc-data-start descriptor)) | |
| 895 (following-descs (cdr (memq descriptor tar-parse-info)))) | |
| 896 (if link-p (setq size 0)) ; size lies for hard-links. | |
| 897 ;; | |
| 898 ;; delete the current line... | |
| 899 (beginning-of-line) | |
| 900 (let ((line-start (point))) | |
| 901 (end-of-line) (forward-char) | |
| 902 (let ((line-len (- (point) line-start))) | |
| 903 (delete-region line-start (point)) | |
| 904 ;; | |
| 905 ;; decrement the header-pointer to be in synch... | |
| 906 (setq tar-header-offset (- tar-header-offset line-len)))) | |
| 907 ;; | |
| 908 ;; delete the data pointer... | |
| 909 (setq tar-parse-info (delq descriptor tar-parse-info)) | |
| 910 ;; | |
| 911 ;; delete the data from inside the file... | |
| 912 (widen) | |
| 913 (let* ((data-start (+ start tar-header-offset -513)) | |
| 914 (data-end (+ data-start 512 (ash (ash (+ size 511) -9) 9)))) | |
| 915 (delete-region data-start data-end) | |
| 916 ;; | |
| 917 ;; and finally, decrement the start-pointers of all following | |
| 918 ;; entries in the archive. This is a pig when deleting a bunch | |
| 919 ;; of files at once - we could optimize this to only do the | |
| 920 ;; iteration over the files that remain, or only iterate up to | |
| 921 ;; the next file to be deleted. | |
| 922 (let ((data-length (- data-end data-start))) | |
| 923 (tar-dolist (desc following-descs) | |
| 924 (tar-setf (tar-desc-data-start desc) | |
| 925 (- (tar-desc-data-start desc) data-length)))) | |
| 926 )) | |
| 927 (narrow-to-region 1 tar-header-offset)) | |
| 928 | |
| 929 | |
| 930 (defun tar-expunge (&optional noconfirm) | |
| 931 "*In tar-mode, delete all the archived files flagged for deletion. | |
| 932 This does not modify the disk image; you must save the tar file itself | |
| 933 for this to be permanent." | |
| 934 (interactive) | |
| 935 (if (or noconfirm | |
| 936 (y-or-n-p "expunge files marked for deletion? ")) | |
| 937 (let ((n 0)) | |
| 938 (save-excursion | |
| 939 (goto-char 0) | |
| 940 (while (not (eobp)) | |
| 941 (if (looking-at "D") | |
| 942 (progn (tar-expunge-internal) | |
| 943 (setq n (1+ n))) | |
| 944 (forward-line 1))) | |
| 945 ;; after doing the deletions, add any padding that may be necessary. | |
| 946 (tar-pad-to-blocksize) | |
| 947 (narrow-to-region 1 tar-header-offset) | |
| 948 ) | |
| 949 (if (zerop n) | |
| 950 (message "nothing to expunge.") | |
| 951 (message "%s expunged. Be sure to save this buffer." n))))) | |
| 952 | |
| 953 | |
| 954 (defun tar-clear-modification-flags () | |
| 955 "remove the stars at the beginning of each line." | |
| 956 (save-excursion | |
| 957 (goto-char 0) | |
| 958 (while (< (point) tar-header-offset) | |
| 959 (if (looking-at "*") | |
| 960 (progn (delete-char 1) (insert " "))) | |
| 961 (forward-line 1)))) | |
| 962 | |
| 963 | |
| 964 (defun tar-chown-entry (new-uid) | |
| 965 "*Change the user-id associated with this entry in the tar file. | |
| 966 If this tar file was written by GNU tar, then you will be able to edit | |
| 967 the user id as a string; otherwise, you must edit it as a number. | |
| 968 You can force editing as a number by calling this with a prefix arg. | |
| 969 This does not modify the disk image; you must save the tar file itself | |
| 970 for this to be permanent." | |
| 971 (interactive (list | |
| 972 (let ((tokens (tar-desc-tokens (tar-current-descriptor)))) | |
| 973 (if (or current-prefix-arg | |
| 974 (not (tar-header-magic tokens))) | |
| 975 (let (n) | |
| 976 (while (not (numberp (setq n (read-minibuffer | |
| 977 "New UID number: " | |
| 978 (format "%s" (tar-header-uid tokens))))))) | |
| 979 n) | |
| 980 (read-string "New UID string: " (tar-header-uname tokens)))))) | |
| 981 (cond ((stringp new-uid) | |
| 982 (tar-setf (tar-header-uname (tar-desc-tokens (tar-current-descriptor))) | |
| 983 new-uid) | |
| 984 (tar-alter-one-field tar-uname-offset (concat new-uid "\000"))) | |
| 985 (t | |
| 986 (tar-setf (tar-header-uid (tar-desc-tokens (tar-current-descriptor))) | |
| 987 new-uid) | |
| 988 (tar-alter-one-field tar-uid-offset | |
| 989 (concat (substring (format "%6o" new-uid) 0 6) "\000 "))))) | |
| 990 | |
| 991 | |
| 992 (defun tar-chgrp-entry (new-gid) | |
| 993 "*Change the group-id associated with this entry in the tar file. | |
| 994 If this tar file was written by GNU tar, then you will be able to edit | |
| 995 the group id as a string; otherwise, you must edit it as a number. | |
| 996 You can force editing as a number by calling this with a prefix arg. | |
| 997 This does not modify the disk image; you must save the tar file itself | |
| 998 for this to be permanent." | |
| 999 (interactive (list | |
| 1000 (let ((tokens (tar-desc-tokens (tar-current-descriptor)))) | |
| 1001 (if (or current-prefix-arg | |
| 1002 (not (tar-header-magic tokens))) | |
| 1003 (let (n) | |
| 1004 (while (not (numberp (setq n (read-minibuffer | |
| 1005 "New GID number: " | |
| 1006 (format "%s" (tar-header-gid tokens))))))) | |
| 1007 n) | |
| 1008 (read-string "New GID string: " (tar-header-gname tokens)))))) | |
| 1009 (cond ((stringp new-gid) | |
| 1010 (tar-setf (tar-header-gname (tar-desc-tokens (tar-current-descriptor))) | |
| 1011 new-gid) | |
| 1012 (tar-alter-one-field tar-gname-offset | |
| 1013 (concat new-gid "\000"))) | |
| 1014 (t | |
| 1015 (tar-setf (tar-header-gid (tar-desc-tokens (tar-current-descriptor))) | |
| 1016 new-gid) | |
| 1017 (tar-alter-one-field tar-gid-offset | |
| 1018 (concat (substring (format "%6o" new-gid) 0 6) "\000 "))))) | |
| 1019 | |
| 1020 (defun tar-rename-entry (new-name) | |
| 1021 "*Change the name associated with this entry in the tar file. | |
| 1022 This does not modify the disk image; you must save the tar file itself | |
| 1023 for this to be permanent." | |
| 1024 (interactive | |
| 1025 (list (read-string "New name: " | |
| 1026 (tar-header-name (tar-desc-tokens (tar-current-descriptor)))))) | |
| 1027 (if (string= "" new-name) (error "zero length name.")) | |
| 1028 (if (> (length new-name) 98) (error "name too long.")) | |
| 1029 (tar-setf (tar-header-name (tar-desc-tokens (tar-current-descriptor))) | |
| 1030 new-name) | |
| 1031 (tar-alter-one-field 0 | |
| 1032 (substring (concat new-name (make-string 99 0)) 0 99))) | |
| 1033 | |
| 1034 | |
| 1035 (defun tar-chmod-entry (new-mode) | |
| 1036 "*Change the protection bits associated with this entry in the tar file. | |
| 1037 This does not modify the disk image; you must save the tar file itself | |
| 1038 for this to be permanent." | |
| 1039 (interactive (list (tar-parse-octal-integer-safe | |
| 1040 (read-string "New protection (octal): ")))) | |
| 1041 (tar-setf (tar-header-mode (tar-desc-tokens (tar-current-descriptor))) | |
| 1042 new-mode) | |
| 1043 (tar-alter-one-field tar-mode-offset | |
| 1044 (concat (substring (format "%6o" new-mode) 0 6) "\000 "))) | |
| 1045 | |
| 1046 | |
| 1047 (defun tar-alter-one-field (data-position new-data-string) | |
| 1048 (let* ((descriptor (tar-current-descriptor)) | |
| 1049 (tokens (tar-desc-tokens descriptor))) | |
| 1050 (unwind-protect | |
| 1051 (save-excursion | |
| 1052 ;; | |
| 1053 ;; update the header-line. | |
| 1054 (beginning-of-line) | |
| 1055 (let ((p (point))) | |
| 1056 (forward-line 1) | |
| 1057 (delete-region p (point)) | |
| 1058 (insert (summarize-tar-header-block tokens) "\n") | |
| 1059 (setq tar-header-offset (point-max))) | |
| 1060 | |
| 1061 (widen) | |
| 1062 (let* ((start (+ (tar-desc-data-start descriptor) tar-header-offset -513))) | |
| 1063 ;; | |
| 1064 ;; delete the old field and insert a new one. | |
| 1065 (goto-char (+ start data-position)) | |
| 1066 (delete-region (point) (+ (point) (length new-data-string))) ; <-- | |
| 1067 (insert new-data-string) ; <-- | |
| 1068 ;; | |
| 1069 ;; compute a new checksum and insert it. | |
| 1070 (let ((chk (checksum-tar-header-block | |
| 1071 (buffer-substring start (+ start 512))))) | |
| 1072 (goto-char (+ start tar-chk-offset)) | |
| 1073 (delete-region (point) (+ (point) 8)) | |
| 1074 (insert (format "%6o" chk)) | |
| 1075 (insert 0) | |
| 1076 (insert ? ) | |
| 1077 (tar-setf (tar-header-checksum tokens) chk) | |
| 1078 ;; | |
| 1079 ;; ok, make sure we didn't botch it. | |
| 1080 (check-tar-header-block-checksum | |
| 1081 (buffer-substring start (+ start 512)) | |
| 1082 chk (tar-header-name tokens)) | |
| 1083 ))) | |
| 1084 (narrow-to-region 1 tar-header-offset)))) | |
| 1085 | |
| 1086 | |
| 1087 (defun tar-subfile-save-buffer () | |
| 1088 "In tar subfile mode, write this buffer back into its parent tar-file buffer. | |
| 1089 This doesn't write anything to disk - you must save the parent tar-file buffer | |
| 1090 to make your changes permanent." | |
| 1091 (interactive) | |
| 1092 (cond (buffer-file-name | |
| 1093 ;; tar-subfile buffers should have nil as buffer-file-name. If they | |
| 1094 ;; ever gain a buffer-file-name, that means they have been written to | |
| 1095 ;; a real disk file, as with ^X^W. If this happens, behave just like | |
| 1096 ;; `save-buffer.' | |
| 1097 (call-interactively 'save-buffer)) | |
| 1098 (t | |
| 1099 (tar-subfile-save-buffer-internal)))) | |
| 1100 | |
| 1101 (defun tar-subfile-save-buffer-internal () | |
| 1102 (if (not (and (boundp 'superior-tar-buffer) superior-tar-buffer)) | |
| 1103 (error "this buffer has no superior tar file buffer.")) | |
| 1104 (or (buffer-name superior-tar-buffer) | |
| 1105 (error "the superior tar file's buffer has been killed.")) | |
| 1106 (if (not (and (boundp 'superior-tar-descriptor) superior-tar-descriptor)) | |
| 1107 (error "this buffer doesn't have an index into its superior tar file!")) | |
| 1108 | |
| 1109 ;; Notice when crypt.el has uncompressed while reading the subfile, and | |
| 1110 ;; signal an error if the user tries to save back into the parent file | |
| 1111 ;; (because it won't work - the .Z subfile it writes won't really be | |
| 1112 ;; compressed.) | |
| 1113 ;; | |
| 1114 ; ;; These are for the old crypt.el | |
| 1115 ; (if (and (boundp 'buffer-save-encrypted) buffer-save-encrypted) | |
| 1116 ; (error "Don't know how to encrypt back into a tar file.")) | |
| 1117 ; (if (and (boundp 'buffer-save-compacted) buffer-save-compacted) | |
| 1118 ; (error "Don't know how to compact back into a tar file.")) | |
| 1119 ; (if (and (boundp 'buffer-save-compressed) buffer-save-compressed) | |
| 1120 ; (error "Don't know how to compress back into a tar file.")) | |
| 1121 ; (if (and (boundp 'buffer-save-gzipped) buffer-save-gzipped) | |
| 1122 ; (error "Don't know how to gzip back into a tar file.")) | |
| 1123 | |
| 1124 ;; These are for the new crypt++.el | |
| 1125 (if (and (boundp 'crypt-buffer-save-encrypted) crypt-buffer-save-encrypted) | |
| 1126 (error "Don't know how to encrypt back into a tar file.")) | |
| 1127 (if (and (boundp 'crypt-buffer-save-compact) crypt-buffer-save-compact) | |
| 1128 (error "Don't know how to compact back into a tar file.")) | |
| 1129 (if (and (boundp 'crypt-buffer-save-compress) crypt-buffer-save-compress) | |
| 1130 (error "Don't know how to compress back into a tar file.")) | |
| 1131 (if (and (boundp 'crypt-buffer-save-gzip) crypt-buffer-save-gzip) | |
| 1132 (error "Don't know how to gzip back into a tar file.")) | |
| 1133 (if (and (boundp 'crypt-buffer-save-freeze) crypt-buffer-save-freeze) | |
| 1134 (error "Don't know how to freeze back into a tar file.")) | |
| 1135 | |
| 1136 (save-excursion | |
| 1137 (let ((subfile (current-buffer)) | |
| 1138 (subfile-size (buffer-size)) | |
| 1139 (descriptor superior-tar-descriptor)) | |
| 1140 (set-buffer superior-tar-buffer) | |
| 1141 (let* ((tokens (tar-desc-tokens descriptor)) | |
| 1142 (start (tar-desc-data-start descriptor)) | |
| 1143 (name (tar-header-name tokens)) | |
| 1144 (size (tar-header-size tokens)) | |
| 1145 (size-pad (ash (ash (+ size 511) -9) 9)) | |
| 1146 (head (memq descriptor tar-parse-info)) | |
| 1147 (following-descs (cdr head))) | |
| 1148 (if (not head) | |
| 1149 (error "Can't find this tar file entry in its parent tar file!")) | |
| 1150 (unwind-protect | |
| 1151 (save-excursion | |
| 1152 (widen) | |
| 1153 ;; delete the old data... | |
| 1154 (let* ((data-start (+ start tar-header-offset -1)) | |
| 1155 (data-end (+ data-start (ash (ash (+ size 511) -9) 9)))) | |
| 1156 (delete-region data-start data-end) | |
| 1157 ;; insert the new data... | |
| 1158 (goto-char data-start) | |
| 1159 (insert-buffer subfile) | |
| 1160 ;; | |
| 1161 ;; pad the new data out to a multiple of 512... | |
| 1162 (let ((subfile-size-pad (ash (ash (+ subfile-size 511) -9) 9))) | |
| 1163 (goto-char (+ data-start subfile-size)) | |
| 1164 (insert (make-string (- subfile-size-pad subfile-size) 0)) | |
| 1165 ;; | |
| 1166 ;; update the data pointer of this and all following files... | |
| 1167 (tar-setf (tar-header-size tokens) subfile-size) | |
| 1168 (let ((difference (- subfile-size-pad size-pad))) | |
| 1169 (tar-dolist (desc following-descs) | |
| 1170 (tar-setf (tar-desc-data-start desc) | |
| 1171 (+ (tar-desc-data-start desc) difference)))) | |
| 1172 ;; | |
| 1173 ;; Update the size field in the header block. | |
| 1174 (let ((header-start (- data-start 512))) | |
| 1175 (goto-char (+ header-start tar-size-offset)) | |
| 1176 (delete-region (point) (+ (point) 12)) | |
| 1177 (insert (format "%11o" subfile-size)) | |
| 1178 (insert ? ) | |
| 1179 ;; | |
| 1180 ;; Maybe update the datestamp. | |
| 1181 (if (not tar-update-datestamp) | |
| 1182 nil | |
| 1183 (goto-char (+ header-start tar-time-offset)) | |
| 1184 (delete-region (point) (+ (point) 12)) | |
| 1185 (let (now top bot) | |
| 1186 (cond ((fboundp 'current-time) | |
| 1187 (setq now (current-time)) | |
| 1188 (setcdr now (car (cdr now)))) | |
| 1189 ; ((fboundp 'current-time-seconds) | |
| 1190 ; (setq now (current-time-seconds))) | |
| 1191 ) | |
| 1192 (setq top (car now) | |
| 1193 bot (cdr now)) | |
| 1194 (cond | |
| 1195 (now | |
| 1196 (tar-setf (tar-header-date tokens) now) | |
| 1197 ;; hair to print two 16-bit numbers as one octal number. | |
| 1198 (setq bot (logior (ash (logand top 3) 16) bot)) | |
| 1199 (setq top (ash top -2)) | |
| 1200 (insert (format "%5o" top)) | |
| 1201 (insert (format "%06o " bot))) | |
| 1202 (t | |
| 1203 ;; otherwise, set it to the epoch. | |
| 1204 (insert (format "%11o " 0)) | |
| 1205 (tar-setf (tar-header-date tokens) (cons 0 0)) | |
| 1206 )))) | |
| 1207 ;; | |
| 1208 ;; compute a new checksum and insert it. | |
| 1209 (let ((chk (checksum-tar-header-block | |
| 1210 (buffer-substring header-start data-start)))) | |
| 1211 (goto-char (+ header-start tar-chk-offset)) | |
| 1212 (delete-region (point) (+ (point) 8)) | |
| 1213 (insert (format "%6o" chk)) | |
| 1214 (insert 0) | |
| 1215 (insert ? ) | |
| 1216 (tar-setf (tar-header-checksum tokens) chk))) | |
| 1217 ;; | |
| 1218 ;; alter the descriptor-line... | |
| 1219 ;; | |
| 1220 (let ((position (- (length tar-parse-info) (length head)))) | |
| 1221 (goto-char 1) | |
| 1222 (next-line position) | |
| 1223 (beginning-of-line) | |
| 1224 (let ((p (point)) | |
| 1225 (m (set-marker (make-marker) tar-header-offset))) | |
| 1226 (forward-line 1) | |
| 1227 (delete-region p (point)) | |
| 1228 (insert-before-markers (summarize-tar-header-block tokens t) "\n") | |
| 1229 (setq tar-header-offset (marker-position m))) | |
| 1230 ))) | |
| 1231 ;; after doing the insertion, add any final padding that may be necessary. | |
| 1232 (tar-pad-to-blocksize)) | |
| 1233 (narrow-to-region 1 tar-header-offset))) | |
| 1234 (set-buffer-modified-p t) ; mark the tar file as modified | |
| 1235 (set-buffer subfile) | |
| 1236 (set-buffer-modified-p nil) ; mark the tar subfile as unmodified | |
| 1237 (message "saved into tar-buffer \"%s\" - remember to save that buffer!" | |
| 1238 (buffer-name superior-tar-buffer)) | |
| 1239 ))) | |
| 1240 | |
| 1241 | |
| 1242 (defun tar-pad-to-blocksize () | |
| 1243 "If we are being anal about tar file blocksizes, fix up the current buffer. | |
| 1244 Leaves the region wide." | |
| 1245 (if (null tar-anal-blocksize) | |
| 1246 nil | |
| 1247 (widen) | |
| 1248 (let* ((last-desc (nth (1- (length tar-parse-info)) tar-parse-info)) | |
| 1249 (start (tar-desc-data-start last-desc)) | |
| 1250 (tokens (tar-desc-tokens last-desc)) | |
| 1251 (link-p (tar-header-link-type tokens)) | |
| 1252 (size (if link-p 0 (tar-header-size tokens))) | |
| 1253 (data-end (+ start size)) | |
| 1254 (bbytes (ash tar-anal-blocksize 9)) | |
| 1255 (pad-to (+ bbytes (* bbytes (/ (1- data-end) bbytes)))) | |
| 1256 (buffer-read-only nil) ; ## | |
| 1257 ) | |
| 1258 ;; If the padding after the last data is too long, delete some; | |
| 1259 ;; else insert some until we are padded out to the right number of blocks. | |
| 1260 ;; | |
| 1261 (goto-char (+ (or tar-header-offset 0) data-end)) | |
| 1262 (if (> (1+ (buffer-size)) (+ (or tar-header-offset 0) pad-to)) | |
| 1263 (delete-region (+ (or tar-header-offset 0) pad-to) (1+ (buffer-size))) | |
| 1264 (insert (make-string (- (+ (or tar-header-offset 0) pad-to) | |
| 1265 (1+ (buffer-size))) | |
| 1266 0))) | |
| 1267 ))) | |
| 1268 | |
| 1269 | |
| 1270 (defun maybe-write-tar-file () | |
| 1271 "Used as a write-file-hook to write tar-files out correctly." | |
| 1272 ;; | |
| 1273 ;; If the current buffer is in tar-mode and has its header-offset set, | |
| 1274 ;; remove the header from the file, call the remaining write-file hooks, | |
| 1275 ;; and then write out the buffer (if and only if one of the write-file | |
| 1276 ;; hooks didn't write it already). Then put the header back on the | |
| 1277 ;; buffer. Many thanks to Piet van Oostrum for this code, which causes | |
| 1278 ;; correct interaction with crypt.el (and probably anything like it.) | |
| 1279 ;; | |
| 1280 ;; Kludge: in XEmacs Emacs, write-file-hooks is bound to nil before the | |
| 1281 ;; write-file-hooks are run, to prevent them from being run recursively | |
| 1282 ;; (this is more of a danger in v19-vintage emacses, which have both | |
| 1283 ;; write-file-hooks and write-contents-hooks.) So, we need to reference | |
| 1284 ;; an internal variable of basic-save-buffer to get the list of hooks | |
| 1285 ;; remaining to be run. | |
| 1286 ;; | |
| 1287 (and (eq major-mode 'tar-mode) | |
| 1288 (and (boundp 'tar-header-offset) tar-header-offset) | |
| 1289 (let* ((hooks (cond ((string-match "XEmacs" emacs-version) | |
| 1290 ;; Internal to basic-save-buffer in XEmacs. | |
| 1291 (symbol-value 'hooks)) | |
| 1292 ((string-lessp "19" emacs-version) | |
| 1293 ;; I think this is what we need to do in fsfmacs. | |
| 1294 (append write-contents-hooks write-file-hooks)) | |
| 1295 (t | |
| 1296 write-file-hooks))) | |
| 1297 (remaining-hooks (cdr (memq 'maybe-write-tar-file hooks))) | |
| 1298 header-string | |
| 1299 done) | |
| 1300 (save-excursion | |
| 1301 (save-restriction | |
| 1302 (widen) | |
| 1303 (tar-clear-modification-flags) | |
| 1304 (setq header-string (buffer-substring 1 tar-header-offset)) | |
| 1305 (delete-region 1 tar-header-offset) | |
| 1306 (unwind-protect | |
| 1307 (progn | |
| 1308 (while (and remaining-hooks | |
| 1309 (not (setq done (funcall (car remaining-hooks))))) | |
| 1310 (setq remaining-hooks (cdr remaining-hooks))) | |
| 1311 (cond ((not done) | |
| 1312 (write-region 1 (1+ (buffer-size)) | |
| 1313 buffer-file-name nil t) | |
| 1314 (setq done t)))) | |
| 1315 (goto-char 1) | |
| 1316 (insert header-string) | |
| 1317 (set-buffer-modified-p nil)))) | |
| 1318 done))) | |
| 1319 | |
| 1320 | |
| 1321 ;;; Patch it in. | |
| 1322 | |
| 1323 (defvar tar-regexp "\\.\\(tar\\|tgz\\)$" | |
| 1324 "The regular expression used to identify tar file names.") | |
| 1325 | |
| 1326 (setq auto-mode-alist | |
| 1327 (cons (cons tar-regexp 'tar-mode) auto-mode-alist)) | |
| 1328 | |
| 1329 ;; Note: the tar write-file-hook should go on the list *before* any other | |
| 1330 ;; hooks which might write the file. Since things like crypt-mode add things | |
| 1331 ;; to the end of the write-file-hooks, this will normally be the case. | |
| 1332 | |
| 1333 ;(or (boundp 'write-file-hooks) (setq write-file-hooks nil)) | |
| 1334 ;(or (listp write-file-hooks) | |
| 1335 ; (setq write-file-hooks (list write-file-hooks))) | |
| 1336 ;(or (memq 'maybe-write-tar-file write-file-hooks) | |
| 1337 ; (setq write-file-hooks | |
| 1338 ; (cons 'maybe-write-tar-file write-file-hooks))) | |
| 1339 | |
| 1340 (add-hook 'write-file-hooks 'maybe-write-tar-file); ####write-contents-hooks?? | |
| 1341 (cond ((boundp 'after-save-hook) | |
| 1342 (add-hook 'after-save-hook 'tar-subfile-after-write-file-hook)) | |
| 1343 ((boundp 'after-write-file-hooks) | |
| 1344 (add-hook 'after-write-file-hooks 'tar-subfile-after-write-file-hook)) | |
| 1345 (t (error "neither after-save-hook nor after-write-file-hooks?"))) | |
| 1346 | |
| 1347 | |
| 1348 ;;; This is a hack. For files ending in .tar, we want -*- lines to be | |
| 1349 ;;; completely ignored - if there is one, it applies to the first file | |
| 1350 ;;; in the archive, and not the archive itself! Similarly for local | |
| 1351 ;;; variables specifications in the last file of the archive. | |
| 1352 | |
| 1353 (defun tar-normal-mode (&optional find-file) | |
| 1354 "Choose the major mode for this buffer automatically. | |
| 1355 Also sets up any specified local variables of the file. | |
| 1356 Uses the visited file name, the -*- line, and the local variables spec. | |
| 1357 | |
| 1358 This function is called automatically from `find-file'. In that case, | |
| 1359 if `inhibit-local-variables' is non-`nil' we require confirmation before | |
| 1360 processing a local variables spec. If you run `normal-mode' explicitly, | |
| 1361 confirmation is never required. | |
| 1362 | |
| 1363 Note that this version of this function has been hacked to interact | |
| 1364 correctly with tar files - when visiting a file which matches | |
| 1365 'tar-regexp', the -*- line and local-variables are not examined, | |
| 1366 as they would apply to a file within the archive rather than the archive | |
| 1367 itself." | |
| 1368 (interactive) | |
| 1369 (if (and buffer-file-name | |
| 1370 (string-match tar-regexp buffer-file-name)) | |
| 1371 (tar-mode) | |
| 1372 (tar-real-normal-mode find-file))) | |
| 1373 | |
| 1374 ;; We have to shadow this as well to get along with crypt.el. | |
| 1375 ;; Shadowing this alone isn't enough, though; we need to shadow | |
| 1376 ;; tar-normal-mode in order to inhibit the local variables of the | |
| 1377 ;; last file in the tar archive. | |
| 1378 ;; | |
| 1379 (defun tar-set-auto-mode () | |
| 1380 "Select major mode appropriate for current buffer. | |
| 1381 May base decision on visited file name (See variable auto-mode-list) | |
| 1382 or on buffer contents (-*- line or local variables spec), but does not look | |
| 1383 for the \"mode:\" local variable. For that, use hack-local-variables. | |
| 1384 | |
| 1385 Note that this version of this function has been hacked to interact | |
| 1386 correctly with tar files - when visiting a file which matches | |
| 1387 'tar-regexp', the -*- line and local-variables are not examined, | |
| 1388 as they would apply to a file within the archive rather than the archive | |
| 1389 itself." | |
| 1390 (interactive) | |
| 1391 (if (and buffer-file-name | |
| 1392 (string-match tar-regexp buffer-file-name)) | |
| 1393 (tar-mode) | |
| 1394 (tar-real-set-auto-mode))) | |
| 1395 | |
| 1396 (if (not (fboundp 'tar-real-normal-mode)) | |
| 1397 (fset 'tar-real-normal-mode (symbol-function 'normal-mode))) | |
| 1398 (fset 'normal-mode 'tar-normal-mode) | |
| 1399 | |
| 1400 (if (not (fboundp 'tar-real-set-auto-mode)) | |
| 1401 (fset 'tar-real-set-auto-mode (symbol-function 'set-auto-mode))) | |
| 1402 (fset 'set-auto-mode 'tar-set-auto-mode) | |
| 1403 | |
| 1404 (provide 'tar-mode) |