*** empty log message ***
[emacs.git] / lisp / w32-fns.el
blob8e0e85dc5f1b839609b7d98824adc398bfb1029a
1 ;;; w32-fns.el --- Lisp routines for Windows NT.
3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
5 ;; Author: Geoff Voelker <voelker@cs.washington.edu>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
24 ;;; Commentary:
26 ;; (August 12, 1993)
27 ;; Created.
29 ;; (November 21, 1994)
30 ;; [C-M-backspace] defined.
31 ;; mode-line-format defined to show buffer file type.
32 ;; audio bell initialized.
34 ;;; Code:
36 ;; Map delete and backspace
37 (define-key function-key-map [backspace] "\177")
38 (define-key function-key-map [delete] "\C-d")
39 (define-key function-key-map [M-backspace] [?\M-\177])
40 (define-key function-key-map [C-M-backspace] [\C-\M-delete])
42 ;; Ignore case on file-name completion
43 (setq completion-ignore-case t)
45 ;; Map all versions of a filename (8.3, longname, mixed case) to the
46 ;; same buffer.
47 (setq find-file-visit-truename t)
49 (defun w32-version ()
50 "Return the MS-Windows version numbers.
51 The value is a list of three integers: the major and minor version
52 numbers, and the build number."
53 (x-server-version))
55 (defvar w32-system-shells '("cmd" "cmd.exe" "command" "command.com"
56 "4nt" "4nt.exe" "4dos" "4dos.exe"
57 "ndos" "ndos.exe")
58 "List of strings recognized as Windows NT/9X system shells.")
60 (defun w32-using-nt ()
61 "Return non-nil if literally running on Windows NT (i.e., not Windows 9X)."
62 (and (eq system-type 'windows-nt) (getenv "SystemRoot")))
64 (defun w32-shell-name ()
65 "Return the name of the shell being used."
66 (or (and (boundp 'explicit-shell-file-name) explicit-shell-file-name)
67 (getenv "ESHELL")
68 (getenv "SHELL")
69 (and (w32-using-nt) "cmd.exe")
70 "command.com"))
72 (defun w32-system-shell-p (shell-name)
73 (and shell-name
74 (member (downcase (file-name-nondirectory shell-name))
75 w32-system-shells)))
77 (defun w32-shell-dos-semantics ()
78 "Return t if the interactive shell being used expects msdos shell semantics."
79 (or (w32-system-shell-p (w32-shell-name))
80 (and (member (downcase (file-name-nondirectory (w32-shell-name)))
81 '("cmdproxy" "cmdproxy.exe"))
82 (w32-system-shell-p (getenv "COMSPEC")))))
84 (defvar w32-allow-system-shell nil
85 "*Disable startup warning when using \"system\" shells.")
87 (defun w32-check-shell-configuration ()
88 "Check the configuration of shell variables on Windows NT/9X.
89 This function is invoked after loading the init files and processing
90 the command line arguments. It issues a warning if the user or site
91 has configured the shell with inappropriate settings."
92 (interactive)
93 (let ((prev-buffer (current-buffer))
94 (buffer (get-buffer-create "*Shell Configuration*"))
95 (system-shell))
96 (set-buffer buffer)
97 (erase-buffer)
98 (if (w32-system-shell-p (getenv "ESHELL"))
99 (insert (format "Warning! The ESHELL environment variable uses %s.
100 You probably want to change it so that it uses cmdproxy.exe instead.\n\n"
101 (getenv "ESHELL"))))
102 (if (w32-system-shell-p (getenv "SHELL"))
103 (insert (format "Warning! The SHELL environment variable uses %s.
104 You probably want to change it so that it uses cmdproxy.exe instead.\n\n"
105 (getenv "SHELL"))))
106 (if (w32-system-shell-p shell-file-name)
107 (insert (format "Warning! shell-file-name uses %s.
108 You probably want to change it so that it uses cmdproxy.exe instead.\n\n"
109 shell-file-name)))
110 (if (and (boundp 'explicit-shell-file-name)
111 (w32-system-shell-p explicit-shell-file-name))
112 (insert (format "Warning! explicit-shell-file-name uses %s.
113 You probably want to change it so that it uses cmdproxy.exe instead.\n\n"
114 explicit-shell-file-name)))
115 (setq system-shell (> (buffer-size) 0))
117 ;; Allow user to specify that they really do want to use one of the
118 ;; "system" shells, despite the drawbacks, but still warn if
119 ;; shell-command-switch doesn't match.
120 (if w32-allow-system-shell
121 (erase-buffer))
123 (cond (system-shell
124 ;; System shells.
125 (if (string-equal "-c" shell-command-switch)
126 (insert "Warning! shell-command-switch is \"-c\".
127 You should set this to \"/c\" when using a system shell.\n\n"))
128 (if w32-quote-process-args
129 (insert "Warning! w32-quote-process-args is t.
130 You should set this to nil when using a system shell.\n\n")))
131 ;; Non-system shells.
133 (if (string-equal "/c" shell-command-switch)
134 (insert "Warning! shell-command-switch is \"/c\".
135 You should set this to \"-c\" when using a non-system shell.\n\n"))
136 (if (not w32-quote-process-args)
137 (insert "Warning! w32-quote-process-args is nil.
138 You should set this to t when using a non-system shell.\n\n"))))
139 (if (> (buffer-size) 0)
140 (display-buffer buffer)
141 (kill-buffer buffer))
142 (set-buffer prev-buffer)))
144 (add-hook 'after-init-hook 'w32-check-shell-configuration)
146 ;;; Override setting chosen at startup.
147 (defun set-default-process-coding-system ()
148 ;; Most programs on Windows will accept Unix line endings on input
149 ;; (and some programs ported from Unix require it) but most will
150 ;; produce DOS line endings on output.
151 (setq default-process-coding-system
152 (if default-enable-multibyte-characters
153 '(undecided-dos . undecided-unix)
154 '(raw-text-dos . raw-text-unix)))
155 (or (w32-using-nt)
156 ;; On Windows 9x, make cmdproxy default to using DOS line endings
157 ;; for input, because command.com requires this.
158 (setq process-coding-system-alist
159 `(("[cC][mM][dD][pP][rR][oO][xX][yY]"
160 . ,(if default-enable-multibyte-characters
161 '(undecided-dos . undecided-dos)
162 '(raw-text-dos . raw-text-dos)))))))
164 (add-hook 'before-init-hook 'set-default-process-coding-system)
167 ;;; Basic support functions for managing Emacs' locale setting
169 (defvar w32-valid-locales nil
170 "List of locale ids known to be supported.")
172 ;;; This is the brute-force version; an efficient version is now
173 ;;; built-in though.
174 (if (not (fboundp 'w32-get-valid-locale-ids))
175 (defun w32-get-valid-locale-ids ()
176 "Return list of all valid Windows locale ids."
177 (let ((i 65535)
178 locales)
179 (while (> i 0)
180 (if (w32-get-locale-info i)
181 (setq locales (cons i locales)))
182 (setq i (1- i)))
183 locales)))
185 (defun w32-list-locales ()
186 "List the name and id of all locales supported by Windows."
187 (interactive)
188 (if (null w32-valid-locales)
189 (setq w32-valid-locales (w32-get-valid-locale-ids)))
190 (switch-to-buffer-other-window (get-buffer-create "*Supported Locales*"))
191 (erase-buffer)
192 (insert "LCID\tAbbrev\tFull name\n\n")
193 (insert (mapconcat
194 '(lambda (x)
195 (format "%d\t%s\t%s"
197 (w32-get-locale-info x)
198 (w32-get-locale-info x t)))
199 w32-valid-locales "\n"))
200 (insert "\n")
201 (goto-char (point-min)))
204 ;;; Setup Info-default-directory-list to include the info directory
205 ;;; near where Emacs executable was installed. We used to set INFOPATH,
206 ;;; but when this is set Info-default-directory-list is ignored. We
207 ;;; also cannot rely upon what is set in paths.el because they assume
208 ;;; that configuration during build time is correct for runtime.
209 (defun w32-init-info ()
210 (let* ((instdir (file-name-directory invocation-directory))
211 (dir1 (expand-file-name "../info/" instdir))
212 (dir2 (expand-file-name "../../../info/" instdir)))
213 (if (file-exists-p dir1)
214 (setq Info-default-directory-list
215 (append Info-default-directory-list (list dir1)))
216 (if (file-exists-p dir2)
217 (setq Info-default-directory-list
218 (append Info-default-directory-list (list dir2)))))))
220 (add-hook 'before-init-hook 'w32-init-info)
222 ;;; The variable source-directory is used to initialize Info-directory-list.
223 ;;; However, the common case is that Emacs is being used from a binary
224 ;;; distribution, and the value of source-directory is meaningless in that
225 ;;; case. Even worse, source-directory can refer to a directory on a drive
226 ;;; on the build machine that happens to be a removable drive on the user's
227 ;;; machine. When this happens, Emacs tries to access the removable drive
228 ;;; and produces the abort/retry/ignore dialog. Since we do not use
229 ;;; source-directory, set it to something that is a reasonable approximation
230 ;;; on the user's machine.
232 ;(add-hook 'before-init-hook
233 ; '(lambda ()
234 ; (setq source-directory (file-name-as-directory
235 ; (expand-file-name ".." exec-directory)))))
237 ;; Avoid creating auto-save file names containing invalid characters.
238 (fset 'original-make-auto-save-file-name
239 (symbol-function 'make-auto-save-file-name))
241 (defun make-auto-save-file-name ()
242 "Return file name to use for auto-saves of current buffer.
243 Does not consider `auto-save-visited-file-name' as that variable is checked
244 before calling this function. You can redefine this for customization.
245 See also `auto-save-file-name-p'."
246 (let ((filename (original-make-auto-save-file-name)))
247 ;; Don't modify remote (ange-ftp) filenames
248 (if (string-match "^/\\w+@[-A-Za-z0-9._]+:" filename)
249 filename
250 (convert-standard-filename filename))))
252 (defun convert-standard-filename (filename)
253 "Convert a standard file's name to something suitable for the current OS.
254 This function's standard definition is trivial; it just returns the argument.
255 However, on some systems, the function is redefined
256 with a definition that really does change some file names."
257 (let ((name (copy-sequence filename))
258 (start 0))
259 ;; leave ':' if part of drive specifier
260 (if (and (> (length name) 1)
261 (eq (aref name 1) ?:))
262 (setq start 2))
263 ;; destructively replace invalid filename characters with !
264 (while (string-match "[?*:<>|\"\000-\037]" name start)
265 (aset name (match-beginning 0) ?!)
266 (setq start (match-end 0)))
267 ;; convert directory separators to Windows format
268 ;; (but only if the shell in use requires it)
269 (if (w32-shell-dos-semantics)
270 (while (string-match "/" name start)
271 (aset name (match-beginning 0) ?\\)
272 (setq start (match-end 0))))
273 name))
275 ;;; Fix interface to (X-specific) mouse.el
276 (defun x-set-selection (type data)
277 (or type (setq type 'PRIMARY))
278 (put 'x-selections type data))
280 (defun x-get-selection (&optional type data-type)
281 (or type (setq type 'PRIMARY))
282 (get 'x-selections type))
284 (defun set-w32-system-coding-system (coding-system)
285 "Set the coding system used by the Windows System to CODING-SYSTEM.
286 This is used for things like passing font names with non-ASCII
287 characters in them to the system. For a list of possible values of
288 CODING-SYSTEM, use \\[list-coding-systems]."
289 (interactive
290 (list (let ((default w32-system-coding-system))
291 (read-coding-system
292 (format "Coding system for system calls (default, %s): "
293 default)
294 default))))
295 (check-coding-system coding-system)
296 (setq w32-system-coding-system coding-system))
297 ;; Set system coding system initially to iso-latin-1
298 (set-w32-system-coding-system 'iso-latin-1)
300 ;;; Set to a system sound if you want a fancy bell.
301 (set-message-beep nil)
303 ;;; The "Windows" keys on newer keyboards bring up the Start menu
304 ;;; whether you want it or not - make Emacs ignore these keystrokes
305 ;;; rather than beep.
306 (global-set-key [lwindow] 'ignore)
307 (global-set-key [rwindow] 'ignore)
309 ;; Map certain keypad keys into ASCII characters
310 ;; that people usually expect.
311 (define-key function-key-map [tab] [?\t])
312 (define-key function-key-map [linefeed] [?\n])
313 (define-key function-key-map [clear] [11])
314 (define-key function-key-map [return] [13])
315 (define-key function-key-map [escape] [?\e])
316 (define-key function-key-map [M-tab] [?\M-\t])
317 (define-key function-key-map [M-linefeed] [?\M-\n])
318 (define-key function-key-map [M-clear] [?\M-\013])
319 (define-key function-key-map [M-return] [?\M-\015])
320 (define-key function-key-map [M-escape] [?\M-\e])
322 ;; These don't do the right thing (voelker)
323 ;(define-key function-key-map [backspace] [127])
324 ;(define-key function-key-map [delete] [127])
325 ;(define-key function-key-map [M-backspace] [?\M-\d])
326 ;(define-key function-key-map [M-delete] [?\M-\d])
328 ;; These tell read-char how to convert
329 ;; these special chars to ASCII.
330 (put 'tab 'ascii-character ?\t)
331 (put 'linefeed 'ascii-character ?\n)
332 (put 'clear 'ascii-character 12)
333 (put 'return 'ascii-character 13)
334 (put 'escape 'ascii-character ?\e)
335 (put 'backspace 'ascii-character 127)
336 (put 'delete 'ascii-character 127)
338 ;; W32 uses different color indexes than standard:
340 (defvar w32-tty-standard-colors
341 '(("white" 15 65535 65535 65535)
342 ("yellow" 14 65535 65535 0) ; Yellow
343 ("lightmagenta" 13 65535 0 65535) ; Magenta
344 ("lightred" 12 65535 0 0) ; Red
345 ("lightcyan" 11 0 65535 65535) ; Cyan
346 ("lightgreen" 10 0 65535 0) ; Green
347 ("lightblue" 9 0 0 65535) ; Blue
348 ("darkgray" 8 26112 26112 26112) ; Gray40
349 ("lightgray" 7 48640 48640 48640) ; Gray
350 ("brown" 6 40960 20992 11520) ; Sienna
351 ("magenta" 5 35584 0 35584) ; DarkMagenta
352 ("red" 4 45568 8704 8704) ; FireBrick
353 ("cyan" 3 0 52736 53504) ; DarkTurquoise
354 ("green" 2 8704 35584 8704) ; ForestGreen
355 ("blue" 1 0 0 52480) ; MediumBlue
356 ("black" 0 0 0 0))
357 "A list of VGA console colors, their indices and 16-bit RGB values.")
360 (defun w32-add-charset-info (xlfd-charset windows-charset codepage)
361 "Function to add character sets to display with Windows fonts.
362 Creates entries in `w32-charset-info-alist'.
363 XLFD-CHARSET is a string which will appear in the XLFD font name to
364 identify the character set. WINDOWS-CHARSET is a symbol identifying
365 the Windows character set this maps to. For the list of possible
366 values, see the documentation for `w32-charset-info-alist'. CODEPAGE
367 can be a numeric codepage that Windows uses to display the character
368 set, t for Unicode output with no codepage translation or nil for 8
369 bit output with no translation."
370 (add-to-list 'w32-charset-info-alist
371 (cons xlfd-charset (cons windows-charset codepage)))
374 (w32-add-charset-info "iso8859-1" 'w32-charset-ansi 1252)
375 (w32-add-charset-info "iso8859-14" 'w32-charset-ansi 28604)
376 (w32-add-charset-info "iso8859-15" 'w32-charset-ansi 28605)
377 (w32-add-charset-info "jisx0208-sjis" 'w32-charset-shiftjis 932)
378 (w32-add-charset-info "jisx0201-latin" 'w32-charset-shiftjis 932)
379 (w32-add-charset-info "jisx0201-katakana" 'w32-charset-shiftjis 932)
380 (w32-add-charset-info "ksc5601.1987" 'w32-charset-hangeul 949)
381 (w32-add-charset-info "big5" 'w32-charset-chinesebig5 950)
382 (w32-add-charset-info "gb2312" 'w32-charset-gb2312 936)
383 (w32-add-charset-info "ms-symbol" 'w32-charset-symbol nil)
384 (w32-add-charset-info "ms-oem" 'w32-charset-oem 437)
385 (w32-add-charset-info "ms-oemlatin" 'w32-charset-oem 850)
386 (if (boundp 'w32-extra-charsets-defined)
387 (progn
388 (w32-add-charset-info "iso8859-2" 'w32-charset-easteurope 28592)
389 (w32-add-charset-info "iso8859-3" 'w32-charset-turkish 28593)
390 (w32-add-charset-info "iso8859-4" 'w32-charset-baltic 28594)
391 (w32-add-charset-info "iso8859-5" 'w32-charset-russian 28595)
392 (w32-add-charset-info "iso8859-6" 'w32-charset-arabic 28596)
393 (w32-add-charset-info "iso8859-7" 'w32-charset-greek 28597)
394 (w32-add-charset-info "iso8859-8" 'w32-charset-hebrew 1255)
395 (w32-add-charset-info "iso8859-9" 'w32-charset-turkish 1254)
396 (w32-add-charset-info "iso8859-13" 'w32-charset-baltic 1257)
397 (w32-add-charset-info "koi8-r" 'w32-charset-russian 20866)
398 (w32-add-charset-info "tis620" 'w32-charset-thai 874)
399 (w32-add-charset-info "ksc5601.1992" 'w32-charset-johab 1361)
400 (w32-add-charset-info "mac" 'w32-charset-mac nil)))
401 (if (boundp 'w32-unicode-charset-defined)
402 (progn
403 (w32-add-charset-info "iso10646" 'w32-charset-unicode t)
404 (w32-add-charset-info "unicode" 'w32-charset-unicode t)))
407 (make-obsolete-variable 'w32-enable-italics
408 'w32-enable-synthesized-fonts "21.1")
409 (make-obsolete-variable 'w32-charset-to-codepage-alist
410 'w32-charset-info-alist "21.1")
413 ;;;; Selections and cut buffers
415 ;;; We keep track of the last text selected here, so we can check the
416 ;;; current selection against it, and avoid passing back our own text
417 ;;; from x-cut-buffer-or-selection-value.
418 (defvar x-last-selected-text nil)
420 ;;; It is said that overlarge strings are slow to put into the cut buffer.
421 ;;; Note this value is overridden below.
422 (defvar x-cut-buffer-max 20000
423 "Max number of characters to put in the cut buffer.")
425 (defcustom x-select-enable-clipboard t
426 "Non-nil means cutting and pasting uses the clipboard.
427 This is in addition to the primary selection."
428 :type 'boolean
429 :group 'killing)
431 (defun x-select-text (text &optional push)
432 "Make TEXT the last selected text.
433 If `x-select-enable-clipboard' is non-nil, copy the text to the system
434 clipboard as well. Optional PUSH is ignored on Windows."
435 (if x-select-enable-clipboard
436 (w32-set-clipboard-data text))
437 (setq x-last-selected-text text))
439 (defun x-get-selection-value ()
440 "Return the value of the current selection.
441 Consult the selection, then the cut buffer. Treat empty strings as if
442 they were unset."
443 (if x-select-enable-clipboard
444 (let (text)
445 ;; Don't die if x-get-selection signals an error.
446 (condition-case c
447 (setq text (w32-get-clipboard-data))
448 (error (message "w32-get-clipboard-data:%s" c)))
449 (if (string= text "") (setq text nil))
450 (cond
451 ((not text) nil)
452 ((eq text x-last-selected-text) nil)
453 ((string= text x-last-selected-text)
454 ;; Record the newer string, so subsequent calls can use the 'eq' test.
455 (setq x-last-selected-text text)
456 nil)
458 (setq x-last-selected-text text))))))
460 (defalias 'x-cut-buffer-or-selection-value 'x-get-selection-value)
462 ;;; Arrange for the kill and yank functions to set and check the clipboard.
463 (setq interprogram-cut-function 'x-select-text)
464 (setq interprogram-paste-function 'x-get-selection-value)
467 ;;; w32-fns.el ends here