Doc fixes.
[emacs.git] / src / w32fns.c
blobad914f44a4ce299f07f529be97dc040fe9137dfe
1 /* Graphical user interface functions for the Microsoft W32 API.
2 Copyright (C) 1989, 92, 93, 94, 95, 1996, 1997, 1998, 1999
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
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.
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.
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. */
22 /* Added by Kevin Gallo */
24 #include <config.h>
26 #include <signal.h>
27 #include <stdio.h>
28 #include <limits.h>
29 #include <errno.h>
31 #include "lisp.h"
32 #include "charset.h"
33 #include "w32term.h"
34 #include "frame.h"
35 #include "window.h"
36 #include "buffer.h"
37 #include "dispextern.h"
38 #include "fontset.h"
39 #include "intervals.h"
40 #include "keyboard.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"
49 #include "bitmaps/gray.xbm"
51 #include <commdlg.h>
52 #include <shellapi.h>
53 #include <ctype.h>
55 extern void free_frame_menubar ();
56 extern double atof ();
57 extern struct scroll_bar *x_window_to_scroll_bar ();
58 extern int w32_console_toggle_lock_key (int vk_code, Lisp_Object new_state);
59 extern int quit_char;
61 /* A definition of XColor for non-X frames. */
62 #ifndef HAVE_X_WINDOWS
63 typedef struct {
64 unsigned long pixel;
65 unsigned short red, green, blue;
66 char flags;
67 char pad;
68 } XColor;
69 #endif
71 extern char *lispy_function_keys[];
73 /* The gray bitmap `bitmaps/gray'. This is done because w32term.c uses
74 it, and including `bitmaps/gray' more than once is a problem when
75 config.h defines `static' as an empty replacement string. */
77 int gray_bitmap_width = gray_width;
78 int gray_bitmap_height = gray_height;
79 unsigned char *gray_bitmap_bits = gray_bits;
81 /* The colormap for converting color names to RGB values */
82 Lisp_Object Vw32_color_map;
84 /* Non nil if alt key presses are passed on to Windows. */
85 Lisp_Object Vw32_pass_alt_to_system;
87 /* Non nil if alt key is translated to meta_modifier, nil if it is translated
88 to alt_modifier. */
89 Lisp_Object Vw32_alt_is_meta;
91 /* If non-zero, the windows virtual key code for an alternative quit key. */
92 Lisp_Object Vw32_quit_key;
94 /* Non nil if left window key events are passed on to Windows (this only
95 affects whether "tapping" the key opens the Start menu). */
96 Lisp_Object Vw32_pass_lwindow_to_system;
98 /* Non nil if right window key events are passed on to Windows (this
99 only affects whether "tapping" the key opens the Start menu). */
100 Lisp_Object Vw32_pass_rwindow_to_system;
102 /* Virtual key code used to generate "phantom" key presses in order
103 to stop system from acting on Windows key events. */
104 Lisp_Object Vw32_phantom_key_code;
106 /* Modifier associated with the left "Windows" key, or nil to act as a
107 normal key. */
108 Lisp_Object Vw32_lwindow_modifier;
110 /* Modifier associated with the right "Windows" key, or nil to act as a
111 normal key. */
112 Lisp_Object Vw32_rwindow_modifier;
114 /* Modifier associated with the "Apps" key, or nil to act as a normal
115 key. */
116 Lisp_Object Vw32_apps_modifier;
118 /* Value is nil if Num Lock acts as a function key. */
119 Lisp_Object Vw32_enable_num_lock;
121 /* Value is nil if Caps Lock acts as a function key. */
122 Lisp_Object Vw32_enable_caps_lock;
124 /* Modifier associated with Scroll Lock, or nil to act as a normal key. */
125 Lisp_Object Vw32_scroll_lock_modifier;
127 /* Switch to control whether we inhibit requests for synthesized bold
128 and italic versions of fonts. */
129 Lisp_Object Vw32_enable_synthesized_fonts;
131 /* Enable palette management. */
132 Lisp_Object Vw32_enable_palette;
134 /* Control how close left/right button down events must be to
135 be converted to a middle button down event. */
136 Lisp_Object Vw32_mouse_button_tolerance;
138 /* Minimum interval between mouse movement (and scroll bar drag)
139 events that are passed on to the event loop. */
140 Lisp_Object Vw32_mouse_move_interval;
142 /* The name we're using in resource queries. */
143 Lisp_Object Vx_resource_name;
145 /* Non nil if no window manager is in use. */
146 Lisp_Object Vx_no_window_manager;
148 /* Non-zero means we're allowed to display a busy cursor. */
149 int display_busy_cursor_p;
151 /* The background and shape of the mouse pointer, and shape when not
152 over text or in the modeline. */
153 Lisp_Object Vx_pointer_shape, Vx_nontext_pointer_shape, Vx_mode_pointer_shape;
154 Lisp_Object Vx_busy_pointer_shape;
156 /* The shape when over mouse-sensitive text. */
157 Lisp_Object Vx_sensitive_text_pointer_shape;
159 /* Color of chars displayed in cursor box. */
160 Lisp_Object Vx_cursor_fore_pixel;
162 /* Nonzero if using Windows. */
163 static int w32_in_use;
165 /* Search path for bitmap files. */
166 Lisp_Object Vx_bitmap_file_path;
168 /* Regexp matching a font name whose width is the same as `PIXEL_SIZE'. */
169 Lisp_Object Vx_pixel_size_width_font_regexp;
171 /* Alist of bdf fonts and the files that define them. */
172 Lisp_Object Vw32_bdf_filename_alist;
174 Lisp_Object Vw32_system_coding_system;
176 /* A flag to control whether fonts are matched strictly or not. */
177 int w32_strict_fontnames;
179 /* A flag to control whether we should only repaint if GetUpdateRect
180 indicates there is an update region. */
181 int w32_strict_painting;
183 /* Evaluate this expression to rebuild the section of syms_of_w32fns
184 that initializes and staticpros the symbols declared below. Note
185 that Emacs 18 has a bug that keeps C-x C-e from being able to
186 evaluate this expression.
188 (progn
189 ;; Accumulate a list of the symbols we want to initialize from the
190 ;; declarations at the top of the file.
191 (goto-char (point-min))
192 (search-forward "/\*&&& symbols declared here &&&*\/\n")
193 (let (symbol-list)
194 (while (looking-at "Lisp_Object \\(Q[a-z_]+\\)")
195 (setq symbol-list
196 (cons (buffer-substring (match-beginning 1) (match-end 1))
197 symbol-list))
198 (forward-line 1))
199 (setq symbol-list (nreverse symbol-list))
200 ;; Delete the section of syms_of_... where we initialize the symbols.
201 (search-forward "\n /\*&&& init symbols here &&&*\/\n")
202 (let ((start (point)))
203 (while (looking-at "^ Q")
204 (forward-line 2))
205 (kill-region start (point)))
206 ;; Write a new symbol initialization section.
207 (while symbol-list
208 (insert (format " %s = intern (\"" (car symbol-list)))
209 (let ((start (point)))
210 (insert (substring (car symbol-list) 1))
211 (subst-char-in-region start (point) ?_ ?-))
212 (insert (format "\");\n staticpro (&%s);\n" (car symbol-list)))
213 (setq symbol-list (cdr symbol-list)))))
217 /*&&& symbols declared here &&&*/
218 Lisp_Object Qauto_raise;
219 Lisp_Object Qauto_lower;
220 Lisp_Object Qbar;
221 Lisp_Object Qborder_color;
222 Lisp_Object Qborder_width;
223 Lisp_Object Qbox;
224 Lisp_Object Qcursor_color;
225 Lisp_Object Qcursor_type;
226 Lisp_Object Qgeometry;
227 Lisp_Object Qicon_left;
228 Lisp_Object Qicon_top;
229 Lisp_Object Qicon_type;
230 Lisp_Object Qicon_name;
231 Lisp_Object Qinternal_border_width;
232 Lisp_Object Qleft;
233 Lisp_Object Qright;
234 Lisp_Object Qmouse_color;
235 Lisp_Object Qnone;
236 Lisp_Object Qparent_id;
237 Lisp_Object Qscroll_bar_width;
238 Lisp_Object Qsuppress_icon;
239 Lisp_Object Qundefined_color;
240 Lisp_Object Qvertical_scroll_bars;
241 Lisp_Object Qvisibility;
242 Lisp_Object Qwindow_id;
243 Lisp_Object Qx_frame_parameter;
244 Lisp_Object Qx_resource_name;
245 Lisp_Object Quser_position;
246 Lisp_Object Quser_size;
247 Lisp_Object Qscreen_gamma;
248 Lisp_Object Qhyper;
249 Lisp_Object Qsuper;
250 Lisp_Object Qmeta;
251 Lisp_Object Qalt;
252 Lisp_Object Qctrl;
253 Lisp_Object Qcontrol;
254 Lisp_Object Qshift;
256 extern Lisp_Object Qtop;
257 extern Lisp_Object Qdisplay;
258 extern Lisp_Object Qtool_bar_lines;
260 /* State variables for emulating a three button mouse. */
261 #define LMOUSE 1
262 #define MMOUSE 2
263 #define RMOUSE 4
265 static int button_state = 0;
266 static W32Msg saved_mouse_button_msg;
267 static unsigned mouse_button_timer; /* non-zero when timer is active */
268 static W32Msg saved_mouse_move_msg;
269 static unsigned mouse_move_timer;
271 /* W95 mousewheel handler */
272 unsigned int msh_mousewheel = 0;
274 #define MOUSE_BUTTON_ID 1
275 #define MOUSE_MOVE_ID 2
277 /* The below are defined in frame.c. */
278 extern Lisp_Object Qheight, Qminibuffer, Qname, Qonly, Qwidth;
279 extern Lisp_Object Qunsplittable, Qmenu_bar_lines, Qbuffer_predicate, Qtitle;
280 extern Lisp_Object Qtool_bar_lines;
282 extern Lisp_Object Vwindow_system_version;
284 Lisp_Object Qface_set_after_frame_default;
286 extern Lisp_Object last_mouse_scroll_bar;
287 extern int last_mouse_scroll_bar_pos;
289 /* From w32term.c. */
290 extern Lisp_Object Vw32_num_mouse_buttons;
291 extern Lisp_Object Vw32_recognize_altgr;
294 /* Error if we are not connected to MS-Windows. */
295 void
296 check_w32 ()
298 if (! w32_in_use)
299 error ("MS-Windows not in use or not initialized");
302 /* Nonzero if we can use mouse menus.
303 You should not call this unless HAVE_MENUS is defined. */
306 have_menus_p ()
308 return w32_in_use;
311 /* Extract a frame as a FRAME_PTR, defaulting to the selected frame
312 and checking validity for W32. */
314 FRAME_PTR
315 check_x_frame (frame)
316 Lisp_Object frame;
318 FRAME_PTR f;
320 if (NILP (frame))
321 frame = selected_frame;
322 CHECK_LIVE_FRAME (frame, 0);
323 f = XFRAME (frame);
324 if (! FRAME_W32_P (f))
325 error ("non-w32 frame used");
326 return f;
329 /* Let the user specify an display with a frame.
330 nil stands for the selected frame--or, if that is not a w32 frame,
331 the first display on the list. */
333 static struct w32_display_info *
334 check_x_display_info (frame)
335 Lisp_Object frame;
337 if (NILP (frame))
339 struct frame *sf = XFRAME (selected_frame);
341 if (FRAME_W32_P (sf) && FRAME_LIVE_P (sf))
342 return FRAME_W32_DISPLAY_INFO (sf);
343 else
344 return &one_w32_display_info;
346 else if (STRINGP (frame))
347 return x_display_info_for_name (frame);
348 else
350 FRAME_PTR f;
352 CHECK_LIVE_FRAME (frame, 0);
353 f = XFRAME (frame);
354 if (! FRAME_W32_P (f))
355 error ("non-w32 frame used");
356 return FRAME_W32_DISPLAY_INFO (f);
360 /* Return the Emacs frame-object corresponding to an w32 window.
361 It could be the frame's main window or an icon window. */
363 /* This function can be called during GC, so use GC_xxx type test macros. */
365 struct frame *
366 x_window_to_frame (dpyinfo, wdesc)
367 struct w32_display_info *dpyinfo;
368 HWND wdesc;
370 Lisp_Object tail, frame;
371 struct frame *f;
373 for (tail = Vframe_list; GC_CONSP (tail); tail = XCDR (tail))
375 frame = XCAR (tail);
376 if (!GC_FRAMEP (frame))
377 continue;
378 f = XFRAME (frame);
379 if (!FRAME_W32_P (f) || FRAME_W32_DISPLAY_INFO (f) != dpyinfo)
380 continue;
381 if (f->output_data.w32->busy_window == wdesc)
382 return f;
384 /* NTEMACS_TODO: Check tooltips when supported. */
385 if (FRAME_W32_WINDOW (f) == wdesc)
386 return f;
388 return 0;
393 /* Code to deal with bitmaps. Bitmaps are referenced by their bitmap
394 id, which is just an int that this section returns. Bitmaps are
395 reference counted so they can be shared among frames.
397 Bitmap indices are guaranteed to be > 0, so a negative number can
398 be used to indicate no bitmap.
400 If you use x_create_bitmap_from_data, then you must keep track of
401 the bitmaps yourself. That is, creating a bitmap from the same
402 data more than once will not be caught. */
405 /* Functions to access the contents of a bitmap, given an id. */
408 x_bitmap_height (f, id)
409 FRAME_PTR f;
410 int id;
412 return FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].height;
416 x_bitmap_width (f, id)
417 FRAME_PTR f;
418 int id;
420 return FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].width;
424 x_bitmap_pixmap (f, id)
425 FRAME_PTR f;
426 int id;
428 return (int) FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].pixmap;
432 /* Allocate a new bitmap record. Returns index of new record. */
434 static int
435 x_allocate_bitmap_record (f)
436 FRAME_PTR f;
438 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
439 int i;
441 if (dpyinfo->bitmaps == NULL)
443 dpyinfo->bitmaps_size = 10;
444 dpyinfo->bitmaps
445 = (struct w32_bitmap_record *) xmalloc (dpyinfo->bitmaps_size * sizeof (struct w32_bitmap_record));
446 dpyinfo->bitmaps_last = 1;
447 return 1;
450 if (dpyinfo->bitmaps_last < dpyinfo->bitmaps_size)
451 return ++dpyinfo->bitmaps_last;
453 for (i = 0; i < dpyinfo->bitmaps_size; ++i)
454 if (dpyinfo->bitmaps[i].refcount == 0)
455 return i + 1;
457 dpyinfo->bitmaps_size *= 2;
458 dpyinfo->bitmaps
459 = (struct w32_bitmap_record *) xrealloc (dpyinfo->bitmaps,
460 dpyinfo->bitmaps_size * sizeof (struct w32_bitmap_record));
461 return ++dpyinfo->bitmaps_last;
464 /* Add one reference to the reference count of the bitmap with id ID. */
466 void
467 x_reference_bitmap (f, id)
468 FRAME_PTR f;
469 int id;
471 ++FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].refcount;
474 /* Create a bitmap for frame F from a HEIGHT x WIDTH array of bits at BITS. */
477 x_create_bitmap_from_data (f, bits, width, height)
478 struct frame *f;
479 char *bits;
480 unsigned int width, height;
482 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
483 Pixmap bitmap;
484 int id;
486 bitmap = CreateBitmap (width, height,
487 FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_planes,
488 FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_cbits,
489 bits);
491 if (! bitmap)
492 return -1;
494 id = x_allocate_bitmap_record (f);
495 dpyinfo->bitmaps[id - 1].pixmap = bitmap;
496 dpyinfo->bitmaps[id - 1].file = NULL;
497 dpyinfo->bitmaps[id - 1].hinst = NULL;
498 dpyinfo->bitmaps[id - 1].refcount = 1;
499 dpyinfo->bitmaps[id - 1].depth = 1;
500 dpyinfo->bitmaps[id - 1].height = height;
501 dpyinfo->bitmaps[id - 1].width = width;
503 return id;
506 /* Create bitmap from file FILE for frame F. */
509 x_create_bitmap_from_file (f, file)
510 struct frame *f;
511 Lisp_Object file;
513 return -1;
514 #if 0 /* NTEMACS_TODO : bitmap support */
515 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
516 unsigned int width, height;
517 HBITMAP bitmap;
518 int xhot, yhot, result, id;
519 Lisp_Object found;
520 int fd;
521 char *filename;
522 HINSTANCE hinst;
524 /* Look for an existing bitmap with the same name. */
525 for (id = 0; id < dpyinfo->bitmaps_last; ++id)
527 if (dpyinfo->bitmaps[id].refcount
528 && dpyinfo->bitmaps[id].file
529 && !strcmp (dpyinfo->bitmaps[id].file, (char *) XSTRING (file)->data))
531 ++dpyinfo->bitmaps[id].refcount;
532 return id + 1;
536 /* Search bitmap-file-path for the file, if appropriate. */
537 fd = openp (Vx_bitmap_file_path, file, "", &found, 0);
538 if (fd < 0)
539 return -1;
540 /* LoadLibraryEx won't handle special files handled by Emacs handler. */
541 if (fd == 0)
542 return -1;
543 emacs_close (fd);
545 filename = (char *) XSTRING (found)->data;
547 hinst = LoadLibraryEx (filename, NULL, LOAD_LIBRARY_AS_DATAFILE);
549 if (hinst == NULL)
550 return -1;
553 result = XReadBitmapFile (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
554 filename, &width, &height, &bitmap, &xhot, &yhot);
555 if (result != BitmapSuccess)
556 return -1;
558 id = x_allocate_bitmap_record (f);
559 dpyinfo->bitmaps[id - 1].pixmap = bitmap;
560 dpyinfo->bitmaps[id - 1].refcount = 1;
561 dpyinfo->bitmaps[id - 1].file = (char *) xmalloc (XSTRING (file)->size + 1);
562 dpyinfo->bitmaps[id - 1].depth = 1;
563 dpyinfo->bitmaps[id - 1].height = height;
564 dpyinfo->bitmaps[id - 1].width = width;
565 strcpy (dpyinfo->bitmaps[id - 1].file, XSTRING (file)->data);
567 return id;
568 #endif /* NTEMACS_TODO */
571 /* Remove reference to bitmap with id number ID. */
573 void
574 x_destroy_bitmap (f, id)
575 FRAME_PTR f;
576 int id;
578 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
580 if (id > 0)
582 --dpyinfo->bitmaps[id - 1].refcount;
583 if (dpyinfo->bitmaps[id - 1].refcount == 0)
585 BLOCK_INPUT;
586 DeleteObject (dpyinfo->bitmaps[id - 1].pixmap);
587 if (dpyinfo->bitmaps[id - 1].file)
589 xfree (dpyinfo->bitmaps[id - 1].file);
590 dpyinfo->bitmaps[id - 1].file = NULL;
592 UNBLOCK_INPUT;
597 /* Free all the bitmaps for the display specified by DPYINFO. */
599 static void
600 x_destroy_all_bitmaps (dpyinfo)
601 struct w32_display_info *dpyinfo;
603 int i;
604 for (i = 0; i < dpyinfo->bitmaps_last; i++)
605 if (dpyinfo->bitmaps[i].refcount > 0)
607 DeleteObject (dpyinfo->bitmaps[i].pixmap);
608 if (dpyinfo->bitmaps[i].file)
609 xfree (dpyinfo->bitmaps[i].file);
611 dpyinfo->bitmaps_last = 0;
614 /* Connect the frame-parameter names for W32 frames
615 to the ways of passing the parameter values to the window system.
617 The name of a parameter, as a Lisp symbol,
618 has an `x-frame-parameter' property which is an integer in Lisp
619 but can be interpreted as an `enum x_frame_parm' in C. */
621 enum x_frame_parm
623 X_PARM_FOREGROUND_COLOR,
624 X_PARM_BACKGROUND_COLOR,
625 X_PARM_MOUSE_COLOR,
626 X_PARM_CURSOR_COLOR,
627 X_PARM_BORDER_COLOR,
628 X_PARM_ICON_TYPE,
629 X_PARM_FONT,
630 X_PARM_BORDER_WIDTH,
631 X_PARM_INTERNAL_BORDER_WIDTH,
632 X_PARM_NAME,
633 X_PARM_AUTORAISE,
634 X_PARM_AUTOLOWER,
635 X_PARM_VERT_SCROLL_BAR,
636 X_PARM_VISIBILITY,
637 X_PARM_MENU_BAR_LINES
641 struct x_frame_parm_table
643 char *name;
644 void (*setter) P_ ((struct frame *, Lisp_Object, Lisp_Object));
647 /* NTEMACS_TODO: Native Input Method support; see x_create_im. */
648 void x_set_foreground_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
649 void x_set_background_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
650 void x_set_mouse_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
651 void x_set_cursor_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
652 void x_set_border_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
653 void x_set_cursor_type P_ ((struct frame *, Lisp_Object, Lisp_Object));
654 void x_set_icon_type P_ ((struct frame *, Lisp_Object, Lisp_Object));
655 void x_set_icon_name P_ ((struct frame *, Lisp_Object, Lisp_Object));
656 void x_set_font P_ ((struct frame *, Lisp_Object, Lisp_Object));
657 void x_set_border_width P_ ((struct frame *, Lisp_Object, Lisp_Object));
658 void x_set_internal_border_width P_ ((struct frame *, Lisp_Object,
659 Lisp_Object));
660 void x_explicitly_set_name P_ ((struct frame *, Lisp_Object, Lisp_Object));
661 void x_set_autoraise P_ ((struct frame *, Lisp_Object, Lisp_Object));
662 void x_set_autolower P_ ((struct frame *, Lisp_Object, Lisp_Object));
663 void x_set_vertical_scroll_bars P_ ((struct frame *, Lisp_Object,
664 Lisp_Object));
665 void x_set_visibility P_ ((struct frame *, Lisp_Object, Lisp_Object));
666 void x_set_menu_bar_lines P_ ((struct frame *, Lisp_Object, Lisp_Object));
667 void x_set_scroll_bar_width P_ ((struct frame *, Lisp_Object, Lisp_Object));
668 void x_set_title P_ ((struct frame *, Lisp_Object, Lisp_Object));
669 void x_set_unsplittable P_ ((struct frame *, Lisp_Object, Lisp_Object));
670 void x_set_tool_bar_lines P_ ((struct frame *, Lisp_Object, Lisp_Object));
671 static void x_set_screen_gamma P_ ((struct frame *, Lisp_Object, Lisp_Object));
673 static struct x_frame_parm_table x_frame_parms[] =
675 "auto-raise", x_set_autoraise,
676 "auto-lower", x_set_autolower,
677 "background-color", x_set_background_color,
678 "border-color", x_set_border_color,
679 "border-width", x_set_border_width,
680 "cursor-color", x_set_cursor_color,
681 "cursor-type", x_set_cursor_type,
682 "font", x_set_font,
683 "foreground-color", x_set_foreground_color,
684 "icon-name", x_set_icon_name,
685 "icon-type", x_set_icon_type,
686 "internal-border-width", x_set_internal_border_width,
687 "menu-bar-lines", x_set_menu_bar_lines,
688 "mouse-color", x_set_mouse_color,
689 "name", x_explicitly_set_name,
690 "scroll-bar-width", x_set_scroll_bar_width,
691 "title", x_set_title,
692 "unsplittable", x_set_unsplittable,
693 "vertical-scroll-bars", x_set_vertical_scroll_bars,
694 "visibility", x_set_visibility,
695 "tool-bar-lines", x_set_tool_bar_lines,
696 "screen-gamma", x_set_screen_gamma
699 /* Attach the `x-frame-parameter' properties to
700 the Lisp symbol names of parameters relevant to W32. */
702 init_x_parm_symbols ()
704 int i;
706 for (i = 0; i < sizeof (x_frame_parms) / sizeof (x_frame_parms[0]); i++)
707 Fput (intern (x_frame_parms[i].name), Qx_frame_parameter,
708 make_number (i));
711 /* Change the parameters of FRAME as specified by ALIST.
712 If a parameter is not specially recognized, do nothing;
713 otherwise call the `x_set_...' function for that parameter. */
715 void
716 x_set_frame_parameters (f, alist)
717 FRAME_PTR f;
718 Lisp_Object alist;
720 Lisp_Object tail;
722 /* If both of these parameters are present, it's more efficient to
723 set them both at once. So we wait until we've looked at the
724 entire list before we set them. */
725 int width, height;
727 /* Same here. */
728 Lisp_Object left, top;
730 /* Same with these. */
731 Lisp_Object icon_left, icon_top;
733 /* Record in these vectors all the parms specified. */
734 Lisp_Object *parms;
735 Lisp_Object *values;
736 int i, p;
737 int left_no_change = 0, top_no_change = 0;
738 int icon_left_no_change = 0, icon_top_no_change = 0;
740 struct gcpro gcpro1, gcpro2;
742 i = 0;
743 for (tail = alist; CONSP (tail); tail = Fcdr (tail))
744 i++;
746 parms = (Lisp_Object *) alloca (i * sizeof (Lisp_Object));
747 values = (Lisp_Object *) alloca (i * sizeof (Lisp_Object));
749 /* Extract parm names and values into those vectors. */
751 i = 0;
752 for (tail = alist; CONSP (tail); tail = Fcdr (tail))
754 Lisp_Object elt;
756 elt = Fcar (tail);
757 parms[i] = Fcar (elt);
758 values[i] = Fcdr (elt);
759 i++;
762 /* TAIL and ALIST are not used again below here. */
763 alist = tail = Qnil;
765 GCPRO2 (*parms, *values);
766 gcpro1.nvars = i;
767 gcpro2.nvars = i;
769 /* There is no need to gcpro LEFT, TOP, ICON_LEFT, or ICON_TOP,
770 because their values appear in VALUES and strings are not valid. */
771 top = left = Qunbound;
772 icon_left = icon_top = Qunbound;
774 /* Provide default values for HEIGHT and WIDTH. */
775 width = FRAME_WIDTH (f);
776 height = FRAME_HEIGHT (f);
778 /* Process foreground_color and background_color before anything else.
779 They are independent of other properties, but other properties (e.g.,
780 cursor_color) are dependent upon them. */
781 for (p = 0; p < i; p++)
783 Lisp_Object prop, val;
785 prop = parms[p];
786 val = values[p];
787 if (EQ (prop, Qforeground_color) || EQ (prop, Qbackground_color))
789 register Lisp_Object param_index, old_value;
791 param_index = Fget (prop, Qx_frame_parameter);
792 old_value = get_frame_param (f, prop);
793 store_frame_param (f, prop, val);
794 if (NATNUMP (param_index)
795 && (XFASTINT (param_index)
796 < sizeof (x_frame_parms)/sizeof (x_frame_parms[0])))
797 (*x_frame_parms[XINT (param_index)].setter)(f, val, old_value);
801 /* Now process them in reverse of specified order. */
802 for (i--; i >= 0; i--)
804 Lisp_Object prop, val;
806 prop = parms[i];
807 val = values[i];
809 if (EQ (prop, Qwidth) && NUMBERP (val))
810 width = XFASTINT (val);
811 else if (EQ (prop, Qheight) && NUMBERP (val))
812 height = XFASTINT (val);
813 else if (EQ (prop, Qtop))
814 top = val;
815 else if (EQ (prop, Qleft))
816 left = val;
817 else if (EQ (prop, Qicon_top))
818 icon_top = val;
819 else if (EQ (prop, Qicon_left))
820 icon_left = val;
821 else if (EQ (prop, Qforeground_color) || EQ (prop, Qbackground_color))
822 /* Processed above. */
823 continue;
824 else
826 register Lisp_Object param_index, old_value;
828 param_index = Fget (prop, Qx_frame_parameter);
829 old_value = get_frame_param (f, prop);
830 store_frame_param (f, prop, val);
831 if (NATNUMP (param_index)
832 && (XFASTINT (param_index)
833 < sizeof (x_frame_parms)/sizeof (x_frame_parms[0])))
834 (*x_frame_parms[XINT (param_index)].setter)(f, val, old_value);
838 /* Don't die if just one of these was set. */
839 if (EQ (left, Qunbound))
841 left_no_change = 1;
842 if (f->output_data.w32->left_pos < 0)
843 left = Fcons (Qplus, Fcons (make_number (f->output_data.w32->left_pos), Qnil));
844 else
845 XSETINT (left, f->output_data.w32->left_pos);
847 if (EQ (top, Qunbound))
849 top_no_change = 1;
850 if (f->output_data.w32->top_pos < 0)
851 top = Fcons (Qplus, Fcons (make_number (f->output_data.w32->top_pos), Qnil));
852 else
853 XSETINT (top, f->output_data.w32->top_pos);
856 /* If one of the icon positions was not set, preserve or default it. */
857 if (EQ (icon_left, Qunbound) || ! INTEGERP (icon_left))
859 icon_left_no_change = 1;
860 icon_left = Fcdr (Fassq (Qicon_left, f->param_alist));
861 if (NILP (icon_left))
862 XSETINT (icon_left, 0);
864 if (EQ (icon_top, Qunbound) || ! INTEGERP (icon_top))
866 icon_top_no_change = 1;
867 icon_top = Fcdr (Fassq (Qicon_top, f->param_alist));
868 if (NILP (icon_top))
869 XSETINT (icon_top, 0);
872 /* Don't set these parameters unless they've been explicitly
873 specified. The window might be mapped or resized while we're in
874 this function, and we don't want to override that unless the lisp
875 code has asked for it.
877 Don't set these parameters unless they actually differ from the
878 window's current parameters; the window may not actually exist
879 yet. */
881 Lisp_Object frame;
883 check_frame_size (f, &height, &width);
885 XSETFRAME (frame, f);
887 if (XINT (width) != FRAME_WIDTH (f)
888 || XINT (height) != FRAME_HEIGHT (f))
889 Fset_frame_size (frame, make_number (width), make_number (height));
891 if ((!NILP (left) || !NILP (top))
892 && ! (left_no_change && top_no_change)
893 && ! (NUMBERP (left) && XINT (left) == f->output_data.w32->left_pos
894 && NUMBERP (top) && XINT (top) == f->output_data.w32->top_pos))
896 int leftpos = 0;
897 int toppos = 0;
899 /* Record the signs. */
900 f->output_data.w32->size_hint_flags &= ~ (XNegative | YNegative);
901 if (EQ (left, Qminus))
902 f->output_data.w32->size_hint_flags |= XNegative;
903 else if (INTEGERP (left))
905 leftpos = XINT (left);
906 if (leftpos < 0)
907 f->output_data.w32->size_hint_flags |= XNegative;
909 else if (CONSP (left) && EQ (XCAR (left), Qminus)
910 && CONSP (XCDR (left))
911 && INTEGERP (XCAR (XCDR (left))))
913 leftpos = - XINT (XCAR (XCDR (left)));
914 f->output_data.w32->size_hint_flags |= XNegative;
916 else if (CONSP (left) && EQ (XCAR (left), Qplus)
917 && CONSP (XCDR (left))
918 && INTEGERP (XCAR (XCDR (left))))
920 leftpos = XINT (XCAR (XCDR (left)));
923 if (EQ (top, Qminus))
924 f->output_data.w32->size_hint_flags |= YNegative;
925 else if (INTEGERP (top))
927 toppos = XINT (top);
928 if (toppos < 0)
929 f->output_data.w32->size_hint_flags |= YNegative;
931 else if (CONSP (top) && EQ (XCAR (top), Qminus)
932 && CONSP (XCDR (top))
933 && INTEGERP (XCAR (XCDR (top))))
935 toppos = - XINT (XCAR (XCDR (top)));
936 f->output_data.w32->size_hint_flags |= YNegative;
938 else if (CONSP (top) && EQ (XCAR (top), Qplus)
939 && CONSP (XCDR (top))
940 && INTEGERP (XCAR (XCDR (top))))
942 toppos = XINT (XCAR (XCDR (top)));
946 /* Store the numeric value of the position. */
947 f->output_data.w32->top_pos = toppos;
948 f->output_data.w32->left_pos = leftpos;
950 f->output_data.w32->win_gravity = NorthWestGravity;
952 /* Actually set that position, and convert to absolute. */
953 x_set_offset (f, leftpos, toppos, -1);
956 if ((!NILP (icon_left) || !NILP (icon_top))
957 && ! (icon_left_no_change && icon_top_no_change))
958 x_wm_set_icon_position (f, XINT (icon_left), XINT (icon_top));
961 UNGCPRO;
964 /* Store the screen positions of frame F into XPTR and YPTR.
965 These are the positions of the containing window manager window,
966 not Emacs's own window. */
968 void
969 x_real_positions (f, xptr, yptr)
970 FRAME_PTR f;
971 int *xptr, *yptr;
973 POINT pt;
976 RECT rect;
978 GetClientRect(FRAME_W32_WINDOW(f), &rect);
979 AdjustWindowRect(&rect, f->output_data.w32->dwStyle, FRAME_EXTERNAL_MENU_BAR(f));
981 pt.x = rect.left;
982 pt.y = rect.top;
985 ClientToScreen (FRAME_W32_WINDOW(f), &pt);
987 *xptr = pt.x;
988 *yptr = pt.y;
991 /* Insert a description of internally-recorded parameters of frame X
992 into the parameter alist *ALISTPTR that is to be given to the user.
993 Only parameters that are specific to W32
994 and whose values are not correctly recorded in the frame's
995 param_alist need to be considered here. */
997 x_report_frame_params (f, alistptr)
998 struct frame *f;
999 Lisp_Object *alistptr;
1001 char buf[16];
1002 Lisp_Object tem;
1004 /* Represent negative positions (off the top or left screen edge)
1005 in a way that Fmodify_frame_parameters will understand correctly. */
1006 XSETINT (tem, f->output_data.w32->left_pos);
1007 if (f->output_data.w32->left_pos >= 0)
1008 store_in_alist (alistptr, Qleft, tem);
1009 else
1010 store_in_alist (alistptr, Qleft, Fcons (Qplus, Fcons (tem, Qnil)));
1012 XSETINT (tem, f->output_data.w32->top_pos);
1013 if (f->output_data.w32->top_pos >= 0)
1014 store_in_alist (alistptr, Qtop, tem);
1015 else
1016 store_in_alist (alistptr, Qtop, Fcons (Qplus, Fcons (tem, Qnil)));
1018 store_in_alist (alistptr, Qborder_width,
1019 make_number (f->output_data.w32->border_width));
1020 store_in_alist (alistptr, Qinternal_border_width,
1021 make_number (f->output_data.w32->internal_border_width));
1022 sprintf (buf, "%ld", (long) FRAME_W32_WINDOW (f));
1023 store_in_alist (alistptr, Qwindow_id,
1024 build_string (buf));
1025 store_in_alist (alistptr, Qicon_name, f->icon_name);
1026 FRAME_SAMPLE_VISIBILITY (f);
1027 store_in_alist (alistptr, Qvisibility,
1028 (FRAME_VISIBLE_P (f) ? Qt
1029 : FRAME_ICONIFIED_P (f) ? Qicon : Qnil));
1030 store_in_alist (alistptr, Qdisplay,
1031 XCAR (FRAME_W32_DISPLAY_INFO (f)->name_list_element));
1035 DEFUN ("w32-define-rgb-color", Fw32_define_rgb_color, Sw32_define_rgb_color, 4, 4, 0,
1036 "Convert RGB numbers to a windows color reference and associate with NAME (a string).\n\
1037 This adds or updates a named color to w32-color-map, making it available for use.\n\
1038 The original entry's RGB ref is returned, or nil if the entry is new.")
1039 (red, green, blue, name)
1040 Lisp_Object red, green, blue, name;
1042 Lisp_Object rgb;
1043 Lisp_Object oldrgb = Qnil;
1044 Lisp_Object entry;
1046 CHECK_NUMBER (red, 0);
1047 CHECK_NUMBER (green, 0);
1048 CHECK_NUMBER (blue, 0);
1049 CHECK_STRING (name, 0);
1051 XSET (rgb, Lisp_Int, RGB(XUINT (red), XUINT (green), XUINT (blue)));
1053 BLOCK_INPUT;
1055 /* replace existing entry in w32-color-map or add new entry. */
1056 entry = Fassoc (name, Vw32_color_map);
1057 if (NILP (entry))
1059 entry = Fcons (name, rgb);
1060 Vw32_color_map = Fcons (entry, Vw32_color_map);
1062 else
1064 oldrgb = Fcdr (entry);
1065 Fsetcdr (entry, rgb);
1068 UNBLOCK_INPUT;
1070 return (oldrgb);
1073 DEFUN ("w32-load-color-file", Fw32_load_color_file, Sw32_load_color_file, 1, 1, 0,
1074 "Create an alist of color entries from an external file (ie. rgb.txt).\n\
1075 Assign this value to w32-color-map to replace the existing color map.\n\
1077 The file should define one named RGB color per line like so:\
1078 R G B name\n\
1079 where R,G,B are numbers between 0 and 255 and name is an arbitrary string.")
1080 (filename)
1081 Lisp_Object filename;
1083 FILE *fp;
1084 Lisp_Object cmap = Qnil;
1085 Lisp_Object abspath;
1087 CHECK_STRING (filename, 0);
1088 abspath = Fexpand_file_name (filename, Qnil);
1090 fp = fopen (XSTRING (filename)->data, "rt");
1091 if (fp)
1093 char buf[512];
1094 int red, green, blue;
1095 int num;
1097 BLOCK_INPUT;
1099 while (fgets (buf, sizeof (buf), fp) != NULL) {
1100 if (sscanf (buf, "%u %u %u %n", &red, &green, &blue, &num) == 3)
1102 char *name = buf + num;
1103 num = strlen (name) - 1;
1104 if (name[num] == '\n')
1105 name[num] = 0;
1106 cmap = Fcons (Fcons (build_string (name),
1107 make_number (RGB (red, green, blue))),
1108 cmap);
1111 fclose (fp);
1113 UNBLOCK_INPUT;
1116 return cmap;
1119 /* The default colors for the w32 color map */
1120 typedef struct colormap_t
1122 char *name;
1123 COLORREF colorref;
1124 } colormap_t;
1126 colormap_t w32_color_map[] =
1128 {"snow" , PALETTERGB (255,250,250)},
1129 {"ghost white" , PALETTERGB (248,248,255)},
1130 {"GhostWhite" , PALETTERGB (248,248,255)},
1131 {"white smoke" , PALETTERGB (245,245,245)},
1132 {"WhiteSmoke" , PALETTERGB (245,245,245)},
1133 {"gainsboro" , PALETTERGB (220,220,220)},
1134 {"floral white" , PALETTERGB (255,250,240)},
1135 {"FloralWhite" , PALETTERGB (255,250,240)},
1136 {"old lace" , PALETTERGB (253,245,230)},
1137 {"OldLace" , PALETTERGB (253,245,230)},
1138 {"linen" , PALETTERGB (250,240,230)},
1139 {"antique white" , PALETTERGB (250,235,215)},
1140 {"AntiqueWhite" , PALETTERGB (250,235,215)},
1141 {"papaya whip" , PALETTERGB (255,239,213)},
1142 {"PapayaWhip" , PALETTERGB (255,239,213)},
1143 {"blanched almond" , PALETTERGB (255,235,205)},
1144 {"BlanchedAlmond" , PALETTERGB (255,235,205)},
1145 {"bisque" , PALETTERGB (255,228,196)},
1146 {"peach puff" , PALETTERGB (255,218,185)},
1147 {"PeachPuff" , PALETTERGB (255,218,185)},
1148 {"navajo white" , PALETTERGB (255,222,173)},
1149 {"NavajoWhite" , PALETTERGB (255,222,173)},
1150 {"moccasin" , PALETTERGB (255,228,181)},
1151 {"cornsilk" , PALETTERGB (255,248,220)},
1152 {"ivory" , PALETTERGB (255,255,240)},
1153 {"lemon chiffon" , PALETTERGB (255,250,205)},
1154 {"LemonChiffon" , PALETTERGB (255,250,205)},
1155 {"seashell" , PALETTERGB (255,245,238)},
1156 {"honeydew" , PALETTERGB (240,255,240)},
1157 {"mint cream" , PALETTERGB (245,255,250)},
1158 {"MintCream" , PALETTERGB (245,255,250)},
1159 {"azure" , PALETTERGB (240,255,255)},
1160 {"alice blue" , PALETTERGB (240,248,255)},
1161 {"AliceBlue" , PALETTERGB (240,248,255)},
1162 {"lavender" , PALETTERGB (230,230,250)},
1163 {"lavender blush" , PALETTERGB (255,240,245)},
1164 {"LavenderBlush" , PALETTERGB (255,240,245)},
1165 {"misty rose" , PALETTERGB (255,228,225)},
1166 {"MistyRose" , PALETTERGB (255,228,225)},
1167 {"white" , PALETTERGB (255,255,255)},
1168 {"black" , PALETTERGB ( 0, 0, 0)},
1169 {"dark slate gray" , PALETTERGB ( 47, 79, 79)},
1170 {"DarkSlateGray" , PALETTERGB ( 47, 79, 79)},
1171 {"dark slate grey" , PALETTERGB ( 47, 79, 79)},
1172 {"DarkSlateGrey" , PALETTERGB ( 47, 79, 79)},
1173 {"dim gray" , PALETTERGB (105,105,105)},
1174 {"DimGray" , PALETTERGB (105,105,105)},
1175 {"dim grey" , PALETTERGB (105,105,105)},
1176 {"DimGrey" , PALETTERGB (105,105,105)},
1177 {"slate gray" , PALETTERGB (112,128,144)},
1178 {"SlateGray" , PALETTERGB (112,128,144)},
1179 {"slate grey" , PALETTERGB (112,128,144)},
1180 {"SlateGrey" , PALETTERGB (112,128,144)},
1181 {"light slate gray" , PALETTERGB (119,136,153)},
1182 {"LightSlateGray" , PALETTERGB (119,136,153)},
1183 {"light slate grey" , PALETTERGB (119,136,153)},
1184 {"LightSlateGrey" , PALETTERGB (119,136,153)},
1185 {"gray" , PALETTERGB (190,190,190)},
1186 {"grey" , PALETTERGB (190,190,190)},
1187 {"light grey" , PALETTERGB (211,211,211)},
1188 {"LightGrey" , PALETTERGB (211,211,211)},
1189 {"light gray" , PALETTERGB (211,211,211)},
1190 {"LightGray" , PALETTERGB (211,211,211)},
1191 {"midnight blue" , PALETTERGB ( 25, 25,112)},
1192 {"MidnightBlue" , PALETTERGB ( 25, 25,112)},
1193 {"navy" , PALETTERGB ( 0, 0,128)},
1194 {"navy blue" , PALETTERGB ( 0, 0,128)},
1195 {"NavyBlue" , PALETTERGB ( 0, 0,128)},
1196 {"cornflower blue" , PALETTERGB (100,149,237)},
1197 {"CornflowerBlue" , PALETTERGB (100,149,237)},
1198 {"dark slate blue" , PALETTERGB ( 72, 61,139)},
1199 {"DarkSlateBlue" , PALETTERGB ( 72, 61,139)},
1200 {"slate blue" , PALETTERGB (106, 90,205)},
1201 {"SlateBlue" , PALETTERGB (106, 90,205)},
1202 {"medium slate blue" , PALETTERGB (123,104,238)},
1203 {"MediumSlateBlue" , PALETTERGB (123,104,238)},
1204 {"light slate blue" , PALETTERGB (132,112,255)},
1205 {"LightSlateBlue" , PALETTERGB (132,112,255)},
1206 {"medium blue" , PALETTERGB ( 0, 0,205)},
1207 {"MediumBlue" , PALETTERGB ( 0, 0,205)},
1208 {"royal blue" , PALETTERGB ( 65,105,225)},
1209 {"RoyalBlue" , PALETTERGB ( 65,105,225)},
1210 {"blue" , PALETTERGB ( 0, 0,255)},
1211 {"dodger blue" , PALETTERGB ( 30,144,255)},
1212 {"DodgerBlue" , PALETTERGB ( 30,144,255)},
1213 {"deep sky blue" , PALETTERGB ( 0,191,255)},
1214 {"DeepSkyBlue" , PALETTERGB ( 0,191,255)},
1215 {"sky blue" , PALETTERGB (135,206,235)},
1216 {"SkyBlue" , PALETTERGB (135,206,235)},
1217 {"light sky blue" , PALETTERGB (135,206,250)},
1218 {"LightSkyBlue" , PALETTERGB (135,206,250)},
1219 {"steel blue" , PALETTERGB ( 70,130,180)},
1220 {"SteelBlue" , PALETTERGB ( 70,130,180)},
1221 {"light steel blue" , PALETTERGB (176,196,222)},
1222 {"LightSteelBlue" , PALETTERGB (176,196,222)},
1223 {"light blue" , PALETTERGB (173,216,230)},
1224 {"LightBlue" , PALETTERGB (173,216,230)},
1225 {"powder blue" , PALETTERGB (176,224,230)},
1226 {"PowderBlue" , PALETTERGB (176,224,230)},
1227 {"pale turquoise" , PALETTERGB (175,238,238)},
1228 {"PaleTurquoise" , PALETTERGB (175,238,238)},
1229 {"dark turquoise" , PALETTERGB ( 0,206,209)},
1230 {"DarkTurquoise" , PALETTERGB ( 0,206,209)},
1231 {"medium turquoise" , PALETTERGB ( 72,209,204)},
1232 {"MediumTurquoise" , PALETTERGB ( 72,209,204)},
1233 {"turquoise" , PALETTERGB ( 64,224,208)},
1234 {"cyan" , PALETTERGB ( 0,255,255)},
1235 {"light cyan" , PALETTERGB (224,255,255)},
1236 {"LightCyan" , PALETTERGB (224,255,255)},
1237 {"cadet blue" , PALETTERGB ( 95,158,160)},
1238 {"CadetBlue" , PALETTERGB ( 95,158,160)},
1239 {"medium aquamarine" , PALETTERGB (102,205,170)},
1240 {"MediumAquamarine" , PALETTERGB (102,205,170)},
1241 {"aquamarine" , PALETTERGB (127,255,212)},
1242 {"dark green" , PALETTERGB ( 0,100, 0)},
1243 {"DarkGreen" , PALETTERGB ( 0,100, 0)},
1244 {"dark olive green" , PALETTERGB ( 85,107, 47)},
1245 {"DarkOliveGreen" , PALETTERGB ( 85,107, 47)},
1246 {"dark sea green" , PALETTERGB (143,188,143)},
1247 {"DarkSeaGreen" , PALETTERGB (143,188,143)},
1248 {"sea green" , PALETTERGB ( 46,139, 87)},
1249 {"SeaGreen" , PALETTERGB ( 46,139, 87)},
1250 {"medium sea green" , PALETTERGB ( 60,179,113)},
1251 {"MediumSeaGreen" , PALETTERGB ( 60,179,113)},
1252 {"light sea green" , PALETTERGB ( 32,178,170)},
1253 {"LightSeaGreen" , PALETTERGB ( 32,178,170)},
1254 {"pale green" , PALETTERGB (152,251,152)},
1255 {"PaleGreen" , PALETTERGB (152,251,152)},
1256 {"spring green" , PALETTERGB ( 0,255,127)},
1257 {"SpringGreen" , PALETTERGB ( 0,255,127)},
1258 {"lawn green" , PALETTERGB (124,252, 0)},
1259 {"LawnGreen" , PALETTERGB (124,252, 0)},
1260 {"green" , PALETTERGB ( 0,255, 0)},
1261 {"chartreuse" , PALETTERGB (127,255, 0)},
1262 {"medium spring green" , PALETTERGB ( 0,250,154)},
1263 {"MediumSpringGreen" , PALETTERGB ( 0,250,154)},
1264 {"green yellow" , PALETTERGB (173,255, 47)},
1265 {"GreenYellow" , PALETTERGB (173,255, 47)},
1266 {"lime green" , PALETTERGB ( 50,205, 50)},
1267 {"LimeGreen" , PALETTERGB ( 50,205, 50)},
1268 {"yellow green" , PALETTERGB (154,205, 50)},
1269 {"YellowGreen" , PALETTERGB (154,205, 50)},
1270 {"forest green" , PALETTERGB ( 34,139, 34)},
1271 {"ForestGreen" , PALETTERGB ( 34,139, 34)},
1272 {"olive drab" , PALETTERGB (107,142, 35)},
1273 {"OliveDrab" , PALETTERGB (107,142, 35)},
1274 {"dark khaki" , PALETTERGB (189,183,107)},
1275 {"DarkKhaki" , PALETTERGB (189,183,107)},
1276 {"khaki" , PALETTERGB (240,230,140)},
1277 {"pale goldenrod" , PALETTERGB (238,232,170)},
1278 {"PaleGoldenrod" , PALETTERGB (238,232,170)},
1279 {"light goldenrod yellow" , PALETTERGB (250,250,210)},
1280 {"LightGoldenrodYellow" , PALETTERGB (250,250,210)},
1281 {"light yellow" , PALETTERGB (255,255,224)},
1282 {"LightYellow" , PALETTERGB (255,255,224)},
1283 {"yellow" , PALETTERGB (255,255, 0)},
1284 {"gold" , PALETTERGB (255,215, 0)},
1285 {"light goldenrod" , PALETTERGB (238,221,130)},
1286 {"LightGoldenrod" , PALETTERGB (238,221,130)},
1287 {"goldenrod" , PALETTERGB (218,165, 32)},
1288 {"dark goldenrod" , PALETTERGB (184,134, 11)},
1289 {"DarkGoldenrod" , PALETTERGB (184,134, 11)},
1290 {"rosy brown" , PALETTERGB (188,143,143)},
1291 {"RosyBrown" , PALETTERGB (188,143,143)},
1292 {"indian red" , PALETTERGB (205, 92, 92)},
1293 {"IndianRed" , PALETTERGB (205, 92, 92)},
1294 {"saddle brown" , PALETTERGB (139, 69, 19)},
1295 {"SaddleBrown" , PALETTERGB (139, 69, 19)},
1296 {"sienna" , PALETTERGB (160, 82, 45)},
1297 {"peru" , PALETTERGB (205,133, 63)},
1298 {"burlywood" , PALETTERGB (222,184,135)},
1299 {"beige" , PALETTERGB (245,245,220)},
1300 {"wheat" , PALETTERGB (245,222,179)},
1301 {"sandy brown" , PALETTERGB (244,164, 96)},
1302 {"SandyBrown" , PALETTERGB (244,164, 96)},
1303 {"tan" , PALETTERGB (210,180,140)},
1304 {"chocolate" , PALETTERGB (210,105, 30)},
1305 {"firebrick" , PALETTERGB (178,34, 34)},
1306 {"brown" , PALETTERGB (165,42, 42)},
1307 {"dark salmon" , PALETTERGB (233,150,122)},
1308 {"DarkSalmon" , PALETTERGB (233,150,122)},
1309 {"salmon" , PALETTERGB (250,128,114)},
1310 {"light salmon" , PALETTERGB (255,160,122)},
1311 {"LightSalmon" , PALETTERGB (255,160,122)},
1312 {"orange" , PALETTERGB (255,165, 0)},
1313 {"dark orange" , PALETTERGB (255,140, 0)},
1314 {"DarkOrange" , PALETTERGB (255,140, 0)},
1315 {"coral" , PALETTERGB (255,127, 80)},
1316 {"light coral" , PALETTERGB (240,128,128)},
1317 {"LightCoral" , PALETTERGB (240,128,128)},
1318 {"tomato" , PALETTERGB (255, 99, 71)},
1319 {"orange red" , PALETTERGB (255, 69, 0)},
1320 {"OrangeRed" , PALETTERGB (255, 69, 0)},
1321 {"red" , PALETTERGB (255, 0, 0)},
1322 {"hot pink" , PALETTERGB (255,105,180)},
1323 {"HotPink" , PALETTERGB (255,105,180)},
1324 {"deep pink" , PALETTERGB (255, 20,147)},
1325 {"DeepPink" , PALETTERGB (255, 20,147)},
1326 {"pink" , PALETTERGB (255,192,203)},
1327 {"light pink" , PALETTERGB (255,182,193)},
1328 {"LightPink" , PALETTERGB (255,182,193)},
1329 {"pale violet red" , PALETTERGB (219,112,147)},
1330 {"PaleVioletRed" , PALETTERGB (219,112,147)},
1331 {"maroon" , PALETTERGB (176, 48, 96)},
1332 {"medium violet red" , PALETTERGB (199, 21,133)},
1333 {"MediumVioletRed" , PALETTERGB (199, 21,133)},
1334 {"violet red" , PALETTERGB (208, 32,144)},
1335 {"VioletRed" , PALETTERGB (208, 32,144)},
1336 {"magenta" , PALETTERGB (255, 0,255)},
1337 {"violet" , PALETTERGB (238,130,238)},
1338 {"plum" , PALETTERGB (221,160,221)},
1339 {"orchid" , PALETTERGB (218,112,214)},
1340 {"medium orchid" , PALETTERGB (186, 85,211)},
1341 {"MediumOrchid" , PALETTERGB (186, 85,211)},
1342 {"dark orchid" , PALETTERGB (153, 50,204)},
1343 {"DarkOrchid" , PALETTERGB (153, 50,204)},
1344 {"dark violet" , PALETTERGB (148, 0,211)},
1345 {"DarkViolet" , PALETTERGB (148, 0,211)},
1346 {"blue violet" , PALETTERGB (138, 43,226)},
1347 {"BlueViolet" , PALETTERGB (138, 43,226)},
1348 {"purple" , PALETTERGB (160, 32,240)},
1349 {"medium purple" , PALETTERGB (147,112,219)},
1350 {"MediumPurple" , PALETTERGB (147,112,219)},
1351 {"thistle" , PALETTERGB (216,191,216)},
1352 {"gray0" , PALETTERGB ( 0, 0, 0)},
1353 {"grey0" , PALETTERGB ( 0, 0, 0)},
1354 {"dark grey" , PALETTERGB (169,169,169)},
1355 {"DarkGrey" , PALETTERGB (169,169,169)},
1356 {"dark gray" , PALETTERGB (169,169,169)},
1357 {"DarkGray" , PALETTERGB (169,169,169)},
1358 {"dark blue" , PALETTERGB ( 0, 0,139)},
1359 {"DarkBlue" , PALETTERGB ( 0, 0,139)},
1360 {"dark cyan" , PALETTERGB ( 0,139,139)},
1361 {"DarkCyan" , PALETTERGB ( 0,139,139)},
1362 {"dark magenta" , PALETTERGB (139, 0,139)},
1363 {"DarkMagenta" , PALETTERGB (139, 0,139)},
1364 {"dark red" , PALETTERGB (139, 0, 0)},
1365 {"DarkRed" , PALETTERGB (139, 0, 0)},
1366 {"light green" , PALETTERGB (144,238,144)},
1367 {"LightGreen" , PALETTERGB (144,238,144)},
1370 DEFUN ("w32-default-color-map", Fw32_default_color_map, Sw32_default_color_map,
1371 0, 0, 0, "Return the default color map.")
1374 int i;
1375 colormap_t *pc = w32_color_map;
1376 Lisp_Object cmap;
1378 BLOCK_INPUT;
1380 cmap = Qnil;
1382 for (i = 0; i < sizeof (w32_color_map) / sizeof (w32_color_map[0]);
1383 pc++, i++)
1384 cmap = Fcons (Fcons (build_string (pc->name),
1385 make_number (pc->colorref)),
1386 cmap);
1388 UNBLOCK_INPUT;
1390 return (cmap);
1393 Lisp_Object
1394 w32_to_x_color (rgb)
1395 Lisp_Object rgb;
1397 Lisp_Object color;
1399 CHECK_NUMBER (rgb, 0);
1401 BLOCK_INPUT;
1403 color = Frassq (rgb, Vw32_color_map);
1405 UNBLOCK_INPUT;
1407 if (!NILP (color))
1408 return (Fcar (color));
1409 else
1410 return Qnil;
1413 COLORREF
1414 w32_color_map_lookup (colorname)
1415 char *colorname;
1417 Lisp_Object tail, ret = Qnil;
1419 BLOCK_INPUT;
1421 for (tail = Vw32_color_map; !NILP (tail); tail = Fcdr (tail))
1423 register Lisp_Object elt, tem;
1425 elt = Fcar (tail);
1426 if (!CONSP (elt)) continue;
1428 tem = Fcar (elt);
1430 if (lstrcmpi (XSTRING (tem)->data, colorname) == 0)
1432 ret = XUINT (Fcdr (elt));
1433 break;
1436 QUIT;
1440 UNBLOCK_INPUT;
1442 return ret;
1445 COLORREF
1446 x_to_w32_color (colorname)
1447 char * colorname;
1449 register Lisp_Object tail, ret = Qnil;
1451 BLOCK_INPUT;
1453 if (colorname[0] == '#')
1455 /* Could be an old-style RGB Device specification. */
1456 char *color;
1457 int size;
1458 color = colorname + 1;
1460 size = strlen(color);
1461 if (size == 3 || size == 6 || size == 9 || size == 12)
1463 UINT colorval;
1464 int i, pos;
1465 pos = 0;
1466 size /= 3;
1467 colorval = 0;
1469 for (i = 0; i < 3; i++)
1471 char *end;
1472 char t;
1473 unsigned long value;
1475 /* The check for 'x' in the following conditional takes into
1476 account the fact that strtol allows a "0x" in front of
1477 our numbers, and we don't. */
1478 if (!isxdigit(color[0]) || color[1] == 'x')
1479 break;
1480 t = color[size];
1481 color[size] = '\0';
1482 value = strtoul(color, &end, 16);
1483 color[size] = t;
1484 if (errno == ERANGE || end - color != size)
1485 break;
1486 switch (size)
1488 case 1:
1489 value = value * 0x10;
1490 break;
1491 case 2:
1492 break;
1493 case 3:
1494 value /= 0x10;
1495 break;
1496 case 4:
1497 value /= 0x100;
1498 break;
1500 colorval |= (value << pos);
1501 pos += 0x8;
1502 if (i == 2)
1504 UNBLOCK_INPUT;
1505 return (colorval);
1507 color = end;
1511 else if (strnicmp(colorname, "rgb:", 4) == 0)
1513 char *color;
1514 UINT colorval;
1515 int i, pos;
1516 pos = 0;
1518 colorval = 0;
1519 color = colorname + 4;
1520 for (i = 0; i < 3; i++)
1522 char *end;
1523 unsigned long value;
1525 /* The check for 'x' in the following conditional takes into
1526 account the fact that strtol allows a "0x" in front of
1527 our numbers, and we don't. */
1528 if (!isxdigit(color[0]) || color[1] == 'x')
1529 break;
1530 value = strtoul(color, &end, 16);
1531 if (errno == ERANGE)
1532 break;
1533 switch (end - color)
1535 case 1:
1536 value = value * 0x10 + value;
1537 break;
1538 case 2:
1539 break;
1540 case 3:
1541 value /= 0x10;
1542 break;
1543 case 4:
1544 value /= 0x100;
1545 break;
1546 default:
1547 value = ULONG_MAX;
1549 if (value == ULONG_MAX)
1550 break;
1551 colorval |= (value << pos);
1552 pos += 0x8;
1553 if (i == 2)
1555 if (*end != '\0')
1556 break;
1557 UNBLOCK_INPUT;
1558 return (colorval);
1560 if (*end != '/')
1561 break;
1562 color = end + 1;
1565 else if (strnicmp(colorname, "rgbi:", 5) == 0)
1567 /* This is an RGB Intensity specification. */
1568 char *color;
1569 UINT colorval;
1570 int i, pos;
1571 pos = 0;
1573 colorval = 0;
1574 color = colorname + 5;
1575 for (i = 0; i < 3; i++)
1577 char *end;
1578 double value;
1579 UINT val;
1581 value = strtod(color, &end);
1582 if (errno == ERANGE)
1583 break;
1584 if (value < 0.0 || value > 1.0)
1585 break;
1586 val = (UINT)(0x100 * value);
1587 /* We used 0x100 instead of 0xFF to give an continuous
1588 range between 0.0 and 1.0 inclusive. The next statement
1589 fixes the 1.0 case. */
1590 if (val == 0x100)
1591 val = 0xFF;
1592 colorval |= (val << pos);
1593 pos += 0x8;
1594 if (i == 2)
1596 if (*end != '\0')
1597 break;
1598 UNBLOCK_INPUT;
1599 return (colorval);
1601 if (*end != '/')
1602 break;
1603 color = end + 1;
1606 /* I am not going to attempt to handle any of the CIE color schemes
1607 or TekHVC, since I don't know the algorithms for conversion to
1608 RGB. */
1610 /* If we fail to lookup the color name in w32_color_map, then check the
1611 colorname to see if it can be crudely approximated: If the X color
1612 ends in a number (e.g., "darkseagreen2"), strip the number and
1613 return the result of looking up the base color name. */
1614 ret = w32_color_map_lookup (colorname);
1615 if (NILP (ret))
1617 int len = strlen (colorname);
1619 if (isdigit (colorname[len - 1]))
1621 char *ptr, *approx = alloca (len);
1623 strcpy (approx, colorname);
1624 ptr = &approx[len - 1];
1625 while (ptr > approx && isdigit (*ptr))
1626 *ptr-- = '\0';
1628 ret = w32_color_map_lookup (approx);
1632 UNBLOCK_INPUT;
1633 return ret;
1637 void
1638 w32_regenerate_palette (FRAME_PTR f)
1640 struct w32_palette_entry * list;
1641 LOGPALETTE * log_palette;
1642 HPALETTE new_palette;
1643 int i;
1645 /* don't bother trying to create palette if not supported */
1646 if (! FRAME_W32_DISPLAY_INFO (f)->has_palette)
1647 return;
1649 log_palette = (LOGPALETTE *)
1650 alloca (sizeof (LOGPALETTE) +
1651 FRAME_W32_DISPLAY_INFO (f)->num_colors * sizeof (PALETTEENTRY));
1652 log_palette->palVersion = 0x300;
1653 log_palette->palNumEntries = FRAME_W32_DISPLAY_INFO (f)->num_colors;
1655 list = FRAME_W32_DISPLAY_INFO (f)->color_list;
1656 for (i = 0;
1657 i < FRAME_W32_DISPLAY_INFO (f)->num_colors;
1658 i++, list = list->next)
1659 log_palette->palPalEntry[i] = list->entry;
1661 new_palette = CreatePalette (log_palette);
1663 enter_crit ();
1665 if (FRAME_W32_DISPLAY_INFO (f)->palette)
1666 DeleteObject (FRAME_W32_DISPLAY_INFO (f)->palette);
1667 FRAME_W32_DISPLAY_INFO (f)->palette = new_palette;
1669 /* Realize display palette and garbage all frames. */
1670 release_frame_dc (f, get_frame_dc (f));
1672 leave_crit ();
1675 #define W32_COLOR(pe) RGB (pe.peRed, pe.peGreen, pe.peBlue)
1676 #define SET_W32_COLOR(pe, color) \
1677 do \
1679 pe.peRed = GetRValue (color); \
1680 pe.peGreen = GetGValue (color); \
1681 pe.peBlue = GetBValue (color); \
1682 pe.peFlags = 0; \
1683 } while (0)
1685 #if 0
1686 /* Keep these around in case we ever want to track color usage. */
1687 void
1688 w32_map_color (FRAME_PTR f, COLORREF color)
1690 struct w32_palette_entry * list = FRAME_W32_DISPLAY_INFO (f)->color_list;
1692 if (NILP (Vw32_enable_palette))
1693 return;
1695 /* check if color is already mapped */
1696 while (list)
1698 if (W32_COLOR (list->entry) == color)
1700 ++list->refcount;
1701 return;
1703 list = list->next;
1706 /* not already mapped, so add to list and recreate Windows palette */
1707 list = (struct w32_palette_entry *)
1708 xmalloc (sizeof (struct w32_palette_entry));
1709 SET_W32_COLOR (list->entry, color);
1710 list->refcount = 1;
1711 list->next = FRAME_W32_DISPLAY_INFO (f)->color_list;
1712 FRAME_W32_DISPLAY_INFO (f)->color_list = list;
1713 FRAME_W32_DISPLAY_INFO (f)->num_colors++;
1715 /* set flag that palette must be regenerated */
1716 FRAME_W32_DISPLAY_INFO (f)->regen_palette = TRUE;
1719 void
1720 w32_unmap_color (FRAME_PTR f, COLORREF color)
1722 struct w32_palette_entry * list = FRAME_W32_DISPLAY_INFO (f)->color_list;
1723 struct w32_palette_entry **prev = &FRAME_W32_DISPLAY_INFO (f)->color_list;
1725 if (NILP (Vw32_enable_palette))
1726 return;
1728 /* check if color is already mapped */
1729 while (list)
1731 if (W32_COLOR (list->entry) == color)
1733 if (--list->refcount == 0)
1735 *prev = list->next;
1736 xfree (list);
1737 FRAME_W32_DISPLAY_INFO (f)->num_colors--;
1738 break;
1740 else
1741 return;
1743 prev = &list->next;
1744 list = list->next;
1747 /* set flag that palette must be regenerated */
1748 FRAME_W32_DISPLAY_INFO (f)->regen_palette = TRUE;
1750 #endif
1753 /* Gamma-correct COLOR on frame F. */
1755 void
1756 gamma_correct (f, color)
1757 struct frame *f;
1758 COLORREF *color;
1760 if (f->gamma)
1762 *color = PALETTERGB (
1763 pow (GetRValue (*color) / 255.0, f->gamma) * 255.0 + 0.5,
1764 pow (GetGValue (*color) / 255.0, f->gamma) * 255.0 + 0.5,
1765 pow (GetBValue (*color) / 255.0, f->gamma) * 255.0 + 0.5);
1770 /* Decide if color named COLOR is valid for the display associated with
1771 the selected frame; if so, return the rgb values in COLOR_DEF.
1772 If ALLOC is nonzero, allocate a new colormap cell. */
1775 w32_defined_color (f, color, color_def, alloc)
1776 FRAME_PTR f;
1777 char *color;
1778 XColor *color_def;
1779 int alloc;
1781 register Lisp_Object tem;
1782 COLORREF w32_color_ref;
1784 tem = x_to_w32_color (color);
1786 if (!NILP (tem))
1788 if (f)
1790 /* Apply gamma correction. */
1791 w32_color_ref = XUINT (tem);
1792 gamma_correct (f, &w32_color_ref);
1793 XSETINT (tem, w32_color_ref);
1796 /* Map this color to the palette if it is enabled. */
1797 if (!NILP (Vw32_enable_palette))
1799 struct w32_palette_entry * entry =
1800 one_w32_display_info.color_list;
1801 struct w32_palette_entry ** prev =
1802 &one_w32_display_info.color_list;
1804 /* check if color is already mapped */
1805 while (entry)
1807 if (W32_COLOR (entry->entry) == XUINT (tem))
1808 break;
1809 prev = &entry->next;
1810 entry = entry->next;
1813 if (entry == NULL && alloc)
1815 /* not already mapped, so add to list */
1816 entry = (struct w32_palette_entry *)
1817 xmalloc (sizeof (struct w32_palette_entry));
1818 SET_W32_COLOR (entry->entry, XUINT (tem));
1819 entry->next = NULL;
1820 *prev = entry;
1821 one_w32_display_info.num_colors++;
1823 /* set flag that palette must be regenerated */
1824 one_w32_display_info.regen_palette = TRUE;
1827 /* Ensure COLORREF value is snapped to nearest color in (default)
1828 palette by simulating the PALETTERGB macro. This works whether
1829 or not the display device has a palette. */
1830 w32_color_ref = XUINT (tem) | 0x2000000;
1832 color_def->pixel = w32_color_ref;
1833 color_def->red = GetRValue (w32_color_ref);
1834 color_def->green = GetGValue (w32_color_ref);
1835 color_def->blue = GetBValue (w32_color_ref);
1837 return 1;
1839 else
1841 return 0;
1845 /* Given a string ARG naming a color, compute a pixel value from it
1846 suitable for screen F.
1847 If F is not a color screen, return DEF (default) regardless of what
1848 ARG says. */
1851 x_decode_color (f, arg, def)
1852 FRAME_PTR f;
1853 Lisp_Object arg;
1854 int def;
1856 XColor cdef;
1858 CHECK_STRING (arg, 0);
1860 if (strcmp (XSTRING (arg)->data, "black") == 0)
1861 return BLACK_PIX_DEFAULT (f);
1862 else if (strcmp (XSTRING (arg)->data, "white") == 0)
1863 return WHITE_PIX_DEFAULT (f);
1865 if ((FRAME_W32_DISPLAY_INFO (f)->n_planes * FRAME_W32_DISPLAY_INFO (f)->n_cbits) == 1)
1866 return def;
1868 /* w32_defined_color is responsible for coping with failures
1869 by looking for a near-miss. */
1870 if (w32_defined_color (f, XSTRING (arg)->data, &cdef, 1))
1871 return cdef.pixel;
1873 /* defined_color failed; return an ultimate default. */
1874 return def;
1877 /* Change the `screen-gamma' frame parameter of frame F. OLD_VALUE is
1878 the previous value of that parameter, NEW_VALUE is the new value. */
1880 static void
1881 x_set_screen_gamma (f, new_value, old_value)
1882 struct frame *f;
1883 Lisp_Object new_value, old_value;
1885 if (NILP (new_value))
1886 f->gamma = 0;
1887 else if (NUMBERP (new_value) && XFLOATINT (new_value) > 0)
1888 /* The value 0.4545 is the normal viewing gamma. */
1889 f->gamma = 1.0 / (0.4545 * XFLOATINT (new_value));
1890 else
1891 Fsignal (Qerror, Fcons (build_string ("Illegal screen-gamma"),
1892 Fcons (new_value, Qnil)));
1894 clear_face_cache (0);
1898 /* Functions called only from `x_set_frame_param'
1899 to set individual parameters.
1901 If FRAME_W32_WINDOW (f) is 0,
1902 the frame is being created and its window does not exist yet.
1903 In that case, just record the parameter's new value
1904 in the standard place; do not attempt to change the window. */
1906 void
1907 x_set_foreground_color (f, arg, oldval)
1908 struct frame *f;
1909 Lisp_Object arg, oldval;
1911 FRAME_FOREGROUND_PIXEL (f)
1912 = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
1914 if (FRAME_W32_WINDOW (f) != 0)
1916 update_face_from_frame_parameter (f, Qforeground_color, arg);
1917 if (FRAME_VISIBLE_P (f))
1918 redraw_frame (f);
1922 void
1923 x_set_background_color (f, arg, oldval)
1924 struct frame *f;
1925 Lisp_Object arg, oldval;
1927 FRAME_BACKGROUND_PIXEL (f)
1928 = x_decode_color (f, arg, WHITE_PIX_DEFAULT (f));
1930 if (FRAME_W32_WINDOW (f) != 0)
1932 SetWindowLong (FRAME_W32_WINDOW (f), WND_BACKGROUND_INDEX,
1933 FRAME_BACKGROUND_PIXEL (f));
1935 update_face_from_frame_parameter (f, Qbackground_color, arg);
1937 if (FRAME_VISIBLE_P (f))
1938 redraw_frame (f);
1942 void
1943 x_set_mouse_color (f, arg, oldval)
1944 struct frame *f;
1945 Lisp_Object arg, oldval;
1948 Cursor cursor, nontext_cursor, mode_cursor, cross_cursor;
1949 int count;
1950 int mask_color;
1952 if (!EQ (Qnil, arg))
1953 f->output_data.w32->mouse_pixel
1954 = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
1955 mask_color = FRAME_BACKGROUND_PIXEL (f);
1957 /* Don't let pointers be invisible. */
1958 if (mask_color == f->output_data.w32->mouse_pixel
1959 && mask_color == FRAME_BACKGROUND_PIXEL (f))
1960 f->output_data.w32->mouse_pixel = FRAME_FOREGROUND_PIXEL (f);
1962 #if 0 /* NTEMACS_TODO : cursor changes */
1963 BLOCK_INPUT;
1965 /* It's not okay to crash if the user selects a screwy cursor. */
1966 count = x_catch_errors (FRAME_W32_DISPLAY (f));
1968 if (!EQ (Qnil, Vx_pointer_shape))
1970 CHECK_NUMBER (Vx_pointer_shape, 0);
1971 cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XINT (Vx_pointer_shape));
1973 else
1974 cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_xterm);
1975 x_check_errors (FRAME_W32_DISPLAY (f), "bad text pointer cursor: %s");
1977 if (!EQ (Qnil, Vx_nontext_pointer_shape))
1979 CHECK_NUMBER (Vx_nontext_pointer_shape, 0);
1980 nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
1981 XINT (Vx_nontext_pointer_shape));
1983 else
1984 nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_left_ptr);
1985 x_check_errors (FRAME_W32_DISPLAY (f), "bad nontext pointer cursor: %s");
1987 if (!EQ (Qnil, Vx_busy_pointer_shape))
1989 CHECK_NUMBER (Vx_busy_pointer_shape, 0);
1990 busy_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
1991 XINT (Vx_busy_pointer_shape));
1993 else
1994 busy_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_watch);
1995 x_check_errors (FRAME_W32_DISPLAY (f), "bad busy pointer cursor: %s");
1997 x_check_errors (FRAME_W32_DISPLAY (f), "bad nontext pointer cursor: %s");
1998 if (!EQ (Qnil, Vx_mode_pointer_shape))
2000 CHECK_NUMBER (Vx_mode_pointer_shape, 0);
2001 mode_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
2002 XINT (Vx_mode_pointer_shape));
2004 else
2005 mode_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_xterm);
2006 x_check_errors (FRAME_W32_DISPLAY (f), "bad modeline pointer cursor: %s");
2008 if (!EQ (Qnil, Vx_sensitive_text_pointer_shape))
2010 CHECK_NUMBER (Vx_sensitive_text_pointer_shape, 0);
2011 cross_cursor
2012 = XCreateFontCursor (FRAME_W32_DISPLAY (f),
2013 XINT (Vx_sensitive_text_pointer_shape));
2015 else
2016 cross_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_crosshair);
2018 /* Check and report errors with the above calls. */
2019 x_check_errors (FRAME_W32_DISPLAY (f), "can't set cursor shape: %s");
2020 x_uncatch_errors (FRAME_W32_DISPLAY (f), count);
2023 XColor fore_color, back_color;
2025 fore_color.pixel = f->output_data.w32->mouse_pixel;
2026 back_color.pixel = mask_color;
2027 XQueryColor (FRAME_W32_DISPLAY (f),
2028 DefaultColormap (FRAME_W32_DISPLAY (f),
2029 DefaultScreen (FRAME_W32_DISPLAY (f))),
2030 &fore_color);
2031 XQueryColor (FRAME_W32_DISPLAY (f),
2032 DefaultColormap (FRAME_W32_DISPLAY (f),
2033 DefaultScreen (FRAME_W32_DISPLAY (f))),
2034 &back_color);
2035 XRecolorCursor (FRAME_W32_DISPLAY (f), cursor,
2036 &fore_color, &back_color);
2037 XRecolorCursor (FRAME_W32_DISPLAY (f), nontext_cursor,
2038 &fore_color, &back_color);
2039 XRecolorCursor (FRAME_W32_DISPLAY (f), mode_cursor,
2040 &fore_color, &back_color);
2041 XRecolorCursor (FRAME_W32_DISPLAY (f), cross_cursor,
2042 &fore_color, &back_color);
2043 XRecolorCursor (FRAME_W32_DISPLAY (f), busy_cursor,
2044 &fore_color, &back_color);
2047 if (FRAME_W32_WINDOW (f) != 0)
2048 XDefineCursor (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), cursor);
2050 if (cursor != f->output_data.w32->text_cursor && f->output_data.w32->text_cursor != 0)
2051 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->text_cursor);
2052 f->output_data.w32->text_cursor = cursor;
2054 if (nontext_cursor != f->output_data.w32->nontext_cursor
2055 && f->output_data.w32->nontext_cursor != 0)
2056 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->nontext_cursor);
2057 f->output_data.w32->nontext_cursor = nontext_cursor;
2059 if (busy_cursor != f->output_data.w32->busy_cursor
2060 && f->output_data.w32->busy_cursor != 0)
2061 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->busy_cursor);
2062 f->output_data.w32->busy_cursor = busy_cursor;
2064 if (mode_cursor != f->output_data.w32->modeline_cursor
2065 && f->output_data.w32->modeline_cursor != 0)
2066 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->modeline_cursor);
2067 f->output_data.w32->modeline_cursor = mode_cursor;
2069 if (cross_cursor != f->output_data.w32->cross_cursor
2070 && f->output_data.w32->cross_cursor != 0)
2071 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->cross_cursor);
2072 f->output_data.w32->cross_cursor = cross_cursor;
2074 XFlush (FRAME_W32_DISPLAY (f));
2075 UNBLOCK_INPUT;
2077 update_face_from_frame_parameter (f, Qmouse_color, arg);
2078 #endif /* NTEMACS_TODO */
2081 void
2082 x_set_cursor_color (f, arg, oldval)
2083 struct frame *f;
2084 Lisp_Object arg, oldval;
2086 unsigned long fore_pixel;
2088 if (!EQ (Vx_cursor_fore_pixel, Qnil))
2089 fore_pixel = x_decode_color (f, Vx_cursor_fore_pixel,
2090 WHITE_PIX_DEFAULT (f));
2091 else
2092 fore_pixel = FRAME_BACKGROUND_PIXEL (f);
2093 f->output_data.w32->cursor_pixel = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
2095 /* Make sure that the cursor color differs from the background color. */
2096 if (f->output_data.w32->cursor_pixel == FRAME_BACKGROUND_PIXEL (f))
2098 f->output_data.w32->cursor_pixel = f->output_data.w32->mouse_pixel;
2099 if (f->output_data.w32->cursor_pixel == fore_pixel)
2100 fore_pixel = FRAME_BACKGROUND_PIXEL (f);
2102 FRAME_FOREGROUND_PIXEL (f) = fore_pixel;
2104 if (FRAME_W32_WINDOW (f) != 0)
2106 if (FRAME_VISIBLE_P (f))
2108 x_display_cursor (f, 0);
2109 x_display_cursor (f, 1);
2113 update_face_from_frame_parameter (f, Qcursor_color, arg);
2116 /* Set the border-color of frame F to pixel value PIX.
2117 Note that this does not fully take effect if done before
2118 F has an window. */
2119 void
2120 x_set_border_pixel (f, pix)
2121 struct frame *f;
2122 int pix;
2124 f->output_data.w32->border_pixel = pix;
2126 if (FRAME_W32_WINDOW (f) != 0 && f->output_data.w32->border_width > 0)
2128 if (FRAME_VISIBLE_P (f))
2129 redraw_frame (f);
2133 /* Set the border-color of frame F to value described by ARG.
2134 ARG can be a string naming a color.
2135 The border-color is used for the border that is drawn by the server.
2136 Note that this does not fully take effect if done before
2137 F has a window; it must be redone when the window is created. */
2139 void
2140 x_set_border_color (f, arg, oldval)
2141 struct frame *f;
2142 Lisp_Object arg, oldval;
2144 int pix;
2146 CHECK_STRING (arg, 0);
2147 pix = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
2148 x_set_border_pixel (f, pix);
2149 update_face_from_frame_parameter (f, Qborder_color, arg);
2152 void
2153 x_set_cursor_type (f, arg, oldval)
2154 FRAME_PTR f;
2155 Lisp_Object arg, oldval;
2157 if (EQ (arg, Qbar))
2159 FRAME_DESIRED_CURSOR (f) = BAR_CURSOR;
2160 f->output_data.w32->cursor_width = 2;
2162 else if (CONSP (arg) && EQ (XCAR (arg), Qbar)
2163 && INTEGERP (XCDR (arg)))
2165 FRAME_DESIRED_CURSOR (f) = BAR_CURSOR;
2166 f->output_data.w32->cursor_width = XINT (XCDR (arg));
2168 else
2169 /* Treat anything unknown as "box cursor".
2170 It was bad to signal an error; people have trouble fixing
2171 .Xdefaults with Emacs, when it has something bad in it. */
2172 FRAME_DESIRED_CURSOR (f) = FILLED_BOX_CURSOR;
2174 /* Make sure the cursor gets redrawn. This is overkill, but how
2175 often do people change cursor types? */
2176 update_mode_lines++;
2179 void
2180 x_set_icon_type (f, arg, oldval)
2181 struct frame *f;
2182 Lisp_Object arg, oldval;
2184 int result;
2186 if (NILP (arg) && NILP (oldval))
2187 return;
2189 if (STRINGP (arg) && STRINGP (oldval)
2190 && EQ (Fstring_equal (oldval, arg), Qt))
2191 return;
2193 if (SYMBOLP (arg) && SYMBOLP (oldval) && EQ (arg, oldval))
2194 return;
2196 BLOCK_INPUT;
2198 result = x_bitmap_icon (f, arg);
2199 if (result)
2201 UNBLOCK_INPUT;
2202 error ("No icon window available");
2205 UNBLOCK_INPUT;
2208 /* Return non-nil if frame F wants a bitmap icon. */
2210 Lisp_Object
2211 x_icon_type (f)
2212 FRAME_PTR f;
2214 Lisp_Object tem;
2216 tem = assq_no_quit (Qicon_type, f->param_alist);
2217 if (CONSP (tem))
2218 return XCDR (tem);
2219 else
2220 return Qnil;
2223 void
2224 x_set_icon_name (f, arg, oldval)
2225 struct frame *f;
2226 Lisp_Object arg, oldval;
2228 int result;
2230 if (STRINGP (arg))
2232 if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt))
2233 return;
2235 else if (!STRINGP (oldval) && EQ (oldval, Qnil) == EQ (arg, Qnil))
2236 return;
2238 f->icon_name = arg;
2240 #if 0
2241 if (f->output_data.w32->icon_bitmap != 0)
2242 return;
2244 BLOCK_INPUT;
2246 result = x_text_icon (f,
2247 (char *) XSTRING ((!NILP (f->icon_name)
2248 ? f->icon_name
2249 : !NILP (f->title)
2250 ? f->title
2251 : f->name))->data);
2253 if (result)
2255 UNBLOCK_INPUT;
2256 error ("No icon window available");
2259 /* If the window was unmapped (and its icon was mapped),
2260 the new icon is not mapped, so map the window in its stead. */
2261 if (FRAME_VISIBLE_P (f))
2263 #ifdef USE_X_TOOLKIT
2264 XtPopup (f->output_data.w32->widget, XtGrabNone);
2265 #endif
2266 XMapWindow (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f));
2269 XFlush (FRAME_W32_DISPLAY (f));
2270 UNBLOCK_INPUT;
2271 #endif
2274 extern Lisp_Object x_new_font ();
2275 extern Lisp_Object x_new_fontset();
2277 void
2278 x_set_font (f, arg, oldval)
2279 struct frame *f;
2280 Lisp_Object arg, oldval;
2282 Lisp_Object result;
2283 Lisp_Object fontset_name;
2284 Lisp_Object frame;
2286 CHECK_STRING (arg, 1);
2288 fontset_name = Fquery_fontset (arg, Qnil);
2290 BLOCK_INPUT;
2291 result = (STRINGP (fontset_name)
2292 ? x_new_fontset (f, XSTRING (fontset_name)->data)
2293 : x_new_font (f, XSTRING (arg)->data));
2294 UNBLOCK_INPUT;
2296 if (EQ (result, Qnil))
2297 error ("Font \"%s\" is not defined", XSTRING (arg)->data);
2298 else if (EQ (result, Qt))
2299 error ("the characters of the given font have varying widths");
2300 else if (STRINGP (result))
2302 store_frame_param (f, Qfont, result);
2303 recompute_basic_faces (f);
2305 else
2306 abort ();
2308 do_pending_window_change (0);
2310 /* Don't call `face-set-after-frame-default' when faces haven't been
2311 initialized yet. This is the case when called from
2312 Fx_create_frame. In that case, the X widget or window doesn't
2313 exist either, and we can end up in x_report_frame_params with a
2314 null widget which gives a segfault. */
2315 if (FRAME_FACE_CACHE (f))
2317 XSETFRAME (frame, f);
2318 call1 (Qface_set_after_frame_default, frame);
2322 void
2323 x_set_border_width (f, arg, oldval)
2324 struct frame *f;
2325 Lisp_Object arg, oldval;
2327 CHECK_NUMBER (arg, 0);
2329 if (XINT (arg) == f->output_data.w32->border_width)
2330 return;
2332 if (FRAME_W32_WINDOW (f) != 0)
2333 error ("Cannot change the border width of a window");
2335 f->output_data.w32->border_width = XINT (arg);
2338 void
2339 x_set_internal_border_width (f, arg, oldval)
2340 struct frame *f;
2341 Lisp_Object arg, oldval;
2343 int old = f->output_data.w32->internal_border_width;
2345 CHECK_NUMBER (arg, 0);
2346 f->output_data.w32->internal_border_width = XINT (arg);
2347 if (f->output_data.w32->internal_border_width < 0)
2348 f->output_data.w32->internal_border_width = 0;
2350 if (f->output_data.w32->internal_border_width == old)
2351 return;
2353 if (FRAME_W32_WINDOW (f) != 0)
2355 x_set_window_size (f, 0, f->width, f->height);
2356 SET_FRAME_GARBAGED (f);
2357 do_pending_window_change (0);
2361 void
2362 x_set_visibility (f, value, oldval)
2363 struct frame *f;
2364 Lisp_Object value, oldval;
2366 Lisp_Object frame;
2367 XSETFRAME (frame, f);
2369 if (NILP (value))
2370 Fmake_frame_invisible (frame, Qt);
2371 else if (EQ (value, Qicon))
2372 Ficonify_frame (frame);
2373 else
2374 Fmake_frame_visible (frame);
2377 void
2378 x_set_menu_bar_lines (f, value, oldval)
2379 struct frame *f;
2380 Lisp_Object value, oldval;
2382 int nlines;
2383 int olines = FRAME_MENU_BAR_LINES (f);
2385 /* Right now, menu bars don't work properly in minibuf-only frames;
2386 most of the commands try to apply themselves to the minibuffer
2387 frame itself, and get an error because you can't switch buffers
2388 in or split the minibuffer window. */
2389 if (FRAME_MINIBUF_ONLY_P (f))
2390 return;
2392 if (INTEGERP (value))
2393 nlines = XINT (value);
2394 else
2395 nlines = 0;
2397 FRAME_MENU_BAR_LINES (f) = 0;
2398 if (nlines)
2399 FRAME_EXTERNAL_MENU_BAR (f) = 1;
2400 else
2402 if (FRAME_EXTERNAL_MENU_BAR (f) == 1)
2403 free_frame_menubar (f);
2404 FRAME_EXTERNAL_MENU_BAR (f) = 0;
2406 /* Adjust the frame size so that the client (text) dimensions
2407 remain the same. This depends on FRAME_EXTERNAL_MENU_BAR being
2408 set correctly. */
2409 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
2410 do_pending_window_change (0);
2412 adjust_glyphs (f);
2416 /* Set the number of lines used for the tool bar of frame F to VALUE.
2417 VALUE not an integer, or < 0 means set the lines to zero. OLDVAL
2418 is the old number of tool bar lines. This function changes the
2419 height of all windows on frame F to match the new tool bar height.
2420 The frame's height doesn't change. */
2422 void
2423 x_set_tool_bar_lines (f, value, oldval)
2424 struct frame *f;
2425 Lisp_Object value, oldval;
2427 int delta, nlines;
2429 /* Use VALUE only if an integer >= 0. */
2430 if (INTEGERP (value) && XINT (value) >= 0)
2431 nlines = XFASTINT (value);
2432 else
2433 nlines = 0;
2435 /* Make sure we redisplay all windows in this frame. */
2436 ++windows_or_buffers_changed;
2438 delta = nlines - FRAME_TOOL_BAR_LINES (f);
2439 FRAME_TOOL_BAR_LINES (f) = nlines;
2440 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
2441 do_pending_window_change (0);
2442 adjust_glyphs (f);
2446 /* Change the name of frame F to NAME. If NAME is nil, set F's name to
2447 w32_id_name.
2449 If EXPLICIT is non-zero, that indicates that lisp code is setting the
2450 name; if NAME is a string, set F's name to NAME and set
2451 F->explicit_name; if NAME is Qnil, then clear F->explicit_name.
2453 If EXPLICIT is zero, that indicates that Emacs redisplay code is
2454 suggesting a new name, which lisp code should override; if
2455 F->explicit_name is set, ignore the new name; otherwise, set it. */
2457 void
2458 x_set_name (f, name, explicit)
2459 struct frame *f;
2460 Lisp_Object name;
2461 int explicit;
2463 /* Make sure that requests from lisp code override requests from
2464 Emacs redisplay code. */
2465 if (explicit)
2467 /* If we're switching from explicit to implicit, we had better
2468 update the mode lines and thereby update the title. */
2469 if (f->explicit_name && NILP (name))
2470 update_mode_lines = 1;
2472 f->explicit_name = ! NILP (name);
2474 else if (f->explicit_name)
2475 return;
2477 /* If NAME is nil, set the name to the w32_id_name. */
2478 if (NILP (name))
2480 /* Check for no change needed in this very common case
2481 before we do any consing. */
2482 if (!strcmp (FRAME_W32_DISPLAY_INFO (f)->w32_id_name,
2483 XSTRING (f->name)->data))
2484 return;
2485 name = build_string (FRAME_W32_DISPLAY_INFO (f)->w32_id_name);
2487 else
2488 CHECK_STRING (name, 0);
2490 /* Don't change the name if it's already NAME. */
2491 if (! NILP (Fstring_equal (name, f->name)))
2492 return;
2494 f->name = name;
2496 /* For setting the frame title, the title parameter should override
2497 the name parameter. */
2498 if (! NILP (f->title))
2499 name = f->title;
2501 if (FRAME_W32_WINDOW (f))
2503 if (STRING_MULTIBYTE (name))
2504 name = string_make_unibyte (name);
2506 BLOCK_INPUT;
2507 SetWindowText(FRAME_W32_WINDOW (f), XSTRING (name)->data);
2508 UNBLOCK_INPUT;
2512 /* This function should be called when the user's lisp code has
2513 specified a name for the frame; the name will override any set by the
2514 redisplay code. */
2515 void
2516 x_explicitly_set_name (f, arg, oldval)
2517 FRAME_PTR f;
2518 Lisp_Object arg, oldval;
2520 x_set_name (f, arg, 1);
2523 /* This function should be called by Emacs redisplay code to set the
2524 name; names set this way will never override names set by the user's
2525 lisp code. */
2526 void
2527 x_implicitly_set_name (f, arg, oldval)
2528 FRAME_PTR f;
2529 Lisp_Object arg, oldval;
2531 x_set_name (f, arg, 0);
2534 /* Change the title of frame F to NAME.
2535 If NAME is nil, use the frame name as the title.
2537 If EXPLICIT is non-zero, that indicates that lisp code is setting the
2538 name; if NAME is a string, set F's name to NAME and set
2539 F->explicit_name; if NAME is Qnil, then clear F->explicit_name.
2541 If EXPLICIT is zero, that indicates that Emacs redisplay code is
2542 suggesting a new name, which lisp code should override; if
2543 F->explicit_name is set, ignore the new name; otherwise, set it. */
2545 void
2546 x_set_title (f, name, old_name)
2547 struct frame *f;
2548 Lisp_Object name, old_name;
2550 /* Don't change the title if it's already NAME. */
2551 if (EQ (name, f->title))
2552 return;
2554 update_mode_lines = 1;
2556 f->title = name;
2558 if (NILP (name))
2559 name = f->name;
2561 if (FRAME_W32_WINDOW (f))
2563 if (STRING_MULTIBYTE (name))
2564 name = string_make_unibyte (name);
2566 BLOCK_INPUT;
2567 SetWindowText(FRAME_W32_WINDOW (f), XSTRING (name)->data);
2568 UNBLOCK_INPUT;
2572 void
2573 x_set_autoraise (f, arg, oldval)
2574 struct frame *f;
2575 Lisp_Object arg, oldval;
2577 f->auto_raise = !EQ (Qnil, arg);
2580 void
2581 x_set_autolower (f, arg, oldval)
2582 struct frame *f;
2583 Lisp_Object arg, oldval;
2585 f->auto_lower = !EQ (Qnil, arg);
2588 void
2589 x_set_unsplittable (f, arg, oldval)
2590 struct frame *f;
2591 Lisp_Object arg, oldval;
2593 f->no_split = !NILP (arg);
2596 void
2597 x_set_vertical_scroll_bars (f, arg, oldval)
2598 struct frame *f;
2599 Lisp_Object arg, oldval;
2601 if ((EQ (arg, Qleft) && FRAME_HAS_VERTICAL_SCROLL_BARS_ON_RIGHT (f))
2602 || (EQ (arg, Qright) && FRAME_HAS_VERTICAL_SCROLL_BARS_ON_LEFT (f))
2603 || (NILP (arg) && FRAME_HAS_VERTICAL_SCROLL_BARS (f))
2604 || (!NILP (arg) && ! FRAME_HAS_VERTICAL_SCROLL_BARS (f)))
2606 FRAME_VERTICAL_SCROLL_BAR_TYPE (f) = NILP (arg) ?
2607 vertical_scroll_bar_none :
2608 /* Put scroll bars on the right by default, as is conventional
2609 on MS-Windows. */
2610 EQ (Qleft, arg)
2611 ? vertical_scroll_bar_left
2612 : vertical_scroll_bar_right;
2614 /* We set this parameter before creating the window for the
2615 frame, so we can get the geometry right from the start.
2616 However, if the window hasn't been created yet, we shouldn't
2617 call x_set_window_size. */
2618 if (FRAME_W32_WINDOW (f))
2619 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
2620 do_pending_window_change (0);
2624 void
2625 x_set_scroll_bar_width (f, arg, oldval)
2626 struct frame *f;
2627 Lisp_Object arg, oldval;
2629 int wid = FONT_WIDTH (f->output_data.w32->font);
2631 if (NILP (arg))
2633 FRAME_SCROLL_BAR_PIXEL_WIDTH (f) = GetSystemMetrics (SM_CXVSCROLL);
2634 FRAME_SCROLL_BAR_COLS (f) = (FRAME_SCROLL_BAR_PIXEL_WIDTH (f) +
2635 wid - 1) / wid;
2636 if (FRAME_W32_WINDOW (f))
2637 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
2638 do_pending_window_change (0);
2640 else if (INTEGERP (arg) && XINT (arg) > 0
2641 && XFASTINT (arg) != FRAME_SCROLL_BAR_PIXEL_WIDTH (f))
2643 FRAME_SCROLL_BAR_PIXEL_WIDTH (f) = XFASTINT (arg);
2644 FRAME_SCROLL_BAR_COLS (f) = (FRAME_SCROLL_BAR_PIXEL_WIDTH (f)
2645 + wid-1) / wid;
2646 if (FRAME_W32_WINDOW (f))
2647 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
2648 do_pending_window_change (0);
2650 change_frame_size (f, 0, FRAME_WIDTH (f), 0, 0, 0);
2651 XWINDOW (FRAME_SELECTED_WINDOW (f))->cursor.hpos = 0;
2652 XWINDOW (FRAME_SELECTED_WINDOW (f))->cursor.x = 0;
2655 /* Subroutines of creating an frame. */
2657 /* Make sure that Vx_resource_name is set to a reasonable value.
2658 Fix it up, or set it to `emacs' if it is too hopeless. */
2660 static void
2661 validate_x_resource_name ()
2663 int len = 0;
2664 /* Number of valid characters in the resource name. */
2665 int good_count = 0;
2666 /* Number of invalid characters in the resource name. */
2667 int bad_count = 0;
2668 Lisp_Object new;
2669 int i;
2671 if (STRINGP (Vx_resource_name))
2673 unsigned char *p = XSTRING (Vx_resource_name)->data;
2674 int i;
2676 len = XSTRING (Vx_resource_name)->size;
2678 /* Only letters, digits, - and _ are valid in resource names.
2679 Count the valid characters and count the invalid ones. */
2680 for (i = 0; i < len; i++)
2682 int c = p[i];
2683 if (! ((c >= 'a' && c <= 'z')
2684 || (c >= 'A' && c <= 'Z')
2685 || (c >= '0' && c <= '9')
2686 || c == '-' || c == '_'))
2687 bad_count++;
2688 else
2689 good_count++;
2692 else
2693 /* Not a string => completely invalid. */
2694 bad_count = 5, good_count = 0;
2696 /* If name is valid already, return. */
2697 if (bad_count == 0)
2698 return;
2700 /* If name is entirely invalid, or nearly so, use `emacs'. */
2701 if (good_count == 0
2702 || (good_count == 1 && bad_count > 0))
2704 Vx_resource_name = build_string ("emacs");
2705 return;
2708 /* Name is partly valid. Copy it and replace the invalid characters
2709 with underscores. */
2711 Vx_resource_name = new = Fcopy_sequence (Vx_resource_name);
2713 for (i = 0; i < len; i++)
2715 int c = XSTRING (new)->data[i];
2716 if (! ((c >= 'a' && c <= 'z')
2717 || (c >= 'A' && c <= 'Z')
2718 || (c >= '0' && c <= '9')
2719 || c == '-' || c == '_'))
2720 XSTRING (new)->data[i] = '_';
2725 extern char *x_get_string_resource ();
2727 DEFUN ("x-get-resource", Fx_get_resource, Sx_get_resource, 2, 4, 0,
2728 "Return the value of ATTRIBUTE, of class CLASS, from the X defaults database.\n\
2729 This uses `INSTANCE.ATTRIBUTE' as the key and `Emacs.CLASS' as the\n\
2730 class, where INSTANCE is the name under which Emacs was invoked, or\n\
2731 the name specified by the `-name' or `-rn' command-line arguments.\n\
2733 The optional arguments COMPONENT and SUBCLASS add to the key and the\n\
2734 class, respectively. You must specify both of them or neither.\n\
2735 If you specify them, the key is `INSTANCE.COMPONENT.ATTRIBUTE'\n\
2736 and the class is `Emacs.CLASS.SUBCLASS'.")
2737 (attribute, class, component, subclass)
2738 Lisp_Object attribute, class, component, subclass;
2740 register char *value;
2741 char *name_key;
2742 char *class_key;
2744 CHECK_STRING (attribute, 0);
2745 CHECK_STRING (class, 0);
2747 if (!NILP (component))
2748 CHECK_STRING (component, 1);
2749 if (!NILP (subclass))
2750 CHECK_STRING (subclass, 2);
2751 if (NILP (component) != NILP (subclass))
2752 error ("x-get-resource: must specify both COMPONENT and SUBCLASS or neither");
2754 validate_x_resource_name ();
2756 /* Allocate space for the components, the dots which separate them,
2757 and the final '\0'. Make them big enough for the worst case. */
2758 name_key = (char *) alloca (XSTRING (Vx_resource_name)->size
2759 + (STRINGP (component)
2760 ? XSTRING (component)->size : 0)
2761 + XSTRING (attribute)->size
2762 + 3);
2764 class_key = (char *) alloca ((sizeof (EMACS_CLASS) - 1)
2765 + XSTRING (class)->size
2766 + (STRINGP (subclass)
2767 ? XSTRING (subclass)->size : 0)
2768 + 3);
2770 /* Start with emacs.FRAMENAME for the name (the specific one)
2771 and with `Emacs' for the class key (the general one). */
2772 strcpy (name_key, XSTRING (Vx_resource_name)->data);
2773 strcpy (class_key, EMACS_CLASS);
2775 strcat (class_key, ".");
2776 strcat (class_key, XSTRING (class)->data);
2778 if (!NILP (component))
2780 strcat (class_key, ".");
2781 strcat (class_key, XSTRING (subclass)->data);
2783 strcat (name_key, ".");
2784 strcat (name_key, XSTRING (component)->data);
2787 strcat (name_key, ".");
2788 strcat (name_key, XSTRING (attribute)->data);
2790 value = x_get_string_resource (Qnil,
2791 name_key, class_key);
2793 if (value != (char *) 0)
2794 return build_string (value);
2795 else
2796 return Qnil;
2799 /* Used when C code wants a resource value. */
2801 char *
2802 x_get_resource_string (attribute, class)
2803 char *attribute, *class;
2805 char *name_key;
2806 char *class_key;
2807 struct frame *sf = SELECTED_FRAME ();
2809 /* Allocate space for the components, the dots which separate them,
2810 and the final '\0'. */
2811 name_key = (char *) alloca (XSTRING (Vinvocation_name)->size
2812 + strlen (attribute) + 2);
2813 class_key = (char *) alloca ((sizeof (EMACS_CLASS) - 1)
2814 + strlen (class) + 2);
2816 sprintf (name_key, "%s.%s",
2817 XSTRING (Vinvocation_name)->data,
2818 attribute);
2819 sprintf (class_key, "%s.%s", EMACS_CLASS, class);
2821 return x_get_string_resource (sf, name_key, class_key);
2824 /* Types we might convert a resource string into. */
2825 enum resource_types
2827 RES_TYPE_NUMBER,
2828 RES_TYPE_FLOAT,
2829 RES_TYPE_BOOLEAN,
2830 RES_TYPE_STRING,
2831 RES_TYPE_SYMBOL
2834 /* Return the value of parameter PARAM.
2836 First search ALIST, then Vdefault_frame_alist, then the X defaults
2837 database, using ATTRIBUTE as the attribute name and CLASS as its class.
2839 Convert the resource to the type specified by desired_type.
2841 If no default is specified, return Qunbound. If you call
2842 w32_get_arg, make sure you deal with Qunbound in a reasonable way,
2843 and don't let it get stored in any Lisp-visible variables! */
2845 static Lisp_Object
2846 w32_get_arg (alist, param, attribute, class, type)
2847 Lisp_Object alist, param;
2848 char *attribute;
2849 char *class;
2850 enum resource_types type;
2852 register Lisp_Object tem;
2854 tem = Fassq (param, alist);
2855 if (EQ (tem, Qnil))
2856 tem = Fassq (param, Vdefault_frame_alist);
2857 if (EQ (tem, Qnil))
2860 if (attribute)
2862 tem = Fx_get_resource (build_string (attribute),
2863 build_string (class),
2864 Qnil, Qnil);
2866 if (NILP (tem))
2867 return Qunbound;
2869 switch (type)
2871 case RES_TYPE_NUMBER:
2872 return make_number (atoi (XSTRING (tem)->data));
2874 case RES_TYPE_FLOAT:
2875 return make_float (atof (XSTRING (tem)->data));
2877 case RES_TYPE_BOOLEAN:
2878 tem = Fdowncase (tem);
2879 if (!strcmp (XSTRING (tem)->data, "on")
2880 || !strcmp (XSTRING (tem)->data, "true"))
2881 return Qt;
2882 else
2883 return Qnil;
2885 case RES_TYPE_STRING:
2886 return tem;
2888 case RES_TYPE_SYMBOL:
2889 /* As a special case, we map the values `true' and `on'
2890 to Qt, and `false' and `off' to Qnil. */
2892 Lisp_Object lower;
2893 lower = Fdowncase (tem);
2894 if (!strcmp (XSTRING (lower)->data, "on")
2895 || !strcmp (XSTRING (lower)->data, "true"))
2896 return Qt;
2897 else if (!strcmp (XSTRING (lower)->data, "off")
2898 || !strcmp (XSTRING (lower)->data, "false"))
2899 return Qnil;
2900 else
2901 return Fintern (tem, Qnil);
2904 default:
2905 abort ();
2908 else
2909 return Qunbound;
2911 return Fcdr (tem);
2914 /* Record in frame F the specified or default value according to ALIST
2915 of the parameter named PARAM (a Lisp symbol).
2916 If no value is specified for PARAM, look for an X default for XPROP
2917 on the frame named NAME.
2918 If that is not found either, use the value DEFLT. */
2920 static Lisp_Object
2921 x_default_parameter (f, alist, prop, deflt, xprop, xclass, type)
2922 struct frame *f;
2923 Lisp_Object alist;
2924 Lisp_Object prop;
2925 Lisp_Object deflt;
2926 char *xprop;
2927 char *xclass;
2928 enum resource_types type;
2930 Lisp_Object tem;
2932 tem = w32_get_arg (alist, prop, xprop, xclass, type);
2933 if (EQ (tem, Qunbound))
2934 tem = deflt;
2935 x_set_frame_parameters (f, Fcons (Fcons (prop, tem), Qnil));
2936 return tem;
2939 DEFUN ("x-parse-geometry", Fx_parse_geometry, Sx_parse_geometry, 1, 1, 0,
2940 "Parse an X-style geometry string STRING.\n\
2941 Returns an alist of the form ((top . TOP), (left . LEFT) ... ).\n\
2942 The properties returned may include `top', `left', `height', and `width'.\n\
2943 The value of `left' or `top' may be an integer,\n\
2944 or a list (+ N) meaning N pixels relative to top/left corner,\n\
2945 or a list (- N) meaning -N pixels relative to bottom/right corner.")
2946 (string)
2947 Lisp_Object string;
2949 int geometry, x, y;
2950 unsigned int width, height;
2951 Lisp_Object result;
2953 CHECK_STRING (string, 0);
2955 geometry = XParseGeometry ((char *) XSTRING (string)->data,
2956 &x, &y, &width, &height);
2958 result = Qnil;
2959 if (geometry & XValue)
2961 Lisp_Object element;
2963 if (x >= 0 && (geometry & XNegative))
2964 element = Fcons (Qleft, Fcons (Qminus, Fcons (make_number (-x), Qnil)));
2965 else if (x < 0 && ! (geometry & XNegative))
2966 element = Fcons (Qleft, Fcons (Qplus, Fcons (make_number (x), Qnil)));
2967 else
2968 element = Fcons (Qleft, make_number (x));
2969 result = Fcons (element, result);
2972 if (geometry & YValue)
2974 Lisp_Object element;
2976 if (y >= 0 && (geometry & YNegative))
2977 element = Fcons (Qtop, Fcons (Qminus, Fcons (make_number (-y), Qnil)));
2978 else if (y < 0 && ! (geometry & YNegative))
2979 element = Fcons (Qtop, Fcons (Qplus, Fcons (make_number (y), Qnil)));
2980 else
2981 element = Fcons (Qtop, make_number (y));
2982 result = Fcons (element, result);
2985 if (geometry & WidthValue)
2986 result = Fcons (Fcons (Qwidth, make_number (width)), result);
2987 if (geometry & HeightValue)
2988 result = Fcons (Fcons (Qheight, make_number (height)), result);
2990 return result;
2993 /* Calculate the desired size and position of this window,
2994 and return the flags saying which aspects were specified.
2996 This function does not make the coordinates positive. */
2998 #define DEFAULT_ROWS 40
2999 #define DEFAULT_COLS 80
3001 static int
3002 x_figure_window_size (f, parms)
3003 struct frame *f;
3004 Lisp_Object parms;
3006 register Lisp_Object tem0, tem1, tem2;
3007 long window_prompting = 0;
3009 /* Default values if we fall through.
3010 Actually, if that happens we should get
3011 window manager prompting. */
3012 SET_FRAME_WIDTH (f, DEFAULT_COLS);
3013 f->height = DEFAULT_ROWS;
3014 /* Window managers expect that if program-specified
3015 positions are not (0,0), they're intentional, not defaults. */
3016 f->output_data.w32->top_pos = 0;
3017 f->output_data.w32->left_pos = 0;
3019 tem0 = w32_get_arg (parms, Qheight, 0, 0, RES_TYPE_NUMBER);
3020 tem1 = w32_get_arg (parms, Qwidth, 0, 0, RES_TYPE_NUMBER);
3021 tem2 = w32_get_arg (parms, Quser_size, 0, 0, RES_TYPE_NUMBER);
3022 if (! EQ (tem0, Qunbound) || ! EQ (tem1, Qunbound))
3024 if (!EQ (tem0, Qunbound))
3026 CHECK_NUMBER (tem0, 0);
3027 f->height = XINT (tem0);
3029 if (!EQ (tem1, Qunbound))
3031 CHECK_NUMBER (tem1, 0);
3032 SET_FRAME_WIDTH (f, XINT (tem1));
3034 if (!NILP (tem2) && !EQ (tem2, Qunbound))
3035 window_prompting |= USSize;
3036 else
3037 window_prompting |= PSize;
3040 f->output_data.w32->vertical_scroll_bar_extra
3041 = (!FRAME_HAS_VERTICAL_SCROLL_BARS (f)
3043 : FRAME_SCROLL_BAR_PIXEL_WIDTH (f) > 0
3044 ? FRAME_SCROLL_BAR_PIXEL_WIDTH (f)
3045 : (FRAME_SCROLL_BAR_COLS (f) * FONT_WIDTH (f->output_data.w32->font)));
3046 f->output_data.w32->flags_areas_extra
3047 = FRAME_FLAGS_AREA_WIDTH (f);
3048 f->output_data.w32->pixel_width = CHAR_TO_PIXEL_WIDTH (f, f->width);
3049 f->output_data.w32->pixel_height = CHAR_TO_PIXEL_HEIGHT (f, f->height);
3051 tem0 = w32_get_arg (parms, Qtop, 0, 0, RES_TYPE_NUMBER);
3052 tem1 = w32_get_arg (parms, Qleft, 0, 0, RES_TYPE_NUMBER);
3053 tem2 = w32_get_arg (parms, Quser_position, 0, 0, RES_TYPE_NUMBER);
3054 if (! EQ (tem0, Qunbound) || ! EQ (tem1, Qunbound))
3056 if (EQ (tem0, Qminus))
3058 f->output_data.w32->top_pos = 0;
3059 window_prompting |= YNegative;
3061 else if (CONSP (tem0) && EQ (XCAR (tem0), Qminus)
3062 && CONSP (XCDR (tem0))
3063 && INTEGERP (XCAR (XCDR (tem0))))
3065 f->output_data.w32->top_pos = - XINT (XCAR (XCDR (tem0)));
3066 window_prompting |= YNegative;
3068 else if (CONSP (tem0) && EQ (XCAR (tem0), Qplus)
3069 && CONSP (XCDR (tem0))
3070 && INTEGERP (XCAR (XCDR (tem0))))
3072 f->output_data.w32->top_pos = XINT (XCAR (XCDR (tem0)));
3074 else if (EQ (tem0, Qunbound))
3075 f->output_data.w32->top_pos = 0;
3076 else
3078 CHECK_NUMBER (tem0, 0);
3079 f->output_data.w32->top_pos = XINT (tem0);
3080 if (f->output_data.w32->top_pos < 0)
3081 window_prompting |= YNegative;
3084 if (EQ (tem1, Qminus))
3086 f->output_data.w32->left_pos = 0;
3087 window_prompting |= XNegative;
3089 else if (CONSP (tem1) && EQ (XCAR (tem1), Qminus)
3090 && CONSP (XCDR (tem1))
3091 && INTEGERP (XCAR (XCDR (tem1))))
3093 f->output_data.w32->left_pos = - XINT (XCAR (XCDR (tem1)));
3094 window_prompting |= XNegative;
3096 else if (CONSP (tem1) && EQ (XCAR (tem1), Qplus)
3097 && CONSP (XCDR (tem1))
3098 && INTEGERP (XCAR (XCDR (tem1))))
3100 f->output_data.w32->left_pos = XINT (XCAR (XCDR (tem1)));
3102 else if (EQ (tem1, Qunbound))
3103 f->output_data.w32->left_pos = 0;
3104 else
3106 CHECK_NUMBER (tem1, 0);
3107 f->output_data.w32->left_pos = XINT (tem1);
3108 if (f->output_data.w32->left_pos < 0)
3109 window_prompting |= XNegative;
3112 if (!NILP (tem2) && ! EQ (tem2, Qunbound))
3113 window_prompting |= USPosition;
3114 else
3115 window_prompting |= PPosition;
3118 return window_prompting;
3123 extern LRESULT CALLBACK w32_wnd_proc ();
3125 BOOL
3126 w32_init_class (hinst)
3127 HINSTANCE hinst;
3129 WNDCLASS wc;
3131 wc.style = CS_HREDRAW | CS_VREDRAW;
3132 wc.lpfnWndProc = (WNDPROC) w32_wnd_proc;
3133 wc.cbClsExtra = 0;
3134 wc.cbWndExtra = WND_EXTRA_BYTES;
3135 wc.hInstance = hinst;
3136 wc.hIcon = LoadIcon (hinst, EMACS_CLASS);
3137 wc.hCursor = LoadCursor (NULL, IDC_ARROW);
3138 wc.hbrBackground = NULL; /* GetStockObject (WHITE_BRUSH); */
3139 wc.lpszMenuName = NULL;
3140 wc.lpszClassName = EMACS_CLASS;
3142 return (RegisterClass (&wc));
3145 HWND
3146 w32_createscrollbar (f, bar)
3147 struct frame *f;
3148 struct scroll_bar * bar;
3150 return (CreateWindow ("SCROLLBAR", "", SBS_VERT | WS_CHILD | WS_VISIBLE,
3151 /* Position and size of scroll bar. */
3152 XINT(bar->left) + VERTICAL_SCROLL_BAR_WIDTH_TRIM,
3153 XINT(bar->top),
3154 XINT(bar->width) - VERTICAL_SCROLL_BAR_WIDTH_TRIM * 2,
3155 XINT(bar->height),
3156 FRAME_W32_WINDOW (f),
3157 NULL,
3158 hinst,
3159 NULL));
3162 void
3163 w32_createwindow (f)
3164 struct frame *f;
3166 HWND hwnd;
3167 RECT rect;
3169 rect.left = rect.top = 0;
3170 rect.right = PIXEL_WIDTH (f);
3171 rect.bottom = PIXEL_HEIGHT (f);
3173 AdjustWindowRect (&rect, f->output_data.w32->dwStyle,
3174 FRAME_EXTERNAL_MENU_BAR (f));
3176 /* Do first time app init */
3178 if (!hprevinst)
3180 w32_init_class (hinst);
3183 FRAME_W32_WINDOW (f) = hwnd
3184 = CreateWindow (EMACS_CLASS,
3185 f->namebuf,
3186 f->output_data.w32->dwStyle | WS_CLIPCHILDREN,
3187 f->output_data.w32->left_pos,
3188 f->output_data.w32->top_pos,
3189 rect.right - rect.left,
3190 rect.bottom - rect.top,
3191 NULL,
3192 NULL,
3193 hinst,
3194 NULL);
3196 if (hwnd)
3198 SetWindowLong (hwnd, WND_FONTWIDTH_INDEX, FONT_WIDTH (f->output_data.w32->font));
3199 SetWindowLong (hwnd, WND_LINEHEIGHT_INDEX, f->output_data.w32->line_height);
3200 SetWindowLong (hwnd, WND_BORDER_INDEX, f->output_data.w32->internal_border_width);
3201 SetWindowLong (hwnd, WND_SCROLLBAR_INDEX, f->output_data.w32->vertical_scroll_bar_extra);
3202 SetWindowLong (hwnd, WND_BACKGROUND_INDEX, FRAME_BACKGROUND_PIXEL (f));
3204 /* Enable drag-n-drop. */
3205 DragAcceptFiles (hwnd, TRUE);
3207 /* Do this to discard the default setting specified by our parent. */
3208 ShowWindow (hwnd, SW_HIDE);
3212 void
3213 my_post_msg (wmsg, hwnd, msg, wParam, lParam)
3214 W32Msg * wmsg;
3215 HWND hwnd;
3216 UINT msg;
3217 WPARAM wParam;
3218 LPARAM lParam;
3220 wmsg->msg.hwnd = hwnd;
3221 wmsg->msg.message = msg;
3222 wmsg->msg.wParam = wParam;
3223 wmsg->msg.lParam = lParam;
3224 wmsg->msg.time = GetMessageTime ();
3226 post_msg (wmsg);
3229 /* GetKeyState and MapVirtualKey on Windows 95 do not actually distinguish
3230 between left and right keys as advertised. We test for this
3231 support dynamically, and set a flag when the support is absent. If
3232 absent, we keep track of the left and right control and alt keys
3233 ourselves. This is particularly necessary on keyboards that rely
3234 upon the AltGr key, which is represented as having the left control
3235 and right alt keys pressed. For these keyboards, we need to know
3236 when the left alt key has been pressed in addition to the AltGr key
3237 so that we can properly support M-AltGr-key sequences (such as M-@
3238 on Swedish keyboards). */
3240 #define EMACS_LCONTROL 0
3241 #define EMACS_RCONTROL 1
3242 #define EMACS_LMENU 2
3243 #define EMACS_RMENU 3
3245 static int modifiers[4];
3246 static int modifiers_recorded;
3247 static int modifier_key_support_tested;
3249 static void
3250 test_modifier_support (unsigned int wparam)
3252 unsigned int l, r;
3254 if (wparam != VK_CONTROL && wparam != VK_MENU)
3255 return;
3256 if (wparam == VK_CONTROL)
3258 l = VK_LCONTROL;
3259 r = VK_RCONTROL;
3261 else
3263 l = VK_LMENU;
3264 r = VK_RMENU;
3266 if (!(GetKeyState (l) & 0x8000) && !(GetKeyState (r) & 0x8000))
3267 modifiers_recorded = 1;
3268 else
3269 modifiers_recorded = 0;
3270 modifier_key_support_tested = 1;
3273 static void
3274 record_keydown (unsigned int wparam, unsigned int lparam)
3276 int i;
3278 if (!modifier_key_support_tested)
3279 test_modifier_support (wparam);
3281 if ((wparam != VK_CONTROL && wparam != VK_MENU) || !modifiers_recorded)
3282 return;
3284 if (wparam == VK_CONTROL)
3285 i = (lparam & 0x1000000) ? EMACS_RCONTROL : EMACS_LCONTROL;
3286 else
3287 i = (lparam & 0x1000000) ? EMACS_RMENU : EMACS_LMENU;
3289 modifiers[i] = 1;
3292 static void
3293 record_keyup (unsigned int wparam, unsigned int lparam)
3295 int i;
3297 if ((wparam != VK_CONTROL && wparam != VK_MENU) || !modifiers_recorded)
3298 return;
3300 if (wparam == VK_CONTROL)
3301 i = (lparam & 0x1000000) ? EMACS_RCONTROL : EMACS_LCONTROL;
3302 else
3303 i = (lparam & 0x1000000) ? EMACS_RMENU : EMACS_LMENU;
3305 modifiers[i] = 0;
3308 /* Emacs can lose focus while a modifier key has been pressed. When
3309 it regains focus, be conservative and clear all modifiers since
3310 we cannot reconstruct the left and right modifier state. */
3311 static void
3312 reset_modifiers ()
3314 SHORT ctrl, alt;
3316 if (GetFocus () == NULL)
3317 /* Emacs doesn't have keyboard focus. Do nothing. */
3318 return;
3320 ctrl = GetAsyncKeyState (VK_CONTROL);
3321 alt = GetAsyncKeyState (VK_MENU);
3323 if (!(ctrl & 0x08000))
3324 /* Clear any recorded control modifier state. */
3325 modifiers[EMACS_RCONTROL] = modifiers[EMACS_LCONTROL] = 0;
3327 if (!(alt & 0x08000))
3328 /* Clear any recorded alt modifier state. */
3329 modifiers[EMACS_RMENU] = modifiers[EMACS_LMENU] = 0;
3331 /* Update the state of all modifier keys, because modifiers used in
3332 hot-key combinations can get stuck on if Emacs loses focus as a
3333 result of a hot-key being pressed. */
3335 BYTE keystate[256];
3337 #define CURRENT_STATE(key) ((GetAsyncKeyState (key) & 0x8000) >> 8)
3339 GetKeyboardState (keystate);
3340 keystate[VK_SHIFT] = CURRENT_STATE (VK_SHIFT);
3341 keystate[VK_CONTROL] = CURRENT_STATE (VK_CONTROL);
3342 keystate[VK_LCONTROL] = CURRENT_STATE (VK_LCONTROL);
3343 keystate[VK_RCONTROL] = CURRENT_STATE (VK_RCONTROL);
3344 keystate[VK_MENU] = CURRENT_STATE (VK_MENU);
3345 keystate[VK_LMENU] = CURRENT_STATE (VK_LMENU);
3346 keystate[VK_RMENU] = CURRENT_STATE (VK_RMENU);
3347 keystate[VK_LWIN] = CURRENT_STATE (VK_LWIN);
3348 keystate[VK_RWIN] = CURRENT_STATE (VK_RWIN);
3349 keystate[VK_APPS] = CURRENT_STATE (VK_APPS);
3350 SetKeyboardState (keystate);
3354 /* Synchronize modifier state with what is reported with the current
3355 keystroke. Even if we cannot distinguish between left and right
3356 modifier keys, we know that, if no modifiers are set, then neither
3357 the left or right modifier should be set. */
3358 static void
3359 sync_modifiers ()
3361 if (!modifiers_recorded)
3362 return;
3364 if (!(GetKeyState (VK_CONTROL) & 0x8000))
3365 modifiers[EMACS_RCONTROL] = modifiers[EMACS_LCONTROL] = 0;
3367 if (!(GetKeyState (VK_MENU) & 0x8000))
3368 modifiers[EMACS_RMENU] = modifiers[EMACS_LMENU] = 0;
3371 static int
3372 modifier_set (int vkey)
3374 if (vkey == VK_CAPITAL || vkey == VK_SCROLL)
3375 return (GetKeyState (vkey) & 0x1);
3376 if (!modifiers_recorded)
3377 return (GetKeyState (vkey) & 0x8000);
3379 switch (vkey)
3381 case VK_LCONTROL:
3382 return modifiers[EMACS_LCONTROL];
3383 case VK_RCONTROL:
3384 return modifiers[EMACS_RCONTROL];
3385 case VK_LMENU:
3386 return modifiers[EMACS_LMENU];
3387 case VK_RMENU:
3388 return modifiers[EMACS_RMENU];
3390 return (GetKeyState (vkey) & 0x8000);
3393 /* Convert between the modifier bits W32 uses and the modifier bits
3394 Emacs uses. */
3396 unsigned int
3397 w32_key_to_modifier (int key)
3399 Lisp_Object key_mapping;
3401 switch (key)
3403 case VK_LWIN:
3404 key_mapping = Vw32_lwindow_modifier;
3405 break;
3406 case VK_RWIN:
3407 key_mapping = Vw32_rwindow_modifier;
3408 break;
3409 case VK_APPS:
3410 key_mapping = Vw32_apps_modifier;
3411 break;
3412 case VK_SCROLL:
3413 key_mapping = Vw32_scroll_lock_modifier;
3414 break;
3415 default:
3416 key_mapping = Qnil;
3419 /* NB. This code runs in the input thread, asychronously to the lisp
3420 thread, so we must be careful to ensure access to lisp data is
3421 thread-safe. The following code is safe because the modifier
3422 variable values are updated atomically from lisp and symbols are
3423 not relocated by GC. Also, we don't have to worry about seeing GC
3424 markbits here. */
3425 if (EQ (key_mapping, Qhyper))
3426 return hyper_modifier;
3427 if (EQ (key_mapping, Qsuper))
3428 return super_modifier;
3429 if (EQ (key_mapping, Qmeta))
3430 return meta_modifier;
3431 if (EQ (key_mapping, Qalt))
3432 return alt_modifier;
3433 if (EQ (key_mapping, Qctrl))
3434 return ctrl_modifier;
3435 if (EQ (key_mapping, Qcontrol)) /* synonym for ctrl */
3436 return ctrl_modifier;
3437 if (EQ (key_mapping, Qshift))
3438 return shift_modifier;
3440 /* Don't generate any modifier if not explicitly requested. */
3441 return 0;
3444 unsigned int
3445 w32_get_modifiers ()
3447 return ((modifier_set (VK_SHIFT) ? shift_modifier : 0) |
3448 (modifier_set (VK_CONTROL) ? ctrl_modifier : 0) |
3449 (modifier_set (VK_LWIN) ? w32_key_to_modifier (VK_LWIN) : 0) |
3450 (modifier_set (VK_RWIN) ? w32_key_to_modifier (VK_RWIN) : 0) |
3451 (modifier_set (VK_APPS) ? w32_key_to_modifier (VK_APPS) : 0) |
3452 (modifier_set (VK_SCROLL) ? w32_key_to_modifier (VK_SCROLL) : 0) |
3453 (modifier_set (VK_MENU) ?
3454 ((NILP (Vw32_alt_is_meta)) ? alt_modifier : meta_modifier) : 0));
3457 /* We map the VK_* modifiers into console modifier constants
3458 so that we can use the same routines to handle both console
3459 and window input. */
3461 static int
3462 construct_console_modifiers ()
3464 int mods;
3466 mods = 0;
3467 mods |= (modifier_set (VK_SHIFT)) ? SHIFT_PRESSED : 0;
3468 mods |= (modifier_set (VK_CAPITAL)) ? CAPSLOCK_ON : 0;
3469 mods |= (modifier_set (VK_SCROLL)) ? SCROLLLOCK_ON : 0;
3470 mods |= (modifier_set (VK_NUMLOCK)) ? NUMLOCK_ON : 0;
3471 mods |= (modifier_set (VK_LCONTROL)) ? LEFT_CTRL_PRESSED : 0;
3472 mods |= (modifier_set (VK_RCONTROL)) ? RIGHT_CTRL_PRESSED : 0;
3473 mods |= (modifier_set (VK_LMENU)) ? LEFT_ALT_PRESSED : 0;
3474 mods |= (modifier_set (VK_RMENU)) ? RIGHT_ALT_PRESSED : 0;
3475 mods |= (modifier_set (VK_LWIN)) ? LEFT_WIN_PRESSED : 0;
3476 mods |= (modifier_set (VK_RWIN)) ? RIGHT_WIN_PRESSED : 0;
3477 mods |= (modifier_set (VK_APPS)) ? APPS_PRESSED : 0;
3479 return mods;
3482 static int
3483 w32_get_key_modifiers (unsigned int wparam, unsigned int lparam)
3485 int mods;
3487 /* Convert to emacs modifiers. */
3488 mods = w32_kbd_mods_to_emacs (construct_console_modifiers (), wparam);
3490 return mods;
3493 unsigned int
3494 map_keypad_keys (unsigned int virt_key, unsigned int extended)
3496 if (virt_key < VK_CLEAR || virt_key > VK_DELETE)
3497 return virt_key;
3499 if (virt_key == VK_RETURN)
3500 return (extended ? VK_NUMPAD_ENTER : VK_RETURN);
3502 if (virt_key >= VK_PRIOR && virt_key <= VK_DOWN)
3503 return (!extended ? (VK_NUMPAD_PRIOR + (virt_key - VK_PRIOR)) : virt_key);
3505 if (virt_key == VK_INSERT || virt_key == VK_DELETE)
3506 return (!extended ? (VK_NUMPAD_INSERT + (virt_key - VK_INSERT)) : virt_key);
3508 if (virt_key == VK_CLEAR)
3509 return (!extended ? VK_NUMPAD_CLEAR : virt_key);
3511 return virt_key;
3514 /* List of special key combinations which w32 would normally capture,
3515 but emacs should grab instead. Not directly visible to lisp, to
3516 simplify synchronization. Each item is an integer encoding a virtual
3517 key code and modifier combination to capture. */
3518 Lisp_Object w32_grabbed_keys;
3520 #define HOTKEY(vk,mods) make_number (((vk) & 255) | ((mods) << 8))
3521 #define HOTKEY_ID(k) (XFASTINT (k) & 0xbfff)
3522 #define HOTKEY_VK_CODE(k) (XFASTINT (k) & 255)
3523 #define HOTKEY_MODIFIERS(k) (XFASTINT (k) >> 8)
3525 /* Register hot-keys for reserved key combinations when Emacs has
3526 keyboard focus, since this is the only way Emacs can receive key
3527 combinations like Alt-Tab which are used by the system. */
3529 static void
3530 register_hot_keys (hwnd)
3531 HWND hwnd;
3533 Lisp_Object keylist;
3535 /* Use GC_CONSP, since we are called asynchronously. */
3536 for (keylist = w32_grabbed_keys; GC_CONSP (keylist); keylist = XCDR (keylist))
3538 Lisp_Object key = XCAR (keylist);
3540 /* Deleted entries get set to nil. */
3541 if (!INTEGERP (key))
3542 continue;
3544 RegisterHotKey (hwnd, HOTKEY_ID (key),
3545 HOTKEY_MODIFIERS (key), HOTKEY_VK_CODE (key));
3549 static void
3550 unregister_hot_keys (hwnd)
3551 HWND hwnd;
3553 Lisp_Object keylist;
3555 /* Use GC_CONSP, since we are called asynchronously. */
3556 for (keylist = w32_grabbed_keys; GC_CONSP (keylist); keylist = XCDR (keylist))
3558 Lisp_Object key = XCAR (keylist);
3560 if (!INTEGERP (key))
3561 continue;
3563 UnregisterHotKey (hwnd, HOTKEY_ID (key));
3567 /* Main message dispatch loop. */
3569 static void
3570 w32_msg_pump (deferred_msg * msg_buf)
3572 MSG msg;
3573 int result;
3574 HWND focus_window;
3576 msh_mousewheel = RegisterWindowMessage (MSH_MOUSEWHEEL);
3578 while (GetMessage (&msg, NULL, 0, 0))
3580 if (msg.hwnd == NULL)
3582 switch (msg.message)
3584 case WM_NULL:
3585 /* Produced by complete_deferred_msg; just ignore. */
3586 break;
3587 case WM_EMACS_CREATEWINDOW:
3588 w32_createwindow ((struct frame *) msg.wParam);
3589 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
3590 abort ();
3591 break;
3592 case WM_EMACS_SETLOCALE:
3593 SetThreadLocale (msg.wParam);
3594 /* Reply is not expected. */
3595 break;
3596 case WM_EMACS_SETKEYBOARDLAYOUT:
3597 result = (int) ActivateKeyboardLayout ((HKL) msg.wParam, 0);
3598 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE,
3599 result, 0))
3600 abort ();
3601 break;
3602 case WM_EMACS_REGISTER_HOT_KEY:
3603 focus_window = GetFocus ();
3604 if (focus_window != NULL)
3605 RegisterHotKey (focus_window,
3606 HOTKEY_ID (msg.wParam),
3607 HOTKEY_MODIFIERS (msg.wParam),
3608 HOTKEY_VK_CODE (msg.wParam));
3609 /* Reply is not expected. */
3610 break;
3611 case WM_EMACS_UNREGISTER_HOT_KEY:
3612 focus_window = GetFocus ();
3613 if (focus_window != NULL)
3614 UnregisterHotKey (focus_window, HOTKEY_ID (msg.wParam));
3615 /* Mark item as erased. NB: this code must be
3616 thread-safe. The next line is okay because the cons
3617 cell is never made into garbage and is not relocated by
3618 GC. */
3619 XCAR ((Lisp_Object) msg.lParam) = Qnil;
3620 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
3621 abort ();
3622 break;
3623 case WM_EMACS_TOGGLE_LOCK_KEY:
3625 int vk_code = (int) msg.wParam;
3626 int cur_state = (GetKeyState (vk_code) & 1);
3627 Lisp_Object new_state = (Lisp_Object) msg.lParam;
3629 /* NB: This code must be thread-safe. It is safe to
3630 call NILP because symbols are not relocated by GC,
3631 and pointer here is not touched by GC (so the markbit
3632 can't be set). Numbers are safe because they are
3633 immediate values. */
3634 if (NILP (new_state)
3635 || (NUMBERP (new_state)
3636 && (XUINT (new_state)) & 1 != cur_state))
3638 one_w32_display_info.faked_key = vk_code;
3640 keybd_event ((BYTE) vk_code,
3641 (BYTE) MapVirtualKey (vk_code, 0),
3642 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
3643 keybd_event ((BYTE) vk_code,
3644 (BYTE) MapVirtualKey (vk_code, 0),
3645 KEYEVENTF_EXTENDEDKEY | 0, 0);
3646 keybd_event ((BYTE) vk_code,
3647 (BYTE) MapVirtualKey (vk_code, 0),
3648 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
3649 cur_state = !cur_state;
3651 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE,
3652 cur_state, 0))
3653 abort ();
3655 break;
3656 default:
3657 DebPrint (("msg %x not expected by w32_msg_pump\n", msg.message));
3660 else
3662 DispatchMessage (&msg);
3665 /* Exit nested loop when our deferred message has completed. */
3666 if (msg_buf->completed)
3667 break;
3671 deferred_msg * deferred_msg_head;
3673 static deferred_msg *
3674 find_deferred_msg (HWND hwnd, UINT msg)
3676 deferred_msg * item;
3678 /* Don't actually need synchronization for read access, since
3679 modification of single pointer is always atomic. */
3680 /* enter_crit (); */
3682 for (item = deferred_msg_head; item != NULL; item = item->next)
3683 if (item->w32msg.msg.hwnd == hwnd
3684 && item->w32msg.msg.message == msg)
3685 break;
3687 /* leave_crit (); */
3689 return item;
3692 static LRESULT
3693 send_deferred_msg (deferred_msg * msg_buf,
3694 HWND hwnd,
3695 UINT msg,
3696 WPARAM wParam,
3697 LPARAM lParam)
3699 /* Only input thread can send deferred messages. */
3700 if (GetCurrentThreadId () != dwWindowsThreadId)
3701 abort ();
3703 /* It is an error to send a message that is already deferred. */
3704 if (find_deferred_msg (hwnd, msg) != NULL)
3705 abort ();
3707 /* Enforced synchronization is not needed because this is the only
3708 function that alters deferred_msg_head, and the following critical
3709 section is guaranteed to only be serially reentered (since only the
3710 input thread can call us). */
3712 /* enter_crit (); */
3714 msg_buf->completed = 0;
3715 msg_buf->next = deferred_msg_head;
3716 deferred_msg_head = msg_buf;
3717 my_post_msg (&msg_buf->w32msg, hwnd, msg, wParam, lParam);
3719 /* leave_crit (); */
3721 /* Start a new nested message loop to process other messages until
3722 this one is completed. */
3723 w32_msg_pump (msg_buf);
3725 deferred_msg_head = msg_buf->next;
3727 return msg_buf->result;
3730 void
3731 complete_deferred_msg (HWND hwnd, UINT msg, LRESULT result)
3733 deferred_msg * msg_buf = find_deferred_msg (hwnd, msg);
3735 if (msg_buf == NULL)
3736 /* Message may have been cancelled, so don't abort(). */
3737 return;
3739 msg_buf->result = result;
3740 msg_buf->completed = 1;
3742 /* Ensure input thread is woken so it notices the completion. */
3743 PostThreadMessage (dwWindowsThreadId, WM_NULL, 0, 0);
3746 void
3747 cancel_all_deferred_msgs ()
3749 deferred_msg * item;
3751 /* Don't actually need synchronization for read access, since
3752 modification of single pointer is always atomic. */
3753 /* enter_crit (); */
3755 for (item = deferred_msg_head; item != NULL; item = item->next)
3757 item->result = 0;
3758 item->completed = 1;
3761 /* leave_crit (); */
3763 /* Ensure input thread is woken so it notices the completion. */
3764 PostThreadMessage (dwWindowsThreadId, WM_NULL, 0, 0);
3767 DWORD
3768 w32_msg_worker (dw)
3769 DWORD dw;
3771 MSG msg;
3772 deferred_msg dummy_buf;
3774 /* Ensure our message queue is created */
3776 PeekMessage (&msg, NULL, 0, 0, PM_NOREMOVE);
3778 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
3779 abort ();
3781 memset (&dummy_buf, 0, sizeof (dummy_buf));
3782 dummy_buf.w32msg.msg.hwnd = NULL;
3783 dummy_buf.w32msg.msg.message = WM_NULL;
3785 /* This is the inital message loop which should only exit when the
3786 application quits. */
3787 w32_msg_pump (&dummy_buf);
3789 return 0;
3792 static void
3793 post_character_message (hwnd, msg, wParam, lParam, modifiers)
3794 HWND hwnd;
3795 UINT msg;
3796 WPARAM wParam;
3797 LPARAM lParam;
3798 DWORD modifiers;
3801 W32Msg wmsg;
3803 wmsg.dwModifiers = modifiers;
3805 /* Detect quit_char and set quit-flag directly. Note that we
3806 still need to post a message to ensure the main thread will be
3807 woken up if blocked in sys_select(), but we do NOT want to post
3808 the quit_char message itself (because it will usually be as if
3809 the user had typed quit_char twice). Instead, we post a dummy
3810 message that has no particular effect. */
3812 int c = wParam;
3813 if (isalpha (c) && wmsg.dwModifiers == ctrl_modifier)
3814 c = make_ctrl_char (c) & 0377;
3815 if (c == quit_char
3816 || (wmsg.dwModifiers == 0 &&
3817 XFASTINT (Vw32_quit_key) && wParam == XFASTINT (Vw32_quit_key)))
3819 Vquit_flag = Qt;
3821 /* The choice of message is somewhat arbitrary, as long as
3822 the main thread handler just ignores it. */
3823 msg = WM_NULL;
3825 /* Interrupt any blocking system calls. */
3826 signal_quit ();
3828 /* As a safety precaution, forcibly complete any deferred
3829 messages. This is a kludge, but I don't see any particularly
3830 clean way to handle the situation where a deferred message is
3831 "dropped" in the lisp thread, and will thus never be
3832 completed, eg. by the user trying to activate the menubar
3833 when the lisp thread is busy, and then typing C-g when the
3834 menubar doesn't open promptly (with the result that the
3835 menubar never responds at all because the deferred
3836 WM_INITMENU message is never completed). Another problem
3837 situation is when the lisp thread calls SendMessage (to send
3838 a window manager command) when a message has been deferred;
3839 the lisp thread gets blocked indefinitely waiting for the
3840 deferred message to be completed, which itself is waiting for
3841 the lisp thread to respond.
3843 Note that we don't want to block the input thread waiting for
3844 a reponse from the lisp thread (although that would at least
3845 solve the deadlock problem above), because we want to be able
3846 to receive C-g to interrupt the lisp thread. */
3847 cancel_all_deferred_msgs ();
3851 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3854 /* Main window procedure */
3856 LRESULT CALLBACK
3857 w32_wnd_proc (hwnd, msg, wParam, lParam)
3858 HWND hwnd;
3859 UINT msg;
3860 WPARAM wParam;
3861 LPARAM lParam;
3863 struct frame *f;
3864 struct w32_display_info *dpyinfo = &one_w32_display_info;
3865 W32Msg wmsg;
3866 int windows_translate;
3867 int key;
3869 /* Note that it is okay to call x_window_to_frame, even though we are
3870 not running in the main lisp thread, because frame deletion
3871 requires the lisp thread to synchronize with this thread. Thus, if
3872 a frame struct is returned, it can be used without concern that the
3873 lisp thread might make it disappear while we are using it.
3875 NB. Walking the frame list in this thread is safe (as long as
3876 writes of Lisp_Object slots are atomic, which they are on Windows).
3877 Although delete-frame can destructively modify the frame list while
3878 we are walking it, a garbage collection cannot occur until after
3879 delete-frame has synchronized with this thread.
3881 It is also safe to use functions that make GDI calls, such as
3882 w32_clear_rect, because these functions must obtain a DC handle
3883 from the frame struct using get_frame_dc which is thread-aware. */
3885 switch (msg)
3887 case WM_ERASEBKGND:
3888 f = x_window_to_frame (dpyinfo, hwnd);
3889 if (f)
3891 HDC hdc = get_frame_dc (f);
3892 GetUpdateRect (hwnd, &wmsg.rect, FALSE);
3893 w32_clear_rect (f, hdc, &wmsg.rect);
3894 release_frame_dc (f, hdc);
3896 #if defined (W32_DEBUG_DISPLAY)
3897 DebPrint (("WM_ERASEBKGND: erasing %d,%d-%d,%d\n",
3898 wmsg.rect.left, wmsg.rect.top, wmsg.rect.right,
3899 wmsg.rect.bottom));
3900 #endif /* W32_DEBUG_DISPLAY */
3902 return 1;
3903 case WM_PALETTECHANGED:
3904 /* ignore our own changes */
3905 if ((HWND)wParam != hwnd)
3907 f = x_window_to_frame (dpyinfo, hwnd);
3908 if (f)
3909 /* get_frame_dc will realize our palette and force all
3910 frames to be redrawn if needed. */
3911 release_frame_dc (f, get_frame_dc (f));
3913 return 0;
3914 case WM_PAINT:
3916 PAINTSTRUCT paintStruct;
3917 RECT update_rect;
3919 /* MSDN Docs say not to call BeginPaint if GetUpdateRect
3920 fails. Apparently this can happen under some
3921 circumstances. */
3922 if (!w32_strict_painting || GetUpdateRect (hwnd, &update_rect, FALSE))
3924 enter_crit ();
3925 BeginPaint (hwnd, &paintStruct);
3927 if (w32_strict_painting)
3928 /* The rectangles returned by GetUpdateRect and BeginPaint
3929 do not always match. GetUpdateRect seems to be the
3930 more reliable of the two. */
3931 wmsg.rect = update_rect;
3932 else
3933 wmsg.rect = paintStruct.rcPaint;
3935 #if defined (W32_DEBUG_DISPLAY)
3936 DebPrint (("WM_PAINT: painting %d,%d-%d,%d\n", wmsg.rect.left,
3937 wmsg.rect.top, wmsg.rect.right, wmsg.rect.bottom));
3938 DebPrint (("WM_PAINT: update region is %d,%d-%d,%d\n",
3939 update_rect.left, update_rect.top,
3940 update_rect.right, update_rect.bottom));
3941 #endif
3942 EndPaint (hwnd, &paintStruct);
3943 leave_crit ();
3945 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3947 return 0;
3950 /* If GetUpdateRect returns 0 (meaning there is no update
3951 region), assume the whole window needs to be repainted. */
3952 GetClientRect(hwnd, &wmsg.rect);
3953 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3954 return 0;
3957 case WM_INPUTLANGCHANGE:
3958 /* Inform lisp thread of keyboard layout changes. */
3959 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3961 /* Clear dead keys in the keyboard state; for simplicity only
3962 preserve modifier key states. */
3964 int i;
3965 BYTE keystate[256];
3967 GetKeyboardState (keystate);
3968 for (i = 0; i < 256; i++)
3969 if (1
3970 && i != VK_SHIFT
3971 && i != VK_LSHIFT
3972 && i != VK_RSHIFT
3973 && i != VK_CAPITAL
3974 && i != VK_NUMLOCK
3975 && i != VK_SCROLL
3976 && i != VK_CONTROL
3977 && i != VK_LCONTROL
3978 && i != VK_RCONTROL
3979 && i != VK_MENU
3980 && i != VK_LMENU
3981 && i != VK_RMENU
3982 && i != VK_LWIN
3983 && i != VK_RWIN)
3984 keystate[i] = 0;
3985 SetKeyboardState (keystate);
3987 goto dflt;
3989 case WM_HOTKEY:
3990 /* Synchronize hot keys with normal input. */
3991 PostMessage (hwnd, WM_KEYDOWN, HIWORD (lParam), 0);
3992 return (0);
3994 case WM_KEYUP:
3995 case WM_SYSKEYUP:
3996 record_keyup (wParam, lParam);
3997 goto dflt;
3999 case WM_KEYDOWN:
4000 case WM_SYSKEYDOWN:
4001 /* Ignore keystrokes we fake ourself; see below. */
4002 if (dpyinfo->faked_key == wParam)
4004 dpyinfo->faked_key = 0;
4005 /* Make sure TranslateMessage sees them though (as long as
4006 they don't produce WM_CHAR messages). This ensures that
4007 indicator lights are toggled promptly on Windows 9x, for
4008 example. */
4009 if (lispy_function_keys[wParam] != 0)
4011 windows_translate = 1;
4012 goto translate;
4014 return 0;
4017 /* Synchronize modifiers with current keystroke. */
4018 sync_modifiers ();
4019 record_keydown (wParam, lParam);
4020 wParam = map_keypad_keys (wParam, (lParam & 0x1000000L) != 0);
4022 windows_translate = 0;
4024 switch (wParam)
4026 case VK_LWIN:
4027 if (NILP (Vw32_pass_lwindow_to_system))
4029 /* Prevent system from acting on keyup (which opens the
4030 Start menu if no other key was pressed) by simulating a
4031 press of Space which we will ignore. */
4032 if (GetAsyncKeyState (wParam) & 1)
4034 if (NUMBERP (Vw32_phantom_key_code))
4035 key = XUINT (Vw32_phantom_key_code) & 255;
4036 else
4037 key = VK_SPACE;
4038 dpyinfo->faked_key = key;
4039 keybd_event (key, (BYTE) MapVirtualKey (key, 0), 0, 0);
4042 if (!NILP (Vw32_lwindow_modifier))
4043 return 0;
4044 break;
4045 case VK_RWIN:
4046 if (NILP (Vw32_pass_rwindow_to_system))
4048 if (GetAsyncKeyState (wParam) & 1)
4050 if (NUMBERP (Vw32_phantom_key_code))
4051 key = XUINT (Vw32_phantom_key_code) & 255;
4052 else
4053 key = VK_SPACE;
4054 dpyinfo->faked_key = key;
4055 keybd_event (key, (BYTE) MapVirtualKey (key, 0), 0, 0);
4058 if (!NILP (Vw32_rwindow_modifier))
4059 return 0;
4060 break;
4061 case VK_APPS:
4062 if (!NILP (Vw32_apps_modifier))
4063 return 0;
4064 break;
4065 case VK_MENU:
4066 if (NILP (Vw32_pass_alt_to_system))
4067 /* Prevent DefWindowProc from activating the menu bar if an
4068 Alt key is pressed and released by itself. */
4069 return 0;
4070 windows_translate = 1;
4071 break;
4072 case VK_CAPITAL:
4073 /* Decide whether to treat as modifier or function key. */
4074 if (NILP (Vw32_enable_caps_lock))
4075 goto disable_lock_key;
4076 windows_translate = 1;
4077 break;
4078 case VK_NUMLOCK:
4079 /* Decide whether to treat as modifier or function key. */
4080 if (NILP (Vw32_enable_num_lock))
4081 goto disable_lock_key;
4082 windows_translate = 1;
4083 break;
4084 case VK_SCROLL:
4085 /* Decide whether to treat as modifier or function key. */
4086 if (NILP (Vw32_scroll_lock_modifier))
4087 goto disable_lock_key;
4088 windows_translate = 1;
4089 break;
4090 disable_lock_key:
4091 /* Ensure the appropriate lock key state (and indicator light)
4092 remains in the same state. We do this by faking another
4093 press of the relevant key. Apparently, this really is the
4094 only way to toggle the state of the indicator lights. */
4095 dpyinfo->faked_key = wParam;
4096 keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0),
4097 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
4098 keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0),
4099 KEYEVENTF_EXTENDEDKEY | 0, 0);
4100 keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0),
4101 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
4102 /* Ensure indicator lights are updated promptly on Windows 9x
4103 (TranslateMessage apparently does this), after forwarding
4104 input event. */
4105 post_character_message (hwnd, msg, wParam, lParam,
4106 w32_get_key_modifiers (wParam, lParam));
4107 windows_translate = 1;
4108 break;
4109 case VK_CONTROL:
4110 case VK_SHIFT:
4111 case VK_PROCESSKEY: /* Generated by IME. */
4112 windows_translate = 1;
4113 break;
4114 case VK_CANCEL:
4115 /* Windows maps Ctrl-Pause (aka Ctrl-Break) into VK_CANCEL,
4116 which is confusing for purposes of key binding; convert
4117 VK_CANCEL events into VK_PAUSE events. */
4118 wParam = VK_PAUSE;
4119 break;
4120 case VK_PAUSE:
4121 /* Windows maps Ctrl-NumLock into VK_PAUSE, which is confusing
4122 for purposes of key binding; convert these back into
4123 VK_NUMLOCK events, at least when we want to see NumLock key
4124 presses. (Note that there is never any possibility that
4125 VK_PAUSE with Ctrl really is C-Pause as per above.) */
4126 if (NILP (Vw32_enable_num_lock) && modifier_set (VK_CONTROL))
4127 wParam = VK_NUMLOCK;
4128 break;
4129 default:
4130 /* If not defined as a function key, change it to a WM_CHAR message. */
4131 if (lispy_function_keys[wParam] == 0)
4133 DWORD modifiers = construct_console_modifiers ();
4135 if (!NILP (Vw32_recognize_altgr)
4136 && modifier_set (VK_LCONTROL) && modifier_set (VK_RMENU))
4138 /* Always let TranslateMessage handle AltGr key chords;
4139 for some reason, ToAscii doesn't always process AltGr
4140 chords correctly. */
4141 windows_translate = 1;
4143 else if ((modifiers & (~SHIFT_PRESSED & ~CAPSLOCK_ON)) != 0)
4145 /* Handle key chords including any modifiers other
4146 than shift directly, in order to preserve as much
4147 modifier information as possible. */
4148 if ('A' <= wParam && wParam <= 'Z')
4150 /* Don't translate modified alphabetic keystrokes,
4151 so the user doesn't need to constantly switch
4152 layout to type control or meta keystrokes when
4153 the normal layout translates alphabetic
4154 characters to non-ascii characters. */
4155 if (!modifier_set (VK_SHIFT))
4156 wParam += ('a' - 'A');
4157 msg = WM_CHAR;
4159 else
4161 /* Try to handle other keystrokes by determining the
4162 base character (ie. translating the base key plus
4163 shift modifier). */
4164 int add;
4165 int isdead = 0;
4166 KEY_EVENT_RECORD key;
4168 key.bKeyDown = TRUE;
4169 key.wRepeatCount = 1;
4170 key.wVirtualKeyCode = wParam;
4171 key.wVirtualScanCode = (lParam & 0xFF0000) >> 16;
4172 key.uChar.AsciiChar = 0;
4173 key.dwControlKeyState = modifiers;
4175 add = w32_kbd_patch_key (&key);
4176 /* 0 means an unrecognised keycode, negative means
4177 dead key. Ignore both. */
4178 while (--add >= 0)
4180 /* Forward asciified character sequence. */
4181 post_character_message
4182 (hwnd, WM_CHAR, key.uChar.AsciiChar, lParam,
4183 w32_get_key_modifiers (wParam, lParam));
4184 w32_kbd_patch_key (&key);
4186 return 0;
4189 else
4191 /* Let TranslateMessage handle everything else. */
4192 windows_translate = 1;
4197 translate:
4198 if (windows_translate)
4200 MSG windows_msg = { hwnd, msg, wParam, lParam, 0, {0,0} };
4202 windows_msg.time = GetMessageTime ();
4203 TranslateMessage (&windows_msg);
4204 goto dflt;
4207 /* Fall through */
4209 case WM_SYSCHAR:
4210 case WM_CHAR:
4211 post_character_message (hwnd, msg, wParam, lParam,
4212 w32_get_key_modifiers (wParam, lParam));
4213 break;
4215 /* Simulate middle mouse button events when left and right buttons
4216 are used together, but only if user has two button mouse. */
4217 case WM_LBUTTONDOWN:
4218 case WM_RBUTTONDOWN:
4219 if (XINT (Vw32_num_mouse_buttons) > 2)
4220 goto handle_plain_button;
4223 int this = (msg == WM_LBUTTONDOWN) ? LMOUSE : RMOUSE;
4224 int other = (msg == WM_LBUTTONDOWN) ? RMOUSE : LMOUSE;
4226 if (button_state & this)
4227 return 0;
4229 if (button_state == 0)
4230 SetCapture (hwnd);
4232 button_state |= this;
4234 if (button_state & other)
4236 if (mouse_button_timer)
4238 KillTimer (hwnd, mouse_button_timer);
4239 mouse_button_timer = 0;
4241 /* Generate middle mouse event instead. */
4242 msg = WM_MBUTTONDOWN;
4243 button_state |= MMOUSE;
4245 else if (button_state & MMOUSE)
4247 /* Ignore button event if we've already generated a
4248 middle mouse down event. This happens if the
4249 user releases and press one of the two buttons
4250 after we've faked a middle mouse event. */
4251 return 0;
4253 else
4255 /* Flush out saved message. */
4256 post_msg (&saved_mouse_button_msg);
4258 wmsg.dwModifiers = w32_get_modifiers ();
4259 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4261 /* Clear message buffer. */
4262 saved_mouse_button_msg.msg.hwnd = 0;
4264 else
4266 /* Hold onto message for now. */
4267 mouse_button_timer =
4268 SetTimer (hwnd, MOUSE_BUTTON_ID,
4269 XINT (Vw32_mouse_button_tolerance), NULL);
4270 saved_mouse_button_msg.msg.hwnd = hwnd;
4271 saved_mouse_button_msg.msg.message = msg;
4272 saved_mouse_button_msg.msg.wParam = wParam;
4273 saved_mouse_button_msg.msg.lParam = lParam;
4274 saved_mouse_button_msg.msg.time = GetMessageTime ();
4275 saved_mouse_button_msg.dwModifiers = w32_get_modifiers ();
4278 return 0;
4280 case WM_LBUTTONUP:
4281 case WM_RBUTTONUP:
4282 if (XINT (Vw32_num_mouse_buttons) > 2)
4283 goto handle_plain_button;
4286 int this = (msg == WM_LBUTTONUP) ? LMOUSE : RMOUSE;
4287 int other = (msg == WM_LBUTTONUP) ? RMOUSE : LMOUSE;
4289 if ((button_state & this) == 0)
4290 return 0;
4292 button_state &= ~this;
4294 if (button_state & MMOUSE)
4296 /* Only generate event when second button is released. */
4297 if ((button_state & other) == 0)
4299 msg = WM_MBUTTONUP;
4300 button_state &= ~MMOUSE;
4302 if (button_state) abort ();
4304 else
4305 return 0;
4307 else
4309 /* Flush out saved message if necessary. */
4310 if (saved_mouse_button_msg.msg.hwnd)
4312 post_msg (&saved_mouse_button_msg);
4315 wmsg.dwModifiers = w32_get_modifiers ();
4316 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4318 /* Always clear message buffer and cancel timer. */
4319 saved_mouse_button_msg.msg.hwnd = 0;
4320 KillTimer (hwnd, mouse_button_timer);
4321 mouse_button_timer = 0;
4323 if (button_state == 0)
4324 ReleaseCapture ();
4326 return 0;
4328 case WM_MBUTTONDOWN:
4329 case WM_MBUTTONUP:
4330 handle_plain_button:
4332 BOOL up;
4333 int button;
4335 if (parse_button (msg, &button, &up))
4337 if (up) ReleaseCapture ();
4338 else SetCapture (hwnd);
4339 button = (button == 0) ? LMOUSE :
4340 ((button == 1) ? MMOUSE : RMOUSE);
4341 if (up)
4342 button_state &= ~button;
4343 else
4344 button_state |= button;
4348 wmsg.dwModifiers = w32_get_modifiers ();
4349 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4350 return 0;
4352 case WM_VSCROLL:
4353 case WM_MOUSEMOVE:
4354 if (XINT (Vw32_mouse_move_interval) <= 0
4355 || (msg == WM_MOUSEMOVE && button_state == 0))
4357 wmsg.dwModifiers = w32_get_modifiers ();
4358 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4359 return 0;
4362 /* Hang onto mouse move and scroll messages for a bit, to avoid
4363 sending such events to Emacs faster than it can process them.
4364 If we get more events before the timer from the first message
4365 expires, we just replace the first message. */
4367 if (saved_mouse_move_msg.msg.hwnd == 0)
4368 mouse_move_timer =
4369 SetTimer (hwnd, MOUSE_MOVE_ID,
4370 XINT (Vw32_mouse_move_interval), NULL);
4372 /* Hold onto message for now. */
4373 saved_mouse_move_msg.msg.hwnd = hwnd;
4374 saved_mouse_move_msg.msg.message = msg;
4375 saved_mouse_move_msg.msg.wParam = wParam;
4376 saved_mouse_move_msg.msg.lParam = lParam;
4377 saved_mouse_move_msg.msg.time = GetMessageTime ();
4378 saved_mouse_move_msg.dwModifiers = w32_get_modifiers ();
4380 return 0;
4382 case WM_MOUSEWHEEL:
4383 wmsg.dwModifiers = w32_get_modifiers ();
4384 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4385 return 0;
4387 case WM_DROPFILES:
4388 wmsg.dwModifiers = w32_get_modifiers ();
4389 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4390 return 0;
4392 case WM_TIMER:
4393 /* Flush out saved messages if necessary. */
4394 if (wParam == mouse_button_timer)
4396 if (saved_mouse_button_msg.msg.hwnd)
4398 post_msg (&saved_mouse_button_msg);
4399 saved_mouse_button_msg.msg.hwnd = 0;
4401 KillTimer (hwnd, mouse_button_timer);
4402 mouse_button_timer = 0;
4404 else if (wParam == mouse_move_timer)
4406 if (saved_mouse_move_msg.msg.hwnd)
4408 post_msg (&saved_mouse_move_msg);
4409 saved_mouse_move_msg.msg.hwnd = 0;
4411 KillTimer (hwnd, mouse_move_timer);
4412 mouse_move_timer = 0;
4414 return 0;
4416 case WM_NCACTIVATE:
4417 /* Windows doesn't send us focus messages when putting up and
4418 taking down a system popup dialog as for Ctrl-Alt-Del on Windows 95.
4419 The only indication we get that something happened is receiving
4420 this message afterwards. So this is a good time to reset our
4421 keyboard modifiers' state. */
4422 reset_modifiers ();
4423 goto dflt;
4425 case WM_INITMENU:
4426 button_state = 0;
4427 ReleaseCapture ();
4428 /* We must ensure menu bar is fully constructed and up to date
4429 before allowing user interaction with it. To achieve this
4430 we send this message to the lisp thread and wait for a
4431 reply (whose value is not actually needed) to indicate that
4432 the menu bar is now ready for use, so we can now return.
4434 To remain responsive in the meantime, we enter a nested message
4435 loop that can process all other messages.
4437 However, we skip all this if the message results from calling
4438 TrackPopupMenu - in fact, we must NOT attempt to send the lisp
4439 thread a message because it is blocked on us at this point. We
4440 set menubar_active before calling TrackPopupMenu to indicate
4441 this (there is no possibility of confusion with real menubar
4442 being active). */
4444 f = x_window_to_frame (dpyinfo, hwnd);
4445 if (f
4446 && (f->output_data.w32->menubar_active
4447 /* We can receive this message even in the absence of a
4448 menubar (ie. when the system menu is activated) - in this
4449 case we do NOT want to forward the message, otherwise it
4450 will cause the menubar to suddenly appear when the user
4451 had requested it to be turned off! */
4452 || f->output_data.w32->menubar_widget == NULL))
4453 return 0;
4456 deferred_msg msg_buf;
4458 /* Detect if message has already been deferred; in this case
4459 we cannot return any sensible value to ignore this. */
4460 if (find_deferred_msg (hwnd, msg) != NULL)
4461 abort ();
4463 return send_deferred_msg (&msg_buf, hwnd, msg, wParam, lParam);
4466 case WM_EXITMENULOOP:
4467 f = x_window_to_frame (dpyinfo, hwnd);
4469 /* Indicate that menubar can be modified again. */
4470 if (f)
4471 f->output_data.w32->menubar_active = 0;
4472 goto dflt;
4474 case WM_MENUSELECT:
4475 wmsg.dwModifiers = w32_get_modifiers ();
4476 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4477 return 0;
4479 case WM_MEASUREITEM:
4480 f = x_window_to_frame (dpyinfo, hwnd);
4481 if (f)
4483 MEASUREITEMSTRUCT * pMis = (MEASUREITEMSTRUCT *) lParam;
4485 if (pMis->CtlType == ODT_MENU)
4487 /* Work out dimensions for popup menu titles. */
4488 char * title = (char *) pMis->itemData;
4489 HDC hdc = GetDC (hwnd);
4490 HFONT menu_font = GetCurrentObject (hdc, OBJ_FONT);
4491 LOGFONT menu_logfont;
4492 HFONT old_font;
4493 SIZE size;
4495 GetObject (menu_font, sizeof (menu_logfont), &menu_logfont);
4496 menu_logfont.lfWeight = FW_BOLD;
4497 menu_font = CreateFontIndirect (&menu_logfont);
4498 old_font = SelectObject (hdc, menu_font);
4500 GetTextExtentPoint32 (hdc, title, strlen (title), &size);
4501 pMis->itemWidth = size.cx;
4502 pMis->itemHeight = GetSystemMetrics (SM_CYMENUSIZE);
4503 if (pMis->itemHeight < size.cy)
4504 pMis->itemHeight = size.cy;
4506 SelectObject (hdc, old_font);
4507 DeleteObject (menu_font);
4508 ReleaseDC (hwnd, hdc);
4509 return TRUE;
4512 return 0;
4514 case WM_DRAWITEM:
4515 f = x_window_to_frame (dpyinfo, hwnd);
4516 if (f)
4518 DRAWITEMSTRUCT * pDis = (DRAWITEMSTRUCT *) lParam;
4520 if (pDis->CtlType == ODT_MENU)
4522 /* Draw popup menu title. */
4523 char * title = (char *) pDis->itemData;
4524 HDC hdc = pDis->hDC;
4525 HFONT menu_font = GetCurrentObject (hdc, OBJ_FONT);
4526 LOGFONT menu_logfont;
4527 HFONT old_font;
4529 GetObject (menu_font, sizeof (menu_logfont), &menu_logfont);
4530 menu_logfont.lfWeight = FW_BOLD;
4531 menu_font = CreateFontIndirect (&menu_logfont);
4532 old_font = SelectObject (hdc, menu_font);
4534 /* Always draw title as if not selected. */
4535 ExtTextOut (hdc,
4536 pDis->rcItem.left + GetSystemMetrics (SM_CXMENUCHECK),
4537 pDis->rcItem.top,
4538 ETO_OPAQUE, &pDis->rcItem,
4539 title, strlen (title), NULL);
4541 SelectObject (hdc, old_font);
4542 DeleteObject (menu_font);
4543 return TRUE;
4546 return 0;
4548 #if 0
4549 /* Still not right - can't distinguish between clicks in the
4550 client area of the frame from clicks forwarded from the scroll
4551 bars - may have to hook WM_NCHITTEST to remember the mouse
4552 position and then check if it is in the client area ourselves. */
4553 case WM_MOUSEACTIVATE:
4554 /* Discard the mouse click that activates a frame, allowing the
4555 user to click anywhere without changing point (or worse!).
4556 Don't eat mouse clicks on scrollbars though!! */
4557 if (LOWORD (lParam) == HTCLIENT )
4558 return MA_ACTIVATEANDEAT;
4559 goto dflt;
4560 #endif
4562 case WM_ACTIVATEAPP:
4563 case WM_ACTIVATE:
4564 case WM_WINDOWPOSCHANGED:
4565 case WM_SHOWWINDOW:
4566 /* Inform lisp thread that a frame might have just been obscured
4567 or exposed, so should recheck visibility of all frames. */
4568 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4569 goto dflt;
4571 case WM_SETFOCUS:
4572 dpyinfo->faked_key = 0;
4573 reset_modifiers ();
4574 register_hot_keys (hwnd);
4575 goto command;
4576 case WM_KILLFOCUS:
4577 unregister_hot_keys (hwnd);
4578 button_state = 0;
4579 ReleaseCapture ();
4580 case WM_MOVE:
4581 case WM_SIZE:
4582 case WM_COMMAND:
4583 command:
4584 wmsg.dwModifiers = w32_get_modifiers ();
4585 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4586 goto dflt;
4588 case WM_CLOSE:
4589 wmsg.dwModifiers = w32_get_modifiers ();
4590 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4591 return 0;
4593 case WM_WINDOWPOSCHANGING:
4595 WINDOWPLACEMENT wp;
4596 LPWINDOWPOS lppos = (WINDOWPOS *) lParam;
4598 wp.length = sizeof (WINDOWPLACEMENT);
4599 GetWindowPlacement (hwnd, &wp);
4601 if (wp.showCmd != SW_SHOWMINIMIZED && (lppos->flags & SWP_NOSIZE) == 0)
4603 RECT rect;
4604 int wdiff;
4605 int hdiff;
4606 DWORD font_width;
4607 DWORD line_height;
4608 DWORD internal_border;
4609 DWORD scrollbar_extra;
4610 RECT wr;
4612 wp.length = sizeof(wp);
4613 GetWindowRect (hwnd, &wr);
4615 enter_crit ();
4617 font_width = GetWindowLong (hwnd, WND_FONTWIDTH_INDEX);
4618 line_height = GetWindowLong (hwnd, WND_LINEHEIGHT_INDEX);
4619 internal_border = GetWindowLong (hwnd, WND_BORDER_INDEX);
4620 scrollbar_extra = GetWindowLong (hwnd, WND_SCROLLBAR_INDEX);
4622 leave_crit ();
4624 memset (&rect, 0, sizeof (rect));
4625 AdjustWindowRect (&rect, GetWindowLong (hwnd, GWL_STYLE),
4626 GetMenu (hwnd) != NULL);
4628 /* Force width and height of client area to be exact
4629 multiples of the character cell dimensions. */
4630 wdiff = (lppos->cx - (rect.right - rect.left)
4631 - 2 * internal_border - scrollbar_extra)
4632 % font_width;
4633 hdiff = (lppos->cy - (rect.bottom - rect.top)
4634 - 2 * internal_border)
4635 % line_height;
4637 if (wdiff || hdiff)
4639 /* For right/bottom sizing we can just fix the sizes.
4640 However for top/left sizing we will need to fix the X
4641 and Y positions as well. */
4643 lppos->cx -= wdiff;
4644 lppos->cy -= hdiff;
4646 if (wp.showCmd != SW_SHOWMAXIMIZED
4647 && (lppos->flags & SWP_NOMOVE) == 0)
4649 if (lppos->x != wr.left || lppos->y != wr.top)
4651 lppos->x += wdiff;
4652 lppos->y += hdiff;
4654 else
4656 lppos->flags |= SWP_NOMOVE;
4660 return 0;
4665 goto dflt;
4667 case WM_GETMINMAXINFO:
4668 /* Hack to correct bug that allows Emacs frames to be resized
4669 below the Minimum Tracking Size. */
4670 ((LPMINMAXINFO) lParam)->ptMinTrackSize.y++;
4671 return 0;
4673 case WM_EMACS_CREATESCROLLBAR:
4674 return (LRESULT) w32_createscrollbar ((struct frame *) wParam,
4675 (struct scroll_bar *) lParam);
4677 case WM_EMACS_SHOWWINDOW:
4678 return ShowWindow ((HWND) wParam, (WPARAM) lParam);
4680 case WM_EMACS_SETFOREGROUND:
4682 HWND foreground_window;
4683 DWORD foreground_thread, retval;
4685 /* On NT 5.0, and apparently Windows 98, it is necessary to
4686 attach to the thread that currently has focus in order to
4687 pull the focus away from it. */
4688 foreground_window = GetForegroundWindow ();
4689 foreground_thread = GetWindowThreadProcessId (foreground_window, NULL);
4690 if (!foreground_window
4691 || foreground_thread == GetCurrentThreadId ()
4692 || !AttachThreadInput (GetCurrentThreadId (),
4693 foreground_thread, TRUE))
4694 foreground_thread = 0;
4696 retval = SetForegroundWindow ((HWND) wParam);
4698 /* Detach from the previous foreground thread. */
4699 if (foreground_thread)
4700 AttachThreadInput (GetCurrentThreadId (),
4701 foreground_thread, FALSE);
4703 return retval;
4706 case WM_EMACS_SETWINDOWPOS:
4708 WINDOWPOS * pos = (WINDOWPOS *) wParam;
4709 return SetWindowPos (hwnd, pos->hwndInsertAfter,
4710 pos->x, pos->y, pos->cx, pos->cy, pos->flags);
4713 case WM_EMACS_DESTROYWINDOW:
4714 DragAcceptFiles ((HWND) wParam, FALSE);
4715 return DestroyWindow ((HWND) wParam);
4717 case WM_EMACS_TRACKPOPUPMENU:
4719 UINT flags;
4720 POINT *pos;
4721 int retval;
4722 pos = (POINT *)lParam;
4723 flags = TPM_CENTERALIGN;
4724 if (button_state & LMOUSE)
4725 flags |= TPM_LEFTBUTTON;
4726 else if (button_state & RMOUSE)
4727 flags |= TPM_RIGHTBUTTON;
4729 /* Remember we did a SetCapture on the initial mouse down event,
4730 so for safety, we make sure the capture is cancelled now. */
4731 ReleaseCapture ();
4732 button_state = 0;
4734 /* Use menubar_active to indicate that WM_INITMENU is from
4735 TrackPopupMenu below, and should be ignored. */
4736 f = x_window_to_frame (dpyinfo, hwnd);
4737 if (f)
4738 f->output_data.w32->menubar_active = 1;
4740 if (TrackPopupMenu ((HMENU)wParam, flags, pos->x, pos->y,
4741 0, hwnd, NULL))
4743 MSG amsg;
4744 /* Eat any mouse messages during popupmenu */
4745 while (PeekMessage (&amsg, hwnd, WM_MOUSEFIRST, WM_MOUSELAST,
4746 PM_REMOVE));
4747 /* Get the menu selection, if any */
4748 if (PeekMessage (&amsg, hwnd, WM_COMMAND, WM_COMMAND, PM_REMOVE))
4750 retval = LOWORD (amsg.wParam);
4752 else
4754 retval = 0;
4757 else
4759 retval = -1;
4762 return retval;
4765 default:
4766 /* Check for messages registered at runtime. */
4767 if (msg == msh_mousewheel)
4769 wmsg.dwModifiers = w32_get_modifiers ();
4770 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4771 return 0;
4774 dflt:
4775 return DefWindowProc (hwnd, msg, wParam, lParam);
4779 /* The most common default return code for handled messages is 0. */
4780 return 0;
4783 void
4784 my_create_window (f)
4785 struct frame * f;
4787 MSG msg;
4789 if (!PostThreadMessage (dwWindowsThreadId, WM_EMACS_CREATEWINDOW, (WPARAM)f, 0))
4790 abort ();
4791 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
4794 /* Create and set up the w32 window for frame F. */
4796 static void
4797 w32_window (f, window_prompting, minibuffer_only)
4798 struct frame *f;
4799 long window_prompting;
4800 int minibuffer_only;
4802 BLOCK_INPUT;
4804 /* Use the resource name as the top-level window name
4805 for looking up resources. Make a non-Lisp copy
4806 for the window manager, so GC relocation won't bother it.
4808 Elsewhere we specify the window name for the window manager. */
4811 char *str = (char *) XSTRING (Vx_resource_name)->data;
4812 f->namebuf = (char *) xmalloc (strlen (str) + 1);
4813 strcpy (f->namebuf, str);
4816 my_create_window (f);
4818 validate_x_resource_name ();
4820 /* x_set_name normally ignores requests to set the name if the
4821 requested name is the same as the current name. This is the one
4822 place where that assumption isn't correct; f->name is set, but
4823 the server hasn't been told. */
4825 Lisp_Object name;
4826 int explicit = f->explicit_name;
4828 f->explicit_name = 0;
4829 name = f->name;
4830 f->name = Qnil;
4831 x_set_name (f, name, explicit);
4834 UNBLOCK_INPUT;
4836 if (!minibuffer_only && FRAME_EXTERNAL_MENU_BAR (f))
4837 initialize_frame_menubar (f);
4839 if (FRAME_W32_WINDOW (f) == 0)
4840 error ("Unable to create window");
4843 /* Handle the icon stuff for this window. Perhaps later we might
4844 want an x_set_icon_position which can be called interactively as
4845 well. */
4847 static void
4848 x_icon (f, parms)
4849 struct frame *f;
4850 Lisp_Object parms;
4852 Lisp_Object icon_x, icon_y;
4854 /* Set the position of the icon. Note that Windows 95 groups all
4855 icons in the tray. */
4856 icon_x = w32_get_arg (parms, Qicon_left, 0, 0, RES_TYPE_NUMBER);
4857 icon_y = w32_get_arg (parms, Qicon_top, 0, 0, RES_TYPE_NUMBER);
4858 if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound))
4860 CHECK_NUMBER (icon_x, 0);
4861 CHECK_NUMBER (icon_y, 0);
4863 else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound))
4864 error ("Both left and top icon corners of icon must be specified");
4866 BLOCK_INPUT;
4868 if (! EQ (icon_x, Qunbound))
4869 x_wm_set_icon_position (f, XINT (icon_x), XINT (icon_y));
4871 #if 0 /* TODO */
4872 /* Start up iconic or window? */
4873 x_wm_set_window_state
4874 (f, (EQ (w32_get_arg (parms, Qvisibility, 0, 0, RES_TYPE_SYMBOL), Qicon)
4875 ? IconicState
4876 : NormalState));
4878 x_text_icon (f, (char *) XSTRING ((!NILP (f->icon_name)
4879 ? f->icon_name
4880 : f->name))->data);
4881 #endif
4883 UNBLOCK_INPUT;
4887 static void
4888 x_make_gc (f)
4889 struct frame *f;
4891 XGCValues gc_values;
4893 BLOCK_INPUT;
4895 /* Create the GC's of this frame.
4896 Note that many default values are used. */
4898 /* Normal video */
4899 gc_values.font = f->output_data.w32->font;
4901 /* Cursor has cursor-color background, background-color foreground. */
4902 gc_values.foreground = FRAME_BACKGROUND_PIXEL (f);
4903 gc_values.background = f->output_data.w32->cursor_pixel;
4904 f->output_data.w32->cursor_gc
4905 = XCreateGC (NULL, FRAME_W32_WINDOW (f),
4906 (GCFont | GCForeground | GCBackground),
4907 &gc_values);
4909 /* Reliefs. */
4910 f->output_data.w32->white_relief.gc = 0;
4911 f->output_data.w32->black_relief.gc = 0;
4913 UNBLOCK_INPUT;
4917 DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
4918 1, 1, 0,
4919 "Make a new window, which is called a \"frame\" in Emacs terms.\n\
4920 Returns an Emacs frame object.\n\
4921 ALIST is an alist of frame parameters.\n\
4922 If the parameters specify that the frame should not have a minibuffer,\n\
4923 and do not specify a specific minibuffer window to use,\n\
4924 then `default-minibuffer-frame' must be a frame whose minibuffer can\n\
4925 be shared by the new frame.\n\
4927 This function is an internal primitive--use `make-frame' instead.")
4928 (parms)
4929 Lisp_Object parms;
4931 struct frame *f;
4932 Lisp_Object frame, tem;
4933 Lisp_Object name;
4934 int minibuffer_only = 0;
4935 long window_prompting = 0;
4936 int width, height;
4937 int count = specpdl_ptr - specpdl;
4938 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4939 Lisp_Object display;
4940 struct w32_display_info *dpyinfo = NULL;
4941 Lisp_Object parent;
4942 struct kboard *kb;
4944 check_w32 ();
4946 /* Use this general default value to start with
4947 until we know if this frame has a specified name. */
4948 Vx_resource_name = Vinvocation_name;
4950 display = w32_get_arg (parms, Qdisplay, 0, 0, RES_TYPE_STRING);
4951 if (EQ (display, Qunbound))
4952 display = Qnil;
4953 dpyinfo = check_x_display_info (display);
4954 #ifdef MULTI_KBOARD
4955 kb = dpyinfo->kboard;
4956 #else
4957 kb = &the_only_kboard;
4958 #endif
4960 name = w32_get_arg (parms, Qname, "name", "Name", RES_TYPE_STRING);
4961 if (!STRINGP (name)
4962 && ! EQ (name, Qunbound)
4963 && ! NILP (name))
4964 error ("Invalid frame name--not a string or nil");
4966 if (STRINGP (name))
4967 Vx_resource_name = name;
4969 /* See if parent window is specified. */
4970 parent = w32_get_arg (parms, Qparent_id, NULL, NULL, RES_TYPE_NUMBER);
4971 if (EQ (parent, Qunbound))
4972 parent = Qnil;
4973 if (! NILP (parent))
4974 CHECK_NUMBER (parent, 0);
4976 /* make_frame_without_minibuffer can run Lisp code and garbage collect. */
4977 /* No need to protect DISPLAY because that's not used after passing
4978 it to make_frame_without_minibuffer. */
4979 frame = Qnil;
4980 GCPRO4 (parms, parent, name, frame);
4981 tem = w32_get_arg (parms, Qminibuffer, 0, 0, RES_TYPE_SYMBOL);
4982 if (EQ (tem, Qnone) || NILP (tem))
4983 f = make_frame_without_minibuffer (Qnil, kb, display);
4984 else if (EQ (tem, Qonly))
4986 f = make_minibuffer_frame ();
4987 minibuffer_only = 1;
4989 else if (WINDOWP (tem))
4990 f = make_frame_without_minibuffer (tem, kb, display);
4991 else
4992 f = make_frame (1);
4994 XSETFRAME (frame, f);
4996 /* Note that Windows does support scroll bars. */
4997 FRAME_CAN_HAVE_SCROLL_BARS (f) = 1;
4998 /* By default, make scrollbars the system standard width. */
4999 f->scroll_bar_pixel_width = GetSystemMetrics (SM_CXVSCROLL);
5001 f->output_method = output_w32;
5002 f->output_data.w32 =
5003 (struct w32_output *) xmalloc (sizeof (struct w32_output));
5004 bzero (f->output_data.w32, sizeof (struct w32_output));
5006 FRAME_FONTSET (f) = -1;
5008 f->icon_name
5009 = w32_get_arg (parms, Qicon_name, "iconName", "Title", RES_TYPE_STRING);
5010 if (! STRINGP (f->icon_name))
5011 f->icon_name = Qnil;
5013 /* FRAME_W32_DISPLAY_INFO (f) = dpyinfo; */
5014 #ifdef MULTI_KBOARD
5015 FRAME_KBOARD (f) = kb;
5016 #endif
5018 /* Specify the parent under which to make this window. */
5020 if (!NILP (parent))
5022 f->output_data.w32->parent_desc = (Window) parent;
5023 f->output_data.w32->explicit_parent = 1;
5025 else
5027 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
5028 f->output_data.w32->explicit_parent = 0;
5031 /* Set the name; the functions to which we pass f expect the name to
5032 be set. */
5033 if (EQ (name, Qunbound) || NILP (name))
5035 f->name = build_string (dpyinfo->w32_id_name);
5036 f->explicit_name = 0;
5038 else
5040 f->name = name;
5041 f->explicit_name = 1;
5042 /* use the frame's title when getting resources for this frame. */
5043 specbind (Qx_resource_name, name);
5046 /* Extract the window parameters from the supplied values
5047 that are needed to determine window geometry. */
5049 Lisp_Object font;
5051 font = w32_get_arg (parms, Qfont, "font", "Font", RES_TYPE_STRING);
5053 BLOCK_INPUT;
5054 /* First, try whatever font the caller has specified. */
5055 if (STRINGP (font))
5057 tem = Fquery_fontset (font, Qnil);
5058 if (STRINGP (tem))
5059 font = x_new_fontset (f, XSTRING (tem)->data);
5060 else
5061 font = x_new_font (f, XSTRING (font)->data);
5063 /* Try out a font which we hope has bold and italic variations. */
5064 if (!STRINGP (font))
5065 font = x_new_font (f, "-*-Courier New-normal-r-*-*-13-*-*-*-c-*-iso8859-1");
5066 if (! STRINGP (font))
5067 font = x_new_font (f, "-*-Courier-normal-r-*-*-13-*-*-*-c-*-iso8859-1");
5068 /* If those didn't work, look for something which will at least work. */
5069 if (! STRINGP (font))
5070 font = x_new_font (f, "-*-Fixedsys-normal-r-*-*-12-*-*-*-c-*-iso8859-1");
5071 UNBLOCK_INPUT;
5072 if (! STRINGP (font))
5073 font = build_string ("Fixedsys");
5075 x_default_parameter (f, parms, Qfont, font,
5076 "font", "Font", RES_TYPE_STRING);
5079 x_default_parameter (f, parms, Qborder_width, make_number (2),
5080 "borderwidth", "BorderWidth", RES_TYPE_NUMBER);
5081 /* This defaults to 2 in order to match xterm. We recognize either
5082 internalBorderWidth or internalBorder (which is what xterm calls
5083 it). */
5084 if (NILP (Fassq (Qinternal_border_width, parms)))
5086 Lisp_Object value;
5088 value = w32_get_arg (parms, Qinternal_border_width,
5089 "internalBorder", "BorderWidth", RES_TYPE_NUMBER);
5090 if (! EQ (value, Qunbound))
5091 parms = Fcons (Fcons (Qinternal_border_width, value),
5092 parms);
5094 /* Default internalBorderWidth to 0 on Windows to match other programs. */
5095 x_default_parameter (f, parms, Qinternal_border_width, make_number (0),
5096 "internalBorderWidth", "BorderWidth", RES_TYPE_NUMBER);
5097 x_default_parameter (f, parms, Qvertical_scroll_bars, Qt,
5098 "verticalScrollBars", "ScrollBars", RES_TYPE_BOOLEAN);
5100 /* Also do the stuff which must be set before the window exists. */
5101 x_default_parameter (f, parms, Qforeground_color, build_string ("black"),
5102 "foreground", "Foreground", RES_TYPE_STRING);
5103 x_default_parameter (f, parms, Qbackground_color, build_string ("white"),
5104 "background", "Background", RES_TYPE_STRING);
5105 x_default_parameter (f, parms, Qmouse_color, build_string ("black"),
5106 "pointerColor", "Foreground", RES_TYPE_STRING);
5107 x_default_parameter (f, parms, Qcursor_color, build_string ("black"),
5108 "cursorColor", "Foreground", RES_TYPE_STRING);
5109 x_default_parameter (f, parms, Qborder_color, build_string ("black"),
5110 "borderColor", "BorderColor", RES_TYPE_STRING);
5111 x_default_parameter (f, parms, Qscreen_gamma, Qnil,
5112 "screenGamma", "ScreenGamma", RES_TYPE_FLOAT);
5115 /* Init faces before x_default_parameter is called for scroll-bar
5116 parameters because that function calls x_set_scroll_bar_width,
5117 which calls change_frame_size, which calls Fset_window_buffer,
5118 which runs hooks, which call Fvertical_motion. At the end, we
5119 end up in init_iterator with a null face cache, which should not
5120 happen. */
5121 init_frame_faces (f);
5123 x_default_parameter (f, parms, Qmenu_bar_lines, make_number (1),
5124 "menuBar", "MenuBar", RES_TYPE_NUMBER);
5125 x_default_parameter (f, parms, Qtool_bar_lines, make_number (0),
5126 "toolBar", "ToolBar", RES_TYPE_NUMBER);
5127 x_default_parameter (f, parms, Qbuffer_predicate, Qnil,
5128 "bufferPredicate", "BufferPredicate", RES_TYPE_SYMBOL);
5129 x_default_parameter (f, parms, Qtitle, Qnil,
5130 "title", "Title", RES_TYPE_STRING);
5132 f->output_data.w32->dwStyle = WS_OVERLAPPEDWINDOW;
5133 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
5134 window_prompting = x_figure_window_size (f, parms);
5136 if (window_prompting & XNegative)
5138 if (window_prompting & YNegative)
5139 f->output_data.w32->win_gravity = SouthEastGravity;
5140 else
5141 f->output_data.w32->win_gravity = NorthEastGravity;
5143 else
5145 if (window_prompting & YNegative)
5146 f->output_data.w32->win_gravity = SouthWestGravity;
5147 else
5148 f->output_data.w32->win_gravity = NorthWestGravity;
5151 f->output_data.w32->size_hint_flags = window_prompting;
5153 tem = w32_get_arg (parms, Qunsplittable, 0, 0, RES_TYPE_BOOLEAN);
5154 f->no_split = minibuffer_only || EQ (tem, Qt);
5156 /* Create the window. Add the tool-bar height to the initial frame
5157 height so that the user gets a text display area of the size he
5158 specified with -g or via the registry. Later changes of the
5159 tool-bar height don't change the frame size. This is done so that
5160 users can create tall Emacs frames without having to guess how
5161 tall the tool-bar will get. */
5162 f->height += FRAME_TOOL_BAR_LINES (f);
5163 w32_window (f, window_prompting, minibuffer_only);
5164 x_icon (f, parms);
5166 x_make_gc (f);
5168 /* Now consider the frame official. */
5169 FRAME_W32_DISPLAY_INFO (f)->reference_count++;
5170 Vframe_list = Fcons (frame, Vframe_list);
5172 /* We need to do this after creating the window, so that the
5173 icon-creation functions can say whose icon they're describing. */
5174 x_default_parameter (f, parms, Qicon_type, Qnil,
5175 "bitmapIcon", "BitmapIcon", RES_TYPE_SYMBOL);
5177 x_default_parameter (f, parms, Qauto_raise, Qnil,
5178 "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN);
5179 x_default_parameter (f, parms, Qauto_lower, Qnil,
5180 "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN);
5181 x_default_parameter (f, parms, Qcursor_type, Qbox,
5182 "cursorType", "CursorType", RES_TYPE_SYMBOL);
5183 x_default_parameter (f, parms, Qscroll_bar_width, Qnil,
5184 "scrollBarWidth", "ScrollBarWidth", RES_TYPE_NUMBER);
5186 /* Dimensions, especially f->height, must be done via change_frame_size.
5187 Change will not be effected unless different from the current
5188 f->height. */
5189 width = f->width;
5190 height = f->height;
5191 f->height = 0;
5192 SET_FRAME_WIDTH (f, 0);
5193 change_frame_size (f, height, width, 1, 0, 0);
5195 /* Set up faces after all frame parameters are known. */
5196 call1 (Qface_set_after_frame_default, frame);
5198 /* Tell the server what size and position, etc, we want, and how
5199 badly we want them. This should be done after we have the menu
5200 bar so that its size can be taken into account. */
5201 BLOCK_INPUT;
5202 x_wm_set_size_hint (f, window_prompting, 0);
5203 UNBLOCK_INPUT;
5205 /* Make the window appear on the frame and enable display, unless
5206 the caller says not to. However, with explicit parent, Emacs
5207 cannot control visibility, so don't try. */
5208 if (! f->output_data.w32->explicit_parent)
5210 Lisp_Object visibility;
5212 visibility = w32_get_arg (parms, Qvisibility, 0, 0, RES_TYPE_SYMBOL);
5213 if (EQ (visibility, Qunbound))
5214 visibility = Qt;
5216 if (EQ (visibility, Qicon))
5217 x_iconify_frame (f);
5218 else if (! NILP (visibility))
5219 x_make_frame_visible (f);
5220 else
5221 /* Must have been Qnil. */
5224 UNGCPRO;
5225 return unbind_to (count, frame);
5228 /* FRAME is used only to get a handle on the X display. We don't pass the
5229 display info directly because we're called from frame.c, which doesn't
5230 know about that structure. */
5231 Lisp_Object
5232 x_get_focus_frame (frame)
5233 struct frame *frame;
5235 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (frame);
5236 Lisp_Object xfocus;
5237 if (! dpyinfo->w32_focus_frame)
5238 return Qnil;
5240 XSETFRAME (xfocus, dpyinfo->w32_focus_frame);
5241 return xfocus;
5244 DEFUN ("w32-focus-frame", Fw32_focus_frame, Sw32_focus_frame, 1, 1, 0,
5245 "Give FRAME input focus, raising to foreground if necessary.")
5246 (frame)
5247 Lisp_Object frame;
5249 x_focus_on_frame (check_x_frame (frame));
5250 return Qnil;
5254 struct font_info *w32_load_bdf_font (struct frame *f, char *fontname,
5255 int size, char* filename);
5257 struct font_info *
5258 w32_load_system_font (f,fontname,size)
5259 struct frame *f;
5260 char * fontname;
5261 int size;
5263 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
5264 Lisp_Object font_names;
5266 /* Get a list of all the fonts that match this name. Once we
5267 have a list of matching fonts, we compare them against the fonts
5268 we already have loaded by comparing names. */
5269 font_names = w32_list_fonts (f, build_string (fontname), size, 100);
5271 if (!NILP (font_names))
5273 Lisp_Object tail;
5274 int i;
5276 /* First check if any are already loaded, as that is cheaper
5277 than loading another one. */
5278 for (i = 0; i < dpyinfo->n_fonts; i++)
5279 for (tail = font_names; CONSP (tail); tail = XCDR (tail))
5280 if (dpyinfo->font_table[i].name
5281 && (!strcmp (dpyinfo->font_table[i].name,
5282 XSTRING (XCAR (tail))->data)
5283 || !strcmp (dpyinfo->font_table[i].full_name,
5284 XSTRING (XCAR (tail))->data)))
5285 return (dpyinfo->font_table + i);
5287 fontname = (char *) XSTRING (XCAR (font_names))->data;
5289 else if (w32_strict_fontnames)
5291 /* If EnumFontFamiliesEx was available, we got a full list of
5292 fonts back so stop now to avoid the possibility of loading a
5293 random font. If we had to fall back to EnumFontFamilies, the
5294 list is incomplete, so continue whether the font we want was
5295 listed or not. */
5296 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
5297 FARPROC enum_font_families_ex
5298 = GetProcAddress (gdi32, "EnumFontFamiliesExA");
5299 if (enum_font_families_ex)
5300 return NULL;
5303 /* Load the font and add it to the table. */
5305 char *full_name, *encoding;
5306 XFontStruct *font;
5307 struct font_info *fontp;
5308 LOGFONT lf;
5309 BOOL ok;
5310 int i;
5312 if (!fontname || !x_to_w32_font (fontname, &lf))
5313 return (NULL);
5315 if (!*lf.lfFaceName)
5316 /* If no name was specified for the font, we get a random font
5317 from CreateFontIndirect - this is not particularly
5318 desirable, especially since CreateFontIndirect does not
5319 fill out the missing name in lf, so we never know what we
5320 ended up with. */
5321 return NULL;
5323 font = (XFontStruct *) xmalloc (sizeof (XFontStruct));
5325 /* Set bdf to NULL to indicate that this is a Windows font. */
5326 font->bdf = NULL;
5328 BLOCK_INPUT;
5330 font->hfont = CreateFontIndirect (&lf);
5332 if (font->hfont == NULL)
5334 ok = FALSE;
5336 else
5338 HDC hdc;
5339 HANDLE oldobj;
5341 hdc = GetDC (dpyinfo->root_window);
5342 oldobj = SelectObject (hdc, font->hfont);
5343 ok = GetTextMetrics (hdc, &font->tm);
5344 SelectObject (hdc, oldobj);
5345 ReleaseDC (dpyinfo->root_window, hdc);
5346 /* Fill out details in lf according to the font that was
5347 actually loaded. */
5348 lf.lfHeight = font->tm.tmInternalLeading - font->tm.tmHeight;
5349 lf.lfWidth = font->tm.tmAveCharWidth;
5350 lf.lfWeight = font->tm.tmWeight;
5351 lf.lfItalic = font->tm.tmItalic;
5352 lf.lfCharSet = font->tm.tmCharSet;
5353 lf.lfPitchAndFamily = ((font->tm.tmPitchAndFamily & TMPF_FIXED_PITCH)
5354 ? VARIABLE_PITCH : FIXED_PITCH);
5355 lf.lfOutPrecision = ((font->tm.tmPitchAndFamily & TMPF_VECTOR)
5356 ? OUT_STROKE_PRECIS : OUT_STRING_PRECIS);
5359 UNBLOCK_INPUT;
5361 if (!ok)
5363 w32_unload_font (dpyinfo, font);
5364 return (NULL);
5367 /* Find a free slot in the font table. */
5368 for (i = 0; i < dpyinfo->n_fonts; ++i)
5369 if (dpyinfo->font_table[i].name == NULL)
5370 break;
5372 /* If no free slot found, maybe enlarge the font table. */
5373 if (i == dpyinfo->n_fonts
5374 && dpyinfo->n_fonts == dpyinfo->font_table_size)
5376 int sz;
5377 dpyinfo->font_table_size = max (16, 2 * dpyinfo->font_table_size);
5378 sz = dpyinfo->font_table_size * sizeof *dpyinfo->font_table;
5379 dpyinfo->font_table
5380 = (struct font_info *) xrealloc (dpyinfo->font_table, sz);
5383 fontp = dpyinfo->font_table + i;
5384 if (i == dpyinfo->n_fonts)
5385 ++dpyinfo->n_fonts;
5387 /* Now fill in the slots of *FONTP. */
5388 BLOCK_INPUT;
5389 fontp->font = font;
5390 fontp->font_idx = i;
5391 fontp->name = (char *) xmalloc (strlen (fontname) + 1);
5392 bcopy (fontname, fontp->name, strlen (fontname) + 1);
5394 /* Work out the font's full name. */
5395 full_name = (char *)xmalloc (100);
5396 if (full_name && w32_to_x_font (&lf, full_name, 100))
5397 fontp->full_name = full_name;
5398 else
5400 /* If all else fails - just use the name we used to load it. */
5401 xfree (full_name);
5402 fontp->full_name = fontp->name;
5405 fontp->size = FONT_WIDTH (font);
5406 fontp->height = FONT_HEIGHT (font);
5408 /* The slot `encoding' specifies how to map a character
5409 code-points (0x20..0x7F or 0x2020..0x7F7F) of each charset to
5410 the font code-points (0:0x20..0x7F, 1:0xA0..0xFF), or
5411 (0:0x20..0x7F, 1:0xA0..0xFF,
5412 (0:0x2020..0x7F7F, 1:0xA0A0..0xFFFF, 3:0x20A0..0x7FFF,
5413 2:0xA020..0xFF7F). For the moment, we don't know which charset
5414 uses this font. So, we set information in fontp->encoding[1]
5415 which is never used by any charset. If mapping can't be
5416 decided, set FONT_ENCODING_NOT_DECIDED. */
5418 /* SJIS fonts need to be set to type 4, all others seem to work as
5419 type FONT_ENCODING_NOT_DECIDED. */
5420 encoding = strrchr (fontp->name, '-');
5421 if (encoding && stricmp (encoding+1, "sjis") == 0)
5422 fontp->encoding[1] = 4;
5423 else
5424 fontp->encoding[1] = FONT_ENCODING_NOT_DECIDED;
5426 /* The following three values are set to 0 under W32, which is
5427 what they get set to if XGetFontProperty fails under X. */
5428 fontp->baseline_offset = 0;
5429 fontp->relative_compose = 0;
5430 fontp->default_ascent = 0;
5432 /* Set global flag fonts_changed_p to non-zero if the font loaded
5433 has a character with a smaller width than any other character
5434 before, or if the font loaded has a smalle>r height than any
5435 other font loaded before. If this happens, it will make a
5436 glyph matrix reallocation necessary. */
5437 fonts_changed_p = x_compute_min_glyph_bounds (f);
5438 UNBLOCK_INPUT;
5439 return fontp;
5443 /* Load font named FONTNAME of size SIZE for frame F, and return a
5444 pointer to the structure font_info while allocating it dynamically.
5445 If loading fails, return NULL. */
5446 struct font_info *
5447 w32_load_font (f,fontname,size)
5448 struct frame *f;
5449 char * fontname;
5450 int size;
5452 Lisp_Object bdf_fonts;
5453 struct font_info *retval = NULL;
5455 bdf_fonts = w32_list_bdf_fonts (build_string (fontname));
5457 while (!retval && CONSP (bdf_fonts))
5459 char *bdf_name, *bdf_file;
5460 Lisp_Object bdf_pair;
5462 bdf_name = XSTRING (XCAR (bdf_fonts))->data;
5463 bdf_pair = Fassoc (XCAR (bdf_fonts), Vw32_bdf_filename_alist);
5464 bdf_file = XSTRING (XCDR (bdf_pair))->data;
5466 retval = w32_load_bdf_font (f, bdf_name, size, bdf_file);
5468 bdf_fonts = XCDR (bdf_fonts);
5471 if (retval)
5472 return retval;
5474 return w32_load_system_font(f, fontname, size);
5478 void
5479 w32_unload_font (dpyinfo, font)
5480 struct w32_display_info *dpyinfo;
5481 XFontStruct * font;
5483 if (font)
5485 if (font->bdf) w32_free_bdf_font (font->bdf);
5487 if (font->hfont) DeleteObject(font->hfont);
5488 xfree (font);
5492 /* The font conversion stuff between x and w32 */
5494 /* X font string is as follows (from faces.el)
5495 * (let ((- "[-?]")
5496 * (foundry "[^-]+")
5497 * (family "[^-]+")
5498 * (weight "\\(bold\\|demibold\\|medium\\)") ; 1
5499 * (weight\? "\\([^-]*\\)") ; 1
5500 * (slant "\\([ior]\\)") ; 2
5501 * (slant\? "\\([^-]?\\)") ; 2
5502 * (swidth "\\([^-]*\\)") ; 3
5503 * (adstyle "[^-]*") ; 4
5504 * (pixelsize "[0-9]+")
5505 * (pointsize "[0-9][0-9]+")
5506 * (resx "[0-9][0-9]+")
5507 * (resy "[0-9][0-9]+")
5508 * (spacing "[cmp?*]")
5509 * (avgwidth "[0-9]+")
5510 * (registry "[^-]+")
5511 * (encoding "[^-]+")
5513 * (setq x-font-regexp
5514 * (concat "\\`\\*?[-?*]"
5515 * foundry - family - weight\? - slant\? - swidth - adstyle -
5516 * pixelsize - pointsize - resx - resy - spacing - registry -
5517 * encoding "[-?*]\\*?\\'"
5518 * ))
5519 * (setq x-font-regexp-head
5520 * (concat "\\`[-?*]" foundry - family - weight\? - slant\?
5521 * "\\([-*?]\\|\\'\\)"))
5522 * (setq x-font-regexp-slant (concat - slant -))
5523 * (setq x-font-regexp-weight (concat - weight -))
5524 * nil)
5527 #define FONT_START "[-?]"
5528 #define FONT_FOUNDRY "[^-]+"
5529 #define FONT_FAMILY "\\([^-]+\\)" /* 1 */
5530 #define FONT_WEIGHT "\\(bold\\|demibold\\|medium\\)" /* 2 */
5531 #define FONT_WEIGHT_Q "\\([^-]*\\)" /* 2 */
5532 #define FONT_SLANT "\\([ior]\\)" /* 3 */
5533 #define FONT_SLANT_Q "\\([^-]?\\)" /* 3 */
5534 #define FONT_SWIDTH "\\([^-]*\\)" /* 4 */
5535 #define FONT_ADSTYLE "[^-]*"
5536 #define FONT_PIXELSIZE "[^-]*"
5537 #define FONT_POINTSIZE "\\([0-9][0-9]+\\|\\*\\)" /* 5 */
5538 #define FONT_RESX "[0-9][0-9]+"
5539 #define FONT_RESY "[0-9][0-9]+"
5540 #define FONT_SPACING "[cmp?*]"
5541 #define FONT_AVGWIDTH "[0-9]+"
5542 #define FONT_REGISTRY "[^-]+"
5543 #define FONT_ENCODING "[^-]+"
5545 #define FONT_REGEXP ("\\`\\*?[-?*]" \
5546 FONT_FOUNDRY "-" \
5547 FONT_FAMILY "-" \
5548 FONT_WEIGHT_Q "-" \
5549 FONT_SLANT_Q "-" \
5550 FONT_SWIDTH "-" \
5551 FONT_ADSTYLE "-" \
5552 FONT_PIXELSIZE "-" \
5553 FONT_POINTSIZE "-" \
5554 "[-?*]\\|\\'")
5556 #define FONT_REGEXP_HEAD ("\\`[-?*]" \
5557 FONT_FOUNDRY "-" \
5558 FONT_FAMILY "-" \
5559 FONT_WEIGHT_Q "-" \
5560 FONT_SLANT_Q \
5561 "\\([-*?]\\|\\'\\)")
5563 #define FONT_REGEXP_SLANT "-" FONT_SLANT "-"
5564 #define FONT_REGEXP_WEIGHT "-" FONT_WEIGHT "-"
5566 LONG
5567 x_to_w32_weight (lpw)
5568 char * lpw;
5570 if (!lpw) return (FW_DONTCARE);
5572 if (stricmp (lpw,"heavy") == 0) return FW_HEAVY;
5573 else if (stricmp (lpw,"extrabold") == 0) return FW_EXTRABOLD;
5574 else if (stricmp (lpw,"bold") == 0) return FW_BOLD;
5575 else if (stricmp (lpw,"demibold") == 0) return FW_SEMIBOLD;
5576 else if (stricmp (lpw,"semibold") == 0) return FW_SEMIBOLD;
5577 else if (stricmp (lpw,"medium") == 0) return FW_MEDIUM;
5578 else if (stricmp (lpw,"normal") == 0) return FW_NORMAL;
5579 else if (stricmp (lpw,"light") == 0) return FW_LIGHT;
5580 else if (stricmp (lpw,"extralight") == 0) return FW_EXTRALIGHT;
5581 else if (stricmp (lpw,"thin") == 0) return FW_THIN;
5582 else
5583 return FW_DONTCARE;
5587 char *
5588 w32_to_x_weight (fnweight)
5589 int fnweight;
5591 if (fnweight >= FW_HEAVY) return "heavy";
5592 if (fnweight >= FW_EXTRABOLD) return "extrabold";
5593 if (fnweight >= FW_BOLD) return "bold";
5594 if (fnweight >= FW_SEMIBOLD) return "demibold";
5595 if (fnweight >= FW_MEDIUM) return "medium";
5596 if (fnweight >= FW_NORMAL) return "normal";
5597 if (fnweight >= FW_LIGHT) return "light";
5598 if (fnweight >= FW_EXTRALIGHT) return "extralight";
5599 if (fnweight >= FW_THIN) return "thin";
5600 else
5601 return "*";
5604 LONG
5605 x_to_w32_charset (lpcs)
5606 char * lpcs;
5608 if (!lpcs) return (0);
5610 if (stricmp (lpcs,"ansi") == 0) return ANSI_CHARSET;
5611 else if (stricmp (lpcs,"iso8859-1") == 0) return ANSI_CHARSET;
5612 else if (stricmp (lpcs, "ms-symbol") == 0) return SYMBOL_CHARSET;
5613 /* Map all Japanese charsets to the Windows Shift-JIS charset. */
5614 else if (strnicmp (lpcs, "jis", 3) == 0) return SHIFTJIS_CHARSET;
5615 /* Map all GB charsets to the Windows GB2312 charset. */
5616 else if (strnicmp (lpcs, "gb2312", 6) == 0) return GB2312_CHARSET;
5617 /* Map all Big5 charsets to the Windows Big5 charset. */
5618 else if (strnicmp (lpcs, "big5", 4) == 0) return CHINESEBIG5_CHARSET;
5619 else if (stricmp (lpcs, "ksc5601.1987") == 0) return HANGEUL_CHARSET;
5620 else if (stricmp (lpcs, "ms-oem") == 0) return OEM_CHARSET;
5622 #ifdef EASTEUROPE_CHARSET
5623 else if (stricmp (lpcs, "iso8859-2") == 0) return EASTEUROPE_CHARSET;
5624 else if (stricmp (lpcs, "iso8859-3") == 0) return TURKISH_CHARSET;
5625 else if (stricmp (lpcs, "iso8859-4") == 0) return BALTIC_CHARSET;
5626 else if (stricmp (lpcs, "iso8859-5") == 0) return RUSSIAN_CHARSET;
5627 else if (stricmp (lpcs, "koi8") == 0) return RUSSIAN_CHARSET;
5628 else if (stricmp (lpcs, "iso8859-6") == 0) return ARABIC_CHARSET;
5629 else if (stricmp (lpcs, "iso8859-7") == 0) return GREEK_CHARSET;
5630 else if (stricmp (lpcs, "iso8859-8") == 0) return HEBREW_CHARSET;
5631 else if (stricmp (lpcs, "iso8859-9") == 0) return TURKISH_CHARSET;
5632 #ifndef VIETNAMESE_CHARSET
5633 #define VIETNAMESE_CHARSET 163
5634 #endif
5635 /* Map all Viscii charsets to the Windows Vietnamese charset. */
5636 else if (strnicmp (lpcs, "viscii", 6) == 0) return VIETNAMESE_CHARSET;
5637 else if (strnicmp (lpcs, "vscii", 5) == 0) return VIETNAMESE_CHARSET;
5638 /* Map all TIS charsets to the Windows Thai charset. */
5639 else if (strnicmp (lpcs, "tis620", 6) == 0) return THAI_CHARSET;
5640 else if (stricmp (lpcs, "mac") == 0) return MAC_CHARSET;
5641 else if (stricmp (lpcs, "ksc5601.1992") == 0) return JOHAB_CHARSET;
5642 /* For backwards compatibility with previous 20.4 pretests, map
5643 non-specific KSC charsets to the Windows Hangeul charset. */
5644 else if (strnicmp (lpcs, "ksc5601", 7) == 0) return HANGEUL_CHARSET;
5645 else if (stricmp (lpcs, "johab") == 0) return JOHAB_CHARSET;
5646 #endif
5648 #ifdef UNICODE_CHARSET
5649 else if (stricmp (lpcs,"iso10646") == 0) return UNICODE_CHARSET;
5650 else if (stricmp (lpcs, "unicode") == 0) return UNICODE_CHARSET;
5651 #endif
5652 else if (lpcs[0] == '#') return atoi (lpcs + 1);
5653 else
5654 return DEFAULT_CHARSET;
5657 char *
5658 w32_to_x_charset (fncharset)
5659 int fncharset;
5661 static char buf[16];
5663 switch (fncharset)
5665 /* ansi is considered iso8859-1, as most modern ansi fonts are. */
5666 case ANSI_CHARSET: return "iso8859-1";
5667 case DEFAULT_CHARSET: return "ascii-*";
5668 case SYMBOL_CHARSET: return "ms-symbol";
5669 case SHIFTJIS_CHARSET: return "jisx0208-sjis";
5670 case HANGEUL_CHARSET: return "ksc5601.1987-*";
5671 case GB2312_CHARSET: return "gb2312-*";
5672 case CHINESEBIG5_CHARSET: return "big5-*";
5673 case OEM_CHARSET: return "ms-oem";
5675 /* More recent versions of Windows (95 and NT4.0) define more
5676 character sets. */
5677 #ifdef EASTEUROPE_CHARSET
5678 case EASTEUROPE_CHARSET: return "iso8859-2";
5679 case TURKISH_CHARSET: return "iso8859-9";
5680 case BALTIC_CHARSET: return "iso8859-4";
5682 /* W95 with international support but not IE4 often has the
5683 KOI8-R codepage but not ISO8859-5. */
5684 case RUSSIAN_CHARSET:
5685 if (!IsValidCodePage(28595) && IsValidCodePage(20886))
5686 return "koi8-r";
5687 else
5688 return "iso8859-5";
5689 case ARABIC_CHARSET: return "iso8859-6";
5690 case GREEK_CHARSET: return "iso8859-7";
5691 case HEBREW_CHARSET: return "iso8859-8";
5692 case VIETNAMESE_CHARSET: return "viscii1.1-*";
5693 case THAI_CHARSET: return "tis620-*";
5694 case MAC_CHARSET: return "mac-*";
5695 case JOHAB_CHARSET: return "ksc5601.1992-*";
5697 #endif
5699 #ifdef UNICODE_CHARSET
5700 case UNICODE_CHARSET: return "iso10646-unicode";
5701 #endif
5703 /* Encode numerical value of unknown charset. */
5704 sprintf (buf, "*-#%u", fncharset);
5705 return buf;
5708 BOOL
5709 w32_to_x_font (lplogfont, lpxstr, len)
5710 LOGFONT * lplogfont;
5711 char * lpxstr;
5712 int len;
5714 char* fonttype;
5715 char *fontname;
5716 char height_pixels[8];
5717 char height_dpi[8];
5718 char width_pixels[8];
5719 char *fontname_dash;
5720 int display_resy = one_w32_display_info.resy;
5721 int display_resx = one_w32_display_info.resx;
5722 int bufsz;
5723 struct coding_system coding;
5725 if (!lpxstr) abort ();
5727 if (!lplogfont)
5728 return FALSE;
5730 if (lplogfont->lfOutPrecision == OUT_STRING_PRECIS)
5731 fonttype = "raster";
5732 else if (lplogfont->lfOutPrecision == OUT_STROKE_PRECIS)
5733 fonttype = "outline";
5734 else
5735 fonttype = "unknown";
5737 setup_coding_system (Fcheck_coding_system (Vw32_system_coding_system),
5738 &coding);
5739 coding.mode |= CODING_MODE_LAST_BLOCK;
5740 bufsz = decoding_buffer_size (&coding, LF_FACESIZE);
5742 fontname = alloca(sizeof(*fontname) * bufsz);
5743 decode_coding (&coding, lplogfont->lfFaceName, fontname,
5744 strlen(lplogfont->lfFaceName), bufsz - 1);
5745 *(fontname + coding.produced) = '\0';
5747 /* Replace dashes with underscores so the dashes are not
5748 misinterpreted. */
5749 fontname_dash = fontname;
5750 while (fontname_dash = strchr (fontname_dash, '-'))
5751 *fontname_dash = '_';
5753 if (lplogfont->lfHeight)
5755 sprintf (height_pixels, "%u", abs (lplogfont->lfHeight));
5756 sprintf (height_dpi, "%u",
5757 abs (lplogfont->lfHeight) * 720 / display_resy);
5759 else
5761 strcpy (height_pixels, "*");
5762 strcpy (height_dpi, "*");
5764 if (lplogfont->lfWidth)
5765 sprintf (width_pixels, "%u", lplogfont->lfWidth * 10);
5766 else
5767 strcpy (width_pixels, "*");
5769 _snprintf (lpxstr, len - 1,
5770 "-%s-%s-%s-%c-normal-normal-%s-%s-%d-%d-%c-%s-%s",
5771 fonttype, /* foundry */
5772 fontname, /* family */
5773 w32_to_x_weight (lplogfont->lfWeight), /* weight */
5774 lplogfont->lfItalic?'i':'r', /* slant */
5775 /* setwidth name */
5776 /* add style name */
5777 height_pixels, /* pixel size */
5778 height_dpi, /* point size */
5779 display_resx, /* resx */
5780 display_resy, /* resy */
5781 ((lplogfont->lfPitchAndFamily & 0x3) == VARIABLE_PITCH)
5782 ? 'p' : 'c', /* spacing */
5783 width_pixels, /* avg width */
5784 w32_to_x_charset (lplogfont->lfCharSet) /* charset registry
5785 and encoding*/
5788 lpxstr[len - 1] = 0; /* just to be sure */
5789 return (TRUE);
5792 BOOL
5793 x_to_w32_font (lpxstr, lplogfont)
5794 char * lpxstr;
5795 LOGFONT * lplogfont;
5797 struct coding_system coding;
5799 if (!lplogfont) return (FALSE);
5801 memset (lplogfont, 0, sizeof (*lplogfont));
5803 /* Set default value for each field. */
5804 #if 1
5805 lplogfont->lfOutPrecision = OUT_DEFAULT_PRECIS;
5806 lplogfont->lfClipPrecision = CLIP_DEFAULT_PRECIS;
5807 lplogfont->lfQuality = DEFAULT_QUALITY;
5808 #else
5809 /* go for maximum quality */
5810 lplogfont->lfOutPrecision = OUT_STROKE_PRECIS;
5811 lplogfont->lfClipPrecision = CLIP_STROKE_PRECIS;
5812 lplogfont->lfQuality = PROOF_QUALITY;
5813 #endif
5815 lplogfont->lfCharSet = DEFAULT_CHARSET;
5816 lplogfont->lfWeight = FW_DONTCARE;
5817 lplogfont->lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE;
5819 if (!lpxstr)
5820 return FALSE;
5822 /* Provide a simple escape mechanism for specifying Windows font names
5823 * directly -- if font spec does not beginning with '-', assume this
5824 * format:
5825 * "<font name>[:height in pixels[:width in pixels[:weight]]]"
5828 if (*lpxstr == '-')
5830 int fields, tem;
5831 char name[50], weight[20], slant, pitch, pixels[10], height[10],
5832 width[10], resy[10], remainder[20];
5833 char * encoding;
5834 int dpi = one_w32_display_info.height_in;
5836 fields = sscanf (lpxstr,
5837 "-%*[^-]-%49[^-]-%19[^-]-%c-%*[^-]-%*[^-]-%9[^-]-%9[^-]-%*[^-]-%9[^-]-%c-%9[^-]-%19s",
5838 name, weight, &slant, pixels, height, resy, &pitch, width, remainder);
5839 if (fields == EOF) return (FALSE);
5841 /* If wildcards cover more than one field, we don't know which
5842 field is which, so don't fill any in. */
5844 if (fields < 9)
5845 fields = 0;
5847 if (fields > 0 && name[0] != '*')
5849 int bufsize;
5850 unsigned char *buf;
5852 setup_coding_system
5853 (Fcheck_coding_system (Vw32_system_coding_system), &coding);
5854 bufsize = encoding_buffer_size (&coding, strlen (name));
5855 buf = (unsigned char *) alloca (bufsize);
5856 coding.mode |= CODING_MODE_LAST_BLOCK;
5857 encode_coding (&coding, name, buf, strlen (name), bufsize);
5858 if (coding.produced >= LF_FACESIZE)
5859 coding.produced = LF_FACESIZE - 1;
5860 buf[coding.produced] = 0;
5861 strcpy (lplogfont->lfFaceName, buf);
5863 else
5865 lplogfont->lfFaceName[0] = '\0';
5868 fields--;
5870 lplogfont->lfWeight = x_to_w32_weight ((fields > 0 ? weight : ""));
5872 fields--;
5874 if (!NILP (Vw32_enable_synthesized_fonts))
5875 lplogfont->lfItalic = (fields > 0 && slant == 'i');
5877 fields--;
5879 if (fields > 0 && pixels[0] != '*')
5880 lplogfont->lfHeight = atoi (pixels);
5882 fields--;
5883 fields--;
5884 if (fields > 0 && resy[0] != '*')
5886 tem = atoi (resy);
5887 if (tem > 0) dpi = tem;
5890 if (fields > -1 && lplogfont->lfHeight == 0 && height[0] != '*')
5891 lplogfont->lfHeight = atoi (height) * dpi / 720;
5893 if (fields > 0)
5894 lplogfont->lfPitchAndFamily =
5895 (fields > 0 && pitch == 'p') ? VARIABLE_PITCH : FIXED_PITCH;
5897 fields--;
5899 if (fields > 0 && width[0] != '*')
5900 lplogfont->lfWidth = atoi (width) / 10;
5902 fields--;
5904 /* Strip the trailing '-' if present. (it shouldn't be, as it
5905 fails the test against xlfd-tight-regexp in fontset.el). */
5907 int len = strlen (remainder);
5908 if (len > 0 && remainder[len-1] == '-')
5909 remainder[len-1] = 0;
5911 encoding = remainder;
5912 if (strncmp (encoding, "*-", 2) == 0)
5913 encoding += 2;
5914 lplogfont->lfCharSet = x_to_w32_charset (fields > 0 ? encoding : "");
5916 else
5918 int fields;
5919 char name[100], height[10], width[10], weight[20];
5921 fields = sscanf (lpxstr,
5922 "%99[^:]:%9[^:]:%9[^:]:%19s",
5923 name, height, width, weight);
5925 if (fields == EOF) return (FALSE);
5927 if (fields > 0)
5929 strncpy (lplogfont->lfFaceName,name, LF_FACESIZE);
5930 lplogfont->lfFaceName[LF_FACESIZE-1] = 0;
5932 else
5934 lplogfont->lfFaceName[0] = 0;
5937 fields--;
5939 if (fields > 0)
5940 lplogfont->lfHeight = atoi (height);
5942 fields--;
5944 if (fields > 0)
5945 lplogfont->lfWidth = atoi (width);
5947 fields--;
5949 lplogfont->lfWeight = x_to_w32_weight ((fields > 0 ? weight : ""));
5952 /* This makes TrueType fonts work better. */
5953 lplogfont->lfHeight = - abs (lplogfont->lfHeight);
5955 return (TRUE);
5958 /* Strip the pixel height and point height from the given xlfd, and
5959 return the pixel height. If no pixel height is specified, calculate
5960 one from the point height, or if that isn't defined either, return
5961 0 (which usually signifies a scalable font).
5963 int xlfd_strip_height (char *fontname)
5965 int pixel_height, point_height, dpi, field_number;
5966 char *read_from, *write_to;
5968 xassert (fontname);
5970 pixel_height = field_number = 0;
5971 write_to = NULL;
5973 /* Look for height fields. */
5974 for (read_from = fontname; *read_from; read_from++)
5976 if (*read_from == '-')
5978 field_number++;
5979 if (field_number == 7) /* Pixel height. */
5981 read_from++;
5982 write_to = read_from;
5984 /* Find end of field. */
5985 for (;*read_from && *read_from != '-'; read_from++)
5988 /* Split the fontname at end of field. */
5989 if (*read_from)
5991 *read_from = '\0';
5992 read_from++;
5994 pixel_height = atoi (write_to);
5995 /* Blank out field. */
5996 if (read_from > write_to)
5998 *write_to = '-';
5999 write_to++;
6001 /* If the pixel height field is at the end (partial xfld),
6002 return now. */
6003 else
6004 return pixel_height;
6006 /* If we got a pixel height, the point height can be
6007 ignored. Just blank it out and break now. */
6008 if (pixel_height)
6010 /* Find end of point size field. */
6011 for (; *read_from && *read_from != '-'; read_from++)
6014 if (*read_from)
6015 read_from++;
6017 /* Blank out the point size field. */
6018 if (read_from > write_to)
6020 *write_to = '-';
6021 write_to++;
6023 else
6024 return pixel_height;
6026 break;
6028 /* If the point height is already blank, break now. */
6029 if (*read_from == '-')
6031 read_from++;
6032 break;
6035 else if (field_number == 8)
6037 /* If we didn't get a pixel height, try to get the point
6038 height and convert that. */
6039 int point_size;
6040 char *point_size_start = read_from++;
6042 /* Find end of field. */
6043 for (; *read_from && *read_from != '-'; read_from++)
6046 if (*read_from)
6048 *read_from = '\0';
6049 read_from++;
6052 point_size = atoi (point_size_start);
6054 /* Convert to pixel height. */
6055 pixel_height = point_size
6056 * one_w32_display_info.height_in / 720;
6058 /* Blank out this field and break. */
6059 *write_to = '-';
6060 write_to++;
6061 break;
6066 /* Shift the rest of the font spec into place. */
6067 if (write_to && read_from > write_to)
6069 for (; *read_from; read_from++, write_to++)
6070 *write_to = *read_from;
6071 *write_to = '\0';
6074 return pixel_height;
6077 /* Assume parameter 1 is fully qualified, no wildcards. */
6078 BOOL
6079 w32_font_match (fontname, pattern)
6080 char * fontname;
6081 char * pattern;
6083 char *regex = alloca (strlen (pattern) * 2);
6084 char *font_name_copy = alloca (strlen (fontname) + 1);
6085 char *ptr;
6087 /* Copy fontname so we can modify it during comparison. */
6088 strcpy (font_name_copy, fontname);
6090 ptr = regex;
6091 *ptr++ = '^';
6093 /* Turn pattern into a regexp and do a regexp match. */
6094 for (; *pattern; pattern++)
6096 if (*pattern == '?')
6097 *ptr++ = '.';
6098 else if (*pattern == '*')
6100 *ptr++ = '.';
6101 *ptr++ = '*';
6103 else
6104 *ptr++ = *pattern;
6106 *ptr = '$';
6107 *(ptr + 1) = '\0';
6109 /* Strip out font heights and compare them seperately, since
6110 rounding error can cause mismatches. This also allows a
6111 comparison between a font that declares only a pixel height and a
6112 pattern that declares the point height.
6115 int font_height, pattern_height;
6117 font_height = xlfd_strip_height (font_name_copy);
6118 pattern_height = xlfd_strip_height (regex);
6120 /* Compare now, and don't bother doing expensive regexp matching
6121 if the heights differ. */
6122 if (font_height && pattern_height && (font_height != pattern_height))
6123 return FALSE;
6126 return (fast_c_string_match_ignore_case (build_string (regex),
6127 font_name_copy) >= 0);
6130 /* Callback functions, and a structure holding info they need, for
6131 listing system fonts on W32. We need one set of functions to do the
6132 job properly, but these don't work on NT 3.51 and earlier, so we
6133 have a second set which don't handle character sets properly to
6134 fall back on.
6136 In both cases, there are two passes made. The first pass gets one
6137 font from each family, the second pass lists all the fonts from
6138 each family. */
6140 typedef struct enumfont_t
6142 HDC hdc;
6143 int numFonts;
6144 LOGFONT logfont;
6145 XFontStruct *size_ref;
6146 Lisp_Object *pattern;
6147 Lisp_Object *tail;
6148 } enumfont_t;
6150 int CALLBACK
6151 enum_font_cb2 (lplf, lptm, FontType, lpef)
6152 ENUMLOGFONT * lplf;
6153 NEWTEXTMETRIC * lptm;
6154 int FontType;
6155 enumfont_t * lpef;
6157 if (lplf->elfLogFont.lfStrikeOut || lplf->elfLogFont.lfUnderline)
6158 return (1);
6160 /* Check that the character set matches if it was specified */
6161 if (lpef->logfont.lfCharSet != DEFAULT_CHARSET &&
6162 lplf->elfLogFont.lfCharSet != lpef->logfont.lfCharSet)
6163 return (1);
6166 char buf[100];
6167 Lisp_Object width = Qnil;
6169 /* Truetype fonts do not report their true metrics until loaded */
6170 if (FontType != RASTER_FONTTYPE)
6172 if (!NILP (*(lpef->pattern)))
6174 /* Scalable fonts are as big as you want them to be. */
6175 lplf->elfLogFont.lfHeight = lpef->logfont.lfHeight;
6176 lplf->elfLogFont.lfWidth = lpef->logfont.lfWidth;
6177 width = make_number (lpef->logfont.lfWidth);
6179 else
6181 lplf->elfLogFont.lfHeight = 0;
6182 lplf->elfLogFont.lfWidth = 0;
6186 /* Make sure the height used here is the same as everywhere
6187 else (ie character height, not cell height). */
6188 if (lplf->elfLogFont.lfHeight > 0)
6190 /* lptm can be trusted for RASTER fonts, but not scalable ones. */
6191 if (FontType == RASTER_FONTTYPE)
6192 lplf->elfLogFont.lfHeight = lptm->tmInternalLeading - lptm->tmHeight;
6193 else
6194 lplf->elfLogFont.lfHeight = -lplf->elfLogFont.lfHeight;
6197 if (!w32_to_x_font (&(lplf->elfLogFont), buf, 100))
6198 return (0);
6200 if (NILP (*(lpef->pattern))
6201 || w32_font_match (buf, XSTRING (*(lpef->pattern))->data))
6203 *lpef->tail = Fcons (Fcons (build_string (buf), width), Qnil);
6204 lpef->tail = &(XCDR (*lpef->tail));
6205 lpef->numFonts++;
6209 return (1);
6212 int CALLBACK
6213 enum_font_cb1 (lplf, lptm, FontType, lpef)
6214 ENUMLOGFONT * lplf;
6215 NEWTEXTMETRIC * lptm;
6216 int FontType;
6217 enumfont_t * lpef;
6219 return EnumFontFamilies (lpef->hdc,
6220 lplf->elfLogFont.lfFaceName,
6221 (FONTENUMPROC) enum_font_cb2,
6222 (LPARAM) lpef);
6226 int CALLBACK
6227 enum_fontex_cb2 (lplf, lptm, font_type, lpef)
6228 ENUMLOGFONTEX * lplf;
6229 NEWTEXTMETRICEX * lptm;
6230 int font_type;
6231 enumfont_t * lpef;
6233 /* We are not interested in the extra info we get back from the 'Ex
6234 version - only the fact that we get character set variations
6235 enumerated seperately. */
6236 return enum_font_cb2 ((ENUMLOGFONT *) lplf, (NEWTEXTMETRIC *) lptm,
6237 font_type, lpef);
6240 int CALLBACK
6241 enum_fontex_cb1 (lplf, lptm, font_type, lpef)
6242 ENUMLOGFONTEX * lplf;
6243 NEWTEXTMETRICEX * lptm;
6244 int font_type;
6245 enumfont_t * lpef;
6247 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
6248 FARPROC enum_font_families_ex
6249 = GetProcAddress ( gdi32, "EnumFontFamiliesExA");
6250 /* We don't really expect EnumFontFamiliesEx to disappear once we
6251 get here, so don't bother handling it gracefully. */
6252 if (enum_font_families_ex == NULL)
6253 error ("gdi32.dll has disappeared!");
6254 return enum_font_families_ex (lpef->hdc,
6255 &lplf->elfLogFont,
6256 (FONTENUMPROC) enum_fontex_cb2,
6257 (LPARAM) lpef, 0);
6260 /* Interface to fontset handler. (adapted from mw32font.c in Meadow
6261 and xterm.c in Emacs 20.3) */
6263 Lisp_Object w32_list_bdf_fonts (Lisp_Object pattern, int max_names)
6265 char *fontname, *ptnstr;
6266 Lisp_Object list, tem, newlist = Qnil;
6267 int n_fonts = 0;
6269 list = Vw32_bdf_filename_alist;
6270 ptnstr = XSTRING (pattern)->data;
6272 for ( ; CONSP (list); list = XCDR (list))
6274 tem = XCAR (list);
6275 if (CONSP (tem))
6276 fontname = XSTRING (XCAR (tem))->data;
6277 else if (STRINGP (tem))
6278 fontname = XSTRING (tem)->data;
6279 else
6280 continue;
6282 if (w32_font_match (fontname, ptnstr))
6284 newlist = Fcons (XCAR (tem), newlist);
6285 n_fonts++;
6286 if (n_fonts >= max_names)
6287 break;
6291 return newlist;
6294 Lisp_Object w32_list_synthesized_fonts (FRAME_PTR f, Lisp_Object pattern,
6295 int size, int max_names);
6297 /* Return a list of names of available fonts matching PATTERN on frame
6298 F. If SIZE is not 0, it is the size (maximum bound width) of fonts
6299 to be listed. Frame F NULL means we have not yet created any
6300 frame, which means we can't get proper size info, as we don't have
6301 a device context to use for GetTextMetrics.
6302 MAXNAMES sets a limit on how many fonts to match. */
6304 Lisp_Object
6305 w32_list_fonts (FRAME_PTR f, Lisp_Object pattern, int size, int maxnames )
6307 Lisp_Object patterns, key = Qnil, tem, tpat;
6308 Lisp_Object list = Qnil, newlist = Qnil, second_best = Qnil;
6309 struct w32_display_info *dpyinfo = &one_w32_display_info;
6310 int n_fonts = 0;
6312 patterns = Fassoc (pattern, Valternate_fontname_alist);
6313 if (NILP (patterns))
6314 patterns = Fcons (pattern, Qnil);
6316 for (; CONSP (patterns); patterns = XCDR (patterns))
6318 enumfont_t ef;
6320 tpat = XCAR (patterns);
6322 /* See if we cached the result for this particular query.
6323 The cache is an alist of the form:
6324 ((PATTERN (FONTNAME . WIDTH) ...) ...)
6326 if (tem = XCDR (dpyinfo->name_list_element),
6327 !NILP (list = Fassoc (tpat, tem)))
6329 list = Fcdr_safe (list);
6330 /* We have a cached list. Don't have to get the list again. */
6331 goto label_cached;
6334 BLOCK_INPUT;
6335 /* At first, put PATTERN in the cache. */
6336 list = Qnil;
6337 ef.pattern = &tpat;
6338 ef.tail = &list;
6339 ef.numFonts = 0;
6341 /* Use EnumFontFamiliesEx where it is available, as it knows
6342 about character sets. Fall back to EnumFontFamilies for
6343 older versions of NT that don't support the 'Ex function. */
6344 x_to_w32_font (STRINGP (tpat) ? XSTRING (tpat)->data :
6345 NULL, &ef.logfont);
6347 LOGFONT font_match_pattern;
6348 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
6349 FARPROC enum_font_families_ex
6350 = GetProcAddress ( gdi32, "EnumFontFamiliesExA");
6352 /* We do our own pattern matching so we can handle wildcards. */
6353 font_match_pattern.lfFaceName[0] = 0;
6354 font_match_pattern.lfPitchAndFamily = 0;
6355 /* We can use the charset, because if it is a wildcard it will
6356 be DEFAULT_CHARSET anyway. */
6357 font_match_pattern.lfCharSet = ef.logfont.lfCharSet;
6359 ef.hdc = GetDC (dpyinfo->root_window);
6361 if (enum_font_families_ex)
6362 enum_font_families_ex (ef.hdc,
6363 &font_match_pattern,
6364 (FONTENUMPROC) enum_fontex_cb1,
6365 (LPARAM) &ef, 0);
6366 else
6367 EnumFontFamilies (ef.hdc, NULL, (FONTENUMPROC) enum_font_cb1,
6368 (LPARAM)&ef);
6370 ReleaseDC (dpyinfo->root_window, ef.hdc);
6373 UNBLOCK_INPUT;
6375 /* Make a list of the fonts we got back.
6376 Store that in the font cache for the display. */
6377 XCDR (dpyinfo->name_list_element)
6378 = Fcons (Fcons (tpat, list),
6379 XCDR (dpyinfo->name_list_element));
6381 label_cached:
6382 if (NILP (list)) continue; /* Try the remaining alternatives. */
6384 newlist = second_best = Qnil;
6386 /* Make a list of the fonts that have the right width. */
6387 for (; CONSP (list); list = XCDR (list))
6389 int found_size;
6390 tem = XCAR (list);
6392 if (!CONSP (tem))
6393 continue;
6394 if (NILP (XCAR (tem)))
6395 continue;
6396 if (!size)
6398 newlist = Fcons (XCAR (tem), newlist);
6399 n_fonts++;
6400 if (n_fonts >= maxnames)
6401 break;
6402 else
6403 continue;
6405 if (!INTEGERP (XCDR (tem)))
6407 /* Since we don't yet know the size of the font, we must
6408 load it and try GetTextMetrics. */
6409 W32FontStruct thisinfo;
6410 LOGFONT lf;
6411 HDC hdc;
6412 HANDLE oldobj;
6414 if (!x_to_w32_font (XSTRING (XCAR (tem))->data, &lf))
6415 continue;
6417 BLOCK_INPUT;
6418 thisinfo.bdf = NULL;
6419 thisinfo.hfont = CreateFontIndirect (&lf);
6420 if (thisinfo.hfont == NULL)
6421 continue;
6423 hdc = GetDC (dpyinfo->root_window);
6424 oldobj = SelectObject (hdc, thisinfo.hfont);
6425 if (GetTextMetrics (hdc, &thisinfo.tm))
6426 XCDR (tem) = make_number (FONT_WIDTH (&thisinfo));
6427 else
6428 XCDR (tem) = make_number (0);
6429 SelectObject (hdc, oldobj);
6430 ReleaseDC (dpyinfo->root_window, hdc);
6431 DeleteObject(thisinfo.hfont);
6432 UNBLOCK_INPUT;
6434 found_size = XINT (XCDR (tem));
6435 if (found_size == size)
6437 newlist = Fcons (XCAR (tem), newlist);
6438 n_fonts++;
6439 if (n_fonts >= maxnames)
6440 break;
6442 /* keep track of the closest matching size in case
6443 no exact match is found. */
6444 else if (found_size > 0)
6446 if (NILP (second_best))
6447 second_best = tem;
6449 else if (found_size < size)
6451 if (XINT (XCDR (second_best)) > size
6452 || XINT (XCDR (second_best)) < found_size)
6453 second_best = tem;
6455 else
6457 if (XINT (XCDR (second_best)) > size
6458 && XINT (XCDR (second_best)) >
6459 found_size)
6460 second_best = tem;
6465 if (!NILP (newlist))
6466 break;
6467 else if (!NILP (second_best))
6469 newlist = Fcons (XCAR (second_best), Qnil);
6470 break;
6474 /* Include any bdf fonts. */
6475 if (n_fonts < maxnames)
6477 Lisp_Object combined[2];
6478 combined[0] = w32_list_bdf_fonts (pattern, maxnames - n_fonts);
6479 combined[1] = newlist;
6480 newlist = Fnconc(2, combined);
6483 /* If we can't find a font that matches, check if Windows would be
6484 able to synthesize it from a different style. */
6485 if (NILP (newlist) && !NILP (Vw32_enable_synthesized_fonts))
6486 newlist = w32_list_synthesized_fonts (f, pattern, size, maxnames);
6488 return newlist;
6491 Lisp_Object
6492 w32_list_synthesized_fonts (f, pattern, size, max_names)
6493 FRAME_PTR f;
6494 Lisp_Object pattern;
6495 int size;
6496 int max_names;
6498 int fields;
6499 char *full_pattn, *new_pattn, foundary[50], family[50], *pattn_part2;
6500 char style[20], slant;
6501 Lisp_Object matches, match, tem, synthed_matches = Qnil;
6503 full_pattn = XSTRING (pattern)->data;
6505 pattn_part2 = alloca (XSTRING (pattern)->size);
6506 /* Allow some space for wildcard expansion. */
6507 new_pattn = alloca (XSTRING (pattern)->size + 100);
6509 fields = sscanf (full_pattn, "-%49[^-]-%49[^-]-%19[^-]-%c-%s",
6510 foundary, family, style, &slant, pattn_part2);
6511 if (fields == EOF || fields < 5)
6512 return Qnil;
6514 /* If the style and slant are wildcards already there is no point
6515 checking again (and we don't want to keep recursing). */
6516 if (*style == '*' && slant == '*')
6517 return Qnil;
6519 sprintf (new_pattn, "-%s-%s-*-*-%s", foundary, family, pattn_part2);
6521 matches = w32_list_fonts (f, build_string (new_pattn), size, max_names);
6523 for ( ; CONSP (matches); matches = XCDR (matches))
6525 tem = XCAR (matches);
6526 if (!STRINGP (tem))
6527 continue;
6529 full_pattn = XSTRING (tem)->data;
6530 fields = sscanf (full_pattn, "-%49[^-]-%49[^-]-%*[^-]-%*c-%s",
6531 foundary, family, pattn_part2);
6532 if (fields == EOF || fields < 3)
6533 continue;
6535 sprintf (new_pattn, "-%s-%s-%s-%c-%s", foundary, family, style,
6536 slant, pattn_part2);
6538 synthed_matches = Fcons (build_string (new_pattn),
6539 synthed_matches);
6542 return synthed_matches;
6546 /* Return a pointer to struct font_info of font FONT_IDX of frame F. */
6547 struct font_info *
6548 w32_get_font_info (f, font_idx)
6549 FRAME_PTR f;
6550 int font_idx;
6552 return (FRAME_W32_FONT_TABLE (f) + font_idx);
6556 struct font_info*
6557 w32_query_font (struct frame *f, char *fontname)
6559 int i;
6560 struct font_info *pfi;
6562 pfi = FRAME_W32_FONT_TABLE (f);
6564 for (i = 0; i < one_w32_display_info.n_fonts ;i++, pfi++)
6566 if (strcmp(pfi->name, fontname) == 0) return pfi;
6569 return NULL;
6572 /* Find a CCL program for a font specified by FONTP, and set the member
6573 `encoder' of the structure. */
6575 void
6576 w32_find_ccl_program (fontp)
6577 struct font_info *fontp;
6579 Lisp_Object list, elt;
6581 for (list = Vfont_ccl_encoder_alist; CONSP (list); list = XCDR (list))
6583 elt = XCAR (list);
6584 if (CONSP (elt)
6585 && STRINGP (XCAR (elt))
6586 && (fast_c_string_match_ignore_case (XCAR (elt), fontp->name)
6587 >= 0))
6588 break;
6590 if (! NILP (list))
6592 struct ccl_program *ccl
6593 = (struct ccl_program *) xmalloc (sizeof (struct ccl_program));
6595 if (setup_ccl_program (ccl, XCDR (elt)) < 0)
6596 xfree (ccl);
6597 else
6598 fontp->font_encoder = ccl;
6603 DEFUN ("w32-find-bdf-fonts", Fw32_find_bdf_fonts, Sw32_find_bdf_fonts,
6604 1, 1, 0,
6605 "Return a list of BDF fonts in DIR, suitable for appending to\n\
6606 w32-bdf-filename-alist. Fonts which do not contain an xfld description\n\
6607 will not be included in the list. DIR may be a list of directories.")
6608 (directory)
6609 Lisp_Object directory;
6611 Lisp_Object list = Qnil;
6612 struct gcpro gcpro1, gcpro2;
6614 if (!CONSP (directory))
6615 return w32_find_bdf_fonts_in_dir (directory);
6617 for ( ; CONSP (directory); directory = XCDR (directory))
6619 Lisp_Object pair[2];
6620 pair[0] = list;
6621 pair[1] = Qnil;
6622 GCPRO2 (directory, list);
6623 pair[1] = w32_find_bdf_fonts_in_dir( XCAR (directory) );
6624 list = Fnconc( 2, pair );
6625 UNGCPRO;
6627 return list;
6630 /* Find BDF files in a specified directory. (use GCPRO when calling,
6631 as this calls lisp to get a directory listing). */
6632 Lisp_Object w32_find_bdf_fonts_in_dir( Lisp_Object directory )
6634 Lisp_Object filelist, list = Qnil;
6635 char fontname[100];
6637 if (!STRINGP(directory))
6638 return Qnil;
6640 filelist = Fdirectory_files (directory, Qt,
6641 build_string (".*\\.[bB][dD][fF]"), Qt);
6643 for ( ; CONSP(filelist); filelist = XCDR (filelist))
6645 Lisp_Object filename = XCAR (filelist);
6646 if (w32_BDF_to_x_font (XSTRING (filename)->data, fontname, 100))
6647 store_in_alist (&list, build_string (fontname), filename);
6649 return list;
6653 DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0,
6654 "Return non-nil if color COLOR is supported on frame FRAME.\n\
6655 If FRAME is omitted or nil, use the selected frame.")
6656 (color, frame)
6657 Lisp_Object color, frame;
6659 XColor foo;
6660 FRAME_PTR f = check_x_frame (frame);
6662 CHECK_STRING (color, 1);
6664 if (w32_defined_color (f, XSTRING (color)->data, &foo, 0))
6665 return Qt;
6666 else
6667 return Qnil;
6670 DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0,
6671 "Return a description of the color named COLOR on frame FRAME.\n\
6672 The value is a list of integer RGB values--(RED GREEN BLUE).\n\
6673 These values appear to range from 0 to 65280 or 65535, depending\n\
6674 on the system; white is (65280 65280 65280) or (65535 65535 65535).\n\
6675 If FRAME is omitted or nil, use the selected frame.")
6676 (color, frame)
6677 Lisp_Object color, frame;
6679 XColor foo;
6680 FRAME_PTR f = check_x_frame (frame);
6682 CHECK_STRING (color, 1);
6684 if (w32_defined_color (f, XSTRING (color)->data, &foo, 0))
6686 Lisp_Object rgb[3];
6688 rgb[0] = make_number ((GetRValue (foo.pixel) << 8)
6689 | GetRValue (foo.pixel));
6690 rgb[1] = make_number ((GetGValue (foo.pixel) << 8)
6691 | GetGValue (foo.pixel));
6692 rgb[2] = make_number ((GetBValue (foo.pixel) << 8)
6693 | GetBValue (foo.pixel));
6694 return Flist (3, rgb);
6696 else
6697 return Qnil;
6700 DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0,
6701 "Return t if the X display supports color.\n\
6702 The optional argument DISPLAY specifies which display to ask about.\n\
6703 DISPLAY should be either a frame or a display name (a string).\n\
6704 If omitted or nil, that stands for the selected frame's display.")
6705 (display)
6706 Lisp_Object display;
6708 struct w32_display_info *dpyinfo = check_x_display_info (display);
6710 if ((dpyinfo->n_planes * dpyinfo->n_cbits) <= 2)
6711 return Qnil;
6713 return Qt;
6716 DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p,
6717 0, 1, 0,
6718 "Return t if the X display supports shades of gray.\n\
6719 Note that color displays do support shades of gray.\n\
6720 The optional argument DISPLAY specifies which display to ask about.\n\
6721 DISPLAY should be either a frame or a display name (a string).\n\
6722 If omitted or nil, that stands for the selected frame's display.")
6723 (display)
6724 Lisp_Object display;
6726 struct w32_display_info *dpyinfo = check_x_display_info (display);
6728 if ((dpyinfo->n_planes * dpyinfo->n_cbits) <= 1)
6729 return Qnil;
6731 return Qt;
6734 DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width,
6735 0, 1, 0,
6736 "Returns the width in pixels of the X display DISPLAY.\n\
6737 The optional argument DISPLAY specifies which display to ask about.\n\
6738 DISPLAY should be either a frame or a display name (a string).\n\
6739 If omitted or nil, that stands for the selected frame's display.")
6740 (display)
6741 Lisp_Object display;
6743 struct w32_display_info *dpyinfo = check_x_display_info (display);
6745 return make_number (dpyinfo->width);
6748 DEFUN ("x-display-pixel-height", Fx_display_pixel_height,
6749 Sx_display_pixel_height, 0, 1, 0,
6750 "Returns the height in pixels of the X display DISPLAY.\n\
6751 The optional argument DISPLAY specifies which display to ask about.\n\
6752 DISPLAY should be either a frame or a display name (a string).\n\
6753 If omitted or nil, that stands for the selected frame's display.")
6754 (display)
6755 Lisp_Object display;
6757 struct w32_display_info *dpyinfo = check_x_display_info (display);
6759 return make_number (dpyinfo->height);
6762 DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes,
6763 0, 1, 0,
6764 "Returns the number of bitplanes of the display DISPLAY.\n\
6765 The optional argument DISPLAY specifies which display to ask about.\n\
6766 DISPLAY should be either a frame or a display name (a string).\n\
6767 If omitted or nil, that stands for the selected frame's display.")
6768 (display)
6769 Lisp_Object display;
6771 struct w32_display_info *dpyinfo = check_x_display_info (display);
6773 return make_number (dpyinfo->n_planes * dpyinfo->n_cbits);
6776 DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells,
6777 0, 1, 0,
6778 "Returns the number of color cells of the display DISPLAY.\n\
6779 The optional argument DISPLAY specifies which display to ask about.\n\
6780 DISPLAY should be either a frame or a display name (a string).\n\
6781 If omitted or nil, that stands for the selected frame's display.")
6782 (display)
6783 Lisp_Object display;
6785 struct w32_display_info *dpyinfo = check_x_display_info (display);
6786 HDC hdc;
6787 int cap;
6789 hdc = GetDC (dpyinfo->root_window);
6790 if (dpyinfo->has_palette)
6791 cap = GetDeviceCaps (hdc,SIZEPALETTE);
6792 else
6793 cap = GetDeviceCaps (hdc,NUMCOLORS);
6795 ReleaseDC (dpyinfo->root_window, hdc);
6797 return make_number (cap);
6800 DEFUN ("x-server-max-request-size", Fx_server_max_request_size,
6801 Sx_server_max_request_size,
6802 0, 1, 0,
6803 "Returns the maximum request size of the server of display DISPLAY.\n\
6804 The optional argument DISPLAY specifies which display to ask about.\n\
6805 DISPLAY should be either a frame or a display name (a string).\n\
6806 If omitted or nil, that stands for the selected frame's display.")
6807 (display)
6808 Lisp_Object display;
6810 struct w32_display_info *dpyinfo = check_x_display_info (display);
6812 return make_number (1);
6815 DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
6816 "Returns the vendor ID string of the W32 system (Microsoft).\n\
6817 The optional argument DISPLAY specifies which display to ask about.\n\
6818 DISPLAY should be either a frame or a display name (a string).\n\
6819 If omitted or nil, that stands for the selected frame's display.")
6820 (display)
6821 Lisp_Object display;
6823 struct w32_display_info *dpyinfo = check_x_display_info (display);
6824 char *vendor = "Microsoft Corp.";
6826 if (! vendor) vendor = "";
6827 return build_string (vendor);
6830 DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0,
6831 "Returns the version numbers of the server of display DISPLAY.\n\
6832 The value is a list of three integers: the major and minor\n\
6833 version numbers, and the vendor-specific release\n\
6834 number. See also the function `x-server-vendor'.\n\n\
6835 The optional argument DISPLAY specifies which display to ask about.\n\
6836 DISPLAY should be either a frame or a display name (a string).\n\
6837 If omitted or nil, that stands for the selected frame's display.")
6838 (display)
6839 Lisp_Object display;
6841 struct w32_display_info *dpyinfo = check_x_display_info (display);
6843 return Fcons (make_number (w32_major_version),
6844 Fcons (make_number (w32_minor_version), Qnil));
6847 DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0,
6848 "Returns the number of screens on the server of display DISPLAY.\n\
6849 The optional argument DISPLAY specifies which display to ask about.\n\
6850 DISPLAY should be either a frame or a display name (a string).\n\
6851 If omitted or nil, that stands for the selected frame's display.")
6852 (display)
6853 Lisp_Object display;
6855 struct w32_display_info *dpyinfo = check_x_display_info (display);
6857 return make_number (1);
6860 DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0,
6861 "Returns the height in millimeters of the X display DISPLAY.\n\
6862 The optional argument DISPLAY specifies which display to ask about.\n\
6863 DISPLAY should be either a frame or a display name (a string).\n\
6864 If omitted or nil, that stands for the selected frame's display.")
6865 (display)
6866 Lisp_Object display;
6868 struct w32_display_info *dpyinfo = check_x_display_info (display);
6869 HDC hdc;
6870 int cap;
6872 hdc = GetDC (dpyinfo->root_window);
6874 cap = GetDeviceCaps (hdc, VERTSIZE);
6876 ReleaseDC (dpyinfo->root_window, hdc);
6878 return make_number (cap);
6881 DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0,
6882 "Returns the width in millimeters of the X display DISPLAY.\n\
6883 The optional argument DISPLAY specifies which display to ask about.\n\
6884 DISPLAY should be either a frame or a display name (a string).\n\
6885 If omitted or nil, that stands for the selected frame's display.")
6886 (display)
6887 Lisp_Object display;
6889 struct w32_display_info *dpyinfo = check_x_display_info (display);
6891 HDC hdc;
6892 int cap;
6894 hdc = GetDC (dpyinfo->root_window);
6896 cap = GetDeviceCaps (hdc, HORZSIZE);
6898 ReleaseDC (dpyinfo->root_window, hdc);
6900 return make_number (cap);
6903 DEFUN ("x-display-backing-store", Fx_display_backing_store,
6904 Sx_display_backing_store, 0, 1, 0,
6905 "Returns an indication of whether display DISPLAY does backing store.\n\
6906 The value may be `always', `when-mapped', or `not-useful'.\n\
6907 The optional argument DISPLAY specifies which display to ask about.\n\
6908 DISPLAY should be either a frame or a display name (a string).\n\
6909 If omitted or nil, that stands for the selected frame's display.")
6910 (display)
6911 Lisp_Object display;
6913 return intern ("not-useful");
6916 DEFUN ("x-display-visual-class", Fx_display_visual_class,
6917 Sx_display_visual_class, 0, 1, 0,
6918 "Returns the visual class of the display DISPLAY.\n\
6919 The value is one of the symbols `static-gray', `gray-scale',\n\
6920 `static-color', `pseudo-color', `true-color', or `direct-color'.\n\n\
6921 The optional argument DISPLAY specifies which display to ask about.\n\
6922 DISPLAY should be either a frame or a display name (a string).\n\
6923 If omitted or nil, that stands for the selected frame's display.")
6924 (display)
6925 Lisp_Object display;
6927 struct w32_display_info *dpyinfo = check_x_display_info (display);
6929 #if 0
6930 switch (dpyinfo->visual->class)
6932 case StaticGray: return (intern ("static-gray"));
6933 case GrayScale: return (intern ("gray-scale"));
6934 case StaticColor: return (intern ("static-color"));
6935 case PseudoColor: return (intern ("pseudo-color"));
6936 case TrueColor: return (intern ("true-color"));
6937 case DirectColor: return (intern ("direct-color"));
6938 default:
6939 error ("Display has an unknown visual class");
6941 #endif
6943 error ("Display has an unknown visual class");
6946 DEFUN ("x-display-save-under", Fx_display_save_under,
6947 Sx_display_save_under, 0, 1, 0,
6948 "Returns t if the display DISPLAY supports the save-under feature.\n\
6949 The optional argument DISPLAY specifies which display to ask about.\n\
6950 DISPLAY should be either a frame or a display name (a string).\n\
6951 If omitted or nil, that stands for the selected frame's display.")
6952 (display)
6953 Lisp_Object display;
6955 struct w32_display_info *dpyinfo = check_x_display_info (display);
6957 return Qnil;
6961 x_pixel_width (f)
6962 register struct frame *f;
6964 return PIXEL_WIDTH (f);
6968 x_pixel_height (f)
6969 register struct frame *f;
6971 return PIXEL_HEIGHT (f);
6975 x_char_width (f)
6976 register struct frame *f;
6978 return FONT_WIDTH (f->output_data.w32->font);
6982 x_char_height (f)
6983 register struct frame *f;
6985 return f->output_data.w32->line_height;
6989 x_screen_planes (f)
6990 register struct frame *f;
6992 return FRAME_W32_DISPLAY_INFO (f)->n_planes;
6995 /* Return the display structure for the display named NAME.
6996 Open a new connection if necessary. */
6998 struct w32_display_info *
6999 x_display_info_for_name (name)
7000 Lisp_Object name;
7002 Lisp_Object names;
7003 struct w32_display_info *dpyinfo;
7005 CHECK_STRING (name, 0);
7007 for (dpyinfo = &one_w32_display_info, names = w32_display_name_list;
7008 dpyinfo;
7009 dpyinfo = dpyinfo->next, names = XCDR (names))
7011 Lisp_Object tem;
7012 tem = Fstring_equal (XCAR (XCAR (names)), name);
7013 if (!NILP (tem))
7014 return dpyinfo;
7017 /* Use this general default value to start with. */
7018 Vx_resource_name = Vinvocation_name;
7020 validate_x_resource_name ();
7022 dpyinfo = w32_term_init (name, (unsigned char *)0,
7023 (char *) XSTRING (Vx_resource_name)->data);
7025 if (dpyinfo == 0)
7026 error ("Cannot connect to server %s", XSTRING (name)->data);
7028 w32_in_use = 1;
7029 XSETFASTINT (Vwindow_system_version, 3);
7031 return dpyinfo;
7034 DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection,
7035 1, 3, 0, "Open a connection to a server.\n\
7036 DISPLAY is the name of the display to connect to.\n\
7037 Optional second arg XRM-STRING is a string of resources in xrdb format.\n\
7038 If the optional third arg MUST-SUCCEED is non-nil,\n\
7039 terminate Emacs if we can't open the connection.")
7040 (display, xrm_string, must_succeed)
7041 Lisp_Object display, xrm_string, must_succeed;
7043 unsigned char *xrm_option;
7044 struct w32_display_info *dpyinfo;
7046 CHECK_STRING (display, 0);
7047 if (! NILP (xrm_string))
7048 CHECK_STRING (xrm_string, 1);
7050 if (! EQ (Vwindow_system, intern ("w32")))
7051 error ("Not using Microsoft Windows");
7053 /* Allow color mapping to be defined externally; first look in user's
7054 HOME directory, then in Emacs etc dir for a file called rgb.txt. */
7056 Lisp_Object color_file;
7057 struct gcpro gcpro1;
7059 color_file = build_string("~/rgb.txt");
7061 GCPRO1 (color_file);
7063 if (NILP (Ffile_readable_p (color_file)))
7064 color_file =
7065 Fexpand_file_name (build_string ("rgb.txt"),
7066 Fsymbol_value (intern ("data-directory")));
7068 Vw32_color_map = Fw32_load_color_file (color_file);
7070 UNGCPRO;
7072 if (NILP (Vw32_color_map))
7073 Vw32_color_map = Fw32_default_color_map ();
7075 if (! NILP (xrm_string))
7076 xrm_option = (unsigned char *) XSTRING (xrm_string)->data;
7077 else
7078 xrm_option = (unsigned char *) 0;
7080 /* Use this general default value to start with. */
7081 /* First remove .exe suffix from invocation-name - it looks ugly. */
7083 char basename[ MAX_PATH ], *str;
7085 strcpy (basename, XSTRING (Vinvocation_name)->data);
7086 str = strrchr (basename, '.');
7087 if (str) *str = 0;
7088 Vinvocation_name = build_string (basename);
7090 Vx_resource_name = Vinvocation_name;
7092 validate_x_resource_name ();
7094 /* This is what opens the connection and sets x_current_display.
7095 This also initializes many symbols, such as those used for input. */
7096 dpyinfo = w32_term_init (display, xrm_option,
7097 (char *) XSTRING (Vx_resource_name)->data);
7099 if (dpyinfo == 0)
7101 if (!NILP (must_succeed))
7102 fatal ("Cannot connect to server %s.\n",
7103 XSTRING (display)->data);
7104 else
7105 error ("Cannot connect to server %s", XSTRING (display)->data);
7108 w32_in_use = 1;
7110 XSETFASTINT (Vwindow_system_version, 3);
7111 return Qnil;
7114 DEFUN ("x-close-connection", Fx_close_connection,
7115 Sx_close_connection, 1, 1, 0,
7116 "Close the connection to DISPLAY's server.\n\
7117 For DISPLAY, specify either a frame or a display name (a string).\n\
7118 If DISPLAY is nil, that stands for the selected frame's display.")
7119 (display)
7120 Lisp_Object display;
7122 struct w32_display_info *dpyinfo = check_x_display_info (display);
7123 int i;
7125 if (dpyinfo->reference_count > 0)
7126 error ("Display still has frames on it");
7128 BLOCK_INPUT;
7129 /* Free the fonts in the font table. */
7130 for (i = 0; i < dpyinfo->n_fonts; i++)
7131 if (dpyinfo->font_table[i].name)
7133 if (dpyinfo->font_table[i].name != dpyinfo->font_table[i].full_name)
7134 xfree (dpyinfo->font_table[i].full_name);
7135 xfree (dpyinfo->font_table[i].name);
7136 w32_unload_font (dpyinfo, dpyinfo->font_table[i].font);
7138 x_destroy_all_bitmaps (dpyinfo);
7140 x_delete_display (dpyinfo);
7141 UNBLOCK_INPUT;
7143 return Qnil;
7146 DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0,
7147 "Return the list of display names that Emacs has connections to.")
7150 Lisp_Object tail, result;
7152 result = Qnil;
7153 for (tail = w32_display_name_list; ! NILP (tail); tail = XCDR (tail))
7154 result = Fcons (XCAR (XCAR (tail)), result);
7156 return result;
7159 DEFUN ("x-synchronize", Fx_synchronize, Sx_synchronize, 1, 2, 0,
7160 "If ON is non-nil, report errors as soon as the erring request is made.\n\
7161 If ON is nil, allow buffering of requests.\n\
7162 This is a noop on W32 systems.\n\
7163 The optional second argument DISPLAY specifies which display to act on.\n\
7164 DISPLAY should be either a frame or a display name (a string).\n\
7165 If DISPLAY is omitted or nil, that stands for the selected frame's display.")
7166 (on, display)
7167 Lisp_Object display, on;
7169 struct w32_display_info *dpyinfo = check_x_display_info (display);
7171 return Qnil;
7176 /***********************************************************************
7177 Image types
7178 ***********************************************************************/
7180 /* Value is the number of elements of vector VECTOR. */
7182 #define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR))
7184 /* List of supported image types. Use define_image_type to add new
7185 types. Use lookup_image_type to find a type for a given symbol. */
7187 static struct image_type *image_types;
7189 /* A list of symbols, one for each supported image type. */
7191 Lisp_Object Vimage_types;
7193 /* The symbol `image' which is the car of the lists used to represent
7194 images in Lisp. */
7196 extern Lisp_Object Qimage;
7198 /* The symbol `xbm' which is used as the type symbol for XBM images. */
7200 Lisp_Object Qxbm;
7202 /* Keywords. */
7204 Lisp_Object QCtype, QCascent, QCmargin, QCrelief;
7205 extern Lisp_Object QCwidth, QCheight, QCforeground, QCbackground, QCfile;
7206 Lisp_Object QCalgorithm, QCcolor_symbols, QCheuristic_mask;
7207 extern Lisp_Object QCindex;
7209 /* Other symbols. */
7211 Lisp_Object Qlaplace;
7213 /* Time in seconds after which images should be removed from the cache
7214 if not displayed. */
7216 Lisp_Object Vimage_cache_eviction_delay;
7218 /* Function prototypes. */
7220 static void define_image_type P_ ((struct image_type *type));
7221 static struct image_type *lookup_image_type P_ ((Lisp_Object symbol));
7222 static void image_error P_ ((char *format, Lisp_Object, Lisp_Object));
7223 static void x_laplace P_ ((struct frame *, struct image *));
7224 static int x_build_heuristic_mask P_ ((struct frame *, struct image *,
7225 Lisp_Object));
7227 /* Define a new image type from TYPE. This adds a copy of TYPE to
7228 image_types and adds the symbol *TYPE->type to Vimage_types. */
7230 static void
7231 define_image_type (type)
7232 struct image_type *type;
7234 /* Make a copy of TYPE to avoid a bus error in a dumped Emacs.
7235 The initialized data segment is read-only. */
7236 struct image_type *p = (struct image_type *) xmalloc (sizeof *p);
7237 bcopy (type, p, sizeof *p);
7238 p->next = image_types;
7239 image_types = p;
7240 Vimage_types = Fcons (*p->type, Vimage_types);
7244 /* Look up image type SYMBOL, and return a pointer to its image_type
7245 structure. Value is null if SYMBOL is not a known image type. */
7247 static INLINE struct image_type *
7248 lookup_image_type (symbol)
7249 Lisp_Object symbol;
7251 struct image_type *type;
7253 for (type = image_types; type; type = type->next)
7254 if (EQ (symbol, *type->type))
7255 break;
7257 return type;
7261 /* Value is non-zero if OBJECT is a valid Lisp image specification. A
7262 valid image specification is a list whose car is the symbol
7263 `image', and whose rest is a property list. The property list must
7264 contain a value for key `:type'. That value must be the name of a
7265 supported image type. The rest of the property list depends on the
7266 image type. */
7269 valid_image_p (object)
7270 Lisp_Object object;
7272 int valid_p = 0;
7274 if (CONSP (object) && EQ (XCAR (object), Qimage))
7276 Lisp_Object symbol = Fplist_get (XCDR (object), QCtype);
7277 struct image_type *type = lookup_image_type (symbol);
7279 if (type)
7280 valid_p = type->valid_p (object);
7283 return valid_p;
7287 /* Log error message with format string FORMAT and argument ARG.
7288 Signaling an error, e.g. when an image cannot be loaded, is not a
7289 good idea because this would interrupt redisplay, and the error
7290 message display would lead to another redisplay. This function
7291 therefore simply displays a message. */
7293 static void
7294 image_error (format, arg1, arg2)
7295 char *format;
7296 Lisp_Object arg1, arg2;
7298 add_to_log (format, arg1, arg2);
7303 /***********************************************************************
7304 Image specifications
7305 ***********************************************************************/
7307 enum image_value_type
7309 IMAGE_DONT_CHECK_VALUE_TYPE,
7310 IMAGE_STRING_VALUE,
7311 IMAGE_SYMBOL_VALUE,
7312 IMAGE_POSITIVE_INTEGER_VALUE,
7313 IMAGE_NON_NEGATIVE_INTEGER_VALUE,
7314 IMAGE_INTEGER_VALUE,
7315 IMAGE_FUNCTION_VALUE,
7316 IMAGE_NUMBER_VALUE,
7317 IMAGE_BOOL_VALUE
7320 /* Structure used when parsing image specifications. */
7322 struct image_keyword
7324 /* Name of keyword. */
7325 char *name;
7327 /* The type of value allowed. */
7328 enum image_value_type type;
7330 /* Non-zero means key must be present. */
7331 int mandatory_p;
7333 /* Used to recognize duplicate keywords in a property list. */
7334 int count;
7336 /* The value that was found. */
7337 Lisp_Object value;
7341 static int parse_image_spec P_ ((Lisp_Object, struct image_keyword *,
7342 int, Lisp_Object));
7343 static Lisp_Object image_spec_value P_ ((Lisp_Object, Lisp_Object, int *));
7346 /* Parse image spec SPEC according to KEYWORDS. A valid image spec
7347 has the format (image KEYWORD VALUE ...). One of the keyword/
7348 value pairs must be `:type TYPE'. KEYWORDS is a vector of
7349 image_keywords structures of size NKEYWORDS describing other
7350 allowed keyword/value pairs. Value is non-zero if SPEC is valid. */
7352 static int
7353 parse_image_spec (spec, keywords, nkeywords, type)
7354 Lisp_Object spec;
7355 struct image_keyword *keywords;
7356 int nkeywords;
7357 Lisp_Object type;
7359 int i;
7360 Lisp_Object plist;
7362 if (!CONSP (spec) || !EQ (XCAR (spec), Qimage))
7363 return 0;
7365 plist = XCDR (spec);
7366 while (CONSP (plist))
7368 Lisp_Object key, value;
7370 /* First element of a pair must be a symbol. */
7371 key = XCAR (plist);
7372 plist = XCDR (plist);
7373 if (!SYMBOLP (key))
7374 return 0;
7376 /* There must follow a value. */
7377 if (!CONSP (plist))
7378 return 0;
7379 value = XCAR (plist);
7380 plist = XCDR (plist);
7382 /* Find key in KEYWORDS. Error if not found. */
7383 for (i = 0; i < nkeywords; ++i)
7384 if (strcmp (keywords[i].name, XSYMBOL (key)->name->data) == 0)
7385 break;
7387 if (i == nkeywords)
7388 continue;
7390 /* Record that we recognized the keyword. If a keywords
7391 was found more than once, it's an error. */
7392 keywords[i].value = value;
7393 ++keywords[i].count;
7395 if (keywords[i].count > 1)
7396 return 0;
7398 /* Check type of value against allowed type. */
7399 switch (keywords[i].type)
7401 case IMAGE_STRING_VALUE:
7402 if (!STRINGP (value))
7403 return 0;
7404 break;
7406 case IMAGE_SYMBOL_VALUE:
7407 if (!SYMBOLP (value))
7408 return 0;
7409 break;
7411 case IMAGE_POSITIVE_INTEGER_VALUE:
7412 if (!INTEGERP (value) || XINT (value) <= 0)
7413 return 0;
7414 break;
7416 case IMAGE_NON_NEGATIVE_INTEGER_VALUE:
7417 if (!INTEGERP (value) || XINT (value) < 0)
7418 return 0;
7419 break;
7421 case IMAGE_DONT_CHECK_VALUE_TYPE:
7422 break;
7424 case IMAGE_FUNCTION_VALUE:
7425 value = indirect_function (value);
7426 if (SUBRP (value)
7427 || COMPILEDP (value)
7428 || (CONSP (value) && EQ (XCAR (value), Qlambda)))
7429 break;
7430 return 0;
7432 case IMAGE_NUMBER_VALUE:
7433 if (!INTEGERP (value) && !FLOATP (value))
7434 return 0;
7435 break;
7437 case IMAGE_INTEGER_VALUE:
7438 if (!INTEGERP (value))
7439 return 0;
7440 break;
7442 case IMAGE_BOOL_VALUE:
7443 if (!NILP (value) && !EQ (value, Qt))
7444 return 0;
7445 break;
7447 default:
7448 abort ();
7449 break;
7452 if (EQ (key, QCtype) && !EQ (type, value))
7453 return 0;
7456 /* Check that all mandatory fields are present. */
7457 for (i = 0; i < nkeywords; ++i)
7458 if (keywords[i].mandatory_p && keywords[i].count == 0)
7459 return 0;
7461 return NILP (plist);
7465 /* Return the value of KEY in image specification SPEC. Value is nil
7466 if KEY is not present in SPEC. if FOUND is not null, set *FOUND
7467 to 1 if KEY was found in SPEC, set it to 0 otherwise. */
7469 static Lisp_Object
7470 image_spec_value (spec, key, found)
7471 Lisp_Object spec, key;
7472 int *found;
7474 Lisp_Object tail;
7476 xassert (valid_image_p (spec));
7478 for (tail = XCDR (spec);
7479 CONSP (tail) && CONSP (XCDR (tail));
7480 tail = XCDR (XCDR (tail)))
7482 if (EQ (XCAR (tail), key))
7484 if (found)
7485 *found = 1;
7486 return XCAR (XCDR (tail));
7490 if (found)
7491 *found = 0;
7492 return Qnil;
7498 /***********************************************************************
7499 Image type independent image structures
7500 ***********************************************************************/
7502 static struct image *make_image P_ ((Lisp_Object spec, unsigned hash));
7503 static void free_image P_ ((struct frame *f, struct image *img));
7506 /* Allocate and return a new image structure for image specification
7507 SPEC. SPEC has a hash value of HASH. */
7509 static struct image *
7510 make_image (spec, hash)
7511 Lisp_Object spec;
7512 unsigned hash;
7514 struct image *img = (struct image *) xmalloc (sizeof *img);
7516 xassert (valid_image_p (spec));
7517 bzero (img, sizeof *img);
7518 img->type = lookup_image_type (image_spec_value (spec, QCtype, NULL));
7519 xassert (img->type != NULL);
7520 img->spec = spec;
7521 img->data.lisp_val = Qnil;
7522 img->ascent = DEFAULT_IMAGE_ASCENT;
7523 img->hash = hash;
7524 return img;
7528 /* Free image IMG which was used on frame F, including its resources. */
7530 static void
7531 free_image (f, img)
7532 struct frame *f;
7533 struct image *img;
7535 if (img)
7537 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7539 /* Remove IMG from the hash table of its cache. */
7540 if (img->prev)
7541 img->prev->next = img->next;
7542 else
7543 c->buckets[img->hash % IMAGE_CACHE_BUCKETS_SIZE] = img->next;
7545 if (img->next)
7546 img->next->prev = img->prev;
7548 c->images[img->id] = NULL;
7550 /* Free resources, then free IMG. */
7551 img->type->free (f, img);
7552 xfree (img);
7557 /* Prepare image IMG for display on frame F. Must be called before
7558 drawing an image. */
7560 void
7561 prepare_image_for_display (f, img)
7562 struct frame *f;
7563 struct image *img;
7565 EMACS_TIME t;
7567 /* We're about to display IMG, so set its timestamp to `now'. */
7568 EMACS_GET_TIME (t);
7569 img->timestamp = EMACS_SECS (t);
7571 /* If IMG doesn't have a pixmap yet, load it now, using the image
7572 type dependent loader function. */
7573 if (img->pixmap == 0 && !img->load_failed_p)
7574 img->load_failed_p = img->type->load (f, img) == 0;
7579 /***********************************************************************
7580 Helper functions for X image types
7581 ***********************************************************************/
7583 static void x_clear_image P_ ((struct frame *f, struct image *img));
7584 static unsigned long x_alloc_image_color P_ ((struct frame *f,
7585 struct image *img,
7586 Lisp_Object color_name,
7587 unsigned long dflt));
7589 /* Free X resources of image IMG which is used on frame F. */
7591 static void
7592 x_clear_image (f, img)
7593 struct frame *f;
7594 struct image *img;
7596 #if 0 /* NTEMACS_TODO: W32 image support */
7598 if (img->pixmap)
7600 BLOCK_INPUT;
7601 XFreePixmap (NULL, img->pixmap);
7602 img->pixmap = 0;
7603 UNBLOCK_INPUT;
7606 if (img->ncolors)
7608 int class = FRAME_W32_DISPLAY_INFO (f)->visual->class;
7610 /* If display has an immutable color map, freeing colors is not
7611 necessary and some servers don't allow it. So don't do it. */
7612 if (class != StaticColor
7613 && class != StaticGray
7614 && class != TrueColor)
7616 Colormap cmap;
7617 BLOCK_INPUT;
7618 cmap = DefaultColormapOfScreen (FRAME_W32_DISPLAY_INFO (f)->screen);
7619 XFreeColors (FRAME_W32_DISPLAY (f), cmap, img->colors,
7620 img->ncolors, 0);
7621 UNBLOCK_INPUT;
7624 xfree (img->colors);
7625 img->colors = NULL;
7626 img->ncolors = 0;
7628 #endif
7632 /* Allocate color COLOR_NAME for image IMG on frame F. If color
7633 cannot be allocated, use DFLT. Add a newly allocated color to
7634 IMG->colors, so that it can be freed again. Value is the pixel
7635 color. */
7637 static unsigned long
7638 x_alloc_image_color (f, img, color_name, dflt)
7639 struct frame *f;
7640 struct image *img;
7641 Lisp_Object color_name;
7642 unsigned long dflt;
7644 #if 0 /* NTEMACS_TODO: allocing colors. */
7645 XColor color;
7646 unsigned long result;
7648 xassert (STRINGP (color_name));
7650 if (w32_defined_color (f, XSTRING (color_name)->data, &color, 1))
7652 /* This isn't called frequently so we get away with simply
7653 reallocating the color vector to the needed size, here. */
7654 ++img->ncolors;
7655 img->colors =
7656 (unsigned long *) xrealloc (img->colors,
7657 img->ncolors * sizeof *img->colors);
7658 img->colors[img->ncolors - 1] = color.pixel;
7659 result = color.pixel;
7661 else
7662 result = dflt;
7663 return result;
7664 #endif
7665 return 0;
7670 /***********************************************************************
7671 Image Cache
7672 ***********************************************************************/
7674 static void cache_image P_ ((struct frame *f, struct image *img));
7677 /* Return a new, initialized image cache that is allocated from the
7678 heap. Call free_image_cache to free an image cache. */
7680 struct image_cache *
7681 make_image_cache ()
7683 struct image_cache *c = (struct image_cache *) xmalloc (sizeof *c);
7684 int size;
7686 bzero (c, sizeof *c);
7687 c->size = 50;
7688 c->images = (struct image **) xmalloc (c->size * sizeof *c->images);
7689 size = IMAGE_CACHE_BUCKETS_SIZE * sizeof *c->buckets;
7690 c->buckets = (struct image **) xmalloc (size);
7691 bzero (c->buckets, size);
7692 return c;
7696 /* Free image cache of frame F. Be aware that X frames share images
7697 caches. */
7699 void
7700 free_image_cache (f)
7701 struct frame *f;
7703 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7704 if (c)
7706 int i;
7708 /* Cache should not be referenced by any frame when freed. */
7709 xassert (c->refcount == 0);
7711 for (i = 0; i < c->used; ++i)
7712 free_image (f, c->images[i]);
7713 xfree (c->images);
7714 xfree (c);
7715 xfree (c->buckets);
7716 FRAME_X_IMAGE_CACHE (f) = NULL;
7721 /* Clear image cache of frame F. FORCE_P non-zero means free all
7722 images. FORCE_P zero means clear only images that haven't been
7723 displayed for some time. Should be called from time to time to
7724 reduce the number of loaded images. If image-cache-eveiction-delay
7725 is non-nil, this frees images in the cache which weren't displayed for
7726 at least that many seconds. */
7728 void
7729 clear_image_cache (f, force_p)
7730 struct frame *f;
7731 int force_p;
7733 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7735 if (c && INTEGERP (Vimage_cache_eviction_delay))
7737 EMACS_TIME t;
7738 unsigned long old;
7739 int i, any_freed_p = 0;
7741 EMACS_GET_TIME (t);
7742 old = EMACS_SECS (t) - XFASTINT (Vimage_cache_eviction_delay);
7744 for (i = 0; i < c->used; ++i)
7746 struct image *img = c->images[i];
7747 if (img != NULL
7748 && (force_p
7749 || (img->timestamp > old)))
7751 free_image (f, img);
7752 any_freed_p = 1;
7756 /* We may be clearing the image cache because, for example,
7757 Emacs was iconified for a longer period of time. In that
7758 case, current matrices may still contain references to
7759 images freed above. So, clear these matrices. */
7760 if (any_freed_p)
7762 clear_current_matrices (f);
7763 ++windows_or_buffers_changed;
7769 DEFUN ("clear-image-cache", Fclear_image_cache, Sclear_image_cache,
7770 0, 1, 0,
7771 "Clear the image cache of FRAME.\n\
7772 FRAME nil or omitted means use the selected frame.\n\
7773 FRAME t means clear the image caches of all frames.")
7774 (frame)
7775 Lisp_Object frame;
7777 if (EQ (frame, Qt))
7779 Lisp_Object tail;
7781 FOR_EACH_FRAME (tail, frame)
7782 if (FRAME_W32_P (XFRAME (frame)))
7783 clear_image_cache (XFRAME (frame), 1);
7785 else
7786 clear_image_cache (check_x_frame (frame), 1);
7788 return Qnil;
7792 /* Return the id of image with Lisp specification SPEC on frame F.
7793 SPEC must be a valid Lisp image specification (see valid_image_p). */
7796 lookup_image (f, spec)
7797 struct frame *f;
7798 Lisp_Object spec;
7800 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7801 struct image *img;
7802 int i;
7803 unsigned hash;
7804 struct gcpro gcpro1;
7805 EMACS_TIME now;
7807 /* F must be a window-system frame, and SPEC must be a valid image
7808 specification. */
7809 xassert (FRAME_WINDOW_P (f));
7810 xassert (valid_image_p (spec));
7812 GCPRO1 (spec);
7814 /* Look up SPEC in the hash table of the image cache. */
7815 hash = sxhash (spec, 0);
7816 i = hash % IMAGE_CACHE_BUCKETS_SIZE;
7818 for (img = c->buckets[i]; img; img = img->next)
7819 if (img->hash == hash && !NILP (Fequal (img->spec, spec)))
7820 break;
7822 /* If not found, create a new image and cache it. */
7823 if (img == NULL)
7825 img = make_image (spec, hash);
7826 cache_image (f, img);
7827 img->load_failed_p = img->type->load (f, img) == 0;
7828 xassert (!interrupt_input_blocked);
7830 /* If we can't load the image, and we don't have a width and
7831 height, use some arbitrary width and height so that we can
7832 draw a rectangle for it. */
7833 if (img->load_failed_p)
7835 Lisp_Object value;
7837 value = image_spec_value (spec, QCwidth, NULL);
7838 img->width = (INTEGERP (value)
7839 ? XFASTINT (value) : DEFAULT_IMAGE_WIDTH);
7840 value = image_spec_value (spec, QCheight, NULL);
7841 img->height = (INTEGERP (value)
7842 ? XFASTINT (value) : DEFAULT_IMAGE_HEIGHT);
7844 else
7846 /* Handle image type independent image attributes
7847 `:ascent PERCENT', `:margin MARGIN', `:relief RELIEF'. */
7848 Lisp_Object ascent, margin, relief, algorithm, heuristic_mask;
7849 Lisp_Object file;
7851 ascent = image_spec_value (spec, QCascent, NULL);
7852 if (INTEGERP (ascent))
7853 img->ascent = XFASTINT (ascent);
7855 margin = image_spec_value (spec, QCmargin, NULL);
7856 if (INTEGERP (margin) && XINT (margin) >= 0)
7857 img->margin = XFASTINT (margin);
7859 relief = image_spec_value (spec, QCrelief, NULL);
7860 if (INTEGERP (relief))
7862 img->relief = XINT (relief);
7863 img->margin += abs (img->relief);
7866 /* Should we apply a Laplace edge-detection algorithm? */
7867 algorithm = image_spec_value (spec, QCalgorithm, NULL);
7868 if (img->pixmap && EQ (algorithm, Qlaplace))
7869 x_laplace (f, img);
7871 /* Should we built a mask heuristically? */
7872 heuristic_mask = image_spec_value (spec, QCheuristic_mask, NULL);
7873 if (img->pixmap && !img->mask && !NILP (heuristic_mask))
7874 x_build_heuristic_mask (f, img, heuristic_mask);
7878 /* We're using IMG, so set its timestamp to `now'. */
7879 EMACS_GET_TIME (now);
7880 img->timestamp = EMACS_SECS (now);
7882 UNGCPRO;
7884 /* Value is the image id. */
7885 return img->id;
7889 /* Cache image IMG in the image cache of frame F. */
7891 static void
7892 cache_image (f, img)
7893 struct frame *f;
7894 struct image *img;
7896 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7897 int i;
7899 /* Find a free slot in c->images. */
7900 for (i = 0; i < c->used; ++i)
7901 if (c->images[i] == NULL)
7902 break;
7904 /* If no free slot found, maybe enlarge c->images. */
7905 if (i == c->used && c->used == c->size)
7907 c->size *= 2;
7908 c->images = (struct image **) xrealloc (c->images,
7909 c->size * sizeof *c->images);
7912 /* Add IMG to c->images, and assign IMG an id. */
7913 c->images[i] = img;
7914 img->id = i;
7915 if (i == c->used)
7916 ++c->used;
7918 /* Add IMG to the cache's hash table. */
7919 i = img->hash % IMAGE_CACHE_BUCKETS_SIZE;
7920 img->next = c->buckets[i];
7921 if (img->next)
7922 img->next->prev = img;
7923 img->prev = NULL;
7924 c->buckets[i] = img;
7928 /* Call FN on every image in the image cache of frame F. Used to mark
7929 Lisp Objects in the image cache. */
7931 void
7932 forall_images_in_image_cache (f, fn)
7933 struct frame *f;
7934 void (*fn) P_ ((struct image *img));
7936 if (FRAME_LIVE_P (f) && FRAME_W32_P (f))
7938 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7939 if (c)
7941 int i;
7942 for (i = 0; i < c->used; ++i)
7943 if (c->images[i])
7944 fn (c->images[i]);
7951 /***********************************************************************
7952 W32 support code
7953 ***********************************************************************/
7955 #if 0 /* NTEMACS_TODO: W32 specific image code. */
7957 static int x_create_x_image_and_pixmap P_ ((struct frame *, int, int, int,
7958 XImage **, Pixmap *));
7959 static void x_destroy_x_image P_ ((XImage *));
7960 static void x_put_x_image P_ ((struct frame *, XImage *, Pixmap, int, int));
7963 /* Create an XImage and a pixmap of size WIDTH x HEIGHT for use on
7964 frame F. Set *XIMG and *PIXMAP to the XImage and Pixmap created.
7965 Set (*XIMG)->data to a raster of WIDTH x HEIGHT pixels allocated
7966 via xmalloc. Print error messages via image_error if an error
7967 occurs. Value is non-zero if successful. */
7969 static int
7970 x_create_x_image_and_pixmap (f, width, height, depth, ximg, pixmap)
7971 struct frame *f;
7972 int width, height, depth;
7973 XImage **ximg;
7974 Pixmap *pixmap;
7976 #if 0 /* NTEMACS_TODO: Image support for W32 */
7977 Display *display = FRAME_W32_DISPLAY (f);
7978 Screen *screen = FRAME_X_SCREEN (f);
7979 Window window = FRAME_W32_WINDOW (f);
7981 xassert (interrupt_input_blocked);
7983 if (depth <= 0)
7984 depth = DefaultDepthOfScreen (screen);
7985 *ximg = XCreateImage (display, DefaultVisualOfScreen (screen),
7986 depth, ZPixmap, 0, NULL, width, height,
7987 depth > 16 ? 32 : depth > 8 ? 16 : 8, 0);
7988 if (*ximg == NULL)
7990 image_error ("Unable to allocate X image", Qnil, Qnil);
7991 return 0;
7994 /* Allocate image raster. */
7995 (*ximg)->data = (char *) xmalloc ((*ximg)->bytes_per_line * height);
7997 /* Allocate a pixmap of the same size. */
7998 *pixmap = XCreatePixmap (display, window, width, height, depth);
7999 if (*pixmap == 0)
8001 x_destroy_x_image (*ximg);
8002 *ximg = NULL;
8003 image_error ("Unable to create X pixmap", Qnil, Qnil);
8004 return 0;
8006 #endif
8007 return 1;
8011 /* Destroy XImage XIMG. Free XIMG->data. */
8013 static void
8014 x_destroy_x_image (ximg)
8015 XImage *ximg;
8017 xassert (interrupt_input_blocked);
8018 if (ximg)
8020 xfree (ximg->data);
8021 ximg->data = NULL;
8022 XDestroyImage (ximg);
8027 /* Put XImage XIMG into pixmap PIXMAP on frame F. WIDTH and HEIGHT
8028 are width and height of both the image and pixmap. */
8030 static void
8031 x_put_x_image (f, ximg, pixmap, width, height)
8032 struct frame *f;
8033 XImage *ximg;
8034 Pixmap pixmap;
8036 GC gc;
8038 xassert (interrupt_input_blocked);
8039 gc = XCreateGC (NULL, pixmap, 0, NULL);
8040 XPutImage (NULL, pixmap, gc, ximg, 0, 0, 0, 0, width, height);
8041 XFreeGC (NULL, gc);
8044 #endif
8047 /***********************************************************************
8048 Searching files
8049 ***********************************************************************/
8051 static Lisp_Object x_find_image_file P_ ((Lisp_Object));
8053 /* Find image file FILE. Look in data-directory, then
8054 x-bitmap-file-path. Value is the full name of the file found, or
8055 nil if not found. */
8057 static Lisp_Object
8058 x_find_image_file (file)
8059 Lisp_Object file;
8061 Lisp_Object file_found, search_path;
8062 struct gcpro gcpro1, gcpro2;
8063 int fd;
8065 file_found = Qnil;
8066 search_path = Fcons (Vdata_directory, Vx_bitmap_file_path);
8067 GCPRO2 (file_found, search_path);
8069 /* Try to find FILE in data-directory, then x-bitmap-file-path. */
8070 fd = openp (search_path, file, "", &file_found, 0);
8072 if (fd < 0)
8073 file_found = Qnil;
8074 else
8075 close (fd);
8077 UNGCPRO;
8078 return file_found;
8083 /***********************************************************************
8084 XBM images
8085 ***********************************************************************/
8087 static int xbm_load P_ ((struct frame *f, struct image *img));
8088 static int xbm_load_image_from_file P_ ((struct frame *f, struct image *img,
8089 Lisp_Object file));
8090 static int xbm_image_p P_ ((Lisp_Object object));
8091 static int xbm_read_bitmap_file_data P_ ((char *, int *, int *,
8092 unsigned char **));
8095 /* Indices of image specification fields in xbm_format, below. */
8097 enum xbm_keyword_index
8099 XBM_TYPE,
8100 XBM_FILE,
8101 XBM_WIDTH,
8102 XBM_HEIGHT,
8103 XBM_DATA,
8104 XBM_FOREGROUND,
8105 XBM_BACKGROUND,
8106 XBM_ASCENT,
8107 XBM_MARGIN,
8108 XBM_RELIEF,
8109 XBM_ALGORITHM,
8110 XBM_HEURISTIC_MASK,
8111 XBM_LAST
8114 /* Vector of image_keyword structures describing the format
8115 of valid XBM image specifications. */
8117 static struct image_keyword xbm_format[XBM_LAST] =
8119 {":type", IMAGE_SYMBOL_VALUE, 1},
8120 {":file", IMAGE_STRING_VALUE, 0},
8121 {":width", IMAGE_POSITIVE_INTEGER_VALUE, 0},
8122 {":height", IMAGE_POSITIVE_INTEGER_VALUE, 0},
8123 {":data", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8124 {":foreground", IMAGE_STRING_VALUE, 0},
8125 {":background", IMAGE_STRING_VALUE, 0},
8126 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
8127 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
8128 {":relief", IMAGE_INTEGER_VALUE, 0},
8129 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8130 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
8133 /* Structure describing the image type XBM. */
8135 static struct image_type xbm_type =
8137 &Qxbm,
8138 xbm_image_p,
8139 xbm_load,
8140 x_clear_image,
8141 NULL
8144 /* Tokens returned from xbm_scan. */
8146 enum xbm_token
8148 XBM_TK_IDENT = 256,
8149 XBM_TK_NUMBER
8153 /* Return non-zero if OBJECT is a valid XBM-type image specification.
8154 A valid specification is a list starting with the symbol `image'
8155 The rest of the list is a property list which must contain an
8156 entry `:type xbm..
8158 If the specification specifies a file to load, it must contain
8159 an entry `:file FILENAME' where FILENAME is a string.
8161 If the specification is for a bitmap loaded from memory it must
8162 contain `:width WIDTH', `:height HEIGHT', and `:data DATA', where
8163 WIDTH and HEIGHT are integers > 0. DATA may be:
8165 1. a string large enough to hold the bitmap data, i.e. it must
8166 have a size >= (WIDTH + 7) / 8 * HEIGHT
8168 2. a bool-vector of size >= WIDTH * HEIGHT
8170 3. a vector of strings or bool-vectors, one for each line of the
8171 bitmap.
8173 Both the file and data forms may contain the additional entries
8174 `:background COLOR' and `:foreground COLOR'. If not present,
8175 foreground and background of the frame on which the image is
8176 displayed, is used. */
8178 static int
8179 xbm_image_p (object)
8180 Lisp_Object object;
8182 struct image_keyword kw[XBM_LAST];
8184 bcopy (xbm_format, kw, sizeof kw);
8185 if (!parse_image_spec (object, kw, XBM_LAST, Qxbm))
8186 return 0;
8188 xassert (EQ (kw[XBM_TYPE].value, Qxbm));
8190 if (kw[XBM_FILE].count)
8192 if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_DATA].count)
8193 return 0;
8195 else
8197 Lisp_Object data;
8198 int width, height;
8200 /* Entries for `:width', `:height' and `:data' must be present. */
8201 if (!kw[XBM_WIDTH].count
8202 || !kw[XBM_HEIGHT].count
8203 || !kw[XBM_DATA].count)
8204 return 0;
8206 data = kw[XBM_DATA].value;
8207 width = XFASTINT (kw[XBM_WIDTH].value);
8208 height = XFASTINT (kw[XBM_HEIGHT].value);
8210 /* Check type of data, and width and height against contents of
8211 data. */
8212 if (VECTORP (data))
8214 int i;
8216 /* Number of elements of the vector must be >= height. */
8217 if (XVECTOR (data)->size < height)
8218 return 0;
8220 /* Each string or bool-vector in data must be large enough
8221 for one line of the image. */
8222 for (i = 0; i < height; ++i)
8224 Lisp_Object elt = XVECTOR (data)->contents[i];
8226 if (STRINGP (elt))
8228 if (XSTRING (elt)->size
8229 < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR)
8230 return 0;
8232 else if (BOOL_VECTOR_P (elt))
8234 if (XBOOL_VECTOR (elt)->size < width)
8235 return 0;
8237 else
8238 return 0;
8241 else if (STRINGP (data))
8243 if (XSTRING (data)->size
8244 < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR * height)
8245 return 0;
8247 else if (BOOL_VECTOR_P (data))
8249 if (XBOOL_VECTOR (data)->size < width * height)
8250 return 0;
8252 else
8253 return 0;
8256 /* Baseline must be a value between 0 and 100 (a percentage). */
8257 if (kw[XBM_ASCENT].count
8258 && XFASTINT (kw[XBM_ASCENT].value) > 100)
8259 return 0;
8261 return 1;
8265 /* Scan a bitmap file. FP is the stream to read from. Value is
8266 either an enumerator from enum xbm_token, or a character for a
8267 single-character token, or 0 at end of file. If scanning an
8268 identifier, store the lexeme of the identifier in SVAL. If
8269 scanning a number, store its value in *IVAL. */
8271 static int
8272 xbm_scan (fp, sval, ival)
8273 FILE *fp;
8274 char *sval;
8275 int *ival;
8277 int c;
8279 /* Skip white space. */
8280 while ((c = fgetc (fp)) != EOF && isspace (c))
8283 if (c == EOF)
8284 c = 0;
8285 else if (isdigit (c))
8287 int value = 0, digit;
8289 if (c == '0')
8291 c = fgetc (fp);
8292 if (c == 'x' || c == 'X')
8294 while ((c = fgetc (fp)) != EOF)
8296 if (isdigit (c))
8297 digit = c - '0';
8298 else if (c >= 'a' && c <= 'f')
8299 digit = c - 'a' + 10;
8300 else if (c >= 'A' && c <= 'F')
8301 digit = c - 'A' + 10;
8302 else
8303 break;
8304 value = 16 * value + digit;
8307 else if (isdigit (c))
8309 value = c - '0';
8310 while ((c = fgetc (fp)) != EOF
8311 && isdigit (c))
8312 value = 8 * value + c - '0';
8315 else
8317 value = c - '0';
8318 while ((c = fgetc (fp)) != EOF
8319 && isdigit (c))
8320 value = 10 * value + c - '0';
8323 if (c != EOF)
8324 ungetc (c, fp);
8325 *ival = value;
8326 c = XBM_TK_NUMBER;
8328 else if (isalpha (c) || c == '_')
8330 *sval++ = c;
8331 while ((c = fgetc (fp)) != EOF
8332 && (isalnum (c) || c == '_'))
8333 *sval++ = c;
8334 *sval = 0;
8335 if (c != EOF)
8336 ungetc (c, fp);
8337 c = XBM_TK_IDENT;
8340 return c;
8344 /* Replacement for XReadBitmapFileData which isn't available under old
8345 X versions. FILE is the name of the bitmap file to read. Set
8346 *WIDTH and *HEIGHT to the width and height of the image. Return in
8347 *DATA the bitmap data allocated with xmalloc. Value is non-zero if
8348 successful. */
8350 static int
8351 xbm_read_bitmap_file_data (file, width, height, data)
8352 char *file;
8353 int *width, *height;
8354 unsigned char **data;
8356 FILE *fp;
8357 char buffer[BUFSIZ];
8358 int padding_p = 0;
8359 int v10 = 0;
8360 int bytes_per_line, i, nbytes;
8361 unsigned char *p;
8362 int value;
8363 int LA1;
8365 #define match() \
8366 LA1 = xbm_scan (fp, buffer, &value)
8368 #define expect(TOKEN) \
8369 if (LA1 != (TOKEN)) \
8370 goto failure; \
8371 else \
8372 match ()
8374 #define expect_ident(IDENT) \
8375 if (LA1 == XBM_TK_IDENT && strcmp (buffer, (IDENT)) == 0) \
8376 match (); \
8377 else \
8378 goto failure
8380 fp = fopen (file, "r");
8381 if (fp == NULL)
8382 return 0;
8384 *width = *height = -1;
8385 *data = NULL;
8386 LA1 = xbm_scan (fp, buffer, &value);
8388 /* Parse defines for width, height and hot-spots. */
8389 while (LA1 == '#')
8391 match ();
8392 expect_ident ("define");
8393 expect (XBM_TK_IDENT);
8395 if (LA1 == XBM_TK_NUMBER);
8397 char *p = strrchr (buffer, '_');
8398 p = p ? p + 1 : buffer;
8399 if (strcmp (p, "width") == 0)
8400 *width = value;
8401 else if (strcmp (p, "height") == 0)
8402 *height = value;
8404 expect (XBM_TK_NUMBER);
8407 if (*width < 0 || *height < 0)
8408 goto failure;
8410 /* Parse bits. Must start with `static'. */
8411 expect_ident ("static");
8412 if (LA1 == XBM_TK_IDENT)
8414 if (strcmp (buffer, "unsigned") == 0)
8416 match ();
8417 expect_ident ("char");
8419 else if (strcmp (buffer, "short") == 0)
8421 match ();
8422 v10 = 1;
8423 if (*width % 16 && *width % 16 < 9)
8424 padding_p = 1;
8426 else if (strcmp (buffer, "char") == 0)
8427 match ();
8428 else
8429 goto failure;
8431 else
8432 goto failure;
8434 expect (XBM_TK_IDENT);
8435 expect ('[');
8436 expect (']');
8437 expect ('=');
8438 expect ('{');
8440 bytes_per_line = (*width + 7) / 8 + padding_p;
8441 nbytes = bytes_per_line * *height;
8442 p = *data = (char *) xmalloc (nbytes);
8444 if (v10)
8447 for (i = 0; i < nbytes; i += 2)
8449 int val = value;
8450 expect (XBM_TK_NUMBER);
8452 *p++ = val;
8453 if (!padding_p || ((i + 2) % bytes_per_line))
8454 *p++ = value >> 8;
8456 if (LA1 == ',' || LA1 == '}')
8457 match ();
8458 else
8459 goto failure;
8462 else
8464 for (i = 0; i < nbytes; ++i)
8466 int val = value;
8467 expect (XBM_TK_NUMBER);
8469 *p++ = val;
8471 if (LA1 == ',' || LA1 == '}')
8472 match ();
8473 else
8474 goto failure;
8478 fclose (fp);
8479 return 1;
8481 failure:
8483 fclose (fp);
8484 if (*data)
8486 xfree (*data);
8487 *data = NULL;
8489 return 0;
8491 #undef match
8492 #undef expect
8493 #undef expect_ident
8497 /* Load XBM image IMG which will be displayed on frame F from file
8498 SPECIFIED_FILE. Value is non-zero if successful. */
8500 static int
8501 xbm_load_image_from_file (f, img, specified_file)
8502 struct frame *f;
8503 struct image *img;
8504 Lisp_Object specified_file;
8506 int rc;
8507 unsigned char *data;
8508 int success_p = 0;
8509 Lisp_Object file;
8510 struct gcpro gcpro1;
8512 xassert (STRINGP (specified_file));
8513 file = Qnil;
8514 GCPRO1 (file);
8516 file = x_find_image_file (specified_file);
8517 if (!STRINGP (file))
8519 image_error ("Cannot find image file `%s'", specified_file, Qnil);
8520 UNGCPRO;
8521 return 0;
8524 rc = xbm_read_bitmap_file_data (XSTRING (file)->data, &img->width,
8525 &img->height, &data);
8526 if (rc)
8528 int depth = one_w32_display_info.n_cbits;
8529 unsigned long foreground = FRAME_FOREGROUND_PIXEL (f);
8530 unsigned long background = FRAME_BACKGROUND_PIXEL (f);
8531 Lisp_Object value;
8533 xassert (img->width > 0 && img->height > 0);
8535 /* Get foreground and background colors, maybe allocate colors. */
8536 value = image_spec_value (img->spec, QCforeground, NULL);
8537 if (!NILP (value))
8538 foreground = x_alloc_image_color (f, img, value, foreground);
8540 value = image_spec_value (img->spec, QCbackground, NULL);
8541 if (!NILP (value))
8542 background = x_alloc_image_color (f, img, value, background);
8544 #if 0 /* NTEMACS_TODO : Port image display to W32 */
8545 BLOCK_INPUT;
8546 img->pixmap
8547 = XCreatePixmapFromBitmapData (FRAME_W32_DISPLAY (f),
8548 FRAME_W32_WINDOW (f),
8549 data,
8550 img->width, img->height,
8551 foreground, background,
8552 depth);
8553 xfree (data);
8555 if (img->pixmap == 0)
8557 x_clear_image (f, img);
8558 image_error ("Unable to create X pixmap for `%s'", file, Qnil);
8560 else
8561 success_p = 1;
8563 UNBLOCK_INPUT;
8564 #endif
8566 else
8567 image_error ("Error loading XBM image `%s'", img->spec, Qnil);
8569 UNGCPRO;
8570 return success_p;
8574 /* Fill image IMG which is used on frame F with pixmap data. Value is
8575 non-zero if successful. */
8577 static int
8578 xbm_load (f, img)
8579 struct frame *f;
8580 struct image *img;
8582 int success_p = 0;
8583 Lisp_Object file_name;
8585 xassert (xbm_image_p (img->spec));
8587 /* If IMG->spec specifies a file name, create a non-file spec from it. */
8588 file_name = image_spec_value (img->spec, QCfile, NULL);
8589 if (STRINGP (file_name))
8590 success_p = xbm_load_image_from_file (f, img, file_name);
8591 else
8593 struct image_keyword fmt[XBM_LAST];
8594 Lisp_Object data;
8595 int depth;
8596 unsigned long foreground = FRAME_FOREGROUND_PIXEL (f);
8597 unsigned long background = FRAME_BACKGROUND_PIXEL (f);
8598 char *bits;
8599 int parsed_p;
8601 /* Parse the list specification. */
8602 bcopy (xbm_format, fmt, sizeof fmt);
8603 parsed_p = parse_image_spec (img->spec, fmt, XBM_LAST, Qxbm);
8604 xassert (parsed_p);
8606 /* Get specified width, and height. */
8607 img->width = XFASTINT (fmt[XBM_WIDTH].value);
8608 img->height = XFASTINT (fmt[XBM_HEIGHT].value);
8609 xassert (img->width > 0 && img->height > 0);
8611 BLOCK_INPUT;
8613 if (fmt[XBM_ASCENT].count)
8614 img->ascent = XFASTINT (fmt[XBM_ASCENT].value);
8616 /* Get foreground and background colors, maybe allocate colors. */
8617 if (fmt[XBM_FOREGROUND].count)
8618 foreground = x_alloc_image_color (f, img, fmt[XBM_FOREGROUND].value,
8619 foreground);
8620 if (fmt[XBM_BACKGROUND].count)
8621 background = x_alloc_image_color (f, img, fmt[XBM_BACKGROUND].value,
8622 background);
8624 /* Set bits to the bitmap image data. */
8625 data = fmt[XBM_DATA].value;
8626 if (VECTORP (data))
8628 int i;
8629 char *p;
8630 int nbytes = (img->width + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
8632 p = bits = (char *) alloca (nbytes * img->height);
8633 for (i = 0; i < img->height; ++i, p += nbytes)
8635 Lisp_Object line = XVECTOR (data)->contents[i];
8636 if (STRINGP (line))
8637 bcopy (XSTRING (line)->data, p, nbytes);
8638 else
8639 bcopy (XBOOL_VECTOR (line)->data, p, nbytes);
8642 else if (STRINGP (data))
8643 bits = XSTRING (data)->data;
8644 else
8645 bits = XBOOL_VECTOR (data)->data;
8647 #if 0 /* NTEMACS_TODO : W32 XPM code */
8648 /* Create the pixmap. */
8649 depth = DefaultDepthOfScreen (FRAME_X_SCREEN (f));
8650 img->pixmap
8651 = XCreatePixmapFromBitmapData (FRAME_W32_DISPLAY (f),
8652 FRAME_W32_WINDOW (f),
8653 bits,
8654 img->width, img->height,
8655 foreground, background,
8656 depth);
8657 #endif /* NTEMACS_TODO */
8659 if (img->pixmap)
8660 success_p = 1;
8661 else
8663 image_error ("Unable to create pixmap for XBM image `%s'",
8664 img->spec, Qnil);
8665 x_clear_image (f, img);
8668 UNBLOCK_INPUT;
8671 return success_p;
8676 /***********************************************************************
8677 XPM images
8678 ***********************************************************************/
8680 #if HAVE_XPM
8682 static int xpm_image_p P_ ((Lisp_Object object));
8683 static int xpm_load P_ ((struct frame *f, struct image *img));
8684 static int xpm_valid_color_symbols_p P_ ((Lisp_Object));
8686 #include "X11/xpm.h"
8688 /* The symbol `xpm' identifying XPM-format images. */
8690 Lisp_Object Qxpm;
8692 /* Indices of image specification fields in xpm_format, below. */
8694 enum xpm_keyword_index
8696 XPM_TYPE,
8697 XPM_FILE,
8698 XPM_DATA,
8699 XPM_ASCENT,
8700 XPM_MARGIN,
8701 XPM_RELIEF,
8702 XPM_ALGORITHM,
8703 XPM_HEURISTIC_MASK,
8704 XPM_COLOR_SYMBOLS,
8705 XPM_LAST
8708 /* Vector of image_keyword structures describing the format
8709 of valid XPM image specifications. */
8711 static struct image_keyword xpm_format[XPM_LAST] =
8713 {":type", IMAGE_SYMBOL_VALUE, 1},
8714 {":file", IMAGE_STRING_VALUE, 0},
8715 {":data", IMAGE_STRING_VALUE, 0},
8716 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
8717 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
8718 {":relief", IMAGE_INTEGER_VALUE, 0},
8719 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8720 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8721 {":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
8724 /* Structure describing the image type XBM. */
8726 static struct image_type xpm_type =
8728 &Qxpm,
8729 xpm_image_p,
8730 xpm_load,
8731 x_clear_image,
8732 NULL
8736 /* Value is non-zero if COLOR_SYMBOLS is a valid color symbols list
8737 for XPM images. Such a list must consist of conses whose car and
8738 cdr are strings. */
8740 static int
8741 xpm_valid_color_symbols_p (color_symbols)
8742 Lisp_Object color_symbols;
8744 while (CONSP (color_symbols))
8746 Lisp_Object sym = XCAR (color_symbols);
8747 if (!CONSP (sym)
8748 || !STRINGP (XCAR (sym))
8749 || !STRINGP (XCDR (sym)))
8750 break;
8751 color_symbols = XCDR (color_symbols);
8754 return NILP (color_symbols);
8758 /* Value is non-zero if OBJECT is a valid XPM image specification. */
8760 static int
8761 xpm_image_p (object)
8762 Lisp_Object object;
8764 struct image_keyword fmt[XPM_LAST];
8765 bcopy (xpm_format, fmt, sizeof fmt);
8766 return (parse_image_spec (object, fmt, XPM_LAST, Qxpm)
8767 /* Either `:file' or `:data' must be present. */
8768 && fmt[XPM_FILE].count + fmt[XPM_DATA].count == 1
8769 /* Either no `:color-symbols' or it's a list of conses
8770 whose car and cdr are strings. */
8771 && (fmt[XPM_COLOR_SYMBOLS].count == 0
8772 || xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value))
8773 && (fmt[XPM_ASCENT].count == 0
8774 || XFASTINT (fmt[XPM_ASCENT].value) < 100));
8778 /* Load image IMG which will be displayed on frame F. Value is
8779 non-zero if successful. */
8781 static int
8782 xpm_load (f, img)
8783 struct frame *f;
8784 struct image *img;
8786 int rc, i;
8787 XpmAttributes attrs;
8788 Lisp_Object specified_file, color_symbols;
8790 /* Configure the XPM lib. Use the visual of frame F. Allocate
8791 close colors. Return colors allocated. */
8792 bzero (&attrs, sizeof attrs);
8793 attrs.visual = FRAME_W32_DISPLAY_INFO (f)->visual;
8794 attrs.valuemask |= XpmVisual;
8795 attrs.valuemask |= XpmReturnAllocPixels;
8796 attrs.alloc_close_colors = 1;
8797 attrs.valuemask |= XpmAllocCloseColors;
8799 /* If image specification contains symbolic color definitions, add
8800 these to `attrs'. */
8801 color_symbols = image_spec_value (img->spec, QCcolor_symbols, NULL);
8802 if (CONSP (color_symbols))
8804 Lisp_Object tail;
8805 XpmColorSymbol *xpm_syms;
8806 int i, size;
8808 attrs.valuemask |= XpmColorSymbols;
8810 /* Count number of symbols. */
8811 attrs.numsymbols = 0;
8812 for (tail = color_symbols; CONSP (tail); tail = XCDR (tail))
8813 ++attrs.numsymbols;
8815 /* Allocate an XpmColorSymbol array. */
8816 size = attrs.numsymbols * sizeof *xpm_syms;
8817 xpm_syms = (XpmColorSymbol *) alloca (size);
8818 bzero (xpm_syms, size);
8819 attrs.colorsymbols = xpm_syms;
8821 /* Fill the color symbol array. */
8822 for (tail = color_symbols, i = 0;
8823 CONSP (tail);
8824 ++i, tail = XCDR (tail))
8826 Lisp_Object name = XCAR (XCAR (tail));
8827 Lisp_Object color = XCDR (XCAR (tail));
8828 xpm_syms[i].name = (char *) alloca (XSTRING (name)->size + 1);
8829 strcpy (xpm_syms[i].name, XSTRING (name)->data);
8830 xpm_syms[i].value = (char *) alloca (XSTRING (color)->size + 1);
8831 strcpy (xpm_syms[i].value, XSTRING (color)->data);
8835 /* Create a pixmap for the image, either from a file, or from a
8836 string buffer containing data in the same format as an XPM file. */
8837 BLOCK_INPUT;
8838 specified_file = image_spec_value (img->spec, QCfile, NULL);
8839 if (STRINGP (specified_file))
8841 Lisp_Object file = x_find_image_file (specified_file);
8842 if (!STRINGP (file))
8844 image_error ("Cannot find image file `%s'", specified_file, Qnil);
8845 UNBLOCK_INPUT;
8846 return 0;
8849 rc = XpmReadFileToPixmap (NULL, FRAME_W32_WINDOW (f),
8850 XSTRING (file)->data, &img->pixmap, &img->mask,
8851 &attrs);
8853 else
8855 Lisp_Object buffer = image_spec_value (img->spec, QCdata, NULL);
8856 rc = XpmCreatePixmapFromBuffer (NULL, FRAME_W32_WINDOW (f),
8857 XSTRING (buffer)->data,
8858 &img->pixmap, &img->mask,
8859 &attrs);
8861 UNBLOCK_INPUT;
8863 if (rc == XpmSuccess)
8865 /* Remember allocated colors. */
8866 img->ncolors = attrs.nalloc_pixels;
8867 img->colors = (unsigned long *) xmalloc (img->ncolors
8868 * sizeof *img->colors);
8869 for (i = 0; i < attrs.nalloc_pixels; ++i)
8870 img->colors[i] = attrs.alloc_pixels[i];
8872 img->width = attrs.width;
8873 img->height = attrs.height;
8874 xassert (img->width > 0 && img->height > 0);
8876 /* The call to XpmFreeAttributes below frees attrs.alloc_pixels. */
8877 BLOCK_INPUT;
8878 XpmFreeAttributes (&attrs);
8879 UNBLOCK_INPUT;
8881 else
8883 switch (rc)
8885 case XpmOpenFailed:
8886 image_error ("Error opening XPM file (%s)", img->spec, Qnil);
8887 break;
8889 case XpmFileInvalid:
8890 image_error ("Invalid XPM file (%s)", img->spec, Qnil);
8891 break;
8893 case XpmNoMemory:
8894 image_error ("Out of memory (%s)", img->spec, Qnil);
8895 break;
8897 case XpmColorFailed:
8898 image_error ("Color allocation error (%s)", img->spec, Qnil);
8899 break;
8901 default:
8902 image_error ("Unknown error (%s)", img->spec, Qnil);
8903 break;
8907 return rc == XpmSuccess;
8910 #endif /* HAVE_XPM != 0 */
8913 #if 0 /* NTEMACS_TODO : Color tables on W32. */
8914 /***********************************************************************
8915 Color table
8916 ***********************************************************************/
8918 /* An entry in the color table mapping an RGB color to a pixel color. */
8920 struct ct_color
8922 int r, g, b;
8923 unsigned long pixel;
8925 /* Next in color table collision list. */
8926 struct ct_color *next;
8929 /* The bucket vector size to use. Must be prime. */
8931 #define CT_SIZE 101
8933 /* Value is a hash of the RGB color given by R, G, and B. */
8935 #define CT_HASH_RGB(R, G, B) (((R) << 16) ^ ((G) << 8) ^ (B))
8937 /* The color hash table. */
8939 struct ct_color **ct_table;
8941 /* Number of entries in the color table. */
8943 int ct_colors_allocated;
8945 /* Function prototypes. */
8947 static void init_color_table P_ ((void));
8948 static void free_color_table P_ ((void));
8949 static unsigned long *colors_in_color_table P_ ((int *n));
8950 static unsigned long lookup_rgb_color P_ ((struct frame *f, int r, int g, int b));
8951 static unsigned long lookup_pixel_color P_ ((struct frame *f, unsigned long p));
8954 /* Initialize the color table. */
8956 static void
8957 init_color_table ()
8959 int size = CT_SIZE * sizeof (*ct_table);
8960 ct_table = (struct ct_color **) xmalloc (size);
8961 bzero (ct_table, size);
8962 ct_colors_allocated = 0;
8966 /* Free memory associated with the color table. */
8968 static void
8969 free_color_table ()
8971 int i;
8972 struct ct_color *p, *next;
8974 for (i = 0; i < CT_SIZE; ++i)
8975 for (p = ct_table[i]; p; p = next)
8977 next = p->next;
8978 xfree (p);
8981 xfree (ct_table);
8982 ct_table = NULL;
8986 /* Value is a pixel color for RGB color R, G, B on frame F. If an
8987 entry for that color already is in the color table, return the
8988 pixel color of that entry. Otherwise, allocate a new color for R,
8989 G, B, and make an entry in the color table. */
8991 static unsigned long
8992 lookup_rgb_color (f, r, g, b)
8993 struct frame *f;
8994 int r, g, b;
8996 unsigned hash = CT_HASH_RGB (r, g, b);
8997 int i = hash % CT_SIZE;
8998 struct ct_color *p;
9000 for (p = ct_table[i]; p; p = p->next)
9001 if (p->r == r && p->g == g && p->b == b)
9002 break;
9004 if (p == NULL)
9006 COLORREF color;
9007 Colormap cmap;
9008 int rc;
9010 color = PALETTERGB (r, g, b);
9012 ++ct_colors_allocated;
9014 p = (struct ct_color *) xmalloc (sizeof *p);
9015 p->r = r;
9016 p->g = g;
9017 p->b = b;
9018 p->pixel = color;
9019 p->next = ct_table[i];
9020 ct_table[i] = p;
9023 return p->pixel;
9027 /* Look up pixel color PIXEL which is used on frame F in the color
9028 table. If not already present, allocate it. Value is PIXEL. */
9030 static unsigned long
9031 lookup_pixel_color (f, pixel)
9032 struct frame *f;
9033 unsigned long pixel;
9035 int i = pixel % CT_SIZE;
9036 struct ct_color *p;
9038 for (p = ct_table[i]; p; p = p->next)
9039 if (p->pixel == pixel)
9040 break;
9042 if (p == NULL)
9044 XColor color;
9045 Colormap cmap;
9046 int rc;
9048 BLOCK_INPUT;
9050 cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
9051 color.pixel = pixel;
9052 XQueryColor (NULL, cmap, &color);
9053 rc = x_alloc_nearest_color (f, cmap, &color);
9054 UNBLOCK_INPUT;
9056 if (rc)
9058 ++ct_colors_allocated;
9060 p = (struct ct_color *) xmalloc (sizeof *p);
9061 p->r = color.red;
9062 p->g = color.green;
9063 p->b = color.blue;
9064 p->pixel = pixel;
9065 p->next = ct_table[i];
9066 ct_table[i] = p;
9068 else
9069 return FRAME_FOREGROUND_PIXEL (f);
9071 return p->pixel;
9075 /* Value is a vector of all pixel colors contained in the color table,
9076 allocated via xmalloc. Set *N to the number of colors. */
9078 static unsigned long *
9079 colors_in_color_table (n)
9080 int *n;
9082 int i, j;
9083 struct ct_color *p;
9084 unsigned long *colors;
9086 if (ct_colors_allocated == 0)
9088 *n = 0;
9089 colors = NULL;
9091 else
9093 colors = (unsigned long *) xmalloc (ct_colors_allocated
9094 * sizeof *colors);
9095 *n = ct_colors_allocated;
9097 for (i = j = 0; i < CT_SIZE; ++i)
9098 for (p = ct_table[i]; p; p = p->next)
9099 colors[j++] = p->pixel;
9102 return colors;
9105 #endif /* NTEMACS_TODO */
9108 /***********************************************************************
9109 Algorithms
9110 ***********************************************************************/
9112 #if 0 /* NTEMACS_TODO : W32 versions of low level algorithms */
9113 static void x_laplace_write_row P_ ((struct frame *, long *,
9114 int, XImage *, int));
9115 static void x_laplace_read_row P_ ((struct frame *, Colormap,
9116 XColor *, int, XImage *, int));
9119 /* Fill COLORS with RGB colors from row Y of image XIMG. F is the
9120 frame we operate on, CMAP is the color-map in effect, and WIDTH is
9121 the width of one row in the image. */
9123 static void
9124 x_laplace_read_row (f, cmap, colors, width, ximg, y)
9125 struct frame *f;
9126 Colormap cmap;
9127 XColor *colors;
9128 int width;
9129 XImage *ximg;
9130 int y;
9132 int x;
9134 for (x = 0; x < width; ++x)
9135 colors[x].pixel = XGetPixel (ximg, x, y);
9137 XQueryColors (NULL, cmap, colors, width);
9141 /* Write row Y of image XIMG. PIXELS is an array of WIDTH longs
9142 containing the pixel colors to write. F is the frame we are
9143 working on. */
9145 static void
9146 x_laplace_write_row (f, pixels, width, ximg, y)
9147 struct frame *f;
9148 long *pixels;
9149 int width;
9150 XImage *ximg;
9151 int y;
9153 int x;
9155 for (x = 0; x < width; ++x)
9156 XPutPixel (ximg, x, y, pixels[x]);
9158 #endif
9160 /* Transform image IMG which is used on frame F with a Laplace
9161 edge-detection algorithm. The result is an image that can be used
9162 to draw disabled buttons, for example. */
9164 static void
9165 x_laplace (f, img)
9166 struct frame *f;
9167 struct image *img;
9169 #if 0 /* NTEMACS_TODO : W32 version */
9170 Colormap cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
9171 XImage *ximg, *oimg;
9172 XColor *in[3];
9173 long *out;
9174 Pixmap pixmap;
9175 int x, y, i;
9176 long pixel;
9177 int in_y, out_y, rc;
9178 int mv2 = 45000;
9180 BLOCK_INPUT;
9182 /* Get the X image IMG->pixmap. */
9183 ximg = XGetImage (NULL, img->pixmap,
9184 0, 0, img->width, img->height, ~0, ZPixmap);
9186 /* Allocate 3 input rows, and one output row of colors. */
9187 for (i = 0; i < 3; ++i)
9188 in[i] = (XColor *) alloca (img->width * sizeof (XColor));
9189 out = (long *) alloca (img->width * sizeof (long));
9191 /* Create an X image for output. */
9192 rc = x_create_x_image_and_pixmap (f, img->width, img->height, 0,
9193 &oimg, &pixmap);
9195 /* Fill first two rows. */
9196 x_laplace_read_row (f, cmap, in[0], img->width, ximg, 0);
9197 x_laplace_read_row (f, cmap, in[1], img->width, ximg, 1);
9198 in_y = 2;
9200 /* Write first row, all zeros. */
9201 init_color_table ();
9202 pixel = lookup_rgb_color (f, 0, 0, 0);
9203 for (x = 0; x < img->width; ++x)
9204 out[x] = pixel;
9205 x_laplace_write_row (f, out, img->width, oimg, 0);
9206 out_y = 1;
9208 for (y = 2; y < img->height; ++y)
9210 int rowa = y % 3;
9211 int rowb = (y + 2) % 3;
9213 x_laplace_read_row (f, cmap, in[rowa], img->width, ximg, in_y++);
9215 for (x = 0; x < img->width - 2; ++x)
9217 int r = in[rowa][x].red + mv2 - in[rowb][x + 2].red;
9218 int g = in[rowa][x].green + mv2 - in[rowb][x + 2].green;
9219 int b = in[rowa][x].blue + mv2 - in[rowb][x + 2].blue;
9221 out[x + 1] = lookup_rgb_color (f, r & 0xffff, g & 0xffff,
9222 b & 0xffff);
9225 x_laplace_write_row (f, out, img->width, oimg, out_y++);
9228 /* Write last line, all zeros. */
9229 for (x = 0; x < img->width; ++x)
9230 out[x] = pixel;
9231 x_laplace_write_row (f, out, img->width, oimg, out_y);
9233 /* Free the input image, and free resources of IMG. */
9234 XDestroyImage (ximg);
9235 x_clear_image (f, img);
9237 /* Put the output image into pixmap, and destroy it. */
9238 x_put_x_image (f, oimg, pixmap, img->width, img->height);
9239 x_destroy_x_image (oimg);
9241 /* Remember new pixmap and colors in IMG. */
9242 img->pixmap = pixmap;
9243 img->colors = colors_in_color_table (&img->ncolors);
9244 free_color_table ();
9246 UNBLOCK_INPUT;
9247 #endif /* NTEMACS_TODO */
9251 /* Build a mask for image IMG which is used on frame F. FILE is the
9252 name of an image file, for error messages. HOW determines how to
9253 determine the background color of IMG. If it is a list '(R G B)',
9254 with R, G, and B being integers >= 0, take that as the color of the
9255 background. Otherwise, determine the background color of IMG
9256 heuristically. Value is non-zero if successful. */
9258 static int
9259 x_build_heuristic_mask (f, img, how)
9260 struct frame *f;
9261 struct image *img;
9262 Lisp_Object how;
9264 #if 0 /* NTEMACS_TODO : W32 version */
9265 Display *dpy = FRAME_W32_DISPLAY (f);
9266 XImage *ximg, *mask_img;
9267 int x, y, rc, look_at_corners_p;
9268 unsigned long bg;
9270 BLOCK_INPUT;
9272 /* Create an image and pixmap serving as mask. */
9273 rc = x_create_x_image_and_pixmap (f, img->width, img->height, 1,
9274 &mask_img, &img->mask);
9275 if (!rc)
9277 UNBLOCK_INPUT;
9278 return 0;
9281 /* Get the X image of IMG->pixmap. */
9282 ximg = XGetImage (dpy, img->pixmap, 0, 0, img->width, img->height,
9283 ~0, ZPixmap);
9285 /* Determine the background color of ximg. If HOW is `(R G B)'
9286 take that as color. Otherwise, try to determine the color
9287 heuristically. */
9288 look_at_corners_p = 1;
9290 if (CONSP (how))
9292 int rgb[3], i = 0;
9294 while (i < 3
9295 && CONSP (how)
9296 && NATNUMP (XCAR (how)))
9298 rgb[i] = XFASTINT (XCAR (how)) & 0xffff;
9299 how = XCDR (how);
9302 if (i == 3 && NILP (how))
9304 char color_name[30];
9305 XColor exact, color;
9306 Colormap cmap;
9308 sprintf (color_name, "#%04x%04x%04x", rgb[0], rgb[1], rgb[2]);
9310 cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
9311 if (XLookupColor (dpy, cmap, color_name, &exact, &color))
9313 bg = color.pixel;
9314 look_at_corners_p = 0;
9319 if (look_at_corners_p)
9321 unsigned long corners[4];
9322 int i, best_count;
9324 /* Get the colors at the corners of ximg. */
9325 corners[0] = XGetPixel (ximg, 0, 0);
9326 corners[1] = XGetPixel (ximg, img->width - 1, 0);
9327 corners[2] = XGetPixel (ximg, img->width - 1, img->height - 1);
9328 corners[3] = XGetPixel (ximg, 0, img->height - 1);
9330 /* Choose the most frequently found color as background. */
9331 for (i = best_count = 0; i < 4; ++i)
9333 int j, n;
9335 for (j = n = 0; j < 4; ++j)
9336 if (corners[i] == corners[j])
9337 ++n;
9339 if (n > best_count)
9340 bg = corners[i], best_count = n;
9344 /* Set all bits in mask_img to 1 whose color in ximg is different
9345 from the background color bg. */
9346 for (y = 0; y < img->height; ++y)
9347 for (x = 0; x < img->width; ++x)
9348 XPutPixel (mask_img, x, y, XGetPixel (ximg, x, y) != bg);
9350 /* Put mask_img into img->mask. */
9351 x_put_x_image (f, mask_img, img->mask, img->width, img->height);
9352 x_destroy_x_image (mask_img);
9353 XDestroyImage (ximg);
9355 UNBLOCK_INPUT;
9356 #endif /* NTEMACS_TODO */
9358 return 1;
9363 /***********************************************************************
9364 PBM (mono, gray, color)
9365 ***********************************************************************/
9366 #ifdef HAVE_PBM
9368 static int pbm_image_p P_ ((Lisp_Object object));
9369 static int pbm_load P_ ((struct frame *f, struct image *img));
9370 static int pbm_scan_number P_ ((unsigned char **, unsigned char *));
9372 /* The symbol `pbm' identifying images of this type. */
9374 Lisp_Object Qpbm;
9376 /* Indices of image specification fields in gs_format, below. */
9378 enum pbm_keyword_index
9380 PBM_TYPE,
9381 PBM_FILE,
9382 PBM_DATA,
9383 PBM_ASCENT,
9384 PBM_MARGIN,
9385 PBM_RELIEF,
9386 PBM_ALGORITHM,
9387 PBM_HEURISTIC_MASK,
9388 PBM_LAST
9391 /* Vector of image_keyword structures describing the format
9392 of valid user-defined image specifications. */
9394 static struct image_keyword pbm_format[PBM_LAST] =
9396 {":type", IMAGE_SYMBOL_VALUE, 1},
9397 {":file", IMAGE_STRING_VALUE, 0},
9398 {":data", IMAGE_STRING_VALUE, 0},
9399 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
9400 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
9401 {":relief", IMAGE_INTEGER_VALUE, 0},
9402 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
9403 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
9406 /* Structure describing the image type `pbm'. */
9408 static struct image_type pbm_type =
9410 &Qpbm,
9411 pbm_image_p,
9412 pbm_load,
9413 x_clear_image,
9414 NULL
9418 /* Return non-zero if OBJECT is a valid PBM image specification. */
9420 static int
9421 pbm_image_p (object)
9422 Lisp_Object object;
9424 struct image_keyword fmt[PBM_LAST];
9426 bcopy (pbm_format, fmt, sizeof fmt);
9428 if (!parse_image_spec (object, fmt, PBM_LAST, Qpbm)
9429 || (fmt[PBM_ASCENT].count
9430 && XFASTINT (fmt[PBM_ASCENT].value) > 100))
9431 return 0;
9433 /* Must specify either :data or :file. */
9434 return fmt[PBM_DATA].count + fmt[PBM_FILE].count == 1;
9438 /* Scan a decimal number from *S and return it. Advance *S while
9439 reading the number. END is the end of the string. Value is -1 at
9440 end of input. */
9442 static int
9443 pbm_scan_number (s, end)
9444 unsigned char **s, *end;
9446 int c, val = -1;
9448 while (*s < end)
9450 /* Skip white-space. */
9451 while (*s < end && (c = *(*s)++, isspace (c)))
9454 if (c == '#')
9456 /* Skip comment to end of line. */
9457 while (*s < end && (c = *(*s)++, c != '\n'))
9460 else if (isdigit (c))
9462 /* Read decimal number. */
9463 val = c - '0';
9464 while (*s < end && (c = *(*s)++, isdigit (c)))
9465 val = 10 * val + c - '0';
9466 break;
9468 else
9469 break;
9472 return val;
9476 /* Read FILE into memory. Value is a pointer to a buffer allocated
9477 with xmalloc holding FILE's contents. Value is null if an error
9478 occured. *SIZE is set to the size of the file. */
9480 static char *
9481 pbm_read_file (file, size)
9482 Lisp_Object file;
9483 int *size;
9485 FILE *fp = NULL;
9486 char *buf = NULL;
9487 struct stat st;
9489 if (stat (XSTRING (file)->data, &st) == 0
9490 && (fp = fopen (XSTRING (file)->data, "r")) != NULL
9491 && (buf = (char *) xmalloc (st.st_size),
9492 fread (buf, 1, st.st_size, fp) == st.st_size))
9494 *size = st.st_size;
9495 fclose (fp);
9497 else
9499 if (fp)
9500 fclose (fp);
9501 if (buf)
9503 xfree (buf);
9504 buf = NULL;
9508 return buf;
9512 /* Load PBM image IMG for use on frame F. */
9514 static int
9515 pbm_load (f, img)
9516 struct frame *f;
9517 struct image *img;
9519 int raw_p, x, y;
9520 int width, height, max_color_idx = 0;
9521 XImage *ximg;
9522 Lisp_Object file, specified_file;
9523 enum {PBM_MONO, PBM_GRAY, PBM_COLOR} type;
9524 struct gcpro gcpro1;
9525 unsigned char *contents = NULL;
9526 unsigned char *end, *p;
9527 int size;
9529 specified_file = image_spec_value (img->spec, QCfile, NULL);
9530 file = Qnil;
9531 GCPRO1 (file);
9533 if (STRINGP (specified_file))
9535 file = x_find_image_file (specified_file);
9536 if (!STRINGP (file))
9538 image_error ("Cannot find image file `%s'", specified_file, Qnil);
9539 UNGCPRO;
9540 return 0;
9543 contents = pbm_read_file (file, &size);
9544 if (contents == NULL)
9546 image_error ("Error reading `%s'", file, Qnil);
9547 UNGCPRO;
9548 return 0;
9551 p = contents;
9552 end = contents + size;
9554 else
9556 Lisp_Object data;
9557 data = image_spec_value (img->spec, QCdata, NULL);
9558 p = XSTRING (data)->data;
9559 end = p + STRING_BYTES (XSTRING (data));
9562 /* Check magic number. */
9563 if (end - p < 2 || *p++ != 'P')
9565 image_error ("Not a PBM image: `%s'", img->spec, Qnil);
9566 error:
9567 xfree (contents);
9568 UNGCPRO;
9569 return 0;
9572 if (*magic != 'P')
9574 fclose (fp);
9575 image_error ("Not a PBM image file: %s", file, Qnil);
9576 UNGCPRO;
9577 return 0;
9580 switch (*p++)
9582 case '1':
9583 raw_p = 0, type = PBM_MONO;
9584 break;
9586 case '2':
9587 raw_p = 0, type = PBM_GRAY;
9588 break;
9590 case '3':
9591 raw_p = 0, type = PBM_COLOR;
9592 break;
9594 case '4':
9595 raw_p = 1, type = PBM_MONO;
9596 break;
9598 case '5':
9599 raw_p = 1, type = PBM_GRAY;
9600 break;
9602 case '6':
9603 raw_p = 1, type = PBM_COLOR;
9604 break;
9606 default:
9607 image_error ("Not a PBM image: `%s'", img->spec, Qnil);
9608 goto error;
9611 /* Read width, height, maximum color-component. Characters
9612 starting with `#' up to the end of a line are ignored. */
9613 width = pbm_scan_number (&p, end);
9614 height = pbm_scan_number (&p, end);
9616 if (type != PBM_MONO)
9618 max_color_idx = pbm_scan_number (&p, end);
9619 if (raw_p && max_color_idx > 255)
9620 max_color_idx = 255;
9623 if (width < 0
9624 || height < 0
9625 || (type != PBM_MONO && max_color_idx < 0))
9626 goto error;
9628 BLOCK_INPUT;
9629 if (!x_create_x_image_and_pixmap (f, width, height, 0,
9630 &ximg, &img->pixmap))
9632 UNBLOCK_INPUT;
9633 goto error;
9636 /* Initialize the color hash table. */
9637 init_color_table ();
9639 if (type == PBM_MONO)
9641 int c = 0, g;
9643 for (y = 0; y < height; ++y)
9644 for (x = 0; x < width; ++x)
9646 if (raw_p)
9648 if ((x & 7) == 0)
9649 c = *p++;
9650 g = c & 0x80;
9651 c <<= 1;
9653 else
9654 g = pbm_scan_number (&p, end);
9656 XPutPixel (ximg, x, y, (g
9657 ? FRAME_FOREGROUND_PIXEL (f)
9658 : FRAME_BACKGROUND_PIXEL (f)));
9661 else
9663 for (y = 0; y < height; ++y)
9664 for (x = 0; x < width; ++x)
9666 int r, g, b;
9668 if (type == PBM_GRAY)
9669 r = g = b = raw_p ? *p++ : pbm_scan_number (&p, end);
9670 else if (raw_p)
9672 r = *p++;
9673 g = *p++;
9674 b = *p++;
9676 else
9678 r = pbm_scan_number (&p, end);
9679 g = pbm_scan_number (&p, end);
9680 b = pbm_scan_number (&p, end);
9683 if (r < 0 || g < 0 || b < 0)
9685 b xfree (ximg->data);
9686 ximg->data = NULL;
9687 XDestroyImage (ximg);
9688 UNBLOCK_INPUT;
9689 image_error ("Invalid pixel value in image `%s'",
9690 img->spec, Qnil);
9691 goto error;
9694 /* RGB values are now in the range 0..max_color_idx.
9695 Scale this to the range 0..0xffff supported by X. */
9696 r = (double) r * 65535 / max_color_idx;
9697 g = (double) g * 65535 / max_color_idx;
9698 b = (double) b * 65535 / max_color_idx;
9699 XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b));
9703 /* Store in IMG->colors the colors allocated for the image, and
9704 free the color table. */
9705 img->colors = colors_in_color_table (&img->ncolors);
9706 free_color_table ();
9708 /* Put the image into a pixmap. */
9709 x_put_x_image (f, ximg, img->pixmap, width, height);
9710 x_destroy_x_image (ximg);
9711 UNBLOCK_INPUT;
9713 img->width = width;
9714 img->height = height;
9716 UNGCPRO;
9717 xfree (contents);
9718 return 1;
9720 #endif /* HAVE_PBM */
9723 /***********************************************************************
9725 ***********************************************************************/
9727 #if HAVE_PNG
9729 #include <png.h>
9731 /* Function prototypes. */
9733 static int png_image_p P_ ((Lisp_Object object));
9734 static int png_load P_ ((struct frame *f, struct image *img));
9736 /* The symbol `png' identifying images of this type. */
9738 Lisp_Object Qpng;
9740 /* Indices of image specification fields in png_format, below. */
9742 enum png_keyword_index
9744 PNG_TYPE,
9745 PNG_DATA,
9746 PNG_FILE,
9747 PNG_ASCENT,
9748 PNG_MARGIN,
9749 PNG_RELIEF,
9750 PNG_ALGORITHM,
9751 PNG_HEURISTIC_MASK,
9752 PNG_LAST
9755 /* Vector of image_keyword structures describing the format
9756 of valid user-defined image specifications. */
9758 static struct image_keyword png_format[PNG_LAST] =
9760 {":type", IMAGE_SYMBOL_VALUE, 1},
9761 {":data", IMAGE_STRING_VALUE, 0},
9762 {":file", IMAGE_STRING_VALUE, 0},
9763 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
9764 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
9765 {":relief", IMAGE_INTEGER_VALUE, 0},
9766 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
9767 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
9770 /* Structure describing the image type `png'. */
9772 static struct image_type png_type =
9774 &Qpng,
9775 png_image_p,
9776 png_load,
9777 x_clear_image,
9778 NULL
9782 /* Return non-zero if OBJECT is a valid PNG image specification. */
9784 static int
9785 png_image_p (object)
9786 Lisp_Object object;
9788 struct image_keyword fmt[PNG_LAST];
9789 bcopy (png_format, fmt, sizeof fmt);
9791 if (!parse_image_spec (object, fmt, PNG_LAST, Qpng)
9792 || (fmt[PNG_ASCENT].count
9793 && XFASTINT (fmt[PNG_ASCENT].value) > 100))
9794 return 0;
9796 /* Must specify either the :data or :file keyword. */
9797 return fmt[PNG_FILE].count + fmt[PNG_DATA].count == 1;
9801 /* Error and warning handlers installed when the PNG library
9802 is initialized. */
9804 static void
9805 my_png_error (png_ptr, msg)
9806 png_struct *png_ptr;
9807 char *msg;
9809 xassert (png_ptr != NULL);
9810 image_error ("PNG error: %s", build_string (msg), Qnil);
9811 longjmp (png_ptr->jmpbuf, 1);
9815 static void
9816 my_png_warning (png_ptr, msg)
9817 png_struct *png_ptr;
9818 char *msg;
9820 xassert (png_ptr != NULL);
9821 image_error ("PNG warning: %s", build_string (msg), Qnil);
9825 /* Memory source for PNG decoding. */
9827 struct png_memory_storage
9829 unsigned char *bytes; /* The data */
9830 size_t len; /* How big is it? */
9831 int index; /* Where are we? */
9835 /* Function set as reader function when reading PNG image from memory.
9836 PNG_PTR is a pointer to the PNG control structure. Copy LENGTH
9837 bytes from the input to DATA. */
9839 static void
9840 png_read_from_memory (png_ptr, data, length)
9841 png_structp png_ptr;
9842 png_bytep data;
9843 png_size_t length;
9845 struct png_memory_storage *tbr
9846 = (struct png_memory_storage *) png_get_io_ptr (png_ptr);
9848 if (length > tbr->len - tbr->index)
9849 png_error (png_ptr, "Read error");
9851 bcopy (tbr->bytes + tbr->index, data, length);
9852 tbr->index = tbr->index + length;
9856 /* Load PNG image IMG for use on frame F. Value is non-zero if
9857 successful. */
9859 static int
9860 png_load (f, img)
9861 struct frame *f;
9862 struct image *img;
9864 Lisp_Object file, specified_file;
9865 Lisp_Object specified_data;
9866 int x, y, i;
9867 XImage *ximg, *mask_img = NULL;
9868 struct gcpro gcpro1;
9869 png_struct *png_ptr = NULL;
9870 png_info *info_ptr = NULL, *end_info = NULL;
9871 FILE *fp = NULL;
9872 png_byte sig[8];
9873 png_byte *pixels = NULL;
9874 png_byte **rows = NULL;
9875 png_uint_32 width, height;
9876 int bit_depth, color_type, interlace_type;
9877 png_byte channels;
9878 png_uint_32 row_bytes;
9879 int transparent_p;
9880 char *gamma_str;
9881 double screen_gamma, image_gamma;
9882 int intent;
9883 struct png_memory_storage tbr; /* Data to be read */
9885 /* Find out what file to load. */
9886 specified_file = image_spec_value (img->spec, QCfile, NULL);
9887 specified_data = image_spec_value (img->spec, QCdata, NULL);
9888 file = Qnil;
9889 GCPRO1 (file);
9891 if (NILP (specified_data))
9893 file = x_find_image_file (specified_file);
9894 if (!STRINGP (file))
9896 image_error ("Cannot find image file `%s'", specified_file, Qnil);
9897 UNGCPRO;
9898 return 0;
9901 /* Open the image file. */
9902 fp = fopen (XSTRING (file)->data, "rb");
9903 if (!fp)
9905 image_error ("Cannot open image file `%s'", file, Qnil);
9906 UNGCPRO;
9907 fclose (fp);
9908 return 0;
9911 /* Check PNG signature. */
9912 if (fread (sig, 1, sizeof sig, fp) != sizeof sig
9913 || !png_check_sig (sig, sizeof sig))
9915 image_error ("Not a PNG file:` %s'", file, Qnil);
9916 UNGCPRO;
9917 fclose (fp);
9918 return 0;
9921 else
9923 /* Read from memory. */
9924 tbr.bytes = XSTRING (specified_data)->data;
9925 tbr.len = STRING_BYTES (XSTRING (specified_data));
9926 tbr.index = 0;
9928 /* Check PNG signature. */
9929 if (tbr.len < sizeof sig
9930 || !png_check_sig (tbr.bytes, sizeof sig))
9932 image_error ("Not a PNG image: `%s'", img->spec, Qnil);
9933 UNGCPRO;
9934 return 0;
9937 /* Need to skip past the signature. */
9938 tbr.bytes += sizeof (sig);
9942 /* Initialize read and info structs for PNG lib. */
9943 png_ptr = png_create_read_struct (PNG_LIBPNG_VER_STRING, NULL,
9944 my_png_error, my_png_warning);
9945 if (!png_ptr)
9947 if (fp) fclose (fp);
9948 UNGCPRO;
9949 return 0;
9952 info_ptr = png_create_info_struct (png_ptr);
9953 if (!info_ptr)
9955 png_destroy_read_struct (&png_ptr, NULL, NULL);
9956 if (fp) fclose (fp);
9957 UNGCPRO;
9958 return 0;
9961 end_info = png_create_info_struct (png_ptr);
9962 if (!end_info)
9964 png_destroy_read_struct (&png_ptr, &info_ptr, NULL);
9965 if (fp) fclose (fp);
9966 UNGCPRO;
9967 return 0;
9970 /* Set error jump-back. We come back here when the PNG library
9971 detects an error. */
9972 if (setjmp (png_ptr->jmpbuf))
9974 error:
9975 if (png_ptr)
9976 png_destroy_read_struct (&png_ptr, &info_ptr, &end_info);
9977 xfree (pixels);
9978 xfree (rows);
9979 if (fp) fclose (fp);
9980 UNGCPRO;
9981 return 0;
9984 /* Read image info. */
9985 if (!NILP (specified_data))
9986 png_set_read_fn (png_ptr, (void *) &tbr, png_read_from_memory);
9987 else
9988 png_init_io (png_ptr, fp);
9990 png_set_sig_bytes (png_ptr, sizeof sig);
9991 png_read_info (png_ptr, info_ptr);
9992 png_get_IHDR (png_ptr, info_ptr, &width, &height, &bit_depth, &color_type,
9993 &interlace_type, NULL, NULL);
9995 /* If image contains simply transparency data, we prefer to
9996 construct a clipping mask. */
9997 if (png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS))
9998 transparent_p = 1;
9999 else
10000 transparent_p = 0;
10002 /* This function is easier to write if we only have to handle
10003 one data format: RGB or RGBA with 8 bits per channel. Let's
10004 transform other formats into that format. */
10006 /* Strip more than 8 bits per channel. */
10007 if (bit_depth == 16)
10008 png_set_strip_16 (png_ptr);
10010 /* Expand data to 24 bit RGB, or 8 bit grayscale, with alpha channel
10011 if available. */
10012 png_set_expand (png_ptr);
10014 /* Convert grayscale images to RGB. */
10015 if (color_type == PNG_COLOR_TYPE_GRAY
10016 || color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
10017 png_set_gray_to_rgb (png_ptr);
10019 /* The value 2.2 is a guess for PC monitors from PNG example.c. */
10020 gamma_str = getenv ("SCREEN_GAMMA");
10021 screen_gamma = gamma_str ? atof (gamma_str) : 2.2;
10023 /* Tell the PNG lib to handle gamma correction for us. */
10025 #if defined(PNG_READ_sRGB_SUPPORTED) || defined(PNG_WRITE_sRGB_SUPPORTED)
10026 if (png_get_sRGB (png_ptr, info_ptr, &intent))
10027 /* There is a special chunk in the image specifying the gamma. */
10028 png_set_sRGB (png_ptr, info_ptr, intent);
10029 else
10030 #endif
10031 if (png_get_gAMA (png_ptr, info_ptr, &image_gamma))
10032 /* Image contains gamma information. */
10033 png_set_gamma (png_ptr, screen_gamma, image_gamma);
10034 else
10035 /* Use a default of 0.5 for the image gamma. */
10036 png_set_gamma (png_ptr, screen_gamma, 0.5);
10038 /* Handle alpha channel by combining the image with a background
10039 color. Do this only if a real alpha channel is supplied. For
10040 simple transparency, we prefer a clipping mask. */
10041 if (!transparent_p)
10043 png_color_16 *image_background;
10045 if (png_get_bKGD (png_ptr, info_ptr, &image_background))
10046 /* Image contains a background color with which to
10047 combine the image. */
10048 png_set_background (png_ptr, image_background,
10049 PNG_BACKGROUND_GAMMA_FILE, 1, 1.0);
10050 else
10052 /* Image does not contain a background color with which
10053 to combine the image data via an alpha channel. Use
10054 the frame's background instead. */
10055 XColor color;
10056 Colormap cmap;
10057 png_color_16 frame_background;
10059 BLOCK_INPUT;
10060 cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
10061 color.pixel = FRAME_BACKGROUND_PIXEL (f);
10062 XQueryColor (FRAME_W32_DISPLAY (f), cmap, &color);
10063 UNBLOCK_INPUT;
10065 bzero (&frame_background, sizeof frame_background);
10066 frame_background.red = color.red;
10067 frame_background.green = color.green;
10068 frame_background.blue = color.blue;
10070 png_set_background (png_ptr, &frame_background,
10071 PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0);
10075 /* Update info structure. */
10076 png_read_update_info (png_ptr, info_ptr);
10078 /* Get number of channels. Valid values are 1 for grayscale images
10079 and images with a palette, 2 for grayscale images with transparency
10080 information (alpha channel), 3 for RGB images, and 4 for RGB
10081 images with alpha channel, i.e. RGBA. If conversions above were
10082 sufficient we should only have 3 or 4 channels here. */
10083 channels = png_get_channels (png_ptr, info_ptr);
10084 xassert (channels == 3 || channels == 4);
10086 /* Number of bytes needed for one row of the image. */
10087 row_bytes = png_get_rowbytes (png_ptr, info_ptr);
10089 /* Allocate memory for the image. */
10090 pixels = (png_byte *) xmalloc (row_bytes * height * sizeof *pixels);
10091 rows = (png_byte **) xmalloc (height * sizeof *rows);
10092 for (i = 0; i < height; ++i)
10093 rows[i] = pixels + i * row_bytes;
10095 /* Read the entire image. */
10096 png_read_image (png_ptr, rows);
10097 png_read_end (png_ptr, info_ptr);
10098 if (fp)
10100 fclose (fp);
10101 fp = NULL;
10104 BLOCK_INPUT;
10106 /* Create the X image and pixmap. */
10107 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg,
10108 &img->pixmap))
10110 UNBLOCK_INPUT;
10111 goto error;
10114 /* Create an image and pixmap serving as mask if the PNG image
10115 contains an alpha channel. */
10116 if (channels == 4
10117 && !transparent_p
10118 && !x_create_x_image_and_pixmap (f, width, height, 1,
10119 &mask_img, &img->mask))
10121 x_destroy_x_image (ximg);
10122 XFreePixmap (FRAME_W32_DISPLAY (f), img->pixmap);
10123 img->pixmap = 0;
10124 UNBLOCK_INPUT;
10125 goto error;
10128 /* Fill the X image and mask from PNG data. */
10129 init_color_table ();
10131 for (y = 0; y < height; ++y)
10133 png_byte *p = rows[y];
10135 for (x = 0; x < width; ++x)
10137 unsigned r, g, b;
10139 r = *p++ << 8;
10140 g = *p++ << 8;
10141 b = *p++ << 8;
10142 XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b));
10144 /* An alpha channel, aka mask channel, associates variable
10145 transparency with an image. Where other image formats
10146 support binary transparency---fully transparent or fully
10147 opaque---PNG allows up to 254 levels of partial transparency.
10148 The PNG library implements partial transparency by combining
10149 the image with a specified background color.
10151 I'm not sure how to handle this here nicely: because the
10152 background on which the image is displayed may change, for
10153 real alpha channel support, it would be necessary to create
10154 a new image for each possible background.
10156 What I'm doing now is that a mask is created if we have
10157 boolean transparency information. Otherwise I'm using
10158 the frame's background color to combine the image with. */
10160 if (channels == 4)
10162 if (mask_img)
10163 XPutPixel (mask_img, x, y, *p > 0);
10164 ++p;
10169 /* Remember colors allocated for this image. */
10170 img->colors = colors_in_color_table (&img->ncolors);
10171 free_color_table ();
10173 /* Clean up. */
10174 png_destroy_read_struct (&png_ptr, &info_ptr, &end_info);
10175 xfree (rows);
10176 xfree (pixels);
10178 img->width = width;
10179 img->height = height;
10181 /* Put the image into the pixmap, then free the X image and its buffer. */
10182 x_put_x_image (f, ximg, img->pixmap, width, height);
10183 x_destroy_x_image (ximg);
10185 /* Same for the mask. */
10186 if (mask_img)
10188 x_put_x_image (f, mask_img, img->mask, img->width, img->height);
10189 x_destroy_x_image (mask_img);
10192 UNBLOCK_INPUT;
10193 UNGCPRO;
10194 return 1;
10197 #endif /* HAVE_PNG != 0 */
10201 /***********************************************************************
10202 JPEG
10203 ***********************************************************************/
10205 #if HAVE_JPEG
10207 /* Work around a warning about HAVE_STDLIB_H being redefined in
10208 jconfig.h. */
10209 #ifdef HAVE_STDLIB_H
10210 #define HAVE_STDLIB_H_1
10211 #undef HAVE_STDLIB_H
10212 #endif /* HAVE_STLIB_H */
10214 #include <jpeglib.h>
10215 #include <jerror.h>
10216 #include <setjmp.h>
10218 #ifdef HAVE_STLIB_H_1
10219 #define HAVE_STDLIB_H 1
10220 #endif
10222 static int jpeg_image_p P_ ((Lisp_Object object));
10223 static int jpeg_load P_ ((struct frame *f, struct image *img));
10225 /* The symbol `jpeg' identifying images of this type. */
10227 Lisp_Object Qjpeg;
10229 /* Indices of image specification fields in gs_format, below. */
10231 enum jpeg_keyword_index
10233 JPEG_TYPE,
10234 JPEG_DATA,
10235 JPEG_FILE,
10236 JPEG_ASCENT,
10237 JPEG_MARGIN,
10238 JPEG_RELIEF,
10239 JPEG_ALGORITHM,
10240 JPEG_HEURISTIC_MASK,
10241 JPEG_LAST
10244 /* Vector of image_keyword structures describing the format
10245 of valid user-defined image specifications. */
10247 static struct image_keyword jpeg_format[JPEG_LAST] =
10249 {":type", IMAGE_SYMBOL_VALUE, 1},
10250 {":data", IMAGE_STRING_VALUE, 0},
10251 {":file", IMAGE_STRING_VALUE, 0},
10252 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
10253 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
10254 {":relief", IMAGE_INTEGER_VALUE, 0},
10255 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10256 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
10259 /* Structure describing the image type `jpeg'. */
10261 static struct image_type jpeg_type =
10263 &Qjpeg,
10264 jpeg_image_p,
10265 jpeg_load,
10266 x_clear_image,
10267 NULL
10271 /* Return non-zero if OBJECT is a valid JPEG image specification. */
10273 static int
10274 jpeg_image_p (object)
10275 Lisp_Object object;
10277 struct image_keyword fmt[JPEG_LAST];
10279 bcopy (jpeg_format, fmt, sizeof fmt);
10281 if (!parse_image_spec (object, fmt, JPEG_LAST, Qjpeg)
10282 || (fmt[JPEG_ASCENT].count
10283 && XFASTINT (fmt[JPEG_ASCENT].value) > 100))
10284 return 0;
10286 /* Must specify either the :data or :file keyword. */
10287 return fmt[JPEG_FILE].count + fmt[JPEG_DATA].count == 1;
10291 struct my_jpeg_error_mgr
10293 struct jpeg_error_mgr pub;
10294 jmp_buf setjmp_buffer;
10297 static void
10298 my_error_exit (cinfo)
10299 j_common_ptr cinfo;
10301 struct my_jpeg_error_mgr *mgr = (struct my_jpeg_error_mgr *) cinfo->err;
10302 longjmp (mgr->setjmp_buffer, 1);
10306 /* Init source method for JPEG data source manager. Called by
10307 jpeg_read_header() before any data is actually read. See
10308 libjpeg.doc from the JPEG lib distribution. */
10310 static void
10311 our_init_source (cinfo)
10312 j_decompress_ptr cinfo;
10317 /* Fill input buffer method for JPEG data source manager. Called
10318 whenever more data is needed. We read the whole image in one step,
10319 so this only adds a fake end of input marker at the end. */
10321 static boolean
10322 our_fill_input_buffer (cinfo)
10323 j_decompress_ptr cinfo;
10325 /* Insert a fake EOI marker. */
10326 struct jpeg_source_mgr *src = cinfo->src;
10327 static JOCTET buffer[2];
10329 buffer[0] = (JOCTET) 0xFF;
10330 buffer[1] = (JOCTET) JPEG_EOI;
10332 src->next_input_byte = buffer;
10333 src->bytes_in_buffer = 2;
10334 return TRUE;
10338 /* Method to skip over NUM_BYTES bytes in the image data. CINFO->src
10339 is the JPEG data source manager. */
10341 static void
10342 our_skip_input_data (cinfo, num_bytes)
10343 j_decompress_ptr cinfo;
10344 long num_bytes;
10346 struct jpeg_source_mgr *src = (struct jpeg_source_mgr *) cinfo->src;
10348 if (src)
10350 if (num_bytes > src->bytes_in_buffer)
10351 ERREXIT (cinfo, JERR_INPUT_EOF);
10353 src->bytes_in_buffer -= num_bytes;
10354 src->next_input_byte += num_bytes;
10359 /* Method to terminate data source. Called by
10360 jpeg_finish_decompress() after all data has been processed. */
10362 static void
10363 our_term_source (cinfo)
10364 j_decompress_ptr cinfo;
10369 /* Set up the JPEG lib for reading an image from DATA which contains
10370 LEN bytes. CINFO is the decompression info structure created for
10371 reading the image. */
10373 static void
10374 jpeg_memory_src (cinfo, data, len)
10375 j_decompress_ptr cinfo;
10376 JOCTET *data;
10377 unsigned int len;
10379 struct jpeg_source_mgr *src;
10381 if (cinfo->src == NULL)
10383 /* First time for this JPEG object? */
10384 cinfo->src = (struct jpeg_source_mgr *)
10385 (*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT,
10386 sizeof (struct jpeg_source_mgr));
10387 src = (struct jpeg_source_mgr *) cinfo->src;
10388 src->next_input_byte = data;
10391 src = (struct jpeg_source_mgr *) cinfo->src;
10392 src->init_source = our_init_source;
10393 src->fill_input_buffer = our_fill_input_buffer;
10394 src->skip_input_data = our_skip_input_data;
10395 src->resync_to_restart = jpeg_resync_to_restart; /* Use default method. */
10396 src->term_source = our_term_source;
10397 src->bytes_in_buffer = len;
10398 src->next_input_byte = data;
10402 /* Load image IMG for use on frame F. Patterned after example.c
10403 from the JPEG lib. */
10405 static int
10406 jpeg_load (f, img)
10407 struct frame *f;
10408 struct image *img;
10410 struct jpeg_decompress_struct cinfo;
10411 struct my_jpeg_error_mgr mgr;
10412 Lisp_Object file, specified_file;
10413 Lisp_Object specified_data;
10414 FILE *fp = NULL;
10415 JSAMPARRAY buffer;
10416 int row_stride, x, y;
10417 XImage *ximg = NULL;
10418 int rc;
10419 unsigned long *colors;
10420 int width, height;
10421 struct gcpro gcpro1;
10423 /* Open the JPEG file. */
10424 specified_file = image_spec_value (img->spec, QCfile, NULL);
10425 specified_data = image_spec_value (img->spec, QCdata, NULL);
10426 file = Qnil;
10427 GCPRO1 (file);
10430 if (NILP (specified_data))
10432 file = x_find_image_file (specified_file);
10433 if (!STRINGP (file))
10435 image_error ("Cannot find image file `%s'", specified_file, Qnil);
10436 UNGCPRO;
10437 return 0;
10440 fp = fopen (XSTRING (file)->data, "r");
10441 if (fp == NULL)
10443 image_error ("Cannot open `%s'", file, Qnil);
10444 UNGCPRO;
10445 return 0;
10449 /* Customize libjpeg's error handling to call my_error_exit when an
10450 error is detected. This function will perform a longjmp. */
10451 mgr.pub.error_exit = my_error_exit;
10452 cinfo.err = jpeg_std_error (&mgr.pub);
10454 if ((rc = setjmp (mgr.setjmp_buffer)) != 0)
10456 if (rc == 1)
10458 /* Called from my_error_exit. Display a JPEG error. */
10459 char buffer[JMSG_LENGTH_MAX];
10460 cinfo.err->format_message ((j_common_ptr) &cinfo, buffer);
10461 image_error ("Error reading JPEG image `%s': %s", img->spec,
10462 build_string (buffer));
10465 /* Close the input file and destroy the JPEG object. */
10466 if (fp)
10467 fclose (fp);
10468 jpeg_destroy_decompress (&cinfo);
10470 BLOCK_INPUT;
10472 /* If we already have an XImage, free that. */
10473 x_destroy_x_image (ximg);
10475 /* Free pixmap and colors. */
10476 x_clear_image (f, img);
10478 UNBLOCK_INPUT;
10479 UNGCPRO;
10480 return 0;
10483 /* Create the JPEG decompression object. Let it read from fp.
10484 Read the JPEG image header. */
10485 jpeg_create_decompress (&cinfo);
10487 if (NILP (specified_data))
10488 jpeg_stdio_src (&cinfo, fp);
10489 else
10490 jpeg_memory_src (&cinfo, XSTRING (specified_data)->data,
10491 STRING_BYTES (XSTRING (specified_data)));
10493 jpeg_read_header (&cinfo, TRUE);
10495 /* Customize decompression so that color quantization will be used.
10496 Start decompression. */
10497 cinfo.quantize_colors = TRUE;
10498 jpeg_start_decompress (&cinfo);
10499 width = img->width = cinfo.output_width;
10500 height = img->height = cinfo.output_height;
10502 BLOCK_INPUT;
10504 /* Create X image and pixmap. */
10505 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg,
10506 &img->pixmap))
10508 UNBLOCK_INPUT;
10509 longjmp (mgr.setjmp_buffer, 2);
10512 /* Allocate colors. When color quantization is used,
10513 cinfo.actual_number_of_colors has been set with the number of
10514 colors generated, and cinfo.colormap is a two-dimensional array
10515 of color indices in the range 0..cinfo.actual_number_of_colors.
10516 No more than 255 colors will be generated. */
10518 int i, ir, ig, ib;
10520 if (cinfo.out_color_components > 2)
10521 ir = 0, ig = 1, ib = 2;
10522 else if (cinfo.out_color_components > 1)
10523 ir = 0, ig = 1, ib = 0;
10524 else
10525 ir = 0, ig = 0, ib = 0;
10527 /* Use the color table mechanism because it handles colors that
10528 cannot be allocated nicely. Such colors will be replaced with
10529 a default color, and we don't have to care about which colors
10530 can be freed safely, and which can't. */
10531 init_color_table ();
10532 colors = (unsigned long *) alloca (cinfo.actual_number_of_colors
10533 * sizeof *colors);
10535 for (i = 0; i < cinfo.actual_number_of_colors; ++i)
10537 /* Multiply RGB values with 255 because X expects RGB values
10538 in the range 0..0xffff. */
10539 int r = cinfo.colormap[ir][i] << 8;
10540 int g = cinfo.colormap[ig][i] << 8;
10541 int b = cinfo.colormap[ib][i] << 8;
10542 colors[i] = lookup_rgb_color (f, r, g, b);
10545 /* Remember those colors actually allocated. */
10546 img->colors = colors_in_color_table (&img->ncolors);
10547 free_color_table ();
10550 /* Read pixels. */
10551 row_stride = width * cinfo.output_components;
10552 buffer = cinfo.mem->alloc_sarray ((j_common_ptr) &cinfo, JPOOL_IMAGE,
10553 row_stride, 1);
10554 for (y = 0; y < height; ++y)
10556 jpeg_read_scanlines (&cinfo, buffer, 1);
10557 for (x = 0; x < cinfo.output_width; ++x)
10558 XPutPixel (ximg, x, y, colors[buffer[0][x]]);
10561 /* Clean up. */
10562 jpeg_finish_decompress (&cinfo);
10563 jpeg_destroy_decompress (&cinfo);
10564 if (fp)
10565 fclose (fp);
10567 /* Put the image into the pixmap. */
10568 x_put_x_image (f, ximg, img->pixmap, width, height);
10569 x_destroy_x_image (ximg);
10570 UNBLOCK_INPUT;
10571 UNGCPRO;
10572 return 1;
10575 #endif /* HAVE_JPEG */
10579 /***********************************************************************
10580 TIFF
10581 ***********************************************************************/
10583 #if HAVE_TIFF
10585 #include <tiffio.h>
10587 static int tiff_image_p P_ ((Lisp_Object object));
10588 static int tiff_load P_ ((struct frame *f, struct image *img));
10590 /* The symbol `tiff' identifying images of this type. */
10592 Lisp_Object Qtiff;
10594 /* Indices of image specification fields in tiff_format, below. */
10596 enum tiff_keyword_index
10598 TIFF_TYPE,
10599 TIFF_DATA,
10600 TIFF_FILE,
10601 TIFF_ASCENT,
10602 TIFF_MARGIN,
10603 TIFF_RELIEF,
10604 TIFF_ALGORITHM,
10605 TIFF_HEURISTIC_MASK,
10606 TIFF_LAST
10609 /* Vector of image_keyword structures describing the format
10610 of valid user-defined image specifications. */
10612 static struct image_keyword tiff_format[TIFF_LAST] =
10614 {":type", IMAGE_SYMBOL_VALUE, 1},
10615 {":data", IMAGE_STRING_VALUE, 0},
10616 {":file", IMAGE_STRING_VALUE, 0},
10617 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
10618 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
10619 {":relief", IMAGE_INTEGER_VALUE, 0},
10620 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10621 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
10624 /* Structure describing the image type `tiff'. */
10626 static struct image_type tiff_type =
10628 &Qtiff,
10629 tiff_image_p,
10630 tiff_load,
10631 x_clear_image,
10632 NULL
10636 /* Return non-zero if OBJECT is a valid TIFF image specification. */
10638 static int
10639 tiff_image_p (object)
10640 Lisp_Object object;
10642 struct image_keyword fmt[TIFF_LAST];
10643 bcopy (tiff_format, fmt, sizeof fmt);
10645 if (!parse_image_spec (object, fmt, TIFF_LAST, Qtiff)
10646 || (fmt[TIFF_ASCENT].count
10647 && XFASTINT (fmt[TIFF_ASCENT].value) > 100))
10648 return 0;
10650 /* Must specify either the :data or :file keyword. */
10651 return fmt[TIFF_FILE].count + fmt[TIFF_DATA].count == 1;
10655 /* Reading from a memory buffer for TIFF images Based on the PNG
10656 memory source, but we have to provide a lot of extra functions.
10657 Blah.
10659 We really only need to implement read and seek, but I am not
10660 convinced that the TIFF library is smart enough not to destroy
10661 itself if we only hand it the function pointers we need to
10662 override. */
10664 typedef struct
10666 unsigned char *bytes;
10667 size_t len;
10668 int index;
10670 tiff_memory_source;
10672 static size_t
10673 tiff_read_from_memory (data, buf, size)
10674 thandle_t data;
10675 tdata_t buf;
10676 tsize_t size;
10678 tiff_memory_source *src = (tiff_memory_source *) data;
10680 if (size > src->len - src->index)
10681 return (size_t) -1;
10682 bcopy (src->bytes + src->index, buf, size);
10683 src->index += size;
10684 return size;
10687 static size_t
10688 tiff_write_from_memory (data, buf, size)
10689 thandle_t data;
10690 tdata_t buf;
10691 tsize_t size;
10693 return (size_t) -1;
10696 static toff_t
10697 tiff_seek_in_memory (data, off, whence)
10698 thandle_t data;
10699 toff_t off;
10700 int whence;
10702 tiff_memory_source *src = (tiff_memory_source *) data;
10703 int idx;
10705 switch (whence)
10707 case SEEK_SET: /* Go from beginning of source. */
10708 idx = off;
10709 break;
10711 case SEEK_END: /* Go from end of source. */
10712 idx = src->len + off;
10713 break;
10715 case SEEK_CUR: /* Go from current position. */
10716 idx = src->index + off;
10717 break;
10719 default: /* Invalid `whence'. */
10720 return -1;
10723 if (idx > src->len || idx < 0)
10724 return -1;
10726 src->index = idx;
10727 return src->index;
10730 static int
10731 tiff_close_memory (data)
10732 thandle_t data;
10734 /* NOOP */
10735 return 0;
10738 static int
10739 tiff_mmap_memory (data, pbase, psize)
10740 thandle_t data;
10741 tdata_t *pbase;
10742 toff_t *psize;
10744 /* It is already _IN_ memory. */
10745 return 0;
10748 static void
10749 tiff_unmap_memory (data, base, size)
10750 thandle_t data;
10751 tdata_t base;
10752 toff_t size;
10754 /* We don't need to do this. */
10757 static toff_t
10758 tiff_size_of_memory (data)
10759 thandle_t data;
10761 return ((tiff_memory_source *) data)->len;
10765 /* Load TIFF image IMG for use on frame F. Value is non-zero if
10766 successful. */
10768 static int
10769 tiff_load (f, img)
10770 struct frame *f;
10771 struct image *img;
10773 Lisp_Object file, specified_file;
10774 Lisp_Object specified_data;
10775 TIFF *tiff;
10776 int width, height, x, y;
10777 uint32 *buf;
10778 int rc;
10779 XImage *ximg;
10780 struct gcpro gcpro1;
10781 tiff_memory_source memsrc;
10783 specified_file = image_spec_value (img->spec, QCfile, NULL);
10784 specified_data = image_spec_value (img->spec, QCdata, NULL);
10785 file = Qnil;
10786 GCPRO1 (file);
10788 if (NILP (specified_data))
10790 /* Read from a file */
10791 file = x_find_image_file (specified_file);
10792 if (!STRINGP (file))
10794 image_error ("Cannot find image file `%s'", file, Qnil);
10795 UNGCPRO;
10796 return 0;
10799 /* Try to open the image file. */
10800 tiff = TIFFOpen (XSTRING (file)->data, "r");
10801 if (tiff == NULL)
10803 image_error ("Cannot open `%s'", file, Qnil);
10804 UNGCPRO;
10805 return 0;
10808 else
10810 /* Memory source! */
10811 memsrc.bytes = XSTRING (specified_data)->data;
10812 memsrc.len = STRING_BYTES (XSTRING (specified_data));
10813 memsrc.index = 0;
10815 tiff = TIFFClientOpen ("memory_source", "r", &memsrc,
10816 (TIFFReadWriteProc) tiff_read_from_memory,
10817 (TIFFReadWriteProc) tiff_write_from_memory,
10818 tiff_seek_in_memory,
10819 tiff_close_memory,
10820 tiff_size_of_memory,
10821 tiff_mmap_memory,
10822 tiff_unmap_memory);
10824 if (!tiff)
10826 image_error ("Cannot open memory source for `%s'", img->spec, Qnil);
10827 UNGCPRO;
10828 return 0;
10832 /* Get width and height of the image, and allocate a raster buffer
10833 of width x height 32-bit values. */
10834 TIFFGetField (tiff, TIFFTAG_IMAGEWIDTH, &width);
10835 TIFFGetField (tiff, TIFFTAG_IMAGELENGTH, &height);
10836 buf = (uint32 *) xmalloc (width * height * sizeof *buf);
10838 rc = TIFFReadRGBAImage (tiff, width, height, buf, 0);
10839 TIFFClose (tiff);
10840 if (!rc)
10842 image_error ("Error reading TIFF image `%s'", img->spec, Qnil);
10843 xfree (buf);
10844 UNGCPRO;
10845 return 0;
10848 BLOCK_INPUT;
10850 /* Create the X image and pixmap. */
10851 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
10853 UNBLOCK_INPUT;
10854 xfree (buf);
10855 UNGCPRO;
10856 return 0;
10859 /* Initialize the color table. */
10860 init_color_table ();
10862 /* Process the pixel raster. Origin is in the lower-left corner. */
10863 for (y = 0; y < height; ++y)
10865 uint32 *row = buf + y * width;
10867 for (x = 0; x < width; ++x)
10869 uint32 abgr = row[x];
10870 int r = TIFFGetR (abgr) << 8;
10871 int g = TIFFGetG (abgr) << 8;
10872 int b = TIFFGetB (abgr) << 8;
10873 XPutPixel (ximg, x, height - 1 - y, lookup_rgb_color (f, r, g, b));
10877 /* Remember the colors allocated for the image. Free the color table. */
10878 img->colors = colors_in_color_table (&img->ncolors);
10879 free_color_table ();
10881 /* Put the image into the pixmap, then free the X image and its buffer. */
10882 x_put_x_image (f, ximg, img->pixmap, width, height);
10883 x_destroy_x_image (ximg);
10884 xfree (buf);
10885 UNBLOCK_INPUT;
10887 img->width = width;
10888 img->height = height;
10890 UNGCPRO;
10891 return 1;
10894 #endif /* HAVE_TIFF != 0 */
10898 /***********************************************************************
10900 ***********************************************************************/
10902 #if HAVE_GIF
10904 #include <gif_lib.h>
10906 static int gif_image_p P_ ((Lisp_Object object));
10907 static int gif_load P_ ((struct frame *f, struct image *img));
10909 /* The symbol `gif' identifying images of this type. */
10911 Lisp_Object Qgif;
10913 /* Indices of image specification fields in gif_format, below. */
10915 enum gif_keyword_index
10917 GIF_TYPE,
10918 GIF_DATA,
10919 GIF_FILE,
10920 GIF_ASCENT,
10921 GIF_MARGIN,
10922 GIF_RELIEF,
10923 GIF_ALGORITHM,
10924 GIF_HEURISTIC_MASK,
10925 GIF_IMAGE,
10926 GIF_LAST
10929 /* Vector of image_keyword structures describing the format
10930 of valid user-defined image specifications. */
10932 static struct image_keyword gif_format[GIF_LAST] =
10934 {":type", IMAGE_SYMBOL_VALUE, 1},
10935 {":data", IMAGE_STRING_VALUE, 0},
10936 {":file", IMAGE_STRING_VALUE, 0},
10937 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
10938 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
10939 {":relief", IMAGE_INTEGER_VALUE, 0},
10940 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10941 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10942 {":image", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}
10945 /* Structure describing the image type `gif'. */
10947 static struct image_type gif_type =
10949 &Qgif,
10950 gif_image_p,
10951 gif_load,
10952 x_clear_image,
10953 NULL
10956 /* Return non-zero if OBJECT is a valid GIF image specification. */
10958 static int
10959 gif_image_p (object)
10960 Lisp_Object object;
10962 struct image_keyword fmt[GIF_LAST];
10963 bcopy (gif_format, fmt, sizeof fmt);
10965 if (!parse_image_spec (object, fmt, GIF_LAST, Qgif)
10966 || (fmt[GIF_ASCENT].count
10967 && XFASTINT (fmt[GIF_ASCENT].value) > 100))
10968 return 0;
10970 /* Must specify either the :data or :file keyword. */
10971 return fmt[GIF_FILE].count + fmt[GIF_DATA].count == 1;
10974 /* Reading a GIF image from memory
10975 Based on the PNG memory stuff to a certain extent. */
10977 typedef struct
10979 unsigned char *bytes;
10980 size_t len;
10981 int index;
10983 gif_memory_source;
10985 /* Make the current memory source available to gif_read_from_memory.
10986 It's done this way because not all versions of libungif support
10987 a UserData field in the GifFileType structure. */
10988 static gif_memory_source *current_gif_memory_src;
10990 static int
10991 gif_read_from_memory (file, buf, len)
10992 GifFileType *file;
10993 GifByteType *buf;
10994 int len;
10996 gif_memory_source *src = current_gif_memory_src;
10998 if (len > src->len - src->index)
10999 return -1;
11001 bcopy (src->bytes + src->index, buf, len);
11002 src->index += len;
11003 return len;
11007 /* Load GIF image IMG for use on frame F. Value is non-zero if
11008 successful. */
11010 static int
11011 gif_load (f, img)
11012 struct frame *f;
11013 struct image *img;
11015 Lisp_Object file, specified_file;
11016 Lisp_Object specified_data;
11017 int rc, width, height, x, y, i;
11018 XImage *ximg;
11019 ColorMapObject *gif_color_map;
11020 unsigned long pixel_colors[256];
11021 GifFileType *gif;
11022 struct gcpro gcpro1;
11023 Lisp_Object image;
11024 int ino, image_left, image_top, image_width, image_height;
11025 gif_memory_source memsrc;
11026 unsigned char *raster;
11028 specified_file = image_spec_value (img->spec, QCfile, NULL);
11029 specified_data = image_spec_value (img->spec, QCdata, NULL);
11030 file = Qnil;
11032 if (NILP (specified_data))
11034 file = x_find_image_file (specified_file);
11035 GCPRO1 (file);
11036 if (!STRINGP (file))
11038 image_error ("Cannot find image file `%s'", specified_file, Qnil);
11039 UNGCPRO;
11040 return 0;
11043 /* Open the GIF file. */
11044 gif = DGifOpenFileName (XSTRING (file)->data);
11045 if (gif == NULL)
11047 image_error ("Cannot open `%s'", file, Qnil);
11048 UNGCPRO;
11049 return 0;
11052 else
11054 /* Read from memory! */
11055 current_gif_memory_src = &memsrc;
11056 memsrc.bytes = XSTRING (specified_data)->data;
11057 memsrc.len = STRING_BYTES (XSTRING (specified_data));
11058 memsrc.index = 0;
11060 gif = DGifOpen(&memsrc, gif_read_from_memory);
11061 if (!gif)
11063 image_error ("Cannot open memory source `%s'", img->spec, Qnil);
11064 UNGCPRO;
11065 return 0;
11069 /* Read entire contents. */
11070 rc = DGifSlurp (gif);
11071 if (rc == GIF_ERROR)
11073 image_error ("Error reading `%s'", img->spec, Qnil);
11074 DGifCloseFile (gif);
11075 UNGCPRO;
11076 return 0;
11079 image = image_spec_value (img->spec, QCindex, NULL);
11080 ino = INTEGERP (image) ? XFASTINT (image) : 0;
11081 if (ino >= gif->ImageCount)
11083 image_error ("Invalid image number `%s' in image `%s'",
11084 image, img->spec);
11085 DGifCloseFile (gif);
11086 UNGCPRO;
11087 return 0;
11090 width = img->width = gif->SWidth;
11091 height = img->height = gif->SHeight;
11093 BLOCK_INPUT;
11095 /* Create the X image and pixmap. */
11096 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
11098 UNBLOCK_INPUT;
11099 DGifCloseFile (gif);
11100 UNGCPRO;
11101 return 0;
11104 /* Allocate colors. */
11105 gif_color_map = gif->SavedImages[ino].ImageDesc.ColorMap;
11106 if (!gif_color_map)
11107 gif_color_map = gif->SColorMap;
11108 init_color_table ();
11109 bzero (pixel_colors, sizeof pixel_colors);
11111 for (i = 0; i < gif_color_map->ColorCount; ++i)
11113 int r = gif_color_map->Colors[i].Red << 8;
11114 int g = gif_color_map->Colors[i].Green << 8;
11115 int b = gif_color_map->Colors[i].Blue << 8;
11116 pixel_colors[i] = lookup_rgb_color (f, r, g, b);
11119 img->colors = colors_in_color_table (&img->ncolors);
11120 free_color_table ();
11122 /* Clear the part of the screen image that are not covered by
11123 the image from the GIF file. Full animated GIF support
11124 requires more than can be done here (see the gif89 spec,
11125 disposal methods). Let's simply assume that the part
11126 not covered by a sub-image is in the frame's background color. */
11127 image_top = gif->SavedImages[ino].ImageDesc.Top;
11128 image_left = gif->SavedImages[ino].ImageDesc.Left;
11129 image_width = gif->SavedImages[ino].ImageDesc.Width;
11130 image_height = gif->SavedImages[ino].ImageDesc.Height;
11132 for (y = 0; y < image_top; ++y)
11133 for (x = 0; x < width; ++x)
11134 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11136 for (y = image_top + image_height; y < height; ++y)
11137 for (x = 0; x < width; ++x)
11138 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11140 for (y = image_top; y < image_top + image_height; ++y)
11142 for (x = 0; x < image_left; ++x)
11143 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11144 for (x = image_left + image_width; x < width; ++x)
11145 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11148 /* Read the GIF image into the X image. We use a local variable
11149 `raster' here because RasterBits below is a char *, and invites
11150 problems with bytes >= 0x80. */
11151 raster = (unsigned char *) gif->SavedImages[ino].RasterBits;
11153 if (gif->SavedImages[ino].ImageDesc.Interlace)
11155 static int interlace_start[] = {0, 4, 2, 1};
11156 static int interlace_increment[] = {8, 8, 4, 2};
11157 int pass, inc;
11158 int row = interlace_start[0];
11160 pass = 0;
11162 for (y = 0; y < image_height; y++)
11164 if (row >= image_height)
11166 row = interlace_start[++pass];
11167 while (row >= image_height)
11168 row = interlace_start[++pass];
11171 for (x = 0; x < image_width; x++)
11173 int i = raster[(y * image_width) + x];
11174 XPutPixel (ximg, x + image_left, row + image_top,
11175 pixel_colors[i]);
11178 row += interlace_increment[pass];
11181 else
11183 for (y = 0; y < image_height; ++y)
11184 for (x = 0; x < image_width; ++x)
11186 int i = raster[y* image_width + x];
11187 XPutPixel (ximg, x + image_left, y + image_top, pixel_colors[i]);
11191 DGifCloseFile (gif);
11193 /* Put the image into the pixmap, then free the X image and its buffer. */
11194 x_put_x_image (f, ximg, img->pixmap, width, height);
11195 x_destroy_x_image (ximg);
11196 UNBLOCK_INPUT;
11198 UNGCPRO;
11199 return 1;
11202 #endif /* HAVE_GIF != 0 */
11206 /***********************************************************************
11207 Ghostscript
11208 ***********************************************************************/
11210 #ifdef HAVE_GHOSTSCRIPT
11211 static int gs_image_p P_ ((Lisp_Object object));
11212 static int gs_load P_ ((struct frame *f, struct image *img));
11213 static void gs_clear_image P_ ((struct frame *f, struct image *img));
11215 /* The symbol `postscript' identifying images of this type. */
11217 Lisp_Object Qpostscript;
11219 /* Keyword symbols. */
11221 Lisp_Object QCloader, QCbounding_box, QCpt_width, QCpt_height;
11223 /* Indices of image specification fields in gs_format, below. */
11225 enum gs_keyword_index
11227 GS_TYPE,
11228 GS_PT_WIDTH,
11229 GS_PT_HEIGHT,
11230 GS_FILE,
11231 GS_LOADER,
11232 GS_BOUNDING_BOX,
11233 GS_ASCENT,
11234 GS_MARGIN,
11235 GS_RELIEF,
11236 GS_ALGORITHM,
11237 GS_HEURISTIC_MASK,
11238 GS_LAST
11241 /* Vector of image_keyword structures describing the format
11242 of valid user-defined image specifications. */
11244 static struct image_keyword gs_format[GS_LAST] =
11246 {":type", IMAGE_SYMBOL_VALUE, 1},
11247 {":pt-width", IMAGE_POSITIVE_INTEGER_VALUE, 1},
11248 {":pt-height", IMAGE_POSITIVE_INTEGER_VALUE, 1},
11249 {":file", IMAGE_STRING_VALUE, 1},
11250 {":loader", IMAGE_FUNCTION_VALUE, 0},
11251 {":bounding-box", IMAGE_DONT_CHECK_VALUE_TYPE, 1},
11252 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
11253 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
11254 {":relief", IMAGE_INTEGER_VALUE, 0},
11255 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
11256 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
11259 /* Structure describing the image type `ghostscript'. */
11261 static struct image_type gs_type =
11263 &Qpostscript,
11264 gs_image_p,
11265 gs_load,
11266 gs_clear_image,
11267 NULL
11271 /* Free X resources of Ghostscript image IMG which is used on frame F. */
11273 static void
11274 gs_clear_image (f, img)
11275 struct frame *f;
11276 struct image *img;
11278 /* IMG->data.ptr_val may contain a recorded colormap. */
11279 xfree (img->data.ptr_val);
11280 x_clear_image (f, img);
11284 /* Return non-zero if OBJECT is a valid Ghostscript image
11285 specification. */
11287 static int
11288 gs_image_p (object)
11289 Lisp_Object object;
11291 struct image_keyword fmt[GS_LAST];
11292 Lisp_Object tem;
11293 int i;
11295 bcopy (gs_format, fmt, sizeof fmt);
11297 if (!parse_image_spec (object, fmt, GS_LAST, Qpostscript)
11298 || (fmt[GS_ASCENT].count
11299 && XFASTINT (fmt[GS_ASCENT].value) > 100))
11300 return 0;
11302 /* Bounding box must be a list or vector containing 4 integers. */
11303 tem = fmt[GS_BOUNDING_BOX].value;
11304 if (CONSP (tem))
11306 for (i = 0; i < 4; ++i, tem = XCDR (tem))
11307 if (!CONSP (tem) || !INTEGERP (XCAR (tem)))
11308 return 0;
11309 if (!NILP (tem))
11310 return 0;
11312 else if (VECTORP (tem))
11314 if (XVECTOR (tem)->size != 4)
11315 return 0;
11316 for (i = 0; i < 4; ++i)
11317 if (!INTEGERP (XVECTOR (tem)->contents[i]))
11318 return 0;
11320 else
11321 return 0;
11323 return 1;
11327 /* Load Ghostscript image IMG for use on frame F. Value is non-zero
11328 if successful. */
11330 static int
11331 gs_load (f, img)
11332 struct frame *f;
11333 struct image *img;
11335 char buffer[100];
11336 Lisp_Object window_and_pixmap_id = Qnil, loader, pt_height, pt_width;
11337 struct gcpro gcpro1, gcpro2;
11338 Lisp_Object frame;
11339 double in_width, in_height;
11340 Lisp_Object pixel_colors = Qnil;
11342 /* Compute pixel size of pixmap needed from the given size in the
11343 image specification. Sizes in the specification are in pt. 1 pt
11344 = 1/72 in, xdpi and ydpi are stored in the frame's X display
11345 info. */
11346 pt_width = image_spec_value (img->spec, QCpt_width, NULL);
11347 in_width = XFASTINT (pt_width) / 72.0;
11348 img->width = in_width * FRAME_W32_DISPLAY_INFO (f)->resx;
11349 pt_height = image_spec_value (img->spec, QCpt_height, NULL);
11350 in_height = XFASTINT (pt_height) / 72.0;
11351 img->height = in_height * FRAME_W32_DISPLAY_INFO (f)->resy;
11353 /* Create the pixmap. */
11354 BLOCK_INPUT;
11355 xassert (img->pixmap == 0);
11356 img->pixmap = XCreatePixmap (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
11357 img->width, img->height,
11358 DefaultDepthOfScreen (FRAME_X_SCREEN (f)));
11359 UNBLOCK_INPUT;
11361 if (!img->pixmap)
11363 image_error ("Unable to create pixmap for `%s'", img->spec, Qnil);
11364 return 0;
11367 /* Call the loader to fill the pixmap. It returns a process object
11368 if successful. We do not record_unwind_protect here because
11369 other places in redisplay like calling window scroll functions
11370 don't either. Let the Lisp loader use `unwind-protect' instead. */
11371 GCPRO2 (window_and_pixmap_id, pixel_colors);
11373 sprintf (buffer, "%lu %lu",
11374 (unsigned long) FRAME_W32_WINDOW (f),
11375 (unsigned long) img->pixmap);
11376 window_and_pixmap_id = build_string (buffer);
11378 sprintf (buffer, "%lu %lu",
11379 FRAME_FOREGROUND_PIXEL (f),
11380 FRAME_BACKGROUND_PIXEL (f));
11381 pixel_colors = build_string (buffer);
11383 XSETFRAME (frame, f);
11384 loader = image_spec_value (img->spec, QCloader, NULL);
11385 if (NILP (loader))
11386 loader = intern ("gs-load-image");
11388 img->data.lisp_val = call6 (loader, frame, img->spec,
11389 make_number (img->width),
11390 make_number (img->height),
11391 window_and_pixmap_id,
11392 pixel_colors);
11393 UNGCPRO;
11394 return PROCESSP (img->data.lisp_val);
11398 /* Kill the Ghostscript process that was started to fill PIXMAP on
11399 frame F. Called from XTread_socket when receiving an event
11400 telling Emacs that Ghostscript has finished drawing. */
11402 void
11403 x_kill_gs_process (pixmap, f)
11404 Pixmap pixmap;
11405 struct frame *f;
11407 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
11408 int class, i;
11409 struct image *img;
11411 /* Find the image containing PIXMAP. */
11412 for (i = 0; i < c->used; ++i)
11413 if (c->images[i]->pixmap == pixmap)
11414 break;
11416 /* Kill the GS process. We should have found PIXMAP in the image
11417 cache and its image should contain a process object. */
11418 xassert (i < c->used);
11419 img = c->images[i];
11420 xassert (PROCESSP (img->data.lisp_val));
11421 Fkill_process (img->data.lisp_val, Qnil);
11422 img->data.lisp_val = Qnil;
11424 /* On displays with a mutable colormap, figure out the colors
11425 allocated for the image by looking at the pixels of an XImage for
11426 img->pixmap. */
11427 class = FRAME_W32_DISPLAY_INFO (f)->visual->class;
11428 if (class != StaticColor && class != StaticGray && class != TrueColor)
11430 XImage *ximg;
11432 BLOCK_INPUT;
11434 /* Try to get an XImage for img->pixmep. */
11435 ximg = XGetImage (FRAME_W32_DISPLAY (f), img->pixmap,
11436 0, 0, img->width, img->height, ~0, ZPixmap);
11437 if (ximg)
11439 int x, y;
11441 /* Initialize the color table. */
11442 init_color_table ();
11444 /* For each pixel of the image, look its color up in the
11445 color table. After having done so, the color table will
11446 contain an entry for each color used by the image. */
11447 for (y = 0; y < img->height; ++y)
11448 for (x = 0; x < img->width; ++x)
11450 unsigned long pixel = XGetPixel (ximg, x, y);
11451 lookup_pixel_color (f, pixel);
11454 /* Record colors in the image. Free color table and XImage. */
11455 img->colors = colors_in_color_table (&img->ncolors);
11456 free_color_table ();
11457 XDestroyImage (ximg);
11459 #if 0 /* This doesn't seem to be the case. If we free the colors
11460 here, we get a BadAccess later in x_clear_image when
11461 freeing the colors. */
11462 /* We have allocated colors once, but Ghostscript has also
11463 allocated colors on behalf of us. So, to get the
11464 reference counts right, free them once. */
11465 if (img->ncolors)
11467 Colormap cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
11468 XFreeColors (FRAME_W32_DISPLAY (f), cmap,
11469 img->colors, img->ncolors, 0);
11471 #endif
11473 else
11474 image_error ("Cannot get X image of `%s'; colors will not be freed",
11475 img->spec, Qnil);
11477 UNBLOCK_INPUT;
11481 #endif /* HAVE_GHOSTSCRIPT */
11484 /***********************************************************************
11485 Window properties
11486 ***********************************************************************/
11488 DEFUN ("x-change-window-property", Fx_change_window_property,
11489 Sx_change_window_property, 2, 3, 0,
11490 "Change window property PROP to VALUE on the X window of FRAME.\n\
11491 PROP and VALUE must be strings. FRAME nil or omitted means use the\n\
11492 selected frame. Value is VALUE.")
11493 (prop, value, frame)
11494 Lisp_Object frame, prop, value;
11496 #if 0 /* NTEMACS_TODO : port window properties to W32 */
11497 struct frame *f = check_x_frame (frame);
11498 Atom prop_atom;
11500 CHECK_STRING (prop, 1);
11501 CHECK_STRING (value, 2);
11503 BLOCK_INPUT;
11504 prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), XSTRING (prop)->data, False);
11505 XChangeProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
11506 prop_atom, XA_STRING, 8, PropModeReplace,
11507 XSTRING (value)->data, XSTRING (value)->size);
11509 /* Make sure the property is set when we return. */
11510 XFlush (FRAME_W32_DISPLAY (f));
11511 UNBLOCK_INPUT;
11513 #endif /* NTEMACS_TODO */
11515 return value;
11519 DEFUN ("x-delete-window-property", Fx_delete_window_property,
11520 Sx_delete_window_property, 1, 2, 0,
11521 "Remove window property PROP from X window of FRAME.\n\
11522 FRAME nil or omitted means use the selected frame. Value is PROP.")
11523 (prop, frame)
11524 Lisp_Object prop, frame;
11526 #if 0 /* NTEMACS_TODO : port window properties to W32 */
11528 struct frame *f = check_x_frame (frame);
11529 Atom prop_atom;
11531 CHECK_STRING (prop, 1);
11532 BLOCK_INPUT;
11533 prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), XSTRING (prop)->data, False);
11534 XDeleteProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), prop_atom);
11536 /* Make sure the property is removed when we return. */
11537 XFlush (FRAME_W32_DISPLAY (f));
11538 UNBLOCK_INPUT;
11539 #endif /* NTEMACS_TODO */
11541 return prop;
11545 DEFUN ("x-window-property", Fx_window_property, Sx_window_property,
11546 1, 2, 0,
11547 "Value is the value of window property PROP on FRAME.\n\
11548 If FRAME is nil or omitted, use the selected frame. Value is nil\n\
11549 if FRAME hasn't a property with name PROP or if PROP has no string\n\
11550 value.")
11551 (prop, frame)
11552 Lisp_Object prop, frame;
11554 #if 0 /* NTEMACS_TODO : port window properties to W32 */
11556 struct frame *f = check_x_frame (frame);
11557 Atom prop_atom;
11558 int rc;
11559 Lisp_Object prop_value = Qnil;
11560 char *tmp_data = NULL;
11561 Atom actual_type;
11562 int actual_format;
11563 unsigned long actual_size, bytes_remaining;
11565 CHECK_STRING (prop, 1);
11566 BLOCK_INPUT;
11567 prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), XSTRING (prop)->data, False);
11568 rc = XGetWindowProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
11569 prop_atom, 0, 0, False, XA_STRING,
11570 &actual_type, &actual_format, &actual_size,
11571 &bytes_remaining, (unsigned char **) &tmp_data);
11572 if (rc == Success)
11574 int size = bytes_remaining;
11576 XFree (tmp_data);
11577 tmp_data = NULL;
11579 rc = XGetWindowProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
11580 prop_atom, 0, bytes_remaining,
11581 False, XA_STRING,
11582 &actual_type, &actual_format,
11583 &actual_size, &bytes_remaining,
11584 (unsigned char **) &tmp_data);
11585 if (rc == Success)
11586 prop_value = make_string (tmp_data, size);
11588 XFree (tmp_data);
11591 UNBLOCK_INPUT;
11593 return prop_value;
11595 #endif /* NTEMACS_TODO */
11596 return Qnil;
11601 /***********************************************************************
11602 Busy cursor
11603 ***********************************************************************/
11605 /* If non-null, an asynchronous timer that, when it expires, displays
11606 a busy cursor on all frames. */
11608 static struct atimer *busy_cursor_atimer;
11610 /* Non-zero means a busy cursor is currently shown. */
11612 static int busy_cursor_shown_p;
11614 /* Number of seconds to wait before displaying a busy cursor. */
11616 static Lisp_Object Vbusy_cursor_delay;
11618 /* Default number of seconds to wait before displaying a busy
11619 cursor. */
11621 #define DEFAULT_BUSY_CURSOR_DELAY 1
11623 /* Function prototypes. */
11625 static void show_busy_cursor P_ ((struct atimer *));
11626 static void hide_busy_cursor P_ ((void));
11629 /* Cancel a currently active busy-cursor timer, and start a new one. */
11631 void
11632 start_busy_cursor ()
11634 #if 0 /* NTEMACS_TODO: cursor shape changes. */
11635 EMACS_TIME delay;
11636 int secs;
11638 cancel_busy_cursor ();
11640 if (INTEGERP (Vbusy_cursor_delay)
11641 && XINT (Vbusy_cursor_delay) > 0)
11642 secs = XFASTINT (Vbusy_cursor_delay);
11643 else
11644 secs = DEFAULT_BUSY_CURSOR_DELAY;
11646 EMACS_SET_SECS_USECS (delay, secs, 0);
11647 busy_cursor_atimer = start_atimer (ATIMER_RELATIVE, delay,
11648 show_busy_cursor, NULL);
11649 #endif
11653 /* Cancel the busy cursor timer if active, hide a busy cursor if
11654 shown. */
11656 void
11657 cancel_busy_cursor ()
11659 if (busy_cursor_atimer)
11660 cancel_atimer (busy_cursor_atimer);
11661 if (busy_cursor_shown_p)
11662 hide_busy_cursor ();
11666 /* Timer function of busy_cursor_atimer. TIMER is equal to
11667 busy_cursor_atimer.
11669 Display a busy cursor on all frames by mapping the frames'
11670 busy_window. Set the busy_p flag in the frames' output_data.x
11671 structure to indicate that a busy cursor is shown on the
11672 frames. */
11674 static void
11675 show_busy_cursor (timer)
11676 struct atimer *timer;
11678 #if 0 /* NTEMACS_TODO: cursor shape changes. */
11679 /* The timer implementation will cancel this timer automatically
11680 after this function has run. Set busy_cursor_atimer to null
11681 so that we know the timer doesn't have to be canceled. */
11682 busy_cursor_atimer = NULL;
11684 if (!busy_cursor_shown_p)
11686 Lisp_Object rest, frame;
11688 BLOCK_INPUT;
11690 FOR_EACH_FRAME (rest, frame)
11691 if (FRAME_X_P (XFRAME (frame)))
11693 struct frame *f = XFRAME (frame);
11695 f->output_data.w32->busy_p = 1;
11697 if (!f->output_data.w32->busy_window)
11699 unsigned long mask = CWCursor;
11700 XSetWindowAttributes attrs;
11702 attrs.cursor = f->output_data.w32->busy_cursor;
11704 f->output_data.w32->busy_window
11705 = XCreateWindow (FRAME_X_DISPLAY (f),
11706 FRAME_OUTER_WINDOW (f),
11707 0, 0, 32000, 32000, 0, 0,
11708 InputOnly,
11709 CopyFromParent,
11710 mask, &attrs);
11713 XMapRaised (FRAME_X_DISPLAY (f), f->output_data.w32->busy_window);
11714 XFlush (FRAME_X_DISPLAY (f));
11717 busy_cursor_shown_p = 1;
11718 UNBLOCK_INPUT;
11720 #endif
11724 /* Hide the busy cursor on all frames, if it is currently shown. */
11726 static void
11727 hide_busy_cursor ()
11729 #if 0 /* NTEMACS_TODO: cursor shape changes. */
11730 if (busy_cursor_shown_p)
11732 Lisp_Object rest, frame;
11734 BLOCK_INPUT;
11735 FOR_EACH_FRAME (rest, frame)
11737 struct frame *f = XFRAME (frame);
11739 if (FRAME_X_P (f)
11740 /* Watch out for newly created frames. */
11741 && f->output_data.x->busy_window)
11743 XUnmapWindow (FRAME_X_DISPLAY (f), f->output_data.x->busy_window);
11744 /* Sync here because XTread_socket looks at the busy_p flag
11745 that is reset to zero below. */
11746 XSync (FRAME_X_DISPLAY (f), False);
11747 f->output_data.x->busy_p = 0;
11751 busy_cursor_shown_p = 0;
11752 UNBLOCK_INPUT;
11754 #endif
11759 /***********************************************************************
11760 Tool tips
11761 ***********************************************************************/
11763 static Lisp_Object x_create_tip_frame P_ ((struct w32_display_info *,
11764 Lisp_Object));
11766 /* The frame of a currently visible tooltip, or null. */
11768 struct frame *tip_frame;
11770 /* If non-nil, a timer started that hides the last tooltip when it
11771 fires. */
11773 Lisp_Object tip_timer;
11774 Window tip_window;
11776 /* Create a frame for a tooltip on the display described by DPYINFO.
11777 PARMS is a list of frame parameters. Value is the frame. */
11779 static Lisp_Object
11780 x_create_tip_frame (dpyinfo, parms)
11781 struct w32_display_info *dpyinfo;
11782 Lisp_Object parms;
11784 #if 0 /* NTEMACS_TODO : w32 version */
11785 struct frame *f;
11786 Lisp_Object frame, tem;
11787 Lisp_Object name;
11788 long window_prompting = 0;
11789 int width, height;
11790 int count = specpdl_ptr - specpdl;
11791 struct gcpro gcpro1, gcpro2, gcpro3;
11792 struct kboard *kb;
11794 check_x ();
11796 /* Use this general default value to start with until we know if
11797 this frame has a specified name. */
11798 Vx_resource_name = Vinvocation_name;
11800 #ifdef MULTI_KBOARD
11801 kb = dpyinfo->kboard;
11802 #else
11803 kb = &the_only_kboard;
11804 #endif
11806 /* Get the name of the frame to use for resource lookup. */
11807 name = w32_get_arg (parms, Qname, "name", "Name", RES_TYPE_STRING);
11808 if (!STRINGP (name)
11809 && !EQ (name, Qunbound)
11810 && !NILP (name))
11811 error ("Invalid frame name--not a string or nil");
11812 Vx_resource_name = name;
11814 frame = Qnil;
11815 GCPRO3 (parms, name, frame);
11816 tip_frame = f = make_frame (1);
11817 XSETFRAME (frame, f);
11818 FRAME_CAN_HAVE_SCROLL_BARS (f) = 0;
11820 f->output_method = output_w32;
11821 f->output_data.w32 =
11822 (struct w32_output *) xmalloc (sizeof (struct w32_output));
11823 bzero (f->output_data.w32, sizeof (struct w32_output));
11824 #if 0
11825 f->output_data.w32->icon_bitmap = -1;
11826 #endif
11827 f->output_data.w32->fontset = -1;
11828 f->icon_name = Qnil;
11830 #ifdef MULTI_KBOARD
11831 FRAME_KBOARD (f) = kb;
11832 #endif
11833 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
11834 f->output_data.w32->explicit_parent = 0;
11836 /* Set the name; the functions to which we pass f expect the name to
11837 be set. */
11838 if (EQ (name, Qunbound) || NILP (name))
11840 f->name = build_string (dpyinfo->x_id_name);
11841 f->explicit_name = 0;
11843 else
11845 f->name = name;
11846 f->explicit_name = 1;
11847 /* use the frame's title when getting resources for this frame. */
11848 specbind (Qx_resource_name, name);
11851 /* Extract the window parameters from the supplied values
11852 that are needed to determine window geometry. */
11854 Lisp_Object font;
11856 font = w32_get_arg (parms, Qfont, "font", "Font", RES_TYPE_STRING);
11858 BLOCK_INPUT;
11859 /* First, try whatever font the caller has specified. */
11860 if (STRINGP (font))
11862 tem = Fquery_fontset (font, Qnil);
11863 if (STRINGP (tem))
11864 font = x_new_fontset (f, XSTRING (tem)->data);
11865 else
11866 font = x_new_font (f, XSTRING (font)->data);
11869 /* Try out a font which we hope has bold and italic variations. */
11870 if (!STRINGP (font))
11871 font = x_new_font (f, "-adobe-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-1");
11872 if (!STRINGP (font))
11873 font = x_new_font (f, "-misc-fixed-medium-r-normal-*-*-140-*-*-c-*-iso8859-1");
11874 if (! STRINGP (font))
11875 font = x_new_font (f, "-*-*-medium-r-normal-*-*-140-*-*-c-*-iso8859-1");
11876 if (! STRINGP (font))
11877 /* This was formerly the first thing tried, but it finds too many fonts
11878 and takes too long. */
11879 font = x_new_font (f, "-*-*-medium-r-*-*-*-*-*-*-c-*-iso8859-1");
11880 /* If those didn't work, look for something which will at least work. */
11881 if (! STRINGP (font))
11882 font = x_new_font (f, "-*-fixed-*-*-*-*-*-140-*-*-c-*-iso8859-1");
11883 UNBLOCK_INPUT;
11884 if (! STRINGP (font))
11885 font = build_string ("fixed");
11887 x_default_parameter (f, parms, Qfont, font,
11888 "font", "Font", RES_TYPE_STRING);
11891 x_default_parameter (f, parms, Qborder_width, make_number (2),
11892 "borderWidth", "BorderWidth", RES_TYPE_NUMBER);
11894 /* This defaults to 2 in order to match xterm. We recognize either
11895 internalBorderWidth or internalBorder (which is what xterm calls
11896 it). */
11897 if (NILP (Fassq (Qinternal_border_width, parms)))
11899 Lisp_Object value;
11901 value = w32_get_arg (parms, Qinternal_border_width,
11902 "internalBorder", "internalBorder", RES_TYPE_NUMBER);
11903 if (! EQ (value, Qunbound))
11904 parms = Fcons (Fcons (Qinternal_border_width, value),
11905 parms);
11908 x_default_parameter (f, parms, Qinternal_border_width, make_number (1),
11909 "internalBorderWidth", "internalBorderWidth",
11910 RES_TYPE_NUMBER);
11912 /* Also do the stuff which must be set before the window exists. */
11913 x_default_parameter (f, parms, Qforeground_color, build_string ("black"),
11914 "foreground", "Foreground", RES_TYPE_STRING);
11915 x_default_parameter (f, parms, Qbackground_color, build_string ("white"),
11916 "background", "Background", RES_TYPE_STRING);
11917 x_default_parameter (f, parms, Qmouse_color, build_string ("black"),
11918 "pointerColor", "Foreground", RES_TYPE_STRING);
11919 x_default_parameter (f, parms, Qcursor_color, build_string ("black"),
11920 "cursorColor", "Foreground", RES_TYPE_STRING);
11921 x_default_parameter (f, parms, Qborder_color, build_string ("black"),
11922 "borderColor", "BorderColor", RES_TYPE_STRING);
11924 /* Init faces before x_default_parameter is called for scroll-bar
11925 parameters because that function calls x_set_scroll_bar_width,
11926 which calls change_frame_size, which calls Fset_window_buffer,
11927 which runs hooks, which call Fvertical_motion. At the end, we
11928 end up in init_iterator with a null face cache, which should not
11929 happen. */
11930 init_frame_faces (f);
11932 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
11933 window_prompting = x_figure_window_size (f, parms);
11935 if (window_prompting & XNegative)
11937 if (window_prompting & YNegative)
11938 f->output_data.w32->win_gravity = SouthEastGravity;
11939 else
11940 f->output_data.w32->win_gravity = NorthEastGravity;
11942 else
11944 if (window_prompting & YNegative)
11945 f->output_data.w32->win_gravity = SouthWestGravity;
11946 else
11947 f->output_data.w32->win_gravity = NorthWestGravity;
11950 f->output_data.w32->size_hint_flags = window_prompting;
11952 XSetWindowAttributes attrs;
11953 unsigned long mask;
11955 BLOCK_INPUT;
11956 mask = CWBackPixel | CWOverrideRedirect | CWSaveUnder | CWEventMask;
11957 /* Window managers looks at the override-redirect flag to
11958 determine whether or net to give windows a decoration (Xlib
11959 3.2.8). */
11960 attrs.override_redirect = True;
11961 attrs.save_under = True;
11962 attrs.background_pixel = FRAME_BACKGROUND_PIXEL (f);
11963 /* Arrange for getting MapNotify and UnmapNotify events. */
11964 attrs.event_mask = StructureNotifyMask;
11965 tip_window
11966 = FRAME_W32_WINDOW (f)
11967 = XCreateWindow (FRAME_W32_DISPLAY (f),
11968 FRAME_W32_DISPLAY_INFO (f)->root_window,
11969 /* x, y, width, height */
11970 0, 0, 1, 1,
11971 /* Border. */
11973 CopyFromParent, InputOutput, CopyFromParent,
11974 mask, &attrs);
11975 UNBLOCK_INPUT;
11978 x_make_gc (f);
11980 x_default_parameter (f, parms, Qauto_raise, Qnil,
11981 "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN);
11982 x_default_parameter (f, parms, Qauto_lower, Qnil,
11983 "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN);
11984 x_default_parameter (f, parms, Qcursor_type, Qbox,
11985 "cursorType", "CursorType", RES_TYPE_SYMBOL);
11987 /* Dimensions, especially f->height, must be done via change_frame_size.
11988 Change will not be effected unless different from the current
11989 f->height. */
11990 width = f->width;
11991 height = f->height;
11992 f->height = 0;
11993 SET_FRAME_WIDTH (f, 0);
11994 change_frame_size (f, height, width, 1, 0, 0);
11996 f->no_split = 1;
11998 UNGCPRO;
12000 /* It is now ok to make the frame official even if we get an error
12001 below. And the frame needs to be on Vframe_list or making it
12002 visible won't work. */
12003 Vframe_list = Fcons (frame, Vframe_list);
12005 /* Now that the frame is official, it counts as a reference to
12006 its display. */
12007 FRAME_W32_DISPLAY_INFO (f)->reference_count++;
12009 return unbind_to (count, frame);
12010 #endif /* NTEMACS_TODO */
12011 return Qnil;
12015 DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 4, 0,
12016 "Show STRING in a \"tooltip\" window on frame FRAME.\n\
12017 A tooltip window is a small X window displaying STRING at\n\
12018 the current mouse position.\n\
12019 FRAME nil or omitted means use the selected frame.\n\
12020 PARMS is an optional list of frame parameters which can be\n\
12021 used to change the tooltip's appearance.\n\
12022 Automatically hide the tooltip after TIMEOUT seconds.\n\
12023 TIMEOUT nil means use the default timeout of 5 seconds.")
12024 (string, frame, parms, timeout)
12025 Lisp_Object string, frame, parms, timeout;
12027 struct frame *f;
12028 struct window *w;
12029 Window root, child;
12030 Lisp_Object buffer;
12031 struct buffer *old_buffer;
12032 struct text_pos pos;
12033 int i, width, height;
12034 int root_x, root_y, win_x, win_y;
12035 unsigned pmask;
12036 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
12037 int old_windows_or_buffers_changed = windows_or_buffers_changed;
12038 int count = specpdl_ptr - specpdl;
12040 specbind (Qinhibit_redisplay, Qt);
12042 GCPRO3 (string, parms, frame, timeout);
12044 CHECK_STRING (string, 0);
12045 f = check_x_frame (frame);
12046 if (NILP (timeout))
12047 timeout = make_number (5);
12048 else
12049 CHECK_NATNUM (timeout, 2);
12051 /* Hide a previous tip, if any. */
12052 Fx_hide_tip ();
12054 /* Add default values to frame parameters. */
12055 if (NILP (Fassq (Qname, parms)))
12056 parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms);
12057 if (NILP (Fassq (Qinternal_border_width, parms)))
12058 parms = Fcons (Fcons (Qinternal_border_width, make_number (3)), parms);
12059 if (NILP (Fassq (Qborder_width, parms)))
12060 parms = Fcons (Fcons (Qborder_width, make_number (1)), parms);
12061 if (NILP (Fassq (Qborder_color, parms)))
12062 parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms);
12063 if (NILP (Fassq (Qbackground_color, parms)))
12064 parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")),
12065 parms);
12067 /* Create a frame for the tooltip, and record it in the global
12068 variable tip_frame. */
12069 frame = x_create_tip_frame (FRAME_W32_DISPLAY_INFO (f), parms);
12070 tip_frame = f = XFRAME (frame);
12072 /* Set up the frame's root window. Currently we use a size of 80
12073 columns x 40 lines. If someone wants to show a larger tip, he
12074 will loose. I don't think this is a realistic case. */
12075 w = XWINDOW (FRAME_ROOT_WINDOW (f));
12076 w->left = w->top = make_number (0);
12077 w->width = 80;
12078 w->height = 40;
12079 adjust_glyphs (f);
12080 w->pseudo_window_p = 1;
12082 /* Display the tooltip text in a temporary buffer. */
12083 buffer = Fget_buffer_create (build_string (" *tip*"));
12084 Fset_window_buffer (FRAME_ROOT_WINDOW (f), buffer);
12085 old_buffer = current_buffer;
12086 set_buffer_internal_1 (XBUFFER (buffer));
12087 Ferase_buffer ();
12088 Finsert (make_number (1), &string);
12089 clear_glyph_matrix (w->desired_matrix);
12090 clear_glyph_matrix (w->current_matrix);
12091 SET_TEXT_POS (pos, BEGV, BEGV_BYTE);
12092 try_window (FRAME_ROOT_WINDOW (f), pos);
12094 /* Compute width and height of the tooltip. */
12095 width = height = 0;
12096 for (i = 0; i < w->desired_matrix->nrows; ++i)
12098 struct glyph_row *row = &w->desired_matrix->rows[i];
12099 struct glyph *last;
12100 int row_width;
12102 /* Stop at the first empty row at the end. */
12103 if (!row->enabled_p || !row->displays_text_p)
12104 break;
12106 /* Let the row go over the full width of the frame. */
12107 row->full_width_p = 1;
12109 /* There's a glyph at the end of rows that is use to place
12110 the cursor there. Don't include the width of this glyph. */
12111 if (row->used[TEXT_AREA])
12113 last = &row->glyphs[TEXT_AREA][row->used[TEXT_AREA] - 1];
12114 row_width = row->pixel_width - last->pixel_width;
12116 else
12117 row_width = row->pixel_width;
12119 height += row->height;
12120 width = max (width, row_width);
12123 /* Add the frame's internal border to the width and height the X
12124 window should have. */
12125 height += 2 * FRAME_INTERNAL_BORDER_WIDTH (f);
12126 width += 2 * FRAME_INTERNAL_BORDER_WIDTH (f);
12128 /* Move the tooltip window where the mouse pointer is. Resize and
12129 show it. */
12130 #if 0 /* NTEMACS_TODO : W32 specifics */
12131 BLOCK_INPUT;
12132 XQueryPointer (FRAME_W32_DISPLAY (f), FRAME_W32_DISPLAY_INFO (f)->root_window,
12133 &root, &child, &root_x, &root_y, &win_x, &win_y, &pmask);
12134 XMoveResizeWindow (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
12135 root_x + 5, root_y - height - 5, width, height);
12136 XMapRaised (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f));
12137 UNBLOCK_INPUT;
12138 #endif /* NTEMACS_TODO */
12140 /* Draw into the window. */
12141 w->must_be_updated_p = 1;
12142 update_single_window (w, 1);
12144 /* Restore original current buffer. */
12145 set_buffer_internal_1 (old_buffer);
12146 windows_or_buffers_changed = old_windows_or_buffers_changed;
12148 /* Let the tip disappear after timeout seconds. */
12149 tip_timer = call3 (intern ("run-at-time"), timeout, Qnil,
12150 intern ("x-hide-tip"));
12151 UNGCPRO;
12153 return unbind_to (count, Qnil);
12157 DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0,
12158 "Hide the current tooltip window, if there is any.\n\
12159 Value is t is tooltip was open, nil otherwise.")
12162 int count = specpdl_ptr - specpdl;
12163 int deleted_p = 0;
12165 specbind (Qinhibit_redisplay, Qt);
12167 if (!NILP (tip_timer))
12169 call1 (intern ("cancel-timer"), tip_timer);
12170 tip_timer = Qnil;
12173 if (tip_frame)
12175 Lisp_Object frame;
12177 XSETFRAME (frame, tip_frame);
12178 Fdelete_frame (frame, Qt);
12179 tip_frame = NULL;
12180 deleted_p = 1;
12183 return unbind_to (count, deleted_p ? Qt : Qnil);
12188 /***********************************************************************
12189 File selection dialog
12190 ***********************************************************************/
12192 extern Lisp_Object Qfile_name_history;
12194 DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 4, 0,
12195 "Read file name, prompting with PROMPT in directory DIR.\n\
12196 Use a file selection dialog.\n\
12197 Select DEFAULT-FILENAME in the dialog's file selection box, if\n\
12198 specified. Don't let the user enter a file name in the file\n\
12199 selection dialog's entry field, if MUSTMATCH is non-nil.")
12200 (prompt, dir, default_filename, mustmatch)
12201 Lisp_Object prompt, dir, default_filename, mustmatch;
12203 struct frame *f = SELECTED_FRAME ();
12204 Lisp_Object file = Qnil;
12205 int count = specpdl_ptr - specpdl;
12206 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
12207 char filename[MAX_PATH + 1];
12208 char init_dir[MAX_PATH + 1];
12209 int use_dialog_p = 1;
12211 GCPRO5 (prompt, dir, default_filename, mustmatch, file);
12212 CHECK_STRING (prompt, 0);
12213 CHECK_STRING (dir, 1);
12215 /* Create the dialog with PROMPT as title, using DIR as initial
12216 directory and using "*" as pattern. */
12217 dir = Fexpand_file_name (dir, Qnil);
12218 strncpy (init_dir, XSTRING (dir)->data, MAX_PATH);
12219 init_dir[MAX_PATH] = '\0';
12220 unixtodos_filename (init_dir);
12222 if (STRINGP (default_filename))
12224 char *file_name_only;
12225 char *full_path_name = XSTRING (default_filename)->data;
12227 unixtodos_filename (full_path_name);
12229 file_name_only = strrchr (full_path_name, '\\');
12230 if (!file_name_only)
12231 file_name_only = full_path_name;
12232 else
12234 file_name_only++;
12236 /* If default_file_name is a directory, don't use the open
12237 file dialog, as it does not support selecting
12238 directories. */
12239 if (!(*file_name_only))
12240 use_dialog_p = 0;
12243 strncpy (filename, file_name_only, MAX_PATH);
12244 filename[MAX_PATH] = '\0';
12246 else
12247 filename[0] = '\0';
12249 if (use_dialog_p)
12251 OPENFILENAME file_details;
12252 char *filename_file;
12254 /* Prevent redisplay. */
12255 specbind (Qinhibit_redisplay, Qt);
12256 BLOCK_INPUT;
12258 bzero (&file_details, sizeof (file_details));
12259 file_details.lStructSize = sizeof (file_details);
12260 file_details.hwndOwner = FRAME_W32_WINDOW (f);
12261 file_details.lpstrFile = filename;
12262 file_details.nMaxFile = sizeof (filename);
12263 file_details.lpstrInitialDir = init_dir;
12264 file_details.lpstrTitle = XSTRING (prompt)->data;
12265 file_details.Flags = OFN_HIDEREADONLY | OFN_NOCHANGEDIR;
12267 if (!NILP (mustmatch))
12268 file_details.Flags |= OFN_FILEMUSTEXIST | OFN_PATHMUSTEXIST;
12270 if (GetOpenFileName (&file_details))
12272 dostounix_filename (filename);
12273 file = build_string (filename);
12275 else
12276 file = Qnil;
12278 UNBLOCK_INPUT;
12279 file = unbind_to (count, file);
12281 /* Open File dialog will not allow folders to be selected, so resort
12282 to minibuffer completing reads for directories. */
12283 else
12284 file = Fcompleting_read (prompt, intern ("read-file-name-internal"),
12285 dir, mustmatch, dir, Qfile_name_history,
12286 default_filename, Qnil);
12288 UNGCPRO;
12290 /* Make "Cancel" equivalent to C-g. */
12291 if (NILP (file))
12292 Fsignal (Qquit, Qnil);
12294 return file;
12299 /***********************************************************************
12300 Tests
12301 ***********************************************************************/
12303 #if GLYPH_DEBUG
12305 DEFUN ("imagep", Fimagep, Simagep, 1, 1, 0,
12306 "Value is non-nil if SPEC is a valid image specification.")
12307 (spec)
12308 Lisp_Object spec;
12310 return valid_image_p (spec) ? Qt : Qnil;
12314 DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0, "")
12315 (spec)
12316 Lisp_Object spec;
12318 int id = -1;
12320 if (valid_image_p (spec))
12321 id = lookup_image (SELECTED_FRAME (), spec);
12323 debug_print (spec);
12324 return make_number (id);
12327 #endif /* GLYPH_DEBUG != 0 */
12331 /***********************************************************************
12332 w32 specialized functions
12333 ***********************************************************************/
12335 DEFUN ("w32-select-font", Fw32_select_font, Sw32_select_font, 0, 1, 0,
12336 "This will display the W32 font dialog and return an X font string corresponding to the selection.")
12337 (frame)
12338 Lisp_Object frame;
12340 FRAME_PTR f = check_x_frame (frame);
12341 CHOOSEFONT cf;
12342 LOGFONT lf;
12343 TEXTMETRIC tm;
12344 HDC hdc;
12345 HANDLE oldobj;
12346 char buf[100];
12348 bzero (&cf, sizeof (cf));
12349 bzero (&lf, sizeof (lf));
12351 cf.lStructSize = sizeof (cf);
12352 cf.hwndOwner = FRAME_W32_WINDOW (f);
12353 cf.Flags = CF_FORCEFONTEXIST | CF_SCREENFONTS;
12354 cf.lpLogFont = &lf;
12356 /* Initialize as much of the font details as we can from the current
12357 default font. */
12358 hdc = GetDC (FRAME_W32_WINDOW (f));
12359 oldobj = SelectObject (hdc, FRAME_FONT (f)->hfont);
12360 GetTextFace (hdc, LF_FACESIZE, lf.lfFaceName);
12361 if (GetTextMetrics (hdc, &tm))
12363 lf.lfHeight = tm.tmInternalLeading - tm.tmHeight;
12364 lf.lfWeight = tm.tmWeight;
12365 lf.lfItalic = tm.tmItalic;
12366 lf.lfUnderline = tm.tmUnderlined;
12367 lf.lfStrikeOut = tm.tmStruckOut;
12368 lf.lfCharSet = tm.tmCharSet;
12369 cf.Flags |= CF_INITTOLOGFONTSTRUCT;
12371 SelectObject (hdc, oldobj);
12372 ReleaseDC (FRAME_W32_WINDOW (f), hdc);
12374 if (!ChooseFont (&cf) || !w32_to_x_font (&lf, buf, 100))
12375 return Qnil;
12377 return build_string (buf);
12380 DEFUN ("w32-send-sys-command", Fw32_send_sys_command, Sw32_send_sys_command, 1, 2, 0,
12381 "Send frame a Windows WM_SYSCOMMAND message of type COMMAND.\n\
12382 Some useful values for command are 0xf030 to maximise frame (0xf020\n\
12383 to minimize), 0xf120 to restore frame to original size, and 0xf100\n\
12384 to activate the menubar for keyboard access. 0xf140 activates the\n\
12385 screen saver if defined.\n\
12387 If optional parameter FRAME is not specified, use selected frame.")
12388 (command, frame)
12389 Lisp_Object command, frame;
12391 WPARAM code;
12392 FRAME_PTR f = check_x_frame (frame);
12394 CHECK_NUMBER (command, 0);
12396 PostMessage (FRAME_W32_WINDOW (f), WM_SYSCOMMAND, XINT (command), 0);
12398 return Qnil;
12401 DEFUN ("w32-shell-execute", Fw32_shell_execute, Sw32_shell_execute, 2, 4, 0,
12402 "Get Windows to perform OPERATION on DOCUMENT.\n\
12403 This is a wrapper around the ShellExecute system function, which\n\
12404 invokes the application registered to handle OPERATION for DOCUMENT.\n\
12405 OPERATION is typically \"open\", \"print\" or \"explore\" (but can be\n\
12406 nil for the default action), and DOCUMENT is typically the name of a\n\
12407 document file or URL, but can also be a program executable to run or\n\
12408 a directory to open in the Windows Explorer.\n\
12410 If DOCUMENT is a program executable, PARAMETERS can be a string\n\
12411 containing command line parameters, but otherwise should be nil.\n\
12413 SHOW-FLAG can be used to control whether the invoked application is hidden\n\
12414 or minimized. If SHOW-FLAG is nil, the application is displayed normally,\n\
12415 otherwise it is an integer representing a ShowWindow flag:\n\
12417 0 - start hidden\n\
12418 1 - start normally\n\
12419 3 - start maximized\n\
12420 6 - start minimized")
12421 (operation, document, parameters, show_flag)
12422 Lisp_Object operation, document, parameters, show_flag;
12424 Lisp_Object current_dir;
12426 CHECK_STRING (document, 0);
12428 /* Encode filename and current directory. */
12429 current_dir = ENCODE_FILE (current_buffer->directory);
12430 document = ENCODE_FILE (document);
12431 if ((int) ShellExecute (NULL,
12432 (STRINGP (operation) ?
12433 XSTRING (operation)->data : NULL),
12434 XSTRING (document)->data,
12435 (STRINGP (parameters) ?
12436 XSTRING (parameters)->data : NULL),
12437 XSTRING (current_dir)->data,
12438 (INTEGERP (show_flag) ?
12439 XINT (show_flag) : SW_SHOWDEFAULT))
12440 > 32)
12441 return Qt;
12442 error ("ShellExecute failed");
12445 /* Lookup virtual keycode from string representing the name of a
12446 non-ascii keystroke into the corresponding virtual key, using
12447 lispy_function_keys. */
12448 static int
12449 lookup_vk_code (char *key)
12451 int i;
12453 for (i = 0; i < 256; i++)
12454 if (lispy_function_keys[i] != 0
12455 && strcmp (lispy_function_keys[i], key) == 0)
12456 return i;
12458 return -1;
12461 /* Convert a one-element vector style key sequence to a hot key
12462 definition. */
12463 static int
12464 w32_parse_hot_key (key)
12465 Lisp_Object key;
12467 /* Copied from Fdefine_key and store_in_keymap. */
12468 register Lisp_Object c;
12469 int vk_code;
12470 int lisp_modifiers;
12471 int w32_modifiers;
12472 struct gcpro gcpro1;
12474 CHECK_VECTOR (key, 0);
12476 if (XFASTINT (Flength (key)) != 1)
12477 return Qnil;
12479 GCPRO1 (key);
12481 c = Faref (key, make_number (0));
12483 if (CONSP (c) && lucid_event_type_list_p (c))
12484 c = Fevent_convert_list (c);
12486 UNGCPRO;
12488 if (! INTEGERP (c) && ! SYMBOLP (c))
12489 error ("Key definition is invalid");
12491 /* Work out the base key and the modifiers. */
12492 if (SYMBOLP (c))
12494 c = parse_modifiers (c);
12495 lisp_modifiers = Fcar (Fcdr (c));
12496 c = Fcar (c);
12497 if (!SYMBOLP (c))
12498 abort ();
12499 vk_code = lookup_vk_code (XSYMBOL (c)->name->data);
12501 else if (INTEGERP (c))
12503 lisp_modifiers = XINT (c) & ~CHARACTERBITS;
12504 /* Many ascii characters are their own virtual key code. */
12505 vk_code = XINT (c) & CHARACTERBITS;
12508 if (vk_code < 0 || vk_code > 255)
12509 return Qnil;
12511 if ((lisp_modifiers & meta_modifier) != 0
12512 && !NILP (Vw32_alt_is_meta))
12513 lisp_modifiers |= alt_modifier;
12515 /* Convert lisp modifiers to Windows hot-key form. */
12516 w32_modifiers = (lisp_modifiers & hyper_modifier) ? MOD_WIN : 0;
12517 w32_modifiers |= (lisp_modifiers & alt_modifier) ? MOD_ALT : 0;
12518 w32_modifiers |= (lisp_modifiers & ctrl_modifier) ? MOD_CONTROL : 0;
12519 w32_modifiers |= (lisp_modifiers & shift_modifier) ? MOD_SHIFT : 0;
12521 return HOTKEY (vk_code, w32_modifiers);
12524 DEFUN ("w32-register-hot-key", Fw32_register_hot_key, Sw32_register_hot_key, 1, 1, 0,
12525 "Register KEY as a hot-key combination.\n\
12526 Certain key combinations like Alt-Tab are reserved for system use on\n\
12527 Windows, and therefore are normally intercepted by the system. However,\n\
12528 most of these key combinations can be received by registering them as\n\
12529 hot-keys, overriding their special meaning.\n\
12531 KEY must be a one element key definition in vector form that would be\n\
12532 acceptable to `define-key' (e.g. [A-tab] for Alt-Tab). The meta\n\
12533 modifier is interpreted as Alt if `w32-alt-is-meta' is t, and hyper\n\
12534 is always interpreted as the Windows modifier keys.\n\
12536 The return value is the hotkey-id if registered, otherwise nil.")
12537 (key)
12538 Lisp_Object key;
12540 key = w32_parse_hot_key (key);
12542 if (NILP (Fmemq (key, w32_grabbed_keys)))
12544 /* Reuse an empty slot if possible. */
12545 Lisp_Object item = Fmemq (Qnil, w32_grabbed_keys);
12547 /* Safe to add new key to list, even if we have focus. */
12548 if (NILP (item))
12549 w32_grabbed_keys = Fcons (key, w32_grabbed_keys);
12550 else
12551 XCAR (item) = key;
12553 /* Notify input thread about new hot-key definition, so that it
12554 takes effect without needing to switch focus. */
12555 PostThreadMessage (dwWindowsThreadId, WM_EMACS_REGISTER_HOT_KEY,
12556 (WPARAM) key, 0);
12559 return key;
12562 DEFUN ("w32-unregister-hot-key", Fw32_unregister_hot_key, Sw32_unregister_hot_key, 1, 1, 0,
12563 "Unregister HOTKEY as a hot-key combination.")
12564 (key)
12565 Lisp_Object key;
12567 Lisp_Object item;
12569 if (!INTEGERP (key))
12570 key = w32_parse_hot_key (key);
12572 item = Fmemq (key, w32_grabbed_keys);
12574 if (!NILP (item))
12576 /* Notify input thread about hot-key definition being removed, so
12577 that it takes effect without needing focus switch. */
12578 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_UNREGISTER_HOT_KEY,
12579 (WPARAM) XINT (XCAR (item)), (LPARAM) item))
12581 MSG msg;
12582 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
12584 return Qt;
12586 return Qnil;
12589 DEFUN ("w32-registered-hot-keys", Fw32_registered_hot_keys, Sw32_registered_hot_keys, 0, 0, 0,
12590 "Return list of registered hot-key IDs.")
12593 return Fcopy_sequence (w32_grabbed_keys);
12596 DEFUN ("w32-reconstruct-hot-key", Fw32_reconstruct_hot_key, Sw32_reconstruct_hot_key, 1, 1, 0,
12597 "Convert hot-key ID to a lisp key combination.")
12598 (hotkeyid)
12599 Lisp_Object hotkeyid;
12601 int vk_code, w32_modifiers;
12602 Lisp_Object key;
12604 CHECK_NUMBER (hotkeyid, 0);
12606 vk_code = HOTKEY_VK_CODE (hotkeyid);
12607 w32_modifiers = HOTKEY_MODIFIERS (hotkeyid);
12609 if (lispy_function_keys[vk_code])
12610 key = intern (lispy_function_keys[vk_code]);
12611 else
12612 key = make_number (vk_code);
12614 key = Fcons (key, Qnil);
12615 if (w32_modifiers & MOD_SHIFT)
12616 key = Fcons (Qshift, key);
12617 if (w32_modifiers & MOD_CONTROL)
12618 key = Fcons (Qctrl, key);
12619 if (w32_modifiers & MOD_ALT)
12620 key = Fcons (NILP (Vw32_alt_is_meta) ? Qalt : Qmeta, key);
12621 if (w32_modifiers & MOD_WIN)
12622 key = Fcons (Qhyper, key);
12624 return key;
12627 DEFUN ("w32-toggle-lock-key", Fw32_toggle_lock_key, Sw32_toggle_lock_key, 1, 2, 0,
12628 "Toggle the state of the lock key KEY.\n\
12629 KEY can be `capslock', `kp-numlock', or `scroll'.\n\
12630 If the optional parameter NEW-STATE is a number, then the state of KEY\n\
12631 is set to off if the low bit of NEW-STATE is zero, otherwise on.")
12632 (key, new_state)
12633 Lisp_Object key, new_state;
12635 int vk_code;
12636 int cur_state;
12638 if (EQ (key, intern ("capslock")))
12639 vk_code = VK_CAPITAL;
12640 else if (EQ (key, intern ("kp-numlock")))
12641 vk_code = VK_NUMLOCK;
12642 else if (EQ (key, intern ("scroll")))
12643 vk_code = VK_SCROLL;
12644 else
12645 return Qnil;
12647 if (!dwWindowsThreadId)
12648 return make_number (w32_console_toggle_lock_key (vk_code, new_state));
12650 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_TOGGLE_LOCK_KEY,
12651 (WPARAM) vk_code, (LPARAM) new_state))
12653 MSG msg;
12654 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
12655 return make_number (msg.wParam);
12657 return Qnil;
12660 syms_of_w32fns ()
12662 /* This is zero if not using MS-Windows. */
12663 w32_in_use = 0;
12665 /* The section below is built by the lisp expression at the top of the file,
12666 just above where these variables are declared. */
12667 /*&&& init symbols here &&&*/
12668 Qauto_raise = intern ("auto-raise");
12669 staticpro (&Qauto_raise);
12670 Qauto_lower = intern ("auto-lower");
12671 staticpro (&Qauto_lower);
12672 Qbar = intern ("bar");
12673 staticpro (&Qbar);
12674 Qborder_color = intern ("border-color");
12675 staticpro (&Qborder_color);
12676 Qborder_width = intern ("border-width");
12677 staticpro (&Qborder_width);
12678 Qbox = intern ("box");
12679 staticpro (&Qbox);
12680 Qcursor_color = intern ("cursor-color");
12681 staticpro (&Qcursor_color);
12682 Qcursor_type = intern ("cursor-type");
12683 staticpro (&Qcursor_type);
12684 Qgeometry = intern ("geometry");
12685 staticpro (&Qgeometry);
12686 Qicon_left = intern ("icon-left");
12687 staticpro (&Qicon_left);
12688 Qicon_top = intern ("icon-top");
12689 staticpro (&Qicon_top);
12690 Qicon_type = intern ("icon-type");
12691 staticpro (&Qicon_type);
12692 Qicon_name = intern ("icon-name");
12693 staticpro (&Qicon_name);
12694 Qinternal_border_width = intern ("internal-border-width");
12695 staticpro (&Qinternal_border_width);
12696 Qleft = intern ("left");
12697 staticpro (&Qleft);
12698 Qright = intern ("right");
12699 staticpro (&Qright);
12700 Qmouse_color = intern ("mouse-color");
12701 staticpro (&Qmouse_color);
12702 Qnone = intern ("none");
12703 staticpro (&Qnone);
12704 Qparent_id = intern ("parent-id");
12705 staticpro (&Qparent_id);
12706 Qscroll_bar_width = intern ("scroll-bar-width");
12707 staticpro (&Qscroll_bar_width);
12708 Qsuppress_icon = intern ("suppress-icon");
12709 staticpro (&Qsuppress_icon);
12710 Qundefined_color = intern ("undefined-color");
12711 staticpro (&Qundefined_color);
12712 Qvertical_scroll_bars = intern ("vertical-scroll-bars");
12713 staticpro (&Qvertical_scroll_bars);
12714 Qvisibility = intern ("visibility");
12715 staticpro (&Qvisibility);
12716 Qwindow_id = intern ("window-id");
12717 staticpro (&Qwindow_id);
12718 Qx_frame_parameter = intern ("x-frame-parameter");
12719 staticpro (&Qx_frame_parameter);
12720 Qx_resource_name = intern ("x-resource-name");
12721 staticpro (&Qx_resource_name);
12722 Quser_position = intern ("user-position");
12723 staticpro (&Quser_position);
12724 Quser_size = intern ("user-size");
12725 staticpro (&Quser_size);
12726 #if 0 /* Duplicate initialization in xdisp.c */
12727 Qdisplay = intern ("display");
12728 staticpro (&Qdisplay);
12729 #endif
12730 Qscreen_gamma = intern ("screen-gamma");
12731 staticpro (&Qscreen_gamma);
12732 /* This is the end of symbol initialization. */
12734 Qhyper = intern ("hyper");
12735 staticpro (&Qhyper);
12736 Qsuper = intern ("super");
12737 staticpro (&Qsuper);
12738 Qmeta = intern ("meta");
12739 staticpro (&Qmeta);
12740 Qalt = intern ("alt");
12741 staticpro (&Qalt);
12742 Qctrl = intern ("ctrl");
12743 staticpro (&Qctrl);
12744 Qcontrol = intern ("control");
12745 staticpro (&Qcontrol);
12746 Qshift = intern ("shift");
12747 staticpro (&Qshift);
12749 /* Text property `display' should be nonsticky by default. */
12750 Vtext_property_default_nonsticky
12751 = Fcons (Fcons (Qdisplay, Qt), Vtext_property_default_nonsticky);
12754 Qlaplace = intern ("laplace");
12755 staticpro (&Qlaplace);
12757 Qface_set_after_frame_default = intern ("face-set-after-frame-default");
12758 staticpro (&Qface_set_after_frame_default);
12760 Fput (Qundefined_color, Qerror_conditions,
12761 Fcons (Qundefined_color, Fcons (Qerror, Qnil)));
12762 Fput (Qundefined_color, Qerror_message,
12763 build_string ("Undefined color"));
12765 staticpro (&w32_grabbed_keys);
12766 w32_grabbed_keys = Qnil;
12768 DEFVAR_LISP ("w32-color-map", &Vw32_color_map,
12769 "An array of color name mappings for windows.");
12770 Vw32_color_map = Qnil;
12772 DEFVAR_LISP ("w32-pass-alt-to-system", &Vw32_pass_alt_to_system,
12773 "Non-nil if alt key presses are passed on to Windows.\n\
12774 When non-nil, for example, alt pressed and released and then space will\n\
12775 open the System menu. When nil, Emacs silently swallows alt key events.");
12776 Vw32_pass_alt_to_system = Qnil;
12778 DEFVAR_LISP ("w32-alt-is-meta", &Vw32_alt_is_meta,
12779 "Non-nil if the alt key is to be considered the same as the meta key.\n\
12780 When nil, Emacs will translate the alt key to the Alt modifier, and not Meta.");
12781 Vw32_alt_is_meta = Qt;
12783 DEFVAR_INT ("w32-quit-key", &Vw32_quit_key,
12784 "If non-zero, the virtual key code for an alternative quit key.");
12785 XSETINT (Vw32_quit_key, 0);
12787 DEFVAR_LISP ("w32-pass-lwindow-to-system",
12788 &Vw32_pass_lwindow_to_system,
12789 "Non-nil if the left \"Windows\" key is passed on to Windows.\n\
12790 When non-nil, the Start menu is opened by tapping the key.");
12791 Vw32_pass_lwindow_to_system = Qt;
12793 DEFVAR_LISP ("w32-pass-rwindow-to-system",
12794 &Vw32_pass_rwindow_to_system,
12795 "Non-nil if the right \"Windows\" key is passed on to Windows.\n\
12796 When non-nil, the Start menu is opened by tapping the key.");
12797 Vw32_pass_rwindow_to_system = Qt;
12799 DEFVAR_INT ("w32-phantom-key-code",
12800 &Vw32_phantom_key_code,
12801 "Virtual key code used to generate \"phantom\" key presses.\n\
12802 Value is a number between 0 and 255.\n\
12804 Phantom key presses are generated in order to stop the system from\n\
12805 acting on \"Windows\" key events when `w32-pass-lwindow-to-system' or\n\
12806 `w32-pass-rwindow-to-system' is nil.");
12807 /* Although 255 is technically not a valid key code, it works and
12808 means that this hack won't interfere with any real key code. */
12809 Vw32_phantom_key_code = 255;
12811 DEFVAR_LISP ("w32-enable-num-lock",
12812 &Vw32_enable_num_lock,
12813 "Non-nil if Num Lock should act normally.\n\
12814 Set to nil to see Num Lock as the key `kp-numlock'.");
12815 Vw32_enable_num_lock = Qt;
12817 DEFVAR_LISP ("w32-enable-caps-lock",
12818 &Vw32_enable_caps_lock,
12819 "Non-nil if Caps Lock should act normally.\n\
12820 Set to nil to see Caps Lock as the key `capslock'.");
12821 Vw32_enable_caps_lock = Qt;
12823 DEFVAR_LISP ("w32-scroll-lock-modifier",
12824 &Vw32_scroll_lock_modifier,
12825 "Modifier to use for the Scroll Lock on state.\n\
12826 The value can be hyper, super, meta, alt, control or shift for the\n\
12827 respective modifier, or nil to see Scroll Lock as the key `scroll'.\n\
12828 Any other value will cause the key to be ignored.");
12829 Vw32_scroll_lock_modifier = Qt;
12831 DEFVAR_LISP ("w32-lwindow-modifier",
12832 &Vw32_lwindow_modifier,
12833 "Modifier to use for the left \"Windows\" key.\n\
12834 The value can be hyper, super, meta, alt, control or shift for the\n\
12835 respective modifier, or nil to appear as the key `lwindow'.\n\
12836 Any other value will cause the key to be ignored.");
12837 Vw32_lwindow_modifier = Qnil;
12839 DEFVAR_LISP ("w32-rwindow-modifier",
12840 &Vw32_rwindow_modifier,
12841 "Modifier to use for the right \"Windows\" key.\n\
12842 The value can be hyper, super, meta, alt, control or shift for the\n\
12843 respective modifier, or nil to appear as the key `rwindow'.\n\
12844 Any other value will cause the key to be ignored.");
12845 Vw32_rwindow_modifier = Qnil;
12847 DEFVAR_LISP ("w32-apps-modifier",
12848 &Vw32_apps_modifier,
12849 "Modifier to use for the \"Apps\" key.\n\
12850 The value can be hyper, super, meta, alt, control or shift for the\n\
12851 respective modifier, or nil to appear as the key `apps'.\n\
12852 Any other value will cause the key to be ignored.");
12853 Vw32_apps_modifier = Qnil;
12855 DEFVAR_LISP ("w32-enable-synthesized_fonts", &Vw32_enable_synthesized_fonts,
12856 "Non-nil enables selection of artificially italicized and bold fonts.");
12857 Vw32_enable_synthesized_fonts = Qnil;
12859 DEFVAR_LISP ("w32-enable-palette", &Vw32_enable_palette,
12860 "Non-nil enables Windows palette management to map colors exactly.");
12861 Vw32_enable_palette = Qt;
12863 DEFVAR_INT ("w32-mouse-button-tolerance",
12864 &Vw32_mouse_button_tolerance,
12865 "Analogue of double click interval for faking middle mouse events.\n\
12866 The value is the minimum time in milliseconds that must elapse between\n\
12867 left/right button down events before they are considered distinct events.\n\
12868 If both mouse buttons are depressed within this interval, a middle mouse\n\
12869 button down event is generated instead.");
12870 XSETINT (Vw32_mouse_button_tolerance, GetDoubleClickTime () / 2);
12872 DEFVAR_INT ("w32-mouse-move-interval",
12873 &Vw32_mouse_move_interval,
12874 "Minimum interval between mouse move events.\n\
12875 The value is the minimum time in milliseconds that must elapse between\n\
12876 successive mouse move (or scroll bar drag) events before they are\n\
12877 reported as lisp events.");
12878 XSETINT (Vw32_mouse_move_interval, 0);
12880 init_x_parm_symbols ();
12882 DEFVAR_LISP ("x-bitmap-file-path", &Vx_bitmap_file_path,
12883 "List of directories to search for bitmap files for w32.");
12884 Vx_bitmap_file_path = decode_env_path ((char *) 0, "PATH");
12886 DEFVAR_LISP ("x-pointer-shape", &Vx_pointer_shape,
12887 "The shape of the pointer when over text.\n\
12888 Changing the value does not affect existing frames\n\
12889 unless you set the mouse color.");
12890 Vx_pointer_shape = Qnil;
12892 DEFVAR_LISP ("x-resource-name", &Vx_resource_name,
12893 "The name Emacs uses to look up resources; for internal use only.\n\
12894 `x-get-resource' uses this as the first component of the instance name\n\
12895 when requesting resource values.\n\
12896 Emacs initially sets `x-resource-name' to the name under which Emacs\n\
12897 was invoked, or to the value specified with the `-name' or `-rn'\n\
12898 switches, if present.");
12899 Vx_resource_name = Qnil;
12901 Vx_nontext_pointer_shape = Qnil;
12903 Vx_mode_pointer_shape = Qnil;
12905 DEFVAR_LISP ("x-busy-pointer-shape", &Vx_busy_pointer_shape,
12906 "The shape of the pointer when Emacs is busy.\n\
12907 This variable takes effect when you create a new frame\n\
12908 or when you set the mouse color.");
12909 Vx_busy_pointer_shape = Qnil;
12911 DEFVAR_BOOL ("display-busy-cursor", &display_busy_cursor_p,
12912 "Non-zero means Emacs displays a busy cursor on window systems.");
12913 display_busy_cursor_p = 1;
12915 DEFVAR_LISP ("busy-cursor-delay", &Vbusy_cursor_delay,
12916 "*Seconds to wait before displaying a busy-cursor.\n\
12917 Value must be an integer.");
12918 Vbusy_cursor_delay = make_number (DEFAULT_BUSY_CURSOR_DELAY);
12920 DEFVAR_LISP ("x-sensitive-text-pointer-shape",
12921 &Vx_sensitive_text_pointer_shape,
12922 "The shape of the pointer when over mouse-sensitive text.\n\
12923 This variable takes effect when you create a new frame\n\
12924 or when you set the mouse color.");
12925 Vx_sensitive_text_pointer_shape = Qnil;
12927 DEFVAR_LISP ("x-cursor-fore-pixel", &Vx_cursor_fore_pixel,
12928 "A string indicating the foreground color of the cursor box.");
12929 Vx_cursor_fore_pixel = Qnil;
12931 DEFVAR_LISP ("x-no-window-manager", &Vx_no_window_manager,
12932 "Non-nil if no window manager is in use.\n\
12933 Emacs doesn't try to figure this out; this is always nil\n\
12934 unless you set it to something else.");
12935 /* We don't have any way to find this out, so set it to nil
12936 and maybe the user would like to set it to t. */
12937 Vx_no_window_manager = Qnil;
12939 DEFVAR_LISP ("x-pixel-size-width-font-regexp",
12940 &Vx_pixel_size_width_font_regexp,
12941 "Regexp matching a font name whose width is the same as `PIXEL_SIZE'.\n\
12943 Since Emacs gets width of a font matching with this regexp from\n\
12944 PIXEL_SIZE field of the name, font finding mechanism gets faster for\n\
12945 such a font. This is especially effective for such large fonts as\n\
12946 Chinese, Japanese, and Korean.");
12947 Vx_pixel_size_width_font_regexp = Qnil;
12949 DEFVAR_LISP ("image-cache-eviction-delay", &Vimage_cache_eviction_delay,
12950 "Time after which cached images are removed from the cache.\n\
12951 When an image has not been displayed this many seconds, remove it\n\
12952 from the image cache. Value must be an integer or nil with nil\n\
12953 meaning don't clear the cache.");
12954 Vimage_cache_eviction_delay = make_number (30 * 60);
12956 DEFVAR_LISP ("image-types", &Vimage_types,
12957 "List of supported image types.\n\
12958 Each element of the list is a symbol for a supported image type.");
12959 Vimage_types = Qnil;
12961 DEFVAR_LISP ("w32-bdf-filename-alist",
12962 &Vw32_bdf_filename_alist,
12963 "List of bdf fonts and their corresponding filenames.");
12964 Vw32_bdf_filename_alist = Qnil;
12966 DEFVAR_BOOL ("w32-strict-fontnames",
12967 &w32_strict_fontnames,
12968 "Non-nil means only use fonts that are exact matches for those requested.\n\
12969 Default is nil, which allows old fontnames that are not XLFD compliant,\n\
12970 and allows third-party CJK display to work by specifying false charset\n\
12971 fields to trick Emacs into translating to Big5, SJIS etc.\n\
12972 Setting this to t will prevent wrong fonts being selected when\n\
12973 fontsets are automatically created.");
12974 w32_strict_fontnames = 0;
12976 DEFVAR_BOOL ("w32-strict-painting",
12977 &w32_strict_painting,
12978 "Non-nil means use strict rules for repainting frames.\n\
12979 Set this to nil to get the old behaviour for repainting; this should\n\
12980 only be necessary if the default setting causes problems.");
12981 w32_strict_painting = 1;
12983 DEFVAR_LISP ("w32-system-coding-system",
12984 &Vw32_system_coding_system,
12985 "Coding system used by Windows system functions, such as for font names.");
12986 Vw32_system_coding_system = Qnil;
12988 defsubr (&Sx_get_resource);
12989 #if 0 /* NTEMACS_TODO: Port to W32 */
12990 defsubr (&Sx_change_window_property);
12991 defsubr (&Sx_delete_window_property);
12992 defsubr (&Sx_window_property);
12993 #endif
12994 defsubr (&Sxw_display_color_p);
12995 defsubr (&Sx_display_grayscale_p);
12996 defsubr (&Sxw_color_defined_p);
12997 defsubr (&Sxw_color_values);
12998 defsubr (&Sx_server_max_request_size);
12999 defsubr (&Sx_server_vendor);
13000 defsubr (&Sx_server_version);
13001 defsubr (&Sx_display_pixel_width);
13002 defsubr (&Sx_display_pixel_height);
13003 defsubr (&Sx_display_mm_width);
13004 defsubr (&Sx_display_mm_height);
13005 defsubr (&Sx_display_screens);
13006 defsubr (&Sx_display_planes);
13007 defsubr (&Sx_display_color_cells);
13008 defsubr (&Sx_display_visual_class);
13009 defsubr (&Sx_display_backing_store);
13010 defsubr (&Sx_display_save_under);
13011 defsubr (&Sx_parse_geometry);
13012 defsubr (&Sx_create_frame);
13013 defsubr (&Sx_open_connection);
13014 defsubr (&Sx_close_connection);
13015 defsubr (&Sx_display_list);
13016 defsubr (&Sx_synchronize);
13018 /* W32 specific functions */
13020 defsubr (&Sw32_focus_frame);
13021 defsubr (&Sw32_select_font);
13022 defsubr (&Sw32_define_rgb_color);
13023 defsubr (&Sw32_default_color_map);
13024 defsubr (&Sw32_load_color_file);
13025 defsubr (&Sw32_send_sys_command);
13026 defsubr (&Sw32_shell_execute);
13027 defsubr (&Sw32_register_hot_key);
13028 defsubr (&Sw32_unregister_hot_key);
13029 defsubr (&Sw32_registered_hot_keys);
13030 defsubr (&Sw32_reconstruct_hot_key);
13031 defsubr (&Sw32_toggle_lock_key);
13032 defsubr (&Sw32_find_bdf_fonts);
13034 /* Setting callback functions for fontset handler. */
13035 get_font_info_func = w32_get_font_info;
13037 #if 0 /* This function pointer doesn't seem to be used anywhere.
13038 And the pointer assigned has the wrong type, anyway. */
13039 list_fonts_func = w32_list_fonts;
13040 #endif
13042 load_font_func = w32_load_font;
13043 find_ccl_program_func = w32_find_ccl_program;
13044 query_font_func = w32_query_font;
13045 set_frame_fontset_func = x_set_font;
13046 check_window_system_func = check_w32;
13048 #if 0 /* NTEMACS_TODO Image support for W32 */
13049 /* Images. */
13050 Qxbm = intern ("xbm");
13051 staticpro (&Qxbm);
13052 QCtype = intern (":type");
13053 staticpro (&QCtype);
13054 QCalgorithm = intern (":algorithm");
13055 staticpro (&QCalgorithm);
13056 QCheuristic_mask = intern (":heuristic-mask");
13057 staticpro (&QCheuristic_mask);
13058 QCcolor_symbols = intern (":color-symbols");
13059 staticpro (&QCcolor_symbols);
13060 QCascent = intern (":ascent");
13061 staticpro (&QCascent);
13062 QCmargin = intern (":margin");
13063 staticpro (&QCmargin);
13064 QCrelief = intern (":relief");
13065 staticpro (&QCrelief);
13066 Qpostscript = intern ("postscript");
13067 staticpro (&Qpostscript);
13068 QCloader = intern (":loader");
13069 staticpro (&QCloader);
13070 QCbounding_box = intern (":bounding-box");
13071 staticpro (&QCbounding_box);
13072 QCpt_width = intern (":pt-width");
13073 staticpro (&QCpt_width);
13074 QCpt_height = intern (":pt-height");
13075 staticpro (&QCpt_height);
13076 QCindex = intern (":index");
13077 staticpro (&QCindex);
13078 Qpbm = intern ("pbm");
13079 staticpro (&Qpbm);
13081 #if HAVE_XPM
13082 Qxpm = intern ("xpm");
13083 staticpro (&Qxpm);
13084 #endif
13086 #if HAVE_JPEG
13087 Qjpeg = intern ("jpeg");
13088 staticpro (&Qjpeg);
13089 #endif
13091 #if HAVE_TIFF
13092 Qtiff = intern ("tiff");
13093 staticpro (&Qtiff);
13094 #endif
13096 #if HAVE_GIF
13097 Qgif = intern ("gif");
13098 staticpro (&Qgif);
13099 #endif
13101 #if HAVE_PNG
13102 Qpng = intern ("png");
13103 staticpro (&Qpng);
13104 #endif
13106 defsubr (&Sclear_image_cache);
13108 #if GLYPH_DEBUG
13109 defsubr (&Simagep);
13110 defsubr (&Slookup_image);
13111 #endif
13112 #endif /* NTEMACS_TODO */
13114 defsubr (&Sx_show_tip);
13115 defsubr (&Sx_hide_tip);
13116 staticpro (&tip_timer);
13117 tip_timer = Qnil;
13119 defsubr (&Sx_file_dialog);
13123 void
13124 init_xfns ()
13126 image_types = NULL;
13127 Vimage_types = Qnil;
13129 #if 0 /* NTEMACS_TODO : Image support for W32 */
13130 define_image_type (&xbm_type);
13131 define_image_type (&gs_type);
13132 define_image_type (&pbm_type);
13134 #if HAVE_XPM
13135 define_image_type (&xpm_type);
13136 #endif
13138 #if HAVE_JPEG
13139 define_image_type (&jpeg_type);
13140 #endif
13142 #if HAVE_TIFF
13143 define_image_type (&tiff_type);
13144 #endif
13146 #if HAVE_GIF
13147 define_image_type (&gif_type);
13148 #endif
13150 #if HAVE_PNG
13151 define_image_type (&png_type);
13152 #endif
13153 #endif /* NTEMACS_TODO */
13156 #undef abort
13158 void
13159 w32_abort()
13161 int button;
13162 button = MessageBox (NULL,
13163 "A fatal error has occurred!\n\n"
13164 "Select Abort to exit, Retry to debug, Ignore to continue",
13165 "Emacs Abort Dialog",
13166 MB_ICONEXCLAMATION | MB_TASKMODAL
13167 | MB_SETFOREGROUND | MB_ABORTRETRYIGNORE);
13168 switch (button)
13170 case IDRETRY:
13171 DebugBreak ();
13172 break;
13173 case IDIGNORE:
13174 break;
13175 case IDABORT:
13176 default:
13177 abort ();
13178 break;
13182 /* For convenience when debugging. */
13184 w32_last_error()
13186 return GetLastError ();