w32-win.el 24 KB
Newer Older
1
;;; w32-win.el --- parse switches controlling interface with W32 window system
Erik Naggum's avatar
Erik Naggum committed
2

Glenn Morris's avatar
Glenn Morris committed
3
;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004,
Glenn Morris's avatar
Glenn Morris committed
4
;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
Geoff Voelker's avatar
Geoff Voelker committed
5 6 7 8

;; Author: Kevin Gallo
;; Keywords: terminals

Erik Naggum's avatar
Erik Naggum committed
9 10
;; This file is part of GNU Emacs.

11
;; GNU Emacs is free software: you can redistribute it and/or modify
Erik Naggum's avatar
Erik Naggum committed
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Erik Naggum's avatar
Erik Naggum committed
15 16 17 18 19 20 21

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; 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/>.
Geoff Voelker's avatar
Geoff Voelker committed
23 24 25

;;; Commentary:

Geoff Voelker's avatar
Geoff Voelker committed
26 27 28 29
;; w32-win.el:  this file is loaded from ../lisp/startup.el when it recognizes
;; that W32 windows are to be used.  Command line switches are parsed and those
;; pertaining to W32 are processed and removed from the command line.  The
;; W32 display is opened and hooks are set for popping up the initial window.
Geoff Voelker's avatar
Geoff Voelker committed
30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68

;; startup.el will then examine startup files, and eventually call the hooks
;; which create the first window (s).

;;; Code:


;; These are the standard X switches from the Xt Initialize.c file of
;; Release 4.

;; Command line		Resource Manager string

;; +rv			*reverseVideo
;; +synchronous		*synchronous
;; -background		*background
;; -bd			*borderColor
;; -bg			*background
;; -bordercolor		*borderColor
;; -borderwidth		.borderWidth
;; -bw			.borderWidth
;; -display		.display
;; -fg			*foreground
;; -fn			*font
;; -font		*font
;; -foreground		*foreground
;; -geometry		.geometry
;; -i			.iconType
;; -itype		.iconType
;; -iconic		.iconic
;; -name		.name
;; -reverse		*reverseVideo
;; -rv			*reverseVideo
;; -selectionTimeout    .selectionTimeout
;; -synchronous		*synchronous
;; -xrm

;; An alist of X options and the function which handles them.  See
;; ../startup.el.

Jason Rumney's avatar
Jason Rumney committed
69 70
;; (if (not (eq window-system 'w32))
;;     (error "%s: Loading w32-win.el but not compiled for w32" (invocation-name)))
71

Geoff Voelker's avatar
Geoff Voelker committed
72 73 74 75 76 77
(require 'frame)
(require 'mouse)
(require 'scroll-bar)
(require 'faces)
(require 'select)
(require 'menu-bar)
78
(require 'dnd)
79
(require 'w32-vars)
Jason Rumney's avatar
Jason Rumney committed
80

81 82 83 84
;; Keep an obsolete alias for w32-focus-frame in case it is used by code
;; outside Emacs.
(define-obsolete-function-alias 'w32-focus-frame 'x-focus-frame "23.1")

85
(defvar xlfd-regexp-registry-subnum)
86
(defvar w32-color-map) ;; defined in w32fns.c
87

88 89 90 91
(declare-function w32-send-sys-command "w32fns.c")
(declare-function w32-select-font "w32fns.c")
(declare-function set-message-beep "w32console.c")

92
;; Conditional on new-fontset so bootstrapping works on non-GUI compiles
93 94
(if (fboundp 'new-fontset)
    (require 'fontset))
Geoff Voelker's avatar
Geoff Voelker committed
95

96
;; The following definition is used for debugging scroll bar events.
97
;(defun w32-handle-scroll-bar-event (event) (interactive "e") (princ event))
98

99 100 101
(defun w32-drag-n-drop-debug (event)
  "Print the drag-n-drop EVENT in a readable form."
  (interactive "e")
102 103 104
  (princ event))

(defun w32-drag-n-drop (event)
105
  "Edit the files listed in the drag-n-drop EVENT.
106 107
Switch to a buffer editing the last file dropped."
  (interactive "e")
108
  (save-excursion
109 110 111 112 113 114 115 116 117
    ;; Make sure the drop target has positive co-ords
    ;; before setting the selected frame - otherwise it
    ;; won't work.  <skx@tardis.ed.ac.uk>
    (let* ((window (posn-window (event-start event)))
	   (coords (posn-x-y (event-start event)))
	   (x (car coords))
	   (y (cdr coords)))
      (if (and (> x 0) (> y 0))
	  (set-frame-selected-window nil window))
118
      (mapc (lambda (file-name)
119 120 121 122 123 124 125 126
		(let ((f (subst-char-in-string ?\\ ?/ file-name))
		      (coding (or file-name-coding-system
				  default-file-name-coding-system)))
		  (setq file-name
			(mapconcat 'url-hexify-string
				   (split-string (encode-coding-string f coding)
						 "/")
				   "/")))
127
		(dnd-handle-one-url window 'private
128
				    (concat "file:" file-name)))
129
		(car (cdr (cdr event)))))
130
  (raise-frame)))
131 132

(defun w32-drag-n-drop-other-frame (event)
133
  "Edit the files listed in the drag-n-drop EVENT, in other frames.
134 135 136 137 138 139 140 141 142
May create new frames, or reuse existing ones.  The frame editing
the last file dropped is selected."
  (interactive "e")
  (mapcar 'find-file-other-frame (car (cdr (cdr event)))))

;; Bind the drag-n-drop event.
(global-set-key [drag-n-drop] 'w32-drag-n-drop)
(global-set-key [C-drag-n-drop] 'w32-drag-n-drop-other-frame)

143 144 145 146 147 148
;; Keyboard layout/language change events
;; For now ignore language-change events; in the future
;; we should switch the Emacs Input Method to match the
;; new layout/language selected by the user.
(global-set-key [language-change] 'ignore)

Geoff Voelker's avatar
Geoff Voelker committed
149 150 151 152 153
(defvar x-invocation-args)

(defvar x-command-line-resources nil)

(defun x-handle-switch (switch)
154
  "Handle SWITCH of the form \"-switch value\" or \"-switch\"."
155
  (let ((aelt (assoc switch command-line-x-option-alist)))
Geoff Voelker's avatar
Geoff Voelker committed
156
    (if aelt
Stefan Monnier's avatar
Stefan Monnier committed
157 158
	(push (cons (nth 3 aelt) (or (nth 4 aelt) (pop x-invocation-args)))
	      default-frame-alist))))
159

Geoff Voelker's avatar
Geoff Voelker committed
160
(defun x-handle-numeric-switch (switch)
161
  "Handle SWITCH of the form \"-switch n\"."
162
  (let ((aelt (assoc switch command-line-x-option-alist)))
Geoff Voelker's avatar
Geoff Voelker committed
163
    (if aelt
164
	(push (cons (nth 3 aelt) (string-to-number (pop x-invocation-args)))
Stefan Monnier's avatar
Stefan Monnier committed
165
	      default-frame-alist))))
166 167 168 169 170

;; Handle options that apply to initial frame only
(defun x-handle-initial-switch (switch)
  (let ((aelt (assoc switch command-line-x-option-alist)))
    (if aelt
Stefan Monnier's avatar
Stefan Monnier committed
171 172
	(push (cons (nth 3 aelt) (or (nth 4 aelt) (pop x-invocation-args)))
	      initial-frame-alist))))
173 174 175

(defun x-handle-iconic (switch)
  "Make \"-iconic\" SWITCH apply only to the initial frame."
Stefan Monnier's avatar
Stefan Monnier committed
176
  (push '(visibility . icon) initial-frame-alist))
Geoff Voelker's avatar
Geoff Voelker committed
177 178

(defun x-handle-xrm-switch (switch)
179
  "Handle the \"-xrm\" SWITCH."
Geoff Voelker's avatar
Geoff Voelker committed
180 181
  (or (consp x-invocation-args)
      (error "%s: missing argument to `%s' option" (invocation-name) switch))
182 183 184 185
  (setq x-command-line-resources
	(if (null x-command-line-resources)
	    (car x-invocation-args)
	  (concat x-command-line-resources "\n" (car x-invocation-args))))
Geoff Voelker's avatar
Geoff Voelker committed
186 187 188
  (setq x-invocation-args (cdr x-invocation-args)))

(defun x-handle-geometry (switch)
189
  "Handle the \"-geometry\" SWITCH."
190 191 192 193 194 195 196 197
  (let* ((geo (x-parse-geometry (car x-invocation-args)))
	 (left (assq 'left geo))
	 (top (assq 'top geo))
	 (height (assq 'height geo))
	 (width (assq 'width geo)))
    (if (or height width)
	(setq default-frame-alist
	      (append default-frame-alist
198 199 200 201 202
		      '((user-size . t))
		      (if height (list height))
		      (if width (list width)))
	      initial-frame-alist
	      (append initial-frame-alist
203 204 205 206 207 208 209 210 211 212
		      '((user-size . t))
		      (if height (list height))
		      (if width (list width)))))
    (if (or left top)
	(setq initial-frame-alist
	      (append initial-frame-alist
		      '((user-position . t))
		      (if left (list left))
		      (if top (list top)))))
    (setq x-invocation-args (cdr x-invocation-args))))
Geoff Voelker's avatar
Geoff Voelker committed
213

214
(defun x-handle-name-switch (switch)
215
  "Handle the \"-name\" SWITCH."
216 217
;; Handle the -name option.  Set the variable x-resource-name
;; to the option's operand; set the name of the initial frame, too.
Geoff Voelker's avatar
Geoff Voelker committed
218 219
  (or (consp x-invocation-args)
      (error "%s: missing argument to `%s' option" (invocation-name) switch))
Stefan Monnier's avatar
Stefan Monnier committed
220 221
  (setq x-resource-name (pop x-invocation-args))
  (push (cons 'name x-resource-name) initial-frame-alist))
Geoff Voelker's avatar
Geoff Voelker committed
222 223 224 225 226

(defvar x-display-name nil
  "The display name specifying server and frame.")

(defun x-handle-display (switch)
227
  "Handle the \"-display\" SWITCH."
Stefan Monnier's avatar
Stefan Monnier committed
228
  (setq x-display-name (pop x-invocation-args)))
Geoff Voelker's avatar
Geoff Voelker committed
229 230 231 232

(defun x-handle-args (args)
  "Process the X-related command line options in ARGS.
This is done before the user's startup file is loaded.  They are copied to
233
`x-invocation args' from which the X-related things are extracted, first
Geoff Voelker's avatar
Geoff Voelker committed
234 235 236
the switch (e.g., \"-fg\") in the following code, and possible values
\(e.g., \"black\") in the option handler code (e.g., x-handle-switch).
This returns ARGS with the arguments that have been processed removed."
237
  ;; We use ARGS to accumulate the args that we don't handle here, to return.
Geoff Voelker's avatar
Geoff Voelker committed
238 239
  (setq x-invocation-args args
	args nil)
240 241
  (while (and x-invocation-args
	      (not (equal (car x-invocation-args) "--")))
Geoff Voelker's avatar
Geoff Voelker committed
242 243
    (let* ((this-switch (car x-invocation-args))
	   (orig-this-switch this-switch)
244
	   completion argval aelt handler)
Geoff Voelker's avatar
Geoff Voelker committed
245 246 247 248 249 250
      (setq x-invocation-args (cdr x-invocation-args))
      ;; Check for long options with attached arguments
      ;; and separate out the attached option argument into argval.
      (if (string-match "^--[^=]*=" this-switch)
	  (setq argval (substring this-switch (match-end 0))
		this-switch (substring this-switch 0 (1- (match-end 0)))))
251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266
      ;; Complete names of long options.
      (if (string-match "^--" this-switch)
	  (progn
	    (setq completion (try-completion this-switch command-line-x-option-alist))
	    (if (eq completion t)
		;; Exact match for long option.
		nil
	      (if (stringp completion)
		  (let ((elt (assoc completion command-line-x-option-alist)))
		    ;; Check for abbreviated long option.
		    (or elt
			(error "Option `%s' is ambiguous" this-switch))
		    (setq this-switch completion))))))
      (setq aelt (assoc this-switch command-line-x-option-alist))
      (if aelt (setq handler (nth 2 aelt)))
      (if handler
Geoff Voelker's avatar
Geoff Voelker committed
267 268 269
	  (if argval
	      (let ((x-invocation-args
		     (cons argval x-invocation-args)))
270 271
		(funcall handler this-switch))
	    (funcall handler this-switch))
Stefan Monnier's avatar
Stefan Monnier committed
272
	(push orig-this-switch args))))
273
  (nconc (nreverse args) x-invocation-args))
Geoff Voelker's avatar
Geoff Voelker committed
274 275 276 277

;;
;; Available colors
;;
Chong Yidong's avatar
Chong Yidong committed
278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357
;; The ordering of the colors is chosen for the user's convenience in
;; `list-colors-display', which displays the reverse of this list.
;; Roughly speaking, `list-colors-display' orders by (i) named shades
;; of grey with hue 0.0, sorted by value (ii) named colors with
;; saturation 1.0, sorted by hue, (iii) named non-white colors with
;; saturation less than 1.0, sorted by hue, (iv) other named shades of
;; white, (v) numbered colors sorted by hue, and (vi) numbered shades
;; of grey.

(defvar x-colors
  '("gray100" "gray99" "gray98" "gray97" "gray96" "gray95" "gray94" "gray93" "gray92"
    "gray91" "gray90" "gray89" "gray88" "gray87" "gray86" "gray85" "gray84" "gray83"
    "gray82" "gray81" "gray80" "gray79" "gray78" "gray77" "gray76" "gray75" "gray74"
    "gray73" "gray72" "gray71" "gray70" "gray69" "gray68" "gray67" "gray66" "gray65"
    "gray64" "gray63" "gray62" "gray61" "gray60" "gray59" "gray58" "gray57" "gray56"
    "gray55" "gray54" "gray53" "gray52" "gray51" "gray50" "gray49" "gray48" "gray47"
    "gray46" "gray45" "gray44" "gray43" "gray42" "gray41" "gray40" "gray39" "gray38"
    "gray37" "gray36" "gray35" "gray34" "gray33" "gray32" "gray31" "gray30" "gray29"
    "gray28" "gray27" "gray26" "gray25" "gray24" "gray23" "gray22" "gray21" "gray20"
    "gray19" "gray18" "gray17" "gray16" "gray15" "gray14" "gray13" "gray12" "gray11"
    "gray10" "gray9" "gray8" "gray7" "gray6" "gray5" "gray4" "gray3" "gray2" "gray1"
    "gray0" "LightPink1" "LightPink2" "LightPink3" "LightPink4" "pink1" "pink2" "pink3"
    "pink4" "PaleVioletRed1" "PaleVioletRed2" "PaleVioletRed3" "PaleVioletRed4"
    "LavenderBlush1" "LavenderBlush2" "LavenderBlush3" "LavenderBlush4" "VioletRed1"
    "VioletRed2" "VioletRed3" "VioletRed4" "HotPink1" "HotPink2" "HotPink3" "HotPink4"
    "DeepPink1" "DeepPink2" "DeepPink3" "DeepPink4" "maroon1" "maroon2" "maroon3"
    "maroon4" "orchid1" "orchid2" "orchid3" "orchid4" "plum1" "plum2" "plum3" "plum4"
    "thistle1" "thistle2" "thistle3" "thistle4" "MediumOrchid1" "MediumOrchid2"
    "MediumOrchid3" "MediumOrchid4" "DarkOrchid1" "DarkOrchid2" "DarkOrchid3"
    "DarkOrchid4" "purple1" "purple2" "purple3" "purple4" "MediumPurple1"
    "MediumPurple2" "MediumPurple3" "MediumPurple4" "SlateBlue1" "SlateBlue2"
    "SlateBlue3" "SlateBlue4" "RoyalBlue1" "RoyalBlue2" "RoyalBlue3" "RoyalBlue4"
    "LightSteelBlue1" "LightSteelBlue2" "LightSteelBlue3" "LightSteelBlue4" "SlateGray1"
    "SlateGray2" "SlateGray3" "SlateGray4" "DodgerBlue1" "DodgerBlue2" "DodgerBlue3"
    "DodgerBlue4" "SteelBlue1" "SteelBlue2" "SteelBlue3" "SteelBlue4" "SkyBlue1"
    "SkyBlue2" "SkyBlue3" "SkyBlue4" "LightSkyBlue1" "LightSkyBlue2" "LightSkyBlue3"
    "LightSkyBlue4" "LightBlue1" "LightBlue2" "LightBlue3" "LightBlue4" "CadetBlue1"
    "CadetBlue2" "CadetBlue3" "CadetBlue4" "azure1" "azure2" "azure3" "azure4"
    "LightCyan1" "LightCyan2" "LightCyan3" "LightCyan4" "PaleTurquoise1"
    "PaleTurquoise2" "PaleTurquoise3" "PaleTurquoise4" "DarkSlateGray1" "DarkSlateGray2"
    "DarkSlateGray3" "DarkSlateGray4" "aquamarine1" "aquamarine2" "aquamarine3"
    "aquamarine4" "SeaGreen1" "SeaGreen2" "SeaGreen3" "SeaGreen4" "honeydew1"
    "honeydew2" "honeydew3" "honeydew4" "DarkSeaGreen1" "DarkSeaGreen2" "DarkSeaGreen3"
    "DarkSeaGreen4" "PaleGreen1" "PaleGreen2" "PaleGreen3" "PaleGreen4"
    "DarkOliveGreen1" "DarkOliveGreen2" "DarkOliveGreen3" "DarkOliveGreen4" "OliveDrab1"
    "OliveDrab2" "OliveDrab3" "OliveDrab4" "ivory1" "ivory2" "ivory3" "ivory4"
    "LightYellow1" "LightYellow2" "LightYellow3" "LightYellow4" "khaki1" "khaki2"
    "khaki3" "khaki4" "LemonChiffon1" "LemonChiffon2" "LemonChiffon3" "LemonChiffon4"
    "LightGoldenrod1" "LightGoldenrod2" "LightGoldenrod3" "LightGoldenrod4" "cornsilk1"
    "cornsilk2" "cornsilk3" "cornsilk4" "goldenrod1" "goldenrod2" "goldenrod3"
    "goldenrod4" "DarkGoldenrod1" "DarkGoldenrod2" "DarkGoldenrod3" "DarkGoldenrod4"
    "wheat1" "wheat2" "wheat3" "wheat4" "NavajoWhite1" "NavajoWhite2" "NavajoWhite3"
    "NavajoWhite4" "burlywood1" "burlywood2" "burlywood3" "burlywood4" "AntiqueWhite1"
    "AntiqueWhite2" "AntiqueWhite3" "AntiqueWhite4" "bisque1" "bisque2" "bisque3"
    "bisque4" "tan1" "tan2" "tan3" "tan4" "PeachPuff1" "PeachPuff2" "PeachPuff3"
    "PeachPuff4" "seashell1" "seashell2" "seashell3" "seashell4" "chocolate1"
    "chocolate2" "chocolate3" "chocolate4" "sienna1" "sienna2" "sienna3" "sienna4"
    "LightSalmon1" "LightSalmon2" "LightSalmon3" "LightSalmon4" "salmon1" "salmon2"
    "salmon3" "salmon4" "coral1" "coral2" "coral3" "coral4" "tomato1" "tomato2"
    "tomato3" "tomato4" "MistyRose1" "MistyRose2" "MistyRose3" "MistyRose4" "snow1"
    "snow2" "snow3" "snow4" "RosyBrown1" "RosyBrown2" "RosyBrown3" "RosyBrown4"
    "IndianRed1" "IndianRed2" "IndianRed3" "IndianRed4" "firebrick1" "firebrick2"
    "firebrick3" "firebrick4" "brown1" "brown2" "brown3" "brown4" "magenta1" "magenta2"
    "magenta3" "magenta4" "blue1" "blue2" "blue3" "blue4" "DeepSkyBlue1" "DeepSkyBlue2"
    "DeepSkyBlue3" "DeepSkyBlue4" "turquoise1" "turquoise2" "turquoise3" "turquoise4"
    "cyan1" "cyan2" "cyan3" "cyan4" "SpringGreen1" "SpringGreen2" "SpringGreen3"
    "SpringGreen4" "green1" "green2" "green3" "green4" "chartreuse1" "chartreuse2"
    "chartreuse3" "chartreuse4" "yellow1" "yellow2" "yellow3" "yellow4" "gold1" "gold2"
    "gold3" "gold4" "orange1" "orange2" "orange3" "orange4" "DarkOrange1" "DarkOrange2"
    "DarkOrange3" "DarkOrange4" "OrangeRed1" "OrangeRed2" "OrangeRed3" "OrangeRed4"
    "red1" "red2" "red3" "red4" "lavender blush" "ghost white" "lavender" "alice blue"
    "azure" "light cyan" "mint cream" "honeydew" "ivory" "light goldenrod yellow"
    "light yellow" "beige" "floral white" "old lace" "blanched almond" "moccasin"
    "papaya whip" "bisque" "antique white" "linen" "peach puff" "seashell" "misty rose"
    "snow" "light pink" "pink" "hot pink" "deep pink" "maroon" "pale violet red"
    "violet red" "medium violet red" "violet" "plum" "thistle" "orchid" "medium orchid"
    "dark orchid" "purple" "blue violet" "medium purple" "light slate blue"
    "medium slate blue" "slate blue" "dark slate blue" "midnight blue" "navy"
    "dark blue" "light steel blue" "cornflower blue" "dodger blue" "royal blue"
    "light slate gray" "slate gray" "dark slate gray" "steel blue" "cadet blue"
Chong Yidong's avatar
Chong Yidong committed
358
    "light sky blue" "sky blue" "light blue" "powder blue" "pale turquoise" "turquoise"
Chong Yidong's avatar
Chong Yidong committed
359 360 361 362 363 364 365 366
    "medium turquoise" "dark cyan" "aquamarine" "medium aquamarine" "light sea green"
    "medium sea green" "sea green" "dark sea green" "pale green" "lime green"
    "forest green" "light green" "green yellow" "yellow green" "olive drab"
    "dark olive green" "lemon chiffon" "khaki" "dark khaki" "cornsilk"
    "pale goldenrod" "light goldenrod" "goldenrod" "dark goldenrod" "wheat"
    "navajo white" "tan" "burlywood" "sandy brown" "peru" "chocolate" "saddle brown"
    "sienna" "rosy brown" "dark salmon" "coral" "tomato" "light salmon" "salmon"
    "light coral" "indian red" "firebrick" "brown" "dark red" "magenta"
Chong Yidong's avatar
Chong Yidong committed
367
    "dark magenta" "dark violet" "medium blue" "blue" "deep sky blue"
Chong Yidong's avatar
Chong Yidong committed
368 369 370
    "cyan" "medium spring green" "spring green" "green" "lawn green" "chartreuse"
    "yellow" "gold" "orange" "dark orange" "orange red" "red" "white" "white smoke"
    "gainsboro" "light grey" "gray" "dark grey" "dim gray" "black" )
371 372
  "The list of X colors from the `rgb.txt' file.
XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp")
Geoff Voelker's avatar
Geoff Voelker committed
373

374 375
(defun xw-defined-colors (&optional frame)
  "Internal function called by `defined-colors', which see."
Geoff Voelker's avatar
Geoff Voelker committed
376
  (or frame (setq frame (selected-frame)))
Stefan Monnier's avatar
Stefan Monnier committed
377 378
  (let ((defined-colors nil))
    (dolist (this-color (or (mapcar 'car w32-color-map) x-colors))
379
      (and (color-supported-p this-color frame t)
Stefan Monnier's avatar
Stefan Monnier committed
380
	   (push this-color defined-colors)))
Geoff Voelker's avatar
Geoff Voelker committed
381 382
    defined-colors))

383

Geoff Voelker's avatar
Geoff Voelker committed
384 385
;;;; Function keys

Miles Bader's avatar
Miles Bader committed
386 387
 ;;; make f10 activate the real menubar rather than the mini-buffer menu
 ;;; navigation feature.
388
 (defun w32-menu-bar-open (&optional frame)
Miles Bader's avatar
Miles Bader committed
389 390
   "Start key navigation of the menu bar in FRAME.
 
391 392 393
This initially activates the first menu-bar item, and you can then navigate
with the arrow keys, select a menu entry with the Return key or cancel with
the Escape key.  If FRAME has no menu bar, this function does nothing.
Miles Bader's avatar
Miles Bader committed
394
 
395 396 397
If FRAME is nil or not given, use the selected frame.
If FRAME does not have the menu bar enabled, display a text menu using
`tmm-menubar'."
Miles Bader's avatar
Miles Bader committed
398
   (interactive "i")
399 400 401 402
   (if menu-bar-mode
       (w32-send-sys-command ?\xf100 frame)
     (with-selected-frame (or frame (selected-frame))
       (tmm-menubar))))
Geoff Voelker's avatar
Geoff Voelker committed
403 404


405 406 407
;; W32 systems have different fonts than commonly found on X, so
;; we define our own standard fontset here.
(defvar w32-standard-fontset-spec
408
 "-*-Courier New-normal-r-*-*-13-*-*-*-c-*-fontset-standard"
409 410 411 412
 "String of fontset spec of the standard fontset.
This defines a fontset consisting of the Courier New variations for
European languages which are distributed with Windows as
\"Multilanguage Support\".
413

414
See the documentation of `create-fontset-from-fontset-spec' for the format.")
415

Geoff Voelker's avatar
Geoff Voelker committed
416
(defun x-win-suspend-error ()
417 418
  "Report an error when a suspend is attempted."
  (error "Suspending an Emacs running under W32 makes no sense"))
Geoff Voelker's avatar
Geoff Voelker committed
419 420 421


(defun mouse-set-font (&rest fonts)
422 423
  "Select an Emacs font from a list of known good fonts and fontsets.

424
If `w32-use-w32-font-dialog' is non-nil (the default), use the Windows
Eli Zaretskii's avatar
Eli Zaretskii committed
425
font dialog to display the list of possible fonts.  Otherwise use a
426 427 428 429 430
pop-up menu (like Emacs does on other platforms) initialized with
the fonts in `w32-fixed-font-alist'.
If `w32-list-proportional-fonts' is non-nil, add proportional fonts
to the list in the font selection dialog (the fonts listed by the
pop-up menu are unaffected by `w32-list-proportional-fonts')."
431 432
  (interactive
   (if w32-use-w32-font-dialog
433 434
       (let ((chosen-font (w32-select-font (selected-frame)
					   w32-list-proportional-fonts)))
435
	 (and chosen-font (list chosen-font)))
436 437
     (x-popup-menu
      last-nonmenu-event
Stefan Monnier's avatar
Stefan Monnier committed
438
      ;; Append list of fontsets currently defined.
439
      ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles
440
      (if (fboundp 'new-fontset)
Miles Bader's avatar
Miles Bader committed
441
          (append w32-fixed-font-alist (list (generate-fontset-menu)))))))
442
  (if fonts
443
      (let (font)
444 445 446
	(while fonts
	  (condition-case nil
	      (progn
447
                (setq font (car fonts))
448
		(set-default-font font)
449 450
                (setq fonts nil))
	    (error (setq fonts (cdr fonts)))))
451 452
	(if (null font)
	    (error "Font not found")))))
Geoff Voelker's avatar
Geoff Voelker committed
453

454 455
;;; Set default known names for image libraries
(setq image-library-alist
456
      '((xpm "libxpm.dll" "xpm4.dll" "libXpm-nox4.dll")
457 458 459
        (png "libpng12d.dll" "libpng12.dll" "libpng.dll"
	 ;; these are libpng 1.2.8 from GTK+
	 "libpng13d.dll" "libpng13.dll")
460 461
        (jpeg "jpeg62.dll" "libjpeg.dll" "jpeg-62.dll" "jpeg.dll")
        (tiff "libtiff3.dll" "libtiff.dll")
462 463 464 465
        (gif "giflib4.dll" "libungif4.dll" "libungif.dll")
        (svg "librsvg-2-2.dll")
        (gdk-pixbuf "libgdk_pixbuf-2.0-0.dll")
        (glib "libglib-2.0-0.dll")))
466

467 468 469 470
;;; multi-tty support
(defvar w32-initialized nil
  "Non-nil if the w32 window system has been initialized.")

Jason Rumney's avatar
Jason Rumney committed
471 472
(defun w32-initialize-window-system ()
  "Initialize Emacs for W32 GUI frames."
473 474 475 476 477 478 479 480 481 482 483 484 485

  ;; Do the actual Windows setup here; the above code just defines
  ;; functions and variables that we use now.

  (setq command-line-args (x-handle-args command-line-args))

  ;; Make sure we have a valid resource name.
  (or (stringp x-resource-name)
      (setq x-resource-name
            ;; Change any . or * characters in x-resource-name to hyphens,
            ;; so as not to choke when we use it in X resource queries.
            (replace-regexp-in-string "[.*]" "-" (invocation-name))))

486 487 488 489
  (x-open-connection "" x-command-line-resources
                     ;; Exit with a fatal error if this fails and we
                     ;; are the initial display
                     (eq initial-window-system 'w32))
490 491 492

  ;; Setup the default fontset.
  (setup-default-fontset)
493 494

  ;; Enable Japanese fonts on Windows to be used by default.
495
  (set-fontset-font t (make-char 'katakana-jisx0201)
496
		    '("*" . "JISX0208-SJIS"))
497
  (set-fontset-font t (make-char 'latin-jisx0201)
498
		    '("*" . "JISX0208-SJIS"))
499
  (set-fontset-font t (make-char 'japanese-jisx0208)
500
		    '("*" . "JISX0208-SJIS"))
501
  (set-fontset-font t (make-char 'japanese-jisx0208-1978)
502 503
		    '("*" . "JISX0208-SJIS"))

504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531
  ;; Create the standard fontset.
  (create-fontset-from-fontset-spec w32-standard-fontset-spec t)
  ;; Create fontset specified in X resources "Fontset-N" (N is 0, 1,...).
  (create-fontset-from-x-resource)

  ;; Apply a geometry resource to the initial frame.  Put it at the end
  ;; of the alist, so that anything specified on the command line takes
  ;; precedence.
  (let* ((res-geometry (x-get-resource "geometry" "Geometry"))
         parsed)
    (if res-geometry
        (progn
          (setq parsed (x-parse-geometry res-geometry))
          ;; If the resource specifies a position,
          ;; call the position and size "user-specified".
          (if (or (assq 'top parsed) (assq 'left parsed))
              (setq parsed (cons '(user-position . t)
                                 (cons '(user-size . t) parsed))))
          ;; All geometry parms apply to the initial frame.
          (setq initial-frame-alist (append initial-frame-alist parsed))
          ;; The size parms apply to all frames.
          (if (assq 'height parsed)
              (push (cons 'height (cdr (assq 'height parsed)))
                    default-frame-alist))
          (if (assq 'width parsed)
              (push (cons 'width (cdr (assq 'width parsed)))
                    default-frame-alist)))))

532 533 534 535 536 537 538
  ;; Check the reverseVideo resource.
  (let ((case-fold-search t))
    (let ((rv (x-get-resource "reverseVideo" "ReverseVideo")))
      (if (and rv (string-match "^\\(true\\|yes\\|on\\)$" rv))
          (push '(reverse . t) default-frame-alist))))

  ;; Don't let Emacs suspend under w32 gui
539 540 541 542 543 544
  (add-hook 'suspend-hook 'x-win-suspend-error)

  ;; Turn off window-splitting optimization; w32 is usually fast enough
  ;; that this is only annoying.
  (setq split-window-keep-point t)

545 546 547 548 549 550
  ;; Turn on support for mouse wheels
  (mouse-wheel-mode 1)

  ;; W32 expects the menu bar cut and paste commands to use the clipboard.
  (menu-bar-enable-clipboard)

551 552 553 554 555
  ;; Don't show the frame name; that's redundant.
  (setq-default mode-line-frame-identification "  ")

  ;; Set to a system sound if you want a fancy bell.
  (set-message-beep 'ok)
556
  (setq w32-initialized t))
Jason Rumney's avatar
Jason Rumney committed
557 558 559 560 561 562

(add-to-list 'handle-args-function-alist '(w32 . x-handle-args))
(add-to-list 'frame-creation-function-alist '(w32 . x-create-frame-with-faces))
(add-to-list 'window-system-initialization-alist '(w32 . w32-initialize-window-system))

(provide 'w32-win)
563

Stefan Monnier's avatar
Stefan Monnier committed
564
;; arch-tag: 69fb1701-28c2-4890-b351-3d1fe4b4f166
Geoff Voelker's avatar
Geoff Voelker committed
565
;;; w32-win.el ends here