(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.

1 files changed, 149 insertions, 55 deletions

diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index 1207a577910..a20770c9f53 100644
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -1,6 +1,6 @@
 ;;; 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)))