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