| 1 | ;; dos-w32.el --- Functions shared among MS-DOS and W32 (NT/95) platforms |
| 2 | |
| 3 | ;; Copyright (C) 1996, 2001-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Maintainer: Geoff Voelker <voelker@cs.washington.edu> |
| 6 | ;; Keywords: internal |
| 7 | ;; Package: emacs |
| 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 |
| 13 | ;; the Free Software Foundation, either version 3 of the License, or |
| 14 | ;; (at your option) 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 |
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 23 | |
| 24 | ;;; Commentary: |
| 25 | |
| 26 | ;; Parts of this code are duplicated functions taken from dos-fns.el |
| 27 | ;; and winnt.el. |
| 28 | |
| 29 | ;;; Code: |
| 30 | |
| 31 | ;; Use ";" instead of ":" as a path separator (from files.el). |
| 32 | (when (memq system-type '(ms-dos windows-nt)) |
| 33 | (setq path-separator ";") |
| 34 | (push 'file-name-history minibuffer-history-case-insensitive-variables) |
| 35 | ;; Set the null device (for compile.el). |
| 36 | (setq null-device "NUL") |
| 37 | (setq-default buffer-file-coding-system 'undecided-dos)) |
| 38 | |
| 39 | ;; For distinguishing file types based upon suffixes. DEPRECATED, DO NOT USE! |
| 40 | (defcustom file-name-buffer-file-type-alist |
| 41 | '(("[:/].*config.sys$" . nil) ; config.sys text |
| 42 | ("\\.\\(obj\\|exe\\|com\\|lib\\|sys\\|bin\\|ico\\|pif\\|class\\)$" . t) |
| 43 | ; MS-Dos stuff |
| 44 | ("\\.\\(dll\\|drv\\|386\\|vxd\\|fon\\|fnt\\|fot\\|ttf\\|grp\\)$" . t) |
| 45 | ; Windows stuff |
| 46 | ("\\.\\(bmp\\|wav\\|avi\\|mpg\\|jpg\\|tif\\|mov\\|au\\)$" . t) |
| 47 | ; known binary data files |
| 48 | ("\\.\\(arc\\|zip\\|pak\\|lzh\\|zoo\\)$" . t) |
| 49 | ; Packers |
| 50 | ("\\.\\(a\\|o\\|tar\\|z\\|gz\\|taz\\|jar\\)$" . t) |
| 51 | ; Unix stuff |
| 52 | ("\\.sx[dmicw]$" . t) ; OpenOffice.org |
| 53 | ("\\.tp[ulpw]$" . t) ; borland Pascal stuff |
| 54 | ("[:/]tags$" . nil) ; emacs TAGS file |
| 55 | ) |
| 56 | "Alist used in the past for distinguishing text files from binary files. |
| 57 | Each element has the form (REGEXP . TYPE), where REGEXP is matched |
| 58 | against the file name, and TYPE is nil for text, t for binary. |
| 59 | |
| 60 | This variable is deprecated, not used anywhere, and will soon be deleted." |
| 61 | :type '(repeat (cons regexp boolean)) |
| 62 | :group 'dos-fns |
| 63 | :group 'w32) |
| 64 | |
| 65 | (make-obsolete-variable 'file-name-buffer-file-type-alist |
| 66 | 'file-coding-system-alist |
| 67 | "24.4") |
| 68 | |
| 69 | (defun find-buffer-file-type-coding-system (command) |
| 70 | "Choose a coding system for a file operation in COMMAND. |
| 71 | COMMAND is a list that specifies the operation, an I/O primitive, as its |
| 72 | CAR, and the arguments that might be given to that operation as its CDR. |
| 73 | If operation is `insert-file-contents', the coding system is chosen based |
| 74 | upon the filename (the CAR of the arguments beyond the operation), the contents |
| 75 | of `w32-untranslated-filesystem-list' and `file-name-buffer-file-type-alist', |
| 76 | and whether the file exists: |
| 77 | |
| 78 | If it matches in `w32-untranslated-filesystem-list': |
| 79 | If the file exists: `undecided' |
| 80 | If the file does not exist: `undecided-unix' |
| 81 | Otherwise: |
| 82 | If the file exists: `undecided' |
| 83 | If the file does not exist default value of `buffer-file-coding-system' |
| 84 | |
| 85 | Note that the CAR of arguments to `insert-file-contents' operation could |
| 86 | be a cons cell of the form (FILENAME . BUFFER), where BUFFER is a buffer |
| 87 | into which the file's contents were already read, but not yet decoded. |
| 88 | |
| 89 | If operation is `write-region', the coding system is chosen based |
| 90 | upon the value of `buffer-file-coding-system'. If |
| 91 | `buffer-file-coding-system' is non-nil, its value is used. |
| 92 | Otherwise, it is `undecided-dos'. |
| 93 | |
| 94 | The most common situation is when DOS and Unix files are read and |
| 95 | written, and their names do not match in `w32-untranslated-filesystem-list'. |
| 96 | In these cases, the coding system initially will be `undecided'. |
| 97 | As the file is read in the DOS case, the coding system will be |
| 98 | changed to `undecided-dos' as CR/LFs are detected. As the file |
| 99 | is read in the Unix case, the coding system will be changed to |
| 100 | `undecided-unix' as LFs are detected. In both cases, |
| 101 | `buffer-file-coding-system' will be set to the appropriate coding |
| 102 | system, and the value of `buffer-file-coding-system' will be used |
| 103 | when writing the file." |
| 104 | |
| 105 | (let ((op (nth 0 command)) |
| 106 | (undecided nil) (undecided-unix nil) |
| 107 | target target-buf) |
| 108 | (cond ((eq op 'insert-file-contents) |
| 109 | (setq target (nth 1 command)) |
| 110 | ;; If TARGET is a cons cell, it has the form (FILENAME . BUFFER), |
| 111 | ;; where BUFFER is a buffer into which the file was already read, |
| 112 | ;; but its contents were not yet decoded. (This form of the |
| 113 | ;; arguments is used, e.g., in arc-mode.el.) This function |
| 114 | ;; doesn't care about the contents, it only looks at the file's |
| 115 | ;; name, which is the CAR of the cons cell. |
| 116 | (when (consp target) |
| 117 | (setq target-buf |
| 118 | (and (bufferp (cdr target)) |
| 119 | (buffer-name (cdr target)))) |
| 120 | (setq target (car target))) |
| 121 | (cond ((or |
| 122 | ;; For any existing file, decide based on contents. |
| 123 | (file-exists-p target) |
| 124 | ;; If TARGET does not exist as a file, replace its |
| 125 | ;; base name with TARGET-BUF and try again. This |
| 126 | ;; is for jka-compr's sake, which strips the |
| 127 | ;; compression (.gz etc.) extension from the |
| 128 | ;; FILENAME, but leaves it in the BUFFER's name. |
| 129 | (and (stringp target-buf) |
| 130 | (file-exists-p |
| 131 | (expand-file-name target-buf |
| 132 | (file-name-directory target))))) |
| 133 | (setq undecided t)) |
| 134 | ;; Next check for a non-DOS file system. |
| 135 | ((w32-untranslated-file-p target) |
| 136 | (setq undecided-unix t))) |
| 137 | (cond (undecided-unix '(undecided-unix . undecided-unix)) |
| 138 | (undecided '(undecided . undecided)) |
| 139 | (t (cons (default-value 'buffer-file-coding-system) |
| 140 | (default-value 'buffer-file-coding-system))))) |
| 141 | ((eq op 'write-region) |
| 142 | (if buffer-file-coding-system |
| 143 | (cons buffer-file-coding-system |
| 144 | buffer-file-coding-system) |
| 145 | ;; Normally this is used only in a non-file-visiting |
| 146 | ;; buffer, because normally buffer-file-coding-system is non-nil |
| 147 | ;; in a file-visiting buffer. |
| 148 | '(undecided-dos . undecided-dos)))))) |
| 149 | (make-obsolete 'find-buffer-file-type-coding-system nil "24.4") |
| 150 | |
| 151 | (defun find-file-binary (filename) |
| 152 | "Visit file FILENAME and treat it as binary." |
| 153 | ;; FIXME: Why here rather than in files.el? |
| 154 | ;; FIXME: Can't we use find-file-literally for the same purposes? |
| 155 | (interactive "FFind file binary: ") |
| 156 | (let ((coding-system-for-read 'no-conversion)) ;; FIXME: undecided-unix? |
| 157 | (find-file filename))) |
| 158 | |
| 159 | (defun find-file-text (filename) |
| 160 | "Visit file FILENAME and treat it as a text file." |
| 161 | (interactive "FFind file text: ") |
| 162 | (let ((coding-system-for-read 'undecided-dos)) |
| 163 | (find-file filename))) |
| 164 | |
| 165 | (defun w32-find-file-not-found-set-buffer-file-coding-system () |
| 166 | (with-current-buffer (current-buffer) |
| 167 | (let ((coding buffer-file-coding-system)) |
| 168 | ;; buffer-file-coding-system is already set by |
| 169 | ;; find-operation-coding-system, which was called from |
| 170 | ;; insert-file-contents. All that's left is to change |
| 171 | ;; the EOL conversion, if required by the user. |
| 172 | (when (and (null coding-system-for-read) |
| 173 | (or inhibit-eol-conversion |
| 174 | (w32-untranslated-file-p (buffer-file-name)))) |
| 175 | (setq coding (coding-system-change-eol-conversion coding 0)) |
| 176 | (setq buffer-file-coding-system coding)) |
| 177 | nil))) |
| 178 | |
| 179 | ;; To set the default coding system on new files. |
| 180 | (add-hook 'find-file-not-found-functions |
| 181 | 'w32-find-file-not-found-set-buffer-file-coding-system) |
| 182 | |
| 183 | ;;; To accommodate filesystems that do not require CR/LF translation. |
| 184 | (define-obsolete-variable-alias 'untranslated-filesystem-list |
| 185 | 'w32-untranslated-filesystem-list "24.4") |
| 186 | (defvar w32-untranslated-filesystem-list nil |
| 187 | "List of filesystems that require no CR/LF translation when reading |
| 188 | and writing files. Each filesystem in the list is a string naming |
| 189 | the directory prefix corresponding to the filesystem.") |
| 190 | |
| 191 | (defun w32-untranslated-canonical-name (filename) |
| 192 | "Return FILENAME in a canonicalized form for use with the functions |
| 193 | dealing with untranslated filesystems." |
| 194 | (if (memq system-type '(ms-dos windows-nt cygwin)) |
| 195 | ;; The canonical form for DOS/W32 is with A-Z downcased and all |
| 196 | ;; directory separators changed to directory-sep-char. |
| 197 | (let ((name |
| 198 | (mapconcat (lambda (char) |
| 199 | (char-to-string (if (and (<= ?A char ?Z)) |
| 200 | (+ (- char ?A) ?a) |
| 201 | char))) |
| 202 | filename nil))) |
| 203 | ;; Use expand-file-name to canonicalize directory separators, except |
| 204 | ;; with bare drive letters (which would have the cwd appended). |
| 205 | ;; Avoid expanding names that could trigger ange-ftp to prompt |
| 206 | ;; for passwords, though. |
| 207 | (if (or (string-match-p "^.:\\'" name) |
| 208 | (string-match-p "^/[^/:]+:" name)) |
| 209 | name |
| 210 | (expand-file-name name))) |
| 211 | filename)) |
| 212 | |
| 213 | (defun w32-untranslated-file-p (filename) |
| 214 | "Return t if FILENAME is on a filesystem that does not require |
| 215 | CR/LF translation, and nil otherwise." |
| 216 | (let ((fs (w32-untranslated-canonical-name filename)) |
| 217 | (ufs-list w32-untranslated-filesystem-list) |
| 218 | (found nil)) |
| 219 | (while (and (not found) ufs-list) |
| 220 | (if (string-match-p (concat "^" (car ufs-list)) fs) |
| 221 | (setq found t) |
| 222 | (setq ufs-list (cdr ufs-list)))) |
| 223 | found)) |
| 224 | |
| 225 | (define-obsolete-function-alias 'add-untranslated-filesystem |
| 226 | 'w32-add-untranslated-filesystem "24.4") |
| 227 | (defun w32-add-untranslated-filesystem (filesystem) |
| 228 | "Add FILESYSTEM to the list of filesystems that do not require |
| 229 | CR/LF translation. FILESYSTEM is a string containing the directory |
| 230 | prefix corresponding to the filesystem. For example, for a Unix |
| 231 | filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"." |
| 232 | ;; We use "D", not "f", to avoid confusing the user: "f" prompts |
| 233 | ;; with a directory, but RET returns the current buffer's file, not |
| 234 | ;; its directory. |
| 235 | (interactive "DUntranslated file system: ") |
| 236 | (let ((fs (w32-untranslated-canonical-name filesystem))) |
| 237 | (if (member fs w32-untranslated-filesystem-list) |
| 238 | w32-untranslated-filesystem-list |
| 239 | (push fs w32-untranslated-filesystem-list)))) |
| 240 | |
| 241 | |
| 242 | (define-obsolete-function-alias 'remove-untranslated-filesystem |
| 243 | 'w32-remove-untranslated-filesystem "24.4") |
| 244 | (defun w32-remove-untranslated-filesystem (filesystem) |
| 245 | "Remove FILESYSTEM from the list of filesystems that do not require |
| 246 | CR/LF translation. FILESYSTEM is a string containing the directory |
| 247 | prefix corresponding to the filesystem. For example, for a Unix |
| 248 | filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"." |
| 249 | (interactive "fUntranslated file system: ") |
| 250 | (setq w32-untranslated-filesystem-list |
| 251 | (delete (w32-untranslated-canonical-name filesystem) |
| 252 | w32-untranslated-filesystem-list))) |
| 253 | |
| 254 | ;;; Support for printing under DOS/Windows, see lpr.el and ps-print.el. |
| 255 | |
| 256 | (define-obsolete-variable-alias 'direct-print-region-use-command-dot-com |
| 257 | 'w32-direct-print-region-use-command-dot-com "24.4") |
| 258 | (defcustom w32-direct-print-region-use-command-dot-com t |
| 259 | "If non-nil, use command.com to print on Windows 9x." |
| 260 | :type 'boolean |
| 261 | :group 'dos-fns |
| 262 | :group 'w32) |
| 263 | |
| 264 | ;; Function to actually send data to the printer port. |
| 265 | ;; Supports writing directly, and using various programs. |
| 266 | (defun w32-direct-print-region-helper (printer |
| 267 | start end |
| 268 | lpr-prog |
| 269 | _delete-text _buf _display |
| 270 | rest) |
| 271 | (let* (;; Ignore case when matching known external program names. |
| 272 | (case-fold-search t) |
| 273 | ;; Convert / to \ in printer name, for sake of external programs. |
| 274 | (printer |
| 275 | (if (stringp printer) |
| 276 | (subst-char-in-string ?/ ?\\ printer) |
| 277 | printer)) |
| 278 | ;; Find a directory that is local, to work-around Windows bug. |
| 279 | (safe-dir |
| 280 | (let ((safe-dirs (list "c:/" (getenv "windir") (getenv "TMPDIR")))) |
| 281 | (while (not (file-attributes (car safe-dirs))) |
| 282 | (setq safe-dirs (cdr safe-dirs))) |
| 283 | (car safe-dirs))) |
| 284 | (tempfile |
| 285 | (subst-char-in-string |
| 286 | ?/ ?\\ |
| 287 | (make-temp-name |
| 288 | (expand-file-name "EP" temporary-file-directory)))) |
| 289 | ;; capture output for diagnosis |
| 290 | (errbuf (list (get-buffer-create " *print-region-helper*") t))) |
| 291 | ;; It seems that we must be careful about the directory name that |
| 292 | ;; gets added to the printer port name by write-region when using |
| 293 | ;; the standard "PRN" or "LPTx" ports, because the write can fail if |
| 294 | ;; the directory is on a network drive. The same is true when |
| 295 | ;; asking command.com to copy the file. |
| 296 | ;; No action is needed for UNC printer names, which is just as well |
| 297 | ;; because `expand-file-name' doesn't support UNC names on MS-DOS. |
| 298 | (if (and (stringp printer) (not (string-match-p "^\\\\" printer))) |
| 299 | (setq printer |
| 300 | (subst-char-in-string ?/ ?\\ (expand-file-name printer safe-dir)))) |
| 301 | ;; Handle known programs specially where necessary. |
| 302 | (unwind-protect |
| 303 | (cond |
| 304 | ;; nprint.exe is the standard print command on Netware |
| 305 | ((string-match-p "\\`nprint\\(\\.exe\\)?\\'" |
| 306 | (file-name-nondirectory lpr-prog)) |
| 307 | (write-region start end tempfile nil 0) |
| 308 | (call-process lpr-prog nil errbuf nil |
| 309 | tempfile (concat "P=" printer))) |
| 310 | ;; print.exe is a standard command on NT |
| 311 | ((string-match-p "\\`print\\(\\.exe\\)?\\'" |
| 312 | (file-name-nondirectory lpr-prog)) |
| 313 | ;; Be careful not to invoke print.exe on MS-DOS or Windows 9x |
| 314 | ;; though, because it is a TSR program there (hangs Emacs). |
| 315 | (or (and (eq system-type 'windows-nt) |
| 316 | (null (getenv "winbootdir"))) |
| 317 | (error "Printing via print.exe is not supported on MS-DOS or Windows 9x")) |
| 318 | ;; It seems that print.exe always appends a form-feed so we |
| 319 | ;; should make sure to omit the last FF in the data. |
| 320 | (if (and (> end start) |
| 321 | (char-equal (char-before end) ?\C-l)) |
| 322 | (setq end (1- end))) |
| 323 | ;; cancel out annotate function for non-PS case |
| 324 | (let ((write-region-annotate-functions nil)) |
| 325 | (write-region start end tempfile nil 0)) |
| 326 | (call-process lpr-prog nil errbuf nil |
| 327 | (concat "/D:" printer) tempfile)) |
| 328 | ;; support lpr and similar programs for convenience, but |
| 329 | ;; supply an explicit filename because the NT version of lpr |
| 330 | ;; can't read from stdin. |
| 331 | ((> (length lpr-prog) 0) |
| 332 | (write-region start end tempfile nil 0) |
| 333 | (setq rest (append rest (list tempfile))) |
| 334 | (apply 'call-process lpr-prog nil errbuf nil rest)) |
| 335 | ;; Run command.com to access printer port on Windows 9x, unless |
| 336 | ;; we are supposed to append to an existing (non-empty) file, |
| 337 | ;; to work around a bug in Windows 9x that prevents Windows |
| 338 | ;; programs from accessing LPT ports reliably. |
| 339 | ((and (eq system-type 'windows-nt) |
| 340 | (getenv "winbootdir") |
| 341 | ;; Allow cop-out so command.com isn't invoked |
| 342 | w32-direct-print-region-use-command-dot-com |
| 343 | ;; file-attributes fails on LPT ports on Windows 9x but |
| 344 | ;; not on NT, so handle both cases for safety. |
| 345 | (eq (or (nth 7 (file-attributes printer)) 0) 0)) |
| 346 | (write-region start end tempfile nil 0) |
| 347 | (let ((w32-quote-process-args nil)) |
| 348 | (call-process "command.com" nil errbuf nil "/c" |
| 349 | (format "copy /b %s %s" tempfile printer)))) |
| 350 | ;; write directly to the printer port |
| 351 | (t |
| 352 | (write-region start end printer t 0))) |
| 353 | ;; ensure we remove the tempfile if created |
| 354 | (if (file-exists-p tempfile) |
| 355 | (delete-file tempfile))))) |
| 356 | |
| 357 | (defvar printer-name) |
| 358 | |
| 359 | (declare-function default-printer-name "w32fns.c") |
| 360 | |
| 361 | (define-obsolete-function-alias 'direct-print-region-function |
| 362 | 'w32-direct-print-region-function "24.4") |
| 363 | (defun w32-direct-print-region-function (start end |
| 364 | &optional lpr-prog |
| 365 | delete-text buf display |
| 366 | &rest rest) |
| 367 | "DOS/Windows-specific function to print the region on a printer. |
| 368 | Writes the region to the device or file which is a value of |
| 369 | `printer-name' (which see), unless the value of `lpr-command' |
| 370 | indicates a specific program should be invoked." |
| 371 | |
| 372 | ;; DOS printers need the lines to end with CR-LF pairs, so make |
| 373 | ;; sure it always happens that way, unless the buffer is binary. |
| 374 | (let* ((coding coding-system-for-write) |
| 375 | (coding-base |
| 376 | (if (null coding) 'undecided (coding-system-base coding))) |
| 377 | (eol-type (coding-system-eol-type coding-base)) |
| 378 | ;; Make each print-out eject the final page, but don't waste |
| 379 | ;; paper if the file ends with a form-feed already. |
| 380 | (write-region-annotate-functions |
| 381 | (cons |
| 382 | (lambda (_start end) |
| 383 | (if (not (char-equal (char-before end) ?\f)) |
| 384 | `((,end . "\f")))) |
| 385 | write-region-annotate-functions)) |
| 386 | (printer (or (and (boundp 'dos-printer) |
| 387 | (stringp (symbol-value 'dos-printer)) |
| 388 | (symbol-value 'dos-printer)) |
| 389 | printer-name |
| 390 | (default-printer-name)))) |
| 391 | (or (eq coding-system-for-write 'no-conversion) |
| 392 | (setq coding-system-for-write |
| 393 | (aref eol-type 1))) ; force conversion to DOS EOLs |
| 394 | (w32-direct-print-region-helper printer start end lpr-prog |
| 395 | delete-text buf display rest))) |
| 396 | |
| 397 | (defvar lpr-headers-switches) |
| 398 | |
| 399 | ;; Set this to nil if you have a port of the `pr' program |
| 400 | ;; (e.g., from GNU Textutils), or if you have an `lpr' |
| 401 | ;; program (see above) that can print page headers. |
| 402 | ;; If `lpr-headers-switches' is non-nil (the default) and |
| 403 | ;; `print-region-function' is set to `dos-print-region-function', |
| 404 | ;; then requests to print page headers will be silently |
| 405 | ;; ignored, and `print-buffer' and `print-region' produce |
| 406 | ;; the same output as `lpr-buffer' and `lpr-region', accordingly. |
| 407 | (when (memq system-type '(ms-dos windows-nt)) |
| 408 | (setq lpr-headers-switches "(page headers are not supported)")) |
| 409 | |
| 410 | (defvar ps-printer-name) |
| 411 | |
| 412 | (define-obsolete-function-alias 'direct-ps-print-region-function |
| 413 | 'w32-direct-ps-print-region-function "24.4") |
| 414 | (defun w32-direct-ps-print-region-function (start end |
| 415 | &optional lpr-prog |
| 416 | delete-text buf display |
| 417 | &rest rest) |
| 418 | "DOS/Windows-specific function to print the region on a PostScript printer. |
| 419 | Writes the region to the device or file which is a value of |
| 420 | `ps-printer-name' (which see), unless the value of `ps-lpr-command' |
| 421 | indicates a specific program should be invoked." |
| 422 | |
| 423 | (let ((printer (or (and (boundp 'dos-ps-printer) |
| 424 | (stringp (symbol-value 'dos-ps-printer)) |
| 425 | (symbol-value 'dos-ps-printer)) |
| 426 | ps-printer-name |
| 427 | (default-printer-name)))) |
| 428 | (w32-direct-print-region-helper printer start end lpr-prog |
| 429 | delete-text buf display rest))) |
| 430 | |
| 431 | ;(setq ps-lpr-command "gs") |
| 432 | |
| 433 | ;(setq ps-lpr-switches '("-q" "-dNOPAUSE" "-sDEVICE=epson" "-r240x60" |
| 434 | ; "-sOutputFile=LPT1")) |
| 435 | |
| 436 | (provide 'dos-w32) |
| 437 | |
| 438 | ;;; dos-w32.el ends here |