dos-fns.el 11 KB
Newer Older
1
;;; dos-fns.el --- MS-Dos specific functions
Richard M. Stallman's avatar
Richard M. Stallman committed
2

3 4
;; Copyright (C) 1991, 1993, 1995, 1996, 2001, 2002, 2003, 2004, 2005,
;;   2006, 2007, 2008, 2009  Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
5

Richard M. Stallman's avatar
Richard M. Stallman committed
6
;; Maintainer: Morten Welinder <terra@diku.dk>
Richard M. Stallman's avatar
Richard M. Stallman committed
7 8 9 10
;; Keywords: internal

;; This file is part of GNU Emacs.

11
;; GNU Emacs is free software: you can redistribute it and/or modify
Richard M. Stallman's avatar
Richard M. Stallman committed
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Richard M. Stallman's avatar
Richard M. Stallman committed
15 16 17 18 19 20 21

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; 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/>.
Richard M. Stallman's avatar
Richard M. Stallman committed
23 24 25 26 27 28 29

;;; Commentary:

;; Part of this code is taken from (or derived from) demacs.

;;; Code:

Glenn Morris's avatar
Glenn Morris committed
30
(declare-function int86 "dosfns.c")
31 32
(declare-function msdos-long-file-names "msdos.c")

33 34 35
;; 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.
36 37 38 39 40 41 42
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')."
43
  (if (or (not (stringp filename))
44 45 46
	  ;; This catches the case where FILENAME is "x:" or "x:/" or
	  ;; "/", thus preventing infinite recursion.
	  (string-match "\\`\\([a-zA-Z]:\\)?[/\\]?\\'" filename))
47
      filename
48 49 50
    (let ((flen (length filename)))
      ;; If FILENAME has a trailing slash, remove it and recurse.
      (if (memq (aref filename (1- flen)) '(?/ ?\\))
51
	  (concat (convert-standard-filename
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75
		   (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)
76 77
	    ;; Replace characters that are invalid even on Windows.
	    (while (setq i (string-match "[?*:<>|\"\000-\037]" string))
78 79 80 81 82
	      (aset string i ?!)))
	   ((not (member string '("" "." "..")))
	    ;; Change a leading period to a leading underscore.
	    (if (= (aref string 0) ?.)
		(aset string 0 ?_))
83 84 85 86 87 88 89 90 91 92 93
	    ;; 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 ?\.))
94 95 96 97 98 99
	    ;; 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.
100 101
	    ;; This enables to have 3 more characters from the original
	    ;; name in the extension.
102 103 104 105 106 107 108 109 110 111 112 113
	    (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.
114
	    ;; (DOS doesn't allow more than one period.)
115 116 117
	    (while (string-match "\\." string (1+ firstdot))
	      (setq i (string-match "\\." string (1+ firstdot)))
	      (aset string i ?_))
118 119 120 121
	    ;; 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 '(?~ ?#))
122 123 124 125 126 127 128 129
		(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))))))
130

131
(defun dos-8+3-filename (filename)
132 133 134 135 136 137 138
  "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)) '(?/ ?\\))
139
	  (concat (dos-8+3-filename (substring filename 0 (1- flen)))
140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182
		  "/")
	(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) '(?/ ?\\)))
183
		      (concat (dos-8+3-filename (substring dir 0 dlen-m-1))
184 185
			      "/")
		    ;; Recurse to truncate the leading directories.
186
		    (dos-8+3-filename dir))
187 188
		  string))))))

189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
;; This is for the sake of standard file names elsewhere in Emacs that
;; are defined as constant strings or via defconst, and whose
;; conversion via `convert-standard-filename' does not give good
;; enough results.
(defun dosified-file-name (file-name)
  "Return a variant of FILE-NAME that is valid on MS-DOS filesystems.

This function is for those rare cases where `convert-standard-filename'
does not do a job that is good enough, e.g. if you need to preserve the
file-name extension.  It recognizes only certain specific file names
that are used in Emacs Lisp sources; any other file name will be
returned unaltered."
  (cond
   ;; See files.el:dir-locals-file.
   ((string= file-name ".dir-locals.el")
    "_dir-locals.el")
   (t
    file-name)))

208 209
;; See dos-vars.el for defcustom.
(defvar msdos-shells)
Richard M. Stallman's avatar
Richard M. Stallman committed
210

211
;; Override settings chosen at startup.
212 213
(defun set-default-process-coding-system ()
  (setq default-process-coding-system
214
	(if (default-value 'enable-multibyte-characters)
215 216 217 218 219
	    '(undecided-dos . undecided-dos)
	  '(raw-text-dos . raw-text-dos))))

(add-hook 'before-init-hook 'set-default-process-coding-system)

220 221
;; File names defined in preloaded packages can be incorrect or
;; invalid if long file names were available during dumping, but not
222 223 224 225
;; at runtime, or vice versa, and if the default file name begins with
;; a period.  Their defcustom's need to be reevaluated at startup.  To
;; see if the list of defcustom's below is up to date, run the command
;; "M-x apropos-value RET ~/\. RET".
226
(defun dos-reevaluate-defcustoms ()
227 228 229 230 231
  ;; This is not needed in Emacs 23.2 and later, as trash-directory is
  ;; initialized as nil.  But something like this might become
  ;; necessary in the future, so I'm keeping it here as a reminder.
  ;(custom-reevaluate-setting 'trash-directory)
  )
232 233 234

(add-hook 'before-init-hook 'dos-reevaluate-defcustoms)

235
(defvar register-name-alist
Richard M. Stallman's avatar
Richard M. Stallman committed
236
  '((ax . 0) (bx . 1) (cx . 2) (dx . 3) (si . 4) (di . 5)
237 238 239
    (cflag . 6) (flags . 7)
    (al . (0 . 0)) (bl . (1 . 0)) (cl . (2 . 0)) (dl . (3 . 0))
    (ah . (0 . 1)) (bh . (1 . 1)) (ch . (2 . 1)) (dh . (3 . 1))))
Richard M. Stallman's avatar
Richard M. Stallman committed
240 241 242 243 244

(defun make-register ()
  (make-vector 8 0))

(defun register-value (regs name)
245
  (let ((where (cdr (assoc name register-name-alist))))
Richard M. Stallman's avatar
Richard M. Stallman committed
246 247 248 249 250 251 252 253 254 255 256
    (cond ((consp where)
	   (let ((tem (aref regs (car where))))
	     (if (zerop (cdr where))
		 (% tem 256)
	       (/ tem 256))))
	  ((numberp where)
	   (aref regs where))
	  (t nil))))

(defun set-register-value (regs name value)
  (and (numberp value)
257 258
       (>= value 0)
       (let ((where (cdr (assoc name register-name-alist))))
Richard M. Stallman's avatar
Richard M. Stallman committed
259
	 (cond ((consp where)
260 261 262 263 264 265 266
		(let ((tem (aref regs (car where)))
		      (value (logand value 255)))
		  (aset regs
			(car where)
			(if (zerop (cdr where))
			    (logior (logand tem 65280) value)
			  (logior (logand tem 255) (lsh value 8))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
267
	       ((numberp where)
268
		(aset regs where (logand value 65535))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
269 270 271 272 273
  regs)

(defsubst intdos (regs)
  (int86 33 regs))

274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292
;; Backward compatibility for obsolescent functions which
;; set screen size.

(defun mode25 ()
  "Changes the number of screen rows to 25."
  (interactive)
  (set-frame-size (selected-frame) 80 25))

(defun mode4350 ()
  "Changes the number of rows to 43 or 50.
Emacs always tries to set the screen height to 50 rows first.
If this fails, it will try to set it to 43 rows, on the assumption
that your video hardware might not support 50-line mode."
  (interactive)
  (set-frame-size (selected-frame) 80 50)
  (if (eq (frame-height (selected-frame)) 50)
      nil  ; the original built-in function returned nil
    (set-frame-size (selected-frame) 80 43)))

293 294
(provide 'dos-fns)

295
;; arch-tag: 00b03579-8ebb-4a02-8762-5c5a929774ad
296
;;; dos-fns.el ends here