Mercurial > emacs

--- a/lisp/arc-mode.el	Thu May 14 05:39:59 1998 +0000
+++ b/lisp/arc-mode.el	Thu May 14 15:08:55 1998 +0000
@@ -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 @@
   :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 @@
 (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 @@
 	(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 @@
       (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 @@
 	   '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 @@
 	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 @@
 ;; -------------------------------------------------------------------------
 ;; 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 @@
          (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 @@
           (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 @@
 	    (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 @@
       (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 @@
     (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 @@
               (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 @@
 (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 @@
 			   (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 @@
 			    (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 @@
 		 (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)))