|
38436
|
1 ;;; dos-fns.el --- MS-Dos specific functions
|
|
5443
|
2
|
|
74439
|
3 ;; Copyright (C) 1991, 1993, 1995, 1996, 2001, 2002, 2003, 2004,
|
|
79721
|
4 ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
|
|
5443
|
5
|
|
17977
|
6 ;; Maintainer: Morten Welinder <terra@diku.dk>
|
|
5443
|
7 ;; Keywords: internal
|
|
|
8
|
|
|
9 ;; This file is part of GNU Emacs.
|
|
|
10
|
|
|
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
|
|
78236
|
13 ;; the Free Software Foundation; either version 3, or (at your option)
|
|
5443
|
14 ;; any later version.
|
|
|
15
|
|
|
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.
|
|
|
20
|
|
|
21 ;; You should have received a copy of the GNU General Public License
|
|
14169
|
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
64091
|
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
|
24 ;; Boston, MA 02110-1301, USA.
|
|
5443
|
25
|
|
|
26 ;;; Commentary:
|
|
|
27
|
|
|
28 ;; Part of this code is taken from (or derived from) demacs.
|
|
|
29
|
|
|
30 ;;; Code:
|
|
|
31
|
|
86293
|
32 (declare-function int86 "dosfns.c")
|
|
86289
|
33 (declare-function msdos-long-file-names "msdos.c")
|
|
|
34
|
|
13913
|
35 ;; This overrides a trivial definition in files.el.
|
|
|
36 (defun convert-standard-filename (filename)
|
|
|
37 "Convert a standard file's name to something suitable for the current OS.
|
55865
ccd8cdf69359
Rework docstring (wording by Eli Zaretskii and Kai Grossjohann).
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
38 This means to guarantee valid names and perhaps to canonicalize
|
ccd8cdf69359
Rework docstring (wording by Eli Zaretskii and Kai Grossjohann).
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
39 certain patterns.
|
ccd8cdf69359
Rework docstring (wording by Eli Zaretskii and Kai Grossjohann).
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
40
|
ccd8cdf69359
Rework docstring (wording by Eli Zaretskii and Kai Grossjohann).
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
41 On Windows and DOS, replace invalid characters. On DOS, make
|
ccd8cdf69359
Rework docstring (wording by Eli Zaretskii and Kai Grossjohann).
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
42 sure to obey the 8.3 limitations. On Windows, turn Cygwin names
|
ccd8cdf69359
Rework docstring (wording by Eli Zaretskii and Kai Grossjohann).
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
43 into native names, and also turn slashes into backslashes if the
|
ccd8cdf69359
Rework docstring (wording by Eli Zaretskii and Kai Grossjohann).
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
44 shell requires it (see `w32-shell-dos-semantics')."
|
|
29855
|
45 (if (or (not (stringp filename))
|
|
29966
|
46 ;; This catches the case where FILENAME is "x:" or "x:/" or
|
|
|
47 ;; "/", thus preventing infinite recursion.
|
|
|
48 (string-match "\\`\\([a-zA-Z]:\\)?[/\\]?\\'" filename))
|
|
15187
|
49 filename
|
|
29966
|
50 (let ((flen (length filename)))
|
|
|
51 ;; If FILENAME has a trailing slash, remove it and recurse.
|
|
|
52 (if (memq (aref filename (1- flen)) '(?/ ?\\))
|
|
49588
|
53 (concat (convert-standard-filename
|
|
29966
|
54 (substring filename 0 (1- flen)))
|
|
|
55 "/")
|
|
|
56 (let* (;; ange-ftp gets in the way for names like "/foo:bar".
|
|
|
57 ;; We need to inhibit all magic file names, because
|
|
|
58 ;; remote file names should never be passed through
|
|
|
59 ;; this function, as they are not meant for the local
|
|
|
60 ;; filesystem!
|
|
|
61 (file-name-handler-alist nil)
|
|
|
62 (dir
|
|
|
63 ;; If FILENAME is "x:foo", file-name-directory returns
|
|
|
64 ;; "x:/bar/baz", substituting the current working
|
|
|
65 ;; directory on drive x:. We want to be left with "x:"
|
|
|
66 ;; instead.
|
|
|
67 (if (and (< 1 flen)
|
|
|
68 (eq (aref filename 1) ?:)
|
|
|
69 (null (string-match "[/\\]" filename)))
|
|
|
70 (substring filename 0 2)
|
|
|
71 (file-name-directory filename)))
|
|
|
72 (dlen-m-1 (1- (length dir)))
|
|
|
73 (string (copy-sequence (file-name-nondirectory filename)))
|
|
|
74 (lastchar (aref string (1- (length string))))
|
|
|
75 i firstdot)
|
|
|
76 (cond
|
|
|
77 ((msdos-long-file-names)
|
|
29855
|
78 ;; Replace characters that are invalid even on Windows.
|
|
|
79 (while (setq i (string-match "[?*:<>|\"\000-\037]" string))
|
|
29966
|
80 (aset string i ?!)))
|
|
|
81 ((not (member string '("" "." "..")))
|
|
|
82 ;; Change a leading period to a leading underscore.
|
|
|
83 (if (= (aref string 0) ?.)
|
|
|
84 (aset string 0 ?_))
|
|
39305
|
85 ;; If the name is longer than 8 chars, and doesn't have a
|
|
|
86 ;; period, and we have a dash or underscore that isn't too
|
|
|
87 ;; close to the beginning, change that to a period. This
|
|
|
88 ;; is so we could salvage more characters of the original
|
|
|
89 ;; name by pushing them into the extension.
|
|
|
90 (if (and (not (string-match "\\." string))
|
|
|
91 (> (length string) 8)
|
|
|
92 ;; We don't gain anything if we put the period closer
|
|
|
93 ;; than 5 chars from the beginning (5 + 3 = 8).
|
|
|
94 (setq i (string-match "[-_]" string 5)))
|
|
|
95 (aset string i ?\.))
|
|
29966
|
96 ;; Get rid of invalid characters.
|
|
|
97 (while (setq i (string-match
|
|
|
98 "[^-a-zA-Z0-9_.%~^$!#&{}@`'()\200-\376]"
|
|
|
99 string))
|
|
|
100 (aset string i ?_))
|
|
|
101 ;; If we don't have a period in the first 8 chars, insert one.
|
|
39305
|
102 ;; This enables to have 3 more characters from the original
|
|
|
103 ;; name in the extension.
|
|
29966
|
104 (if (> (or (string-match "\\." string) (length string))
|
|
|
105 8)
|
|
|
106 (setq string
|
|
|
107 (concat (substring string 0 8)
|
|
|
108 "."
|
|
|
109 (substring string 8))))
|
|
|
110 (setq firstdot (or (string-match "\\." string)
|
|
|
111 (1- (length string))))
|
|
|
112 ;; Truncate to 3 chars after the first period.
|
|
|
113 (if (> (length string) (+ firstdot 4))
|
|
|
114 (setq string (substring string 0 (+ firstdot 4))))
|
|
|
115 ;; Change all periods except the first one into underscores.
|
|
39305
|
116 ;; (DOS doesn't allow more than one period.)
|
|
29966
|
117 (while (string-match "\\." string (1+ firstdot))
|
|
|
118 (setq i (string-match "\\." string (1+ firstdot)))
|
|
|
119 (aset string i ?_))
|
|
39305
|
120 ;; If the last character of the original filename was `~' or `#',
|
|
|
121 ;; make sure the munged name ends with it also. This is so that
|
|
|
122 ;; backup and auto-save files retain their telltale form.
|
|
|
123 (if (memq lastchar '(?~ ?#))
|
|
29966
|
124 (aset string (1- (length string)) lastchar))))
|
|
|
125 (concat (if (and (stringp dir)
|
|
|
126 (memq (aref dir dlen-m-1) '(?/ ?\\)))
|
|
|
127 (concat (convert-standard-filename
|
|
|
128 (substring dir 0 dlen-m-1))
|
|
|
129 "/")
|
|
|
130 (convert-standard-filename dir))
|
|
|
131 string))))))
|
|
13913
|
132
|
|
37262
|
133 (defun dos-8+3-filename (filename)
|
|
37257
|
134 "Truncate FILENAME to DOS 8+3 limits."
|
|
|
135 (if (or (not (stringp filename))
|
|
|
136 (< (length filename) 5)) ; too short to give any trouble
|
|
|
137 filename
|
|
|
138 (let ((flen (length filename)))
|
|
|
139 ;; If FILENAME has a trailing slash, remove it and recurse.
|
|
|
140 (if (memq (aref filename (1- flen)) '(?/ ?\\))
|
|
37262
|
141 (concat (dos-8+3-filename (substring filename 0 (1- flen)))
|
|
37257
|
142 "/")
|
|
|
143 (let* (;; ange-ftp gets in the way for names like "/foo:bar".
|
|
|
144 ;; We need to inhibit all magic file names, because
|
|
|
145 ;; remote file names should never be passed through
|
|
|
146 ;; this function, as they are not meant for the local
|
|
|
147 ;; filesystem!
|
|
|
148 (file-name-handler-alist nil)
|
|
|
149 (dir
|
|
|
150 ;; If FILENAME is "x:foo", file-name-directory returns
|
|
|
151 ;; "x:/bar/baz", substituting the current working
|
|
|
152 ;; directory on drive x:. We want to be left with "x:"
|
|
|
153 ;; instead.
|
|
|
154 (if (and (< 1 flen)
|
|
|
155 (eq (aref filename 1) ?:)
|
|
|
156 (null (string-match "[/\\]" filename)))
|
|
|
157 (substring filename 0 2)
|
|
|
158 (file-name-directory filename)))
|
|
|
159 (dlen-m-1 (1- (length dir)))
|
|
|
160 (string (copy-sequence (file-name-nondirectory filename)))
|
|
|
161 (strlen (length string))
|
|
|
162 (lastchar (aref string (1- strlen)))
|
|
|
163 i firstdot)
|
|
|
164 (setq firstdot (string-match "\\." string))
|
|
|
165 (cond
|
|
|
166 (firstdot
|
|
|
167 ;; Truncate the extension to 3 characters.
|
|
|
168 (if (> strlen (+ firstdot 4))
|
|
|
169 (setq string (substring string 0 (+ firstdot 4))))
|
|
|
170 ;; Truncate the basename to 8 characters.
|
|
|
171 (if (> firstdot 8)
|
|
|
172 (setq string (concat (substring string 0 8)
|
|
|
173 "."
|
|
|
174 (substring string (1+ firstdot))))))
|
|
|
175 ((> strlen 8)
|
|
|
176 ;; No dot; truncate file name to 8 characters.
|
|
|
177 (setq string (substring string 0 8))))
|
|
|
178 ;; If the last character of the original filename was `~',
|
|
|
179 ;; make sure the munged name ends with it also. This is so
|
|
|
180 ;; a backup file retains its final `~'.
|
|
|
181 (if (equal lastchar ?~)
|
|
|
182 (aset string (1- (length string)) lastchar))
|
|
|
183 (concat (if (and (stringp dir)
|
|
|
184 (memq (aref dir dlen-m-1) '(?/ ?\\)))
|
|
37262
|
185 (concat (dos-8+3-filename (substring dir 0 dlen-m-1))
|
|
37257
|
186 "/")
|
|
|
187 ;; Recurse to truncate the leading directories.
|
|
37262
|
188 (dos-8+3-filename dir))
|
|
37257
|
189 string))))))
|
|
|
190
|
|
22070
|
191 ;; See dos-vars.el for defcustom.
|
|
|
192 (defvar msdos-shells)
|
|
5443
|
193
|
|
24515
|
194 ;;; Override setting chosen at startup.
|
|
|
195 (defun set-default-process-coding-system ()
|
|
|
196 (setq default-process-coding-system
|
|
|
197 (if default-enable-multibyte-characters
|
|
|
198 '(undecided-dos . undecided-dos)
|
|
|
199 '(raw-text-dos . raw-text-dos))))
|
|
|
200
|
|
|
201 (add-hook 'before-init-hook 'set-default-process-coding-system)
|
|
|
202
|
|
16690
|
203 (defvar register-name-alist
|
|
5443
|
204 '((ax . 0) (bx . 1) (cx . 2) (dx . 3) (si . 4) (di . 5)
|
|
7256
|
205 (cflag . 6) (flags . 7)
|
|
|
206 (al . (0 . 0)) (bl . (1 . 0)) (cl . (2 . 0)) (dl . (3 . 0))
|
|
|
207 (ah . (0 . 1)) (bh . (1 . 1)) (ch . (2 . 1)) (dh . (3 . 1))))
|
|
5443
|
208
|
|
|
209 (defun make-register ()
|
|
|
210 (make-vector 8 0))
|
|
|
211
|
|
|
212 (defun register-value (regs name)
|
|
7256
|
213 (let ((where (cdr (assoc name register-name-alist))))
|
|
5443
|
214 (cond ((consp where)
|
|
|
215 (let ((tem (aref regs (car where))))
|
|
|
216 (if (zerop (cdr where))
|
|
|
217 (% tem 256)
|
|
|
218 (/ tem 256))))
|
|
|
219 ((numberp where)
|
|
|
220 (aref regs where))
|
|
|
221 (t nil))))
|
|
|
222
|
|
|
223 (defun set-register-value (regs name value)
|
|
|
224 (and (numberp value)
|
|
7256
|
225 (>= value 0)
|
|
|
226 (let ((where (cdr (assoc name register-name-alist))))
|
|
5443
|
227 (cond ((consp where)
|
|
7256
|
228 (let ((tem (aref regs (car where)))
|
|
|
229 (value (logand value 255)))
|
|
|
230 (aset regs
|
|
|
231 (car where)
|
|
|
232 (if (zerop (cdr where))
|
|
|
233 (logior (logand tem 65280) value)
|
|
|
234 (logior (logand tem 255) (lsh value 8))))))
|
|
5443
|
235 ((numberp where)
|
|
7256
|
236 (aset regs where (logand value 65535))))))
|
|
5443
|
237 regs)
|
|
|
238
|
|
|
239 (defsubst intdos (regs)
|
|
|
240 (int86 33 regs))
|
|
|
241
|
14380
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
242 ;; Backward compatibility for obsolescent functions which
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
243 ;; set screen size.
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
244
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
245 (defun mode25 ()
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
246 "Changes the number of screen rows to 25."
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
247 (interactive)
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
248 (set-frame-size (selected-frame) 80 25))
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
249
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
250 (defun mode4350 ()
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
251 "Changes the number of rows to 43 or 50.
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
252 Emacs always tries to set the screen height to 50 rows first.
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
253 If this fails, it will try to set it to 43 rows, on the assumption
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
254 that your video hardware might not support 50-line mode."
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
255 (interactive)
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
256 (set-frame-size (selected-frame) 80 50)
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
257 (if (eq (frame-height (selected-frame)) 50)
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
258 nil ; the original built-in function returned nil
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
259 (set-frame-size (selected-frame) 80 43)))
|
874cd82cd2b4
(mode25): Moved from `src/dosfns.c' for backward compatibility.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
260
|
|
14189
|
261 (provide 'dos-fns)
|
|
|
262
|
|
52401
|
263 ;;; arch-tag: 00b03579-8ebb-4a02-8762-5c5a929774ad
|
|
38436
|
264 ;;; dos-fns.el ends here
|
