X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/9d47450f738b7c89a310057a287fb313b6cf20e8..3423ce024a8863c001245e0d7ebb27c1aee77620:/lisp/dos-fns.el

diff --git a/lisp/dos-fns.el b/lisp/dos-fns.el
index 8037de4f54..1253b7b581 100644
--- a/lisp/dos-fns.el
+++ b/lisp/dos-fns.el
@@ -1,4 +1,4 @@
-;;; dos-fns.el --- MS-Dos specific functions.
+;;; dos-fns.el --- MS-Dos specific functions
 
 ;; Copyright (C) 1991, 1993, 1995, 1996 Free Software Foundation, Inc.
 
@@ -31,9 +31,13 @@
 ;; This overrides a trivial definition in files.el.
 (defun convert-standard-filename (filename)
   "Convert a standard file's name to something suitable for the current OS.
-This function's standard definition is trivial; it just returns the argument.
-However, on some systems, the function is redefined
-with a definition that really does change some file names."
+This means to guarantee valid names and perhaps to canonicalize
+certain patterns.
+
+On Windows and DOS, replace invalid characters.  On DOS, make
+sure to obey the 8.3 limitations.  On Windows, turn Cygwin names
+into native names, and also turn slashes into backslashes if the
+shell requires it (see `w32-shell-dos-semantics')."
   (if (or (not (stringp filename))
 	  ;; This catches the case where FILENAME is "x:" or "x:/" or
 	  ;; "/", thus preventing infinite recursion.
@@ -42,7 +46,7 @@ with a definition that really does change some file names."
     (let ((flen (length filename)))
       ;; If FILENAME has a trailing slash, remove it and recurse.
       (if (memq (aref filename (1- flen)) '(?/ ?\\))
-	  (concat (convert-standard-filename 
+	  (concat (convert-standard-filename
 		   (substring filename 0 (1- flen)))
 		  "/")
 	(let* (;; ange-ftp gets in the way for names like "/foo:bar".
@@ -74,18 +78,25 @@ with a definition that really does change some file names."
 	    ;; Change a leading period to a leading underscore.
 	    (if (= (aref string 0) ?.)
 		(aset string 0 ?_))
+	    ;; If the name is longer than 8 chars, and doesn't have a
+	    ;; period, and we have a dash or underscore that isn't too
+	    ;; close to the beginning, change that to a period.  This
+	    ;; is so we could salvage more characters of the original
+	    ;; name by pushing them into the extension.
+	    (if (and (not (string-match "\\." string))
+		     (> (length string) 8)
+		     ;; We don't gain anything if we put the period closer
+		     ;; than 5 chars from the beginning (5 + 3 = 8).
+		     (setq i (string-match "[-_]" string 5)))
+		(aset string i ?\.))
 	    ;; Get rid of invalid characters.
 	    (while (setq i (string-match
 			    "[^-a-zA-Z0-9_.%~^$!#&{}@`'()\200-\376]"
 			    string))
 	      (aset string i ?_))
-	    ;; If we don't have a period,
-	    ;; and we have a dash or underscore that isn't the first char,
-	    ;; change that to a period.
-	    (if (and (not (string-match "\\." string))
-		     (setq i (string-match "[-_]" string 1)))
-		(aset string i ?\.))
 	    ;; If we don't have a period in the first 8 chars, insert one.
+	    ;; This enables to have 3 more characters from the original
+	    ;; name in the extension.
 	    (if (> (or (string-match "\\." string) (length string))
 		   8)
 		(setq string
@@ -98,13 +109,14 @@ with a definition that really does change some file names."
 	    (if (> (length string) (+ firstdot 4))
 		(setq string (substring string 0 (+ firstdot 4))))
 	    ;; Change all periods except the first one into underscores.
+	    ;; (DOS doesn't allow more than one period.)
 	    (while (string-match "\\." string (1+ firstdot))
 	      (setq i (string-match "\\." string (1+ firstdot)))
 	      (aset string i ?_))
-	    ;; If the last character of the original filename was `~',
-	    ;; make sure the munged name ends with it also.  This is so
-	    ;; a backup file retains its final `~'.
-	    (if (equal lastchar ?~)
+	    ;; If the last character of the original filename was `~' or `#',
+	    ;; make sure the munged name ends with it also.  This is so that
+	    ;; backup and auto-save files retain their telltale form.
+	    (if (memq lastchar '(?~ ?#))
 		(aset string (1- (length string)) lastchar))))
 	  (concat (if (and (stringp dir)
 			   (memq (aref dir dlen-m-1) '(?/ ?\\)))
@@ -114,6 +126,64 @@ with a definition that really does change some file names."
 		    (convert-standard-filename dir))
 		  string))))))
 
+(defun dos-8+3-filename (filename)
+  "Truncate FILENAME to DOS 8+3 limits."
+  (if (or (not (stringp filename))
+	  (< (length filename) 5))	; too short to give any trouble
+      filename
+    (let ((flen (length filename)))
+      ;; If FILENAME has a trailing slash, remove it and recurse.
+      (if (memq (aref filename (1- flen)) '(?/ ?\\))
+	  (concat (dos-8+3-filename (substring filename 0 (1- flen)))
+		  "/")
+	(let* (;; ange-ftp gets in the way for names like "/foo:bar".
+	       ;; We need to inhibit all magic file names, because
+	       ;; remote file names should never be passed through
+	       ;; this function, as they are not meant for the local
+	       ;; filesystem!
+	       (file-name-handler-alist nil)
+	       (dir
+		;; If FILENAME is "x:foo", file-name-directory returns
+		;; "x:/bar/baz", substituting the current working
+		;; directory on drive x:.  We want to be left with "x:"
+		;; instead.
+		(if (and (< 1 flen)
+			 (eq (aref filename 1) ?:)
+			 (null (string-match "[/\\]" filename)))
+		    (substring filename 0 2)
+		  (file-name-directory filename)))
+	       (dlen-m-1 (1- (length dir)))
+	       (string (copy-sequence (file-name-nondirectory filename)))
+	       (strlen (length string))
+	       (lastchar (aref string (1- strlen)))
+	       i firstdot)
+	  (setq firstdot (string-match "\\." string))
+	  (cond
+	   (firstdot
+	    ;; Truncate the extension to 3 characters.
+	    (if (> strlen (+ firstdot 4))
+		(setq string (substring string 0 (+ firstdot 4))))
+	    ;; Truncate the basename to 8 characters.
+	    (if (> firstdot 8)
+		(setq string (concat (substring string 0 8)
+				     "."
+				     (substring string (1+ firstdot))))))
+	   ((> strlen 8)
+	    ;; No dot; truncate file name to 8 characters.
+	    (setq string (substring string 0 8))))
+	  ;; If the last character of the original filename was `~',
+	  ;; make sure the munged name ends with it also.  This is so
+	  ;; a backup file retains its final `~'.
+	  (if (equal lastchar ?~)
+	      (aset string (1- (length string)) lastchar))
+	  (concat (if (and (stringp dir)
+			   (memq (aref dir dlen-m-1) '(?/ ?\\)))
+		      (concat (dos-8+3-filename (substring dir 0 dlen-m-1))
+			      "/")
+		    ;; Recurse to truncate the leading directories.
+		    (dos-8+3-filename dir))
+		  string))))))
+
 ;; See dos-vars.el for defcustom.
 (defvar msdos-shells)
 
@@ -186,4 +256,5 @@ that your video hardware might not support 50-line mode."
 
 (provide 'dos-fns)
 
-; dos-fns.el ends here
+;;; arch-tag: 00b03579-8ebb-4a02-8762-5c5a929774ad
+;;; dos-fns.el ends here