X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/08160b08aca60768b21bffa9c943f798e2d8b4c3..f590a2a442d19f3a74d7bbd02bbcb4e3239f2327:/lisp/dos-fns.el

diff --git a/lisp/dos-fns.el b/lisp/dos-fns.el
index 4293ecbc93..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.
 
@@ -28,64 +28,173 @@
 
 ;;; Code:
 
-(defgroup dos-fns nil
-  "MS-Dos specific functions."
-  :group 'environment)
-
 ;; 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."
-  (if (or (msdos-long-file-names)
-	  (not (stringp filename))
-	  (member (file-name-nondirectory filename) '("" "." "..")))
+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.
+	  (string-match "\\`\\([a-zA-Z]:\\)?[/\\]?\\'" filename))
+      filename
+    (let ((flen (length filename)))
+      ;; If FILENAME has a trailing slash, remove it and recurse.
+      (if (memq (aref filename (1- flen)) '(?/ ?\\))
+	  (concat (convert-standard-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)))
+	       (lastchar (aref string (1- (length string))))
+	       i firstdot)
+	  (cond
+	   ((msdos-long-file-names)
+	    ;; Replace characters that are invalid even on Windows.
+	    (while (setq i (string-match "[?*:<>|\"\000-\037]" string))
+	      (aset string i ?!)))
+	   ((not (member string '("" "." "..")))
+	    ;; 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 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
+		      (concat (substring string 0 8)
+			      "."
+			      (substring string 8))))
+	    (setq firstdot (or (string-match "\\." string)
+			       (1- (length string))))
+	    ;; Truncate to 3 chars after the first period.
+	    (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 `~' 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) '(?/ ?\\)))
+		      (concat (convert-standard-filename
+			       (substring dir 0 dlen-m-1))
+			      "/")
+		    (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* ((dir (file-name-directory filename))
-	   (string (copy-sequence (file-name-nondirectory filename)))
-	   (lastchar (aref string (1- (length string))))
-	   i firstdot)
-      ;; Change a leading period to a leading underscore.
-      (if (= (aref string 0) ?.)
-	  (aset string 0 ?_))
-      ;; 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.
-      (if (> (or (string-match "\\." string)
-		 (length string))
-	     8)
-	  (setq string
-		(concat (substring string 0 8)
-			"."
-			(substring string 8))))
-      (setq firstdot (or (string-match "\\." string) (1- (length string))))
-      ;; Truncate to 3 chars after the first period.
-      (if (> (length string) (+ firstdot 4))
-	  (setq string (substring string 0 (+ firstdot 4))))
-      ;; Change all periods except the first one into underscores.
-      (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.
-      (if (equal lastchar ?~)
-	  (aset string (1- (length string)) lastchar))
-      (concat dir string))))
-
-(defcustom msdos-shells '("command.com" "4dos.com" "ndos.com")
-  "*List of shells that use `/c' instead of `-c' and a backslashed command."
-  :type '(repeat string)
-  :group 'dos-fns)
+    (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)
+
+;;; Override setting chosen at startup.
+(defun set-default-process-coding-system ()
+  (setq default-process-coding-system
+	(if default-enable-multibyte-characters
+	    '(undecided-dos . undecided-dos)
+	  '(raw-text-dos . raw-text-dos))))
+
+(add-hook 'before-init-hook 'set-default-process-coding-system)
 
 (defvar register-name-alist
   '((ax . 0) (bx . 1) (cx . 2) (dx . 3) (si . 4) (di . 5)
@@ -126,83 +235,6 @@ with a definition that really does change some file names."
 (defsubst intdos (regs)
   (int86 33 regs))
 
-;; Support for printing under MS-DOS, see lpr.el and ps-print.el.
-(defcustom dos-printer "PRN"
-  "*The name of a local MS-DOS device to which data is sent for printing.
-\(Note that PostScript files are sent to `dos-ps-printer', which see.\)
-
-Typical non-default settings would be \"LPT1\" to \"LPT3\" for
-parallel printers, or \"COM1\" to \"COM4\" or \"AUX\" for serial
-printers.  You can also set it to a name of a file, in which
-case the output gets appended to that file.
-If you want to discard the printed output, set this to \"NUL\"."
-  :type 'file ; could use string but then we lose completion for files.
-  :group 'dos-fns)
-
-(defun dos-print-region-function (start end
-					&optional lpr-prog
-					delete-text buf display rest)
-  "MS-DOS-specific function to print the region on a printer.
-Writes the region to the device or file which is a value of
-`dos-printer' \(which see\).  Ignores any arguments beyond
-START and END."
-
-  ;; DOS printers need the lines to end with CR-LF pairs, so make
-  ;; sure it always happens that way, unless the buffer is binary.
-  (let* ((coding coding-system-for-write)
-	 (coding-base
-	  (if (null coding) 'undecided (coding-system-base coding)))
-	 (eol-type (coding-system-eol-type coding-base)))
-    (or (eq coding-system-for-write 'no-conversion)
-	(setq coding-system-for-write
-	      (aref eol-type 1)))	; force conversion to DOS EOLs
-    (write-region start end dos-printer t 0)
-    ;; Make each print-out start on a new page, but don't waste
-    ;; paper if there was a form-feed at the end of this file.
-    (if (not (char-equal (char-after (1- end)) ?\C-l))
-	(write-region "\f" nil dos-printer t 0))))
-
-;; Set this to nil if you have a port of the `lpr' program and
-;; you want to use it for printing.  If the default setting is
-;; in effect, `lpr-command' and its switches are ignored when
-;; printing with `lpr-xxx' and `print-xxx'.
-(setq print-region-function 'dos-print-region-function)
-
-;; Set this to nil if you have a port of the `pr' program
-;; (e.g., from GNU Textutils), or if you have an `lpr'
-;; program (see above) that can print page headers.
-;; If `lpr-headers-switches' is non-nil (the default) and
-;; `print-region-function' is set to `dos-print-region-function',
-;; then requests to print page headers will be silently
-;; ignored, and `print-buffer' and `print-region' produce
-;; the same output as `lpr-buffer' and `lpr-region', accordingly.
-(setq lpr-headers-switches "(page headers are not supported)")
-
-(defcustom dos-ps-printer "PRN"
-  "*Method for printing PostScript files under MS-DOS.
-
-If the value is a string, then it is taken as the name of the
-device to which PostScript files are written.  By default it
-is the default printer device; typical non-default settings
-would be \"LPT1\" to \"LPT3\" for parallel printers, or \"COM1\"
-to \"COM4\" or \"AUX\" for serial printers.  You can also set it
-to a name of a file, in which case the output gets appended
-to that file.  \(Note that `ps-print' package already has
-facilities for printing to a file, so you might as well use
-them instead of changing the setting of this variable.\)  If
-you want to silently discard the printed output, set this to \"NUL\".
-
-If the value is anything but a string, PostScript files will be
-piped to the program given by `ps-lpr-command', with switches
-given by `ps-lpr-switches', which see."
-  :type '(choice file (const :tag "Pipe to ps-lpr-command" pipe))
-  :group 'dos-fns)
-
-(setq ps-lpr-command "gs")
-
-(setq ps-lpr-switches '("-q" "-dNOPAUSE" "-sDEVICE=epson" "-r240x60"
-			  "-sOutputFile=LPT1" "-"))
-
 ;; Backward compatibility for obsolescent functions which
 ;; set screen size.
 
@@ -224,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