Update calls to openp.
[bpt/emacs.git] / src / w32fns.c
1 /* Graphical user interface functions for the Microsoft W32 API.
2 Copyright (C) 1989, 92, 93, 94, 95, 1996, 1997, 1998, 1999, 2000, 2001
3 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
21
22 /* Added by Kevin Gallo */
23
24 #include <config.h>
25
26 #include <signal.h>
27 #include <stdio.h>
28 #include <limits.h>
29 #include <errno.h>
30
31 #include "lisp.h"
32 #include "charset.h"
33 #include "dispextern.h"
34 #include "w32term.h"
35 #include "keyboard.h"
36 #include "frame.h"
37 #include "window.h"
38 #include "buffer.h"
39 #include "fontset.h"
40 #include "intervals.h"
41 #include "blockinput.h"
42 #include "epaths.h"
43 #include "w32heap.h"
44 #include "termhooks.h"
45 #include "coding.h"
46 #include "ccl.h"
47 #include "systime.h"
48
49 #include "bitmaps/gray.xbm"
50
51 #include <commdlg.h>
52 #include <shellapi.h>
53 #include <ctype.h>
54
55 #define max(a, b) ((a) > (b) ? (a) : (b))
56
57 extern void free_frame_menubar ();
58 extern double atof ();
59 extern int w32_console_toggle_lock_key (int vk_code, Lisp_Object new_state);
60 extern int quit_char;
61
62 /* A definition of XColor for non-X frames. */
63 #ifndef HAVE_X_WINDOWS
64 typedef struct {
65 unsigned long pixel;
66 unsigned short red, green, blue;
67 char flags;
68 char pad;
69 } XColor;
70 #endif
71
72 extern char *lispy_function_keys[];
73
74 /* The gray bitmap `bitmaps/gray'. This is done because w32term.c uses
75 it, and including `bitmaps/gray' more than once is a problem when
76 config.h defines `static' as an empty replacement string. */
77
78 int gray_bitmap_width = gray_width;
79 int gray_bitmap_height = gray_height;
80 unsigned char *gray_bitmap_bits = gray_bits;
81
82 /* The colormap for converting color names to RGB values */
83 Lisp_Object Vw32_color_map;
84
85 /* Non nil if alt key presses are passed on to Windows. */
86 Lisp_Object Vw32_pass_alt_to_system;
87
88 /* Non nil if alt key is translated to meta_modifier, nil if it is translated
89 to alt_modifier. */
90 Lisp_Object Vw32_alt_is_meta;
91
92 /* If non-zero, the windows virtual key code for an alternative quit key. */
93 Lisp_Object Vw32_quit_key;
94
95 /* Non nil if left window key events are passed on to Windows (this only
96 affects whether "tapping" the key opens the Start menu). */
97 Lisp_Object Vw32_pass_lwindow_to_system;
98
99 /* Non nil if right window key events are passed on to Windows (this
100 only affects whether "tapping" the key opens the Start menu). */
101 Lisp_Object Vw32_pass_rwindow_to_system;
102
103 /* Virtual key code used to generate "phantom" key presses in order
104 to stop system from acting on Windows key events. */
105 Lisp_Object Vw32_phantom_key_code;
106
107 /* Modifier associated with the left "Windows" key, or nil to act as a
108 normal key. */
109 Lisp_Object Vw32_lwindow_modifier;
110
111 /* Modifier associated with the right "Windows" key, or nil to act as a
112 normal key. */
113 Lisp_Object Vw32_rwindow_modifier;
114
115 /* Modifier associated with the "Apps" key, or nil to act as a normal
116 key. */
117 Lisp_Object Vw32_apps_modifier;
118
119 /* Value is nil if Num Lock acts as a function key. */
120 Lisp_Object Vw32_enable_num_lock;
121
122 /* Value is nil if Caps Lock acts as a function key. */
123 Lisp_Object Vw32_enable_caps_lock;
124
125 /* Modifier associated with Scroll Lock, or nil to act as a normal key. */
126 Lisp_Object Vw32_scroll_lock_modifier;
127
128 /* Switch to control whether we inhibit requests for synthesized bold
129 and italic versions of fonts. */
130 Lisp_Object Vw32_enable_synthesized_fonts;
131
132 /* Enable palette management. */
133 Lisp_Object Vw32_enable_palette;
134
135 /* Control how close left/right button down events must be to
136 be converted to a middle button down event. */
137 Lisp_Object Vw32_mouse_button_tolerance;
138
139 /* Minimum interval between mouse movement (and scroll bar drag)
140 events that are passed on to the event loop. */
141 Lisp_Object Vw32_mouse_move_interval;
142
143 /* The name we're using in resource queries. */
144 Lisp_Object Vx_resource_name;
145
146 /* Non nil if no window manager is in use. */
147 Lisp_Object Vx_no_window_manager;
148
149 /* Non-zero means we're allowed to display a hourglass pointer. */
150
151 int display_hourglass_p;
152
153 /* The background and shape of the mouse pointer, and shape when not
154 over text or in the modeline. */
155
156 Lisp_Object Vx_pointer_shape, Vx_nontext_pointer_shape, Vx_mode_pointer_shape;
157 Lisp_Object Vx_hourglass_pointer_shape, Vx_window_horizontal_drag_shape;
158
159 /* The shape when over mouse-sensitive text. */
160
161 Lisp_Object Vx_sensitive_text_pointer_shape;
162
163 /* Color of chars displayed in cursor box. */
164
165 Lisp_Object Vx_cursor_fore_pixel;
166
167 /* Nonzero if using Windows. */
168
169 static int w32_in_use;
170
171 /* Search path for bitmap files. */
172
173 Lisp_Object Vx_bitmap_file_path;
174
175 /* Regexp matching a font name whose width is the same as `PIXEL_SIZE'. */
176
177 Lisp_Object Vx_pixel_size_width_font_regexp;
178
179 /* Alist of bdf fonts and the files that define them. */
180 Lisp_Object Vw32_bdf_filename_alist;
181
182 Lisp_Object Vw32_system_coding_system;
183
184 /* A flag to control whether fonts are matched strictly or not. */
185 int w32_strict_fontnames;
186
187 /* A flag to control whether we should only repaint if GetUpdateRect
188 indicates there is an update region. */
189 int w32_strict_painting;
190
191 /* Associative list linking character set strings to Windows codepages. */
192 Lisp_Object Vw32_charset_info_alist;
193
194 /* VIETNAMESE_CHARSET is not defined in some versions of MSVC. */
195 #ifndef VIETNAMESE_CHARSET
196 #define VIETNAMESE_CHARSET 163
197 #endif
198
199 Lisp_Object Qauto_raise;
200 Lisp_Object Qauto_lower;
201 Lisp_Object Qbar;
202 Lisp_Object Qborder_color;
203 Lisp_Object Qborder_width;
204 Lisp_Object Qbox;
205 Lisp_Object Qcursor_color;
206 Lisp_Object Qcursor_type;
207 Lisp_Object Qgeometry;
208 Lisp_Object Qicon_left;
209 Lisp_Object Qicon_top;
210 Lisp_Object Qicon_type;
211 Lisp_Object Qicon_name;
212 Lisp_Object Qinternal_border_width;
213 Lisp_Object Qleft;
214 Lisp_Object Qright;
215 Lisp_Object Qmouse_color;
216 Lisp_Object Qnone;
217 Lisp_Object Qparent_id;
218 Lisp_Object Qscroll_bar_width;
219 Lisp_Object Qsuppress_icon;
220 Lisp_Object Qundefined_color;
221 Lisp_Object Qvertical_scroll_bars;
222 Lisp_Object Qvisibility;
223 Lisp_Object Qwindow_id;
224 Lisp_Object Qx_frame_parameter;
225 Lisp_Object Qx_resource_name;
226 Lisp_Object Quser_position;
227 Lisp_Object Quser_size;
228 Lisp_Object Qscreen_gamma;
229 Lisp_Object Qline_spacing;
230 Lisp_Object Qcenter;
231 Lisp_Object Qcancel_timer;
232 Lisp_Object Qhyper;
233 Lisp_Object Qsuper;
234 Lisp_Object Qmeta;
235 Lisp_Object Qalt;
236 Lisp_Object Qctrl;
237 Lisp_Object Qcontrol;
238 Lisp_Object Qshift;
239
240 Lisp_Object Qw32_charset_ansi;
241 Lisp_Object Qw32_charset_default;
242 Lisp_Object Qw32_charset_symbol;
243 Lisp_Object Qw32_charset_shiftjis;
244 Lisp_Object Qw32_charset_hangeul;
245 Lisp_Object Qw32_charset_gb2312;
246 Lisp_Object Qw32_charset_chinesebig5;
247 Lisp_Object Qw32_charset_oem;
248
249 #ifndef JOHAB_CHARSET
250 #define JOHAB_CHARSET 130
251 #endif
252 #ifdef JOHAB_CHARSET
253 Lisp_Object Qw32_charset_easteurope;
254 Lisp_Object Qw32_charset_turkish;
255 Lisp_Object Qw32_charset_baltic;
256 Lisp_Object Qw32_charset_russian;
257 Lisp_Object Qw32_charset_arabic;
258 Lisp_Object Qw32_charset_greek;
259 Lisp_Object Qw32_charset_hebrew;
260 Lisp_Object Qw32_charset_vietnamese;
261 Lisp_Object Qw32_charset_thai;
262 Lisp_Object Qw32_charset_johab;
263 Lisp_Object Qw32_charset_mac;
264 #endif
265
266 #ifdef UNICODE_CHARSET
267 Lisp_Object Qw32_charset_unicode;
268 #endif
269
270 extern Lisp_Object Qtop;
271 extern Lisp_Object Qdisplay;
272 extern Lisp_Object Qtool_bar_lines;
273
274 /* State variables for emulating a three button mouse. */
275 #define LMOUSE 1
276 #define MMOUSE 2
277 #define RMOUSE 4
278
279 static int button_state = 0;
280 static W32Msg saved_mouse_button_msg;
281 static unsigned mouse_button_timer; /* non-zero when timer is active */
282 static W32Msg saved_mouse_move_msg;
283 static unsigned mouse_move_timer;
284
285 /* W95 mousewheel handler */
286 unsigned int msh_mousewheel = 0;
287
288 #define MOUSE_BUTTON_ID 1
289 #define MOUSE_MOVE_ID 2
290
291 /* The below are defined in frame.c. */
292
293 extern Lisp_Object Qheight, Qminibuffer, Qname, Qonly, Qwidth;
294 extern Lisp_Object Qunsplittable, Qmenu_bar_lines, Qbuffer_predicate, Qtitle;
295 extern Lisp_Object Qtool_bar_lines;
296
297 extern Lisp_Object Vwindow_system_version;
298
299 Lisp_Object Qface_set_after_frame_default;
300
301 #ifdef GLYPH_DEBUG
302 int image_cache_refcount, dpyinfo_refcount;
303 #endif
304
305
306 /* From w32term.c. */
307 extern Lisp_Object Vw32_num_mouse_buttons;
308 extern Lisp_Object Vw32_recognize_altgr;
309
310 \f
311 /* Error if we are not connected to MS-Windows. */
312 void
313 check_w32 ()
314 {
315 if (! w32_in_use)
316 error ("MS-Windows not in use or not initialized");
317 }
318
319 /* Nonzero if we can use mouse menus.
320 You should not call this unless HAVE_MENUS is defined. */
321
322 int
323 have_menus_p ()
324 {
325 return w32_in_use;
326 }
327
328 /* Extract a frame as a FRAME_PTR, defaulting to the selected frame
329 and checking validity for W32. */
330
331 FRAME_PTR
332 check_x_frame (frame)
333 Lisp_Object frame;
334 {
335 FRAME_PTR f;
336
337 if (NILP (frame))
338 frame = selected_frame;
339 CHECK_LIVE_FRAME (frame, 0);
340 f = XFRAME (frame);
341 if (! FRAME_W32_P (f))
342 error ("non-w32 frame used");
343 return f;
344 }
345
346 /* Let the user specify an display with a frame.
347 nil stands for the selected frame--or, if that is not a w32 frame,
348 the first display on the list. */
349
350 static struct w32_display_info *
351 check_x_display_info (frame)
352 Lisp_Object frame;
353 {
354 if (NILP (frame))
355 {
356 struct frame *sf = XFRAME (selected_frame);
357
358 if (FRAME_W32_P (sf) && FRAME_LIVE_P (sf))
359 return FRAME_W32_DISPLAY_INFO (sf);
360 else
361 return &one_w32_display_info;
362 }
363 else if (STRINGP (frame))
364 return x_display_info_for_name (frame);
365 else
366 {
367 FRAME_PTR f;
368
369 CHECK_LIVE_FRAME (frame, 0);
370 f = XFRAME (frame);
371 if (! FRAME_W32_P (f))
372 error ("non-w32 frame used");
373 return FRAME_W32_DISPLAY_INFO (f);
374 }
375 }
376 \f
377 /* Return the Emacs frame-object corresponding to an w32 window.
378 It could be the frame's main window or an icon window. */
379
380 /* This function can be called during GC, so use GC_xxx type test macros. */
381
382 struct frame *
383 x_window_to_frame (dpyinfo, wdesc)
384 struct w32_display_info *dpyinfo;
385 HWND wdesc;
386 {
387 Lisp_Object tail, frame;
388 struct frame *f;
389
390 for (tail = Vframe_list; GC_CONSP (tail); tail = XCDR (tail))
391 {
392 frame = XCAR (tail);
393 if (!GC_FRAMEP (frame))
394 continue;
395 f = XFRAME (frame);
396 if (!FRAME_W32_P (f) || FRAME_W32_DISPLAY_INFO (f) != dpyinfo)
397 continue;
398 if (f->output_data.w32->hourglass_window == wdesc)
399 return f;
400
401 /* TODO: Check tooltips when supported. */
402 if (FRAME_W32_WINDOW (f) == wdesc)
403 return f;
404 }
405 return 0;
406 }
407
408 \f
409
410 /* Code to deal with bitmaps. Bitmaps are referenced by their bitmap
411 id, which is just an int that this section returns. Bitmaps are
412 reference counted so they can be shared among frames.
413
414 Bitmap indices are guaranteed to be > 0, so a negative number can
415 be used to indicate no bitmap.
416
417 If you use x_create_bitmap_from_data, then you must keep track of
418 the bitmaps yourself. That is, creating a bitmap from the same
419 data more than once will not be caught. */
420
421
422 /* Functions to access the contents of a bitmap, given an id. */
423
424 int
425 x_bitmap_height (f, id)
426 FRAME_PTR f;
427 int id;
428 {
429 return FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].height;
430 }
431
432 int
433 x_bitmap_width (f, id)
434 FRAME_PTR f;
435 int id;
436 {
437 return FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].width;
438 }
439
440 int
441 x_bitmap_pixmap (f, id)
442 FRAME_PTR f;
443 int id;
444 {
445 return (int) FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].pixmap;
446 }
447
448
449 /* Allocate a new bitmap record. Returns index of new record. */
450
451 static int
452 x_allocate_bitmap_record (f)
453 FRAME_PTR f;
454 {
455 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
456 int i;
457
458 if (dpyinfo->bitmaps == NULL)
459 {
460 dpyinfo->bitmaps_size = 10;
461 dpyinfo->bitmaps
462 = (struct w32_bitmap_record *) xmalloc (dpyinfo->bitmaps_size * sizeof (struct w32_bitmap_record));
463 dpyinfo->bitmaps_last = 1;
464 return 1;
465 }
466
467 if (dpyinfo->bitmaps_last < dpyinfo->bitmaps_size)
468 return ++dpyinfo->bitmaps_last;
469
470 for (i = 0; i < dpyinfo->bitmaps_size; ++i)
471 if (dpyinfo->bitmaps[i].refcount == 0)
472 return i + 1;
473
474 dpyinfo->bitmaps_size *= 2;
475 dpyinfo->bitmaps
476 = (struct w32_bitmap_record *) xrealloc (dpyinfo->bitmaps,
477 dpyinfo->bitmaps_size * sizeof (struct w32_bitmap_record));
478 return ++dpyinfo->bitmaps_last;
479 }
480
481 /* Add one reference to the reference count of the bitmap with id ID. */
482
483 void
484 x_reference_bitmap (f, id)
485 FRAME_PTR f;
486 int id;
487 {
488 ++FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].refcount;
489 }
490
491 /* Create a bitmap for frame F from a HEIGHT x WIDTH array of bits at BITS. */
492
493 int
494 x_create_bitmap_from_data (f, bits, width, height)
495 struct frame *f;
496 char *bits;
497 unsigned int width, height;
498 {
499 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
500 Pixmap bitmap;
501 int id;
502
503 bitmap = CreateBitmap (width, height,
504 FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_planes,
505 FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_cbits,
506 bits);
507
508 if (! bitmap)
509 return -1;
510
511 id = x_allocate_bitmap_record (f);
512 dpyinfo->bitmaps[id - 1].pixmap = bitmap;
513 dpyinfo->bitmaps[id - 1].file = NULL;
514 dpyinfo->bitmaps[id - 1].hinst = NULL;
515 dpyinfo->bitmaps[id - 1].refcount = 1;
516 dpyinfo->bitmaps[id - 1].depth = 1;
517 dpyinfo->bitmaps[id - 1].height = height;
518 dpyinfo->bitmaps[id - 1].width = width;
519
520 return id;
521 }
522
523 /* Create bitmap from file FILE for frame F. */
524
525 int
526 x_create_bitmap_from_file (f, file)
527 struct frame *f;
528 Lisp_Object file;
529 {
530 return -1;
531 #if 0 /* TODO : bitmap support */
532 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
533 unsigned int width, height;
534 HBITMAP bitmap;
535 int xhot, yhot, result, id;
536 Lisp_Object found;
537 int fd;
538 char *filename;
539 HINSTANCE hinst;
540
541 /* Look for an existing bitmap with the same name. */
542 for (id = 0; id < dpyinfo->bitmaps_last; ++id)
543 {
544 if (dpyinfo->bitmaps[id].refcount
545 && dpyinfo->bitmaps[id].file
546 && !strcmp (dpyinfo->bitmaps[id].file, (char *) XSTRING (file)->data))
547 {
548 ++dpyinfo->bitmaps[id].refcount;
549 return id + 1;
550 }
551 }
552
553 /* Search bitmap-file-path for the file, if appropriate. */
554 fd = openp (Vx_bitmap_file_path, file, Qnil, &found, 0);
555 if (fd < 0)
556 return -1;
557 emacs_close (fd);
558
559 filename = (char *) XSTRING (found)->data;
560
561 hinst = LoadLibraryEx (filename, NULL, LOAD_LIBRARY_AS_DATAFILE);
562
563 if (hinst == NULL)
564 return -1;
565
566
567 result = XReadBitmapFile (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
568 filename, &width, &height, &bitmap, &xhot, &yhot);
569 if (result != BitmapSuccess)
570 return -1;
571
572 id = x_allocate_bitmap_record (f);
573 dpyinfo->bitmaps[id - 1].pixmap = bitmap;
574 dpyinfo->bitmaps[id - 1].refcount = 1;
575 dpyinfo->bitmaps[id - 1].file = (char *) xmalloc (XSTRING (file)->size + 1);
576 dpyinfo->bitmaps[id - 1].depth = 1;
577 dpyinfo->bitmaps[id - 1].height = height;
578 dpyinfo->bitmaps[id - 1].width = width;
579 strcpy (dpyinfo->bitmaps[id - 1].file, XSTRING (file)->data);
580
581 return id;
582 #endif /* TODO */
583 }
584
585 /* Remove reference to bitmap with id number ID. */
586
587 void
588 x_destroy_bitmap (f, id)
589 FRAME_PTR f;
590 int id;
591 {
592 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
593
594 if (id > 0)
595 {
596 --dpyinfo->bitmaps[id - 1].refcount;
597 if (dpyinfo->bitmaps[id - 1].refcount == 0)
598 {
599 BLOCK_INPUT;
600 DeleteObject (dpyinfo->bitmaps[id - 1].pixmap);
601 if (dpyinfo->bitmaps[id - 1].file)
602 {
603 xfree (dpyinfo->bitmaps[id - 1].file);
604 dpyinfo->bitmaps[id - 1].file = NULL;
605 }
606 UNBLOCK_INPUT;
607 }
608 }
609 }
610
611 /* Free all the bitmaps for the display specified by DPYINFO. */
612
613 static void
614 x_destroy_all_bitmaps (dpyinfo)
615 struct w32_display_info *dpyinfo;
616 {
617 int i;
618 for (i = 0; i < dpyinfo->bitmaps_last; i++)
619 if (dpyinfo->bitmaps[i].refcount > 0)
620 {
621 DeleteObject (dpyinfo->bitmaps[i].pixmap);
622 if (dpyinfo->bitmaps[i].file)
623 xfree (dpyinfo->bitmaps[i].file);
624 }
625 dpyinfo->bitmaps_last = 0;
626 }
627 \f
628 /* Connect the frame-parameter names for W32 frames
629 to the ways of passing the parameter values to the window system.
630
631 The name of a parameter, as a Lisp symbol,
632 has an `x-frame-parameter' property which is an integer in Lisp
633 but can be interpreted as an `enum x_frame_parm' in C. */
634
635 enum x_frame_parm
636 {
637 X_PARM_FOREGROUND_COLOR,
638 X_PARM_BACKGROUND_COLOR,
639 X_PARM_MOUSE_COLOR,
640 X_PARM_CURSOR_COLOR,
641 X_PARM_BORDER_COLOR,
642 X_PARM_ICON_TYPE,
643 X_PARM_FONT,
644 X_PARM_BORDER_WIDTH,
645 X_PARM_INTERNAL_BORDER_WIDTH,
646 X_PARM_NAME,
647 X_PARM_AUTORAISE,
648 X_PARM_AUTOLOWER,
649 X_PARM_VERT_SCROLL_BAR,
650 X_PARM_VISIBILITY,
651 X_PARM_MENU_BAR_LINES
652 };
653
654
655 struct x_frame_parm_table
656 {
657 char *name;
658 void (*setter) P_ ((struct frame *, Lisp_Object, Lisp_Object));
659 };
660
661 static Lisp_Object unwind_create_frame P_ ((Lisp_Object));
662 static Lisp_Object unwind_create_tip_frame P_ ((Lisp_Object));
663 static void x_change_window_heights P_ ((Lisp_Object, int));
664 /* TODO: Native Input Method support; see x_create_im. */
665 void x_set_foreground_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
666 static void x_set_line_spacing P_ ((struct frame *, Lisp_Object, Lisp_Object));
667 void x_set_background_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
668 void x_set_mouse_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
669 void x_set_cursor_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
670 void x_set_border_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
671 void x_set_cursor_type P_ ((struct frame *, Lisp_Object, Lisp_Object));
672 void x_set_icon_type P_ ((struct frame *, Lisp_Object, Lisp_Object));
673 void x_set_icon_name P_ ((struct frame *, Lisp_Object, Lisp_Object));
674 void x_set_font P_ ((struct frame *, Lisp_Object, Lisp_Object));
675 void x_set_border_width P_ ((struct frame *, Lisp_Object, Lisp_Object));
676 void x_set_internal_border_width P_ ((struct frame *, Lisp_Object,
677 Lisp_Object));
678 void x_explicitly_set_name P_ ((struct frame *, Lisp_Object, Lisp_Object));
679 void x_set_autoraise P_ ((struct frame *, Lisp_Object, Lisp_Object));
680 void x_set_autolower P_ ((struct frame *, Lisp_Object, Lisp_Object));
681 void x_set_vertical_scroll_bars P_ ((struct frame *, Lisp_Object,
682 Lisp_Object));
683 void x_set_visibility P_ ((struct frame *, Lisp_Object, Lisp_Object));
684 void x_set_menu_bar_lines P_ ((struct frame *, Lisp_Object, Lisp_Object));
685 void x_set_scroll_bar_width P_ ((struct frame *, Lisp_Object, Lisp_Object));
686 void x_set_title P_ ((struct frame *, Lisp_Object, Lisp_Object));
687 void x_set_unsplittable P_ ((struct frame *, Lisp_Object, Lisp_Object));
688 void x_set_tool_bar_lines P_ ((struct frame *, Lisp_Object, Lisp_Object));
689 static void x_set_screen_gamma P_ ((struct frame *, Lisp_Object, Lisp_Object));
690
691 static struct x_frame_parm_table x_frame_parms[] =
692 {
693 "auto-raise", x_set_autoraise,
694 "auto-lower", x_set_autolower,
695 "background-color", x_set_background_color,
696 "border-color", x_set_border_color,
697 "border-width", x_set_border_width,
698 "cursor-color", x_set_cursor_color,
699 "cursor-type", x_set_cursor_type,
700 "font", x_set_font,
701 "foreground-color", x_set_foreground_color,
702 "icon-name", x_set_icon_name,
703 "icon-type", x_set_icon_type,
704 "internal-border-width", x_set_internal_border_width,
705 "menu-bar-lines", x_set_menu_bar_lines,
706 "mouse-color", x_set_mouse_color,
707 "name", x_explicitly_set_name,
708 "scroll-bar-width", x_set_scroll_bar_width,
709 "title", x_set_title,
710 "unsplittable", x_set_unsplittable,
711 "vertical-scroll-bars", x_set_vertical_scroll_bars,
712 "visibility", x_set_visibility,
713 "tool-bar-lines", x_set_tool_bar_lines,
714 "screen-gamma", x_set_screen_gamma,
715 "line-spacing", x_set_line_spacing
716 };
717
718 /* Attach the `x-frame-parameter' properties to
719 the Lisp symbol names of parameters relevant to W32. */
720
721 void
722 init_x_parm_symbols ()
723 {
724 int i;
725
726 for (i = 0; i < sizeof (x_frame_parms) / sizeof (x_frame_parms[0]); i++)
727 Fput (intern (x_frame_parms[i].name), Qx_frame_parameter,
728 make_number (i));
729 }
730 \f
731 /* Change the parameters of frame F as specified by ALIST.
732 If a parameter is not specially recognized, do nothing;
733 otherwise call the `x_set_...' function for that parameter. */
734
735 void
736 x_set_frame_parameters (f, alist)
737 FRAME_PTR f;
738 Lisp_Object alist;
739 {
740 Lisp_Object tail;
741
742 /* If both of these parameters are present, it's more efficient to
743 set them both at once. So we wait until we've looked at the
744 entire list before we set them. */
745 int width, height;
746
747 /* Same here. */
748 Lisp_Object left, top;
749
750 /* Same with these. */
751 Lisp_Object icon_left, icon_top;
752
753 /* Record in these vectors all the parms specified. */
754 Lisp_Object *parms;
755 Lisp_Object *values;
756 int i, p;
757 int left_no_change = 0, top_no_change = 0;
758 int icon_left_no_change = 0, icon_top_no_change = 0;
759
760 struct gcpro gcpro1, gcpro2;
761
762 i = 0;
763 for (tail = alist; CONSP (tail); tail = Fcdr (tail))
764 i++;
765
766 parms = (Lisp_Object *) alloca (i * sizeof (Lisp_Object));
767 values = (Lisp_Object *) alloca (i * sizeof (Lisp_Object));
768
769 /* Extract parm names and values into those vectors. */
770
771 i = 0;
772 for (tail = alist; CONSP (tail); tail = Fcdr (tail))
773 {
774 Lisp_Object elt;
775
776 elt = Fcar (tail);
777 parms[i] = Fcar (elt);
778 values[i] = Fcdr (elt);
779 i++;
780 }
781 /* TAIL and ALIST are not used again below here. */
782 alist = tail = Qnil;
783
784 GCPRO2 (*parms, *values);
785 gcpro1.nvars = i;
786 gcpro2.nvars = i;
787
788 /* There is no need to gcpro LEFT, TOP, ICON_LEFT, or ICON_TOP,
789 because their values appear in VALUES and strings are not valid. */
790 top = left = Qunbound;
791 icon_left = icon_top = Qunbound;
792
793 /* Provide default values for HEIGHT and WIDTH. */
794 if (FRAME_NEW_WIDTH (f))
795 width = FRAME_NEW_WIDTH (f);
796 else
797 width = FRAME_WIDTH (f);
798
799 if (FRAME_NEW_HEIGHT (f))
800 height = FRAME_NEW_HEIGHT (f);
801 else
802 height = FRAME_HEIGHT (f);
803
804 /* Process foreground_color and background_color before anything else.
805 They are independent of other properties, but other properties (e.g.,
806 cursor_color) are dependent upon them. */
807 for (p = 0; p < i; p++)
808 {
809 Lisp_Object prop, val;
810
811 prop = parms[p];
812 val = values[p];
813 if (EQ (prop, Qforeground_color) || EQ (prop, Qbackground_color))
814 {
815 register Lisp_Object param_index, old_value;
816
817 param_index = Fget (prop, Qx_frame_parameter);
818 old_value = get_frame_param (f, prop);
819 store_frame_param (f, prop, val);
820 if (NATNUMP (param_index)
821 && (XFASTINT (param_index)
822 < sizeof (x_frame_parms)/sizeof (x_frame_parms[0])))
823 (*x_frame_parms[XINT (param_index)].setter)(f, val, old_value);
824 }
825 }
826
827 /* Now process them in reverse of specified order. */
828 for (i--; i >= 0; i--)
829 {
830 Lisp_Object prop, val;
831
832 prop = parms[i];
833 val = values[i];
834
835 if (EQ (prop, Qwidth) && NUMBERP (val))
836 width = XFASTINT (val);
837 else if (EQ (prop, Qheight) && NUMBERP (val))
838 height = XFASTINT (val);
839 else if (EQ (prop, Qtop))
840 top = val;
841 else if (EQ (prop, Qleft))
842 left = val;
843 else if (EQ (prop, Qicon_top))
844 icon_top = val;
845 else if (EQ (prop, Qicon_left))
846 icon_left = val;
847 else if (EQ (prop, Qforeground_color) || EQ (prop, Qbackground_color))
848 /* Processed above. */
849 continue;
850 else
851 {
852 register Lisp_Object param_index, old_value;
853
854 param_index = Fget (prop, Qx_frame_parameter);
855 old_value = get_frame_param (f, prop);
856 store_frame_param (f, prop, val);
857 if (NATNUMP (param_index)
858 && (XFASTINT (param_index)
859 < sizeof (x_frame_parms)/sizeof (x_frame_parms[0])))
860 (*x_frame_parms[XINT (param_index)].setter)(f, val, old_value);
861 }
862 }
863
864 /* Don't die if just one of these was set. */
865 if (EQ (left, Qunbound))
866 {
867 left_no_change = 1;
868 if (f->output_data.w32->left_pos < 0)
869 left = Fcons (Qplus, Fcons (make_number (f->output_data.w32->left_pos), Qnil));
870 else
871 XSETINT (left, f->output_data.w32->left_pos);
872 }
873 if (EQ (top, Qunbound))
874 {
875 top_no_change = 1;
876 if (f->output_data.w32->top_pos < 0)
877 top = Fcons (Qplus, Fcons (make_number (f->output_data.w32->top_pos), Qnil));
878 else
879 XSETINT (top, f->output_data.w32->top_pos);
880 }
881
882 /* If one of the icon positions was not set, preserve or default it. */
883 if (EQ (icon_left, Qunbound) || ! INTEGERP (icon_left))
884 {
885 icon_left_no_change = 1;
886 icon_left = Fcdr (Fassq (Qicon_left, f->param_alist));
887 if (NILP (icon_left))
888 XSETINT (icon_left, 0);
889 }
890 if (EQ (icon_top, Qunbound) || ! INTEGERP (icon_top))
891 {
892 icon_top_no_change = 1;
893 icon_top = Fcdr (Fassq (Qicon_top, f->param_alist));
894 if (NILP (icon_top))
895 XSETINT (icon_top, 0);
896 }
897
898 /* Don't set these parameters unless they've been explicitly
899 specified. The window might be mapped or resized while we're in
900 this function, and we don't want to override that unless the lisp
901 code has asked for it.
902
903 Don't set these parameters unless they actually differ from the
904 window's current parameters; the window may not actually exist
905 yet. */
906 {
907 Lisp_Object frame;
908
909 check_frame_size (f, &height, &width);
910
911 XSETFRAME (frame, f);
912
913 if (width != FRAME_WIDTH (f)
914 || height != FRAME_HEIGHT (f)
915 || FRAME_NEW_HEIGHT (f) || FRAME_NEW_WIDTH (f))
916 Fset_frame_size (frame, make_number (width), make_number (height));
917
918 if ((!NILP (left) || !NILP (top))
919 && ! (left_no_change && top_no_change)
920 && ! (NUMBERP (left) && XINT (left) == f->output_data.w32->left_pos
921 && NUMBERP (top) && XINT (top) == f->output_data.w32->top_pos))
922 {
923 int leftpos = 0;
924 int toppos = 0;
925
926 /* Record the signs. */
927 f->output_data.w32->size_hint_flags &= ~ (XNegative | YNegative);
928 if (EQ (left, Qminus))
929 f->output_data.w32->size_hint_flags |= XNegative;
930 else if (INTEGERP (left))
931 {
932 leftpos = XINT (left);
933 if (leftpos < 0)
934 f->output_data.w32->size_hint_flags |= XNegative;
935 }
936 else if (CONSP (left) && EQ (XCAR (left), Qminus)
937 && CONSP (XCDR (left))
938 && INTEGERP (XCAR (XCDR (left))))
939 {
940 leftpos = - XINT (XCAR (XCDR (left)));
941 f->output_data.w32->size_hint_flags |= XNegative;
942 }
943 else if (CONSP (left) && EQ (XCAR (left), Qplus)
944 && CONSP (XCDR (left))
945 && INTEGERP (XCAR (XCDR (left))))
946 {
947 leftpos = XINT (XCAR (XCDR (left)));
948 }
949
950 if (EQ (top, Qminus))
951 f->output_data.w32->size_hint_flags |= YNegative;
952 else if (INTEGERP (top))
953 {
954 toppos = XINT (top);
955 if (toppos < 0)
956 f->output_data.w32->size_hint_flags |= YNegative;
957 }
958 else if (CONSP (top) && EQ (XCAR (top), Qminus)
959 && CONSP (XCDR (top))
960 && INTEGERP (XCAR (XCDR (top))))
961 {
962 toppos = - XINT (XCAR (XCDR (top)));
963 f->output_data.w32->size_hint_flags |= YNegative;
964 }
965 else if (CONSP (top) && EQ (XCAR (top), Qplus)
966 && CONSP (XCDR (top))
967 && INTEGERP (XCAR (XCDR (top))))
968 {
969 toppos = XINT (XCAR (XCDR (top)));
970 }
971
972
973 /* Store the numeric value of the position. */
974 f->output_data.w32->top_pos = toppos;
975 f->output_data.w32->left_pos = leftpos;
976
977 f->output_data.w32->win_gravity = NorthWestGravity;
978
979 /* Actually set that position, and convert to absolute. */
980 x_set_offset (f, leftpos, toppos, -1);
981 }
982
983 if ((!NILP (icon_left) || !NILP (icon_top))
984 && ! (icon_left_no_change && icon_top_no_change))
985 x_wm_set_icon_position (f, XINT (icon_left), XINT (icon_top));
986 }
987
988 UNGCPRO;
989 }
990
991 /* Store the screen positions of frame F into XPTR and YPTR.
992 These are the positions of the containing window manager window,
993 not Emacs's own window. */
994
995 void
996 x_real_positions (f, xptr, yptr)
997 FRAME_PTR f;
998 int *xptr, *yptr;
999 {
1000 POINT pt;
1001
1002 {
1003 RECT rect;
1004
1005 GetClientRect(FRAME_W32_WINDOW(f), &rect);
1006 AdjustWindowRect(&rect, f->output_data.w32->dwStyle, FRAME_EXTERNAL_MENU_BAR(f));
1007
1008 pt.x = rect.left;
1009 pt.y = rect.top;
1010 }
1011
1012 ClientToScreen (FRAME_W32_WINDOW(f), &pt);
1013
1014 *xptr = pt.x;
1015 *yptr = pt.y;
1016 }
1017
1018 /* Insert a description of internally-recorded parameters of frame X
1019 into the parameter alist *ALISTPTR that is to be given to the user.
1020 Only parameters that are specific to W32
1021 and whose values are not correctly recorded in the frame's
1022 param_alist need to be considered here. */
1023
1024 void
1025 x_report_frame_params (f, alistptr)
1026 struct frame *f;
1027 Lisp_Object *alistptr;
1028 {
1029 char buf[16];
1030 Lisp_Object tem;
1031
1032 /* Represent negative positions (off the top or left screen edge)
1033 in a way that Fmodify_frame_parameters will understand correctly. */
1034 XSETINT (tem, f->output_data.w32->left_pos);
1035 if (f->output_data.w32->left_pos >= 0)
1036 store_in_alist (alistptr, Qleft, tem);
1037 else
1038 store_in_alist (alistptr, Qleft, Fcons (Qplus, Fcons (tem, Qnil)));
1039
1040 XSETINT (tem, f->output_data.w32->top_pos);
1041 if (f->output_data.w32->top_pos >= 0)
1042 store_in_alist (alistptr, Qtop, tem);
1043 else
1044 store_in_alist (alistptr, Qtop, Fcons (Qplus, Fcons (tem, Qnil)));
1045
1046 store_in_alist (alistptr, Qborder_width,
1047 make_number (f->output_data.w32->border_width));
1048 store_in_alist (alistptr, Qinternal_border_width,
1049 make_number (f->output_data.w32->internal_border_width));
1050 sprintf (buf, "%ld", (long) FRAME_W32_WINDOW (f));
1051 store_in_alist (alistptr, Qwindow_id,
1052 build_string (buf));
1053 store_in_alist (alistptr, Qicon_name, f->icon_name);
1054 FRAME_SAMPLE_VISIBILITY (f);
1055 store_in_alist (alistptr, Qvisibility,
1056 (FRAME_VISIBLE_P (f) ? Qt
1057 : FRAME_ICONIFIED_P (f) ? Qicon : Qnil));
1058 store_in_alist (alistptr, Qdisplay,
1059 XCAR (FRAME_W32_DISPLAY_INFO (f)->name_list_element));
1060 }
1061 \f
1062
1063 DEFUN ("w32-define-rgb-color", Fw32_define_rgb_color, Sw32_define_rgb_color, 4, 4, 0,
1064 "Convert RGB numbers to a windows color reference and associate with NAME (a string).\n\
1065 This adds or updates a named color to w32-color-map, making it available for use.\n\
1066 The original entry's RGB ref is returned, or nil if the entry is new.")
1067 (red, green, blue, name)
1068 Lisp_Object red, green, blue, name;
1069 {
1070 Lisp_Object rgb;
1071 Lisp_Object oldrgb = Qnil;
1072 Lisp_Object entry;
1073
1074 CHECK_NUMBER (red, 0);
1075 CHECK_NUMBER (green, 0);
1076 CHECK_NUMBER (blue, 0);
1077 CHECK_STRING (name, 0);
1078
1079 XSET (rgb, Lisp_Int, RGB(XUINT (red), XUINT (green), XUINT (blue)));
1080
1081 BLOCK_INPUT;
1082
1083 /* replace existing entry in w32-color-map or add new entry. */
1084 entry = Fassoc (name, Vw32_color_map);
1085 if (NILP (entry))
1086 {
1087 entry = Fcons (name, rgb);
1088 Vw32_color_map = Fcons (entry, Vw32_color_map);
1089 }
1090 else
1091 {
1092 oldrgb = Fcdr (entry);
1093 Fsetcdr (entry, rgb);
1094 }
1095
1096 UNBLOCK_INPUT;
1097
1098 return (oldrgb);
1099 }
1100
1101 DEFUN ("w32-load-color-file", Fw32_load_color_file, Sw32_load_color_file, 1, 1, 0,
1102 "Create an alist of color entries from an external file (ie. rgb.txt).\n\
1103 Assign this value to w32-color-map to replace the existing color map.\n\
1104 \
1105 The file should define one named RGB color per line like so:\
1106 R G B name\n\
1107 where R,G,B are numbers between 0 and 255 and name is an arbitrary string.")
1108 (filename)
1109 Lisp_Object filename;
1110 {
1111 FILE *fp;
1112 Lisp_Object cmap = Qnil;
1113 Lisp_Object abspath;
1114
1115 CHECK_STRING (filename, 0);
1116 abspath = Fexpand_file_name (filename, Qnil);
1117
1118 fp = fopen (XSTRING (filename)->data, "rt");
1119 if (fp)
1120 {
1121 char buf[512];
1122 int red, green, blue;
1123 int num;
1124
1125 BLOCK_INPUT;
1126
1127 while (fgets (buf, sizeof (buf), fp) != NULL) {
1128 if (sscanf (buf, "%u %u %u %n", &red, &green, &blue, &num) == 3)
1129 {
1130 char *name = buf + num;
1131 num = strlen (name) - 1;
1132 if (name[num] == '\n')
1133 name[num] = 0;
1134 cmap = Fcons (Fcons (build_string (name),
1135 make_number (RGB (red, green, blue))),
1136 cmap);
1137 }
1138 }
1139 fclose (fp);
1140
1141 UNBLOCK_INPUT;
1142 }
1143
1144 return cmap;
1145 }
1146
1147 /* The default colors for the w32 color map */
1148 typedef struct colormap_t
1149 {
1150 char *name;
1151 COLORREF colorref;
1152 } colormap_t;
1153
1154 colormap_t w32_color_map[] =
1155 {
1156 {"snow" , PALETTERGB (255,250,250)},
1157 {"ghost white" , PALETTERGB (248,248,255)},
1158 {"GhostWhite" , PALETTERGB (248,248,255)},
1159 {"white smoke" , PALETTERGB (245,245,245)},
1160 {"WhiteSmoke" , PALETTERGB (245,245,245)},
1161 {"gainsboro" , PALETTERGB (220,220,220)},
1162 {"floral white" , PALETTERGB (255,250,240)},
1163 {"FloralWhite" , PALETTERGB (255,250,240)},
1164 {"old lace" , PALETTERGB (253,245,230)},
1165 {"OldLace" , PALETTERGB (253,245,230)},
1166 {"linen" , PALETTERGB (250,240,230)},
1167 {"antique white" , PALETTERGB (250,235,215)},
1168 {"AntiqueWhite" , PALETTERGB (250,235,215)},
1169 {"papaya whip" , PALETTERGB (255,239,213)},
1170 {"PapayaWhip" , PALETTERGB (255,239,213)},
1171 {"blanched almond" , PALETTERGB (255,235,205)},
1172 {"BlanchedAlmond" , PALETTERGB (255,235,205)},
1173 {"bisque" , PALETTERGB (255,228,196)},
1174 {"peach puff" , PALETTERGB (255,218,185)},
1175 {"PeachPuff" , PALETTERGB (255,218,185)},
1176 {"navajo white" , PALETTERGB (255,222,173)},
1177 {"NavajoWhite" , PALETTERGB (255,222,173)},
1178 {"moccasin" , PALETTERGB (255,228,181)},
1179 {"cornsilk" , PALETTERGB (255,248,220)},
1180 {"ivory" , PALETTERGB (255,255,240)},
1181 {"lemon chiffon" , PALETTERGB (255,250,205)},
1182 {"LemonChiffon" , PALETTERGB (255,250,205)},
1183 {"seashell" , PALETTERGB (255,245,238)},
1184 {"honeydew" , PALETTERGB (240,255,240)},
1185 {"mint cream" , PALETTERGB (245,255,250)},
1186 {"MintCream" , PALETTERGB (245,255,250)},
1187 {"azure" , PALETTERGB (240,255,255)},
1188 {"alice blue" , PALETTERGB (240,248,255)},
1189 {"AliceBlue" , PALETTERGB (240,248,255)},
1190 {"lavender" , PALETTERGB (230,230,250)},
1191 {"lavender blush" , PALETTERGB (255,240,245)},
1192 {"LavenderBlush" , PALETTERGB (255,240,245)},
1193 {"misty rose" , PALETTERGB (255,228,225)},
1194 {"MistyRose" , PALETTERGB (255,228,225)},
1195 {"white" , PALETTERGB (255,255,255)},
1196 {"black" , PALETTERGB ( 0, 0, 0)},
1197 {"dark slate gray" , PALETTERGB ( 47, 79, 79)},
1198 {"DarkSlateGray" , PALETTERGB ( 47, 79, 79)},
1199 {"dark slate grey" , PALETTERGB ( 47, 79, 79)},
1200 {"DarkSlateGrey" , PALETTERGB ( 47, 79, 79)},
1201 {"dim gray" , PALETTERGB (105,105,105)},
1202 {"DimGray" , PALETTERGB (105,105,105)},
1203 {"dim grey" , PALETTERGB (105,105,105)},
1204 {"DimGrey" , PALETTERGB (105,105,105)},
1205 {"slate gray" , PALETTERGB (112,128,144)},
1206 {"SlateGray" , PALETTERGB (112,128,144)},
1207 {"slate grey" , PALETTERGB (112,128,144)},
1208 {"SlateGrey" , PALETTERGB (112,128,144)},
1209 {"light slate gray" , PALETTERGB (119,136,153)},
1210 {"LightSlateGray" , PALETTERGB (119,136,153)},
1211 {"light slate grey" , PALETTERGB (119,136,153)},
1212 {"LightSlateGrey" , PALETTERGB (119,136,153)},
1213 {"gray" , PALETTERGB (190,190,190)},
1214 {"grey" , PALETTERGB (190,190,190)},
1215 {"light grey" , PALETTERGB (211,211,211)},
1216 {"LightGrey" , PALETTERGB (211,211,211)},
1217 {"light gray" , PALETTERGB (211,211,211)},
1218 {"LightGray" , PALETTERGB (211,211,211)},
1219 {"midnight blue" , PALETTERGB ( 25, 25,112)},
1220 {"MidnightBlue" , PALETTERGB ( 25, 25,112)},
1221 {"navy" , PALETTERGB ( 0, 0,128)},
1222 {"navy blue" , PALETTERGB ( 0, 0,128)},
1223 {"NavyBlue" , PALETTERGB ( 0, 0,128)},
1224 {"cornflower blue" , PALETTERGB (100,149,237)},
1225 {"CornflowerBlue" , PALETTERGB (100,149,237)},
1226 {"dark slate blue" , PALETTERGB ( 72, 61,139)},
1227 {"DarkSlateBlue" , PALETTERGB ( 72, 61,139)},
1228 {"slate blue" , PALETTERGB (106, 90,205)},
1229 {"SlateBlue" , PALETTERGB (106, 90,205)},
1230 {"medium slate blue" , PALETTERGB (123,104,238)},
1231 {"MediumSlateBlue" , PALETTERGB (123,104,238)},
1232 {"light slate blue" , PALETTERGB (132,112,255)},
1233 {"LightSlateBlue" , PALETTERGB (132,112,255)},
1234 {"medium blue" , PALETTERGB ( 0, 0,205)},
1235 {"MediumBlue" , PALETTERGB ( 0, 0,205)},
1236 {"royal blue" , PALETTERGB ( 65,105,225)},
1237 {"RoyalBlue" , PALETTERGB ( 65,105,225)},
1238 {"blue" , PALETTERGB ( 0, 0,255)},
1239 {"dodger blue" , PALETTERGB ( 30,144,255)},
1240 {"DodgerBlue" , PALETTERGB ( 30,144,255)},
1241 {"deep sky blue" , PALETTERGB ( 0,191,255)},
1242 {"DeepSkyBlue" , PALETTERGB ( 0,191,255)},
1243 {"sky blue" , PALETTERGB (135,206,235)},
1244 {"SkyBlue" , PALETTERGB (135,206,235)},
1245 {"light sky blue" , PALETTERGB (135,206,250)},
1246 {"LightSkyBlue" , PALETTERGB (135,206,250)},
1247 {"steel blue" , PALETTERGB ( 70,130,180)},
1248 {"SteelBlue" , PALETTERGB ( 70,130,180)},
1249 {"light steel blue" , PALETTERGB (176,196,222)},
1250 {"LightSteelBlue" , PALETTERGB (176,196,222)},
1251 {"light blue" , PALETTERGB (173,216,230)},
1252 {"LightBlue" , PALETTERGB (173,216,230)},
1253 {"powder blue" , PALETTERGB (176,224,230)},
1254 {"PowderBlue" , PALETTERGB (176,224,230)},
1255 {"pale turquoise" , PALETTERGB (175,238,238)},
1256 {"PaleTurquoise" , PALETTERGB (175,238,238)},
1257 {"dark turquoise" , PALETTERGB ( 0,206,209)},
1258 {"DarkTurquoise" , PALETTERGB ( 0,206,209)},
1259 {"medium turquoise" , PALETTERGB ( 72,209,204)},
1260 {"MediumTurquoise" , PALETTERGB ( 72,209,204)},
1261 {"turquoise" , PALETTERGB ( 64,224,208)},
1262 {"cyan" , PALETTERGB ( 0,255,255)},
1263 {"light cyan" , PALETTERGB (224,255,255)},
1264 {"LightCyan" , PALETTERGB (224,255,255)},
1265 {"cadet blue" , PALETTERGB ( 95,158,160)},
1266 {"CadetBlue" , PALETTERGB ( 95,158,160)},
1267 {"medium aquamarine" , PALETTERGB (102,205,170)},
1268 {"MediumAquamarine" , PALETTERGB (102,205,170)},
1269 {"aquamarine" , PALETTERGB (127,255,212)},
1270 {"dark green" , PALETTERGB ( 0,100, 0)},
1271 {"DarkGreen" , PALETTERGB ( 0,100, 0)},
1272 {"dark olive green" , PALETTERGB ( 85,107, 47)},
1273 {"DarkOliveGreen" , PALETTERGB ( 85,107, 47)},
1274 {"dark sea green" , PALETTERGB (143,188,143)},
1275 {"DarkSeaGreen" , PALETTERGB (143,188,143)},
1276 {"sea green" , PALETTERGB ( 46,139, 87)},
1277 {"SeaGreen" , PALETTERGB ( 46,139, 87)},
1278 {"medium sea green" , PALETTERGB ( 60,179,113)},
1279 {"MediumSeaGreen" , PALETTERGB ( 60,179,113)},
1280 {"light sea green" , PALETTERGB ( 32,178,170)},
1281 {"LightSeaGreen" , PALETTERGB ( 32,178,170)},
1282 {"pale green" , PALETTERGB (152,251,152)},
1283 {"PaleGreen" , PALETTERGB (152,251,152)},
1284 {"spring green" , PALETTERGB ( 0,255,127)},
1285 {"SpringGreen" , PALETTERGB ( 0,255,127)},
1286 {"lawn green" , PALETTERGB (124,252, 0)},
1287 {"LawnGreen" , PALETTERGB (124,252, 0)},
1288 {"green" , PALETTERGB ( 0,255, 0)},
1289 {"chartreuse" , PALETTERGB (127,255, 0)},
1290 {"medium spring green" , PALETTERGB ( 0,250,154)},
1291 {"MediumSpringGreen" , PALETTERGB ( 0,250,154)},
1292 {"green yellow" , PALETTERGB (173,255, 47)},
1293 {"GreenYellow" , PALETTERGB (173,255, 47)},
1294 {"lime green" , PALETTERGB ( 50,205, 50)},
1295 {"LimeGreen" , PALETTERGB ( 50,205, 50)},
1296 {"yellow green" , PALETTERGB (154,205, 50)},
1297 {"YellowGreen" , PALETTERGB (154,205, 50)},
1298 {"forest green" , PALETTERGB ( 34,139, 34)},
1299 {"ForestGreen" , PALETTERGB ( 34,139, 34)},
1300 {"olive drab" , PALETTERGB (107,142, 35)},
1301 {"OliveDrab" , PALETTERGB (107,142, 35)},
1302 {"dark khaki" , PALETTERGB (189,183,107)},
1303 {"DarkKhaki" , PALETTERGB (189,183,107)},
1304 {"khaki" , PALETTERGB (240,230,140)},
1305 {"pale goldenrod" , PALETTERGB (238,232,170)},
1306 {"PaleGoldenrod" , PALETTERGB (238,232,170)},
1307 {"light goldenrod yellow" , PALETTERGB (250,250,210)},
1308 {"LightGoldenrodYellow" , PALETTERGB (250,250,210)},
1309 {"light yellow" , PALETTERGB (255,255,224)},
1310 {"LightYellow" , PALETTERGB (255,255,224)},
1311 {"yellow" , PALETTERGB (255,255, 0)},
1312 {"gold" , PALETTERGB (255,215, 0)},
1313 {"light goldenrod" , PALETTERGB (238,221,130)},
1314 {"LightGoldenrod" , PALETTERGB (238,221,130)},
1315 {"goldenrod" , PALETTERGB (218,165, 32)},
1316 {"dark goldenrod" , PALETTERGB (184,134, 11)},
1317 {"DarkGoldenrod" , PALETTERGB (184,134, 11)},
1318 {"rosy brown" , PALETTERGB (188,143,143)},
1319 {"RosyBrown" , PALETTERGB (188,143,143)},
1320 {"indian red" , PALETTERGB (205, 92, 92)},
1321 {"IndianRed" , PALETTERGB (205, 92, 92)},
1322 {"saddle brown" , PALETTERGB (139, 69, 19)},
1323 {"SaddleBrown" , PALETTERGB (139, 69, 19)},
1324 {"sienna" , PALETTERGB (160, 82, 45)},
1325 {"peru" , PALETTERGB (205,133, 63)},
1326 {"burlywood" , PALETTERGB (222,184,135)},
1327 {"beige" , PALETTERGB (245,245,220)},
1328 {"wheat" , PALETTERGB (245,222,179)},
1329 {"sandy brown" , PALETTERGB (244,164, 96)},
1330 {"SandyBrown" , PALETTERGB (244,164, 96)},
1331 {"tan" , PALETTERGB (210,180,140)},
1332 {"chocolate" , PALETTERGB (210,105, 30)},
1333 {"firebrick" , PALETTERGB (178,34, 34)},
1334 {"brown" , PALETTERGB (165,42, 42)},
1335 {"dark salmon" , PALETTERGB (233,150,122)},
1336 {"DarkSalmon" , PALETTERGB (233,150,122)},
1337 {"salmon" , PALETTERGB (250,128,114)},
1338 {"light salmon" , PALETTERGB (255,160,122)},
1339 {"LightSalmon" , PALETTERGB (255,160,122)},
1340 {"orange" , PALETTERGB (255,165, 0)},
1341 {"dark orange" , PALETTERGB (255,140, 0)},
1342 {"DarkOrange" , PALETTERGB (255,140, 0)},
1343 {"coral" , PALETTERGB (255,127, 80)},
1344 {"light coral" , PALETTERGB (240,128,128)},
1345 {"LightCoral" , PALETTERGB (240,128,128)},
1346 {"tomato" , PALETTERGB (255, 99, 71)},
1347 {"orange red" , PALETTERGB (255, 69, 0)},
1348 {"OrangeRed" , PALETTERGB (255, 69, 0)},
1349 {"red" , PALETTERGB (255, 0, 0)},
1350 {"hot pink" , PALETTERGB (255,105,180)},
1351 {"HotPink" , PALETTERGB (255,105,180)},
1352 {"deep pink" , PALETTERGB (255, 20,147)},
1353 {"DeepPink" , PALETTERGB (255, 20,147)},
1354 {"pink" , PALETTERGB (255,192,203)},
1355 {"light pink" , PALETTERGB (255,182,193)},
1356 {"LightPink" , PALETTERGB (255,182,193)},
1357 {"pale violet red" , PALETTERGB (219,112,147)},
1358 {"PaleVioletRed" , PALETTERGB (219,112,147)},
1359 {"maroon" , PALETTERGB (176, 48, 96)},
1360 {"medium violet red" , PALETTERGB (199, 21,133)},
1361 {"MediumVioletRed" , PALETTERGB (199, 21,133)},
1362 {"violet red" , PALETTERGB (208, 32,144)},
1363 {"VioletRed" , PALETTERGB (208, 32,144)},
1364 {"magenta" , PALETTERGB (255, 0,255)},
1365 {"violet" , PALETTERGB (238,130,238)},
1366 {"plum" , PALETTERGB (221,160,221)},
1367 {"orchid" , PALETTERGB (218,112,214)},
1368 {"medium orchid" , PALETTERGB (186, 85,211)},
1369 {"MediumOrchid" , PALETTERGB (186, 85,211)},
1370 {"dark orchid" , PALETTERGB (153, 50,204)},
1371 {"DarkOrchid" , PALETTERGB (153, 50,204)},
1372 {"dark violet" , PALETTERGB (148, 0,211)},
1373 {"DarkViolet" , PALETTERGB (148, 0,211)},
1374 {"blue violet" , PALETTERGB (138, 43,226)},
1375 {"BlueViolet" , PALETTERGB (138, 43,226)},
1376 {"purple" , PALETTERGB (160, 32,240)},
1377 {"medium purple" , PALETTERGB (147,112,219)},
1378 {"MediumPurple" , PALETTERGB (147,112,219)},
1379 {"thistle" , PALETTERGB (216,191,216)},
1380 {"gray0" , PALETTERGB ( 0, 0, 0)},
1381 {"grey0" , PALETTERGB ( 0, 0, 0)},
1382 {"dark grey" , PALETTERGB (169,169,169)},
1383 {"DarkGrey" , PALETTERGB (169,169,169)},
1384 {"dark gray" , PALETTERGB (169,169,169)},
1385 {"DarkGray" , PALETTERGB (169,169,169)},
1386 {"dark blue" , PALETTERGB ( 0, 0,139)},
1387 {"DarkBlue" , PALETTERGB ( 0, 0,139)},
1388 {"dark cyan" , PALETTERGB ( 0,139,139)},
1389 {"DarkCyan" , PALETTERGB ( 0,139,139)},
1390 {"dark magenta" , PALETTERGB (139, 0,139)},
1391 {"DarkMagenta" , PALETTERGB (139, 0,139)},
1392 {"dark red" , PALETTERGB (139, 0, 0)},
1393 {"DarkRed" , PALETTERGB (139, 0, 0)},
1394 {"light green" , PALETTERGB (144,238,144)},
1395 {"LightGreen" , PALETTERGB (144,238,144)},
1396 };
1397
1398 DEFUN ("w32-default-color-map", Fw32_default_color_map, Sw32_default_color_map,
1399 0, 0, 0, "Return the default color map.")
1400 ()
1401 {
1402 int i;
1403 colormap_t *pc = w32_color_map;
1404 Lisp_Object cmap;
1405
1406 BLOCK_INPUT;
1407
1408 cmap = Qnil;
1409
1410 for (i = 0; i < sizeof (w32_color_map) / sizeof (w32_color_map[0]);
1411 pc++, i++)
1412 cmap = Fcons (Fcons (build_string (pc->name),
1413 make_number (pc->colorref)),
1414 cmap);
1415
1416 UNBLOCK_INPUT;
1417
1418 return (cmap);
1419 }
1420
1421 Lisp_Object
1422 w32_to_x_color (rgb)
1423 Lisp_Object rgb;
1424 {
1425 Lisp_Object color;
1426
1427 CHECK_NUMBER (rgb, 0);
1428
1429 BLOCK_INPUT;
1430
1431 color = Frassq (rgb, Vw32_color_map);
1432
1433 UNBLOCK_INPUT;
1434
1435 if (!NILP (color))
1436 return (Fcar (color));
1437 else
1438 return Qnil;
1439 }
1440
1441 COLORREF
1442 w32_color_map_lookup (colorname)
1443 char *colorname;
1444 {
1445 Lisp_Object tail, ret = Qnil;
1446
1447 BLOCK_INPUT;
1448
1449 for (tail = Vw32_color_map; !NILP (tail); tail = Fcdr (tail))
1450 {
1451 register Lisp_Object elt, tem;
1452
1453 elt = Fcar (tail);
1454 if (!CONSP (elt)) continue;
1455
1456 tem = Fcar (elt);
1457
1458 if (lstrcmpi (XSTRING (tem)->data, colorname) == 0)
1459 {
1460 ret = XUINT (Fcdr (elt));
1461 break;
1462 }
1463
1464 QUIT;
1465 }
1466
1467
1468 UNBLOCK_INPUT;
1469
1470 return ret;
1471 }
1472
1473 COLORREF
1474 x_to_w32_color (colorname)
1475 char * colorname;
1476 {
1477 register Lisp_Object ret = Qnil;
1478
1479 BLOCK_INPUT;
1480
1481 if (colorname[0] == '#')
1482 {
1483 /* Could be an old-style RGB Device specification. */
1484 char *color;
1485 int size;
1486 color = colorname + 1;
1487
1488 size = strlen(color);
1489 if (size == 3 || size == 6 || size == 9 || size == 12)
1490 {
1491 UINT colorval;
1492 int i, pos;
1493 pos = 0;
1494 size /= 3;
1495 colorval = 0;
1496
1497 for (i = 0; i < 3; i++)
1498 {
1499 char *end;
1500 char t;
1501 unsigned long value;
1502
1503 /* The check for 'x' in the following conditional takes into
1504 account the fact that strtol allows a "0x" in front of
1505 our numbers, and we don't. */
1506 if (!isxdigit(color[0]) || color[1] == 'x')
1507 break;
1508 t = color[size];
1509 color[size] = '\0';
1510 value = strtoul(color, &end, 16);
1511 color[size] = t;
1512 if (errno == ERANGE || end - color != size)
1513 break;
1514 switch (size)
1515 {
1516 case 1:
1517 value = value * 0x10;
1518 break;
1519 case 2:
1520 break;
1521 case 3:
1522 value /= 0x10;
1523 break;
1524 case 4:
1525 value /= 0x100;
1526 break;
1527 }
1528 colorval |= (value << pos);
1529 pos += 0x8;
1530 if (i == 2)
1531 {
1532 UNBLOCK_INPUT;
1533 return (colorval);
1534 }
1535 color = end;
1536 }
1537 }
1538 }
1539 else if (strnicmp(colorname, "rgb:", 4) == 0)
1540 {
1541 char *color;
1542 UINT colorval;
1543 int i, pos;
1544 pos = 0;
1545
1546 colorval = 0;
1547 color = colorname + 4;
1548 for (i = 0; i < 3; i++)
1549 {
1550 char *end;
1551 unsigned long value;
1552
1553 /* The check for 'x' in the following conditional takes into
1554 account the fact that strtol allows a "0x" in front of
1555 our numbers, and we don't. */
1556 if (!isxdigit(color[0]) || color[1] == 'x')
1557 break;
1558 value = strtoul(color, &end, 16);
1559 if (errno == ERANGE)
1560 break;
1561 switch (end - color)
1562 {
1563 case 1:
1564 value = value * 0x10 + value;
1565 break;
1566 case 2:
1567 break;
1568 case 3:
1569 value /= 0x10;
1570 break;
1571 case 4:
1572 value /= 0x100;
1573 break;
1574 default:
1575 value = ULONG_MAX;
1576 }
1577 if (value == ULONG_MAX)
1578 break;
1579 colorval |= (value << pos);
1580 pos += 0x8;
1581 if (i == 2)
1582 {
1583 if (*end != '\0')
1584 break;
1585 UNBLOCK_INPUT;
1586 return (colorval);
1587 }
1588 if (*end != '/')
1589 break;
1590 color = end + 1;
1591 }
1592 }
1593 else if (strnicmp(colorname, "rgbi:", 5) == 0)
1594 {
1595 /* This is an RGB Intensity specification. */
1596 char *color;
1597 UINT colorval;
1598 int i, pos;
1599 pos = 0;
1600
1601 colorval = 0;
1602 color = colorname + 5;
1603 for (i = 0; i < 3; i++)
1604 {
1605 char *end;
1606 double value;
1607 UINT val;
1608
1609 value = strtod(color, &end);
1610 if (errno == ERANGE)
1611 break;
1612 if (value < 0.0 || value > 1.0)
1613 break;
1614 val = (UINT)(0x100 * value);
1615 /* We used 0x100 instead of 0xFF to give an continuous
1616 range between 0.0 and 1.0 inclusive. The next statement
1617 fixes the 1.0 case. */
1618 if (val == 0x100)
1619 val = 0xFF;
1620 colorval |= (val << pos);
1621 pos += 0x8;
1622 if (i == 2)
1623 {
1624 if (*end != '\0')
1625 break;
1626 UNBLOCK_INPUT;
1627 return (colorval);
1628 }
1629 if (*end != '/')
1630 break;
1631 color = end + 1;
1632 }
1633 }
1634 /* I am not going to attempt to handle any of the CIE color schemes
1635 or TekHVC, since I don't know the algorithms for conversion to
1636 RGB. */
1637
1638 /* If we fail to lookup the color name in w32_color_map, then check the
1639 colorname to see if it can be crudely approximated: If the X color
1640 ends in a number (e.g., "darkseagreen2"), strip the number and
1641 return the result of looking up the base color name. */
1642 ret = w32_color_map_lookup (colorname);
1643 if (NILP (ret))
1644 {
1645 int len = strlen (colorname);
1646
1647 if (isdigit (colorname[len - 1]))
1648 {
1649 char *ptr, *approx = alloca (len + 1);
1650
1651 strcpy (approx, colorname);
1652 ptr = &approx[len - 1];
1653 while (ptr > approx && isdigit (*ptr))
1654 *ptr-- = '\0';
1655
1656 ret = w32_color_map_lookup (approx);
1657 }
1658 }
1659
1660 UNBLOCK_INPUT;
1661 return ret;
1662 }
1663
1664
1665 void
1666 w32_regenerate_palette (FRAME_PTR f)
1667 {
1668 struct w32_palette_entry * list;
1669 LOGPALETTE * log_palette;
1670 HPALETTE new_palette;
1671 int i;
1672
1673 /* don't bother trying to create palette if not supported */
1674 if (! FRAME_W32_DISPLAY_INFO (f)->has_palette)
1675 return;
1676
1677 log_palette = (LOGPALETTE *)
1678 alloca (sizeof (LOGPALETTE) +
1679 FRAME_W32_DISPLAY_INFO (f)->num_colors * sizeof (PALETTEENTRY));
1680 log_palette->palVersion = 0x300;
1681 log_palette->palNumEntries = FRAME_W32_DISPLAY_INFO (f)->num_colors;
1682
1683 list = FRAME_W32_DISPLAY_INFO (f)->color_list;
1684 for (i = 0;
1685 i < FRAME_W32_DISPLAY_INFO (f)->num_colors;
1686 i++, list = list->next)
1687 log_palette->palPalEntry[i] = list->entry;
1688
1689 new_palette = CreatePalette (log_palette);
1690
1691 enter_crit ();
1692
1693 if (FRAME_W32_DISPLAY_INFO (f)->palette)
1694 DeleteObject (FRAME_W32_DISPLAY_INFO (f)->palette);
1695 FRAME_W32_DISPLAY_INFO (f)->palette = new_palette;
1696
1697 /* Realize display palette and garbage all frames. */
1698 release_frame_dc (f, get_frame_dc (f));
1699
1700 leave_crit ();
1701 }
1702
1703 #define W32_COLOR(pe) RGB (pe.peRed, pe.peGreen, pe.peBlue)
1704 #define SET_W32_COLOR(pe, color) \
1705 do \
1706 { \
1707 pe.peRed = GetRValue (color); \
1708 pe.peGreen = GetGValue (color); \
1709 pe.peBlue = GetBValue (color); \
1710 pe.peFlags = 0; \
1711 } while (0)
1712
1713 #if 0
1714 /* Keep these around in case we ever want to track color usage. */
1715 void
1716 w32_map_color (FRAME_PTR f, COLORREF color)
1717 {
1718 struct w32_palette_entry * list = FRAME_W32_DISPLAY_INFO (f)->color_list;
1719
1720 if (NILP (Vw32_enable_palette))
1721 return;
1722
1723 /* check if color is already mapped */
1724 while (list)
1725 {
1726 if (W32_COLOR (list->entry) == color)
1727 {
1728 ++list->refcount;
1729 return;
1730 }
1731 list = list->next;
1732 }
1733
1734 /* not already mapped, so add to list and recreate Windows palette */
1735 list = (struct w32_palette_entry *)
1736 xmalloc (sizeof (struct w32_palette_entry));
1737 SET_W32_COLOR (list->entry, color);
1738 list->refcount = 1;
1739 list->next = FRAME_W32_DISPLAY_INFO (f)->color_list;
1740 FRAME_W32_DISPLAY_INFO (f)->color_list = list;
1741 FRAME_W32_DISPLAY_INFO (f)->num_colors++;
1742
1743 /* set flag that palette must be regenerated */
1744 FRAME_W32_DISPLAY_INFO (f)->regen_palette = TRUE;
1745 }
1746
1747 void
1748 w32_unmap_color (FRAME_PTR f, COLORREF color)
1749 {
1750 struct w32_palette_entry * list = FRAME_W32_DISPLAY_INFO (f)->color_list;
1751 struct w32_palette_entry **prev = &FRAME_W32_DISPLAY_INFO (f)->color_list;
1752
1753 if (NILP (Vw32_enable_palette))
1754 return;
1755
1756 /* check if color is already mapped */
1757 while (list)
1758 {
1759 if (W32_COLOR (list->entry) == color)
1760 {
1761 if (--list->refcount == 0)
1762 {
1763 *prev = list->next;
1764 xfree (list);
1765 FRAME_W32_DISPLAY_INFO (f)->num_colors--;
1766 break;
1767 }
1768 else
1769 return;
1770 }
1771 prev = &list->next;
1772 list = list->next;
1773 }
1774
1775 /* set flag that palette must be regenerated */
1776 FRAME_W32_DISPLAY_INFO (f)->regen_palette = TRUE;
1777 }
1778 #endif
1779
1780
1781 /* Gamma-correct COLOR on frame F. */
1782
1783 void
1784 gamma_correct (f, color)
1785 struct frame *f;
1786 COLORREF *color;
1787 {
1788 if (f->gamma)
1789 {
1790 *color = PALETTERGB (
1791 pow (GetRValue (*color) / 255.0, f->gamma) * 255.0 + 0.5,
1792 pow (GetGValue (*color) / 255.0, f->gamma) * 255.0 + 0.5,
1793 pow (GetBValue (*color) / 255.0, f->gamma) * 255.0 + 0.5);
1794 }
1795 }
1796
1797
1798 /* Decide if color named COLOR is valid for the display associated with
1799 the selected frame; if so, return the rgb values in COLOR_DEF.
1800 If ALLOC is nonzero, allocate a new colormap cell. */
1801
1802 int
1803 w32_defined_color (f, color, color_def, alloc)
1804 FRAME_PTR f;
1805 char *color;
1806 XColor *color_def;
1807 int alloc;
1808 {
1809 register Lisp_Object tem;
1810 COLORREF w32_color_ref;
1811
1812 tem = x_to_w32_color (color);
1813
1814 if (!NILP (tem))
1815 {
1816 if (f)
1817 {
1818 /* Apply gamma correction. */
1819 w32_color_ref = XUINT (tem);
1820 gamma_correct (f, &w32_color_ref);
1821 XSETINT (tem, w32_color_ref);
1822 }
1823
1824 /* Map this color to the palette if it is enabled. */
1825 if (!NILP (Vw32_enable_palette))
1826 {
1827 struct w32_palette_entry * entry =
1828 one_w32_display_info.color_list;
1829 struct w32_palette_entry ** prev =
1830 &one_w32_display_info.color_list;
1831
1832 /* check if color is already mapped */
1833 while (entry)
1834 {
1835 if (W32_COLOR (entry->entry) == XUINT (tem))
1836 break;
1837 prev = &entry->next;
1838 entry = entry->next;
1839 }
1840
1841 if (entry == NULL && alloc)
1842 {
1843 /* not already mapped, so add to list */
1844 entry = (struct w32_palette_entry *)
1845 xmalloc (sizeof (struct w32_palette_entry));
1846 SET_W32_COLOR (entry->entry, XUINT (tem));
1847 entry->next = NULL;
1848 *prev = entry;
1849 one_w32_display_info.num_colors++;
1850
1851 /* set flag that palette must be regenerated */
1852 one_w32_display_info.regen_palette = TRUE;
1853 }
1854 }
1855 /* Ensure COLORREF value is snapped to nearest color in (default)
1856 palette by simulating the PALETTERGB macro. This works whether
1857 or not the display device has a palette. */
1858 w32_color_ref = XUINT (tem) | 0x2000000;
1859
1860 color_def->pixel = w32_color_ref;
1861 color_def->red = GetRValue (w32_color_ref);
1862 color_def->green = GetGValue (w32_color_ref);
1863 color_def->blue = GetBValue (w32_color_ref);
1864
1865 return 1;
1866 }
1867 else
1868 {
1869 return 0;
1870 }
1871 }
1872
1873 /* Given a string ARG naming a color, compute a pixel value from it
1874 suitable for screen F.
1875 If F is not a color screen, return DEF (default) regardless of what
1876 ARG says. */
1877
1878 int
1879 x_decode_color (f, arg, def)
1880 FRAME_PTR f;
1881 Lisp_Object arg;
1882 int def;
1883 {
1884 XColor cdef;
1885
1886 CHECK_STRING (arg, 0);
1887
1888 if (strcmp (XSTRING (arg)->data, "black") == 0)
1889 return BLACK_PIX_DEFAULT (f);
1890 else if (strcmp (XSTRING (arg)->data, "white") == 0)
1891 return WHITE_PIX_DEFAULT (f);
1892
1893 if ((FRAME_W32_DISPLAY_INFO (f)->n_planes * FRAME_W32_DISPLAY_INFO (f)->n_cbits) == 1)
1894 return def;
1895
1896 /* w32_defined_color is responsible for coping with failures
1897 by looking for a near-miss. */
1898 if (w32_defined_color (f, XSTRING (arg)->data, &cdef, 1))
1899 return cdef.pixel;
1900
1901 /* defined_color failed; return an ultimate default. */
1902 return def;
1903 }
1904 \f
1905 /* Change the `line-spacing' frame parameter of frame F. OLD_VALUE is
1906 the previous value of that parameter, NEW_VALUE is the new value. */
1907
1908 static void
1909 x_set_line_spacing (f, new_value, old_value)
1910 struct frame *f;
1911 Lisp_Object new_value, old_value;
1912 {
1913 if (NILP (new_value))
1914 f->extra_line_spacing = 0;
1915 else if (NATNUMP (new_value))
1916 f->extra_line_spacing = XFASTINT (new_value);
1917 else
1918 Fsignal (Qerror, Fcons (build_string ("Invalid line-spacing"),
1919 Fcons (new_value, Qnil)));
1920 if (FRAME_VISIBLE_P (f))
1921 redraw_frame (f);
1922 }
1923
1924
1925 /* Change the `screen-gamma' frame parameter of frame F. OLD_VALUE is
1926 the previous value of that parameter, NEW_VALUE is the new value. */
1927
1928 static void
1929 x_set_screen_gamma (f, new_value, old_value)
1930 struct frame *f;
1931 Lisp_Object new_value, old_value;
1932 {
1933 if (NILP (new_value))
1934 f->gamma = 0;
1935 else if (NUMBERP (new_value) && XFLOATINT (new_value) > 0)
1936 /* The value 0.4545 is the normal viewing gamma. */
1937 f->gamma = 1.0 / (0.4545 * XFLOATINT (new_value));
1938 else
1939 Fsignal (Qerror, Fcons (build_string ("Invalid screen-gamma"),
1940 Fcons (new_value, Qnil)));
1941
1942 clear_face_cache (0);
1943 }
1944
1945
1946 /* Functions called only from `x_set_frame_param'
1947 to set individual parameters.
1948
1949 If FRAME_W32_WINDOW (f) is 0,
1950 the frame is being created and its window does not exist yet.
1951 In that case, just record the parameter's new value
1952 in the standard place; do not attempt to change the window. */
1953
1954 void
1955 x_set_foreground_color (f, arg, oldval)
1956 struct frame *f;
1957 Lisp_Object arg, oldval;
1958 {
1959 FRAME_FOREGROUND_PIXEL (f)
1960 = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
1961
1962 if (FRAME_W32_WINDOW (f) != 0)
1963 {
1964 update_face_from_frame_parameter (f, Qforeground_color, arg);
1965 if (FRAME_VISIBLE_P (f))
1966 redraw_frame (f);
1967 }
1968 }
1969
1970 void
1971 x_set_background_color (f, arg, oldval)
1972 struct frame *f;
1973 Lisp_Object arg, oldval;
1974 {
1975 FRAME_BACKGROUND_PIXEL (f)
1976 = x_decode_color (f, arg, WHITE_PIX_DEFAULT (f));
1977
1978 if (FRAME_W32_WINDOW (f) != 0)
1979 {
1980 SetWindowLong (FRAME_W32_WINDOW (f), WND_BACKGROUND_INDEX,
1981 FRAME_BACKGROUND_PIXEL (f));
1982
1983 update_face_from_frame_parameter (f, Qbackground_color, arg);
1984
1985 if (FRAME_VISIBLE_P (f))
1986 redraw_frame (f);
1987 }
1988 }
1989
1990 void
1991 x_set_mouse_color (f, arg, oldval)
1992 struct frame *f;
1993 Lisp_Object arg, oldval;
1994 {
1995 Cursor cursor, nontext_cursor, mode_cursor, cross_cursor;
1996 int count;
1997 int mask_color;
1998
1999 if (!EQ (Qnil, arg))
2000 f->output_data.w32->mouse_pixel
2001 = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
2002 mask_color = FRAME_BACKGROUND_PIXEL (f);
2003
2004 /* Don't let pointers be invisible. */
2005 if (mask_color == f->output_data.w32->mouse_pixel
2006 && mask_color == FRAME_BACKGROUND_PIXEL (f))
2007 f->output_data.w32->mouse_pixel = FRAME_FOREGROUND_PIXEL (f);
2008
2009 #if 0 /* TODO : cursor changes */
2010 BLOCK_INPUT;
2011
2012 /* It's not okay to crash if the user selects a screwy cursor. */
2013 count = x_catch_errors (FRAME_W32_DISPLAY (f));
2014
2015 if (!EQ (Qnil, Vx_pointer_shape))
2016 {
2017 CHECK_NUMBER (Vx_pointer_shape, 0);
2018 cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XINT (Vx_pointer_shape));
2019 }
2020 else
2021 cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_xterm);
2022 x_check_errors (FRAME_W32_DISPLAY (f), "bad text pointer cursor: %s");
2023
2024 if (!EQ (Qnil, Vx_nontext_pointer_shape))
2025 {
2026 CHECK_NUMBER (Vx_nontext_pointer_shape, 0);
2027 nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
2028 XINT (Vx_nontext_pointer_shape));
2029 }
2030 else
2031 nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_left_ptr);
2032 x_check_errors (FRAME_W32_DISPLAY (f), "bad nontext pointer cursor: %s");
2033
2034 if (!EQ (Qnil, Vx_hourglass_pointer_shape))
2035 {
2036 CHECK_NUMBER (Vx_hourglass_pointer_shape, 0);
2037 hourglass_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
2038 XINT (Vx_hourglass_pointer_shape));
2039 }
2040 else
2041 hourglass_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_watch);
2042 x_check_errors (FRAME_W32_DISPLAY (f), "bad busy pointer cursor: %s");
2043
2044 x_check_errors (FRAME_W32_DISPLAY (f), "bad nontext pointer cursor: %s");
2045 if (!EQ (Qnil, Vx_mode_pointer_shape))
2046 {
2047 CHECK_NUMBER (Vx_mode_pointer_shape, 0);
2048 mode_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
2049 XINT (Vx_mode_pointer_shape));
2050 }
2051 else
2052 mode_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_xterm);
2053 x_check_errors (FRAME_W32_DISPLAY (f), "bad modeline pointer cursor: %s");
2054
2055 if (!EQ (Qnil, Vx_sensitive_text_pointer_shape))
2056 {
2057 CHECK_NUMBER (Vx_sensitive_text_pointer_shape, 0);
2058 cross_cursor
2059 = XCreateFontCursor (FRAME_W32_DISPLAY (f),
2060 XINT (Vx_sensitive_text_pointer_shape));
2061 }
2062 else
2063 cross_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_crosshair);
2064
2065 if (!NILP (Vx_window_horizontal_drag_shape))
2066 {
2067 CHECK_NUMBER (Vx_window_horizontal_drag_shape, 0);
2068 horizontal_drag_cursor
2069 = XCreateFontCursor (FRAME_X_DISPLAY (f),
2070 XINT (Vx_window_horizontal_drag_shape));
2071 }
2072 else
2073 horizontal_drag_cursor
2074 = XCreateFontCursor (FRAME_X_DISPLAY (f), XC_sb_h_double_arrow);
2075
2076 /* Check and report errors with the above calls. */
2077 x_check_errors (FRAME_W32_DISPLAY (f), "can't set cursor shape: %s");
2078 x_uncatch_errors (FRAME_W32_DISPLAY (f), count);
2079
2080 {
2081 XColor fore_color, back_color;
2082
2083 fore_color.pixel = f->output_data.w32->mouse_pixel;
2084 back_color.pixel = mask_color;
2085 XQueryColor (FRAME_W32_DISPLAY (f),
2086 DefaultColormap (FRAME_W32_DISPLAY (f),
2087 DefaultScreen (FRAME_W32_DISPLAY (f))),
2088 &fore_color);
2089 XQueryColor (FRAME_W32_DISPLAY (f),
2090 DefaultColormap (FRAME_W32_DISPLAY (f),
2091 DefaultScreen (FRAME_W32_DISPLAY (f))),
2092 &back_color);
2093 XRecolorCursor (FRAME_W32_DISPLAY (f), cursor,
2094 &fore_color, &back_color);
2095 XRecolorCursor (FRAME_W32_DISPLAY (f), nontext_cursor,
2096 &fore_color, &back_color);
2097 XRecolorCursor (FRAME_W32_DISPLAY (f), mode_cursor,
2098 &fore_color, &back_color);
2099 XRecolorCursor (FRAME_W32_DISPLAY (f), cross_cursor,
2100 &fore_color, &back_color);
2101 XRecolorCursor (FRAME_W32_DISPLAY (f), hourglass_cursor,
2102 &fore_color, &back_color);
2103 }
2104
2105 if (FRAME_W32_WINDOW (f) != 0)
2106 XDefineCursor (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), cursor);
2107
2108 if (cursor != f->output_data.w32->text_cursor && f->output_data.w32->text_cursor != 0)
2109 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->text_cursor);
2110 f->output_data.w32->text_cursor = cursor;
2111
2112 if (nontext_cursor != f->output_data.w32->nontext_cursor
2113 && f->output_data.w32->nontext_cursor != 0)
2114 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->nontext_cursor);
2115 f->output_data.w32->nontext_cursor = nontext_cursor;
2116
2117 if (hourglass_cursor != f->output_data.w32->hourglass_cursor
2118 && f->output_data.w32->hourglass_cursor != 0)
2119 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->hourglass_cursor);
2120 f->output_data.w32->hourglass_cursor = hourglass_cursor;
2121
2122 if (mode_cursor != f->output_data.w32->modeline_cursor
2123 && f->output_data.w32->modeline_cursor != 0)
2124 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->modeline_cursor);
2125 f->output_data.w32->modeline_cursor = mode_cursor;
2126
2127 if (cross_cursor != f->output_data.w32->cross_cursor
2128 && f->output_data.w32->cross_cursor != 0)
2129 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->cross_cursor);
2130 f->output_data.w32->cross_cursor = cross_cursor;
2131
2132 XFlush (FRAME_W32_DISPLAY (f));
2133 UNBLOCK_INPUT;
2134
2135 update_face_from_frame_parameter (f, Qmouse_color, arg);
2136 #endif /* TODO */
2137 }
2138
2139 /* Defined in w32term.c. */
2140 void x_update_cursor (struct frame *f, int on_p);
2141
2142 void
2143 x_set_cursor_color (f, arg, oldval)
2144 struct frame *f;
2145 Lisp_Object arg, oldval;
2146 {
2147 unsigned long fore_pixel, pixel;
2148
2149 if (!NILP (Vx_cursor_fore_pixel))
2150 fore_pixel = x_decode_color (f, Vx_cursor_fore_pixel,
2151 WHITE_PIX_DEFAULT (f));
2152 else
2153 fore_pixel = FRAME_BACKGROUND_PIXEL (f);
2154
2155 pixel = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
2156
2157 /* Make sure that the cursor color differs from the background color. */
2158 if (pixel == FRAME_BACKGROUND_PIXEL (f))
2159 {
2160 pixel = f->output_data.w32->mouse_pixel;
2161 if (pixel == fore_pixel)
2162 fore_pixel = FRAME_BACKGROUND_PIXEL (f);
2163 }
2164
2165 FRAME_FOREGROUND_PIXEL (f) = fore_pixel;
2166 f->output_data.w32->cursor_pixel = pixel;
2167
2168 if (FRAME_W32_WINDOW (f) != 0)
2169 {
2170 if (FRAME_VISIBLE_P (f))
2171 {
2172 x_update_cursor (f, 0);
2173 x_update_cursor (f, 1);
2174 }
2175 }
2176
2177 update_face_from_frame_parameter (f, Qcursor_color, arg);
2178 }
2179
2180 /* Set the border-color of frame F to pixel value PIX.
2181 Note that this does not fully take effect if done before
2182 F has an window. */
2183 void
2184 x_set_border_pixel (f, pix)
2185 struct frame *f;
2186 int pix;
2187 {
2188 f->output_data.w32->border_pixel = pix;
2189
2190 if (FRAME_W32_WINDOW (f) != 0 && f->output_data.w32->border_width > 0)
2191 {
2192 if (FRAME_VISIBLE_P (f))
2193 redraw_frame (f);
2194 }
2195 }
2196
2197 /* Set the border-color of frame F to value described by ARG.
2198 ARG can be a string naming a color.
2199 The border-color is used for the border that is drawn by the server.
2200 Note that this does not fully take effect if done before
2201 F has a window; it must be redone when the window is created. */
2202
2203 void
2204 x_set_border_color (f, arg, oldval)
2205 struct frame *f;
2206 Lisp_Object arg, oldval;
2207 {
2208 int pix;
2209
2210 CHECK_STRING (arg, 0);
2211 pix = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
2212 x_set_border_pixel (f, pix);
2213 update_face_from_frame_parameter (f, Qborder_color, arg);
2214 }
2215
2216 /* Value is the internal representation of the specified cursor type
2217 ARG. If type is BAR_CURSOR, return in *WIDTH the specified width
2218 of the bar cursor. */
2219
2220 enum text_cursor_kinds
2221 x_specified_cursor_type (arg, width)
2222 Lisp_Object arg;
2223 int *width;
2224 {
2225 enum text_cursor_kinds type;
2226
2227 if (EQ (arg, Qbar))
2228 {
2229 type = BAR_CURSOR;
2230 *width = 2;
2231 }
2232 else if (CONSP (arg)
2233 && EQ (XCAR (arg), Qbar)
2234 && INTEGERP (XCDR (arg))
2235 && XINT (XCDR (arg)) >= 0)
2236 {
2237 type = BAR_CURSOR;
2238 *width = XINT (XCDR (arg));
2239 }
2240 else if (NILP (arg))
2241 type = NO_CURSOR;
2242 else
2243 /* Treat anything unknown as "box cursor".
2244 It was bad to signal an error; people have trouble fixing
2245 .Xdefaults with Emacs, when it has something bad in it. */
2246 type = FILLED_BOX_CURSOR;
2247
2248 return type;
2249 }
2250
2251 void
2252 x_set_cursor_type (f, arg, oldval)
2253 FRAME_PTR f;
2254 Lisp_Object arg, oldval;
2255 {
2256 int width;
2257
2258 FRAME_DESIRED_CURSOR (f) = x_specified_cursor_type (arg, &width);
2259 f->output_data.w32->cursor_width = width;
2260
2261 /* Make sure the cursor gets redrawn. This is overkill, but how
2262 often do people change cursor types? */
2263 update_mode_lines++;
2264 }
2265 \f
2266 void
2267 x_set_icon_type (f, arg, oldval)
2268 struct frame *f;
2269 Lisp_Object arg, oldval;
2270 {
2271 int result;
2272
2273 if (NILP (arg) && NILP (oldval))
2274 return;
2275
2276 if (STRINGP (arg) && STRINGP (oldval)
2277 && EQ (Fstring_equal (oldval, arg), Qt))
2278 return;
2279
2280 if (SYMBOLP (arg) && SYMBOLP (oldval) && EQ (arg, oldval))
2281 return;
2282
2283 BLOCK_INPUT;
2284
2285 result = x_bitmap_icon (f, arg);
2286 if (result)
2287 {
2288 UNBLOCK_INPUT;
2289 error ("No icon window available");
2290 }
2291
2292 UNBLOCK_INPUT;
2293 }
2294
2295 /* Return non-nil if frame F wants a bitmap icon. */
2296
2297 Lisp_Object
2298 x_icon_type (f)
2299 FRAME_PTR f;
2300 {
2301 Lisp_Object tem;
2302
2303 tem = assq_no_quit (Qicon_type, f->param_alist);
2304 if (CONSP (tem))
2305 return XCDR (tem);
2306 else
2307 return Qnil;
2308 }
2309
2310 void
2311 x_set_icon_name (f, arg, oldval)
2312 struct frame *f;
2313 Lisp_Object arg, oldval;
2314 {
2315 if (STRINGP (arg))
2316 {
2317 if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt))
2318 return;
2319 }
2320 else if (!STRINGP (oldval) && EQ (oldval, Qnil) == EQ (arg, Qnil))
2321 return;
2322
2323 f->icon_name = arg;
2324
2325 #if 0
2326 if (f->output_data.w32->icon_bitmap != 0)
2327 return;
2328
2329 BLOCK_INPUT;
2330
2331 result = x_text_icon (f,
2332 (char *) XSTRING ((!NILP (f->icon_name)
2333 ? f->icon_name
2334 : !NILP (f->title)
2335 ? f->title
2336 : f->name))->data);
2337
2338 if (result)
2339 {
2340 UNBLOCK_INPUT;
2341 error ("No icon window available");
2342 }
2343
2344 /* If the window was unmapped (and its icon was mapped),
2345 the new icon is not mapped, so map the window in its stead. */
2346 if (FRAME_VISIBLE_P (f))
2347 {
2348 #ifdef USE_X_TOOLKIT
2349 XtPopup (f->output_data.w32->widget, XtGrabNone);
2350 #endif
2351 XMapWindow (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f));
2352 }
2353
2354 XFlush (FRAME_W32_DISPLAY (f));
2355 UNBLOCK_INPUT;
2356 #endif
2357 }
2358
2359 extern Lisp_Object x_new_font ();
2360 extern Lisp_Object x_new_fontset();
2361
2362 void
2363 x_set_font (f, arg, oldval)
2364 struct frame *f;
2365 Lisp_Object arg, oldval;
2366 {
2367 Lisp_Object result;
2368 Lisp_Object fontset_name;
2369 Lisp_Object frame;
2370
2371 CHECK_STRING (arg, 1);
2372
2373 fontset_name = Fquery_fontset (arg, Qnil);
2374
2375 BLOCK_INPUT;
2376 result = (STRINGP (fontset_name)
2377 ? x_new_fontset (f, XSTRING (fontset_name)->data)
2378 : x_new_font (f, XSTRING (arg)->data));
2379 UNBLOCK_INPUT;
2380
2381 if (EQ (result, Qnil))
2382 error ("Font `%s' is not defined", XSTRING (arg)->data);
2383 else if (EQ (result, Qt))
2384 error ("The characters of the given font have varying widths");
2385 else if (STRINGP (result))
2386 {
2387 if (!NILP (Fequal (result, oldval)))
2388 return;
2389 store_frame_param (f, Qfont, result);
2390 recompute_basic_faces (f);
2391 }
2392 else
2393 abort ();
2394
2395 do_pending_window_change (0);
2396
2397 /* Don't call `face-set-after-frame-default' when faces haven't been
2398 initialized yet. This is the case when called from
2399 Fx_create_frame. In that case, the X widget or window doesn't
2400 exist either, and we can end up in x_report_frame_params with a
2401 null widget which gives a segfault. */
2402 if (FRAME_FACE_CACHE (f))
2403 {
2404 XSETFRAME (frame, f);
2405 call1 (Qface_set_after_frame_default, frame);
2406 }
2407 }
2408
2409 void
2410 x_set_border_width (f, arg, oldval)
2411 struct frame *f;
2412 Lisp_Object arg, oldval;
2413 {
2414 CHECK_NUMBER (arg, 0);
2415
2416 if (XINT (arg) == f->output_data.w32->border_width)
2417 return;
2418
2419 if (FRAME_W32_WINDOW (f) != 0)
2420 error ("Cannot change the border width of a window");
2421
2422 f->output_data.w32->border_width = XINT (arg);
2423 }
2424
2425 void
2426 x_set_internal_border_width (f, arg, oldval)
2427 struct frame *f;
2428 Lisp_Object arg, oldval;
2429 {
2430 int old = f->output_data.w32->internal_border_width;
2431
2432 CHECK_NUMBER (arg, 0);
2433 f->output_data.w32->internal_border_width = XINT (arg);
2434 if (f->output_data.w32->internal_border_width < 0)
2435 f->output_data.w32->internal_border_width = 0;
2436
2437 if (f->output_data.w32->internal_border_width == old)
2438 return;
2439
2440 if (FRAME_W32_WINDOW (f) != 0)
2441 {
2442 x_set_window_size (f, 0, f->width, f->height);
2443 SET_FRAME_GARBAGED (f);
2444 do_pending_window_change (0);
2445 }
2446 }
2447
2448 void
2449 x_set_visibility (f, value, oldval)
2450 struct frame *f;
2451 Lisp_Object value, oldval;
2452 {
2453 Lisp_Object frame;
2454 XSETFRAME (frame, f);
2455
2456 if (NILP (value))
2457 Fmake_frame_invisible (frame, Qt);
2458 else if (EQ (value, Qicon))
2459 Ficonify_frame (frame);
2460 else
2461 Fmake_frame_visible (frame);
2462 }
2463
2464 \f
2465 /* Change window heights in windows rooted in WINDOW by N lines. */
2466
2467 static void
2468 x_change_window_heights (window, n)
2469 Lisp_Object window;
2470 int n;
2471 {
2472 struct window *w = XWINDOW (window);
2473
2474 XSETFASTINT (w->top, XFASTINT (w->top) + n);
2475 XSETFASTINT (w->height, XFASTINT (w->height) - n);
2476
2477 if (INTEGERP (w->orig_top))
2478 XSETFASTINT (w->orig_top, XFASTINT (w->orig_top) + n);
2479 if (INTEGERP (w->orig_height))
2480 XSETFASTINT (w->orig_height, XFASTINT (w->orig_height) - n);
2481
2482 /* Handle just the top child in a vertical split. */
2483 if (!NILP (w->vchild))
2484 x_change_window_heights (w->vchild, n);
2485
2486 /* Adjust all children in a horizontal split. */
2487 for (window = w->hchild; !NILP (window); window = w->next)
2488 {
2489 w = XWINDOW (window);
2490 x_change_window_heights (window, n);
2491 }
2492 }
2493
2494 void
2495 x_set_menu_bar_lines (f, value, oldval)
2496 struct frame *f;
2497 Lisp_Object value, oldval;
2498 {
2499 int nlines;
2500 int olines = FRAME_MENU_BAR_LINES (f);
2501
2502 /* Right now, menu bars don't work properly in minibuf-only frames;
2503 most of the commands try to apply themselves to the minibuffer
2504 frame itself, and get an error because you can't switch buffers
2505 in or split the minibuffer window. */
2506 if (FRAME_MINIBUF_ONLY_P (f))
2507 return;
2508
2509 if (INTEGERP (value))
2510 nlines = XINT (value);
2511 else
2512 nlines = 0;
2513
2514 FRAME_MENU_BAR_LINES (f) = 0;
2515 if (nlines)
2516 FRAME_EXTERNAL_MENU_BAR (f) = 1;
2517 else
2518 {
2519 if (FRAME_EXTERNAL_MENU_BAR (f) == 1)
2520 free_frame_menubar (f);
2521 FRAME_EXTERNAL_MENU_BAR (f) = 0;
2522
2523 /* Adjust the frame size so that the client (text) dimensions
2524 remain the same. This depends on FRAME_EXTERNAL_MENU_BAR being
2525 set correctly. */
2526 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
2527 do_pending_window_change (0);
2528 }
2529 adjust_glyphs (f);
2530 }
2531
2532
2533 /* Set the number of lines used for the tool bar of frame F to VALUE.
2534 VALUE not an integer, or < 0 means set the lines to zero. OLDVAL
2535 is the old number of tool bar lines. This function changes the
2536 height of all windows on frame F to match the new tool bar height.
2537 The frame's height doesn't change. */
2538
2539 void
2540 x_set_tool_bar_lines (f, value, oldval)
2541 struct frame *f;
2542 Lisp_Object value, oldval;
2543 {
2544 int delta, nlines, root_height;
2545 Lisp_Object root_window;
2546
2547 /* Treat tool bars like menu bars. */
2548 if (FRAME_MINIBUF_ONLY_P (f))
2549 return;
2550
2551 /* Use VALUE only if an integer >= 0. */
2552 if (INTEGERP (value) && XINT (value) >= 0)
2553 nlines = XFASTINT (value);
2554 else
2555 nlines = 0;
2556
2557 /* Make sure we redisplay all windows in this frame. */
2558 ++windows_or_buffers_changed;
2559
2560 delta = nlines - FRAME_TOOL_BAR_LINES (f);
2561
2562 /* Don't resize the tool-bar to more than we have room for. */
2563 root_window = FRAME_ROOT_WINDOW (f);
2564 root_height = XINT (XWINDOW (root_window)->height);
2565 if (root_height - delta < 1)
2566 {
2567 delta = root_height - 1;
2568 nlines = FRAME_TOOL_BAR_LINES (f) + delta;
2569 }
2570
2571 FRAME_TOOL_BAR_LINES (f) = nlines;
2572 x_change_window_heights (root_window, delta);
2573 adjust_glyphs (f);
2574
2575 /* We also have to make sure that the internal border at the top of
2576 the frame, below the menu bar or tool bar, is redrawn when the
2577 tool bar disappears. This is so because the internal border is
2578 below the tool bar if one is displayed, but is below the menu bar
2579 if there isn't a tool bar. The tool bar draws into the area
2580 below the menu bar. */
2581 if (FRAME_W32_WINDOW (f) && FRAME_TOOL_BAR_LINES (f) == 0)
2582 {
2583 updating_frame = f;
2584 clear_frame ();
2585 clear_current_matrices (f);
2586 updating_frame = NULL;
2587 }
2588
2589 /* If the tool bar gets smaller, the internal border below it
2590 has to be cleared. It was formerly part of the display
2591 of the larger tool bar, and updating windows won't clear it. */
2592 if (delta < 0)
2593 {
2594 int height = FRAME_INTERNAL_BORDER_WIDTH (f);
2595 int width = PIXEL_WIDTH (f);
2596 int y = nlines * CANON_Y_UNIT (f);
2597
2598 BLOCK_INPUT;
2599 {
2600 HDC hdc = get_frame_dc (f);
2601 w32_clear_area (f, hdc, 0, y, width, height);
2602 release_frame_dc (f, hdc);
2603 }
2604 UNBLOCK_INPUT;
2605 }
2606 }
2607
2608
2609 /* Change the name of frame F to NAME. If NAME is nil, set F's name to
2610 w32_id_name.
2611
2612 If EXPLICIT is non-zero, that indicates that lisp code is setting the
2613 name; if NAME is a string, set F's name to NAME and set
2614 F->explicit_name; if NAME is Qnil, then clear F->explicit_name.
2615
2616 If EXPLICIT is zero, that indicates that Emacs redisplay code is
2617 suggesting a new name, which lisp code should override; if
2618 F->explicit_name is set, ignore the new name; otherwise, set it. */
2619
2620 void
2621 x_set_name (f, name, explicit)
2622 struct frame *f;
2623 Lisp_Object name;
2624 int explicit;
2625 {
2626 /* Make sure that requests from lisp code override requests from
2627 Emacs redisplay code. */
2628 if (explicit)
2629 {
2630 /* If we're switching from explicit to implicit, we had better
2631 update the mode lines and thereby update the title. */
2632 if (f->explicit_name && NILP (name))
2633 update_mode_lines = 1;
2634
2635 f->explicit_name = ! NILP (name);
2636 }
2637 else if (f->explicit_name)
2638 return;
2639
2640 /* If NAME is nil, set the name to the w32_id_name. */
2641 if (NILP (name))
2642 {
2643 /* Check for no change needed in this very common case
2644 before we do any consing. */
2645 if (!strcmp (FRAME_W32_DISPLAY_INFO (f)->w32_id_name,
2646 XSTRING (f->name)->data))
2647 return;
2648 name = build_string (FRAME_W32_DISPLAY_INFO (f)->w32_id_name);
2649 }
2650 else
2651 CHECK_STRING (name, 0);
2652
2653 /* Don't change the name if it's already NAME. */
2654 if (! NILP (Fstring_equal (name, f->name)))
2655 return;
2656
2657 f->name = name;
2658
2659 /* For setting the frame title, the title parameter should override
2660 the name parameter. */
2661 if (! NILP (f->title))
2662 name = f->title;
2663
2664 if (FRAME_W32_WINDOW (f))
2665 {
2666 if (STRING_MULTIBYTE (name))
2667 name = ENCODE_SYSTEM (name);
2668
2669 BLOCK_INPUT;
2670 SetWindowText(FRAME_W32_WINDOW (f), XSTRING (name)->data);
2671 UNBLOCK_INPUT;
2672 }
2673 }
2674
2675 /* This function should be called when the user's lisp code has
2676 specified a name for the frame; the name will override any set by the
2677 redisplay code. */
2678 void
2679 x_explicitly_set_name (f, arg, oldval)
2680 FRAME_PTR f;
2681 Lisp_Object arg, oldval;
2682 {
2683 x_set_name (f, arg, 1);
2684 }
2685
2686 /* This function should be called by Emacs redisplay code to set the
2687 name; names set this way will never override names set by the user's
2688 lisp code. */
2689 void
2690 x_implicitly_set_name (f, arg, oldval)
2691 FRAME_PTR f;
2692 Lisp_Object arg, oldval;
2693 {
2694 x_set_name (f, arg, 0);
2695 }
2696 \f
2697 /* Change the title of frame F to NAME.
2698 If NAME is nil, use the frame name as the title.
2699
2700 If EXPLICIT is non-zero, that indicates that lisp code is setting the
2701 name; if NAME is a string, set F's name to NAME and set
2702 F->explicit_name; if NAME is Qnil, then clear F->explicit_name.
2703
2704 If EXPLICIT is zero, that indicates that Emacs redisplay code is
2705 suggesting a new name, which lisp code should override; if
2706 F->explicit_name is set, ignore the new name; otherwise, set it. */
2707
2708 void
2709 x_set_title (f, name, old_name)
2710 struct frame *f;
2711 Lisp_Object name, old_name;
2712 {
2713 /* Don't change the title if it's already NAME. */
2714 if (EQ (name, f->title))
2715 return;
2716
2717 update_mode_lines = 1;
2718
2719 f->title = name;
2720
2721 if (NILP (name))
2722 name = f->name;
2723
2724 if (FRAME_W32_WINDOW (f))
2725 {
2726 if (STRING_MULTIBYTE (name))
2727 name = ENCODE_SYSTEM (name);
2728
2729 BLOCK_INPUT;
2730 SetWindowText(FRAME_W32_WINDOW (f), XSTRING (name)->data);
2731 UNBLOCK_INPUT;
2732 }
2733 }
2734 \f
2735 void
2736 x_set_autoraise (f, arg, oldval)
2737 struct frame *f;
2738 Lisp_Object arg, oldval;
2739 {
2740 f->auto_raise = !EQ (Qnil, arg);
2741 }
2742
2743 void
2744 x_set_autolower (f, arg, oldval)
2745 struct frame *f;
2746 Lisp_Object arg, oldval;
2747 {
2748 f->auto_lower = !EQ (Qnil, arg);
2749 }
2750
2751 void
2752 x_set_unsplittable (f, arg, oldval)
2753 struct frame *f;
2754 Lisp_Object arg, oldval;
2755 {
2756 f->no_split = !NILP (arg);
2757 }
2758
2759 void
2760 x_set_vertical_scroll_bars (f, arg, oldval)
2761 struct frame *f;
2762 Lisp_Object arg, oldval;
2763 {
2764 if ((EQ (arg, Qleft) && FRAME_HAS_VERTICAL_SCROLL_BARS_ON_RIGHT (f))
2765 || (EQ (arg, Qright) && FRAME_HAS_VERTICAL_SCROLL_BARS_ON_LEFT (f))
2766 || (NILP (arg) && FRAME_HAS_VERTICAL_SCROLL_BARS (f))
2767 || (!NILP (arg) && ! FRAME_HAS_VERTICAL_SCROLL_BARS (f)))
2768 {
2769 FRAME_VERTICAL_SCROLL_BAR_TYPE (f) = NILP (arg) ?
2770 vertical_scroll_bar_none :
2771 /* Put scroll bars on the right by default, as is conventional
2772 on MS-Windows. */
2773 EQ (Qleft, arg)
2774 ? vertical_scroll_bar_left
2775 : vertical_scroll_bar_right;
2776
2777 /* We set this parameter before creating the window for the
2778 frame, so we can get the geometry right from the start.
2779 However, if the window hasn't been created yet, we shouldn't
2780 call x_set_window_size. */
2781 if (FRAME_W32_WINDOW (f))
2782 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
2783 do_pending_window_change (0);
2784 }
2785 }
2786
2787 void
2788 x_set_scroll_bar_width (f, arg, oldval)
2789 struct frame *f;
2790 Lisp_Object arg, oldval;
2791 {
2792 int wid = FONT_WIDTH (f->output_data.w32->font);
2793
2794 if (NILP (arg))
2795 {
2796 FRAME_SCROLL_BAR_PIXEL_WIDTH (f) = GetSystemMetrics (SM_CXVSCROLL);
2797 FRAME_SCROLL_BAR_COLS (f) = (FRAME_SCROLL_BAR_PIXEL_WIDTH (f) +
2798 wid - 1) / wid;
2799 if (FRAME_W32_WINDOW (f))
2800 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
2801 do_pending_window_change (0);
2802 }
2803 else if (INTEGERP (arg) && XINT (arg) > 0
2804 && XFASTINT (arg) != FRAME_SCROLL_BAR_PIXEL_WIDTH (f))
2805 {
2806 FRAME_SCROLL_BAR_PIXEL_WIDTH (f) = XFASTINT (arg);
2807 FRAME_SCROLL_BAR_COLS (f) = (FRAME_SCROLL_BAR_PIXEL_WIDTH (f)
2808 + wid-1) / wid;
2809 if (FRAME_W32_WINDOW (f))
2810 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
2811 do_pending_window_change (0);
2812 }
2813 change_frame_size (f, 0, FRAME_WIDTH (f), 0, 0, 0);
2814 XWINDOW (FRAME_SELECTED_WINDOW (f))->cursor.hpos = 0;
2815 XWINDOW (FRAME_SELECTED_WINDOW (f))->cursor.x = 0;
2816 }
2817 \f
2818 /* Subroutines of creating an frame. */
2819
2820 /* Make sure that Vx_resource_name is set to a reasonable value.
2821 Fix it up, or set it to `emacs' if it is too hopeless. */
2822
2823 static void
2824 validate_x_resource_name ()
2825 {
2826 int len = 0;
2827 /* Number of valid characters in the resource name. */
2828 int good_count = 0;
2829 /* Number of invalid characters in the resource name. */
2830 int bad_count = 0;
2831 Lisp_Object new;
2832 int i;
2833
2834 if (STRINGP (Vx_resource_name))
2835 {
2836 unsigned char *p = XSTRING (Vx_resource_name)->data;
2837 int i;
2838
2839 len = STRING_BYTES (XSTRING (Vx_resource_name));
2840
2841 /* Only letters, digits, - and _ are valid in resource names.
2842 Count the valid characters and count the invalid ones. */
2843 for (i = 0; i < len; i++)
2844 {
2845 int c = p[i];
2846 if (! ((c >= 'a' && c <= 'z')
2847 || (c >= 'A' && c <= 'Z')
2848 || (c >= '0' && c <= '9')
2849 || c == '-' || c == '_'))
2850 bad_count++;
2851 else
2852 good_count++;
2853 }
2854 }
2855 else
2856 /* Not a string => completely invalid. */
2857 bad_count = 5, good_count = 0;
2858
2859 /* If name is valid already, return. */
2860 if (bad_count == 0)
2861 return;
2862
2863 /* If name is entirely invalid, or nearly so, use `emacs'. */
2864 if (good_count == 0
2865 || (good_count == 1 && bad_count > 0))
2866 {
2867 Vx_resource_name = build_string ("emacs");
2868 return;
2869 }
2870
2871 /* Name is partly valid. Copy it and replace the invalid characters
2872 with underscores. */
2873
2874 Vx_resource_name = new = Fcopy_sequence (Vx_resource_name);
2875
2876 for (i = 0; i < len; i++)
2877 {
2878 int c = XSTRING (new)->data[i];
2879 if (! ((c >= 'a' && c <= 'z')
2880 || (c >= 'A' && c <= 'Z')
2881 || (c >= '0' && c <= '9')
2882 || c == '-' || c == '_'))
2883 XSTRING (new)->data[i] = '_';
2884 }
2885 }
2886
2887
2888 extern char *x_get_string_resource ();
2889
2890 DEFUN ("x-get-resource", Fx_get_resource, Sx_get_resource, 2, 4, 0,
2891 "Return the value of ATTRIBUTE, of class CLASS, from the X defaults database.\n\
2892 This uses `INSTANCE.ATTRIBUTE' as the key and `Emacs.CLASS' as the\n\
2893 class, where INSTANCE is the name under which Emacs was invoked, or\n\
2894 the name specified by the `-name' or `-rn' command-line arguments.\n\
2895 \n\
2896 The optional arguments COMPONENT and SUBCLASS add to the key and the\n\
2897 class, respectively. You must specify both of them or neither.\n\
2898 If you specify them, the key is `INSTANCE.COMPONENT.ATTRIBUTE'\n\
2899 and the class is `Emacs.CLASS.SUBCLASS'.")
2900 (attribute, class, component, subclass)
2901 Lisp_Object attribute, class, component, subclass;
2902 {
2903 register char *value;
2904 char *name_key;
2905 char *class_key;
2906
2907 CHECK_STRING (attribute, 0);
2908 CHECK_STRING (class, 0);
2909
2910 if (!NILP (component))
2911 CHECK_STRING (component, 1);
2912 if (!NILP (subclass))
2913 CHECK_STRING (subclass, 2);
2914 if (NILP (component) != NILP (subclass))
2915 error ("x-get-resource: must specify both COMPONENT and SUBCLASS or neither");
2916
2917 validate_x_resource_name ();
2918
2919 /* Allocate space for the components, the dots which separate them,
2920 and the final '\0'. Make them big enough for the worst case. */
2921 name_key = (char *) alloca (STRING_BYTES (XSTRING (Vx_resource_name))
2922 + (STRINGP (component)
2923 ? STRING_BYTES (XSTRING (component)) : 0)
2924 + STRING_BYTES (XSTRING (attribute))
2925 + 3);
2926
2927 class_key = (char *) alloca ((sizeof (EMACS_CLASS) - 1)
2928 + STRING_BYTES (XSTRING (class))
2929 + (STRINGP (subclass)
2930 ? STRING_BYTES (XSTRING (subclass)) : 0)
2931 + 3);
2932
2933 /* Start with emacs.FRAMENAME for the name (the specific one)
2934 and with `Emacs' for the class key (the general one). */
2935 strcpy (name_key, XSTRING (Vx_resource_name)->data);
2936 strcpy (class_key, EMACS_CLASS);
2937
2938 strcat (class_key, ".");
2939 strcat (class_key, XSTRING (class)->data);
2940
2941 if (!NILP (component))
2942 {
2943 strcat (class_key, ".");
2944 strcat (class_key, XSTRING (subclass)->data);
2945
2946 strcat (name_key, ".");
2947 strcat (name_key, XSTRING (component)->data);
2948 }
2949
2950 strcat (name_key, ".");
2951 strcat (name_key, XSTRING (attribute)->data);
2952
2953 value = x_get_string_resource (Qnil,
2954 name_key, class_key);
2955
2956 if (value != (char *) 0)
2957 return build_string (value);
2958 else
2959 return Qnil;
2960 }
2961
2962 /* Used when C code wants a resource value. */
2963
2964 char *
2965 x_get_resource_string (attribute, class)
2966 char *attribute, *class;
2967 {
2968 char *name_key;
2969 char *class_key;
2970 struct frame *sf = SELECTED_FRAME ();
2971
2972 /* Allocate space for the components, the dots which separate them,
2973 and the final '\0'. */
2974 name_key = (char *) alloca (STRING_BYTES (XSTRING (Vinvocation_name))
2975 + strlen (attribute) + 2);
2976 class_key = (char *) alloca ((sizeof (EMACS_CLASS) - 1)
2977 + strlen (class) + 2);
2978
2979 sprintf (name_key, "%s.%s",
2980 XSTRING (Vinvocation_name)->data,
2981 attribute);
2982 sprintf (class_key, "%s.%s", EMACS_CLASS, class);
2983
2984 return x_get_string_resource (sf, name_key, class_key);
2985 }
2986
2987 /* Types we might convert a resource string into. */
2988 enum resource_types
2989 {
2990 RES_TYPE_NUMBER,
2991 RES_TYPE_FLOAT,
2992 RES_TYPE_BOOLEAN,
2993 RES_TYPE_STRING,
2994 RES_TYPE_SYMBOL
2995 };
2996
2997 /* Return the value of parameter PARAM.
2998
2999 First search ALIST, then Vdefault_frame_alist, then the X defaults
3000 database, using ATTRIBUTE as the attribute name and CLASS as its class.
3001
3002 Convert the resource to the type specified by desired_type.
3003
3004 If no default is specified, return Qunbound. If you call
3005 w32_get_arg, make sure you deal with Qunbound in a reasonable way,
3006 and don't let it get stored in any Lisp-visible variables! */
3007
3008 static Lisp_Object
3009 w32_get_arg (alist, param, attribute, class, type)
3010 Lisp_Object alist, param;
3011 char *attribute;
3012 char *class;
3013 enum resource_types type;
3014 {
3015 register Lisp_Object tem;
3016
3017 tem = Fassq (param, alist);
3018 if (EQ (tem, Qnil))
3019 tem = Fassq (param, Vdefault_frame_alist);
3020 if (EQ (tem, Qnil))
3021 {
3022
3023 if (attribute)
3024 {
3025 tem = Fx_get_resource (build_string (attribute),
3026 build_string (class),
3027 Qnil, Qnil);
3028
3029 if (NILP (tem))
3030 return Qunbound;
3031
3032 switch (type)
3033 {
3034 case RES_TYPE_NUMBER:
3035 return make_number (atoi (XSTRING (tem)->data));
3036
3037 case RES_TYPE_FLOAT:
3038 return make_float (atof (XSTRING (tem)->data));
3039
3040 case RES_TYPE_BOOLEAN:
3041 tem = Fdowncase (tem);
3042 if (!strcmp (XSTRING (tem)->data, "on")
3043 || !strcmp (XSTRING (tem)->data, "true"))
3044 return Qt;
3045 else
3046 return Qnil;
3047
3048 case RES_TYPE_STRING:
3049 return tem;
3050
3051 case RES_TYPE_SYMBOL:
3052 /* As a special case, we map the values `true' and `on'
3053 to Qt, and `false' and `off' to Qnil. */
3054 {
3055 Lisp_Object lower;
3056 lower = Fdowncase (tem);
3057 if (!strcmp (XSTRING (lower)->data, "on")
3058 || !strcmp (XSTRING (lower)->data, "true"))
3059 return Qt;
3060 else if (!strcmp (XSTRING (lower)->data, "off")
3061 || !strcmp (XSTRING (lower)->data, "false"))
3062 return Qnil;
3063 else
3064 return Fintern (tem, Qnil);
3065 }
3066
3067 default:
3068 abort ();
3069 }
3070 }
3071 else
3072 return Qunbound;
3073 }
3074 return Fcdr (tem);
3075 }
3076
3077 /* Record in frame F the specified or default value according to ALIST
3078 of the parameter named PROP (a Lisp symbol).
3079 If no value is specified for PROP, look for an X default for XPROP
3080 on the frame named NAME.
3081 If that is not found either, use the value DEFLT. */
3082
3083 static Lisp_Object
3084 x_default_parameter (f, alist, prop, deflt, xprop, xclass, type)
3085 struct frame *f;
3086 Lisp_Object alist;
3087 Lisp_Object prop;
3088 Lisp_Object deflt;
3089 char *xprop;
3090 char *xclass;
3091 enum resource_types type;
3092 {
3093 Lisp_Object tem;
3094
3095 tem = w32_get_arg (alist, prop, xprop, xclass, type);
3096 if (EQ (tem, Qunbound))
3097 tem = deflt;
3098 x_set_frame_parameters (f, Fcons (Fcons (prop, tem), Qnil));
3099 return tem;
3100 }
3101 \f
3102 DEFUN ("x-parse-geometry", Fx_parse_geometry, Sx_parse_geometry, 1, 1, 0,
3103 "Parse an X-style geometry string STRING.\n\
3104 Returns an alist of the form ((top . TOP), (left . LEFT) ... ).\n\
3105 The properties returned may include `top', `left', `height', and `width'.\n\
3106 The value of `left' or `top' may be an integer,\n\
3107 or a list (+ N) meaning N pixels relative to top/left corner,\n\
3108 or a list (- N) meaning -N pixels relative to bottom/right corner.")
3109 (string)
3110 Lisp_Object string;
3111 {
3112 int geometry, x, y;
3113 unsigned int width, height;
3114 Lisp_Object result;
3115
3116 CHECK_STRING (string, 0);
3117
3118 geometry = XParseGeometry ((char *) XSTRING (string)->data,
3119 &x, &y, &width, &height);
3120
3121 result = Qnil;
3122 if (geometry & XValue)
3123 {
3124 Lisp_Object element;
3125
3126 if (x >= 0 && (geometry & XNegative))
3127 element = Fcons (Qleft, Fcons (Qminus, Fcons (make_number (-x), Qnil)));
3128 else if (x < 0 && ! (geometry & XNegative))
3129 element = Fcons (Qleft, Fcons (Qplus, Fcons (make_number (x), Qnil)));
3130 else
3131 element = Fcons (Qleft, make_number (x));
3132 result = Fcons (element, result);
3133 }
3134
3135 if (geometry & YValue)
3136 {
3137 Lisp_Object element;
3138
3139 if (y >= 0 && (geometry & YNegative))
3140 element = Fcons (Qtop, Fcons (Qminus, Fcons (make_number (-y), Qnil)));
3141 else if (y < 0 && ! (geometry & YNegative))
3142 element = Fcons (Qtop, Fcons (Qplus, Fcons (make_number (y), Qnil)));
3143 else
3144 element = Fcons (Qtop, make_number (y));
3145 result = Fcons (element, result);
3146 }
3147
3148 if (geometry & WidthValue)
3149 result = Fcons (Fcons (Qwidth, make_number (width)), result);
3150 if (geometry & HeightValue)
3151 result = Fcons (Fcons (Qheight, make_number (height)), result);
3152
3153 return result;
3154 }
3155
3156 /* Calculate the desired size and position of this window,
3157 and return the flags saying which aspects were specified.
3158
3159 This function does not make the coordinates positive. */
3160
3161 #define DEFAULT_ROWS 40
3162 #define DEFAULT_COLS 80
3163
3164 static int
3165 x_figure_window_size (f, parms)
3166 struct frame *f;
3167 Lisp_Object parms;
3168 {
3169 register Lisp_Object tem0, tem1, tem2;
3170 long window_prompting = 0;
3171
3172 /* Default values if we fall through.
3173 Actually, if that happens we should get
3174 window manager prompting. */
3175 SET_FRAME_WIDTH (f, DEFAULT_COLS);
3176 f->height = DEFAULT_ROWS;
3177 /* Window managers expect that if program-specified
3178 positions are not (0,0), they're intentional, not defaults. */
3179 f->output_data.w32->top_pos = 0;
3180 f->output_data.w32->left_pos = 0;
3181
3182 /* Ensure that old new_width and new_height will not override the
3183 values set here. */
3184 FRAME_NEW_WIDTH (f) = 0;
3185 FRAME_NEW_HEIGHT (f) = 0;
3186
3187 tem0 = w32_get_arg (parms, Qheight, 0, 0, RES_TYPE_NUMBER);
3188 tem1 = w32_get_arg (parms, Qwidth, 0, 0, RES_TYPE_NUMBER);
3189 tem2 = w32_get_arg (parms, Quser_size, 0, 0, RES_TYPE_NUMBER);
3190 if (! EQ (tem0, Qunbound) || ! EQ (tem1, Qunbound))
3191 {
3192 if (!EQ (tem0, Qunbound))
3193 {
3194 CHECK_NUMBER (tem0, 0);
3195 f->height = XINT (tem0);
3196 }
3197 if (!EQ (tem1, Qunbound))
3198 {
3199 CHECK_NUMBER (tem1, 0);
3200 SET_FRAME_WIDTH (f, XINT (tem1));
3201 }
3202 if (!NILP (tem2) && !EQ (tem2, Qunbound))
3203 window_prompting |= USSize;
3204 else
3205 window_prompting |= PSize;
3206 }
3207
3208 f->output_data.w32->vertical_scroll_bar_extra
3209 = (!FRAME_HAS_VERTICAL_SCROLL_BARS (f)
3210 ? 0
3211 : FRAME_SCROLL_BAR_PIXEL_WIDTH (f) > 0
3212 ? FRAME_SCROLL_BAR_PIXEL_WIDTH (f)
3213 : (FRAME_SCROLL_BAR_COLS (f) * FONT_WIDTH (f->output_data.w32->font)));
3214 f->output_data.w32->flags_areas_extra
3215 = FRAME_FLAGS_AREA_WIDTH (f);
3216 f->output_data.w32->pixel_width = CHAR_TO_PIXEL_WIDTH (f, f->width);
3217 f->output_data.w32->pixel_height = CHAR_TO_PIXEL_HEIGHT (f, f->height);
3218
3219 tem0 = w32_get_arg (parms, Qtop, 0, 0, RES_TYPE_NUMBER);
3220 tem1 = w32_get_arg (parms, Qleft, 0, 0, RES_TYPE_NUMBER);
3221 tem2 = w32_get_arg (parms, Quser_position, 0, 0, RES_TYPE_NUMBER);
3222 if (! EQ (tem0, Qunbound) || ! EQ (tem1, Qunbound))
3223 {
3224 if (EQ (tem0, Qminus))
3225 {
3226 f->output_data.w32->top_pos = 0;
3227 window_prompting |= YNegative;
3228 }
3229 else if (CONSP (tem0) && EQ (XCAR (tem0), Qminus)
3230 && CONSP (XCDR (tem0))
3231 && INTEGERP (XCAR (XCDR (tem0))))
3232 {
3233 f->output_data.w32->top_pos = - XINT (XCAR (XCDR (tem0)));
3234 window_prompting |= YNegative;
3235 }
3236 else if (CONSP (tem0) && EQ (XCAR (tem0), Qplus)
3237 && CONSP (XCDR (tem0))
3238 && INTEGERP (XCAR (XCDR (tem0))))
3239 {
3240 f->output_data.w32->top_pos = XINT (XCAR (XCDR (tem0)));
3241 }
3242 else if (EQ (tem0, Qunbound))
3243 f->output_data.w32->top_pos = 0;
3244 else
3245 {
3246 CHECK_NUMBER (tem0, 0);
3247 f->output_data.w32->top_pos = XINT (tem0);
3248 if (f->output_data.w32->top_pos < 0)
3249 window_prompting |= YNegative;
3250 }
3251
3252 if (EQ (tem1, Qminus))
3253 {
3254 f->output_data.w32->left_pos = 0;
3255 window_prompting |= XNegative;
3256 }
3257 else if (CONSP (tem1) && EQ (XCAR (tem1), Qminus)
3258 && CONSP (XCDR (tem1))
3259 && INTEGERP (XCAR (XCDR (tem1))))
3260 {
3261 f->output_data.w32->left_pos = - XINT (XCAR (XCDR (tem1)));
3262 window_prompting |= XNegative;
3263 }
3264 else if (CONSP (tem1) && EQ (XCAR (tem1), Qplus)
3265 && CONSP (XCDR (tem1))
3266 && INTEGERP (XCAR (XCDR (tem1))))
3267 {
3268 f->output_data.w32->left_pos = XINT (XCAR (XCDR (tem1)));
3269 }
3270 else if (EQ (tem1, Qunbound))
3271 f->output_data.w32->left_pos = 0;
3272 else
3273 {
3274 CHECK_NUMBER (tem1, 0);
3275 f->output_data.w32->left_pos = XINT (tem1);
3276 if (f->output_data.w32->left_pos < 0)
3277 window_prompting |= XNegative;
3278 }
3279
3280 if (!NILP (tem2) && ! EQ (tem2, Qunbound))
3281 window_prompting |= USPosition;
3282 else
3283 window_prompting |= PPosition;
3284 }
3285
3286 return window_prompting;
3287 }
3288
3289 \f
3290
3291 extern LRESULT CALLBACK w32_wnd_proc ();
3292
3293 BOOL
3294 w32_init_class (hinst)
3295 HINSTANCE hinst;
3296 {
3297 WNDCLASS wc;
3298
3299 wc.style = CS_HREDRAW | CS_VREDRAW;
3300 wc.lpfnWndProc = (WNDPROC) w32_wnd_proc;
3301 wc.cbClsExtra = 0;
3302 wc.cbWndExtra = WND_EXTRA_BYTES;
3303 wc.hInstance = hinst;
3304 wc.hIcon = LoadIcon (hinst, EMACS_CLASS);
3305 wc.hCursor = LoadCursor (NULL, IDC_ARROW);
3306 wc.hbrBackground = NULL; /* GetStockObject (WHITE_BRUSH); */
3307 wc.lpszMenuName = NULL;
3308 wc.lpszClassName = EMACS_CLASS;
3309
3310 return (RegisterClass (&wc));
3311 }
3312
3313 HWND
3314 w32_createscrollbar (f, bar)
3315 struct frame *f;
3316 struct scroll_bar * bar;
3317 {
3318 return (CreateWindow ("SCROLLBAR", "", SBS_VERT | WS_CHILD | WS_VISIBLE,
3319 /* Position and size of scroll bar. */
3320 XINT(bar->left) + VERTICAL_SCROLL_BAR_WIDTH_TRIM,
3321 XINT(bar->top),
3322 XINT(bar->width) - VERTICAL_SCROLL_BAR_WIDTH_TRIM * 2,
3323 XINT(bar->height),
3324 FRAME_W32_WINDOW (f),
3325 NULL,
3326 hinst,
3327 NULL));
3328 }
3329
3330 void
3331 w32_createwindow (f)
3332 struct frame *f;
3333 {
3334 HWND hwnd;
3335 RECT rect;
3336
3337 rect.left = rect.top = 0;
3338 rect.right = PIXEL_WIDTH (f);
3339 rect.bottom = PIXEL_HEIGHT (f);
3340
3341 AdjustWindowRect (&rect, f->output_data.w32->dwStyle,
3342 FRAME_EXTERNAL_MENU_BAR (f));
3343
3344 /* Do first time app init */
3345
3346 if (!hprevinst)
3347 {
3348 w32_init_class (hinst);
3349 }
3350
3351 FRAME_W32_WINDOW (f) = hwnd
3352 = CreateWindow (EMACS_CLASS,
3353 f->namebuf,
3354 f->output_data.w32->dwStyle | WS_CLIPCHILDREN,
3355 f->output_data.w32->left_pos,
3356 f->output_data.w32->top_pos,
3357 rect.right - rect.left,
3358 rect.bottom - rect.top,
3359 NULL,
3360 NULL,
3361 hinst,
3362 NULL);
3363
3364 if (hwnd)
3365 {
3366 SetWindowLong (hwnd, WND_FONTWIDTH_INDEX, FONT_WIDTH (f->output_data.w32->font));
3367 SetWindowLong (hwnd, WND_LINEHEIGHT_INDEX, f->output_data.w32->line_height);
3368 SetWindowLong (hwnd, WND_BORDER_INDEX, f->output_data.w32->internal_border_width);
3369 SetWindowLong (hwnd, WND_SCROLLBAR_INDEX, f->output_data.w32->vertical_scroll_bar_extra);
3370 SetWindowLong (hwnd, WND_BACKGROUND_INDEX, FRAME_BACKGROUND_PIXEL (f));
3371
3372 /* Enable drag-n-drop. */
3373 DragAcceptFiles (hwnd, TRUE);
3374
3375 /* Do this to discard the default setting specified by our parent. */
3376 ShowWindow (hwnd, SW_HIDE);
3377 }
3378 }
3379
3380 void
3381 my_post_msg (wmsg, hwnd, msg, wParam, lParam)
3382 W32Msg * wmsg;
3383 HWND hwnd;
3384 UINT msg;
3385 WPARAM wParam;
3386 LPARAM lParam;
3387 {
3388 wmsg->msg.hwnd = hwnd;
3389 wmsg->msg.message = msg;
3390 wmsg->msg.wParam = wParam;
3391 wmsg->msg.lParam = lParam;
3392 wmsg->msg.time = GetMessageTime ();
3393
3394 post_msg (wmsg);
3395 }
3396
3397 /* GetKeyState and MapVirtualKey on Windows 95 do not actually distinguish
3398 between left and right keys as advertised. We test for this
3399 support dynamically, and set a flag when the support is absent. If
3400 absent, we keep track of the left and right control and alt keys
3401 ourselves. This is particularly necessary on keyboards that rely
3402 upon the AltGr key, which is represented as having the left control
3403 and right alt keys pressed. For these keyboards, we need to know
3404 when the left alt key has been pressed in addition to the AltGr key
3405 so that we can properly support M-AltGr-key sequences (such as M-@
3406 on Swedish keyboards). */
3407
3408 #define EMACS_LCONTROL 0
3409 #define EMACS_RCONTROL 1
3410 #define EMACS_LMENU 2
3411 #define EMACS_RMENU 3
3412
3413 static int modifiers[4];
3414 static int modifiers_recorded;
3415 static int modifier_key_support_tested;
3416
3417 static void
3418 test_modifier_support (unsigned int wparam)
3419 {
3420 unsigned int l, r;
3421
3422 if (wparam != VK_CONTROL && wparam != VK_MENU)
3423 return;
3424 if (wparam == VK_CONTROL)
3425 {
3426 l = VK_LCONTROL;
3427 r = VK_RCONTROL;
3428 }
3429 else
3430 {
3431 l = VK_LMENU;
3432 r = VK_RMENU;
3433 }
3434 if (!(GetKeyState (l) & 0x8000) && !(GetKeyState (r) & 0x8000))
3435 modifiers_recorded = 1;
3436 else
3437 modifiers_recorded = 0;
3438 modifier_key_support_tested = 1;
3439 }
3440
3441 static void
3442 record_keydown (unsigned int wparam, unsigned int lparam)
3443 {
3444 int i;
3445
3446 if (!modifier_key_support_tested)
3447 test_modifier_support (wparam);
3448
3449 if ((wparam != VK_CONTROL && wparam != VK_MENU) || !modifiers_recorded)
3450 return;
3451
3452 if (wparam == VK_CONTROL)
3453 i = (lparam & 0x1000000) ? EMACS_RCONTROL : EMACS_LCONTROL;
3454 else
3455 i = (lparam & 0x1000000) ? EMACS_RMENU : EMACS_LMENU;
3456
3457 modifiers[i] = 1;
3458 }
3459
3460 static void
3461 record_keyup (unsigned int wparam, unsigned int lparam)
3462 {
3463 int i;
3464
3465 if ((wparam != VK_CONTROL && wparam != VK_MENU) || !modifiers_recorded)
3466 return;
3467
3468 if (wparam == VK_CONTROL)
3469 i = (lparam & 0x1000000) ? EMACS_RCONTROL : EMACS_LCONTROL;
3470 else
3471 i = (lparam & 0x1000000) ? EMACS_RMENU : EMACS_LMENU;
3472
3473 modifiers[i] = 0;
3474 }
3475
3476 /* Emacs can lose focus while a modifier key has been pressed. When
3477 it regains focus, be conservative and clear all modifiers since
3478 we cannot reconstruct the left and right modifier state. */
3479 static void
3480 reset_modifiers ()
3481 {
3482 SHORT ctrl, alt;
3483
3484 if (GetFocus () == NULL)
3485 /* Emacs doesn't have keyboard focus. Do nothing. */
3486 return;
3487
3488 ctrl = GetAsyncKeyState (VK_CONTROL);
3489 alt = GetAsyncKeyState (VK_MENU);
3490
3491 if (!(ctrl & 0x08000))
3492 /* Clear any recorded control modifier state. */
3493 modifiers[EMACS_RCONTROL] = modifiers[EMACS_LCONTROL] = 0;
3494
3495 if (!(alt & 0x08000))
3496 /* Clear any recorded alt modifier state. */
3497 modifiers[EMACS_RMENU] = modifiers[EMACS_LMENU] = 0;
3498
3499 /* Update the state of all modifier keys, because modifiers used in
3500 hot-key combinations can get stuck on if Emacs loses focus as a
3501 result of a hot-key being pressed. */
3502 {
3503 BYTE keystate[256];
3504
3505 #define CURRENT_STATE(key) ((GetAsyncKeyState (key) & 0x8000) >> 8)
3506
3507 GetKeyboardState (keystate);
3508 keystate[VK_SHIFT] = CURRENT_STATE (VK_SHIFT);
3509 keystate[VK_CONTROL] = CURRENT_STATE (VK_CONTROL);
3510 keystate[VK_LCONTROL] = CURRENT_STATE (VK_LCONTROL);
3511 keystate[VK_RCONTROL] = CURRENT_STATE (VK_RCONTROL);
3512 keystate[VK_MENU] = CURRENT_STATE (VK_MENU);
3513 keystate[VK_LMENU] = CURRENT_STATE (VK_LMENU);
3514 keystate[VK_RMENU] = CURRENT_STATE (VK_RMENU);
3515 keystate[VK_LWIN] = CURRENT_STATE (VK_LWIN);
3516 keystate[VK_RWIN] = CURRENT_STATE (VK_RWIN);
3517 keystate[VK_APPS] = CURRENT_STATE (VK_APPS);
3518 SetKeyboardState (keystate);
3519 }
3520 }
3521
3522 /* Synchronize modifier state with what is reported with the current
3523 keystroke. Even if we cannot distinguish between left and right
3524 modifier keys, we know that, if no modifiers are set, then neither
3525 the left or right modifier should be set. */
3526 static void
3527 sync_modifiers ()
3528 {
3529 if (!modifiers_recorded)
3530 return;
3531
3532 if (!(GetKeyState (VK_CONTROL) & 0x8000))
3533 modifiers[EMACS_RCONTROL] = modifiers[EMACS_LCONTROL] = 0;
3534
3535 if (!(GetKeyState (VK_MENU) & 0x8000))
3536 modifiers[EMACS_RMENU] = modifiers[EMACS_LMENU] = 0;
3537 }
3538
3539 static int
3540 modifier_set (int vkey)
3541 {
3542 if (vkey == VK_CAPITAL || vkey == VK_SCROLL)
3543 return (GetKeyState (vkey) & 0x1);
3544 if (!modifiers_recorded)
3545 return (GetKeyState (vkey) & 0x8000);
3546
3547 switch (vkey)
3548 {
3549 case VK_LCONTROL:
3550 return modifiers[EMACS_LCONTROL];
3551 case VK_RCONTROL:
3552 return modifiers[EMACS_RCONTROL];
3553 case VK_LMENU:
3554 return modifiers[EMACS_LMENU];
3555 case VK_RMENU:
3556 return modifiers[EMACS_RMENU];
3557 }
3558 return (GetKeyState (vkey) & 0x8000);
3559 }
3560
3561 /* Convert between the modifier bits W32 uses and the modifier bits
3562 Emacs uses. */
3563
3564 unsigned int
3565 w32_key_to_modifier (int key)
3566 {
3567 Lisp_Object key_mapping;
3568
3569 switch (key)
3570 {
3571 case VK_LWIN:
3572 key_mapping = Vw32_lwindow_modifier;
3573 break;
3574 case VK_RWIN:
3575 key_mapping = Vw32_rwindow_modifier;
3576 break;
3577 case VK_APPS:
3578 key_mapping = Vw32_apps_modifier;
3579 break;
3580 case VK_SCROLL:
3581 key_mapping = Vw32_scroll_lock_modifier;
3582 break;
3583 default:
3584 key_mapping = Qnil;
3585 }
3586
3587 /* NB. This code runs in the input thread, asychronously to the lisp
3588 thread, so we must be careful to ensure access to lisp data is
3589 thread-safe. The following code is safe because the modifier
3590 variable values are updated atomically from lisp and symbols are
3591 not relocated by GC. Also, we don't have to worry about seeing GC
3592 markbits here. */
3593 if (EQ (key_mapping, Qhyper))
3594 return hyper_modifier;
3595 if (EQ (key_mapping, Qsuper))
3596 return super_modifier;
3597 if (EQ (key_mapping, Qmeta))
3598 return meta_modifier;
3599 if (EQ (key_mapping, Qalt))
3600 return alt_modifier;
3601 if (EQ (key_mapping, Qctrl))
3602 return ctrl_modifier;
3603 if (EQ (key_mapping, Qcontrol)) /* synonym for ctrl */
3604 return ctrl_modifier;
3605 if (EQ (key_mapping, Qshift))
3606 return shift_modifier;
3607
3608 /* Don't generate any modifier if not explicitly requested. */
3609 return 0;
3610 }
3611
3612 unsigned int
3613 w32_get_modifiers ()
3614 {
3615 return ((modifier_set (VK_SHIFT) ? shift_modifier : 0) |
3616 (modifier_set (VK_CONTROL) ? ctrl_modifier : 0) |
3617 (modifier_set (VK_LWIN) ? w32_key_to_modifier (VK_LWIN) : 0) |
3618 (modifier_set (VK_RWIN) ? w32_key_to_modifier (VK_RWIN) : 0) |
3619 (modifier_set (VK_APPS) ? w32_key_to_modifier (VK_APPS) : 0) |
3620 (modifier_set (VK_SCROLL) ? w32_key_to_modifier (VK_SCROLL) : 0) |
3621 (modifier_set (VK_MENU) ?
3622 ((NILP (Vw32_alt_is_meta)) ? alt_modifier : meta_modifier) : 0));
3623 }
3624
3625 /* We map the VK_* modifiers into console modifier constants
3626 so that we can use the same routines to handle both console
3627 and window input. */
3628
3629 static int
3630 construct_console_modifiers ()
3631 {
3632 int mods;
3633
3634 mods = 0;
3635 mods |= (modifier_set (VK_SHIFT)) ? SHIFT_PRESSED : 0;
3636 mods |= (modifier_set (VK_CAPITAL)) ? CAPSLOCK_ON : 0;
3637 mods |= (modifier_set (VK_SCROLL)) ? SCROLLLOCK_ON : 0;
3638 mods |= (modifier_set (VK_NUMLOCK)) ? NUMLOCK_ON : 0;
3639 mods |= (modifier_set (VK_LCONTROL)) ? LEFT_CTRL_PRESSED : 0;
3640 mods |= (modifier_set (VK_RCONTROL)) ? RIGHT_CTRL_PRESSED : 0;
3641 mods |= (modifier_set (VK_LMENU)) ? LEFT_ALT_PRESSED : 0;
3642 mods |= (modifier_set (VK_RMENU)) ? RIGHT_ALT_PRESSED : 0;
3643 mods |= (modifier_set (VK_LWIN)) ? LEFT_WIN_PRESSED : 0;
3644 mods |= (modifier_set (VK_RWIN)) ? RIGHT_WIN_PRESSED : 0;
3645 mods |= (modifier_set (VK_APPS)) ? APPS_PRESSED : 0;
3646
3647 return mods;
3648 }
3649
3650 static int
3651 w32_get_key_modifiers (unsigned int wparam, unsigned int lparam)
3652 {
3653 int mods;
3654
3655 /* Convert to emacs modifiers. */
3656 mods = w32_kbd_mods_to_emacs (construct_console_modifiers (), wparam);
3657
3658 return mods;
3659 }
3660
3661 unsigned int
3662 map_keypad_keys (unsigned int virt_key, unsigned int extended)
3663 {
3664 if (virt_key < VK_CLEAR || virt_key > VK_DELETE)
3665 return virt_key;
3666
3667 if (virt_key == VK_RETURN)
3668 return (extended ? VK_NUMPAD_ENTER : VK_RETURN);
3669
3670 if (virt_key >= VK_PRIOR && virt_key <= VK_DOWN)
3671 return (!extended ? (VK_NUMPAD_PRIOR + (virt_key - VK_PRIOR)) : virt_key);
3672
3673 if (virt_key == VK_INSERT || virt_key == VK_DELETE)
3674 return (!extended ? (VK_NUMPAD_INSERT + (virt_key - VK_INSERT)) : virt_key);
3675
3676 if (virt_key == VK_CLEAR)
3677 return (!extended ? VK_NUMPAD_CLEAR : virt_key);
3678
3679 return virt_key;
3680 }
3681
3682 /* List of special key combinations which w32 would normally capture,
3683 but emacs should grab instead. Not directly visible to lisp, to
3684 simplify synchronization. Each item is an integer encoding a virtual
3685 key code and modifier combination to capture. */
3686 Lisp_Object w32_grabbed_keys;
3687
3688 #define HOTKEY(vk,mods) make_number (((vk) & 255) | ((mods) << 8))
3689 #define HOTKEY_ID(k) (XFASTINT (k) & 0xbfff)
3690 #define HOTKEY_VK_CODE(k) (XFASTINT (k) & 255)
3691 #define HOTKEY_MODIFIERS(k) (XFASTINT (k) >> 8)
3692
3693 /* Register hot-keys for reserved key combinations when Emacs has
3694 keyboard focus, since this is the only way Emacs can receive key
3695 combinations like Alt-Tab which are used by the system. */
3696
3697 static void
3698 register_hot_keys (hwnd)
3699 HWND hwnd;
3700 {
3701 Lisp_Object keylist;
3702
3703 /* Use GC_CONSP, since we are called asynchronously. */
3704 for (keylist = w32_grabbed_keys; GC_CONSP (keylist); keylist = XCDR (keylist))
3705 {
3706 Lisp_Object key = XCAR (keylist);
3707
3708 /* Deleted entries get set to nil. */
3709 if (!INTEGERP (key))
3710 continue;
3711
3712 RegisterHotKey (hwnd, HOTKEY_ID (key),
3713 HOTKEY_MODIFIERS (key), HOTKEY_VK_CODE (key));
3714 }
3715 }
3716
3717 static void
3718 unregister_hot_keys (hwnd)
3719 HWND hwnd;
3720 {
3721 Lisp_Object keylist;
3722
3723 /* Use GC_CONSP, since we are called asynchronously. */
3724 for (keylist = w32_grabbed_keys; GC_CONSP (keylist); keylist = XCDR (keylist))
3725 {
3726 Lisp_Object key = XCAR (keylist);
3727
3728 if (!INTEGERP (key))
3729 continue;
3730
3731 UnregisterHotKey (hwnd, HOTKEY_ID (key));
3732 }
3733 }
3734
3735 /* Main message dispatch loop. */
3736
3737 static void
3738 w32_msg_pump (deferred_msg * msg_buf)
3739 {
3740 MSG msg;
3741 int result;
3742 HWND focus_window;
3743
3744 msh_mousewheel = RegisterWindowMessage (MSH_MOUSEWHEEL);
3745
3746 while (GetMessage (&msg, NULL, 0, 0))
3747 {
3748 if (msg.hwnd == NULL)
3749 {
3750 switch (msg.message)
3751 {
3752 case WM_NULL:
3753 /* Produced by complete_deferred_msg; just ignore. */
3754 break;
3755 case WM_EMACS_CREATEWINDOW:
3756 w32_createwindow ((struct frame *) msg.wParam);
3757 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
3758 abort ();
3759 break;
3760 case WM_EMACS_SETLOCALE:
3761 SetThreadLocale (msg.wParam);
3762 /* Reply is not expected. */
3763 break;
3764 case WM_EMACS_SETKEYBOARDLAYOUT:
3765 result = (int) ActivateKeyboardLayout ((HKL) msg.wParam, 0);
3766 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE,
3767 result, 0))
3768 abort ();
3769 break;
3770 case WM_EMACS_REGISTER_HOT_KEY:
3771 focus_window = GetFocus ();
3772 if (focus_window != NULL)
3773 RegisterHotKey (focus_window,
3774 HOTKEY_ID (msg.wParam),
3775 HOTKEY_MODIFIERS (msg.wParam),
3776 HOTKEY_VK_CODE (msg.wParam));
3777 /* Reply is not expected. */
3778 break;
3779 case WM_EMACS_UNREGISTER_HOT_KEY:
3780 focus_window = GetFocus ();
3781 if (focus_window != NULL)
3782 UnregisterHotKey (focus_window, HOTKEY_ID (msg.wParam));
3783 /* Mark item as erased. NB: this code must be
3784 thread-safe. The next line is okay because the cons
3785 cell is never made into garbage and is not relocated by
3786 GC. */
3787 XCAR ((Lisp_Object) msg.lParam) = Qnil;
3788 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
3789 abort ();
3790 break;
3791 case WM_EMACS_TOGGLE_LOCK_KEY:
3792 {
3793 int vk_code = (int) msg.wParam;
3794 int cur_state = (GetKeyState (vk_code) & 1);
3795 Lisp_Object new_state = (Lisp_Object) msg.lParam;
3796
3797 /* NB: This code must be thread-safe. It is safe to
3798 call NILP because symbols are not relocated by GC,
3799 and pointer here is not touched by GC (so the markbit
3800 can't be set). Numbers are safe because they are
3801 immediate values. */
3802 if (NILP (new_state)
3803 || (NUMBERP (new_state)
3804 && ((XUINT (new_state)) & 1) != cur_state))
3805 {
3806 one_w32_display_info.faked_key = vk_code;
3807
3808 keybd_event ((BYTE) vk_code,
3809 (BYTE) MapVirtualKey (vk_code, 0),
3810 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
3811 keybd_event ((BYTE) vk_code,
3812 (BYTE) MapVirtualKey (vk_code, 0),
3813 KEYEVENTF_EXTENDEDKEY | 0, 0);
3814 keybd_event ((BYTE) vk_code,
3815 (BYTE) MapVirtualKey (vk_code, 0),
3816 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
3817 cur_state = !cur_state;
3818 }
3819 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE,
3820 cur_state, 0))
3821 abort ();
3822 }
3823 break;
3824 default:
3825 DebPrint (("msg %x not expected by w32_msg_pump\n", msg.message));
3826 }
3827 }
3828 else
3829 {
3830 DispatchMessage (&msg);
3831 }
3832
3833 /* Exit nested loop when our deferred message has completed. */
3834 if (msg_buf->completed)
3835 break;
3836 }
3837 }
3838
3839 deferred_msg * deferred_msg_head;
3840
3841 static deferred_msg *
3842 find_deferred_msg (HWND hwnd, UINT msg)
3843 {
3844 deferred_msg * item;
3845
3846 /* Don't actually need synchronization for read access, since
3847 modification of single pointer is always atomic. */
3848 /* enter_crit (); */
3849
3850 for (item = deferred_msg_head; item != NULL; item = item->next)
3851 if (item->w32msg.msg.hwnd == hwnd
3852 && item->w32msg.msg.message == msg)
3853 break;
3854
3855 /* leave_crit (); */
3856
3857 return item;
3858 }
3859
3860 static LRESULT
3861 send_deferred_msg (deferred_msg * msg_buf,
3862 HWND hwnd,
3863 UINT msg,
3864 WPARAM wParam,
3865 LPARAM lParam)
3866 {
3867 /* Only input thread can send deferred messages. */
3868 if (GetCurrentThreadId () != dwWindowsThreadId)
3869 abort ();
3870
3871 /* It is an error to send a message that is already deferred. */
3872 if (find_deferred_msg (hwnd, msg) != NULL)
3873 abort ();
3874
3875 /* Enforced synchronization is not needed because this is the only
3876 function that alters deferred_msg_head, and the following critical
3877 section is guaranteed to only be serially reentered (since only the
3878 input thread can call us). */
3879
3880 /* enter_crit (); */
3881
3882 msg_buf->completed = 0;
3883 msg_buf->next = deferred_msg_head;
3884 deferred_msg_head = msg_buf;
3885 my_post_msg (&msg_buf->w32msg, hwnd, msg, wParam, lParam);
3886
3887 /* leave_crit (); */
3888
3889 /* Start a new nested message loop to process other messages until
3890 this one is completed. */
3891 w32_msg_pump (msg_buf);
3892
3893 deferred_msg_head = msg_buf->next;
3894
3895 return msg_buf->result;
3896 }
3897
3898 void
3899 complete_deferred_msg (HWND hwnd, UINT msg, LRESULT result)
3900 {
3901 deferred_msg * msg_buf = find_deferred_msg (hwnd, msg);
3902
3903 if (msg_buf == NULL)
3904 /* Message may have been cancelled, so don't abort(). */
3905 return;
3906
3907 msg_buf->result = result;
3908 msg_buf->completed = 1;
3909
3910 /* Ensure input thread is woken so it notices the completion. */
3911 PostThreadMessage (dwWindowsThreadId, WM_NULL, 0, 0);
3912 }
3913
3914 void
3915 cancel_all_deferred_msgs ()
3916 {
3917 deferred_msg * item;
3918
3919 /* Don't actually need synchronization for read access, since
3920 modification of single pointer is always atomic. */
3921 /* enter_crit (); */
3922
3923 for (item = deferred_msg_head; item != NULL; item = item->next)
3924 {
3925 item->result = 0;
3926 item->completed = 1;
3927 }
3928
3929 /* leave_crit (); */
3930
3931 /* Ensure input thread is woken so it notices the completion. */
3932 PostThreadMessage (dwWindowsThreadId, WM_NULL, 0, 0);
3933 }
3934
3935 DWORD
3936 w32_msg_worker (dw)
3937 DWORD dw;
3938 {
3939 MSG msg;
3940 deferred_msg dummy_buf;
3941
3942 /* Ensure our message queue is created */
3943
3944 PeekMessage (&msg, NULL, 0, 0, PM_NOREMOVE);
3945
3946 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
3947 abort ();
3948
3949 memset (&dummy_buf, 0, sizeof (dummy_buf));
3950 dummy_buf.w32msg.msg.hwnd = NULL;
3951 dummy_buf.w32msg.msg.message = WM_NULL;
3952
3953 /* This is the inital message loop which should only exit when the
3954 application quits. */
3955 w32_msg_pump (&dummy_buf);
3956
3957 return 0;
3958 }
3959
3960 static void
3961 post_character_message (hwnd, msg, wParam, lParam, modifiers)
3962 HWND hwnd;
3963 UINT msg;
3964 WPARAM wParam;
3965 LPARAM lParam;
3966 DWORD modifiers;
3967
3968 {
3969 W32Msg wmsg;
3970
3971 wmsg.dwModifiers = modifiers;
3972
3973 /* Detect quit_char and set quit-flag directly. Note that we
3974 still need to post a message to ensure the main thread will be
3975 woken up if blocked in sys_select(), but we do NOT want to post
3976 the quit_char message itself (because it will usually be as if
3977 the user had typed quit_char twice). Instead, we post a dummy
3978 message that has no particular effect. */
3979 {
3980 int c = wParam;
3981 if (isalpha (c) && wmsg.dwModifiers == ctrl_modifier)
3982 c = make_ctrl_char (c) & 0377;
3983 if (c == quit_char
3984 || (wmsg.dwModifiers == 0 &&
3985 XFASTINT (Vw32_quit_key) && wParam == XFASTINT (Vw32_quit_key)))
3986 {
3987 Vquit_flag = Qt;
3988
3989 /* The choice of message is somewhat arbitrary, as long as
3990 the main thread handler just ignores it. */
3991 msg = WM_NULL;
3992
3993 /* Interrupt any blocking system calls. */
3994 signal_quit ();
3995
3996 /* As a safety precaution, forcibly complete any deferred
3997 messages. This is a kludge, but I don't see any particularly
3998 clean way to handle the situation where a deferred message is
3999 "dropped" in the lisp thread, and will thus never be
4000 completed, eg. by the user trying to activate the menubar
4001 when the lisp thread is busy, and then typing C-g when the
4002 menubar doesn't open promptly (with the result that the
4003 menubar never responds at all because the deferred
4004 WM_INITMENU message is never completed). Another problem
4005 situation is when the lisp thread calls SendMessage (to send
4006 a window manager command) when a message has been deferred;
4007 the lisp thread gets blocked indefinitely waiting for the
4008 deferred message to be completed, which itself is waiting for
4009 the lisp thread to respond.
4010
4011 Note that we don't want to block the input thread waiting for
4012 a reponse from the lisp thread (although that would at least
4013 solve the deadlock problem above), because we want to be able
4014 to receive C-g to interrupt the lisp thread. */
4015 cancel_all_deferred_msgs ();
4016 }
4017 }
4018
4019 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4020 }
4021
4022 /* Main window procedure */
4023
4024 LRESULT CALLBACK
4025 w32_wnd_proc (hwnd, msg, wParam, lParam)
4026 HWND hwnd;
4027 UINT msg;
4028 WPARAM wParam;
4029 LPARAM lParam;
4030 {
4031 struct frame *f;
4032 struct w32_display_info *dpyinfo = &one_w32_display_info;
4033 W32Msg wmsg;
4034 int windows_translate;
4035 int key;
4036
4037 /* Note that it is okay to call x_window_to_frame, even though we are
4038 not running in the main lisp thread, because frame deletion
4039 requires the lisp thread to synchronize with this thread. Thus, if
4040 a frame struct is returned, it can be used without concern that the
4041 lisp thread might make it disappear while we are using it.
4042
4043 NB. Walking the frame list in this thread is safe (as long as
4044 writes of Lisp_Object slots are atomic, which they are on Windows).
4045 Although delete-frame can destructively modify the frame list while
4046 we are walking it, a garbage collection cannot occur until after
4047 delete-frame has synchronized with this thread.
4048
4049 It is also safe to use functions that make GDI calls, such as
4050 w32_clear_rect, because these functions must obtain a DC handle
4051 from the frame struct using get_frame_dc which is thread-aware. */
4052
4053 switch (msg)
4054 {
4055 case WM_ERASEBKGND:
4056 f = x_window_to_frame (dpyinfo, hwnd);
4057 if (f)
4058 {
4059 HDC hdc = get_frame_dc (f);
4060 GetUpdateRect (hwnd, &wmsg.rect, FALSE);
4061 w32_clear_rect (f, hdc, &wmsg.rect);
4062 release_frame_dc (f, hdc);
4063
4064 #if defined (W32_DEBUG_DISPLAY)
4065 DebPrint (("WM_ERASEBKGND (frame %p): erasing %d,%d-%d,%d\n",
4066 f,
4067 wmsg.rect.left, wmsg.rect.top,
4068 wmsg.rect.right, wmsg.rect.bottom));
4069 #endif /* W32_DEBUG_DISPLAY */
4070 }
4071 return 1;
4072 case WM_PALETTECHANGED:
4073 /* ignore our own changes */
4074 if ((HWND)wParam != hwnd)
4075 {
4076 f = x_window_to_frame (dpyinfo, hwnd);
4077 if (f)
4078 /* get_frame_dc will realize our palette and force all
4079 frames to be redrawn if needed. */
4080 release_frame_dc (f, get_frame_dc (f));
4081 }
4082 return 0;
4083 case WM_PAINT:
4084 {
4085 PAINTSTRUCT paintStruct;
4086 RECT update_rect;
4087
4088 f = x_window_to_frame (dpyinfo, hwnd);
4089 if (f == 0)
4090 {
4091 DebPrint (("WM_PAINT received for unknown window %p\n", hwnd));
4092 return 0;
4093 }
4094
4095 /* MSDN Docs say not to call BeginPaint if GetUpdateRect
4096 fails. Apparently this can happen under some
4097 circumstances. */
4098 if (!w32_strict_painting || GetUpdateRect (hwnd, &update_rect, FALSE))
4099 {
4100 enter_crit ();
4101 BeginPaint (hwnd, &paintStruct);
4102
4103 if (w32_strict_painting)
4104 /* The rectangles returned by GetUpdateRect and BeginPaint
4105 do not always match. GetUpdateRect seems to be the
4106 more reliable of the two. */
4107 wmsg.rect = update_rect;
4108 else
4109 wmsg.rect = paintStruct.rcPaint;
4110
4111 #if defined (W32_DEBUG_DISPLAY)
4112 DebPrint (("WM_PAINT (frame %p): painting %d,%d-%d,%d\n",
4113 f,
4114 wmsg.rect.left, wmsg.rect.top,
4115 wmsg.rect.right, wmsg.rect.bottom));
4116 DebPrint ((" [update region is %d,%d-%d,%d]\n",
4117 update_rect.left, update_rect.top,
4118 update_rect.right, update_rect.bottom));
4119 #endif
4120 EndPaint (hwnd, &paintStruct);
4121 leave_crit ();
4122
4123 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4124
4125 return 0;
4126 }
4127
4128 /* If GetUpdateRect returns 0 (meaning there is no update
4129 region), assume the whole window needs to be repainted. */
4130 GetClientRect(hwnd, &wmsg.rect);
4131 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4132 return 0;
4133 }
4134
4135 case WM_INPUTLANGCHANGE:
4136 /* Inform lisp thread of keyboard layout changes. */
4137 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4138
4139 /* Clear dead keys in the keyboard state; for simplicity only
4140 preserve modifier key states. */
4141 {
4142 int i;
4143 BYTE keystate[256];
4144
4145 GetKeyboardState (keystate);
4146 for (i = 0; i < 256; i++)
4147 if (1
4148 && i != VK_SHIFT
4149 && i != VK_LSHIFT
4150 && i != VK_RSHIFT
4151 && i != VK_CAPITAL
4152 && i != VK_NUMLOCK
4153 && i != VK_SCROLL
4154 && i != VK_CONTROL
4155 && i != VK_LCONTROL
4156 && i != VK_RCONTROL
4157 && i != VK_MENU
4158 && i != VK_LMENU
4159 && i != VK_RMENU
4160 && i != VK_LWIN
4161 && i != VK_RWIN)
4162 keystate[i] = 0;
4163 SetKeyboardState (keystate);
4164 }
4165 goto dflt;
4166
4167 case WM_HOTKEY:
4168 /* Synchronize hot keys with normal input. */
4169 PostMessage (hwnd, WM_KEYDOWN, HIWORD (lParam), 0);
4170 return (0);
4171
4172 case WM_KEYUP:
4173 case WM_SYSKEYUP:
4174 record_keyup (wParam, lParam);
4175 goto dflt;
4176
4177 case WM_KEYDOWN:
4178 case WM_SYSKEYDOWN:
4179 /* Ignore keystrokes we fake ourself; see below. */
4180 if (dpyinfo->faked_key == wParam)
4181 {
4182 dpyinfo->faked_key = 0;
4183 /* Make sure TranslateMessage sees them though (as long as
4184 they don't produce WM_CHAR messages). This ensures that
4185 indicator lights are toggled promptly on Windows 9x, for
4186 example. */
4187 if (lispy_function_keys[wParam] != 0)
4188 {
4189 windows_translate = 1;
4190 goto translate;
4191 }
4192 return 0;
4193 }
4194
4195 /* Synchronize modifiers with current keystroke. */
4196 sync_modifiers ();
4197 record_keydown (wParam, lParam);
4198 wParam = map_keypad_keys (wParam, (lParam & 0x1000000L) != 0);
4199
4200 windows_translate = 0;
4201
4202 switch (wParam)
4203 {
4204 case VK_LWIN:
4205 if (NILP (Vw32_pass_lwindow_to_system))
4206 {
4207 /* Prevent system from acting on keyup (which opens the
4208 Start menu if no other key was pressed) by simulating a
4209 press of Space which we will ignore. */
4210 if (GetAsyncKeyState (wParam) & 1)
4211 {
4212 if (NUMBERP (Vw32_phantom_key_code))
4213 key = XUINT (Vw32_phantom_key_code) & 255;
4214 else
4215 key = VK_SPACE;
4216 dpyinfo->faked_key = key;
4217 keybd_event (key, (BYTE) MapVirtualKey (key, 0), 0, 0);
4218 }
4219 }
4220 if (!NILP (Vw32_lwindow_modifier))
4221 return 0;
4222 break;
4223 case VK_RWIN:
4224 if (NILP (Vw32_pass_rwindow_to_system))
4225 {
4226 if (GetAsyncKeyState (wParam) & 1)
4227 {
4228 if (NUMBERP (Vw32_phantom_key_code))
4229 key = XUINT (Vw32_phantom_key_code) & 255;
4230 else
4231 key = VK_SPACE;
4232 dpyinfo->faked_key = key;
4233 keybd_event (key, (BYTE) MapVirtualKey (key, 0), 0, 0);
4234 }
4235 }
4236 if (!NILP (Vw32_rwindow_modifier))
4237 return 0;
4238 break;
4239 case VK_APPS:
4240 if (!NILP (Vw32_apps_modifier))
4241 return 0;
4242 break;
4243 case VK_MENU:
4244 if (NILP (Vw32_pass_alt_to_system))
4245 /* Prevent DefWindowProc from activating the menu bar if an
4246 Alt key is pressed and released by itself. */
4247 return 0;
4248 windows_translate = 1;
4249 break;
4250 case VK_CAPITAL:
4251 /* Decide whether to treat as modifier or function key. */
4252 if (NILP (Vw32_enable_caps_lock))
4253 goto disable_lock_key;
4254 windows_translate = 1;
4255 break;
4256 case VK_NUMLOCK:
4257 /* Decide whether to treat as modifier or function key. */
4258 if (NILP (Vw32_enable_num_lock))
4259 goto disable_lock_key;
4260 windows_translate = 1;
4261 break;
4262 case VK_SCROLL:
4263 /* Decide whether to treat as modifier or function key. */
4264 if (NILP (Vw32_scroll_lock_modifier))
4265 goto disable_lock_key;
4266 windows_translate = 1;
4267 break;
4268 disable_lock_key:
4269 /* Ensure the appropriate lock key state (and indicator light)
4270 remains in the same state. We do this by faking another
4271 press of the relevant key. Apparently, this really is the
4272 only way to toggle the state of the indicator lights. */
4273 dpyinfo->faked_key = wParam;
4274 keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0),
4275 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
4276 keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0),
4277 KEYEVENTF_EXTENDEDKEY | 0, 0);
4278 keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0),
4279 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
4280 /* Ensure indicator lights are updated promptly on Windows 9x
4281 (TranslateMessage apparently does this), after forwarding
4282 input event. */
4283 post_character_message (hwnd, msg, wParam, lParam,
4284 w32_get_key_modifiers (wParam, lParam));
4285 windows_translate = 1;
4286 break;
4287 case VK_CONTROL:
4288 case VK_SHIFT:
4289 case VK_PROCESSKEY: /* Generated by IME. */
4290 windows_translate = 1;
4291 break;
4292 case VK_CANCEL:
4293 /* Windows maps Ctrl-Pause (aka Ctrl-Break) into VK_CANCEL,
4294 which is confusing for purposes of key binding; convert
4295 VK_CANCEL events into VK_PAUSE events. */
4296 wParam = VK_PAUSE;
4297 break;
4298 case VK_PAUSE:
4299 /* Windows maps Ctrl-NumLock into VK_PAUSE, which is confusing
4300 for purposes of key binding; convert these back into
4301 VK_NUMLOCK events, at least when we want to see NumLock key
4302 presses. (Note that there is never any possibility that
4303 VK_PAUSE with Ctrl really is C-Pause as per above.) */
4304 if (NILP (Vw32_enable_num_lock) && modifier_set (VK_CONTROL))
4305 wParam = VK_NUMLOCK;
4306 break;
4307 default:
4308 /* If not defined as a function key, change it to a WM_CHAR message. */
4309 if (lispy_function_keys[wParam] == 0)
4310 {
4311 DWORD modifiers = construct_console_modifiers ();
4312
4313 if (!NILP (Vw32_recognize_altgr)
4314 && modifier_set (VK_LCONTROL) && modifier_set (VK_RMENU))
4315 {
4316 /* Always let TranslateMessage handle AltGr key chords;
4317 for some reason, ToAscii doesn't always process AltGr
4318 chords correctly. */
4319 windows_translate = 1;
4320 }
4321 else if ((modifiers & (~SHIFT_PRESSED & ~CAPSLOCK_ON)) != 0)
4322 {
4323 /* Handle key chords including any modifiers other
4324 than shift directly, in order to preserve as much
4325 modifier information as possible. */
4326 if ('A' <= wParam && wParam <= 'Z')
4327 {
4328 /* Don't translate modified alphabetic keystrokes,
4329 so the user doesn't need to constantly switch
4330 layout to type control or meta keystrokes when
4331 the normal layout translates alphabetic
4332 characters to non-ascii characters. */
4333 if (!modifier_set (VK_SHIFT))
4334 wParam += ('a' - 'A');
4335 msg = WM_CHAR;
4336 }
4337 else
4338 {
4339 /* Try to handle other keystrokes by determining the
4340 base character (ie. translating the base key plus
4341 shift modifier). */
4342 int add;
4343 int isdead = 0;
4344 KEY_EVENT_RECORD key;
4345
4346 key.bKeyDown = TRUE;
4347 key.wRepeatCount = 1;
4348 key.wVirtualKeyCode = wParam;
4349 key.wVirtualScanCode = (lParam & 0xFF0000) >> 16;
4350 key.uChar.AsciiChar = 0;
4351 key.dwControlKeyState = modifiers;
4352
4353 add = w32_kbd_patch_key (&key);
4354 /* 0 means an unrecognised keycode, negative means
4355 dead key. Ignore both. */
4356 while (--add >= 0)
4357 {
4358 /* Forward asciified character sequence. */
4359 post_character_message
4360 (hwnd, WM_CHAR, key.uChar.AsciiChar, lParam,
4361 w32_get_key_modifiers (wParam, lParam));
4362 w32_kbd_patch_key (&key);
4363 }
4364 return 0;
4365 }
4366 }
4367 else
4368 {
4369 /* Let TranslateMessage handle everything else. */
4370 windows_translate = 1;
4371 }
4372 }
4373 }
4374
4375 translate:
4376 if (windows_translate)
4377 {
4378 MSG windows_msg = { hwnd, msg, wParam, lParam, 0, {0,0} };
4379
4380 windows_msg.time = GetMessageTime ();
4381 TranslateMessage (&windows_msg);
4382 goto dflt;
4383 }
4384
4385 /* Fall through */
4386
4387 case WM_SYSCHAR:
4388 case WM_CHAR:
4389 post_character_message (hwnd, msg, wParam, lParam,
4390 w32_get_key_modifiers (wParam, lParam));
4391 break;
4392
4393 /* Simulate middle mouse button events when left and right buttons
4394 are used together, but only if user has two button mouse. */
4395 case WM_LBUTTONDOWN:
4396 case WM_RBUTTONDOWN:
4397 if (XINT (Vw32_num_mouse_buttons) > 2)
4398 goto handle_plain_button;
4399
4400 {
4401 int this = (msg == WM_LBUTTONDOWN) ? LMOUSE : RMOUSE;
4402 int other = (msg == WM_LBUTTONDOWN) ? RMOUSE : LMOUSE;
4403
4404 if (button_state & this)
4405 return 0;
4406
4407 if (button_state == 0)
4408 SetCapture (hwnd);
4409
4410 button_state |= this;
4411
4412 if (button_state & other)
4413 {
4414 if (mouse_button_timer)
4415 {
4416 KillTimer (hwnd, mouse_button_timer);
4417 mouse_button_timer = 0;
4418
4419 /* Generate middle mouse event instead. */
4420 msg = WM_MBUTTONDOWN;
4421 button_state |= MMOUSE;
4422 }
4423 else if (button_state & MMOUSE)
4424 {
4425 /* Ignore button event if we've already generated a
4426 middle mouse down event. This happens if the
4427 user releases and press one of the two buttons
4428 after we've faked a middle mouse event. */
4429 return 0;
4430 }
4431 else
4432 {
4433 /* Flush out saved message. */
4434 post_msg (&saved_mouse_button_msg);
4435 }
4436 wmsg.dwModifiers = w32_get_modifiers ();
4437 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4438
4439 /* Clear message buffer. */
4440 saved_mouse_button_msg.msg.hwnd = 0;
4441 }
4442 else
4443 {
4444 /* Hold onto message for now. */
4445 mouse_button_timer =
4446 SetTimer (hwnd, MOUSE_BUTTON_ID,
4447 XINT (Vw32_mouse_button_tolerance), NULL);
4448 saved_mouse_button_msg.msg.hwnd = hwnd;
4449 saved_mouse_button_msg.msg.message = msg;
4450 saved_mouse_button_msg.msg.wParam = wParam;
4451 saved_mouse_button_msg.msg.lParam = lParam;
4452 saved_mouse_button_msg.msg.time = GetMessageTime ();
4453 saved_mouse_button_msg.dwModifiers = w32_get_modifiers ();
4454 }
4455 }
4456 return 0;
4457
4458 case WM_LBUTTONUP:
4459 case WM_RBUTTONUP:
4460 if (XINT (Vw32_num_mouse_buttons) > 2)
4461 goto handle_plain_button;
4462
4463 {
4464 int this = (msg == WM_LBUTTONUP) ? LMOUSE : RMOUSE;
4465 int other = (msg == WM_LBUTTONUP) ? RMOUSE : LMOUSE;
4466
4467 if ((button_state & this) == 0)
4468 return 0;
4469
4470 button_state &= ~this;
4471
4472 if (button_state & MMOUSE)
4473 {
4474 /* Only generate event when second button is released. */
4475 if ((button_state & other) == 0)
4476 {
4477 msg = WM_MBUTTONUP;
4478 button_state &= ~MMOUSE;
4479
4480 if (button_state) abort ();
4481 }
4482 else
4483 return 0;
4484 }
4485 else
4486 {
4487 /* Flush out saved message if necessary. */
4488 if (saved_mouse_button_msg.msg.hwnd)
4489 {
4490 post_msg (&saved_mouse_button_msg);
4491 }
4492 }
4493 wmsg.dwModifiers = w32_get_modifiers ();
4494 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4495
4496 /* Always clear message buffer and cancel timer. */
4497 saved_mouse_button_msg.msg.hwnd = 0;
4498 KillTimer (hwnd, mouse_button_timer);
4499 mouse_button_timer = 0;
4500
4501 if (button_state == 0)
4502 ReleaseCapture ();
4503 }
4504 return 0;
4505
4506 case WM_MBUTTONDOWN:
4507 case WM_MBUTTONUP:
4508 handle_plain_button:
4509 {
4510 BOOL up;
4511 int button;
4512
4513 if (parse_button (msg, &button, &up))
4514 {
4515 if (up) ReleaseCapture ();
4516 else SetCapture (hwnd);
4517 button = (button == 0) ? LMOUSE :
4518 ((button == 1) ? MMOUSE : RMOUSE);
4519 if (up)
4520 button_state &= ~button;
4521 else
4522 button_state |= button;
4523 }
4524 }
4525
4526 wmsg.dwModifiers = w32_get_modifiers ();
4527 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4528 return 0;
4529
4530 case WM_VSCROLL:
4531 case WM_MOUSEMOVE:
4532 if (XINT (Vw32_mouse_move_interval) <= 0
4533 || (msg == WM_MOUSEMOVE && button_state == 0))
4534 {
4535 wmsg.dwModifiers = w32_get_modifiers ();
4536 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4537 return 0;
4538 }
4539
4540 /* Hang onto mouse move and scroll messages for a bit, to avoid
4541 sending such events to Emacs faster than it can process them.
4542 If we get more events before the timer from the first message
4543 expires, we just replace the first message. */
4544
4545 if (saved_mouse_move_msg.msg.hwnd == 0)
4546 mouse_move_timer =
4547 SetTimer (hwnd, MOUSE_MOVE_ID,
4548 XINT (Vw32_mouse_move_interval), NULL);
4549
4550 /* Hold onto message for now. */
4551 saved_mouse_move_msg.msg.hwnd = hwnd;
4552 saved_mouse_move_msg.msg.message = msg;
4553 saved_mouse_move_msg.msg.wParam = wParam;
4554 saved_mouse_move_msg.msg.lParam = lParam;
4555 saved_mouse_move_msg.msg.time = GetMessageTime ();
4556 saved_mouse_move_msg.dwModifiers = w32_get_modifiers ();
4557
4558 return 0;
4559
4560 case WM_MOUSEWHEEL:
4561 wmsg.dwModifiers = w32_get_modifiers ();
4562 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4563 return 0;
4564
4565 case WM_DROPFILES:
4566 wmsg.dwModifiers = w32_get_modifiers ();
4567 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4568 return 0;
4569
4570 case WM_TIMER:
4571 /* Flush out saved messages if necessary. */
4572 if (wParam == mouse_button_timer)
4573 {
4574 if (saved_mouse_button_msg.msg.hwnd)
4575 {
4576 post_msg (&saved_mouse_button_msg);
4577 saved_mouse_button_msg.msg.hwnd = 0;
4578 }
4579 KillTimer (hwnd, mouse_button_timer);
4580 mouse_button_timer = 0;
4581 }
4582 else if (wParam == mouse_move_timer)
4583 {
4584 if (saved_mouse_move_msg.msg.hwnd)
4585 {
4586 post_msg (&saved_mouse_move_msg);
4587 saved_mouse_move_msg.msg.hwnd = 0;
4588 }
4589 KillTimer (hwnd, mouse_move_timer);
4590 mouse_move_timer = 0;
4591 }
4592 return 0;
4593
4594 case WM_NCACTIVATE:
4595 /* Windows doesn't send us focus messages when putting up and
4596 taking down a system popup dialog as for Ctrl-Alt-Del on Windows 95.
4597 The only indication we get that something happened is receiving
4598 this message afterwards. So this is a good time to reset our
4599 keyboard modifiers' state. */
4600 reset_modifiers ();
4601 goto dflt;
4602
4603 case WM_INITMENU:
4604 button_state = 0;
4605 ReleaseCapture ();
4606 /* We must ensure menu bar is fully constructed and up to date
4607 before allowing user interaction with it. To achieve this
4608 we send this message to the lisp thread and wait for a
4609 reply (whose value is not actually needed) to indicate that
4610 the menu bar is now ready for use, so we can now return.
4611
4612 To remain responsive in the meantime, we enter a nested message
4613 loop that can process all other messages.
4614
4615 However, we skip all this if the message results from calling
4616 TrackPopupMenu - in fact, we must NOT attempt to send the lisp
4617 thread a message because it is blocked on us at this point. We
4618 set menubar_active before calling TrackPopupMenu to indicate
4619 this (there is no possibility of confusion with real menubar
4620 being active). */
4621
4622 f = x_window_to_frame (dpyinfo, hwnd);
4623 if (f
4624 && (f->output_data.w32->menubar_active
4625 /* We can receive this message even in the absence of a
4626 menubar (ie. when the system menu is activated) - in this
4627 case we do NOT want to forward the message, otherwise it
4628 will cause the menubar to suddenly appear when the user
4629 had requested it to be turned off! */
4630 || f->output_data.w32->menubar_widget == NULL))
4631 return 0;
4632
4633 {
4634 deferred_msg msg_buf;
4635
4636 /* Detect if message has already been deferred; in this case
4637 we cannot return any sensible value to ignore this. */
4638 if (find_deferred_msg (hwnd, msg) != NULL)
4639 abort ();
4640
4641 return send_deferred_msg (&msg_buf, hwnd, msg, wParam, lParam);
4642 }
4643
4644 case WM_EXITMENULOOP:
4645 f = x_window_to_frame (dpyinfo, hwnd);
4646
4647 /* Indicate that menubar can be modified again. */
4648 if (f)
4649 f->output_data.w32->menubar_active = 0;
4650 goto dflt;
4651
4652 case WM_MENUSELECT:
4653 wmsg.dwModifiers = w32_get_modifiers ();
4654 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4655 return 0;
4656
4657 case WM_MEASUREITEM:
4658 f = x_window_to_frame (dpyinfo, hwnd);
4659 if (f)
4660 {
4661 MEASUREITEMSTRUCT * pMis = (MEASUREITEMSTRUCT *) lParam;
4662
4663 if (pMis->CtlType == ODT_MENU)
4664 {
4665 /* Work out dimensions for popup menu titles. */
4666 char * title = (char *) pMis->itemData;
4667 HDC hdc = GetDC (hwnd);
4668 HFONT menu_font = GetCurrentObject (hdc, OBJ_FONT);
4669 LOGFONT menu_logfont;
4670 HFONT old_font;
4671 SIZE size;
4672
4673 GetObject (menu_font, sizeof (menu_logfont), &menu_logfont);
4674 menu_logfont.lfWeight = FW_BOLD;
4675 menu_font = CreateFontIndirect (&menu_logfont);
4676 old_font = SelectObject (hdc, menu_font);
4677
4678 pMis->itemHeight = GetSystemMetrics (SM_CYMENUSIZE);
4679 if (title)
4680 {
4681 GetTextExtentPoint32 (hdc, title, strlen (title), &size);
4682 pMis->itemWidth = size.cx;
4683 if (pMis->itemHeight < size.cy)
4684 pMis->itemHeight = size.cy;
4685 }
4686 else
4687 pMis->itemWidth = 0;
4688
4689 SelectObject (hdc, old_font);
4690 DeleteObject (menu_font);
4691 ReleaseDC (hwnd, hdc);
4692 return TRUE;
4693 }
4694 }
4695 return 0;
4696
4697 case WM_DRAWITEM:
4698 f = x_window_to_frame (dpyinfo, hwnd);
4699 if (f)
4700 {
4701 DRAWITEMSTRUCT * pDis = (DRAWITEMSTRUCT *) lParam;
4702
4703 if (pDis->CtlType == ODT_MENU)
4704 {
4705 /* Draw popup menu title. */
4706 char * title = (char *) pDis->itemData;
4707 if (title)
4708 {
4709 HDC hdc = pDis->hDC;
4710 HFONT menu_font = GetCurrentObject (hdc, OBJ_FONT);
4711 LOGFONT menu_logfont;
4712 HFONT old_font;
4713
4714 GetObject (menu_font, sizeof (menu_logfont), &menu_logfont);
4715 menu_logfont.lfWeight = FW_BOLD;
4716 menu_font = CreateFontIndirect (&menu_logfont);
4717 old_font = SelectObject (hdc, menu_font);
4718
4719 /* Always draw title as if not selected. */
4720 ExtTextOut (hdc,
4721 pDis->rcItem.left
4722 + GetSystemMetrics (SM_CXMENUCHECK),
4723 pDis->rcItem.top,
4724 ETO_OPAQUE, &pDis->rcItem,
4725 title, strlen (title), NULL);
4726
4727 SelectObject (hdc, old_font);
4728 DeleteObject (menu_font);
4729 }
4730 return TRUE;
4731 }
4732 }
4733 return 0;
4734
4735 #if 0
4736 /* Still not right - can't distinguish between clicks in the
4737 client area of the frame from clicks forwarded from the scroll
4738 bars - may have to hook WM_NCHITTEST to remember the mouse
4739 position and then check if it is in the client area ourselves. */
4740 case WM_MOUSEACTIVATE:
4741 /* Discard the mouse click that activates a frame, allowing the
4742 user to click anywhere without changing point (or worse!).
4743 Don't eat mouse clicks on scrollbars though!! */
4744 if (LOWORD (lParam) == HTCLIENT )
4745 return MA_ACTIVATEANDEAT;
4746 goto dflt;
4747 #endif
4748
4749 case WM_ACTIVATEAPP:
4750 case WM_ACTIVATE:
4751 case WM_WINDOWPOSCHANGED:
4752 case WM_SHOWWINDOW:
4753 /* Inform lisp thread that a frame might have just been obscured
4754 or exposed, so should recheck visibility of all frames. */
4755 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4756 goto dflt;
4757
4758 case WM_SETFOCUS:
4759 dpyinfo->faked_key = 0;
4760 reset_modifiers ();
4761 register_hot_keys (hwnd);
4762 goto command;
4763 case WM_KILLFOCUS:
4764 unregister_hot_keys (hwnd);
4765 button_state = 0;
4766 ReleaseCapture ();
4767 case WM_MOVE:
4768 case WM_SIZE:
4769 case WM_COMMAND:
4770 command:
4771 wmsg.dwModifiers = w32_get_modifiers ();
4772 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4773 goto dflt;
4774
4775 case WM_CLOSE:
4776 wmsg.dwModifiers = w32_get_modifiers ();
4777 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4778 return 0;
4779
4780 case WM_WINDOWPOSCHANGING:
4781 {
4782 WINDOWPLACEMENT wp;
4783 LPWINDOWPOS lppos = (WINDOWPOS *) lParam;
4784
4785 wp.length = sizeof (WINDOWPLACEMENT);
4786 GetWindowPlacement (hwnd, &wp);
4787
4788 if (wp.showCmd != SW_SHOWMINIMIZED && (lppos->flags & SWP_NOSIZE) == 0)
4789 {
4790 RECT rect;
4791 int wdiff;
4792 int hdiff;
4793 DWORD font_width;
4794 DWORD line_height;
4795 DWORD internal_border;
4796 DWORD scrollbar_extra;
4797 RECT wr;
4798
4799 wp.length = sizeof(wp);
4800 GetWindowRect (hwnd, &wr);
4801
4802 enter_crit ();
4803
4804 font_width = GetWindowLong (hwnd, WND_FONTWIDTH_INDEX);
4805 line_height = GetWindowLong (hwnd, WND_LINEHEIGHT_INDEX);
4806 internal_border = GetWindowLong (hwnd, WND_BORDER_INDEX);
4807 scrollbar_extra = GetWindowLong (hwnd, WND_SCROLLBAR_INDEX);
4808
4809 leave_crit ();
4810
4811 memset (&rect, 0, sizeof (rect));
4812 AdjustWindowRect (&rect, GetWindowLong (hwnd, GWL_STYLE),
4813 GetMenu (hwnd) != NULL);
4814
4815 /* Force width and height of client area to be exact
4816 multiples of the character cell dimensions. */
4817 wdiff = (lppos->cx - (rect.right - rect.left)
4818 - 2 * internal_border - scrollbar_extra)
4819 % font_width;
4820 hdiff = (lppos->cy - (rect.bottom - rect.top)
4821 - 2 * internal_border)
4822 % line_height;
4823
4824 if (wdiff || hdiff)
4825 {
4826 /* For right/bottom sizing we can just fix the sizes.
4827 However for top/left sizing we will need to fix the X
4828 and Y positions as well. */
4829
4830 lppos->cx -= wdiff;
4831 lppos->cy -= hdiff;
4832
4833 if (wp.showCmd != SW_SHOWMAXIMIZED
4834 && (lppos->flags & SWP_NOMOVE) == 0)
4835 {
4836 if (lppos->x != wr.left || lppos->y != wr.top)
4837 {
4838 lppos->x += wdiff;
4839 lppos->y += hdiff;
4840 }
4841 else
4842 {
4843 lppos->flags |= SWP_NOMOVE;
4844 }
4845 }
4846
4847 return 0;
4848 }
4849 }
4850 }
4851
4852 goto dflt;
4853
4854 case WM_GETMINMAXINFO:
4855 /* Hack to correct bug that allows Emacs frames to be resized
4856 below the Minimum Tracking Size. */
4857 ((LPMINMAXINFO) lParam)->ptMinTrackSize.y++;
4858 /* Hack to allow resizing the Emacs frame above the screen size.
4859 Note that Windows 9x limits coordinates to 16-bits. */
4860 ((LPMINMAXINFO) lParam)->ptMaxTrackSize.x = 32767;
4861 ((LPMINMAXINFO) lParam)->ptMaxTrackSize.y = 32767;
4862 return 0;
4863
4864 case WM_EMACS_CREATESCROLLBAR:
4865 return (LRESULT) w32_createscrollbar ((struct frame *) wParam,
4866 (struct scroll_bar *) lParam);
4867
4868 case WM_EMACS_SHOWWINDOW:
4869 return ShowWindow ((HWND) wParam, (WPARAM) lParam);
4870
4871 case WM_EMACS_SETFOREGROUND:
4872 {
4873 HWND foreground_window;
4874 DWORD foreground_thread, retval;
4875
4876 /* On NT 5.0, and apparently Windows 98, it is necessary to
4877 attach to the thread that currently has focus in order to
4878 pull the focus away from it. */
4879 foreground_window = GetForegroundWindow ();
4880 foreground_thread = GetWindowThreadProcessId (foreground_window, NULL);
4881 if (!foreground_window
4882 || foreground_thread == GetCurrentThreadId ()
4883 || !AttachThreadInput (GetCurrentThreadId (),
4884 foreground_thread, TRUE))
4885 foreground_thread = 0;
4886
4887 retval = SetForegroundWindow ((HWND) wParam);
4888
4889 /* Detach from the previous foreground thread. */
4890 if (foreground_thread)
4891 AttachThreadInput (GetCurrentThreadId (),
4892 foreground_thread, FALSE);
4893
4894 return retval;
4895 }
4896
4897 case WM_EMACS_SETWINDOWPOS:
4898 {
4899 WINDOWPOS * pos = (WINDOWPOS *) wParam;
4900 return SetWindowPos (hwnd, pos->hwndInsertAfter,
4901 pos->x, pos->y, pos->cx, pos->cy, pos->flags);
4902 }
4903
4904 case WM_EMACS_DESTROYWINDOW:
4905 DragAcceptFiles ((HWND) wParam, FALSE);
4906 return DestroyWindow ((HWND) wParam);
4907
4908 case WM_EMACS_TRACKPOPUPMENU:
4909 {
4910 UINT flags;
4911 POINT *pos;
4912 int retval;
4913 pos = (POINT *)lParam;
4914 flags = TPM_CENTERALIGN;
4915 if (button_state & LMOUSE)
4916 flags |= TPM_LEFTBUTTON;
4917 else if (button_state & RMOUSE)
4918 flags |= TPM_RIGHTBUTTON;
4919
4920 /* Remember we did a SetCapture on the initial mouse down event,
4921 so for safety, we make sure the capture is cancelled now. */
4922 ReleaseCapture ();
4923 button_state = 0;
4924
4925 /* Use menubar_active to indicate that WM_INITMENU is from
4926 TrackPopupMenu below, and should be ignored. */
4927 f = x_window_to_frame (dpyinfo, hwnd);
4928 if (f)
4929 f->output_data.w32->menubar_active = 1;
4930
4931 if (TrackPopupMenu ((HMENU)wParam, flags, pos->x, pos->y,
4932 0, hwnd, NULL))
4933 {
4934 MSG amsg;
4935 /* Eat any mouse messages during popupmenu */
4936 while (PeekMessage (&amsg, hwnd, WM_MOUSEFIRST, WM_MOUSELAST,
4937 PM_REMOVE));
4938 /* Get the menu selection, if any */
4939 if (PeekMessage (&amsg, hwnd, WM_COMMAND, WM_COMMAND, PM_REMOVE))
4940 {
4941 retval = LOWORD (amsg.wParam);
4942 }
4943 else
4944 {
4945 retval = 0;
4946 }
4947 }
4948 else
4949 {
4950 retval = -1;
4951 }
4952
4953 return retval;
4954 }
4955
4956 default:
4957 /* Check for messages registered at runtime. */
4958 if (msg == msh_mousewheel)
4959 {
4960 wmsg.dwModifiers = w32_get_modifiers ();
4961 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4962 return 0;
4963 }
4964
4965 dflt:
4966 return DefWindowProc (hwnd, msg, wParam, lParam);
4967 }
4968
4969
4970 /* The most common default return code for handled messages is 0. */
4971 return 0;
4972 }
4973
4974 void
4975 my_create_window (f)
4976 struct frame * f;
4977 {
4978 MSG msg;
4979
4980 if (!PostThreadMessage (dwWindowsThreadId, WM_EMACS_CREATEWINDOW, (WPARAM)f, 0))
4981 abort ();
4982 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
4983 }
4984
4985 /* Create and set up the w32 window for frame F. */
4986
4987 static void
4988 w32_window (f, window_prompting, minibuffer_only)
4989 struct frame *f;
4990 long window_prompting;
4991 int minibuffer_only;
4992 {
4993 BLOCK_INPUT;
4994
4995 /* Use the resource name as the top-level window name
4996 for looking up resources. Make a non-Lisp copy
4997 for the window manager, so GC relocation won't bother it.
4998
4999 Elsewhere we specify the window name for the window manager. */
5000
5001 {
5002 char *str = (char *) XSTRING (Vx_resource_name)->data;
5003 f->namebuf = (char *) xmalloc (strlen (str) + 1);
5004 strcpy (f->namebuf, str);
5005 }
5006
5007 my_create_window (f);
5008
5009 validate_x_resource_name ();
5010
5011 /* x_set_name normally ignores requests to set the name if the
5012 requested name is the same as the current name. This is the one
5013 place where that assumption isn't correct; f->name is set, but
5014 the server hasn't been told. */
5015 {
5016 Lisp_Object name;
5017 int explicit = f->explicit_name;
5018
5019 f->explicit_name = 0;
5020 name = f->name;
5021 f->name = Qnil;
5022 x_set_name (f, name, explicit);
5023 }
5024
5025 UNBLOCK_INPUT;
5026
5027 if (!minibuffer_only && FRAME_EXTERNAL_MENU_BAR (f))
5028 initialize_frame_menubar (f);
5029
5030 if (FRAME_W32_WINDOW (f) == 0)
5031 error ("Unable to create window");
5032 }
5033
5034 /* Handle the icon stuff for this window. Perhaps later we might
5035 want an x_set_icon_position which can be called interactively as
5036 well. */
5037
5038 static void
5039 x_icon (f, parms)
5040 struct frame *f;
5041 Lisp_Object parms;
5042 {
5043 Lisp_Object icon_x, icon_y;
5044
5045 /* Set the position of the icon. Note that Windows 95 groups all
5046 icons in the tray. */
5047 icon_x = w32_get_arg (parms, Qicon_left, 0, 0, RES_TYPE_NUMBER);
5048 icon_y = w32_get_arg (parms, Qicon_top, 0, 0, RES_TYPE_NUMBER);
5049 if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound))
5050 {
5051 CHECK_NUMBER (icon_x, 0);
5052 CHECK_NUMBER (icon_y, 0);
5053 }
5054 else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound))
5055 error ("Both left and top icon corners of icon must be specified");
5056
5057 BLOCK_INPUT;
5058
5059 if (! EQ (icon_x, Qunbound))
5060 x_wm_set_icon_position (f, XINT (icon_x), XINT (icon_y));
5061
5062 #if 0 /* TODO */
5063 /* Start up iconic or window? */
5064 x_wm_set_window_state
5065 (f, (EQ (w32_get_arg (parms, Qvisibility, 0, 0, RES_TYPE_SYMBOL), Qicon)
5066 ? IconicState
5067 : NormalState));
5068
5069 x_text_icon (f, (char *) XSTRING ((!NILP (f->icon_name)
5070 ? f->icon_name
5071 : f->name))->data);
5072 #endif
5073
5074 UNBLOCK_INPUT;
5075 }
5076
5077
5078 static void
5079 x_make_gc (f)
5080 struct frame *f;
5081 {
5082 XGCValues gc_values;
5083
5084 BLOCK_INPUT;
5085
5086 /* Create the GC's of this frame.
5087 Note that many default values are used. */
5088
5089 /* Normal video */
5090 gc_values.font = f->output_data.w32->font;
5091
5092 /* Cursor has cursor-color background, background-color foreground. */
5093 gc_values.foreground = FRAME_BACKGROUND_PIXEL (f);
5094 gc_values.background = f->output_data.w32->cursor_pixel;
5095 f->output_data.w32->cursor_gc
5096 = XCreateGC (NULL, FRAME_W32_WINDOW (f),
5097 (GCFont | GCForeground | GCBackground),
5098 &gc_values);
5099
5100 /* Reliefs. */
5101 f->output_data.w32->white_relief.gc = 0;
5102 f->output_data.w32->black_relief.gc = 0;
5103
5104 UNBLOCK_INPUT;
5105 }
5106
5107
5108 /* Handler for signals raised during x_create_frame and
5109 x_create_top_frame. FRAME is the frame which is partially
5110 constructed. */
5111
5112 static Lisp_Object
5113 unwind_create_frame (frame)
5114 Lisp_Object frame;
5115 {
5116 struct frame *f = XFRAME (frame);
5117
5118 /* If frame is ``official'', nothing to do. */
5119 if (!CONSP (Vframe_list) || !EQ (XCAR (Vframe_list), frame))
5120 {
5121 #ifdef GLYPH_DEBUG
5122 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
5123 #endif
5124
5125 x_free_frame_resources (f);
5126
5127 /* Check that reference counts are indeed correct. */
5128 xassert (dpyinfo->reference_count == dpyinfo_refcount);
5129 xassert (dpyinfo->image_cache->refcount == image_cache_refcount);
5130
5131 return Qt;
5132 }
5133
5134 return Qnil;
5135 }
5136
5137
5138 DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
5139 1, 1, 0,
5140 "Make a new window, which is called a \"frame\" in Emacs terms.\n\
5141 Returns an Emacs frame object.\n\
5142 ALIST is an alist of frame parameters.\n\
5143 If the parameters specify that the frame should not have a minibuffer,\n\
5144 and do not specify a specific minibuffer window to use,\n\
5145 then `default-minibuffer-frame' must be a frame whose minibuffer can\n\
5146 be shared by the new frame.\n\
5147 \n\
5148 This function is an internal primitive--use `make-frame' instead.")
5149 (parms)
5150 Lisp_Object parms;
5151 {
5152 struct frame *f;
5153 Lisp_Object frame, tem;
5154 Lisp_Object name;
5155 int minibuffer_only = 0;
5156 long window_prompting = 0;
5157 int width, height;
5158 int count = BINDING_STACK_SIZE ();
5159 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
5160 Lisp_Object display;
5161 struct w32_display_info *dpyinfo = NULL;
5162 Lisp_Object parent;
5163 struct kboard *kb;
5164
5165 check_w32 ();
5166
5167 /* Use this general default value to start with
5168 until we know if this frame has a specified name. */
5169 Vx_resource_name = Vinvocation_name;
5170
5171 display = w32_get_arg (parms, Qdisplay, 0, 0, RES_TYPE_STRING);
5172 if (EQ (display, Qunbound))
5173 display = Qnil;
5174 dpyinfo = check_x_display_info (display);
5175 #ifdef MULTI_KBOARD
5176 kb = dpyinfo->kboard;
5177 #else
5178 kb = &the_only_kboard;
5179 #endif
5180
5181 name = w32_get_arg (parms, Qname, "name", "Name", RES_TYPE_STRING);
5182 if (!STRINGP (name)
5183 && ! EQ (name, Qunbound)
5184 && ! NILP (name))
5185 error ("Invalid frame name--not a string or nil");
5186
5187 if (STRINGP (name))
5188 Vx_resource_name = name;
5189
5190 /* See if parent window is specified. */
5191 parent = w32_get_arg (parms, Qparent_id, NULL, NULL, RES_TYPE_NUMBER);
5192 if (EQ (parent, Qunbound))
5193 parent = Qnil;
5194 if (! NILP (parent))
5195 CHECK_NUMBER (parent, 0);
5196
5197 /* make_frame_without_minibuffer can run Lisp code and garbage collect. */
5198 /* No need to protect DISPLAY because that's not used after passing
5199 it to make_frame_without_minibuffer. */
5200 frame = Qnil;
5201 GCPRO4 (parms, parent, name, frame);
5202 tem = w32_get_arg (parms, Qminibuffer, "minibuffer", "Minibuffer",
5203 RES_TYPE_SYMBOL);
5204 if (EQ (tem, Qnone) || NILP (tem))
5205 f = make_frame_without_minibuffer (Qnil, kb, display);
5206 else if (EQ (tem, Qonly))
5207 {
5208 f = make_minibuffer_frame ();
5209 minibuffer_only = 1;
5210 }
5211 else if (WINDOWP (tem))
5212 f = make_frame_without_minibuffer (tem, kb, display);
5213 else
5214 f = make_frame (1);
5215
5216 XSETFRAME (frame, f);
5217
5218 /* Note that Windows does support scroll bars. */
5219 FRAME_CAN_HAVE_SCROLL_BARS (f) = 1;
5220 /* By default, make scrollbars the system standard width. */
5221 f->scroll_bar_pixel_width = GetSystemMetrics (SM_CXVSCROLL);
5222
5223 f->output_method = output_w32;
5224 f->output_data.w32 =
5225 (struct w32_output *) xmalloc (sizeof (struct w32_output));
5226 bzero (f->output_data.w32, sizeof (struct w32_output));
5227 FRAME_FONTSET (f) = -1;
5228 record_unwind_protect (unwind_create_frame, frame);
5229
5230 f->icon_name
5231 = w32_get_arg (parms, Qicon_name, "iconName", "Title", RES_TYPE_STRING);
5232 if (! STRINGP (f->icon_name))
5233 f->icon_name = Qnil;
5234
5235 /* FRAME_W32_DISPLAY_INFO (f) = dpyinfo; */
5236 #ifdef MULTI_KBOARD
5237 FRAME_KBOARD (f) = kb;
5238 #endif
5239
5240 /* Specify the parent under which to make this window. */
5241
5242 if (!NILP (parent))
5243 {
5244 f->output_data.w32->parent_desc = (Window) XFASTINT (parent);
5245 f->output_data.w32->explicit_parent = 1;
5246 }
5247 else
5248 {
5249 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
5250 f->output_data.w32->explicit_parent = 0;
5251 }
5252
5253 /* Set the name; the functions to which we pass f expect the name to
5254 be set. */
5255 if (EQ (name, Qunbound) || NILP (name))
5256 {
5257 f->name = build_string (dpyinfo->w32_id_name);
5258 f->explicit_name = 0;
5259 }
5260 else
5261 {
5262 f->name = name;
5263 f->explicit_name = 1;
5264 /* use the frame's title when getting resources for this frame. */
5265 specbind (Qx_resource_name, name);
5266 }
5267
5268 /* Extract the window parameters from the supplied values
5269 that are needed to determine window geometry. */
5270 {
5271 Lisp_Object font;
5272
5273 font = w32_get_arg (parms, Qfont, "font", "Font", RES_TYPE_STRING);
5274
5275 BLOCK_INPUT;
5276 /* First, try whatever font the caller has specified. */
5277 if (STRINGP (font))
5278 {
5279 tem = Fquery_fontset (font, Qnil);
5280 if (STRINGP (tem))
5281 font = x_new_fontset (f, XSTRING (tem)->data);
5282 else
5283 font = x_new_font (f, XSTRING (font)->data);
5284 }
5285 /* Try out a font which we hope has bold and italic variations. */
5286 if (!STRINGP (font))
5287 font = x_new_font (f, "-*-Courier New-normal-r-*-*-*-100-*-*-c-*-iso8859-1");
5288 if (! STRINGP (font))
5289 font = x_new_font (f, "-*-Courier-normal-r-*-*-13-*-*-*-c-*-iso8859-1");
5290 /* If those didn't work, look for something which will at least work. */
5291 if (! STRINGP (font))
5292 font = x_new_font (f, "-*-Fixedsys-normal-r-*-*-12-*-*-*-c-*-iso8859-1");
5293 UNBLOCK_INPUT;
5294 if (! STRINGP (font))
5295 font = build_string ("Fixedsys");
5296
5297 x_default_parameter (f, parms, Qfont, font,
5298 "font", "Font", RES_TYPE_STRING);
5299 }
5300
5301 x_default_parameter (f, parms, Qborder_width, make_number (2),
5302 "borderWidth", "BorderWidth", RES_TYPE_NUMBER);
5303 /* This defaults to 2 in order to match xterm. We recognize either
5304 internalBorderWidth or internalBorder (which is what xterm calls
5305 it). */
5306 if (NILP (Fassq (Qinternal_border_width, parms)))
5307 {
5308 Lisp_Object value;
5309
5310 value = w32_get_arg (parms, Qinternal_border_width,
5311 "internalBorder", "InternalBorder", RES_TYPE_NUMBER);
5312 if (! EQ (value, Qunbound))
5313 parms = Fcons (Fcons (Qinternal_border_width, value),
5314 parms);
5315 }
5316 /* Default internalBorderWidth to 0 on Windows to match other programs. */
5317 x_default_parameter (f, parms, Qinternal_border_width, make_number (0),
5318 "internalBorderWidth", "InternalBorder", RES_TYPE_NUMBER);
5319 x_default_parameter (f, parms, Qvertical_scroll_bars, Qright,
5320 "verticalScrollBars", "ScrollBars", RES_TYPE_SYMBOL);
5321
5322 /* Also do the stuff which must be set before the window exists. */
5323 x_default_parameter (f, parms, Qforeground_color, build_string ("black"),
5324 "foreground", "Foreground", RES_TYPE_STRING);
5325 x_default_parameter (f, parms, Qbackground_color, build_string ("white"),
5326 "background", "Background", RES_TYPE_STRING);
5327 x_default_parameter (f, parms, Qmouse_color, build_string ("black"),
5328 "pointerColor", "Foreground", RES_TYPE_STRING);
5329 x_default_parameter (f, parms, Qcursor_color, build_string ("black"),
5330 "cursorColor", "Foreground", RES_TYPE_STRING);
5331 x_default_parameter (f, parms, Qborder_color, build_string ("black"),
5332 "borderColor", "BorderColor", RES_TYPE_STRING);
5333 x_default_parameter (f, parms, Qscreen_gamma, Qnil,
5334 "screenGamma", "ScreenGamma", RES_TYPE_FLOAT);
5335 x_default_parameter (f, parms, Qline_spacing, Qnil,
5336 "lineSpacing", "LineSpacing", RES_TYPE_NUMBER);
5337
5338
5339 /* Init faces before x_default_parameter is called for scroll-bar
5340 parameters because that function calls x_set_scroll_bar_width,
5341 which calls change_frame_size, which calls Fset_window_buffer,
5342 which runs hooks, which call Fvertical_motion. At the end, we
5343 end up in init_iterator with a null face cache, which should not
5344 happen. */
5345 init_frame_faces (f);
5346
5347 x_default_parameter (f, parms, Qmenu_bar_lines, make_number (1),
5348 "menuBar", "MenuBar", RES_TYPE_NUMBER);
5349 x_default_parameter (f, parms, Qtool_bar_lines, make_number (0),
5350 "toolBar", "ToolBar", RES_TYPE_NUMBER);
5351 x_default_parameter (f, parms, Qbuffer_predicate, Qnil,
5352 "bufferPredicate", "BufferPredicate", RES_TYPE_SYMBOL);
5353 x_default_parameter (f, parms, Qtitle, Qnil,
5354 "title", "Title", RES_TYPE_STRING);
5355
5356 f->output_data.w32->dwStyle = WS_OVERLAPPEDWINDOW;
5357 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
5358 window_prompting = x_figure_window_size (f, parms);
5359
5360 if (window_prompting & XNegative)
5361 {
5362 if (window_prompting & YNegative)
5363 f->output_data.w32->win_gravity = SouthEastGravity;
5364 else
5365 f->output_data.w32->win_gravity = NorthEastGravity;
5366 }
5367 else
5368 {
5369 if (window_prompting & YNegative)
5370 f->output_data.w32->win_gravity = SouthWestGravity;
5371 else
5372 f->output_data.w32->win_gravity = NorthWestGravity;
5373 }
5374
5375 f->output_data.w32->size_hint_flags = window_prompting;
5376
5377 tem = w32_get_arg (parms, Qunsplittable, 0, 0, RES_TYPE_BOOLEAN);
5378 f->no_split = minibuffer_only || EQ (tem, Qt);
5379
5380 w32_window (f, window_prompting, minibuffer_only);
5381 x_icon (f, parms);
5382
5383 x_make_gc (f);
5384
5385 /* Now consider the frame official. */
5386 FRAME_W32_DISPLAY_INFO (f)->reference_count++;
5387 Vframe_list = Fcons (frame, Vframe_list);
5388
5389 /* We need to do this after creating the window, so that the
5390 icon-creation functions can say whose icon they're describing. */
5391 x_default_parameter (f, parms, Qicon_type, Qnil,
5392 "bitmapIcon", "BitmapIcon", RES_TYPE_SYMBOL);
5393
5394 x_default_parameter (f, parms, Qauto_raise, Qnil,
5395 "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN);
5396 x_default_parameter (f, parms, Qauto_lower, Qnil,
5397 "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN);
5398 x_default_parameter (f, parms, Qcursor_type, Qbox,
5399 "cursorType", "CursorType", RES_TYPE_SYMBOL);
5400 x_default_parameter (f, parms, Qscroll_bar_width, Qnil,
5401 "scrollBarWidth", "ScrollBarWidth", RES_TYPE_NUMBER);
5402
5403 /* Dimensions, especially f->height, must be done via change_frame_size.
5404 Change will not be effected unless different from the current
5405 f->height. */
5406 width = f->width;
5407 height = f->height;
5408
5409 /* Add the tool-bar height to the initial frame height so that the
5410 user gets a text display area of the size he specified with -g or
5411 via .Xdefaults. Later changes of the tool-bar height don't
5412 change the frame size. This is done so that users can create
5413 tall Emacs frames without having to guess how tall the tool-bar
5414 will get. */
5415 if (FRAME_TOOL_BAR_LINES (f))
5416 {
5417 int margin, relief, bar_height;
5418
5419 relief = (tool_bar_button_relief > 0
5420 ? tool_bar_button_relief
5421 : DEFAULT_TOOL_BAR_BUTTON_RELIEF);
5422
5423 if (INTEGERP (Vtool_bar_button_margin)
5424 && XINT (Vtool_bar_button_margin) > 0)
5425 margin = XFASTINT (Vtool_bar_button_margin);
5426 else if (CONSP (Vtool_bar_button_margin)
5427 && INTEGERP (XCDR (Vtool_bar_button_margin))
5428 && XINT (XCDR (Vtool_bar_button_margin)) > 0)
5429 margin = XFASTINT (XCDR (Vtool_bar_button_margin));
5430 else
5431 margin = 0;
5432
5433 bar_height = DEFAULT_TOOL_BAR_IMAGE_HEIGHT + 2 * margin + 2 * relief;
5434 height += (bar_height + CANON_Y_UNIT (f) - 1) / CANON_Y_UNIT (f);
5435 }
5436
5437 f->height = 0;
5438 SET_FRAME_WIDTH (f, 0);
5439 change_frame_size (f, height, width, 1, 0, 0);
5440
5441 /* Tell the server what size and position, etc, we want, and how
5442 badly we want them. This should be done after we have the menu
5443 bar so that its size can be taken into account. */
5444 BLOCK_INPUT;
5445 x_wm_set_size_hint (f, window_prompting, 0);
5446 UNBLOCK_INPUT;
5447
5448 /* Set up faces after all frame parameters are known. This call
5449 also merges in face attributes specified for new frames. If we
5450 don't do this, the `menu' face for instance won't have the right
5451 colors, and the menu bar won't appear in the specified colors for
5452 new frames. */
5453 call1 (Qface_set_after_frame_default, frame);
5454
5455 /* Make the window appear on the frame and enable display, unless
5456 the caller says not to. However, with explicit parent, Emacs
5457 cannot control visibility, so don't try. */
5458 if (! f->output_data.w32->explicit_parent)
5459 {
5460 Lisp_Object visibility;
5461
5462 visibility = w32_get_arg (parms, Qvisibility, 0, 0, RES_TYPE_SYMBOL);
5463 if (EQ (visibility, Qunbound))
5464 visibility = Qt;
5465
5466 if (EQ (visibility, Qicon))
5467 x_iconify_frame (f);
5468 else if (! NILP (visibility))
5469 x_make_frame_visible (f);
5470 else
5471 /* Must have been Qnil. */
5472 ;
5473 }
5474 UNGCPRO;
5475
5476 /* Make sure windows on this frame appear in calls to next-window
5477 and similar functions. */
5478 Vwindow_list = Qnil;
5479
5480 return unbind_to (count, frame);
5481 }
5482
5483 /* FRAME is used only to get a handle on the X display. We don't pass the
5484 display info directly because we're called from frame.c, which doesn't
5485 know about that structure. */
5486 Lisp_Object
5487 x_get_focus_frame (frame)
5488 struct frame *frame;
5489 {
5490 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (frame);
5491 Lisp_Object xfocus;
5492 if (! dpyinfo->w32_focus_frame)
5493 return Qnil;
5494
5495 XSETFRAME (xfocus, dpyinfo->w32_focus_frame);
5496 return xfocus;
5497 }
5498
5499 DEFUN ("w32-focus-frame", Fw32_focus_frame, Sw32_focus_frame, 1, 1, 0,
5500 "Give FRAME input focus, raising to foreground if necessary.")
5501 (frame)
5502 Lisp_Object frame;
5503 {
5504 x_focus_on_frame (check_x_frame (frame));
5505 return Qnil;
5506 }
5507
5508 \f
5509 /* Return the charset portion of a font name. */
5510 char * xlfd_charset_of_font (char * fontname)
5511 {
5512 char *charset, *encoding;
5513
5514 encoding = strrchr(fontname, '-');
5515 if (!encoding || encoding == fontname)
5516 return NULL;
5517
5518 for (charset = encoding - 1; charset >= fontname; charset--)
5519 if (*charset == '-')
5520 break;
5521
5522 if (charset == fontname || strcmp(charset, "-*-*") == 0)
5523 return NULL;
5524
5525 return charset + 1;
5526 }
5527
5528 struct font_info *w32_load_bdf_font (struct frame *f, char *fontname,
5529 int size, char* filename);
5530 static Lisp_Object w32_list_bdf_fonts (Lisp_Object pattern, int max_names);
5531 static BOOL w32_to_x_font (LOGFONT * lplf, char * lpxstr, int len,
5532 char * charset);
5533 static BOOL x_to_w32_font (char *lpxstr, LOGFONT *lplogfont);
5534
5535 static struct font_info *
5536 w32_load_system_font (f,fontname,size)
5537 struct frame *f;
5538 char * fontname;
5539 int size;
5540 {
5541 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
5542 Lisp_Object font_names;
5543
5544 /* Get a list of all the fonts that match this name. Once we
5545 have a list of matching fonts, we compare them against the fonts
5546 we already have loaded by comparing names. */
5547 font_names = w32_list_fonts (f, build_string (fontname), size, 100);
5548
5549 if (!NILP (font_names))
5550 {
5551 Lisp_Object tail;
5552 int i;
5553
5554 /* First check if any are already loaded, as that is cheaper
5555 than loading another one. */
5556 for (i = 0; i < dpyinfo->n_fonts; i++)
5557 for (tail = font_names; CONSP (tail); tail = XCDR (tail))
5558 if (dpyinfo->font_table[i].name
5559 && (!strcmp (dpyinfo->font_table[i].name,
5560 XSTRING (XCAR (tail))->data)
5561 || !strcmp (dpyinfo->font_table[i].full_name,
5562 XSTRING (XCAR (tail))->data)))
5563 return (dpyinfo->font_table + i);
5564
5565 fontname = (char *) XSTRING (XCAR (font_names))->data;
5566 }
5567 else if (w32_strict_fontnames)
5568 {
5569 /* If EnumFontFamiliesEx was available, we got a full list of
5570 fonts back so stop now to avoid the possibility of loading a
5571 random font. If we had to fall back to EnumFontFamilies, the
5572 list is incomplete, so continue whether the font we want was
5573 listed or not. */
5574 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
5575 FARPROC enum_font_families_ex
5576 = GetProcAddress (gdi32, "EnumFontFamiliesExA");
5577 if (enum_font_families_ex)
5578 return NULL;
5579 }
5580
5581 /* Load the font and add it to the table. */
5582 {
5583 char *full_name, *encoding, *charset;
5584 XFontStruct *font;
5585 struct font_info *fontp;
5586 LOGFONT lf;
5587 BOOL ok;
5588 int i;
5589
5590 if (!fontname || !x_to_w32_font (fontname, &lf))
5591 return (NULL);
5592
5593 if (!*lf.lfFaceName)
5594 /* If no name was specified for the font, we get a random font
5595 from CreateFontIndirect - this is not particularly
5596 desirable, especially since CreateFontIndirect does not
5597 fill out the missing name in lf, so we never know what we
5598 ended up with. */
5599 return NULL;
5600
5601 font = (XFontStruct *) xmalloc (sizeof (XFontStruct));
5602 bzero (font, sizeof (*font));
5603
5604 /* Set bdf to NULL to indicate that this is a Windows font. */
5605 font->bdf = NULL;
5606
5607 BLOCK_INPUT;
5608
5609 font->hfont = CreateFontIndirect (&lf);
5610
5611 if (font->hfont == NULL)
5612 {
5613 ok = FALSE;
5614 }
5615 else
5616 {
5617 HDC hdc;
5618 HANDLE oldobj;
5619 int codepage = w32_codepage_for_font (fontname);
5620
5621 hdc = GetDC (dpyinfo->root_window);
5622 oldobj = SelectObject (hdc, font->hfont);
5623
5624 ok = GetTextMetrics (hdc, &font->tm);
5625 if (codepage == CP_UNICODE)
5626 font->double_byte_p = 1;
5627 else
5628 {
5629 /* Unfortunately, some fonts (eg. MingLiU, a big5 ttf font)
5630 don't report themselves as double byte fonts, when
5631 patently they are. So instead of trusting
5632 GetFontLanguageInfo, we check the properties of the
5633 codepage directly, since that is ultimately what we are
5634 working from anyway. */
5635 /* font->double_byte_p = GetFontLanguageInfo(hdc) & GCP_DBCS; */
5636 CPINFO cpi = {0};
5637 GetCPInfo (codepage, &cpi);
5638 font->double_byte_p = cpi.MaxCharSize > 1;
5639 }
5640
5641 SelectObject (hdc, oldobj);
5642 ReleaseDC (dpyinfo->root_window, hdc);
5643 /* Fill out details in lf according to the font that was
5644 actually loaded. */
5645 lf.lfHeight = font->tm.tmInternalLeading - font->tm.tmHeight;
5646 lf.lfWidth = font->tm.tmAveCharWidth;
5647 lf.lfWeight = font->tm.tmWeight;
5648 lf.lfItalic = font->tm.tmItalic;
5649 lf.lfCharSet = font->tm.tmCharSet;
5650 lf.lfPitchAndFamily = ((font->tm.tmPitchAndFamily & TMPF_FIXED_PITCH)
5651 ? VARIABLE_PITCH : FIXED_PITCH);
5652 lf.lfOutPrecision = ((font->tm.tmPitchAndFamily & TMPF_VECTOR)
5653 ? OUT_STROKE_PRECIS : OUT_STRING_PRECIS);
5654
5655 w32_cache_char_metrics (font);
5656 }
5657
5658 UNBLOCK_INPUT;
5659
5660 if (!ok)
5661 {
5662 w32_unload_font (dpyinfo, font);
5663 return (NULL);
5664 }
5665
5666 /* Find a free slot in the font table. */
5667 for (i = 0; i < dpyinfo->n_fonts; ++i)
5668 if (dpyinfo->font_table[i].name == NULL)
5669 break;
5670
5671 /* If no free slot found, maybe enlarge the font table. */
5672 if (i == dpyinfo->n_fonts
5673 && dpyinfo->n_fonts == dpyinfo->font_table_size)
5674 {
5675 int sz;
5676 dpyinfo->font_table_size = max (16, 2 * dpyinfo->font_table_size);
5677 sz = dpyinfo->font_table_size * sizeof *dpyinfo->font_table;
5678 dpyinfo->font_table
5679 = (struct font_info *) xrealloc (dpyinfo->font_table, sz);
5680 }
5681
5682 fontp = dpyinfo->font_table + i;
5683 if (i == dpyinfo->n_fonts)
5684 ++dpyinfo->n_fonts;
5685
5686 /* Now fill in the slots of *FONTP. */
5687 BLOCK_INPUT;
5688 fontp->font = font;
5689 fontp->font_idx = i;
5690 fontp->name = (char *) xmalloc (strlen (fontname) + 1);
5691 bcopy (fontname, fontp->name, strlen (fontname) + 1);
5692
5693 charset = xlfd_charset_of_font (fontname);
5694
5695 /* Work out the font's full name. */
5696 full_name = (char *)xmalloc (100);
5697 if (full_name && w32_to_x_font (&lf, full_name, 100, charset))
5698 fontp->full_name = full_name;
5699 else
5700 {
5701 /* If all else fails - just use the name we used to load it. */
5702 xfree (full_name);
5703 fontp->full_name = fontp->name;
5704 }
5705
5706 fontp->size = FONT_WIDTH (font);
5707 fontp->height = FONT_HEIGHT (font);
5708
5709 /* The slot `encoding' specifies how to map a character
5710 code-points (0x20..0x7F or 0x2020..0x7F7F) of each charset to
5711 the font code-points (0:0x20..0x7F, 1:0xA0..0xFF), or
5712 (0:0x20..0x7F, 1:0xA0..0xFF,
5713 (0:0x2020..0x7F7F, 1:0xA0A0..0xFFFF, 3:0x20A0..0x7FFF,
5714 2:0xA020..0xFF7F). For the moment, we don't know which charset
5715 uses this font. So, we set information in fontp->encoding[1]
5716 which is never used by any charset. If mapping can't be
5717 decided, set FONT_ENCODING_NOT_DECIDED. */
5718
5719 /* SJIS fonts need to be set to type 4, all others seem to work as
5720 type FONT_ENCODING_NOT_DECIDED. */
5721 encoding = strrchr (fontp->name, '-');
5722 if (encoding && stricmp (encoding+1, "sjis") == 0)
5723 fontp->encoding[1] = 4;
5724 else
5725 fontp->encoding[1] = FONT_ENCODING_NOT_DECIDED;
5726
5727 /* The following three values are set to 0 under W32, which is
5728 what they get set to if XGetFontProperty fails under X. */
5729 fontp->baseline_offset = 0;
5730 fontp->relative_compose = 0;
5731 fontp->default_ascent = 0;
5732
5733 /* Set global flag fonts_changed_p to non-zero if the font loaded
5734 has a character with a smaller width than any other character
5735 before, or if the font loaded has a smalle>r height than any
5736 other font loaded before. If this happens, it will make a
5737 glyph matrix reallocation necessary. */
5738 fonts_changed_p = x_compute_min_glyph_bounds (f);
5739 UNBLOCK_INPUT;
5740 return fontp;
5741 }
5742 }
5743
5744 /* Load font named FONTNAME of size SIZE for frame F, and return a
5745 pointer to the structure font_info while allocating it dynamically.
5746 If loading fails, return NULL. */
5747 struct font_info *
5748 w32_load_font (f,fontname,size)
5749 struct frame *f;
5750 char * fontname;
5751 int size;
5752 {
5753 Lisp_Object bdf_fonts;
5754 struct font_info *retval = NULL;
5755
5756 bdf_fonts = w32_list_bdf_fonts (build_string (fontname), 1);
5757
5758 while (!retval && CONSP (bdf_fonts))
5759 {
5760 char *bdf_name, *bdf_file;
5761 Lisp_Object bdf_pair;
5762
5763 bdf_name = XSTRING (XCAR (bdf_fonts))->data;
5764 bdf_pair = Fassoc (XCAR (bdf_fonts), Vw32_bdf_filename_alist);
5765 bdf_file = XSTRING (XCDR (bdf_pair))->data;
5766
5767 retval = w32_load_bdf_font (f, bdf_name, size, bdf_file);
5768
5769 bdf_fonts = XCDR (bdf_fonts);
5770 }
5771
5772 if (retval)
5773 return retval;
5774
5775 return w32_load_system_font(f, fontname, size);
5776 }
5777
5778
5779 void
5780 w32_unload_font (dpyinfo, font)
5781 struct w32_display_info *dpyinfo;
5782 XFontStruct * font;
5783 {
5784 if (font)
5785 {
5786 if (font->per_char) xfree (font->per_char);
5787 if (font->bdf) w32_free_bdf_font (font->bdf);
5788
5789 if (font->hfont) DeleteObject(font->hfont);
5790 xfree (font);
5791 }
5792 }
5793
5794 /* The font conversion stuff between x and w32 */
5795
5796 /* X font string is as follows (from faces.el)
5797 * (let ((- "[-?]")
5798 * (foundry "[^-]+")
5799 * (family "[^-]+")
5800 * (weight "\\(bold\\|demibold\\|medium\\)") ; 1
5801 * (weight\? "\\([^-]*\\)") ; 1
5802 * (slant "\\([ior]\\)") ; 2
5803 * (slant\? "\\([^-]?\\)") ; 2
5804 * (swidth "\\([^-]*\\)") ; 3
5805 * (adstyle "[^-]*") ; 4
5806 * (pixelsize "[0-9]+")
5807 * (pointsize "[0-9][0-9]+")
5808 * (resx "[0-9][0-9]+")
5809 * (resy "[0-9][0-9]+")
5810 * (spacing "[cmp?*]")
5811 * (avgwidth "[0-9]+")
5812 * (registry "[^-]+")
5813 * (encoding "[^-]+")
5814 * )
5815 */
5816
5817 static LONG
5818 x_to_w32_weight (lpw)
5819 char * lpw;
5820 {
5821 if (!lpw) return (FW_DONTCARE);
5822
5823 if (stricmp (lpw,"heavy") == 0) return FW_HEAVY;
5824 else if (stricmp (lpw,"extrabold") == 0) return FW_EXTRABOLD;
5825 else if (stricmp (lpw,"bold") == 0) return FW_BOLD;
5826 else if (stricmp (lpw,"demibold") == 0) return FW_SEMIBOLD;
5827 else if (stricmp (lpw,"semibold") == 0) return FW_SEMIBOLD;
5828 else if (stricmp (lpw,"medium") == 0) return FW_MEDIUM;
5829 else if (stricmp (lpw,"normal") == 0) return FW_NORMAL;
5830 else if (stricmp (lpw,"light") == 0) return FW_LIGHT;
5831 else if (stricmp (lpw,"extralight") == 0) return FW_EXTRALIGHT;
5832 else if (stricmp (lpw,"thin") == 0) return FW_THIN;
5833 else
5834 return FW_DONTCARE;
5835 }
5836
5837
5838 static char *
5839 w32_to_x_weight (fnweight)
5840 int fnweight;
5841 {
5842 if (fnweight >= FW_HEAVY) return "heavy";
5843 if (fnweight >= FW_EXTRABOLD) return "extrabold";
5844 if (fnweight >= FW_BOLD) return "bold";
5845 if (fnweight >= FW_SEMIBOLD) return "demibold";
5846 if (fnweight >= FW_MEDIUM) return "medium";
5847 if (fnweight >= FW_NORMAL) return "normal";
5848 if (fnweight >= FW_LIGHT) return "light";
5849 if (fnweight >= FW_EXTRALIGHT) return "extralight";
5850 if (fnweight >= FW_THIN) return "thin";
5851 else
5852 return "*";
5853 }
5854
5855 static LONG
5856 x_to_w32_charset (lpcs)
5857 char * lpcs;
5858 {
5859 Lisp_Object this_entry, w32_charset;
5860 char *charset;
5861 int len = strlen (lpcs);
5862
5863 /* Support "*-#nnn" format for unknown charsets. */
5864 if (strncmp (lpcs, "*-#", 3) == 0)
5865 return atoi (lpcs + 3);
5866
5867 /* Handle wildcards by ignoring them; eg. treat "big5*-*" as "big5". */
5868 charset = alloca (len + 1);
5869 strcpy (charset, lpcs);
5870 lpcs = strchr (charset, '*');
5871 if (lpcs)
5872 *lpcs = 0;
5873
5874 /* Look through w32-charset-info-alist for the character set.
5875 Format of each entry is
5876 (CHARSET_NAME . (WINDOWS_CHARSET . CODEPAGE)).
5877 */
5878 this_entry = Fassoc (build_string(charset), Vw32_charset_info_alist);
5879
5880 if (NILP(this_entry))
5881 {
5882 /* At startup, we want iso8859-1 fonts to come up properly. */
5883 if (stricmp(charset, "iso8859-1") == 0)
5884 return ANSI_CHARSET;
5885 else
5886 return DEFAULT_CHARSET;
5887 }
5888
5889 w32_charset = Fcar (Fcdr (this_entry));
5890
5891 // Translate Lisp symbol to number.
5892 if (w32_charset == Qw32_charset_ansi)
5893 return ANSI_CHARSET;
5894 if (w32_charset == Qw32_charset_symbol)
5895 return SYMBOL_CHARSET;
5896 if (w32_charset == Qw32_charset_shiftjis)
5897 return SHIFTJIS_CHARSET;
5898 if (w32_charset == Qw32_charset_hangeul)
5899 return HANGEUL_CHARSET;
5900 if (w32_charset == Qw32_charset_chinesebig5)
5901 return CHINESEBIG5_CHARSET;
5902 if (w32_charset == Qw32_charset_gb2312)
5903 return GB2312_CHARSET;
5904 if (w32_charset == Qw32_charset_oem)
5905 return OEM_CHARSET;
5906 #ifdef JOHAB_CHARSET
5907 if (w32_charset == Qw32_charset_johab)
5908 return JOHAB_CHARSET;
5909 if (w32_charset == Qw32_charset_easteurope)
5910 return EASTEUROPE_CHARSET;
5911 if (w32_charset == Qw32_charset_turkish)
5912 return TURKISH_CHARSET;
5913 if (w32_charset == Qw32_charset_baltic)
5914 return BALTIC_CHARSET;
5915 if (w32_charset == Qw32_charset_russian)
5916 return RUSSIAN_CHARSET;
5917 if (w32_charset == Qw32_charset_arabic)
5918 return ARABIC_CHARSET;
5919 if (w32_charset == Qw32_charset_greek)
5920 return GREEK_CHARSET;
5921 if (w32_charset == Qw32_charset_hebrew)
5922 return HEBREW_CHARSET;
5923 if (w32_charset == Qw32_charset_vietnamese)
5924 return VIETNAMESE_CHARSET;
5925 if (w32_charset == Qw32_charset_thai)
5926 return THAI_CHARSET;
5927 if (w32_charset == Qw32_charset_mac)
5928 return MAC_CHARSET;
5929 #endif /* JOHAB_CHARSET */
5930 #ifdef UNICODE_CHARSET
5931 if (w32_charset == Qw32_charset_unicode)
5932 return UNICODE_CHARSET;
5933 #endif
5934
5935 return DEFAULT_CHARSET;
5936 }
5937
5938
5939 static char *
5940 w32_to_x_charset (fncharset)
5941 int fncharset;
5942 {
5943 static char buf[16];
5944 Lisp_Object charset_type;
5945
5946 switch (fncharset)
5947 {
5948 case ANSI_CHARSET:
5949 /* Handle startup case of w32-charset-info-alist not
5950 being set up yet. */
5951 if (NILP(Vw32_charset_info_alist))
5952 return "iso8859-1";
5953 charset_type = Qw32_charset_ansi;
5954 break;
5955 case DEFAULT_CHARSET:
5956 charset_type = Qw32_charset_default;
5957 break;
5958 case SYMBOL_CHARSET:
5959 charset_type = Qw32_charset_symbol;
5960 break;
5961 case SHIFTJIS_CHARSET:
5962 charset_type = Qw32_charset_shiftjis;
5963 break;
5964 case HANGEUL_CHARSET:
5965 charset_type = Qw32_charset_hangeul;
5966 break;
5967 case GB2312_CHARSET:
5968 charset_type = Qw32_charset_gb2312;
5969 break;
5970 case CHINESEBIG5_CHARSET:
5971 charset_type = Qw32_charset_chinesebig5;
5972 break;
5973 case OEM_CHARSET:
5974 charset_type = Qw32_charset_oem;
5975 break;
5976
5977 /* More recent versions of Windows (95 and NT4.0) define more
5978 character sets. */
5979 #ifdef EASTEUROPE_CHARSET
5980 case EASTEUROPE_CHARSET:
5981 charset_type = Qw32_charset_easteurope;
5982 break;
5983 case TURKISH_CHARSET:
5984 charset_type = Qw32_charset_turkish;
5985 break;
5986 case BALTIC_CHARSET:
5987 charset_type = Qw32_charset_baltic;
5988 break;
5989 case RUSSIAN_CHARSET:
5990 charset_type = Qw32_charset_russian;
5991 break;
5992 case ARABIC_CHARSET:
5993 charset_type = Qw32_charset_arabic;
5994 break;
5995 case GREEK_CHARSET:
5996 charset_type = Qw32_charset_greek;
5997 break;
5998 case HEBREW_CHARSET:
5999 charset_type = Qw32_charset_hebrew;
6000 break;
6001 case VIETNAMESE_CHARSET:
6002 charset_type = Qw32_charset_vietnamese;
6003 break;
6004 case THAI_CHARSET:
6005 charset_type = Qw32_charset_thai;
6006 break;
6007 case MAC_CHARSET:
6008 charset_type = Qw32_charset_mac;
6009 break;
6010 case JOHAB_CHARSET:
6011 charset_type = Qw32_charset_johab;
6012 break;
6013 #endif
6014
6015 #ifdef UNICODE_CHARSET
6016 case UNICODE_CHARSET:
6017 charset_type = Qw32_charset_unicode;
6018 break;
6019 #endif
6020 default:
6021 /* Encode numerical value of unknown charset. */
6022 sprintf (buf, "*-#%u", fncharset);
6023 return buf;
6024 }
6025
6026 {
6027 Lisp_Object rest;
6028 char * best_match = NULL;
6029
6030 /* Look through w32-charset-info-alist for the character set.
6031 Prefer ISO codepages, and prefer lower numbers in the ISO
6032 range. Only return charsets for codepages which are installed.
6033
6034 Format of each entry is
6035 (CHARSET_NAME . (WINDOWS_CHARSET . CODEPAGE)).
6036 */
6037 for (rest = Vw32_charset_info_alist; CONSP (rest); rest = XCDR (rest))
6038 {
6039 char * x_charset;
6040 Lisp_Object w32_charset;
6041 Lisp_Object codepage;
6042
6043 Lisp_Object this_entry = XCAR (rest);
6044
6045 /* Skip invalid entries in alist. */
6046 if (!CONSP (this_entry) || !STRINGP (XCAR (this_entry))
6047 || !CONSP (XCDR (this_entry))
6048 || !SYMBOLP (XCAR (XCDR (this_entry))))
6049 continue;
6050
6051 x_charset = XSTRING (XCAR (this_entry))->data;
6052 w32_charset = XCAR (XCDR (this_entry));
6053 codepage = XCDR (XCDR (this_entry));
6054
6055 /* Look for Same charset and a valid codepage (or non-int
6056 which means ignore). */
6057 if (w32_charset == charset_type
6058 && (!INTEGERP (codepage) || codepage == CP_DEFAULT
6059 || IsValidCodePage (XINT (codepage))))
6060 {
6061 /* If we don't have a match already, then this is the
6062 best. */
6063 if (!best_match)
6064 best_match = x_charset;
6065 /* If this is an ISO codepage, and the best so far isn't,
6066 then this is better. */
6067 else if (stricmp (best_match, "iso") != 0
6068 && stricmp (x_charset, "iso") == 0)
6069 best_match = x_charset;
6070 /* If both are ISO8859 codepages, choose the one with the
6071 lowest number in the encoding field. */
6072 else if (stricmp (best_match, "iso8859-") == 0
6073 && stricmp (x_charset, "iso8859-") == 0)
6074 {
6075 int best_enc = atoi (best_match + 8);
6076 int this_enc = atoi (x_charset + 8);
6077 if (this_enc > 0 && this_enc < best_enc)
6078 best_match = x_charset;
6079 }
6080 }
6081 }
6082
6083 /* If no match, encode the numeric value. */
6084 if (!best_match)
6085 {
6086 sprintf (buf, "*-#%u", fncharset);
6087 return buf;
6088 }
6089
6090 strncpy(buf, best_match, 15);
6091 buf[15] = '\0';
6092 return buf;
6093 }
6094 }
6095
6096
6097 /* Get the Windows codepage corresponding to the specified font. The
6098 charset info in the font name is used to look up
6099 w32-charset-to-codepage-alist. */
6100 int
6101 w32_codepage_for_font (char *fontname)
6102 {
6103 Lisp_Object codepage, entry;
6104 char *charset_str, *charset, *end;
6105
6106 if (NILP (Vw32_charset_info_alist))
6107 return CP_DEFAULT;
6108
6109 /* Extract charset part of font string. */
6110 charset = xlfd_charset_of_font (fontname);
6111
6112 if (!charset)
6113 return CP_UNKNOWN;
6114
6115 charset_str = (char *) alloca (strlen (charset) + 1);
6116 strcpy (charset_str, charset);
6117
6118 #if 0
6119 /* Remove leading "*-". */
6120 if (strncmp ("*-", charset_str, 2) == 0)
6121 charset = charset_str + 2;
6122 else
6123 #endif
6124 charset = charset_str;
6125
6126 /* Stop match at wildcard (including preceding '-'). */
6127 if (end = strchr (charset, '*'))
6128 {
6129 if (end > charset && *(end-1) == '-')
6130 end--;
6131 *end = '\0';
6132 }
6133
6134 entry = Fassoc (build_string(charset), Vw32_charset_info_alist);
6135 if (NILP (entry))
6136 return CP_UNKNOWN;
6137
6138 codepage = Fcdr (Fcdr (entry));
6139
6140 if (NILP (codepage))
6141 return CP_8BIT;
6142 else if (XFASTINT (codepage) == XFASTINT (Qt))
6143 return CP_UNICODE;
6144 else if (INTEGERP (codepage))
6145 return XINT (codepage);
6146 else
6147 return CP_UNKNOWN;
6148 }
6149
6150
6151 static BOOL
6152 w32_to_x_font (lplogfont, lpxstr, len, specific_charset)
6153 LOGFONT * lplogfont;
6154 char * lpxstr;
6155 int len;
6156 char * specific_charset;
6157 {
6158 char* fonttype;
6159 char *fontname;
6160 char height_pixels[8];
6161 char height_dpi[8];
6162 char width_pixels[8];
6163 char *fontname_dash;
6164 int display_resy = one_w32_display_info.resy;
6165 int display_resx = one_w32_display_info.resx;
6166 int bufsz;
6167 struct coding_system coding;
6168
6169 if (!lpxstr) abort ();
6170
6171 if (!lplogfont)
6172 return FALSE;
6173
6174 if (lplogfont->lfOutPrecision == OUT_STRING_PRECIS)
6175 fonttype = "raster";
6176 else if (lplogfont->lfOutPrecision == OUT_STROKE_PRECIS)
6177 fonttype = "outline";
6178 else
6179 fonttype = "unknown";
6180
6181 setup_coding_system (Fcheck_coding_system (Vw32_system_coding_system),
6182 &coding);
6183 coding.src_multibyte = 0;
6184 coding.dst_multibyte = 1;
6185 coding.mode |= CODING_MODE_LAST_BLOCK;
6186 bufsz = decoding_buffer_size (&coding, LF_FACESIZE);
6187
6188 fontname = alloca(sizeof(*fontname) * bufsz);
6189 decode_coding (&coding, lplogfont->lfFaceName, fontname,
6190 strlen(lplogfont->lfFaceName), bufsz - 1);
6191 *(fontname + coding.produced) = '\0';
6192
6193 /* Replace dashes with underscores so the dashes are not
6194 misinterpreted. */
6195 fontname_dash = fontname;
6196 while (fontname_dash = strchr (fontname_dash, '-'))
6197 *fontname_dash = '_';
6198
6199 if (lplogfont->lfHeight)
6200 {
6201 sprintf (height_pixels, "%u", abs (lplogfont->lfHeight));
6202 sprintf (height_dpi, "%u",
6203 abs (lplogfont->lfHeight) * 720 / display_resy);
6204 }
6205 else
6206 {
6207 strcpy (height_pixels, "*");
6208 strcpy (height_dpi, "*");
6209 }
6210 if (lplogfont->lfWidth)
6211 sprintf (width_pixels, "%u", lplogfont->lfWidth * 10);
6212 else
6213 strcpy (width_pixels, "*");
6214
6215 _snprintf (lpxstr, len - 1,
6216 "-%s-%s-%s-%c-normal-normal-%s-%s-%d-%d-%c-%s-%s",
6217 fonttype, /* foundry */
6218 fontname, /* family */
6219 w32_to_x_weight (lplogfont->lfWeight), /* weight */
6220 lplogfont->lfItalic?'i':'r', /* slant */
6221 /* setwidth name */
6222 /* add style name */
6223 height_pixels, /* pixel size */
6224 height_dpi, /* point size */
6225 display_resx, /* resx */
6226 display_resy, /* resy */
6227 ((lplogfont->lfPitchAndFamily & 0x3) == VARIABLE_PITCH)
6228 ? 'p' : 'c', /* spacing */
6229 width_pixels, /* avg width */
6230 specific_charset ? specific_charset
6231 : w32_to_x_charset (lplogfont->lfCharSet)
6232 /* charset registry and encoding */
6233 );
6234
6235 lpxstr[len - 1] = 0; /* just to be sure */
6236 return (TRUE);
6237 }
6238
6239 static BOOL
6240 x_to_w32_font (lpxstr, lplogfont)
6241 char * lpxstr;
6242 LOGFONT * lplogfont;
6243 {
6244 struct coding_system coding;
6245
6246 if (!lplogfont) return (FALSE);
6247
6248 memset (lplogfont, 0, sizeof (*lplogfont));
6249
6250 /* Set default value for each field. */
6251 #if 1
6252 lplogfont->lfOutPrecision = OUT_DEFAULT_PRECIS;
6253 lplogfont->lfClipPrecision = CLIP_DEFAULT_PRECIS;
6254 lplogfont->lfQuality = DEFAULT_QUALITY;
6255 #else
6256 /* go for maximum quality */
6257 lplogfont->lfOutPrecision = OUT_STROKE_PRECIS;
6258 lplogfont->lfClipPrecision = CLIP_STROKE_PRECIS;
6259 lplogfont->lfQuality = PROOF_QUALITY;
6260 #endif
6261
6262 lplogfont->lfCharSet = DEFAULT_CHARSET;
6263 lplogfont->lfWeight = FW_DONTCARE;
6264 lplogfont->lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE;
6265
6266 if (!lpxstr)
6267 return FALSE;
6268
6269 /* Provide a simple escape mechanism for specifying Windows font names
6270 * directly -- if font spec does not beginning with '-', assume this
6271 * format:
6272 * "<font name>[:height in pixels[:width in pixels[:weight]]]"
6273 */
6274
6275 if (*lpxstr == '-')
6276 {
6277 int fields, tem;
6278 char name[50], weight[20], slant, pitch, pixels[10], height[10],
6279 width[10], resy[10], remainder[50];
6280 char * encoding;
6281 int dpi = one_w32_display_info.resy;
6282
6283 fields = sscanf (lpxstr,
6284 "-%*[^-]-%49[^-]-%19[^-]-%c-%*[^-]-%*[^-]-%9[^-]-%9[^-]-%*[^-]-%9[^-]-%c-%9[^-]-%49s",
6285 name, weight, &slant, pixels, height, resy, &pitch, width, remainder);
6286 if (fields == EOF)
6287 return (FALSE);
6288
6289 /* In the general case when wildcards cover more than one field,
6290 we don't know which field is which, so don't fill any in.
6291 However, we need to cope with this particular form, which is
6292 generated by font_list_1 (invoked by try_font_list):
6293 "-raster-6x10-*-gb2312*-*"
6294 and make sure to correctly parse the charset field. */
6295 if (fields == 3)
6296 {
6297 fields = sscanf (lpxstr,
6298 "-%*[^-]-%49[^-]-*-%49s",
6299 name, remainder);
6300 }
6301 else if (fields < 9)
6302 {
6303 fields = 0;
6304 remainder[0] = 0;
6305 }
6306
6307 if (fields > 0 && name[0] != '*')
6308 {
6309 int bufsize;
6310 unsigned char *buf;
6311
6312 setup_coding_system
6313 (Fcheck_coding_system (Vw32_system_coding_system), &coding);
6314 coding.src_multibyte = 1;
6315 coding.dst_multibyte = 1;
6316 bufsize = encoding_buffer_size (&coding, strlen (name));
6317 buf = (unsigned char *) alloca (bufsize);
6318 coding.mode |= CODING_MODE_LAST_BLOCK;
6319 encode_coding (&coding, name, buf, strlen (name), bufsize);
6320 if (coding.produced >= LF_FACESIZE)
6321 coding.produced = LF_FACESIZE - 1;
6322 buf[coding.produced] = 0;
6323 strcpy (lplogfont->lfFaceName, buf);
6324 }
6325 else
6326 {
6327 lplogfont->lfFaceName[0] = '\0';
6328 }
6329
6330 fields--;
6331
6332 lplogfont->lfWeight = x_to_w32_weight ((fields > 0 ? weight : ""));
6333
6334 fields--;
6335
6336 lplogfont->lfItalic = (fields > 0 && slant == 'i');
6337
6338 fields--;
6339
6340 if (fields > 0 && pixels[0] != '*')
6341 lplogfont->lfHeight = atoi (pixels);
6342
6343 fields--;
6344 fields--;
6345 if (fields > 0 && resy[0] != '*')
6346 {
6347 tem = atoi (resy);
6348 if (tem > 0) dpi = tem;
6349 }
6350
6351 if (fields > -1 && lplogfont->lfHeight == 0 && height[0] != '*')
6352 lplogfont->lfHeight = atoi (height) * dpi / 720;
6353
6354 if (fields > 0)
6355 lplogfont->lfPitchAndFamily =
6356 (fields > 0 && pitch == 'p') ? VARIABLE_PITCH : FIXED_PITCH;
6357
6358 fields--;
6359
6360 if (fields > 0 && width[0] != '*')
6361 lplogfont->lfWidth = atoi (width) / 10;
6362
6363 fields--;
6364
6365 /* Strip the trailing '-' if present. (it shouldn't be, as it
6366 fails the test against xlfd-tight-regexp in fontset.el). */
6367 {
6368 int len = strlen (remainder);
6369 if (len > 0 && remainder[len-1] == '-')
6370 remainder[len-1] = 0;
6371 }
6372 encoding = remainder;
6373 #if 0
6374 if (strncmp (encoding, "*-", 2) == 0)
6375 encoding += 2;
6376 #endif
6377 lplogfont->lfCharSet = x_to_w32_charset (encoding);
6378 }
6379 else
6380 {
6381 int fields;
6382 char name[100], height[10], width[10], weight[20];
6383
6384 fields = sscanf (lpxstr,
6385 "%99[^:]:%9[^:]:%9[^:]:%19s",
6386 name, height, width, weight);
6387
6388 if (fields == EOF) return (FALSE);
6389
6390 if (fields > 0)
6391 {
6392 strncpy (lplogfont->lfFaceName,name, LF_FACESIZE);
6393 lplogfont->lfFaceName[LF_FACESIZE-1] = 0;
6394 }
6395 else
6396 {
6397 lplogfont->lfFaceName[0] = 0;
6398 }
6399
6400 fields--;
6401
6402 if (fields > 0)
6403 lplogfont->lfHeight = atoi (height);
6404
6405 fields--;
6406
6407 if (fields > 0)
6408 lplogfont->lfWidth = atoi (width);
6409
6410 fields--;
6411
6412 lplogfont->lfWeight = x_to_w32_weight ((fields > 0 ? weight : ""));
6413 }
6414
6415 /* This makes TrueType fonts work better. */
6416 lplogfont->lfHeight = - abs (lplogfont->lfHeight);
6417
6418 return (TRUE);
6419 }
6420
6421 /* Strip the pixel height and point height from the given xlfd, and
6422 return the pixel height. If no pixel height is specified, calculate
6423 one from the point height, or if that isn't defined either, return
6424 0 (which usually signifies a scalable font).
6425 */
6426 static int
6427 xlfd_strip_height (char *fontname)
6428 {
6429 int pixel_height, field_number;
6430 char *read_from, *write_to;
6431
6432 xassert (fontname);
6433
6434 pixel_height = field_number = 0;
6435 write_to = NULL;
6436
6437 /* Look for height fields. */
6438 for (read_from = fontname; *read_from; read_from++)
6439 {
6440 if (*read_from == '-')
6441 {
6442 field_number++;
6443 if (field_number == 7) /* Pixel height. */
6444 {
6445 read_from++;
6446 write_to = read_from;
6447
6448 /* Find end of field. */
6449 for (;*read_from && *read_from != '-'; read_from++)
6450 ;
6451
6452 /* Split the fontname at end of field. */
6453 if (*read_from)
6454 {
6455 *read_from = '\0';
6456 read_from++;
6457 }
6458 pixel_height = atoi (write_to);
6459 /* Blank out field. */
6460 if (read_from > write_to)
6461 {
6462 *write_to = '-';
6463 write_to++;
6464 }
6465 /* If the pixel height field is at the end (partial xlfd),
6466 return now. */
6467 else
6468 return pixel_height;
6469
6470 /* If we got a pixel height, the point height can be
6471 ignored. Just blank it out and break now. */
6472 if (pixel_height)
6473 {
6474 /* Find end of point size field. */
6475 for (; *read_from && *read_from != '-'; read_from++)
6476 ;
6477
6478 if (*read_from)
6479 read_from++;
6480
6481 /* Blank out the point size field. */
6482 if (read_from > write_to)
6483 {
6484 *write_to = '-';
6485 write_to++;
6486 }
6487 else
6488 return pixel_height;
6489
6490 break;
6491 }
6492 /* If the point height is already blank, break now. */
6493 if (*read_from == '-')
6494 {
6495 read_from++;
6496 break;
6497 }
6498 }
6499 else if (field_number == 8)
6500 {
6501 /* If we didn't get a pixel height, try to get the point
6502 height and convert that. */
6503 int point_size;
6504 char *point_size_start = read_from++;
6505
6506 /* Find end of field. */
6507 for (; *read_from && *read_from != '-'; read_from++)
6508 ;
6509
6510 if (*read_from)
6511 {
6512 *read_from = '\0';
6513 read_from++;
6514 }
6515
6516 point_size = atoi (point_size_start);
6517
6518 /* Convert to pixel height. */
6519 pixel_height = point_size
6520 * one_w32_display_info.height_in / 720;
6521
6522 /* Blank out this field and break. */
6523 *write_to = '-';
6524 write_to++;
6525 break;
6526 }
6527 }
6528 }
6529
6530 /* Shift the rest of the font spec into place. */
6531 if (write_to && read_from > write_to)
6532 {
6533 for (; *read_from; read_from++, write_to++)
6534 *write_to = *read_from;
6535 *write_to = '\0';
6536 }
6537
6538 return pixel_height;
6539 }
6540
6541 /* Assume parameter 1 is fully qualified, no wildcards. */
6542 static BOOL
6543 w32_font_match (fontname, pattern)
6544 char * fontname;
6545 char * pattern;
6546 {
6547 char *regex = alloca (strlen (pattern) * 2 + 3);
6548 char *font_name_copy = alloca (strlen (fontname) + 1);
6549 char *ptr;
6550
6551 /* Copy fontname so we can modify it during comparison. */
6552 strcpy (font_name_copy, fontname);
6553
6554 ptr = regex;
6555 *ptr++ = '^';
6556
6557 /* Turn pattern into a regexp and do a regexp match. */
6558 for (; *pattern; pattern++)
6559 {
6560 if (*pattern == '?')
6561 *ptr++ = '.';
6562 else if (*pattern == '*')
6563 {
6564 *ptr++ = '.';
6565 *ptr++ = '*';
6566 }
6567 else
6568 *ptr++ = *pattern;
6569 }
6570 *ptr = '$';
6571 *(ptr + 1) = '\0';
6572
6573 /* Strip out font heights and compare them seperately, since
6574 rounding error can cause mismatches. This also allows a
6575 comparison between a font that declares only a pixel height and a
6576 pattern that declares the point height.
6577 */
6578 {
6579 int font_height, pattern_height;
6580
6581 font_height = xlfd_strip_height (font_name_copy);
6582 pattern_height = xlfd_strip_height (regex);
6583
6584 /* Compare now, and don't bother doing expensive regexp matching
6585 if the heights differ. */
6586 if (font_height && pattern_height && (font_height != pattern_height))
6587 return FALSE;
6588 }
6589
6590 return (fast_c_string_match_ignore_case (build_string (regex),
6591 font_name_copy) >= 0);
6592 }
6593
6594 /* Callback functions, and a structure holding info they need, for
6595 listing system fonts on W32. We need one set of functions to do the
6596 job properly, but these don't work on NT 3.51 and earlier, so we
6597 have a second set which don't handle character sets properly to
6598 fall back on.
6599
6600 In both cases, there are two passes made. The first pass gets one
6601 font from each family, the second pass lists all the fonts from
6602 each family. */
6603
6604 typedef struct enumfont_t
6605 {
6606 HDC hdc;
6607 int numFonts;
6608 LOGFONT logfont;
6609 XFontStruct *size_ref;
6610 Lisp_Object *pattern;
6611 Lisp_Object *tail;
6612 } enumfont_t;
6613
6614 static int CALLBACK
6615 enum_font_cb2 (lplf, lptm, FontType, lpef)
6616 ENUMLOGFONT * lplf;
6617 NEWTEXTMETRIC * lptm;
6618 int FontType;
6619 enumfont_t * lpef;
6620 {
6621 if (lplf->elfLogFont.lfStrikeOut || lplf->elfLogFont.lfUnderline)
6622 return (1);
6623
6624 /* Check that the character set matches if it was specified */
6625 if (lpef->logfont.lfCharSet != DEFAULT_CHARSET &&
6626 lplf->elfLogFont.lfCharSet != lpef->logfont.lfCharSet)
6627 return (1);
6628
6629 {
6630 char buf[100];
6631 Lisp_Object width = Qnil;
6632 char *charset = NULL;
6633
6634 /* Truetype fonts do not report their true metrics until loaded */
6635 if (FontType != RASTER_FONTTYPE)
6636 {
6637 if (!NILP (*(lpef->pattern)))
6638 {
6639 /* Scalable fonts are as big as you want them to be. */
6640 lplf->elfLogFont.lfHeight = lpef->logfont.lfHeight;
6641 lplf->elfLogFont.lfWidth = lpef->logfont.lfWidth;
6642 width = make_number (lpef->logfont.lfWidth);
6643 }
6644 else
6645 {
6646 lplf->elfLogFont.lfHeight = 0;
6647 lplf->elfLogFont.lfWidth = 0;
6648 }
6649 }
6650
6651 /* Make sure the height used here is the same as everywhere
6652 else (ie character height, not cell height). */
6653 if (lplf->elfLogFont.lfHeight > 0)
6654 {
6655 /* lptm can be trusted for RASTER fonts, but not scalable ones. */
6656 if (FontType == RASTER_FONTTYPE)
6657 lplf->elfLogFont.lfHeight = lptm->tmInternalLeading - lptm->tmHeight;
6658 else
6659 lplf->elfLogFont.lfHeight = -lplf->elfLogFont.lfHeight;
6660 }
6661
6662 if (!NILP (*(lpef->pattern)))
6663 {
6664 charset = xlfd_charset_of_font (XSTRING(*(lpef->pattern))->data);
6665
6666 /* Ensure that charset is valid for this font. */
6667 if (charset
6668 && (x_to_w32_charset (charset) != lplf->elfLogFont.lfCharSet))
6669 charset = NULL;
6670 }
6671
6672 /* TODO: List all relevant charsets if charset not specified. */
6673 if (!w32_to_x_font (&(lplf->elfLogFont), buf, 100, charset))
6674 return (0);
6675
6676 if (NILP (*(lpef->pattern))
6677 || w32_font_match (buf, XSTRING (*(lpef->pattern))->data))
6678 {
6679 *lpef->tail = Fcons (Fcons (build_string (buf), width), Qnil);
6680 lpef->tail = &(XCDR (*lpef->tail));
6681 lpef->numFonts++;
6682 }
6683 }
6684
6685 return (1);
6686 }
6687
6688 static int CALLBACK
6689 enum_font_cb1 (lplf, lptm, FontType, lpef)
6690 ENUMLOGFONT * lplf;
6691 NEWTEXTMETRIC * lptm;
6692 int FontType;
6693 enumfont_t * lpef;
6694 {
6695 return EnumFontFamilies (lpef->hdc,
6696 lplf->elfLogFont.lfFaceName,
6697 (FONTENUMPROC) enum_font_cb2,
6698 (LPARAM) lpef);
6699 }
6700
6701
6702 static int CALLBACK
6703 enum_fontex_cb2 (lplf, lptm, font_type, lpef)
6704 ENUMLOGFONTEX * lplf;
6705 NEWTEXTMETRICEX * lptm;
6706 int font_type;
6707 enumfont_t * lpef;
6708 {
6709 /* We are not interested in the extra info we get back from the 'Ex
6710 version - only the fact that we get character set variations
6711 enumerated seperately. */
6712 return enum_font_cb2 ((ENUMLOGFONT *) lplf, (NEWTEXTMETRIC *) lptm,
6713 font_type, lpef);
6714 }
6715
6716 static int CALLBACK
6717 enum_fontex_cb1 (lplf, lptm, font_type, lpef)
6718 ENUMLOGFONTEX * lplf;
6719 NEWTEXTMETRICEX * lptm;
6720 int font_type;
6721 enumfont_t * lpef;
6722 {
6723 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
6724 FARPROC enum_font_families_ex
6725 = GetProcAddress ( gdi32, "EnumFontFamiliesExA");
6726 /* We don't really expect EnumFontFamiliesEx to disappear once we
6727 get here, so don't bother handling it gracefully. */
6728 if (enum_font_families_ex == NULL)
6729 error ("gdi32.dll has disappeared!");
6730 return enum_font_families_ex (lpef->hdc,
6731 &lplf->elfLogFont,
6732 (FONTENUMPROC) enum_fontex_cb2,
6733 (LPARAM) lpef, 0);
6734 }
6735
6736 /* Interface to fontset handler. (adapted from mw32font.c in Meadow
6737 and xterm.c in Emacs 20.3) */
6738
6739 static Lisp_Object w32_list_bdf_fonts (Lisp_Object pattern, int max_names)
6740 {
6741 char *fontname, *ptnstr;
6742 Lisp_Object list, tem, newlist = Qnil;
6743 int n_fonts = 0;
6744
6745 list = Vw32_bdf_filename_alist;
6746 ptnstr = XSTRING (pattern)->data;
6747
6748 for ( ; CONSP (list); list = XCDR (list))
6749 {
6750 tem = XCAR (list);
6751 if (CONSP (tem))
6752 fontname = XSTRING (XCAR (tem))->data;
6753 else if (STRINGP (tem))
6754 fontname = XSTRING (tem)->data;
6755 else
6756 continue;
6757
6758 if (w32_font_match (fontname, ptnstr))
6759 {
6760 newlist = Fcons (XCAR (tem), newlist);
6761 n_fonts++;
6762 if (n_fonts >= max_names)
6763 break;
6764 }
6765 }
6766
6767 return newlist;
6768 }
6769
6770 static Lisp_Object w32_list_synthesized_fonts (FRAME_PTR f,
6771 Lisp_Object pattern,
6772 int size, int max_names);
6773
6774 /* Return a list of names of available fonts matching PATTERN on frame
6775 F. If SIZE is not 0, it is the size (maximum bound width) of fonts
6776 to be listed. Frame F NULL means we have not yet created any
6777 frame, which means we can't get proper size info, as we don't have
6778 a device context to use for GetTextMetrics.
6779 MAXNAMES sets a limit on how many fonts to match. */
6780
6781 Lisp_Object
6782 w32_list_fonts (f, pattern, size, maxnames)
6783 struct frame *f;
6784 Lisp_Object pattern;
6785 int size;
6786 int maxnames;
6787 {
6788 Lisp_Object patterns, key = Qnil, tem, tpat;
6789 Lisp_Object list = Qnil, newlist = Qnil, second_best = Qnil;
6790 struct w32_display_info *dpyinfo = &one_w32_display_info;
6791 int n_fonts = 0;
6792
6793 patterns = Fassoc (pattern, Valternate_fontname_alist);
6794 if (NILP (patterns))
6795 patterns = Fcons (pattern, Qnil);
6796
6797 for (; CONSP (patterns); patterns = XCDR (patterns))
6798 {
6799 enumfont_t ef;
6800 int codepage;
6801
6802 tpat = XCAR (patterns);
6803
6804 if (!STRINGP (tpat))
6805 continue;
6806
6807 /* Avoid expensive EnumFontFamilies functions if we are not
6808 going to be able to output one of these anyway. */
6809 codepage = w32_codepage_for_font (XSTRING (tpat)->data);
6810 if (codepage != CP_8BIT && codepage != CP_UNICODE
6811 && codepage != CP_DEFAULT && codepage != CP_UNKNOWN
6812 && !IsValidCodePage(codepage))
6813 continue;
6814
6815 /* See if we cached the result for this particular query.
6816 The cache is an alist of the form:
6817 ((PATTERN (FONTNAME . WIDTH) ...) ...)
6818 */
6819 if (tem = XCDR (dpyinfo->name_list_element),
6820 !NILP (list = Fassoc (tpat, tem)))
6821 {
6822 list = Fcdr_safe (list);
6823 /* We have a cached list. Don't have to get the list again. */
6824 goto label_cached;
6825 }
6826
6827 BLOCK_INPUT;
6828 /* At first, put PATTERN in the cache. */
6829 list = Qnil;
6830 ef.pattern = &tpat;
6831 ef.tail = &list;
6832 ef.numFonts = 0;
6833
6834 /* Use EnumFontFamiliesEx where it is available, as it knows
6835 about character sets. Fall back to EnumFontFamilies for
6836 older versions of NT that don't support the 'Ex function. */
6837 x_to_w32_font (XSTRING (tpat)->data, &ef.logfont);
6838 {
6839 LOGFONT font_match_pattern;
6840 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
6841 FARPROC enum_font_families_ex
6842 = GetProcAddress ( gdi32, "EnumFontFamiliesExA");
6843
6844 /* We do our own pattern matching so we can handle wildcards. */
6845 font_match_pattern.lfFaceName[0] = 0;
6846 font_match_pattern.lfPitchAndFamily = 0;
6847 /* We can use the charset, because if it is a wildcard it will
6848 be DEFAULT_CHARSET anyway. */
6849 font_match_pattern.lfCharSet = ef.logfont.lfCharSet;
6850
6851 ef.hdc = GetDC (dpyinfo->root_window);
6852
6853 if (enum_font_families_ex)
6854 enum_font_families_ex (ef.hdc,
6855 &font_match_pattern,
6856 (FONTENUMPROC) enum_fontex_cb1,
6857 (LPARAM) &ef, 0);
6858 else
6859 EnumFontFamilies (ef.hdc, NULL, (FONTENUMPROC) enum_font_cb1,
6860 (LPARAM)&ef);
6861
6862 ReleaseDC (dpyinfo->root_window, ef.hdc);
6863 }
6864
6865 UNBLOCK_INPUT;
6866
6867 /* Make a list of the fonts we got back.
6868 Store that in the font cache for the display. */
6869 XCDR (dpyinfo->name_list_element)
6870 = Fcons (Fcons (tpat, list),
6871 XCDR (dpyinfo->name_list_element));
6872
6873 label_cached:
6874 if (NILP (list)) continue; /* Try the remaining alternatives. */
6875
6876 newlist = second_best = Qnil;
6877
6878 /* Make a list of the fonts that have the right width. */
6879 for (; CONSP (list); list = XCDR (list))
6880 {
6881 int found_size;
6882 tem = XCAR (list);
6883
6884 if (!CONSP (tem))
6885 continue;
6886 if (NILP (XCAR (tem)))
6887 continue;
6888 if (!size)
6889 {
6890 newlist = Fcons (XCAR (tem), newlist);
6891 n_fonts++;
6892 if (n_fonts >= maxnames)
6893 break;
6894 else
6895 continue;
6896 }
6897 if (!INTEGERP (XCDR (tem)))
6898 {
6899 /* Since we don't yet know the size of the font, we must
6900 load it and try GetTextMetrics. */
6901 W32FontStruct thisinfo;
6902 LOGFONT lf;
6903 HDC hdc;
6904 HANDLE oldobj;
6905
6906 if (!x_to_w32_font (XSTRING (XCAR (tem))->data, &lf))
6907 continue;
6908
6909 BLOCK_INPUT;
6910 thisinfo.bdf = NULL;
6911 thisinfo.hfont = CreateFontIndirect (&lf);
6912 if (thisinfo.hfont == NULL)
6913 continue;
6914
6915 hdc = GetDC (dpyinfo->root_window);
6916 oldobj = SelectObject (hdc, thisinfo.hfont);
6917 if (GetTextMetrics (hdc, &thisinfo.tm))
6918 XCDR (tem) = make_number (FONT_WIDTH (&thisinfo));
6919 else
6920 XCDR (tem) = make_number (0);
6921 SelectObject (hdc, oldobj);
6922 ReleaseDC (dpyinfo->root_window, hdc);
6923 DeleteObject(thisinfo.hfont);
6924 UNBLOCK_INPUT;
6925 }
6926 found_size = XINT (XCDR (tem));
6927 if (found_size == size)
6928 {
6929 newlist = Fcons (XCAR (tem), newlist);
6930 n_fonts++;
6931 if (n_fonts >= maxnames)
6932 break;
6933 }
6934 /* keep track of the closest matching size in case
6935 no exact match is found. */
6936 else if (found_size > 0)
6937 {
6938 if (NILP (second_best))
6939 second_best = tem;
6940
6941 else if (found_size < size)
6942 {
6943 if (XINT (XCDR (second_best)) > size
6944 || XINT (XCDR (second_best)) < found_size)
6945 second_best = tem;
6946 }
6947 else
6948 {
6949 if (XINT (XCDR (second_best)) > size
6950 && XINT (XCDR (second_best)) >
6951 found_size)
6952 second_best = tem;
6953 }
6954 }
6955 }
6956
6957 if (!NILP (newlist))
6958 break;
6959 else if (!NILP (second_best))
6960 {
6961 newlist = Fcons (XCAR (second_best), Qnil);
6962 break;
6963 }
6964 }
6965
6966 /* Include any bdf fonts. */
6967 if (n_fonts < maxnames)
6968 {
6969 Lisp_Object combined[2];
6970 combined[0] = w32_list_bdf_fonts (pattern, maxnames - n_fonts);
6971 combined[1] = newlist;
6972 newlist = Fnconc(2, combined);
6973 }
6974
6975 /* If we can't find a font that matches, check if Windows would be
6976 able to synthesize it from a different style. */
6977 if (NILP (newlist) && !NILP (Vw32_enable_synthesized_fonts))
6978 newlist = w32_list_synthesized_fonts (f, pattern, size, maxnames);
6979
6980 return newlist;
6981 }
6982
6983 static Lisp_Object
6984 w32_list_synthesized_fonts (f, pattern, size, max_names)
6985 FRAME_PTR f;
6986 Lisp_Object pattern;
6987 int size;
6988 int max_names;
6989 {
6990 int fields;
6991 char *full_pattn, *new_pattn, foundary[50], family[50], *pattn_part2;
6992 char style[20], slant;
6993 Lisp_Object matches, tem, synthed_matches = Qnil;
6994
6995 full_pattn = XSTRING (pattern)->data;
6996
6997 pattn_part2 = alloca (XSTRING (pattern)->size + 1);
6998 /* Allow some space for wildcard expansion. */
6999 new_pattn = alloca (XSTRING (pattern)->size + 100);
7000
7001 fields = sscanf (full_pattn, "-%49[^-]-%49[^-]-%19[^-]-%c-%s",
7002 foundary, family, style, &slant, pattn_part2);
7003 if (fields == EOF || fields < 5)
7004 return Qnil;
7005
7006 /* If the style and slant are wildcards already there is no point
7007 checking again (and we don't want to keep recursing). */
7008 if (*style == '*' && slant == '*')
7009 return Qnil;
7010
7011 sprintf (new_pattn, "-%s-%s-*-*-%s", foundary, family, pattn_part2);
7012
7013 matches = w32_list_fonts (f, build_string (new_pattn), size, max_names);
7014
7015 for ( ; CONSP (matches); matches = XCDR (matches))
7016 {
7017 tem = XCAR (matches);
7018 if (!STRINGP (tem))
7019 continue;
7020
7021 full_pattn = XSTRING (tem)->data;
7022 fields = sscanf (full_pattn, "-%49[^-]-%49[^-]-%*[^-]-%*c-%s",
7023 foundary, family, pattn_part2);
7024 if (fields == EOF || fields < 3)
7025 continue;
7026
7027 sprintf (new_pattn, "-%s-%s-%s-%c-%s", foundary, family, style,
7028 slant, pattn_part2);
7029
7030 synthed_matches = Fcons (build_string (new_pattn),
7031 synthed_matches);
7032 }
7033
7034 return synthed_matches;
7035 }
7036
7037
7038 /* Return a pointer to struct font_info of font FONT_IDX of frame F. */
7039 struct font_info *
7040 w32_get_font_info (f, font_idx)
7041 FRAME_PTR f;
7042 int font_idx;
7043 {
7044 return (FRAME_W32_FONT_TABLE (f) + font_idx);
7045 }
7046
7047
7048 struct font_info*
7049 w32_query_font (struct frame *f, char *fontname)
7050 {
7051 int i;
7052 struct font_info *pfi;
7053
7054 pfi = FRAME_W32_FONT_TABLE (f);
7055
7056 for (i = 0; i < one_w32_display_info.n_fonts ;i++, pfi++)
7057 {
7058 if (strcmp(pfi->name, fontname) == 0) return pfi;
7059 }
7060
7061 return NULL;
7062 }
7063
7064 /* Find a CCL program for a font specified by FONTP, and set the member
7065 `encoder' of the structure. */
7066
7067 void
7068 w32_find_ccl_program (fontp)
7069 struct font_info *fontp;
7070 {
7071 Lisp_Object list, elt;
7072
7073 for (list = Vfont_ccl_encoder_alist; CONSP (list); list = XCDR (list))
7074 {
7075 elt = XCAR (list);
7076 if (CONSP (elt)
7077 && STRINGP (XCAR (elt))
7078 && (fast_c_string_match_ignore_case (XCAR (elt), fontp->name)
7079 >= 0))
7080 break;
7081 }
7082 if (! NILP (list))
7083 {
7084 struct ccl_program *ccl
7085 = (struct ccl_program *) xmalloc (sizeof (struct ccl_program));
7086
7087 if (setup_ccl_program (ccl, XCDR (elt)) < 0)
7088 xfree (ccl);
7089 else
7090 fontp->font_encoder = ccl;
7091 }
7092 }
7093
7094 \f
7095 /* Find BDF files in a specified directory. (use GCPRO when calling,
7096 as this calls lisp to get a directory listing). */
7097 static Lisp_Object
7098 w32_find_bdf_fonts_in_dir (Lisp_Object directory)
7099 {
7100 Lisp_Object filelist, list = Qnil;
7101 char fontname[100];
7102
7103 if (!STRINGP(directory))
7104 return Qnil;
7105
7106 filelist = Fdirectory_files (directory, Qt,
7107 build_string (".*\\.[bB][dD][fF]"), Qt);
7108
7109 for ( ; CONSP(filelist); filelist = XCDR (filelist))
7110 {
7111 Lisp_Object filename = XCAR (filelist);
7112 if (w32_BDF_to_x_font (XSTRING (filename)->data, fontname, 100))
7113 store_in_alist (&list, build_string (fontname), filename);
7114 }
7115 return list;
7116 }
7117
7118 DEFUN ("w32-find-bdf-fonts", Fw32_find_bdf_fonts, Sw32_find_bdf_fonts,
7119 1, 1, 0,
7120 "Return a list of BDF fonts in DIR, suitable for appending to\n\
7121 w32-bdf-filename-alist. Fonts which do not contain an xlfd description\n\
7122 will not be included in the list. DIR may be a list of directories.")
7123 (directory)
7124 Lisp_Object directory;
7125 {
7126 Lisp_Object list = Qnil;
7127 struct gcpro gcpro1, gcpro2;
7128
7129 if (!CONSP (directory))
7130 return w32_find_bdf_fonts_in_dir (directory);
7131
7132 for ( ; CONSP (directory); directory = XCDR (directory))
7133 {
7134 Lisp_Object pair[2];
7135 pair[0] = list;
7136 pair[1] = Qnil;
7137 GCPRO2 (directory, list);
7138 pair[1] = w32_find_bdf_fonts_in_dir( XCAR (directory) );
7139 list = Fnconc( 2, pair );
7140 UNGCPRO;
7141 }
7142 return list;
7143 }
7144
7145 \f
7146 DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0,
7147 "Internal function called by `color-defined-p', which see.")
7148 (color, frame)
7149 Lisp_Object color, frame;
7150 {
7151 XColor foo;
7152 FRAME_PTR f = check_x_frame (frame);
7153
7154 CHECK_STRING (color, 1);
7155
7156 if (w32_defined_color (f, XSTRING (color)->data, &foo, 0))
7157 return Qt;
7158 else
7159 return Qnil;
7160 }
7161
7162 DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0,
7163 "Internal function called by `color-values', which see.")
7164 (color, frame)
7165 Lisp_Object color, frame;
7166 {
7167 XColor foo;
7168 FRAME_PTR f = check_x_frame (frame);
7169
7170 CHECK_STRING (color, 1);
7171
7172 if (w32_defined_color (f, XSTRING (color)->data, &foo, 0))
7173 {
7174 Lisp_Object rgb[3];
7175
7176 rgb[0] = make_number ((GetRValue (foo.pixel) << 8)
7177 | GetRValue (foo.pixel));
7178 rgb[1] = make_number ((GetGValue (foo.pixel) << 8)
7179 | GetGValue (foo.pixel));
7180 rgb[2] = make_number ((GetBValue (foo.pixel) << 8)
7181 | GetBValue (foo.pixel));
7182 return Flist (3, rgb);
7183 }
7184 else
7185 return Qnil;
7186 }
7187
7188 DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0,
7189 "Internal function called by `display-color-p', which see.")
7190 (display)
7191 Lisp_Object display;
7192 {
7193 struct w32_display_info *dpyinfo = check_x_display_info (display);
7194
7195 if ((dpyinfo->n_planes * dpyinfo->n_cbits) <= 2)
7196 return Qnil;
7197
7198 return Qt;
7199 }
7200
7201 DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p,
7202 0, 1, 0,
7203 "Return t if the X display supports shades of gray.\n\
7204 Note that color displays do support shades of gray.\n\
7205 The optional argument DISPLAY specifies which display to ask about.\n\
7206 DISPLAY should be either a frame or a display name (a string).\n\
7207 If omitted or nil, that stands for the selected frame's display.")
7208 (display)
7209 Lisp_Object display;
7210 {
7211 struct w32_display_info *dpyinfo = check_x_display_info (display);
7212
7213 if ((dpyinfo->n_planes * dpyinfo->n_cbits) <= 1)
7214 return Qnil;
7215
7216 return Qt;
7217 }
7218
7219 DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width,
7220 0, 1, 0,
7221 "Returns the width in pixels of the X display DISPLAY.\n\
7222 The optional argument DISPLAY specifies which display to ask about.\n\
7223 DISPLAY should be either a frame or a display name (a string).\n\
7224 If omitted or nil, that stands for the selected frame's display.")
7225 (display)
7226 Lisp_Object display;
7227 {
7228 struct w32_display_info *dpyinfo = check_x_display_info (display);
7229
7230 return make_number (dpyinfo->width);
7231 }
7232
7233 DEFUN ("x-display-pixel-height", Fx_display_pixel_height,
7234 Sx_display_pixel_height, 0, 1, 0,
7235 "Returns the height in pixels of the X display DISPLAY.\n\
7236 The optional argument DISPLAY specifies which display to ask about.\n\
7237 DISPLAY should be either a frame or a display name (a string).\n\
7238 If omitted or nil, that stands for the selected frame's display.")
7239 (display)
7240 Lisp_Object display;
7241 {
7242 struct w32_display_info *dpyinfo = check_x_display_info (display);
7243
7244 return make_number (dpyinfo->height);
7245 }
7246
7247 DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes,
7248 0, 1, 0,
7249 "Returns the number of bitplanes of the display DISPLAY.\n\
7250 The optional argument DISPLAY specifies which display to ask about.\n\
7251 DISPLAY should be either a frame or a display name (a string).\n\
7252 If omitted or nil, that stands for the selected frame's display.")
7253 (display)
7254 Lisp_Object display;
7255 {
7256 struct w32_display_info *dpyinfo = check_x_display_info (display);
7257
7258 return make_number (dpyinfo->n_planes * dpyinfo->n_cbits);
7259 }
7260
7261 DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells,
7262 0, 1, 0,
7263 "Returns the number of color cells of the display DISPLAY.\n\
7264 The optional argument DISPLAY specifies which display to ask about.\n\
7265 DISPLAY should be either a frame or a display name (a string).\n\
7266 If omitted or nil, that stands for the selected frame's display.")
7267 (display)
7268 Lisp_Object display;
7269 {
7270 struct w32_display_info *dpyinfo = check_x_display_info (display);
7271 HDC hdc;
7272 int cap;
7273
7274 hdc = GetDC (dpyinfo->root_window);
7275 if (dpyinfo->has_palette)
7276 cap = GetDeviceCaps (hdc,SIZEPALETTE);
7277 else
7278 cap = GetDeviceCaps (hdc,NUMCOLORS);
7279
7280 if (cap < 0)
7281 cap = 1 << (dpyinfo->n_planes * dpyinfo->n_cbits);
7282
7283 ReleaseDC (dpyinfo->root_window, hdc);
7284
7285 return make_number (cap);
7286 }
7287
7288 DEFUN ("x-server-max-request-size", Fx_server_max_request_size,
7289 Sx_server_max_request_size,
7290 0, 1, 0,
7291 "Returns the maximum request size of the server of display DISPLAY.\n\
7292 The optional argument DISPLAY specifies which display to ask about.\n\
7293 DISPLAY should be either a frame or a display name (a string).\n\
7294 If omitted or nil, that stands for the selected frame's display.")
7295 (display)
7296 Lisp_Object display;
7297 {
7298 struct w32_display_info *dpyinfo = check_x_display_info (display);
7299
7300 return make_number (1);
7301 }
7302
7303 DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
7304 "Returns the vendor ID string of the W32 system (Microsoft).\n\
7305 The optional argument DISPLAY specifies which display to ask about.\n\
7306 DISPLAY should be either a frame or a display name (a string).\n\
7307 If omitted or nil, that stands for the selected frame's display.")
7308 (display)
7309 Lisp_Object display;
7310 {
7311 return build_string ("Microsoft Corp.");
7312 }
7313
7314 DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0,
7315 "Returns the version numbers of the server of display DISPLAY.\n\
7316 The value is a list of three integers: the major and minor\n\
7317 version numbers, and the vendor-specific release\n\
7318 number. See also the function `x-server-vendor'.\n\n\
7319 The optional argument DISPLAY specifies which display to ask about.\n\
7320 DISPLAY should be either a frame or a display name (a string).\n\
7321 If omitted or nil, that stands for the selected frame's display.")
7322 (display)
7323 Lisp_Object display;
7324 {
7325 return Fcons (make_number (w32_major_version),
7326 Fcons (make_number (w32_minor_version),
7327 Fcons (make_number (w32_build_number), Qnil)));
7328 }
7329
7330 DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0,
7331 "Returns the number of screens on the server of display DISPLAY.\n\
7332 The optional argument DISPLAY specifies which display to ask about.\n\
7333 DISPLAY should be either a frame or a display name (a string).\n\
7334 If omitted or nil, that stands for the selected frame's display.")
7335 (display)
7336 Lisp_Object display;
7337 {
7338 return make_number (1);
7339 }
7340
7341 DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0,
7342 "Returns the height in millimeters of the X display DISPLAY.\n\
7343 The optional argument DISPLAY specifies which display to ask about.\n\
7344 DISPLAY should be either a frame or a display name (a string).\n\
7345 If omitted or nil, that stands for the selected frame's display.")
7346 (display)
7347 Lisp_Object display;
7348 {
7349 struct w32_display_info *dpyinfo = check_x_display_info (display);
7350 HDC hdc;
7351 int cap;
7352
7353 hdc = GetDC (dpyinfo->root_window);
7354
7355 cap = GetDeviceCaps (hdc, VERTSIZE);
7356
7357 ReleaseDC (dpyinfo->root_window, hdc);
7358
7359 return make_number (cap);
7360 }
7361
7362 DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0,
7363 "Returns the width in millimeters of the X display DISPLAY.\n\
7364 The optional argument DISPLAY specifies which display to ask about.\n\
7365 DISPLAY should be either a frame or a display name (a string).\n\
7366 If omitted or nil, that stands for the selected frame's display.")
7367 (display)
7368 Lisp_Object display;
7369 {
7370 struct w32_display_info *dpyinfo = check_x_display_info (display);
7371
7372 HDC hdc;
7373 int cap;
7374
7375 hdc = GetDC (dpyinfo->root_window);
7376
7377 cap = GetDeviceCaps (hdc, HORZSIZE);
7378
7379 ReleaseDC (dpyinfo->root_window, hdc);
7380
7381 return make_number (cap);
7382 }
7383
7384 DEFUN ("x-display-backing-store", Fx_display_backing_store,
7385 Sx_display_backing_store, 0, 1, 0,
7386 "Returns an indication of whether display DISPLAY does backing store.\n\
7387 The value may be `always', `when-mapped', or `not-useful'.\n\
7388 The optional argument DISPLAY specifies which display to ask about.\n\
7389 DISPLAY should be either a frame or a display name (a string).\n\
7390 If omitted or nil, that stands for the selected frame's display.")
7391 (display)
7392 Lisp_Object display;
7393 {
7394 return intern ("not-useful");
7395 }
7396
7397 DEFUN ("x-display-visual-class", Fx_display_visual_class,
7398 Sx_display_visual_class, 0, 1, 0,
7399 "Returns the visual class of the display DISPLAY.\n\
7400 The value is one of the symbols `static-gray', `gray-scale',\n\
7401 `static-color', `pseudo-color', `true-color', or `direct-color'.\n\n\
7402 The optional argument DISPLAY specifies which display to ask about.\n\
7403 DISPLAY should be either a frame or a display name (a string).\n\
7404 If omitted or nil, that stands for the selected frame's display.")
7405 (display)
7406 Lisp_Object display;
7407 {
7408 struct w32_display_info *dpyinfo = check_x_display_info (display);
7409 Lisp_Object result = Qnil;
7410
7411 if (dpyinfo->has_palette)
7412 result = intern ("pseudo-color");
7413 else if (dpyinfo->n_planes * dpyinfo->n_cbits == 1)
7414 result = intern ("static-grey");
7415 else if (dpyinfo->n_planes * dpyinfo->n_cbits == 4)
7416 result = intern ("static-color");
7417 else if (dpyinfo->n_planes * dpyinfo->n_cbits > 8)
7418 result = intern ("true-color");
7419
7420 return result;
7421 }
7422
7423 DEFUN ("x-display-save-under", Fx_display_save_under,
7424 Sx_display_save_under, 0, 1, 0,
7425 "Returns t if the display DISPLAY supports the save-under feature.\n\
7426 The optional argument DISPLAY specifies which display to ask about.\n\
7427 DISPLAY should be either a frame or a display name (a string).\n\
7428 If omitted or nil, that stands for the selected frame's display.")
7429 (display)
7430 Lisp_Object display;
7431 {
7432 return Qnil;
7433 }
7434 \f
7435 int
7436 x_pixel_width (f)
7437 register struct frame *f;
7438 {
7439 return PIXEL_WIDTH (f);
7440 }
7441
7442 int
7443 x_pixel_height (f)
7444 register struct frame *f;
7445 {
7446 return PIXEL_HEIGHT (f);
7447 }
7448
7449 int
7450 x_char_width (f)
7451 register struct frame *f;
7452 {
7453 return FONT_WIDTH (f->output_data.w32->font);
7454 }
7455
7456 int
7457 x_char_height (f)
7458 register struct frame *f;
7459 {
7460 return f->output_data.w32->line_height;
7461 }
7462
7463 int
7464 x_screen_planes (f)
7465 register struct frame *f;
7466 {
7467 return FRAME_W32_DISPLAY_INFO (f)->n_planes;
7468 }
7469 \f
7470 /* Return the display structure for the display named NAME.
7471 Open a new connection if necessary. */
7472
7473 struct w32_display_info *
7474 x_display_info_for_name (name)
7475 Lisp_Object name;
7476 {
7477 Lisp_Object names;
7478 struct w32_display_info *dpyinfo;
7479
7480 CHECK_STRING (name, 0);
7481
7482 for (dpyinfo = &one_w32_display_info, names = w32_display_name_list;
7483 dpyinfo;
7484 dpyinfo = dpyinfo->next, names = XCDR (names))
7485 {
7486 Lisp_Object tem;
7487 tem = Fstring_equal (XCAR (XCAR (names)), name);
7488 if (!NILP (tem))
7489 return dpyinfo;
7490 }
7491
7492 /* Use this general default value to start with. */
7493 Vx_resource_name = Vinvocation_name;
7494
7495 validate_x_resource_name ();
7496
7497 dpyinfo = w32_term_init (name, (unsigned char *)0,
7498 (char *) XSTRING (Vx_resource_name)->data);
7499
7500 if (dpyinfo == 0)
7501 error ("Cannot connect to server %s", XSTRING (name)->data);
7502
7503 w32_in_use = 1;
7504 XSETFASTINT (Vwindow_system_version, 3);
7505
7506 return dpyinfo;
7507 }
7508
7509 DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection,
7510 1, 3, 0, "Open a connection to a server.\n\
7511 DISPLAY is the name of the display to connect to.\n\
7512 Optional second arg XRM-STRING is a string of resources in xrdb format.\n\
7513 If the optional third arg MUST-SUCCEED is non-nil,\n\
7514 terminate Emacs if we can't open the connection.")
7515 (display, xrm_string, must_succeed)
7516 Lisp_Object display, xrm_string, must_succeed;
7517 {
7518 unsigned char *xrm_option;
7519 struct w32_display_info *dpyinfo;
7520
7521 CHECK_STRING (display, 0);
7522 if (! NILP (xrm_string))
7523 CHECK_STRING (xrm_string, 1);
7524
7525 if (! EQ (Vwindow_system, intern ("w32")))
7526 error ("Not using Microsoft Windows");
7527
7528 /* Allow color mapping to be defined externally; first look in user's
7529 HOME directory, then in Emacs etc dir for a file called rgb.txt. */
7530 {
7531 Lisp_Object color_file;
7532 struct gcpro gcpro1;
7533
7534 color_file = build_string("~/rgb.txt");
7535
7536 GCPRO1 (color_file);
7537
7538 if (NILP (Ffile_readable_p (color_file)))
7539 color_file =
7540 Fexpand_file_name (build_string ("rgb.txt"),
7541 Fsymbol_value (intern ("data-directory")));
7542
7543 Vw32_color_map = Fw32_load_color_file (color_file);
7544
7545 UNGCPRO;
7546 }
7547 if (NILP (Vw32_color_map))
7548 Vw32_color_map = Fw32_default_color_map ();
7549
7550 if (! NILP (xrm_string))
7551 xrm_option = (unsigned char *) XSTRING (xrm_string)->data;
7552 else
7553 xrm_option = (unsigned char *) 0;
7554
7555 /* Use this general default value to start with. */
7556 /* First remove .exe suffix from invocation-name - it looks ugly. */
7557 {
7558 char basename[ MAX_PATH ], *str;
7559
7560 strcpy (basename, XSTRING (Vinvocation_name)->data);
7561 str = strrchr (basename, '.');
7562 if (str) *str = 0;
7563 Vinvocation_name = build_string (basename);
7564 }
7565 Vx_resource_name = Vinvocation_name;
7566
7567 validate_x_resource_name ();
7568
7569 /* This is what opens the connection and sets x_current_display.
7570 This also initializes many symbols, such as those used for input. */
7571 dpyinfo = w32_term_init (display, xrm_option,
7572 (char *) XSTRING (Vx_resource_name)->data);
7573
7574 if (dpyinfo == 0)
7575 {
7576 if (!NILP (must_succeed))
7577 fatal ("Cannot connect to server %s.\n",
7578 XSTRING (display)->data);
7579 else
7580 error ("Cannot connect to server %s", XSTRING (display)->data);
7581 }
7582
7583 w32_in_use = 1;
7584
7585 XSETFASTINT (Vwindow_system_version, 3);
7586 return Qnil;
7587 }
7588
7589 DEFUN ("x-close-connection", Fx_close_connection,
7590 Sx_close_connection, 1, 1, 0,
7591 "Close the connection to DISPLAY's server.\n\
7592 For DISPLAY, specify either a frame or a display name (a string).\n\
7593 If DISPLAY is nil, that stands for the selected frame's display.")
7594 (display)
7595 Lisp_Object display;
7596 {
7597 struct w32_display_info *dpyinfo = check_x_display_info (display);
7598 int i;
7599
7600 if (dpyinfo->reference_count > 0)
7601 error ("Display still has frames on it");
7602
7603 BLOCK_INPUT;
7604 /* Free the fonts in the font table. */
7605 for (i = 0; i < dpyinfo->n_fonts; i++)
7606 if (dpyinfo->font_table[i].name)
7607 {
7608 if (dpyinfo->font_table[i].name != dpyinfo->font_table[i].full_name)
7609 xfree (dpyinfo->font_table[i].full_name);
7610 xfree (dpyinfo->font_table[i].name);
7611 w32_unload_font (dpyinfo, dpyinfo->font_table[i].font);
7612 }
7613 x_destroy_all_bitmaps (dpyinfo);
7614
7615 x_delete_display (dpyinfo);
7616 UNBLOCK_INPUT;
7617
7618 return Qnil;
7619 }
7620
7621 DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0,
7622 "Return the list of display names that Emacs has connections to.")
7623 ()
7624 {
7625 Lisp_Object tail, result;
7626
7627 result = Qnil;
7628 for (tail = w32_display_name_list; ! NILP (tail); tail = XCDR (tail))
7629 result = Fcons (XCAR (XCAR (tail)), result);
7630
7631 return result;
7632 }
7633
7634 DEFUN ("x-synchronize", Fx_synchronize, Sx_synchronize, 1, 2, 0,
7635 "If ON is non-nil, report errors as soon as the erring request is made.\n\
7636 If ON is nil, allow buffering of requests.\n\
7637 This is a noop on W32 systems.\n\
7638 The optional second argument DISPLAY specifies which display to act on.\n\
7639 DISPLAY should be either a frame or a display name (a string).\n\
7640 If DISPLAY is omitted or nil, that stands for the selected frame's display.")
7641 (on, display)
7642 Lisp_Object display, on;
7643 {
7644 return Qnil;
7645 }
7646
7647 \f
7648 \f
7649 /***********************************************************************
7650 Image types
7651 ***********************************************************************/
7652
7653 /* Value is the number of elements of vector VECTOR. */
7654
7655 #define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR))
7656
7657 /* List of supported image types. Use define_image_type to add new
7658 types. Use lookup_image_type to find a type for a given symbol. */
7659
7660 static struct image_type *image_types;
7661
7662 /* The symbol `image' which is the car of the lists used to represent
7663 images in Lisp. */
7664
7665 extern Lisp_Object Qimage;
7666
7667 /* The symbol `xbm' which is used as the type symbol for XBM images. */
7668
7669 Lisp_Object Qxbm;
7670
7671 /* Keywords. */
7672
7673 extern Lisp_Object QCwidth, QCheight, QCforeground, QCbackground, QCfile;
7674 extern Lisp_Object QCdata;
7675 Lisp_Object QCtype, QCascent, QCmargin, QCrelief;
7676 Lisp_Object QCconversion, QCcolor_symbols, QCheuristic_mask;
7677 Lisp_Object QCindex;
7678
7679 /* Other symbols. */
7680
7681 Lisp_Object Qlaplace;
7682
7683 /* Time in seconds after which images should be removed from the cache
7684 if not displayed. */
7685
7686 Lisp_Object Vimage_cache_eviction_delay;
7687
7688 /* Function prototypes. */
7689
7690 static void define_image_type P_ ((struct image_type *type));
7691 static struct image_type *lookup_image_type P_ ((Lisp_Object symbol));
7692 static void image_error P_ ((char *format, Lisp_Object, Lisp_Object));
7693 static void x_laplace P_ ((struct frame *, struct image *));
7694 static int x_build_heuristic_mask P_ ((struct frame *, struct image *,
7695 Lisp_Object));
7696
7697
7698 /* Define a new image type from TYPE. This adds a copy of TYPE to
7699 image_types and adds the symbol *TYPE->type to Vimage_types. */
7700
7701 static void
7702 define_image_type (type)
7703 struct image_type *type;
7704 {
7705 /* Make a copy of TYPE to avoid a bus error in a dumped Emacs.
7706 The initialized data segment is read-only. */
7707 struct image_type *p = (struct image_type *) xmalloc (sizeof *p);
7708 bcopy (type, p, sizeof *p);
7709 p->next = image_types;
7710 image_types = p;
7711 Vimage_types = Fcons (*p->type, Vimage_types);
7712 }
7713
7714
7715 /* Look up image type SYMBOL, and return a pointer to its image_type
7716 structure. Value is null if SYMBOL is not a known image type. */
7717
7718 static INLINE struct image_type *
7719 lookup_image_type (symbol)
7720 Lisp_Object symbol;
7721 {
7722 struct image_type *type;
7723
7724 for (type = image_types; type; type = type->next)
7725 if (EQ (symbol, *type->type))
7726 break;
7727
7728 return type;
7729 }
7730
7731
7732 /* Value is non-zero if OBJECT is a valid Lisp image specification. A
7733 valid image specification is a list whose car is the symbol
7734 `image', and whose rest is a property list. The property list must
7735 contain a value for key `:type'. That value must be the name of a
7736 supported image type. The rest of the property list depends on the
7737 image type. */
7738
7739 int
7740 valid_image_p (object)
7741 Lisp_Object object;
7742 {
7743 int valid_p = 0;
7744
7745 if (CONSP (object) && EQ (XCAR (object), Qimage))
7746 {
7747 Lisp_Object symbol = Fplist_get (XCDR (object), QCtype);
7748 struct image_type *type = lookup_image_type (symbol);
7749
7750 if (type)
7751 valid_p = type->valid_p (object);
7752 }
7753
7754 return valid_p;
7755 }
7756
7757
7758 /* Log error message with format string FORMAT and argument ARG.
7759 Signaling an error, e.g. when an image cannot be loaded, is not a
7760 good idea because this would interrupt redisplay, and the error
7761 message display would lead to another redisplay. This function
7762 therefore simply displays a message. */
7763
7764 static void
7765 image_error (format, arg1, arg2)
7766 char *format;
7767 Lisp_Object arg1, arg2;
7768 {
7769 add_to_log (format, arg1, arg2);
7770 }
7771
7772
7773 \f
7774 /***********************************************************************
7775 Image specifications
7776 ***********************************************************************/
7777
7778 enum image_value_type
7779 {
7780 IMAGE_DONT_CHECK_VALUE_TYPE,
7781 IMAGE_STRING_VALUE,
7782 IMAGE_SYMBOL_VALUE,
7783 IMAGE_POSITIVE_INTEGER_VALUE,
7784 IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR,
7785 IMAGE_NON_NEGATIVE_INTEGER_VALUE,
7786 IMAGE_ASCENT_VALUE,
7787 IMAGE_INTEGER_VALUE,
7788 IMAGE_FUNCTION_VALUE,
7789 IMAGE_NUMBER_VALUE,
7790 IMAGE_BOOL_VALUE
7791 };
7792
7793 /* Structure used when parsing image specifications. */
7794
7795 struct image_keyword
7796 {
7797 /* Name of keyword. */
7798 char *name;
7799
7800 /* The type of value allowed. */
7801 enum image_value_type type;
7802
7803 /* Non-zero means key must be present. */
7804 int mandatory_p;
7805
7806 /* Used to recognize duplicate keywords in a property list. */
7807 int count;
7808
7809 /* The value that was found. */
7810 Lisp_Object value;
7811 };
7812
7813
7814 static int parse_image_spec P_ ((Lisp_Object, struct image_keyword *,
7815 int, Lisp_Object));
7816 static Lisp_Object image_spec_value P_ ((Lisp_Object, Lisp_Object, int *));
7817
7818
7819 /* Parse image spec SPEC according to KEYWORDS. A valid image spec
7820 has the format (image KEYWORD VALUE ...). One of the keyword/
7821 value pairs must be `:type TYPE'. KEYWORDS is a vector of
7822 image_keywords structures of size NKEYWORDS describing other
7823 allowed keyword/value pairs. Value is non-zero if SPEC is valid. */
7824
7825 static int
7826 parse_image_spec (spec, keywords, nkeywords, type)
7827 Lisp_Object spec;
7828 struct image_keyword *keywords;
7829 int nkeywords;
7830 Lisp_Object type;
7831 {
7832 int i;
7833 Lisp_Object plist;
7834
7835 if (!CONSP (spec) || !EQ (XCAR (spec), Qimage))
7836 return 0;
7837
7838 plist = XCDR (spec);
7839 while (CONSP (plist))
7840 {
7841 Lisp_Object key, value;
7842
7843 /* First element of a pair must be a symbol. */
7844 key = XCAR (plist);
7845 plist = XCDR (plist);
7846 if (!SYMBOLP (key))
7847 return 0;
7848
7849 /* There must follow a value. */
7850 if (!CONSP (plist))
7851 return 0;
7852 value = XCAR (plist);
7853 plist = XCDR (plist);
7854
7855 /* Find key in KEYWORDS. Error if not found. */
7856 for (i = 0; i < nkeywords; ++i)
7857 if (strcmp (keywords[i].name, XSYMBOL (key)->name->data) == 0)
7858 break;
7859
7860 if (i == nkeywords)
7861 continue;
7862
7863 /* Record that we recognized the keyword. If a keywords
7864 was found more than once, it's an error. */
7865 keywords[i].value = value;
7866 ++keywords[i].count;
7867
7868 if (keywords[i].count > 1)
7869 return 0;
7870
7871 /* Check type of value against allowed type. */
7872 switch (keywords[i].type)
7873 {
7874 case IMAGE_STRING_VALUE:
7875 if (!STRINGP (value))
7876 return 0;
7877 break;
7878
7879 case IMAGE_SYMBOL_VALUE:
7880 if (!SYMBOLP (value))
7881 return 0;
7882 break;
7883
7884 case IMAGE_POSITIVE_INTEGER_VALUE:
7885 if (!INTEGERP (value) || XINT (value) <= 0)
7886 return 0;
7887 break;
7888
7889 case IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR:
7890 if (INTEGERP (value) && XINT (value) >= 0)
7891 break;
7892 if (CONSP (value)
7893 && INTEGERP (XCAR (value)) && INTEGERP (XCDR (value))
7894 && XINT (XCAR (value)) >= 0 && XINT (XCDR (value)) >= 0)
7895 break;
7896 return 0;
7897
7898 case IMAGE_ASCENT_VALUE:
7899 if (SYMBOLP (value) && EQ (value, Qcenter))
7900 break;
7901 else if (INTEGERP (value)
7902 && XINT (value) >= 0
7903 && XINT (value) <= 100)
7904 break;
7905 return 0;
7906
7907 case IMAGE_NON_NEGATIVE_INTEGER_VALUE:
7908 if (!INTEGERP (value) || XINT (value) < 0)
7909 return 0;
7910 break;
7911
7912 case IMAGE_DONT_CHECK_VALUE_TYPE:
7913 break;
7914
7915 case IMAGE_FUNCTION_VALUE:
7916 value = indirect_function (value);
7917 if (SUBRP (value)
7918 || COMPILEDP (value)
7919 || (CONSP (value) && EQ (XCAR (value), Qlambda)))
7920 break;
7921 return 0;
7922
7923 case IMAGE_NUMBER_VALUE:
7924 if (!INTEGERP (value) && !FLOATP (value))
7925 return 0;
7926 break;
7927
7928 case IMAGE_INTEGER_VALUE:
7929 if (!INTEGERP (value))
7930 return 0;
7931 break;
7932
7933 case IMAGE_BOOL_VALUE:
7934 if (!NILP (value) && !EQ (value, Qt))
7935 return 0;
7936 break;
7937
7938 default:
7939 abort ();
7940 break;
7941 }
7942
7943 if (EQ (key, QCtype) && !EQ (type, value))
7944 return 0;
7945 }
7946
7947 /* Check that all mandatory fields are present. */
7948 for (i = 0; i < nkeywords; ++i)
7949 if (keywords[i].mandatory_p && keywords[i].count == 0)
7950 return 0;
7951
7952 return NILP (plist);
7953 }
7954
7955
7956 /* Return the value of KEY in image specification SPEC. Value is nil
7957 if KEY is not present in SPEC. if FOUND is not null, set *FOUND
7958 to 1 if KEY was found in SPEC, set it to 0 otherwise. */
7959
7960 static Lisp_Object
7961 image_spec_value (spec, key, found)
7962 Lisp_Object spec, key;
7963 int *found;
7964 {
7965 Lisp_Object tail;
7966
7967 xassert (valid_image_p (spec));
7968
7969 for (tail = XCDR (spec);
7970 CONSP (tail) && CONSP (XCDR (tail));
7971 tail = XCDR (XCDR (tail)))
7972 {
7973 if (EQ (XCAR (tail), key))
7974 {
7975 if (found)
7976 *found = 1;
7977 return XCAR (XCDR (tail));
7978 }
7979 }
7980
7981 if (found)
7982 *found = 0;
7983 return Qnil;
7984 }
7985
7986
7987
7988 \f
7989 /***********************************************************************
7990 Image type independent image structures
7991 ***********************************************************************/
7992
7993 static struct image *make_image P_ ((Lisp_Object spec, unsigned hash));
7994 static void free_image P_ ((struct frame *f, struct image *img));
7995
7996
7997 /* Allocate and return a new image structure for image specification
7998 SPEC. SPEC has a hash value of HASH. */
7999
8000 static struct image *
8001 make_image (spec, hash)
8002 Lisp_Object spec;
8003 unsigned hash;
8004 {
8005 struct image *img = (struct image *) xmalloc (sizeof *img);
8006
8007 xassert (valid_image_p (spec));
8008 bzero (img, sizeof *img);
8009 img->type = lookup_image_type (image_spec_value (spec, QCtype, NULL));
8010 xassert (img->type != NULL);
8011 img->spec = spec;
8012 img->data.lisp_val = Qnil;
8013 img->ascent = DEFAULT_IMAGE_ASCENT;
8014 img->hash = hash;
8015 return img;
8016 }
8017
8018
8019 /* Free image IMG which was used on frame F, including its resources. */
8020
8021 static void
8022 free_image (f, img)
8023 struct frame *f;
8024 struct image *img;
8025 {
8026 if (img)
8027 {
8028 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
8029
8030 /* Remove IMG from the hash table of its cache. */
8031 if (img->prev)
8032 img->prev->next = img->next;
8033 else
8034 c->buckets[img->hash % IMAGE_CACHE_BUCKETS_SIZE] = img->next;
8035
8036 if (img->next)
8037 img->next->prev = img->prev;
8038
8039 c->images[img->id] = NULL;
8040
8041 /* Free resources, then free IMG. */
8042 img->type->free (f, img);
8043 xfree (img);
8044 }
8045 }
8046
8047
8048 /* Prepare image IMG for display on frame F. Must be called before
8049 drawing an image. */
8050
8051 void
8052 prepare_image_for_display (f, img)
8053 struct frame *f;
8054 struct image *img;
8055 {
8056 EMACS_TIME t;
8057
8058 /* We're about to display IMG, so set its timestamp to `now'. */
8059 EMACS_GET_TIME (t);
8060 img->timestamp = EMACS_SECS (t);
8061
8062 /* If IMG doesn't have a pixmap yet, load it now, using the image
8063 type dependent loader function. */
8064 if (img->pixmap == 0 && !img->load_failed_p)
8065 img->load_failed_p = img->type->load (f, img) == 0;
8066 }
8067
8068
8069 /* Value is the number of pixels for the ascent of image IMG when
8070 drawn in face FACE. */
8071
8072 int
8073 image_ascent (img, face)
8074 struct image *img;
8075 struct face *face;
8076 {
8077 int height = img->height + img->vmargin;
8078 int ascent;
8079
8080 if (img->ascent == CENTERED_IMAGE_ASCENT)
8081 {
8082 if (face->font)
8083 ascent = height / 2 - (FONT_DESCENT(face->font)
8084 - FONT_BASE(face->font)) / 2;
8085 else
8086 ascent = height / 2;
8087 }
8088 else
8089 ascent = height * img->ascent / 100.0;
8090
8091 return ascent;
8092 }
8093
8094
8095 \f
8096 /***********************************************************************
8097 Helper functions for X image types
8098 ***********************************************************************/
8099
8100 static void x_clear_image P_ ((struct frame *f, struct image *img));
8101 static unsigned long x_alloc_image_color P_ ((struct frame *f,
8102 struct image *img,
8103 Lisp_Object color_name,
8104 unsigned long dflt));
8105
8106 /* Free X resources of image IMG which is used on frame F. */
8107
8108 static void
8109 x_clear_image (f, img)
8110 struct frame *f;
8111 struct image *img;
8112 {
8113 #if 0 /* TODO: W32 image support */
8114
8115 if (img->pixmap)
8116 {
8117 BLOCK_INPUT;
8118 XFreePixmap (NULL, img->pixmap);
8119 img->pixmap = 0;
8120 UNBLOCK_INPUT;
8121 }
8122
8123 if (img->ncolors)
8124 {
8125 int class = FRAME_W32_DISPLAY_INFO (f)->visual->class;
8126
8127 /* If display has an immutable color map, freeing colors is not
8128 necessary and some servers don't allow it. So don't do it. */
8129 if (class != StaticColor
8130 && class != StaticGray
8131 && class != TrueColor)
8132 {
8133 Colormap cmap;
8134 BLOCK_INPUT;
8135 cmap = DefaultColormapOfScreen (FRAME_W32_DISPLAY_INFO (f)->screen);
8136 XFreeColors (FRAME_W32_DISPLAY (f), cmap, img->colors,
8137 img->ncolors, 0);
8138 UNBLOCK_INPUT;
8139 }
8140
8141 xfree (img->colors);
8142 img->colors = NULL;
8143 img->ncolors = 0;
8144 }
8145 #endif
8146 }
8147
8148
8149 /* Allocate color COLOR_NAME for image IMG on frame F. If color
8150 cannot be allocated, use DFLT. Add a newly allocated color to
8151 IMG->colors, so that it can be freed again. Value is the pixel
8152 color. */
8153
8154 static unsigned long
8155 x_alloc_image_color (f, img, color_name, dflt)
8156 struct frame *f;
8157 struct image *img;
8158 Lisp_Object color_name;
8159 unsigned long dflt;
8160 {
8161 #if 0 /* TODO: allocing colors. */
8162 XColor color;
8163 unsigned long result;
8164
8165 xassert (STRINGP (color_name));
8166
8167 if (w32_defined_color (f, XSTRING (color_name)->data, &color, 1))
8168 {
8169 /* This isn't called frequently so we get away with simply
8170 reallocating the color vector to the needed size, here. */
8171 ++img->ncolors;
8172 img->colors =
8173 (unsigned long *) xrealloc (img->colors,
8174 img->ncolors * sizeof *img->colors);
8175 img->colors[img->ncolors - 1] = color.pixel;
8176 result = color.pixel;
8177 }
8178 else
8179 result = dflt;
8180 return result;
8181 #endif
8182 return 0;
8183 }
8184
8185
8186 \f
8187 /***********************************************************************
8188 Image Cache
8189 ***********************************************************************/
8190
8191 static void cache_image P_ ((struct frame *f, struct image *img));
8192
8193
8194 /* Return a new, initialized image cache that is allocated from the
8195 heap. Call free_image_cache to free an image cache. */
8196
8197 struct image_cache *
8198 make_image_cache ()
8199 {
8200 struct image_cache *c = (struct image_cache *) xmalloc (sizeof *c);
8201 int size;
8202
8203 bzero (c, sizeof *c);
8204 c->size = 50;
8205 c->images = (struct image **) xmalloc (c->size * sizeof *c->images);
8206 size = IMAGE_CACHE_BUCKETS_SIZE * sizeof *c->buckets;
8207 c->buckets = (struct image **) xmalloc (size);
8208 bzero (c->buckets, size);
8209 return c;
8210 }
8211
8212
8213 /* Free image cache of frame F. Be aware that X frames share images
8214 caches. */
8215
8216 void
8217 free_image_cache (f)
8218 struct frame *f;
8219 {
8220 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
8221 if (c)
8222 {
8223 int i;
8224
8225 /* Cache should not be referenced by any frame when freed. */
8226 xassert (c->refcount == 0);
8227
8228 for (i = 0; i < c->used; ++i)
8229 free_image (f, c->images[i]);
8230 xfree (c->images);
8231 xfree (c);
8232 xfree (c->buckets);
8233 FRAME_X_IMAGE_CACHE (f) = NULL;
8234 }
8235 }
8236
8237
8238 /* Clear image cache of frame F. FORCE_P non-zero means free all
8239 images. FORCE_P zero means clear only images that haven't been
8240 displayed for some time. Should be called from time to time to
8241 reduce the number of loaded images. If image-eviction-seconds is
8242 non-nil, this frees images in the cache which weren't displayed for
8243 at least that many seconds. */
8244
8245 void
8246 clear_image_cache (f, force_p)
8247 struct frame *f;
8248 int force_p;
8249 {
8250 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
8251
8252 if (c && INTEGERP (Vimage_cache_eviction_delay))
8253 {
8254 EMACS_TIME t;
8255 unsigned long old;
8256 int i, any_freed_p = 0;
8257
8258 EMACS_GET_TIME (t);
8259 old = EMACS_SECS (t) - XFASTINT (Vimage_cache_eviction_delay);
8260
8261 for (i = 0; i < c->used; ++i)
8262 {
8263 struct image *img = c->images[i];
8264 if (img != NULL
8265 && (force_p
8266 || (img->timestamp > old)))
8267 {
8268 free_image (f, img);
8269 any_freed_p = 1;
8270 }
8271 }
8272
8273 /* We may be clearing the image cache because, for example,
8274 Emacs was iconified for a longer period of time. In that
8275 case, current matrices may still contain references to
8276 images freed above. So, clear these matrices. */
8277 if (any_freed_p)
8278 {
8279 clear_current_matrices (f);
8280 ++windows_or_buffers_changed;
8281 }
8282 }
8283 }
8284
8285
8286 DEFUN ("clear-image-cache", Fclear_image_cache, Sclear_image_cache,
8287 0, 1, 0,
8288 "Clear the image cache of FRAME.\n\
8289 FRAME nil or omitted means use the selected frame.\n\
8290 FRAME t means clear the image caches of all frames.")
8291 (frame)
8292 Lisp_Object frame;
8293 {
8294 if (EQ (frame, Qt))
8295 {
8296 Lisp_Object tail;
8297
8298 FOR_EACH_FRAME (tail, frame)
8299 if (FRAME_W32_P (XFRAME (frame)))
8300 clear_image_cache (XFRAME (frame), 1);
8301 }
8302 else
8303 clear_image_cache (check_x_frame (frame), 1);
8304
8305 return Qnil;
8306 }
8307
8308
8309 /* Return the id of image with Lisp specification SPEC on frame F.
8310 SPEC must be a valid Lisp image specification (see valid_image_p). */
8311
8312 int
8313 lookup_image (f, spec)
8314 struct frame *f;
8315 Lisp_Object spec;
8316 {
8317 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
8318 struct image *img;
8319 int i;
8320 unsigned hash;
8321 struct gcpro gcpro1;
8322 EMACS_TIME now;
8323
8324 /* F must be a window-system frame, and SPEC must be a valid image
8325 specification. */
8326 xassert (FRAME_WINDOW_P (f));
8327 xassert (valid_image_p (spec));
8328
8329 GCPRO1 (spec);
8330
8331 /* Look up SPEC in the hash table of the image cache. */
8332 hash = sxhash (spec, 0);
8333 i = hash % IMAGE_CACHE_BUCKETS_SIZE;
8334
8335 for (img = c->buckets[i]; img; img = img->next)
8336 if (img->hash == hash && !NILP (Fequal (img->spec, spec)))
8337 break;
8338
8339 /* If not found, create a new image and cache it. */
8340 if (img == NULL)
8341 {
8342 BLOCK_INPUT;
8343 img = make_image (spec, hash);
8344 cache_image (f, img);
8345 img->load_failed_p = img->type->load (f, img) == 0;
8346
8347 /* If we can't load the image, and we don't have a width and
8348 height, use some arbitrary width and height so that we can
8349 draw a rectangle for it. */
8350 if (img->load_failed_p)
8351 {
8352 Lisp_Object value;
8353
8354 value = image_spec_value (spec, QCwidth, NULL);
8355 img->width = (INTEGERP (value)
8356 ? XFASTINT (value) : DEFAULT_IMAGE_WIDTH);
8357 value = image_spec_value (spec, QCheight, NULL);
8358 img->height = (INTEGERP (value)
8359 ? XFASTINT (value) : DEFAULT_IMAGE_HEIGHT);
8360 }
8361 else
8362 {
8363 /* Handle image type independent image attributes
8364 `:ascent PERCENT', `:margin MARGIN', `:relief RELIEF'. */
8365 Lisp_Object ascent, margin, relief;
8366
8367 ascent = image_spec_value (spec, QCascent, NULL);
8368 if (INTEGERP (ascent))
8369 img->ascent = XFASTINT (ascent);
8370 else if (EQ (ascent, Qcenter))
8371 img->ascent = CENTERED_IMAGE_ASCENT;
8372
8373 margin = image_spec_value (spec, QCmargin, NULL);
8374 if (INTEGERP (margin) && XINT (margin) >= 0)
8375 img->vmargin = img->hmargin = XFASTINT (margin);
8376 else if (CONSP (margin) && INTEGERP (XCAR (margin))
8377 && INTEGERP (XCDR (margin)))
8378 {
8379 if (XINT (XCAR (margin)) > 0)
8380 img->hmargin = XFASTINT (XCAR (margin));
8381 if (XINT (XCDR (margin)) > 0)
8382 img->vmargin = XFASTINT (XCDR (margin));
8383 }
8384
8385 relief = image_spec_value (spec, QCrelief, NULL);
8386 if (INTEGERP (relief))
8387 {
8388 img->relief = XINT (relief);
8389 img->hmargin += abs (img->relief);
8390 img->vmargin += abs (img->relief);
8391 }
8392
8393 #if 0 /* TODO: image mask and algorithm. */
8394 /* Manipulation of the image's mask. */
8395 if (img->pixmap)
8396 {
8397 /* `:heuristic-mask t'
8398 `:mask heuristic'
8399 means build a mask heuristically.
8400 `:heuristic-mask (R G B)'
8401 `:mask (heuristic (R G B))'
8402 means build a mask from color (R G B) in the
8403 image.
8404 `:mask nil'
8405 means remove a mask, if any. */
8406
8407 Lisp_Object mask;
8408
8409 mask = image_spec_value (spec, QCheuristic_mask, NULL);
8410 if (!NILP (mask))
8411 x_build_heuristic_mask (f, img, mask);
8412 else
8413 {
8414 int found_p;
8415
8416 mask = image_spec_value (spec, QCmask, &found_p);
8417
8418 if (EQ (mask, Qheuristic))
8419 x_build_heuristic_mask (f, img, Qt);
8420 else if (CONSP (mask)
8421 && EQ (XCAR (mask), Qheuristic))
8422 {
8423 if (CONSP (XCDR (mask)))
8424 x_build_heuristic_mask (f, img, XCAR (XCDR (mask)));
8425 else
8426 x_build_heuristic_mask (f, img, XCDR (mask));
8427 }
8428 else if (NILP (mask) && found_p && img->mask)
8429 {
8430 XFreePixmap (FRAME_X_DISPLAY (f), img->mask);
8431 img->mask = None;
8432 }
8433 }
8434 }
8435
8436 /* Should we apply an image transformation algorithm? */
8437 if (img->pixmap)
8438 {
8439 Lisp_Object conversion;
8440
8441 algorithm = image_spec_value (spec, QCconversion, NULL);
8442 if (EQ (conversion, Qdisabled))
8443 x_disable_image (f, img);
8444 else if (EQ (conversion, Qlaplace))
8445 x_laplace (f, img);
8446 else if (EQ (conversion, Qemboss))
8447 x_emboss (f, img);
8448 else if (CONSP (conversion)
8449 && EQ (XCAR (conversion), Qedge_detection))
8450 {
8451 Lisp_Object tem;
8452 tem = XCDR (conversion);
8453 if (CONSP (tem))
8454 x_edge_detection (f, img,
8455 Fplist_get (tem, QCmatrix),
8456 Fplist_get (tem, QCcolor_adjustment));
8457 }
8458 }
8459 #endif /* TODO. */
8460 }
8461 UNBLOCK_INPUT;
8462 xassert (!interrupt_input_blocked);
8463 }
8464
8465 /* We're using IMG, so set its timestamp to `now'. */
8466 EMACS_GET_TIME (now);
8467 img->timestamp = EMACS_SECS (now);
8468
8469 UNGCPRO;
8470
8471 /* Value is the image id. */
8472 return img->id;
8473 }
8474
8475
8476 /* Cache image IMG in the image cache of frame F. */
8477
8478 static void
8479 cache_image (f, img)
8480 struct frame *f;
8481 struct image *img;
8482 {
8483 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
8484 int i;
8485
8486 /* Find a free slot in c->images. */
8487 for (i = 0; i < c->used; ++i)
8488 if (c->images[i] == NULL)
8489 break;
8490
8491 /* If no free slot found, maybe enlarge c->images. */
8492 if (i == c->used && c->used == c->size)
8493 {
8494 c->size *= 2;
8495 c->images = (struct image **) xrealloc (c->images,
8496 c->size * sizeof *c->images);
8497 }
8498
8499 /* Add IMG to c->images, and assign IMG an id. */
8500 c->images[i] = img;
8501 img->id = i;
8502 if (i == c->used)
8503 ++c->used;
8504
8505 /* Add IMG to the cache's hash table. */
8506 i = img->hash % IMAGE_CACHE_BUCKETS_SIZE;
8507 img->next = c->buckets[i];
8508 if (img->next)
8509 img->next->prev = img;
8510 img->prev = NULL;
8511 c->buckets[i] = img;
8512 }
8513
8514
8515 /* Call FN on every image in the image cache of frame F. Used to mark
8516 Lisp Objects in the image cache. */
8517
8518 void
8519 forall_images_in_image_cache (f, fn)
8520 struct frame *f;
8521 void (*fn) P_ ((struct image *img));
8522 {
8523 if (FRAME_LIVE_P (f) && FRAME_W32_P (f))
8524 {
8525 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
8526 if (c)
8527 {
8528 int i;
8529 for (i = 0; i < c->used; ++i)
8530 if (c->images[i])
8531 fn (c->images[i]);
8532 }
8533 }
8534 }
8535
8536
8537 \f
8538 /***********************************************************************
8539 W32 support code
8540 ***********************************************************************/
8541
8542 #if 0 /* TODO: W32 specific image code. */
8543
8544 static int x_create_x_image_and_pixmap P_ ((struct frame *, int, int, int,
8545 XImage **, Pixmap *));
8546 static void x_destroy_x_image P_ ((XImage *));
8547 static void x_put_x_image P_ ((struct frame *, XImage *, Pixmap, int, int));
8548
8549
8550 /* Create an XImage and a pixmap of size WIDTH x HEIGHT for use on
8551 frame F. Set *XIMG and *PIXMAP to the XImage and Pixmap created.
8552 Set (*XIMG)->data to a raster of WIDTH x HEIGHT pixels allocated
8553 via xmalloc. Print error messages via image_error if an error
8554 occurs. Value is non-zero if successful. */
8555
8556 static int
8557 x_create_x_image_and_pixmap (f, width, height, depth, ximg, pixmap)
8558 struct frame *f;
8559 int width, height, depth;
8560 XImage **ximg;
8561 Pixmap *pixmap;
8562 {
8563 #if 0 /* TODO: Image support for W32 */
8564 Display *display = FRAME_W32_DISPLAY (f);
8565 Screen *screen = FRAME_X_SCREEN (f);
8566 Window window = FRAME_W32_WINDOW (f);
8567
8568 xassert (interrupt_input_blocked);
8569
8570 if (depth <= 0)
8571 depth = DefaultDepthOfScreen (screen);
8572 *ximg = XCreateImage (display, DefaultVisualOfScreen (screen),
8573 depth, ZPixmap, 0, NULL, width, height,
8574 depth > 16 ? 32 : depth > 8 ? 16 : 8, 0);
8575 if (*ximg == NULL)
8576 {
8577 image_error ("Unable to allocate X image", Qnil, Qnil);
8578 return 0;
8579 }
8580
8581 /* Allocate image raster. */
8582 (*ximg)->data = (char *) xmalloc ((*ximg)->bytes_per_line * height);
8583
8584 /* Allocate a pixmap of the same size. */
8585 *pixmap = XCreatePixmap (display, window, width, height, depth);
8586 if (*pixmap == 0)
8587 {
8588 x_destroy_x_image (*ximg);
8589 *ximg = NULL;
8590 image_error ("Unable to create X pixmap", Qnil, Qnil);
8591 return 0;
8592 }
8593 #endif
8594 return 1;
8595 }
8596
8597
8598 /* Destroy XImage XIMG. Free XIMG->data. */
8599
8600 static void
8601 x_destroy_x_image (ximg)
8602 XImage *ximg;
8603 {
8604 xassert (interrupt_input_blocked);
8605 if (ximg)
8606 {
8607 xfree (ximg->data);
8608 ximg->data = NULL;
8609 XDestroyImage (ximg);
8610 }
8611 }
8612
8613
8614 /* Put XImage XIMG into pixmap PIXMAP on frame F. WIDTH and HEIGHT
8615 are width and height of both the image and pixmap. */
8616
8617 static void
8618 x_put_x_image (f, ximg, pixmap, width, height)
8619 struct frame *f;
8620 XImage *ximg;
8621 Pixmap pixmap;
8622 {
8623 GC gc;
8624
8625 xassert (interrupt_input_blocked);
8626 gc = XCreateGC (NULL, pixmap, 0, NULL);
8627 XPutImage (NULL, pixmap, gc, ximg, 0, 0, 0, 0, width, height);
8628 XFreeGC (NULL, gc);
8629 }
8630
8631 #endif
8632
8633 \f
8634 /***********************************************************************
8635 Searching files
8636 ***********************************************************************/
8637
8638 static Lisp_Object x_find_image_file P_ ((Lisp_Object));
8639
8640 /* Find image file FILE. Look in data-directory, then
8641 x-bitmap-file-path. Value is the full name of the file found, or
8642 nil if not found. */
8643
8644 static Lisp_Object
8645 x_find_image_file (file)
8646 Lisp_Object file;
8647 {
8648 Lisp_Object file_found, search_path;
8649 struct gcpro gcpro1, gcpro2;
8650 int fd;
8651
8652 file_found = Qnil;
8653 search_path = Fcons (Vdata_directory, Vx_bitmap_file_path);
8654 GCPRO2 (file_found, search_path);
8655
8656 /* Try to find FILE in data-directory, then x-bitmap-file-path. */
8657 fd = openp (search_path, file, Qnil, &file_found, 0);
8658
8659 if (fd == -1)
8660 file_found = Qnil;
8661 else
8662 close (fd);
8663
8664 UNGCPRO;
8665 return file_found;
8666 }
8667
8668
8669 \f
8670 /***********************************************************************
8671 XBM images
8672 ***********************************************************************/
8673
8674 static int xbm_load P_ ((struct frame *f, struct image *img));
8675 static int xbm_load_image_from_file P_ ((struct frame *f, struct image *img,
8676 Lisp_Object file));
8677 static int xbm_image_p P_ ((Lisp_Object object));
8678 static int xbm_read_bitmap_file_data P_ ((char *, int *, int *,
8679 unsigned char **));
8680
8681
8682 /* Indices of image specification fields in xbm_format, below. */
8683
8684 enum xbm_keyword_index
8685 {
8686 XBM_TYPE,
8687 XBM_FILE,
8688 XBM_WIDTH,
8689 XBM_HEIGHT,
8690 XBM_DATA,
8691 XBM_FOREGROUND,
8692 XBM_BACKGROUND,
8693 XBM_ASCENT,
8694 XBM_MARGIN,
8695 XBM_RELIEF,
8696 XBM_ALGORITHM,
8697 XBM_HEURISTIC_MASK,
8698 XBM_LAST
8699 };
8700
8701 /* Vector of image_keyword structures describing the format
8702 of valid XBM image specifications. */
8703
8704 static struct image_keyword xbm_format[XBM_LAST] =
8705 {
8706 {":type", IMAGE_SYMBOL_VALUE, 1},
8707 {":file", IMAGE_STRING_VALUE, 0},
8708 {":width", IMAGE_POSITIVE_INTEGER_VALUE, 0},
8709 {":height", IMAGE_POSITIVE_INTEGER_VALUE, 0},
8710 {":data", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8711 {":foreground", IMAGE_STRING_VALUE, 0},
8712 {":background", IMAGE_STRING_VALUE, 0},
8713 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
8714 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
8715 {":relief", IMAGE_INTEGER_VALUE, 0},
8716 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8717 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
8718 };
8719
8720 /* Structure describing the image type XBM. */
8721
8722 static struct image_type xbm_type =
8723 {
8724 &Qxbm,
8725 xbm_image_p,
8726 xbm_load,
8727 x_clear_image,
8728 NULL
8729 };
8730
8731 /* Tokens returned from xbm_scan. */
8732
8733 enum xbm_token
8734 {
8735 XBM_TK_IDENT = 256,
8736 XBM_TK_NUMBER
8737 };
8738
8739
8740 /* Return non-zero if OBJECT is a valid XBM-type image specification.
8741 A valid specification is a list starting with the symbol `image'
8742 The rest of the list is a property list which must contain an
8743 entry `:type xbm..
8744
8745 If the specification specifies a file to load, it must contain
8746 an entry `:file FILENAME' where FILENAME is a string.
8747
8748 If the specification is for a bitmap loaded from memory it must
8749 contain `:width WIDTH', `:height HEIGHT', and `:data DATA', where
8750 WIDTH and HEIGHT are integers > 0. DATA may be:
8751
8752 1. a string large enough to hold the bitmap data, i.e. it must
8753 have a size >= (WIDTH + 7) / 8 * HEIGHT
8754
8755 2. a bool-vector of size >= WIDTH * HEIGHT
8756
8757 3. a vector of strings or bool-vectors, one for each line of the
8758 bitmap.
8759
8760 Both the file and data forms may contain the additional entries
8761 `:background COLOR' and `:foreground COLOR'. If not present,
8762 foreground and background of the frame on which the image is
8763 displayed, is used. */
8764
8765 static int
8766 xbm_image_p (object)
8767 Lisp_Object object;
8768 {
8769 struct image_keyword kw[XBM_LAST];
8770
8771 bcopy (xbm_format, kw, sizeof kw);
8772 if (!parse_image_spec (object, kw, XBM_LAST, Qxbm))
8773 return 0;
8774
8775 xassert (EQ (kw[XBM_TYPE].value, Qxbm));
8776
8777 if (kw[XBM_FILE].count)
8778 {
8779 if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_DATA].count)
8780 return 0;
8781 }
8782 else
8783 {
8784 Lisp_Object data;
8785 int width, height;
8786
8787 /* Entries for `:width', `:height' and `:data' must be present. */
8788 if (!kw[XBM_WIDTH].count
8789 || !kw[XBM_HEIGHT].count
8790 || !kw[XBM_DATA].count)
8791 return 0;
8792
8793 data = kw[XBM_DATA].value;
8794 width = XFASTINT (kw[XBM_WIDTH].value);
8795 height = XFASTINT (kw[XBM_HEIGHT].value);
8796
8797 /* Check type of data, and width and height against contents of
8798 data. */
8799 if (VECTORP (data))
8800 {
8801 int i;
8802
8803 /* Number of elements of the vector must be >= height. */
8804 if (XVECTOR (data)->size < height)
8805 return 0;
8806
8807 /* Each string or bool-vector in data must be large enough
8808 for one line of the image. */
8809 for (i = 0; i < height; ++i)
8810 {
8811 Lisp_Object elt = XVECTOR (data)->contents[i];
8812
8813 if (STRINGP (elt))
8814 {
8815 if (XSTRING (elt)->size
8816 < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR)
8817 return 0;
8818 }
8819 else if (BOOL_VECTOR_P (elt))
8820 {
8821 if (XBOOL_VECTOR (elt)->size < width)
8822 return 0;
8823 }
8824 else
8825 return 0;
8826 }
8827 }
8828 else if (STRINGP (data))
8829 {
8830 if (XSTRING (data)->size
8831 < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR * height)
8832 return 0;
8833 }
8834 else if (BOOL_VECTOR_P (data))
8835 {
8836 if (XBOOL_VECTOR (data)->size < width * height)
8837 return 0;
8838 }
8839 else
8840 return 0;
8841 }
8842
8843 /* Baseline must be a value between 0 and 100 (a percentage). */
8844 if (kw[XBM_ASCENT].count
8845 && XFASTINT (kw[XBM_ASCENT].value) > 100)
8846 return 0;
8847
8848 return 1;
8849 }
8850
8851
8852 /* Scan a bitmap file. FP is the stream to read from. Value is
8853 either an enumerator from enum xbm_token, or a character for a
8854 single-character token, or 0 at end of file. If scanning an
8855 identifier, store the lexeme of the identifier in SVAL. If
8856 scanning a number, store its value in *IVAL. */
8857
8858 static int
8859 xbm_scan (fp, sval, ival)
8860 FILE *fp;
8861 char *sval;
8862 int *ival;
8863 {
8864 int c;
8865
8866 /* Skip white space. */
8867 while ((c = fgetc (fp)) != EOF && isspace (c))
8868 ;
8869
8870 if (c == EOF)
8871 c = 0;
8872 else if (isdigit (c))
8873 {
8874 int value = 0, digit;
8875
8876 if (c == '0')
8877 {
8878 c = fgetc (fp);
8879 if (c == 'x' || c == 'X')
8880 {
8881 while ((c = fgetc (fp)) != EOF)
8882 {
8883 if (isdigit (c))
8884 digit = c - '0';
8885 else if (c >= 'a' && c <= 'f')
8886 digit = c - 'a' + 10;
8887 else if (c >= 'A' && c <= 'F')
8888 digit = c - 'A' + 10;
8889 else
8890 break;
8891 value = 16 * value + digit;
8892 }
8893 }
8894 else if (isdigit (c))
8895 {
8896 value = c - '0';
8897 while ((c = fgetc (fp)) != EOF
8898 && isdigit (c))
8899 value = 8 * value + c - '0';
8900 }
8901 }
8902 else
8903 {
8904 value = c - '0';
8905 while ((c = fgetc (fp)) != EOF
8906 && isdigit (c))
8907 value = 10 * value + c - '0';
8908 }
8909
8910 if (c != EOF)
8911 ungetc (c, fp);
8912 *ival = value;
8913 c = XBM_TK_NUMBER;
8914 }
8915 else if (isalpha (c) || c == '_')
8916 {
8917 *sval++ = c;
8918 while ((c = fgetc (fp)) != EOF
8919 && (isalnum (c) || c == '_'))
8920 *sval++ = c;
8921 *sval = 0;
8922 if (c != EOF)
8923 ungetc (c, fp);
8924 c = XBM_TK_IDENT;
8925 }
8926
8927 return c;
8928 }
8929
8930
8931 /* Replacement for XReadBitmapFileData which isn't available under old
8932 X versions. FILE is the name of the bitmap file to read. Set
8933 *WIDTH and *HEIGHT to the width and height of the image. Return in
8934 *DATA the bitmap data allocated with xmalloc. Value is non-zero if
8935 successful. */
8936
8937 static int
8938 xbm_read_bitmap_file_data (file, width, height, data)
8939 char *file;
8940 int *width, *height;
8941 unsigned char **data;
8942 {
8943 FILE *fp;
8944 char buffer[BUFSIZ];
8945 int padding_p = 0;
8946 int v10 = 0;
8947 int bytes_per_line, i, nbytes;
8948 unsigned char *p;
8949 int value;
8950 int LA1;
8951
8952 #define match() \
8953 LA1 = xbm_scan (fp, buffer, &value)
8954
8955 #define expect(TOKEN) \
8956 if (LA1 != (TOKEN)) \
8957 goto failure; \
8958 else \
8959 match ()
8960
8961 #define expect_ident(IDENT) \
8962 if (LA1 == XBM_TK_IDENT && strcmp (buffer, (IDENT)) == 0) \
8963 match (); \
8964 else \
8965 goto failure
8966
8967 fp = fopen (file, "r");
8968 if (fp == NULL)
8969 return 0;
8970
8971 *width = *height = -1;
8972 *data = NULL;
8973 LA1 = xbm_scan (fp, buffer, &value);
8974
8975 /* Parse defines for width, height and hot-spots. */
8976 while (LA1 == '#')
8977 {
8978 match ();
8979 expect_ident ("define");
8980 expect (XBM_TK_IDENT);
8981
8982 if (LA1 == XBM_TK_NUMBER);
8983 {
8984 char *p = strrchr (buffer, '_');
8985 p = p ? p + 1 : buffer;
8986 if (strcmp (p, "width") == 0)
8987 *width = value;
8988 else if (strcmp (p, "height") == 0)
8989 *height = value;
8990 }
8991 expect (XBM_TK_NUMBER);
8992 }
8993
8994 if (*width < 0 || *height < 0)
8995 goto failure;
8996
8997 /* Parse bits. Must start with `static'. */
8998 expect_ident ("static");
8999 if (LA1 == XBM_TK_IDENT)
9000 {
9001 if (strcmp (buffer, "unsigned") == 0)
9002 {
9003 match ();
9004 expect_ident ("char");
9005 }
9006 else if (strcmp (buffer, "short") == 0)
9007 {
9008 match ();
9009 v10 = 1;
9010 if (*width % 16 && *width % 16 < 9)
9011 padding_p = 1;
9012 }
9013 else if (strcmp (buffer, "char") == 0)
9014 match ();
9015 else
9016 goto failure;
9017 }
9018 else
9019 goto failure;
9020
9021 expect (XBM_TK_IDENT);
9022 expect ('[');
9023 expect (']');
9024 expect ('=');
9025 expect ('{');
9026
9027 bytes_per_line = (*width + 7) / 8 + padding_p;
9028 nbytes = bytes_per_line * *height;
9029 p = *data = (char *) xmalloc (nbytes);
9030
9031 if (v10)
9032 {
9033
9034 for (i = 0; i < nbytes; i += 2)
9035 {
9036 int val = value;
9037 expect (XBM_TK_NUMBER);
9038
9039 *p++ = val;
9040 if (!padding_p || ((i + 2) % bytes_per_line))
9041 *p++ = value >> 8;
9042
9043 if (LA1 == ',' || LA1 == '}')
9044 match ();
9045 else
9046 goto failure;
9047 }
9048 }
9049 else
9050 {
9051 for (i = 0; i < nbytes; ++i)
9052 {
9053 int val = value;
9054 expect (XBM_TK_NUMBER);
9055
9056 *p++ = val;
9057
9058 if (LA1 == ',' || LA1 == '}')
9059 match ();
9060 else
9061 goto failure;
9062 }
9063 }
9064
9065 fclose (fp);
9066 return 1;
9067
9068 failure:
9069
9070 fclose (fp);
9071 if (*data)
9072 {
9073 xfree (*data);
9074 *data = NULL;
9075 }
9076 return 0;
9077
9078 #undef match
9079 #undef expect
9080 #undef expect_ident
9081 }
9082
9083
9084 /* Load XBM image IMG which will be displayed on frame F from file
9085 SPECIFIED_FILE. Value is non-zero if successful. */
9086
9087 static int
9088 xbm_load_image_from_file (f, img, specified_file)
9089 struct frame *f;
9090 struct image *img;
9091 Lisp_Object specified_file;
9092 {
9093 int rc;
9094 unsigned char *data;
9095 int success_p = 0;
9096 Lisp_Object file;
9097 struct gcpro gcpro1;
9098
9099 xassert (STRINGP (specified_file));
9100 file = Qnil;
9101 GCPRO1 (file);
9102
9103 file = x_find_image_file (specified_file);
9104 if (!STRINGP (file))
9105 {
9106 image_error ("Cannot find image file `%s'", specified_file, Qnil);
9107 UNGCPRO;
9108 return 0;
9109 }
9110
9111 rc = xbm_read_bitmap_file_data (XSTRING (file)->data, &img->width,
9112 &img->height, &data);
9113 if (rc)
9114 {
9115 int depth = one_w32_display_info.n_cbits;
9116 unsigned long foreground = FRAME_FOREGROUND_PIXEL (f);
9117 unsigned long background = FRAME_BACKGROUND_PIXEL (f);
9118 Lisp_Object value;
9119
9120 xassert (img->width > 0 && img->height > 0);
9121
9122 /* Get foreground and background colors, maybe allocate colors. */
9123 value = image_spec_value (img->spec, QCforeground, NULL);
9124 if (!NILP (value))
9125 foreground = x_alloc_image_color (f, img, value, foreground);
9126
9127 value = image_spec_value (img->spec, QCbackground, NULL);
9128 if (!NILP (value))
9129 background = x_alloc_image_color (f, img, value, background);
9130
9131 #if 0 /* TODO : Port image display to W32 */
9132 BLOCK_INPUT;
9133 img->pixmap
9134 = XCreatePixmapFromBitmapData (FRAME_W32_DISPLAY (f),
9135 FRAME_W32_WINDOW (f),
9136 data,
9137 img->width, img->height,
9138 foreground, background,
9139 depth);
9140 xfree (data);
9141
9142 if (img->pixmap == 0)
9143 {
9144 x_clear_image (f, img);
9145 image_error ("Unable to create X pixmap for `%s'", file, Qnil);
9146 }
9147 else
9148 success_p = 1;
9149
9150 UNBLOCK_INPUT;
9151 #endif
9152 }
9153 else
9154 image_error ("Error loading XBM image `%s'", img->spec, Qnil);
9155
9156 UNGCPRO;
9157 return success_p;
9158 }
9159
9160
9161 /* Fill image IMG which is used on frame F with pixmap data. Value is
9162 non-zero if successful. */
9163
9164 static int
9165 xbm_load (f, img)
9166 struct frame *f;
9167 struct image *img;
9168 {
9169 int success_p = 0;
9170 Lisp_Object file_name;
9171
9172 xassert (xbm_image_p (img->spec));
9173
9174 /* If IMG->spec specifies a file name, create a non-file spec from it. */
9175 file_name = image_spec_value (img->spec, QCfile, NULL);
9176 if (STRINGP (file_name))
9177 success_p = xbm_load_image_from_file (f, img, file_name);
9178 else
9179 {
9180 struct image_keyword fmt[XBM_LAST];
9181 Lisp_Object data;
9182 int depth;
9183 unsigned long foreground = FRAME_FOREGROUND_PIXEL (f);
9184 unsigned long background = FRAME_BACKGROUND_PIXEL (f);
9185 char *bits;
9186 int parsed_p;
9187
9188 /* Parse the list specification. */
9189 bcopy (xbm_format, fmt, sizeof fmt);
9190 parsed_p = parse_image_spec (img->spec, fmt, XBM_LAST, Qxbm);
9191 xassert (parsed_p);
9192
9193 /* Get specified width, and height. */
9194 img->width = XFASTINT (fmt[XBM_WIDTH].value);
9195 img->height = XFASTINT (fmt[XBM_HEIGHT].value);
9196 xassert (img->width > 0 && img->height > 0);
9197
9198 BLOCK_INPUT;
9199
9200 if (fmt[XBM_ASCENT].count)
9201 img->ascent = XFASTINT (fmt[XBM_ASCENT].value);
9202
9203 /* Get foreground and background colors, maybe allocate colors. */
9204 if (fmt[XBM_FOREGROUND].count)
9205 foreground = x_alloc_image_color (f, img, fmt[XBM_FOREGROUND].value,
9206 foreground);
9207 if (fmt[XBM_BACKGROUND].count)
9208 background = x_alloc_image_color (f, img, fmt[XBM_BACKGROUND].value,
9209 background);
9210
9211 /* Set bits to the bitmap image data. */
9212 data = fmt[XBM_DATA].value;
9213 if (VECTORP (data))
9214 {
9215 int i;
9216 char *p;
9217 int nbytes = (img->width + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
9218
9219 p = bits = (char *) alloca (nbytes * img->height);
9220 for (i = 0; i < img->height; ++i, p += nbytes)
9221 {
9222 Lisp_Object line = XVECTOR (data)->contents[i];
9223 if (STRINGP (line))
9224 bcopy (XSTRING (line)->data, p, nbytes);
9225 else
9226 bcopy (XBOOL_VECTOR (line)->data, p, nbytes);
9227 }
9228 }
9229 else if (STRINGP (data))
9230 bits = XSTRING (data)->data;
9231 else
9232 bits = XBOOL_VECTOR (data)->data;
9233
9234 #if 0 /* TODO : W32 XPM code */
9235 /* Create the pixmap. */
9236 depth = DefaultDepthOfScreen (FRAME_X_SCREEN (f));
9237 img->pixmap
9238 = XCreatePixmapFromBitmapData (FRAME_W32_DISPLAY (f),
9239 FRAME_W32_WINDOW (f),
9240 bits,
9241 img->width, img->height,
9242 foreground, background,
9243 depth);
9244 #endif /* TODO */
9245
9246 if (img->pixmap)
9247 success_p = 1;
9248 else
9249 {
9250 image_error ("Unable to create pixmap for XBM image `%s'",
9251 img->spec, Qnil);
9252 x_clear_image (f, img);
9253 }
9254
9255 UNBLOCK_INPUT;
9256 }
9257
9258 return success_p;
9259 }
9260
9261
9262 \f
9263 /***********************************************************************
9264 XPM images
9265 ***********************************************************************/
9266
9267 #if HAVE_XPM
9268
9269 static int xpm_image_p P_ ((Lisp_Object object));
9270 static int xpm_load P_ ((struct frame *f, struct image *img));
9271 static int xpm_valid_color_symbols_p P_ ((Lisp_Object));
9272
9273 #include "X11/xpm.h"
9274
9275 /* The symbol `xpm' identifying XPM-format images. */
9276
9277 Lisp_Object Qxpm;
9278
9279 /* Indices of image specification fields in xpm_format, below. */
9280
9281 enum xpm_keyword_index
9282 {
9283 XPM_TYPE,
9284 XPM_FILE,
9285 XPM_DATA,
9286 XPM_ASCENT,
9287 XPM_MARGIN,
9288 XPM_RELIEF,
9289 XPM_ALGORITHM,
9290 XPM_HEURISTIC_MASK,
9291 XPM_COLOR_SYMBOLS,
9292 XPM_LAST
9293 };
9294
9295 /* Vector of image_keyword structures describing the format
9296 of valid XPM image specifications. */
9297
9298 static struct image_keyword xpm_format[XPM_LAST] =
9299 {
9300 {":type", IMAGE_SYMBOL_VALUE, 1},
9301 {":file", IMAGE_STRING_VALUE, 0},
9302 {":data", IMAGE_STRING_VALUE, 0},
9303 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
9304 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
9305 {":relief", IMAGE_INTEGER_VALUE, 0},
9306 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
9307 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
9308 {":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
9309 };
9310
9311 /* Structure describing the image type XBM. */
9312
9313 static struct image_type xpm_type =
9314 {
9315 &Qxpm,
9316 xpm_image_p,
9317 xpm_load,
9318 x_clear_image,
9319 NULL
9320 };
9321
9322
9323 /* Value is non-zero if COLOR_SYMBOLS is a valid color symbols list
9324 for XPM images. Such a list must consist of conses whose car and
9325 cdr are strings. */
9326
9327 static int
9328 xpm_valid_color_symbols_p (color_symbols)
9329 Lisp_Object color_symbols;
9330 {
9331 while (CONSP (color_symbols))
9332 {
9333 Lisp_Object sym = XCAR (color_symbols);
9334 if (!CONSP (sym)
9335 || !STRINGP (XCAR (sym))
9336 || !STRINGP (XCDR (sym)))
9337 break;
9338 color_symbols = XCDR (color_symbols);
9339 }
9340
9341 return NILP (color_symbols);
9342 }
9343
9344
9345 /* Value is non-zero if OBJECT is a valid XPM image specification. */
9346
9347 static int
9348 xpm_image_p (object)
9349 Lisp_Object object;
9350 {
9351 struct image_keyword fmt[XPM_LAST];
9352 bcopy (xpm_format, fmt, sizeof fmt);
9353 return (parse_image_spec (object, fmt, XPM_LAST, Qxpm)
9354 /* Either `:file' or `:data' must be present. */
9355 && fmt[XPM_FILE].count + fmt[XPM_DATA].count == 1
9356 /* Either no `:color-symbols' or it's a list of conses
9357 whose car and cdr are strings. */
9358 && (fmt[XPM_COLOR_SYMBOLS].count == 0
9359 || xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value))
9360 && (fmt[XPM_ASCENT].count == 0
9361 || XFASTINT (fmt[XPM_ASCENT].value) < 100));
9362 }
9363
9364
9365 /* Load image IMG which will be displayed on frame F. Value is
9366 non-zero if successful. */
9367
9368 static int
9369 xpm_load (f, img)
9370 struct frame *f;
9371 struct image *img;
9372 {
9373 int rc, i;
9374 XpmAttributes attrs;
9375 Lisp_Object specified_file, color_symbols;
9376
9377 /* Configure the XPM lib. Use the visual of frame F. Allocate
9378 close colors. Return colors allocated. */
9379 bzero (&attrs, sizeof attrs);
9380 attrs.visual = FRAME_X_VISUAL (f);
9381 attrs.colormap = FRAME_X_COLORMAP (f);
9382 attrs.valuemask |= XpmVisual;
9383 attrs.valuemask |= XpmColormap;
9384 attrs.valuemask |= XpmReturnAllocPixels;
9385 #ifdef XpmAllocCloseColors
9386 attrs.alloc_close_colors = 1;
9387 attrs.valuemask |= XpmAllocCloseColors;
9388 #else
9389 attrs.closeness = 600;
9390 attrs.valuemask |= XpmCloseness;
9391 #endif
9392
9393 /* If image specification contains symbolic color definitions, add
9394 these to `attrs'. */
9395 color_symbols = image_spec_value (img->spec, QCcolor_symbols, NULL);
9396 if (CONSP (color_symbols))
9397 {
9398 Lisp_Object tail;
9399 XpmColorSymbol *xpm_syms;
9400 int i, size;
9401
9402 attrs.valuemask |= XpmColorSymbols;
9403
9404 /* Count number of symbols. */
9405 attrs.numsymbols = 0;
9406 for (tail = color_symbols; CONSP (tail); tail = XCDR (tail))
9407 ++attrs.numsymbols;
9408
9409 /* Allocate an XpmColorSymbol array. */
9410 size = attrs.numsymbols * sizeof *xpm_syms;
9411 xpm_syms = (XpmColorSymbol *) alloca (size);
9412 bzero (xpm_syms, size);
9413 attrs.colorsymbols = xpm_syms;
9414
9415 /* Fill the color symbol array. */
9416 for (tail = color_symbols, i = 0;
9417 CONSP (tail);
9418 ++i, tail = XCDR (tail))
9419 {
9420 Lisp_Object name = XCAR (XCAR (tail));
9421 Lisp_Object color = XCDR (XCAR (tail));
9422 xpm_syms[i].name = (char *) alloca (XSTRING (name)->size + 1);
9423 strcpy (xpm_syms[i].name, XSTRING (name)->data);
9424 xpm_syms[i].value = (char *) alloca (XSTRING (color)->size + 1);
9425 strcpy (xpm_syms[i].value, XSTRING (color)->data);
9426 }
9427 }
9428
9429 /* Create a pixmap for the image, either from a file, or from a
9430 string buffer containing data in the same format as an XPM file. */
9431 BLOCK_INPUT;
9432 specified_file = image_spec_value (img->spec, QCfile, NULL);
9433 if (STRINGP (specified_file))
9434 {
9435 Lisp_Object file = x_find_image_file (specified_file);
9436 if (!STRINGP (file))
9437 {
9438 image_error ("Cannot find image file `%s'", specified_file, Qnil);
9439 UNBLOCK_INPUT;
9440 return 0;
9441 }
9442
9443 rc = XpmReadFileToPixmap (NULL, FRAME_W32_WINDOW (f),
9444 XSTRING (file)->data, &img->pixmap, &img->mask,
9445 &attrs);
9446 }
9447 else
9448 {
9449 Lisp_Object buffer = image_spec_value (img->spec, QCdata, NULL);
9450 rc = XpmCreatePixmapFromBuffer (NULL, FRAME_W32_WINDOW (f),
9451 XSTRING (buffer)->data,
9452 &img->pixmap, &img->mask,
9453 &attrs);
9454 }
9455 UNBLOCK_INPUT;
9456
9457 if (rc == XpmSuccess)
9458 {
9459 /* Remember allocated colors. */
9460 img->ncolors = attrs.nalloc_pixels;
9461 img->colors = (unsigned long *) xmalloc (img->ncolors
9462 * sizeof *img->colors);
9463 for (i = 0; i < attrs.nalloc_pixels; ++i)
9464 img->colors[i] = attrs.alloc_pixels[i];
9465
9466 img->width = attrs.width;
9467 img->height = attrs.height;
9468 xassert (img->width > 0 && img->height > 0);
9469
9470 /* The call to XpmFreeAttributes below frees attrs.alloc_pixels. */
9471 BLOCK_INPUT;
9472 XpmFreeAttributes (&attrs);
9473 UNBLOCK_INPUT;
9474 }
9475 else
9476 {
9477 switch (rc)
9478 {
9479 case XpmOpenFailed:
9480 image_error ("Error opening XPM file (%s)", img->spec, Qnil);
9481 break;
9482
9483 case XpmFileInvalid:
9484 image_error ("Invalid XPM file (%s)", img->spec, Qnil);
9485 break;
9486
9487 case XpmNoMemory:
9488 image_error ("Out of memory (%s)", img->spec, Qnil);
9489 break;
9490
9491 case XpmColorFailed:
9492 image_error ("Color allocation error (%s)", img->spec, Qnil);
9493 break;
9494
9495 default:
9496 image_error ("Unknown error (%s)", img->spec, Qnil);
9497 break;
9498 }
9499 }
9500
9501 return rc == XpmSuccess;
9502 }
9503
9504 #endif /* HAVE_XPM != 0 */
9505
9506 \f
9507 #if 0 /* TODO : Color tables on W32. */
9508 /***********************************************************************
9509 Color table
9510 ***********************************************************************/
9511
9512 /* An entry in the color table mapping an RGB color to a pixel color. */
9513
9514 struct ct_color
9515 {
9516 int r, g, b;
9517 unsigned long pixel;
9518
9519 /* Next in color table collision list. */
9520 struct ct_color *next;
9521 };
9522
9523 /* The bucket vector size to use. Must be prime. */
9524
9525 #define CT_SIZE 101
9526
9527 /* Value is a hash of the RGB color given by R, G, and B. */
9528
9529 #define CT_HASH_RGB(R, G, B) (((R) << 16) ^ ((G) << 8) ^ (B))
9530
9531 /* The color hash table. */
9532
9533 struct ct_color **ct_table;
9534
9535 /* Number of entries in the color table. */
9536
9537 int ct_colors_allocated;
9538
9539 /* Function prototypes. */
9540
9541 static void init_color_table P_ ((void));
9542 static void free_color_table P_ ((void));
9543 static unsigned long *colors_in_color_table P_ ((int *n));
9544 static unsigned long lookup_rgb_color P_ ((struct frame *f, int r, int g, int b));
9545 static unsigned long lookup_pixel_color P_ ((struct frame *f, unsigned long p));
9546
9547
9548 /* Initialize the color table. */
9549
9550 static void
9551 init_color_table ()
9552 {
9553 int size = CT_SIZE * sizeof (*ct_table);
9554 ct_table = (struct ct_color **) xmalloc (size);
9555 bzero (ct_table, size);
9556 ct_colors_allocated = 0;
9557 }
9558
9559
9560 /* Free memory associated with the color table. */
9561
9562 static void
9563 free_color_table ()
9564 {
9565 int i;
9566 struct ct_color *p, *next;
9567
9568 for (i = 0; i < CT_SIZE; ++i)
9569 for (p = ct_table[i]; p; p = next)
9570 {
9571 next = p->next;
9572 xfree (p);
9573 }
9574
9575 xfree (ct_table);
9576 ct_table = NULL;
9577 }
9578
9579
9580 /* Value is a pixel color for RGB color R, G, B on frame F. If an
9581 entry for that color already is in the color table, return the
9582 pixel color of that entry. Otherwise, allocate a new color for R,
9583 G, B, and make an entry in the color table. */
9584
9585 static unsigned long
9586 lookup_rgb_color (f, r, g, b)
9587 struct frame *f;
9588 int r, g, b;
9589 {
9590 unsigned hash = CT_HASH_RGB (r, g, b);
9591 int i = hash % CT_SIZE;
9592 struct ct_color *p;
9593
9594 for (p = ct_table[i]; p; p = p->next)
9595 if (p->r == r && p->g == g && p->b == b)
9596 break;
9597
9598 if (p == NULL)
9599 {
9600 COLORREF color;
9601 Colormap cmap;
9602 int rc;
9603
9604 color = PALETTERGB (r, g, b);
9605
9606 ++ct_colors_allocated;
9607
9608 p = (struct ct_color *) xmalloc (sizeof *p);
9609 p->r = r;
9610 p->g = g;
9611 p->b = b;
9612 p->pixel = color;
9613 p->next = ct_table[i];
9614 ct_table[i] = p;
9615 }
9616
9617 return p->pixel;
9618 }
9619
9620
9621 /* Look up pixel color PIXEL which is used on frame F in the color
9622 table. If not already present, allocate it. Value is PIXEL. */
9623
9624 static unsigned long
9625 lookup_pixel_color (f, pixel)
9626 struct frame *f;
9627 unsigned long pixel;
9628 {
9629 int i = pixel % CT_SIZE;
9630 struct ct_color *p;
9631
9632 for (p = ct_table[i]; p; p = p->next)
9633 if (p->pixel == pixel)
9634 break;
9635
9636 if (p == NULL)
9637 {
9638 XColor color;
9639 Colormap cmap;
9640 int rc;
9641
9642 BLOCK_INPUT;
9643
9644 cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
9645 color.pixel = pixel;
9646 XQueryColor (NULL, cmap, &color);
9647 rc = x_alloc_nearest_color (f, cmap, &color);
9648 UNBLOCK_INPUT;
9649
9650 if (rc)
9651 {
9652 ++ct_colors_allocated;
9653
9654 p = (struct ct_color *) xmalloc (sizeof *p);
9655 p->r = color.red;
9656 p->g = color.green;
9657 p->b = color.blue;
9658 p->pixel = pixel;
9659 p->next = ct_table[i];
9660 ct_table[i] = p;
9661 }
9662 else
9663 return FRAME_FOREGROUND_PIXEL (f);
9664 }
9665 return p->pixel;
9666 }
9667
9668
9669 /* Value is a vector of all pixel colors contained in the color table,
9670 allocated via xmalloc. Set *N to the number of colors. */
9671
9672 static unsigned long *
9673 colors_in_color_table (n)
9674 int *n;
9675 {
9676 int i, j;
9677 struct ct_color *p;
9678 unsigned long *colors;
9679
9680 if (ct_colors_allocated == 0)
9681 {
9682 *n = 0;
9683 colors = NULL;
9684 }
9685 else
9686 {
9687 colors = (unsigned long *) xmalloc (ct_colors_allocated
9688 * sizeof *colors);
9689 *n = ct_colors_allocated;
9690
9691 for (i = j = 0; i < CT_SIZE; ++i)
9692 for (p = ct_table[i]; p; p = p->next)
9693 colors[j++] = p->pixel;
9694 }
9695
9696 return colors;
9697 }
9698
9699 #endif /* TODO */
9700
9701 \f
9702 /***********************************************************************
9703 Algorithms
9704 ***********************************************************************/
9705
9706 #if 0 /* TODO : W32 versions of low level algorithms */
9707 static void x_laplace_write_row P_ ((struct frame *, long *,
9708 int, XImage *, int));
9709 static void x_laplace_read_row P_ ((struct frame *, Colormap,
9710 XColor *, int, XImage *, int));
9711
9712
9713 /* Fill COLORS with RGB colors from row Y of image XIMG. F is the
9714 frame we operate on, CMAP is the color-map in effect, and WIDTH is
9715 the width of one row in the image. */
9716
9717 static void
9718 x_laplace_read_row (f, cmap, colors, width, ximg, y)
9719 struct frame *f;
9720 Colormap cmap;
9721 XColor *colors;
9722 int width;
9723 XImage *ximg;
9724 int y;
9725 {
9726 int x;
9727
9728 for (x = 0; x < width; ++x)
9729 colors[x].pixel = XGetPixel (ximg, x, y);
9730
9731 XQueryColors (NULL, cmap, colors, width);
9732 }
9733
9734
9735 /* Write row Y of image XIMG. PIXELS is an array of WIDTH longs
9736 containing the pixel colors to write. F is the frame we are
9737 working on. */
9738
9739 static void
9740 x_laplace_write_row (f, pixels, width, ximg, y)
9741 struct frame *f;
9742 long *pixels;
9743 int width;
9744 XImage *ximg;
9745 int y;
9746 {
9747 int x;
9748
9749 for (x = 0; x < width; ++x)
9750 XPutPixel (ximg, x, y, pixels[x]);
9751 }
9752 #endif
9753
9754 /* Transform image IMG which is used on frame F with a Laplace
9755 edge-detection algorithm. The result is an image that can be used
9756 to draw disabled buttons, for example. */
9757
9758 static void
9759 x_laplace (f, img)
9760 struct frame *f;
9761 struct image *img;
9762 {
9763 #if 0 /* TODO : W32 version */
9764 Colormap cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
9765 XImage *ximg, *oimg;
9766 XColor *in[3];
9767 long *out;
9768 Pixmap pixmap;
9769 int x, y, i;
9770 long pixel;
9771 int in_y, out_y, rc;
9772 int mv2 = 45000;
9773
9774 BLOCK_INPUT;
9775
9776 /* Get the X image IMG->pixmap. */
9777 ximg = XGetImage (NULL, img->pixmap,
9778 0, 0, img->width, img->height, ~0, ZPixmap);
9779
9780 /* Allocate 3 input rows, and one output row of colors. */
9781 for (i = 0; i < 3; ++i)
9782 in[i] = (XColor *) alloca (img->width * sizeof (XColor));
9783 out = (long *) alloca (img->width * sizeof (long));
9784
9785 /* Create an X image for output. */
9786 rc = x_create_x_image_and_pixmap (f, img->width, img->height, 0,
9787 &oimg, &pixmap);
9788
9789 /* Fill first two rows. */
9790 x_laplace_read_row (f, cmap, in[0], img->width, ximg, 0);
9791 x_laplace_read_row (f, cmap, in[1], img->width, ximg, 1);
9792 in_y = 2;
9793
9794 /* Write first row, all zeros. */
9795 init_color_table ();
9796 pixel = lookup_rgb_color (f, 0, 0, 0);
9797 for (x = 0; x < img->width; ++x)
9798 out[x] = pixel;
9799 x_laplace_write_row (f, out, img->width, oimg, 0);
9800 out_y = 1;
9801
9802 for (y = 2; y < img->height; ++y)
9803 {
9804 int rowa = y % 3;
9805 int rowb = (y + 2) % 3;
9806
9807 x_laplace_read_row (f, cmap, in[rowa], img->width, ximg, in_y++);
9808
9809 for (x = 0; x < img->width - 2; ++x)
9810 {
9811 int r = in[rowa][x].red + mv2 - in[rowb][x + 2].red;
9812 int g = in[rowa][x].green + mv2 - in[rowb][x + 2].green;
9813 int b = in[rowa][x].blue + mv2 - in[rowb][x + 2].blue;
9814
9815 out[x + 1] = lookup_rgb_color (f, r & 0xffff, g & 0xffff,
9816 b & 0xffff);
9817 }
9818
9819 x_laplace_write_row (f, out, img->width, oimg, out_y++);
9820 }
9821
9822 /* Write last line, all zeros. */
9823 for (x = 0; x < img->width; ++x)
9824 out[x] = pixel;
9825 x_laplace_write_row (f, out, img->width, oimg, out_y);
9826
9827 /* Free the input image, and free resources of IMG. */
9828 XDestroyImage (ximg);
9829 x_clear_image (f, img);
9830
9831 /* Put the output image into pixmap, and destroy it. */
9832 x_put_x_image (f, oimg, pixmap, img->width, img->height);
9833 x_destroy_x_image (oimg);
9834
9835 /* Remember new pixmap and colors in IMG. */
9836 img->pixmap = pixmap;
9837 img->colors = colors_in_color_table (&img->ncolors);
9838 free_color_table ();
9839
9840 UNBLOCK_INPUT;
9841 #endif /* TODO */
9842 }
9843
9844
9845 /* Build a mask for image IMG which is used on frame F. FILE is the
9846 name of an image file, for error messages. HOW determines how to
9847 determine the background color of IMG. If it is a list '(R G B)',
9848 with R, G, and B being integers >= 0, take that as the color of the
9849 background. Otherwise, determine the background color of IMG
9850 heuristically. Value is non-zero if successful. */
9851
9852 static int
9853 x_build_heuristic_mask (f, img, how)
9854 struct frame *f;
9855 struct image *img;
9856 Lisp_Object how;
9857 {
9858 #if 0 /* TODO : W32 version */
9859 Display *dpy = FRAME_W32_DISPLAY (f);
9860 XImage *ximg, *mask_img;
9861 int x, y, rc, look_at_corners_p;
9862 unsigned long bg;
9863
9864 BLOCK_INPUT;
9865
9866 /* Create an image and pixmap serving as mask. */
9867 rc = x_create_x_image_and_pixmap (f, img->width, img->height, 1,
9868 &mask_img, &img->mask);
9869 if (!rc)
9870 {
9871 UNBLOCK_INPUT;
9872 return 0;
9873 }
9874
9875 /* Get the X image of IMG->pixmap. */
9876 ximg = XGetImage (dpy, img->pixmap, 0, 0, img->width, img->height,
9877 ~0, ZPixmap);
9878
9879 /* Determine the background color of ximg. If HOW is `(R G B)'
9880 take that as color. Otherwise, try to determine the color
9881 heuristically. */
9882 look_at_corners_p = 1;
9883
9884 if (CONSP (how))
9885 {
9886 int rgb[3], i = 0;
9887
9888 while (i < 3
9889 && CONSP (how)
9890 && NATNUMP (XCAR (how)))
9891 {
9892 rgb[i] = XFASTINT (XCAR (how)) & 0xffff;
9893 how = XCDR (how);
9894 }
9895
9896 if (i == 3 && NILP (how))
9897 {
9898 char color_name[30];
9899 XColor exact, color;
9900 Colormap cmap;
9901
9902 sprintf (color_name, "#%04x%04x%04x", rgb[0], rgb[1], rgb[2]);
9903
9904 cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
9905 if (XLookupColor (dpy, cmap, color_name, &exact, &color))
9906 {
9907 bg = color.pixel;
9908 look_at_corners_p = 0;
9909 }
9910 }
9911 }
9912
9913 if (look_at_corners_p)
9914 {
9915 unsigned long corners[4];
9916 int i, best_count;
9917
9918 /* Get the colors at the corners of ximg. */
9919 corners[0] = XGetPixel (ximg, 0, 0);
9920 corners[1] = XGetPixel (ximg, img->width - 1, 0);
9921 corners[2] = XGetPixel (ximg, img->width - 1, img->height - 1);
9922 corners[3] = XGetPixel (ximg, 0, img->height - 1);
9923
9924 /* Choose the most frequently found color as background. */
9925 for (i = best_count = 0; i < 4; ++i)
9926 {
9927 int j, n;
9928
9929 for (j = n = 0; j < 4; ++j)
9930 if (corners[i] == corners[j])
9931 ++n;
9932
9933 if (n > best_count)
9934 bg = corners[i], best_count = n;
9935 }
9936 }
9937
9938 /* Set all bits in mask_img to 1 whose color in ximg is different
9939 from the background color bg. */
9940 for (y = 0; y < img->height; ++y)
9941 for (x = 0; x < img->width; ++x)
9942 XPutPixel (mask_img, x, y, XGetPixel (ximg, x, y) != bg);
9943
9944 /* Put mask_img into img->mask. */
9945 x_put_x_image (f, mask_img, img->mask, img->width, img->height);
9946 x_destroy_x_image (mask_img);
9947 XDestroyImage (ximg);
9948
9949 UNBLOCK_INPUT;
9950 #endif /* TODO */
9951
9952 return 1;
9953 }
9954
9955
9956 \f
9957 /***********************************************************************
9958 PBM (mono, gray, color)
9959 ***********************************************************************/
9960 #ifdef HAVE_PBM
9961
9962 static int pbm_image_p P_ ((Lisp_Object object));
9963 static int pbm_load P_ ((struct frame *f, struct image *img));
9964 static int pbm_scan_number P_ ((unsigned char **, unsigned char *));
9965
9966 /* The symbol `pbm' identifying images of this type. */
9967
9968 Lisp_Object Qpbm;
9969
9970 /* Indices of image specification fields in gs_format, below. */
9971
9972 enum pbm_keyword_index
9973 {
9974 PBM_TYPE,
9975 PBM_FILE,
9976 PBM_DATA,
9977 PBM_ASCENT,
9978 PBM_MARGIN,
9979 PBM_RELIEF,
9980 PBM_ALGORITHM,
9981 PBM_HEURISTIC_MASK,
9982 PBM_LAST
9983 };
9984
9985 /* Vector of image_keyword structures describing the format
9986 of valid user-defined image specifications. */
9987
9988 static struct image_keyword pbm_format[PBM_LAST] =
9989 {
9990 {":type", IMAGE_SYMBOL_VALUE, 1},
9991 {":file", IMAGE_STRING_VALUE, 0},
9992 {":data", IMAGE_STRING_VALUE, 0},
9993 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
9994 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
9995 {":relief", IMAGE_INTEGER_VALUE, 0},
9996 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
9997 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
9998 };
9999
10000 /* Structure describing the image type `pbm'. */
10001
10002 static struct image_type pbm_type =
10003 {
10004 &Qpbm,
10005 pbm_image_p,
10006 pbm_load,
10007 x_clear_image,
10008 NULL
10009 };
10010
10011
10012 /* Return non-zero if OBJECT is a valid PBM image specification. */
10013
10014 static int
10015 pbm_image_p (object)
10016 Lisp_Object object;
10017 {
10018 struct image_keyword fmt[PBM_LAST];
10019
10020 bcopy (pbm_format, fmt, sizeof fmt);
10021
10022 if (!parse_image_spec (object, fmt, PBM_LAST, Qpbm)
10023 || (fmt[PBM_ASCENT].count
10024 && XFASTINT (fmt[PBM_ASCENT].value) > 100))
10025 return 0;
10026
10027 /* Must specify either :data or :file. */
10028 return fmt[PBM_DATA].count + fmt[PBM_FILE].count == 1;
10029 }
10030
10031
10032 /* Scan a decimal number from *S and return it. Advance *S while
10033 reading the number. END is the end of the string. Value is -1 at
10034 end of input. */
10035
10036 static int
10037 pbm_scan_number (s, end)
10038 unsigned char **s, *end;
10039 {
10040 int c, val = -1;
10041
10042 while (*s < end)
10043 {
10044 /* Skip white-space. */
10045 while (*s < end && (c = *(*s)++, isspace (c)))
10046 ;
10047
10048 if (c == '#')
10049 {
10050 /* Skip comment to end of line. */
10051 while (*s < end && (c = *(*s)++, c != '\n'))
10052 ;
10053 }
10054 else if (isdigit (c))
10055 {
10056 /* Read decimal number. */
10057 val = c - '0';
10058 while (*s < end && (c = *(*s)++, isdigit (c)))
10059 val = 10 * val + c - '0';
10060 break;
10061 }
10062 else
10063 break;
10064 }
10065
10066 return val;
10067 }
10068
10069
10070 /* Read FILE into memory. Value is a pointer to a buffer allocated
10071 with xmalloc holding FILE's contents. Value is null if an error
10072 occured. *SIZE is set to the size of the file. */
10073
10074 static char *
10075 pbm_read_file (file, size)
10076 Lisp_Object file;
10077 int *size;
10078 {
10079 FILE *fp = NULL;
10080 char *buf = NULL;
10081 struct stat st;
10082
10083 if (stat (XSTRING (file)->data, &st) == 0
10084 && (fp = fopen (XSTRING (file)->data, "r")) != NULL
10085 && (buf = (char *) xmalloc (st.st_size),
10086 fread (buf, 1, st.st_size, fp) == st.st_size))
10087 {
10088 *size = st.st_size;
10089 fclose (fp);
10090 }
10091 else
10092 {
10093 if (fp)
10094 fclose (fp);
10095 if (buf)
10096 {
10097 xfree (buf);
10098 buf = NULL;
10099 }
10100 }
10101
10102 return buf;
10103 }
10104
10105
10106 /* Load PBM image IMG for use on frame F. */
10107
10108 static int
10109 pbm_load (f, img)
10110 struct frame *f;
10111 struct image *img;
10112 {
10113 int raw_p, x, y;
10114 int width, height, max_color_idx = 0;
10115 XImage *ximg;
10116 Lisp_Object file, specified_file;
10117 enum {PBM_MONO, PBM_GRAY, PBM_COLOR} type;
10118 struct gcpro gcpro1;
10119 unsigned char *contents = NULL;
10120 unsigned char *end, *p;
10121 int size;
10122
10123 specified_file = image_spec_value (img->spec, QCfile, NULL);
10124 file = Qnil;
10125 GCPRO1 (file);
10126
10127 if (STRINGP (specified_file))
10128 {
10129 file = x_find_image_file (specified_file);
10130 if (!STRINGP (file))
10131 {
10132 image_error ("Cannot find image file `%s'", specified_file, Qnil);
10133 UNGCPRO;
10134 return 0;
10135 }
10136
10137 contents = pbm_read_file (file, &size);
10138 if (contents == NULL)
10139 {
10140 image_error ("Error reading `%s'", file, Qnil);
10141 UNGCPRO;
10142 return 0;
10143 }
10144
10145 p = contents;
10146 end = contents + size;
10147 }
10148 else
10149 {
10150 Lisp_Object data;
10151 data = image_spec_value (img->spec, QCdata, NULL);
10152 p = XSTRING (data)->data;
10153 end = p + STRING_BYTES (XSTRING (data));
10154 }
10155
10156 /* Check magic number. */
10157 if (end - p < 2 || *p++ != 'P')
10158 {
10159 image_error ("Not a PBM image: `%s'", img->spec, Qnil);
10160 error:
10161 xfree (contents);
10162 UNGCPRO;
10163 return 0;
10164 }
10165
10166 switch (*p++)
10167 {
10168 case '1':
10169 raw_p = 0, type = PBM_MONO;
10170 break;
10171
10172 case '2':
10173 raw_p = 0, type = PBM_GRAY;
10174 break;
10175
10176 case '3':
10177 raw_p = 0, type = PBM_COLOR;
10178 break;
10179
10180 case '4':
10181 raw_p = 1, type = PBM_MONO;
10182 break;
10183
10184 case '5':
10185 raw_p = 1, type = PBM_GRAY;
10186 break;
10187
10188 case '6':
10189 raw_p = 1, type = PBM_COLOR;
10190 break;
10191
10192 default:
10193 image_error ("Not a PBM image: `%s'", img->spec, Qnil);
10194 goto error;
10195 }
10196
10197 /* Read width, height, maximum color-component. Characters
10198 starting with `#' up to the end of a line are ignored. */
10199 width = pbm_scan_number (&p, end);
10200 height = pbm_scan_number (&p, end);
10201
10202 if (type != PBM_MONO)
10203 {
10204 max_color_idx = pbm_scan_number (&p, end);
10205 if (raw_p && max_color_idx > 255)
10206 max_color_idx = 255;
10207 }
10208
10209 if (width < 0
10210 || height < 0
10211 || (type != PBM_MONO && max_color_idx < 0))
10212 goto error;
10213
10214 BLOCK_INPUT;
10215 if (!x_create_x_image_and_pixmap (f, width, height, 0,
10216 &ximg, &img->pixmap))
10217 {
10218 UNBLOCK_INPUT;
10219 goto error;
10220 }
10221
10222 /* Initialize the color hash table. */
10223 init_color_table ();
10224
10225 if (type == PBM_MONO)
10226 {
10227 int c = 0, g;
10228
10229 for (y = 0; y < height; ++y)
10230 for (x = 0; x < width; ++x)
10231 {
10232 if (raw_p)
10233 {
10234 if ((x & 7) == 0)
10235 c = *p++;
10236 g = c & 0x80;
10237 c <<= 1;
10238 }
10239 else
10240 g = pbm_scan_number (&p, end);
10241
10242 XPutPixel (ximg, x, y, (g
10243 ? FRAME_FOREGROUND_PIXEL (f)
10244 : FRAME_BACKGROUND_PIXEL (f)));
10245 }
10246 }
10247 else
10248 {
10249 for (y = 0; y < height; ++y)
10250 for (x = 0; x < width; ++x)
10251 {
10252 int r, g, b;
10253
10254 if (type == PBM_GRAY)
10255 r = g = b = raw_p ? *p++ : pbm_scan_number (&p, end);
10256 else if (raw_p)
10257 {
10258 r = *p++;
10259 g = *p++;
10260 b = *p++;
10261 }
10262 else
10263 {
10264 r = pbm_scan_number (&p, end);
10265 g = pbm_scan_number (&p, end);
10266 b = pbm_scan_number (&p, end);
10267 }
10268
10269 if (r < 0 || g < 0 || b < 0)
10270 {
10271 xfree (ximg->data);
10272 ximg->data = NULL;
10273 XDestroyImage (ximg);
10274 UNBLOCK_INPUT;
10275 image_error ("Invalid pixel value in image `%s'",
10276 img->spec, Qnil);
10277 goto error;
10278 }
10279
10280 /* RGB values are now in the range 0..max_color_idx.
10281 Scale this to the range 0..0xffff supported by X. */
10282 r = (double) r * 65535 / max_color_idx;
10283 g = (double) g * 65535 / max_color_idx;
10284 b = (double) b * 65535 / max_color_idx;
10285 XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b));
10286 }
10287 }
10288
10289 /* Store in IMG->colors the colors allocated for the image, and
10290 free the color table. */
10291 img->colors = colors_in_color_table (&img->ncolors);
10292 free_color_table ();
10293
10294 /* Put the image into a pixmap. */
10295 x_put_x_image (f, ximg, img->pixmap, width, height);
10296 x_destroy_x_image (ximg);
10297 UNBLOCK_INPUT;
10298
10299 img->width = width;
10300 img->height = height;
10301
10302 UNGCPRO;
10303 xfree (contents);
10304 return 1;
10305 }
10306 #endif /* HAVE_PBM */
10307
10308 \f
10309 /***********************************************************************
10310 PNG
10311 ***********************************************************************/
10312
10313 #if HAVE_PNG
10314
10315 #include <png.h>
10316
10317 /* Function prototypes. */
10318
10319 static int png_image_p P_ ((Lisp_Object object));
10320 static int png_load P_ ((struct frame *f, struct image *img));
10321
10322 /* The symbol `png' identifying images of this type. */
10323
10324 Lisp_Object Qpng;
10325
10326 /* Indices of image specification fields in png_format, below. */
10327
10328 enum png_keyword_index
10329 {
10330 PNG_TYPE,
10331 PNG_DATA,
10332 PNG_FILE,
10333 PNG_ASCENT,
10334 PNG_MARGIN,
10335 PNG_RELIEF,
10336 PNG_ALGORITHM,
10337 PNG_HEURISTIC_MASK,
10338 PNG_LAST
10339 };
10340
10341 /* Vector of image_keyword structures describing the format
10342 of valid user-defined image specifications. */
10343
10344 static struct image_keyword png_format[PNG_LAST] =
10345 {
10346 {":type", IMAGE_SYMBOL_VALUE, 1},
10347 {":data", IMAGE_STRING_VALUE, 0},
10348 {":file", IMAGE_STRING_VALUE, 0},
10349 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
10350 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
10351 {":relief", IMAGE_INTEGER_VALUE, 0},
10352 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10353 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
10354 };
10355
10356 /* Structure describing the image type `png'. */
10357
10358 static struct image_type png_type =
10359 {
10360 &Qpng,
10361 png_image_p,
10362 png_load,
10363 x_clear_image,
10364 NULL
10365 };
10366
10367
10368 /* Return non-zero if OBJECT is a valid PNG image specification. */
10369
10370 static int
10371 png_image_p (object)
10372 Lisp_Object object;
10373 {
10374 struct image_keyword fmt[PNG_LAST];
10375 bcopy (png_format, fmt, sizeof fmt);
10376
10377 if (!parse_image_spec (object, fmt, PNG_LAST, Qpng)
10378 || (fmt[PNG_ASCENT].count
10379 && XFASTINT (fmt[PNG_ASCENT].value) > 100))
10380 return 0;
10381
10382 /* Must specify either the :data or :file keyword. */
10383 return fmt[PNG_FILE].count + fmt[PNG_DATA].count == 1;
10384 }
10385
10386
10387 /* Error and warning handlers installed when the PNG library
10388 is initialized. */
10389
10390 static void
10391 my_png_error (png_ptr, msg)
10392 png_struct *png_ptr;
10393 char *msg;
10394 {
10395 xassert (png_ptr != NULL);
10396 image_error ("PNG error: %s", build_string (msg), Qnil);
10397 longjmp (png_ptr->jmpbuf, 1);
10398 }
10399
10400
10401 static void
10402 my_png_warning (png_ptr, msg)
10403 png_struct *png_ptr;
10404 char *msg;
10405 {
10406 xassert (png_ptr != NULL);
10407 image_error ("PNG warning: %s", build_string (msg), Qnil);
10408 }
10409
10410 /* Memory source for PNG decoding. */
10411
10412 struct png_memory_storage
10413 {
10414 unsigned char *bytes; /* The data */
10415 size_t len; /* How big is it? */
10416 int index; /* Where are we? */
10417 };
10418
10419
10420 /* Function set as reader function when reading PNG image from memory.
10421 PNG_PTR is a pointer to the PNG control structure. Copy LENGTH
10422 bytes from the input to DATA. */
10423
10424 static void
10425 png_read_from_memory (png_ptr, data, length)
10426 png_structp png_ptr;
10427 png_bytep data;
10428 png_size_t length;
10429 {
10430 struct png_memory_storage *tbr
10431 = (struct png_memory_storage *) png_get_io_ptr (png_ptr);
10432
10433 if (length > tbr->len - tbr->index)
10434 png_error (png_ptr, "Read error");
10435
10436 bcopy (tbr->bytes + tbr->index, data, length);
10437 tbr->index = tbr->index + length;
10438 }
10439
10440 /* Load PNG image IMG for use on frame F. Value is non-zero if
10441 successful. */
10442
10443 static int
10444 png_load (f, img)
10445 struct frame *f;
10446 struct image *img;
10447 {
10448 Lisp_Object file, specified_file;
10449 Lisp_Object specified_data;
10450 int x, y, i;
10451 XImage *ximg, *mask_img = NULL;
10452 struct gcpro gcpro1;
10453 png_struct *png_ptr = NULL;
10454 png_info *info_ptr = NULL, *end_info = NULL;
10455 FILE *fp = NULL;
10456 png_byte sig[8];
10457 png_byte *pixels = NULL;
10458 png_byte **rows = NULL;
10459 png_uint_32 width, height;
10460 int bit_depth, color_type, interlace_type;
10461 png_byte channels;
10462 png_uint_32 row_bytes;
10463 int transparent_p;
10464 char *gamma_str;
10465 double screen_gamma, image_gamma;
10466 int intent;
10467 struct png_memory_storage tbr; /* Data to be read */
10468
10469 /* Find out what file to load. */
10470 specified_file = image_spec_value (img->spec, QCfile, NULL);
10471 specified_data = image_spec_value (img->spec, QCdata, NULL);
10472 file = Qnil;
10473 GCPRO1 (file);
10474
10475 if (NILP (specified_data))
10476 {
10477 file = x_find_image_file (specified_file);
10478 if (!STRINGP (file))
10479 {
10480 image_error ("Cannot find image file `%s'", specified_file, Qnil);
10481 UNGCPRO;
10482 return 0;
10483 }
10484
10485 /* Open the image file. */
10486 fp = fopen (XSTRING (file)->data, "rb");
10487 if (!fp)
10488 {
10489 image_error ("Cannot open image file `%s'", file, Qnil);
10490 UNGCPRO;
10491 fclose (fp);
10492 return 0;
10493 }
10494
10495 /* Check PNG signature. */
10496 if (fread (sig, 1, sizeof sig, fp) != sizeof sig
10497 || !png_check_sig (sig, sizeof sig))
10498 {
10499 image_error ("Not a PNG file:` %s'", file, Qnil);
10500 UNGCPRO;
10501 fclose (fp);
10502 return 0;
10503 }
10504 }
10505 else
10506 {
10507 /* Read from memory. */
10508 tbr.bytes = XSTRING (specified_data)->data;
10509 tbr.len = STRING_BYTES (XSTRING (specified_data));
10510 tbr.index = 0;
10511
10512 /* Check PNG signature. */
10513 if (tbr.len < sizeof sig
10514 || !png_check_sig (tbr.bytes, sizeof sig))
10515 {
10516 image_error ("Not a PNG image: `%s'", img->spec, Qnil);
10517 UNGCPRO;
10518 return 0;
10519 }
10520
10521 /* Need to skip past the signature. */
10522 tbr.bytes += sizeof (sig);
10523 }
10524
10525 /* Initialize read and info structs for PNG lib. */
10526 png_ptr = png_create_read_struct (PNG_LIBPNG_VER_STRING, NULL,
10527 my_png_error, my_png_warning);
10528 if (!png_ptr)
10529 {
10530 if (fp) fclose (fp);
10531 UNGCPRO;
10532 return 0;
10533 }
10534
10535 info_ptr = png_create_info_struct (png_ptr);
10536 if (!info_ptr)
10537 {
10538 png_destroy_read_struct (&png_ptr, NULL, NULL);
10539 if (fp) fclose (fp);
10540 UNGCPRO;
10541 return 0;
10542 }
10543
10544 end_info = png_create_info_struct (png_ptr);
10545 if (!end_info)
10546 {
10547 png_destroy_read_struct (&png_ptr, &info_ptr, NULL);
10548 if (fp) fclose (fp);
10549 UNGCPRO;
10550 return 0;
10551 }
10552
10553 /* Set error jump-back. We come back here when the PNG library
10554 detects an error. */
10555 if (setjmp (png_ptr->jmpbuf))
10556 {
10557 error:
10558 if (png_ptr)
10559 png_destroy_read_struct (&png_ptr, &info_ptr, &end_info);
10560 xfree (pixels);
10561 xfree (rows);
10562 if (fp) fclose (fp);
10563 UNGCPRO;
10564 return 0;
10565 }
10566
10567 /* Read image info. */
10568 if (!NILP (specified_data))
10569 png_set_read_fn (png_ptr, (void *) &tbr, png_read_from_memory);
10570 else
10571 png_init_io (png_ptr, fp);
10572
10573 png_set_sig_bytes (png_ptr, sizeof sig);
10574 png_read_info (png_ptr, info_ptr);
10575 png_get_IHDR (png_ptr, info_ptr, &width, &height, &bit_depth, &color_type,
10576 &interlace_type, NULL, NULL);
10577
10578 /* If image contains simply transparency data, we prefer to
10579 construct a clipping mask. */
10580 if (png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS))
10581 transparent_p = 1;
10582 else
10583 transparent_p = 0;
10584
10585 /* This function is easier to write if we only have to handle
10586 one data format: RGB or RGBA with 8 bits per channel. Let's
10587 transform other formats into that format. */
10588
10589 /* Strip more than 8 bits per channel. */
10590 if (bit_depth == 16)
10591 png_set_strip_16 (png_ptr);
10592
10593 /* Expand data to 24 bit RGB, or 8 bit grayscale, with alpha channel
10594 if available. */
10595 png_set_expand (png_ptr);
10596
10597 /* Convert grayscale images to RGB. */
10598 if (color_type == PNG_COLOR_TYPE_GRAY
10599 || color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
10600 png_set_gray_to_rgb (png_ptr);
10601
10602 /* The value 2.2 is a guess for PC monitors from PNG example.c. */
10603 gamma_str = getenv ("SCREEN_GAMMA");
10604 screen_gamma = gamma_str ? atof (gamma_str) : 2.2;
10605
10606 /* Tell the PNG lib to handle gamma correction for us. */
10607
10608 #if defined(PNG_READ_sRGB_SUPPORTED) || defined(PNG_WRITE_sRGB_SUPPORTED)
10609 if (png_get_sRGB (png_ptr, info_ptr, &intent))
10610 /* There is a special chunk in the image specifying the gamma. */
10611 png_set_sRGB (png_ptr, info_ptr, intent);
10612 else
10613 #endif
10614 if (png_get_gAMA (png_ptr, info_ptr, &image_gamma))
10615 /* Image contains gamma information. */
10616 png_set_gamma (png_ptr, screen_gamma, image_gamma);
10617 else
10618 /* Use a default of 0.5 for the image gamma. */
10619 png_set_gamma (png_ptr, screen_gamma, 0.5);
10620
10621 /* Handle alpha channel by combining the image with a background
10622 color. Do this only if a real alpha channel is supplied. For
10623 simple transparency, we prefer a clipping mask. */
10624 if (!transparent_p)
10625 {
10626 png_color_16 *image_background;
10627
10628 if (png_get_bKGD (png_ptr, info_ptr, &image_background))
10629 /* Image contains a background color with which to
10630 combine the image. */
10631 png_set_background (png_ptr, image_background,
10632 PNG_BACKGROUND_GAMMA_FILE, 1, 1.0);
10633 else
10634 {
10635 /* Image does not contain a background color with which
10636 to combine the image data via an alpha channel. Use
10637 the frame's background instead. */
10638 XColor color;
10639 Colormap cmap;
10640 png_color_16 frame_background;
10641
10642 BLOCK_INPUT;
10643 cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
10644 color.pixel = FRAME_BACKGROUND_PIXEL (f);
10645 XQueryColor (FRAME_W32_DISPLAY (f), cmap, &color);
10646 UNBLOCK_INPUT;
10647
10648 bzero (&frame_background, sizeof frame_background);
10649 frame_background.red = color.red;
10650 frame_background.green = color.green;
10651 frame_background.blue = color.blue;
10652
10653 png_set_background (png_ptr, &frame_background,
10654 PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0);
10655 }
10656 }
10657
10658 /* Update info structure. */
10659 png_read_update_info (png_ptr, info_ptr);
10660
10661 /* Get number of channels. Valid values are 1 for grayscale images
10662 and images with a palette, 2 for grayscale images with transparency
10663 information (alpha channel), 3 for RGB images, and 4 for RGB
10664 images with alpha channel, i.e. RGBA. If conversions above were
10665 sufficient we should only have 3 or 4 channels here. */
10666 channels = png_get_channels (png_ptr, info_ptr);
10667 xassert (channels == 3 || channels == 4);
10668
10669 /* Number of bytes needed for one row of the image. */
10670 row_bytes = png_get_rowbytes (png_ptr, info_ptr);
10671
10672 /* Allocate memory for the image. */
10673 pixels = (png_byte *) xmalloc (row_bytes * height * sizeof *pixels);
10674 rows = (png_byte **) xmalloc (height * sizeof *rows);
10675 for (i = 0; i < height; ++i)
10676 rows[i] = pixels + i * row_bytes;
10677
10678 /* Read the entire image. */
10679 png_read_image (png_ptr, rows);
10680 png_read_end (png_ptr, info_ptr);
10681 if (fp)
10682 {
10683 fclose (fp);
10684 fp = NULL;
10685 }
10686
10687 BLOCK_INPUT;
10688
10689 /* Create the X image and pixmap. */
10690 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg,
10691 &img->pixmap))
10692 {
10693 UNBLOCK_INPUT;
10694 goto error;
10695 }
10696
10697 /* Create an image and pixmap serving as mask if the PNG image
10698 contains an alpha channel. */
10699 if (channels == 4
10700 && !transparent_p
10701 && !x_create_x_image_and_pixmap (f, width, height, 1,
10702 &mask_img, &img->mask))
10703 {
10704 x_destroy_x_image (ximg);
10705 XFreePixmap (FRAME_W32_DISPLAY (f), img->pixmap);
10706 img->pixmap = 0;
10707 UNBLOCK_INPUT;
10708 goto error;
10709 }
10710
10711 /* Fill the X image and mask from PNG data. */
10712 init_color_table ();
10713
10714 for (y = 0; y < height; ++y)
10715 {
10716 png_byte *p = rows[y];
10717
10718 for (x = 0; x < width; ++x)
10719 {
10720 unsigned r, g, b;
10721
10722 r = *p++ << 8;
10723 g = *p++ << 8;
10724 b = *p++ << 8;
10725 XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b));
10726
10727 /* An alpha channel, aka mask channel, associates variable
10728 transparency with an image. Where other image formats
10729 support binary transparency---fully transparent or fully
10730 opaque---PNG allows up to 254 levels of partial transparency.
10731 The PNG library implements partial transparency by combining
10732 the image with a specified background color.
10733
10734 I'm not sure how to handle this here nicely: because the
10735 background on which the image is displayed may change, for
10736 real alpha channel support, it would be necessary to create
10737 a new image for each possible background.
10738
10739 What I'm doing now is that a mask is created if we have
10740 boolean transparency information. Otherwise I'm using
10741 the frame's background color to combine the image with. */
10742
10743 if (channels == 4)
10744 {
10745 if (mask_img)
10746 XPutPixel (mask_img, x, y, *p > 0);
10747 ++p;
10748 }
10749 }
10750 }
10751
10752 /* Remember colors allocated for this image. */
10753 img->colors = colors_in_color_table (&img->ncolors);
10754 free_color_table ();
10755
10756 /* Clean up. */
10757 png_destroy_read_struct (&png_ptr, &info_ptr, &end_info);
10758 xfree (rows);
10759 xfree (pixels);
10760
10761 img->width = width;
10762 img->height = height;
10763
10764 /* Put the image into the pixmap, then free the X image and its buffer. */
10765 x_put_x_image (f, ximg, img->pixmap, width, height);
10766 x_destroy_x_image (ximg);
10767
10768 /* Same for the mask. */
10769 if (mask_img)
10770 {
10771 x_put_x_image (f, mask_img, img->mask, img->width, img->height);
10772 x_destroy_x_image (mask_img);
10773 }
10774
10775 UNBLOCK_INPUT;
10776 UNGCPRO;
10777 return 1;
10778 }
10779
10780 #endif /* HAVE_PNG != 0 */
10781
10782
10783 \f
10784 /***********************************************************************
10785 JPEG
10786 ***********************************************************************/
10787
10788 #if HAVE_JPEG
10789
10790 /* Work around a warning about HAVE_STDLIB_H being redefined in
10791 jconfig.h. */
10792 #ifdef HAVE_STDLIB_H
10793 #define HAVE_STDLIB_H_1
10794 #undef HAVE_STDLIB_H
10795 #endif /* HAVE_STLIB_H */
10796
10797 #include <jpeglib.h>
10798 #include <jerror.h>
10799 #include <setjmp.h>
10800
10801 #ifdef HAVE_STLIB_H_1
10802 #define HAVE_STDLIB_H 1
10803 #endif
10804
10805 static int jpeg_image_p P_ ((Lisp_Object object));
10806 static int jpeg_load P_ ((struct frame *f, struct image *img));
10807
10808 /* The symbol `jpeg' identifying images of this type. */
10809
10810 Lisp_Object Qjpeg;
10811
10812 /* Indices of image specification fields in gs_format, below. */
10813
10814 enum jpeg_keyword_index
10815 {
10816 JPEG_TYPE,
10817 JPEG_DATA,
10818 JPEG_FILE,
10819 JPEG_ASCENT,
10820 JPEG_MARGIN,
10821 JPEG_RELIEF,
10822 JPEG_ALGORITHM,
10823 JPEG_HEURISTIC_MASK,
10824 JPEG_LAST
10825 };
10826
10827 /* Vector of image_keyword structures describing the format
10828 of valid user-defined image specifications. */
10829
10830 static struct image_keyword jpeg_format[JPEG_LAST] =
10831 {
10832 {":type", IMAGE_SYMBOL_VALUE, 1},
10833 {":data", IMAGE_STRING_VALUE, 0},
10834 {":file", IMAGE_STRING_VALUE, 0},
10835 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
10836 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
10837 {":relief", IMAGE_INTEGER_VALUE, 0},
10838 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10839 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
10840 };
10841
10842 /* Structure describing the image type `jpeg'. */
10843
10844 static struct image_type jpeg_type =
10845 {
10846 &Qjpeg,
10847 jpeg_image_p,
10848 jpeg_load,
10849 x_clear_image,
10850 NULL
10851 };
10852
10853
10854 /* Return non-zero if OBJECT is a valid JPEG image specification. */
10855
10856 static int
10857 jpeg_image_p (object)
10858 Lisp_Object object;
10859 {
10860 struct image_keyword fmt[JPEG_LAST];
10861
10862 bcopy (jpeg_format, fmt, sizeof fmt);
10863
10864 if (!parse_image_spec (object, fmt, JPEG_LAST, Qjpeg)
10865 || (fmt[JPEG_ASCENT].count
10866 && XFASTINT (fmt[JPEG_ASCENT].value) > 100))
10867 return 0;
10868
10869 /* Must specify either the :data or :file keyword. */
10870 return fmt[JPEG_FILE].count + fmt[JPEG_DATA].count == 1;
10871 }
10872
10873
10874 struct my_jpeg_error_mgr
10875 {
10876 struct jpeg_error_mgr pub;
10877 jmp_buf setjmp_buffer;
10878 };
10879
10880 static void
10881 my_error_exit (cinfo)
10882 j_common_ptr cinfo;
10883 {
10884 struct my_jpeg_error_mgr *mgr = (struct my_jpeg_error_mgr *) cinfo->err;
10885 longjmp (mgr->setjmp_buffer, 1);
10886 }
10887
10888 /* Init source method for JPEG data source manager. Called by
10889 jpeg_read_header() before any data is actually read. See
10890 libjpeg.doc from the JPEG lib distribution. */
10891
10892 static void
10893 our_init_source (cinfo)
10894 j_decompress_ptr cinfo;
10895 {
10896 }
10897
10898
10899 /* Fill input buffer method for JPEG data source manager. Called
10900 whenever more data is needed. We read the whole image in one step,
10901 so this only adds a fake end of input marker at the end. */
10902
10903 static boolean
10904 our_fill_input_buffer (cinfo)
10905 j_decompress_ptr cinfo;
10906 {
10907 /* Insert a fake EOI marker. */
10908 struct jpeg_source_mgr *src = cinfo->src;
10909 static JOCTET buffer[2];
10910
10911 buffer[0] = (JOCTET) 0xFF;
10912 buffer[1] = (JOCTET) JPEG_EOI;
10913
10914 src->next_input_byte = buffer;
10915 src->bytes_in_buffer = 2;
10916 return TRUE;
10917 }
10918
10919
10920 /* Method to skip over NUM_BYTES bytes in the image data. CINFO->src
10921 is the JPEG data source manager. */
10922
10923 static void
10924 our_skip_input_data (cinfo, num_bytes)
10925 j_decompress_ptr cinfo;
10926 long num_bytes;
10927 {
10928 struct jpeg_source_mgr *src = (struct jpeg_source_mgr *) cinfo->src;
10929
10930 if (src)
10931 {
10932 if (num_bytes > src->bytes_in_buffer)
10933 ERREXIT (cinfo, JERR_INPUT_EOF);
10934
10935 src->bytes_in_buffer -= num_bytes;
10936 src->next_input_byte += num_bytes;
10937 }
10938 }
10939
10940
10941 /* Method to terminate data source. Called by
10942 jpeg_finish_decompress() after all data has been processed. */
10943
10944 static void
10945 our_term_source (cinfo)
10946 j_decompress_ptr cinfo;
10947 {
10948 }
10949
10950
10951 /* Set up the JPEG lib for reading an image from DATA which contains
10952 LEN bytes. CINFO is the decompression info structure created for
10953 reading the image. */
10954
10955 static void
10956 jpeg_memory_src (cinfo, data, len)
10957 j_decompress_ptr cinfo;
10958 JOCTET *data;
10959 unsigned int len;
10960 {
10961 struct jpeg_source_mgr *src;
10962
10963 if (cinfo->src == NULL)
10964 {
10965 /* First time for this JPEG object? */
10966 cinfo->src = (struct jpeg_source_mgr *)
10967 (*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT,
10968 sizeof (struct jpeg_source_mgr));
10969 src = (struct jpeg_source_mgr *) cinfo->src;
10970 src->next_input_byte = data;
10971 }
10972
10973 src = (struct jpeg_source_mgr *) cinfo->src;
10974 src->init_source = our_init_source;
10975 src->fill_input_buffer = our_fill_input_buffer;
10976 src->skip_input_data = our_skip_input_data;
10977 src->resync_to_restart = jpeg_resync_to_restart; /* Use default method. */
10978 src->term_source = our_term_source;
10979 src->bytes_in_buffer = len;
10980 src->next_input_byte = data;
10981 }
10982
10983
10984 /* Load image IMG for use on frame F. Patterned after example.c
10985 from the JPEG lib. */
10986
10987 static int
10988 jpeg_load (f, img)
10989 struct frame *f;
10990 struct image *img;
10991 {
10992 struct jpeg_decompress_struct cinfo;
10993 struct my_jpeg_error_mgr mgr;
10994 Lisp_Object file, specified_file;
10995 Lisp_Object specified_data;
10996 FILE *fp = NULL;
10997 JSAMPARRAY buffer;
10998 int row_stride, x, y;
10999 XImage *ximg = NULL;
11000 int rc;
11001 unsigned long *colors;
11002 int width, height;
11003 struct gcpro gcpro1;
11004
11005 /* Open the JPEG file. */
11006 specified_file = image_spec_value (img->spec, QCfile, NULL);
11007 specified_data = image_spec_value (img->spec, QCdata, NULL);
11008 file = Qnil;
11009 GCPRO1 (file);
11010
11011 if (NILP (specified_data))
11012 {
11013 file = x_find_image_file (specified_file);
11014 if (!STRINGP (file))
11015 {
11016 image_error ("Cannot find image file `%s'", specified_file, Qnil);
11017 UNGCPRO;
11018 return 0;
11019 }
11020
11021 fp = fopen (XSTRING (file)->data, "r");
11022 if (fp == NULL)
11023 {
11024 image_error ("Cannot open `%s'", file, Qnil);
11025 UNGCPRO;
11026 return 0;
11027 }
11028 }
11029
11030 /* Customize libjpeg's error handling to call my_error_exit when an
11031 error is detected. This function will perform a longjmp. */
11032 mgr.pub.error_exit = my_error_exit;
11033 cinfo.err = jpeg_std_error (&mgr.pub);
11034
11035 if ((rc = setjmp (mgr.setjmp_buffer)) != 0)
11036 {
11037 if (rc == 1)
11038 {
11039 /* Called from my_error_exit. Display a JPEG error. */
11040 char buffer[JMSG_LENGTH_MAX];
11041 cinfo.err->format_message ((j_common_ptr) &cinfo, buffer);
11042 image_error ("Error reading JPEG image `%s': %s", img->spec,
11043 build_string (buffer));
11044 }
11045
11046 /* Close the input file and destroy the JPEG object. */
11047 if (fp)
11048 fclose (fp);
11049 jpeg_destroy_decompress (&cinfo);
11050
11051 BLOCK_INPUT;
11052
11053 /* If we already have an XImage, free that. */
11054 x_destroy_x_image (ximg);
11055
11056 /* Free pixmap and colors. */
11057 x_clear_image (f, img);
11058
11059 UNBLOCK_INPUT;
11060 UNGCPRO;
11061 return 0;
11062 }
11063
11064 /* Create the JPEG decompression object. Let it read from fp.
11065 Read the JPEG image header. */
11066 jpeg_create_decompress (&cinfo);
11067
11068 if (NILP (specified_data))
11069 jpeg_stdio_src (&cinfo, fp);
11070 else
11071 jpeg_memory_src (&cinfo, XSTRING (specified_data)->data,
11072 STRING_BYTES (XSTRING (specified_data)));
11073
11074 jpeg_read_header (&cinfo, TRUE);
11075
11076 /* Customize decompression so that color quantization will be used.
11077 Start decompression. */
11078 cinfo.quantize_colors = TRUE;
11079 jpeg_start_decompress (&cinfo);
11080 width = img->width = cinfo.output_width;
11081 height = img->height = cinfo.output_height;
11082
11083 BLOCK_INPUT;
11084
11085 /* Create X image and pixmap. */
11086 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg,
11087 &img->pixmap))
11088 {
11089 UNBLOCK_INPUT;
11090 longjmp (mgr.setjmp_buffer, 2);
11091 }
11092
11093 /* Allocate colors. When color quantization is used,
11094 cinfo.actual_number_of_colors has been set with the number of
11095 colors generated, and cinfo.colormap is a two-dimensional array
11096 of color indices in the range 0..cinfo.actual_number_of_colors.
11097 No more than 255 colors will be generated. */
11098 {
11099 int i, ir, ig, ib;
11100
11101 if (cinfo.out_color_components > 2)
11102 ir = 0, ig = 1, ib = 2;
11103 else if (cinfo.out_color_components > 1)
11104 ir = 0, ig = 1, ib = 0;
11105 else
11106 ir = 0, ig = 0, ib = 0;
11107
11108 /* Use the color table mechanism because it handles colors that
11109 cannot be allocated nicely. Such colors will be replaced with
11110 a default color, and we don't have to care about which colors
11111 can be freed safely, and which can't. */
11112 init_color_table ();
11113 colors = (unsigned long *) alloca (cinfo.actual_number_of_colors
11114 * sizeof *colors);
11115
11116 for (i = 0; i < cinfo.actual_number_of_colors; ++i)
11117 {
11118 /* Multiply RGB values with 255 because X expects RGB values
11119 in the range 0..0xffff. */
11120 int r = cinfo.colormap[ir][i] << 8;
11121 int g = cinfo.colormap[ig][i] << 8;
11122 int b = cinfo.colormap[ib][i] << 8;
11123 colors[i] = lookup_rgb_color (f, r, g, b);
11124 }
11125
11126 /* Remember those colors actually allocated. */
11127 img->colors = colors_in_color_table (&img->ncolors);
11128 free_color_table ();
11129 }
11130
11131 /* Read pixels. */
11132 row_stride = width * cinfo.output_components;
11133 buffer = cinfo.mem->alloc_sarray ((j_common_ptr) &cinfo, JPOOL_IMAGE,
11134 row_stride, 1);
11135 for (y = 0; y < height; ++y)
11136 {
11137 jpeg_read_scanlines (&cinfo, buffer, 1);
11138 for (x = 0; x < cinfo.output_width; ++x)
11139 XPutPixel (ximg, x, y, colors[buffer[0][x]]);
11140 }
11141
11142 /* Clean up. */
11143 jpeg_finish_decompress (&cinfo);
11144 jpeg_destroy_decompress (&cinfo);
11145 if (fp)
11146 fclose (fp);
11147
11148 /* Put the image into the pixmap. */
11149 x_put_x_image (f, ximg, img->pixmap, width, height);
11150 x_destroy_x_image (ximg);
11151 UNBLOCK_INPUT;
11152 UNGCPRO;
11153 return 1;
11154 }
11155
11156 #endif /* HAVE_JPEG */
11157
11158
11159 \f
11160 /***********************************************************************
11161 TIFF
11162 ***********************************************************************/
11163
11164 #if HAVE_TIFF
11165
11166 #include <tiffio.h>
11167
11168 static int tiff_image_p P_ ((Lisp_Object object));
11169 static int tiff_load P_ ((struct frame *f, struct image *img));
11170
11171 /* The symbol `tiff' identifying images of this type. */
11172
11173 Lisp_Object Qtiff;
11174
11175 /* Indices of image specification fields in tiff_format, below. */
11176
11177 enum tiff_keyword_index
11178 {
11179 TIFF_TYPE,
11180 TIFF_DATA,
11181 TIFF_FILE,
11182 TIFF_ASCENT,
11183 TIFF_MARGIN,
11184 TIFF_RELIEF,
11185 TIFF_ALGORITHM,
11186 TIFF_HEURISTIC_MASK,
11187 TIFF_LAST
11188 };
11189
11190 /* Vector of image_keyword structures describing the format
11191 of valid user-defined image specifications. */
11192
11193 static struct image_keyword tiff_format[TIFF_LAST] =
11194 {
11195 {":type", IMAGE_SYMBOL_VALUE, 1},
11196 {":data", IMAGE_STRING_VALUE, 0},
11197 {":file", IMAGE_STRING_VALUE, 0},
11198 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
11199 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
11200 {":relief", IMAGE_INTEGER_VALUE, 0},
11201 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
11202 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
11203 };
11204
11205 /* Structure describing the image type `tiff'. */
11206
11207 static struct image_type tiff_type =
11208 {
11209 &Qtiff,
11210 tiff_image_p,
11211 tiff_load,
11212 x_clear_image,
11213 NULL
11214 };
11215
11216
11217 /* Return non-zero if OBJECT is a valid TIFF image specification. */
11218
11219 static int
11220 tiff_image_p (object)
11221 Lisp_Object object;
11222 {
11223 struct image_keyword fmt[TIFF_LAST];
11224 bcopy (tiff_format, fmt, sizeof fmt);
11225
11226 if (!parse_image_spec (object, fmt, TIFF_LAST, Qtiff)
11227 || (fmt[TIFF_ASCENT].count
11228 && XFASTINT (fmt[TIFF_ASCENT].value) > 100))
11229 return 0;
11230
11231 /* Must specify either the :data or :file keyword. */
11232 return fmt[TIFF_FILE].count + fmt[TIFF_DATA].count == 1;
11233 }
11234
11235
11236 /* Reading from a memory buffer for TIFF images Based on the PNG
11237 memory source, but we have to provide a lot of extra functions.
11238 Blah.
11239
11240 We really only need to implement read and seek, but I am not
11241 convinced that the TIFF library is smart enough not to destroy
11242 itself if we only hand it the function pointers we need to
11243 override. */
11244
11245 typedef struct
11246 {
11247 unsigned char *bytes;
11248 size_t len;
11249 int index;
11250 }
11251 tiff_memory_source;
11252
11253 static size_t
11254 tiff_read_from_memory (data, buf, size)
11255 thandle_t data;
11256 tdata_t buf;
11257 tsize_t size;
11258 {
11259 tiff_memory_source *src = (tiff_memory_source *) data;
11260
11261 if (size > src->len - src->index)
11262 return (size_t) -1;
11263 bcopy (src->bytes + src->index, buf, size);
11264 src->index += size;
11265 return size;
11266 }
11267
11268 static size_t
11269 tiff_write_from_memory (data, buf, size)
11270 thandle_t data;
11271 tdata_t buf;
11272 tsize_t size;
11273 {
11274 return (size_t) -1;
11275 }
11276
11277 static toff_t
11278 tiff_seek_in_memory (data, off, whence)
11279 thandle_t data;
11280 toff_t off;
11281 int whence;
11282 {
11283 tiff_memory_source *src = (tiff_memory_source *) data;
11284 int idx;
11285
11286 switch (whence)
11287 {
11288 case SEEK_SET: /* Go from beginning of source. */
11289 idx = off;
11290 break;
11291
11292 case SEEK_END: /* Go from end of source. */
11293 idx = src->len + off;
11294 break;
11295
11296 case SEEK_CUR: /* Go from current position. */
11297 idx = src->index + off;
11298 break;
11299
11300 default: /* Invalid `whence'. */
11301 return -1;
11302 }
11303
11304 if (idx > src->len || idx < 0)
11305 return -1;
11306
11307 src->index = idx;
11308 return src->index;
11309 }
11310
11311 static int
11312 tiff_close_memory (data)
11313 thandle_t data;
11314 {
11315 /* NOOP */
11316 return 0;
11317 }
11318
11319 static int
11320 tiff_mmap_memory (data, pbase, psize)
11321 thandle_t data;
11322 tdata_t *pbase;
11323 toff_t *psize;
11324 {
11325 /* It is already _IN_ memory. */
11326 return 0;
11327 }
11328
11329 static void
11330 tiff_unmap_memory (data, base, size)
11331 thandle_t data;
11332 tdata_t base;
11333 toff_t size;
11334 {
11335 /* We don't need to do this. */
11336 }
11337
11338 static toff_t
11339 tiff_size_of_memory (data)
11340 thandle_t data;
11341 {
11342 return ((tiff_memory_source *) data)->len;
11343 }
11344
11345 /* Load TIFF image IMG for use on frame F. Value is non-zero if
11346 successful. */
11347
11348 static int
11349 tiff_load (f, img)
11350 struct frame *f;
11351 struct image *img;
11352 {
11353 Lisp_Object file, specified_file;
11354 Lisp_Object specified_data;
11355 TIFF *tiff;
11356 int width, height, x, y;
11357 uint32 *buf;
11358 int rc;
11359 XImage *ximg;
11360 struct gcpro gcpro1;
11361 tiff_memory_source memsrc;
11362
11363 specified_file = image_spec_value (img->spec, QCfile, NULL);
11364 specified_data = image_spec_value (img->spec, QCdata, NULL);
11365 file = Qnil;
11366 GCPRO1 (file);
11367
11368 if (NILP (specified_data))
11369 {
11370 /* Read from a file */
11371 file = x_find_image_file (specified_file);
11372 if (!STRINGP (file))
11373 {
11374 image_error ("Cannot find image file `%s'", file, Qnil);
11375 UNGCPRO;
11376 return 0;
11377 }
11378
11379 /* Try to open the image file. */
11380 tiff = TIFFOpen (XSTRING (file)->data, "r");
11381 if (tiff == NULL)
11382 {
11383 image_error ("Cannot open `%s'", file, Qnil);
11384 UNGCPRO;
11385 return 0;
11386 }
11387 }
11388 else
11389 {
11390 /* Memory source! */
11391 memsrc.bytes = XSTRING (specified_data)->data;
11392 memsrc.len = STRING_BYTES (XSTRING (specified_data));
11393 memsrc.index = 0;
11394
11395 tiff = TIFFClientOpen ("memory_source", "r", &memsrc,
11396 (TIFFReadWriteProc) tiff_read_from_memory,
11397 (TIFFReadWriteProc) tiff_write_from_memory,
11398 tiff_seek_in_memory,
11399 tiff_close_memory,
11400 tiff_size_of_memory,
11401 tiff_mmap_memory,
11402 tiff_unmap_memory);
11403
11404 if (!tiff)
11405 {
11406 image_error ("Cannot open memory source for `%s'", img->spec, Qnil);
11407 UNGCPRO;
11408 return 0;
11409 }
11410 }
11411
11412 /* Get width and height of the image, and allocate a raster buffer
11413 of width x height 32-bit values. */
11414 TIFFGetField (tiff, TIFFTAG_IMAGEWIDTH, &width);
11415 TIFFGetField (tiff, TIFFTAG_IMAGELENGTH, &height);
11416 buf = (uint32 *) xmalloc (width * height * sizeof *buf);
11417
11418 rc = TIFFReadRGBAImage (tiff, width, height, buf, 0);
11419 TIFFClose (tiff);
11420 if (!rc)
11421 {
11422 image_error ("Error reading TIFF image `%s'", img->spec, Qnil);
11423 xfree (buf);
11424 UNGCPRO;
11425 return 0;
11426 }
11427
11428 BLOCK_INPUT;
11429
11430 /* Create the X image and pixmap. */
11431 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
11432 {
11433 UNBLOCK_INPUT;
11434 xfree (buf);
11435 UNGCPRO;
11436 return 0;
11437 }
11438
11439 /* Initialize the color table. */
11440 init_color_table ();
11441
11442 /* Process the pixel raster. Origin is in the lower-left corner. */
11443 for (y = 0; y < height; ++y)
11444 {
11445 uint32 *row = buf + y * width;
11446
11447 for (x = 0; x < width; ++x)
11448 {
11449 uint32 abgr = row[x];
11450 int r = TIFFGetR (abgr) << 8;
11451 int g = TIFFGetG (abgr) << 8;
11452 int b = TIFFGetB (abgr) << 8;
11453 XPutPixel (ximg, x, height - 1 - y, lookup_rgb_color (f, r, g, b));
11454 }
11455 }
11456
11457 /* Remember the colors allocated for the image. Free the color table. */
11458 img->colors = colors_in_color_table (&img->ncolors);
11459 free_color_table ();
11460
11461 /* Put the image into the pixmap, then free the X image and its buffer. */
11462 x_put_x_image (f, ximg, img->pixmap, width, height);
11463 x_destroy_x_image (ximg);
11464 xfree (buf);
11465 UNBLOCK_INPUT;
11466
11467 img->width = width;
11468 img->height = height;
11469
11470 UNGCPRO;
11471 return 1;
11472 }
11473
11474 #endif /* HAVE_TIFF != 0 */
11475
11476
11477 \f
11478 /***********************************************************************
11479 GIF
11480 ***********************************************************************/
11481
11482 #if HAVE_GIF
11483
11484 #include <gif_lib.h>
11485
11486 static int gif_image_p P_ ((Lisp_Object object));
11487 static int gif_load P_ ((struct frame *f, struct image *img));
11488
11489 /* The symbol `gif' identifying images of this type. */
11490
11491 Lisp_Object Qgif;
11492
11493 /* Indices of image specification fields in gif_format, below. */
11494
11495 enum gif_keyword_index
11496 {
11497 GIF_TYPE,
11498 GIF_DATA,
11499 GIF_FILE,
11500 GIF_ASCENT,
11501 GIF_MARGIN,
11502 GIF_RELIEF,
11503 GIF_ALGORITHM,
11504 GIF_HEURISTIC_MASK,
11505 GIF_IMAGE,
11506 GIF_LAST
11507 };
11508
11509 /* Vector of image_keyword structures describing the format
11510 of valid user-defined image specifications. */
11511
11512 static struct image_keyword gif_format[GIF_LAST] =
11513 {
11514 {":type", IMAGE_SYMBOL_VALUE, 1},
11515 {":data", IMAGE_STRING_VALUE, 0},
11516 {":file", IMAGE_STRING_VALUE, 0},
11517 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
11518 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
11519 {":relief", IMAGE_INTEGER_VALUE, 0},
11520 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
11521 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
11522 {":image", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}
11523 };
11524
11525 /* Structure describing the image type `gif'. */
11526
11527 static struct image_type gif_type =
11528 {
11529 &Qgif,
11530 gif_image_p,
11531 gif_load,
11532 x_clear_image,
11533 NULL
11534 };
11535
11536 /* Return non-zero if OBJECT is a valid GIF image specification. */
11537
11538 static int
11539 gif_image_p (object)
11540 Lisp_Object object;
11541 {
11542 struct image_keyword fmt[GIF_LAST];
11543 bcopy (gif_format, fmt, sizeof fmt);
11544
11545 if (!parse_image_spec (object, fmt, GIF_LAST, Qgif)
11546 || (fmt[GIF_ASCENT].count
11547 && XFASTINT (fmt[GIF_ASCENT].value) > 100))
11548 return 0;
11549
11550 /* Must specify either the :data or :file keyword. */
11551 return fmt[GIF_FILE].count + fmt[GIF_DATA].count == 1;
11552 }
11553
11554 /* Reading a GIF image from memory
11555 Based on the PNG memory stuff to a certain extent. */
11556
11557 typedef struct
11558 {
11559 unsigned char *bytes;
11560 size_t len;
11561 int index;
11562 }
11563 gif_memory_source;
11564
11565 /* Make the current memory source available to gif_read_from_memory.
11566 It's done this way because not all versions of libungif support
11567 a UserData field in the GifFileType structure. */
11568 static gif_memory_source *current_gif_memory_src;
11569
11570 static int
11571 gif_read_from_memory (file, buf, len)
11572 GifFileType *file;
11573 GifByteType *buf;
11574 int len;
11575 {
11576 gif_memory_source *src = current_gif_memory_src;
11577
11578 if (len > src->len - src->index)
11579 return -1;
11580
11581 bcopy (src->bytes + src->index, buf, len);
11582 src->index += len;
11583 return len;
11584 }
11585
11586
11587 /* Load GIF image IMG for use on frame F. Value is non-zero if
11588 successful. */
11589
11590 static int
11591 gif_load (f, img)
11592 struct frame *f;
11593 struct image *img;
11594 {
11595 Lisp_Object file, specified_file;
11596 Lisp_Object specified_data;
11597 int rc, width, height, x, y, i;
11598 XImage *ximg;
11599 ColorMapObject *gif_color_map;
11600 unsigned long pixel_colors[256];
11601 GifFileType *gif;
11602 struct gcpro gcpro1;
11603 Lisp_Object image;
11604 int ino, image_left, image_top, image_width, image_height;
11605 gif_memory_source memsrc;
11606 unsigned char *raster;
11607
11608 specified_file = image_spec_value (img->spec, QCfile, NULL);
11609 specified_data = image_spec_value (img->spec, QCdata, NULL);
11610 file = Qnil;
11611 GCPRO1 (file);
11612
11613 if (NILP (specified_data))
11614 {
11615 file = x_find_image_file (specified_file);
11616 if (!STRINGP (file))
11617 {
11618 image_error ("Cannot find image file `%s'", specified_file, Qnil);
11619 UNGCPRO;
11620 return 0;
11621 }
11622
11623 /* Open the GIF file. */
11624 gif = DGifOpenFileName (XSTRING (file)->data);
11625 if (gif == NULL)
11626 {
11627 image_error ("Cannot open `%s'", file, Qnil);
11628 UNGCPRO;
11629 return 0;
11630 }
11631 }
11632 else
11633 {
11634 /* Read from memory! */
11635 current_gif_memory_src = &memsrc;
11636 memsrc.bytes = XSTRING (specified_data)->data;
11637 memsrc.len = STRING_BYTES (XSTRING (specified_data));
11638 memsrc.index = 0;
11639
11640 gif = DGifOpen(&memsrc, gif_read_from_memory);
11641 if (!gif)
11642 {
11643 image_error ("Cannot open memory source `%s'", img->spec, Qnil);
11644 UNGCPRO;
11645 return 0;
11646 }
11647 }
11648
11649 /* Read entire contents. */
11650 rc = DGifSlurp (gif);
11651 if (rc == GIF_ERROR)
11652 {
11653 image_error ("Error reading `%s'", img->spec, Qnil);
11654 DGifCloseFile (gif);
11655 UNGCPRO;
11656 return 0;
11657 }
11658
11659 image = image_spec_value (img->spec, QCindex, NULL);
11660 ino = INTEGERP (image) ? XFASTINT (image) : 0;
11661 if (ino >= gif->ImageCount)
11662 {
11663 image_error ("Invalid image number `%s' in image `%s'",
11664 image, img->spec);
11665 DGifCloseFile (gif);
11666 UNGCPRO;
11667 return 0;
11668 }
11669
11670 width = img->width = gif->SWidth;
11671 height = img->height = gif->SHeight;
11672
11673 BLOCK_INPUT;
11674
11675 /* Create the X image and pixmap. */
11676 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
11677 {
11678 UNBLOCK_INPUT;
11679 DGifCloseFile (gif);
11680 UNGCPRO;
11681 return 0;
11682 }
11683
11684 /* Allocate colors. */
11685 gif_color_map = gif->SavedImages[ino].ImageDesc.ColorMap;
11686 if (!gif_color_map)
11687 gif_color_map = gif->SColorMap;
11688 init_color_table ();
11689 bzero (pixel_colors, sizeof pixel_colors);
11690
11691 for (i = 0; i < gif_color_map->ColorCount; ++i)
11692 {
11693 int r = gif_color_map->Colors[i].Red << 8;
11694 int g = gif_color_map->Colors[i].Green << 8;
11695 int b = gif_color_map->Colors[i].Blue << 8;
11696 pixel_colors[i] = lookup_rgb_color (f, r, g, b);
11697 }
11698
11699 img->colors = colors_in_color_table (&img->ncolors);
11700 free_color_table ();
11701
11702 /* Clear the part of the screen image that are not covered by
11703 the image from the GIF file. Full animated GIF support
11704 requires more than can be done here (see the gif89 spec,
11705 disposal methods). Let's simply assume that the part
11706 not covered by a sub-image is in the frame's background color. */
11707 image_top = gif->SavedImages[ino].ImageDesc.Top;
11708 image_left = gif->SavedImages[ino].ImageDesc.Left;
11709 image_width = gif->SavedImages[ino].ImageDesc.Width;
11710 image_height = gif->SavedImages[ino].ImageDesc.Height;
11711
11712 for (y = 0; y < image_top; ++y)
11713 for (x = 0; x < width; ++x)
11714 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11715
11716 for (y = image_top + image_height; y < height; ++y)
11717 for (x = 0; x < width; ++x)
11718 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11719
11720 for (y = image_top; y < image_top + image_height; ++y)
11721 {
11722 for (x = 0; x < image_left; ++x)
11723 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11724 for (x = image_left + image_width; x < width; ++x)
11725 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11726 }
11727
11728 /* Read the GIF image into the X image. We use a local variable
11729 `raster' here because RasterBits below is a char *, and invites
11730 problems with bytes >= 0x80. */
11731 raster = (unsigned char *) gif->SavedImages[ino].RasterBits;
11732
11733 if (gif->SavedImages[ino].ImageDesc.Interlace)
11734 {
11735 static int interlace_start[] = {0, 4, 2, 1};
11736 static int interlace_increment[] = {8, 8, 4, 2};
11737 int pass, inc;
11738 int row = interlace_start[0];
11739
11740 pass = 0;
11741
11742 for (y = 0; y < image_height; y++)
11743 {
11744 if (row >= image_height)
11745 {
11746 row = interlace_start[++pass];
11747 while (row >= image_height)
11748 row = interlace_start[++pass];
11749 }
11750
11751 for (x = 0; x < image_width; x++)
11752 {
11753 int i = raster[(y * image_width) + x];
11754 XPutPixel (ximg, x + image_left, row + image_top,
11755 pixel_colors[i]);
11756 }
11757
11758 row += interlace_increment[pass];
11759 }
11760 }
11761 else
11762 {
11763 for (y = 0; y < image_height; ++y)
11764 for (x = 0; x < image_width; ++x)
11765 {
11766 int i = raster[y* image_width + x];
11767 XPutPixel (ximg, x + image_left, y + image_top, pixel_colors[i]);
11768 }
11769 }
11770
11771 DGifCloseFile (gif);
11772
11773 /* Put the image into the pixmap, then free the X image and its buffer. */
11774 x_put_x_image (f, ximg, img->pixmap, width, height);
11775 x_destroy_x_image (ximg);
11776 UNBLOCK_INPUT;
11777
11778 UNGCPRO;
11779 return 1;
11780 }
11781
11782 #endif /* HAVE_GIF != 0 */
11783
11784
11785 \f
11786 /***********************************************************************
11787 Ghostscript
11788 ***********************************************************************/
11789
11790 #ifdef HAVE_GHOSTSCRIPT
11791 static int gs_image_p P_ ((Lisp_Object object));
11792 static int gs_load P_ ((struct frame *f, struct image *img));
11793 static void gs_clear_image P_ ((struct frame *f, struct image *img));
11794
11795 /* The symbol `postscript' identifying images of this type. */
11796
11797 Lisp_Object Qpostscript;
11798
11799 /* Keyword symbols. */
11800
11801 Lisp_Object QCloader, QCbounding_box, QCpt_width, QCpt_height;
11802
11803 /* Indices of image specification fields in gs_format, below. */
11804
11805 enum gs_keyword_index
11806 {
11807 GS_TYPE,
11808 GS_PT_WIDTH,
11809 GS_PT_HEIGHT,
11810 GS_FILE,
11811 GS_LOADER,
11812 GS_BOUNDING_BOX,
11813 GS_ASCENT,
11814 GS_MARGIN,
11815 GS_RELIEF,
11816 GS_ALGORITHM,
11817 GS_HEURISTIC_MASK,
11818 GS_LAST
11819 };
11820
11821 /* Vector of image_keyword structures describing the format
11822 of valid user-defined image specifications. */
11823
11824 static struct image_keyword gs_format[GS_LAST] =
11825 {
11826 {":type", IMAGE_SYMBOL_VALUE, 1},
11827 {":pt-width", IMAGE_POSITIVE_INTEGER_VALUE, 1},
11828 {":pt-height", IMAGE_POSITIVE_INTEGER_VALUE, 1},
11829 {":file", IMAGE_STRING_VALUE, 1},
11830 {":loader", IMAGE_FUNCTION_VALUE, 0},
11831 {":bounding-box", IMAGE_DONT_CHECK_VALUE_TYPE, 1},
11832 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
11833 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
11834 {":relief", IMAGE_INTEGER_VALUE, 0},
11835 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
11836 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
11837 };
11838
11839 /* Structure describing the image type `ghostscript'. */
11840
11841 static struct image_type gs_type =
11842 {
11843 &Qpostscript,
11844 gs_image_p,
11845 gs_load,
11846 gs_clear_image,
11847 NULL
11848 };
11849
11850
11851 /* Free X resources of Ghostscript image IMG which is used on frame F. */
11852
11853 static void
11854 gs_clear_image (f, img)
11855 struct frame *f;
11856 struct image *img;
11857 {
11858 /* IMG->data.ptr_val may contain a recorded colormap. */
11859 xfree (img->data.ptr_val);
11860 x_clear_image (f, img);
11861 }
11862
11863
11864 /* Return non-zero if OBJECT is a valid Ghostscript image
11865 specification. */
11866
11867 static int
11868 gs_image_p (object)
11869 Lisp_Object object;
11870 {
11871 struct image_keyword fmt[GS_LAST];
11872 Lisp_Object tem;
11873 int i;
11874
11875 bcopy (gs_format, fmt, sizeof fmt);
11876
11877 if (!parse_image_spec (object, fmt, GS_LAST, Qpostscript)
11878 || (fmt[GS_ASCENT].count
11879 && XFASTINT (fmt[GS_ASCENT].value) > 100))
11880 return 0;
11881
11882 /* Bounding box must be a list or vector containing 4 integers. */
11883 tem = fmt[GS_BOUNDING_BOX].value;
11884 if (CONSP (tem))
11885 {
11886 for (i = 0; i < 4; ++i, tem = XCDR (tem))
11887 if (!CONSP (tem) || !INTEGERP (XCAR (tem)))
11888 return 0;
11889 if (!NILP (tem))
11890 return 0;
11891 }
11892 else if (VECTORP (tem))
11893 {
11894 if (XVECTOR (tem)->size != 4)
11895 return 0;
11896 for (i = 0; i < 4; ++i)
11897 if (!INTEGERP (XVECTOR (tem)->contents[i]))
11898 return 0;
11899 }
11900 else
11901 return 0;
11902
11903 return 1;
11904 }
11905
11906
11907 /* Load Ghostscript image IMG for use on frame F. Value is non-zero
11908 if successful. */
11909
11910 static int
11911 gs_load (f, img)
11912 struct frame *f;
11913 struct image *img;
11914 {
11915 char buffer[100];
11916 Lisp_Object window_and_pixmap_id = Qnil, loader, pt_height, pt_width;
11917 struct gcpro gcpro1, gcpro2;
11918 Lisp_Object frame;
11919 double in_width, in_height;
11920 Lisp_Object pixel_colors = Qnil;
11921
11922 /* Compute pixel size of pixmap needed from the given size in the
11923 image specification. Sizes in the specification are in pt. 1 pt
11924 = 1/72 in, xdpi and ydpi are stored in the frame's X display
11925 info. */
11926 pt_width = image_spec_value (img->spec, QCpt_width, NULL);
11927 in_width = XFASTINT (pt_width) / 72.0;
11928 img->width = in_width * FRAME_W32_DISPLAY_INFO (f)->resx;
11929 pt_height = image_spec_value (img->spec, QCpt_height, NULL);
11930 in_height = XFASTINT (pt_height) / 72.0;
11931 img->height = in_height * FRAME_W32_DISPLAY_INFO (f)->resy;
11932
11933 /* Create the pixmap. */
11934 BLOCK_INPUT;
11935 xassert (img->pixmap == 0);
11936 img->pixmap = XCreatePixmap (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
11937 img->width, img->height,
11938 DefaultDepthOfScreen (FRAME_X_SCREEN (f)));
11939 UNBLOCK_INPUT;
11940
11941 if (!img->pixmap)
11942 {
11943 image_error ("Unable to create pixmap for `%s'", img->spec, Qnil);
11944 return 0;
11945 }
11946
11947 /* Call the loader to fill the pixmap. It returns a process object
11948 if successful. We do not record_unwind_protect here because
11949 other places in redisplay like calling window scroll functions
11950 don't either. Let the Lisp loader use `unwind-protect' instead. */
11951 GCPRO2 (window_and_pixmap_id, pixel_colors);
11952
11953 sprintf (buffer, "%lu %lu",
11954 (unsigned long) FRAME_W32_WINDOW (f),
11955 (unsigned long) img->pixmap);
11956 window_and_pixmap_id = build_string (buffer);
11957
11958 sprintf (buffer, "%lu %lu",
11959 FRAME_FOREGROUND_PIXEL (f),
11960 FRAME_BACKGROUND_PIXEL (f));
11961 pixel_colors = build_string (buffer);
11962
11963 XSETFRAME (frame, f);
11964 loader = image_spec_value (img->spec, QCloader, NULL);
11965 if (NILP (loader))
11966 loader = intern ("gs-load-image");
11967
11968 img->data.lisp_val = call6 (loader, frame, img->spec,
11969 make_number (img->width),
11970 make_number (img->height),
11971 window_and_pixmap_id,
11972 pixel_colors);
11973 UNGCPRO;
11974 return PROCESSP (img->data.lisp_val);
11975 }
11976
11977
11978 /* Kill the Ghostscript process that was started to fill PIXMAP on
11979 frame F. Called from XTread_socket when receiving an event
11980 telling Emacs that Ghostscript has finished drawing. */
11981
11982 void
11983 x_kill_gs_process (pixmap, f)
11984 Pixmap pixmap;
11985 struct frame *f;
11986 {
11987 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
11988 int class, i;
11989 struct image *img;
11990
11991 /* Find the image containing PIXMAP. */
11992 for (i = 0; i < c->used; ++i)
11993 if (c->images[i]->pixmap == pixmap)
11994 break;
11995
11996 /* Kill the GS process. We should have found PIXMAP in the image
11997 cache and its image should contain a process object. */
11998 xassert (i < c->used);
11999 img = c->images[i];
12000 xassert (PROCESSP (img->data.lisp_val));
12001 Fkill_process (img->data.lisp_val, Qnil);
12002 img->data.lisp_val = Qnil;
12003
12004 /* On displays with a mutable colormap, figure out the colors
12005 allocated for the image by looking at the pixels of an XImage for
12006 img->pixmap. */
12007 class = FRAME_W32_DISPLAY_INFO (f)->visual->class;
12008 if (class != StaticColor && class != StaticGray && class != TrueColor)
12009 {
12010 XImage *ximg;
12011
12012 BLOCK_INPUT;
12013
12014 /* Try to get an XImage for img->pixmep. */
12015 ximg = XGetImage (FRAME_W32_DISPLAY (f), img->pixmap,
12016 0, 0, img->width, img->height, ~0, ZPixmap);
12017 if (ximg)
12018 {
12019 int x, y;
12020
12021 /* Initialize the color table. */
12022 init_color_table ();
12023
12024 /* For each pixel of the image, look its color up in the
12025 color table. After having done so, the color table will
12026 contain an entry for each color used by the image. */
12027 for (y = 0; y < img->height; ++y)
12028 for (x = 0; x < img->width; ++x)
12029 {
12030 unsigned long pixel = XGetPixel (ximg, x, y);
12031 lookup_pixel_color (f, pixel);
12032 }
12033
12034 /* Record colors in the image. Free color table and XImage. */
12035 img->colors = colors_in_color_table (&img->ncolors);
12036 free_color_table ();
12037 XDestroyImage (ximg);
12038
12039 #if 0 /* This doesn't seem to be the case. If we free the colors
12040 here, we get a BadAccess later in x_clear_image when
12041 freeing the colors. */
12042 /* We have allocated colors once, but Ghostscript has also
12043 allocated colors on behalf of us. So, to get the
12044 reference counts right, free them once. */
12045 if (img->ncolors)
12046 {
12047 Colormap cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
12048 XFreeColors (FRAME_W32_DISPLAY (f), cmap,
12049 img->colors, img->ncolors, 0);
12050 }
12051 #endif
12052 }
12053 else
12054 image_error ("Cannot get X image of `%s'; colors will not be freed",
12055 img->spec, Qnil);
12056
12057 UNBLOCK_INPUT;
12058 }
12059 }
12060
12061 #endif /* HAVE_GHOSTSCRIPT */
12062
12063 \f
12064 /***********************************************************************
12065 Window properties
12066 ***********************************************************************/
12067
12068 DEFUN ("x-change-window-property", Fx_change_window_property,
12069 Sx_change_window_property, 2, 3, 0,
12070 "Change window property PROP to VALUE on the X window of FRAME.\n\
12071 PROP and VALUE must be strings. FRAME nil or omitted means use the\n\
12072 selected frame. Value is VALUE.")
12073 (prop, value, frame)
12074 Lisp_Object frame, prop, value;
12075 {
12076 #if 0 /* TODO : port window properties to W32 */
12077 struct frame *f = check_x_frame (frame);
12078 Atom prop_atom;
12079
12080 CHECK_STRING (prop, 1);
12081 CHECK_STRING (value, 2);
12082
12083 BLOCK_INPUT;
12084 prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), XSTRING (prop)->data, False);
12085 XChangeProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
12086 prop_atom, XA_STRING, 8, PropModeReplace,
12087 XSTRING (value)->data, XSTRING (value)->size);
12088
12089 /* Make sure the property is set when we return. */
12090 XFlush (FRAME_W32_DISPLAY (f));
12091 UNBLOCK_INPUT;
12092
12093 #endif /* TODO */
12094
12095 return value;
12096 }
12097
12098
12099 DEFUN ("x-delete-window-property", Fx_delete_window_property,
12100 Sx_delete_window_property, 1, 2, 0,
12101 "Remove window property PROP from X window of FRAME.\n\
12102 FRAME nil or omitted means use the selected frame. Value is PROP.")
12103 (prop, frame)
12104 Lisp_Object prop, frame;
12105 {
12106 #if 0 /* TODO : port window properties to W32 */
12107
12108 struct frame *f = check_x_frame (frame);
12109 Atom prop_atom;
12110
12111 CHECK_STRING (prop, 1);
12112 BLOCK_INPUT;
12113 prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), XSTRING (prop)->data, False);
12114 XDeleteProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), prop_atom);
12115
12116 /* Make sure the property is removed when we return. */
12117 XFlush (FRAME_W32_DISPLAY (f));
12118 UNBLOCK_INPUT;
12119 #endif /* TODO */
12120
12121 return prop;
12122 }
12123
12124
12125 DEFUN ("x-window-property", Fx_window_property, Sx_window_property,
12126 1, 2, 0,
12127 "Value is the value of window property PROP on FRAME.\n\
12128 If FRAME is nil or omitted, use the selected frame. Value is nil\n\
12129 if FRAME hasn't a property with name PROP or if PROP has no string\n\
12130 value.")
12131 (prop, frame)
12132 Lisp_Object prop, frame;
12133 {
12134 #if 0 /* TODO : port window properties to W32 */
12135
12136 struct frame *f = check_x_frame (frame);
12137 Atom prop_atom;
12138 int rc;
12139 Lisp_Object prop_value = Qnil;
12140 char *tmp_data = NULL;
12141 Atom actual_type;
12142 int actual_format;
12143 unsigned long actual_size, bytes_remaining;
12144
12145 CHECK_STRING (prop, 1);
12146 BLOCK_INPUT;
12147 prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), XSTRING (prop)->data, False);
12148 rc = XGetWindowProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
12149 prop_atom, 0, 0, False, XA_STRING,
12150 &actual_type, &actual_format, &actual_size,
12151 &bytes_remaining, (unsigned char **) &tmp_data);
12152 if (rc == Success)
12153 {
12154 int size = bytes_remaining;
12155
12156 XFree (tmp_data);
12157 tmp_data = NULL;
12158
12159 rc = XGetWindowProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
12160 prop_atom, 0, bytes_remaining,
12161 False, XA_STRING,
12162 &actual_type, &actual_format,
12163 &actual_size, &bytes_remaining,
12164 (unsigned char **) &tmp_data);
12165 if (rc == Success)
12166 prop_value = make_string (tmp_data, size);
12167
12168 XFree (tmp_data);
12169 }
12170
12171 UNBLOCK_INPUT;
12172
12173 return prop_value;
12174
12175 #endif /* TODO */
12176 return Qnil;
12177 }
12178
12179
12180 \f
12181 /***********************************************************************
12182 Busy cursor
12183 ***********************************************************************/
12184
12185 /* If non-null, an asynchronous timer that, when it expires, displays
12186 an hourglass cursor on all frames. */
12187
12188 static struct atimer *hourglass_atimer;
12189
12190 /* Non-zero means an hourglass cursor is currently shown. */
12191
12192 static int hourglass_shown_p;
12193
12194 /* Number of seconds to wait before displaying an hourglass cursor. */
12195
12196 static Lisp_Object Vhourglass_delay;
12197
12198 /* Default number of seconds to wait before displaying an hourglass
12199 cursor. */
12200
12201 #define DEFAULT_HOURGLASS_DELAY 1
12202
12203 /* Function prototypes. */
12204
12205 static void show_hourglass P_ ((struct atimer *));
12206 static void hide_hourglass P_ ((void));
12207
12208
12209 /* Cancel a currently active hourglass timer, and start a new one. */
12210
12211 void
12212 start_hourglass ()
12213 {
12214 #if 0 /* TODO: cursor shape changes. */
12215 EMACS_TIME delay;
12216 int secs, usecs = 0;
12217
12218 cancel_hourglass ();
12219
12220 if (INTEGERP (Vhourglass_delay)
12221 && XINT (Vhourglass_delay) > 0)
12222 secs = XFASTINT (Vhourglass_delay);
12223 else if (FLOATP (Vhourglass_delay)
12224 && XFLOAT_DATA (Vhourglass_delay) > 0)
12225 {
12226 Lisp_Object tem;
12227 tem = Ftruncate (Vhourglass_delay, Qnil);
12228 secs = XFASTINT (tem);
12229 usecs = (XFLOAT_DATA (Vhourglass_delay) - secs) * 1000000;
12230 }
12231 else
12232 secs = DEFAULT_HOURGLASS_DELAY;
12233
12234 EMACS_SET_SECS_USECS (delay, secs, usecs);
12235 hourglass_atimer = start_atimer (ATIMER_RELATIVE, delay,
12236 show_hourglass, NULL);
12237 #endif
12238 }
12239
12240
12241 /* Cancel the hourglass cursor timer if active, hide an hourglass
12242 cursor if shown. */
12243
12244 void
12245 cancel_hourglass ()
12246 {
12247 if (hourglass_atimer)
12248 {
12249 cancel_atimer (hourglass_atimer);
12250 hourglass_atimer = NULL;
12251 }
12252
12253 if (hourglass_shown_p)
12254 hide_hourglass ();
12255 }
12256
12257
12258 /* Timer function of hourglass_atimer. TIMER is equal to
12259 hourglass_atimer.
12260
12261 Display an hourglass cursor on all frames by mapping the frames'
12262 hourglass_window. Set the hourglass_p flag in the frames'
12263 output_data.x structure to indicate that an hourglass cursor is
12264 shown on the frames. */
12265
12266 static void
12267 show_hourglass (timer)
12268 struct atimer *timer;
12269 {
12270 #if 0 /* TODO: cursor shape changes. */
12271 /* The timer implementation will cancel this timer automatically
12272 after this function has run. Set hourglass_atimer to null
12273 so that we know the timer doesn't have to be canceled. */
12274 hourglass_atimer = NULL;
12275
12276 if (!hourglass_shown_p)
12277 {
12278 Lisp_Object rest, frame;
12279
12280 BLOCK_INPUT;
12281
12282 FOR_EACH_FRAME (rest, frame)
12283 if (FRAME_W32_P (XFRAME (frame)))
12284 {
12285 struct frame *f = XFRAME (frame);
12286
12287 f->output_data.w32->hourglass_p = 1;
12288
12289 if (!f->output_data.w32->hourglass_window)
12290 {
12291 unsigned long mask = CWCursor;
12292 XSetWindowAttributes attrs;
12293
12294 attrs.cursor = f->output_data.w32->hourglass_cursor;
12295
12296 f->output_data.w32->hourglass_window
12297 = XCreateWindow (FRAME_X_DISPLAY (f),
12298 FRAME_OUTER_WINDOW (f),
12299 0, 0, 32000, 32000, 0, 0,
12300 InputOnly,
12301 CopyFromParent,
12302 mask, &attrs);
12303 }
12304
12305 XMapRaised (FRAME_X_DISPLAY (f),
12306 f->output_data.w32->hourglass_window);
12307 XFlush (FRAME_X_DISPLAY (f));
12308 }
12309
12310 hourglass_shown_p = 1;
12311 UNBLOCK_INPUT;
12312 }
12313 #endif
12314 }
12315
12316
12317 /* Hide the hourglass cursor on all frames, if it is currently shown. */
12318
12319 static void
12320 hide_hourglass ()
12321 {
12322 #if 0 /* TODO: cursor shape changes. */
12323 if (hourglass_shown_p)
12324 {
12325 Lisp_Object rest, frame;
12326
12327 BLOCK_INPUT;
12328 FOR_EACH_FRAME (rest, frame)
12329 {
12330 struct frame *f = XFRAME (frame);
12331
12332 if (FRAME_W32_P (f)
12333 /* Watch out for newly created frames. */
12334 && f->output_data.x->hourglass_window)
12335 {
12336 XUnmapWindow (FRAME_X_DISPLAY (f),
12337 f->output_data.x->hourglass_window);
12338 /* Sync here because XTread_socket looks at the
12339 hourglass_p flag that is reset to zero below. */
12340 XSync (FRAME_X_DISPLAY (f), False);
12341 f->output_data.x->hourglass_p = 0;
12342 }
12343 }
12344
12345 hourglass_shown_p = 0;
12346 UNBLOCK_INPUT;
12347 }
12348 #endif
12349 }
12350
12351
12352 \f
12353 /***********************************************************************
12354 Tool tips
12355 ***********************************************************************/
12356
12357 static Lisp_Object x_create_tip_frame P_ ((struct w32_display_info *,
12358 Lisp_Object));
12359
12360 /* The frame of a currently visible tooltip, or null. */
12361
12362 Lisp_Object tip_frame;
12363
12364 /* If non-nil, a timer started that hides the last tooltip when it
12365 fires. */
12366
12367 Lisp_Object tip_timer;
12368 Window tip_window;
12369
12370 static Lisp_Object
12371 unwind_create_tip_frame (frame)
12372 Lisp_Object frame;
12373 {
12374 Lisp_Object deleted;
12375
12376 deleted = unwind_create_frame (frame);
12377 if (EQ (deleted, Qt))
12378 {
12379 tip_window = NULL;
12380 tip_frame = Qnil;
12381 }
12382
12383 return deleted;
12384 }
12385
12386
12387 /* Create a frame for a tooltip on the display described by DPYINFO.
12388 PARMS is a list of frame parameters. Value is the frame.
12389
12390 Note that functions called here, esp. x_default_parameter can
12391 signal errors, for instance when a specified color name is
12392 undefined. We have to make sure that we're in a consistent state
12393 when this happens. */
12394
12395 static Lisp_Object
12396 x_create_tip_frame (dpyinfo, parms)
12397 struct w32_display_info *dpyinfo;
12398 Lisp_Object parms;
12399 {
12400 #if 0 /* TODO : w32 version */
12401 struct frame *f;
12402 Lisp_Object frame, tem;
12403 Lisp_Object name;
12404 long window_prompting = 0;
12405 int width, height;
12406 int count = BINDING_STACK_SIZE ();
12407 struct gcpro gcpro1, gcpro2, gcpro3;
12408 struct kboard *kb;
12409
12410 check_x ();
12411
12412 /* Use this general default value to start with until we know if
12413 this frame has a specified name. */
12414 Vx_resource_name = Vinvocation_name;
12415
12416 #ifdef MULTI_KBOARD
12417 kb = dpyinfo->kboard;
12418 #else
12419 kb = &the_only_kboard;
12420 #endif
12421
12422 /* Get the name of the frame to use for resource lookup. */
12423 name = w32_get_arg (parms, Qname, "name", "Name", RES_TYPE_STRING);
12424 if (!STRINGP (name)
12425 && !EQ (name, Qunbound)
12426 && !NILP (name))
12427 error ("Invalid frame name--not a string or nil");
12428 Vx_resource_name = name;
12429
12430 frame = Qnil;
12431 GCPRO3 (parms, name, frame);
12432 f = make_frame (1);
12433 XSETFRAME (frame, f);
12434 FRAME_CAN_HAVE_SCROLL_BARS (f) = 0;
12435 record_unwind_protect (unwind_create_tip_frame, frame);
12436
12437 f->output_method = output_w32;
12438 f->output_data.w32 =
12439 (struct w32_output *) xmalloc (sizeof (struct w32_output));
12440 bzero (f->output_data.w32, sizeof (struct w32_output));
12441 #if 0
12442 f->output_data.w32->icon_bitmap = -1;
12443 #endif
12444 f->output_data.w32->fontset = -1;
12445 f->icon_name = Qnil;
12446
12447 #ifdef GLYPH_DEBUG
12448 image_cache_refcount = FRAME_X_IMAGE_CACHE (f)->refcount;
12449 dpyinfo_refcount = dpyinfo->reference_count;
12450 #endif /* GLYPH_DEBUG */
12451 #ifdef MULTI_KBOARD
12452 FRAME_KBOARD (f) = kb;
12453 #endif
12454 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
12455 f->output_data.w32->explicit_parent = 0;
12456
12457 /* Set the name; the functions to which we pass f expect the name to
12458 be set. */
12459 if (EQ (name, Qunbound) || NILP (name))
12460 {
12461 f->name = build_string (dpyinfo->x_id_name);
12462 f->explicit_name = 0;
12463 }
12464 else
12465 {
12466 f->name = name;
12467 f->explicit_name = 1;
12468 /* use the frame's title when getting resources for this frame. */
12469 specbind (Qx_resource_name, name);
12470 }
12471
12472 /* Extract the window parameters from the supplied values
12473 that are needed to determine window geometry. */
12474 {
12475 Lisp_Object font;
12476
12477 font = w32_get_arg (parms, Qfont, "font", "Font", RES_TYPE_STRING);
12478
12479 BLOCK_INPUT;
12480 /* First, try whatever font the caller has specified. */
12481 if (STRINGP (font))
12482 {
12483 tem = Fquery_fontset (font, Qnil);
12484 if (STRINGP (tem))
12485 font = x_new_fontset (f, XSTRING (tem)->data);
12486 else
12487 font = x_new_font (f, XSTRING (font)->data);
12488 }
12489
12490 /* Try out a font which we hope has bold and italic variations. */
12491 if (!STRINGP (font))
12492 font = x_new_font (f, "-*-courier new-normal-r-*-*-*-100-*-*-*-*-iso8859-1");
12493 if (!STRINGP (font))
12494 font = x_new_font (f, "-misc-fixed-medium-r-normal-*-*-140-*-*-c-*-iso8859-1");
12495 if (! STRINGP (font))
12496 font = x_new_font (f, "-*-*-medium-r-normal-*-*-140-*-*-c-*-iso8859-1");
12497 if (! STRINGP (font))
12498 /* This was formerly the first thing tried, but it finds too many fonts
12499 and takes too long. */
12500 font = x_new_font (f, "-*-*-medium-r-*-*-*-*-*-*-c-*-iso8859-1");
12501 /* If those didn't work, look for something which will at least work. */
12502 if (! STRINGP (font))
12503 font = x_new_font (f, "-*-fixed-*-*-*-*-*-140-*-*-c-*-iso8859-1");
12504 UNBLOCK_INPUT;
12505 if (! STRINGP (font))
12506 font = build_string ("fixed");
12507
12508 x_default_parameter (f, parms, Qfont, font,
12509 "font", "Font", RES_TYPE_STRING);
12510 }
12511
12512 x_default_parameter (f, parms, Qborder_width, make_number (2),
12513 "borderWidth", "BorderWidth", RES_TYPE_NUMBER);
12514
12515 /* This defaults to 2 in order to match xterm. We recognize either
12516 internalBorderWidth or internalBorder (which is what xterm calls
12517 it). */
12518 if (NILP (Fassq (Qinternal_border_width, parms)))
12519 {
12520 Lisp_Object value;
12521
12522 value = w32_get_arg (parms, Qinternal_border_width,
12523 "internalBorder", "internalBorder", RES_TYPE_NUMBER);
12524 if (! EQ (value, Qunbound))
12525 parms = Fcons (Fcons (Qinternal_border_width, value),
12526 parms);
12527 }
12528
12529 x_default_parameter (f, parms, Qinternal_border_width, make_number (1),
12530 "internalBorderWidth", "internalBorderWidth",
12531 RES_TYPE_NUMBER);
12532
12533 /* Also do the stuff which must be set before the window exists. */
12534 x_default_parameter (f, parms, Qforeground_color, build_string ("black"),
12535 "foreground", "Foreground", RES_TYPE_STRING);
12536 x_default_parameter (f, parms, Qbackground_color, build_string ("white"),
12537 "background", "Background", RES_TYPE_STRING);
12538 x_default_parameter (f, parms, Qmouse_color, build_string ("black"),
12539 "pointerColor", "Foreground", RES_TYPE_STRING);
12540 x_default_parameter (f, parms, Qcursor_color, build_string ("black"),
12541 "cursorColor", "Foreground", RES_TYPE_STRING);
12542 x_default_parameter (f, parms, Qborder_color, build_string ("black"),
12543 "borderColor", "BorderColor", RES_TYPE_STRING);
12544
12545 /* Init faces before x_default_parameter is called for scroll-bar
12546 parameters because that function calls x_set_scroll_bar_width,
12547 which calls change_frame_size, which calls Fset_window_buffer,
12548 which runs hooks, which call Fvertical_motion. At the end, we
12549 end up in init_iterator with a null face cache, which should not
12550 happen. */
12551 init_frame_faces (f);
12552
12553 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
12554 window_prompting = x_figure_window_size (f, parms);
12555
12556 if (window_prompting & XNegative)
12557 {
12558 if (window_prompting & YNegative)
12559 f->output_data.w32->win_gravity = SouthEastGravity;
12560 else
12561 f->output_data.w32->win_gravity = NorthEastGravity;
12562 }
12563 else
12564 {
12565 if (window_prompting & YNegative)
12566 f->output_data.w32->win_gravity = SouthWestGravity;
12567 else
12568 f->output_data.w32->win_gravity = NorthWestGravity;
12569 }
12570
12571 f->output_data.w32->size_hint_flags = window_prompting;
12572 {
12573 XSetWindowAttributes attrs;
12574 unsigned long mask;
12575
12576 BLOCK_INPUT;
12577 mask = CWBackPixel | CWOverrideRedirect | CWSaveUnder | CWEventMask;
12578 /* Window managers looks at the override-redirect flag to
12579 determine whether or net to give windows a decoration (Xlib
12580 3.2.8). */
12581 attrs.override_redirect = True;
12582 attrs.save_under = True;
12583 attrs.background_pixel = FRAME_BACKGROUND_PIXEL (f);
12584 /* Arrange for getting MapNotify and UnmapNotify events. */
12585 attrs.event_mask = StructureNotifyMask;
12586 tip_window
12587 = FRAME_W32_WINDOW (f)
12588 = XCreateWindow (FRAME_W32_DISPLAY (f),
12589 FRAME_W32_DISPLAY_INFO (f)->root_window,
12590 /* x, y, width, height */
12591 0, 0, 1, 1,
12592 /* Border. */
12593 1,
12594 CopyFromParent, InputOutput, CopyFromParent,
12595 mask, &attrs);
12596 UNBLOCK_INPUT;
12597 }
12598
12599 x_make_gc (f);
12600
12601 x_default_parameter (f, parms, Qauto_raise, Qnil,
12602 "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN);
12603 x_default_parameter (f, parms, Qauto_lower, Qnil,
12604 "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN);
12605 x_default_parameter (f, parms, Qcursor_type, Qbox,
12606 "cursorType", "CursorType", RES_TYPE_SYMBOL);
12607
12608 /* Dimensions, especially f->height, must be done via change_frame_size.
12609 Change will not be effected unless different from the current
12610 f->height. */
12611 width = f->width;
12612 height = f->height;
12613 f->height = 0;
12614 SET_FRAME_WIDTH (f, 0);
12615 change_frame_size (f, height, width, 1, 0, 0);
12616
12617 f->no_split = 1;
12618
12619 UNGCPRO;
12620
12621 /* It is now ok to make the frame official even if we get an error
12622 below. And the frame needs to be on Vframe_list or making it
12623 visible won't work. */
12624 Vframe_list = Fcons (frame, Vframe_list);
12625 tip_frame = frame;
12626
12627 /* Now that the frame is official, it counts as a reference to
12628 its display. */
12629 FRAME_W32_DISPLAY_INFO (f)->reference_count++;
12630
12631 return unbind_to (count, frame);
12632 #endif /* TODO */
12633 return Qnil;
12634 }
12635
12636 #ifdef TODO /* Tooltip support not complete. */
12637 DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0,
12638 "Show STRING in a \"tooltip\" window on frame FRAME.\n\
12639 A tooltip window is a small window displaying a string.\n\
12640 \n\
12641 FRAME nil or omitted means use the selected frame.\n\
12642 \n\
12643 PARMS is an optional list of frame parameters which can be\n\
12644 used to change the tooltip's appearance.\n\
12645 \n\
12646 Automatically hide the tooltip after TIMEOUT seconds.\n\
12647 TIMEOUT nil means use the default timeout of 5 seconds.\n\
12648 \n\
12649 If the list of frame parameters PARAMS contains a `left' parameters,\n\
12650 the tooltip is displayed at that x-position. Otherwise it is\n\
12651 displayed at the mouse position, with offset DX added (default is 5 if\n\
12652 DX isn't specified). Likewise for the y-position; if a `top' frame\n\
12653 parameter is specified, it determines the y-position of the tooltip\n\
12654 window, otherwise it is displayed at the mouse position, with offset\n\
12655 DY added (default is 10).")
12656 (string, frame, parms, timeout, dx, dy)
12657 Lisp_Object string, frame, parms, timeout, dx, dy;
12658 {
12659 struct frame *f;
12660 struct window *w;
12661 Window root, child;
12662 Lisp_Object buffer, top, left;
12663 struct buffer *old_buffer;
12664 struct text_pos pos;
12665 int i, width, height;
12666 int root_x, root_y, win_x, win_y;
12667 unsigned pmask;
12668 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
12669 int old_windows_or_buffers_changed = windows_or_buffers_changed;
12670 int count = specpdl_ptr - specpdl;
12671
12672 specbind (Qinhibit_redisplay, Qt);
12673
12674 GCPRO4 (string, parms, frame, timeout);
12675
12676 CHECK_STRING (string, 0);
12677 f = check_x_frame (frame);
12678 if (NILP (timeout))
12679 timeout = make_number (5);
12680 else
12681 CHECK_NATNUM (timeout, 2);
12682
12683 if (NILP (dx))
12684 dx = make_number (5);
12685 else
12686 CHECK_NUMBER (dx, 5);
12687
12688 if (NILP (dy))
12689 dy = make_number (-10);
12690 else
12691 CHECK_NUMBER (dy, 6);
12692
12693 if (NILP (last_show_tip_args))
12694 last_show_tip_args = Fmake_vector (make_number (3), Qnil);
12695
12696 if (!NILP (tip_frame))
12697 {
12698 Lisp_Object last_string = AREF (last_show_tip_args, 0);
12699 Lisp_Object last_frame = AREF (last_show_tip_args, 1);
12700 Lisp_Object last_parms = AREF (last_show_tip_args, 2);
12701
12702 if (EQ (frame, last_frame)
12703 && !NILP (Fequal (last_string, string))
12704 && !NILP (Fequal (last_parms, parms)))
12705 {
12706 struct frame *f = XFRAME (tip_frame);
12707
12708 /* Only DX and DY have changed. */
12709 if (!NILP (tip_timer))
12710 {
12711 Lisp_Object timer = tip_timer;
12712 tip_timer = Qnil;
12713 call1 (Qcancel_timer, timer);
12714 }
12715
12716 BLOCK_INPUT;
12717 compute_tip_xy (f, parms, dx, dy, &root_x, &root_y);
12718 XMoveWindow (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
12719 root_x, root_y - PIXEL_HEIGHT (f));
12720 UNBLOCK_INPUT;
12721 goto start_timer;
12722 }
12723 }
12724
12725 /* Hide a previous tip, if any. */
12726 Fx_hide_tip ();
12727
12728 ASET (last_show_tip_args, 0, string);
12729 ASET (last_show_tip_args, 1, frame);
12730 ASET (last_show_tip_args, 2, parms);
12731
12732 /* Add default values to frame parameters. */
12733 if (NILP (Fassq (Qname, parms)))
12734 parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms);
12735 if (NILP (Fassq (Qinternal_border_width, parms)))
12736 parms = Fcons (Fcons (Qinternal_border_width, make_number (3)), parms);
12737 if (NILP (Fassq (Qborder_width, parms)))
12738 parms = Fcons (Fcons (Qborder_width, make_number (1)), parms);
12739 if (NILP (Fassq (Qborder_color, parms)))
12740 parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms);
12741 if (NILP (Fassq (Qbackground_color, parms)))
12742 parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")),
12743 parms);
12744
12745 /* Create a frame for the tooltip, and record it in the global
12746 variable tip_frame. */
12747 frame = x_create_tip_frame (FRAME_W32_DISPLAY_INFO (f), parms);
12748 f = XFRAME (frame);
12749
12750 /* Set up the frame's root window. Currently we use a size of 80
12751 columns x 40 lines. If someone wants to show a larger tip, he
12752 will loose. I don't think this is a realistic case. */
12753 w = XWINDOW (FRAME_ROOT_WINDOW (f));
12754 w->left = w->top = make_number (0);
12755 w->width = make_number (80);
12756 w->height = make_number (40);
12757 adjust_glyphs (f);
12758 w->pseudo_window_p = 1;
12759
12760 /* Display the tooltip text in a temporary buffer. */
12761 buffer = Fget_buffer_create (build_string (" *tip*"));
12762 Fset_window_buffer (FRAME_ROOT_WINDOW (f), buffer);
12763 old_buffer = current_buffer;
12764 set_buffer_internal_1 (XBUFFER (buffer));
12765 Ferase_buffer ();
12766 Finsert (1, &string);
12767 clear_glyph_matrix (w->desired_matrix);
12768 clear_glyph_matrix (w->current_matrix);
12769 SET_TEXT_POS (pos, BEGV, BEGV_BYTE);
12770 try_window (FRAME_ROOT_WINDOW (f), pos);
12771
12772 /* Compute width and height of the tooltip. */
12773 width = height = 0;
12774 for (i = 0; i < w->desired_matrix->nrows; ++i)
12775 {
12776 struct glyph_row *row = &w->desired_matrix->rows[i];
12777 struct glyph *last;
12778 int row_width;
12779
12780 /* Stop at the first empty row at the end. */
12781 if (!row->enabled_p || !row->displays_text_p)
12782 break;
12783
12784 /* Let the row go over the full width of the frame. */
12785 row->full_width_p = 1;
12786
12787 /* There's a glyph at the end of rows that is use to place
12788 the cursor there. Don't include the width of this glyph. */
12789 if (row->used[TEXT_AREA])
12790 {
12791 last = &row->glyphs[TEXT_AREA][row->used[TEXT_AREA] - 1];
12792 row_width = row->pixel_width - last->pixel_width;
12793 }
12794 else
12795 row_width = row->pixel_width;
12796
12797 height += row->height;
12798 width = max (width, row_width);
12799 }
12800
12801 /* Add the frame's internal border to the width and height the X
12802 window should have. */
12803 height += 2 * FRAME_INTERNAL_BORDER_WIDTH (f);
12804 width += 2 * FRAME_INTERNAL_BORDER_WIDTH (f);
12805
12806 /* Move the tooltip window where the mouse pointer is. Resize and
12807 show it. */
12808 compute_tip_xy (f, parms, dx, dy, &root_x, &root_y);
12809
12810 #if 0 /* TODO : W32 specifics */
12811 BLOCK_INPUT;
12812 XMoveResizeWindow (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
12813 root_x, root_y - height, width, height);
12814 XMapRaised (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f));
12815 UNBLOCK_INPUT;
12816 #endif /* TODO */
12817
12818 /* Draw into the window. */
12819 w->must_be_updated_p = 1;
12820 update_single_window (w, 1);
12821
12822 /* Restore original current buffer. */
12823 set_buffer_internal_1 (old_buffer);
12824 windows_or_buffers_changed = old_windows_or_buffers_changed;
12825
12826 start_timer:
12827 /* Let the tip disappear after timeout seconds. */
12828 tip_timer = call3 (intern ("run-at-time"), timeout, Qnil,
12829 intern ("x-hide-tip"));
12830
12831 UNGCPRO;
12832 return unbind_to (count, Qnil);
12833 }
12834
12835
12836 DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0,
12837 "Hide the current tooltip window, if there is any.\n\
12838 Value is t is tooltip was open, nil otherwise.")
12839 ()
12840 {
12841 int count;
12842 Lisp_Object deleted, frame, timer;
12843 struct gcpro gcpro1, gcpro2;
12844
12845 /* Return quickly if nothing to do. */
12846 if (NILP (tip_timer) && NILP (tip_frame))
12847 return Qnil;
12848
12849 frame = tip_frame;
12850 timer = tip_timer;
12851 GCPRO2 (frame, timer);
12852 tip_frame = tip_timer = deleted = Qnil;
12853
12854 count = BINDING_STACK_SIZE ();
12855 specbind (Qinhibit_redisplay, Qt);
12856 specbind (Qinhibit_quit, Qt);
12857
12858 if (!NILP (timer))
12859 call1 (Qcancel_timer, timer);
12860
12861 if (FRAMEP (frame))
12862 {
12863 Fdelete_frame (frame, Qnil);
12864 deleted = Qt;
12865 }
12866
12867 UNGCPRO;
12868 return unbind_to (count, deleted);
12869 }
12870 #endif
12871
12872
12873 \f
12874 /***********************************************************************
12875 File selection dialog
12876 ***********************************************************************/
12877
12878 extern Lisp_Object Qfile_name_history;
12879
12880 DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 4, 0,
12881 "Read file name, prompting with PROMPT in directory DIR.\n\
12882 Use a file selection dialog.\n\
12883 Select DEFAULT-FILENAME in the dialog's file selection box, if\n\
12884 specified. Don't let the user enter a file name in the file\n\
12885 selection dialog's entry field, if MUSTMATCH is non-nil.")
12886 (prompt, dir, default_filename, mustmatch)
12887 Lisp_Object prompt, dir, default_filename, mustmatch;
12888 {
12889 struct frame *f = SELECTED_FRAME ();
12890 Lisp_Object file = Qnil;
12891 int count = specpdl_ptr - specpdl;
12892 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
12893 char filename[MAX_PATH + 1];
12894 char init_dir[MAX_PATH + 1];
12895 int use_dialog_p = 1;
12896
12897 GCPRO5 (prompt, dir, default_filename, mustmatch, file);
12898 CHECK_STRING (prompt, 0);
12899 CHECK_STRING (dir, 1);
12900
12901 /* Create the dialog with PROMPT as title, using DIR as initial
12902 directory and using "*" as pattern. */
12903 dir = Fexpand_file_name (dir, Qnil);
12904 strncpy (init_dir, XSTRING (dir)->data, MAX_PATH);
12905 init_dir[MAX_PATH] = '\0';
12906 unixtodos_filename (init_dir);
12907
12908 if (STRINGP (default_filename))
12909 {
12910 char *file_name_only;
12911 char *full_path_name = XSTRING (default_filename)->data;
12912
12913 unixtodos_filename (full_path_name);
12914
12915 file_name_only = strrchr (full_path_name, '\\');
12916 if (!file_name_only)
12917 file_name_only = full_path_name;
12918 else
12919 {
12920 file_name_only++;
12921
12922 /* If default_file_name is a directory, don't use the open
12923 file dialog, as it does not support selecting
12924 directories. */
12925 if (!(*file_name_only))
12926 use_dialog_p = 0;
12927 }
12928
12929 strncpy (filename, file_name_only, MAX_PATH);
12930 filename[MAX_PATH] = '\0';
12931 }
12932 else
12933 filename[0] = '\0';
12934
12935 if (use_dialog_p)
12936 {
12937 OPENFILENAME file_details;
12938
12939 /* Prevent redisplay. */
12940 specbind (Qinhibit_redisplay, Qt);
12941 BLOCK_INPUT;
12942
12943 bzero (&file_details, sizeof (file_details));
12944 file_details.lStructSize = sizeof (file_details);
12945 file_details.hwndOwner = FRAME_W32_WINDOW (f);
12946 file_details.lpstrFile = filename;
12947 file_details.nMaxFile = sizeof (filename);
12948 file_details.lpstrInitialDir = init_dir;
12949 file_details.lpstrTitle = XSTRING (prompt)->data;
12950 file_details.Flags = OFN_HIDEREADONLY | OFN_NOCHANGEDIR;
12951
12952 if (!NILP (mustmatch))
12953 file_details.Flags |= OFN_FILEMUSTEXIST | OFN_PATHMUSTEXIST;
12954
12955 if (GetOpenFileName (&file_details))
12956 {
12957 dostounix_filename (filename);
12958 file = build_string (filename);
12959 }
12960 else
12961 file = Qnil;
12962
12963 UNBLOCK_INPUT;
12964 file = unbind_to (count, file);
12965 }
12966 /* Open File dialog will not allow folders to be selected, so resort
12967 to minibuffer completing reads for directories. */
12968 else
12969 file = Fcompleting_read (prompt, intern ("read-file-name-internal"),
12970 dir, mustmatch, dir, Qfile_name_history,
12971 default_filename, Qnil);
12972
12973 UNGCPRO;
12974
12975 /* Make "Cancel" equivalent to C-g. */
12976 if (NILP (file))
12977 Fsignal (Qquit, Qnil);
12978
12979 return unbind_to (count, file);
12980 }
12981
12982
12983 \f
12984 /***********************************************************************
12985 Tests
12986 ***********************************************************************/
12987
12988 #if GLYPH_DEBUG
12989
12990 DEFUN ("imagep", Fimagep, Simagep, 1, 1, 0,
12991 "Value is non-nil if SPEC is a valid image specification.")
12992 (spec)
12993 Lisp_Object spec;
12994 {
12995 return valid_image_p (spec) ? Qt : Qnil;
12996 }
12997
12998
12999 DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0, "")
13000 (spec)
13001 Lisp_Object spec;
13002 {
13003 int id = -1;
13004
13005 if (valid_image_p (spec))
13006 id = lookup_image (SELECTED_FRAME (), spec);
13007
13008 debug_print (spec);
13009 return make_number (id);
13010 }
13011
13012 #endif /* GLYPH_DEBUG != 0 */
13013
13014
13015 \f
13016 /***********************************************************************
13017 w32 specialized functions
13018 ***********************************************************************/
13019
13020 DEFUN ("w32-select-font", Fw32_select_font, Sw32_select_font, 0, 1, 0,
13021 "This will display the W32 font dialog and return an X font string corresponding to the selection.")
13022 (frame)
13023 Lisp_Object frame;
13024 {
13025 FRAME_PTR f = check_x_frame (frame);
13026 CHOOSEFONT cf;
13027 LOGFONT lf;
13028 TEXTMETRIC tm;
13029 HDC hdc;
13030 HANDLE oldobj;
13031 char buf[100];
13032
13033 bzero (&cf, sizeof (cf));
13034 bzero (&lf, sizeof (lf));
13035
13036 cf.lStructSize = sizeof (cf);
13037 cf.hwndOwner = FRAME_W32_WINDOW (f);
13038 cf.Flags = CF_FORCEFONTEXIST | CF_SCREENFONTS;
13039 cf.lpLogFont = &lf;
13040
13041 /* Initialize as much of the font details as we can from the current
13042 default font. */
13043 hdc = GetDC (FRAME_W32_WINDOW (f));
13044 oldobj = SelectObject (hdc, FRAME_FONT (f)->hfont);
13045 GetTextFace (hdc, LF_FACESIZE, lf.lfFaceName);
13046 if (GetTextMetrics (hdc, &tm))
13047 {
13048 lf.lfHeight = tm.tmInternalLeading - tm.tmHeight;
13049 lf.lfWeight = tm.tmWeight;
13050 lf.lfItalic = tm.tmItalic;
13051 lf.lfUnderline = tm.tmUnderlined;
13052 lf.lfStrikeOut = tm.tmStruckOut;
13053 lf.lfCharSet = tm.tmCharSet;
13054 cf.Flags |= CF_INITTOLOGFONTSTRUCT;
13055 }
13056 SelectObject (hdc, oldobj);
13057 ReleaseDC (FRAME_W32_WINDOW (f), hdc);
13058
13059 if (!ChooseFont (&cf) || !w32_to_x_font (&lf, buf, 100, NULL))
13060 return Qnil;
13061
13062 return build_string (buf);
13063 }
13064
13065 DEFUN ("w32-send-sys-command", Fw32_send_sys_command, Sw32_send_sys_command, 1, 2, 0,
13066 "Send frame a Windows WM_SYSCOMMAND message of type COMMAND.\n\
13067 Some useful values for command are 0xf030 to maximise frame (0xf020\n\
13068 to minimize), 0xf120 to restore frame to original size, and 0xf100\n\
13069 to activate the menubar for keyboard access. 0xf140 activates the\n\
13070 screen saver if defined.\n\
13071 \n\
13072 If optional parameter FRAME is not specified, use selected frame.")
13073 (command, frame)
13074 Lisp_Object command, frame;
13075 {
13076 FRAME_PTR f = check_x_frame (frame);
13077
13078 CHECK_NUMBER (command, 0);
13079
13080 PostMessage (FRAME_W32_WINDOW (f), WM_SYSCOMMAND, XINT (command), 0);
13081
13082 return Qnil;
13083 }
13084
13085 DEFUN ("w32-shell-execute", Fw32_shell_execute, Sw32_shell_execute, 2, 4, 0,
13086 "Get Windows to perform OPERATION on DOCUMENT.\n\
13087 This is a wrapper around the ShellExecute system function, which\n\
13088 invokes the application registered to handle OPERATION for DOCUMENT.\n\
13089 OPERATION is typically \"open\", \"print\" or \"explore\" (but can be\n\
13090 nil for the default action), and DOCUMENT is typically the name of a\n\
13091 document file or URL, but can also be a program executable to run or\n\
13092 a directory to open in the Windows Explorer.\n\
13093 \n\
13094 If DOCUMENT is a program executable, PARAMETERS can be a string\n\
13095 containing command line parameters, but otherwise should be nil.\n\
13096 \n\
13097 SHOW-FLAG can be used to control whether the invoked application is hidden\n\
13098 or minimized. If SHOW-FLAG is nil, the application is displayed normally,\n\
13099 otherwise it is an integer representing a ShowWindow flag:\n\
13100 \n\
13101 0 - start hidden\n\
13102 1 - start normally\n\
13103 3 - start maximized\n\
13104 6 - start minimized")
13105 (operation, document, parameters, show_flag)
13106 Lisp_Object operation, document, parameters, show_flag;
13107 {
13108 Lisp_Object current_dir;
13109
13110 CHECK_STRING (document, 0);
13111
13112 /* Encode filename and current directory. */
13113 current_dir = ENCODE_FILE (current_buffer->directory);
13114 document = ENCODE_FILE (document);
13115 if ((int) ShellExecute (NULL,
13116 (STRINGP (operation) ?
13117 XSTRING (operation)->data : NULL),
13118 XSTRING (document)->data,
13119 (STRINGP (parameters) ?
13120 XSTRING (parameters)->data : NULL),
13121 XSTRING (current_dir)->data,
13122 (INTEGERP (show_flag) ?
13123 XINT (show_flag) : SW_SHOWDEFAULT))
13124 > 32)
13125 return Qt;
13126 error ("ShellExecute failed: %s", w32_strerror (0));
13127 }
13128
13129 /* Lookup virtual keycode from string representing the name of a
13130 non-ascii keystroke into the corresponding virtual key, using
13131 lispy_function_keys. */
13132 static int
13133 lookup_vk_code (char *key)
13134 {
13135 int i;
13136
13137 for (i = 0; i < 256; i++)
13138 if (lispy_function_keys[i] != 0
13139 && strcmp (lispy_function_keys[i], key) == 0)
13140 return i;
13141
13142 return -1;
13143 }
13144
13145 /* Convert a one-element vector style key sequence to a hot key
13146 definition. */
13147 static int
13148 w32_parse_hot_key (key)
13149 Lisp_Object key;
13150 {
13151 /* Copied from Fdefine_key and store_in_keymap. */
13152 register Lisp_Object c;
13153 int vk_code;
13154 int lisp_modifiers;
13155 int w32_modifiers;
13156 struct gcpro gcpro1;
13157
13158 CHECK_VECTOR (key, 0);
13159
13160 if (XFASTINT (Flength (key)) != 1)
13161 return Qnil;
13162
13163 GCPRO1 (key);
13164
13165 c = Faref (key, make_number (0));
13166
13167 if (CONSP (c) && lucid_event_type_list_p (c))
13168 c = Fevent_convert_list (c);
13169
13170 UNGCPRO;
13171
13172 if (! INTEGERP (c) && ! SYMBOLP (c))
13173 error ("Key definition is invalid");
13174
13175 /* Work out the base key and the modifiers. */
13176 if (SYMBOLP (c))
13177 {
13178 c = parse_modifiers (c);
13179 lisp_modifiers = Fcar (Fcdr (c));
13180 c = Fcar (c);
13181 if (!SYMBOLP (c))
13182 abort ();
13183 vk_code = lookup_vk_code (XSYMBOL (c)->name->data);
13184 }
13185 else if (INTEGERP (c))
13186 {
13187 lisp_modifiers = XINT (c) & ~CHARACTERBITS;
13188 /* Many ascii characters are their own virtual key code. */
13189 vk_code = XINT (c) & CHARACTERBITS;
13190 }
13191
13192 if (vk_code < 0 || vk_code > 255)
13193 return Qnil;
13194
13195 if ((lisp_modifiers & meta_modifier) != 0
13196 && !NILP (Vw32_alt_is_meta))
13197 lisp_modifiers |= alt_modifier;
13198
13199 /* Supply defs missing from mingw32. */
13200 #ifndef MOD_ALT
13201 #define MOD_ALT 0x0001
13202 #define MOD_CONTROL 0x0002
13203 #define MOD_SHIFT 0x0004
13204 #define MOD_WIN 0x0008
13205 #endif
13206
13207 /* Convert lisp modifiers to Windows hot-key form. */
13208 w32_modifiers = (lisp_modifiers & hyper_modifier) ? MOD_WIN : 0;
13209 w32_modifiers |= (lisp_modifiers & alt_modifier) ? MOD_ALT : 0;
13210 w32_modifiers |= (lisp_modifiers & ctrl_modifier) ? MOD_CONTROL : 0;
13211 w32_modifiers |= (lisp_modifiers & shift_modifier) ? MOD_SHIFT : 0;
13212
13213 return HOTKEY (vk_code, w32_modifiers);
13214 }
13215
13216 DEFUN ("w32-register-hot-key", Fw32_register_hot_key, Sw32_register_hot_key, 1, 1, 0,
13217 "Register KEY as a hot-key combination.\n\
13218 Certain key combinations like Alt-Tab are reserved for system use on\n\
13219 Windows, and therefore are normally intercepted by the system. However,\n\
13220 most of these key combinations can be received by registering them as\n\
13221 hot-keys, overriding their special meaning.\n\
13222 \n\
13223 KEY must be a one element key definition in vector form that would be\n\
13224 acceptable to `define-key' (e.g. [A-tab] for Alt-Tab). The meta\n\
13225 modifier is interpreted as Alt if `w32-alt-is-meta' is t, and hyper\n\
13226 is always interpreted as the Windows modifier keys.\n\
13227 \n\
13228 The return value is the hotkey-id if registered, otherwise nil.")
13229 (key)
13230 Lisp_Object key;
13231 {
13232 key = w32_parse_hot_key (key);
13233
13234 if (NILP (Fmemq (key, w32_grabbed_keys)))
13235 {
13236 /* Reuse an empty slot if possible. */
13237 Lisp_Object item = Fmemq (Qnil, w32_grabbed_keys);
13238
13239 /* Safe to add new key to list, even if we have focus. */
13240 if (NILP (item))
13241 w32_grabbed_keys = Fcons (key, w32_grabbed_keys);
13242 else
13243 XCAR (item) = key;
13244
13245 /* Notify input thread about new hot-key definition, so that it
13246 takes effect without needing to switch focus. */
13247 PostThreadMessage (dwWindowsThreadId, WM_EMACS_REGISTER_HOT_KEY,
13248 (WPARAM) key, 0);
13249 }
13250
13251 return key;
13252 }
13253
13254 DEFUN ("w32-unregister-hot-key", Fw32_unregister_hot_key, Sw32_unregister_hot_key, 1, 1, 0,
13255 "Unregister HOTKEY as a hot-key combination.")
13256 (key)
13257 Lisp_Object key;
13258 {
13259 Lisp_Object item;
13260
13261 if (!INTEGERP (key))
13262 key = w32_parse_hot_key (key);
13263
13264 item = Fmemq (key, w32_grabbed_keys);
13265
13266 if (!NILP (item))
13267 {
13268 /* Notify input thread about hot-key definition being removed, so
13269 that it takes effect without needing focus switch. */
13270 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_UNREGISTER_HOT_KEY,
13271 (WPARAM) XINT (XCAR (item)), (LPARAM) item))
13272 {
13273 MSG msg;
13274 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
13275 }
13276 return Qt;
13277 }
13278 return Qnil;
13279 }
13280
13281 DEFUN ("w32-registered-hot-keys", Fw32_registered_hot_keys, Sw32_registered_hot_keys, 0, 0, 0,
13282 "Return list of registered hot-key IDs.")
13283 ()
13284 {
13285 return Fcopy_sequence (w32_grabbed_keys);
13286 }
13287
13288 DEFUN ("w32-reconstruct-hot-key", Fw32_reconstruct_hot_key, Sw32_reconstruct_hot_key, 1, 1, 0,
13289 "Convert hot-key ID to a lisp key combination.")
13290 (hotkeyid)
13291 Lisp_Object hotkeyid;
13292 {
13293 int vk_code, w32_modifiers;
13294 Lisp_Object key;
13295
13296 CHECK_NUMBER (hotkeyid, 0);
13297
13298 vk_code = HOTKEY_VK_CODE (hotkeyid);
13299 w32_modifiers = HOTKEY_MODIFIERS (hotkeyid);
13300
13301 if (lispy_function_keys[vk_code])
13302 key = intern (lispy_function_keys[vk_code]);
13303 else
13304 key = make_number (vk_code);
13305
13306 key = Fcons (key, Qnil);
13307 if (w32_modifiers & MOD_SHIFT)
13308 key = Fcons (Qshift, key);
13309 if (w32_modifiers & MOD_CONTROL)
13310 key = Fcons (Qctrl, key);
13311 if (w32_modifiers & MOD_ALT)
13312 key = Fcons (NILP (Vw32_alt_is_meta) ? Qalt : Qmeta, key);
13313 if (w32_modifiers & MOD_WIN)
13314 key = Fcons (Qhyper, key);
13315
13316 return key;
13317 }
13318
13319 DEFUN ("w32-toggle-lock-key", Fw32_toggle_lock_key, Sw32_toggle_lock_key, 1, 2, 0,
13320 "Toggle the state of the lock key KEY.\n\
13321 KEY can be `capslock', `kp-numlock', or `scroll'.\n\
13322 If the optional parameter NEW-STATE is a number, then the state of KEY\n\
13323 is set to off if the low bit of NEW-STATE is zero, otherwise on.")
13324 (key, new_state)
13325 Lisp_Object key, new_state;
13326 {
13327 int vk_code;
13328
13329 if (EQ (key, intern ("capslock")))
13330 vk_code = VK_CAPITAL;
13331 else if (EQ (key, intern ("kp-numlock")))
13332 vk_code = VK_NUMLOCK;
13333 else if (EQ (key, intern ("scroll")))
13334 vk_code = VK_SCROLL;
13335 else
13336 return Qnil;
13337
13338 if (!dwWindowsThreadId)
13339 return make_number (w32_console_toggle_lock_key (vk_code, new_state));
13340
13341 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_TOGGLE_LOCK_KEY,
13342 (WPARAM) vk_code, (LPARAM) new_state))
13343 {
13344 MSG msg;
13345 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
13346 return make_number (msg.wParam);
13347 }
13348 return Qnil;
13349 }
13350 \f
13351 DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0,
13352 "Return storage information about the file system FILENAME is on.\n\
13353 Value is a list of floats (TOTAL FREE AVAIL), where TOTAL is the total\n\
13354 storage of the file system, FREE is the free storage, and AVAIL is the\n\
13355 storage available to a non-superuser. All 3 numbers are in bytes.\n\
13356 If the underlying system call fails, value is nil.")
13357 (filename)
13358 Lisp_Object filename;
13359 {
13360 Lisp_Object encoded, value;
13361
13362 CHECK_STRING (filename, 0);
13363 filename = Fexpand_file_name (filename, Qnil);
13364 encoded = ENCODE_FILE (filename);
13365
13366 value = Qnil;
13367
13368 /* Determining the required information on Windows turns out, sadly,
13369 to be more involved than one would hope. The original Win32 api
13370 call for this will return bogus information on some systems, but we
13371 must dynamically probe for the replacement api, since that was
13372 added rather late on. */
13373 {
13374 HMODULE hKernel = GetModuleHandle ("kernel32");
13375 BOOL (*pfn_GetDiskFreeSpaceEx)
13376 (char *, PULARGE_INTEGER, PULARGE_INTEGER, PULARGE_INTEGER)
13377 = (void *) GetProcAddress (hKernel, "GetDiskFreeSpaceEx");
13378
13379 /* On Windows, we may need to specify the root directory of the
13380 volume holding FILENAME. */
13381 char rootname[MAX_PATH];
13382 char *name = XSTRING (encoded)->data;
13383
13384 /* find the root name of the volume if given */
13385 if (isalpha (name[0]) && name[1] == ':')
13386 {
13387 rootname[0] = name[0];
13388 rootname[1] = name[1];
13389 rootname[2] = '\\';
13390 rootname[3] = 0;
13391 }
13392 else if (IS_DIRECTORY_SEP (name[0]) && IS_DIRECTORY_SEP (name[1]))
13393 {
13394 char *str = rootname;
13395 int slashes = 4;
13396 do
13397 {
13398 if (IS_DIRECTORY_SEP (*name) && --slashes == 0)
13399 break;
13400 *str++ = *name++;
13401 }
13402 while ( *name );
13403
13404 *str++ = '\\';
13405 *str = 0;
13406 }
13407
13408 if (pfn_GetDiskFreeSpaceEx)
13409 {
13410 LARGE_INTEGER availbytes;
13411 LARGE_INTEGER freebytes;
13412 LARGE_INTEGER totalbytes;
13413
13414 if (pfn_GetDiskFreeSpaceEx(rootname,
13415 &availbytes,
13416 &totalbytes,
13417 &freebytes))
13418 value = list3 (make_float ((double) totalbytes.QuadPart),
13419 make_float ((double) freebytes.QuadPart),
13420 make_float ((double) availbytes.QuadPart));
13421 }
13422 else
13423 {
13424 DWORD sectors_per_cluster;
13425 DWORD bytes_per_sector;
13426 DWORD free_clusters;
13427 DWORD total_clusters;
13428
13429 if (GetDiskFreeSpace(rootname,
13430 &sectors_per_cluster,
13431 &bytes_per_sector,
13432 &free_clusters,
13433 &total_clusters))
13434 value = list3 (make_float ((double) total_clusters
13435 * sectors_per_cluster * bytes_per_sector),
13436 make_float ((double) free_clusters
13437 * sectors_per_cluster * bytes_per_sector),
13438 make_float ((double) free_clusters
13439 * sectors_per_cluster * bytes_per_sector));
13440 }
13441 }
13442
13443 return value;
13444 }
13445 \f
13446 syms_of_w32fns ()
13447 {
13448 /* This is zero if not using MS-Windows. */
13449 w32_in_use = 0;
13450
13451 /* The section below is built by the lisp expression at the top of the file,
13452 just above where these variables are declared. */
13453 /*&&& init symbols here &&&*/
13454 Qauto_raise = intern ("auto-raise");
13455 staticpro (&Qauto_raise);
13456 Qauto_lower = intern ("auto-lower");
13457 staticpro (&Qauto_lower);
13458 Qbar = intern ("bar");
13459 staticpro (&Qbar);
13460 Qborder_color = intern ("border-color");
13461 staticpro (&Qborder_color);
13462 Qborder_width = intern ("border-width");
13463 staticpro (&Qborder_width);
13464 Qbox = intern ("box");
13465 staticpro (&Qbox);
13466 Qcursor_color = intern ("cursor-color");
13467 staticpro (&Qcursor_color);
13468 Qcursor_type = intern ("cursor-type");
13469 staticpro (&Qcursor_type);
13470 Qgeometry = intern ("geometry");
13471 staticpro (&Qgeometry);
13472 Qicon_left = intern ("icon-left");
13473 staticpro (&Qicon_left);
13474 Qicon_top = intern ("icon-top");
13475 staticpro (&Qicon_top);
13476 Qicon_type = intern ("icon-type");
13477 staticpro (&Qicon_type);
13478 Qicon_name = intern ("icon-name");
13479 staticpro (&Qicon_name);
13480 Qinternal_border_width = intern ("internal-border-width");
13481 staticpro (&Qinternal_border_width);
13482 Qleft = intern ("left");
13483 staticpro (&Qleft);
13484 Qright = intern ("right");
13485 staticpro (&Qright);
13486 Qmouse_color = intern ("mouse-color");
13487 staticpro (&Qmouse_color);
13488 Qnone = intern ("none");
13489 staticpro (&Qnone);
13490 Qparent_id = intern ("parent-id");
13491 staticpro (&Qparent_id);
13492 Qscroll_bar_width = intern ("scroll-bar-width");
13493 staticpro (&Qscroll_bar_width);
13494 Qsuppress_icon = intern ("suppress-icon");
13495 staticpro (&Qsuppress_icon);
13496 Qundefined_color = intern ("undefined-color");
13497 staticpro (&Qundefined_color);
13498 Qvertical_scroll_bars = intern ("vertical-scroll-bars");
13499 staticpro (&Qvertical_scroll_bars);
13500 Qvisibility = intern ("visibility");
13501 staticpro (&Qvisibility);
13502 Qwindow_id = intern ("window-id");
13503 staticpro (&Qwindow_id);
13504 Qx_frame_parameter = intern ("x-frame-parameter");
13505 staticpro (&Qx_frame_parameter);
13506 Qx_resource_name = intern ("x-resource-name");
13507 staticpro (&Qx_resource_name);
13508 Quser_position = intern ("user-position");
13509 staticpro (&Quser_position);
13510 Quser_size = intern ("user-size");
13511 staticpro (&Quser_size);
13512 Qscreen_gamma = intern ("screen-gamma");
13513 staticpro (&Qscreen_gamma);
13514 Qline_spacing = intern ("line-spacing");
13515 staticpro (&Qline_spacing);
13516 Qcenter = intern ("center");
13517 staticpro (&Qcenter);
13518 Qcancel_timer = intern ("cancel-timer");
13519 staticpro (&Qcancel_timer);
13520 /* This is the end of symbol initialization. */
13521
13522 Qhyper = intern ("hyper");
13523 staticpro (&Qhyper);
13524 Qsuper = intern ("super");
13525 staticpro (&Qsuper);
13526 Qmeta = intern ("meta");
13527 staticpro (&Qmeta);
13528 Qalt = intern ("alt");
13529 staticpro (&Qalt);
13530 Qctrl = intern ("ctrl");
13531 staticpro (&Qctrl);
13532 Qcontrol = intern ("control");
13533 staticpro (&Qcontrol);
13534 Qshift = intern ("shift");
13535 staticpro (&Qshift);
13536
13537 /* Text property `display' should be nonsticky by default. */
13538 Vtext_property_default_nonsticky
13539 = Fcons (Fcons (Qdisplay, Qt), Vtext_property_default_nonsticky);
13540
13541
13542 Qlaplace = intern ("laplace");
13543 staticpro (&Qlaplace);
13544
13545 Qface_set_after_frame_default = intern ("face-set-after-frame-default");
13546 staticpro (&Qface_set_after_frame_default);
13547
13548 Fput (Qundefined_color, Qerror_conditions,
13549 Fcons (Qundefined_color, Fcons (Qerror, Qnil)));
13550 Fput (Qundefined_color, Qerror_message,
13551 build_string ("Undefined color"));
13552
13553 staticpro (&w32_grabbed_keys);
13554 w32_grabbed_keys = Qnil;
13555
13556 DEFVAR_LISP ("w32-color-map", &Vw32_color_map,
13557 "An array of color name mappings for windows.");
13558 Vw32_color_map = Qnil;
13559
13560 DEFVAR_LISP ("w32-pass-alt-to-system", &Vw32_pass_alt_to_system,
13561 "Non-nil if alt key presses are passed on to Windows.\n\
13562 When non-nil, for example, alt pressed and released and then space will\n\
13563 open the System menu. When nil, Emacs silently swallows alt key events.");
13564 Vw32_pass_alt_to_system = Qnil;
13565
13566 DEFVAR_LISP ("w32-alt-is-meta", &Vw32_alt_is_meta,
13567 "Non-nil if the alt key is to be considered the same as the meta key.\n\
13568 When nil, Emacs will translate the alt key to the Alt modifier, and not Meta.");
13569 Vw32_alt_is_meta = Qt;
13570
13571 DEFVAR_INT ("w32-quit-key", &Vw32_quit_key,
13572 "If non-zero, the virtual key code for an alternative quit key.");
13573 XSETINT (Vw32_quit_key, 0);
13574
13575 DEFVAR_LISP ("w32-pass-lwindow-to-system",
13576 &Vw32_pass_lwindow_to_system,
13577 "Non-nil if the left \"Windows\" key is passed on to Windows.\n\
13578 When non-nil, the Start menu is opened by tapping the key.");
13579 Vw32_pass_lwindow_to_system = Qt;
13580
13581 DEFVAR_LISP ("w32-pass-rwindow-to-system",
13582 &Vw32_pass_rwindow_to_system,
13583 "Non-nil if the right \"Windows\" key is passed on to Windows.\n\
13584 When non-nil, the Start menu is opened by tapping the key.");
13585 Vw32_pass_rwindow_to_system = Qt;
13586
13587 DEFVAR_INT ("w32-phantom-key-code",
13588 &Vw32_phantom_key_code,
13589 "Virtual key code used to generate \"phantom\" key presses.\n\
13590 Value is a number between 0 and 255.\n\
13591 \n\
13592 Phantom key presses are generated in order to stop the system from\n\
13593 acting on \"Windows\" key events when `w32-pass-lwindow-to-system' or\n\
13594 `w32-pass-rwindow-to-system' is nil.");
13595 /* Although 255 is technically not a valid key code, it works and
13596 means that this hack won't interfere with any real key code. */
13597 Vw32_phantom_key_code = 255;
13598
13599 DEFVAR_LISP ("w32-enable-num-lock",
13600 &Vw32_enable_num_lock,
13601 "Non-nil if Num Lock should act normally.\n\
13602 Set to nil to see Num Lock as the key `kp-numlock'.");
13603 Vw32_enable_num_lock = Qt;
13604
13605 DEFVAR_LISP ("w32-enable-caps-lock",
13606 &Vw32_enable_caps_lock,
13607 "Non-nil if Caps Lock should act normally.\n\
13608 Set to nil to see Caps Lock as the key `capslock'.");
13609 Vw32_enable_caps_lock = Qt;
13610
13611 DEFVAR_LISP ("w32-scroll-lock-modifier",
13612 &Vw32_scroll_lock_modifier,
13613 "Modifier to use for the Scroll Lock on state.\n\
13614 The value can be hyper, super, meta, alt, control or shift for the\n\
13615 respective modifier, or nil to see Scroll Lock as the key `scroll'.\n\
13616 Any other value will cause the key to be ignored.");
13617 Vw32_scroll_lock_modifier = Qt;
13618
13619 DEFVAR_LISP ("w32-lwindow-modifier",
13620 &Vw32_lwindow_modifier,
13621 "Modifier to use for the left \"Windows\" key.\n\
13622 The value can be hyper, super, meta, alt, control or shift for the\n\
13623 respective modifier, or nil to appear as the key `lwindow'.\n\
13624 Any other value will cause the key to be ignored.");
13625 Vw32_lwindow_modifier = Qnil;
13626
13627 DEFVAR_LISP ("w32-rwindow-modifier",
13628 &Vw32_rwindow_modifier,
13629 "Modifier to use for the right \"Windows\" key.\n\
13630 The value can be hyper, super, meta, alt, control or shift for the\n\
13631 respective modifier, or nil to appear as the key `rwindow'.\n\
13632 Any other value will cause the key to be ignored.");
13633 Vw32_rwindow_modifier = Qnil;
13634
13635 DEFVAR_LISP ("w32-apps-modifier",
13636 &Vw32_apps_modifier,
13637 "Modifier to use for the \"Apps\" key.\n\
13638 The value can be hyper, super, meta, alt, control or shift for the\n\
13639 respective modifier, or nil to appear as the key `apps'.\n\
13640 Any other value will cause the key to be ignored.");
13641 Vw32_apps_modifier = Qnil;
13642
13643 DEFVAR_LISP ("w32-enable-synthesized-fonts", &Vw32_enable_synthesized_fonts,
13644 "Non-nil enables selection of artificially italicized and bold fonts.");
13645 Vw32_enable_synthesized_fonts = Qnil;
13646
13647 DEFVAR_LISP ("w32-enable-palette", &Vw32_enable_palette,
13648 "Non-nil enables Windows palette management to map colors exactly.");
13649 Vw32_enable_palette = Qt;
13650
13651 DEFVAR_INT ("w32-mouse-button-tolerance",
13652 &Vw32_mouse_button_tolerance,
13653 "Analogue of double click interval for faking middle mouse events.\n\
13654 The value is the minimum time in milliseconds that must elapse between\n\
13655 left/right button down events before they are considered distinct events.\n\
13656 If both mouse buttons are depressed within this interval, a middle mouse\n\
13657 button down event is generated instead.");
13658 XSETINT (Vw32_mouse_button_tolerance, GetDoubleClickTime () / 2);
13659
13660 DEFVAR_INT ("w32-mouse-move-interval",
13661 &Vw32_mouse_move_interval,
13662 "Minimum interval between mouse move events.\n\
13663 The value is the minimum time in milliseconds that must elapse between\n\
13664 successive mouse move (or scroll bar drag) events before they are\n\
13665 reported as lisp events.");
13666 XSETINT (Vw32_mouse_move_interval, 0);
13667
13668 init_x_parm_symbols ();
13669
13670 DEFVAR_LISP ("x-bitmap-file-path", &Vx_bitmap_file_path,
13671 "List of directories to search for bitmap files for w32.");
13672 Vx_bitmap_file_path = decode_env_path ((char *) 0, "PATH");
13673
13674 DEFVAR_LISP ("x-pointer-shape", &Vx_pointer_shape,
13675 "The shape of the pointer when over text.\n\
13676 Changing the value does not affect existing frames\n\
13677 unless you set the mouse color.");
13678 Vx_pointer_shape = Qnil;
13679
13680 DEFVAR_LISP ("x-resource-name", &Vx_resource_name,
13681 "The name Emacs uses to look up resources; for internal use only.\n\
13682 `x-get-resource' uses this as the first component of the instance name\n\
13683 when requesting resource values.\n\
13684 Emacs initially sets `x-resource-name' to the name under which Emacs\n\
13685 was invoked, or to the value specified with the `-name' or `-rn'\n\
13686 switches, if present.");
13687 Vx_resource_name = Qnil;
13688
13689 Vx_nontext_pointer_shape = Qnil;
13690
13691 Vx_mode_pointer_shape = Qnil;
13692
13693 DEFVAR_LISP ("x-hourglass-pointer-shape", &Vx_hourglass_pointer_shape,
13694 "The shape of the pointer when Emacs is busy.\n\
13695 This variable takes effect when you create a new frame\n\
13696 or when you set the mouse color.");
13697 Vx_hourglass_pointer_shape = Qnil;
13698
13699 DEFVAR_BOOL ("display-hourglass", &display_hourglass_p,
13700 "Non-zero means Emacs displays an hourglass pointer on window systems.");
13701 display_hourglass_p = 1;
13702
13703 DEFVAR_LISP ("hourglass-delay", &Vhourglass_delay,
13704 "*Seconds to wait before displaying an hourglass pointer.\n\
13705 Value must be an integer or float.");
13706 Vhourglass_delay = make_number (DEFAULT_HOURGLASS_DELAY);
13707
13708 DEFVAR_LISP ("x-sensitive-text-pointer-shape",
13709 &Vx_sensitive_text_pointer_shape,
13710 "The shape of the pointer when over mouse-sensitive text.\n\
13711 This variable takes effect when you create a new frame\n\
13712 or when you set the mouse color.");
13713 Vx_sensitive_text_pointer_shape = Qnil;
13714
13715 DEFVAR_LISP ("x-window-horizontal-drag-cursor",
13716 &Vx_window_horizontal_drag_shape,
13717 "Pointer shape to use for indicating a window can be dragged horizontally.\n\
13718 This variable takes effect when you create a new frame\n\
13719 or when you set the mouse color.");
13720 Vx_window_horizontal_drag_shape = Qnil;
13721
13722 DEFVAR_LISP ("x-cursor-fore-pixel", &Vx_cursor_fore_pixel,
13723 "A string indicating the foreground color of the cursor box.");
13724 Vx_cursor_fore_pixel = Qnil;
13725
13726 DEFVAR_LISP ("x-no-window-manager", &Vx_no_window_manager,
13727 "Non-nil if no window manager is in use.\n\
13728 Emacs doesn't try to figure this out; this is always nil\n\
13729 unless you set it to something else.");
13730 /* We don't have any way to find this out, so set it to nil
13731 and maybe the user would like to set it to t. */
13732 Vx_no_window_manager = Qnil;
13733
13734 DEFVAR_LISP ("x-pixel-size-width-font-regexp",
13735 &Vx_pixel_size_width_font_regexp,
13736 "Regexp matching a font name whose width is the same as `PIXEL_SIZE'.\n\
13737 \n\
13738 Since Emacs gets width of a font matching with this regexp from\n\
13739 PIXEL_SIZE field of the name, font finding mechanism gets faster for\n\
13740 such a font. This is especially effective for such large fonts as\n\
13741 Chinese, Japanese, and Korean.");
13742 Vx_pixel_size_width_font_regexp = Qnil;
13743
13744 DEFVAR_LISP ("image-cache-eviction-delay", &Vimage_cache_eviction_delay,
13745 "Time after which cached images are removed from the cache.\n\
13746 When an image has not been displayed this many seconds, remove it\n\
13747 from the image cache. Value must be an integer or nil with nil\n\
13748 meaning don't clear the cache.");
13749 Vimage_cache_eviction_delay = make_number (30 * 60);
13750
13751 DEFVAR_LISP ("w32-bdf-filename-alist",
13752 &Vw32_bdf_filename_alist,
13753 "List of bdf fonts and their corresponding filenames.");
13754 Vw32_bdf_filename_alist = Qnil;
13755
13756 DEFVAR_BOOL ("w32-strict-fontnames",
13757 &w32_strict_fontnames,
13758 "Non-nil means only use fonts that are exact matches for those requested.\n\
13759 Default is nil, which allows old fontnames that are not XLFD compliant,\n\
13760 and allows third-party CJK display to work by specifying false charset\n\
13761 fields to trick Emacs into translating to Big5, SJIS etc.\n\
13762 Setting this to t will prevent wrong fonts being selected when\n\
13763 fontsets are automatically created.");
13764 w32_strict_fontnames = 0;
13765
13766 DEFVAR_BOOL ("w32-strict-painting",
13767 &w32_strict_painting,
13768 "Non-nil means use strict rules for repainting frames.\n\
13769 Set this to nil to get the old behaviour for repainting; this should\n\
13770 only be necessary if the default setting causes problems.");
13771 w32_strict_painting = 1;
13772
13773 DEFVAR_LISP ("w32-system-coding-system",
13774 &Vw32_system_coding_system,
13775 "Coding system used by Windows system functions, such as for font names.");
13776 Vw32_system_coding_system = Qnil;
13777
13778 DEFVAR_LISP ("w32-charset-info-alist",
13779 &Vw32_charset_info_alist,
13780 "Alist linking Emacs character sets to Windows fonts\n\
13781 and codepages. Each entry should be of the form:\n\
13782 \n\
13783 (CHARSET_NAME . (WINDOWS_CHARSET . CODEPAGE))\n\
13784 \n\
13785 where CHARSET_NAME is a string used in font names to identify the charset,\n\
13786 WINDOWS_CHARSET is a symbol that can be one of:\n\
13787 w32-charset-ansi, w32-charset-default, w32-charset-symbol,\n\
13788 w32-charset-shiftjis, w32-charset-hangeul, w32-charset-gb2312,\n\
13789 w32-charset-chinesebig5, "
13790 #ifdef JOHAB_CHARSET
13791 "w32-charset-johab, w32-charset-hebrew,\n\
13792 w32-charset-arabic, w32-charset-greek, w32-charset-turkish,\n\
13793 w32-charset-vietnamese, w32-charset-thai, w32-charset-easteurope,\n\
13794 w32-charset-russian, w32-charset-mac, w32-charset-baltic,\n"
13795 #endif
13796 #ifdef UNICODE_CHARSET
13797 "w32-charset-unicode, "
13798 #endif
13799 "or w32-charset-oem.\n\
13800 CODEPAGE should be an integer specifying the codepage that should be used\n\
13801 to display the character set, t to do no translation and output as Unicode,\n\
13802 or nil to do no translation and output as 8 bit (or multibyte on far-east\n\
13803 versions of Windows) characters.");
13804 Vw32_charset_info_alist = Qnil;
13805
13806 staticpro (&Qw32_charset_ansi);
13807 Qw32_charset_ansi = intern ("w32-charset-ansi");
13808 staticpro (&Qw32_charset_symbol);
13809 Qw32_charset_symbol = intern ("w32-charset-symbol");
13810 staticpro (&Qw32_charset_shiftjis);
13811 Qw32_charset_shiftjis = intern ("w32-charset-shiftjis");
13812 staticpro (&Qw32_charset_hangeul);
13813 Qw32_charset_hangeul = intern ("w32-charset-hangeul");
13814 staticpro (&Qw32_charset_chinesebig5);
13815 Qw32_charset_chinesebig5 = intern ("w32-charset-chinesebig5");
13816 staticpro (&Qw32_charset_gb2312);
13817 Qw32_charset_gb2312 = intern ("w32-charset-gb2312");
13818 staticpro (&Qw32_charset_oem);
13819 Qw32_charset_oem = intern ("w32-charset-oem");
13820
13821 #ifdef JOHAB_CHARSET
13822 {
13823 static int w32_extra_charsets_defined = 1;
13824 DEFVAR_BOOL ("w32-extra-charsets-defined", &w32_extra_charsets_defined, "");
13825
13826 staticpro (&Qw32_charset_johab);
13827 Qw32_charset_johab = intern ("w32-charset-johab");
13828 staticpro (&Qw32_charset_easteurope);
13829 Qw32_charset_easteurope = intern ("w32-charset-easteurope");
13830 staticpro (&Qw32_charset_turkish);
13831 Qw32_charset_turkish = intern ("w32-charset-turkish");
13832 staticpro (&Qw32_charset_baltic);
13833 Qw32_charset_baltic = intern ("w32-charset-baltic");
13834 staticpro (&Qw32_charset_russian);
13835 Qw32_charset_russian = intern ("w32-charset-russian");
13836 staticpro (&Qw32_charset_arabic);
13837 Qw32_charset_arabic = intern ("w32-charset-arabic");
13838 staticpro (&Qw32_charset_greek);
13839 Qw32_charset_greek = intern ("w32-charset-greek");
13840 staticpro (&Qw32_charset_hebrew);
13841 Qw32_charset_hebrew = intern ("w32-charset-hebrew");
13842 staticpro (&Qw32_charset_vietnamese);
13843 Qw32_charset_vietnamese = intern ("w32-charset-vietnamese");
13844 staticpro (&Qw32_charset_thai);
13845 Qw32_charset_thai = intern ("w32-charset-thai");
13846 staticpro (&Qw32_charset_mac);
13847 Qw32_charset_mac = intern ("w32-charset-mac");
13848 }
13849 #endif
13850
13851 #ifdef UNICODE_CHARSET
13852 {
13853 static int w32_unicode_charset_defined = 1;
13854 DEFVAR_BOOL ("w32-unicode-charset-defined",
13855 &w32_unicode_charset_defined, "");
13856
13857 staticpro (&Qw32_charset_unicode);
13858 Qw32_charset_unicode = intern ("w32-charset-unicode");
13859 #endif
13860
13861 defsubr (&Sx_get_resource);
13862 #if 0 /* TODO: Port to W32 */
13863 defsubr (&Sx_change_window_property);
13864 defsubr (&Sx_delete_window_property);
13865 defsubr (&Sx_window_property);
13866 #endif
13867 defsubr (&Sxw_display_color_p);
13868 defsubr (&Sx_display_grayscale_p);
13869 defsubr (&Sxw_color_defined_p);
13870 defsubr (&Sxw_color_values);
13871 defsubr (&Sx_server_max_request_size);
13872 defsubr (&Sx_server_vendor);
13873 defsubr (&Sx_server_version);
13874 defsubr (&Sx_display_pixel_width);
13875 defsubr (&Sx_display_pixel_height);
13876 defsubr (&Sx_display_mm_width);
13877 defsubr (&Sx_display_mm_height);
13878 defsubr (&Sx_display_screens);
13879 defsubr (&Sx_display_planes);
13880 defsubr (&Sx_display_color_cells);
13881 defsubr (&Sx_display_visual_class);
13882 defsubr (&Sx_display_backing_store);
13883 defsubr (&Sx_display_save_under);
13884 defsubr (&Sx_parse_geometry);
13885 defsubr (&Sx_create_frame);
13886 defsubr (&Sx_open_connection);
13887 defsubr (&Sx_close_connection);
13888 defsubr (&Sx_display_list);
13889 defsubr (&Sx_synchronize);
13890
13891 /* W32 specific functions */
13892
13893 defsubr (&Sw32_focus_frame);
13894 defsubr (&Sw32_select_font);
13895 defsubr (&Sw32_define_rgb_color);
13896 defsubr (&Sw32_default_color_map);
13897 defsubr (&Sw32_load_color_file);
13898 defsubr (&Sw32_send_sys_command);
13899 defsubr (&Sw32_shell_execute);
13900 defsubr (&Sw32_register_hot_key);
13901 defsubr (&Sw32_unregister_hot_key);
13902 defsubr (&Sw32_registered_hot_keys);
13903 defsubr (&Sw32_reconstruct_hot_key);
13904 defsubr (&Sw32_toggle_lock_key);
13905 defsubr (&Sw32_find_bdf_fonts);
13906
13907 defsubr (&Sfile_system_info);
13908
13909 /* Setting callback functions for fontset handler. */
13910 get_font_info_func = w32_get_font_info;
13911
13912 #if 0 /* This function pointer doesn't seem to be used anywhere.
13913 And the pointer assigned has the wrong type, anyway. */
13914 list_fonts_func = w32_list_fonts;
13915 #endif
13916
13917 load_font_func = w32_load_font;
13918 find_ccl_program_func = w32_find_ccl_program;
13919 query_font_func = w32_query_font;
13920 set_frame_fontset_func = x_set_font;
13921 check_window_system_func = check_w32;
13922
13923 #if 0 /* TODO Image support for W32 */
13924 /* Images. */
13925 Qxbm = intern ("xbm");
13926 staticpro (&Qxbm);
13927 QCtype = intern (":type");
13928 staticpro (&QCtype);
13929 QCconversion = intern (":conversion");
13930 staticpro (&QCconversion);
13931 QCheuristic_mask = intern (":heuristic-mask");
13932 staticpro (&QCheuristic_mask);
13933 QCcolor_symbols = intern (":color-symbols");
13934 staticpro (&QCcolor_symbols);
13935 QCascent = intern (":ascent");
13936 staticpro (&QCascent);
13937 QCmargin = intern (":margin");
13938 staticpro (&QCmargin);
13939 QCrelief = intern (":relief");
13940 staticpro (&QCrelief);
13941 Qpostscript = intern ("postscript");
13942 staticpro (&Qpostscript);
13943 QCloader = intern (":loader");
13944 staticpro (&QCloader);
13945 QCbounding_box = intern (":bounding-box");
13946 staticpro (&QCbounding_box);
13947 QCpt_width = intern (":pt-width");
13948 staticpro (&QCpt_width);
13949 QCpt_height = intern (":pt-height");
13950 staticpro (&QCpt_height);
13951 QCindex = intern (":index");
13952 staticpro (&QCindex);
13953 Qpbm = intern ("pbm");
13954 staticpro (&Qpbm);
13955
13956 #if HAVE_XPM
13957 Qxpm = intern ("xpm");
13958 staticpro (&Qxpm);
13959 #endif
13960
13961 #if HAVE_JPEG
13962 Qjpeg = intern ("jpeg");
13963 staticpro (&Qjpeg);
13964 #endif
13965
13966 #if HAVE_TIFF
13967 Qtiff = intern ("tiff");
13968 staticpro (&Qtiff);
13969 #endif
13970
13971 #if HAVE_GIF
13972 Qgif = intern ("gif");
13973 staticpro (&Qgif);
13974 #endif
13975
13976 #if HAVE_PNG
13977 Qpng = intern ("png");
13978 staticpro (&Qpng);
13979 #endif
13980
13981 defsubr (&Sclear_image_cache);
13982
13983 #if GLYPH_DEBUG
13984 defsubr (&Simagep);
13985 defsubr (&Slookup_image);
13986 #endif
13987 #endif /* TODO */
13988
13989 hourglass_atimer = NULL;
13990 hourglass_shown_p = 0;
13991 #ifdef TODO /* Tooltip support not complete. */
13992 defsubr (&Sx_show_tip);
13993 defsubr (&Sx_hide_tip);
13994 #endif
13995 tip_timer = Qnil;
13996 staticpro (&tip_timer);
13997 tip_frame = Qnil;
13998 staticpro (&tip_frame);
13999
14000 defsubr (&Sx_file_dialog);
14001 }
14002
14003
14004 void
14005 init_xfns ()
14006 {
14007 image_types = NULL;
14008 Vimage_types = Qnil;
14009
14010 #if 0 /* TODO : Image support for W32 */
14011 define_image_type (&xbm_type);
14012 define_image_type (&gs_type);
14013 define_image_type (&pbm_type);
14014
14015 #if HAVE_XPM
14016 define_image_type (&xpm_type);
14017 #endif
14018
14019 #if HAVE_JPEG
14020 define_image_type (&jpeg_type);
14021 #endif
14022
14023 #if HAVE_TIFF
14024 define_image_type (&tiff_type);
14025 #endif
14026
14027 #if HAVE_GIF
14028 define_image_type (&gif_type);
14029 #endif
14030
14031 #if HAVE_PNG
14032 define_image_type (&png_type);
14033 #endif
14034 #endif /* TODO */
14035 }
14036
14037 #undef abort
14038
14039 void
14040 w32_abort()
14041 {
14042 int button;
14043 button = MessageBox (NULL,
14044 "A fatal error has occurred!\n\n"
14045 "Select Abort to exit, Retry to debug, Ignore to continue",
14046 "Emacs Abort Dialog",
14047 MB_ICONEXCLAMATION | MB_TASKMODAL
14048 | MB_SETFOREGROUND | MB_ABORTRETRYIGNORE);
14049 switch (button)
14050 {
14051 case IDRETRY:
14052 DebugBreak ();
14053 break;
14054 case IDIGNORE:
14055 break;
14056 case IDABORT:
14057 default:
14058 abort ();
14059 break;
14060 }
14061 }
14062
14063 /* For convenience when debugging. */
14064 int
14065 w32_last_error()
14066 {
14067 return GetLastError ();
14068 }