1 ;;; dos-fns.el --- MS-Dos specific functions
3 ;; Copyright (C) 1991, 1993, 1995, 1996, 2001, 2002, 2003, 2004, 2005,
4 ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Maintainer: Morten Welinder <terra@diku.dk>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; Part of this code is taken from (or derived from) demacs.
30 (declare-function int86 "dosfns.c")
31 (declare-function msdos-long-file-names "msdos.c")
33 ;; This overrides a trivial definition in files.el.
34 (defun dos-convert-standard-filename (filename)
35 "Convert a standard file's name to something suitable for the current OS.
36 This means to guarantee valid names and perhaps to canonicalize
39 On Windows and DOS, replace invalid characters. On DOS, make
40 sure to obey the 8.3 limitations. On Windows, turn Cygwin names
41 into native names, and also turn slashes into backslashes if the
42 shell requires it (see `w32-shell-dos-semantics')."
43 (if (or (not (stringp filename))
44 ;; This catches the case where FILENAME is "x:" or "x:/" or
45 ;; "/", thus preventing infinite recursion.
46 (string-match "\\`\\([a-zA-Z]:\\)?[/\\]?\\'" filename))
48 (let ((flen (length filename)))
49 ;; If FILENAME has a trailing slash, remove it and recurse.
50 (if (memq (aref filename (1- flen)) '(?/ ?\\))
51 (concat (dos-convert-standard-filename
52 (substring filename 0 (1- flen)))
54 (let* (;; ange-ftp gets in the way for names like "/foo:bar".
55 ;; We need to inhibit all magic file names, because
56 ;; remote file names should never be passed through
57 ;; this function, as they are not meant for the local
59 (file-name-handler-alist nil)
61 ;; If FILENAME is "x:foo", file-name-directory returns
62 ;; "x:/bar/baz", substituting the current working
63 ;; directory on drive x:. We want to be left with "x:"
66 (eq (aref filename 1) ?:)
67 (null (string-match "[/\\]" filename)))
68 (substring filename 0 2)
69 (file-name-directory filename)))
70 (dlen-m-1 (1- (length dir)))
71 (string (copy-sequence (file-name-nondirectory filename)))
72 (lastchar (aref string (1- (length string))))
75 ((msdos-long-file-names)
76 ;; Replace characters that are invalid even on Windows.
77 (while (setq i (string-match "[?*:<>|\"\000-\037]" string))
79 ((not (member string '("" "." "..")))
80 ;; Change a leading period to a leading underscore.
81 (if (= (aref string 0) ?.)
83 ;; If the name is longer than 8 chars, and doesn't have a
84 ;; period, and we have a dash or underscore that isn't too
85 ;; close to the beginning, change that to a period. This
86 ;; is so we could salvage more characters of the original
87 ;; name by pushing them into the extension.
88 (if (and (not (string-match "\\." string))
90 ;; We don't gain anything if we put the period closer
91 ;; than 5 chars from the beginning (5 + 3 = 8).
92 (setq i (string-match "[-_]" string 5)))
94 ;; Get rid of invalid characters.
95 (while (setq i (string-match
96 "[^-a-zA-Z0-9_.%~^$!#&{}@`'()\200-\376]"
99 ;; If we don't have a period in the first 8 chars, insert one.
100 ;; This enables to have 3 more characters from the original
101 ;; name in the extension.
102 (if (> (or (string-match "\\." string) (length string))
105 (concat (substring string 0 8)
107 (substring string 8))))
108 (setq firstdot (or (string-match "\\." string)
109 (1- (length string))))
110 ;; Truncate to 3 chars after the first period.
111 (if (> (length string) (+ firstdot 4))
112 (setq string (substring string 0 (+ firstdot 4))))
113 ;; Change all periods except the first one into underscores.
114 ;; (DOS doesn't allow more than one period.)
115 (while (string-match "\\." string (1+ firstdot))
116 (setq i (string-match "\\." string (1+ firstdot)))
118 ;; If the last character of the original filename was `~' or `#',
119 ;; make sure the munged name ends with it also. This is so that
120 ;; backup and auto-save files retain their telltale form.
121 (if (memq lastchar '(?~ ?#))
122 (aset string (1- (length string)) lastchar))))
123 (concat (if (and (stringp dir)
124 (memq (aref dir dlen-m-1) '(?/ ?\\)))
125 (concat (dos-convert-standard-filename
126 (substring dir 0 dlen-m-1))
128 (dos-convert-standard-filename dir))
131 ;; Only redirect convert-standard-filename if it has a chance of working,
132 ;; otherwise loading dos-fns.el might make your non-DOS Emacs misbehave.
133 (when (fboundp 'msdos-long-file-names)
134 (defalias 'convert-standard-filename 'dos-convert-standard-filename))
136 (defun dos-8+3-filename (filename)
137 "Truncate FILENAME to DOS 8+3 limits."
138 (if (or (not (stringp filename))
139 (< (length filename) 5)) ; too short to give any trouble
141 (let ((flen (length filename)))
142 ;; If FILENAME has a trailing slash, remove it and recurse.
143 (if (memq (aref filename (1- flen)) '(?/ ?\\))
144 (concat (dos-8+3-filename (substring filename 0 (1- flen)))
146 (let* (;; ange-ftp gets in the way for names like "/foo:bar".
147 ;; We need to inhibit all magic file names, because
148 ;; remote file names should never be passed through
149 ;; this function, as they are not meant for the local
151 (file-name-handler-alist nil)
153 ;; If FILENAME is "x:foo", file-name-directory returns
154 ;; "x:/bar/baz", substituting the current working
155 ;; directory on drive x:. We want to be left with "x:"
158 (eq (aref filename 1) ?:)
159 (null (string-match "[/\\]" filename)))
160 (substring filename 0 2)
161 (file-name-directory filename)))
162 (dlen-m-1 (1- (length dir)))
163 (string (copy-sequence (file-name-nondirectory filename)))
164 (strlen (length string))
165 (lastchar (aref string (1- strlen)))
167 (setq firstdot (string-match "\\." string))
170 ;; Truncate the extension to 3 characters.
171 (if (> strlen (+ firstdot 4))
172 (setq string (substring string 0 (+ firstdot 4))))
173 ;; Truncate the basename to 8 characters.
175 (setq string (concat (substring string 0 8)
177 (substring string (1+ firstdot))))))
179 ;; No dot; truncate file name to 8 characters.
180 (setq string (substring string 0 8))))
181 ;; If the last character of the original filename was `~',
182 ;; make sure the munged name ends with it also. This is so
183 ;; a backup file retains its final `~'.
184 (if (equal lastchar ?~)
185 (aset string (1- (length string)) lastchar))
186 (concat (if (and (stringp dir)
187 (memq (aref dir dlen-m-1) '(?/ ?\\)))
188 (concat (dos-8+3-filename (substring dir 0 dlen-m-1))
190 ;; Recurse to truncate the leading directories.
191 (dos-8+3-filename dir))
194 ;; This is for the sake of standard file names elsewhere in Emacs that
195 ;; are defined as constant strings or via defconst, and whose
196 ;; conversion via `dos-convert-standard-filename' does not give good
198 (defun dosified-file-name (file-name)
199 "Return a variant of FILE-NAME that is valid on MS-DOS filesystems.
201 This function is for those rare cases where `dos-convert-standard-filename'
202 does not do a job that is good enough, e.g. if you need to preserve the
203 file-name extension. It recognizes only certain specific file names
204 that are used in Emacs Lisp sources; any other file name will be
207 ;; See files.el:dir-locals-file.
208 ((string= file-name ".dir-locals.el")
213 ;; See dos-vars.el for defcustom.
214 (defvar msdos-shells)
216 ;; Override settings chosen at startup.
217 (defun dos-set-default-process-coding-system ()
218 (setq default-process-coding-system
219 (if (default-value 'enable-multibyte-characters)
220 '(undecided-dos . undecided-dos)
221 '(raw-text-dos . raw-text-dos))))
223 (add-hook 'before-init-hook 'dos-set-default-process-coding-system)
225 ;; File names defined in preloaded packages can be incorrect or
226 ;; invalid if long file names were available during dumping, but not
227 ;; at runtime, or vice versa, and if the default file name begins with
228 ;; a period. Their defcustom's need to be reevaluated at startup. To
229 ;; see if the list of defcustom's below is up to date, run the command
230 ;; "M-x apropos-value RET ~/\. RET".
231 (defun dos-reevaluate-defcustoms ()
232 ;; This is not needed in Emacs 23.2 and later, as trash-directory is
233 ;; initialized as nil. But something like this might become
234 ;; necessary in the future, so I'm keeping it here as a reminder.
235 ;(custom-reevaluate-setting 'trash-directory)
238 (add-hook 'before-init-hook 'dos-reevaluate-defcustoms)
240 (defvar dos-register-name-alist
241 '((ax . 0) (bx . 1) (cx . 2) (dx . 3) (si . 4) (di . 5)
242 (cflag . 6) (flags . 7)
243 (al . (0 . 0)) (bl . (1 . 0)) (cl . (2 . 0)) (dl . (3 . 0))
244 (ah . (0 . 1)) (bh . (1 . 1)) (ch . (2 . 1)) (dh . (3 . 1))))
246 (defun dos-make-register ()
249 (defun dos-register-value (regs name)
250 (let ((where (cdr (assoc name dos-register-name-alist))))
252 (let ((tem (aref regs (car where))))
253 (if (zerop (cdr where))
260 (defun dos-set-register-value (regs name value)
263 (let ((where (cdr (assoc name dos-register-name-alist))))
265 (let ((tem (aref regs (car where)))
266 (value (logand value 255)))
269 (if (zerop (cdr where))
270 (logior (logand tem 65280) value)
271 (logior (logand tem 255) (lsh value 8))))))
273 (aset regs where (logand value 65535))))))
276 (defsubst dos-intdos (regs)
279 ;; Backward compatibility for obsolescent functions which
283 "Changes the number of screen rows to 25."
285 (set-frame-size (selected-frame) 80 25))
287 (defun dos-mode4350 ()
288 "Changes the number of rows to 43 or 50.
289 Emacs always tries to set the screen height to 50 rows first.
290 If this fails, it will try to set it to 43 rows, on the assumption
291 that your video hardware might not support 50-line mode."
293 (set-frame-size (selected-frame) 80 50)
294 (if (eq (frame-height (selected-frame)) 50)
295 nil ; the original built-in function returned nil
296 (set-frame-size (selected-frame) 80 43)))
300 ;; arch-tag: 00b03579-8ebb-4a02-8762-5c5a929774ad
301 ;;; dos-fns.el ends here