| 1 | ;;; dos-fns.el --- MS-Dos specific functions |
| 2 | |
| 3 | ;; Copyright (C) 1991, 1993, 1995-1996, 2001-2014 Free Software |
| 4 | ;; Foundation, Inc. |
| 5 | |
| 6 | ;; Maintainer: Morten Welinder <terra@diku.dk> |
| 7 | ;; Keywords: internal |
| 8 | ;; Package: emacs |
| 9 | |
| 10 | ;; This file is part of GNU Emacs. |
| 11 | |
| 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. |
| 16 | |
| 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. |
| 21 | |
| 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/>. |
| 24 | |
| 25 | ;;; Commentary: |
| 26 | |
| 27 | ;; Part of this code is taken from (or derived from) demacs. |
| 28 | |
| 29 | ;;; Code: |
| 30 | |
| 31 | (declare-function int86 "dosfns.c") |
| 32 | (declare-function msdos-long-file-names "msdos.c") |
| 33 | |
| 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. |
| 39 | |
| 40 | This function is called by `convert-standard-filename'. |
| 41 | |
| 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)) |
| 104 | 8) |
| 105 | (setq string |
| 106 | (concat (substring string 0 8) |
| 107 | "." |
| 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)))))) |
| 131 | |
| 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) |
| 172 | "." |
| 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)))))) |
| 189 | |
| 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. |
| 196 | |
| 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") |
| 206 | (t |
| 207 | file-name))) |
| 208 | |
| 209 | ;; See dos-vars.el for defcustom. |
| 210 | (defvar msdos-shells) |
| 211 | |
| 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)))) |
| 218 | |
| 219 | (add-hook 'before-init-hook 'dos-set-default-process-coding-system) |
| 220 | |
| 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) |
| 232 | ) |
| 233 | |
| 234 | (add-hook 'before-init-hook 'dos-reevaluate-defcustoms) |
| 235 | |
| 236 | (define-obsolete-variable-alias |
| 237 | 'register-name-alist 'dos-register-name-alist "24.1") |
| 238 | |
| 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)))) |
| 244 | |
| 245 | (defun dos-make-register () |
| 246 | (make-vector 8 0)) |
| 247 | |
| 248 | (define-obsolete-function-alias 'make-register 'dos-make-register "24.1") |
| 249 | |
| 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)))) |
| 260 | |
| 261 | (define-obsolete-function-alias 'register-value 'dos-register-value "24.1") |
| 262 | |
| 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) |
| 278 | |
| 279 | (define-obsolete-function-alias |
| 280 | 'set-register-value 'dos-set-register-value "24.1") |
| 281 | |
| 282 | (defsubst dos-intdos (regs) |
| 283 | "Issue the DOS Int 21h with registers REGS. |
| 284 | |
| 285 | REGS should be a vector produced by `dos-make-register' |
| 286 | and `dos-set-register-value', which see." |
| 287 | (int86 33 regs)) |
| 288 | |
| 289 | (define-obsolete-function-alias 'intdos 'dos-intdos "24.1") |
| 290 | |
| 291 | ;; Backward compatibility for obsolescent functions which |
| 292 | ;; set screen size. |
| 293 | |
| 294 | (defun dos-mode25 () |
| 295 | "Changes the number of screen rows to 25." |
| 296 | (interactive) |
| 297 | (set-frame-size (selected-frame) 80 25)) |
| 298 | |
| 299 | (define-obsolete-function-alias 'mode25 'dos-mode25 "24.1") |
| 300 | |
| 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))) |
| 311 | |
| 312 | (define-obsolete-function-alias 'mode4350 'dos-mode4350 "24.1") |
| 313 | |
| 314 | (provide 'dos-fns) |
| 315 | |
| 316 | ;;; dos-fns.el ends here |