]> code.delx.au - gnu-emacs/blob - src/w32fns.c
delx.au / code / gnu-emacs / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Use epaths.h istead of paths.h.
[gnu-emacs] / src / w32fns.c
1 /* Graphical user interface functions for the Microsoft W32 API.
2 Copyright (C) 1989, 92, 93, 94, 95, 1996 Free Software Foundation, Inc.
3
4 This file is part of GNU Emacs.
5
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
9 any later version.
10
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
20
21 /* Added by Kevin Gallo */
22
23 #include <config.h>
24
25 #include <signal.h>
26 #include <stdio.h>
27 #include <limits.h>
28 #include <errno.h>
29
30 #include "lisp.h"
31 #include "charset.h"
32 #include "fontset.h"
33 #include "w32term.h"
34 #include "frame.h"
35 #include "window.h"
36 #include "buffer.h"
37 #include "dispextern.h"
38 #include "keyboard.h"
39 #include "blockinput.h"
40 #include "epaths.h"
41 #include "w32heap.h"
42 #include "termhooks.h"
43 #include "coding.h"
44
45 #include <commdlg.h>
46 #include <shellapi.h>
47
48 extern void abort ();
49 extern void free_frame_menubar ();
50 extern struct scroll_bar *x_window_to_scroll_bar ();
51 extern int w32_console_toggle_lock_key (int vk_code, Lisp_Object new_state);
52 extern int quit_char;
53
54 extern char *lispy_function_keys[];
55
56 /* The colormap for converting color names to RGB values */
57 Lisp_Object Vw32_color_map;
58
59 /* Non nil if alt key presses are passed on to Windows. */
60 Lisp_Object Vw32_pass_alt_to_system;
61
62 /* Non nil if alt key is translated to meta_modifier, nil if it is translated
63 to alt_modifier. */
64 Lisp_Object Vw32_alt_is_meta;
65
66 /* If non-zero, the windows virtual key code for an alternative quit key. */
67 Lisp_Object Vw32_quit_key;
68
69 /* Non nil if left window key events are passed on to Windows (this only
70 affects whether "tapping" the key opens the Start menu). */
71 Lisp_Object Vw32_pass_lwindow_to_system;
72
73 /* Non nil if right window key events are passed on to Windows (this
74 only affects whether "tapping" the key opens the Start menu). */
75 Lisp_Object Vw32_pass_rwindow_to_system;
76
77 /* Virtual key code used to generate "phantom" key presses in order
78 to stop system from acting on Windows key events. */
79 Lisp_Object Vw32_phantom_key_code;
80
81 /* Modifier associated with the left "Windows" key, or nil to act as a
82 normal key. */
83 Lisp_Object Vw32_lwindow_modifier;
84
85 /* Modifier associated with the right "Windows" key, or nil to act as a
86 normal key. */
87 Lisp_Object Vw32_rwindow_modifier;
88
89 /* Modifier associated with the "Apps" key, or nil to act as a normal
90 key. */
91 Lisp_Object Vw32_apps_modifier;
92
93 /* Value is nil if Num Lock acts as a function key. */
94 Lisp_Object Vw32_enable_num_lock;
95
96 /* Value is nil if Caps Lock acts as a function key. */
97 Lisp_Object Vw32_enable_caps_lock;
98
99 /* Modifier associated with Scroll Lock, or nil to act as a normal key. */
100 Lisp_Object Vw32_scroll_lock_modifier;
101
102 /* Switch to control whether we inhibit requests for italicised fonts (which
103 are synthesized, look ugly, and are trashed by cursor movement under NT). */
104 Lisp_Object Vw32_enable_italics;
105
106 /* Enable palette management. */
107 Lisp_Object Vw32_enable_palette;
108
109 /* Control how close left/right button down events must be to
110 be converted to a middle button down event. */
111 Lisp_Object Vw32_mouse_button_tolerance;
112
113 /* Minimum interval between mouse movement (and scroll bar drag)
114 events that are passed on to the event loop. */
115 Lisp_Object Vw32_mouse_move_interval;
116
117 /* The name we're using in resource queries. */
118 Lisp_Object Vx_resource_name;
119
120 /* Non nil if no window manager is in use. */
121 Lisp_Object Vx_no_window_manager;
122
123 /* The background and shape of the mouse pointer, and shape when not
124 over text or in the modeline. */
125 Lisp_Object Vx_pointer_shape, Vx_nontext_pointer_shape, Vx_mode_pointer_shape;
126 /* The shape when over mouse-sensitive text. */
127 Lisp_Object Vx_sensitive_text_pointer_shape;
128
129 /* Color of chars displayed in cursor box. */
130 Lisp_Object Vx_cursor_fore_pixel;
131
132 /* Nonzero if using Windows. */
133 static int w32_in_use;
134
135 /* Search path for bitmap files. */
136 Lisp_Object Vx_bitmap_file_path;
137
138 /* Regexp matching a font name whose width is the same as `PIXEL_SIZE'. */
139 Lisp_Object Vx_pixel_size_width_font_regexp;
140
141 /* Alist of bdf fonts and the files that define them. */
142 Lisp_Object Vw32_bdf_filename_alist;
143
144 /* A flag to control how to display unibyte 8-bit character. */
145 int unibyte_display_via_language_environment;
146
147 /* Evaluate this expression to rebuild the section of syms_of_w32fns
148 that initializes and staticpros the symbols declared below. Note
149 that Emacs 18 has a bug that keeps C-x C-e from being able to
150 evaluate this expression.
151
152 (progn
153 ;; Accumulate a list of the symbols we want to initialize from the
154 ;; declarations at the top of the file.
155 (goto-char (point-min))
156 (search-forward "/\*&&& symbols declared here &&&*\/\n")
157 (let (symbol-list)
158 (while (looking-at "Lisp_Object \\(Q[a-z_]+\\)")
159 (setq symbol-list
160 (cons (buffer-substring (match-beginning 1) (match-end 1))
161 symbol-list))
162 (forward-line 1))
163 (setq symbol-list (nreverse symbol-list))
164 ;; Delete the section of syms_of_... where we initialize the symbols.
165 (search-forward "\n /\*&&& init symbols here &&&*\/\n")
166 (let ((start (point)))
167 (while (looking-at "^ Q")
168 (forward-line 2))
169 (kill-region start (point)))
170 ;; Write a new symbol initialization section.
171 (while symbol-list
172 (insert (format " %s = intern (\"" (car symbol-list)))
173 (let ((start (point)))
174 (insert (substring (car symbol-list) 1))
175 (subst-char-in-region start (point) ?_ ?-))
176 (insert (format "\");\n staticpro (&%s);\n" (car symbol-list)))
177 (setq symbol-list (cdr symbol-list)))))
178
179 */
180
181 /*&&& symbols declared here &&&*/
182 Lisp_Object Qauto_raise;
183 Lisp_Object Qauto_lower;
184 Lisp_Object Qbackground_color;
185 Lisp_Object Qbar;
186 Lisp_Object Qborder_color;
187 Lisp_Object Qborder_width;
188 Lisp_Object Qbox;
189 Lisp_Object Qcursor_color;
190 Lisp_Object Qcursor_type;
191 Lisp_Object Qforeground_color;
192 Lisp_Object Qgeometry;
193 Lisp_Object Qicon_left;
194 Lisp_Object Qicon_top;
195 Lisp_Object Qicon_type;
196 Lisp_Object Qicon_name;
197 Lisp_Object Qinternal_border_width;
198 Lisp_Object Qleft;
199 Lisp_Object Qright;
200 Lisp_Object Qmouse_color;
201 Lisp_Object Qnone;
202 Lisp_Object Qparent_id;
203 Lisp_Object Qscroll_bar_width;
204 Lisp_Object Qsuppress_icon;
205 Lisp_Object Qtop;
206 Lisp_Object Qundefined_color;
207 Lisp_Object Qvertical_scroll_bars;
208 Lisp_Object Qvisibility;
209 Lisp_Object Qwindow_id;
210 Lisp_Object Qx_frame_parameter;
211 Lisp_Object Qx_resource_name;
212 Lisp_Object Quser_position;
213 Lisp_Object Quser_size;
214 Lisp_Object Qdisplay;
215
216 Lisp_Object Qhyper;
217 Lisp_Object Qsuper;
218 Lisp_Object Qmeta;
219 Lisp_Object Qalt;
220 Lisp_Object Qctrl;
221 Lisp_Object Qcontrol;
222 Lisp_Object Qshift;
223
224 /* State variables for emulating a three button mouse. */
225 #define LMOUSE 1
226 #define MMOUSE 2
227 #define RMOUSE 4
228
229 static int button_state = 0;
230 static W32Msg saved_mouse_button_msg;
231 static unsigned mouse_button_timer; /* non-zero when timer is active */
232 static W32Msg saved_mouse_move_msg;
233 static unsigned mouse_move_timer;
234
235 /* W95 mousewheel handler */
236 unsigned int msh_mousewheel = 0;
237
238 #define MOUSE_BUTTON_ID 1
239 #define MOUSE_MOVE_ID 2
240
241 /* The below are defined in frame.c. */
242 extern Lisp_Object Qheight, Qminibuffer, Qname, Qonly, Qwidth;
243 extern Lisp_Object Qunsplittable, Qmenu_bar_lines, Qbuffer_predicate, Qtitle;
244
245 extern Lisp_Object Vwindow_system_version;
246
247 Lisp_Object Qface_set_after_frame_default;
248
249 extern Lisp_Object last_mouse_scroll_bar;
250 extern int last_mouse_scroll_bar_pos;
251
252 /* From w32term.c. */
253 extern Lisp_Object Vw32_num_mouse_buttons;
254 extern Lisp_Object Vw32_recognize_altgr;
255
256 \f
257 /* Error if we are not connected to MS-Windows. */
258 void
259 check_w32 ()
260 {
261 if (! w32_in_use)
262 error ("MS-Windows not in use or not initialized");
263 }
264
265 /* Nonzero if we can use mouse menus.
266 You should not call this unless HAVE_MENUS is defined. */
267
268 int
269 have_menus_p ()
270 {
271 return w32_in_use;
272 }
273
274 /* Extract a frame as a FRAME_PTR, defaulting to the selected frame
275 and checking validity for W32. */
276
277 FRAME_PTR
278 check_x_frame (frame)
279 Lisp_Object frame;
280 {
281 FRAME_PTR f;
282
283 if (NILP (frame))
284 f = selected_frame;
285 else
286 {
287 CHECK_LIVE_FRAME (frame, 0);
288 f = XFRAME (frame);
289 }
290 if (! FRAME_W32_P (f))
291 error ("non-w32 frame used");
292 return f;
293 }
294
295 /* Let the user specify an display with a frame.
296 nil stands for the selected frame--or, if that is not a w32 frame,
297 the first display on the list. */
298
299 static struct w32_display_info *
300 check_x_display_info (frame)
301 Lisp_Object frame;
302 {
303 if (NILP (frame))
304 {
305 if (FRAME_W32_P (selected_frame))
306 return FRAME_W32_DISPLAY_INFO (selected_frame);
307 else
308 return &one_w32_display_info;
309 }
310 else if (STRINGP (frame))
311 return x_display_info_for_name (frame);
312 else
313 {
314 FRAME_PTR f;
315
316 CHECK_LIVE_FRAME (frame, 0);
317 f = XFRAME (frame);
318 if (! FRAME_W32_P (f))
319 error ("non-w32 frame used");
320 return FRAME_W32_DISPLAY_INFO (f);
321 }
322 }
323 \f
324 /* Return the Emacs frame-object corresponding to an w32 window.
325 It could be the frame's main window or an icon window. */
326
327 /* This function can be called during GC, so use GC_xxx type test macros. */
328
329 struct frame *
330 x_window_to_frame (dpyinfo, wdesc)
331 struct w32_display_info *dpyinfo;
332 HWND wdesc;
333 {
334 Lisp_Object tail, frame;
335 struct frame *f;
336
337 for (tail = Vframe_list; GC_CONSP (tail); tail = XCONS (tail)->cdr)
338 {
339 frame = XCONS (tail)->car;
340 if (!GC_FRAMEP (frame))
341 continue;
342 f = XFRAME (frame);
343 if (f->output_data.nothing == 1
344 || FRAME_W32_DISPLAY_INFO (f) != dpyinfo)
345 continue;
346 if (FRAME_W32_WINDOW (f) == wdesc)
347 return f;
348 }
349 return 0;
350 }
351
352 \f
353
354 /* Code to deal with bitmaps. Bitmaps are referenced by their bitmap
355 id, which is just an int that this section returns. Bitmaps are
356 reference counted so they can be shared among frames.
357
358 Bitmap indices are guaranteed to be > 0, so a negative number can
359 be used to indicate no bitmap.
360
361 If you use x_create_bitmap_from_data, then you must keep track of
362 the bitmaps yourself. That is, creating a bitmap from the same
363 data more than once will not be caught. */
364
365
366 /* Functions to access the contents of a bitmap, given an id. */
367
368 int
369 x_bitmap_height (f, id)
370 FRAME_PTR f;
371 int id;
372 {
373 return FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].height;
374 }
375
376 int
377 x_bitmap_width (f, id)
378 FRAME_PTR f;
379 int id;
380 {
381 return FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].width;
382 }
383
384 int
385 x_bitmap_pixmap (f, id)
386 FRAME_PTR f;
387 int id;
388 {
389 return (int) FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].pixmap;
390 }
391
392
393 /* Allocate a new bitmap record. Returns index of new record. */
394
395 static int
396 x_allocate_bitmap_record (f)
397 FRAME_PTR f;
398 {
399 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
400 int i;
401
402 if (dpyinfo->bitmaps == NULL)
403 {
404 dpyinfo->bitmaps_size = 10;
405 dpyinfo->bitmaps
406 = (struct w32_bitmap_record *) xmalloc (dpyinfo->bitmaps_size * sizeof (struct w32_bitmap_record));
407 dpyinfo->bitmaps_last = 1;
408 return 1;
409 }
410
411 if (dpyinfo->bitmaps_last < dpyinfo->bitmaps_size)
412 return ++dpyinfo->bitmaps_last;
413
414 for (i = 0; i < dpyinfo->bitmaps_size; ++i)
415 if (dpyinfo->bitmaps[i].refcount == 0)
416 return i + 1;
417
418 dpyinfo->bitmaps_size *= 2;
419 dpyinfo->bitmaps
420 = (struct w32_bitmap_record *) xrealloc (dpyinfo->bitmaps,
421 dpyinfo->bitmaps_size * sizeof (struct w32_bitmap_record));
422 return ++dpyinfo->bitmaps_last;
423 }
424
425 /* Add one reference to the reference count of the bitmap with id ID. */
426
427 void
428 x_reference_bitmap (f, id)
429 FRAME_PTR f;
430 int id;
431 {
432 ++FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].refcount;
433 }
434
435 /* Create a bitmap for frame F from a HEIGHT x WIDTH array of bits at BITS. */
436
437 int
438 x_create_bitmap_from_data (f, bits, width, height)
439 struct frame *f;
440 char *bits;
441 unsigned int width, height;
442 {
443 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
444 Pixmap bitmap;
445 int id;
446
447 bitmap = CreateBitmap (width, height,
448 FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_planes,
449 FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_cbits,
450 bits);
451
452 if (! bitmap)
453 return -1;
454
455 id = x_allocate_bitmap_record (f);
456 dpyinfo->bitmaps[id - 1].pixmap = bitmap;
457 dpyinfo->bitmaps[id - 1].file = NULL;
458 dpyinfo->bitmaps[id - 1].hinst = NULL;
459 dpyinfo->bitmaps[id - 1].refcount = 1;
460 dpyinfo->bitmaps[id - 1].depth = 1;
461 dpyinfo->bitmaps[id - 1].height = height;
462 dpyinfo->bitmaps[id - 1].width = width;
463
464 return id;
465 }
466
467 /* Create bitmap from file FILE for frame F. */
468
469 int
470 x_create_bitmap_from_file (f, file)
471 struct frame *f;
472 Lisp_Object file;
473 {
474 return -1;
475 #if 0
476 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
477 unsigned int width, height;
478 Pixmap bitmap;
479 int xhot, yhot, result, id;
480 Lisp_Object found;
481 int fd;
482 char *filename;
483 HINSTANCE hinst;
484
485 /* Look for an existing bitmap with the same name. */
486 for (id = 0; id < dpyinfo->bitmaps_last; ++id)
487 {
488 if (dpyinfo->bitmaps[id].refcount
489 && dpyinfo->bitmaps[id].file
490 && !strcmp (dpyinfo->bitmaps[id].file, (char *) XSTRING (file)->data))
491 {
492 ++dpyinfo->bitmaps[id].refcount;
493 return id + 1;
494 }
495 }
496
497 /* Search bitmap-file-path for the file, if appropriate. */
498 fd = openp (Vx_bitmap_file_path, file, "", &found, 0);
499 if (fd < 0)
500 return -1;
501 /* LoadLibraryEx won't handle special files handled by Emacs handler. */
502 if (fd == 0)
503 return -1;
504 close (fd);
505
506 filename = (char *) XSTRING (found)->data;
507
508 hinst = LoadLibraryEx (filename, NULL, LOAD_LIBRARY_AS_DATAFILE);
509
510 if (hinst == NULL)
511 return -1;
512
513
514 result = XReadBitmapFile (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
515 filename, &width, &height, &bitmap, &xhot, &yhot);
516 if (result != BitmapSuccess)
517 return -1;
518
519 id = x_allocate_bitmap_record (f);
520 dpyinfo->bitmaps[id - 1].pixmap = bitmap;
521 dpyinfo->bitmaps[id - 1].refcount = 1;
522 dpyinfo->bitmaps[id - 1].file = (char *) xmalloc (XSTRING (file)->size + 1);
523 dpyinfo->bitmaps[id - 1].depth = 1;
524 dpyinfo->bitmaps[id - 1].height = height;
525 dpyinfo->bitmaps[id - 1].width = width;
526 strcpy (dpyinfo->bitmaps[id - 1].file, XSTRING (file)->data);
527
528 return id;
529 #endif
530 }
531
532 /* Remove reference to bitmap with id number ID. */
533
534 void
535 x_destroy_bitmap (f, id)
536 FRAME_PTR f;
537 int id;
538 {
539 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
540
541 if (id > 0)
542 {
543 --dpyinfo->bitmaps[id - 1].refcount;
544 if (dpyinfo->bitmaps[id - 1].refcount == 0)
545 {
546 BLOCK_INPUT;
547 DeleteObject (dpyinfo->bitmaps[id - 1].pixmap);
548 if (dpyinfo->bitmaps[id - 1].file)
549 {
550 free (dpyinfo->bitmaps[id - 1].file);
551 dpyinfo->bitmaps[id - 1].file = NULL;
552 }
553 UNBLOCK_INPUT;
554 }
555 }
556 }
557
558 /* Free all the bitmaps for the display specified by DPYINFO. */
559
560 static void
561 x_destroy_all_bitmaps (dpyinfo)
562 struct w32_display_info *dpyinfo;
563 {
564 int i;
565 for (i = 0; i < dpyinfo->bitmaps_last; i++)
566 if (dpyinfo->bitmaps[i].refcount > 0)
567 {
568 DeleteObject (dpyinfo->bitmaps[i].pixmap);
569 if (dpyinfo->bitmaps[i].file)
570 free (dpyinfo->bitmaps[i].file);
571 }
572 dpyinfo->bitmaps_last = 0;
573 }
574 \f
575 /* Connect the frame-parameter names for W32 frames
576 to the ways of passing the parameter values to the window system.
577
578 The name of a parameter, as a Lisp symbol,
579 has an `x-frame-parameter' property which is an integer in Lisp
580 but can be interpreted as an `enum x_frame_parm' in C. */
581
582 enum x_frame_parm
583 {
584 X_PARM_FOREGROUND_COLOR,
585 X_PARM_BACKGROUND_COLOR,
586 X_PARM_MOUSE_COLOR,
587 X_PARM_CURSOR_COLOR,
588 X_PARM_BORDER_COLOR,
589 X_PARM_ICON_TYPE,
590 X_PARM_FONT,
591 X_PARM_BORDER_WIDTH,
592 X_PARM_INTERNAL_BORDER_WIDTH,
593 X_PARM_NAME,
594 X_PARM_AUTORAISE,
595 X_PARM_AUTOLOWER,
596 X_PARM_VERT_SCROLL_BAR,
597 X_PARM_VISIBILITY,
598 X_PARM_MENU_BAR_LINES
599 };
600
601
602 struct x_frame_parm_table
603 {
604 char *name;
605 void (*setter)( /* struct frame *frame, Lisp_Object val, oldval */ );
606 };
607
608 void x_set_foreground_color ();
609 void x_set_background_color ();
610 void x_set_mouse_color ();
611 void x_set_cursor_color ();
612 void x_set_border_color ();
613 void x_set_cursor_type ();
614 void x_set_icon_type ();
615 void x_set_icon_name ();
616 void x_set_font ();
617 void x_set_border_width ();
618 void x_set_internal_border_width ();
619 void x_explicitly_set_name ();
620 void x_set_autoraise ();
621 void x_set_autolower ();
622 void x_set_vertical_scroll_bars ();
623 void x_set_visibility ();
624 void x_set_menu_bar_lines ();
625 void x_set_scroll_bar_width ();
626 void x_set_title ();
627 void x_set_unsplittable ();
628
629 static struct x_frame_parm_table x_frame_parms[] =
630 {
631 "auto-raise", x_set_autoraise,
632 "auto-lower", x_set_autolower,
633 "background-color", x_set_background_color,
634 "border-color", x_set_border_color,
635 "border-width", x_set_border_width,
636 "cursor-color", x_set_cursor_color,
637 "cursor-type", x_set_cursor_type,
638 "font", x_set_font,
639 "foreground-color", x_set_foreground_color,
640 "icon-name", x_set_icon_name,
641 "icon-type", x_set_icon_type,
642 "internal-border-width", x_set_internal_border_width,
643 "menu-bar-lines", x_set_menu_bar_lines,
644 "mouse-color", x_set_mouse_color,
645 "name", x_explicitly_set_name,
646 "scroll-bar-width", x_set_scroll_bar_width,
647 "title", x_set_title,
648 "unsplittable", x_set_unsplittable,
649 "vertical-scroll-bars", x_set_vertical_scroll_bars,
650 "visibility", x_set_visibility,
651 };
652
653 /* Attach the `x-frame-parameter' properties to
654 the Lisp symbol names of parameters relevant to W32. */
655
656 init_x_parm_symbols ()
657 {
658 int i;
659
660 for (i = 0; i < sizeof (x_frame_parms) / sizeof (x_frame_parms[0]); i++)
661 Fput (intern (x_frame_parms[i].name), Qx_frame_parameter,
662 make_number (i));
663 }
664 \f
665 /* Change the parameters of FRAME as specified by ALIST.
666 If a parameter is not specially recognized, do nothing;
667 otherwise call the `x_set_...' function for that parameter. */
668
669 void
670 x_set_frame_parameters (f, alist)
671 FRAME_PTR f;
672 Lisp_Object alist;
673 {
674 Lisp_Object tail;
675
676 /* If both of these parameters are present, it's more efficient to
677 set them both at once. So we wait until we've looked at the
678 entire list before we set them. */
679 int width, height;
680
681 /* Same here. */
682 Lisp_Object left, top;
683
684 /* Same with these. */
685 Lisp_Object icon_left, icon_top;
686
687 /* Record in these vectors all the parms specified. */
688 Lisp_Object *parms;
689 Lisp_Object *values;
690 int i;
691 int left_no_change = 0, top_no_change = 0;
692 int icon_left_no_change = 0, icon_top_no_change = 0;
693
694 struct gcpro gcpro1, gcpro2;
695
696 i = 0;
697 for (tail = alist; CONSP (tail); tail = Fcdr (tail))
698 i++;
699
700 parms = (Lisp_Object *) alloca (i * sizeof (Lisp_Object));
701 values = (Lisp_Object *) alloca (i * sizeof (Lisp_Object));
702
703 /* Extract parm names and values into those vectors. */
704
705 i = 0;
706 for (tail = alist; CONSP (tail); tail = Fcdr (tail))
707 {
708 Lisp_Object elt, prop, val;
709
710 elt = Fcar (tail);
711 parms[i] = Fcar (elt);
712 values[i] = Fcdr (elt);
713 i++;
714 }
715
716 /* TAIL and ALIST are not used again below here. */
717 alist = tail = Qnil;
718
719 GCPRO2 (*parms, *values);
720 gcpro1.nvars = i;
721 gcpro2.nvars = i;
722
723 /* There is no need to gcpro LEFT, TOP, ICON_LEFT, or ICON_TOP,
724 because their values appear in VALUES and strings are not valid. */
725 top = left = Qunbound;
726 icon_left = icon_top = Qunbound;
727
728 /* Provide default values for HEIGHT and WIDTH. */
729 width = FRAME_WIDTH (f);
730 height = FRAME_HEIGHT (f);
731
732 /* Now process them in reverse of specified order. */
733 for (i--; i >= 0; i--)
734 {
735 Lisp_Object prop, val;
736
737 prop = parms[i];
738 val = values[i];
739
740 if (EQ (prop, Qwidth) && NUMBERP (val))
741 width = XFASTINT (val);
742 else if (EQ (prop, Qheight) && NUMBERP (val))
743 height = XFASTINT (val);
744 else if (EQ (prop, Qtop))
745 top = val;
746 else if (EQ (prop, Qleft))
747 left = val;
748 else if (EQ (prop, Qicon_top))
749 icon_top = val;
750 else if (EQ (prop, Qicon_left))
751 icon_left = val;
752 else
753 {
754 register Lisp_Object param_index, old_value;
755
756 param_index = Fget (prop, Qx_frame_parameter);
757 old_value = get_frame_param (f, prop);
758 store_frame_param (f, prop, val);
759 if (NATNUMP (param_index)
760 && (XFASTINT (param_index)
761 < sizeof (x_frame_parms)/sizeof (x_frame_parms[0])))
762 (*x_frame_parms[XINT (param_index)].setter)(f, val, old_value);
763 }
764 }
765
766 /* Don't die if just one of these was set. */
767 if (EQ (left, Qunbound))
768 {
769 left_no_change = 1;
770 if (f->output_data.w32->left_pos < 0)
771 left = Fcons (Qplus, Fcons (make_number (f->output_data.w32->left_pos), Qnil));
772 else
773 XSETINT (left, f->output_data.w32->left_pos);
774 }
775 if (EQ (top, Qunbound))
776 {
777 top_no_change = 1;
778 if (f->output_data.w32->top_pos < 0)
779 top = Fcons (Qplus, Fcons (make_number (f->output_data.w32->top_pos), Qnil));
780 else
781 XSETINT (top, f->output_data.w32->top_pos);
782 }
783
784 /* If one of the icon positions was not set, preserve or default it. */
785 if (EQ (icon_left, Qunbound) || ! INTEGERP (icon_left))
786 {
787 icon_left_no_change = 1;
788 icon_left = Fcdr (Fassq (Qicon_left, f->param_alist));
789 if (NILP (icon_left))
790 XSETINT (icon_left, 0);
791 }
792 if (EQ (icon_top, Qunbound) || ! INTEGERP (icon_top))
793 {
794 icon_top_no_change = 1;
795 icon_top = Fcdr (Fassq (Qicon_top, f->param_alist));
796 if (NILP (icon_top))
797 XSETINT (icon_top, 0);
798 }
799
800 /* Don't set these parameters unless they've been explicitly
801 specified. The window might be mapped or resized while we're in
802 this function, and we don't want to override that unless the lisp
803 code has asked for it.
804
805 Don't set these parameters unless they actually differ from the
806 window's current parameters; the window may not actually exist
807 yet. */
808 {
809 Lisp_Object frame;
810
811 check_frame_size (f, &height, &width);
812
813 XSETFRAME (frame, f);
814
815 if (XINT (width) != FRAME_WIDTH (f)
816 || XINT (height) != FRAME_HEIGHT (f))
817 Fset_frame_size (frame, make_number (width), make_number (height));
818
819 if ((!NILP (left) || !NILP (top))
820 && ! (left_no_change && top_no_change)
821 && ! (NUMBERP (left) && XINT (left) == f->output_data.w32->left_pos
822 && NUMBERP (top) && XINT (top) == f->output_data.w32->top_pos))
823 {
824 int leftpos = 0;
825 int toppos = 0;
826
827 /* Record the signs. */
828 f->output_data.w32->size_hint_flags &= ~ (XNegative | YNegative);
829 if (EQ (left, Qminus))
830 f->output_data.w32->size_hint_flags |= XNegative;
831 else if (INTEGERP (left))
832 {
833 leftpos = XINT (left);
834 if (leftpos < 0)
835 f->output_data.w32->size_hint_flags |= XNegative;
836 }
837 else if (CONSP (left) && EQ (XCONS (left)->car, Qminus)
838 && CONSP (XCONS (left)->cdr)
839 && INTEGERP (XCONS (XCONS (left)->cdr)->car))
840 {
841 leftpos = - XINT (XCONS (XCONS (left)->cdr)->car);
842 f->output_data.w32->size_hint_flags |= XNegative;
843 }
844 else if (CONSP (left) && EQ (XCONS (left)->car, Qplus)
845 && CONSP (XCONS (left)->cdr)
846 && INTEGERP (XCONS (XCONS (left)->cdr)->car))
847 {
848 leftpos = XINT (XCONS (XCONS (left)->cdr)->car);
849 }
850
851 if (EQ (top, Qminus))
852 f->output_data.w32->size_hint_flags |= YNegative;
853 else if (INTEGERP (top))
854 {
855 toppos = XINT (top);
856 if (toppos < 0)
857 f->output_data.w32->size_hint_flags |= YNegative;
858 }
859 else if (CONSP (top) && EQ (XCONS (top)->car, Qminus)
860 && CONSP (XCONS (top)->cdr)
861 && INTEGERP (XCONS (XCONS (top)->cdr)->car))
862 {
863 toppos = - XINT (XCONS (XCONS (top)->cdr)->car);
864 f->output_data.w32->size_hint_flags |= YNegative;
865 }
866 else if (CONSP (top) && EQ (XCONS (top)->car, Qplus)
867 && CONSP (XCONS (top)->cdr)
868 && INTEGERP (XCONS (XCONS (top)->cdr)->car))
869 {
870 toppos = XINT (XCONS (XCONS (top)->cdr)->car);
871 }
872
873
874 /* Store the numeric value of the position. */
875 f->output_data.w32->top_pos = toppos;
876 f->output_data.w32->left_pos = leftpos;
877
878 f->output_data.w32->win_gravity = NorthWestGravity;
879
880 /* Actually set that position, and convert to absolute. */
881 x_set_offset (f, leftpos, toppos, -1);
882 }
883
884 if ((!NILP (icon_left) || !NILP (icon_top))
885 && ! (icon_left_no_change && icon_top_no_change))
886 x_wm_set_icon_position (f, XINT (icon_left), XINT (icon_top));
887 }
888
889 UNGCPRO;
890 }
891
892 /* Store the screen positions of frame F into XPTR and YPTR.
893 These are the positions of the containing window manager window,
894 not Emacs's own window. */
895
896 void
897 x_real_positions (f, xptr, yptr)
898 FRAME_PTR f;
899 int *xptr, *yptr;
900 {
901 POINT pt;
902
903 {
904 RECT rect;
905
906 GetClientRect(FRAME_W32_WINDOW(f), &rect);
907 AdjustWindowRect(&rect, f->output_data.w32->dwStyle, FRAME_EXTERNAL_MENU_BAR(f));
908
909 pt.x = rect.left;
910 pt.y = rect.top;
911 }
912
913 ClientToScreen (FRAME_W32_WINDOW(f), &pt);
914
915 *xptr = pt.x;
916 *yptr = pt.y;
917 }
918
919 /* Insert a description of internally-recorded parameters of frame X
920 into the parameter alist *ALISTPTR that is to be given to the user.
921 Only parameters that are specific to W32
922 and whose values are not correctly recorded in the frame's
923 param_alist need to be considered here. */
924
925 x_report_frame_params (f, alistptr)
926 struct frame *f;
927 Lisp_Object *alistptr;
928 {
929 char buf[16];
930 Lisp_Object tem;
931
932 /* Represent negative positions (off the top or left screen edge)
933 in a way that Fmodify_frame_parameters will understand correctly. */
934 XSETINT (tem, f->output_data.w32->left_pos);
935 if (f->output_data.w32->left_pos >= 0)
936 store_in_alist (alistptr, Qleft, tem);
937 else
938 store_in_alist (alistptr, Qleft, Fcons (Qplus, Fcons (tem, Qnil)));
939
940 XSETINT (tem, f->output_data.w32->top_pos);
941 if (f->output_data.w32->top_pos >= 0)
942 store_in_alist (alistptr, Qtop, tem);
943 else
944 store_in_alist (alistptr, Qtop, Fcons (Qplus, Fcons (tem, Qnil)));
945
946 store_in_alist (alistptr, Qborder_width,
947 make_number (f->output_data.w32->border_width));
948 store_in_alist (alistptr, Qinternal_border_width,
949 make_number (f->output_data.w32->internal_border_width));
950 sprintf (buf, "%ld", (long) FRAME_W32_WINDOW (f));
951 store_in_alist (alistptr, Qwindow_id,
952 build_string (buf));
953 store_in_alist (alistptr, Qicon_name, f->icon_name);
954 FRAME_SAMPLE_VISIBILITY (f);
955 store_in_alist (alistptr, Qvisibility,
956 (FRAME_VISIBLE_P (f) ? Qt
957 : FRAME_ICONIFIED_P (f) ? Qicon : Qnil));
958 store_in_alist (alistptr, Qdisplay,
959 XCONS (FRAME_W32_DISPLAY_INFO (f)->name_list_element)->car);
960 }
961 \f
962
963 DEFUN ("w32-define-rgb-color", Fw32_define_rgb_color, Sw32_define_rgb_color, 4, 4, 0,
964 "Convert RGB numbers to a windows color reference and associate with NAME (a string).\n\
965 This adds or updates a named color to w32-color-map, making it available for use.\n\
966 The original entry's RGB ref is returned, or nil if the entry is new.")
967 (red, green, blue, name)
968 Lisp_Object red, green, blue, name;
969 {
970 Lisp_Object rgb;
971 Lisp_Object oldrgb = Qnil;
972 Lisp_Object entry;
973
974 CHECK_NUMBER (red, 0);
975 CHECK_NUMBER (green, 0);
976 CHECK_NUMBER (blue, 0);
977 CHECK_STRING (name, 0);
978
979 XSET (rgb, Lisp_Int, RGB(XUINT (red), XUINT (green), XUINT (blue)));
980
981 BLOCK_INPUT;
982
983 /* replace existing entry in w32-color-map or add new entry. */
984 entry = Fassoc (name, Vw32_color_map);
985 if (NILP (entry))
986 {
987 entry = Fcons (name, rgb);
988 Vw32_color_map = Fcons (entry, Vw32_color_map);
989 }
990 else
991 {
992 oldrgb = Fcdr (entry);
993 Fsetcdr (entry, rgb);
994 }
995
996 UNBLOCK_INPUT;
997
998 return (oldrgb);
999 }
1000
1001 DEFUN ("w32-load-color-file", Fw32_load_color_file, Sw32_load_color_file, 1, 1, 0,
1002 "Create an alist of color entries from an external file (ie. rgb.txt).\n\
1003 Assign this value to w32-color-map to replace the existing color map.\n\
1004 \
1005 The file should define one named RGB color per line like so:\
1006 R G B name\n\
1007 where R,G,B are numbers between 0 and 255 and name is an arbitrary string.")
1008 (filename)
1009 Lisp_Object filename;
1010 {
1011 FILE *fp;
1012 Lisp_Object cmap = Qnil;
1013 Lisp_Object abspath;
1014
1015 CHECK_STRING (filename, 0);
1016 abspath = Fexpand_file_name (filename, Qnil);
1017
1018 fp = fopen (XSTRING (filename)->data, "rt");
1019 if (fp)
1020 {
1021 char buf[512];
1022 int red, green, blue;
1023 int num;
1024
1025 BLOCK_INPUT;
1026
1027 while (fgets (buf, sizeof (buf), fp) != NULL) {
1028 if (sscanf (buf, "%u %u %u %n", &red, &green, &blue, &num) == 3)
1029 {
1030 char *name = buf + num;
1031 num = strlen (name) - 1;
1032 if (name[num] == '\n')
1033 name[num] = 0;
1034 cmap = Fcons (Fcons (build_string (name),
1035 make_number (RGB (red, green, blue))),
1036 cmap);
1037 }
1038 }
1039 fclose (fp);
1040
1041 UNBLOCK_INPUT;
1042 }
1043
1044 return cmap;
1045 }
1046
1047 /* The default colors for the w32 color map */
1048 typedef struct colormap_t
1049 {
1050 char *name;
1051 COLORREF colorref;
1052 } colormap_t;
1053
1054 colormap_t w32_color_map[] =
1055 {
1056 {"snow" , PALETTERGB (255,250,250)},
1057 {"ghost white" , PALETTERGB (248,248,255)},
1058 {"GhostWhite" , PALETTERGB (248,248,255)},
1059 {"white smoke" , PALETTERGB (245,245,245)},
1060 {"WhiteSmoke" , PALETTERGB (245,245,245)},
1061 {"gainsboro" , PALETTERGB (220,220,220)},
1062 {"floral white" , PALETTERGB (255,250,240)},
1063 {"FloralWhite" , PALETTERGB (255,250,240)},
1064 {"old lace" , PALETTERGB (253,245,230)},
1065 {"OldLace" , PALETTERGB (253,245,230)},
1066 {"linen" , PALETTERGB (250,240,230)},
1067 {"antique white" , PALETTERGB (250,235,215)},
1068 {"AntiqueWhite" , PALETTERGB (250,235,215)},
1069 {"papaya whip" , PALETTERGB (255,239,213)},
1070 {"PapayaWhip" , PALETTERGB (255,239,213)},
1071 {"blanched almond" , PALETTERGB (255,235,205)},
1072 {"BlanchedAlmond" , PALETTERGB (255,235,205)},
1073 {"bisque" , PALETTERGB (255,228,196)},
1074 {"peach puff" , PALETTERGB (255,218,185)},
1075 {"PeachPuff" , PALETTERGB (255,218,185)},
1076 {"navajo white" , PALETTERGB (255,222,173)},
1077 {"NavajoWhite" , PALETTERGB (255,222,173)},
1078 {"moccasin" , PALETTERGB (255,228,181)},
1079 {"cornsilk" , PALETTERGB (255,248,220)},
1080 {"ivory" , PALETTERGB (255,255,240)},
1081 {"lemon chiffon" , PALETTERGB (255,250,205)},
1082 {"LemonChiffon" , PALETTERGB (255,250,205)},
1083 {"seashell" , PALETTERGB (255,245,238)},
1084 {"honeydew" , PALETTERGB (240,255,240)},
1085 {"mint cream" , PALETTERGB (245,255,250)},
1086 {"MintCream" , PALETTERGB (245,255,250)},
1087 {"azure" , PALETTERGB (240,255,255)},
1088 {"alice blue" , PALETTERGB (240,248,255)},
1089 {"AliceBlue" , PALETTERGB (240,248,255)},
1090 {"lavender" , PALETTERGB (230,230,250)},
1091 {"lavender blush" , PALETTERGB (255,240,245)},
1092 {"LavenderBlush" , PALETTERGB (255,240,245)},
1093 {"misty rose" , PALETTERGB (255,228,225)},
1094 {"MistyRose" , PALETTERGB (255,228,225)},
1095 {"white" , PALETTERGB (255,255,255)},
1096 {"black" , PALETTERGB ( 0, 0, 0)},
1097 {"dark slate gray" , PALETTERGB ( 47, 79, 79)},
1098 {"DarkSlateGray" , PALETTERGB ( 47, 79, 79)},
1099 {"dark slate grey" , PALETTERGB ( 47, 79, 79)},
1100 {"DarkSlateGrey" , PALETTERGB ( 47, 79, 79)},
1101 {"dim gray" , PALETTERGB (105,105,105)},
1102 {"DimGray" , PALETTERGB (105,105,105)},
1103 {"dim grey" , PALETTERGB (105,105,105)},
1104 {"DimGrey" , PALETTERGB (105,105,105)},
1105 {"slate gray" , PALETTERGB (112,128,144)},
1106 {"SlateGray" , PALETTERGB (112,128,144)},
1107 {"slate grey" , PALETTERGB (112,128,144)},
1108 {"SlateGrey" , PALETTERGB (112,128,144)},
1109 {"light slate gray" , PALETTERGB (119,136,153)},
1110 {"LightSlateGray" , PALETTERGB (119,136,153)},
1111 {"light slate grey" , PALETTERGB (119,136,153)},
1112 {"LightSlateGrey" , PALETTERGB (119,136,153)},
1113 {"gray" , PALETTERGB (190,190,190)},
1114 {"grey" , PALETTERGB (190,190,190)},
1115 {"light grey" , PALETTERGB (211,211,211)},
1116 {"LightGrey" , PALETTERGB (211,211,211)},
1117 {"light gray" , PALETTERGB (211,211,211)},
1118 {"LightGray" , PALETTERGB (211,211,211)},
1119 {"midnight blue" , PALETTERGB ( 25, 25,112)},
1120 {"MidnightBlue" , PALETTERGB ( 25, 25,112)},
1121 {"navy" , PALETTERGB ( 0, 0,128)},
1122 {"navy blue" , PALETTERGB ( 0, 0,128)},
1123 {"NavyBlue" , PALETTERGB ( 0, 0,128)},
1124 {"cornflower blue" , PALETTERGB (100,149,237)},
1125 {"CornflowerBlue" , PALETTERGB (100,149,237)},
1126 {"dark slate blue" , PALETTERGB ( 72, 61,139)},
1127 {"DarkSlateBlue" , PALETTERGB ( 72, 61,139)},
1128 {"slate blue" , PALETTERGB (106, 90,205)},
1129 {"SlateBlue" , PALETTERGB (106, 90,205)},
1130 {"medium slate blue" , PALETTERGB (123,104,238)},
1131 {"MediumSlateBlue" , PALETTERGB (123,104,238)},
1132 {"light slate blue" , PALETTERGB (132,112,255)},
1133 {"LightSlateBlue" , PALETTERGB (132,112,255)},
1134 {"medium blue" , PALETTERGB ( 0, 0,205)},
1135 {"MediumBlue" , PALETTERGB ( 0, 0,205)},
1136 {"royal blue" , PALETTERGB ( 65,105,225)},
1137 {"RoyalBlue" , PALETTERGB ( 65,105,225)},
1138 {"blue" , PALETTERGB ( 0, 0,255)},
1139 {"dodger blue" , PALETTERGB ( 30,144,255)},
1140 {"DodgerBlue" , PALETTERGB ( 30,144,255)},
1141 {"deep sky blue" , PALETTERGB ( 0,191,255)},
1142 {"DeepSkyBlue" , PALETTERGB ( 0,191,255)},
1143 {"sky blue" , PALETTERGB (135,206,235)},
1144 {"SkyBlue" , PALETTERGB (135,206,235)},
1145 {"light sky blue" , PALETTERGB (135,206,250)},
1146 {"LightSkyBlue" , PALETTERGB (135,206,250)},
1147 {"steel blue" , PALETTERGB ( 70,130,180)},
1148 {"SteelBlue" , PALETTERGB ( 70,130,180)},
1149 {"light steel blue" , PALETTERGB (176,196,222)},
1150 {"LightSteelBlue" , PALETTERGB (176,196,222)},
1151 {"light blue" , PALETTERGB (173,216,230)},
1152 {"LightBlue" , PALETTERGB (173,216,230)},
1153 {"powder blue" , PALETTERGB (176,224,230)},
1154 {"PowderBlue" , PALETTERGB (176,224,230)},
1155 {"pale turquoise" , PALETTERGB (175,238,238)},
1156 {"PaleTurquoise" , PALETTERGB (175,238,238)},
1157 {"dark turquoise" , PALETTERGB ( 0,206,209)},
1158 {"DarkTurquoise" , PALETTERGB ( 0,206,209)},
1159 {"medium turquoise" , PALETTERGB ( 72,209,204)},
1160 {"MediumTurquoise" , PALETTERGB ( 72,209,204)},
1161 {"turquoise" , PALETTERGB ( 64,224,208)},
1162 {"cyan" , PALETTERGB ( 0,255,255)},
1163 {"light cyan" , PALETTERGB (224,255,255)},
1164 {"LightCyan" , PALETTERGB (224,255,255)},
1165 {"cadet blue" , PALETTERGB ( 95,158,160)},
1166 {"CadetBlue" , PALETTERGB ( 95,158,160)},
1167 {"medium aquamarine" , PALETTERGB (102,205,170)},
1168 {"MediumAquamarine" , PALETTERGB (102,205,170)},
1169 {"aquamarine" , PALETTERGB (127,255,212)},
1170 {"dark green" , PALETTERGB ( 0,100, 0)},
1171 {"DarkGreen" , PALETTERGB ( 0,100, 0)},
1172 {"dark olive green" , PALETTERGB ( 85,107, 47)},
1173 {"DarkOliveGreen" , PALETTERGB ( 85,107, 47)},
1174 {"dark sea green" , PALETTERGB (143,188,143)},
1175 {"DarkSeaGreen" , PALETTERGB (143,188,143)},
1176 {"sea green" , PALETTERGB ( 46,139, 87)},
1177 {"SeaGreen" , PALETTERGB ( 46,139, 87)},
1178 {"medium sea green" , PALETTERGB ( 60,179,113)},
1179 {"MediumSeaGreen" , PALETTERGB ( 60,179,113)},
1180 {"light sea green" , PALETTERGB ( 32,178,170)},
1181 {"LightSeaGreen" , PALETTERGB ( 32,178,170)},
1182 {"pale green" , PALETTERGB (152,251,152)},
1183 {"PaleGreen" , PALETTERGB (152,251,152)},
1184 {"spring green" , PALETTERGB ( 0,255,127)},
1185 {"SpringGreen" , PALETTERGB ( 0,255,127)},
1186 {"lawn green" , PALETTERGB (124,252, 0)},
1187 {"LawnGreen" , PALETTERGB (124,252, 0)},
1188 {"green" , PALETTERGB ( 0,255, 0)},
1189 {"chartreuse" , PALETTERGB (127,255, 0)},
1190 {"medium spring green" , PALETTERGB ( 0,250,154)},
1191 {"MediumSpringGreen" , PALETTERGB ( 0,250,154)},
1192 {"green yellow" , PALETTERGB (173,255, 47)},
1193 {"GreenYellow" , PALETTERGB (173,255, 47)},
1194 {"lime green" , PALETTERGB ( 50,205, 50)},
1195 {"LimeGreen" , PALETTERGB ( 50,205, 50)},
1196 {"yellow green" , PALETTERGB (154,205, 50)},
1197 {"YellowGreen" , PALETTERGB (154,205, 50)},
1198 {"forest green" , PALETTERGB ( 34,139, 34)},
1199 {"ForestGreen" , PALETTERGB ( 34,139, 34)},
1200 {"olive drab" , PALETTERGB (107,142, 35)},
1201 {"OliveDrab" , PALETTERGB (107,142, 35)},
1202 {"dark khaki" , PALETTERGB (189,183,107)},
1203 {"DarkKhaki" , PALETTERGB (189,183,107)},
1204 {"khaki" , PALETTERGB (240,230,140)},
1205 {"pale goldenrod" , PALETTERGB (238,232,170)},
1206 {"PaleGoldenrod" , PALETTERGB (238,232,170)},
1207 {"light goldenrod yellow" , PALETTERGB (250,250,210)},
1208 {"LightGoldenrodYellow" , PALETTERGB (250,250,210)},
1209 {"light yellow" , PALETTERGB (255,255,224)},
1210 {"LightYellow" , PALETTERGB (255,255,224)},
1211 {"yellow" , PALETTERGB (255,255, 0)},
1212 {"gold" , PALETTERGB (255,215, 0)},
1213 {"light goldenrod" , PALETTERGB (238,221,130)},
1214 {"LightGoldenrod" , PALETTERGB (238,221,130)},
1215 {"goldenrod" , PALETTERGB (218,165, 32)},
1216 {"dark goldenrod" , PALETTERGB (184,134, 11)},
1217 {"DarkGoldenrod" , PALETTERGB (184,134, 11)},
1218 {"rosy brown" , PALETTERGB (188,143,143)},
1219 {"RosyBrown" , PALETTERGB (188,143,143)},
1220 {"indian red" , PALETTERGB (205, 92, 92)},
1221 {"IndianRed" , PALETTERGB (205, 92, 92)},
1222 {"saddle brown" , PALETTERGB (139, 69, 19)},
1223 {"SaddleBrown" , PALETTERGB (139, 69, 19)},
1224 {"sienna" , PALETTERGB (160, 82, 45)},
1225 {"peru" , PALETTERGB (205,133, 63)},
1226 {"burlywood" , PALETTERGB (222,184,135)},
1227 {"beige" , PALETTERGB (245,245,220)},
1228 {"wheat" , PALETTERGB (245,222,179)},
1229 {"sandy brown" , PALETTERGB (244,164, 96)},
1230 {"SandyBrown" , PALETTERGB (244,164, 96)},
1231 {"tan" , PALETTERGB (210,180,140)},
1232 {"chocolate" , PALETTERGB (210,105, 30)},
1233 {"firebrick" , PALETTERGB (178,34, 34)},
1234 {"brown" , PALETTERGB (165,42, 42)},
1235 {"dark salmon" , PALETTERGB (233,150,122)},
1236 {"DarkSalmon" , PALETTERGB (233,150,122)},
1237 {"salmon" , PALETTERGB (250,128,114)},
1238 {"light salmon" , PALETTERGB (255,160,122)},
1239 {"LightSalmon" , PALETTERGB (255,160,122)},
1240 {"orange" , PALETTERGB (255,165, 0)},
1241 {"dark orange" , PALETTERGB (255,140, 0)},
1242 {"DarkOrange" , PALETTERGB (255,140, 0)},
1243 {"coral" , PALETTERGB (255,127, 80)},
1244 {"light coral" , PALETTERGB (240,128,128)},
1245 {"LightCoral" , PALETTERGB (240,128,128)},
1246 {"tomato" , PALETTERGB (255, 99, 71)},
1247 {"orange red" , PALETTERGB (255, 69, 0)},
1248 {"OrangeRed" , PALETTERGB (255, 69, 0)},
1249 {"red" , PALETTERGB (255, 0, 0)},
1250 {"hot pink" , PALETTERGB (255,105,180)},
1251 {"HotPink" , PALETTERGB (255,105,180)},
1252 {"deep pink" , PALETTERGB (255, 20,147)},
1253 {"DeepPink" , PALETTERGB (255, 20,147)},
1254 {"pink" , PALETTERGB (255,192,203)},
1255 {"light pink" , PALETTERGB (255,182,193)},
1256 {"LightPink" , PALETTERGB (255,182,193)},
1257 {"pale violet red" , PALETTERGB (219,112,147)},
1258 {"PaleVioletRed" , PALETTERGB (219,112,147)},
1259 {"maroon" , PALETTERGB (176, 48, 96)},
1260 {"medium violet red" , PALETTERGB (199, 21,133)},
1261 {"MediumVioletRed" , PALETTERGB (199, 21,133)},
1262 {"violet red" , PALETTERGB (208, 32,144)},
1263 {"VioletRed" , PALETTERGB (208, 32,144)},
1264 {"magenta" , PALETTERGB (255, 0,255)},
1265 {"violet" , PALETTERGB (238,130,238)},
1266 {"plum" , PALETTERGB (221,160,221)},
1267 {"orchid" , PALETTERGB (218,112,214)},
1268 {"medium orchid" , PALETTERGB (186, 85,211)},
1269 {"MediumOrchid" , PALETTERGB (186, 85,211)},
1270 {"dark orchid" , PALETTERGB (153, 50,204)},
1271 {"DarkOrchid" , PALETTERGB (153, 50,204)},
1272 {"dark violet" , PALETTERGB (148, 0,211)},
1273 {"DarkViolet" , PALETTERGB (148, 0,211)},
1274 {"blue violet" , PALETTERGB (138, 43,226)},
1275 {"BlueViolet" , PALETTERGB (138, 43,226)},
1276 {"purple" , PALETTERGB (160, 32,240)},
1277 {"medium purple" , PALETTERGB (147,112,219)},
1278 {"MediumPurple" , PALETTERGB (147,112,219)},
1279 {"thistle" , PALETTERGB (216,191,216)},
1280 {"gray0" , PALETTERGB ( 0, 0, 0)},
1281 {"grey0" , PALETTERGB ( 0, 0, 0)},
1282 {"dark grey" , PALETTERGB (169,169,169)},
1283 {"DarkGrey" , PALETTERGB (169,169,169)},
1284 {"dark gray" , PALETTERGB (169,169,169)},
1285 {"DarkGray" , PALETTERGB (169,169,169)},
1286 {"dark blue" , PALETTERGB ( 0, 0,139)},
1287 {"DarkBlue" , PALETTERGB ( 0, 0,139)},
1288 {"dark cyan" , PALETTERGB ( 0,139,139)},
1289 {"DarkCyan" , PALETTERGB ( 0,139,139)},
1290 {"dark magenta" , PALETTERGB (139, 0,139)},
1291 {"DarkMagenta" , PALETTERGB (139, 0,139)},
1292 {"dark red" , PALETTERGB (139, 0, 0)},
1293 {"DarkRed" , PALETTERGB (139, 0, 0)},
1294 {"light green" , PALETTERGB (144,238,144)},
1295 {"LightGreen" , PALETTERGB (144,238,144)},
1296 };
1297
1298 DEFUN ("w32-default-color-map", Fw32_default_color_map, Sw32_default_color_map,
1299 0, 0, 0, "Return the default color map.")
1300 ()
1301 {
1302 int i;
1303 colormap_t *pc = w32_color_map;
1304 Lisp_Object cmap;
1305
1306 BLOCK_INPUT;
1307
1308 cmap = Qnil;
1309
1310 for (i = 0; i < sizeof (w32_color_map) / sizeof (w32_color_map[0]);
1311 pc++, i++)
1312 cmap = Fcons (Fcons (build_string (pc->name),
1313 make_number (pc->colorref)),
1314 cmap);
1315
1316 UNBLOCK_INPUT;
1317
1318 return (cmap);
1319 }
1320
1321 Lisp_Object
1322 w32_to_x_color (rgb)
1323 Lisp_Object rgb;
1324 {
1325 Lisp_Object color;
1326
1327 CHECK_NUMBER (rgb, 0);
1328
1329 BLOCK_INPUT;
1330
1331 color = Frassq (rgb, Vw32_color_map);
1332
1333 UNBLOCK_INPUT;
1334
1335 if (!NILP (color))
1336 return (Fcar (color));
1337 else
1338 return Qnil;
1339 }
1340
1341 COLORREF
1342 w32_color_map_lookup (colorname)
1343 char *colorname;
1344 {
1345 Lisp_Object tail, ret = Qnil;
1346
1347 BLOCK_INPUT;
1348
1349 for (tail = Vw32_color_map; !NILP (tail); tail = Fcdr (tail))
1350 {
1351 register Lisp_Object elt, tem;
1352
1353 elt = Fcar (tail);
1354 if (!CONSP (elt)) continue;
1355
1356 tem = Fcar (elt);
1357
1358 if (lstrcmpi (XSTRING (tem)->data, colorname) == 0)
1359 {
1360 ret = XUINT (Fcdr (elt));
1361 break;
1362 }
1363
1364 QUIT;
1365 }
1366
1367
1368 UNBLOCK_INPUT;
1369
1370 return ret;
1371 }
1372
1373 COLORREF
1374 x_to_w32_color (colorname)
1375 char * colorname;
1376 {
1377 register Lisp_Object tail, ret = Qnil;
1378
1379 BLOCK_INPUT;
1380
1381 if (colorname[0] == '#')
1382 {
1383 /* Could be an old-style RGB Device specification. */
1384 char *color;
1385 int size;
1386 color = colorname + 1;
1387
1388 size = strlen(color);
1389 if (size == 3 || size == 6 || size == 9 || size == 12)
1390 {
1391 UINT colorval;
1392 int i, pos;
1393 pos = 0;
1394 size /= 3;
1395 colorval = 0;
1396
1397 for (i = 0; i < 3; i++)
1398 {
1399 char *end;
1400 char t;
1401 unsigned long value;
1402
1403 /* The check for 'x' in the following conditional takes into
1404 account the fact that strtol allows a "0x" in front of
1405 our numbers, and we don't. */
1406 if (!isxdigit(color[0]) || color[1] == 'x')
1407 break;
1408 t = color[size];
1409 color[size] = '\0';
1410 value = strtoul(color, &end, 16);
1411 color[size] = t;
1412 if (errno == ERANGE || end - color != size)
1413 break;
1414 switch (size)
1415 {
1416 case 1:
1417 value = value * 0x10;
1418 break;
1419 case 2:
1420 break;
1421 case 3:
1422 value /= 0x10;
1423 break;
1424 case 4:
1425 value /= 0x100;
1426 break;
1427 }
1428 colorval |= (value << pos);
1429 pos += 0x8;
1430 if (i == 2)
1431 {
1432 UNBLOCK_INPUT;
1433 return (colorval);
1434 }
1435 color = end;
1436 }
1437 }
1438 }
1439 else if (strnicmp(colorname, "rgb:", 4) == 0)
1440 {
1441 char *color;
1442 UINT colorval;
1443 int i, pos;
1444 pos = 0;
1445
1446 colorval = 0;
1447 color = colorname + 4;
1448 for (i = 0; i < 3; i++)
1449 {
1450 char *end;
1451 unsigned long value;
1452
1453 /* The check for 'x' in the following conditional takes into
1454 account the fact that strtol allows a "0x" in front of
1455 our numbers, and we don't. */
1456 if (!isxdigit(color[0]) || color[1] == 'x')
1457 break;
1458 value = strtoul(color, &end, 16);
1459 if (errno == ERANGE)
1460 break;
1461 switch (end - color)
1462 {
1463 case 1:
1464 value = value * 0x10 + value;
1465 break;
1466 case 2:
1467 break;
1468 case 3:
1469 value /= 0x10;
1470 break;
1471 case 4:
1472 value /= 0x100;
1473 break;
1474 default:
1475 value = ULONG_MAX;
1476 }
1477 if (value == ULONG_MAX)
1478 break;
1479 colorval |= (value << pos);
1480 pos += 0x8;
1481 if (i == 2)
1482 {
1483 if (*end != '\0')
1484 break;
1485 UNBLOCK_INPUT;
1486 return (colorval);
1487 }
1488 if (*end != '/')
1489 break;
1490 color = end + 1;
1491 }
1492 }
1493 else if (strnicmp(colorname, "rgbi:", 5) == 0)
1494 {
1495 /* This is an RGB Intensity specification. */
1496 char *color;
1497 UINT colorval;
1498 int i, pos;
1499 pos = 0;
1500
1501 colorval = 0;
1502 color = colorname + 5;
1503 for (i = 0; i < 3; i++)
1504 {
1505 char *end;
1506 double value;
1507 UINT val;
1508
1509 value = strtod(color, &end);
1510 if (errno == ERANGE)
1511 break;
1512 if (value < 0.0 || value > 1.0)
1513 break;
1514 val = (UINT)(0x100 * value);
1515 /* We used 0x100 instead of 0xFF to give an continuous
1516 range between 0.0 and 1.0 inclusive. The next statement
1517 fixes the 1.0 case. */
1518 if (val == 0x100)
1519 val = 0xFF;
1520 colorval |= (val << pos);
1521 pos += 0x8;
1522 if (i == 2)
1523 {
1524 if (*end != '\0')
1525 break;
1526 UNBLOCK_INPUT;
1527 return (colorval);
1528 }
1529 if (*end != '/')
1530 break;
1531 color = end + 1;
1532 }
1533 }
1534 /* I am not going to attempt to handle any of the CIE color schemes
1535 or TekHVC, since I don't know the algorithms for conversion to
1536 RGB. */
1537
1538 /* If we fail to lookup the color name in w32_color_map, then check the
1539 colorname to see if it can be crudely approximated: If the X color
1540 ends in a number (e.g., "darkseagreen2"), strip the number and
1541 return the result of looking up the base color name. */
1542 ret = w32_color_map_lookup (colorname);
1543 if (NILP (ret))
1544 {
1545 int len = strlen (colorname);
1546
1547 if (isdigit (colorname[len - 1]))
1548 {
1549 char *ptr, *approx = alloca (len);
1550
1551 strcpy (approx, colorname);
1552 ptr = &approx[len - 1];
1553 while (ptr > approx && isdigit (*ptr))
1554 *ptr-- = '\0';
1555
1556 ret = w32_color_map_lookup (approx);
1557 }
1558 }
1559
1560 UNBLOCK_INPUT;
1561 return ret;
1562 }
1563
1564
1565 void
1566 w32_regenerate_palette (FRAME_PTR f)
1567 {
1568 struct w32_palette_entry * list;
1569 LOGPALETTE * log_palette;
1570 HPALETTE new_palette;
1571 int i;
1572
1573 /* don't bother trying to create palette if not supported */
1574 if (! FRAME_W32_DISPLAY_INFO (f)->has_palette)
1575 return;
1576
1577 log_palette = (LOGPALETTE *)
1578 alloca (sizeof (LOGPALETTE) +
1579 FRAME_W32_DISPLAY_INFO (f)->num_colors * sizeof (PALETTEENTRY));
1580 log_palette->palVersion = 0x300;
1581 log_palette->palNumEntries = FRAME_W32_DISPLAY_INFO (f)->num_colors;
1582
1583 list = FRAME_W32_DISPLAY_INFO (f)->color_list;
1584 for (i = 0;
1585 i < FRAME_W32_DISPLAY_INFO (f)->num_colors;
1586 i++, list = list->next)
1587 log_palette->palPalEntry[i] = list->entry;
1588
1589 new_palette = CreatePalette (log_palette);
1590
1591 enter_crit ();
1592
1593 if (FRAME_W32_DISPLAY_INFO (f)->palette)
1594 DeleteObject (FRAME_W32_DISPLAY_INFO (f)->palette);
1595 FRAME_W32_DISPLAY_INFO (f)->palette = new_palette;
1596
1597 /* Realize display palette and garbage all frames. */
1598 release_frame_dc (f, get_frame_dc (f));
1599
1600 leave_crit ();
1601 }
1602
1603 #define W32_COLOR(pe) RGB (pe.peRed, pe.peGreen, pe.peBlue)
1604 #define SET_W32_COLOR(pe, color) \
1605 do \
1606 { \
1607 pe.peRed = GetRValue (color); \
1608 pe.peGreen = GetGValue (color); \
1609 pe.peBlue = GetBValue (color); \
1610 pe.peFlags = 0; \
1611 } while (0)
1612
1613 #if 0
1614 /* Keep these around in case we ever want to track color usage. */
1615 void
1616 w32_map_color (FRAME_PTR f, COLORREF color)
1617 {
1618 struct w32_palette_entry * list = FRAME_W32_DISPLAY_INFO (f)->color_list;
1619
1620 if (NILP (Vw32_enable_palette))
1621 return;
1622
1623 /* check if color is already mapped */
1624 while (list)
1625 {
1626 if (W32_COLOR (list->entry) == color)
1627 {
1628 ++list->refcount;
1629 return;
1630 }
1631 list = list->next;
1632 }
1633
1634 /* not already mapped, so add to list and recreate Windows palette */
1635 list = (struct w32_palette_entry *)
1636 xmalloc (sizeof (struct w32_palette_entry));
1637 SET_W32_COLOR (list->entry, color);
1638 list->refcount = 1;
1639 list->next = FRAME_W32_DISPLAY_INFO (f)->color_list;
1640 FRAME_W32_DISPLAY_INFO (f)->color_list = list;
1641 FRAME_W32_DISPLAY_INFO (f)->num_colors++;
1642
1643 /* set flag that palette must be regenerated */
1644 FRAME_W32_DISPLAY_INFO (f)->regen_palette = TRUE;
1645 }
1646
1647 void
1648 w32_unmap_color (FRAME_PTR f, COLORREF color)
1649 {
1650 struct w32_palette_entry * list = FRAME_W32_DISPLAY_INFO (f)->color_list;
1651 struct w32_palette_entry **prev = &FRAME_W32_DISPLAY_INFO (f)->color_list;
1652
1653 if (NILP (Vw32_enable_palette))
1654 return;
1655
1656 /* check if color is already mapped */
1657 while (list)
1658 {
1659 if (W32_COLOR (list->entry) == color)
1660 {
1661 if (--list->refcount == 0)
1662 {
1663 *prev = list->next;
1664 xfree (list);
1665 FRAME_W32_DISPLAY_INFO (f)->num_colors--;
1666 break;
1667 }
1668 else
1669 return;
1670 }
1671 prev = &list->next;
1672 list = list->next;
1673 }
1674
1675 /* set flag that palette must be regenerated */
1676 FRAME_W32_DISPLAY_INFO (f)->regen_palette = TRUE;
1677 }
1678 #endif
1679
1680 /* Decide if color named COLOR is valid for the display associated with
1681 the selected frame; if so, return the rgb values in COLOR_DEF.
1682 If ALLOC is nonzero, allocate a new colormap cell. */
1683
1684 int
1685 defined_color (f, color, color_def, alloc)
1686 FRAME_PTR f;
1687 char *color;
1688 COLORREF *color_def;
1689 int alloc;
1690 {
1691 register Lisp_Object tem;
1692
1693 tem = x_to_w32_color (color);
1694
1695 if (!NILP (tem))
1696 {
1697 if (!NILP (Vw32_enable_palette))
1698 {
1699 struct w32_palette_entry * entry =
1700 FRAME_W32_DISPLAY_INFO (f)->color_list;
1701 struct w32_palette_entry ** prev =
1702 &FRAME_W32_DISPLAY_INFO (f)->color_list;
1703
1704 /* check if color is already mapped */
1705 while (entry)
1706 {
1707 if (W32_COLOR (entry->entry) == XUINT (tem))
1708 break;
1709 prev = &entry->next;
1710 entry = entry->next;
1711 }
1712
1713 if (entry == NULL && alloc)
1714 {
1715 /* not already mapped, so add to list */
1716 entry = (struct w32_palette_entry *)
1717 xmalloc (sizeof (struct w32_palette_entry));
1718 SET_W32_COLOR (entry->entry, XUINT (tem));
1719 entry->next = NULL;
1720 *prev = entry;
1721 FRAME_W32_DISPLAY_INFO (f)->num_colors++;
1722
1723 /* set flag that palette must be regenerated */
1724 FRAME_W32_DISPLAY_INFO (f)->regen_palette = TRUE;
1725 }
1726 }
1727 /* Ensure COLORREF value is snapped to nearest color in (default)
1728 palette by simulating the PALETTERGB macro. This works whether
1729 or not the display device has a palette. */
1730 *color_def = XUINT (tem) | 0x2000000;
1731 return 1;
1732 }
1733 else
1734 {
1735 return 0;
1736 }
1737 }
1738
1739 /* Given a string ARG naming a color, compute a pixel value from it
1740 suitable for screen F.
1741 If F is not a color screen, return DEF (default) regardless of what
1742 ARG says. */
1743
1744 int
1745 x_decode_color (f, arg, def)
1746 FRAME_PTR f;
1747 Lisp_Object arg;
1748 int def;
1749 {
1750 COLORREF cdef;
1751
1752 CHECK_STRING (arg, 0);
1753
1754 if (strcmp (XSTRING (arg)->data, "black") == 0)
1755 return BLACK_PIX_DEFAULT (f);
1756 else if (strcmp (XSTRING (arg)->data, "white") == 0)
1757 return WHITE_PIX_DEFAULT (f);
1758
1759 if ((FRAME_W32_DISPLAY_INFO (f)->n_planes * FRAME_W32_DISPLAY_INFO (f)->n_cbits) == 1)
1760 return def;
1761
1762 /* defined_color is responsible for coping with failures
1763 by looking for a near-miss. */
1764 if (defined_color (f, XSTRING (arg)->data, &cdef, 1))
1765 return cdef;
1766
1767 /* defined_color failed; return an ultimate default. */
1768 return def;
1769 }
1770 \f
1771 /* Functions called only from `x_set_frame_param'
1772 to set individual parameters.
1773
1774 If FRAME_W32_WINDOW (f) is 0,
1775 the frame is being created and its window does not exist yet.
1776 In that case, just record the parameter's new value
1777 in the standard place; do not attempt to change the window. */
1778
1779 void
1780 x_set_foreground_color (f, arg, oldval)
1781 struct frame *f;
1782 Lisp_Object arg, oldval;
1783 {
1784 f->output_data.w32->foreground_pixel
1785 = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
1786
1787 if (FRAME_W32_WINDOW (f) != 0)
1788 {
1789 recompute_basic_faces (f);
1790 if (FRAME_VISIBLE_P (f))
1791 redraw_frame (f);
1792 }
1793 }
1794
1795 void
1796 x_set_background_color (f, arg, oldval)
1797 struct frame *f;
1798 Lisp_Object arg, oldval;
1799 {
1800 Pixmap temp;
1801 int mask;
1802
1803 f->output_data.w32->background_pixel
1804 = x_decode_color (f, arg, WHITE_PIX_DEFAULT (f));
1805
1806 if (FRAME_W32_WINDOW (f) != 0)
1807 {
1808 SetWindowLong (FRAME_W32_WINDOW (f), WND_BACKGROUND_INDEX, f->output_data.w32->background_pixel);
1809
1810 recompute_basic_faces (f);
1811
1812 if (FRAME_VISIBLE_P (f))
1813 redraw_frame (f);
1814 }
1815 }
1816
1817 void
1818 x_set_mouse_color (f, arg, oldval)
1819 struct frame *f;
1820 Lisp_Object arg, oldval;
1821 {
1822 #if 0
1823 Cursor cursor, nontext_cursor, mode_cursor, cross_cursor;
1824 #endif
1825 int count;
1826 int mask_color;
1827
1828 if (!EQ (Qnil, arg))
1829 f->output_data.w32->mouse_pixel
1830 = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
1831 mask_color = f->output_data.w32->background_pixel;
1832 /* No invisible pointers. */
1833 if (mask_color == f->output_data.w32->mouse_pixel
1834 && mask_color == f->output_data.w32->background_pixel)
1835 f->output_data.w32->mouse_pixel = f->output_data.w32->foreground_pixel;
1836
1837 #if 0
1838 BLOCK_INPUT;
1839
1840 /* It's not okay to crash if the user selects a screwy cursor. */
1841 count = x_catch_errors (FRAME_W32_DISPLAY (f));
1842
1843 if (!EQ (Qnil, Vx_pointer_shape))
1844 {
1845 CHECK_NUMBER (Vx_pointer_shape, 0);
1846 cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XINT (Vx_pointer_shape));
1847 }
1848 else
1849 cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_xterm);
1850 x_check_errors (FRAME_W32_DISPLAY (f), "bad text pointer cursor: %s");
1851
1852 if (!EQ (Qnil, Vx_nontext_pointer_shape))
1853 {
1854 CHECK_NUMBER (Vx_nontext_pointer_shape, 0);
1855 nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
1856 XINT (Vx_nontext_pointer_shape));
1857 }
1858 else
1859 nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_left_ptr);
1860 x_check_errors (FRAME_W32_DISPLAY (f), "bad nontext pointer cursor: %s");
1861
1862 if (!EQ (Qnil, Vx_mode_pointer_shape))
1863 {
1864 CHECK_NUMBER (Vx_mode_pointer_shape, 0);
1865 mode_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
1866 XINT (Vx_mode_pointer_shape));
1867 }
1868 else
1869 mode_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_xterm);
1870 x_check_errors (FRAME_W32_DISPLAY (f), "bad modeline pointer cursor: %s");
1871
1872 if (!EQ (Qnil, Vx_sensitive_text_pointer_shape))
1873 {
1874 CHECK_NUMBER (Vx_sensitive_text_pointer_shape, 0);
1875 cross_cursor
1876 = XCreateFontCursor (FRAME_W32_DISPLAY (f),
1877 XINT (Vx_sensitive_text_pointer_shape));
1878 }
1879 else
1880 cross_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_crosshair);
1881
1882 /* Check and report errors with the above calls. */
1883 x_check_errors (FRAME_W32_DISPLAY (f), "can't set cursor shape: %s");
1884 x_uncatch_errors (FRAME_W32_DISPLAY (f), count);
1885
1886 {
1887 XColor fore_color, back_color;
1888
1889 fore_color.pixel = f->output_data.w32->mouse_pixel;
1890 back_color.pixel = mask_color;
1891 XQueryColor (FRAME_W32_DISPLAY (f),
1892 DefaultColormap (FRAME_W32_DISPLAY (f),
1893 DefaultScreen (FRAME_W32_DISPLAY (f))),
1894 &fore_color);
1895 XQueryColor (FRAME_W32_DISPLAY (f),
1896 DefaultColormap (FRAME_W32_DISPLAY (f),
1897 DefaultScreen (FRAME_W32_DISPLAY (f))),
1898 &back_color);
1899 XRecolorCursor (FRAME_W32_DISPLAY (f), cursor,
1900 &fore_color, &back_color);
1901 XRecolorCursor (FRAME_W32_DISPLAY (f), nontext_cursor,
1902 &fore_color, &back_color);
1903 XRecolorCursor (FRAME_W32_DISPLAY (f), mode_cursor,
1904 &fore_color, &back_color);
1905 XRecolorCursor (FRAME_W32_DISPLAY (f), cross_cursor,
1906 &fore_color, &back_color);
1907 }
1908
1909 if (FRAME_W32_WINDOW (f) != 0)
1910 {
1911 XDefineCursor (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), cursor);
1912 }
1913
1914 if (cursor != f->output_data.w32->text_cursor && f->output_data.w32->text_cursor != 0)
1915 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->text_cursor);
1916 f->output_data.w32->text_cursor = cursor;
1917
1918 if (nontext_cursor != f->output_data.w32->nontext_cursor
1919 && f->output_data.w32->nontext_cursor != 0)
1920 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->nontext_cursor);
1921 f->output_data.w32->nontext_cursor = nontext_cursor;
1922
1923 if (mode_cursor != f->output_data.w32->modeline_cursor
1924 && f->output_data.w32->modeline_cursor != 0)
1925 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->modeline_cursor);
1926 f->output_data.w32->modeline_cursor = mode_cursor;
1927 if (cross_cursor != f->output_data.w32->cross_cursor
1928 && f->output_data.w32->cross_cursor != 0)
1929 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->cross_cursor);
1930 f->output_data.w32->cross_cursor = cross_cursor;
1931
1932 XFlush (FRAME_W32_DISPLAY (f));
1933 UNBLOCK_INPUT;
1934 #endif
1935 }
1936
1937 void
1938 x_set_cursor_color (f, arg, oldval)
1939 struct frame *f;
1940 Lisp_Object arg, oldval;
1941 {
1942 unsigned long fore_pixel;
1943
1944 if (!EQ (Vx_cursor_fore_pixel, Qnil))
1945 fore_pixel = x_decode_color (f, Vx_cursor_fore_pixel,
1946 WHITE_PIX_DEFAULT (f));
1947 else
1948 fore_pixel = f->output_data.w32->background_pixel;
1949 f->output_data.w32->cursor_pixel = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
1950
1951 /* Make sure that the cursor color differs from the background color. */
1952 if (f->output_data.w32->cursor_pixel == f->output_data.w32->background_pixel)
1953 {
1954 f->output_data.w32->cursor_pixel = f->output_data.w32->mouse_pixel;
1955 if (f->output_data.w32->cursor_pixel == fore_pixel)
1956 fore_pixel = f->output_data.w32->background_pixel;
1957 }
1958 f->output_data.w32->cursor_foreground_pixel = fore_pixel;
1959
1960 if (FRAME_W32_WINDOW (f) != 0)
1961 {
1962 if (FRAME_VISIBLE_P (f))
1963 {
1964 x_display_cursor (f, 0);
1965 x_display_cursor (f, 1);
1966 }
1967 }
1968 }
1969
1970 /* Set the border-color of frame F to pixel value PIX.
1971 Note that this does not fully take effect if done before
1972 F has an window. */
1973 void
1974 x_set_border_pixel (f, pix)
1975 struct frame *f;
1976 int pix;
1977 {
1978 f->output_data.w32->border_pixel = pix;
1979
1980 if (FRAME_W32_WINDOW (f) != 0 && f->output_data.w32->border_width > 0)
1981 {
1982 if (FRAME_VISIBLE_P (f))
1983 redraw_frame (f);
1984 }
1985 }
1986
1987 /* Set the border-color of frame F to value described by ARG.
1988 ARG can be a string naming a color.
1989 The border-color is used for the border that is drawn by the server.
1990 Note that this does not fully take effect if done before
1991 F has a window; it must be redone when the window is created. */
1992
1993 void
1994 x_set_border_color (f, arg, oldval)
1995 struct frame *f;
1996 Lisp_Object arg, oldval;
1997 {
1998 unsigned char *str;
1999 int pix;
2000
2001 CHECK_STRING (arg, 0);
2002 str = XSTRING (arg)->data;
2003
2004 pix = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
2005
2006 x_set_border_pixel (f, pix);
2007 }
2008
2009 void
2010 x_set_cursor_type (f, arg, oldval)
2011 FRAME_PTR f;
2012 Lisp_Object arg, oldval;
2013 {
2014 if (EQ (arg, Qbar))
2015 {
2016 FRAME_DESIRED_CURSOR (f) = bar_cursor;
2017 f->output_data.w32->cursor_width = 2;
2018 }
2019 else if (CONSP (arg) && EQ (XCONS (arg)->car, Qbar)
2020 && INTEGERP (XCONS (arg)->cdr))
2021 {
2022 FRAME_DESIRED_CURSOR (f) = bar_cursor;
2023 f->output_data.w32->cursor_width = XINT (XCONS (arg)->cdr);
2024 }
2025 else
2026 /* Treat anything unknown as "box cursor".
2027 It was bad to signal an error; people have trouble fixing
2028 .Xdefaults with Emacs, when it has something bad in it. */
2029 FRAME_DESIRED_CURSOR (f) = filled_box_cursor;
2030
2031 /* Make sure the cursor gets redrawn. This is overkill, but how
2032 often do people change cursor types? */
2033 update_mode_lines++;
2034 }
2035
2036 void
2037 x_set_icon_type (f, arg, oldval)
2038 struct frame *f;
2039 Lisp_Object arg, oldval;
2040 {
2041 #if 0
2042 Lisp_Object tem;
2043 int result;
2044
2045 if (STRINGP (arg))
2046 {
2047 if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt))
2048 return;
2049 }
2050 else if (!STRINGP (oldval) && EQ (oldval, Qnil) == EQ (arg, Qnil))
2051 return;
2052
2053 BLOCK_INPUT;
2054 if (NILP (arg))
2055 result = x_text_icon (f,
2056 (char *) XSTRING ((!NILP (f->icon_name)
2057 ? f->icon_name
2058 : f->name))->data);
2059 else
2060 result = x_bitmap_icon (f, arg);
2061
2062 if (result)
2063 {
2064 UNBLOCK_INPUT;
2065 error ("No icon window available");
2066 }
2067
2068 /* If the window was unmapped (and its icon was mapped),
2069 the new icon is not mapped, so map the window in its stead. */
2070 if (FRAME_VISIBLE_P (f))
2071 {
2072 #ifdef USE_X_TOOLKIT
2073 XtPopup (f->output_data.w32->widget, XtGrabNone);
2074 #endif
2075 XMapWindow (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f));
2076 }
2077
2078 XFlush (FRAME_W32_DISPLAY (f));
2079 UNBLOCK_INPUT;
2080 #endif
2081 }
2082
2083 /* Return non-nil if frame F wants a bitmap icon. */
2084
2085 Lisp_Object
2086 x_icon_type (f)
2087 FRAME_PTR f;
2088 {
2089 Lisp_Object tem;
2090
2091 tem = assq_no_quit (Qicon_type, f->param_alist);
2092 if (CONSP (tem))
2093 return XCONS (tem)->cdr;
2094 else
2095 return Qnil;
2096 }
2097
2098 void
2099 x_set_icon_name (f, arg, oldval)
2100 struct frame *f;
2101 Lisp_Object arg, oldval;
2102 {
2103 Lisp_Object tem;
2104 int result;
2105
2106 if (STRINGP (arg))
2107 {
2108 if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt))
2109 return;
2110 }
2111 else if (!STRINGP (oldval) && EQ (oldval, Qnil) == EQ (arg, Qnil))
2112 return;
2113
2114 f->icon_name = arg;
2115
2116 #if 0
2117 if (f->output_data.w32->icon_bitmap != 0)
2118 return;
2119
2120 BLOCK_INPUT;
2121
2122 result = x_text_icon (f,
2123 (char *) XSTRING ((!NILP (f->icon_name)
2124 ? f->icon_name
2125 : !NILP (f->title)
2126 ? f->title
2127 : f->name))->data);
2128
2129 if (result)
2130 {
2131 UNBLOCK_INPUT;
2132 error ("No icon window available");
2133 }
2134
2135 /* If the window was unmapped (and its icon was mapped),
2136 the new icon is not mapped, so map the window in its stead. */
2137 if (FRAME_VISIBLE_P (f))
2138 {
2139 #ifdef USE_X_TOOLKIT
2140 XtPopup (f->output_data.w32->widget, XtGrabNone);
2141 #endif
2142 XMapWindow (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f));
2143 }
2144
2145 XFlush (FRAME_W32_DISPLAY (f));
2146 UNBLOCK_INPUT;
2147 #endif
2148 }
2149
2150 extern Lisp_Object x_new_font ();
2151 extern Lisp_Object x_new_fontset();
2152
2153 void
2154 x_set_font (f, arg, oldval)
2155 struct frame *f;
2156 Lisp_Object arg, oldval;
2157 {
2158 Lisp_Object result;
2159 Lisp_Object fontset_name;
2160 Lisp_Object frame;
2161
2162 CHECK_STRING (arg, 1);
2163
2164 fontset_name = Fquery_fontset (arg, Qnil);
2165
2166 BLOCK_INPUT;
2167 result = (STRINGP (fontset_name)
2168 ? x_new_fontset (f, XSTRING (fontset_name)->data)
2169 : x_new_font (f, XSTRING (arg)->data));
2170 UNBLOCK_INPUT;
2171
2172 if (EQ (result, Qnil))
2173 error ("Font \"%s\" is not defined", XSTRING (arg)->data);
2174 else if (EQ (result, Qt))
2175 error ("the characters of the given font have varying widths");
2176 else if (STRINGP (result))
2177 {
2178 recompute_basic_faces (f);
2179 store_frame_param (f, Qfont, result);
2180 }
2181 else
2182 abort ();
2183
2184 XSETFRAME (frame, f);
2185 call1 (Qface_set_after_frame_default, frame);
2186 }
2187
2188 void
2189 x_set_border_width (f, arg, oldval)
2190 struct frame *f;
2191 Lisp_Object arg, oldval;
2192 {
2193 CHECK_NUMBER (arg, 0);
2194
2195 if (XINT (arg) == f->output_data.w32->border_width)
2196 return;
2197
2198 if (FRAME_W32_WINDOW (f) != 0)
2199 error ("Cannot change the border width of a window");
2200
2201 f->output_data.w32->border_width = XINT (arg);
2202 }
2203
2204 void
2205 x_set_internal_border_width (f, arg, oldval)
2206 struct frame *f;
2207 Lisp_Object arg, oldval;
2208 {
2209 int mask;
2210 int old = f->output_data.w32->internal_border_width;
2211
2212 CHECK_NUMBER (arg, 0);
2213 f->output_data.w32->internal_border_width = XINT (arg);
2214 if (f->output_data.w32->internal_border_width < 0)
2215 f->output_data.w32->internal_border_width = 0;
2216
2217 if (f->output_data.w32->internal_border_width == old)
2218 return;
2219
2220 if (FRAME_W32_WINDOW (f) != 0)
2221 {
2222 BLOCK_INPUT;
2223 x_set_window_size (f, 0, f->width, f->height);
2224 UNBLOCK_INPUT;
2225 SET_FRAME_GARBAGED (f);
2226 }
2227 }
2228
2229 void
2230 x_set_visibility (f, value, oldval)
2231 struct frame *f;
2232 Lisp_Object value, oldval;
2233 {
2234 Lisp_Object frame;
2235 XSETFRAME (frame, f);
2236
2237 if (NILP (value))
2238 Fmake_frame_invisible (frame, Qt);
2239 else if (EQ (value, Qicon))
2240 Ficonify_frame (frame);
2241 else
2242 Fmake_frame_visible (frame);
2243 }
2244
2245 void
2246 x_set_menu_bar_lines (f, value, oldval)
2247 struct frame *f;
2248 Lisp_Object value, oldval;
2249 {
2250 int nlines;
2251 int olines = FRAME_MENU_BAR_LINES (f);
2252
2253 /* Right now, menu bars don't work properly in minibuf-only frames;
2254 most of the commands try to apply themselves to the minibuffer
2255 frame itslef, and get an error because you can't switch buffers
2256 in or split the minibuffer window. */
2257 if (FRAME_MINIBUF_ONLY_P (f))
2258 return;
2259
2260 if (INTEGERP (value))
2261 nlines = XINT (value);
2262 else
2263 nlines = 0;
2264
2265 FRAME_MENU_BAR_LINES (f) = 0;
2266 if (nlines)
2267 FRAME_EXTERNAL_MENU_BAR (f) = 1;
2268 else
2269 {
2270 if (FRAME_EXTERNAL_MENU_BAR (f) == 1)
2271 free_frame_menubar (f);
2272 FRAME_EXTERNAL_MENU_BAR (f) = 0;
2273
2274 /* Adjust the frame size so that the client (text) dimensions
2275 remain the same. This depends on FRAME_EXTERNAL_MENU_BAR being
2276 set correctly. */
2277 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
2278 }
2279 }
2280
2281 /* Change the name of frame F to NAME. If NAME is nil, set F's name to
2282 w32_id_name.
2283
2284 If EXPLICIT is non-zero, that indicates that lisp code is setting the
2285 name; if NAME is a string, set F's name to NAME and set
2286 F->explicit_name; if NAME is Qnil, then clear F->explicit_name.
2287
2288 If EXPLICIT is zero, that indicates that Emacs redisplay code is
2289 suggesting a new name, which lisp code should override; if
2290 F->explicit_name is set, ignore the new name; otherwise, set it. */
2291
2292 void
2293 x_set_name (f, name, explicit)
2294 struct frame *f;
2295 Lisp_Object name;
2296 int explicit;
2297 {
2298 /* Make sure that requests from lisp code override requests from
2299 Emacs redisplay code. */
2300 if (explicit)
2301 {
2302 /* If we're switching from explicit to implicit, we had better
2303 update the mode lines and thereby update the title. */
2304 if (f->explicit_name && NILP (name))
2305 update_mode_lines = 1;
2306
2307 f->explicit_name = ! NILP (name);
2308 }
2309 else if (f->explicit_name)
2310 return;
2311
2312 /* If NAME is nil, set the name to the w32_id_name. */
2313 if (NILP (name))
2314 {
2315 /* Check for no change needed in this very common case
2316 before we do any consing. */
2317 if (!strcmp (FRAME_W32_DISPLAY_INFO (f)->w32_id_name,
2318 XSTRING (f->name)->data))
2319 return;
2320 name = build_string (FRAME_W32_DISPLAY_INFO (f)->w32_id_name);
2321 }
2322 else
2323 CHECK_STRING (name, 0);
2324
2325 /* Don't change the name if it's already NAME. */
2326 if (! NILP (Fstring_equal (name, f->name)))
2327 return;
2328
2329 f->name = name;
2330
2331 /* For setting the frame title, the title parameter should override
2332 the name parameter. */
2333 if (! NILP (f->title))
2334 name = f->title;
2335
2336 if (FRAME_W32_WINDOW (f))
2337 {
2338 BLOCK_INPUT;
2339 SetWindowText(FRAME_W32_WINDOW (f), XSTRING (name)->data);
2340 UNBLOCK_INPUT;
2341 }
2342 }
2343
2344 /* This function should be called when the user's lisp code has
2345 specified a name for the frame; the name will override any set by the
2346 redisplay code. */
2347 void
2348 x_explicitly_set_name (f, arg, oldval)
2349 FRAME_PTR f;
2350 Lisp_Object arg, oldval;
2351 {
2352 x_set_name (f, arg, 1);
2353 }
2354
2355 /* This function should be called by Emacs redisplay code to set the
2356 name; names set this way will never override names set by the user's
2357 lisp code. */
2358 void
2359 x_implicitly_set_name (f, arg, oldval)
2360 FRAME_PTR f;
2361 Lisp_Object arg, oldval;
2362 {
2363 x_set_name (f, arg, 0);
2364 }
2365 \f
2366 /* Change the title of frame F to NAME.
2367 If NAME is nil, use the frame name as the title.
2368
2369 If EXPLICIT is non-zero, that indicates that lisp code is setting the
2370 name; if NAME is a string, set F's name to NAME and set
2371 F->explicit_name; if NAME is Qnil, then clear F->explicit_name.
2372
2373 If EXPLICIT is zero, that indicates that Emacs redisplay code is
2374 suggesting a new name, which lisp code should override; if
2375 F->explicit_name is set, ignore the new name; otherwise, set it. */
2376
2377 void
2378 x_set_title (f, name)
2379 struct frame *f;
2380 Lisp_Object name;
2381 {
2382 /* Don't change the title if it's already NAME. */
2383 if (EQ (name, f->title))
2384 return;
2385
2386 update_mode_lines = 1;
2387
2388 f->title = name;
2389
2390 if (NILP (name))
2391 name = f->name;
2392
2393 if (FRAME_W32_WINDOW (f))
2394 {
2395 BLOCK_INPUT;
2396 SetWindowText(FRAME_W32_WINDOW (f), XSTRING (name)->data);
2397 UNBLOCK_INPUT;
2398 }
2399 }
2400 \f
2401 void
2402 x_set_autoraise (f, arg, oldval)
2403 struct frame *f;
2404 Lisp_Object arg, oldval;
2405 {
2406 f->auto_raise = !EQ (Qnil, arg);
2407 }
2408
2409 void
2410 x_set_autolower (f, arg, oldval)
2411 struct frame *f;
2412 Lisp_Object arg, oldval;
2413 {
2414 f->auto_lower = !EQ (Qnil, arg);
2415 }
2416
2417 void
2418 x_set_unsplittable (f, arg, oldval)
2419 struct frame *f;
2420 Lisp_Object arg, oldval;
2421 {
2422 f->no_split = !NILP (arg);
2423 }
2424
2425 void
2426 x_set_vertical_scroll_bars (f, arg, oldval)
2427 struct frame *f;
2428 Lisp_Object arg, oldval;
2429 {
2430 if ((EQ (arg, Qleft) && FRAME_HAS_VERTICAL_SCROLL_BARS_ON_RIGHT (f))
2431 || (EQ (arg, Qright) && FRAME_HAS_VERTICAL_SCROLL_BARS_ON_LEFT (f))
2432 || (NILP (arg) && FRAME_HAS_VERTICAL_SCROLL_BARS (f))
2433 || (!NILP (arg) && ! FRAME_HAS_VERTICAL_SCROLL_BARS (f)))
2434 {
2435 FRAME_VERTICAL_SCROLL_BAR_TYPE (f) = NILP (arg) ?
2436 vertical_scroll_bar_none :
2437 /* Put scroll bars on the right by default, as is conventional
2438 on MS-Windows. */
2439 EQ (Qleft, arg)
2440 ? vertical_scroll_bar_left
2441 : vertical_scroll_bar_right;
2442
2443 /* We set this parameter before creating the window for the
2444 frame, so we can get the geometry right from the start.
2445 However, if the window hasn't been created yet, we shouldn't
2446 call x_set_window_size. */
2447 if (FRAME_W32_WINDOW (f))
2448 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
2449 }
2450 }
2451
2452 void
2453 x_set_scroll_bar_width (f, arg, oldval)
2454 struct frame *f;
2455 Lisp_Object arg, oldval;
2456 {
2457 if (NILP (arg))
2458 {
2459 FRAME_SCROLL_BAR_PIXEL_WIDTH (f) = 0;
2460 FRAME_SCROLL_BAR_COLS (f) = 2;
2461 }
2462 else if (INTEGERP (arg) && XINT (arg) > 0
2463 && XFASTINT (arg) != FRAME_SCROLL_BAR_PIXEL_WIDTH (f))
2464 {
2465 int wid = FONT_WIDTH (f->output_data.w32->font);
2466 FRAME_SCROLL_BAR_PIXEL_WIDTH (f) = XFASTINT (arg);
2467 FRAME_SCROLL_BAR_COLS (f) = (XFASTINT (arg) + wid-1) / wid;
2468 if (FRAME_W32_WINDOW (f))
2469 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
2470 }
2471 }
2472 \f
2473 /* Subroutines of creating an frame. */
2474
2475 /* Make sure that Vx_resource_name is set to a reasonable value.
2476 Fix it up, or set it to `emacs' if it is too hopeless. */
2477
2478 static void
2479 validate_x_resource_name ()
2480 {
2481 int len;
2482 /* Number of valid characters in the resource name. */
2483 int good_count = 0;
2484 /* Number of invalid characters in the resource name. */
2485 int bad_count = 0;
2486 Lisp_Object new;
2487 int i;
2488
2489 if (STRINGP (Vx_resource_name))
2490 {
2491 unsigned char *p = XSTRING (Vx_resource_name)->data;
2492 int i;
2493
2494 len = XSTRING (Vx_resource_name)->size;
2495
2496 /* Only letters, digits, - and _ are valid in resource names.
2497 Count the valid characters and count the invalid ones. */
2498 for (i = 0; i < len; i++)
2499 {
2500 int c = p[i];
2501 if (! ((c >= 'a' && c <= 'z')
2502 || (c >= 'A' && c <= 'Z')
2503 || (c >= '0' && c <= '9')
2504 || c == '-' || c == '_'))
2505 bad_count++;
2506 else
2507 good_count++;
2508 }
2509 }
2510 else
2511 /* Not a string => completely invalid. */
2512 bad_count = 5, good_count = 0;
2513
2514 /* If name is valid already, return. */
2515 if (bad_count == 0)
2516 return;
2517
2518 /* If name is entirely invalid, or nearly so, use `emacs'. */
2519 if (good_count == 0
2520 || (good_count == 1 && bad_count > 0))
2521 {
2522 Vx_resource_name = build_string ("emacs");
2523 return;
2524 }
2525
2526 /* Name is partly valid. Copy it and replace the invalid characters
2527 with underscores. */
2528
2529 Vx_resource_name = new = Fcopy_sequence (Vx_resource_name);
2530
2531 for (i = 0; i < len; i++)
2532 {
2533 int c = XSTRING (new)->data[i];
2534 if (! ((c >= 'a' && c <= 'z')
2535 || (c >= 'A' && c <= 'Z')
2536 || (c >= '0' && c <= '9')
2537 || c == '-' || c == '_'))
2538 XSTRING (new)->data[i] = '_';
2539 }
2540 }
2541
2542
2543 extern char *x_get_string_resource ();
2544
2545 DEFUN ("x-get-resource", Fx_get_resource, Sx_get_resource, 2, 4, 0,
2546 "Return the value of ATTRIBUTE, of class CLASS, from the X defaults database.\n\
2547 This uses `INSTANCE.ATTRIBUTE' as the key and `Emacs.CLASS' as the\n\
2548 class, where INSTANCE is the name under which Emacs was invoked, or\n\
2549 the name specified by the `-name' or `-rn' command-line arguments.\n\
2550 \n\
2551 The optional arguments COMPONENT and SUBCLASS add to the key and the\n\
2552 class, respectively. You must specify both of them or neither.\n\
2553 If you specify them, the key is `INSTANCE.COMPONENT.ATTRIBUTE'\n\
2554 and the class is `Emacs.CLASS.SUBCLASS'.")
2555 (attribute, class, component, subclass)
2556 Lisp_Object attribute, class, component, subclass;
2557 {
2558 register char *value;
2559 char *name_key;
2560 char *class_key;
2561
2562 CHECK_STRING (attribute, 0);
2563 CHECK_STRING (class, 0);
2564
2565 if (!NILP (component))
2566 CHECK_STRING (component, 1);
2567 if (!NILP (subclass))
2568 CHECK_STRING (subclass, 2);
2569 if (NILP (component) != NILP (subclass))
2570 error ("x-get-resource: must specify both COMPONENT and SUBCLASS or neither");
2571
2572 validate_x_resource_name ();
2573
2574 /* Allocate space for the components, the dots which separate them,
2575 and the final '\0'. Make them big enough for the worst case. */
2576 name_key = (char *) alloca (XSTRING (Vx_resource_name)->size
2577 + (STRINGP (component)
2578 ? XSTRING (component)->size : 0)
2579 + XSTRING (attribute)->size
2580 + 3);
2581
2582 class_key = (char *) alloca ((sizeof (EMACS_CLASS) - 1)
2583 + XSTRING (class)->size
2584 + (STRINGP (subclass)
2585 ? XSTRING (subclass)->size : 0)
2586 + 3);
2587
2588 /* Start with emacs.FRAMENAME for the name (the specific one)
2589 and with `Emacs' for the class key (the general one). */
2590 strcpy (name_key, XSTRING (Vx_resource_name)->data);
2591 strcpy (class_key, EMACS_CLASS);
2592
2593 strcat (class_key, ".");
2594 strcat (class_key, XSTRING (class)->data);
2595
2596 if (!NILP (component))
2597 {
2598 strcat (class_key, ".");
2599 strcat (class_key, XSTRING (subclass)->data);
2600
2601 strcat (name_key, ".");
2602 strcat (name_key, XSTRING (component)->data);
2603 }
2604
2605 strcat (name_key, ".");
2606 strcat (name_key, XSTRING (attribute)->data);
2607
2608 value = x_get_string_resource (Qnil,
2609 name_key, class_key);
2610
2611 if (value != (char *) 0)
2612 return build_string (value);
2613 else
2614 return Qnil;
2615 }
2616
2617 /* Used when C code wants a resource value. */
2618
2619 char *
2620 x_get_resource_string (attribute, class)
2621 char *attribute, *class;
2622 {
2623 register char *value;
2624 char *name_key;
2625 char *class_key;
2626
2627 /* Allocate space for the components, the dots which separate them,
2628 and the final '\0'. */
2629 name_key = (char *) alloca (XSTRING (Vinvocation_name)->size
2630 + strlen (attribute) + 2);
2631 class_key = (char *) alloca ((sizeof (EMACS_CLASS) - 1)
2632 + strlen (class) + 2);
2633
2634 sprintf (name_key, "%s.%s",
2635 XSTRING (Vinvocation_name)->data,
2636 attribute);
2637 sprintf (class_key, "%s.%s", EMACS_CLASS, class);
2638
2639 return x_get_string_resource (selected_frame,
2640 name_key, class_key);
2641 }
2642
2643 /* Types we might convert a resource string into. */
2644 enum resource_types
2645 {
2646 number, boolean, string, symbol
2647 };
2648
2649 /* Return the value of parameter PARAM.
2650
2651 First search ALIST, then Vdefault_frame_alist, then the X defaults
2652 database, using ATTRIBUTE as the attribute name and CLASS as its class.
2653
2654 Convert the resource to the type specified by desired_type.
2655
2656 If no default is specified, return Qunbound. If you call
2657 x_get_arg, make sure you deal with Qunbound in a reasonable way,
2658 and don't let it get stored in any Lisp-visible variables! */
2659
2660 static Lisp_Object
2661 x_get_arg (alist, param, attribute, class, type)
2662 Lisp_Object alist, param;
2663 char *attribute;
2664 char *class;
2665 enum resource_types type;
2666 {
2667 register Lisp_Object tem;
2668
2669 tem = Fassq (param, alist);
2670 if (EQ (tem, Qnil))
2671 tem = Fassq (param, Vdefault_frame_alist);
2672 if (EQ (tem, Qnil))
2673 {
2674
2675 if (attribute)
2676 {
2677 tem = Fx_get_resource (build_string (attribute),
2678 build_string (class),
2679 Qnil, Qnil);
2680
2681 if (NILP (tem))
2682 return Qunbound;
2683
2684 switch (type)
2685 {
2686 case number:
2687 return make_number (atoi (XSTRING (tem)->data));
2688
2689 case boolean:
2690 tem = Fdowncase (tem);
2691 if (!strcmp (XSTRING (tem)->data, "on")
2692 || !strcmp (XSTRING (tem)->data, "true"))
2693 return Qt;
2694 else
2695 return Qnil;
2696
2697 case string:
2698 return tem;
2699
2700 case symbol:
2701 /* As a special case, we map the values `true' and `on'
2702 to Qt, and `false' and `off' to Qnil. */
2703 {
2704 Lisp_Object lower;
2705 lower = Fdowncase (tem);
2706 if (!strcmp (XSTRING (lower)->data, "on")
2707 || !strcmp (XSTRING (lower)->data, "true"))
2708 return Qt;
2709 else if (!strcmp (XSTRING (lower)->data, "off")
2710 || !strcmp (XSTRING (lower)->data, "false"))
2711 return Qnil;
2712 else
2713 return Fintern (tem, Qnil);
2714 }
2715
2716 default:
2717 abort ();
2718 }
2719 }
2720 else
2721 return Qunbound;
2722 }
2723 return Fcdr (tem);
2724 }
2725
2726 /* Record in frame F the specified or default value according to ALIST
2727 of the parameter named PARAM (a Lisp symbol).
2728 If no value is specified for PARAM, look for an X default for XPROP
2729 on the frame named NAME.
2730 If that is not found either, use the value DEFLT. */
2731
2732 static Lisp_Object
2733 x_default_parameter (f, alist, prop, deflt, xprop, xclass, type)
2734 struct frame *f;
2735 Lisp_Object alist;
2736 Lisp_Object prop;
2737 Lisp_Object deflt;
2738 char *xprop;
2739 char *xclass;
2740 enum resource_types type;
2741 {
2742 Lisp_Object tem;
2743
2744 tem = x_get_arg (alist, prop, xprop, xclass, type);
2745 if (EQ (tem, Qunbound))
2746 tem = deflt;
2747 x_set_frame_parameters (f, Fcons (Fcons (prop, tem), Qnil));
2748 return tem;
2749 }
2750 \f
2751 DEFUN ("x-parse-geometry", Fx_parse_geometry, Sx_parse_geometry, 1, 1, 0,
2752 "Parse an X-style geometry string STRING.\n\
2753 Returns an alist of the form ((top . TOP), (left . LEFT) ... ).\n\
2754 The properties returned may include `top', `left', `height', and `width'.\n\
2755 The value of `left' or `top' may be an integer,\n\
2756 or a list (+ N) meaning N pixels relative to top/left corner,\n\
2757 or a list (- N) meaning -N pixels relative to bottom/right corner.")
2758 (string)
2759 Lisp_Object string;
2760 {
2761 int geometry, x, y;
2762 unsigned int width, height;
2763 Lisp_Object result;
2764
2765 CHECK_STRING (string, 0);
2766
2767 geometry = XParseGeometry ((char *) XSTRING (string)->data,
2768 &x, &y, &width, &height);
2769
2770 result = Qnil;
2771 if (geometry & XValue)
2772 {
2773 Lisp_Object element;
2774
2775 if (x >= 0 && (geometry & XNegative))
2776 element = Fcons (Qleft, Fcons (Qminus, Fcons (make_number (-x), Qnil)));
2777 else if (x < 0 && ! (geometry & XNegative))
2778 element = Fcons (Qleft, Fcons (Qplus, Fcons (make_number (x), Qnil)));
2779 else
2780 element = Fcons (Qleft, make_number (x));
2781 result = Fcons (element, result);
2782 }
2783
2784 if (geometry & YValue)
2785 {
2786 Lisp_Object element;
2787
2788 if (y >= 0 && (geometry & YNegative))
2789 element = Fcons (Qtop, Fcons (Qminus, Fcons (make_number (-y), Qnil)));
2790 else if (y < 0 && ! (geometry & YNegative))
2791 element = Fcons (Qtop, Fcons (Qplus, Fcons (make_number (y), Qnil)));
2792 else
2793 element = Fcons (Qtop, make_number (y));
2794 result = Fcons (element, result);
2795 }
2796
2797 if (geometry & WidthValue)
2798 result = Fcons (Fcons (Qwidth, make_number (width)), result);
2799 if (geometry & HeightValue)
2800 result = Fcons (Fcons (Qheight, make_number (height)), result);
2801
2802 return result;
2803 }
2804
2805 /* Calculate the desired size and position of this window,
2806 and return the flags saying which aspects were specified.
2807
2808 This function does not make the coordinates positive. */
2809
2810 #define DEFAULT_ROWS 40
2811 #define DEFAULT_COLS 80
2812
2813 static int
2814 x_figure_window_size (f, parms)
2815 struct frame *f;
2816 Lisp_Object parms;
2817 {
2818 register Lisp_Object tem0, tem1, tem2;
2819 int height, width, left, top;
2820 register int geometry;
2821 long window_prompting = 0;
2822
2823 /* Default values if we fall through.
2824 Actually, if that happens we should get
2825 window manager prompting. */
2826 SET_FRAME_WIDTH (f, DEFAULT_COLS);
2827 f->height = DEFAULT_ROWS;
2828 /* Window managers expect that if program-specified
2829 positions are not (0,0), they're intentional, not defaults. */
2830 f->output_data.w32->top_pos = 0;
2831 f->output_data.w32->left_pos = 0;
2832
2833 tem0 = x_get_arg (parms, Qheight, 0, 0, number);
2834 tem1 = x_get_arg (parms, Qwidth, 0, 0, number);
2835 tem2 = x_get_arg (parms, Quser_size, 0, 0, number);
2836 if (! EQ (tem0, Qunbound) || ! EQ (tem1, Qunbound))
2837 {
2838 if (!EQ (tem0, Qunbound))
2839 {
2840 CHECK_NUMBER (tem0, 0);
2841 f->height = XINT (tem0);
2842 }
2843 if (!EQ (tem1, Qunbound))
2844 {
2845 CHECK_NUMBER (tem1, 0);
2846 SET_FRAME_WIDTH (f, XINT (tem1));
2847 }
2848 if (!NILP (tem2) && !EQ (tem2, Qunbound))
2849 window_prompting |= USSize;
2850 else
2851 window_prompting |= PSize;
2852 }
2853
2854 f->output_data.w32->vertical_scroll_bar_extra
2855 = (!FRAME_HAS_VERTICAL_SCROLL_BARS (f)
2856 ? 0
2857 : FRAME_SCROLL_BAR_PIXEL_WIDTH (f) > 0
2858 ? FRAME_SCROLL_BAR_PIXEL_WIDTH (f)
2859 : (FRAME_SCROLL_BAR_COLS (f) * FONT_WIDTH (f->output_data.w32->font)));
2860 f->output_data.w32->pixel_width = CHAR_TO_PIXEL_WIDTH (f, f->width);
2861 f->output_data.w32->pixel_height = CHAR_TO_PIXEL_HEIGHT (f, f->height);
2862
2863 tem0 = x_get_arg (parms, Qtop, 0, 0, number);
2864 tem1 = x_get_arg (parms, Qleft, 0, 0, number);
2865 tem2 = x_get_arg (parms, Quser_position, 0, 0, number);
2866 if (! EQ (tem0, Qunbound) || ! EQ (tem1, Qunbound))
2867 {
2868 if (EQ (tem0, Qminus))
2869 {
2870 f->output_data.w32->top_pos = 0;
2871 window_prompting |= YNegative;
2872 }
2873 else if (CONSP (tem0) && EQ (XCONS (tem0)->car, Qminus)
2874 && CONSP (XCONS (tem0)->cdr)
2875 && INTEGERP (XCONS (XCONS (tem0)->cdr)->car))
2876 {
2877 f->output_data.w32->top_pos = - XINT (XCONS (XCONS (tem0)->cdr)->car);
2878 window_prompting |= YNegative;
2879 }
2880 else if (CONSP (tem0) && EQ (XCONS (tem0)->car, Qplus)
2881 && CONSP (XCONS (tem0)->cdr)
2882 && INTEGERP (XCONS (XCONS (tem0)->cdr)->car))
2883 {
2884 f->output_data.w32->top_pos = XINT (XCONS (XCONS (tem0)->cdr)->car);
2885 }
2886 else if (EQ (tem0, Qunbound))
2887 f->output_data.w32->top_pos = 0;
2888 else
2889 {
2890 CHECK_NUMBER (tem0, 0);
2891 f->output_data.w32->top_pos = XINT (tem0);
2892 if (f->output_data.w32->top_pos < 0)
2893 window_prompting |= YNegative;
2894 }
2895
2896 if (EQ (tem1, Qminus))
2897 {
2898 f->output_data.w32->left_pos = 0;
2899 window_prompting |= XNegative;
2900 }
2901 else if (CONSP (tem1) && EQ (XCONS (tem1)->car, Qminus)
2902 && CONSP (XCONS (tem1)->cdr)
2903 && INTEGERP (XCONS (XCONS (tem1)->cdr)->car))
2904 {
2905 f->output_data.w32->left_pos = - XINT (XCONS (XCONS (tem1)->cdr)->car);
2906 window_prompting |= XNegative;
2907 }
2908 else if (CONSP (tem1) && EQ (XCONS (tem1)->car, Qplus)
2909 && CONSP (XCONS (tem1)->cdr)
2910 && INTEGERP (XCONS (XCONS (tem1)->cdr)->car))
2911 {
2912 f->output_data.w32->left_pos = XINT (XCONS (XCONS (tem1)->cdr)->car);
2913 }
2914 else if (EQ (tem1, Qunbound))
2915 f->output_data.w32->left_pos = 0;
2916 else
2917 {
2918 CHECK_NUMBER (tem1, 0);
2919 f->output_data.w32->left_pos = XINT (tem1);
2920 if (f->output_data.w32->left_pos < 0)
2921 window_prompting |= XNegative;
2922 }
2923
2924 if (!NILP (tem2) && ! EQ (tem2, Qunbound))
2925 window_prompting |= USPosition;
2926 else
2927 window_prompting |= PPosition;
2928 }
2929
2930 return window_prompting;
2931 }
2932
2933 \f
2934
2935 extern LRESULT CALLBACK w32_wnd_proc ();
2936
2937 BOOL
2938 w32_init_class (hinst)
2939 HINSTANCE hinst;
2940 {
2941 WNDCLASS wc;
2942
2943 wc.style = CS_HREDRAW | CS_VREDRAW;
2944 wc.lpfnWndProc = (WNDPROC) w32_wnd_proc;
2945 wc.cbClsExtra = 0;
2946 wc.cbWndExtra = WND_EXTRA_BYTES;
2947 wc.hInstance = hinst;
2948 wc.hIcon = LoadIcon (hinst, EMACS_CLASS);
2949 wc.hCursor = LoadCursor (NULL, IDC_ARROW);
2950 wc.hbrBackground = NULL; /* GetStockObject (WHITE_BRUSH); */
2951 wc.lpszMenuName = NULL;
2952 wc.lpszClassName = EMACS_CLASS;
2953
2954 return (RegisterClass (&wc));
2955 }
2956
2957 HWND
2958 w32_createscrollbar (f, bar)
2959 struct frame *f;
2960 struct scroll_bar * bar;
2961 {
2962 return (CreateWindow ("SCROLLBAR", "", SBS_VERT | WS_CHILD | WS_VISIBLE,
2963 /* Position and size of scroll bar. */
2964 XINT(bar->left), XINT(bar->top),
2965 XINT(bar->width), XINT(bar->height),
2966 FRAME_W32_WINDOW (f),
2967 NULL,
2968 hinst,
2969 NULL));
2970 }
2971
2972 void
2973 w32_createwindow (f)
2974 struct frame *f;
2975 {
2976 HWND hwnd;
2977 RECT rect;
2978
2979 rect.left = rect.top = 0;
2980 rect.right = PIXEL_WIDTH (f);
2981 rect.bottom = PIXEL_HEIGHT (f);
2982
2983 AdjustWindowRect (&rect, f->output_data.w32->dwStyle,
2984 FRAME_EXTERNAL_MENU_BAR (f));
2985
2986 /* Do first time app init */
2987
2988 if (!hprevinst)
2989 {
2990 w32_init_class (hinst);
2991 }
2992
2993 FRAME_W32_WINDOW (f) = hwnd
2994 = CreateWindow (EMACS_CLASS,
2995 f->namebuf,
2996 f->output_data.w32->dwStyle | WS_CLIPCHILDREN,
2997 f->output_data.w32->left_pos,
2998 f->output_data.w32->top_pos,
2999 rect.right - rect.left,
3000 rect.bottom - rect.top,
3001 NULL,
3002 NULL,
3003 hinst,
3004 NULL);
3005
3006 if (hwnd)
3007 {
3008 SetWindowLong (hwnd, WND_FONTWIDTH_INDEX, FONT_WIDTH (f->output_data.w32->font));
3009 SetWindowLong (hwnd, WND_LINEHEIGHT_INDEX, f->output_data.w32->line_height);
3010 SetWindowLong (hwnd, WND_BORDER_INDEX, f->output_data.w32->internal_border_width);
3011 SetWindowLong (hwnd, WND_SCROLLBAR_INDEX, f->output_data.w32->vertical_scroll_bar_extra);
3012 SetWindowLong (hwnd, WND_BACKGROUND_INDEX, f->output_data.w32->background_pixel);
3013
3014 /* Enable drag-n-drop. */
3015 DragAcceptFiles (hwnd, TRUE);
3016
3017 /* Do this to discard the default setting specified by our parent. */
3018 ShowWindow (hwnd, SW_HIDE);
3019 }
3020 }
3021
3022 void
3023 my_post_msg (wmsg, hwnd, msg, wParam, lParam)
3024 W32Msg * wmsg;
3025 HWND hwnd;
3026 UINT msg;
3027 WPARAM wParam;
3028 LPARAM lParam;
3029 {
3030 wmsg->msg.hwnd = hwnd;
3031 wmsg->msg.message = msg;
3032 wmsg->msg.wParam = wParam;
3033 wmsg->msg.lParam = lParam;
3034 wmsg->msg.time = GetMessageTime ();
3035
3036 post_msg (wmsg);
3037 }
3038
3039 /* GetKeyState and MapVirtualKey on Windows 95 do not actually distinguish
3040 between left and right keys as advertised. We test for this
3041 support dynamically, and set a flag when the support is absent. If
3042 absent, we keep track of the left and right control and alt keys
3043 ourselves. This is particularly necessary on keyboards that rely
3044 upon the AltGr key, which is represented as having the left control
3045 and right alt keys pressed. For these keyboards, we need to know
3046 when the left alt key has been pressed in addition to the AltGr key
3047 so that we can properly support M-AltGr-key sequences (such as M-@
3048 on Swedish keyboards). */
3049
3050 #define EMACS_LCONTROL 0
3051 #define EMACS_RCONTROL 1
3052 #define EMACS_LMENU 2
3053 #define EMACS_RMENU 3
3054
3055 static int modifiers[4];
3056 static int modifiers_recorded;
3057 static int modifier_key_support_tested;
3058
3059 static void
3060 test_modifier_support (unsigned int wparam)
3061 {
3062 unsigned int l, r;
3063
3064 if (wparam != VK_CONTROL && wparam != VK_MENU)
3065 return;
3066 if (wparam == VK_CONTROL)
3067 {
3068 l = VK_LCONTROL;
3069 r = VK_RCONTROL;
3070 }
3071 else
3072 {
3073 l = VK_LMENU;
3074 r = VK_RMENU;
3075 }
3076 if (!(GetKeyState (l) & 0x8000) && !(GetKeyState (r) & 0x8000))
3077 modifiers_recorded = 1;
3078 else
3079 modifiers_recorded = 0;
3080 modifier_key_support_tested = 1;
3081 }
3082
3083 static void
3084 record_keydown (unsigned int wparam, unsigned int lparam)
3085 {
3086 int i;
3087
3088 if (!modifier_key_support_tested)
3089 test_modifier_support (wparam);
3090
3091 if ((wparam != VK_CONTROL && wparam != VK_MENU) || !modifiers_recorded)
3092 return;
3093
3094 if (wparam == VK_CONTROL)
3095 i = (lparam & 0x1000000) ? EMACS_RCONTROL : EMACS_LCONTROL;
3096 else
3097 i = (lparam & 0x1000000) ? EMACS_RMENU : EMACS_LMENU;
3098
3099 modifiers[i] = 1;
3100 }
3101
3102 static void
3103 record_keyup (unsigned int wparam, unsigned int lparam)
3104 {
3105 int i;
3106
3107 if ((wparam != VK_CONTROL && wparam != VK_MENU) || !modifiers_recorded)
3108 return;
3109
3110 if (wparam == VK_CONTROL)
3111 i = (lparam & 0x1000000) ? EMACS_RCONTROL : EMACS_LCONTROL;
3112 else
3113 i = (lparam & 0x1000000) ? EMACS_RMENU : EMACS_LMENU;
3114
3115 modifiers[i] = 0;
3116 }
3117
3118 /* Emacs can lose focus while a modifier key has been pressed. When
3119 it regains focus, be conservative and clear all modifiers since
3120 we cannot reconstruct the left and right modifier state. */
3121 static void
3122 reset_modifiers ()
3123 {
3124 SHORT ctrl, alt;
3125
3126 if (GetFocus () == NULL)
3127 /* Emacs doesn't have keyboard focus. Do nothing. */
3128 return;
3129
3130 ctrl = GetAsyncKeyState (VK_CONTROL);
3131 alt = GetAsyncKeyState (VK_MENU);
3132
3133 if (!(ctrl & 0x08000))
3134 /* Clear any recorded control modifier state. */
3135 modifiers[EMACS_RCONTROL] = modifiers[EMACS_LCONTROL] = 0;
3136
3137 if (!(alt & 0x08000))
3138 /* Clear any recorded alt modifier state. */
3139 modifiers[EMACS_RMENU] = modifiers[EMACS_LMENU] = 0;
3140
3141 /* Update the state of all modifier keys, because modifiers used in
3142 hot-key combinations can get stuck on if Emacs loses focus as a
3143 result of a hot-key being pressed. */
3144 {
3145 BYTE keystate[256];
3146
3147 #define CURRENT_STATE(key) ((GetAsyncKeyState (key) & 0x8000) >> 8)
3148
3149 GetKeyboardState (keystate);
3150 keystate[VK_SHIFT] = CURRENT_STATE (VK_SHIFT);
3151 keystate[VK_CONTROL] = CURRENT_STATE (VK_CONTROL);
3152 keystate[VK_LCONTROL] = CURRENT_STATE (VK_LCONTROL);
3153 keystate[VK_RCONTROL] = CURRENT_STATE (VK_RCONTROL);
3154 keystate[VK_MENU] = CURRENT_STATE (VK_MENU);
3155 keystate[VK_LMENU] = CURRENT_STATE (VK_LMENU);
3156 keystate[VK_RMENU] = CURRENT_STATE (VK_RMENU);
3157 keystate[VK_LWIN] = CURRENT_STATE (VK_LWIN);
3158 keystate[VK_RWIN] = CURRENT_STATE (VK_RWIN);
3159 keystate[VK_APPS] = CURRENT_STATE (VK_APPS);
3160 SetKeyboardState (keystate);
3161 }
3162 }
3163
3164 /* Synchronize modifier state with what is reported with the current
3165 keystroke. Even if we cannot distinguish between left and right
3166 modifier keys, we know that, if no modifiers are set, then neither
3167 the left or right modifier should be set. */
3168 static void
3169 sync_modifiers ()
3170 {
3171 if (!modifiers_recorded)
3172 return;
3173
3174 if (!(GetKeyState (VK_CONTROL) & 0x8000))
3175 modifiers[EMACS_RCONTROL] = modifiers[EMACS_LCONTROL] = 0;
3176
3177 if (!(GetKeyState (VK_MENU) & 0x8000))
3178 modifiers[EMACS_RMENU] = modifiers[EMACS_LMENU] = 0;
3179 }
3180
3181 static int
3182 modifier_set (int vkey)
3183 {
3184 if (vkey == VK_CAPITAL || vkey == VK_SCROLL)
3185 return (GetKeyState (vkey) & 0x1);
3186 if (!modifiers_recorded)
3187 return (GetKeyState (vkey) & 0x8000);
3188
3189 switch (vkey)
3190 {
3191 case VK_LCONTROL:
3192 return modifiers[EMACS_LCONTROL];
3193 case VK_RCONTROL:
3194 return modifiers[EMACS_RCONTROL];
3195 case VK_LMENU:
3196 return modifiers[EMACS_LMENU];
3197 case VK_RMENU:
3198 return modifiers[EMACS_RMENU];
3199 }
3200 return (GetKeyState (vkey) & 0x8000);
3201 }
3202
3203 /* Convert between the modifier bits W32 uses and the modifier bits
3204 Emacs uses. */
3205
3206 unsigned int
3207 w32_key_to_modifier (int key)
3208 {
3209 Lisp_Object key_mapping;
3210
3211 switch (key)
3212 {
3213 case VK_LWIN:
3214 key_mapping = Vw32_lwindow_modifier;
3215 break;
3216 case VK_RWIN:
3217 key_mapping = Vw32_rwindow_modifier;
3218 break;
3219 case VK_APPS:
3220 key_mapping = Vw32_apps_modifier;
3221 break;
3222 case VK_SCROLL:
3223 key_mapping = Vw32_scroll_lock_modifier;
3224 break;
3225 default:
3226 key_mapping = Qnil;
3227 }
3228
3229 /* NB. This code runs in the input thread, asychronously to the lisp
3230 thread, so we must be careful to ensure access to lisp data is
3231 thread-safe. The following code is safe because the modifier
3232 variable values are updated atomically from lisp and symbols are
3233 not relocated by GC. Also, we don't have to worry about seeing GC
3234 markbits here. */
3235 if (EQ (key_mapping, Qhyper))
3236 return hyper_modifier;
3237 if (EQ (key_mapping, Qsuper))
3238 return super_modifier;
3239 if (EQ (key_mapping, Qmeta))
3240 return meta_modifier;
3241 if (EQ (key_mapping, Qalt))
3242 return alt_modifier;
3243 if (EQ (key_mapping, Qctrl))
3244 return ctrl_modifier;
3245 if (EQ (key_mapping, Qcontrol)) /* synonym for ctrl */
3246 return ctrl_modifier;
3247 if (EQ (key_mapping, Qshift))
3248 return shift_modifier;
3249
3250 /* Don't generate any modifier if not explicitly requested. */
3251 return 0;
3252 }
3253
3254 unsigned int
3255 w32_get_modifiers ()
3256 {
3257 return ((modifier_set (VK_SHIFT) ? shift_modifier : 0) |
3258 (modifier_set (VK_CONTROL) ? ctrl_modifier : 0) |
3259 (modifier_set (VK_LWIN) ? w32_key_to_modifier (VK_LWIN) : 0) |
3260 (modifier_set (VK_RWIN) ? w32_key_to_modifier (VK_RWIN) : 0) |
3261 (modifier_set (VK_APPS) ? w32_key_to_modifier (VK_APPS) : 0) |
3262 (modifier_set (VK_SCROLL) ? w32_key_to_modifier (VK_SCROLL) : 0) |
3263 (modifier_set (VK_MENU) ?
3264 ((NILP (Vw32_alt_is_meta)) ? alt_modifier : meta_modifier) : 0));
3265 }
3266
3267 /* We map the VK_* modifiers into console modifier constants
3268 so that we can use the same routines to handle both console
3269 and window input. */
3270
3271 static int
3272 construct_console_modifiers ()
3273 {
3274 int mods;
3275
3276 mods = 0;
3277 mods |= (modifier_set (VK_SHIFT)) ? SHIFT_PRESSED : 0;
3278 mods |= (modifier_set (VK_CAPITAL)) ? CAPSLOCK_ON : 0;
3279 mods |= (modifier_set (VK_SCROLL)) ? SCROLLLOCK_ON : 0;
3280 mods |= (modifier_set (VK_NUMLOCK)) ? NUMLOCK_ON : 0;
3281 mods |= (modifier_set (VK_LCONTROL)) ? LEFT_CTRL_PRESSED : 0;
3282 mods |= (modifier_set (VK_RCONTROL)) ? RIGHT_CTRL_PRESSED : 0;
3283 mods |= (modifier_set (VK_LMENU)) ? LEFT_ALT_PRESSED : 0;
3284 mods |= (modifier_set (VK_RMENU)) ? RIGHT_ALT_PRESSED : 0;
3285 mods |= (modifier_set (VK_LWIN)) ? LEFT_WIN_PRESSED : 0;
3286 mods |= (modifier_set (VK_RWIN)) ? RIGHT_WIN_PRESSED : 0;
3287 mods |= (modifier_set (VK_APPS)) ? APPS_PRESSED : 0;
3288
3289 return mods;
3290 }
3291
3292 static int
3293 w32_get_key_modifiers (unsigned int wparam, unsigned int lparam)
3294 {
3295 int mods;
3296
3297 /* Convert to emacs modifiers. */
3298 mods = w32_kbd_mods_to_emacs (construct_console_modifiers (), wparam);
3299
3300 return mods;
3301 }
3302
3303 unsigned int
3304 map_keypad_keys (unsigned int virt_key, unsigned int extended)
3305 {
3306 if (virt_key < VK_CLEAR || virt_key > VK_DELETE)
3307 return virt_key;
3308
3309 if (virt_key == VK_RETURN)
3310 return (extended ? VK_NUMPAD_ENTER : VK_RETURN);
3311
3312 if (virt_key >= VK_PRIOR && virt_key <= VK_DOWN)
3313 return (!extended ? (VK_NUMPAD_PRIOR + (virt_key - VK_PRIOR)) : virt_key);
3314
3315 if (virt_key == VK_INSERT || virt_key == VK_DELETE)
3316 return (!extended ? (VK_NUMPAD_INSERT + (virt_key - VK_INSERT)) : virt_key);
3317
3318 if (virt_key == VK_CLEAR)
3319 return (!extended ? VK_NUMPAD_CLEAR : virt_key);
3320
3321 return virt_key;
3322 }
3323
3324 /* List of special key combinations which w32 would normally capture,
3325 but emacs should grab instead. Not directly visible to lisp, to
3326 simplify synchronization. Each item is an integer encoding a virtual
3327 key code and modifier combination to capture. */
3328 Lisp_Object w32_grabbed_keys;
3329
3330 #define HOTKEY(vk,mods) make_number (((vk) & 255) | ((mods) << 8))
3331 #define HOTKEY_ID(k) (XFASTINT (k) & 0xbfff)
3332 #define HOTKEY_VK_CODE(k) (XFASTINT (k) & 255)
3333 #define HOTKEY_MODIFIERS(k) (XFASTINT (k) >> 8)
3334
3335 /* Register hot-keys for reserved key combinations when Emacs has
3336 keyboard focus, since this is the only way Emacs can receive key
3337 combinations like Alt-Tab which are used by the system. */
3338
3339 static void
3340 register_hot_keys (hwnd)
3341 HWND hwnd;
3342 {
3343 Lisp_Object keylist;
3344
3345 /* Use GC_CONSP, since we are called asynchronously. */
3346 for (keylist = w32_grabbed_keys; GC_CONSP (keylist); keylist = XCDR (keylist))
3347 {
3348 Lisp_Object key = XCAR (keylist);
3349
3350 /* Deleted entries get set to nil. */
3351 if (!INTEGERP (key))
3352 continue;
3353
3354 RegisterHotKey (hwnd, HOTKEY_ID (key),
3355 HOTKEY_MODIFIERS (key), HOTKEY_VK_CODE (key));
3356 }
3357 }
3358
3359 static void
3360 unregister_hot_keys (hwnd)
3361 HWND hwnd;
3362 {
3363 Lisp_Object keylist;
3364
3365 /* Use GC_CONSP, since we are called asynchronously. */
3366 for (keylist = w32_grabbed_keys; GC_CONSP (keylist); keylist = XCDR (keylist))
3367 {
3368 Lisp_Object key = XCAR (keylist);
3369
3370 if (!INTEGERP (key))
3371 continue;
3372
3373 UnregisterHotKey (hwnd, HOTKEY_ID (key));
3374 }
3375 }
3376
3377 /* Main message dispatch loop. */
3378
3379 static void
3380 w32_msg_pump (deferred_msg * msg_buf)
3381 {
3382 MSG msg;
3383 int result;
3384 HWND focus_window;
3385
3386 msh_mousewheel = RegisterWindowMessage (MSH_MOUSEWHEEL);
3387
3388 while (GetMessage (&msg, NULL, 0, 0))
3389 {
3390 if (msg.hwnd == NULL)
3391 {
3392 switch (msg.message)
3393 {
3394 case WM_NULL:
3395 /* Produced by complete_deferred_msg; just ignore. */
3396 break;
3397 case WM_EMACS_CREATEWINDOW:
3398 w32_createwindow ((struct frame *) msg.wParam);
3399 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
3400 abort ();
3401 break;
3402 case WM_EMACS_SETLOCALE:
3403 SetThreadLocale (msg.wParam);
3404 /* Reply is not expected. */
3405 break;
3406 case WM_EMACS_SETKEYBOARDLAYOUT:
3407 result = (int) ActivateKeyboardLayout ((HKL) msg.wParam, 0);
3408 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE,
3409 result, 0))
3410 abort ();
3411 break;
3412 case WM_EMACS_REGISTER_HOT_KEY:
3413 focus_window = GetFocus ();
3414 if (focus_window != NULL)
3415 RegisterHotKey (focus_window,
3416 HOTKEY_ID (msg.wParam),
3417 HOTKEY_MODIFIERS (msg.wParam),
3418 HOTKEY_VK_CODE (msg.wParam));
3419 /* Reply is not expected. */
3420 break;
3421 case WM_EMACS_UNREGISTER_HOT_KEY:
3422 focus_window = GetFocus ();
3423 if (focus_window != NULL)
3424 UnregisterHotKey (focus_window, HOTKEY_ID (msg.wParam));
3425 /* Mark item as erased. NB: this code must be
3426 thread-safe. The next line is okay because the cons
3427 cell is never made into garbage and is not relocated by
3428 GC. */
3429 XCAR ((Lisp_Object) msg.lParam) = Qnil;
3430 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
3431 abort ();
3432 break;
3433 case WM_EMACS_TOGGLE_LOCK_KEY:
3434 {
3435 int vk_code = (int) msg.wParam;
3436 int cur_state = (GetKeyState (vk_code) & 1);
3437 Lisp_Object new_state = (Lisp_Object) msg.lParam;
3438
3439 /* NB: This code must be thread-safe. It is safe to
3440 call NILP because symbols are not relocated by GC,
3441 and pointer here is not touched by GC (so the markbit
3442 can't be set). Numbers are safe because they are
3443 immediate values. */
3444 if (NILP (new_state)
3445 || (NUMBERP (new_state)
3446 && (XUINT (new_state)) & 1 != cur_state))
3447 {
3448 one_w32_display_info.faked_key = vk_code;
3449
3450 keybd_event ((BYTE) vk_code,
3451 (BYTE) MapVirtualKey (vk_code, 0),
3452 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
3453 keybd_event ((BYTE) vk_code,
3454 (BYTE) MapVirtualKey (vk_code, 0),
3455 KEYEVENTF_EXTENDEDKEY | 0, 0);
3456 keybd_event ((BYTE) vk_code,
3457 (BYTE) MapVirtualKey (vk_code, 0),
3458 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
3459 cur_state = !cur_state;
3460 }
3461 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE,
3462 cur_state, 0))
3463 abort ();
3464 }
3465 break;
3466 default:
3467 DebPrint (("msg %x not expected by w32_msg_pump\n", msg.message));
3468 }
3469 }
3470 else
3471 {
3472 DispatchMessage (&msg);
3473 }
3474
3475 /* Exit nested loop when our deferred message has completed. */
3476 if (msg_buf->completed)
3477 break;
3478 }
3479 }
3480
3481 deferred_msg * deferred_msg_head;
3482
3483 static deferred_msg *
3484 find_deferred_msg (HWND hwnd, UINT msg)
3485 {
3486 deferred_msg * item;
3487
3488 /* Don't actually need synchronization for read access, since
3489 modification of single pointer is always atomic. */
3490 /* enter_crit (); */
3491
3492 for (item = deferred_msg_head; item != NULL; item = item->next)
3493 if (item->w32msg.msg.hwnd == hwnd
3494 && item->w32msg.msg.message == msg)
3495 break;
3496
3497 /* leave_crit (); */
3498
3499 return item;
3500 }
3501
3502 static LRESULT
3503 send_deferred_msg (deferred_msg * msg_buf,
3504 HWND hwnd,
3505 UINT msg,
3506 WPARAM wParam,
3507 LPARAM lParam)
3508 {
3509 /* Only input thread can send deferred messages. */
3510 if (GetCurrentThreadId () != dwWindowsThreadId)
3511 abort ();
3512
3513 /* It is an error to send a message that is already deferred. */
3514 if (find_deferred_msg (hwnd, msg) != NULL)
3515 abort ();
3516
3517 /* Enforced synchronization is not needed because this is the only
3518 function that alters deferred_msg_head, and the following critical
3519 section is guaranteed to only be serially reentered (since only the
3520 input thread can call us). */
3521
3522 /* enter_crit (); */
3523
3524 msg_buf->completed = 0;
3525 msg_buf->next = deferred_msg_head;
3526 deferred_msg_head = msg_buf;
3527 my_post_msg (&msg_buf->w32msg, hwnd, msg, wParam, lParam);
3528
3529 /* leave_crit (); */
3530
3531 /* Start a new nested message loop to process other messages until
3532 this one is completed. */
3533 w32_msg_pump (msg_buf);
3534
3535 deferred_msg_head = msg_buf->next;
3536
3537 return msg_buf->result;
3538 }
3539
3540 void
3541 complete_deferred_msg (HWND hwnd, UINT msg, LRESULT result)
3542 {
3543 deferred_msg * msg_buf = find_deferred_msg (hwnd, msg);
3544
3545 if (msg_buf == NULL)
3546 /* Message may have been cancelled, so don't abort(). */
3547 return;
3548
3549 msg_buf->result = result;
3550 msg_buf->completed = 1;
3551
3552 /* Ensure input thread is woken so it notices the completion. */
3553 PostThreadMessage (dwWindowsThreadId, WM_NULL, 0, 0);
3554 }
3555
3556 void
3557 cancel_all_deferred_msgs ()
3558 {
3559 deferred_msg * item;
3560
3561 /* Don't actually need synchronization for read access, since
3562 modification of single pointer is always atomic. */
3563 /* enter_crit (); */
3564
3565 for (item = deferred_msg_head; item != NULL; item = item->next)
3566 {
3567 item->result = 0;
3568 item->completed = 1;
3569 }
3570
3571 /* leave_crit (); */
3572
3573 /* Ensure input thread is woken so it notices the completion. */
3574 PostThreadMessage (dwWindowsThreadId, WM_NULL, 0, 0);
3575 }
3576
3577 DWORD
3578 w32_msg_worker (dw)
3579 DWORD dw;
3580 {
3581 MSG msg;
3582 deferred_msg dummy_buf;
3583
3584 /* Ensure our message queue is created */
3585
3586 PeekMessage (&msg, NULL, 0, 0, PM_NOREMOVE);
3587
3588 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
3589 abort ();
3590
3591 memset (&dummy_buf, 0, sizeof (dummy_buf));
3592 dummy_buf.w32msg.msg.hwnd = NULL;
3593 dummy_buf.w32msg.msg.message = WM_NULL;
3594
3595 /* This is the inital message loop which should only exit when the
3596 application quits. */
3597 w32_msg_pump (&dummy_buf);
3598
3599 return 0;
3600 }
3601
3602 static void
3603 post_character_message (hwnd, msg, wParam, lParam, modifiers)
3604 HWND hwnd;
3605 UINT msg;
3606 WPARAM wParam;
3607 LPARAM lParam;
3608 DWORD modifiers;
3609
3610 {
3611 W32Msg wmsg;
3612
3613 wmsg.dwModifiers = modifiers;
3614
3615 /* Detect quit_char and set quit-flag directly. Note that we
3616 still need to post a message to ensure the main thread will be
3617 woken up if blocked in sys_select(), but we do NOT want to post
3618 the quit_char message itself (because it will usually be as if
3619 the user had typed quit_char twice). Instead, we post a dummy
3620 message that has no particular effect. */
3621 {
3622 int c = wParam;
3623 if (isalpha (c) && wmsg.dwModifiers == ctrl_modifier)
3624 c = make_ctrl_char (c) & 0377;
3625 if (c == quit_char
3626 || (wmsg.dwModifiers == 0 &&
3627 XFASTINT (Vw32_quit_key) && wParam == XFASTINT (Vw32_quit_key)))
3628 {
3629 Vquit_flag = Qt;
3630
3631 /* The choice of message is somewhat arbitrary, as long as
3632 the main thread handler just ignores it. */
3633 msg = WM_NULL;
3634
3635 /* Interrupt any blocking system calls. */
3636 signal_quit ();
3637
3638 /* As a safety precaution, forcibly complete any deferred
3639 messages. This is a kludge, but I don't see any particularly
3640 clean way to handle the situation where a deferred message is
3641 "dropped" in the lisp thread, and will thus never be
3642 completed, eg. by the user trying to activate the menubar
3643 when the lisp thread is busy, and then typing C-g when the
3644 menubar doesn't open promptly (with the result that the
3645 menubar never responds at all because the deferred
3646 WM_INITMENU message is never completed). Another problem
3647 situation is when the lisp thread calls SendMessage (to send
3648 a window manager command) when a message has been deferred;
3649 the lisp thread gets blocked indefinitely waiting for the
3650 deferred message to be completed, which itself is waiting for
3651 the lisp thread to respond.
3652
3653 Note that we don't want to block the input thread waiting for
3654 a reponse from the lisp thread (although that would at least
3655 solve the deadlock problem above), because we want to be able
3656 to receive C-g to interrupt the lisp thread. */
3657 cancel_all_deferred_msgs ();
3658 }
3659 }
3660
3661 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3662 }
3663
3664 /* Main window procedure */
3665
3666 LRESULT CALLBACK
3667 w32_wnd_proc (hwnd, msg, wParam, lParam)
3668 HWND hwnd;
3669 UINT msg;
3670 WPARAM wParam;
3671 LPARAM lParam;
3672 {
3673 struct frame *f;
3674 struct w32_display_info *dpyinfo = &one_w32_display_info;
3675 W32Msg wmsg;
3676 int windows_translate;
3677 int key;
3678
3679 /* Note that it is okay to call x_window_to_frame, even though we are
3680 not running in the main lisp thread, because frame deletion
3681 requires the lisp thread to synchronize with this thread. Thus, if
3682 a frame struct is returned, it can be used without concern that the
3683 lisp thread might make it disappear while we are using it.
3684
3685 NB. Walking the frame list in this thread is safe (as long as
3686 writes of Lisp_Object slots are atomic, which they are on Windows).
3687 Although delete-frame can destructively modify the frame list while
3688 we are walking it, a garbage collection cannot occur until after
3689 delete-frame has synchronized with this thread.
3690
3691 It is also safe to use functions that make GDI calls, such as
3692 w32_clear_rect, because these functions must obtain a DC handle
3693 from the frame struct using get_frame_dc which is thread-aware. */
3694
3695 switch (msg)
3696 {
3697 case WM_ERASEBKGND:
3698 f = x_window_to_frame (dpyinfo, hwnd);
3699 if (f)
3700 {
3701 GetUpdateRect (hwnd, &wmsg.rect, FALSE);
3702 w32_clear_rect (f, NULL, &wmsg.rect);
3703 }
3704 return 1;
3705 case WM_PALETTECHANGED:
3706 /* ignore our own changes */
3707 if ((HWND)wParam != hwnd)
3708 {
3709 f = x_window_to_frame (dpyinfo, hwnd);
3710 if (f)
3711 /* get_frame_dc will realize our palette and force all
3712 frames to be redrawn if needed. */
3713 release_frame_dc (f, get_frame_dc (f));
3714 }
3715 return 0;
3716 case WM_PAINT:
3717 {
3718 PAINTSTRUCT paintStruct;
3719
3720 enter_crit ();
3721 BeginPaint (hwnd, &paintStruct);
3722 wmsg.rect = paintStruct.rcPaint;
3723 EndPaint (hwnd, &paintStruct);
3724 leave_crit ();
3725
3726 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3727
3728 return (0);
3729 }
3730
3731 case WM_INPUTLANGCHANGE:
3732 /* Inform lisp thread of keyboard layout changes. */
3733 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3734
3735 /* Clear dead keys in the keyboard state; for simplicity only
3736 preserve modifier key states. */
3737 {
3738 int i;
3739 BYTE keystate[256];
3740
3741 GetKeyboardState (keystate);
3742 for (i = 0; i < 256; i++)
3743 if (1
3744 && i != VK_SHIFT
3745 && i != VK_LSHIFT
3746 && i != VK_RSHIFT
3747 && i != VK_CAPITAL
3748 && i != VK_NUMLOCK
3749 && i != VK_SCROLL
3750 && i != VK_CONTROL
3751 && i != VK_LCONTROL
3752 && i != VK_RCONTROL
3753 && i != VK_MENU
3754 && i != VK_LMENU
3755 && i != VK_RMENU
3756 && i != VK_LWIN
3757 && i != VK_RWIN)
3758 keystate[i] = 0;
3759 SetKeyboardState (keystate);
3760 }
3761 goto dflt;
3762
3763 case WM_HOTKEY:
3764 /* Synchronize hot keys with normal input. */
3765 PostMessage (hwnd, WM_KEYDOWN, HIWORD (lParam), 0);
3766 return (0);
3767
3768 case WM_KEYUP:
3769 case WM_SYSKEYUP:
3770 record_keyup (wParam, lParam);
3771 goto dflt;
3772
3773 case WM_KEYDOWN:
3774 case WM_SYSKEYDOWN:
3775 /* Ignore keystrokes we fake ourself; see below. */
3776 if (dpyinfo->faked_key == wParam)
3777 {
3778 dpyinfo->faked_key = 0;
3779 /* Make sure TranslateMessage sees them though (as long as
3780 they don't produce WM_CHAR messages). This ensures that
3781 indicator lights are toggled promptly on Windows 9x, for
3782 example. */
3783 if (lispy_function_keys[wParam] != 0)
3784 {
3785 windows_translate = 1;
3786 goto translate;
3787 }
3788 return 0;
3789 }
3790
3791 /* Synchronize modifiers with current keystroke. */
3792 sync_modifiers ();
3793 record_keydown (wParam, lParam);
3794 wParam = map_keypad_keys (wParam, (lParam & 0x1000000L) != 0);
3795
3796 windows_translate = 0;
3797
3798 switch (wParam)
3799 {
3800 case VK_LWIN:
3801 if (NILP (Vw32_pass_lwindow_to_system))
3802 {
3803 /* Prevent system from acting on keyup (which opens the
3804 Start menu if no other key was pressed) by simulating a
3805 press of Space which we will ignore. */
3806 if (GetAsyncKeyState (wParam) & 1)
3807 {
3808 if (NUMBERP (Vw32_phantom_key_code))
3809 key = XUINT (Vw32_phantom_key_code) & 255;
3810 else
3811 key = VK_SPACE;
3812 dpyinfo->faked_key = key;
3813 keybd_event (key, (BYTE) MapVirtualKey (key, 0), 0, 0);
3814 }
3815 }
3816 if (!NILP (Vw32_lwindow_modifier))
3817 return 0;
3818 break;
3819 case VK_RWIN:
3820 if (NILP (Vw32_pass_rwindow_to_system))
3821 {
3822 if (GetAsyncKeyState (wParam) & 1)
3823 {
3824 if (NUMBERP (Vw32_phantom_key_code))
3825 key = XUINT (Vw32_phantom_key_code) & 255;
3826 else
3827 key = VK_SPACE;
3828 dpyinfo->faked_key = key;
3829 keybd_event (key, (BYTE) MapVirtualKey (key, 0), 0, 0);
3830 }
3831 }
3832 if (!NILP (Vw32_rwindow_modifier))
3833 return 0;
3834 break;
3835 case VK_APPS:
3836 if (!NILP (Vw32_apps_modifier))
3837 return 0;
3838 break;
3839 case VK_MENU:
3840 if (NILP (Vw32_pass_alt_to_system))
3841 /* Prevent DefWindowProc from activating the menu bar if an
3842 Alt key is pressed and released by itself. */
3843 return 0;
3844 windows_translate = 1;
3845 break;
3846 case VK_CAPITAL:
3847 /* Decide whether to treat as modifier or function key. */
3848 if (NILP (Vw32_enable_caps_lock))
3849 goto disable_lock_key;
3850 windows_translate = 1;
3851 break;
3852 case VK_NUMLOCK:
3853 /* Decide whether to treat as modifier or function key. */
3854 if (NILP (Vw32_enable_num_lock))
3855 goto disable_lock_key;
3856 windows_translate = 1;
3857 break;
3858 case VK_SCROLL:
3859 /* Decide whether to treat as modifier or function key. */
3860 if (NILP (Vw32_scroll_lock_modifier))
3861 goto disable_lock_key;
3862 windows_translate = 1;
3863 break;
3864 disable_lock_key:
3865 /* Ensure the appropriate lock key state (and indicator light)
3866 remains in the same state. We do this by faking another
3867 press of the relevant key. Apparently, this really is the
3868 only way to toggle the state of the indicator lights. */
3869 dpyinfo->faked_key = wParam;
3870 keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0),
3871 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
3872 keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0),
3873 KEYEVENTF_EXTENDEDKEY | 0, 0);
3874 keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0),
3875 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
3876 /* Ensure indicator lights are updated promptly on Windows 9x
3877 (TranslateMessage apparently does this), after forwarding
3878 input event. */
3879 post_character_message (hwnd, msg, wParam, lParam,
3880 w32_get_key_modifiers (wParam, lParam));
3881 windows_translate = 1;
3882 break;
3883 case VK_CONTROL:
3884 case VK_SHIFT:
3885 case VK_PROCESSKEY: /* Generated by IME. */
3886 windows_translate = 1;
3887 break;
3888 case VK_CANCEL:
3889 /* Windows maps Ctrl-Pause (aka Ctrl-Break) into VK_CANCEL,
3890 which is confusing for purposes of key binding; convert
3891 VK_CANCEL events into VK_PAUSE events. */
3892 wParam = VK_PAUSE;
3893 break;
3894 case VK_PAUSE:
3895 /* Windows maps Ctrl-NumLock into VK_PAUSE, which is confusing
3896 for purposes of key binding; convert these back into
3897 VK_NUMLOCK events, at least when we want to see NumLock key
3898 presses. (Note that there is never any possibility that
3899 VK_PAUSE with Ctrl really is C-Pause as per above.) */
3900 if (NILP (Vw32_enable_num_lock) && modifier_set (VK_CONTROL))
3901 wParam = VK_NUMLOCK;
3902 break;
3903 default:
3904 /* If not defined as a function key, change it to a WM_CHAR message. */
3905 if (lispy_function_keys[wParam] == 0)
3906 {
3907 DWORD modifiers = construct_console_modifiers ();
3908
3909 if (!NILP (Vw32_recognize_altgr)
3910 && modifier_set (VK_LCONTROL) && modifier_set (VK_RMENU))
3911 {
3912 /* Always let TranslateMessage handle AltGr key chords;
3913 for some reason, ToAscii doesn't always process AltGr
3914 chords correctly. */
3915 windows_translate = 1;
3916 }
3917 else if ((modifiers & (~SHIFT_PRESSED & ~CAPSLOCK_ON)) != 0)
3918 {
3919 /* Handle key chords including any modifiers other
3920 than shift directly, in order to preserve as much
3921 modifier information as possible. */
3922 if ('A' <= wParam && wParam <= 'Z')
3923 {
3924 /* Don't translate modified alphabetic keystrokes,
3925 so the user doesn't need to constantly switch
3926 layout to type control or meta keystrokes when
3927 the normal layout translates alphabetic
3928 characters to non-ascii characters. */
3929 if (!modifier_set (VK_SHIFT))
3930 wParam += ('a' - 'A');
3931 msg = WM_CHAR;
3932 }
3933 else
3934 {
3935 /* Try to handle other keystrokes by determining the
3936 base character (ie. translating the base key plus
3937 shift modifier). */
3938 int add;
3939 int isdead = 0;
3940 KEY_EVENT_RECORD key;
3941
3942 key.bKeyDown = TRUE;
3943 key.wRepeatCount = 1;
3944 key.wVirtualKeyCode = wParam;
3945 key.wVirtualScanCode = (lParam & 0xFF0000) >> 16;
3946 key.uChar.AsciiChar = 0;
3947 key.dwControlKeyState = modifiers;
3948
3949 add = w32_kbd_patch_key (&key);
3950 /* 0 means an unrecognised keycode, negative means
3951 dead key. Ignore both. */
3952 while (--add >= 0)
3953 {
3954 /* Forward asciified character sequence. */
3955 post_character_message
3956 (hwnd, WM_CHAR, key.uChar.AsciiChar, lParam,
3957 w32_get_key_modifiers (wParam, lParam));
3958 w32_kbd_patch_key (&key);
3959 }
3960 return 0;
3961 }
3962 }
3963 else
3964 {
3965 /* Let TranslateMessage handle everything else. */
3966 windows_translate = 1;
3967 }
3968 }
3969 }
3970
3971 translate:
3972 if (windows_translate)
3973 {
3974 MSG windows_msg = { hwnd, msg, wParam, lParam, 0, {0,0} };
3975
3976 windows_msg.time = GetMessageTime ();
3977 TranslateMessage (&windows_msg);
3978 goto dflt;
3979 }
3980
3981 /* Fall through */
3982
3983 case WM_SYSCHAR:
3984 case WM_CHAR:
3985 post_character_message (hwnd, msg, wParam, lParam,
3986 w32_get_key_modifiers (wParam, lParam));
3987 break;
3988
3989 /* Simulate middle mouse button events when left and right buttons
3990 are used together, but only if user has two button mouse. */
3991 case WM_LBUTTONDOWN:
3992 case WM_RBUTTONDOWN:
3993 if (XINT (Vw32_num_mouse_buttons) == 3)
3994 goto handle_plain_button;
3995
3996 {
3997 int this = (msg == WM_LBUTTONDOWN) ? LMOUSE : RMOUSE;
3998 int other = (msg == WM_LBUTTONDOWN) ? RMOUSE : LMOUSE;
3999
4000 if (button_state & this)
4001 return 0;
4002
4003 if (button_state == 0)
4004 SetCapture (hwnd);
4005
4006 button_state |= this;
4007
4008 if (button_state & other)
4009 {
4010 if (mouse_button_timer)
4011 {
4012 KillTimer (hwnd, mouse_button_timer);
4013 mouse_button_timer = 0;
4014
4015 /* Generate middle mouse event instead. */
4016 msg = WM_MBUTTONDOWN;
4017 button_state |= MMOUSE;
4018 }
4019 else if (button_state & MMOUSE)
4020 {
4021 /* Ignore button event if we've already generated a
4022 middle mouse down event. This happens if the
4023 user releases and press one of the two buttons
4024 after we've faked a middle mouse event. */
4025 return 0;
4026 }
4027 else
4028 {
4029 /* Flush out saved message. */
4030 post_msg (&saved_mouse_button_msg);
4031 }
4032 wmsg.dwModifiers = w32_get_modifiers ();
4033 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4034
4035 /* Clear message buffer. */
4036 saved_mouse_button_msg.msg.hwnd = 0;
4037 }
4038 else
4039 {
4040 /* Hold onto message for now. */
4041 mouse_button_timer =
4042 SetTimer (hwnd, MOUSE_BUTTON_ID,
4043 XINT (Vw32_mouse_button_tolerance), NULL);
4044 saved_mouse_button_msg.msg.hwnd = hwnd;
4045 saved_mouse_button_msg.msg.message = msg;
4046 saved_mouse_button_msg.msg.wParam = wParam;
4047 saved_mouse_button_msg.msg.lParam = lParam;
4048 saved_mouse_button_msg.msg.time = GetMessageTime ();
4049 saved_mouse_button_msg.dwModifiers = w32_get_modifiers ();
4050 }
4051 }
4052 return 0;
4053
4054 case WM_LBUTTONUP:
4055 case WM_RBUTTONUP:
4056 if (XINT (Vw32_num_mouse_buttons) == 3)
4057 goto handle_plain_button;
4058
4059 {
4060 int this = (msg == WM_LBUTTONUP) ? LMOUSE : RMOUSE;
4061 int other = (msg == WM_LBUTTONUP) ? RMOUSE : LMOUSE;
4062
4063 if ((button_state & this) == 0)
4064 return 0;
4065
4066 button_state &= ~this;
4067
4068 if (button_state & MMOUSE)
4069 {
4070 /* Only generate event when second button is released. */
4071 if ((button_state & other) == 0)
4072 {
4073 msg = WM_MBUTTONUP;
4074 button_state &= ~MMOUSE;
4075
4076 if (button_state) abort ();
4077 }
4078 else
4079 return 0;
4080 }
4081 else
4082 {
4083 /* Flush out saved message if necessary. */
4084 if (saved_mouse_button_msg.msg.hwnd)
4085 {
4086 post_msg (&saved_mouse_button_msg);
4087 }
4088 }
4089 wmsg.dwModifiers = w32_get_modifiers ();
4090 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4091
4092 /* Always clear message buffer and cancel timer. */
4093 saved_mouse_button_msg.msg.hwnd = 0;
4094 KillTimer (hwnd, mouse_button_timer);
4095 mouse_button_timer = 0;
4096
4097 if (button_state == 0)
4098 ReleaseCapture ();
4099 }
4100 return 0;
4101
4102 case WM_MBUTTONDOWN:
4103 case WM_MBUTTONUP:
4104 handle_plain_button:
4105 {
4106 BOOL up;
4107 int button;
4108
4109 if (parse_button (msg, &button, &up))
4110 {
4111 if (up) ReleaseCapture ();
4112 else SetCapture (hwnd);
4113 button = (button == 0) ? LMOUSE :
4114 ((button == 1) ? MMOUSE : RMOUSE);
4115 if (up)
4116 button_state &= ~button;
4117 else
4118 button_state |= button;
4119 }
4120 }
4121
4122 wmsg.dwModifiers = w32_get_modifiers ();
4123 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4124 return 0;
4125
4126 case WM_VSCROLL:
4127 case WM_MOUSEMOVE:
4128 if (XINT (Vw32_mouse_move_interval) <= 0
4129 || (msg == WM_MOUSEMOVE && button_state == 0))
4130 {
4131 wmsg.dwModifiers = w32_get_modifiers ();
4132 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4133 return 0;
4134 }
4135
4136 /* Hang onto mouse move and scroll messages for a bit, to avoid
4137 sending such events to Emacs faster than it can process them.
4138 If we get more events before the timer from the first message
4139 expires, we just replace the first message. */
4140
4141 if (saved_mouse_move_msg.msg.hwnd == 0)
4142 mouse_move_timer =
4143 SetTimer (hwnd, MOUSE_MOVE_ID,
4144 XINT (Vw32_mouse_move_interval), NULL);
4145
4146 /* Hold onto message for now. */
4147 saved_mouse_move_msg.msg.hwnd = hwnd;
4148 saved_mouse_move_msg.msg.message = msg;
4149 saved_mouse_move_msg.msg.wParam = wParam;
4150 saved_mouse_move_msg.msg.lParam = lParam;
4151 saved_mouse_move_msg.msg.time = GetMessageTime ();
4152 saved_mouse_move_msg.dwModifiers = w32_get_modifiers ();
4153
4154 return 0;
4155
4156 case WM_MOUSEWHEEL:
4157 wmsg.dwModifiers = w32_get_modifiers ();
4158 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4159 return 0;
4160
4161 case WM_DROPFILES:
4162 wmsg.dwModifiers = w32_get_modifiers ();
4163 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4164 return 0;
4165
4166 case WM_TIMER:
4167 /* Flush out saved messages if necessary. */
4168 if (wParam == mouse_button_timer)
4169 {
4170 if (saved_mouse_button_msg.msg.hwnd)
4171 {
4172 post_msg (&saved_mouse_button_msg);
4173 saved_mouse_button_msg.msg.hwnd = 0;
4174 }
4175 KillTimer (hwnd, mouse_button_timer);
4176 mouse_button_timer = 0;
4177 }
4178 else if (wParam == mouse_move_timer)
4179 {
4180 if (saved_mouse_move_msg.msg.hwnd)
4181 {
4182 post_msg (&saved_mouse_move_msg);
4183 saved_mouse_move_msg.msg.hwnd = 0;
4184 }
4185 KillTimer (hwnd, mouse_move_timer);
4186 mouse_move_timer = 0;
4187 }
4188 return 0;
4189
4190 case WM_NCACTIVATE:
4191 /* Windows doesn't send us focus messages when putting up and
4192 taking down a system popup dialog as for Ctrl-Alt-Del on Windows 95.
4193 The only indication we get that something happened is receiving
4194 this message afterwards. So this is a good time to reset our
4195 keyboard modifiers' state. */
4196 reset_modifiers ();
4197 goto dflt;
4198
4199 case WM_INITMENU:
4200 /* We must ensure menu bar is fully constructed and up to date
4201 before allowing user interaction with it. To achieve this
4202 we send this message to the lisp thread and wait for a
4203 reply (whose value is not actually needed) to indicate that
4204 the menu bar is now ready for use, so we can now return.
4205
4206 To remain responsive in the meantime, we enter a nested message
4207 loop that can process all other messages.
4208
4209 However, we skip all this if the message results from calling
4210 TrackPopupMenu - in fact, we must NOT attempt to send the lisp
4211 thread a message because it is blocked on us at this point. We
4212 set menubar_active before calling TrackPopupMenu to indicate
4213 this (there is no possibility of confusion with real menubar
4214 being active). */
4215
4216 f = x_window_to_frame (dpyinfo, hwnd);
4217 if (f
4218 && (f->output_data.w32->menubar_active
4219 /* We can receive this message even in the absence of a
4220 menubar (ie. when the system menu is activated) - in this
4221 case we do NOT want to forward the message, otherwise it
4222 will cause the menubar to suddenly appear when the user
4223 had requested it to be turned off! */
4224 || f->output_data.w32->menubar_widget == NULL))
4225 return 0;
4226
4227 {
4228 deferred_msg msg_buf;
4229
4230 /* Detect if message has already been deferred; in this case
4231 we cannot return any sensible value to ignore this. */
4232 if (find_deferred_msg (hwnd, msg) != NULL)
4233 abort ();
4234
4235 return send_deferred_msg (&msg_buf, hwnd, msg, wParam, lParam);
4236 }
4237
4238 case WM_EXITMENULOOP:
4239 f = x_window_to_frame (dpyinfo, hwnd);
4240
4241 /* Indicate that menubar can be modified again. */
4242 if (f)
4243 f->output_data.w32->menubar_active = 0;
4244 goto dflt;
4245
4246 case WM_MEASUREITEM:
4247 f = x_window_to_frame (dpyinfo, hwnd);
4248 if (f)
4249 {
4250 MEASUREITEMSTRUCT * pMis = (MEASUREITEMSTRUCT *) lParam;
4251
4252 if (pMis->CtlType == ODT_MENU)
4253 {
4254 /* Work out dimensions for popup menu titles. */
4255 char * title = (char *) pMis->itemData;
4256 HDC hdc = GetDC (hwnd);
4257 HFONT menu_font = GetCurrentObject (hdc, OBJ_FONT);
4258 LOGFONT menu_logfont;
4259 HFONT old_font;
4260 SIZE size;
4261
4262 GetObject (menu_font, sizeof (menu_logfont), &menu_logfont);
4263 menu_logfont.lfWeight = FW_BOLD;
4264 menu_font = CreateFontIndirect (&menu_logfont);
4265 old_font = SelectObject (hdc, menu_font);
4266
4267 GetTextExtentPoint32 (hdc, title, strlen (title), &size);
4268 pMis->itemWidth = size.cx;
4269 pMis->itemHeight = GetSystemMetrics (SM_CYMENUSIZE);
4270 if (pMis->itemHeight < size.cy)
4271 pMis->itemHeight = size.cy;
4272
4273 SelectObject (hdc, old_font);
4274 DeleteObject (menu_font);
4275 ReleaseDC (hwnd, hdc);
4276 return TRUE;
4277 }
4278 }
4279 return 0;
4280
4281 case WM_DRAWITEM:
4282 f = x_window_to_frame (dpyinfo, hwnd);
4283 if (f)
4284 {
4285 DRAWITEMSTRUCT * pDis = (DRAWITEMSTRUCT *) lParam;
4286
4287 if (pDis->CtlType == ODT_MENU)
4288 {
4289 /* Draw popup menu title. */
4290 char * title = (char *) pDis->itemData;
4291 HDC hdc = pDis->hDC;
4292 HFONT menu_font = GetCurrentObject (hdc, OBJ_FONT);
4293 LOGFONT menu_logfont;
4294 HFONT old_font;
4295
4296 GetObject (menu_font, sizeof (menu_logfont), &menu_logfont);
4297 menu_logfont.lfWeight = FW_BOLD;
4298 menu_font = CreateFontIndirect (&menu_logfont);
4299 old_font = SelectObject (hdc, menu_font);
4300
4301 /* Always draw title as if not selected. */
4302 ExtTextOut (hdc,
4303 pDis->rcItem.left + GetSystemMetrics (SM_CXMENUCHECK),
4304 pDis->rcItem.top,
4305 ETO_OPAQUE, &pDis->rcItem,
4306 title, strlen (title), NULL);
4307
4308 SelectObject (hdc, old_font);
4309 DeleteObject (menu_font);
4310 return TRUE;
4311 }
4312 }
4313 return 0;
4314
4315 #if 0
4316 /* Still not right - can't distinguish between clicks in the
4317 client area of the frame from clicks forwarded from the scroll
4318 bars - may have to hook WM_NCHITTEST to remember the mouse
4319 position and then check if it is in the client area ourselves. */
4320 case WM_MOUSEACTIVATE:
4321 /* Discard the mouse click that activates a frame, allowing the
4322 user to click anywhere without changing point (or worse!).
4323 Don't eat mouse clicks on scrollbars though!! */
4324 if (LOWORD (lParam) == HTCLIENT )
4325 return MA_ACTIVATEANDEAT;
4326 goto dflt;
4327 #endif
4328
4329 case WM_ACTIVATEAPP:
4330 case WM_ACTIVATE:
4331 case WM_WINDOWPOSCHANGED:
4332 case WM_SHOWWINDOW:
4333 /* Inform lisp thread that a frame might have just been obscured
4334 or exposed, so should recheck visibility of all frames. */
4335 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4336 goto dflt;
4337
4338 case WM_SETFOCUS:
4339 dpyinfo->faked_key = 0;
4340 reset_modifiers ();
4341 register_hot_keys (hwnd);
4342 goto command;
4343 case WM_KILLFOCUS:
4344 unregister_hot_keys (hwnd);
4345 case WM_MOVE:
4346 case WM_SIZE:
4347 case WM_COMMAND:
4348 command:
4349 wmsg.dwModifiers = w32_get_modifiers ();
4350 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4351 goto dflt;
4352
4353 case WM_CLOSE:
4354 wmsg.dwModifiers = w32_get_modifiers ();
4355 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4356 return 0;
4357
4358 case WM_WINDOWPOSCHANGING:
4359 {
4360 WINDOWPLACEMENT wp;
4361 LPWINDOWPOS lppos = (WINDOWPOS *) lParam;
4362
4363 wp.length = sizeof (WINDOWPLACEMENT);
4364 GetWindowPlacement (hwnd, &wp);
4365
4366 if (wp.showCmd != SW_SHOWMINIMIZED && (lppos->flags & SWP_NOSIZE) == 0)
4367 {
4368 RECT rect;
4369 int wdiff;
4370 int hdiff;
4371 DWORD font_width;
4372 DWORD line_height;
4373 DWORD internal_border;
4374 DWORD scrollbar_extra;
4375 RECT wr;
4376
4377 wp.length = sizeof(wp);
4378 GetWindowRect (hwnd, &wr);
4379
4380 enter_crit ();
4381
4382 font_width = GetWindowLong (hwnd, WND_FONTWIDTH_INDEX);
4383 line_height = GetWindowLong (hwnd, WND_LINEHEIGHT_INDEX);
4384 internal_border = GetWindowLong (hwnd, WND_BORDER_INDEX);
4385 scrollbar_extra = GetWindowLong (hwnd, WND_SCROLLBAR_INDEX);
4386
4387 leave_crit ();
4388
4389 memset (&rect, 0, sizeof (rect));
4390 AdjustWindowRect (&rect, GetWindowLong (hwnd, GWL_STYLE),
4391 GetMenu (hwnd) != NULL);
4392
4393 /* Force width and height of client area to be exact
4394 multiples of the character cell dimensions. */
4395 wdiff = (lppos->cx - (rect.right - rect.left)
4396 - 2 * internal_border - scrollbar_extra)
4397 % font_width;
4398 hdiff = (lppos->cy - (rect.bottom - rect.top)
4399 - 2 * internal_border)
4400 % line_height;
4401
4402 if (wdiff || hdiff)
4403 {
4404 /* For right/bottom sizing we can just fix the sizes.
4405 However for top/left sizing we will need to fix the X
4406 and Y positions as well. */
4407
4408 lppos->cx -= wdiff;
4409 lppos->cy -= hdiff;
4410
4411 if (wp.showCmd != SW_SHOWMAXIMIZED
4412 && (lppos->flags & SWP_NOMOVE) == 0)
4413 {
4414 if (lppos->x != wr.left || lppos->y != wr.top)
4415 {
4416 lppos->x += wdiff;
4417 lppos->y += hdiff;
4418 }
4419 else
4420 {
4421 lppos->flags |= SWP_NOMOVE;
4422 }
4423 }
4424
4425 return 0;
4426 }
4427 }
4428 }
4429
4430 goto dflt;
4431
4432 case WM_EMACS_CREATESCROLLBAR:
4433 return (LRESULT) w32_createscrollbar ((struct frame *) wParam,
4434 (struct scroll_bar *) lParam);
4435
4436 case WM_EMACS_SHOWWINDOW:
4437 return ShowWindow ((HWND) wParam, (WPARAM) lParam);
4438
4439 case WM_EMACS_SETFOREGROUND:
4440 return SetForegroundWindow ((HWND) wParam);
4441
4442 case WM_EMACS_SETWINDOWPOS:
4443 {
4444 WINDOWPOS * pos = (WINDOWPOS *) wParam;
4445 return SetWindowPos (hwnd, pos->hwndInsertAfter,
4446 pos->x, pos->y, pos->cx, pos->cy, pos->flags);
4447 }
4448
4449 case WM_EMACS_DESTROYWINDOW:
4450 DragAcceptFiles ((HWND) wParam, FALSE);
4451 return DestroyWindow ((HWND) wParam);
4452
4453 case WM_EMACS_TRACKPOPUPMENU:
4454 {
4455 UINT flags;
4456 POINT *pos;
4457 int retval;
4458 pos = (POINT *)lParam;
4459 flags = TPM_CENTERALIGN;
4460 if (button_state & LMOUSE)
4461 flags |= TPM_LEFTBUTTON;
4462 else if (button_state & RMOUSE)
4463 flags |= TPM_RIGHTBUTTON;
4464
4465 /* Remember we did a SetCapture on the initial mouse down event,
4466 so for safety, we make sure the capture is cancelled now. */
4467 ReleaseCapture ();
4468 button_state = 0;
4469
4470 /* Use menubar_active to indicate that WM_INITMENU is from
4471 TrackPopupMenu below, and should be ignored. */
4472 f = x_window_to_frame (dpyinfo, hwnd);
4473 if (f)
4474 f->output_data.w32->menubar_active = 1;
4475
4476 if (TrackPopupMenu ((HMENU)wParam, flags, pos->x, pos->y,
4477 0, hwnd, NULL))
4478 {
4479 MSG amsg;
4480 /* Eat any mouse messages during popupmenu */
4481 while (PeekMessage (&amsg, hwnd, WM_MOUSEFIRST, WM_MOUSELAST,
4482 PM_REMOVE));
4483 /* Get the menu selection, if any */
4484 if (PeekMessage (&amsg, hwnd, WM_COMMAND, WM_COMMAND, PM_REMOVE))
4485 {
4486 retval = LOWORD (amsg.wParam);
4487 }
4488 else
4489 {
4490 retval = 0;
4491 }
4492 }
4493 else
4494 {
4495 retval = -1;
4496 }
4497
4498 return retval;
4499 }
4500
4501 default:
4502 /* Check for messages registered at runtime. */
4503 if (msg == msh_mousewheel)
4504 {
4505 wmsg.dwModifiers = w32_get_modifiers ();
4506 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4507 return 0;
4508 }
4509
4510 dflt:
4511 return DefWindowProc (hwnd, msg, wParam, lParam);
4512 }
4513
4514
4515 /* The most common default return code for handled messages is 0. */
4516 return 0;
4517 }
4518
4519 void
4520 my_create_window (f)
4521 struct frame * f;
4522 {
4523 MSG msg;
4524
4525 if (!PostThreadMessage (dwWindowsThreadId, WM_EMACS_CREATEWINDOW, (WPARAM)f, 0))
4526 abort ();
4527 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
4528 }
4529
4530 /* Create and set up the w32 window for frame F. */
4531
4532 static void
4533 w32_window (f, window_prompting, minibuffer_only)
4534 struct frame *f;
4535 long window_prompting;
4536 int minibuffer_only;
4537 {
4538 BLOCK_INPUT;
4539
4540 /* Use the resource name as the top-level window name
4541 for looking up resources. Make a non-Lisp copy
4542 for the window manager, so GC relocation won't bother it.
4543
4544 Elsewhere we specify the window name for the window manager. */
4545
4546 {
4547 char *str = (char *) XSTRING (Vx_resource_name)->data;
4548 f->namebuf = (char *) xmalloc (strlen (str) + 1);
4549 strcpy (f->namebuf, str);
4550 }
4551
4552 my_create_window (f);
4553
4554 validate_x_resource_name ();
4555
4556 /* x_set_name normally ignores requests to set the name if the
4557 requested name is the same as the current name. This is the one
4558 place where that assumption isn't correct; f->name is set, but
4559 the server hasn't been told. */
4560 {
4561 Lisp_Object name;
4562 int explicit = f->explicit_name;
4563
4564 f->explicit_name = 0;
4565 name = f->name;
4566 f->name = Qnil;
4567 x_set_name (f, name, explicit);
4568 }
4569
4570 UNBLOCK_INPUT;
4571
4572 if (!minibuffer_only && FRAME_EXTERNAL_MENU_BAR (f))
4573 initialize_frame_menubar (f);
4574
4575 if (FRAME_W32_WINDOW (f) == 0)
4576 error ("Unable to create window");
4577 }
4578
4579 /* Handle the icon stuff for this window. Perhaps later we might
4580 want an x_set_icon_position which can be called interactively as
4581 well. */
4582
4583 static void
4584 x_icon (f, parms)
4585 struct frame *f;
4586 Lisp_Object parms;
4587 {
4588 Lisp_Object icon_x, icon_y;
4589
4590 /* Set the position of the icon. Note that Windows 95 groups all
4591 icons in the tray. */
4592 icon_x = x_get_arg (parms, Qicon_left, 0, 0, number);
4593 icon_y = x_get_arg (parms, Qicon_top, 0, 0, number);
4594 if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound))
4595 {
4596 CHECK_NUMBER (icon_x, 0);
4597 CHECK_NUMBER (icon_y, 0);
4598 }
4599 else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound))
4600 error ("Both left and top icon corners of icon must be specified");
4601
4602 BLOCK_INPUT;
4603
4604 if (! EQ (icon_x, Qunbound))
4605 x_wm_set_icon_position (f, XINT (icon_x), XINT (icon_y));
4606
4607 #if 0 /* TODO */
4608 /* Start up iconic or window? */
4609 x_wm_set_window_state
4610 (f, (EQ (x_get_arg (parms, Qvisibility, 0, 0, symbol), Qicon)
4611 ? IconicState
4612 : NormalState));
4613
4614 x_text_icon (f, (char *) XSTRING ((!NILP (f->icon_name)
4615 ? f->icon_name
4616 : f->name))->data);
4617 #endif
4618
4619 UNBLOCK_INPUT;
4620 }
4621
4622 DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
4623 1, 1, 0,
4624 "Make a new window, which is called a \"frame\" in Emacs terms.\n\
4625 Returns an Emacs frame object.\n\
4626 ALIST is an alist of frame parameters.\n\
4627 If the parameters specify that the frame should not have a minibuffer,\n\
4628 and do not specify a specific minibuffer window to use,\n\
4629 then `default-minibuffer-frame' must be a frame whose minibuffer can\n\
4630 be shared by the new frame.\n\
4631 \n\
4632 This function is an internal primitive--use `make-frame' instead.")
4633 (parms)
4634 Lisp_Object parms;
4635 {
4636 struct frame *f;
4637 Lisp_Object frame, tem;
4638 Lisp_Object name;
4639 int minibuffer_only = 0;
4640 long window_prompting = 0;
4641 int width, height;
4642 int count = specpdl_ptr - specpdl;
4643 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4644 Lisp_Object display;
4645 struct w32_display_info *dpyinfo;
4646 Lisp_Object parent;
4647 struct kboard *kb;
4648
4649 check_w32 ();
4650
4651 /* Use this general default value to start with
4652 until we know if this frame has a specified name. */
4653 Vx_resource_name = Vinvocation_name;
4654
4655 display = x_get_arg (parms, Qdisplay, 0, 0, string);
4656 if (EQ (display, Qunbound))
4657 display = Qnil;
4658 dpyinfo = check_x_display_info (display);
4659 #ifdef MULTI_KBOARD
4660 kb = dpyinfo->kboard;
4661 #else
4662 kb = &the_only_kboard;
4663 #endif
4664
4665 name = x_get_arg (parms, Qname, "name", "Name", string);
4666 if (!STRINGP (name)
4667 && ! EQ (name, Qunbound)
4668 && ! NILP (name))
4669 error ("Invalid frame name--not a string or nil");
4670
4671 if (STRINGP (name))
4672 Vx_resource_name = name;
4673
4674 /* See if parent window is specified. */
4675 parent = x_get_arg (parms, Qparent_id, NULL, NULL, number);
4676 if (EQ (parent, Qunbound))
4677 parent = Qnil;
4678 if (! NILP (parent))
4679 CHECK_NUMBER (parent, 0);
4680
4681 /* make_frame_without_minibuffer can run Lisp code and garbage collect. */
4682 /* No need to protect DISPLAY because that's not used after passing
4683 it to make_frame_without_minibuffer. */
4684 frame = Qnil;
4685 GCPRO4 (parms, parent, name, frame);
4686 tem = x_get_arg (parms, Qminibuffer, 0, 0, symbol);
4687 if (EQ (tem, Qnone) || NILP (tem))
4688 f = make_frame_without_minibuffer (Qnil, kb, display);
4689 else if (EQ (tem, Qonly))
4690 {
4691 f = make_minibuffer_frame ();
4692 minibuffer_only = 1;
4693 }
4694 else if (WINDOWP (tem))
4695 f = make_frame_without_minibuffer (tem, kb, display);
4696 else
4697 f = make_frame (1);
4698
4699 XSETFRAME (frame, f);
4700
4701 /* Note that Windows does support scroll bars. */
4702 FRAME_CAN_HAVE_SCROLL_BARS (f) = 1;
4703 /* By default, make scrollbars the system standard width. */
4704 f->scroll_bar_pixel_width = GetSystemMetrics (SM_CXVSCROLL);
4705
4706 f->output_method = output_w32;
4707 f->output_data.w32 = (struct w32_output *) xmalloc (sizeof (struct w32_output));
4708 bzero (f->output_data.w32, sizeof (struct w32_output));
4709
4710 FRAME_FONTSET (f) = -1;
4711
4712 f->icon_name
4713 = x_get_arg (parms, Qicon_name, "iconName", "Title", string);
4714 if (! STRINGP (f->icon_name))
4715 f->icon_name = Qnil;
4716
4717 /* FRAME_W32_DISPLAY_INFO (f) = dpyinfo; */
4718 #ifdef MULTI_KBOARD
4719 FRAME_KBOARD (f) = kb;
4720 #endif
4721
4722 /* Specify the parent under which to make this window. */
4723
4724 if (!NILP (parent))
4725 {
4726 f->output_data.w32->parent_desc = (Window) parent;
4727 f->output_data.w32->explicit_parent = 1;
4728 }
4729 else
4730 {
4731 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
4732 f->output_data.w32->explicit_parent = 0;
4733 }
4734
4735 /* Note that the frame has no physical cursor right now. */
4736 f->phys_cursor_x = -1;
4737
4738 /* Set the name; the functions to which we pass f expect the name to
4739 be set. */
4740 if (EQ (name, Qunbound) || NILP (name))
4741 {
4742 f->name = build_string (dpyinfo->w32_id_name);
4743 f->explicit_name = 0;
4744 }
4745 else
4746 {
4747 f->name = name;
4748 f->explicit_name = 1;
4749 /* use the frame's title when getting resources for this frame. */
4750 specbind (Qx_resource_name, name);
4751 }
4752
4753 /* Create fontsets from `global_fontset_alist' before handling fonts. */
4754 for (tem = Vglobal_fontset_alist; CONSP (tem); tem = XCONS (tem)->cdr)
4755 fs_register_fontset (f, XCONS (tem)->car);
4756
4757 /* Extract the window parameters from the supplied values
4758 that are needed to determine window geometry. */
4759 {
4760 Lisp_Object font;
4761
4762 font = x_get_arg (parms, Qfont, "font", "Font", string);
4763 BLOCK_INPUT;
4764 /* First, try whatever font the caller has specified. */
4765 if (STRINGP (font))
4766 {
4767 tem = Fquery_fontset (font, Qnil);
4768 if (STRINGP (tem))
4769 font = x_new_fontset (f, XSTRING (tem)->data);
4770 else
4771 font = x_new_font (f, XSTRING (font)->data);
4772 }
4773 /* Try out a font which we hope has bold and italic variations. */
4774 if (!STRINGP (font))
4775 font = x_new_font (f, "-*-Courier New-normal-r-*-*-13-*-*-*-c-*-iso8859-1");
4776 if (! STRINGP (font))
4777 font = x_new_font (f, "-*-Courier-normal-r-*-*-*-97-*-*-c-*-iso8859-1");
4778 /* If those didn't work, look for something which will at least work. */
4779 if (! STRINGP (font))
4780 font = x_new_font (f, "-*-Fixedsys-normal-r-*-*-*-*-90-*-c-*-iso8859-1");
4781 UNBLOCK_INPUT;
4782 if (! STRINGP (font))
4783 font = build_string ("Fixedsys");
4784
4785 x_default_parameter (f, parms, Qfont, font,
4786 "font", "Font", string);
4787 }
4788
4789 x_default_parameter (f, parms, Qborder_width, make_number (2),
4790 "borderwidth", "BorderWidth", number);
4791 /* This defaults to 2 in order to match xterm. We recognize either
4792 internalBorderWidth or internalBorder (which is what xterm calls
4793 it). */
4794 if (NILP (Fassq (Qinternal_border_width, parms)))
4795 {
4796 Lisp_Object value;
4797
4798 value = x_get_arg (parms, Qinternal_border_width,
4799 "internalBorder", "BorderWidth", number);
4800 if (! EQ (value, Qunbound))
4801 parms = Fcons (Fcons (Qinternal_border_width, value),
4802 parms);
4803 }
4804 /* Default internalBorderWidth to 0 on Windows to match other programs. */
4805 x_default_parameter (f, parms, Qinternal_border_width, make_number (0),
4806 "internalBorderWidth", "BorderWidth", number);
4807 x_default_parameter (f, parms, Qvertical_scroll_bars, Qt,
4808 "verticalScrollBars", "ScrollBars", boolean);
4809
4810 /* Also do the stuff which must be set before the window exists. */
4811 x_default_parameter (f, parms, Qforeground_color, build_string ("black"),
4812 "foreground", "Foreground", string);
4813 x_default_parameter (f, parms, Qbackground_color, build_string ("white"),
4814 "background", "Background", string);
4815 x_default_parameter (f, parms, Qmouse_color, build_string ("black"),
4816 "pointerColor", "Foreground", string);
4817 x_default_parameter (f, parms, Qcursor_color, build_string ("black"),
4818 "cursorColor", "Foreground", string);
4819 x_default_parameter (f, parms, Qborder_color, build_string ("black"),
4820 "borderColor", "BorderColor", string);
4821
4822 x_default_parameter (f, parms, Qmenu_bar_lines, make_number (1),
4823 "menuBar", "MenuBar", number);
4824 x_default_parameter (f, parms, Qscroll_bar_width, Qnil,
4825 "scrollBarWidth", "ScrollBarWidth", number);
4826 x_default_parameter (f, parms, Qbuffer_predicate, Qnil,
4827 "bufferPredicate", "BufferPredicate", symbol);
4828 x_default_parameter (f, parms, Qtitle, Qnil,
4829 "title", "Title", string);
4830
4831 f->output_data.w32->dwStyle = WS_OVERLAPPEDWINDOW;
4832 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
4833 window_prompting = x_figure_window_size (f, parms);
4834
4835 if (window_prompting & XNegative)
4836 {
4837 if (window_prompting & YNegative)
4838 f->output_data.w32->win_gravity = SouthEastGravity;
4839 else
4840 f->output_data.w32->win_gravity = NorthEastGravity;
4841 }
4842 else
4843 {
4844 if (window_prompting & YNegative)
4845 f->output_data.w32->win_gravity = SouthWestGravity;
4846 else
4847 f->output_data.w32->win_gravity = NorthWestGravity;
4848 }
4849
4850 f->output_data.w32->size_hint_flags = window_prompting;
4851
4852 w32_window (f, window_prompting, minibuffer_only);
4853 x_icon (f, parms);
4854 init_frame_faces (f);
4855
4856 /* We need to do this after creating the window, so that the
4857 icon-creation functions can say whose icon they're describing. */
4858 x_default_parameter (f, parms, Qicon_type, Qnil,
4859 "bitmapIcon", "BitmapIcon", symbol);
4860
4861 x_default_parameter (f, parms, Qauto_raise, Qnil,
4862 "autoRaise", "AutoRaiseLower", boolean);
4863 x_default_parameter (f, parms, Qauto_lower, Qnil,
4864 "autoLower", "AutoRaiseLower", boolean);
4865 x_default_parameter (f, parms, Qcursor_type, Qbox,
4866 "cursorType", "CursorType", symbol);
4867
4868 /* Dimensions, especially f->height, must be done via change_frame_size.
4869 Change will not be effected unless different from the current
4870 f->height. */
4871 width = f->width;
4872 height = f->height;
4873 f->height = 0;
4874 SET_FRAME_WIDTH (f, 0);
4875 change_frame_size (f, height, width, 1, 0);
4876
4877 /* Tell the server what size and position, etc, we want,
4878 and how badly we want them. */
4879 BLOCK_INPUT;
4880 x_wm_set_size_hint (f, window_prompting, 0);
4881 UNBLOCK_INPUT;
4882
4883 tem = x_get_arg (parms, Qunsplittable, 0, 0, boolean);
4884 f->no_split = minibuffer_only || EQ (tem, Qt);
4885
4886 UNGCPRO;
4887
4888 /* It is now ok to make the frame official
4889 even if we get an error below.
4890 And the frame needs to be on Vframe_list
4891 or making it visible won't work. */
4892 Vframe_list = Fcons (frame, Vframe_list);
4893
4894 /* Now that the frame is official, it counts as a reference to
4895 its display. */
4896 FRAME_W32_DISPLAY_INFO (f)->reference_count++;
4897
4898 /* Make the window appear on the frame and enable display,
4899 unless the caller says not to. However, with explicit parent,
4900 Emacs cannot control visibility, so don't try. */
4901 if (! f->output_data.w32->explicit_parent)
4902 {
4903 Lisp_Object visibility;
4904
4905 visibility = x_get_arg (parms, Qvisibility, 0, 0, symbol);
4906 if (EQ (visibility, Qunbound))
4907 visibility = Qt;
4908
4909 if (EQ (visibility, Qicon))
4910 x_iconify_frame (f);
4911 else if (! NILP (visibility))
4912 x_make_frame_visible (f);
4913 else
4914 /* Must have been Qnil. */
4915 ;
4916 }
4917
4918 return unbind_to (count, frame);
4919 }
4920
4921 /* FRAME is used only to get a handle on the X display. We don't pass the
4922 display info directly because we're called from frame.c, which doesn't
4923 know about that structure. */
4924 Lisp_Object
4925 x_get_focus_frame (frame)
4926 struct frame *frame;
4927 {
4928 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (frame);
4929 Lisp_Object xfocus;
4930 if (! dpyinfo->w32_focus_frame)
4931 return Qnil;
4932
4933 XSETFRAME (xfocus, dpyinfo->w32_focus_frame);
4934 return xfocus;
4935 }
4936
4937 DEFUN ("w32-focus-frame", Fw32_focus_frame, Sw32_focus_frame, 1, 1, 0,
4938 "Give FRAME input focus, raising to foreground if necessary.")
4939 (frame)
4940 Lisp_Object frame;
4941 {
4942 x_focus_on_frame (check_x_frame (frame));
4943 return Qnil;
4944 }
4945
4946 \f
4947 struct font_info *w32_load_bdf_font (struct frame *f, char *fontname,
4948 int size, char* filename);
4949
4950 struct font_info *
4951 w32_load_system_font (f,fontname,size)
4952 struct frame *f;
4953 char * fontname;
4954 int size;
4955 {
4956 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
4957 Lisp_Object font_names;
4958
4959 /* Get a list of all the fonts that match this name. Once we
4960 have a list of matching fonts, we compare them against the fonts
4961 we already have loaded by comparing names. */
4962 font_names = w32_list_fonts (f, build_string (fontname), size, 100);
4963
4964 if (!NILP (font_names))
4965 {
4966 Lisp_Object tail;
4967 int i;
4968 #if 0 /* This code has nasty side effects that cause Emacs to crash. */
4969
4970 /* First check if any are already loaded, as that is cheaper
4971 than loading another one. */
4972 for (i = 0; i < dpyinfo->n_fonts; i++)
4973 for (tail = font_names; CONSP (tail); tail = XCONS (tail)->cdr)
4974 if (!strcmp (dpyinfo->font_table[i].name,
4975 XSTRING (XCONS (tail)->car)->data)
4976 || !strcmp (dpyinfo->font_table[i].full_name,
4977 XSTRING (XCONS (tail)->car)->data))
4978 return (dpyinfo->font_table + i);
4979 #endif
4980 fontname = (char *) XSTRING (XCONS (font_names)->car)->data;
4981 }
4982 else
4983 {
4984 /* If EnumFontFamiliesEx was available, we got a full list of
4985 fonts back so stop now to avoid the possibility of loading a
4986 random font. If we had to fall back to EnumFontFamilies, the
4987 list is incomplete, so continue whether the font we want was
4988 listed or not. */
4989 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
4990 FARPROC enum_font_families_ex
4991 = GetProcAddress ( gdi32, "EnumFontFamiliesExA");
4992 if (enum_font_families_ex)
4993 return NULL;
4994 }
4995
4996 /* Load the font and add it to the table. */
4997 {
4998 char *full_name, *encoding;
4999 XFontStruct *font;
5000 struct font_info *fontp;
5001 LOGFONT lf;
5002 BOOL ok;
5003
5004 if (!fontname || !x_to_w32_font (fontname, &lf))
5005 return (NULL);
5006
5007 if (!*lf.lfFaceName)
5008 /* If no name was specified for the font, we get a random font
5009 from CreateFontIndirect - this is not particularly
5010 desirable, especially since CreateFontIndirect does not
5011 fill out the missing name in lf, so we never know what we
5012 ended up with. */
5013 return NULL;
5014
5015 font = (XFontStruct *) xmalloc (sizeof (XFontStruct));
5016
5017 /* Set bdf to NULL to indicate that this is a Windows font. */
5018 font->bdf = NULL;
5019
5020 BLOCK_INPUT;
5021
5022 font->hfont = CreateFontIndirect (&lf);
5023
5024 if (font->hfont == NULL)
5025 {
5026 ok = FALSE;
5027 }
5028 else
5029 {
5030 HDC hdc;
5031 HANDLE oldobj;
5032
5033 hdc = GetDC (dpyinfo->root_window);
5034 oldobj = SelectObject (hdc, font->hfont);
5035 ok = GetTextMetrics (hdc, &font->tm);
5036 SelectObject (hdc, oldobj);
5037 ReleaseDC (dpyinfo->root_window, hdc);
5038 }
5039
5040 UNBLOCK_INPUT;
5041
5042 if (!ok)
5043 {
5044 w32_unload_font (dpyinfo, font);
5045 return (NULL);
5046 }
5047
5048 /* Do we need to create the table? */
5049 if (dpyinfo->font_table_size == 0)
5050 {
5051 dpyinfo->font_table_size = 16;
5052 dpyinfo->font_table
5053 = (struct font_info *) xmalloc (dpyinfo->font_table_size
5054 * sizeof (struct font_info));
5055 }
5056 /* Do we need to grow the table? */
5057 else if (dpyinfo->n_fonts
5058 >= dpyinfo->font_table_size)
5059 {
5060 dpyinfo->font_table_size *= 2;
5061 dpyinfo->font_table
5062 = (struct font_info *) xrealloc (dpyinfo->font_table,
5063 (dpyinfo->font_table_size
5064 * sizeof (struct font_info)));
5065 }
5066
5067 fontp = dpyinfo->font_table + dpyinfo->n_fonts;
5068
5069 /* Now fill in the slots of *FONTP. */
5070 BLOCK_INPUT;
5071 fontp->font = font;
5072 fontp->font_idx = dpyinfo->n_fonts;
5073 fontp->name = (char *) xmalloc (strlen (fontname) + 1);
5074 bcopy (fontname, fontp->name, strlen (fontname) + 1);
5075
5076 /* Work out the font's full name. */
5077 full_name = (char *)xmalloc (100);
5078 if (full_name && w32_to_x_font (&lf, full_name, 100))
5079 fontp->full_name = full_name;
5080 else
5081 {
5082 /* If all else fails - just use the name we used to load it. */
5083 xfree (full_name);
5084 fontp->full_name = fontp->name;
5085 }
5086
5087 fontp->size = FONT_WIDTH (font);
5088 fontp->height = FONT_HEIGHT (font);
5089
5090 /* The slot `encoding' specifies how to map a character
5091 code-points (0x20..0x7F or 0x2020..0x7F7F) of each charset to
5092 the font code-points (0:0x20..0x7F, 1:0xA0..0xFF, 0:0x2020..0x7F7F,
5093 the font code-points (0:0x20..0x7F, 1:0xA0..0xFF,
5094 0:0x2020..0x7F7F, 1:0xA0A0..0xFFFF, 3:0x20A0..0x7FFF, or
5095 2:0xA020..0xFF7F). For the moment, we don't know which charset
5096 uses this font. So, we set informatoin in fontp->encoding[1]
5097 which is never used by any charset. If mapping can't be
5098 decided, set FONT_ENCODING_NOT_DECIDED. */
5099
5100 /* SJIS fonts need to be set to type 4, all others seem to work as
5101 type FONT_ENCODING_NOT_DECIDED. */
5102 encoding = strrchr (fontp->name, '-');
5103 if (encoding && stricmp (encoding+1, "sjis") == 0)
5104 fontp->encoding[1] = 4;
5105 else
5106 fontp->encoding[1] = FONT_ENCODING_NOT_DECIDED;
5107
5108 /* The following three values are set to 0 under W32, which is
5109 what they get set to if XGetFontProperty fails under X. */
5110 fontp->baseline_offset = 0;
5111 fontp->relative_compose = 0;
5112 fontp->default_ascent = 0;
5113
5114 UNBLOCK_INPUT;
5115 dpyinfo->n_fonts++;
5116
5117 return fontp;
5118 }
5119 }
5120
5121 /* Load font named FONTNAME of size SIZE for frame F, and return a
5122 pointer to the structure font_info while allocating it dynamically.
5123 If loading fails, return NULL. */
5124 struct font_info *
5125 w32_load_font (f,fontname,size)
5126 struct frame *f;
5127 char * fontname;
5128 int size;
5129 {
5130 Lisp_Object bdf_fonts;
5131 struct font_info *retval = NULL;
5132
5133 bdf_fonts = w32_list_bdf_fonts (build_string (fontname));
5134
5135 while (!retval && CONSP (bdf_fonts))
5136 {
5137 char *bdf_name, *bdf_file;
5138 Lisp_Object bdf_pair;
5139
5140 bdf_name = XSTRING (XCONS (bdf_fonts)->car)->data;
5141 bdf_pair = Fassoc (XCONS (bdf_fonts)->car, Vw32_bdf_filename_alist);
5142 bdf_file = XSTRING (XCONS (bdf_pair)->cdr)->data;
5143
5144 retval = w32_load_bdf_font (f, bdf_name, size, bdf_file);
5145
5146 bdf_fonts = XCONS (bdf_fonts)->cdr;
5147 }
5148
5149 if (retval)
5150 return retval;
5151
5152 return w32_load_system_font(f, fontname, size);
5153 }
5154
5155
5156 void
5157 w32_unload_font (dpyinfo, font)
5158 struct w32_display_info *dpyinfo;
5159 XFontStruct * font;
5160 {
5161 if (font)
5162 {
5163 if (font->bdf) w32_free_bdf_font (font->bdf);
5164
5165 if (font->hfont) DeleteObject(font->hfont);
5166 xfree (font);
5167 }
5168 }
5169
5170 /* The font conversion stuff between x and w32 */
5171
5172 /* X font string is as follows (from faces.el)
5173 * (let ((- "[-?]")
5174 * (foundry "[^-]+")
5175 * (family "[^-]+")
5176 * (weight "\\(bold\\|demibold\\|medium\\)") ; 1
5177 * (weight\? "\\([^-]*\\)") ; 1
5178 * (slant "\\([ior]\\)") ; 2
5179 * (slant\? "\\([^-]?\\)") ; 2
5180 * (swidth "\\([^-]*\\)") ; 3
5181 * (adstyle "[^-]*") ; 4
5182 * (pixelsize "[0-9]+")
5183 * (pointsize "[0-9][0-9]+")
5184 * (resx "[0-9][0-9]+")
5185 * (resy "[0-9][0-9]+")
5186 * (spacing "[cmp?*]")
5187 * (avgwidth "[0-9]+")
5188 * (registry "[^-]+")
5189 * (encoding "[^-]+")
5190 * )
5191 * (setq x-font-regexp
5192 * (concat "\\`\\*?[-?*]"
5193 * foundry - family - weight\? - slant\? - swidth - adstyle -
5194 * pixelsize - pointsize - resx - resy - spacing - registry -
5195 * encoding "[-?*]\\*?\\'"
5196 * ))
5197 * (setq x-font-regexp-head
5198 * (concat "\\`[-?*]" foundry - family - weight\? - slant\?
5199 * "\\([-*?]\\|\\'\\)"))
5200 * (setq x-font-regexp-slant (concat - slant -))
5201 * (setq x-font-regexp-weight (concat - weight -))
5202 * nil)
5203 */
5204
5205 #define FONT_START "[-?]"
5206 #define FONT_FOUNDRY "[^-]+"
5207 #define FONT_FAMILY "\\([^-]+\\)" /* 1 */
5208 #define FONT_WEIGHT "\\(bold\\|demibold\\|medium\\)" /* 2 */
5209 #define FONT_WEIGHT_Q "\\([^-]*\\)" /* 2 */
5210 #define FONT_SLANT "\\([ior]\\)" /* 3 */
5211 #define FONT_SLANT_Q "\\([^-]?\\)" /* 3 */
5212 #define FONT_SWIDTH "\\([^-]*\\)" /* 4 */
5213 #define FONT_ADSTYLE "[^-]*"
5214 #define FONT_PIXELSIZE "[^-]*"
5215 #define FONT_POINTSIZE "\\([0-9][0-9]+\\|\\*\\)" /* 5 */
5216 #define FONT_RESX "[0-9][0-9]+"
5217 #define FONT_RESY "[0-9][0-9]+"
5218 #define FONT_SPACING "[cmp?*]"
5219 #define FONT_AVGWIDTH "[0-9]+"
5220 #define FONT_REGISTRY "[^-]+"
5221 #define FONT_ENCODING "[^-]+"
5222
5223 #define FONT_REGEXP ("\\`\\*?[-?*]" \
5224 FONT_FOUNDRY "-" \
5225 FONT_FAMILY "-" \
5226 FONT_WEIGHT_Q "-" \
5227 FONT_SLANT_Q "-" \
5228 FONT_SWIDTH "-" \
5229 FONT_ADSTYLE "-" \
5230 FONT_PIXELSIZE "-" \
5231 FONT_POINTSIZE "-" \
5232 "[-?*]\\|\\'")
5233
5234 #define FONT_REGEXP_HEAD ("\\`[-?*]" \
5235 FONT_FOUNDRY "-" \
5236 FONT_FAMILY "-" \
5237 FONT_WEIGHT_Q "-" \
5238 FONT_SLANT_Q \
5239 "\\([-*?]\\|\\'\\)")
5240
5241 #define FONT_REGEXP_SLANT "-" FONT_SLANT "-"
5242 #define FONT_REGEXP_WEIGHT "-" FONT_WEIGHT "-"
5243
5244 LONG
5245 x_to_w32_weight (lpw)
5246 char * lpw;
5247 {
5248 if (!lpw) return (FW_DONTCARE);
5249
5250 if (stricmp (lpw,"heavy") == 0) return FW_HEAVY;
5251 else if (stricmp (lpw,"extrabold") == 0) return FW_EXTRABOLD;
5252 else if (stricmp (lpw,"bold") == 0) return FW_BOLD;
5253 else if (stricmp (lpw,"demibold") == 0) return FW_SEMIBOLD;
5254 else if (stricmp (lpw,"semibold") == 0) return FW_SEMIBOLD;
5255 else if (stricmp (lpw,"medium") == 0) return FW_MEDIUM;
5256 else if (stricmp (lpw,"normal") == 0) return FW_NORMAL;
5257 else if (stricmp (lpw,"light") == 0) return FW_LIGHT;
5258 else if (stricmp (lpw,"extralight") == 0) return FW_EXTRALIGHT;
5259 else if (stricmp (lpw,"thin") == 0) return FW_THIN;
5260 else
5261 return FW_DONTCARE;
5262 }
5263
5264
5265 char *
5266 w32_to_x_weight (fnweight)
5267 int fnweight;
5268 {
5269 if (fnweight >= FW_HEAVY) return "heavy";
5270 if (fnweight >= FW_EXTRABOLD) return "extrabold";
5271 if (fnweight >= FW_BOLD) return "bold";
5272 if (fnweight >= FW_SEMIBOLD) return "semibold";
5273 if (fnweight >= FW_MEDIUM) return "medium";
5274 if (fnweight >= FW_NORMAL) return "normal";
5275 if (fnweight >= FW_LIGHT) return "light";
5276 if (fnweight >= FW_EXTRALIGHT) return "extralight";
5277 if (fnweight >= FW_THIN) return "thin";
5278 else
5279 return "*";
5280 }
5281
5282 LONG
5283 x_to_w32_charset (lpcs)
5284 char * lpcs;
5285 {
5286 if (!lpcs) return (0);
5287
5288 if (stricmp (lpcs,"ansi") == 0) return ANSI_CHARSET;
5289 else if (stricmp (lpcs,"iso8859-1") == 0) return ANSI_CHARSET;
5290 else if (stricmp (lpcs, "ms-symbol") == 0) return SYMBOL_CHARSET;
5291 else if (stricmp (lpcs, "jis") == 0) return SHIFTJIS_CHARSET;
5292 else if (stricmp (lpcs, "ksc5601.1987") == 0) return HANGEUL_CHARSET;
5293 else if (stricmp (lpcs, "gb2312") == 0) return GB2312_CHARSET;
5294 else if (stricmp (lpcs, "big5") == 0) return CHINESEBIG5_CHARSET;
5295 else if (stricmp (lpcs, "ms-oem") == 0) return OEM_CHARSET;
5296
5297 #ifdef EASTEUROPE_CHARSET
5298 else if (stricmp (lpcs, "iso8859-2") == 0) return EASTEUROPE_CHARSET;
5299 else if (stricmp (lpcs, "iso8859-3") == 0) return TURKISH_CHARSET;
5300 else if (stricmp (lpcs, "iso8859-4") == 0) return BALTIC_CHARSET;
5301 else if (stricmp (lpcs, "iso8859-5") == 0) return RUSSIAN_CHARSET;
5302 else if (stricmp (lpcs, "koi8") == 0) return RUSSIAN_CHARSET;
5303 else if (stricmp (lpcs, "iso8859-6") == 0) return ARABIC_CHARSET;
5304 else if (stricmp (lpcs, "iso8859-7") == 0) return GREEK_CHARSET;
5305 else if (stricmp (lpcs, "iso8859-8") == 0) return HEBREW_CHARSET;
5306 else if (stricmp (lpcs, "iso8859-9") == 0) return TURKISH_CHARSET;
5307 else if (stricmp (lpcs, "viscii") == 0) return VIETNAMESE_CHARSET;
5308 else if (stricmp (lpcs, "vscii") == 0) return VIETNAMESE_CHARSET;
5309 else if (stricmp (lpcs, "tis620") == 0) return THAI_CHARSET;
5310 else if (stricmp (lpcs, "mac") == 0) return MAC_CHARSET;
5311 else if (stricmp (lpcs, "ksc5601.1992") == 0) return JOHAB_CHARSET;
5312 /* For backwards compatibility with previous 20.4 pretests. */
5313 else if (stricmp (lpcs, "ksc5601") == 0) return HANGEUL_CHARSET;
5314 else if (stricmp (lpcs, "johab") == 0) return JOHAB_CHARSET;
5315 #endif
5316
5317 #ifdef UNICODE_CHARSET
5318 else if (stricmp (lpcs,"iso10646") == 0) return UNICODE_CHARSET;
5319 else if (stricmp (lpcs, "unicode") == 0) return UNICODE_CHARSET;
5320 #endif
5321 else if (lpcs[0] == '#') return atoi (lpcs + 1);
5322 else
5323 return DEFAULT_CHARSET;
5324 }
5325
5326 char *
5327 w32_to_x_charset (fncharset)
5328 int fncharset;
5329 {
5330 static char buf[16];
5331
5332 switch (fncharset)
5333 {
5334 /* ansi is considered iso8859-1, as most modern ansi fonts are. */
5335 case ANSI_CHARSET: return "iso8859-1";
5336 case DEFAULT_CHARSET: return "ascii-*";
5337 case SYMBOL_CHARSET: return "ms-symbol";
5338 case SHIFTJIS_CHARSET: return "jisx0208-sjis";
5339 case HANGEUL_CHARSET: return "ksc5601.1987-*";
5340 case GB2312_CHARSET: return "gb2312-*";
5341 case CHINESEBIG5_CHARSET: return "big5-*";
5342 case OEM_CHARSET: return "ms-oem";
5343
5344 /* More recent versions of Windows (95 and NT4.0) define more
5345 character sets. */
5346 #ifdef EASTEUROPE_CHARSET
5347 case EASTEUROPE_CHARSET: return "iso8859-2";
5348 case TURKISH_CHARSET: return "iso8859-9";
5349 case BALTIC_CHARSET: return "iso8859-4";
5350
5351 /* W95 with international support but not IE4 often has the
5352 KOI8-R codepage but not ISO8859-5. */
5353 case RUSSIAN_CHARSET:
5354 if (!IsValidCodePage(28595) && IsValidCodePage(20886))
5355 return "koi8-r";
5356 else
5357 return "iso8859-5";
5358 case ARABIC_CHARSET: return "iso8859-6";
5359 case GREEK_CHARSET: return "iso8859-7";
5360 case HEBREW_CHARSET: return "iso8859-8";
5361 case VIETNAMESE_CHARSET: return "viscii1.1-*";
5362 case THAI_CHARSET: return "tis620-*";
5363 case MAC_CHARSET: return "mac-*";
5364 case JOHAB_CHARSET: return "ksc5601.1992-*";
5365
5366 #endif
5367
5368 #ifdef UNICODE_CHARSET
5369 case UNICODE_CHARSET: return "iso10646-unicode";
5370 #endif
5371 }
5372 /* Encode numerical value of unknown charset. */
5373 sprintf (buf, "*-#%u", fncharset);
5374 return buf;
5375 }
5376
5377 BOOL
5378 w32_to_x_font (lplogfont, lpxstr, len)
5379 LOGFONT * lplogfont;
5380 char * lpxstr;
5381 int len;
5382 {
5383 char fontname[50];
5384 char height_pixels[8];
5385 char height_dpi[8];
5386 char width_pixels[8];
5387 char *fontname_dash;
5388 int display_resy = one_w32_display_info.height_in;
5389 int display_resx = one_w32_display_info.width_in;
5390
5391 if (!lpxstr) abort ();
5392
5393 if (!lplogfont)
5394 return FALSE;
5395
5396 strncpy (fontname, lplogfont->lfFaceName, 50);
5397 fontname[49] = '\0'; /* Just in case */
5398
5399 /* Replace dashes with underscores so the dashes are not
5400 misinterpreted */
5401 fontname_dash = fontname;
5402 while (fontname_dash = strchr (fontname_dash, '-'))
5403 *fontname_dash = '_';
5404
5405 if (lplogfont->lfHeight)
5406 {
5407 sprintf (height_pixels, "%u", abs (lplogfont->lfHeight));
5408 sprintf (height_dpi, "%u",
5409 abs (lplogfont->lfHeight) * 720 / display_resy);
5410 }
5411 else
5412 {
5413 strcpy (height_pixels, "*");
5414 strcpy (height_dpi, "*");
5415 }
5416 if (lplogfont->lfWidth)
5417 sprintf (width_pixels, "%u", lplogfont->lfWidth * 10);
5418 else
5419 strcpy (width_pixels, "*");
5420
5421 _snprintf (lpxstr, len - 1,
5422 "-*-%s-%s-%c-*-*-%s-%s-%d-%d-%c-%s-%s",
5423 /* foundry */
5424 fontname, /* family */
5425 w32_to_x_weight (lplogfont->lfWeight), /* weight */
5426 lplogfont->lfItalic?'i':'r', /* slant */
5427 /* setwidth name */
5428 /* add style name */
5429 height_pixels, /* pixel size */
5430 height_dpi, /* point size */
5431 display_resx, /* resx */
5432 display_resy, /* resy */
5433 ((lplogfont->lfPitchAndFamily & 0x3) == VARIABLE_PITCH)
5434 ? 'p' : 'c', /* spacing */
5435 width_pixels, /* avg width */
5436 w32_to_x_charset (lplogfont->lfCharSet) /* charset registry
5437 and encoding*/
5438 );
5439
5440 lpxstr[len - 1] = 0; /* just to be sure */
5441 return (TRUE);
5442 }
5443
5444 BOOL
5445 x_to_w32_font (lpxstr, lplogfont)
5446 char * lpxstr;
5447 LOGFONT * lplogfont;
5448 {
5449 if (!lplogfont) return (FALSE);
5450
5451 memset (lplogfont, 0, sizeof (*lplogfont));
5452
5453 /* Set default value for each field. */
5454 #if 1
5455 lplogfont->lfOutPrecision = OUT_DEFAULT_PRECIS;
5456 lplogfont->lfClipPrecision = CLIP_DEFAULT_PRECIS;
5457 lplogfont->lfQuality = DEFAULT_QUALITY;
5458 #else
5459 /* go for maximum quality */
5460 lplogfont->lfOutPrecision = OUT_STROKE_PRECIS;
5461 lplogfont->lfClipPrecision = CLIP_STROKE_PRECIS;
5462 lplogfont->lfQuality = PROOF_QUALITY;
5463 #endif
5464
5465 lplogfont->lfCharSet = DEFAULT_CHARSET;
5466 lplogfont->lfWeight = FW_DONTCARE;
5467 lplogfont->lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE;
5468
5469 if (!lpxstr)
5470 return FALSE;
5471
5472 /* Provide a simple escape mechanism for specifying Windows font names
5473 * directly -- if font spec does not beginning with '-', assume this
5474 * format:
5475 * "<font name>[:height in pixels[:width in pixels[:weight]]]"
5476 */
5477
5478 if (*lpxstr == '-')
5479 {
5480 int fields, tem;
5481 char name[50], weight[20], slant, pitch, pixels[10], height[10],
5482 width[10], resy[10], remainder[20];
5483 char * encoding;
5484 int dpi = one_w32_display_info.height_in;
5485
5486 fields = sscanf (lpxstr,
5487 "-%*[^-]-%49[^-]-%19[^-]-%c-%*[^-]-%*[^-]-%9[^-]-%9[^-]-%*[^-]-%9[^-]-%c-%9[^-]-%19s",
5488 name, weight, &slant, pixels, height, resy, &pitch, width, remainder);
5489 if (fields == EOF) return (FALSE);
5490
5491 if (fields > 0 && name[0] != '*')
5492 {
5493 strncpy (lplogfont->lfFaceName,name, LF_FACESIZE);
5494 lplogfont->lfFaceName[LF_FACESIZE-1] = 0;
5495 }
5496 else
5497 {
5498 lplogfont->lfFaceName[0] = 0;
5499 }
5500
5501 fields--;
5502
5503 lplogfont->lfWeight = x_to_w32_weight ((fields > 0 ? weight : ""));
5504
5505 fields--;
5506
5507 if (!NILP (Vw32_enable_italics))
5508 lplogfont->lfItalic = (fields > 0 && slant == 'i');
5509
5510 fields--;
5511
5512 if (fields > 0 && pixels[0] != '*')
5513 lplogfont->lfHeight = atoi (pixels);
5514
5515 fields--;
5516 fields--;
5517 if (fields > 0 && resy[0] != '*')
5518 {
5519 tem = atoi (pixels);
5520 if (tem > 0) dpi = tem;
5521 }
5522
5523 if (fields > -1 && lplogfont->lfHeight == 0 && height[0] != '*')
5524 lplogfont->lfHeight = atoi (height) * dpi / 720;
5525
5526 if (fields > 0)
5527 lplogfont->lfPitchAndFamily =
5528 (fields > 0 && pitch == 'p') ? VARIABLE_PITCH : FIXED_PITCH;
5529
5530 fields--;
5531
5532 if (fields > 0 && width[0] != '*')
5533 lplogfont->lfWidth = atoi (width) / 10;
5534
5535 fields--;
5536
5537 /* Strip the trailing '-' if present. (it shouldn't be, as it
5538 fails the test against xlfn-tight-regexp in fontset.el). */
5539 {
5540 int len = strlen (remainder);
5541 if (len > 0 && remainder[len-1] == '-')
5542 remainder[len-1] = 0;
5543 }
5544 encoding = remainder;
5545 if (strncmp (encoding, "*-", 2) == 0)
5546 encoding += 2;
5547 lplogfont->lfCharSet = x_to_w32_charset (fields > 0 ? encoding : "");
5548 }
5549 else
5550 {
5551 int fields;
5552 char name[100], height[10], width[10], weight[20];
5553
5554 fields = sscanf (lpxstr,
5555 "%99[^:]:%9[^:]:%9[^:]:%19s",
5556 name, height, width, weight);
5557
5558 if (fields == EOF) return (FALSE);
5559
5560 if (fields > 0)
5561 {
5562 strncpy (lplogfont->lfFaceName,name, LF_FACESIZE);
5563 lplogfont->lfFaceName[LF_FACESIZE-1] = 0;
5564 }
5565 else
5566 {
5567 lplogfont->lfFaceName[0] = 0;
5568 }
5569
5570 fields--;
5571
5572 if (fields > 0)
5573 lplogfont->lfHeight = atoi (height);
5574
5575 fields--;
5576
5577 if (fields > 0)
5578 lplogfont->lfWidth = atoi (width);
5579
5580 fields--;
5581
5582 lplogfont->lfWeight = x_to_w32_weight ((fields > 0 ? weight : ""));
5583 }
5584
5585 /* This makes TrueType fonts work better. */
5586 lplogfont->lfHeight = - abs (lplogfont->lfHeight);
5587
5588 return (TRUE);
5589 }
5590
5591 BOOL
5592 w32_font_match (lpszfont1, lpszfont2)
5593 char * lpszfont1;
5594 char * lpszfont2;
5595 {
5596 char * s1 = lpszfont1, *e1, *w1;
5597 char * s2 = lpszfont2, *e2, *w2;
5598
5599 if (s1 == NULL || s2 == NULL) return (FALSE);
5600
5601 if (*s1 == '-') s1++;
5602 if (*s2 == '-') s2++;
5603
5604 while (1)
5605 {
5606 int len1, len2, len3=0;
5607
5608 e1 = strchr (s1, '-');
5609 e2 = strchr (s2, '-');
5610 w1 = strchr (s1, '*');
5611 w2 = strchr (s2, '*');
5612
5613 if (e1 == NULL)
5614 len1 = strlen (s1);
5615 else
5616 len1 = e1 - s1;
5617 if (e2 == NULL)
5618 len2 = strlen (s1);
5619 else
5620 len2 = e2 - s2;
5621
5622 if (w1 && w1 < e1)
5623 len3 = w1 - s1;
5624 if (w2 && w2 < e2 && ( len3 == 0 || (w2 - s2) < len3))
5625 len3 = w2 - s2;
5626
5627 /* Whole field is not a wildcard, and ...*/
5628 if (*s1 != '*' && *s2 != '*' && *s1 != '-' && *s2 != '-'
5629 /* Lengths are different and there are no wildcards, or ... */
5630 && ((len1 != len2 && len3 == 0) ||
5631 /* strings don't match up until first wildcard or end. */
5632 strnicmp (s1, s2, len3 > 0 ? len3 : len1) != 0))
5633 return (FALSE);
5634
5635 if (e1 == NULL || e2 == NULL)
5636 return (TRUE);
5637
5638 s1 = e1 + 1;
5639 s2 = e2 + 1;
5640 }
5641 }
5642
5643 /* Callback functions, and a structure holding info they need, for
5644 listing system fonts on W32. We need one set of functions to do the
5645 job properly, but these don't work on NT 3.51 and earlier, so we
5646 have a second set which don't handle character sets properly to
5647 fall back on.
5648
5649 In both cases, there are two passes made. The first pass gets one
5650 font from each family, the second pass lists all the fonts from
5651 each family. */
5652
5653 typedef struct enumfont_t
5654 {
5655 HDC hdc;
5656 int numFonts;
5657 LOGFONT logfont;
5658 XFontStruct *size_ref;
5659 Lisp_Object *pattern;
5660 Lisp_Object *tail;
5661 } enumfont_t;
5662
5663 int CALLBACK
5664 enum_font_cb2 (lplf, lptm, FontType, lpef)
5665 ENUMLOGFONT * lplf;
5666 NEWTEXTMETRIC * lptm;
5667 int FontType;
5668 enumfont_t * lpef;
5669 {
5670 if (lplf->elfLogFont.lfStrikeOut || lplf->elfLogFont.lfUnderline)
5671 return (1);
5672
5673 /* Check that the character set matches if it was specified */
5674 if (lpef->logfont.lfCharSet != DEFAULT_CHARSET &&
5675 lplf->elfLogFont.lfCharSet != lpef->logfont.lfCharSet)
5676 return (1);
5677
5678 /* We want all fonts cached, so don't compare sizes just yet */
5679 /* if (!lpef->size_ref || lptm->tmMaxCharWidth == FONT_WIDTH (lpef->size_ref)) */
5680 {
5681 char buf[100];
5682 Lisp_Object width = Qnil;
5683
5684 if (!NILP (*(lpef->pattern)) && FontType != RASTER_FONTTYPE)
5685 {
5686 /* Scalable fonts are as big as you want them to be. */
5687 lplf->elfLogFont.lfHeight = lpef->logfont.lfHeight;
5688 lplf->elfLogFont.lfWidth = lpef->logfont.lfWidth;
5689 }
5690
5691 /* The MaxCharWidth is not valid at this stage for scalable fonts. */
5692 if (FontType == RASTER_FONTTYPE)
5693 width = make_number (lptm->tmMaxCharWidth);
5694
5695 if (!w32_to_x_font (&(lplf->elfLogFont), buf, 100))
5696 return (0);
5697
5698 if (NILP (*(lpef->pattern))
5699 || w32_font_match (buf, XSTRING (*(lpef->pattern))->data))
5700 {
5701 *lpef->tail = Fcons (Fcons (build_string (buf), width), Qnil);
5702 lpef->tail = &(XCONS (*lpef->tail)->cdr);
5703 lpef->numFonts++;
5704 }
5705 }
5706
5707 return (1);
5708 }
5709
5710 int CALLBACK
5711 enum_font_cb1 (lplf, lptm, FontType, lpef)
5712 ENUMLOGFONT * lplf;
5713 NEWTEXTMETRIC * lptm;
5714 int FontType;
5715 enumfont_t * lpef;
5716 {
5717 return EnumFontFamilies (lpef->hdc,
5718 lplf->elfLogFont.lfFaceName,
5719 (FONTENUMPROC) enum_font_cb2,
5720 (LPARAM) lpef);
5721 }
5722
5723
5724 int CALLBACK
5725 enum_fontex_cb2 (lplf, lptm, font_type, lpef)
5726 ENUMLOGFONTEX * lplf;
5727 NEWTEXTMETRICEX * lptm;
5728 int font_type;
5729 enumfont_t * lpef;
5730 {
5731 /* We are not interested in the extra info we get back from the 'Ex
5732 version - only the fact that we get character set variations
5733 enumerated seperately. */
5734 return enum_font_cb2 ((ENUMLOGFONT *) lplf, (NEWTEXTMETRIC *) lptm,
5735 font_type, lpef);
5736 }
5737
5738 int CALLBACK
5739 enum_fontex_cb1 (lplf, lptm, font_type, lpef)
5740 ENUMLOGFONTEX * lplf;
5741 NEWTEXTMETRICEX * lptm;
5742 int font_type;
5743 enumfont_t * lpef;
5744 {
5745 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
5746 FARPROC enum_font_families_ex
5747 = GetProcAddress ( gdi32, "EnumFontFamiliesExA");
5748 /* We don't really expect EnumFontFamiliesEx to disappear once we
5749 get here, so don't bother handling it gracefully. */
5750 if (enum_font_families_ex == NULL)
5751 error ("gdi32.dll has disappeared!");
5752 return enum_font_families_ex (lpef->hdc,
5753 &lplf->elfLogFont,
5754 (FONTENUMPROC) enum_fontex_cb2,
5755 (LPARAM) lpef, 0);
5756 }
5757
5758 /* Interface to fontset handler. (adapted from mw32font.c in Meadow
5759 and xterm.c in Emacs 20.3) */
5760
5761 Lisp_Object w32_list_bdf_fonts (Lisp_Object pattern, int max_names)
5762 {
5763 char *fontname, *ptnstr;
5764 Lisp_Object list, tem, newlist = Qnil;
5765 int n_fonts;
5766
5767 list = Vw32_bdf_filename_alist;
5768 ptnstr = XSTRING (pattern)->data;
5769
5770 for ( ; CONSP (list); list = XCONS (list)->cdr)
5771 {
5772 tem = XCONS (list)->car;
5773 if (CONSP (tem))
5774 fontname = XSTRING (XCONS (tem)->car)->data;
5775 else if (STRINGP (tem))
5776 fontname = XSTRING (tem)->data;
5777 else
5778 continue;
5779
5780 if (w32_font_match (fontname, ptnstr))
5781 {
5782 newlist = Fcons (XCONS (tem)->car, newlist);
5783 n_fonts++;
5784 if (n_fonts >= max_names)
5785 break;
5786 }
5787 }
5788
5789 return newlist;
5790 }
5791
5792 Lisp_Object w32_list_synthesized_fonts (FRAME_PTR f, Lisp_Object pattern,
5793 int size, int max_names);
5794
5795 /* Return a list of names of available fonts matching PATTERN on frame
5796 F. If SIZE is not 0, it is the size (maximum bound width) of fonts
5797 to be listed. Frame F NULL means we have not yet created any
5798 frame, which means we can't get proper size info, as we don't have
5799 a device context to use for GetTextMetrics.
5800 MAXNAMES sets a limit on how many fonts to match. */
5801
5802 Lisp_Object
5803 w32_list_fonts (FRAME_PTR f, Lisp_Object pattern, int size, int maxnames )
5804 {
5805 Lisp_Object patterns, key, tem, tpat;
5806 Lisp_Object list = Qnil, newlist = Qnil, second_best = Qnil;
5807 struct w32_display_info *dpyinfo = &one_w32_display_info;
5808 int n_fonts = 0;
5809
5810 patterns = Fassoc (pattern, Valternate_fontname_alist);
5811 if (NILP (patterns))
5812 patterns = Fcons (pattern, Qnil);
5813
5814 for (; CONSP (patterns); patterns = XCONS (patterns)->cdr)
5815 {
5816 enumfont_t ef;
5817
5818 tpat = XCONS (patterns)->car;
5819
5820 /* See if we cached the result for this particular query.
5821 The cache is an alist of the form:
5822 ((PATTERN (FONTNAME . WIDTH) ...) ...)
5823 */
5824 if (tem = XCONS (dpyinfo->name_list_element)->cdr,
5825 !NILP (list = Fassoc (tpat, tem)))
5826 {
5827 list = Fcdr_safe (list);
5828 /* We have a cached list. Don't have to get the list again. */
5829 goto label_cached;
5830 }
5831
5832 BLOCK_INPUT;
5833 /* At first, put PATTERN in the cache. */
5834 list = Qnil;
5835 ef.pattern = &tpat;
5836 ef.tail = &list;
5837 ef.numFonts = 0;
5838
5839 /* Use EnumFontFamiliesEx where it is available, as it knows
5840 about character sets. Fall back to EnumFontFamilies for
5841 older versions of NT that don't support the 'Ex function. */
5842 x_to_w32_font (STRINGP (tpat) ? XSTRING (tpat)->data :
5843 NULL, &ef.logfont);
5844 {
5845 LOGFONT font_match_pattern;
5846 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
5847 FARPROC enum_font_families_ex
5848 = GetProcAddress ( gdi32, "EnumFontFamiliesExA");
5849
5850 /* We do our own pattern matching so we can handle wildcards. */
5851 font_match_pattern.lfFaceName[0] = 0;
5852 font_match_pattern.lfPitchAndFamily = 0;
5853 /* We can use the charset, because if it is a wildcard it will
5854 be DEFAULT_CHARSET anyway. */
5855 font_match_pattern.lfCharSet = ef.logfont.lfCharSet;
5856
5857 ef.hdc = GetDC (dpyinfo->root_window);
5858
5859 if (enum_font_families_ex)
5860 enum_font_families_ex (ef.hdc,
5861 &font_match_pattern,
5862 (FONTENUMPROC) enum_fontex_cb1,
5863 (LPARAM) &ef, 0);
5864 else
5865 EnumFontFamilies (ef.hdc, NULL, (FONTENUMPROC) enum_font_cb1,
5866 (LPARAM)&ef);
5867
5868 ReleaseDC (dpyinfo->root_window, ef.hdc);
5869 }
5870
5871 UNBLOCK_INPUT;
5872
5873 /* Make a list of the fonts we got back.
5874 Store that in the font cache for the display. */
5875 XCONS (dpyinfo->name_list_element)->cdr
5876 = Fcons (Fcons (tpat, list),
5877 XCONS (dpyinfo->name_list_element)->cdr);
5878
5879 label_cached:
5880 if (NILP (list)) continue; /* Try the remaining alternatives. */
5881
5882 newlist = second_best = Qnil;
5883
5884 /* Make a list of the fonts that have the right width. */
5885 for (; CONSP (list); list = XCONS (list)->cdr)
5886 {
5887 int found_size;
5888 tem = XCONS (list)->car;
5889
5890 if (!CONSP (tem))
5891 continue;
5892 if (NILP (XCONS (tem)->car))
5893 continue;
5894 if (!size)
5895 {
5896 newlist = Fcons (XCONS (tem)->car, newlist);
5897 n_fonts++;
5898 if (n_fonts >= maxnames)
5899 break;
5900 else
5901 continue;
5902 }
5903 if (!INTEGERP (XCONS (tem)->cdr))
5904 {
5905 /* Since we don't yet know the size of the font, we must
5906 load it and try GetTextMetrics. */
5907 W32FontStruct thisinfo;
5908 LOGFONT lf;
5909 HDC hdc;
5910 HANDLE oldobj;
5911
5912 if (!x_to_w32_font (XSTRING (XCONS (tem)->car)->data, &lf))
5913 continue;
5914
5915 BLOCK_INPUT;
5916 thisinfo.bdf = NULL;
5917 thisinfo.hfont = CreateFontIndirect (&lf);
5918 if (thisinfo.hfont == NULL)
5919 continue;
5920
5921 hdc = GetDC (dpyinfo->root_window);
5922 oldobj = SelectObject (hdc, thisinfo.hfont);
5923 if (GetTextMetrics (hdc, &thisinfo.tm))
5924 XCONS (tem)->cdr = make_number (FONT_WIDTH (&thisinfo));
5925 else
5926 XCONS (tem)->cdr = make_number (0);
5927 SelectObject (hdc, oldobj);
5928 ReleaseDC (dpyinfo->root_window, hdc);
5929 DeleteObject(thisinfo.hfont);
5930 UNBLOCK_INPUT;
5931 }
5932 found_size = XINT (XCONS (tem)->cdr);
5933 if (found_size == size)
5934 {
5935 newlist = Fcons (XCONS (tem)->car, newlist);
5936 n_fonts++;
5937 if (n_fonts >= maxnames)
5938 break;
5939 }
5940 /* keep track of the closest matching size in case
5941 no exact match is found. */
5942 else if (found_size > 0)
5943 {
5944 if (NILP (second_best))
5945 second_best = tem;
5946
5947 else if (found_size < size)
5948 {
5949 if (XINT (XCONS (second_best)->cdr) > size
5950 || XINT (XCONS (second_best)->cdr) < found_size)
5951 second_best = tem;
5952 }
5953 else
5954 {
5955 if (XINT (XCONS (second_best)->cdr) > size
5956 && XINT (XCONS (second_best)->cdr) >
5957 found_size)
5958 second_best = tem;
5959 }
5960 }
5961 }
5962
5963 if (!NILP (newlist))
5964 break;
5965 else if (!NILP (second_best))
5966 {
5967 newlist = Fcons (XCONS (second_best)->car, Qnil);
5968 break;
5969 }
5970 }
5971
5972 /* Include any bdf fonts. */
5973 if (n_fonts < maxnames)
5974 {
5975 Lisp_Object combined[2];
5976 combined[0] = w32_list_bdf_fonts (pattern, maxnames - n_fonts);
5977 combined[1] = newlist;
5978 newlist = Fnconc(2, combined);
5979 }
5980
5981 /* If we can't find a font that matches, check if Windows would be
5982 able to synthesize it from a different style. */
5983 if (NILP (newlist) && !NILP (Vw32_enable_italics))
5984 newlist = w32_list_synthesized_fonts (f, pattern, size, maxnames);
5985
5986 return newlist;
5987 }
5988
5989 Lisp_Object
5990 w32_list_synthesized_fonts (f, pattern, size, max_names)
5991 FRAME_PTR f;
5992 Lisp_Object pattern;
5993 int size;
5994 int max_names;
5995 {
5996 int fields;
5997 char *full_pattn, *new_pattn, foundary[50], family[50], *pattn_part2;
5998 char style[20], slant;
5999 Lisp_Object matches, match, tem, synthed_matches = Qnil;
6000
6001 full_pattn = XSTRING (pattern)->data;
6002
6003 pattn_part2 = alloca (XSTRING (pattern)->size);
6004 /* Allow some space for wildcard expansion. */
6005 new_pattn = alloca (XSTRING (pattern)->size + 100);
6006
6007 fields = sscanf (full_pattn, "-%49[^-]-%49[^-]-%19[^-]-%c-%s",
6008 foundary, family, style, &slant, pattn_part2);
6009 if (fields == EOF || fields < 5)
6010 return Qnil;
6011
6012 /* If the style and slant are wildcards already there is no point
6013 checking again (and we don't want to keep recursing). */
6014 if (*style == '*' && slant == '*')
6015 return Qnil;
6016
6017 sprintf (new_pattn, "-%s-%s-*-*-%s", foundary, family, pattn_part2);
6018
6019 matches = w32_list_fonts (f, build_string (new_pattn), size, max_names);
6020
6021 for ( ; CONSP (matches); matches = XCONS (matches)->cdr)
6022 {
6023 tem = XCONS (matches)->car;
6024 if (!STRINGP (tem))
6025 continue;
6026
6027 full_pattn = XSTRING (tem)->data;
6028 fields = sscanf (full_pattn, "-%49[^-]-%49[^-]-%*[^-]-%*c-%s",
6029 foundary, family, pattn_part2);
6030 if (fields == EOF || fields < 3)
6031 continue;
6032
6033 sprintf (new_pattn, "-%s-%s-%s-%c-%s", foundary, family, style,
6034 slant, pattn_part2);
6035
6036 synthed_matches = Fcons (build_string (new_pattn),
6037 synthed_matches);
6038 }
6039
6040 return synthed_matches;
6041 }
6042
6043
6044 /* Return a pointer to struct font_info of font FONT_IDX of frame F. */
6045 struct font_info *
6046 w32_get_font_info (f, font_idx)
6047 FRAME_PTR f;
6048 int font_idx;
6049 {
6050 return (FRAME_W32_FONT_TABLE (f) + font_idx);
6051 }
6052
6053
6054 struct font_info*
6055 w32_query_font (struct frame *f, char *fontname)
6056 {
6057 int i;
6058 struct font_info *pfi;
6059
6060 pfi = FRAME_W32_FONT_TABLE (f);
6061
6062 for (i = 0; i < one_w32_display_info.n_fonts ;i++, pfi++)
6063 {
6064 if (strcmp(pfi->name, fontname) == 0) return pfi;
6065 }
6066
6067 return NULL;
6068 }
6069
6070 /* Find a CCL program for a font specified by FONTP, and set the member
6071 `encoder' of the structure. */
6072
6073 void
6074 w32_find_ccl_program (fontp)
6075 struct font_info *fontp;
6076 {
6077 extern Lisp_Object Vfont_ccl_encoder_alist, Vccl_program_table;
6078 extern Lisp_Object Qccl_program_idx;
6079 extern Lisp_Object resolve_symbol_ccl_program ();
6080 Lisp_Object list, elt, ccl_prog, ccl_id;
6081
6082 for (list = Vfont_ccl_encoder_alist; CONSP (list); list = XCONS (list)->cdr)
6083 {
6084 elt = XCONS (list)->car;
6085 if (CONSP (elt)
6086 && STRINGP (XCONS (elt)->car)
6087 && (fast_c_string_match_ignore_case (XCONS (elt)->car, fontp->name)
6088 >= 0))
6089 {
6090 if (SYMBOLP (XCONS (elt)->cdr) &&
6091 (!NILP (ccl_id = Fget (XCONS (elt)->cdr, Qccl_program_idx))))
6092 {
6093 ccl_prog = XVECTOR (Vccl_program_table)->contents[XUINT (ccl_id)];
6094 if (!CONSP (ccl_prog)) continue;
6095 ccl_prog = XCONS (ccl_prog)->cdr;
6096 }
6097 else
6098 {
6099 ccl_prog = XCONS (elt)->cdr;
6100 if (!VECTORP (ccl_prog)) continue;
6101 }
6102
6103 fontp->font_encoder
6104 = (struct ccl_program *) xmalloc (sizeof (struct ccl_program));
6105 setup_ccl_program (fontp->font_encoder,
6106 resolve_symbol_ccl_program (ccl_prog));
6107 break;
6108 }
6109 }
6110 }
6111
6112 \f
6113 #if 1
6114 #include "x-list-font.c"
6115 #else
6116 DEFUN ("x-list-fonts", Fx_list_fonts, Sx_list_fonts, 1, 4, 0,
6117 "Return a list of the names of available fonts matching PATTERN.\n\
6118 If optional arguments FACE and FRAME are specified, return only fonts\n\
6119 the same size as FACE on FRAME.\n\
6120 \n\
6121 PATTERN is a string, perhaps with wildcard characters;\n\
6122 the * character matches any substring, and\n\
6123 the ? character matches any single character.\n\
6124 PATTERN is case-insensitive.\n\
6125 FACE is a face name--a symbol.\n\
6126 \n\
6127 The return value is a list of strings, suitable as arguments to\n\
6128 set-face-font.\n\
6129 \n\
6130 Fonts Emacs can't use (i.e. proportional fonts) may or may not be excluded\n\
6131 even if they match PATTERN and FACE.\n\
6132 \n\
6133 The optional fourth argument MAXIMUM sets a limit on how many\n\
6134 fonts to match. The first MAXIMUM fonts are reported.")
6135 (pattern, face, frame, maximum)
6136 Lisp_Object pattern, face, frame, maximum;
6137 {
6138 int num_fonts;
6139 char **names;
6140 XFontStruct *info;
6141 XFontStruct *size_ref;
6142 Lisp_Object namelist;
6143 Lisp_Object list;
6144 FRAME_PTR f;
6145 enumfont_t ef;
6146
6147 CHECK_STRING (pattern, 0);
6148 if (!NILP (face))
6149 CHECK_SYMBOL (face, 1);
6150
6151 f = check_x_frame (frame);
6152
6153 /* Determine the width standard for comparison with the fonts we find. */
6154
6155 if (NILP (face))
6156 size_ref = 0;
6157 else
6158 {
6159 int face_id;
6160
6161 /* Don't die if we get called with a terminal frame. */
6162 if (! FRAME_W32_P (f))
6163 error ("non-w32 frame used in `x-list-fonts'");
6164
6165 face_id = face_name_id_number (f, face);
6166
6167 if (face_id < 0 || face_id >= FRAME_N_PARAM_FACES (f)
6168 || FRAME_PARAM_FACES (f) [face_id] == 0)
6169 size_ref = f->output_data.w32->font;
6170 else
6171 {
6172 size_ref = FRAME_PARAM_FACES (f) [face_id]->font;
6173 if (size_ref == (XFontStruct *) (~0))
6174 size_ref = f->output_data.w32->font;
6175 }
6176 }
6177
6178 /* See if we cached the result for this particular query. */
6179 list = Fassoc (pattern,
6180 XCONS (FRAME_W32_DISPLAY_INFO (f)->name_list_element)->cdr);
6181
6182 /* We have info in the cache for this PATTERN. */
6183 if (!NILP (list))
6184 {
6185 Lisp_Object tem, newlist;
6186
6187 /* We have info about this pattern. */
6188 list = XCONS (list)->cdr;
6189
6190 if (size_ref == 0)
6191 return list;
6192
6193 BLOCK_INPUT;
6194
6195 /* Filter the cached info and return just the fonts that match FACE. */
6196 newlist = Qnil;
6197 for (tem = list; CONSP (tem); tem = XCONS (tem)->cdr)
6198 {
6199 struct font_info *fontinf;
6200 XFontStruct *thisinfo = NULL;
6201
6202 fontinf = w32_load_font (f, XSTRING (XCONS (tem)->car)->data, 0);
6203 if (fontinf)
6204 thisinfo = (XFontStruct *)fontinf->font;
6205 if (thisinfo && same_size_fonts (thisinfo, size_ref))
6206 newlist = Fcons (XCONS (tem)->car, newlist);
6207
6208 w32_unload_font (FRAME_W32_DISPLAY_INFO (f), thisinfo);
6209 }
6210
6211 UNBLOCK_INPUT;
6212
6213 return newlist;
6214 }
6215
6216 BLOCK_INPUT;
6217
6218 namelist = Qnil;
6219 ef.pattern = &pattern;
6220 ef.tail &namelist;
6221 ef.numFonts = 0;
6222 x_to_w32_font (STRINGP (pattern) ? XSTRING (pattern)->data : NULL, &ef.logfont);
6223
6224 {
6225 ef.hdc = GetDC (FRAME_W32_WINDOW (f));
6226
6227 EnumFontFamilies (ef.hdc, NULL, (FONTENUMPROC) enum_font_cb1, (LPARAM)&ef);
6228
6229 ReleaseDC (FRAME_W32_WINDOW (f), ef.hdc);
6230 }
6231
6232 UNBLOCK_INPUT;
6233
6234 if (ef.numFonts)
6235 {
6236 int i;
6237 Lisp_Object cur;
6238
6239 /* Make a list of all the fonts we got back.
6240 Store that in the font cache for the display. */
6241 XCONS (FRAME_W32_DISPLAY_INFO (f)->name_list_element)->cdr
6242 = Fcons (Fcons (pattern, namelist),
6243 XCONS (FRAME_W32_DISPLAY_INFO (f)->name_list_element)->cdr);
6244
6245 /* Make a list of the fonts that have the right width. */
6246 list = Qnil;
6247 cur=namelist;
6248 for (i = 0; i < ef.numFonts; i++)
6249 {
6250 int keeper;
6251
6252 if (!size_ref)
6253 keeper = 1;
6254 else
6255 {
6256 struct font_info *fontinf;
6257 XFontStruct *thisinfo = NULL;
6258
6259 BLOCK_INPUT;
6260 fontinf = w32_load_font (f, XSTRING (Fcar (cur))->data, 0);
6261 if (fontinf)
6262 thisinfo = (XFontStruct *)fontinf->font;
6263
6264 keeper = thisinfo && same_size_fonts (thisinfo, size_ref);
6265
6266 w32_unload_font (FRAME_W32_DISPLAY_INFO (f), thisinfo);
6267
6268 UNBLOCK_INPUT;
6269 }
6270 if (keeper)
6271 list = Fcons (build_string (XSTRING (Fcar (cur))->data), list);
6272
6273 cur = Fcdr (cur);
6274 }
6275 list = Fnreverse (list);
6276 }
6277
6278 return list;
6279 }
6280 #endif
6281 \f
6282 DEFUN ("w32-find-bdf-fonts", Fw32_find_bdf_fonts, Sw32_find_bdf_fonts,
6283 1, 1, 0,
6284 "Return a list of BDF fonts in DIR, suitable for appending to\n\
6285 w32-bdf-filename-alist. Fonts which do not contain an xfld description\n\
6286 will not be included in the list. DIR may be a list of directories.")
6287 (directory)
6288 Lisp_Object directory;
6289 {
6290 Lisp_Object list = Qnil;
6291 struct gcpro gcpro1, gcpro2;
6292
6293 if (!CONSP (directory))
6294 return w32_find_bdf_fonts_in_dir (directory);
6295
6296 for ( ; CONSP (directory); directory = XCONS (directory)->cdr)
6297 {
6298 Lisp_Object pair[2];
6299 pair[0] = list;
6300 pair[1] = Qnil;
6301 GCPRO2 (directory, list);
6302 pair[1] = w32_find_bdf_fonts_in_dir( XCONS (directory)->car );
6303 list = Fnconc( 2, pair );
6304 UNGCPRO;
6305 }
6306 return list;
6307 }
6308
6309 /* Find BDF files in a specified directory. (use GCPRO when calling,
6310 as this calls lisp to get a directory listing). */
6311 Lisp_Object w32_find_bdf_fonts_in_dir( Lisp_Object directory )
6312 {
6313 Lisp_Object filelist, list = Qnil;
6314 char fontname[100];
6315
6316 if (!STRINGP(directory))
6317 return Qnil;
6318
6319 filelist = Fdirectory_files (directory, Qt,
6320 build_string (".*\\.[bB][dD][fF]"), Qt);
6321
6322 for ( ; CONSP(filelist); filelist = XCONS (filelist)->cdr)
6323 {
6324 Lisp_Object filename = XCONS (filelist)->car;
6325 if (w32_BDF_to_x_font (XSTRING (filename)->data, fontname, 100))
6326 store_in_alist (&list, build_string (fontname), filename);
6327 }
6328 return list;
6329 }
6330
6331 \f
6332 DEFUN ("x-color-defined-p", Fx_color_defined_p, Sx_color_defined_p, 1, 2, 0,
6333 "Return non-nil if color COLOR is supported on frame FRAME.\n\
6334 If FRAME is omitted or nil, use the selected frame.")
6335 (color, frame)
6336 Lisp_Object color, frame;
6337 {
6338 COLORREF foo;
6339 FRAME_PTR f = check_x_frame (frame);
6340
6341 CHECK_STRING (color, 1);
6342
6343 if (defined_color (f, XSTRING (color)->data, &foo, 0))
6344 return Qt;
6345 else
6346 return Qnil;
6347 }
6348
6349 DEFUN ("x-color-values", Fx_color_values, Sx_color_values, 1, 2, 0,
6350 "Return a description of the color named COLOR on frame FRAME.\n\
6351 The value is a list of integer RGB values--(RED GREEN BLUE).\n\
6352 These values appear to range from 0 to 65280 or 65535, depending\n\
6353 on the system; white is (65280 65280 65280) or (65535 65535 65535).\n\
6354 If FRAME is omitted or nil, use the selected frame.")
6355 (color, frame)
6356 Lisp_Object color, frame;
6357 {
6358 COLORREF foo;
6359 FRAME_PTR f = check_x_frame (frame);
6360
6361 CHECK_STRING (color, 1);
6362
6363 if (defined_color (f, XSTRING (color)->data, &foo, 0))
6364 {
6365 Lisp_Object rgb[3];
6366
6367 rgb[0] = make_number ((GetRValue (foo) << 8) | GetRValue (foo));
6368 rgb[1] = make_number ((GetGValue (foo) << 8) | GetGValue (foo));
6369 rgb[2] = make_number ((GetBValue (foo) << 8) | GetBValue (foo));
6370 return Flist (3, rgb);
6371 }
6372 else
6373 return Qnil;
6374 }
6375
6376 DEFUN ("x-display-color-p", Fx_display_color_p, Sx_display_color_p, 0, 1, 0,
6377 "Return t if the X display supports color.\n\
6378 The optional argument DISPLAY specifies which display to ask about.\n\
6379 DISPLAY should be either a frame or a display name (a string).\n\
6380 If omitted or nil, that stands for the selected frame's display.")
6381 (display)
6382 Lisp_Object display;
6383 {
6384 struct w32_display_info *dpyinfo = check_x_display_info (display);
6385
6386 if ((dpyinfo->n_planes * dpyinfo->n_cbits) <= 2)
6387 return Qnil;
6388
6389 return Qt;
6390 }
6391
6392 DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p,
6393 0, 1, 0,
6394 "Return t if the X display supports shades of gray.\n\
6395 Note that color displays do support shades of gray.\n\
6396 The optional argument DISPLAY specifies which display to ask about.\n\
6397 DISPLAY should be either a frame or a display name (a string).\n\
6398 If omitted or nil, that stands for the selected frame's display.")
6399 (display)
6400 Lisp_Object display;
6401 {
6402 struct w32_display_info *dpyinfo = check_x_display_info (display);
6403
6404 if ((dpyinfo->n_planes * dpyinfo->n_cbits) <= 1)
6405 return Qnil;
6406
6407 return Qt;
6408 }
6409
6410 DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width,
6411 0, 1, 0,
6412 "Returns the width in pixels of the X display DISPLAY.\n\
6413 The optional argument DISPLAY specifies which display to ask about.\n\
6414 DISPLAY should be either a frame or a display name (a string).\n\
6415 If omitted or nil, that stands for the selected frame's display.")
6416 (display)
6417 Lisp_Object display;
6418 {
6419 struct w32_display_info *dpyinfo = check_x_display_info (display);
6420
6421 return make_number (dpyinfo->width);
6422 }
6423
6424 DEFUN ("x-display-pixel-height", Fx_display_pixel_height,
6425 Sx_display_pixel_height, 0, 1, 0,
6426 "Returns the height in pixels of the X display DISPLAY.\n\
6427 The optional argument DISPLAY specifies which display to ask about.\n\
6428 DISPLAY should be either a frame or a display name (a string).\n\
6429 If omitted or nil, that stands for the selected frame's display.")
6430 (display)
6431 Lisp_Object display;
6432 {
6433 struct w32_display_info *dpyinfo = check_x_display_info (display);
6434
6435 return make_number (dpyinfo->height);
6436 }
6437
6438 DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes,
6439 0, 1, 0,
6440 "Returns the number of bitplanes of the display DISPLAY.\n\
6441 The optional argument DISPLAY specifies which display to ask about.\n\
6442 DISPLAY should be either a frame or a display name (a string).\n\
6443 If omitted or nil, that stands for the selected frame's display.")
6444 (display)
6445 Lisp_Object display;
6446 {
6447 struct w32_display_info *dpyinfo = check_x_display_info (display);
6448
6449 return make_number (dpyinfo->n_planes * dpyinfo->n_cbits);
6450 }
6451
6452 DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells,
6453 0, 1, 0,
6454 "Returns the number of color cells of the display DISPLAY.\n\
6455 The optional argument DISPLAY specifies which display to ask about.\n\
6456 DISPLAY should be either a frame or a display name (a string).\n\
6457 If omitted or nil, that stands for the selected frame's display.")
6458 (display)
6459 Lisp_Object display;
6460 {
6461 struct w32_display_info *dpyinfo = check_x_display_info (display);
6462 HDC hdc;
6463 int cap;
6464
6465 hdc = GetDC (dpyinfo->root_window);
6466 if (dpyinfo->has_palette)
6467 cap = GetDeviceCaps (hdc,SIZEPALETTE);
6468 else
6469 cap = GetDeviceCaps (hdc,NUMCOLORS);
6470
6471 ReleaseDC (dpyinfo->root_window, hdc);
6472
6473 return make_number (cap);
6474 }
6475
6476 DEFUN ("x-server-max-request-size", Fx_server_max_request_size,
6477 Sx_server_max_request_size,
6478 0, 1, 0,
6479 "Returns the maximum request size of the server of display DISPLAY.\n\
6480 The optional argument DISPLAY specifies which display to ask about.\n\
6481 DISPLAY should be either a frame or a display name (a string).\n\
6482 If omitted or nil, that stands for the selected frame's display.")
6483 (display)
6484 Lisp_Object display;
6485 {
6486 struct w32_display_info *dpyinfo = check_x_display_info (display);
6487
6488 return make_number (1);
6489 }
6490
6491 DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
6492 "Returns the vendor ID string of the W32 system (Microsoft).\n\
6493 The optional argument DISPLAY specifies which display to ask about.\n\
6494 DISPLAY should be either a frame or a display name (a string).\n\
6495 If omitted or nil, that stands for the selected frame's display.")
6496 (display)
6497 Lisp_Object display;
6498 {
6499 struct w32_display_info *dpyinfo = check_x_display_info (display);
6500 char *vendor = "Microsoft Corp.";
6501
6502 if (! vendor) vendor = "";
6503 return build_string (vendor);
6504 }
6505
6506 DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0,
6507 "Returns the version numbers of the server of display DISPLAY.\n\
6508 The value is a list of three integers: the major and minor\n\
6509 version numbers, and the vendor-specific release\n\
6510 number. See also the function `x-server-vendor'.\n\n\
6511 The optional argument DISPLAY specifies which display to ask about.\n\
6512 DISPLAY should be either a frame or a display name (a string).\n\
6513 If omitted or nil, that stands for the selected frame's display.")
6514 (display)
6515 Lisp_Object display;
6516 {
6517 struct w32_display_info *dpyinfo = check_x_display_info (display);
6518
6519 return Fcons (make_number (w32_major_version),
6520 Fcons (make_number (w32_minor_version), Qnil));
6521 }
6522
6523 DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0,
6524 "Returns the number of screens on the server of display DISPLAY.\n\
6525 The optional argument DISPLAY specifies which display to ask about.\n\
6526 DISPLAY should be either a frame or a display name (a string).\n\
6527 If omitted or nil, that stands for the selected frame's display.")
6528 (display)
6529 Lisp_Object display;
6530 {
6531 struct w32_display_info *dpyinfo = check_x_display_info (display);
6532
6533 return make_number (1);
6534 }
6535
6536 DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0,
6537 "Returns the height in millimeters of the X display DISPLAY.\n\
6538 The optional argument DISPLAY specifies which display to ask about.\n\
6539 DISPLAY should be either a frame or a display name (a string).\n\
6540 If omitted or nil, that stands for the selected frame's display.")
6541 (display)
6542 Lisp_Object display;
6543 {
6544 struct w32_display_info *dpyinfo = check_x_display_info (display);
6545 HDC hdc;
6546 int cap;
6547
6548 hdc = GetDC (dpyinfo->root_window);
6549
6550 cap = GetDeviceCaps (hdc, VERTSIZE);
6551
6552 ReleaseDC (dpyinfo->root_window, hdc);
6553
6554 return make_number (cap);
6555 }
6556
6557 DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0,
6558 "Returns the width in millimeters of the X display DISPLAY.\n\
6559 The optional argument DISPLAY specifies which display to ask about.\n\
6560 DISPLAY should be either a frame or a display name (a string).\n\
6561 If omitted or nil, that stands for the selected frame's display.")
6562 (display)
6563 Lisp_Object display;
6564 {
6565 struct w32_display_info *dpyinfo = check_x_display_info (display);
6566
6567 HDC hdc;
6568 int cap;
6569
6570 hdc = GetDC (dpyinfo->root_window);
6571
6572 cap = GetDeviceCaps (hdc, HORZSIZE);
6573
6574 ReleaseDC (dpyinfo->root_window, hdc);
6575
6576 return make_number (cap);
6577 }
6578
6579 DEFUN ("x-display-backing-store", Fx_display_backing_store,
6580 Sx_display_backing_store, 0, 1, 0,
6581 "Returns an indication of whether display DISPLAY does backing store.\n\
6582 The value may be `always', `when-mapped', or `not-useful'.\n\
6583 The optional argument DISPLAY specifies which display to ask about.\n\
6584 DISPLAY should be either a frame or a display name (a string).\n\
6585 If omitted or nil, that stands for the selected frame's display.")
6586 (display)
6587 Lisp_Object display;
6588 {
6589 return intern ("not-useful");
6590 }
6591
6592 DEFUN ("x-display-visual-class", Fx_display_visual_class,
6593 Sx_display_visual_class, 0, 1, 0,
6594 "Returns the visual class of the display DISPLAY.\n\
6595 The value is one of the symbols `static-gray', `gray-scale',\n\
6596 `static-color', `pseudo-color', `true-color', or `direct-color'.\n\n\
6597 The optional argument DISPLAY specifies which display to ask about.\n\
6598 DISPLAY should be either a frame or a display name (a string).\n\
6599 If omitted or nil, that stands for the selected frame's display.")
6600 (display)
6601 Lisp_Object display;
6602 {
6603 struct w32_display_info *dpyinfo = check_x_display_info (display);
6604
6605 #if 0
6606 switch (dpyinfo->visual->class)
6607 {
6608 case StaticGray: return (intern ("static-gray"));
6609 case GrayScale: return (intern ("gray-scale"));
6610 case StaticColor: return (intern ("static-color"));
6611 case PseudoColor: return (intern ("pseudo-color"));
6612 case TrueColor: return (intern ("true-color"));
6613 case DirectColor: return (intern ("direct-color"));
6614 default:
6615 error ("Display has an unknown visual class");
6616 }
6617 #endif
6618
6619 error ("Display has an unknown visual class");
6620 }
6621
6622 DEFUN ("x-display-save-under", Fx_display_save_under,
6623 Sx_display_save_under, 0, 1, 0,
6624 "Returns t if the display DISPLAY supports the save-under feature.\n\
6625 The optional argument DISPLAY specifies which display to ask about.\n\
6626 DISPLAY should be either a frame or a display name (a string).\n\
6627 If omitted or nil, that stands for the selected frame's display.")
6628 (display)
6629 Lisp_Object display;
6630 {
6631 struct w32_display_info *dpyinfo = check_x_display_info (display);
6632
6633 return Qnil;
6634 }
6635 \f
6636 int
6637 x_pixel_width (f)
6638 register struct frame *f;
6639 {
6640 return PIXEL_WIDTH (f);
6641 }
6642
6643 int
6644 x_pixel_height (f)
6645 register struct frame *f;
6646 {
6647 return PIXEL_HEIGHT (f);
6648 }
6649
6650 int
6651 x_char_width (f)
6652 register struct frame *f;
6653 {
6654 return FONT_WIDTH (f->output_data.w32->font);
6655 }
6656
6657 int
6658 x_char_height (f)
6659 register struct frame *f;
6660 {
6661 return f->output_data.w32->line_height;
6662 }
6663
6664 int
6665 x_screen_planes (frame)
6666 Lisp_Object frame;
6667 {
6668 return (FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_planes *
6669 FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_cbits);
6670 }
6671 \f
6672 /* Return the display structure for the display named NAME.
6673 Open a new connection if necessary. */
6674
6675 struct w32_display_info *
6676 x_display_info_for_name (name)
6677 Lisp_Object name;
6678 {
6679 Lisp_Object names;
6680 struct w32_display_info *dpyinfo;
6681
6682 CHECK_STRING (name, 0);
6683
6684 for (dpyinfo = &one_w32_display_info, names = w32_display_name_list;
6685 dpyinfo;
6686 dpyinfo = dpyinfo->next, names = XCONS (names)->cdr)
6687 {
6688 Lisp_Object tem;
6689 tem = Fstring_equal (XCONS (XCONS (names)->car)->car, name);
6690 if (!NILP (tem))
6691 return dpyinfo;
6692 }
6693
6694 /* Use this general default value to start with. */
6695 Vx_resource_name = Vinvocation_name;
6696
6697 validate_x_resource_name ();
6698
6699 dpyinfo = w32_term_init (name, (unsigned char *)0,
6700 (char *) XSTRING (Vx_resource_name)->data);
6701
6702 if (dpyinfo == 0)
6703 error ("Cannot connect to server %s", XSTRING (name)->data);
6704
6705 w32_in_use = 1;
6706 XSETFASTINT (Vwindow_system_version, 3);
6707
6708 return dpyinfo;
6709 }
6710
6711 DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection,
6712 1, 3, 0, "Open a connection to a server.\n\
6713 DISPLAY is the name of the display to connect to.\n\
6714 Optional second arg XRM-STRING is a string of resources in xrdb format.\n\
6715 If the optional third arg MUST-SUCCEED is non-nil,\n\
6716 terminate Emacs if we can't open the connection.")
6717 (display, xrm_string, must_succeed)
6718 Lisp_Object display, xrm_string, must_succeed;
6719 {
6720 unsigned int n_planes;
6721 unsigned char *xrm_option;
6722 struct w32_display_info *dpyinfo;
6723
6724 CHECK_STRING (display, 0);
6725 if (! NILP (xrm_string))
6726 CHECK_STRING (xrm_string, 1);
6727
6728 if (! EQ (Vwindow_system, intern ("w32")))
6729 error ("Not using Microsoft Windows");
6730
6731 /* Allow color mapping to be defined externally; first look in user's
6732 HOME directory, then in Emacs etc dir for a file called rgb.txt. */
6733 {
6734 Lisp_Object color_file;
6735 struct gcpro gcpro1;
6736
6737 color_file = build_string("~/rgb.txt");
6738
6739 GCPRO1 (color_file);
6740
6741 if (NILP (Ffile_readable_p (color_file)))
6742 color_file =
6743 Fexpand_file_name (build_string ("rgb.txt"),
6744 Fsymbol_value (intern ("data-directory")));
6745
6746 Vw32_color_map = Fw32_load_color_file (color_file);
6747
6748 UNGCPRO;
6749 }
6750 if (NILP (Vw32_color_map))
6751 Vw32_color_map = Fw32_default_color_map ();
6752
6753 if (! NILP (xrm_string))
6754 xrm_option = (unsigned char *) XSTRING (xrm_string)->data;
6755 else
6756 xrm_option = (unsigned char *) 0;
6757
6758 /* Use this general default value to start with. */
6759 /* First remove .exe suffix from invocation-name - it looks ugly. */
6760 {
6761 char basename[ MAX_PATH ], *str;
6762
6763 strcpy (basename, XSTRING (Vinvocation_name)->data);
6764 str = strrchr (basename, '.');
6765 if (str) *str = 0;
6766 Vinvocation_name = build_string (basename);
6767 }
6768 Vx_resource_name = Vinvocation_name;
6769
6770 validate_x_resource_name ();
6771
6772 /* This is what opens the connection and sets x_current_display.
6773 This also initializes many symbols, such as those used for input. */
6774 dpyinfo = w32_term_init (display, xrm_option,
6775 (char *) XSTRING (Vx_resource_name)->data);
6776
6777 if (dpyinfo == 0)
6778 {
6779 if (!NILP (must_succeed))
6780 fatal ("Cannot connect to server %s.\n",
6781 XSTRING (display)->data);
6782 else
6783 error ("Cannot connect to server %s", XSTRING (display)->data);
6784 }
6785
6786 w32_in_use = 1;
6787
6788 XSETFASTINT (Vwindow_system_version, 3);
6789 return Qnil;
6790 }
6791
6792 DEFUN ("x-close-connection", Fx_close_connection,
6793 Sx_close_connection, 1, 1, 0,
6794 "Close the connection to DISPLAY's server.\n\
6795 For DISPLAY, specify either a frame or a display name (a string).\n\
6796 If DISPLAY is nil, that stands for the selected frame's display.")
6797 (display)
6798 Lisp_Object display;
6799 {
6800 struct w32_display_info *dpyinfo = check_x_display_info (display);
6801 struct w32_display_info *tail;
6802 int i;
6803
6804 if (dpyinfo->reference_count > 0)
6805 error ("Display still has frames on it");
6806
6807 BLOCK_INPUT;
6808 /* Free the fonts in the font table. */
6809 for (i = 0; i < dpyinfo->n_fonts; i++)
6810 {
6811 if (dpyinfo->font_table[i].name)
6812 free (dpyinfo->font_table[i].name);
6813 /* Don't free the full_name string;
6814 it is always shared with something else. */
6815 w32_unload_font (dpyinfo, dpyinfo->font_table[i].font);
6816 }
6817 x_destroy_all_bitmaps (dpyinfo);
6818
6819 x_delete_display (dpyinfo);
6820 UNBLOCK_INPUT;
6821
6822 return Qnil;
6823 }
6824
6825 DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0,
6826 "Return the list of display names that Emacs has connections to.")
6827 ()
6828 {
6829 Lisp_Object tail, result;
6830
6831 result = Qnil;
6832 for (tail = w32_display_name_list; ! NILP (tail); tail = XCONS (tail)->cdr)
6833 result = Fcons (XCONS (XCONS (tail)->car)->car, result);
6834
6835 return result;
6836 }
6837
6838 DEFUN ("x-synchronize", Fx_synchronize, Sx_synchronize, 1, 2, 0,
6839 "If ON is non-nil, report errors as soon as the erring request is made.\n\
6840 If ON is nil, allow buffering of requests.\n\
6841 This is a noop on W32 systems.\n\
6842 The optional second argument DISPLAY specifies which display to act on.\n\
6843 DISPLAY should be either a frame or a display name (a string).\n\
6844 If DISPLAY is omitted or nil, that stands for the selected frame's display.")
6845 (on, display)
6846 Lisp_Object display, on;
6847 {
6848 struct w32_display_info *dpyinfo = check_x_display_info (display);
6849
6850 return Qnil;
6851 }
6852
6853 \f
6854 /* These are the w32 specialized functions */
6855
6856 DEFUN ("w32-select-font", Fw32_select_font, Sw32_select_font, 0, 1, 0,
6857 "This will display the W32 font dialog and return an X font string corresponding to the selection.")
6858 (frame)
6859 Lisp_Object frame;
6860 {
6861 FRAME_PTR f = check_x_frame (frame);
6862 CHOOSEFONT cf;
6863 LOGFONT lf;
6864 char buf[100];
6865
6866 bzero (&cf, sizeof (cf));
6867
6868 cf.lStructSize = sizeof (cf);
6869 cf.hwndOwner = FRAME_W32_WINDOW (f);
6870 cf.Flags = CF_FIXEDPITCHONLY | CF_FORCEFONTEXIST | CF_SCREENFONTS;
6871 cf.lpLogFont = &lf;
6872
6873 if (!ChooseFont (&cf) || !w32_to_x_font (&lf, buf, 100))
6874 return Qnil;
6875
6876 return build_string (buf);
6877 }
6878
6879 DEFUN ("w32-send-sys-command", Fw32_send_sys_command, Sw32_send_sys_command, 1, 2, 0,
6880 "Send frame a Windows WM_SYSCOMMAND message of type COMMAND.\n\
6881 Some useful values for command are 0xf030 to maximise frame (0xf020\n\
6882 to minimize), 0xf120 to restore frame to original size, and 0xf100\n\
6883 to activate the menubar for keyboard access. 0xf140 activates the\n\
6884 screen saver if defined.\n\
6885 \n\
6886 If optional parameter FRAME is not specified, use selected frame.")
6887 (command, frame)
6888 Lisp_Object command, frame;
6889 {
6890 WPARAM code;
6891 FRAME_PTR f = check_x_frame (frame);
6892
6893 CHECK_NUMBER (command, 0);
6894
6895 SendMessage (FRAME_W32_WINDOW (f), WM_SYSCOMMAND, XINT (command), 0);
6896
6897 return Qnil;
6898 }
6899
6900 /* Lookup virtual keycode from string representing the name of a
6901 non-ascii keystroke into the corresponding virtual key, using
6902 lispy_function_keys. */
6903 static int
6904 lookup_vk_code (char *key)
6905 {
6906 int i;
6907
6908 for (i = 0; i < 256; i++)
6909 if (lispy_function_keys[i] != 0
6910 && strcmp (lispy_function_keys[i], key) == 0)
6911 return i;
6912
6913 return -1;
6914 }
6915
6916 /* Convert a one-element vector style key sequence to a hot key
6917 definition. */
6918 static int
6919 w32_parse_hot_key (key)
6920 Lisp_Object key;
6921 {
6922 /* Copied from Fdefine_key and store_in_keymap. */
6923 register Lisp_Object c;
6924 int vk_code;
6925 int lisp_modifiers;
6926 int w32_modifiers;
6927 struct gcpro gcpro1;
6928
6929 CHECK_VECTOR (key, 0);
6930
6931 if (XFASTINT (Flength (key)) != 1)
6932 return Qnil;
6933
6934 GCPRO1 (key);
6935
6936 c = Faref (key, make_number (0));
6937
6938 if (CONSP (c) && lucid_event_type_list_p (c))
6939 c = Fevent_convert_list (c);
6940
6941 UNGCPRO;
6942
6943 if (! INTEGERP (c) && ! SYMBOLP (c))
6944 error ("Key definition is invalid");
6945
6946 /* Work out the base key and the modifiers. */
6947 if (SYMBOLP (c))
6948 {
6949 c = parse_modifiers (c);
6950 lisp_modifiers = Fcar (Fcdr (c));
6951 c = Fcar (c);
6952 if (!SYMBOLP (c))
6953 abort ();
6954 vk_code = lookup_vk_code (XSYMBOL (c)->name->data);
6955 }
6956 else if (INTEGERP (c))
6957 {
6958 lisp_modifiers = XINT (c) & ~CHARACTERBITS;
6959 /* Many ascii characters are their own virtual key code. */
6960 vk_code = XINT (c) & CHARACTERBITS;
6961 }
6962
6963 if (vk_code < 0 || vk_code > 255)
6964 return Qnil;
6965
6966 if ((lisp_modifiers & meta_modifier) != 0
6967 && !NILP (Vw32_alt_is_meta))
6968 lisp_modifiers |= alt_modifier;
6969
6970 /* Convert lisp modifiers to Windows hot-key form. */
6971 w32_modifiers = (lisp_modifiers & hyper_modifier) ? MOD_WIN : 0;
6972 w32_modifiers |= (lisp_modifiers & alt_modifier) ? MOD_ALT : 0;
6973 w32_modifiers |= (lisp_modifiers & ctrl_modifier) ? MOD_CONTROL : 0;
6974 w32_modifiers |= (lisp_modifiers & shift_modifier) ? MOD_SHIFT : 0;
6975
6976 return HOTKEY (vk_code, w32_modifiers);
6977 }
6978
6979 DEFUN ("w32-register-hot-key", Fw32_register_hot_key, Sw32_register_hot_key, 1, 1, 0,
6980 "Register KEY as a hot-key combination.\n\
6981 Certain key combinations like Alt-Tab are reserved for system use on\n\
6982 Windows, and therefore are normally intercepted by the system. However,\n\
6983 most of these key combinations can be received by registering them as\n\
6984 hot-keys, overriding their special meaning.\n\
6985 \n\
6986 KEY must be a one element key definition in vector form that would be\n\
6987 acceptable to `define-key' (e.g. [A-tab] for Alt-Tab). The meta\n\
6988 modifier is interpreted as Alt if `w32-alt-is-meta' is t, and hyper\n\
6989 is always interpreted as the Windows modifier keys.\n\
6990 \n\
6991 The return value is the hotkey-id if registered, otherwise nil.")
6992 (key)
6993 Lisp_Object key;
6994 {
6995 key = w32_parse_hot_key (key);
6996
6997 if (NILP (Fmemq (key, w32_grabbed_keys)))
6998 {
6999 /* Reuse an empty slot if possible. */
7000 Lisp_Object item = Fmemq (Qnil, w32_grabbed_keys);
7001
7002 /* Safe to add new key to list, even if we have focus. */
7003 if (NILP (item))
7004 w32_grabbed_keys = Fcons (key, w32_grabbed_keys);
7005 else
7006 XCAR (item) = key;
7007
7008 /* Notify input thread about new hot-key definition, so that it
7009 takes effect without needing to switch focus. */
7010 PostThreadMessage (dwWindowsThreadId, WM_EMACS_REGISTER_HOT_KEY,
7011 (WPARAM) key, 0);
7012 }
7013
7014 return key;
7015 }
7016
7017 DEFUN ("w32-unregister-hot-key", Fw32_unregister_hot_key, Sw32_unregister_hot_key, 1, 1, 0,
7018 "Unregister HOTKEY as a hot-key combination.")
7019 (key)
7020 Lisp_Object key;
7021 {
7022 Lisp_Object item;
7023
7024 if (!INTEGERP (key))
7025 key = w32_parse_hot_key (key);
7026
7027 item = Fmemq (key, w32_grabbed_keys);
7028
7029 if (!NILP (item))
7030 {
7031 /* Notify input thread about hot-key definition being removed, so
7032 that it takes effect without needing focus switch. */
7033 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_UNREGISTER_HOT_KEY,
7034 (WPARAM) XINT (XCAR (item)), (LPARAM) item))
7035 {
7036 MSG msg;
7037 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
7038 }
7039 return Qt;
7040 }
7041 return Qnil;
7042 }
7043
7044 DEFUN ("w32-registered-hot-keys", Fw32_registered_hot_keys, Sw32_registered_hot_keys, 0, 0, 0,
7045 "Return list of registered hot-key IDs.")
7046 ()
7047 {
7048 return Fcopy_sequence (w32_grabbed_keys);
7049 }
7050
7051 DEFUN ("w32-reconstruct-hot-key", Fw32_reconstruct_hot_key, Sw32_reconstruct_hot_key, 1, 1, 0,
7052 "Convert hot-key ID to a lisp key combination.")
7053 (hotkeyid)
7054 Lisp_Object hotkeyid;
7055 {
7056 int vk_code, w32_modifiers;
7057 Lisp_Object key;
7058
7059 CHECK_NUMBER (hotkeyid, 0);
7060
7061 vk_code = HOTKEY_VK_CODE (hotkeyid);
7062 w32_modifiers = HOTKEY_MODIFIERS (hotkeyid);
7063
7064 if (lispy_function_keys[vk_code])
7065 key = intern (lispy_function_keys[vk_code]);
7066 else
7067 key = make_number (vk_code);
7068
7069 key = Fcons (key, Qnil);
7070 if (w32_modifiers & MOD_SHIFT)
7071 key = Fcons (Qshift, key);
7072 if (w32_modifiers & MOD_CONTROL)
7073 key = Fcons (Qctrl, key);
7074 if (w32_modifiers & MOD_ALT)
7075 key = Fcons (NILP (Vw32_alt_is_meta) ? Qalt : Qmeta, key);
7076 if (w32_modifiers & MOD_WIN)
7077 key = Fcons (Qhyper, key);
7078
7079 return key;
7080 }
7081
7082 DEFUN ("w32-toggle-lock-key", Fw32_toggle_lock_key, Sw32_toggle_lock_key, 1, 2, 0,
7083 "Toggle the state of the lock key KEY.\n\
7084 KEY can be `capslock', `kp-numlock', or `scroll'.\n\
7085 If the optional parameter NEW-STATE is a number, then the state of KEY\n\
7086 is set to off if the low bit of NEW-STATE is zero, otherwise on.")
7087 (key, new_state)
7088 Lisp_Object key, new_state;
7089 {
7090 int vk_code;
7091 int cur_state;
7092
7093 if (EQ (key, intern ("capslock")))
7094 vk_code = VK_CAPITAL;
7095 else if (EQ (key, intern ("kp-numlock")))
7096 vk_code = VK_NUMLOCK;
7097 else if (EQ (key, intern ("scroll")))
7098 vk_code = VK_SCROLL;
7099 else
7100 return Qnil;
7101
7102 if (!dwWindowsThreadId)
7103 return make_number (w32_console_toggle_lock_key (vk_code, new_state));
7104
7105 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_TOGGLE_LOCK_KEY,
7106 (WPARAM) vk_code, (LPARAM) new_state))
7107 {
7108 MSG msg;
7109 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
7110 return make_number (msg.wParam);
7111 }
7112 return Qnil;
7113 }
7114 \f
7115 syms_of_w32fns ()
7116 {
7117 /* This is zero if not using MS-Windows. */
7118 w32_in_use = 0;
7119
7120 /* The section below is built by the lisp expression at the top of the file,
7121 just above where these variables are declared. */
7122 /*&&& init symbols here &&&*/
7123 Qauto_raise = intern ("auto-raise");
7124 staticpro (&Qauto_raise);
7125 Qauto_lower = intern ("auto-lower");
7126 staticpro (&Qauto_lower);
7127 Qbackground_color = intern ("background-color");
7128 staticpro (&Qbackground_color);
7129 Qbar = intern ("bar");
7130 staticpro (&Qbar);
7131 Qborder_color = intern ("border-color");
7132 staticpro (&Qborder_color);
7133 Qborder_width = intern ("border-width");
7134 staticpro (&Qborder_width);
7135 Qbox = intern ("box");
7136 staticpro (&Qbox);
7137 Qcursor_color = intern ("cursor-color");
7138 staticpro (&Qcursor_color);
7139 Qcursor_type = intern ("cursor-type");
7140 staticpro (&Qcursor_type);
7141 Qforeground_color = intern ("foreground-color");
7142 staticpro (&Qforeground_color);
7143 Qgeometry = intern ("geometry");
7144 staticpro (&Qgeometry);
7145 Qicon_left = intern ("icon-left");
7146 staticpro (&Qicon_left);
7147 Qicon_top = intern ("icon-top");
7148 staticpro (&Qicon_top);
7149 Qicon_type = intern ("icon-type");
7150 staticpro (&Qicon_type);
7151 Qicon_name = intern ("icon-name");
7152 staticpro (&Qicon_name);
7153 Qinternal_border_width = intern ("internal-border-width");
7154 staticpro (&Qinternal_border_width);
7155 Qleft = intern ("left");
7156 staticpro (&Qleft);
7157 Qright = intern ("right");
7158 staticpro (&Qright);
7159 Qmouse_color = intern ("mouse-color");
7160 staticpro (&Qmouse_color);
7161 Qnone = intern ("none");
7162 staticpro (&Qnone);
7163 Qparent_id = intern ("parent-id");
7164 staticpro (&Qparent_id);
7165 Qscroll_bar_width = intern ("scroll-bar-width");
7166 staticpro (&Qscroll_bar_width);
7167 Qsuppress_icon = intern ("suppress-icon");
7168 staticpro (&Qsuppress_icon);
7169 Qtop = intern ("top");
7170 staticpro (&Qtop);
7171 Qundefined_color = intern ("undefined-color");
7172 staticpro (&Qundefined_color);
7173 Qvertical_scroll_bars = intern ("vertical-scroll-bars");
7174 staticpro (&Qvertical_scroll_bars);
7175 Qvisibility = intern ("visibility");
7176 staticpro (&Qvisibility);
7177 Qwindow_id = intern ("window-id");
7178 staticpro (&Qwindow_id);
7179 Qx_frame_parameter = intern ("x-frame-parameter");
7180 staticpro (&Qx_frame_parameter);
7181 Qx_resource_name = intern ("x-resource-name");
7182 staticpro (&Qx_resource_name);
7183 Quser_position = intern ("user-position");
7184 staticpro (&Quser_position);
7185 Quser_size = intern ("user-size");
7186 staticpro (&Quser_size);
7187 Qdisplay = intern ("display");
7188 staticpro (&Qdisplay);
7189 /* This is the end of symbol initialization. */
7190
7191 Qhyper = intern ("hyper");
7192 staticpro (&Qhyper);
7193 Qsuper = intern ("super");
7194 staticpro (&Qsuper);
7195 Qmeta = intern ("meta");
7196 staticpro (&Qmeta);
7197 Qalt = intern ("alt");
7198 staticpro (&Qalt);
7199 Qctrl = intern ("ctrl");
7200 staticpro (&Qctrl);
7201 Qcontrol = intern ("control");
7202 staticpro (&Qcontrol);
7203 Qshift = intern ("shift");
7204 staticpro (&Qshift);
7205
7206 Qface_set_after_frame_default = intern ("face-set-after-frame-default");
7207 staticpro (&Qface_set_after_frame_default);
7208
7209 Fput (Qundefined_color, Qerror_conditions,
7210 Fcons (Qundefined_color, Fcons (Qerror, Qnil)));
7211 Fput (Qundefined_color, Qerror_message,
7212 build_string ("Undefined color"));
7213
7214 staticpro (&w32_grabbed_keys);
7215 w32_grabbed_keys = Qnil;
7216
7217 DEFVAR_LISP ("w32-color-map", &Vw32_color_map,
7218 "An array of color name mappings for windows.");
7219 Vw32_color_map = Qnil;
7220
7221 DEFVAR_LISP ("w32-pass-alt-to-system", &Vw32_pass_alt_to_system,
7222 "Non-nil if alt key presses are passed on to Windows.\n\
7223 When non-nil, for example, alt pressed and released and then space will\n\
7224 open the System menu. When nil, Emacs silently swallows alt key events.");
7225 Vw32_pass_alt_to_system = Qnil;
7226
7227 DEFVAR_LISP ("w32-alt-is-meta", &Vw32_alt_is_meta,
7228 "Non-nil if the alt key is to be considered the same as the meta key.\n\
7229 When nil, Emacs will translate the alt key to the Alt modifier, and not Meta.");
7230 Vw32_alt_is_meta = Qt;
7231
7232 DEFVAR_INT ("w32-quit-key", &Vw32_quit_key,
7233 "If non-zero, the virtual key code for an alternative quit key.");
7234 XSETINT (Vw32_quit_key, 0);
7235
7236 DEFVAR_LISP ("w32-pass-lwindow-to-system",
7237 &Vw32_pass_lwindow_to_system,
7238 "Non-nil if the left \"Windows\" key is passed on to Windows.\n\
7239 When non-nil, the Start menu is opened by tapping the key.");
7240 Vw32_pass_lwindow_to_system = Qt;
7241
7242 DEFVAR_LISP ("w32-pass-rwindow-to-system",
7243 &Vw32_pass_rwindow_to_system,
7244 "Non-nil if the right \"Windows\" key is passed on to Windows.\n\
7245 When non-nil, the Start menu is opened by tapping the key.");
7246 Vw32_pass_rwindow_to_system = Qt;
7247
7248 DEFVAR_INT ("w32-phantom-key-code",
7249 &Vw32_phantom_key_code,
7250 "Virtual key code used to generate \"phantom\" key presses.\n\
7251 Value is a number between 0 and 255.\n\
7252 \n\
7253 Phantom key presses are generated in order to stop the system from\n\
7254 acting on \"Windows\" key events when `w32-pass-lwindow-to-system' or\n\
7255 `w32-pass-rwindow-to-system' is nil.");
7256 Vw32_phantom_key_code = VK_SPACE;
7257
7258 DEFVAR_LISP ("w32-enable-num-lock",
7259 &Vw32_enable_num_lock,
7260 "Non-nil if Num Lock should act normally.\n\
7261 Set to nil to see Num Lock as the key `kp-numlock'.");
7262 Vw32_enable_num_lock = Qt;
7263
7264 DEFVAR_LISP ("w32-enable-caps-lock",
7265 &Vw32_enable_caps_lock,
7266 "Non-nil if Caps Lock should act normally.\n\
7267 Set to nil to see Caps Lock as the key `capslock'.");
7268 Vw32_enable_caps_lock = Qt;
7269
7270 DEFVAR_LISP ("w32-scroll-lock-modifier",
7271 &Vw32_scroll_lock_modifier,
7272 "Modifier to use for the Scroll Lock on state.\n\
7273 The value can be hyper, super, meta, alt, control or shift for the\n\
7274 respective modifier, or nil to see Scroll Lock as the key `scroll'.\n\
7275 Any other value will cause the key to be ignored.");
7276 Vw32_scroll_lock_modifier = Qt;
7277
7278 DEFVAR_LISP ("w32-lwindow-modifier",
7279 &Vw32_lwindow_modifier,
7280 "Modifier to use for the left \"Windows\" key.\n\
7281 The value can be hyper, super, meta, alt, control or shift for the\n\
7282 respective modifier, or nil to appear as the key `lwindow'.\n\
7283 Any other value will cause the key to be ignored.");
7284 Vw32_lwindow_modifier = Qnil;
7285
7286 DEFVAR_LISP ("w32-rwindow-modifier",
7287 &Vw32_rwindow_modifier,
7288 "Modifier to use for the right \"Windows\" key.\n\
7289 The value can be hyper, super, meta, alt, control or shift for the\n\
7290 respective modifier, or nil to appear as the key `rwindow'.\n\
7291 Any other value will cause the key to be ignored.");
7292 Vw32_rwindow_modifier = Qnil;
7293
7294 DEFVAR_LISP ("w32-apps-modifier",
7295 &Vw32_apps_modifier,
7296 "Modifier to use for the \"Apps\" key.\n\
7297 The value can be hyper, super, meta, alt, control or shift for the\n\
7298 respective modifier, or nil to appear as the key `apps'.\n\
7299 Any other value will cause the key to be ignored.");
7300 Vw32_apps_modifier = Qnil;
7301
7302 DEFVAR_LISP ("w32-enable-italics", &Vw32_enable_italics,
7303 "Non-nil enables selection of artificially italicized fonts.");
7304 Vw32_enable_italics = Qnil;
7305
7306 DEFVAR_LISP ("w32-enable-palette", &Vw32_enable_palette,
7307 "Non-nil enables Windows palette management to map colors exactly.");
7308 Vw32_enable_palette = Qt;
7309
7310 DEFVAR_INT ("w32-mouse-button-tolerance",
7311 &Vw32_mouse_button_tolerance,
7312 "Analogue of double click interval for faking middle mouse events.\n\
7313 The value is the minimum time in milliseconds that must elapse between\n\
7314 left/right button down events before they are considered distinct events.\n\
7315 If both mouse buttons are depressed within this interval, a middle mouse\n\
7316 button down event is generated instead.");
7317 XSETINT (Vw32_mouse_button_tolerance, GetDoubleClickTime () / 2);
7318
7319 DEFVAR_INT ("w32-mouse-move-interval",
7320 &Vw32_mouse_move_interval,
7321 "Minimum interval between mouse move events.\n\
7322 The value is the minimum time in milliseconds that must elapse between\n\
7323 successive mouse move (or scroll bar drag) events before they are\n\
7324 reported as lisp events.");
7325 XSETINT (Vw32_mouse_move_interval, 0);
7326
7327 init_x_parm_symbols ();
7328
7329 DEFVAR_LISP ("x-bitmap-file-path", &Vx_bitmap_file_path,
7330 "List of directories to search for bitmap files for w32.");
7331 Vx_bitmap_file_path = decode_env_path ((char *) 0, "PATH");
7332
7333 DEFVAR_LISP ("x-pointer-shape", &Vx_pointer_shape,
7334 "The shape of the pointer when over text.\n\
7335 Changing the value does not affect existing frames\n\
7336 unless you set the mouse color.");
7337 Vx_pointer_shape = Qnil;
7338
7339 DEFVAR_LISP ("x-resource-name", &Vx_resource_name,
7340 "The name Emacs uses to look up resources; for internal use only.\n\
7341 `x-get-resource' uses this as the first component of the instance name\n\
7342 when requesting resource values.\n\
7343 Emacs initially sets `x-resource-name' to the name under which Emacs\n\
7344 was invoked, or to the value specified with the `-name' or `-rn'\n\
7345 switches, if present.");
7346 Vx_resource_name = Qnil;
7347
7348 Vx_nontext_pointer_shape = Qnil;
7349
7350 Vx_mode_pointer_shape = Qnil;
7351
7352 DEFVAR_INT ("x-sensitive-text-pointer-shape",
7353 &Vx_sensitive_text_pointer_shape,
7354 "The shape of the pointer when over mouse-sensitive text.\n\
7355 This variable takes effect when you create a new frame\n\
7356 or when you set the mouse color.");
7357 Vx_sensitive_text_pointer_shape = Qnil;
7358
7359 DEFVAR_LISP ("x-cursor-fore-pixel", &Vx_cursor_fore_pixel,
7360 "A string indicating the foreground color of the cursor box.");
7361 Vx_cursor_fore_pixel = Qnil;
7362
7363 DEFVAR_LISP ("x-no-window-manager", &Vx_no_window_manager,
7364 "Non-nil if no window manager is in use.\n\
7365 Emacs doesn't try to figure this out; this is always nil\n\
7366 unless you set it to something else.");
7367 /* We don't have any way to find this out, so set it to nil
7368 and maybe the user would like to set it to t. */
7369 Vx_no_window_manager = Qnil;
7370
7371 DEFVAR_LISP ("x-pixel-size-width-font-regexp",
7372 &Vx_pixel_size_width_font_regexp,
7373 "Regexp matching a font name whose width is the same as `PIXEL_SIZE'.\n\
7374 \n\
7375 Since Emacs gets width of a font matching with this regexp from\n\
7376 PIXEL_SIZE field of the name, font finding mechanism gets faster for\n\
7377 such a font. This is especially effective for such large fonts as\n\
7378 Chinese, Japanese, and Korean.");
7379 Vx_pixel_size_width_font_regexp = Qnil;
7380
7381 DEFVAR_BOOL ("unibyte-display-via-language-environment",
7382 &unibyte_display_via_language_environment,
7383 "*Non-nil means display unibyte text according to language environment.\n\
7384 Specifically this means that unibyte non-ASCII characters\n\
7385 are displayed by converting them to the equivalent multibyte characters\n\
7386 according to the current language environment. As a result, they are\n\
7387 displayed according to the current fontset.");
7388 unibyte_display_via_language_environment = 0;
7389
7390 DEFVAR_LISP ("w32-bdf-filename-alist",
7391 &Vw32_bdf_filename_alist,
7392 "List of bdf fonts and their corresponding filenames.");
7393 Vw32_bdf_filename_alist = Qnil;
7394
7395 defsubr (&Sx_get_resource);
7396 defsubr (&Sx_list_fonts);
7397 defsubr (&Sx_display_color_p);
7398 defsubr (&Sx_display_grayscale_p);
7399 defsubr (&Sx_color_defined_p);
7400 defsubr (&Sx_color_values);
7401 defsubr (&Sx_server_max_request_size);
7402 defsubr (&Sx_server_vendor);
7403 defsubr (&Sx_server_version);
7404 defsubr (&Sx_display_pixel_width);
7405 defsubr (&Sx_display_pixel_height);
7406 defsubr (&Sx_display_mm_width);
7407 defsubr (&Sx_display_mm_height);
7408 defsubr (&Sx_display_screens);
7409 defsubr (&Sx_display_planes);
7410 defsubr (&Sx_display_color_cells);
7411 defsubr (&Sx_display_visual_class);
7412 defsubr (&Sx_display_backing_store);
7413 defsubr (&Sx_display_save_under);
7414 defsubr (&Sx_parse_geometry);
7415 defsubr (&Sx_create_frame);
7416 defsubr (&Sx_open_connection);
7417 defsubr (&Sx_close_connection);
7418 defsubr (&Sx_display_list);
7419 defsubr (&Sx_synchronize);
7420
7421 /* W32 specific functions */
7422
7423 defsubr (&Sw32_focus_frame);
7424 defsubr (&Sw32_select_font);
7425 defsubr (&Sw32_define_rgb_color);
7426 defsubr (&Sw32_default_color_map);
7427 defsubr (&Sw32_load_color_file);
7428 defsubr (&Sw32_send_sys_command);
7429 defsubr (&Sw32_register_hot_key);
7430 defsubr (&Sw32_unregister_hot_key);
7431 defsubr (&Sw32_registered_hot_keys);
7432 defsubr (&Sw32_reconstruct_hot_key);
7433 defsubr (&Sw32_toggle_lock_key);
7434 defsubr (&Sw32_find_bdf_fonts);
7435
7436 /* Setting callback functions for fontset handler. */
7437 get_font_info_func = w32_get_font_info;
7438 list_fonts_func = w32_list_fonts;
7439 load_font_func = w32_load_font;
7440 find_ccl_program_func = w32_find_ccl_program;
7441 query_font_func = w32_query_font;
7442 set_frame_fontset_func = x_set_font;
7443 check_window_system_func = check_w32;
7444 }
7445
7446 #undef abort
7447
7448 void
7449 w32_abort()
7450 {
7451 int button;
7452 button = MessageBox (NULL,
7453 "A fatal error has occurred!\n\n"
7454 "Select Abort to exit, Retry to debug, Ignore to continue",
7455 "Emacs Abort Dialog",
7456 MB_ICONEXCLAMATION | MB_TASKMODAL
7457 | MB_SETFOREGROUND | MB_ABORTRETRYIGNORE);
7458 switch (button)
7459 {
7460 case IDRETRY:
7461 DebugBreak ();
7462 break;
7463 case IDIGNORE:
7464 break;
7465 case IDABORT:
7466 default:
7467 abort ();
7468 break;
7469 }
7470 }
7471
7472 /* For convenience when debugging. */
7473 int
7474 w32_last_error()
7475 {
7476 return GetLastError ();
7477 }