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