lisp/w32-fns.el

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