1 ;;; dos-w32.el --- Functions shared among MS-DOS and W32 (NT/95) platforms
3 ;; Copyright (C) 1996 Free Software Foundation, Inc.
5 ;; Maintainer: Geoff Voelker (voelker@cs.washington.edu)
8 ;; This file is part of GNU Emacs.
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)
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.
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.
27 ;; Parts of this code are duplicated functions taken from dos-fns.el
32 ;;; Add %t: into the mode line format just after the open-paren.
33 (let ((tail (member " %[(" mode-line-format)))
34 (setcdr tail (cons (purecopy "%t:")
37 ;; Use ";" instead of ":" as a path separator (from files.el).
38 (setq path-separator ";")
40 ;; Set the null device (for compile.el).
41 (setq grep-null-device "NUL")
43 ;; Set the grep regexp to match entries with drive letters.
44 (setq grep-regexp-alist
45 '(("^\\(\\([a-zA-Z]:\\)?[^:( \t\n]+\\)[:( \t]+\\([0-9]+\\)[:) \t]" 1 3)))
47 ;; For distinguishing file types based upon suffixes.
48 (defvar file-name-buffer-file-type-alist
50 ("[:/].*config.sys$" . nil) ; config.sys text
51 ("\\.elc$" . t) ; emacs stuff
52 ("\\.\\(obj\\|exe\\|com\\|lib\\|sys\\|chk\\|out\\|bin\\|ico\\|pif\\)$" . t)
54 ("\\.\\(arc\\|zip\\|pak\\|lzh\\|zoo\\)$" . t)
56 ("\\.\\(a\\|o\\|tar\\|z\\|gz\\|taz\\)$" . t)
59 ; Borland Pascal stuff
63 "*Alist for distinguishing text files from binary files.
64 Each element has the form (REGEXP . TYPE), where REGEXP is matched
65 against the file name, and TYPE is nil for text, t for binary.")
67 ;; Return the pair matching filename on file-name-buffer-file-type-alist,
69 (defun find-buffer-file-type-match (filename)
70 (let ((alist file-name-buffer-file-type-alist)
72 (let ((case-fold-search t))
73 (setq filename (file-name-sans-versions filename))
74 (while (and (not found) alist)
75 (if (string-match (car (car alist)) filename)
76 (setq found (car alist)))
77 (setq alist (cdr alist)))
80 (defun find-buffer-file-type (filename)
81 ;; First check if file is on an untranslated filesystem, then on the alist.
82 (if (untranslated-file-p filename)
84 (let ((match (find-buffer-file-type-match filename))
87 default-buffer-file-type
88 (setq code (cdr match))
89 (cond ((memq code '(nil t)) code)
90 ((and (symbolp code) (fboundp code))
91 (funcall code filename)))))))
93 (defun find-buffer-file-type-coding-system (command args)
94 "Choose a coding system for a file operation.
95 If COMMAND is 'insert-file-contents', the coding system is chosen based
96 upon the filename, the contents of 'untranslated-filesystem-list' and
97 'file-name-buffer-file-type-alist', and whether the file exists:
99 If it matches in 'untranslated-filesystem-list': 'no-conversion'
100 If it matches in 'file-name-buffer-file-type-alist':
101 If the match is t (for binary): 'no-conversion'
102 If the match is nil (for text): 'emacs-mule-dos'
104 If the file exists: 'undecided'
105 If the file does not exist: 'emacs-mule-dos'
107 If COMMAND is 'write-region', the coding system is chosen based
108 upon the value of 'buffer-file-type': If t, the coding system is
109 'no-conversion', otherwise it is 'emacs-mule-dos'."
110 (let ((op (nth 0 command))
114 (cond ((eq op 'insert-file-contents)
115 (setq target (nth 1 command))
116 (setq binary (find-buffer-file-type target))
119 (and (file-exists-p target)
120 (not (find-buffer-file-type-match target))))))
121 ((eq op 'write-region)
122 (setq binary buffer-file-type)))
123 (cond (binary '(no-conversion . no-conversion))
124 (undecided '(undecided . undecided))
125 (t '(emacs-mule-dos . emacs-mule-dos)))))
127 (modify-coding-system-alist 'file "" 'find-buffer-file-type-coding-system)
129 (defun find-file-binary (filename)
130 "Visit file FILENAME and treat it as binary."
131 (interactive "FFind file binary: ")
132 (let ((file-name-buffer-file-type-alist '(("" . t))))
133 (find-file filename)))
135 (defun find-file-text (filename)
136 "Visit file FILENAME and treat it as a text file."
137 (interactive "FFind file text: ")
138 (let ((file-name-buffer-file-type-alist '(("" . nil))))
139 (find-file filename)))
141 (defun find-file-not-found-set-buffer-file-type ()
143 (set-buffer (current-buffer))
144 (setq buffer-file-type (find-buffer-file-type (buffer-file-name))))
147 ;;; To set the default file type on new files.
148 (add-hook 'find-file-not-found-hooks 'find-file-not-found-set-buffer-file-type)
151 ;;; To accomodate filesystems that do not require CR/LF translation.
152 (defvar untranslated-filesystem-list nil
153 "List of filesystems that require no CR/LF translation when reading
154 and writing files. Each filesystem in the list is a string naming
155 the directory prefix corresponding to the filesystem.")
157 (defun untranslated-canonical-name (filename)
158 "Return FILENAME in a canonicalized form for use with the functions
159 dealing with untranslated filesystems."
160 (if (memq system-type '(ms-dos windows-nt))
161 ;; The canonical form for DOS/W32 is with A-Z downcased and all
162 ;; directory separators changed to directory-sep-char.
164 (setq name (mapconcat
166 (if (and (<= ?A char) (<= char ?Z))
167 (char-to-string (+ (- char ?A) ?a))
168 (char-to-string char)))
170 ;; Use expand-file-name to canonicalize directory separators, except
171 ;; with bare drive letters (which would have the cwd appended).
172 (if (string-match "^.:$" name)
174 (expand-file-name name)))
177 (defun untranslated-file-p (filename)
178 "Return t if FILENAME is on a filesystem that does not require
179 CR/LF translation, and nil otherwise."
180 (let ((fs (untranslated-canonical-name filename))
181 (ufs-list untranslated-filesystem-list)
183 (while (and (not found) ufs-list)
184 (if (string-match (concat "^" (car ufs-list)) fs)
186 (setq ufs-list (cdr ufs-list))))
189 (defun add-untranslated-filesystem (filesystem)
190 "Add FILESYSTEM to the list of filesystems that do not require
191 CR/LF translation. FILESYSTEM is a string containing the directory
192 prefix corresponding to the filesystem. For example, for a Unix
193 filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
194 (interactive "fUntranslated file system: ")
195 (let ((fs (untranslated-canonical-name filesystem)))
196 (if (member fs untranslated-filesystem-list)
197 untranslated-filesystem-list
198 (setq untranslated-filesystem-list
199 (cons fs untranslated-filesystem-list)))))
201 (defun remove-untranslated-filesystem (filesystem)
202 "Remove FILESYSTEM from the list of filesystems that do not require
203 CR/LF translation. FILESYSTEM is a string containing the directory
204 prefix corresponding to the filesystem. For example, for a Unix
205 filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
206 (interactive "fUntranslated file system: ")
207 (setq untranslated-filesystem-list
208 (delete (untranslated-canonical-name filesystem)
209 untranslated-filesystem-list)))
211 ;; Process I/O decoding and encoding.
213 (defun find-binary-process-coding-system (op args)
214 "Choose a coding system for process I/O.
215 The coding system for decode is 'no-conversion' if 'binary-process-output'
216 is non-nil, and 'emacs-mule-dos' otherwise. Similarly, the coding system
217 for encode is 'no-conversion' if 'binary-process-input' is non-nil,
218 and 'emacs-mule-dos' otherwise."
219 (let ((decode 'emacs-mule-dos)
220 (encode 'emacs-mule-dos))
221 (if binary-process-output
222 (setq decode 'no-conversion))
223 (if binary-process-input
224 (setq encode 'no-conversion))
225 (cons decode encode)))
227 (modify-coding-system-alist 'process "" 'find-binary-process-coding-system)
232 ;;; dos-w32.el ends here