Commit 380683ed authored by Eli Zaretskii's avatar Eli Zaretskii

(archive-tmpdir): Make the prefix of the temporary

directory absolute.
(file-name-invalid-regexp): New variable.
(archive-zip-case-fiddle): Doc fix.
(archive-remote): Make it permanent-local.
(archive-member-coding-system): New variable.
(archive-mode): Don't use write-contents-hooks for remote
archives.  Archives whose names are illegal for the current
filesystem are marked read-only.
(archive-summarize): Optional argument SHUT-UP makes it silent.
All callers changed.
(archive-unique-fname): New function.
(archive-maybe-copy): Use it.
(archive-maybe-copy, archive-write-file): Bind
coding-system-for-write to no-conversion.
(archive-maybe-update, archive-mode-revert): Bind
coding-system-for-read to no-conversion.
(archive-maybe-update): Remain at the same line in the archive
listing, after updating the archive.  Print the buffer name of the
archive to be saved.
(archive-extract): Mark archive members whose names are invalid as
read-only.  Don't set buffer-file-type.  Remove the write-contents
hook for remote archives.  Warn about read-only archives inside
other archives.
(archive-write-file-member): Handle remote archives.  Restore
value of last-coding-system-used.
(archive-*-write-file-member): Handle archives inside other
archives.  Save the value of last-coding-system-used.
(archive-write-file): New optional variable FILE: where to write
the archive; defaults to buffer-file-name, for remote archives.
(archive-zip-summarize, archive-zip-chmod-entry): Support VFAT
type of host filesystem.
(archive-zip-summarize): Don't fiddle letter case of mixed-case
file names.
parent 2036d16f
;;; arc-mode.el --- simple editing of archives
;; Copyright (C) 1995, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1997, 1998 Free Software Foundation, Inc.
;; Author: Morten Welinder <terra@diku.dk>
;; Keywords: archives msdog editing major-mode
......@@ -120,13 +120,25 @@
:group 'archive)
(defcustom archive-tmpdir
(expand-file-name
(make-temp-name (if (eq system-type 'ms-dos) "ar" "archive.tmp"))
(or (getenv "TMPDIR") (getenv "TMP") "/tmp"))
(make-temp-name
(expand-file-name (if (eq system-type 'ms-dos) "ar" "archive.tmp")
(or (getenv "TMPDIR") (getenv "TMP") "/tmp")))
"*Directory for temporary files made by arc-mode.el"
:type 'directory
:group 'archive)
(defvar archive-file-name-invalid-regexp
(cond ((and (eq system-type 'ms-dos) (not (msdos-long-file-names)))
(concat "\\(^\\([A-z]:\\)?/?.*:\\)\\|" ; colon except after drive
"[+, ;=|<>\"?*]\\|\\[\\|\\]\\|" ; invalid characters
"\\(/\\.\\.?[^/]\\)\\|" ; leading dots
"\\(/[^/.]+\\.[^/.]*\\.\\)")) ; more than a single dot
((memq system-type '(ms-dos windows-nt))
(concat "\\(^\\([A-z]:\\)?/?.*:\\)\\|" ; colon except after drive
"[|<>\"?*]")) ; invalid characters
(t "[\000]"))
"Regexp recognizing file names which aren't allowed by the filesystem.")
(defcustom archive-remote-regexp "^/[^/:]*[^/:.]:"
"*Regexp recognizing archive files names that are not local.
A non-local file is one whose file name is not proper outside Emacs.
......@@ -265,9 +277,9 @@ Archive and member name will be added."
:group 'archive-zip)
(defcustom archive-zip-case-fiddle t
"*If non-nil then zip file members are case fiddled.
Case fiddling will only happen for members created by a system that
uses caseless file names."
"*If non-nil then zip file members may be down-cased.
This case fiddling will only happen for members created by a system
that uses caseless file names."
:type 'boolean
:group 'archive-zip)
;; ------------------------------
......@@ -311,11 +323,17 @@ Archive and member name will be added."
(defvar archive-file-list-end nil "*Position just after last contents line.")
(defvar archive-proper-file-start nil "*Position of real archive's start.")
(defvar archive-read-only nil "*Non-nil if the archive is read-only on disk.")
(defvar archive-remote nil "*Non-nil if the archive is outside file system.")
(defvar archive-local-name nil "*Name of local copy of remote archive.")
(defvar archive-mode-map nil "*Local keymap for archive mode listings.")
(defvar archive-file-name-indent nil "*Column where file names start.")
(defvar archive-remote nil "*Non-nil if the archive is outside file system.")
(make-variable-buffer-local 'archive-remote)
(put 'archive-remote 'permanent-local t)
(defvar archive-member-coding-system nil "Coding-system of archive member.")
(make-variable-buffer-local 'archive-member-coding-system)
(defvar archive-alternate-display nil
"*Non-nil when alternate information is shown.")
(make-variable-buffer-local 'archive-alternate-display)
......@@ -509,23 +527,36 @@ archive.
(make-local-variable 'revert-buffer-function)
(setq revert-buffer-function 'archive-mode-revert)
(auto-save-mode 0)
(make-local-variable 'write-contents-hooks)
(add-hook 'write-contents-hooks 'archive-write-file)
;; Real file contents is binary
;; Remote archives are not written by a hook.
(if archive-remote nil
(make-local-variable 'write-contents-hooks)
(add-hook 'write-contents-hooks 'archive-write-file))
(make-local-variable 'require-final-newline)
(setq require-final-newline nil)
(make-local-variable 'enable-local-variables)
(setq enable-local-variables nil)
(make-local-variable 'archive-read-only)
(setq archive-read-only (not (file-writable-p (buffer-file-name))))
;; Archives which are inside other archives and whose
;; names are invalid for this OS, can't be written.
(setq archive-read-only
(or (not (file-writable-p (buffer-file-name)))
(and archive-subfile-mode
(string-match archive-file-name-invalid-regexp
(aref archive-subfile-mode 0)))))
;; Should we use a local copy when accessing from outside Emacs?
(make-local-variable 'archive-local-name)
(make-local-variable 'archive-remote)
(setq archive-remote (string-match archive-remote-regexp
(buffer-file-name)))
;; An archive can contain another archive whose name is invalid
;; on local filesystem. Treat such archives as remote.
(or archive-remote
(setq archive-remote
(or (string-match archive-remote-regexp (buffer-file-name))
(string-match archive-file-name-invalid-regexp
(buffer-file-name)))))
(setq major-mode 'archive-mode)
(setq mode-name (concat typename "-Archive"))
......@@ -537,7 +568,7 @@ archive.
(make-local-variable 'archive-file-list-start)
(make-local-variable 'archive-file-list-end)
(make-local-variable 'archive-file-name-indent)
(archive-summarize)
(archive-summarize nil)
(setq buffer-read-only t))))
;; Archive mode is suitable only for specially formatted data.
......@@ -663,17 +694,21 @@ archive.
'arc)
(t (error "Buffer format not recognized.")))))
;; -------------------------------------------------------------------------
(defun archive-summarize ()
(defun archive-summarize (&optional shut-up)
"Parse the contents of the archive file in the current buffer.
Place a dired-like listing on the front;
then narrow to it, so that only that listing
is visible (and the real data of the buffer is hidden)."
is visible (and the real data of the buffer is hidden).
Optional argument SHUT-UP, if non-nil, means don't print messages
when parsing the archive."
(widen)
(let (buffer-read-only)
(message "Parsing archive file...")
(or shut-up
(message "Parsing archive file..."))
(buffer-disable-undo (current-buffer))
(setq archive-files (funcall (archive-name "summarize")))
(message "Parsing archive file...done.")
(or shut-up
(message "Parsing archive file...done."))
(setq archive-proper-file-start (point-marker))
(narrow-to-region (point-min) (point))
(set-buffer-modified-p nil)
......@@ -688,7 +723,7 @@ is visible (and the real data of the buffer is hidden)."
buffer-read-only)
(widen)
(delete-region (point-min) archive-proper-file-start)
(archive-summarize)
(archive-summarize t)
(set-buffer-modified-p modified)
(goto-char archive-file-list-start)
(archive-next-line no)))
......@@ -727,32 +762,65 @@ This function changes the set of information shown for each files."
;; -------------------------------------------------------------------------
;; Section: Local archive copy handling
(defun archive-unique-fname (fname dir)
"Make sure a file FNAME can be created uniquely in directory DIR.
If FNAME can be uniquely created in DIR, it is returned unaltered.
If FNAME is something our underlying filesystem can't grok, or if another
file by that name already exists in DIR, a unique new name is generated
using `make-temp-name', and the generated name is returned."
(let ((fullname (expand-file-name fname dir))
(alien (string-match archive-file-name-invalid-regexp fname)))
(if (or alien (file-exists-p fullname))
(make-temp-name
(expand-file-name
(if (and (eq system-type 'ms-dos) (not (msdos-long-file-names)))
"am"
"arc-mode.")
dir))
fullname)))
(defun archive-maybe-copy (archive)
(if archive-remote
(let ((start (point-max)))
(setq archive-local-name (expand-file-name
(file-name-nondirectory archive)
archive-tmpdir))
(make-directory archive-tmpdir t)
(save-restriction
(widen)
(write-region start (point-max) archive-local-name nil 'nomessage))
archive-local-name)
(if (buffer-modified-p) (save-buffer))
archive))
(let ((coding-system-for-write 'no-conversion))
(if archive-remote
(let ((start (point-max))
;; Sometimes ARCHIVE is invalid while its actual name, as
;; recorded in its parent archive, is not. For example, an
;; archive bar.zip inside another archive foo.zip gets a name
;; "foo.zip:bar.zip", which is invalid on DOS/Windows.
;; So use the actual name if available.
(archive-name
(or (and archive-subfile-mode (aref archive-subfile-mode 0))
archive)))
(make-directory archive-tmpdir t)
(setq archive-local-name
(archive-unique-fname archive-name archive-tmpdir))
(save-restriction
(widen)
(write-region start (point-max) archive-local-name nil 'nomessage))
archive-local-name)
(if (buffer-modified-p) (save-buffer))
archive)))
(defun archive-maybe-update (unchanged)
(if archive-remote
(let ((name archive-local-name)
(modified (buffer-modified-p))
(coding-system-for-read 'no-conversion)
(lno (archive-get-lineno))
buffer-read-only)
(if unchanged nil
(setq archive-files nil)
(erase-buffer)
(insert-file-contents name)
(archive-mode t))
(archive-mode t)
(goto-char archive-file-list-start)
(archive-next-line lno))
(archive-delete-local name)
(if (not unchanged)
(message "Archive file must be saved for changes to take effect"))
(message
"Buffer `%s' must be saved for changes to take effect"
(buffer-name (current-buffer))))
(set-buffer-modified-p (or modified (not unchanged))))))
(defun archive-delete-local (name)
......@@ -793,7 +861,11 @@ This function changes the set of information shown for each files."
(arcname (file-name-nondirectory archive))
(bufname (concat (file-name-nondirectory iname) " (" arcname ")"))
(extractor (archive-name "extract"))
(read-only-p (or archive-read-only view-p))
;; Members with file names which aren't valid for the
;; underlying filesystem, are treated as read-only.
(read-only-p (or archive-read-only
view-p
(string-match archive-file-name-invalid-regexp ename)))
(buffer (get-buffer bufname))
(just-created nil))
(if buffer
......@@ -814,8 +886,6 @@ This function changes the set of information shown for each files."
(make-local-variable 'local-write-file-hooks)
(add-hook 'local-write-file-hooks 'archive-write-file-member)
(setq archive-subfile-mode descr)
; (if (boundp 'default-buffer-file-type)
; (setq buffer-file-type t))
(if (and
(null
(if (fboundp extractor)
......@@ -834,9 +904,16 @@ This function changes the set of information shown for each files."
(normal-mode)
;; Just in case an archive occurs inside another archive.
(if (eq major-mode 'archive-mode)
(setq archive-remote t))
(run-hooks 'archive-extract-hooks))
(archive-maybe-update t)))
(progn
(setq archive-remote t)
(if read-only-p (setq archive-read-only t))
;; We will write out the archive ourselves if it is
;; part of another archive.
(remove-hook 'write-contents-hooks 'archive-write-file t)))
(run-hooks 'archive-extract-hooks)
(if archive-read-only
(message "Note: altering this archive is not implemented."))))
(archive-maybe-update t))
(or (not (buffer-name buffer))
(progn
(if view-p
......@@ -952,17 +1029,21 @@ This function changes the set of information shown for each files."
(let ((writer (save-excursion (set-buffer archive-superior-buffer)
(archive-name "write-file-member")))
(archive (save-excursion (set-buffer archive-superior-buffer)
(buffer-file-name))))
(archive-maybe-copy (buffer-file-name)))))
(if (fboundp writer)
(funcall writer archive archive-subfile-mode)
(archive-*-write-file-member archive
archive-subfile-mode
(symbol-value writer))))
(set-buffer-modified-p nil)
(message "Updating archive...done")
(symbol-value writer)))
(set-buffer-modified-p nil)
(message "Updating archive...done"))
(set-buffer archive-superior-buffer)
(revert-buffer)
t)))
(if (not archive-remote) (revert-buffer) (archive-maybe-update nil))))
;; Restore the value of last-coding-system-used, so that basic-save-buffer
;; won't reset the coding-system of this archive member.
(if (local-variable-p 'archive-member-coding-system)
(setq last-coding-system-used archive-member-coding-system))
t)
(defun archive-*-write-file-member (archive descr command)
(let* ((ename (aref descr 0))
......@@ -972,7 +1053,16 @@ This function changes the set of information shown for each files."
(unwind-protect
(progn
(make-directory (file-name-directory tmpfile) t)
(write-region (point-min) (point-max) tmpfile nil 'nomessage)
;; If the member is itself an archive, write it without
;; the dired-like listing we created.
(if (eq major-mode 'archive-mode)
(archive-write-file tmpfile)
(write-region (point-min) (point-max) tmpfile nil 'nomessage))
;; basic-save-buffer needs last-coding-system-used to have
;; the value used to write the file, so save it before any
;; further processing clobbers it (we restore it in
;; archive-write-file-member, above).
(setq archive-member-coding-system last-coding-system-used)
(if (aref descr 3)
;; Set the file modes, but make sure we can read it.
(set-file-modes tmpfile (logior ?\400 (aref descr 3))))
......@@ -987,10 +1077,12 @@ This function changes the set of information shown for each files."
(error "Updating was unsuccessful (%S)" exitcode))))
(archive-delete-local tmpfile))))
(defun archive-write-file ()
(defun archive-write-file (&optional file)
(save-excursion
(write-region archive-proper-file-start (point-max) buffer-file-name nil t)
(set-buffer-modified-p nil)
(let ((coding-system-for-write 'no-conversion))
(write-region archive-proper-file-start (point-max)
(or file buffer-file-name) nil t)
(set-buffer-modified-p nil))
t))
;; -------------------------------------------------------------------------
;; Section: Marking and unmarking.
......@@ -1159,7 +1251,8 @@ as a relative change like \"g+rw\" as for chmod(2)"
(defun archive-mode-revert (&optional no-autosave no-confirm)
(let ((no (archive-get-lineno)))
(setq archive-files nil)
(let ((revert-buffer-function nil))
(let ((revert-buffer-function nil)
(coding-system-for-read 'no-conversion))
(revert-buffer t t))
(archive-mode)
(goto-char archive-file-list-start)
......@@ -1426,7 +1519,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(string= (file-name-nondirectory efnname) "")))
(mode (cond ((memq creator '(2 3)) ; Unix + VMS
(archive-l-e (+ p 40) 2))
((memq creator '(0 5 6 7 10 11)) ; Dos etc.
((memq creator '(0 5 6 7 10 11 15)) ; Dos etc.
(logior ?\444
(if isdir (logior 16384 ?\111) 0)
(if (zerop
......@@ -1435,7 +1528,8 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(t nil)))
(modestr (if mode (archive-int-to-mode mode) "??????????"))
(fiddle (and archive-zip-case-fiddle
(not (not (memq creator '(0 2 4 5 9))))))
(not (not (memq creator '(0 2 4 5 9))))
(string= (upcase efnname) efnname)))
(ifnname (if fiddle (downcase efnname) efnname))
(text (format " %10s %8d %-11s %-8s %s"
modestr
......@@ -1496,7 +1590,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(goto-char (+ p 40))
(delete-char 2)
(insert (logand newval 255) (lsh newval -8)))
((memq creator '(0 5 6 7 10 11)) ; Dos etc.
((memq creator '(0 5 6 7 10 11 15)) ; Dos etc.
(goto-char (+ p 38))
(insert (logior (logand (char-after (point)) 254)
(logand (logxor 1 (lsh newval -7)) 1)))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment