Merge from emacs-24
[emacs.git] / lisp / dos-fns.el
blob42ae053879cd0b0cf2c911d7e1d5bca890379d20
1 ;;; dos-fns.el --- MS-Dos specific functions
3 ;; Copyright (C) 1991, 1993, 1995-1996, 2001-2014 Free Software
4 ;; Foundation, Inc.
6 ;; Maintainer: Morten Welinder <terra@diku.dk>
7 ;; Keywords: internal
8 ;; Package: emacs
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;;; Commentary:
27 ;; Part of this code is taken from (or derived from) demacs.
29 ;;; Code:
31 (declare-function int86 "dosfns.c")
32 (declare-function msdos-long-file-names "msdos.c")
34 ;; See convert-standard-filename in files.el.
35 (defun dos-convert-standard-filename (filename)
36 "Convert a standard file's name to something suitable for MS-DOS.
37 This means to guarantee valid names and perhaps to canonicalize
38 certain patterns.
40 This function is called by `convert-standard-filename'.
42 On Windows and DOS, replace invalid characters. On DOS, make
43 sure to obey the 8.3 limitations."
44 (if (or (not (stringp filename))
45 ;; This catches the case where FILENAME is "x:" or "x:/" or
46 ;; "/", thus preventing infinite recursion.
47 (string-match "\\`\\([a-zA-Z]:\\)?[/\\]?\\'" filename))
48 filename
49 (let ((flen (length filename)))
50 ;; If FILENAME has a trailing slash, remove it and recurse.
51 (if (memq (aref filename (1- flen)) '(?/ ?\\))
52 (concat (dos-convert-standard-filename
53 (substring filename 0 (1- flen)))
54 "/")
55 (let* (;; ange-ftp gets in the way for names like "/foo:bar".
56 ;; We need to inhibit all magic file names, because
57 ;; remote file names should never be passed through
58 ;; this function, as they are not meant for the local
59 ;; filesystem!
60 (file-name-handler-alist nil)
61 (dir
62 ;; If FILENAME is "x:foo", file-name-directory returns
63 ;; "x:/bar/baz", substituting the current working
64 ;; directory on drive x:. We want to be left with "x:"
65 ;; instead.
66 (if (and (< 1 flen)
67 (eq (aref filename 1) ?:)
68 (null (string-match "[/\\]" filename)))
69 (substring filename 0 2)
70 (file-name-directory filename)))
71 (dlen-m-1 (1- (length dir)))
72 (string (copy-sequence (file-name-nondirectory filename)))
73 (lastchar (aref string (1- (length string))))
74 i firstdot)
75 (cond
76 ((msdos-long-file-names)
77 ;; Replace characters that are invalid even on Windows.
78 (while (setq i (string-match "[?*:<>|\"\000-\037]" string))
79 (aset string i ?!)))
80 ((not (member string '("" "." "..")))
81 ;; Change a leading period to a leading underscore.
82 (if (= (aref string 0) ?.)
83 (aset string 0 ?_))
84 ;; If the name is longer than 8 chars, and doesn't have a
85 ;; period, and we have a dash or underscore that isn't too
86 ;; close to the beginning, change that to a period. This
87 ;; is so we could salvage more characters of the original
88 ;; name by pushing them into the extension.
89 (if (and (not (string-match "\\." string))
90 (> (length string) 8)
91 ;; We don't gain anything if we put the period closer
92 ;; than 5 chars from the beginning (5 + 3 = 8).
93 (setq i (string-match "[-_]" string 5)))
94 (aset string i ?\.))
95 ;; Get rid of invalid characters.
96 (while (setq i (string-match
97 "[^-a-zA-Z0-9_.%~^$!#&{}@`'()\200-\376]"
98 string))
99 (aset string i ?_))
100 ;; If we don't have a period in the first 8 chars, insert one.
101 ;; This enables to have 3 more characters from the original
102 ;; name in the extension.
103 (if (> (or (string-match "\\." string) (length string))
105 (setq string
106 (concat (substring string 0 8)
108 (substring string 8))))
109 (setq firstdot (or (string-match "\\." string)
110 (1- (length string))))
111 ;; Truncate to 3 chars after the first period.
112 (if (> (length string) (+ firstdot 4))
113 (setq string (substring string 0 (+ firstdot 4))))
114 ;; Change all periods except the first one into underscores.
115 ;; (DOS doesn't allow more than one period.)
116 (while (string-match "\\." string (1+ firstdot))
117 (setq i (string-match "\\." string (1+ firstdot)))
118 (aset string i ?_))
119 ;; If the last character of the original filename was `~' or `#',
120 ;; make sure the munged name ends with it also. This is so that
121 ;; backup and auto-save files retain their telltale form.
122 (if (memq lastchar '(?~ ?#))
123 (aset string (1- (length string)) lastchar))))
124 (concat (if (and (stringp dir)
125 (memq (aref dir dlen-m-1) '(?/ ?\\)))
126 (concat (dos-convert-standard-filename
127 (substring dir 0 dlen-m-1))
128 "/")
129 (dos-convert-standard-filename dir))
130 string))))))
132 (defun dos-8+3-filename (filename)
133 "Truncate FILENAME to DOS 8+3 limits."
134 (if (or (not (stringp filename))
135 (< (length filename) 5)) ; too short to give any trouble
136 filename
137 (let ((flen (length filename)))
138 ;; If FILENAME has a trailing slash, remove it and recurse.
139 (if (memq (aref filename (1- flen)) '(?/ ?\\))
140 (concat (dos-8+3-filename (substring filename 0 (1- flen)))
141 "/")
142 (let* (;; ange-ftp gets in the way for names like "/foo:bar".
143 ;; We need to inhibit all magic file names, because
144 ;; remote file names should never be passed through
145 ;; this function, as they are not meant for the local
146 ;; filesystem!
147 (file-name-handler-alist nil)
148 (dir
149 ;; If FILENAME is "x:foo", file-name-directory returns
150 ;; "x:/bar/baz", substituting the current working
151 ;; directory on drive x:. We want to be left with "x:"
152 ;; instead.
153 (if (and (< 1 flen)
154 (eq (aref filename 1) ?:)
155 (null (string-match "[/\\]" filename)))
156 (substring filename 0 2)
157 (file-name-directory filename)))
158 (dlen-m-1 (1- (length dir)))
159 (string (copy-sequence (file-name-nondirectory filename)))
160 (strlen (length string))
161 (lastchar (aref string (1- strlen)))
162 firstdot)
163 (setq firstdot (string-match "\\." string))
164 (cond
165 (firstdot
166 ;; Truncate the extension to 3 characters.
167 (if (> strlen (+ firstdot 4))
168 (setq string (substring string 0 (+ firstdot 4))))
169 ;; Truncate the basename to 8 characters.
170 (if (> firstdot 8)
171 (setq string (concat (substring string 0 8)
173 (substring string (1+ firstdot))))))
174 ((> strlen 8)
175 ;; No dot; truncate file name to 8 characters.
176 (setq string (substring string 0 8))))
177 ;; If the last character of the original filename was `~',
178 ;; make sure the munged name ends with it also. This is so
179 ;; a backup file retains its final `~'.
180 (if (equal lastchar ?~)
181 (aset string (1- (length string)) lastchar))
182 (concat (if (and (stringp dir)
183 (memq (aref dir dlen-m-1) '(?/ ?\\)))
184 (concat (dos-8+3-filename (substring dir 0 dlen-m-1))
185 "/")
186 ;; Recurse to truncate the leading directories.
187 (dos-8+3-filename dir))
188 string))))))
190 ;; This is for the sake of standard file names elsewhere in Emacs that
191 ;; are defined as constant strings or via defconst, and whose
192 ;; conversion via `dos-convert-standard-filename' does not give good
193 ;; enough results.
194 (defun dosified-file-name (file-name)
195 "Return a variant of FILE-NAME that is valid on MS-DOS filesystems.
197 This function is for those rare cases where `dos-convert-standard-filename'
198 does not do a job that is good enough, e.g. if you need to preserve the
199 file-name extension. It recognizes only certain specific file names
200 that are used in Emacs Lisp sources; any other file name will be
201 returned unaltered."
202 (cond
203 ;; See files.el:dir-locals-file.
204 ((string= file-name ".dir-locals.el")
205 "_dir-locals.el")
207 file-name)))
209 ;; See dos-vars.el for defcustom.
210 (defvar msdos-shells)
212 ;; Override settings chosen at startup.
213 (defun dos-set-default-process-coding-system ()
214 (setq default-process-coding-system
215 (if (default-value 'enable-multibyte-characters)
216 '(undecided-dos . undecided-dos)
217 '(raw-text-dos . raw-text-dos))))
219 (add-hook 'before-init-hook 'dos-set-default-process-coding-system)
221 ;; File names defined in preloaded packages can be incorrect or
222 ;; invalid if long file names were available during dumping, but not
223 ;; at runtime, or vice versa, and if the default file name begins with
224 ;; a period. Their defcustom's need to be reevaluated at startup. To
225 ;; see if the list of defcustom's below is up to date, run the command
226 ;; "M-x apropos-value RET ~/\. RET".
227 (defun dos-reevaluate-defcustoms ()
228 ;; This is not needed in Emacs 23.2 and later, as trash-directory is
229 ;; initialized as nil. But something like this might become
230 ;; necessary in the future, so I'm keeping it here as a reminder.
231 ;(custom-reevaluate-setting 'trash-directory)
234 (add-hook 'before-init-hook 'dos-reevaluate-defcustoms)
236 (define-obsolete-variable-alias
237 'register-name-alist 'dos-register-name-alist "24.1")
239 (defvar dos-register-name-alist
240 '((ax . 0) (bx . 1) (cx . 2) (dx . 3) (si . 4) (di . 5)
241 (cflag . 6) (flags . 7)
242 (al . (0 . 0)) (bl . (1 . 0)) (cl . (2 . 0)) (dl . (3 . 0))
243 (ah . (0 . 1)) (bh . (1 . 1)) (ch . (2 . 1)) (dh . (3 . 1))))
245 (defun dos-make-register ()
246 (make-vector 8 0))
248 (define-obsolete-function-alias 'make-register 'dos-make-register "24.1")
250 (defun dos-register-value (regs name)
251 (let ((where (cdr (assoc name dos-register-name-alist))))
252 (cond ((consp where)
253 (let ((tem (aref regs (car where))))
254 (if (zerop (cdr where))
255 (% tem 256)
256 (/ tem 256))))
257 ((numberp where)
258 (aref regs where))
259 (t nil))))
261 (define-obsolete-function-alias 'register-value 'dos-register-value "24.1")
263 (defun dos-set-register-value (regs name value)
264 (and (numberp value)
265 (>= value 0)
266 (let ((where (cdr (assoc name dos-register-name-alist))))
267 (cond ((consp where)
268 (let ((tem (aref regs (car where)))
269 (value (logand value 255)))
270 (aset regs
271 (car where)
272 (if (zerop (cdr where))
273 (logior (logand tem 65280) value)
274 (logior (logand tem 255) (lsh value 8))))))
275 ((numberp where)
276 (aset regs where (logand value 65535))))))
277 regs)
279 (define-obsolete-function-alias
280 'set-register-value 'dos-set-register-value "24.1")
282 (defsubst dos-intdos (regs)
283 "Issue the DOS Int 21h with registers REGS.
285 REGS should be a vector produced by `dos-make-register'
286 and `dos-set-register-value', which see."
287 (int86 33 regs))
289 (define-obsolete-function-alias 'intdos 'dos-intdos "24.1")
291 ;; Backward compatibility for obsolescent functions which
292 ;; set screen size.
294 (defun dos-mode25 ()
295 "Changes the number of screen rows to 25."
296 (interactive)
297 (set-frame-size (selected-frame) 80 25))
299 (define-obsolete-function-alias 'mode25 'dos-mode25 "24.1")
301 (defun dos-mode4350 ()
302 "Changes the number of rows to 43 or 50.
303 Emacs always tries to set the screen height to 50 rows first.
304 If this fails, it will try to set it to 43 rows, on the assumption
305 that your video hardware might not support 50-line mode."
306 (interactive)
307 (set-frame-size (selected-frame) 80 50)
308 (if (eq (frame-height (selected-frame)) 50)
309 nil ; the original built-in function returned nil
310 (set-frame-size (selected-frame) 80 43)))
312 (define-obsolete-function-alias 'mode4350 'dos-mode4350 "24.1")
314 (provide 'dos-fns)
316 ;;; dos-fns.el ends here