(combine-run-hooks): New function.
[emacs.git] / src / w32fns.c
blobdc2f86ccdb46bfab115b88eddff94973c79f32ad
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 "fontset.h"
34 #include "w32term.h"
35 #include "frame.h"
36 #include "window.h"
37 #include "buffer.h"
38 #include "dispextern.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_MEASUREITEM:
4475 f = x_window_to_frame (dpyinfo, hwnd);
4476 if (f)
4478 MEASUREITEMSTRUCT * pMis = (MEASUREITEMSTRUCT *) lParam;
4480 if (pMis->CtlType == ODT_MENU)
4482 /* Work out dimensions for popup menu titles. */
4483 char * title = (char *) pMis->itemData;
4484 HDC hdc = GetDC (hwnd);
4485 HFONT menu_font = GetCurrentObject (hdc, OBJ_FONT);
4486 LOGFONT menu_logfont;
4487 HFONT old_font;
4488 SIZE size;
4490 GetObject (menu_font, sizeof (menu_logfont), &menu_logfont);
4491 menu_logfont.lfWeight = FW_BOLD;
4492 menu_font = CreateFontIndirect (&menu_logfont);
4493 old_font = SelectObject (hdc, menu_font);
4495 GetTextExtentPoint32 (hdc, title, strlen (title), &size);
4496 pMis->itemWidth = size.cx;
4497 pMis->itemHeight = GetSystemMetrics (SM_CYMENUSIZE);
4498 if (pMis->itemHeight < size.cy)
4499 pMis->itemHeight = size.cy;
4501 SelectObject (hdc, old_font);
4502 DeleteObject (menu_font);
4503 ReleaseDC (hwnd, hdc);
4504 return TRUE;
4507 return 0;
4509 case WM_DRAWITEM:
4510 f = x_window_to_frame (dpyinfo, hwnd);
4511 if (f)
4513 DRAWITEMSTRUCT * pDis = (DRAWITEMSTRUCT *) lParam;
4515 if (pDis->CtlType == ODT_MENU)
4517 /* Draw popup menu title. */
4518 char * title = (char *) pDis->itemData;
4519 HDC hdc = pDis->hDC;
4520 HFONT menu_font = GetCurrentObject (hdc, OBJ_FONT);
4521 LOGFONT menu_logfont;
4522 HFONT old_font;
4524 GetObject (menu_font, sizeof (menu_logfont), &menu_logfont);
4525 menu_logfont.lfWeight = FW_BOLD;
4526 menu_font = CreateFontIndirect (&menu_logfont);
4527 old_font = SelectObject (hdc, menu_font);
4529 /* Always draw title as if not selected. */
4530 ExtTextOut (hdc,
4531 pDis->rcItem.left + GetSystemMetrics (SM_CXMENUCHECK),
4532 pDis->rcItem.top,
4533 ETO_OPAQUE, &pDis->rcItem,
4534 title, strlen (title), NULL);
4536 SelectObject (hdc, old_font);
4537 DeleteObject (menu_font);
4538 return TRUE;
4541 return 0;
4543 #if 0
4544 /* Still not right - can't distinguish between clicks in the
4545 client area of the frame from clicks forwarded from the scroll
4546 bars - may have to hook WM_NCHITTEST to remember the mouse
4547 position and then check if it is in the client area ourselves. */
4548 case WM_MOUSEACTIVATE:
4549 /* Discard the mouse click that activates a frame, allowing the
4550 user to click anywhere without changing point (or worse!).
4551 Don't eat mouse clicks on scrollbars though!! */
4552 if (LOWORD (lParam) == HTCLIENT )
4553 return MA_ACTIVATEANDEAT;
4554 goto dflt;
4555 #endif
4557 case WM_ACTIVATEAPP:
4558 case WM_ACTIVATE:
4559 case WM_WINDOWPOSCHANGED:
4560 case WM_SHOWWINDOW:
4561 /* Inform lisp thread that a frame might have just been obscured
4562 or exposed, so should recheck visibility of all frames. */
4563 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4564 goto dflt;
4566 case WM_SETFOCUS:
4567 dpyinfo->faked_key = 0;
4568 reset_modifiers ();
4569 register_hot_keys (hwnd);
4570 goto command;
4571 case WM_KILLFOCUS:
4572 unregister_hot_keys (hwnd);
4573 button_state = 0;
4574 ReleaseCapture ();
4575 case WM_MOVE:
4576 case WM_SIZE:
4577 case WM_COMMAND:
4578 command:
4579 wmsg.dwModifiers = w32_get_modifiers ();
4580 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4581 goto dflt;
4583 case WM_CLOSE:
4584 wmsg.dwModifiers = w32_get_modifiers ();
4585 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4586 return 0;
4588 case WM_WINDOWPOSCHANGING:
4590 WINDOWPLACEMENT wp;
4591 LPWINDOWPOS lppos = (WINDOWPOS *) lParam;
4593 wp.length = sizeof (WINDOWPLACEMENT);
4594 GetWindowPlacement (hwnd, &wp);
4596 if (wp.showCmd != SW_SHOWMINIMIZED && (lppos->flags & SWP_NOSIZE) == 0)
4598 RECT rect;
4599 int wdiff;
4600 int hdiff;
4601 DWORD font_width;
4602 DWORD line_height;
4603 DWORD internal_border;
4604 DWORD scrollbar_extra;
4605 RECT wr;
4607 wp.length = sizeof(wp);
4608 GetWindowRect (hwnd, &wr);
4610 enter_crit ();
4612 font_width = GetWindowLong (hwnd, WND_FONTWIDTH_INDEX);
4613 line_height = GetWindowLong (hwnd, WND_LINEHEIGHT_INDEX);
4614 internal_border = GetWindowLong (hwnd, WND_BORDER_INDEX);
4615 scrollbar_extra = GetWindowLong (hwnd, WND_SCROLLBAR_INDEX);
4617 leave_crit ();
4619 memset (&rect, 0, sizeof (rect));
4620 AdjustWindowRect (&rect, GetWindowLong (hwnd, GWL_STYLE),
4621 GetMenu (hwnd) != NULL);
4623 /* Force width and height of client area to be exact
4624 multiples of the character cell dimensions. */
4625 wdiff = (lppos->cx - (rect.right - rect.left)
4626 - 2 * internal_border - scrollbar_extra)
4627 % font_width;
4628 hdiff = (lppos->cy - (rect.bottom - rect.top)
4629 - 2 * internal_border)
4630 % line_height;
4632 if (wdiff || hdiff)
4634 /* For right/bottom sizing we can just fix the sizes.
4635 However for top/left sizing we will need to fix the X
4636 and Y positions as well. */
4638 lppos->cx -= wdiff;
4639 lppos->cy -= hdiff;
4641 if (wp.showCmd != SW_SHOWMAXIMIZED
4642 && (lppos->flags & SWP_NOMOVE) == 0)
4644 if (lppos->x != wr.left || lppos->y != wr.top)
4646 lppos->x += wdiff;
4647 lppos->y += hdiff;
4649 else
4651 lppos->flags |= SWP_NOMOVE;
4655 return 0;
4660 goto dflt;
4662 case WM_GETMINMAXINFO:
4663 /* Hack to correct bug that allows Emacs frames to be resized
4664 below the Minimum Tracking Size. */
4665 ((LPMINMAXINFO) lParam)->ptMinTrackSize.y++;
4666 return 0;
4668 case WM_EMACS_CREATESCROLLBAR:
4669 return (LRESULT) w32_createscrollbar ((struct frame *) wParam,
4670 (struct scroll_bar *) lParam);
4672 case WM_EMACS_SHOWWINDOW:
4673 return ShowWindow ((HWND) wParam, (WPARAM) lParam);
4675 case WM_EMACS_SETFOREGROUND:
4677 HWND foreground_window;
4678 DWORD foreground_thread, retval;
4680 /* On NT 5.0, and apparently Windows 98, it is necessary to
4681 attach to the thread that currently has focus in order to
4682 pull the focus away from it. */
4683 foreground_window = GetForegroundWindow ();
4684 foreground_thread = GetWindowThreadProcessId (foreground_window, NULL);
4685 if (!foreground_window
4686 || foreground_thread == GetCurrentThreadId ()
4687 || !AttachThreadInput (GetCurrentThreadId (),
4688 foreground_thread, TRUE))
4689 foreground_thread = 0;
4691 retval = SetForegroundWindow ((HWND) wParam);
4693 /* Detach from the previous foreground thread. */
4694 if (foreground_thread)
4695 AttachThreadInput (GetCurrentThreadId (),
4696 foreground_thread, FALSE);
4698 return retval;
4701 case WM_EMACS_SETWINDOWPOS:
4703 WINDOWPOS * pos = (WINDOWPOS *) wParam;
4704 return SetWindowPos (hwnd, pos->hwndInsertAfter,
4705 pos->x, pos->y, pos->cx, pos->cy, pos->flags);
4708 case WM_EMACS_DESTROYWINDOW:
4709 DragAcceptFiles ((HWND) wParam, FALSE);
4710 return DestroyWindow ((HWND) wParam);
4712 case WM_EMACS_TRACKPOPUPMENU:
4714 UINT flags;
4715 POINT *pos;
4716 int retval;
4717 pos = (POINT *)lParam;
4718 flags = TPM_CENTERALIGN;
4719 if (button_state & LMOUSE)
4720 flags |= TPM_LEFTBUTTON;
4721 else if (button_state & RMOUSE)
4722 flags |= TPM_RIGHTBUTTON;
4724 /* Remember we did a SetCapture on the initial mouse down event,
4725 so for safety, we make sure the capture is cancelled now. */
4726 ReleaseCapture ();
4727 button_state = 0;
4729 /* Use menubar_active to indicate that WM_INITMENU is from
4730 TrackPopupMenu below, and should be ignored. */
4731 f = x_window_to_frame (dpyinfo, hwnd);
4732 if (f)
4733 f->output_data.w32->menubar_active = 1;
4735 if (TrackPopupMenu ((HMENU)wParam, flags, pos->x, pos->y,
4736 0, hwnd, NULL))
4738 MSG amsg;
4739 /* Eat any mouse messages during popupmenu */
4740 while (PeekMessage (&amsg, hwnd, WM_MOUSEFIRST, WM_MOUSELAST,
4741 PM_REMOVE));
4742 /* Get the menu selection, if any */
4743 if (PeekMessage (&amsg, hwnd, WM_COMMAND, WM_COMMAND, PM_REMOVE))
4745 retval = LOWORD (amsg.wParam);
4747 else
4749 retval = 0;
4752 else
4754 retval = -1;
4757 return retval;
4760 default:
4761 /* Check for messages registered at runtime. */
4762 if (msg == msh_mousewheel)
4764 wmsg.dwModifiers = w32_get_modifiers ();
4765 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
4766 return 0;
4769 dflt:
4770 return DefWindowProc (hwnd, msg, wParam, lParam);
4774 /* The most common default return code for handled messages is 0. */
4775 return 0;
4778 void
4779 my_create_window (f)
4780 struct frame * f;
4782 MSG msg;
4784 if (!PostThreadMessage (dwWindowsThreadId, WM_EMACS_CREATEWINDOW, (WPARAM)f, 0))
4785 abort ();
4786 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
4789 /* Create and set up the w32 window for frame F. */
4791 static void
4792 w32_window (f, window_prompting, minibuffer_only)
4793 struct frame *f;
4794 long window_prompting;
4795 int minibuffer_only;
4797 BLOCK_INPUT;
4799 /* Use the resource name as the top-level window name
4800 for looking up resources. Make a non-Lisp copy
4801 for the window manager, so GC relocation won't bother it.
4803 Elsewhere we specify the window name for the window manager. */
4806 char *str = (char *) XSTRING (Vx_resource_name)->data;
4807 f->namebuf = (char *) xmalloc (strlen (str) + 1);
4808 strcpy (f->namebuf, str);
4811 my_create_window (f);
4813 validate_x_resource_name ();
4815 /* x_set_name normally ignores requests to set the name if the
4816 requested name is the same as the current name. This is the one
4817 place where that assumption isn't correct; f->name is set, but
4818 the server hasn't been told. */
4820 Lisp_Object name;
4821 int explicit = f->explicit_name;
4823 f->explicit_name = 0;
4824 name = f->name;
4825 f->name = Qnil;
4826 x_set_name (f, name, explicit);
4829 UNBLOCK_INPUT;
4831 if (!minibuffer_only && FRAME_EXTERNAL_MENU_BAR (f))
4832 initialize_frame_menubar (f);
4834 if (FRAME_W32_WINDOW (f) == 0)
4835 error ("Unable to create window");
4838 /* Handle the icon stuff for this window. Perhaps later we might
4839 want an x_set_icon_position which can be called interactively as
4840 well. */
4842 static void
4843 x_icon (f, parms)
4844 struct frame *f;
4845 Lisp_Object parms;
4847 Lisp_Object icon_x, icon_y;
4849 /* Set the position of the icon. Note that Windows 95 groups all
4850 icons in the tray. */
4851 icon_x = w32_get_arg (parms, Qicon_left, 0, 0, RES_TYPE_NUMBER);
4852 icon_y = w32_get_arg (parms, Qicon_top, 0, 0, RES_TYPE_NUMBER);
4853 if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound))
4855 CHECK_NUMBER (icon_x, 0);
4856 CHECK_NUMBER (icon_y, 0);
4858 else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound))
4859 error ("Both left and top icon corners of icon must be specified");
4861 BLOCK_INPUT;
4863 if (! EQ (icon_x, Qunbound))
4864 x_wm_set_icon_position (f, XINT (icon_x), XINT (icon_y));
4866 #if 0 /* TODO */
4867 /* Start up iconic or window? */
4868 x_wm_set_window_state
4869 (f, (EQ (w32_get_arg (parms, Qvisibility, 0, 0, RES_TYPE_SYMBOL), Qicon)
4870 ? IconicState
4871 : NormalState));
4873 x_text_icon (f, (char *) XSTRING ((!NILP (f->icon_name)
4874 ? f->icon_name
4875 : f->name))->data);
4876 #endif
4878 UNBLOCK_INPUT;
4882 static void
4883 x_make_gc (f)
4884 struct frame *f;
4886 XGCValues gc_values;
4888 BLOCK_INPUT;
4890 /* Create the GC's of this frame.
4891 Note that many default values are used. */
4893 /* Normal video */
4894 gc_values.font = f->output_data.w32->font;
4896 /* Cursor has cursor-color background, background-color foreground. */
4897 gc_values.foreground = FRAME_BACKGROUND_PIXEL (f);
4898 gc_values.background = f->output_data.w32->cursor_pixel;
4899 f->output_data.w32->cursor_gc
4900 = XCreateGC (NULL, FRAME_W32_WINDOW (f),
4901 (GCFont | GCForeground | GCBackground),
4902 &gc_values);
4904 /* Reliefs. */
4905 f->output_data.w32->white_relief.gc = 0;
4906 f->output_data.w32->black_relief.gc = 0;
4908 UNBLOCK_INPUT;
4912 DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
4913 1, 1, 0,
4914 "Make a new window, which is called a \"frame\" in Emacs terms.\n\
4915 Returns an Emacs frame object.\n\
4916 ALIST is an alist of frame parameters.\n\
4917 If the parameters specify that the frame should not have a minibuffer,\n\
4918 and do not specify a specific minibuffer window to use,\n\
4919 then `default-minibuffer-frame' must be a frame whose minibuffer can\n\
4920 be shared by the new frame.\n\
4922 This function is an internal primitive--use `make-frame' instead.")
4923 (parms)
4924 Lisp_Object parms;
4926 struct frame *f;
4927 Lisp_Object frame, tem;
4928 Lisp_Object name;
4929 int minibuffer_only = 0;
4930 long window_prompting = 0;
4931 int width, height;
4932 int count = specpdl_ptr - specpdl;
4933 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4934 Lisp_Object display;
4935 struct w32_display_info *dpyinfo = NULL;
4936 Lisp_Object parent;
4937 struct kboard *kb;
4939 check_w32 ();
4941 /* Use this general default value to start with
4942 until we know if this frame has a specified name. */
4943 Vx_resource_name = Vinvocation_name;
4945 display = w32_get_arg (parms, Qdisplay, 0, 0, RES_TYPE_STRING);
4946 if (EQ (display, Qunbound))
4947 display = Qnil;
4948 dpyinfo = check_x_display_info (display);
4949 #ifdef MULTI_KBOARD
4950 kb = dpyinfo->kboard;
4951 #else
4952 kb = &the_only_kboard;
4953 #endif
4955 name = w32_get_arg (parms, Qname, "name", "Name", RES_TYPE_STRING);
4956 if (!STRINGP (name)
4957 && ! EQ (name, Qunbound)
4958 && ! NILP (name))
4959 error ("Invalid frame name--not a string or nil");
4961 if (STRINGP (name))
4962 Vx_resource_name = name;
4964 /* See if parent window is specified. */
4965 parent = w32_get_arg (parms, Qparent_id, NULL, NULL, RES_TYPE_NUMBER);
4966 if (EQ (parent, Qunbound))
4967 parent = Qnil;
4968 if (! NILP (parent))
4969 CHECK_NUMBER (parent, 0);
4971 /* make_frame_without_minibuffer can run Lisp code and garbage collect. */
4972 /* No need to protect DISPLAY because that's not used after passing
4973 it to make_frame_without_minibuffer. */
4974 frame = Qnil;
4975 GCPRO4 (parms, parent, name, frame);
4976 tem = w32_get_arg (parms, Qminibuffer, 0, 0, RES_TYPE_SYMBOL);
4977 if (EQ (tem, Qnone) || NILP (tem))
4978 f = make_frame_without_minibuffer (Qnil, kb, display);
4979 else if (EQ (tem, Qonly))
4981 f = make_minibuffer_frame ();
4982 minibuffer_only = 1;
4984 else if (WINDOWP (tem))
4985 f = make_frame_without_minibuffer (tem, kb, display);
4986 else
4987 f = make_frame (1);
4989 XSETFRAME (frame, f);
4991 /* Note that Windows does support scroll bars. */
4992 FRAME_CAN_HAVE_SCROLL_BARS (f) = 1;
4993 /* By default, make scrollbars the system standard width. */
4994 f->scroll_bar_pixel_width = GetSystemMetrics (SM_CXVSCROLL);
4996 f->output_method = output_w32;
4997 f->output_data.w32 =
4998 (struct w32_output *) xmalloc (sizeof (struct w32_output));
4999 bzero (f->output_data.w32, sizeof (struct w32_output));
5001 FRAME_FONTSET (f) = -1;
5003 f->icon_name
5004 = w32_get_arg (parms, Qicon_name, "iconName", "Title", RES_TYPE_STRING);
5005 if (! STRINGP (f->icon_name))
5006 f->icon_name = Qnil;
5008 /* FRAME_W32_DISPLAY_INFO (f) = dpyinfo; */
5009 #ifdef MULTI_KBOARD
5010 FRAME_KBOARD (f) = kb;
5011 #endif
5013 /* Specify the parent under which to make this window. */
5015 if (!NILP (parent))
5017 f->output_data.w32->parent_desc = (Window) parent;
5018 f->output_data.w32->explicit_parent = 1;
5020 else
5022 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
5023 f->output_data.w32->explicit_parent = 0;
5026 /* Set the name; the functions to which we pass f expect the name to
5027 be set. */
5028 if (EQ (name, Qunbound) || NILP (name))
5030 f->name = build_string (dpyinfo->w32_id_name);
5031 f->explicit_name = 0;
5033 else
5035 f->name = name;
5036 f->explicit_name = 1;
5037 /* use the frame's title when getting resources for this frame. */
5038 specbind (Qx_resource_name, name);
5041 /* Create fontsets from `global_fontset_alist' before handling fonts. */
5042 for (tem = Vglobal_fontset_alist; CONSP (tem); tem = XCDR (tem))
5043 fs_register_fontset (f, XCAR (tem));
5045 /* Extract the window parameters from the supplied values
5046 that are needed to determine window geometry. */
5048 Lisp_Object font;
5050 font = w32_get_arg (parms, Qfont, "font", "Font", RES_TYPE_STRING);
5052 BLOCK_INPUT;
5053 /* First, try whatever font the caller has specified. */
5054 if (STRINGP (font))
5056 tem = Fquery_fontset (font, Qnil);
5057 if (STRINGP (tem))
5058 font = x_new_fontset (f, XSTRING (tem)->data);
5059 else
5060 font = x_new_font (f, XSTRING (font)->data);
5062 /* Try out a font which we hope has bold and italic variations. */
5063 if (!STRINGP (font))
5064 font = x_new_font (f, "-*-Courier New-normal-r-*-*-13-*-*-*-c-*-iso8859-1");
5065 if (! STRINGP (font))
5066 font = x_new_font (f, "-*-Courier-normal-r-*-*-13-*-*-*-c-*-iso8859-1");
5067 /* If those didn't work, look for something which will at least work. */
5068 if (! STRINGP (font))
5069 font = x_new_font (f, "-*-Fixedsys-normal-r-*-*-12-*-*-*-c-*-iso8859-1");
5070 UNBLOCK_INPUT;
5071 if (! STRINGP (font))
5072 font = build_string ("Fixedsys");
5074 x_default_parameter (f, parms, Qfont, font,
5075 "font", "Font", RES_TYPE_STRING);
5078 x_default_parameter (f, parms, Qborder_width, make_number (2),
5079 "borderwidth", "BorderWidth", RES_TYPE_NUMBER);
5080 /* This defaults to 2 in order to match xterm. We recognize either
5081 internalBorderWidth or internalBorder (which is what xterm calls
5082 it). */
5083 if (NILP (Fassq (Qinternal_border_width, parms)))
5085 Lisp_Object value;
5087 value = w32_get_arg (parms, Qinternal_border_width,
5088 "internalBorder", "BorderWidth", RES_TYPE_NUMBER);
5089 if (! EQ (value, Qunbound))
5090 parms = Fcons (Fcons (Qinternal_border_width, value),
5091 parms);
5093 /* Default internalBorderWidth to 0 on Windows to match other programs. */
5094 x_default_parameter (f, parms, Qinternal_border_width, make_number (0),
5095 "internalBorderWidth", "BorderWidth", RES_TYPE_NUMBER);
5096 x_default_parameter (f, parms, Qvertical_scroll_bars, Qt,
5097 "verticalScrollBars", "ScrollBars", RES_TYPE_BOOLEAN);
5099 /* Also do the stuff which must be set before the window exists. */
5100 x_default_parameter (f, parms, Qforeground_color, build_string ("black"),
5101 "foreground", "Foreground", RES_TYPE_STRING);
5102 x_default_parameter (f, parms, Qbackground_color, build_string ("white"),
5103 "background", "Background", RES_TYPE_STRING);
5104 x_default_parameter (f, parms, Qmouse_color, build_string ("black"),
5105 "pointerColor", "Foreground", RES_TYPE_STRING);
5106 x_default_parameter (f, parms, Qcursor_color, build_string ("black"),
5107 "cursorColor", "Foreground", RES_TYPE_STRING);
5108 x_default_parameter (f, parms, Qborder_color, build_string ("black"),
5109 "borderColor", "BorderColor", RES_TYPE_STRING);
5110 x_default_parameter (f, parms, Qscreen_gamma, Qnil,
5111 "screenGamma", "ScreenGamma", RES_TYPE_FLOAT);
5114 /* Init faces before x_default_parameter is called for scroll-bar
5115 parameters because that function calls x_set_scroll_bar_width,
5116 which calls change_frame_size, which calls Fset_window_buffer,
5117 which runs hooks, which call Fvertical_motion. At the end, we
5118 end up in init_iterator with a null face cache, which should not
5119 happen. */
5120 init_frame_faces (f);
5122 x_default_parameter (f, parms, Qmenu_bar_lines, make_number (1),
5123 "menuBar", "MenuBar", RES_TYPE_NUMBER);
5124 x_default_parameter (f, parms, Qtool_bar_lines, make_number (0),
5125 "toolBar", "ToolBar", RES_TYPE_NUMBER);
5126 x_default_parameter (f, parms, Qbuffer_predicate, Qnil,
5127 "bufferPredicate", "BufferPredicate", RES_TYPE_SYMBOL);
5128 x_default_parameter (f, parms, Qtitle, Qnil,
5129 "title", "Title", RES_TYPE_STRING);
5131 f->output_data.w32->dwStyle = WS_OVERLAPPEDWINDOW;
5132 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
5133 window_prompting = x_figure_window_size (f, parms);
5135 if (window_prompting & XNegative)
5137 if (window_prompting & YNegative)
5138 f->output_data.w32->win_gravity = SouthEastGravity;
5139 else
5140 f->output_data.w32->win_gravity = NorthEastGravity;
5142 else
5144 if (window_prompting & YNegative)
5145 f->output_data.w32->win_gravity = SouthWestGravity;
5146 else
5147 f->output_data.w32->win_gravity = NorthWestGravity;
5150 f->output_data.w32->size_hint_flags = window_prompting;
5152 tem = w32_get_arg (parms, Qunsplittable, 0, 0, RES_TYPE_BOOLEAN);
5153 f->no_split = minibuffer_only || EQ (tem, Qt);
5155 /* Create the window. Add the tool-bar height to the initial frame
5156 height so that the user gets a text display area of the size he
5157 specified with -g or via the registry. Later changes of the
5158 tool-bar height don't change the frame size. This is done so that
5159 users can create tall Emacs frames without having to guess how
5160 tall the tool-bar will get. */
5161 f->height += FRAME_TOOL_BAR_LINES (f);
5162 w32_window (f, window_prompting, minibuffer_only);
5163 x_icon (f, parms);
5165 x_make_gc (f);
5167 /* Now consider the frame official. */
5168 FRAME_W32_DISPLAY_INFO (f)->reference_count++;
5169 Vframe_list = Fcons (frame, Vframe_list);
5171 /* We need to do this after creating the window, so that the
5172 icon-creation functions can say whose icon they're describing. */
5173 x_default_parameter (f, parms, Qicon_type, Qnil,
5174 "bitmapIcon", "BitmapIcon", RES_TYPE_SYMBOL);
5176 x_default_parameter (f, parms, Qauto_raise, Qnil,
5177 "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN);
5178 x_default_parameter (f, parms, Qauto_lower, Qnil,
5179 "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN);
5180 x_default_parameter (f, parms, Qcursor_type, Qbox,
5181 "cursorType", "CursorType", RES_TYPE_SYMBOL);
5182 x_default_parameter (f, parms, Qscroll_bar_width, Qnil,
5183 "scrollBarWidth", "ScrollBarWidth", RES_TYPE_NUMBER);
5185 /* Dimensions, especially f->height, must be done via change_frame_size.
5186 Change will not be effected unless different from the current
5187 f->height. */
5188 width = f->width;
5189 height = f->height;
5190 f->height = 0;
5191 SET_FRAME_WIDTH (f, 0);
5192 change_frame_size (f, height, width, 1, 0, 0);
5194 /* Set up faces after all frame parameters are known. */
5195 call1 (Qface_set_after_frame_default, frame);
5197 /* Tell the server what size and position, etc, we want, and how
5198 badly we want them. This should be done after we have the menu
5199 bar so that its size can be taken into account. */
5200 BLOCK_INPUT;
5201 x_wm_set_size_hint (f, window_prompting, 0);
5202 UNBLOCK_INPUT;
5204 /* Make the window appear on the frame and enable display, unless
5205 the caller says not to. However, with explicit parent, Emacs
5206 cannot control visibility, so don't try. */
5207 if (! f->output_data.w32->explicit_parent)
5209 Lisp_Object visibility;
5211 visibility = w32_get_arg (parms, Qvisibility, 0, 0, RES_TYPE_SYMBOL);
5212 if (EQ (visibility, Qunbound))
5213 visibility = Qt;
5215 if (EQ (visibility, Qicon))
5216 x_iconify_frame (f);
5217 else if (! NILP (visibility))
5218 x_make_frame_visible (f);
5219 else
5220 /* Must have been Qnil. */
5223 UNGCPRO;
5224 return unbind_to (count, frame);
5227 /* FRAME is used only to get a handle on the X display. We don't pass the
5228 display info directly because we're called from frame.c, which doesn't
5229 know about that structure. */
5230 Lisp_Object
5231 x_get_focus_frame (frame)
5232 struct frame *frame;
5234 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (frame);
5235 Lisp_Object xfocus;
5236 if (! dpyinfo->w32_focus_frame)
5237 return Qnil;
5239 XSETFRAME (xfocus, dpyinfo->w32_focus_frame);
5240 return xfocus;
5243 DEFUN ("w32-focus-frame", Fw32_focus_frame, Sw32_focus_frame, 1, 1, 0,
5244 "Give FRAME input focus, raising to foreground if necessary.")
5245 (frame)
5246 Lisp_Object frame;
5248 x_focus_on_frame (check_x_frame (frame));
5249 return Qnil;
5253 struct font_info *w32_load_bdf_font (struct frame *f, char *fontname,
5254 int size, char* filename);
5256 struct font_info *
5257 w32_load_system_font (f,fontname,size)
5258 struct frame *f;
5259 char * fontname;
5260 int size;
5262 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
5263 Lisp_Object font_names;
5265 /* Get a list of all the fonts that match this name. Once we
5266 have a list of matching fonts, we compare them against the fonts
5267 we already have loaded by comparing names. */
5268 font_names = w32_list_fonts (f, build_string (fontname), size, 100);
5270 if (!NILP (font_names))
5272 Lisp_Object tail;
5273 int i;
5275 /* First check if any are already loaded, as that is cheaper
5276 than loading another one. */
5277 for (i = 0; i < dpyinfo->n_fonts; i++)
5278 for (tail = font_names; CONSP (tail); tail = XCDR (tail))
5279 if (dpyinfo->font_table[i].name
5280 && (!strcmp (dpyinfo->font_table[i].name,
5281 XSTRING (XCAR (tail))->data)
5282 || !strcmp (dpyinfo->font_table[i].full_name,
5283 XSTRING (XCAR (tail))->data)))
5284 return (dpyinfo->font_table + i);
5286 fontname = (char *) XSTRING (XCAR (font_names))->data;
5288 else if (w32_strict_fontnames)
5290 /* If EnumFontFamiliesEx was available, we got a full list of
5291 fonts back so stop now to avoid the possibility of loading a
5292 random font. If we had to fall back to EnumFontFamilies, the
5293 list is incomplete, so continue whether the font we want was
5294 listed or not. */
5295 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
5296 FARPROC enum_font_families_ex
5297 = GetProcAddress (gdi32, "EnumFontFamiliesExA");
5298 if (enum_font_families_ex)
5299 return NULL;
5302 /* Load the font and add it to the table. */
5304 char *full_name, *encoding;
5305 XFontStruct *font;
5306 struct font_info *fontp;
5307 LOGFONT lf;
5308 BOOL ok;
5309 int i;
5311 if (!fontname || !x_to_w32_font (fontname, &lf))
5312 return (NULL);
5314 if (!*lf.lfFaceName)
5315 /* If no name was specified for the font, we get a random font
5316 from CreateFontIndirect - this is not particularly
5317 desirable, especially since CreateFontIndirect does not
5318 fill out the missing name in lf, so we never know what we
5319 ended up with. */
5320 return NULL;
5322 font = (XFontStruct *) xmalloc (sizeof (XFontStruct));
5324 /* Set bdf to NULL to indicate that this is a Windows font. */
5325 font->bdf = NULL;
5327 BLOCK_INPUT;
5329 font->hfont = CreateFontIndirect (&lf);
5331 if (font->hfont == NULL)
5333 ok = FALSE;
5335 else
5337 HDC hdc;
5338 HANDLE oldobj;
5340 hdc = GetDC (dpyinfo->root_window);
5341 oldobj = SelectObject (hdc, font->hfont);
5342 ok = GetTextMetrics (hdc, &font->tm);
5343 SelectObject (hdc, oldobj);
5344 ReleaseDC (dpyinfo->root_window, hdc);
5345 /* Fill out details in lf according to the font that was
5346 actually loaded. */
5347 lf.lfHeight = font->tm.tmInternalLeading - font->tm.tmHeight;
5348 lf.lfWidth = font->tm.tmAveCharWidth;
5349 lf.lfWeight = font->tm.tmWeight;
5350 lf.lfItalic = font->tm.tmItalic;
5351 lf.lfCharSet = font->tm.tmCharSet;
5352 lf.lfPitchAndFamily = ((font->tm.tmPitchAndFamily & TMPF_FIXED_PITCH)
5353 ? VARIABLE_PITCH : FIXED_PITCH);
5354 lf.lfOutPrecision = ((font->tm.tmPitchAndFamily & TMPF_VECTOR)
5355 ? OUT_STROKE_PRECIS : OUT_STRING_PRECIS);
5358 UNBLOCK_INPUT;
5360 if (!ok)
5362 w32_unload_font (dpyinfo, font);
5363 return (NULL);
5366 /* Find a free slot in the font table. */
5367 for (i = 0; i < dpyinfo->n_fonts; ++i)
5368 if (dpyinfo->font_table[i].name == NULL)
5369 break;
5371 /* If no free slot found, maybe enlarge the font table. */
5372 if (i == dpyinfo->n_fonts
5373 && dpyinfo->n_fonts == dpyinfo->font_table_size)
5375 int sz;
5376 dpyinfo->font_table_size = max (16, 2 * dpyinfo->font_table_size);
5377 sz = dpyinfo->font_table_size * sizeof *dpyinfo->font_table;
5378 dpyinfo->font_table
5379 = (struct font_info *) xrealloc (dpyinfo->font_table, sz);
5382 fontp = dpyinfo->font_table + i;
5383 if (i == dpyinfo->n_fonts)
5384 ++dpyinfo->n_fonts;
5386 /* Now fill in the slots of *FONTP. */
5387 BLOCK_INPUT;
5388 fontp->font = font;
5389 fontp->font_idx = i;
5390 fontp->name = (char *) xmalloc (strlen (fontname) + 1);
5391 bcopy (fontname, fontp->name, strlen (fontname) + 1);
5393 /* Work out the font's full name. */
5394 full_name = (char *)xmalloc (100);
5395 if (full_name && w32_to_x_font (&lf, full_name, 100))
5396 fontp->full_name = full_name;
5397 else
5399 /* If all else fails - just use the name we used to load it. */
5400 xfree (full_name);
5401 fontp->full_name = fontp->name;
5404 fontp->size = FONT_WIDTH (font);
5405 fontp->height = FONT_HEIGHT (font);
5407 /* The slot `encoding' specifies how to map a character
5408 code-points (0x20..0x7F or 0x2020..0x7F7F) of each charset to
5409 the font code-points (0:0x20..0x7F, 1:0xA0..0xFF, 0:0x2020..0x7F7F,
5410 the font code-points (0:0x20..0x7F, 1:0xA0..0xFF,
5411 0:0x2020..0x7F7F, 1:0xA0A0..0xFFFF, 3:0x20A0..0x7FFF, or
5412 2:0xA020..0xFF7F). For the moment, we don't know which charset
5413 uses this font. So, we set information in fontp->encoding[1]
5414 which is never used by any charset. If mapping can't be
5415 decided, set FONT_ENCODING_NOT_DECIDED. */
5417 /* SJIS fonts need to be set to type 4, all others seem to work as
5418 type FONT_ENCODING_NOT_DECIDED. */
5419 encoding = strrchr (fontp->name, '-');
5420 if (encoding && stricmp (encoding+1, "sjis") == 0)
5421 fontp->encoding[1] = 4;
5422 else
5423 fontp->encoding[1] = FONT_ENCODING_NOT_DECIDED;
5425 /* The following three values are set to 0 under W32, which is
5426 what they get set to if XGetFontProperty fails under X. */
5427 fontp->baseline_offset = 0;
5428 fontp->relative_compose = 0;
5429 fontp->default_ascent = 0;
5431 /* Set global flag fonts_changed_p to non-zero if the font loaded
5432 has a character with a smaller width than any other character
5433 before, or if the font loaded has a smalle>r height than any
5434 other font loaded before. If this happens, it will make a
5435 glyph matrix reallocation necessary. */
5436 fonts_changed_p = x_compute_min_glyph_bounds (f);
5437 UNBLOCK_INPUT;
5438 return fontp;
5442 /* Load font named FONTNAME of size SIZE for frame F, and return a
5443 pointer to the structure font_info while allocating it dynamically.
5444 If loading fails, return NULL. */
5445 struct font_info *
5446 w32_load_font (f,fontname,size)
5447 struct frame *f;
5448 char * fontname;
5449 int size;
5451 Lisp_Object bdf_fonts;
5452 struct font_info *retval = NULL;
5454 bdf_fonts = w32_list_bdf_fonts (build_string (fontname));
5456 while (!retval && CONSP (bdf_fonts))
5458 char *bdf_name, *bdf_file;
5459 Lisp_Object bdf_pair;
5461 bdf_name = XSTRING (XCAR (bdf_fonts))->data;
5462 bdf_pair = Fassoc (XCAR (bdf_fonts), Vw32_bdf_filename_alist);
5463 bdf_file = XSTRING (XCDR (bdf_pair))->data;
5465 retval = w32_load_bdf_font (f, bdf_name, size, bdf_file);
5467 bdf_fonts = XCDR (bdf_fonts);
5470 if (retval)
5471 return retval;
5473 return w32_load_system_font(f, fontname, size);
5477 void
5478 w32_unload_font (dpyinfo, font)
5479 struct w32_display_info *dpyinfo;
5480 XFontStruct * font;
5482 if (font)
5484 if (font->bdf) w32_free_bdf_font (font->bdf);
5486 if (font->hfont) DeleteObject(font->hfont);
5487 xfree (font);
5491 /* The font conversion stuff between x and w32 */
5493 /* X font string is as follows (from faces.el)
5494 * (let ((- "[-?]")
5495 * (foundry "[^-]+")
5496 * (family "[^-]+")
5497 * (weight "\\(bold\\|demibold\\|medium\\)") ; 1
5498 * (weight\? "\\([^-]*\\)") ; 1
5499 * (slant "\\([ior]\\)") ; 2
5500 * (slant\? "\\([^-]?\\)") ; 2
5501 * (swidth "\\([^-]*\\)") ; 3
5502 * (adstyle "[^-]*") ; 4
5503 * (pixelsize "[0-9]+")
5504 * (pointsize "[0-9][0-9]+")
5505 * (resx "[0-9][0-9]+")
5506 * (resy "[0-9][0-9]+")
5507 * (spacing "[cmp?*]")
5508 * (avgwidth "[0-9]+")
5509 * (registry "[^-]+")
5510 * (encoding "[^-]+")
5512 * (setq x-font-regexp
5513 * (concat "\\`\\*?[-?*]"
5514 * foundry - family - weight\? - slant\? - swidth - adstyle -
5515 * pixelsize - pointsize - resx - resy - spacing - registry -
5516 * encoding "[-?*]\\*?\\'"
5517 * ))
5518 * (setq x-font-regexp-head
5519 * (concat "\\`[-?*]" foundry - family - weight\? - slant\?
5520 * "\\([-*?]\\|\\'\\)"))
5521 * (setq x-font-regexp-slant (concat - slant -))
5522 * (setq x-font-regexp-weight (concat - weight -))
5523 * nil)
5526 #define FONT_START "[-?]"
5527 #define FONT_FOUNDRY "[^-]+"
5528 #define FONT_FAMILY "\\([^-]+\\)" /* 1 */
5529 #define FONT_WEIGHT "\\(bold\\|demibold\\|medium\\)" /* 2 */
5530 #define FONT_WEIGHT_Q "\\([^-]*\\)" /* 2 */
5531 #define FONT_SLANT "\\([ior]\\)" /* 3 */
5532 #define FONT_SLANT_Q "\\([^-]?\\)" /* 3 */
5533 #define FONT_SWIDTH "\\([^-]*\\)" /* 4 */
5534 #define FONT_ADSTYLE "[^-]*"
5535 #define FONT_PIXELSIZE "[^-]*"
5536 #define FONT_POINTSIZE "\\([0-9][0-9]+\\|\\*\\)" /* 5 */
5537 #define FONT_RESX "[0-9][0-9]+"
5538 #define FONT_RESY "[0-9][0-9]+"
5539 #define FONT_SPACING "[cmp?*]"
5540 #define FONT_AVGWIDTH "[0-9]+"
5541 #define FONT_REGISTRY "[^-]+"
5542 #define FONT_ENCODING "[^-]+"
5544 #define FONT_REGEXP ("\\`\\*?[-?*]" \
5545 FONT_FOUNDRY "-" \
5546 FONT_FAMILY "-" \
5547 FONT_WEIGHT_Q "-" \
5548 FONT_SLANT_Q "-" \
5549 FONT_SWIDTH "-" \
5550 FONT_ADSTYLE "-" \
5551 FONT_PIXELSIZE "-" \
5552 FONT_POINTSIZE "-" \
5553 "[-?*]\\|\\'")
5555 #define FONT_REGEXP_HEAD ("\\`[-?*]" \
5556 FONT_FOUNDRY "-" \
5557 FONT_FAMILY "-" \
5558 FONT_WEIGHT_Q "-" \
5559 FONT_SLANT_Q \
5560 "\\([-*?]\\|\\'\\)")
5562 #define FONT_REGEXP_SLANT "-" FONT_SLANT "-"
5563 #define FONT_REGEXP_WEIGHT "-" FONT_WEIGHT "-"
5565 LONG
5566 x_to_w32_weight (lpw)
5567 char * lpw;
5569 if (!lpw) return (FW_DONTCARE);
5571 if (stricmp (lpw,"heavy") == 0) return FW_HEAVY;
5572 else if (stricmp (lpw,"extrabold") == 0) return FW_EXTRABOLD;
5573 else if (stricmp (lpw,"bold") == 0) return FW_BOLD;
5574 else if (stricmp (lpw,"demibold") == 0) return FW_SEMIBOLD;
5575 else if (stricmp (lpw,"semibold") == 0) return FW_SEMIBOLD;
5576 else if (stricmp (lpw,"medium") == 0) return FW_MEDIUM;
5577 else if (stricmp (lpw,"normal") == 0) return FW_NORMAL;
5578 else if (stricmp (lpw,"light") == 0) return FW_LIGHT;
5579 else if (stricmp (lpw,"extralight") == 0) return FW_EXTRALIGHT;
5580 else if (stricmp (lpw,"thin") == 0) return FW_THIN;
5581 else
5582 return FW_DONTCARE;
5586 char *
5587 w32_to_x_weight (fnweight)
5588 int fnweight;
5590 if (fnweight >= FW_HEAVY) return "heavy";
5591 if (fnweight >= FW_EXTRABOLD) return "extrabold";
5592 if (fnweight >= FW_BOLD) return "bold";
5593 if (fnweight >= FW_SEMIBOLD) return "demibold";
5594 if (fnweight >= FW_MEDIUM) return "medium";
5595 if (fnweight >= FW_NORMAL) return "normal";
5596 if (fnweight >= FW_LIGHT) return "light";
5597 if (fnweight >= FW_EXTRALIGHT) return "extralight";
5598 if (fnweight >= FW_THIN) return "thin";
5599 else
5600 return "*";
5603 LONG
5604 x_to_w32_charset (lpcs)
5605 char * lpcs;
5607 if (!lpcs) return (0);
5609 if (stricmp (lpcs,"ansi") == 0) return ANSI_CHARSET;
5610 else if (stricmp (lpcs,"iso8859-1") == 0) return ANSI_CHARSET;
5611 else if (stricmp (lpcs, "ms-symbol") == 0) return SYMBOL_CHARSET;
5612 /* Map all Japanese charsets to the Windows Shift-JIS charset. */
5613 else if (strnicmp (lpcs, "jis", 3) == 0) return SHIFTJIS_CHARSET;
5614 /* Map all GB charsets to the Windows GB2312 charset. */
5615 else if (strnicmp (lpcs, "gb2312", 6) == 0) return GB2312_CHARSET;
5616 /* Map all Big5 charsets to the Windows Big5 charset. */
5617 else if (strnicmp (lpcs, "big5", 4) == 0) return CHINESEBIG5_CHARSET;
5618 else if (stricmp (lpcs, "ksc5601.1987") == 0) return HANGEUL_CHARSET;
5619 else if (stricmp (lpcs, "ms-oem") == 0) return OEM_CHARSET;
5621 #ifdef EASTEUROPE_CHARSET
5622 else if (stricmp (lpcs, "iso8859-2") == 0) return EASTEUROPE_CHARSET;
5623 else if (stricmp (lpcs, "iso8859-3") == 0) return TURKISH_CHARSET;
5624 else if (stricmp (lpcs, "iso8859-4") == 0) return BALTIC_CHARSET;
5625 else if (stricmp (lpcs, "iso8859-5") == 0) return RUSSIAN_CHARSET;
5626 else if (stricmp (lpcs, "koi8") == 0) return RUSSIAN_CHARSET;
5627 else if (stricmp (lpcs, "iso8859-6") == 0) return ARABIC_CHARSET;
5628 else if (stricmp (lpcs, "iso8859-7") == 0) return GREEK_CHARSET;
5629 else if (stricmp (lpcs, "iso8859-8") == 0) return HEBREW_CHARSET;
5630 else if (stricmp (lpcs, "iso8859-9") == 0) return TURKISH_CHARSET;
5631 #ifndef VIETNAMESE_CHARSET
5632 #define VIETNAMESE_CHARSET 163
5633 #endif
5634 /* Map all Viscii charsets to the Windows Vietnamese charset. */
5635 else if (strnicmp (lpcs, "viscii", 6) == 0) return VIETNAMESE_CHARSET;
5636 else if (strnicmp (lpcs, "vscii", 5) == 0) return VIETNAMESE_CHARSET;
5637 /* Map all TIS charsets to the Windows Thai charset. */
5638 else if (strnicmp (lpcs, "tis620", 6) == 0) return THAI_CHARSET;
5639 else if (stricmp (lpcs, "mac") == 0) return MAC_CHARSET;
5640 else if (stricmp (lpcs, "ksc5601.1992") == 0) return JOHAB_CHARSET;
5641 /* For backwards compatibility with previous 20.4 pretests, map
5642 non-specific KSC charsets to the Windows Hangeul charset. */
5643 else if (strnicmp (lpcs, "ksc5601", 7) == 0) return HANGEUL_CHARSET;
5644 else if (stricmp (lpcs, "johab") == 0) return JOHAB_CHARSET;
5645 #endif
5647 #ifdef UNICODE_CHARSET
5648 else if (stricmp (lpcs,"iso10646") == 0) return UNICODE_CHARSET;
5649 else if (stricmp (lpcs, "unicode") == 0) return UNICODE_CHARSET;
5650 #endif
5651 else if (lpcs[0] == '#') return atoi (lpcs + 1);
5652 else
5653 return DEFAULT_CHARSET;
5656 char *
5657 w32_to_x_charset (fncharset)
5658 int fncharset;
5660 static char buf[16];
5662 switch (fncharset)
5664 /* ansi is considered iso8859-1, as most modern ansi fonts are. */
5665 case ANSI_CHARSET: return "iso8859-1";
5666 case DEFAULT_CHARSET: return "ascii-*";
5667 case SYMBOL_CHARSET: return "ms-symbol";
5668 case SHIFTJIS_CHARSET: return "jisx0208-sjis";
5669 case HANGEUL_CHARSET: return "ksc5601.1987-*";
5670 case GB2312_CHARSET: return "gb2312-*";
5671 case CHINESEBIG5_CHARSET: return "big5-*";
5672 case OEM_CHARSET: return "ms-oem";
5674 /* More recent versions of Windows (95 and NT4.0) define more
5675 character sets. */
5676 #ifdef EASTEUROPE_CHARSET
5677 case EASTEUROPE_CHARSET: return "iso8859-2";
5678 case TURKISH_CHARSET: return "iso8859-9";
5679 case BALTIC_CHARSET: return "iso8859-4";
5681 /* W95 with international support but not IE4 often has the
5682 KOI8-R codepage but not ISO8859-5. */
5683 case RUSSIAN_CHARSET:
5684 if (!IsValidCodePage(28595) && IsValidCodePage(20886))
5685 return "koi8-r";
5686 else
5687 return "iso8859-5";
5688 case ARABIC_CHARSET: return "iso8859-6";
5689 case GREEK_CHARSET: return "iso8859-7";
5690 case HEBREW_CHARSET: return "iso8859-8";
5691 case VIETNAMESE_CHARSET: return "viscii1.1-*";
5692 case THAI_CHARSET: return "tis620-*";
5693 case MAC_CHARSET: return "mac-*";
5694 case JOHAB_CHARSET: return "ksc5601.1992-*";
5696 #endif
5698 #ifdef UNICODE_CHARSET
5699 case UNICODE_CHARSET: return "iso10646-unicode";
5700 #endif
5702 /* Encode numerical value of unknown charset. */
5703 sprintf (buf, "*-#%u", fncharset);
5704 return buf;
5707 BOOL
5708 w32_to_x_font (lplogfont, lpxstr, len)
5709 LOGFONT * lplogfont;
5710 char * lpxstr;
5711 int len;
5713 char* fonttype;
5714 char *fontname;
5715 char height_pixels[8];
5716 char height_dpi[8];
5717 char width_pixels[8];
5718 char *fontname_dash;
5719 int display_resy = one_w32_display_info.resy;
5720 int display_resx = one_w32_display_info.resx;
5721 int bufsz;
5722 struct coding_system coding;
5724 if (!lpxstr) abort ();
5726 if (!lplogfont)
5727 return FALSE;
5729 if (lplogfont->lfOutPrecision == OUT_STRING_PRECIS)
5730 fonttype = "raster";
5731 else if (lplogfont->lfOutPrecision == OUT_STROKE_PRECIS)
5732 fonttype = "outline";
5733 else
5734 fonttype = "unknown";
5736 setup_coding_system (Fcheck_coding_system (Vw32_system_coding_system),
5737 &coding);
5738 coding.mode |= CODING_MODE_LAST_BLOCK;
5739 bufsz = decoding_buffer_size (&coding, LF_FACESIZE);
5741 fontname = alloca(sizeof(*fontname) * bufsz);
5742 decode_coding (&coding, lplogfont->lfFaceName, fontname,
5743 strlen(lplogfont->lfFaceName), bufsz - 1);
5744 *(fontname + coding.produced) = '\0';
5746 /* Replace dashes with underscores so the dashes are not
5747 misinterpreted. */
5748 fontname_dash = fontname;
5749 while (fontname_dash = strchr (fontname_dash, '-'))
5750 *fontname_dash = '_';
5752 if (lplogfont->lfHeight)
5754 sprintf (height_pixels, "%u", abs (lplogfont->lfHeight));
5755 sprintf (height_dpi, "%u",
5756 abs (lplogfont->lfHeight) * 720 / display_resy);
5758 else
5760 strcpy (height_pixels, "*");
5761 strcpy (height_dpi, "*");
5763 if (lplogfont->lfWidth)
5764 sprintf (width_pixels, "%u", lplogfont->lfWidth * 10);
5765 else
5766 strcpy (width_pixels, "*");
5768 _snprintf (lpxstr, len - 1,
5769 "-%s-%s-%s-%c-normal-normal-%s-%s-%d-%d-%c-%s-%s",
5770 fonttype, /* foundry */
5771 fontname, /* family */
5772 w32_to_x_weight (lplogfont->lfWeight), /* weight */
5773 lplogfont->lfItalic?'i':'r', /* slant */
5774 /* setwidth name */
5775 /* add style name */
5776 height_pixels, /* pixel size */
5777 height_dpi, /* point size */
5778 display_resx, /* resx */
5779 display_resy, /* resy */
5780 ((lplogfont->lfPitchAndFamily & 0x3) == VARIABLE_PITCH)
5781 ? 'p' : 'c', /* spacing */
5782 width_pixels, /* avg width */
5783 w32_to_x_charset (lplogfont->lfCharSet) /* charset registry
5784 and encoding*/
5787 lpxstr[len - 1] = 0; /* just to be sure */
5788 return (TRUE);
5791 BOOL
5792 x_to_w32_font (lpxstr, lplogfont)
5793 char * lpxstr;
5794 LOGFONT * lplogfont;
5796 struct coding_system coding;
5798 if (!lplogfont) return (FALSE);
5800 memset (lplogfont, 0, sizeof (*lplogfont));
5802 /* Set default value for each field. */
5803 #if 1
5804 lplogfont->lfOutPrecision = OUT_DEFAULT_PRECIS;
5805 lplogfont->lfClipPrecision = CLIP_DEFAULT_PRECIS;
5806 lplogfont->lfQuality = DEFAULT_QUALITY;
5807 #else
5808 /* go for maximum quality */
5809 lplogfont->lfOutPrecision = OUT_STROKE_PRECIS;
5810 lplogfont->lfClipPrecision = CLIP_STROKE_PRECIS;
5811 lplogfont->lfQuality = PROOF_QUALITY;
5812 #endif
5814 lplogfont->lfCharSet = DEFAULT_CHARSET;
5815 lplogfont->lfWeight = FW_DONTCARE;
5816 lplogfont->lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE;
5818 if (!lpxstr)
5819 return FALSE;
5821 /* Provide a simple escape mechanism for specifying Windows font names
5822 * directly -- if font spec does not beginning with '-', assume this
5823 * format:
5824 * "<font name>[:height in pixels[:width in pixels[:weight]]]"
5827 if (*lpxstr == '-')
5829 int fields, tem;
5830 char name[50], weight[20], slant, pitch, pixels[10], height[10],
5831 width[10], resy[10], remainder[20];
5832 char * encoding;
5833 int dpi = one_w32_display_info.height_in;
5835 fields = sscanf (lpxstr,
5836 "-%*[^-]-%49[^-]-%19[^-]-%c-%*[^-]-%*[^-]-%9[^-]-%9[^-]-%*[^-]-%9[^-]-%c-%9[^-]-%19s",
5837 name, weight, &slant, pixels, height, resy, &pitch, width, remainder);
5838 if (fields == EOF) return (FALSE);
5840 /* If wildcards cover more than one field, we don't know which
5841 field is which, so don't fill any in. */
5843 if (fields < 9)
5844 fields = 0;
5846 if (fields > 0 && name[0] != '*')
5848 int bufsize;
5849 unsigned char *buf;
5851 setup_coding_system
5852 (Fcheck_coding_system (Vw32_system_coding_system), &coding);
5853 bufsize = encoding_buffer_size (&coding, strlen (name));
5854 buf = (unsigned char *) alloca (bufsize);
5855 coding.mode |= CODING_MODE_LAST_BLOCK;
5856 encode_coding (&coding, name, buf, strlen (name), bufsize);
5857 if (coding.produced >= LF_FACESIZE)
5858 coding.produced = LF_FACESIZE - 1;
5859 buf[coding.produced] = 0;
5860 strcpy (lplogfont->lfFaceName, buf);
5862 else
5864 lplogfont->lfFaceName[0] = '\0';
5867 fields--;
5869 lplogfont->lfWeight = x_to_w32_weight ((fields > 0 ? weight : ""));
5871 fields--;
5873 if (!NILP (Vw32_enable_synthesized_fonts))
5874 lplogfont->lfItalic = (fields > 0 && slant == 'i');
5876 fields--;
5878 if (fields > 0 && pixels[0] != '*')
5879 lplogfont->lfHeight = atoi (pixels);
5881 fields--;
5882 fields--;
5883 if (fields > 0 && resy[0] != '*')
5885 tem = atoi (resy);
5886 if (tem > 0) dpi = tem;
5889 if (fields > -1 && lplogfont->lfHeight == 0 && height[0] != '*')
5890 lplogfont->lfHeight = atoi (height) * dpi / 720;
5892 if (fields > 0)
5893 lplogfont->lfPitchAndFamily =
5894 (fields > 0 && pitch == 'p') ? VARIABLE_PITCH : FIXED_PITCH;
5896 fields--;
5898 if (fields > 0 && width[0] != '*')
5899 lplogfont->lfWidth = atoi (width) / 10;
5901 fields--;
5903 /* Strip the trailing '-' if present. (it shouldn't be, as it
5904 fails the test against xlfd-tight-regexp in fontset.el). */
5906 int len = strlen (remainder);
5907 if (len > 0 && remainder[len-1] == '-')
5908 remainder[len-1] = 0;
5910 encoding = remainder;
5911 if (strncmp (encoding, "*-", 2) == 0)
5912 encoding += 2;
5913 lplogfont->lfCharSet = x_to_w32_charset (fields > 0 ? encoding : "");
5915 else
5917 int fields;
5918 char name[100], height[10], width[10], weight[20];
5920 fields = sscanf (lpxstr,
5921 "%99[^:]:%9[^:]:%9[^:]:%19s",
5922 name, height, width, weight);
5924 if (fields == EOF) return (FALSE);
5926 if (fields > 0)
5928 strncpy (lplogfont->lfFaceName,name, LF_FACESIZE);
5929 lplogfont->lfFaceName[LF_FACESIZE-1] = 0;
5931 else
5933 lplogfont->lfFaceName[0] = 0;
5936 fields--;
5938 if (fields > 0)
5939 lplogfont->lfHeight = atoi (height);
5941 fields--;
5943 if (fields > 0)
5944 lplogfont->lfWidth = atoi (width);
5946 fields--;
5948 lplogfont->lfWeight = x_to_w32_weight ((fields > 0 ? weight : ""));
5951 /* This makes TrueType fonts work better. */
5952 lplogfont->lfHeight = - abs (lplogfont->lfHeight);
5954 return (TRUE);
5957 /* Strip the pixel height and point height from the given xlfd, and
5958 return the pixel height. If no pixel height is specified, calculate
5959 one from the point height, or if that isn't defined either, return
5960 0 (which usually signifies a scalable font).
5962 int xlfd_strip_height (char *fontname)
5964 int pixel_height, point_height, dpi, field_number;
5965 char *read_from, *write_to;
5967 xassert (fontname);
5969 pixel_height = field_number = 0;
5970 write_to = NULL;
5972 /* Look for height fields. */
5973 for (read_from = fontname; *read_from; read_from++)
5975 if (*read_from == '-')
5977 field_number++;
5978 if (field_number == 7) /* Pixel height. */
5980 read_from++;
5981 write_to = read_from;
5983 /* Find end of field. */
5984 for (;*read_from && *read_from != '-'; read_from++)
5987 /* Split the fontname at end of field. */
5988 if (*read_from)
5990 *read_from = '\0';
5991 read_from++;
5993 pixel_height = atoi (write_to);
5994 /* Blank out field. */
5995 if (read_from > write_to)
5997 *write_to = '-';
5998 write_to++;
6000 /* If the pixel height field is at the end (partial xfld),
6001 return now. */
6002 else
6003 return pixel_height;
6005 /* If we got a pixel height, the point height can be
6006 ignored. Just blank it out and break now. */
6007 if (pixel_height)
6009 /* Find end of point size field. */
6010 for (; *read_from && *read_from != '-'; read_from++)
6013 if (*read_from)
6014 read_from++;
6016 /* Blank out the point size field. */
6017 if (read_from > write_to)
6019 *write_to = '-';
6020 write_to++;
6022 else
6023 return pixel_height;
6025 break;
6027 /* If the point height is already blank, break now. */
6028 if (*read_from == '-')
6030 read_from++;
6031 break;
6034 else if (field_number == 8)
6036 /* If we didn't get a pixel height, try to get the point
6037 height and convert that. */
6038 int point_size;
6039 char *point_size_start = read_from++;
6041 /* Find end of field. */
6042 for (; *read_from && *read_from != '-'; read_from++)
6045 if (*read_from)
6047 *read_from = '\0';
6048 read_from++;
6051 point_size = atoi (point_size_start);
6053 /* Convert to pixel height. */
6054 pixel_height = point_size
6055 * one_w32_display_info.height_in / 720;
6057 /* Blank out this field and break. */
6058 *write_to = '-';
6059 write_to++;
6060 break;
6065 /* Shift the rest of the font spec into place. */
6066 if (write_to && read_from > write_to)
6068 for (; *read_from; read_from++, write_to++)
6069 *write_to = *read_from;
6070 *write_to = '\0';
6073 return pixel_height;
6076 /* Assume parameter 1 is fully qualified, no wildcards. */
6077 BOOL
6078 w32_font_match (fontname, pattern)
6079 char * fontname;
6080 char * pattern;
6082 char *regex = alloca (strlen (pattern) * 2);
6083 char *font_name_copy = alloca (strlen (fontname) + 1);
6084 char *ptr;
6086 /* Copy fontname so we can modify it during comparison. */
6087 strcpy (font_name_copy, fontname);
6089 ptr = regex;
6090 *ptr++ = '^';
6092 /* Turn pattern into a regexp and do a regexp match. */
6093 for (; *pattern; pattern++)
6095 if (*pattern == '?')
6096 *ptr++ = '.';
6097 else if (*pattern == '*')
6099 *ptr++ = '.';
6100 *ptr++ = '*';
6102 else
6103 *ptr++ = *pattern;
6105 *ptr = '$';
6106 *(ptr + 1) = '\0';
6108 /* Strip out font heights and compare them seperately, since
6109 rounding error can cause mismatches. This also allows a
6110 comparison between a font that declares only a pixel height and a
6111 pattern that declares the point height.
6114 int font_height, pattern_height;
6116 font_height = xlfd_strip_height (font_name_copy);
6117 pattern_height = xlfd_strip_height (regex);
6119 /* Compare now, and don't bother doing expensive regexp matching
6120 if the heights differ. */
6121 if (font_height && pattern_height && (font_height != pattern_height))
6122 return FALSE;
6125 return (fast_c_string_match_ignore_case (build_string (regex),
6126 font_name_copy) >= 0);
6129 /* Callback functions, and a structure holding info they need, for
6130 listing system fonts on W32. We need one set of functions to do the
6131 job properly, but these don't work on NT 3.51 and earlier, so we
6132 have a second set which don't handle character sets properly to
6133 fall back on.
6135 In both cases, there are two passes made. The first pass gets one
6136 font from each family, the second pass lists all the fonts from
6137 each family. */
6139 typedef struct enumfont_t
6141 HDC hdc;
6142 int numFonts;
6143 LOGFONT logfont;
6144 XFontStruct *size_ref;
6145 Lisp_Object *pattern;
6146 Lisp_Object *tail;
6147 } enumfont_t;
6149 int CALLBACK
6150 enum_font_cb2 (lplf, lptm, FontType, lpef)
6151 ENUMLOGFONT * lplf;
6152 NEWTEXTMETRIC * lptm;
6153 int FontType;
6154 enumfont_t * lpef;
6156 if (lplf->elfLogFont.lfStrikeOut || lplf->elfLogFont.lfUnderline)
6157 return (1);
6159 /* Check that the character set matches if it was specified */
6160 if (lpef->logfont.lfCharSet != DEFAULT_CHARSET &&
6161 lplf->elfLogFont.lfCharSet != lpef->logfont.lfCharSet)
6162 return (1);
6165 char buf[100];
6166 Lisp_Object width = Qnil;
6168 /* Truetype fonts do not report their true metrics until loaded */
6169 if (FontType != RASTER_FONTTYPE)
6171 if (!NILP (*(lpef->pattern)))
6173 /* Scalable fonts are as big as you want them to be. */
6174 lplf->elfLogFont.lfHeight = lpef->logfont.lfHeight;
6175 lplf->elfLogFont.lfWidth = lpef->logfont.lfWidth;
6176 width = make_number (lpef->logfont.lfWidth);
6178 else
6180 lplf->elfLogFont.lfHeight = 0;
6181 lplf->elfLogFont.lfWidth = 0;
6185 /* Make sure the height used here is the same as everywhere
6186 else (ie character height, not cell height). */
6187 if (lplf->elfLogFont.lfHeight > 0)
6189 /* lptm can be trusted for RASTER fonts, but not scalable ones. */
6190 if (FontType == RASTER_FONTTYPE)
6191 lplf->elfLogFont.lfHeight = lptm->tmInternalLeading - lptm->tmHeight;
6192 else
6193 lplf->elfLogFont.lfHeight = -lplf->elfLogFont.lfHeight;
6196 if (!w32_to_x_font (&(lplf->elfLogFont), buf, 100))
6197 return (0);
6199 if (NILP (*(lpef->pattern))
6200 || w32_font_match (buf, XSTRING (*(lpef->pattern))->data))
6202 *lpef->tail = Fcons (Fcons (build_string (buf), width), Qnil);
6203 lpef->tail = &(XCDR (*lpef->tail));
6204 lpef->numFonts++;
6208 return (1);
6211 int CALLBACK
6212 enum_font_cb1 (lplf, lptm, FontType, lpef)
6213 ENUMLOGFONT * lplf;
6214 NEWTEXTMETRIC * lptm;
6215 int FontType;
6216 enumfont_t * lpef;
6218 return EnumFontFamilies (lpef->hdc,
6219 lplf->elfLogFont.lfFaceName,
6220 (FONTENUMPROC) enum_font_cb2,
6221 (LPARAM) lpef);
6225 int CALLBACK
6226 enum_fontex_cb2 (lplf, lptm, font_type, lpef)
6227 ENUMLOGFONTEX * lplf;
6228 NEWTEXTMETRICEX * lptm;
6229 int font_type;
6230 enumfont_t * lpef;
6232 /* We are not interested in the extra info we get back from the 'Ex
6233 version - only the fact that we get character set variations
6234 enumerated seperately. */
6235 return enum_font_cb2 ((ENUMLOGFONT *) lplf, (NEWTEXTMETRIC *) lptm,
6236 font_type, lpef);
6239 int CALLBACK
6240 enum_fontex_cb1 (lplf, lptm, font_type, lpef)
6241 ENUMLOGFONTEX * lplf;
6242 NEWTEXTMETRICEX * lptm;
6243 int font_type;
6244 enumfont_t * lpef;
6246 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
6247 FARPROC enum_font_families_ex
6248 = GetProcAddress ( gdi32, "EnumFontFamiliesExA");
6249 /* We don't really expect EnumFontFamiliesEx to disappear once we
6250 get here, so don't bother handling it gracefully. */
6251 if (enum_font_families_ex == NULL)
6252 error ("gdi32.dll has disappeared!");
6253 return enum_font_families_ex (lpef->hdc,
6254 &lplf->elfLogFont,
6255 (FONTENUMPROC) enum_fontex_cb2,
6256 (LPARAM) lpef, 0);
6259 /* Interface to fontset handler. (adapted from mw32font.c in Meadow
6260 and xterm.c in Emacs 20.3) */
6262 Lisp_Object w32_list_bdf_fonts (Lisp_Object pattern, int max_names)
6264 char *fontname, *ptnstr;
6265 Lisp_Object list, tem, newlist = Qnil;
6266 int n_fonts = 0;
6268 list = Vw32_bdf_filename_alist;
6269 ptnstr = XSTRING (pattern)->data;
6271 for ( ; CONSP (list); list = XCDR (list))
6273 tem = XCAR (list);
6274 if (CONSP (tem))
6275 fontname = XSTRING (XCAR (tem))->data;
6276 else if (STRINGP (tem))
6277 fontname = XSTRING (tem)->data;
6278 else
6279 continue;
6281 if (w32_font_match (fontname, ptnstr))
6283 newlist = Fcons (XCAR (tem), newlist);
6284 n_fonts++;
6285 if (n_fonts >= max_names)
6286 break;
6290 return newlist;
6293 Lisp_Object w32_list_synthesized_fonts (FRAME_PTR f, Lisp_Object pattern,
6294 int size, int max_names);
6296 /* Return a list of names of available fonts matching PATTERN on frame
6297 F. If SIZE is not 0, it is the size (maximum bound width) of fonts
6298 to be listed. Frame F NULL means we have not yet created any
6299 frame, which means we can't get proper size info, as we don't have
6300 a device context to use for GetTextMetrics.
6301 MAXNAMES sets a limit on how many fonts to match. */
6303 Lisp_Object
6304 w32_list_fonts (FRAME_PTR f, Lisp_Object pattern, int size, int maxnames )
6306 Lisp_Object patterns, key = Qnil, tem, tpat;
6307 Lisp_Object list = Qnil, newlist = Qnil, second_best = Qnil;
6308 struct w32_display_info *dpyinfo = &one_w32_display_info;
6309 int n_fonts = 0;
6311 patterns = Fassoc (pattern, Valternate_fontname_alist);
6312 if (NILP (patterns))
6313 patterns = Fcons (pattern, Qnil);
6315 for (; CONSP (patterns); patterns = XCDR (patterns))
6317 enumfont_t ef;
6319 tpat = XCAR (patterns);
6321 /* See if we cached the result for this particular query.
6322 The cache is an alist of the form:
6323 ((PATTERN (FONTNAME . WIDTH) ...) ...)
6325 if (tem = XCDR (dpyinfo->name_list_element),
6326 !NILP (list = Fassoc (tpat, tem)))
6328 list = Fcdr_safe (list);
6329 /* We have a cached list. Don't have to get the list again. */
6330 goto label_cached;
6333 BLOCK_INPUT;
6334 /* At first, put PATTERN in the cache. */
6335 list = Qnil;
6336 ef.pattern = &tpat;
6337 ef.tail = &list;
6338 ef.numFonts = 0;
6340 /* Use EnumFontFamiliesEx where it is available, as it knows
6341 about character sets. Fall back to EnumFontFamilies for
6342 older versions of NT that don't support the 'Ex function. */
6343 x_to_w32_font (STRINGP (tpat) ? XSTRING (tpat)->data :
6344 NULL, &ef.logfont);
6346 LOGFONT font_match_pattern;
6347 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
6348 FARPROC enum_font_families_ex
6349 = GetProcAddress ( gdi32, "EnumFontFamiliesExA");
6351 /* We do our own pattern matching so we can handle wildcards. */
6352 font_match_pattern.lfFaceName[0] = 0;
6353 font_match_pattern.lfPitchAndFamily = 0;
6354 /* We can use the charset, because if it is a wildcard it will
6355 be DEFAULT_CHARSET anyway. */
6356 font_match_pattern.lfCharSet = ef.logfont.lfCharSet;
6358 ef.hdc = GetDC (dpyinfo->root_window);
6360 if (enum_font_families_ex)
6361 enum_font_families_ex (ef.hdc,
6362 &font_match_pattern,
6363 (FONTENUMPROC) enum_fontex_cb1,
6364 (LPARAM) &ef, 0);
6365 else
6366 EnumFontFamilies (ef.hdc, NULL, (FONTENUMPROC) enum_font_cb1,
6367 (LPARAM)&ef);
6369 ReleaseDC (dpyinfo->root_window, ef.hdc);
6372 UNBLOCK_INPUT;
6374 /* Make a list of the fonts we got back.
6375 Store that in the font cache for the display. */
6376 XCDR (dpyinfo->name_list_element)
6377 = Fcons (Fcons (tpat, list),
6378 XCDR (dpyinfo->name_list_element));
6380 label_cached:
6381 if (NILP (list)) continue; /* Try the remaining alternatives. */
6383 newlist = second_best = Qnil;
6385 /* Make a list of the fonts that have the right width. */
6386 for (; CONSP (list); list = XCDR (list))
6388 int found_size;
6389 tem = XCAR (list);
6391 if (!CONSP (tem))
6392 continue;
6393 if (NILP (XCAR (tem)))
6394 continue;
6395 if (!size)
6397 newlist = Fcons (XCAR (tem), newlist);
6398 n_fonts++;
6399 if (n_fonts >= maxnames)
6400 break;
6401 else
6402 continue;
6404 if (!INTEGERP (XCDR (tem)))
6406 /* Since we don't yet know the size of the font, we must
6407 load it and try GetTextMetrics. */
6408 W32FontStruct thisinfo;
6409 LOGFONT lf;
6410 HDC hdc;
6411 HANDLE oldobj;
6413 if (!x_to_w32_font (XSTRING (XCAR (tem))->data, &lf))
6414 continue;
6416 BLOCK_INPUT;
6417 thisinfo.bdf = NULL;
6418 thisinfo.hfont = CreateFontIndirect (&lf);
6419 if (thisinfo.hfont == NULL)
6420 continue;
6422 hdc = GetDC (dpyinfo->root_window);
6423 oldobj = SelectObject (hdc, thisinfo.hfont);
6424 if (GetTextMetrics (hdc, &thisinfo.tm))
6425 XCDR (tem) = make_number (FONT_WIDTH (&thisinfo));
6426 else
6427 XCDR (tem) = make_number (0);
6428 SelectObject (hdc, oldobj);
6429 ReleaseDC (dpyinfo->root_window, hdc);
6430 DeleteObject(thisinfo.hfont);
6431 UNBLOCK_INPUT;
6433 found_size = XINT (XCDR (tem));
6434 if (found_size == size)
6436 newlist = Fcons (XCAR (tem), newlist);
6437 n_fonts++;
6438 if (n_fonts >= maxnames)
6439 break;
6441 /* keep track of the closest matching size in case
6442 no exact match is found. */
6443 else if (found_size > 0)
6445 if (NILP (second_best))
6446 second_best = tem;
6448 else if (found_size < size)
6450 if (XINT (XCDR (second_best)) > size
6451 || XINT (XCDR (second_best)) < found_size)
6452 second_best = tem;
6454 else
6456 if (XINT (XCDR (second_best)) > size
6457 && XINT (XCDR (second_best)) >
6458 found_size)
6459 second_best = tem;
6464 if (!NILP (newlist))
6465 break;
6466 else if (!NILP (second_best))
6468 newlist = Fcons (XCAR (second_best), Qnil);
6469 break;
6473 /* Include any bdf fonts. */
6474 if (n_fonts < maxnames)
6476 Lisp_Object combined[2];
6477 combined[0] = w32_list_bdf_fonts (pattern, maxnames - n_fonts);
6478 combined[1] = newlist;
6479 newlist = Fnconc(2, combined);
6482 /* If we can't find a font that matches, check if Windows would be
6483 able to synthesize it from a different style. */
6484 if (NILP (newlist) && !NILP (Vw32_enable_synthesized_fonts))
6485 newlist = w32_list_synthesized_fonts (f, pattern, size, maxnames);
6487 return newlist;
6490 Lisp_Object
6491 w32_list_synthesized_fonts (f, pattern, size, max_names)
6492 FRAME_PTR f;
6493 Lisp_Object pattern;
6494 int size;
6495 int max_names;
6497 int fields;
6498 char *full_pattn, *new_pattn, foundary[50], family[50], *pattn_part2;
6499 char style[20], slant;
6500 Lisp_Object matches, match, tem, synthed_matches = Qnil;
6502 full_pattn = XSTRING (pattern)->data;
6504 pattn_part2 = alloca (XSTRING (pattern)->size);
6505 /* Allow some space for wildcard expansion. */
6506 new_pattn = alloca (XSTRING (pattern)->size + 100);
6508 fields = sscanf (full_pattn, "-%49[^-]-%49[^-]-%19[^-]-%c-%s",
6509 foundary, family, style, &slant, pattn_part2);
6510 if (fields == EOF || fields < 5)
6511 return Qnil;
6513 /* If the style and slant are wildcards already there is no point
6514 checking again (and we don't want to keep recursing). */
6515 if (*style == '*' && slant == '*')
6516 return Qnil;
6518 sprintf (new_pattn, "-%s-%s-*-*-%s", foundary, family, pattn_part2);
6520 matches = w32_list_fonts (f, build_string (new_pattn), size, max_names);
6522 for ( ; CONSP (matches); matches = XCDR (matches))
6524 tem = XCAR (matches);
6525 if (!STRINGP (tem))
6526 continue;
6528 full_pattn = XSTRING (tem)->data;
6529 fields = sscanf (full_pattn, "-%49[^-]-%49[^-]-%*[^-]-%*c-%s",
6530 foundary, family, pattn_part2);
6531 if (fields == EOF || fields < 3)
6532 continue;
6534 sprintf (new_pattn, "-%s-%s-%s-%c-%s", foundary, family, style,
6535 slant, pattn_part2);
6537 synthed_matches = Fcons (build_string (new_pattn),
6538 synthed_matches);
6541 return synthed_matches;
6545 /* Return a pointer to struct font_info of font FONT_IDX of frame F. */
6546 struct font_info *
6547 w32_get_font_info (f, font_idx)
6548 FRAME_PTR f;
6549 int font_idx;
6551 return (FRAME_W32_FONT_TABLE (f) + font_idx);
6555 struct font_info*
6556 w32_query_font (struct frame *f, char *fontname)
6558 int i;
6559 struct font_info *pfi;
6561 pfi = FRAME_W32_FONT_TABLE (f);
6563 for (i = 0; i < one_w32_display_info.n_fonts ;i++, pfi++)
6565 if (strcmp(pfi->name, fontname) == 0) return pfi;
6568 return NULL;
6571 /* Find a CCL program for a font specified by FONTP, and set the member
6572 `encoder' of the structure. */
6574 void
6575 w32_find_ccl_program (fontp)
6576 struct font_info *fontp;
6578 Lisp_Object list, elt;
6580 for (list = Vfont_ccl_encoder_alist; CONSP (list); list = XCDR (list))
6582 elt = XCAR (list);
6583 if (CONSP (elt)
6584 && STRINGP (XCAR (elt))
6585 && (fast_c_string_match_ignore_case (XCAR (elt), fontp->name)
6586 >= 0))
6587 break;
6589 if (! NILP (list))
6591 struct ccl_program *ccl
6592 = (struct ccl_program *) xmalloc (sizeof (struct ccl_program));
6594 if (setup_ccl_program (ccl, XCDR (elt)) < 0)
6595 xfree (ccl);
6596 else
6597 fontp->font_encoder = ccl;
6602 DEFUN ("w32-find-bdf-fonts", Fw32_find_bdf_fonts, Sw32_find_bdf_fonts,
6603 1, 1, 0,
6604 "Return a list of BDF fonts in DIR, suitable for appending to\n\
6605 w32-bdf-filename-alist. Fonts which do not contain an xfld description\n\
6606 will not be included in the list. DIR may be a list of directories.")
6607 (directory)
6608 Lisp_Object directory;
6610 Lisp_Object list = Qnil;
6611 struct gcpro gcpro1, gcpro2;
6613 if (!CONSP (directory))
6614 return w32_find_bdf_fonts_in_dir (directory);
6616 for ( ; CONSP (directory); directory = XCDR (directory))
6618 Lisp_Object pair[2];
6619 pair[0] = list;
6620 pair[1] = Qnil;
6621 GCPRO2 (directory, list);
6622 pair[1] = w32_find_bdf_fonts_in_dir( XCAR (directory) );
6623 list = Fnconc( 2, pair );
6624 UNGCPRO;
6626 return list;
6629 /* Find BDF files in a specified directory. (use GCPRO when calling,
6630 as this calls lisp to get a directory listing). */
6631 Lisp_Object w32_find_bdf_fonts_in_dir( Lisp_Object directory )
6633 Lisp_Object filelist, list = Qnil;
6634 char fontname[100];
6636 if (!STRINGP(directory))
6637 return Qnil;
6639 filelist = Fdirectory_files (directory, Qt,
6640 build_string (".*\\.[bB][dD][fF]"), Qt);
6642 for ( ; CONSP(filelist); filelist = XCDR (filelist))
6644 Lisp_Object filename = XCAR (filelist);
6645 if (w32_BDF_to_x_font (XSTRING (filename)->data, fontname, 100))
6646 store_in_alist (&list, build_string (fontname), filename);
6648 return list;
6652 DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0,
6653 "Return non-nil if color COLOR is supported on frame FRAME.\n\
6654 If FRAME is omitted or nil, use the selected frame.")
6655 (color, frame)
6656 Lisp_Object color, frame;
6658 XColor foo;
6659 FRAME_PTR f = check_x_frame (frame);
6661 CHECK_STRING (color, 1);
6663 if (w32_defined_color (f, XSTRING (color)->data, &foo, 0))
6664 return Qt;
6665 else
6666 return Qnil;
6669 DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0,
6670 "Return a description of the color named COLOR on frame FRAME.\n\
6671 The value is a list of integer RGB values--(RED GREEN BLUE).\n\
6672 These values appear to range from 0 to 65280 or 65535, depending\n\
6673 on the system; white is (65280 65280 65280) or (65535 65535 65535).\n\
6674 If FRAME is omitted or nil, use the selected frame.")
6675 (color, frame)
6676 Lisp_Object color, frame;
6678 XColor foo;
6679 FRAME_PTR f = check_x_frame (frame);
6681 CHECK_STRING (color, 1);
6683 if (w32_defined_color (f, XSTRING (color)->data, &foo, 0))
6685 Lisp_Object rgb[3];
6687 rgb[0] = make_number ((GetRValue (foo.pixel) << 8)
6688 | GetRValue (foo.pixel));
6689 rgb[1] = make_number ((GetGValue (foo.pixel) << 8)
6690 | GetGValue (foo.pixel));
6691 rgb[2] = make_number ((GetBValue (foo.pixel) << 8)
6692 | GetBValue (foo.pixel));
6693 return Flist (3, rgb);
6695 else
6696 return Qnil;
6699 DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0,
6700 "Return t if the X display supports color.\n\
6701 The optional argument DISPLAY specifies which display to ask about.\n\
6702 DISPLAY should be either a frame or a display name (a string).\n\
6703 If omitted or nil, that stands for the selected frame's display.")
6704 (display)
6705 Lisp_Object display;
6707 struct w32_display_info *dpyinfo = check_x_display_info (display);
6709 if ((dpyinfo->n_planes * dpyinfo->n_cbits) <= 2)
6710 return Qnil;
6712 return Qt;
6715 DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p,
6716 0, 1, 0,
6717 "Return t if the X display supports shades of gray.\n\
6718 Note that color displays do support shades of gray.\n\
6719 The optional argument DISPLAY specifies which display to ask about.\n\
6720 DISPLAY should be either a frame or a display name (a string).\n\
6721 If omitted or nil, that stands for the selected frame's display.")
6722 (display)
6723 Lisp_Object display;
6725 struct w32_display_info *dpyinfo = check_x_display_info (display);
6727 if ((dpyinfo->n_planes * dpyinfo->n_cbits) <= 1)
6728 return Qnil;
6730 return Qt;
6733 DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width,
6734 0, 1, 0,
6735 "Returns the width in pixels of the X display DISPLAY.\n\
6736 The optional argument DISPLAY specifies which display to ask about.\n\
6737 DISPLAY should be either a frame or a display name (a string).\n\
6738 If omitted or nil, that stands for the selected frame's display.")
6739 (display)
6740 Lisp_Object display;
6742 struct w32_display_info *dpyinfo = check_x_display_info (display);
6744 return make_number (dpyinfo->width);
6747 DEFUN ("x-display-pixel-height", Fx_display_pixel_height,
6748 Sx_display_pixel_height, 0, 1, 0,
6749 "Returns the height in pixels of the X display DISPLAY.\n\
6750 The optional argument DISPLAY specifies which display to ask about.\n\
6751 DISPLAY should be either a frame or a display name (a string).\n\
6752 If omitted or nil, that stands for the selected frame's display.")
6753 (display)
6754 Lisp_Object display;
6756 struct w32_display_info *dpyinfo = check_x_display_info (display);
6758 return make_number (dpyinfo->height);
6761 DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes,
6762 0, 1, 0,
6763 "Returns the number of bitplanes of the display DISPLAY.\n\
6764 The optional argument DISPLAY specifies which display to ask about.\n\
6765 DISPLAY should be either a frame or a display name (a string).\n\
6766 If omitted or nil, that stands for the selected frame's display.")
6767 (display)
6768 Lisp_Object display;
6770 struct w32_display_info *dpyinfo = check_x_display_info (display);
6772 return make_number (dpyinfo->n_planes * dpyinfo->n_cbits);
6775 DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells,
6776 0, 1, 0,
6777 "Returns the number of color cells of the display DISPLAY.\n\
6778 The optional argument DISPLAY specifies which display to ask about.\n\
6779 DISPLAY should be either a frame or a display name (a string).\n\
6780 If omitted or nil, that stands for the selected frame's display.")
6781 (display)
6782 Lisp_Object display;
6784 struct w32_display_info *dpyinfo = check_x_display_info (display);
6785 HDC hdc;
6786 int cap;
6788 hdc = GetDC (dpyinfo->root_window);
6789 if (dpyinfo->has_palette)
6790 cap = GetDeviceCaps (hdc,SIZEPALETTE);
6791 else
6792 cap = GetDeviceCaps (hdc,NUMCOLORS);
6794 ReleaseDC (dpyinfo->root_window, hdc);
6796 return make_number (cap);
6799 DEFUN ("x-server-max-request-size", Fx_server_max_request_size,
6800 Sx_server_max_request_size,
6801 0, 1, 0,
6802 "Returns the maximum request size of the server of display DISPLAY.\n\
6803 The optional argument DISPLAY specifies which display to ask about.\n\
6804 DISPLAY should be either a frame or a display name (a string).\n\
6805 If omitted or nil, that stands for the selected frame's display.")
6806 (display)
6807 Lisp_Object display;
6809 struct w32_display_info *dpyinfo = check_x_display_info (display);
6811 return make_number (1);
6814 DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
6815 "Returns the vendor ID string of the W32 system (Microsoft).\n\
6816 The optional argument DISPLAY specifies which display to ask about.\n\
6817 DISPLAY should be either a frame or a display name (a string).\n\
6818 If omitted or nil, that stands for the selected frame's display.")
6819 (display)
6820 Lisp_Object display;
6822 struct w32_display_info *dpyinfo = check_x_display_info (display);
6823 char *vendor = "Microsoft Corp.";
6825 if (! vendor) vendor = "";
6826 return build_string (vendor);
6829 DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0,
6830 "Returns the version numbers of the server of display DISPLAY.\n\
6831 The value is a list of three integers: the major and minor\n\
6832 version numbers, and the vendor-specific release\n\
6833 number. See also the function `x-server-vendor'.\n\n\
6834 The optional argument DISPLAY specifies which display to ask about.\n\
6835 DISPLAY should be either a frame or a display name (a string).\n\
6836 If omitted or nil, that stands for the selected frame's display.")
6837 (display)
6838 Lisp_Object display;
6840 struct w32_display_info *dpyinfo = check_x_display_info (display);
6842 return Fcons (make_number (w32_major_version),
6843 Fcons (make_number (w32_minor_version), Qnil));
6846 DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0,
6847 "Returns the number of screens on the server of display DISPLAY.\n\
6848 The optional argument DISPLAY specifies which display to ask about.\n\
6849 DISPLAY should be either a frame or a display name (a string).\n\
6850 If omitted or nil, that stands for the selected frame's display.")
6851 (display)
6852 Lisp_Object display;
6854 struct w32_display_info *dpyinfo = check_x_display_info (display);
6856 return make_number (1);
6859 DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0,
6860 "Returns the height in millimeters of the X display DISPLAY.\n\
6861 The optional argument DISPLAY specifies which display to ask about.\n\
6862 DISPLAY should be either a frame or a display name (a string).\n\
6863 If omitted or nil, that stands for the selected frame's display.")
6864 (display)
6865 Lisp_Object display;
6867 struct w32_display_info *dpyinfo = check_x_display_info (display);
6868 HDC hdc;
6869 int cap;
6871 hdc = GetDC (dpyinfo->root_window);
6873 cap = GetDeviceCaps (hdc, VERTSIZE);
6875 ReleaseDC (dpyinfo->root_window, hdc);
6877 return make_number (cap);
6880 DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0,
6881 "Returns the width in millimeters of the X display DISPLAY.\n\
6882 The optional argument DISPLAY specifies which display to ask about.\n\
6883 DISPLAY should be either a frame or a display name (a string).\n\
6884 If omitted or nil, that stands for the selected frame's display.")
6885 (display)
6886 Lisp_Object display;
6888 struct w32_display_info *dpyinfo = check_x_display_info (display);
6890 HDC hdc;
6891 int cap;
6893 hdc = GetDC (dpyinfo->root_window);
6895 cap = GetDeviceCaps (hdc, HORZSIZE);
6897 ReleaseDC (dpyinfo->root_window, hdc);
6899 return make_number (cap);
6902 DEFUN ("x-display-backing-store", Fx_display_backing_store,
6903 Sx_display_backing_store, 0, 1, 0,
6904 "Returns an indication of whether display DISPLAY does backing store.\n\
6905 The value may be `always', `when-mapped', or `not-useful'.\n\
6906 The optional argument DISPLAY specifies which display to ask about.\n\
6907 DISPLAY should be either a frame or a display name (a string).\n\
6908 If omitted or nil, that stands for the selected frame's display.")
6909 (display)
6910 Lisp_Object display;
6912 return intern ("not-useful");
6915 DEFUN ("x-display-visual-class", Fx_display_visual_class,
6916 Sx_display_visual_class, 0, 1, 0,
6917 "Returns the visual class of the display DISPLAY.\n\
6918 The value is one of the symbols `static-gray', `gray-scale',\n\
6919 `static-color', `pseudo-color', `true-color', or `direct-color'.\n\n\
6920 The optional argument DISPLAY specifies which display to ask about.\n\
6921 DISPLAY should be either a frame or a display name (a string).\n\
6922 If omitted or nil, that stands for the selected frame's display.")
6923 (display)
6924 Lisp_Object display;
6926 struct w32_display_info *dpyinfo = check_x_display_info (display);
6928 #if 0
6929 switch (dpyinfo->visual->class)
6931 case StaticGray: return (intern ("static-gray"));
6932 case GrayScale: return (intern ("gray-scale"));
6933 case StaticColor: return (intern ("static-color"));
6934 case PseudoColor: return (intern ("pseudo-color"));
6935 case TrueColor: return (intern ("true-color"));
6936 case DirectColor: return (intern ("direct-color"));
6937 default:
6938 error ("Display has an unknown visual class");
6940 #endif
6942 error ("Display has an unknown visual class");
6945 DEFUN ("x-display-save-under", Fx_display_save_under,
6946 Sx_display_save_under, 0, 1, 0,
6947 "Returns t if the display DISPLAY supports the save-under feature.\n\
6948 The optional argument DISPLAY specifies which display to ask about.\n\
6949 DISPLAY should be either a frame or a display name (a string).\n\
6950 If omitted or nil, that stands for the selected frame's display.")
6951 (display)
6952 Lisp_Object display;
6954 struct w32_display_info *dpyinfo = check_x_display_info (display);
6956 return Qnil;
6960 x_pixel_width (f)
6961 register struct frame *f;
6963 return PIXEL_WIDTH (f);
6967 x_pixel_height (f)
6968 register struct frame *f;
6970 return PIXEL_HEIGHT (f);
6974 x_char_width (f)
6975 register struct frame *f;
6977 return FONT_WIDTH (f->output_data.w32->font);
6981 x_char_height (f)
6982 register struct frame *f;
6984 return f->output_data.w32->line_height;
6988 x_screen_planes (f)
6989 register struct frame *f;
6991 return FRAME_W32_DISPLAY_INFO (f)->n_planes;
6994 /* Return the display structure for the display named NAME.
6995 Open a new connection if necessary. */
6997 struct w32_display_info *
6998 x_display_info_for_name (name)
6999 Lisp_Object name;
7001 Lisp_Object names;
7002 struct w32_display_info *dpyinfo;
7004 CHECK_STRING (name, 0);
7006 for (dpyinfo = &one_w32_display_info, names = w32_display_name_list;
7007 dpyinfo;
7008 dpyinfo = dpyinfo->next, names = XCDR (names))
7010 Lisp_Object tem;
7011 tem = Fstring_equal (XCAR (XCAR (names)), name);
7012 if (!NILP (tem))
7013 return dpyinfo;
7016 /* Use this general default value to start with. */
7017 Vx_resource_name = Vinvocation_name;
7019 validate_x_resource_name ();
7021 dpyinfo = w32_term_init (name, (unsigned char *)0,
7022 (char *) XSTRING (Vx_resource_name)->data);
7024 if (dpyinfo == 0)
7025 error ("Cannot connect to server %s", XSTRING (name)->data);
7027 w32_in_use = 1;
7028 XSETFASTINT (Vwindow_system_version, 3);
7030 return dpyinfo;
7033 DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection,
7034 1, 3, 0, "Open a connection to a server.\n\
7035 DISPLAY is the name of the display to connect to.\n\
7036 Optional second arg XRM-STRING is a string of resources in xrdb format.\n\
7037 If the optional third arg MUST-SUCCEED is non-nil,\n\
7038 terminate Emacs if we can't open the connection.")
7039 (display, xrm_string, must_succeed)
7040 Lisp_Object display, xrm_string, must_succeed;
7042 unsigned char *xrm_option;
7043 struct w32_display_info *dpyinfo;
7045 CHECK_STRING (display, 0);
7046 if (! NILP (xrm_string))
7047 CHECK_STRING (xrm_string, 1);
7049 if (! EQ (Vwindow_system, intern ("w32")))
7050 error ("Not using Microsoft Windows");
7052 /* Allow color mapping to be defined externally; first look in user's
7053 HOME directory, then in Emacs etc dir for a file called rgb.txt. */
7055 Lisp_Object color_file;
7056 struct gcpro gcpro1;
7058 color_file = build_string("~/rgb.txt");
7060 GCPRO1 (color_file);
7062 if (NILP (Ffile_readable_p (color_file)))
7063 color_file =
7064 Fexpand_file_name (build_string ("rgb.txt"),
7065 Fsymbol_value (intern ("data-directory")));
7067 Vw32_color_map = Fw32_load_color_file (color_file);
7069 UNGCPRO;
7071 if (NILP (Vw32_color_map))
7072 Vw32_color_map = Fw32_default_color_map ();
7074 if (! NILP (xrm_string))
7075 xrm_option = (unsigned char *) XSTRING (xrm_string)->data;
7076 else
7077 xrm_option = (unsigned char *) 0;
7079 /* Use this general default value to start with. */
7080 /* First remove .exe suffix from invocation-name - it looks ugly. */
7082 char basename[ MAX_PATH ], *str;
7084 strcpy (basename, XSTRING (Vinvocation_name)->data);
7085 str = strrchr (basename, '.');
7086 if (str) *str = 0;
7087 Vinvocation_name = build_string (basename);
7089 Vx_resource_name = Vinvocation_name;
7091 validate_x_resource_name ();
7093 /* This is what opens the connection and sets x_current_display.
7094 This also initializes many symbols, such as those used for input. */
7095 dpyinfo = w32_term_init (display, xrm_option,
7096 (char *) XSTRING (Vx_resource_name)->data);
7098 if (dpyinfo == 0)
7100 if (!NILP (must_succeed))
7101 fatal ("Cannot connect to server %s.\n",
7102 XSTRING (display)->data);
7103 else
7104 error ("Cannot connect to server %s", XSTRING (display)->data);
7107 w32_in_use = 1;
7109 XSETFASTINT (Vwindow_system_version, 3);
7110 return Qnil;
7113 DEFUN ("x-close-connection", Fx_close_connection,
7114 Sx_close_connection, 1, 1, 0,
7115 "Close the connection to DISPLAY's server.\n\
7116 For DISPLAY, specify either a frame or a display name (a string).\n\
7117 If DISPLAY is nil, that stands for the selected frame's display.")
7118 (display)
7119 Lisp_Object display;
7121 struct w32_display_info *dpyinfo = check_x_display_info (display);
7122 int i;
7124 if (dpyinfo->reference_count > 0)
7125 error ("Display still has frames on it");
7127 BLOCK_INPUT;
7128 /* Free the fonts in the font table. */
7129 for (i = 0; i < dpyinfo->n_fonts; i++)
7130 if (dpyinfo->font_table[i].name)
7132 xfree (dpyinfo->font_table[i].name);
7133 /* Don't free the full_name string;
7134 it is always shared with something else. */
7135 w32_unload_font (dpyinfo, dpyinfo->font_table[i].font);
7137 x_destroy_all_bitmaps (dpyinfo);
7139 x_delete_display (dpyinfo);
7140 UNBLOCK_INPUT;
7142 return Qnil;
7145 DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0,
7146 "Return the list of display names that Emacs has connections to.")
7149 Lisp_Object tail, result;
7151 result = Qnil;
7152 for (tail = w32_display_name_list; ! NILP (tail); tail = XCDR (tail))
7153 result = Fcons (XCAR (XCAR (tail)), result);
7155 return result;
7158 DEFUN ("x-synchronize", Fx_synchronize, Sx_synchronize, 1, 2, 0,
7159 "If ON is non-nil, report errors as soon as the erring request is made.\n\
7160 If ON is nil, allow buffering of requests.\n\
7161 This is a noop on W32 systems.\n\
7162 The optional second argument DISPLAY specifies which display to act on.\n\
7163 DISPLAY should be either a frame or a display name (a string).\n\
7164 If DISPLAY is omitted or nil, that stands for the selected frame's display.")
7165 (on, display)
7166 Lisp_Object display, on;
7168 struct w32_display_info *dpyinfo = check_x_display_info (display);
7170 return Qnil;
7175 /***********************************************************************
7176 Image types
7177 ***********************************************************************/
7179 /* Value is the number of elements of vector VECTOR. */
7181 #define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR))
7183 /* List of supported image types. Use define_image_type to add new
7184 types. Use lookup_image_type to find a type for a given symbol. */
7186 static struct image_type *image_types;
7188 /* A list of symbols, one for each supported image type. */
7190 Lisp_Object Vimage_types;
7192 /* The symbol `image' which is the car of the lists used to represent
7193 images in Lisp. */
7195 extern Lisp_Object Qimage;
7197 /* The symbol `xbm' which is used as the type symbol for XBM images. */
7199 Lisp_Object Qxbm;
7201 /* Keywords. */
7203 Lisp_Object QCtype, QCdata, QCascent, QCmargin, QCrelief;
7204 extern Lisp_Object QCwidth, QCheight, QCforeground, QCbackground, QCfile;
7205 Lisp_Object QCalgorithm, QCcolor_symbols, QCheuristic_mask;
7206 extern Lisp_Object QCindex;
7208 /* Other symbols. */
7210 Lisp_Object Qlaplace;
7212 /* Time in seconds after which images should be removed from the cache
7213 if not displayed. */
7215 Lisp_Object Vimage_cache_eviction_delay;
7217 /* Function prototypes. */
7219 static void define_image_type P_ ((struct image_type *type));
7220 static struct image_type *lookup_image_type P_ ((Lisp_Object symbol));
7221 static void image_error P_ ((char *format, Lisp_Object, Lisp_Object));
7222 static void x_laplace P_ ((struct frame *, struct image *));
7223 static int x_build_heuristic_mask P_ ((struct frame *, struct image *,
7224 Lisp_Object));
7226 /* Define a new image type from TYPE. This adds a copy of TYPE to
7227 image_types and adds the symbol *TYPE->type to Vimage_types. */
7229 static void
7230 define_image_type (type)
7231 struct image_type *type;
7233 /* Make a copy of TYPE to avoid a bus error in a dumped Emacs.
7234 The initialized data segment is read-only. */
7235 struct image_type *p = (struct image_type *) xmalloc (sizeof *p);
7236 bcopy (type, p, sizeof *p);
7237 p->next = image_types;
7238 image_types = p;
7239 Vimage_types = Fcons (*p->type, Vimage_types);
7243 /* Look up image type SYMBOL, and return a pointer to its image_type
7244 structure. Value is null if SYMBOL is not a known image type. */
7246 static INLINE struct image_type *
7247 lookup_image_type (symbol)
7248 Lisp_Object symbol;
7250 struct image_type *type;
7252 for (type = image_types; type; type = type->next)
7253 if (EQ (symbol, *type->type))
7254 break;
7256 return type;
7260 /* Value is non-zero if OBJECT is a valid Lisp image specification. A
7261 valid image specification is a list whose car is the symbol
7262 `image', and whose rest is a property list. The property list must
7263 contain a value for key `:type'. That value must be the name of a
7264 supported image type. The rest of the property list depends on the
7265 image type. */
7268 valid_image_p (object)
7269 Lisp_Object object;
7271 int valid_p = 0;
7273 if (CONSP (object) && EQ (XCAR (object), Qimage))
7275 Lisp_Object symbol = Fplist_get (XCDR (object), QCtype);
7276 struct image_type *type = lookup_image_type (symbol);
7278 if (type)
7279 valid_p = type->valid_p (object);
7282 return valid_p;
7286 /* Log error message with format string FORMAT and argument ARG.
7287 Signaling an error, e.g. when an image cannot be loaded, is not a
7288 good idea because this would interrupt redisplay, and the error
7289 message display would lead to another redisplay. This function
7290 therefore simply displays a message. */
7292 static void
7293 image_error (format, arg1, arg2)
7294 char *format;
7295 Lisp_Object arg1, arg2;
7297 add_to_log (format, arg1, arg2);
7302 /***********************************************************************
7303 Image specifications
7304 ***********************************************************************/
7306 enum image_value_type
7308 IMAGE_DONT_CHECK_VALUE_TYPE,
7309 IMAGE_STRING_VALUE,
7310 IMAGE_SYMBOL_VALUE,
7311 IMAGE_POSITIVE_INTEGER_VALUE,
7312 IMAGE_NON_NEGATIVE_INTEGER_VALUE,
7313 IMAGE_INTEGER_VALUE,
7314 IMAGE_FUNCTION_VALUE,
7315 IMAGE_NUMBER_VALUE,
7316 IMAGE_BOOL_VALUE
7319 /* Structure used when parsing image specifications. */
7321 struct image_keyword
7323 /* Name of keyword. */
7324 char *name;
7326 /* The type of value allowed. */
7327 enum image_value_type type;
7329 /* Non-zero means key must be present. */
7330 int mandatory_p;
7332 /* Used to recognize duplicate keywords in a property list. */
7333 int count;
7335 /* The value that was found. */
7336 Lisp_Object value;
7340 static int parse_image_spec P_ ((Lisp_Object, struct image_keyword *,
7341 int, Lisp_Object));
7342 static Lisp_Object image_spec_value P_ ((Lisp_Object, Lisp_Object, int *));
7345 /* Parse image spec SPEC according to KEYWORDS. A valid image spec
7346 has the format (image KEYWORD VALUE ...). One of the keyword/
7347 value pairs must be `:type TYPE'. KEYWORDS is a vector of
7348 image_keywords structures of size NKEYWORDS describing other
7349 allowed keyword/value pairs. Value is non-zero if SPEC is valid. */
7351 static int
7352 parse_image_spec (spec, keywords, nkeywords, type)
7353 Lisp_Object spec;
7354 struct image_keyword *keywords;
7355 int nkeywords;
7356 Lisp_Object type;
7358 int i;
7359 Lisp_Object plist;
7361 if (!CONSP (spec) || !EQ (XCAR (spec), Qimage))
7362 return 0;
7364 plist = XCDR (spec);
7365 while (CONSP (plist))
7367 Lisp_Object key, value;
7369 /* First element of a pair must be a symbol. */
7370 key = XCAR (plist);
7371 plist = XCDR (plist);
7372 if (!SYMBOLP (key))
7373 return 0;
7375 /* There must follow a value. */
7376 if (!CONSP (plist))
7377 return 0;
7378 value = XCAR (plist);
7379 plist = XCDR (plist);
7381 /* Find key in KEYWORDS. Error if not found. */
7382 for (i = 0; i < nkeywords; ++i)
7383 if (strcmp (keywords[i].name, XSYMBOL (key)->name->data) == 0)
7384 break;
7386 if (i == nkeywords)
7387 continue;
7389 /* Record that we recognized the keyword. If a keywords
7390 was found more than once, it's an error. */
7391 keywords[i].value = value;
7392 ++keywords[i].count;
7394 if (keywords[i].count > 1)
7395 return 0;
7397 /* Check type of value against allowed type. */
7398 switch (keywords[i].type)
7400 case IMAGE_STRING_VALUE:
7401 if (!STRINGP (value))
7402 return 0;
7403 break;
7405 case IMAGE_SYMBOL_VALUE:
7406 if (!SYMBOLP (value))
7407 return 0;
7408 break;
7410 case IMAGE_POSITIVE_INTEGER_VALUE:
7411 if (!INTEGERP (value) || XINT (value) <= 0)
7412 return 0;
7413 break;
7415 case IMAGE_NON_NEGATIVE_INTEGER_VALUE:
7416 if (!INTEGERP (value) || XINT (value) < 0)
7417 return 0;
7418 break;
7420 case IMAGE_DONT_CHECK_VALUE_TYPE:
7421 break;
7423 case IMAGE_FUNCTION_VALUE:
7424 value = indirect_function (value);
7425 if (SUBRP (value)
7426 || COMPILEDP (value)
7427 || (CONSP (value) && EQ (XCAR (value), Qlambda)))
7428 break;
7429 return 0;
7431 case IMAGE_NUMBER_VALUE:
7432 if (!INTEGERP (value) && !FLOATP (value))
7433 return 0;
7434 break;
7436 case IMAGE_INTEGER_VALUE:
7437 if (!INTEGERP (value))
7438 return 0;
7439 break;
7441 case IMAGE_BOOL_VALUE:
7442 if (!NILP (value) && !EQ (value, Qt))
7443 return 0;
7444 break;
7446 default:
7447 abort ();
7448 break;
7451 if (EQ (key, QCtype) && !EQ (type, value))
7452 return 0;
7455 /* Check that all mandatory fields are present. */
7456 for (i = 0; i < nkeywords; ++i)
7457 if (keywords[i].mandatory_p && keywords[i].count == 0)
7458 return 0;
7460 return NILP (plist);
7464 /* Return the value of KEY in image specification SPEC. Value is nil
7465 if KEY is not present in SPEC. if FOUND is not null, set *FOUND
7466 to 1 if KEY was found in SPEC, set it to 0 otherwise. */
7468 static Lisp_Object
7469 image_spec_value (spec, key, found)
7470 Lisp_Object spec, key;
7471 int *found;
7473 Lisp_Object tail;
7475 xassert (valid_image_p (spec));
7477 for (tail = XCDR (spec);
7478 CONSP (tail) && CONSP (XCDR (tail));
7479 tail = XCDR (XCDR (tail)))
7481 if (EQ (XCAR (tail), key))
7483 if (found)
7484 *found = 1;
7485 return XCAR (XCDR (tail));
7489 if (found)
7490 *found = 0;
7491 return Qnil;
7497 /***********************************************************************
7498 Image type independent image structures
7499 ***********************************************************************/
7501 static struct image *make_image P_ ((Lisp_Object spec, unsigned hash));
7502 static void free_image P_ ((struct frame *f, struct image *img));
7505 /* Allocate and return a new image structure for image specification
7506 SPEC. SPEC has a hash value of HASH. */
7508 static struct image *
7509 make_image (spec, hash)
7510 Lisp_Object spec;
7511 unsigned hash;
7513 struct image *img = (struct image *) xmalloc (sizeof *img);
7515 xassert (valid_image_p (spec));
7516 bzero (img, sizeof *img);
7517 img->type = lookup_image_type (image_spec_value (spec, QCtype, NULL));
7518 xassert (img->type != NULL);
7519 img->spec = spec;
7520 img->data.lisp_val = Qnil;
7521 img->ascent = DEFAULT_IMAGE_ASCENT;
7522 img->hash = hash;
7523 return img;
7527 /* Free image IMG which was used on frame F, including its resources. */
7529 static void
7530 free_image (f, img)
7531 struct frame *f;
7532 struct image *img;
7534 if (img)
7536 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7538 /* Remove IMG from the hash table of its cache. */
7539 if (img->prev)
7540 img->prev->next = img->next;
7541 else
7542 c->buckets[img->hash % IMAGE_CACHE_BUCKETS_SIZE] = img->next;
7544 if (img->next)
7545 img->next->prev = img->prev;
7547 c->images[img->id] = NULL;
7549 /* Free resources, then free IMG. */
7550 img->type->free (f, img);
7551 xfree (img);
7556 /* Prepare image IMG for display on frame F. Must be called before
7557 drawing an image. */
7559 void
7560 prepare_image_for_display (f, img)
7561 struct frame *f;
7562 struct image *img;
7564 EMACS_TIME t;
7566 /* We're about to display IMG, so set its timestamp to `now'. */
7567 EMACS_GET_TIME (t);
7568 img->timestamp = EMACS_SECS (t);
7570 /* If IMG doesn't have a pixmap yet, load it now, using the image
7571 type dependent loader function. */
7572 if (img->pixmap == 0 && !img->load_failed_p)
7573 img->load_failed_p = img->type->load (f, img) == 0;
7578 /***********************************************************************
7579 Helper functions for X image types
7580 ***********************************************************************/
7582 static void x_clear_image P_ ((struct frame *f, struct image *img));
7583 static unsigned long x_alloc_image_color P_ ((struct frame *f,
7584 struct image *img,
7585 Lisp_Object color_name,
7586 unsigned long dflt));
7588 /* Free X resources of image IMG which is used on frame F. */
7590 static void
7591 x_clear_image (f, img)
7592 struct frame *f;
7593 struct image *img;
7595 #if 0 /* NTEMACS_TODO: W32 image support */
7597 if (img->pixmap)
7599 BLOCK_INPUT;
7600 XFreePixmap (NULL, img->pixmap);
7601 img->pixmap = 0;
7602 UNBLOCK_INPUT;
7605 if (img->ncolors)
7607 int class = FRAME_W32_DISPLAY_INFO (f)->visual->class;
7609 /* If display has an immutable color map, freeing colors is not
7610 necessary and some servers don't allow it. So don't do it. */
7611 if (class != StaticColor
7612 && class != StaticGray
7613 && class != TrueColor)
7615 Colormap cmap;
7616 BLOCK_INPUT;
7617 cmap = DefaultColormapOfScreen (FRAME_W32_DISPLAY_INFO (f)->screen);
7618 XFreeColors (FRAME_W32_DISPLAY (f), cmap, img->colors,
7619 img->ncolors, 0);
7620 UNBLOCK_INPUT;
7623 xfree (img->colors);
7624 img->colors = NULL;
7625 img->ncolors = 0;
7627 #endif
7631 /* Allocate color COLOR_NAME for image IMG on frame F. If color
7632 cannot be allocated, use DFLT. Add a newly allocated color to
7633 IMG->colors, so that it can be freed again. Value is the pixel
7634 color. */
7636 static unsigned long
7637 x_alloc_image_color (f, img, color_name, dflt)
7638 struct frame *f;
7639 struct image *img;
7640 Lisp_Object color_name;
7641 unsigned long dflt;
7643 #if 0 /* NTEMACS_TODO: allocing colors. */
7644 XColor color;
7645 unsigned long result;
7647 xassert (STRINGP (color_name));
7649 if (w32_defined_color (f, XSTRING (color_name)->data, &color, 1))
7651 /* This isn't called frequently so we get away with simply
7652 reallocating the color vector to the needed size, here. */
7653 ++img->ncolors;
7654 img->colors =
7655 (unsigned long *) xrealloc (img->colors,
7656 img->ncolors * sizeof *img->colors);
7657 img->colors[img->ncolors - 1] = color.pixel;
7658 result = color.pixel;
7660 else
7661 result = dflt;
7662 return result;
7663 #endif
7664 return 0;
7669 /***********************************************************************
7670 Image Cache
7671 ***********************************************************************/
7673 static void cache_image P_ ((struct frame *f, struct image *img));
7676 /* Return a new, initialized image cache that is allocated from the
7677 heap. Call free_image_cache to free an image cache. */
7679 struct image_cache *
7680 make_image_cache ()
7682 struct image_cache *c = (struct image_cache *) xmalloc (sizeof *c);
7683 int size;
7685 bzero (c, sizeof *c);
7686 c->size = 50;
7687 c->images = (struct image **) xmalloc (c->size * sizeof *c->images);
7688 size = IMAGE_CACHE_BUCKETS_SIZE * sizeof *c->buckets;
7689 c->buckets = (struct image **) xmalloc (size);
7690 bzero (c->buckets, size);
7691 return c;
7695 /* Free image cache of frame F. Be aware that X frames share images
7696 caches. */
7698 void
7699 free_image_cache (f)
7700 struct frame *f;
7702 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7703 if (c)
7705 int i;
7707 /* Cache should not be referenced by any frame when freed. */
7708 xassert (c->refcount == 0);
7710 for (i = 0; i < c->used; ++i)
7711 free_image (f, c->images[i]);
7712 xfree (c->images);
7713 xfree (c);
7714 xfree (c->buckets);
7715 FRAME_X_IMAGE_CACHE (f) = NULL;
7720 /* Clear image cache of frame F. FORCE_P non-zero means free all
7721 images. FORCE_P zero means clear only images that haven't been
7722 displayed for some time. Should be called from time to time to
7723 reduce the number of loaded images. If image-cache-eveiction-delay
7724 is non-nil, this frees images in the cache which weren't displayed for
7725 at least that many seconds. */
7727 void
7728 clear_image_cache (f, force_p)
7729 struct frame *f;
7730 int force_p;
7732 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7734 if (c && INTEGERP (Vimage_cache_eviction_delay))
7736 EMACS_TIME t;
7737 unsigned long old;
7738 int i, any_freed_p = 0;
7740 EMACS_GET_TIME (t);
7741 old = EMACS_SECS (t) - XFASTINT (Vimage_cache_eviction_delay);
7743 for (i = 0; i < c->used; ++i)
7745 struct image *img = c->images[i];
7746 if (img != NULL
7747 && (force_p
7748 || (img->timestamp > old)))
7750 free_image (f, img);
7751 any_freed_p = 1;
7755 /* We may be clearing the image cache because, for example,
7756 Emacs was iconified for a longer period of time. In that
7757 case, current matrices may still contain references to
7758 images freed above. So, clear these matrices. */
7759 if (any_freed_p)
7761 clear_current_matrices (f);
7762 ++windows_or_buffers_changed;
7768 DEFUN ("clear-image-cache", Fclear_image_cache, Sclear_image_cache,
7769 0, 1, 0,
7770 "Clear the image cache of FRAME.\n\
7771 FRAME nil or omitted means use the selected frame.\n\
7772 FRAME t means clear the image caches of all frames.")
7773 (frame)
7774 Lisp_Object frame;
7776 if (EQ (frame, Qt))
7778 Lisp_Object tail;
7780 FOR_EACH_FRAME (tail, frame)
7781 if (FRAME_W32_P (XFRAME (frame)))
7782 clear_image_cache (XFRAME (frame), 1);
7784 else
7785 clear_image_cache (check_x_frame (frame), 1);
7787 return Qnil;
7791 /* Return the id of image with Lisp specification SPEC on frame F.
7792 SPEC must be a valid Lisp image specification (see valid_image_p). */
7795 lookup_image (f, spec)
7796 struct frame *f;
7797 Lisp_Object spec;
7799 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7800 struct image *img;
7801 int i;
7802 unsigned hash;
7803 struct gcpro gcpro1;
7804 EMACS_TIME now;
7806 /* F must be a window-system frame, and SPEC must be a valid image
7807 specification. */
7808 xassert (FRAME_WINDOW_P (f));
7809 xassert (valid_image_p (spec));
7811 GCPRO1 (spec);
7813 /* Look up SPEC in the hash table of the image cache. */
7814 hash = sxhash (spec, 0);
7815 i = hash % IMAGE_CACHE_BUCKETS_SIZE;
7817 for (img = c->buckets[i]; img; img = img->next)
7818 if (img->hash == hash && !NILP (Fequal (img->spec, spec)))
7819 break;
7821 /* If not found, create a new image and cache it. */
7822 if (img == NULL)
7824 img = make_image (spec, hash);
7825 cache_image (f, img);
7826 img->load_failed_p = img->type->load (f, img) == 0;
7827 xassert (!interrupt_input_blocked);
7829 /* If we can't load the image, and we don't have a width and
7830 height, use some arbitrary width and height so that we can
7831 draw a rectangle for it. */
7832 if (img->load_failed_p)
7834 Lisp_Object value;
7836 value = image_spec_value (spec, QCwidth, NULL);
7837 img->width = (INTEGERP (value)
7838 ? XFASTINT (value) : DEFAULT_IMAGE_WIDTH);
7839 value = image_spec_value (spec, QCheight, NULL);
7840 img->height = (INTEGERP (value)
7841 ? XFASTINT (value) : DEFAULT_IMAGE_HEIGHT);
7843 else
7845 /* Handle image type independent image attributes
7846 `:ascent PERCENT', `:margin MARGIN', `:relief RELIEF'. */
7847 Lisp_Object ascent, margin, relief, algorithm, heuristic_mask;
7848 Lisp_Object file;
7850 ascent = image_spec_value (spec, QCascent, NULL);
7851 if (INTEGERP (ascent))
7852 img->ascent = XFASTINT (ascent);
7854 margin = image_spec_value (spec, QCmargin, NULL);
7855 if (INTEGERP (margin) && XINT (margin) >= 0)
7856 img->margin = XFASTINT (margin);
7858 relief = image_spec_value (spec, QCrelief, NULL);
7859 if (INTEGERP (relief))
7861 img->relief = XINT (relief);
7862 img->margin += abs (img->relief);
7865 /* Should we apply a Laplace edge-detection algorithm? */
7866 algorithm = image_spec_value (spec, QCalgorithm, NULL);
7867 if (img->pixmap && EQ (algorithm, Qlaplace))
7868 x_laplace (f, img);
7870 /* Should we built a mask heuristically? */
7871 heuristic_mask = image_spec_value (spec, QCheuristic_mask, NULL);
7872 if (img->pixmap && !img->mask && !NILP (heuristic_mask))
7873 x_build_heuristic_mask (f, img, heuristic_mask);
7877 /* We're using IMG, so set its timestamp to `now'. */
7878 EMACS_GET_TIME (now);
7879 img->timestamp = EMACS_SECS (now);
7881 UNGCPRO;
7883 /* Value is the image id. */
7884 return img->id;
7888 /* Cache image IMG in the image cache of frame F. */
7890 static void
7891 cache_image (f, img)
7892 struct frame *f;
7893 struct image *img;
7895 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7896 int i;
7898 /* Find a free slot in c->images. */
7899 for (i = 0; i < c->used; ++i)
7900 if (c->images[i] == NULL)
7901 break;
7903 /* If no free slot found, maybe enlarge c->images. */
7904 if (i == c->used && c->used == c->size)
7906 c->size *= 2;
7907 c->images = (struct image **) xrealloc (c->images,
7908 c->size * sizeof *c->images);
7911 /* Add IMG to c->images, and assign IMG an id. */
7912 c->images[i] = img;
7913 img->id = i;
7914 if (i == c->used)
7915 ++c->used;
7917 /* Add IMG to the cache's hash table. */
7918 i = img->hash % IMAGE_CACHE_BUCKETS_SIZE;
7919 img->next = c->buckets[i];
7920 if (img->next)
7921 img->next->prev = img;
7922 img->prev = NULL;
7923 c->buckets[i] = img;
7927 /* Call FN on every image in the image cache of frame F. Used to mark
7928 Lisp Objects in the image cache. */
7930 void
7931 forall_images_in_image_cache (f, fn)
7932 struct frame *f;
7933 void (*fn) P_ ((struct image *img));
7935 if (FRAME_LIVE_P (f) && FRAME_W32_P (f))
7937 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7938 if (c)
7940 int i;
7941 for (i = 0; i < c->used; ++i)
7942 if (c->images[i])
7943 fn (c->images[i]);
7950 /***********************************************************************
7951 W32 support code
7952 ***********************************************************************/
7954 #if 0 /* NTEMACS_TODO: W32 specific image code. */
7956 static int x_create_x_image_and_pixmap P_ ((struct frame *, int, int, int,
7957 XImage **, Pixmap *));
7958 static void x_destroy_x_image P_ ((XImage *));
7959 static void x_put_x_image P_ ((struct frame *, XImage *, Pixmap, int, int));
7962 /* Create an XImage and a pixmap of size WIDTH x HEIGHT for use on
7963 frame F. Set *XIMG and *PIXMAP to the XImage and Pixmap created.
7964 Set (*XIMG)->data to a raster of WIDTH x HEIGHT pixels allocated
7965 via xmalloc. Print error messages via image_error if an error
7966 occurs. Value is non-zero if successful. */
7968 static int
7969 x_create_x_image_and_pixmap (f, width, height, depth, ximg, pixmap)
7970 struct frame *f;
7971 int width, height, depth;
7972 XImage **ximg;
7973 Pixmap *pixmap;
7975 #if 0 /* NTEMACS_TODO: Image support for W32 */
7976 Display *display = FRAME_W32_DISPLAY (f);
7977 Screen *screen = FRAME_X_SCREEN (f);
7978 Window window = FRAME_W32_WINDOW (f);
7980 xassert (interrupt_input_blocked);
7982 if (depth <= 0)
7983 depth = DefaultDepthOfScreen (screen);
7984 *ximg = XCreateImage (display, DefaultVisualOfScreen (screen),
7985 depth, ZPixmap, 0, NULL, width, height,
7986 depth > 16 ? 32 : depth > 8 ? 16 : 8, 0);
7987 if (*ximg == NULL)
7989 image_error ("Unable to allocate X image", Qnil, Qnil);
7990 return 0;
7993 /* Allocate image raster. */
7994 (*ximg)->data = (char *) xmalloc ((*ximg)->bytes_per_line * height);
7996 /* Allocate a pixmap of the same size. */
7997 *pixmap = XCreatePixmap (display, window, width, height, depth);
7998 if (*pixmap == 0)
8000 x_destroy_x_image (*ximg);
8001 *ximg = NULL;
8002 image_error ("Unable to create X pixmap", Qnil, Qnil);
8003 return 0;
8005 #endif
8006 return 1;
8010 /* Destroy XImage XIMG. Free XIMG->data. */
8012 static void
8013 x_destroy_x_image (ximg)
8014 XImage *ximg;
8016 xassert (interrupt_input_blocked);
8017 if (ximg)
8019 xfree (ximg->data);
8020 ximg->data = NULL;
8021 XDestroyImage (ximg);
8026 /* Put XImage XIMG into pixmap PIXMAP on frame F. WIDTH and HEIGHT
8027 are width and height of both the image and pixmap. */
8029 static void
8030 x_put_x_image (f, ximg, pixmap, width, height)
8031 struct frame *f;
8032 XImage *ximg;
8033 Pixmap pixmap;
8035 GC gc;
8037 xassert (interrupt_input_blocked);
8038 gc = XCreateGC (NULL, pixmap, 0, NULL);
8039 XPutImage (NULL, pixmap, gc, ximg, 0, 0, 0, 0, width, height);
8040 XFreeGC (NULL, gc);
8043 #endif
8046 /***********************************************************************
8047 Searching files
8048 ***********************************************************************/
8050 static Lisp_Object x_find_image_file P_ ((Lisp_Object));
8052 /* Find image file FILE. Look in data-directory, then
8053 x-bitmap-file-path. Value is the full name of the file found, or
8054 nil if not found. */
8056 static Lisp_Object
8057 x_find_image_file (file)
8058 Lisp_Object file;
8060 Lisp_Object file_found, search_path;
8061 struct gcpro gcpro1, gcpro2;
8062 int fd;
8064 file_found = Qnil;
8065 search_path = Fcons (Vdata_directory, Vx_bitmap_file_path);
8066 GCPRO2 (file_found, search_path);
8068 /* Try to find FILE in data-directory, then x-bitmap-file-path. */
8069 fd = openp (search_path, file, "", &file_found, 0);
8071 if (fd < 0)
8072 file_found = Qnil;
8073 else
8074 close (fd);
8076 UNGCPRO;
8077 return file_found;
8082 /***********************************************************************
8083 XBM images
8084 ***********************************************************************/
8086 static int xbm_load P_ ((struct frame *f, struct image *img));
8087 static int xbm_load_image_from_file P_ ((struct frame *f, struct image *img,
8088 Lisp_Object file));
8089 static int xbm_image_p P_ ((Lisp_Object object));
8090 static int xbm_read_bitmap_file_data P_ ((char *, int *, int *,
8091 unsigned char **));
8094 /* Indices of image specification fields in xbm_format, below. */
8096 enum xbm_keyword_index
8098 XBM_TYPE,
8099 XBM_FILE,
8100 XBM_WIDTH,
8101 XBM_HEIGHT,
8102 XBM_DATA,
8103 XBM_FOREGROUND,
8104 XBM_BACKGROUND,
8105 XBM_ASCENT,
8106 XBM_MARGIN,
8107 XBM_RELIEF,
8108 XBM_ALGORITHM,
8109 XBM_HEURISTIC_MASK,
8110 XBM_LAST
8113 /* Vector of image_keyword structures describing the format
8114 of valid XBM image specifications. */
8116 static struct image_keyword xbm_format[XBM_LAST] =
8118 {":type", IMAGE_SYMBOL_VALUE, 1},
8119 {":file", IMAGE_STRING_VALUE, 0},
8120 {":width", IMAGE_POSITIVE_INTEGER_VALUE, 0},
8121 {":height", IMAGE_POSITIVE_INTEGER_VALUE, 0},
8122 {":data", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8123 {":foreground", IMAGE_STRING_VALUE, 0},
8124 {":background", IMAGE_STRING_VALUE, 0},
8125 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
8126 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
8127 {":relief", IMAGE_INTEGER_VALUE, 0},
8128 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8129 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
8132 /* Structure describing the image type XBM. */
8134 static struct image_type xbm_type =
8136 &Qxbm,
8137 xbm_image_p,
8138 xbm_load,
8139 x_clear_image,
8140 NULL
8143 /* Tokens returned from xbm_scan. */
8145 enum xbm_token
8147 XBM_TK_IDENT = 256,
8148 XBM_TK_NUMBER
8152 /* Return non-zero if OBJECT is a valid XBM-type image specification.
8153 A valid specification is a list starting with the symbol `image'
8154 The rest of the list is a property list which must contain an
8155 entry `:type xbm..
8157 If the specification specifies a file to load, it must contain
8158 an entry `:file FILENAME' where FILENAME is a string.
8160 If the specification is for a bitmap loaded from memory it must
8161 contain `:width WIDTH', `:height HEIGHT', and `:data DATA', where
8162 WIDTH and HEIGHT are integers > 0. DATA may be:
8164 1. a string large enough to hold the bitmap data, i.e. it must
8165 have a size >= (WIDTH + 7) / 8 * HEIGHT
8167 2. a bool-vector of size >= WIDTH * HEIGHT
8169 3. a vector of strings or bool-vectors, one for each line of the
8170 bitmap.
8172 Both the file and data forms may contain the additional entries
8173 `:background COLOR' and `:foreground COLOR'. If not present,
8174 foreground and background of the frame on which the image is
8175 displayed, is used. */
8177 static int
8178 xbm_image_p (object)
8179 Lisp_Object object;
8181 struct image_keyword kw[XBM_LAST];
8183 bcopy (xbm_format, kw, sizeof kw);
8184 if (!parse_image_spec (object, kw, XBM_LAST, Qxbm))
8185 return 0;
8187 xassert (EQ (kw[XBM_TYPE].value, Qxbm));
8189 if (kw[XBM_FILE].count)
8191 if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_DATA].count)
8192 return 0;
8194 else
8196 Lisp_Object data;
8197 int width, height;
8199 /* Entries for `:width', `:height' and `:data' must be present. */
8200 if (!kw[XBM_WIDTH].count
8201 || !kw[XBM_HEIGHT].count
8202 || !kw[XBM_DATA].count)
8203 return 0;
8205 data = kw[XBM_DATA].value;
8206 width = XFASTINT (kw[XBM_WIDTH].value);
8207 height = XFASTINT (kw[XBM_HEIGHT].value);
8209 /* Check type of data, and width and height against contents of
8210 data. */
8211 if (VECTORP (data))
8213 int i;
8215 /* Number of elements of the vector must be >= height. */
8216 if (XVECTOR (data)->size < height)
8217 return 0;
8219 /* Each string or bool-vector in data must be large enough
8220 for one line of the image. */
8221 for (i = 0; i < height; ++i)
8223 Lisp_Object elt = XVECTOR (data)->contents[i];
8225 if (STRINGP (elt))
8227 if (XSTRING (elt)->size
8228 < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR)
8229 return 0;
8231 else if (BOOL_VECTOR_P (elt))
8233 if (XBOOL_VECTOR (elt)->size < width)
8234 return 0;
8236 else
8237 return 0;
8240 else if (STRINGP (data))
8242 if (XSTRING (data)->size
8243 < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR * height)
8244 return 0;
8246 else if (BOOL_VECTOR_P (data))
8248 if (XBOOL_VECTOR (data)->size < width * height)
8249 return 0;
8251 else
8252 return 0;
8255 /* Baseline must be a value between 0 and 100 (a percentage). */
8256 if (kw[XBM_ASCENT].count
8257 && XFASTINT (kw[XBM_ASCENT].value) > 100)
8258 return 0;
8260 return 1;
8264 /* Scan a bitmap file. FP is the stream to read from. Value is
8265 either an enumerator from enum xbm_token, or a character for a
8266 single-character token, or 0 at end of file. If scanning an
8267 identifier, store the lexeme of the identifier in SVAL. If
8268 scanning a number, store its value in *IVAL. */
8270 static int
8271 xbm_scan (fp, sval, ival)
8272 FILE *fp;
8273 char *sval;
8274 int *ival;
8276 int c;
8278 /* Skip white space. */
8279 while ((c = fgetc (fp)) != EOF && isspace (c))
8282 if (c == EOF)
8283 c = 0;
8284 else if (isdigit (c))
8286 int value = 0, digit;
8288 if (c == '0')
8290 c = fgetc (fp);
8291 if (c == 'x' || c == 'X')
8293 while ((c = fgetc (fp)) != EOF)
8295 if (isdigit (c))
8296 digit = c - '0';
8297 else if (c >= 'a' && c <= 'f')
8298 digit = c - 'a' + 10;
8299 else if (c >= 'A' && c <= 'F')
8300 digit = c - 'A' + 10;
8301 else
8302 break;
8303 value = 16 * value + digit;
8306 else if (isdigit (c))
8308 value = c - '0';
8309 while ((c = fgetc (fp)) != EOF
8310 && isdigit (c))
8311 value = 8 * value + c - '0';
8314 else
8316 value = c - '0';
8317 while ((c = fgetc (fp)) != EOF
8318 && isdigit (c))
8319 value = 10 * value + c - '0';
8322 if (c != EOF)
8323 ungetc (c, fp);
8324 *ival = value;
8325 c = XBM_TK_NUMBER;
8327 else if (isalpha (c) || c == '_')
8329 *sval++ = c;
8330 while ((c = fgetc (fp)) != EOF
8331 && (isalnum (c) || c == '_'))
8332 *sval++ = c;
8333 *sval = 0;
8334 if (c != EOF)
8335 ungetc (c, fp);
8336 c = XBM_TK_IDENT;
8339 return c;
8343 /* Replacement for XReadBitmapFileData which isn't available under old
8344 X versions. FILE is the name of the bitmap file to read. Set
8345 *WIDTH and *HEIGHT to the width and height of the image. Return in
8346 *DATA the bitmap data allocated with xmalloc. Value is non-zero if
8347 successful. */
8349 static int
8350 xbm_read_bitmap_file_data (file, width, height, data)
8351 char *file;
8352 int *width, *height;
8353 unsigned char **data;
8355 FILE *fp;
8356 char buffer[BUFSIZ];
8357 int padding_p = 0;
8358 int v10 = 0;
8359 int bytes_per_line, i, nbytes;
8360 unsigned char *p;
8361 int value;
8362 int LA1;
8364 #define match() \
8365 LA1 = xbm_scan (fp, buffer, &value)
8367 #define expect(TOKEN) \
8368 if (LA1 != (TOKEN)) \
8369 goto failure; \
8370 else \
8371 match ()
8373 #define expect_ident(IDENT) \
8374 if (LA1 == XBM_TK_IDENT && strcmp (buffer, (IDENT)) == 0) \
8375 match (); \
8376 else \
8377 goto failure
8379 fp = fopen (file, "r");
8380 if (fp == NULL)
8381 return 0;
8383 *width = *height = -1;
8384 *data = NULL;
8385 LA1 = xbm_scan (fp, buffer, &value);
8387 /* Parse defines for width, height and hot-spots. */
8388 while (LA1 == '#')
8390 match ();
8391 expect_ident ("define");
8392 expect (XBM_TK_IDENT);
8394 if (LA1 == XBM_TK_NUMBER);
8396 char *p = strrchr (buffer, '_');
8397 p = p ? p + 1 : buffer;
8398 if (strcmp (p, "width") == 0)
8399 *width = value;
8400 else if (strcmp (p, "height") == 0)
8401 *height = value;
8403 expect (XBM_TK_NUMBER);
8406 if (*width < 0 || *height < 0)
8407 goto failure;
8409 /* Parse bits. Must start with `static'. */
8410 expect_ident ("static");
8411 if (LA1 == XBM_TK_IDENT)
8413 if (strcmp (buffer, "unsigned") == 0)
8415 match ();
8416 expect_ident ("char");
8418 else if (strcmp (buffer, "short") == 0)
8420 match ();
8421 v10 = 1;
8422 if (*width % 16 && *width % 16 < 9)
8423 padding_p = 1;
8425 else if (strcmp (buffer, "char") == 0)
8426 match ();
8427 else
8428 goto failure;
8430 else
8431 goto failure;
8433 expect (XBM_TK_IDENT);
8434 expect ('[');
8435 expect (']');
8436 expect ('=');
8437 expect ('{');
8439 bytes_per_line = (*width + 7) / 8 + padding_p;
8440 nbytes = bytes_per_line * *height;
8441 p = *data = (char *) xmalloc (nbytes);
8443 if (v10)
8446 for (i = 0; i < nbytes; i += 2)
8448 int val = value;
8449 expect (XBM_TK_NUMBER);
8451 *p++ = val;
8452 if (!padding_p || ((i + 2) % bytes_per_line))
8453 *p++ = value >> 8;
8455 if (LA1 == ',' || LA1 == '}')
8456 match ();
8457 else
8458 goto failure;
8461 else
8463 for (i = 0; i < nbytes; ++i)
8465 int val = value;
8466 expect (XBM_TK_NUMBER);
8468 *p++ = val;
8470 if (LA1 == ',' || LA1 == '}')
8471 match ();
8472 else
8473 goto failure;
8477 fclose (fp);
8478 return 1;
8480 failure:
8482 fclose (fp);
8483 if (*data)
8485 xfree (*data);
8486 *data = NULL;
8488 return 0;
8490 #undef match
8491 #undef expect
8492 #undef expect_ident
8496 /* Load XBM image IMG which will be displayed on frame F from file
8497 SPECIFIED_FILE. Value is non-zero if successful. */
8499 static int
8500 xbm_load_image_from_file (f, img, specified_file)
8501 struct frame *f;
8502 struct image *img;
8503 Lisp_Object specified_file;
8505 int rc;
8506 unsigned char *data;
8507 int success_p = 0;
8508 Lisp_Object file;
8509 struct gcpro gcpro1;
8511 xassert (STRINGP (specified_file));
8512 file = Qnil;
8513 GCPRO1 (file);
8515 file = x_find_image_file (specified_file);
8516 if (!STRINGP (file))
8518 image_error ("Cannot find image file `%s'", specified_file, Qnil);
8519 UNGCPRO;
8520 return 0;
8523 rc = xbm_read_bitmap_file_data (XSTRING (file)->data, &img->width,
8524 &img->height, &data);
8525 if (rc)
8527 int depth = one_w32_display_info.n_cbits;
8528 unsigned long foreground = FRAME_FOREGROUND_PIXEL (f);
8529 unsigned long background = FRAME_BACKGROUND_PIXEL (f);
8530 Lisp_Object value;
8532 xassert (img->width > 0 && img->height > 0);
8534 /* Get foreground and background colors, maybe allocate colors. */
8535 value = image_spec_value (img->spec, QCforeground, NULL);
8536 if (!NILP (value))
8537 foreground = x_alloc_image_color (f, img, value, foreground);
8539 value = image_spec_value (img->spec, QCbackground, NULL);
8540 if (!NILP (value))
8541 background = x_alloc_image_color (f, img, value, background);
8543 #if 0 /* NTEMACS_TODO : Port image display to W32 */
8544 BLOCK_INPUT;
8545 img->pixmap
8546 = XCreatePixmapFromBitmapData (FRAME_W32_DISPLAY (f),
8547 FRAME_W32_WINDOW (f),
8548 data,
8549 img->width, img->height,
8550 foreground, background,
8551 depth);
8552 xfree (data);
8554 if (img->pixmap == 0)
8556 x_clear_image (f, img);
8557 image_error ("Unable to create X pixmap for `%s'", file, Qnil);
8559 else
8560 success_p = 1;
8562 UNBLOCK_INPUT;
8563 #endif
8565 else
8566 image_error ("Error loading XBM image `%s'", img->spec, Qnil);
8568 UNGCPRO;
8569 return success_p;
8573 /* Fill image IMG which is used on frame F with pixmap data. Value is
8574 non-zero if successful. */
8576 static int
8577 xbm_load (f, img)
8578 struct frame *f;
8579 struct image *img;
8581 int success_p = 0;
8582 Lisp_Object file_name;
8584 xassert (xbm_image_p (img->spec));
8586 /* If IMG->spec specifies a file name, create a non-file spec from it. */
8587 file_name = image_spec_value (img->spec, QCfile, NULL);
8588 if (STRINGP (file_name))
8589 success_p = xbm_load_image_from_file (f, img, file_name);
8590 else
8592 struct image_keyword fmt[XBM_LAST];
8593 Lisp_Object data;
8594 int depth;
8595 unsigned long foreground = FRAME_FOREGROUND_PIXEL (f);
8596 unsigned long background = FRAME_BACKGROUND_PIXEL (f);
8597 char *bits;
8598 int parsed_p;
8600 /* Parse the list specification. */
8601 bcopy (xbm_format, fmt, sizeof fmt);
8602 parsed_p = parse_image_spec (img->spec, fmt, XBM_LAST, Qxbm);
8603 xassert (parsed_p);
8605 /* Get specified width, and height. */
8606 img->width = XFASTINT (fmt[XBM_WIDTH].value);
8607 img->height = XFASTINT (fmt[XBM_HEIGHT].value);
8608 xassert (img->width > 0 && img->height > 0);
8610 BLOCK_INPUT;
8612 if (fmt[XBM_ASCENT].count)
8613 img->ascent = XFASTINT (fmt[XBM_ASCENT].value);
8615 /* Get foreground and background colors, maybe allocate colors. */
8616 if (fmt[XBM_FOREGROUND].count)
8617 foreground = x_alloc_image_color (f, img, fmt[XBM_FOREGROUND].value,
8618 foreground);
8619 if (fmt[XBM_BACKGROUND].count)
8620 background = x_alloc_image_color (f, img, fmt[XBM_BACKGROUND].value,
8621 background);
8623 /* Set bits to the bitmap image data. */
8624 data = fmt[XBM_DATA].value;
8625 if (VECTORP (data))
8627 int i;
8628 char *p;
8629 int nbytes = (img->width + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
8631 p = bits = (char *) alloca (nbytes * img->height);
8632 for (i = 0; i < img->height; ++i, p += nbytes)
8634 Lisp_Object line = XVECTOR (data)->contents[i];
8635 if (STRINGP (line))
8636 bcopy (XSTRING (line)->data, p, nbytes);
8637 else
8638 bcopy (XBOOL_VECTOR (line)->data, p, nbytes);
8641 else if (STRINGP (data))
8642 bits = XSTRING (data)->data;
8643 else
8644 bits = XBOOL_VECTOR (data)->data;
8646 #if 0 /* NTEMACS_TODO : W32 XPM code */
8647 /* Create the pixmap. */
8648 depth = DefaultDepthOfScreen (FRAME_X_SCREEN (f));
8649 img->pixmap
8650 = XCreatePixmapFromBitmapData (FRAME_W32_DISPLAY (f),
8651 FRAME_W32_WINDOW (f),
8652 bits,
8653 img->width, img->height,
8654 foreground, background,
8655 depth);
8656 #endif /* NTEMACS_TODO */
8658 if (img->pixmap)
8659 success_p = 1;
8660 else
8662 image_error ("Unable to create pixmap for XBM image `%s'",
8663 img->spec, Qnil);
8664 x_clear_image (f, img);
8667 UNBLOCK_INPUT;
8670 return success_p;
8675 /***********************************************************************
8676 XPM images
8677 ***********************************************************************/
8679 #if HAVE_XPM
8681 static int xpm_image_p P_ ((Lisp_Object object));
8682 static int xpm_load P_ ((struct frame *f, struct image *img));
8683 static int xpm_valid_color_symbols_p P_ ((Lisp_Object));
8685 #include "X11/xpm.h"
8687 /* The symbol `xpm' identifying XPM-format images. */
8689 Lisp_Object Qxpm;
8691 /* Indices of image specification fields in xpm_format, below. */
8693 enum xpm_keyword_index
8695 XPM_TYPE,
8696 XPM_FILE,
8697 XPM_DATA,
8698 XPM_ASCENT,
8699 XPM_MARGIN,
8700 XPM_RELIEF,
8701 XPM_ALGORITHM,
8702 XPM_HEURISTIC_MASK,
8703 XPM_COLOR_SYMBOLS,
8704 XPM_LAST
8707 /* Vector of image_keyword structures describing the format
8708 of valid XPM image specifications. */
8710 static struct image_keyword xpm_format[XPM_LAST] =
8712 {":type", IMAGE_SYMBOL_VALUE, 1},
8713 {":file", IMAGE_STRING_VALUE, 0},
8714 {":data", IMAGE_STRING_VALUE, 0},
8715 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
8716 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
8717 {":relief", IMAGE_INTEGER_VALUE, 0},
8718 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8719 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8720 {":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
8723 /* Structure describing the image type XBM. */
8725 static struct image_type xpm_type =
8727 &Qxpm,
8728 xpm_image_p,
8729 xpm_load,
8730 x_clear_image,
8731 NULL
8735 /* Value is non-zero if COLOR_SYMBOLS is a valid color symbols list
8736 for XPM images. Such a list must consist of conses whose car and
8737 cdr are strings. */
8739 static int
8740 xpm_valid_color_symbols_p (color_symbols)
8741 Lisp_Object color_symbols;
8743 while (CONSP (color_symbols))
8745 Lisp_Object sym = XCAR (color_symbols);
8746 if (!CONSP (sym)
8747 || !STRINGP (XCAR (sym))
8748 || !STRINGP (XCDR (sym)))
8749 break;
8750 color_symbols = XCDR (color_symbols);
8753 return NILP (color_symbols);
8757 /* Value is non-zero if OBJECT is a valid XPM image specification. */
8759 static int
8760 xpm_image_p (object)
8761 Lisp_Object object;
8763 struct image_keyword fmt[XPM_LAST];
8764 bcopy (xpm_format, fmt, sizeof fmt);
8765 return (parse_image_spec (object, fmt, XPM_LAST, Qxpm)
8766 /* Either `:file' or `:data' must be present. */
8767 && fmt[XPM_FILE].count + fmt[XPM_DATA].count == 1
8768 /* Either no `:color-symbols' or it's a list of conses
8769 whose car and cdr are strings. */
8770 && (fmt[XPM_COLOR_SYMBOLS].count == 0
8771 || xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value))
8772 && (fmt[XPM_ASCENT].count == 0
8773 || XFASTINT (fmt[XPM_ASCENT].value) < 100));
8777 /* Load image IMG which will be displayed on frame F. Value is
8778 non-zero if successful. */
8780 static int
8781 xpm_load (f, img)
8782 struct frame *f;
8783 struct image *img;
8785 int rc, i;
8786 XpmAttributes attrs;
8787 Lisp_Object specified_file, color_symbols;
8789 /* Configure the XPM lib. Use the visual of frame F. Allocate
8790 close colors. Return colors allocated. */
8791 bzero (&attrs, sizeof attrs);
8792 attrs.visual = FRAME_W32_DISPLAY_INFO (f)->visual;
8793 attrs.valuemask |= XpmVisual;
8794 attrs.valuemask |= XpmReturnAllocPixels;
8795 attrs.alloc_close_colors = 1;
8796 attrs.valuemask |= XpmAllocCloseColors;
8798 /* If image specification contains symbolic color definitions, add
8799 these to `attrs'. */
8800 color_symbols = image_spec_value (img->spec, QCcolor_symbols, NULL);
8801 if (CONSP (color_symbols))
8803 Lisp_Object tail;
8804 XpmColorSymbol *xpm_syms;
8805 int i, size;
8807 attrs.valuemask |= XpmColorSymbols;
8809 /* Count number of symbols. */
8810 attrs.numsymbols = 0;
8811 for (tail = color_symbols; CONSP (tail); tail = XCDR (tail))
8812 ++attrs.numsymbols;
8814 /* Allocate an XpmColorSymbol array. */
8815 size = attrs.numsymbols * sizeof *xpm_syms;
8816 xpm_syms = (XpmColorSymbol *) alloca (size);
8817 bzero (xpm_syms, size);
8818 attrs.colorsymbols = xpm_syms;
8820 /* Fill the color symbol array. */
8821 for (tail = color_symbols, i = 0;
8822 CONSP (tail);
8823 ++i, tail = XCDR (tail))
8825 Lisp_Object name = XCAR (XCAR (tail));
8826 Lisp_Object color = XCDR (XCAR (tail));
8827 xpm_syms[i].name = (char *) alloca (XSTRING (name)->size + 1);
8828 strcpy (xpm_syms[i].name, XSTRING (name)->data);
8829 xpm_syms[i].value = (char *) alloca (XSTRING (color)->size + 1);
8830 strcpy (xpm_syms[i].value, XSTRING (color)->data);
8834 /* Create a pixmap for the image, either from a file, or from a
8835 string buffer containing data in the same format as an XPM file. */
8836 BLOCK_INPUT;
8837 specified_file = image_spec_value (img->spec, QCfile, NULL);
8838 if (STRINGP (specified_file))
8840 Lisp_Object file = x_find_image_file (specified_file);
8841 if (!STRINGP (file))
8843 image_error ("Cannot find image file `%s'", specified_file, Qnil);
8844 UNBLOCK_INPUT;
8845 return 0;
8848 rc = XpmReadFileToPixmap (NULL, FRAME_W32_WINDOW (f),
8849 XSTRING (file)->data, &img->pixmap, &img->mask,
8850 &attrs);
8852 else
8854 Lisp_Object buffer = image_spec_value (img->spec, QCdata, NULL);
8855 rc = XpmCreatePixmapFromBuffer (NULL, FRAME_W32_WINDOW (f),
8856 XSTRING (buffer)->data,
8857 &img->pixmap, &img->mask,
8858 &attrs);
8860 UNBLOCK_INPUT;
8862 if (rc == XpmSuccess)
8864 /* Remember allocated colors. */
8865 img->ncolors = attrs.nalloc_pixels;
8866 img->colors = (unsigned long *) xmalloc (img->ncolors
8867 * sizeof *img->colors);
8868 for (i = 0; i < attrs.nalloc_pixels; ++i)
8869 img->colors[i] = attrs.alloc_pixels[i];
8871 img->width = attrs.width;
8872 img->height = attrs.height;
8873 xassert (img->width > 0 && img->height > 0);
8875 /* The call to XpmFreeAttributes below frees attrs.alloc_pixels. */
8876 BLOCK_INPUT;
8877 XpmFreeAttributes (&attrs);
8878 UNBLOCK_INPUT;
8880 else
8882 switch (rc)
8884 case XpmOpenFailed:
8885 image_error ("Error opening XPM file (%s)", img->spec, Qnil);
8886 break;
8888 case XpmFileInvalid:
8889 image_error ("Invalid XPM file (%s)", img->spec, Qnil);
8890 break;
8892 case XpmNoMemory:
8893 image_error ("Out of memory (%s)", img->spec, Qnil);
8894 break;
8896 case XpmColorFailed:
8897 image_error ("Color allocation error (%s)", img->spec, Qnil);
8898 break;
8900 default:
8901 image_error ("Unknown error (%s)", img->spec, Qnil);
8902 break;
8906 return rc == XpmSuccess;
8909 #endif /* HAVE_XPM != 0 */
8912 #if 0 /* NTEMACS_TODO : Color tables on W32. */
8913 /***********************************************************************
8914 Color table
8915 ***********************************************************************/
8917 /* An entry in the color table mapping an RGB color to a pixel color. */
8919 struct ct_color
8921 int r, g, b;
8922 unsigned long pixel;
8924 /* Next in color table collision list. */
8925 struct ct_color *next;
8928 /* The bucket vector size to use. Must be prime. */
8930 #define CT_SIZE 101
8932 /* Value is a hash of the RGB color given by R, G, and B. */
8934 #define CT_HASH_RGB(R, G, B) (((R) << 16) ^ ((G) << 8) ^ (B))
8936 /* The color hash table. */
8938 struct ct_color **ct_table;
8940 /* Number of entries in the color table. */
8942 int ct_colors_allocated;
8944 /* Function prototypes. */
8946 static void init_color_table P_ ((void));
8947 static void free_color_table P_ ((void));
8948 static unsigned long *colors_in_color_table P_ ((int *n));
8949 static unsigned long lookup_rgb_color P_ ((struct frame *f, int r, int g, int b));
8950 static unsigned long lookup_pixel_color P_ ((struct frame *f, unsigned long p));
8953 /* Initialize the color table. */
8955 static void
8956 init_color_table ()
8958 int size = CT_SIZE * sizeof (*ct_table);
8959 ct_table = (struct ct_color **) xmalloc (size);
8960 bzero (ct_table, size);
8961 ct_colors_allocated = 0;
8965 /* Free memory associated with the color table. */
8967 static void
8968 free_color_table ()
8970 int i;
8971 struct ct_color *p, *next;
8973 for (i = 0; i < CT_SIZE; ++i)
8974 for (p = ct_table[i]; p; p = next)
8976 next = p->next;
8977 xfree (p);
8980 xfree (ct_table);
8981 ct_table = NULL;
8985 /* Value is a pixel color for RGB color R, G, B on frame F. If an
8986 entry for that color already is in the color table, return the
8987 pixel color of that entry. Otherwise, allocate a new color for R,
8988 G, B, and make an entry in the color table. */
8990 static unsigned long
8991 lookup_rgb_color (f, r, g, b)
8992 struct frame *f;
8993 int r, g, b;
8995 unsigned hash = CT_HASH_RGB (r, g, b);
8996 int i = hash % CT_SIZE;
8997 struct ct_color *p;
8999 for (p = ct_table[i]; p; p = p->next)
9000 if (p->r == r && p->g == g && p->b == b)
9001 break;
9003 if (p == NULL)
9005 COLORREF color;
9006 Colormap cmap;
9007 int rc;
9009 color = PALETTERGB (r, g, b);
9011 ++ct_colors_allocated;
9013 p = (struct ct_color *) xmalloc (sizeof *p);
9014 p->r = r;
9015 p->g = g;
9016 p->b = b;
9017 p->pixel = color;
9018 p->next = ct_table[i];
9019 ct_table[i] = p;
9022 return p->pixel;
9026 /* Look up pixel color PIXEL which is used on frame F in the color
9027 table. If not already present, allocate it. Value is PIXEL. */
9029 static unsigned long
9030 lookup_pixel_color (f, pixel)
9031 struct frame *f;
9032 unsigned long pixel;
9034 int i = pixel % CT_SIZE;
9035 struct ct_color *p;
9037 for (p = ct_table[i]; p; p = p->next)
9038 if (p->pixel == pixel)
9039 break;
9041 if (p == NULL)
9043 XColor color;
9044 Colormap cmap;
9045 int rc;
9047 BLOCK_INPUT;
9049 cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
9050 color.pixel = pixel;
9051 XQueryColor (NULL, cmap, &color);
9052 rc = x_alloc_nearest_color (f, cmap, &color);
9053 UNBLOCK_INPUT;
9055 if (rc)
9057 ++ct_colors_allocated;
9059 p = (struct ct_color *) xmalloc (sizeof *p);
9060 p->r = color.red;
9061 p->g = color.green;
9062 p->b = color.blue;
9063 p->pixel = pixel;
9064 p->next = ct_table[i];
9065 ct_table[i] = p;
9067 else
9068 return FRAME_FOREGROUND_PIXEL (f);
9070 return p->pixel;
9074 /* Value is a vector of all pixel colors contained in the color table,
9075 allocated via xmalloc. Set *N to the number of colors. */
9077 static unsigned long *
9078 colors_in_color_table (n)
9079 int *n;
9081 int i, j;
9082 struct ct_color *p;
9083 unsigned long *colors;
9085 if (ct_colors_allocated == 0)
9087 *n = 0;
9088 colors = NULL;
9090 else
9092 colors = (unsigned long *) xmalloc (ct_colors_allocated
9093 * sizeof *colors);
9094 *n = ct_colors_allocated;
9096 for (i = j = 0; i < CT_SIZE; ++i)
9097 for (p = ct_table[i]; p; p = p->next)
9098 colors[j++] = p->pixel;
9101 return colors;
9104 #endif /* NTEMACS_TODO */
9107 /***********************************************************************
9108 Algorithms
9109 ***********************************************************************/
9111 #if 0 /* NTEMACS_TODO : W32 versions of low level algorithms */
9112 static void x_laplace_write_row P_ ((struct frame *, long *,
9113 int, XImage *, int));
9114 static void x_laplace_read_row P_ ((struct frame *, Colormap,
9115 XColor *, int, XImage *, int));
9118 /* Fill COLORS with RGB colors from row Y of image XIMG. F is the
9119 frame we operate on, CMAP is the color-map in effect, and WIDTH is
9120 the width of one row in the image. */
9122 static void
9123 x_laplace_read_row (f, cmap, colors, width, ximg, y)
9124 struct frame *f;
9125 Colormap cmap;
9126 XColor *colors;
9127 int width;
9128 XImage *ximg;
9129 int y;
9131 int x;
9133 for (x = 0; x < width; ++x)
9134 colors[x].pixel = XGetPixel (ximg, x, y);
9136 XQueryColors (NULL, cmap, colors, width);
9140 /* Write row Y of image XIMG. PIXELS is an array of WIDTH longs
9141 containing the pixel colors to write. F is the frame we are
9142 working on. */
9144 static void
9145 x_laplace_write_row (f, pixels, width, ximg, y)
9146 struct frame *f;
9147 long *pixels;
9148 int width;
9149 XImage *ximg;
9150 int y;
9152 int x;
9154 for (x = 0; x < width; ++x)
9155 XPutPixel (ximg, x, y, pixels[x]);
9157 #endif
9159 /* Transform image IMG which is used on frame F with a Laplace
9160 edge-detection algorithm. The result is an image that can be used
9161 to draw disabled buttons, for example. */
9163 static void
9164 x_laplace (f, img)
9165 struct frame *f;
9166 struct image *img;
9168 #if 0 /* NTEMACS_TODO : W32 version */
9169 Colormap cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
9170 XImage *ximg, *oimg;
9171 XColor *in[3];
9172 long *out;
9173 Pixmap pixmap;
9174 int x, y, i;
9175 long pixel;
9176 int in_y, out_y, rc;
9177 int mv2 = 45000;
9179 BLOCK_INPUT;
9181 /* Get the X image IMG->pixmap. */
9182 ximg = XGetImage (NULL, img->pixmap,
9183 0, 0, img->width, img->height, ~0, ZPixmap);
9185 /* Allocate 3 input rows, and one output row of colors. */
9186 for (i = 0; i < 3; ++i)
9187 in[i] = (XColor *) alloca (img->width * sizeof (XColor));
9188 out = (long *) alloca (img->width * sizeof (long));
9190 /* Create an X image for output. */
9191 rc = x_create_x_image_and_pixmap (f, img->width, img->height, 0,
9192 &oimg, &pixmap);
9194 /* Fill first two rows. */
9195 x_laplace_read_row (f, cmap, in[0], img->width, ximg, 0);
9196 x_laplace_read_row (f, cmap, in[1], img->width, ximg, 1);
9197 in_y = 2;
9199 /* Write first row, all zeros. */
9200 init_color_table ();
9201 pixel = lookup_rgb_color (f, 0, 0, 0);
9202 for (x = 0; x < img->width; ++x)
9203 out[x] = pixel;
9204 x_laplace_write_row (f, out, img->width, oimg, 0);
9205 out_y = 1;
9207 for (y = 2; y < img->height; ++y)
9209 int rowa = y % 3;
9210 int rowb = (y + 2) % 3;
9212 x_laplace_read_row (f, cmap, in[rowa], img->width, ximg, in_y++);
9214 for (x = 0; x < img->width - 2; ++x)
9216 int r = in[rowa][x].red + mv2 - in[rowb][x + 2].red;
9217 int g = in[rowa][x].green + mv2 - in[rowb][x + 2].green;
9218 int b = in[rowa][x].blue + mv2 - in[rowb][x + 2].blue;
9220 out[x + 1] = lookup_rgb_color (f, r & 0xffff, g & 0xffff,
9221 b & 0xffff);
9224 x_laplace_write_row (f, out, img->width, oimg, out_y++);
9227 /* Write last line, all zeros. */
9228 for (x = 0; x < img->width; ++x)
9229 out[x] = pixel;
9230 x_laplace_write_row (f, out, img->width, oimg, out_y);
9232 /* Free the input image, and free resources of IMG. */
9233 XDestroyImage (ximg);
9234 x_clear_image (f, img);
9236 /* Put the output image into pixmap, and destroy it. */
9237 x_put_x_image (f, oimg, pixmap, img->width, img->height);
9238 x_destroy_x_image (oimg);
9240 /* Remember new pixmap and colors in IMG. */
9241 img->pixmap = pixmap;
9242 img->colors = colors_in_color_table (&img->ncolors);
9243 free_color_table ();
9245 UNBLOCK_INPUT;
9246 #endif /* NTEMACS_TODO */
9250 /* Build a mask for image IMG which is used on frame F. FILE is the
9251 name of an image file, for error messages. HOW determines how to
9252 determine the background color of IMG. If it is a list '(R G B)',
9253 with R, G, and B being integers >= 0, take that as the color of the
9254 background. Otherwise, determine the background color of IMG
9255 heuristically. Value is non-zero if successful. */
9257 static int
9258 x_build_heuristic_mask (f, img, how)
9259 struct frame *f;
9260 struct image *img;
9261 Lisp_Object how;
9263 #if 0 /* NTEMACS_TODO : W32 version */
9264 Display *dpy = FRAME_W32_DISPLAY (f);
9265 XImage *ximg, *mask_img;
9266 int x, y, rc, look_at_corners_p;
9267 unsigned long bg;
9269 BLOCK_INPUT;
9271 /* Create an image and pixmap serving as mask. */
9272 rc = x_create_x_image_and_pixmap (f, img->width, img->height, 1,
9273 &mask_img, &img->mask);
9274 if (!rc)
9276 UNBLOCK_INPUT;
9277 return 0;
9280 /* Get the X image of IMG->pixmap. */
9281 ximg = XGetImage (dpy, img->pixmap, 0, 0, img->width, img->height,
9282 ~0, ZPixmap);
9284 /* Determine the background color of ximg. If HOW is `(R G B)'
9285 take that as color. Otherwise, try to determine the color
9286 heuristically. */
9287 look_at_corners_p = 1;
9289 if (CONSP (how))
9291 int rgb[3], i = 0;
9293 while (i < 3
9294 && CONSP (how)
9295 && NATNUMP (XCAR (how)))
9297 rgb[i] = XFASTINT (XCAR (how)) & 0xffff;
9298 how = XCDR (how);
9301 if (i == 3 && NILP (how))
9303 char color_name[30];
9304 XColor exact, color;
9305 Colormap cmap;
9307 sprintf (color_name, "#%04x%04x%04x", rgb[0], rgb[1], rgb[2]);
9309 cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
9310 if (XLookupColor (dpy, cmap, color_name, &exact, &color))
9312 bg = color.pixel;
9313 look_at_corners_p = 0;
9318 if (look_at_corners_p)
9320 unsigned long corners[4];
9321 int i, best_count;
9323 /* Get the colors at the corners of ximg. */
9324 corners[0] = XGetPixel (ximg, 0, 0);
9325 corners[1] = XGetPixel (ximg, img->width - 1, 0);
9326 corners[2] = XGetPixel (ximg, img->width - 1, img->height - 1);
9327 corners[3] = XGetPixel (ximg, 0, img->height - 1);
9329 /* Choose the most frequently found color as background. */
9330 for (i = best_count = 0; i < 4; ++i)
9332 int j, n;
9334 for (j = n = 0; j < 4; ++j)
9335 if (corners[i] == corners[j])
9336 ++n;
9338 if (n > best_count)
9339 bg = corners[i], best_count = n;
9343 /* Set all bits in mask_img to 1 whose color in ximg is different
9344 from the background color bg. */
9345 for (y = 0; y < img->height; ++y)
9346 for (x = 0; x < img->width; ++x)
9347 XPutPixel (mask_img, x, y, XGetPixel (ximg, x, y) != bg);
9349 /* Put mask_img into img->mask. */
9350 x_put_x_image (f, mask_img, img->mask, img->width, img->height);
9351 x_destroy_x_image (mask_img);
9352 XDestroyImage (ximg);
9354 UNBLOCK_INPUT;
9355 #endif /* NTEMACS_TODO */
9357 return 1;
9362 /***********************************************************************
9363 PBM (mono, gray, color)
9364 ***********************************************************************/
9365 #ifdef HAVE_PBM
9367 static int pbm_image_p P_ ((Lisp_Object object));
9368 static int pbm_load P_ ((struct frame *f, struct image *img));
9369 static int pbm_scan_number P_ ((unsigned char **, unsigned char *));
9371 /* The symbol `pbm' identifying images of this type. */
9373 Lisp_Object Qpbm;
9375 /* Indices of image specification fields in gs_format, below. */
9377 enum pbm_keyword_index
9379 PBM_TYPE,
9380 PBM_FILE,
9381 PBM_DATA,
9382 PBM_ASCENT,
9383 PBM_MARGIN,
9384 PBM_RELIEF,
9385 PBM_ALGORITHM,
9386 PBM_HEURISTIC_MASK,
9387 PBM_LAST
9390 /* Vector of image_keyword structures describing the format
9391 of valid user-defined image specifications. */
9393 static struct image_keyword pbm_format[PBM_LAST] =
9395 {":type", IMAGE_SYMBOL_VALUE, 1},
9396 {":file", IMAGE_STRING_VALUE, 0},
9397 {":data", IMAGE_STRING_VALUE, 0},
9398 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
9399 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
9400 {":relief", IMAGE_INTEGER_VALUE, 0},
9401 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
9402 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
9405 /* Structure describing the image type `pbm'. */
9407 static struct image_type pbm_type =
9409 &Qpbm,
9410 pbm_image_p,
9411 pbm_load,
9412 x_clear_image,
9413 NULL
9417 /* Return non-zero if OBJECT is a valid PBM image specification. */
9419 static int
9420 pbm_image_p (object)
9421 Lisp_Object object;
9423 struct image_keyword fmt[PBM_LAST];
9425 bcopy (pbm_format, fmt, sizeof fmt);
9427 if (!parse_image_spec (object, fmt, PBM_LAST, Qpbm)
9428 || (fmt[PBM_ASCENT].count
9429 && XFASTINT (fmt[PBM_ASCENT].value) > 100))
9430 return 0;
9432 /* Must specify either :data or :file. */
9433 return fmt[PBM_DATA].count + fmt[PBM_FILE].count == 1;
9437 /* Scan a decimal number from *S and return it. Advance *S while
9438 reading the number. END is the end of the string. Value is -1 at
9439 end of input. */
9441 static int
9442 pbm_scan_number (s, end)
9443 unsigned char **s, *end;
9445 int c, val = -1;
9447 while (*s < end)
9449 /* Skip white-space. */
9450 while (*s < end && (c = *(*s)++, isspace (c)))
9453 if (c == '#')
9455 /* Skip comment to end of line. */
9456 while (*s < end && (c = *(*s)++, c != '\n'))
9459 else if (isdigit (c))
9461 /* Read decimal number. */
9462 val = c - '0';
9463 while (*s < end && (c = *(*s)++, isdigit (c)))
9464 val = 10 * val + c - '0';
9465 break;
9467 else
9468 break;
9471 return val;
9475 /* Read FILE into memory. Value is a pointer to a buffer allocated
9476 with xmalloc holding FILE's contents. Value is null if an error
9477 occured. *SIZE is set to the size of the file. */
9479 static char *
9480 pbm_read_file (file, size)
9481 Lisp_Object file;
9482 int *size;
9484 FILE *fp = NULL;
9485 char *buf = NULL;
9486 struct stat st;
9488 if (stat (XSTRING (file)->data, &st) == 0
9489 && (fp = fopen (XSTRING (file)->data, "r")) != NULL
9490 && (buf = (char *) xmalloc (st.st_size),
9491 fread (buf, 1, st.st_size, fp) == st.st_size))
9493 *size = st.st_size;
9494 fclose (fp);
9496 else
9498 if (fp)
9499 fclose (fp);
9500 if (buf)
9502 xfree (buf);
9503 buf = NULL;
9507 return buf;
9511 /* Load PBM image IMG for use on frame F. */
9513 static int
9514 pbm_load (f, img)
9515 struct frame *f;
9516 struct image *img;
9518 int raw_p, x, y;
9519 int width, height, max_color_idx = 0;
9520 XImage *ximg;
9521 Lisp_Object file, specified_file;
9522 enum {PBM_MONO, PBM_GRAY, PBM_COLOR} type;
9523 struct gcpro gcpro1;
9524 unsigned char *contents = NULL;
9525 unsigned char *end, *p;
9526 int size;
9528 specified_file = image_spec_value (img->spec, QCfile, NULL);
9529 file = Qnil;
9530 GCPRO1 (file);
9532 if (STRINGP (specified_file))
9534 file = x_find_image_file (specified_file);
9535 if (!STRINGP (file))
9537 image_error ("Cannot find image file `%s'", specified_file, Qnil);
9538 UNGCPRO;
9539 return 0;
9542 contents = pbm_read_file (file, &size);
9543 if (contents == NULL)
9545 image_error ("Error reading `%s'", file, Qnil);
9546 UNGCPRO;
9547 return 0;
9550 p = contents;
9551 end = contents + size;
9553 else
9555 Lisp_Object data;
9556 data = image_spec_value (img->spec, QCdata, NULL);
9557 p = XSTRING (data)->data;
9558 end = p + STRING_BYTES (XSTRING (data));
9561 /* Check magic number. */
9562 if (end - p < 2 || *p++ != 'P')
9564 image_error ("Not a PBM image: `%s'", img->spec, Qnil);
9565 error:
9566 xfree (contents);
9567 UNGCPRO;
9568 return 0;
9571 if (*magic != 'P')
9573 fclose (fp);
9574 image_error ("Not a PBM image file: %s", file, Qnil);
9575 UNGCPRO;
9576 return 0;
9579 switch (*p++)
9581 case '1':
9582 raw_p = 0, type = PBM_MONO;
9583 break;
9585 case '2':
9586 raw_p = 0, type = PBM_GRAY;
9587 break;
9589 case '3':
9590 raw_p = 0, type = PBM_COLOR;
9591 break;
9593 case '4':
9594 raw_p = 1, type = PBM_MONO;
9595 break;
9597 case '5':
9598 raw_p = 1, type = PBM_GRAY;
9599 break;
9601 case '6':
9602 raw_p = 1, type = PBM_COLOR;
9603 break;
9605 default:
9606 image_error ("Not a PBM image: `%s'", img->spec, Qnil);
9607 goto error;
9610 /* Read width, height, maximum color-component. Characters
9611 starting with `#' up to the end of a line are ignored. */
9612 width = pbm_scan_number (&p, end);
9613 height = pbm_scan_number (&p, end);
9615 if (type != PBM_MONO)
9617 max_color_idx = pbm_scan_number (&p, end);
9618 if (raw_p && max_color_idx > 255)
9619 max_color_idx = 255;
9622 if (width < 0
9623 || height < 0
9624 || (type != PBM_MONO && max_color_idx < 0))
9625 goto error;
9627 BLOCK_INPUT;
9628 if (!x_create_x_image_and_pixmap (f, width, height, 0,
9629 &ximg, &img->pixmap))
9631 UNBLOCK_INPUT;
9632 goto error;
9635 /* Initialize the color hash table. */
9636 init_color_table ();
9638 if (type == PBM_MONO)
9640 int c = 0, g;
9642 for (y = 0; y < height; ++y)
9643 for (x = 0; x < width; ++x)
9645 if (raw_p)
9647 if ((x & 7) == 0)
9648 c = *p++;
9649 g = c & 0x80;
9650 c <<= 1;
9652 else
9653 g = pbm_scan_number (&p, end);
9655 XPutPixel (ximg, x, y, (g
9656 ? FRAME_FOREGROUND_PIXEL (f)
9657 : FRAME_BACKGROUND_PIXEL (f)));
9660 else
9662 for (y = 0; y < height; ++y)
9663 for (x = 0; x < width; ++x)
9665 int r, g, b;
9667 if (type == PBM_GRAY)
9668 r = g = b = raw_p ? *p++ : pbm_scan_number (&p, end);
9669 else if (raw_p)
9671 r = *p++;
9672 g = *p++;
9673 b = *p++;
9675 else
9677 r = pbm_scan_number (&p, end);
9678 g = pbm_scan_number (&p, end);
9679 b = pbm_scan_number (&p, end);
9682 if (r < 0 || g < 0 || b < 0)
9684 b xfree (ximg->data);
9685 ximg->data = NULL;
9686 XDestroyImage (ximg);
9687 UNBLOCK_INPUT;
9688 image_error ("Invalid pixel value in image `%s'",
9689 img->spec, Qnil);
9690 goto error;
9693 /* RGB values are now in the range 0..max_color_idx.
9694 Scale this to the range 0..0xffff supported by X. */
9695 r = (double) r * 65535 / max_color_idx;
9696 g = (double) g * 65535 / max_color_idx;
9697 b = (double) b * 65535 / max_color_idx;
9698 XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b));
9702 /* Store in IMG->colors the colors allocated for the image, and
9703 free the color table. */
9704 img->colors = colors_in_color_table (&img->ncolors);
9705 free_color_table ();
9707 /* Put the image into a pixmap. */
9708 x_put_x_image (f, ximg, img->pixmap, width, height);
9709 x_destroy_x_image (ximg);
9710 UNBLOCK_INPUT;
9712 img->width = width;
9713 img->height = height;
9715 UNGCPRO;
9716 xfree (contents);
9717 return 1;
9719 #endif /* HAVE_PBM */
9722 /***********************************************************************
9724 ***********************************************************************/
9726 #if HAVE_PNG
9728 #include <png.h>
9730 /* Function prototypes. */
9732 static int png_image_p P_ ((Lisp_Object object));
9733 static int png_load P_ ((struct frame *f, struct image *img));
9735 /* The symbol `png' identifying images of this type. */
9737 Lisp_Object Qpng;
9739 /* Indices of image specification fields in png_format, below. */
9741 enum png_keyword_index
9743 PNG_TYPE,
9744 PNG_DATA,
9745 PNG_FILE,
9746 PNG_ASCENT,
9747 PNG_MARGIN,
9748 PNG_RELIEF,
9749 PNG_ALGORITHM,
9750 PNG_HEURISTIC_MASK,
9751 PNG_LAST
9754 /* Vector of image_keyword structures describing the format
9755 of valid user-defined image specifications. */
9757 static struct image_keyword png_format[PNG_LAST] =
9759 {":type", IMAGE_SYMBOL_VALUE, 1},
9760 {":data", IMAGE_STRING_VALUE, 0},
9761 {":file", IMAGE_STRING_VALUE, 0},
9762 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
9763 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
9764 {":relief", IMAGE_INTEGER_VALUE, 0},
9765 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
9766 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
9769 /* Structure describing the image type `png'. */
9771 static struct image_type png_type =
9773 &Qpng,
9774 png_image_p,
9775 png_load,
9776 x_clear_image,
9777 NULL
9781 /* Return non-zero if OBJECT is a valid PNG image specification. */
9783 static int
9784 png_image_p (object)
9785 Lisp_Object object;
9787 struct image_keyword fmt[PNG_LAST];
9788 bcopy (png_format, fmt, sizeof fmt);
9790 if (!parse_image_spec (object, fmt, PNG_LAST, Qpng)
9791 || (fmt[PNG_ASCENT].count
9792 && XFASTINT (fmt[PNG_ASCENT].value) > 100))
9793 return 0;
9795 /* Must specify either the :data or :file keyword. */
9796 return fmt[PNG_FILE].count + fmt[PNG_DATA].count == 1;
9800 /* Error and warning handlers installed when the PNG library
9801 is initialized. */
9803 static void
9804 my_png_error (png_ptr, msg)
9805 png_struct *png_ptr;
9806 char *msg;
9808 xassert (png_ptr != NULL);
9809 image_error ("PNG error: %s", build_string (msg), Qnil);
9810 longjmp (png_ptr->jmpbuf, 1);
9814 static void
9815 my_png_warning (png_ptr, msg)
9816 png_struct *png_ptr;
9817 char *msg;
9819 xassert (png_ptr != NULL);
9820 image_error ("PNG warning: %s", build_string (msg), Qnil);
9824 /* Memory source for PNG decoding. */
9826 struct png_memory_storage
9828 unsigned char *bytes; /* The data */
9829 size_t len; /* How big is it? */
9830 int index; /* Where are we? */
9834 /* Function set as reader function when reading PNG image from memory.
9835 PNG_PTR is a pointer to the PNG control structure. Copy LENGTH
9836 bytes from the input to DATA. */
9838 static void
9839 png_read_from_memory (png_ptr, data, length)
9840 png_structp png_ptr;
9841 png_bytep data;
9842 png_size_t length;
9844 struct png_memory_storage *tbr
9845 = (struct png_memory_storage *) png_get_io_ptr (png_ptr);
9847 if (length > tbr->len - tbr->index)
9848 png_error (png_ptr, "Read error");
9850 bcopy (tbr->bytes + tbr->index, data, length);
9851 tbr->index = tbr->index + length;
9855 /* Load PNG image IMG for use on frame F. Value is non-zero if
9856 successful. */
9858 static int
9859 png_load (f, img)
9860 struct frame *f;
9861 struct image *img;
9863 Lisp_Object file, specified_file;
9864 Lisp_Object specified_data;
9865 int x, y, i;
9866 XImage *ximg, *mask_img = NULL;
9867 struct gcpro gcpro1;
9868 png_struct *png_ptr = NULL;
9869 png_info *info_ptr = NULL, *end_info = NULL;
9870 FILE *fp = NULL;
9871 png_byte sig[8];
9872 png_byte *pixels = NULL;
9873 png_byte **rows = NULL;
9874 png_uint_32 width, height;
9875 int bit_depth, color_type, interlace_type;
9876 png_byte channels;
9877 png_uint_32 row_bytes;
9878 int transparent_p;
9879 char *gamma_str;
9880 double screen_gamma, image_gamma;
9881 int intent;
9882 struct png_memory_storage tbr; /* Data to be read */
9884 /* Find out what file to load. */
9885 specified_file = image_spec_value (img->spec, QCfile, NULL);
9886 specified_data = image_spec_value (img->spec, QCdata, NULL);
9887 file = Qnil;
9888 GCPRO1 (file);
9890 if (NILP (specified_data))
9892 file = x_find_image_file (specified_file);
9893 if (!STRINGP (file))
9895 image_error ("Cannot find image file `%s'", specified_file, Qnil);
9896 UNGCPRO;
9897 return 0;
9900 /* Open the image file. */
9901 fp = fopen (XSTRING (file)->data, "rb");
9902 if (!fp)
9904 image_error ("Cannot open image file `%s'", file, Qnil);
9905 UNGCPRO;
9906 fclose (fp);
9907 return 0;
9910 /* Check PNG signature. */
9911 if (fread (sig, 1, sizeof sig, fp) != sizeof sig
9912 || !png_check_sig (sig, sizeof sig))
9914 image_error ("Not a PNG file:` %s'", file, Qnil);
9915 UNGCPRO;
9916 fclose (fp);
9917 return 0;
9920 else
9922 /* Read from memory. */
9923 tbr.bytes = XSTRING (specified_data)->data;
9924 tbr.len = STRING_BYTES (XSTRING (specified_data));
9925 tbr.index = 0;
9927 /* Check PNG signature. */
9928 if (tbr.len < sizeof sig
9929 || !png_check_sig (tbr.bytes, sizeof sig))
9931 image_error ("Not a PNG image: `%s'", img->spec, Qnil);
9932 UNGCPRO;
9933 return 0;
9936 /* Need to skip past the signature. */
9937 tbr.bytes += sizeof (sig);
9941 /* Initialize read and info structs for PNG lib. */
9942 png_ptr = png_create_read_struct (PNG_LIBPNG_VER_STRING, NULL,
9943 my_png_error, my_png_warning);
9944 if (!png_ptr)
9946 if (fp) fclose (fp);
9947 UNGCPRO;
9948 return 0;
9951 info_ptr = png_create_info_struct (png_ptr);
9952 if (!info_ptr)
9954 png_destroy_read_struct (&png_ptr, NULL, NULL);
9955 if (fp) fclose (fp);
9956 UNGCPRO;
9957 return 0;
9960 end_info = png_create_info_struct (png_ptr);
9961 if (!end_info)
9963 png_destroy_read_struct (&png_ptr, &info_ptr, NULL);
9964 if (fp) fclose (fp);
9965 UNGCPRO;
9966 return 0;
9969 /* Set error jump-back. We come back here when the PNG library
9970 detects an error. */
9971 if (setjmp (png_ptr->jmpbuf))
9973 error:
9974 if (png_ptr)
9975 png_destroy_read_struct (&png_ptr, &info_ptr, &end_info);
9976 xfree (pixels);
9977 xfree (rows);
9978 if (fp) fclose (fp);
9979 UNGCPRO;
9980 return 0;
9983 /* Read image info. */
9984 if (!NILP (specified_data))
9985 png_set_read_fn (png_ptr, (void *) &tbr, png_read_from_memory);
9986 else
9987 png_init_io (png_ptr, fp);
9989 png_set_sig_bytes (png_ptr, sizeof sig);
9990 png_read_info (png_ptr, info_ptr);
9991 png_get_IHDR (png_ptr, info_ptr, &width, &height, &bit_depth, &color_type,
9992 &interlace_type, NULL, NULL);
9994 /* If image contains simply transparency data, we prefer to
9995 construct a clipping mask. */
9996 if (png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS))
9997 transparent_p = 1;
9998 else
9999 transparent_p = 0;
10001 /* This function is easier to write if we only have to handle
10002 one data format: RGB or RGBA with 8 bits per channel. Let's
10003 transform other formats into that format. */
10005 /* Strip more than 8 bits per channel. */
10006 if (bit_depth == 16)
10007 png_set_strip_16 (png_ptr);
10009 /* Expand data to 24 bit RGB, or 8 bit grayscale, with alpha channel
10010 if available. */
10011 png_set_expand (png_ptr);
10013 /* Convert grayscale images to RGB. */
10014 if (color_type == PNG_COLOR_TYPE_GRAY
10015 || color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
10016 png_set_gray_to_rgb (png_ptr);
10018 /* The value 2.2 is a guess for PC monitors from PNG example.c. */
10019 gamma_str = getenv ("SCREEN_GAMMA");
10020 screen_gamma = gamma_str ? atof (gamma_str) : 2.2;
10022 /* Tell the PNG lib to handle gamma correction for us. */
10024 #if defined(PNG_READ_sRGB_SUPPORTED) || defined(PNG_WRITE_sRGB_SUPPORTED)
10025 if (png_get_sRGB (png_ptr, info_ptr, &intent))
10026 /* There is a special chunk in the image specifying the gamma. */
10027 png_set_sRGB (png_ptr, info_ptr, intent);
10028 else
10029 #endif
10030 if (png_get_gAMA (png_ptr, info_ptr, &image_gamma))
10031 /* Image contains gamma information. */
10032 png_set_gamma (png_ptr, screen_gamma, image_gamma);
10033 else
10034 /* Use a default of 0.5 for the image gamma. */
10035 png_set_gamma (png_ptr, screen_gamma, 0.5);
10037 /* Handle alpha channel by combining the image with a background
10038 color. Do this only if a real alpha channel is supplied. For
10039 simple transparency, we prefer a clipping mask. */
10040 if (!transparent_p)
10042 png_color_16 *image_background;
10044 if (png_get_bKGD (png_ptr, info_ptr, &image_background))
10045 /* Image contains a background color with which to
10046 combine the image. */
10047 png_set_background (png_ptr, image_background,
10048 PNG_BACKGROUND_GAMMA_FILE, 1, 1.0);
10049 else
10051 /* Image does not contain a background color with which
10052 to combine the image data via an alpha channel. Use
10053 the frame's background instead. */
10054 XColor color;
10055 Colormap cmap;
10056 png_color_16 frame_background;
10058 BLOCK_INPUT;
10059 cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
10060 color.pixel = FRAME_BACKGROUND_PIXEL (f);
10061 XQueryColor (FRAME_W32_DISPLAY (f), cmap, &color);
10062 UNBLOCK_INPUT;
10064 bzero (&frame_background, sizeof frame_background);
10065 frame_background.red = color.red;
10066 frame_background.green = color.green;
10067 frame_background.blue = color.blue;
10069 png_set_background (png_ptr, &frame_background,
10070 PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0);
10074 /* Update info structure. */
10075 png_read_update_info (png_ptr, info_ptr);
10077 /* Get number of channels. Valid values are 1 for grayscale images
10078 and images with a palette, 2 for grayscale images with transparency
10079 information (alpha channel), 3 for RGB images, and 4 for RGB
10080 images with alpha channel, i.e. RGBA. If conversions above were
10081 sufficient we should only have 3 or 4 channels here. */
10082 channels = png_get_channels (png_ptr, info_ptr);
10083 xassert (channels == 3 || channels == 4);
10085 /* Number of bytes needed for one row of the image. */
10086 row_bytes = png_get_rowbytes (png_ptr, info_ptr);
10088 /* Allocate memory for the image. */
10089 pixels = (png_byte *) xmalloc (row_bytes * height * sizeof *pixels);
10090 rows = (png_byte **) xmalloc (height * sizeof *rows);
10091 for (i = 0; i < height; ++i)
10092 rows[i] = pixels + i * row_bytes;
10094 /* Read the entire image. */
10095 png_read_image (png_ptr, rows);
10096 png_read_end (png_ptr, info_ptr);
10097 if (fp)
10099 fclose (fp);
10100 fp = NULL;
10103 BLOCK_INPUT;
10105 /* Create the X image and pixmap. */
10106 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg,
10107 &img->pixmap))
10109 UNBLOCK_INPUT;
10110 goto error;
10113 /* Create an image and pixmap serving as mask if the PNG image
10114 contains an alpha channel. */
10115 if (channels == 4
10116 && !transparent_p
10117 && !x_create_x_image_and_pixmap (f, width, height, 1,
10118 &mask_img, &img->mask))
10120 x_destroy_x_image (ximg);
10121 XFreePixmap (FRAME_W32_DISPLAY (f), img->pixmap);
10122 img->pixmap = 0;
10123 UNBLOCK_INPUT;
10124 goto error;
10127 /* Fill the X image and mask from PNG data. */
10128 init_color_table ();
10130 for (y = 0; y < height; ++y)
10132 png_byte *p = rows[y];
10134 for (x = 0; x < width; ++x)
10136 unsigned r, g, b;
10138 r = *p++ << 8;
10139 g = *p++ << 8;
10140 b = *p++ << 8;
10141 XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b));
10143 /* An alpha channel, aka mask channel, associates variable
10144 transparency with an image. Where other image formats
10145 support binary transparency---fully transparent or fully
10146 opaque---PNG allows up to 254 levels of partial transparency.
10147 The PNG library implements partial transparency by combining
10148 the image with a specified background color.
10150 I'm not sure how to handle this here nicely: because the
10151 background on which the image is displayed may change, for
10152 real alpha channel support, it would be necessary to create
10153 a new image for each possible background.
10155 What I'm doing now is that a mask is created if we have
10156 boolean transparency information. Otherwise I'm using
10157 the frame's background color to combine the image with. */
10159 if (channels == 4)
10161 if (mask_img)
10162 XPutPixel (mask_img, x, y, *p > 0);
10163 ++p;
10168 /* Remember colors allocated for this image. */
10169 img->colors = colors_in_color_table (&img->ncolors);
10170 free_color_table ();
10172 /* Clean up. */
10173 png_destroy_read_struct (&png_ptr, &info_ptr, &end_info);
10174 xfree (rows);
10175 xfree (pixels);
10177 img->width = width;
10178 img->height = height;
10180 /* Put the image into the pixmap, then free the X image and its buffer. */
10181 x_put_x_image (f, ximg, img->pixmap, width, height);
10182 x_destroy_x_image (ximg);
10184 /* Same for the mask. */
10185 if (mask_img)
10187 x_put_x_image (f, mask_img, img->mask, img->width, img->height);
10188 x_destroy_x_image (mask_img);
10191 UNBLOCK_INPUT;
10192 UNGCPRO;
10193 return 1;
10196 #endif /* HAVE_PNG != 0 */
10200 /***********************************************************************
10201 JPEG
10202 ***********************************************************************/
10204 #if HAVE_JPEG
10206 /* Work around a warning about HAVE_STDLIB_H being redefined in
10207 jconfig.h. */
10208 #ifdef HAVE_STDLIB_H
10209 #define HAVE_STDLIB_H_1
10210 #undef HAVE_STDLIB_H
10211 #endif /* HAVE_STLIB_H */
10213 #include <jpeglib.h>
10214 #include <jerror.h>
10215 #include <setjmp.h>
10217 #ifdef HAVE_STLIB_H_1
10218 #define HAVE_STDLIB_H 1
10219 #endif
10221 static int jpeg_image_p P_ ((Lisp_Object object));
10222 static int jpeg_load P_ ((struct frame *f, struct image *img));
10224 /* The symbol `jpeg' identifying images of this type. */
10226 Lisp_Object Qjpeg;
10228 /* Indices of image specification fields in gs_format, below. */
10230 enum jpeg_keyword_index
10232 JPEG_TYPE,
10233 JPEG_DATA,
10234 JPEG_FILE,
10235 JPEG_ASCENT,
10236 JPEG_MARGIN,
10237 JPEG_RELIEF,
10238 JPEG_ALGORITHM,
10239 JPEG_HEURISTIC_MASK,
10240 JPEG_LAST
10243 /* Vector of image_keyword structures describing the format
10244 of valid user-defined image specifications. */
10246 static struct image_keyword jpeg_format[JPEG_LAST] =
10248 {":type", IMAGE_SYMBOL_VALUE, 1},
10249 {":data", IMAGE_STRING_VALUE, 0},
10250 {":file", IMAGE_STRING_VALUE, 0},
10251 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
10252 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
10253 {":relief", IMAGE_INTEGER_VALUE, 0},
10254 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10255 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
10258 /* Structure describing the image type `jpeg'. */
10260 static struct image_type jpeg_type =
10262 &Qjpeg,
10263 jpeg_image_p,
10264 jpeg_load,
10265 x_clear_image,
10266 NULL
10270 /* Return non-zero if OBJECT is a valid JPEG image specification. */
10272 static int
10273 jpeg_image_p (object)
10274 Lisp_Object object;
10276 struct image_keyword fmt[JPEG_LAST];
10278 bcopy (jpeg_format, fmt, sizeof fmt);
10280 if (!parse_image_spec (object, fmt, JPEG_LAST, Qjpeg)
10281 || (fmt[JPEG_ASCENT].count
10282 && XFASTINT (fmt[JPEG_ASCENT].value) > 100))
10283 return 0;
10285 /* Must specify either the :data or :file keyword. */
10286 return fmt[JPEG_FILE].count + fmt[JPEG_DATA].count == 1;
10290 struct my_jpeg_error_mgr
10292 struct jpeg_error_mgr pub;
10293 jmp_buf setjmp_buffer;
10296 static void
10297 my_error_exit (cinfo)
10298 j_common_ptr cinfo;
10300 struct my_jpeg_error_mgr *mgr = (struct my_jpeg_error_mgr *) cinfo->err;
10301 longjmp (mgr->setjmp_buffer, 1);
10305 /* Init source method for JPEG data source manager. Called by
10306 jpeg_read_header() before any data is actually read. See
10307 libjpeg.doc from the JPEG lib distribution. */
10309 static void
10310 our_init_source (cinfo)
10311 j_decompress_ptr cinfo;
10316 /* Fill input buffer method for JPEG data source manager. Called
10317 whenever more data is needed. We read the whole image in one step,
10318 so this only adds a fake end of input marker at the end. */
10320 static boolean
10321 our_fill_input_buffer (cinfo)
10322 j_decompress_ptr cinfo;
10324 /* Insert a fake EOI marker. */
10325 struct jpeg_source_mgr *src = cinfo->src;
10326 static JOCTET buffer[2];
10328 buffer[0] = (JOCTET) 0xFF;
10329 buffer[1] = (JOCTET) JPEG_EOI;
10331 src->next_input_byte = buffer;
10332 src->bytes_in_buffer = 2;
10333 return TRUE;
10337 /* Method to skip over NUM_BYTES bytes in the image data. CINFO->src
10338 is the JPEG data source manager. */
10340 static void
10341 our_skip_input_data (cinfo, num_bytes)
10342 j_decompress_ptr cinfo;
10343 long num_bytes;
10345 struct jpeg_source_mgr *src = (struct jpeg_source_mgr *) cinfo->src;
10347 if (src)
10349 if (num_bytes > src->bytes_in_buffer)
10350 ERREXIT (cinfo, JERR_INPUT_EOF);
10352 src->bytes_in_buffer -= num_bytes;
10353 src->next_input_byte += num_bytes;
10358 /* Method to terminate data source. Called by
10359 jpeg_finish_decompress() after all data has been processed. */
10361 static void
10362 our_term_source (cinfo)
10363 j_decompress_ptr cinfo;
10368 /* Set up the JPEG lib for reading an image from DATA which contains
10369 LEN bytes. CINFO is the decompression info structure created for
10370 reading the image. */
10372 static void
10373 jpeg_memory_src (cinfo, data, len)
10374 j_decompress_ptr cinfo;
10375 JOCTET *data;
10376 unsigned int len;
10378 struct jpeg_source_mgr *src;
10380 if (cinfo->src == NULL)
10382 /* First time for this JPEG object? */
10383 cinfo->src = (struct jpeg_source_mgr *)
10384 (*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT,
10385 sizeof (struct jpeg_source_mgr));
10386 src = (struct jpeg_source_mgr *) cinfo->src;
10387 src->next_input_byte = data;
10390 src = (struct jpeg_source_mgr *) cinfo->src;
10391 src->init_source = our_init_source;
10392 src->fill_input_buffer = our_fill_input_buffer;
10393 src->skip_input_data = our_skip_input_data;
10394 src->resync_to_restart = jpeg_resync_to_restart; /* Use default method. */
10395 src->term_source = our_term_source;
10396 src->bytes_in_buffer = len;
10397 src->next_input_byte = data;
10401 /* Load image IMG for use on frame F. Patterned after example.c
10402 from the JPEG lib. */
10404 static int
10405 jpeg_load (f, img)
10406 struct frame *f;
10407 struct image *img;
10409 struct jpeg_decompress_struct cinfo;
10410 struct my_jpeg_error_mgr mgr;
10411 Lisp_Object file, specified_file;
10412 Lisp_Object specified_data;
10413 FILE *fp = NULL;
10414 JSAMPARRAY buffer;
10415 int row_stride, x, y;
10416 XImage *ximg = NULL;
10417 int rc;
10418 unsigned long *colors;
10419 int width, height;
10420 struct gcpro gcpro1;
10422 /* Open the JPEG file. */
10423 specified_file = image_spec_value (img->spec, QCfile, NULL);
10424 specified_data = image_spec_value (img->spec, QCdata, NULL);
10425 file = Qnil;
10426 GCPRO1 (file);
10429 if (NILP (specified_data))
10431 file = x_find_image_file (specified_file);
10432 if (!STRINGP (file))
10434 image_error ("Cannot find image file `%s'", specified_file, Qnil);
10435 UNGCPRO;
10436 return 0;
10439 fp = fopen (XSTRING (file)->data, "r");
10440 if (fp == NULL)
10442 image_error ("Cannot open `%s'", file, Qnil);
10443 UNGCPRO;
10444 return 0;
10448 /* Customize libjpeg's error handling to call my_error_exit when an
10449 error is detected. This function will perform a longjmp. */
10450 mgr.pub.error_exit = my_error_exit;
10451 cinfo.err = jpeg_std_error (&mgr.pub);
10453 if ((rc = setjmp (mgr.setjmp_buffer)) != 0)
10455 if (rc == 1)
10457 /* Called from my_error_exit. Display a JPEG error. */
10458 char buffer[JMSG_LENGTH_MAX];
10459 cinfo.err->format_message ((j_common_ptr) &cinfo, buffer);
10460 image_error ("Error reading JPEG image `%s': %s", img->spec,
10461 build_string (buffer));
10464 /* Close the input file and destroy the JPEG object. */
10465 if (fp)
10466 fclose (fp);
10467 jpeg_destroy_decompress (&cinfo);
10469 BLOCK_INPUT;
10471 /* If we already have an XImage, free that. */
10472 x_destroy_x_image (ximg);
10474 /* Free pixmap and colors. */
10475 x_clear_image (f, img);
10477 UNBLOCK_INPUT;
10478 UNGCPRO;
10479 return 0;
10482 /* Create the JPEG decompression object. Let it read from fp.
10483 Read the JPEG image header. */
10484 jpeg_create_decompress (&cinfo);
10486 if (NILP (specified_data))
10487 jpeg_stdio_src (&cinfo, fp);
10488 else
10489 jpeg_memory_src (&cinfo, XSTRING (specified_data)->data,
10490 STRING_BYTES (XSTRING (specified_data)));
10492 jpeg_read_header (&cinfo, TRUE);
10494 /* Customize decompression so that color quantization will be used.
10495 Start decompression. */
10496 cinfo.quantize_colors = TRUE;
10497 jpeg_start_decompress (&cinfo);
10498 width = img->width = cinfo.output_width;
10499 height = img->height = cinfo.output_height;
10501 BLOCK_INPUT;
10503 /* Create X image and pixmap. */
10504 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg,
10505 &img->pixmap))
10507 UNBLOCK_INPUT;
10508 longjmp (mgr.setjmp_buffer, 2);
10511 /* Allocate colors. When color quantization is used,
10512 cinfo.actual_number_of_colors has been set with the number of
10513 colors generated, and cinfo.colormap is a two-dimensional array
10514 of color indices in the range 0..cinfo.actual_number_of_colors.
10515 No more than 255 colors will be generated. */
10517 int i, ir, ig, ib;
10519 if (cinfo.out_color_components > 2)
10520 ir = 0, ig = 1, ib = 2;
10521 else if (cinfo.out_color_components > 1)
10522 ir = 0, ig = 1, ib = 0;
10523 else
10524 ir = 0, ig = 0, ib = 0;
10526 /* Use the color table mechanism because it handles colors that
10527 cannot be allocated nicely. Such colors will be replaced with
10528 a default color, and we don't have to care about which colors
10529 can be freed safely, and which can't. */
10530 init_color_table ();
10531 colors = (unsigned long *) alloca (cinfo.actual_number_of_colors
10532 * sizeof *colors);
10534 for (i = 0; i < cinfo.actual_number_of_colors; ++i)
10536 /* Multiply RGB values with 255 because X expects RGB values
10537 in the range 0..0xffff. */
10538 int r = cinfo.colormap[ir][i] << 8;
10539 int g = cinfo.colormap[ig][i] << 8;
10540 int b = cinfo.colormap[ib][i] << 8;
10541 colors[i] = lookup_rgb_color (f, r, g, b);
10544 /* Remember those colors actually allocated. */
10545 img->colors = colors_in_color_table (&img->ncolors);
10546 free_color_table ();
10549 /* Read pixels. */
10550 row_stride = width * cinfo.output_components;
10551 buffer = cinfo.mem->alloc_sarray ((j_common_ptr) &cinfo, JPOOL_IMAGE,
10552 row_stride, 1);
10553 for (y = 0; y < height; ++y)
10555 jpeg_read_scanlines (&cinfo, buffer, 1);
10556 for (x = 0; x < cinfo.output_width; ++x)
10557 XPutPixel (ximg, x, y, colors[buffer[0][x]]);
10560 /* Clean up. */
10561 jpeg_finish_decompress (&cinfo);
10562 jpeg_destroy_decompress (&cinfo);
10563 if (fp)
10564 fclose (fp);
10566 /* Put the image into the pixmap. */
10567 x_put_x_image (f, ximg, img->pixmap, width, height);
10568 x_destroy_x_image (ximg);
10569 UNBLOCK_INPUT;
10570 UNGCPRO;
10571 return 1;
10574 #endif /* HAVE_JPEG */
10578 /***********************************************************************
10579 TIFF
10580 ***********************************************************************/
10582 #if HAVE_TIFF
10584 #include <tiffio.h>
10586 static int tiff_image_p P_ ((Lisp_Object object));
10587 static int tiff_load P_ ((struct frame *f, struct image *img));
10589 /* The symbol `tiff' identifying images of this type. */
10591 Lisp_Object Qtiff;
10593 /* Indices of image specification fields in tiff_format, below. */
10595 enum tiff_keyword_index
10597 TIFF_TYPE,
10598 TIFF_DATA,
10599 TIFF_FILE,
10600 TIFF_ASCENT,
10601 TIFF_MARGIN,
10602 TIFF_RELIEF,
10603 TIFF_ALGORITHM,
10604 TIFF_HEURISTIC_MASK,
10605 TIFF_LAST
10608 /* Vector of image_keyword structures describing the format
10609 of valid user-defined image specifications. */
10611 static struct image_keyword tiff_format[TIFF_LAST] =
10613 {":type", IMAGE_SYMBOL_VALUE, 1},
10614 {":data", IMAGE_STRING_VALUE, 0},
10615 {":file", IMAGE_STRING_VALUE, 0},
10616 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
10617 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
10618 {":relief", IMAGE_INTEGER_VALUE, 0},
10619 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10620 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
10623 /* Structure describing the image type `tiff'. */
10625 static struct image_type tiff_type =
10627 &Qtiff,
10628 tiff_image_p,
10629 tiff_load,
10630 x_clear_image,
10631 NULL
10635 /* Return non-zero if OBJECT is a valid TIFF image specification. */
10637 static int
10638 tiff_image_p (object)
10639 Lisp_Object object;
10641 struct image_keyword fmt[TIFF_LAST];
10642 bcopy (tiff_format, fmt, sizeof fmt);
10644 if (!parse_image_spec (object, fmt, TIFF_LAST, Qtiff)
10645 || (fmt[TIFF_ASCENT].count
10646 && XFASTINT (fmt[TIFF_ASCENT].value) > 100))
10647 return 0;
10649 /* Must specify either the :data or :file keyword. */
10650 return fmt[TIFF_FILE].count + fmt[TIFF_DATA].count == 1;
10654 /* Reading from a memory buffer for TIFF images Based on the PNG
10655 memory source, but we have to provide a lot of extra functions.
10656 Blah.
10658 We really only need to implement read and seek, but I am not
10659 convinced that the TIFF library is smart enough not to destroy
10660 itself if we only hand it the function pointers we need to
10661 override. */
10663 typedef struct
10665 unsigned char *bytes;
10666 size_t len;
10667 int index;
10669 tiff_memory_source;
10671 static size_t
10672 tiff_read_from_memory (data, buf, size)
10673 thandle_t data;
10674 tdata_t buf;
10675 tsize_t size;
10677 tiff_memory_source *src = (tiff_memory_source *) data;
10679 if (size > src->len - src->index)
10680 return (size_t) -1;
10681 bcopy (src->bytes + src->index, buf, size);
10682 src->index += size;
10683 return size;
10686 static size_t
10687 tiff_write_from_memory (data, buf, size)
10688 thandle_t data;
10689 tdata_t buf;
10690 tsize_t size;
10692 return (size_t) -1;
10695 static toff_t
10696 tiff_seek_in_memory (data, off, whence)
10697 thandle_t data;
10698 toff_t off;
10699 int whence;
10701 tiff_memory_source *src = (tiff_memory_source *) data;
10702 int idx;
10704 switch (whence)
10706 case SEEK_SET: /* Go from beginning of source. */
10707 idx = off;
10708 break;
10710 case SEEK_END: /* Go from end of source. */
10711 idx = src->len + off;
10712 break;
10714 case SEEK_CUR: /* Go from current position. */
10715 idx = src->index + off;
10716 break;
10718 default: /* Invalid `whence'. */
10719 return -1;
10722 if (idx > src->len || idx < 0)
10723 return -1;
10725 src->index = idx;
10726 return src->index;
10729 static int
10730 tiff_close_memory (data)
10731 thandle_t data;
10733 /* NOOP */
10734 return 0;
10737 static int
10738 tiff_mmap_memory (data, pbase, psize)
10739 thandle_t data;
10740 tdata_t *pbase;
10741 toff_t *psize;
10743 /* It is already _IN_ memory. */
10744 return 0;
10747 static void
10748 tiff_unmap_memory (data, base, size)
10749 thandle_t data;
10750 tdata_t base;
10751 toff_t size;
10753 /* We don't need to do this. */
10756 static toff_t
10757 tiff_size_of_memory (data)
10758 thandle_t data;
10760 return ((tiff_memory_source *) data)->len;
10764 /* Load TIFF image IMG for use on frame F. Value is non-zero if
10765 successful. */
10767 static int
10768 tiff_load (f, img)
10769 struct frame *f;
10770 struct image *img;
10772 Lisp_Object file, specified_file;
10773 Lisp_Object specified_data;
10774 TIFF *tiff;
10775 int width, height, x, y;
10776 uint32 *buf;
10777 int rc;
10778 XImage *ximg;
10779 struct gcpro gcpro1;
10780 tiff_memory_source memsrc;
10782 specified_file = image_spec_value (img->spec, QCfile, NULL);
10783 specified_data = image_spec_value (img->spec, QCdata, NULL);
10784 file = Qnil;
10785 GCPRO1 (file);
10787 if (NILP (specified_data))
10789 /* Read from a file */
10790 file = x_find_image_file (specified_file);
10791 if (!STRINGP (file))
10793 image_error ("Cannot find image file `%s'", file, Qnil);
10794 UNGCPRO;
10795 return 0;
10798 /* Try to open the image file. */
10799 tiff = TIFFOpen (XSTRING (file)->data, "r");
10800 if (tiff == NULL)
10802 image_error ("Cannot open `%s'", file, Qnil);
10803 UNGCPRO;
10804 return 0;
10807 else
10809 /* Memory source! */
10810 memsrc.bytes = XSTRING (specified_data)->data;
10811 memsrc.len = STRING_BYTES (XSTRING (specified_data));
10812 memsrc.index = 0;
10814 tiff = TIFFClientOpen ("memory_source", "r", &memsrc,
10815 (TIFFReadWriteProc) tiff_read_from_memory,
10816 (TIFFReadWriteProc) tiff_write_from_memory,
10817 tiff_seek_in_memory,
10818 tiff_close_memory,
10819 tiff_size_of_memory,
10820 tiff_mmap_memory,
10821 tiff_unmap_memory);
10823 if (!tiff)
10825 image_error ("Cannot open memory source for `%s'", img->spec, Qnil);
10826 UNGCPRO;
10827 return 0;
10831 /* Get width and height of the image, and allocate a raster buffer
10832 of width x height 32-bit values. */
10833 TIFFGetField (tiff, TIFFTAG_IMAGEWIDTH, &width);
10834 TIFFGetField (tiff, TIFFTAG_IMAGELENGTH, &height);
10835 buf = (uint32 *) xmalloc (width * height * sizeof *buf);
10837 rc = TIFFReadRGBAImage (tiff, width, height, buf, 0);
10838 TIFFClose (tiff);
10839 if (!rc)
10841 image_error ("Error reading TIFF image `%s'", img->spec, Qnil);
10842 xfree (buf);
10843 UNGCPRO;
10844 return 0;
10847 BLOCK_INPUT;
10849 /* Create the X image and pixmap. */
10850 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
10852 UNBLOCK_INPUT;
10853 xfree (buf);
10854 UNGCPRO;
10855 return 0;
10858 /* Initialize the color table. */
10859 init_color_table ();
10861 /* Process the pixel raster. Origin is in the lower-left corner. */
10862 for (y = 0; y < height; ++y)
10864 uint32 *row = buf + y * width;
10866 for (x = 0; x < width; ++x)
10868 uint32 abgr = row[x];
10869 int r = TIFFGetR (abgr) << 8;
10870 int g = TIFFGetG (abgr) << 8;
10871 int b = TIFFGetB (abgr) << 8;
10872 XPutPixel (ximg, x, height - 1 - y, lookup_rgb_color (f, r, g, b));
10876 /* Remember the colors allocated for the image. Free the color table. */
10877 img->colors = colors_in_color_table (&img->ncolors);
10878 free_color_table ();
10880 /* Put the image into the pixmap, then free the X image and its buffer. */
10881 x_put_x_image (f, ximg, img->pixmap, width, height);
10882 x_destroy_x_image (ximg);
10883 xfree (buf);
10884 UNBLOCK_INPUT;
10886 img->width = width;
10887 img->height = height;
10889 UNGCPRO;
10890 return 1;
10893 #endif /* HAVE_TIFF != 0 */
10897 /***********************************************************************
10899 ***********************************************************************/
10901 #if HAVE_GIF
10903 #include <gif_lib.h>
10905 static int gif_image_p P_ ((Lisp_Object object));
10906 static int gif_load P_ ((struct frame *f, struct image *img));
10908 /* The symbol `gif' identifying images of this type. */
10910 Lisp_Object Qgif;
10912 /* Indices of image specification fields in gif_format, below. */
10914 enum gif_keyword_index
10916 GIF_TYPE,
10917 GIF_DATA,
10918 GIF_FILE,
10919 GIF_ASCENT,
10920 GIF_MARGIN,
10921 GIF_RELIEF,
10922 GIF_ALGORITHM,
10923 GIF_HEURISTIC_MASK,
10924 GIF_IMAGE,
10925 GIF_LAST
10928 /* Vector of image_keyword structures describing the format
10929 of valid user-defined image specifications. */
10931 static struct image_keyword gif_format[GIF_LAST] =
10933 {":type", IMAGE_SYMBOL_VALUE, 1},
10934 {":data", IMAGE_STRING_VALUE, 0},
10935 {":file", IMAGE_STRING_VALUE, 0},
10936 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
10937 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
10938 {":relief", IMAGE_INTEGER_VALUE, 0},
10939 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10940 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10941 {":image", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}
10944 /* Structure describing the image type `gif'. */
10946 static struct image_type gif_type =
10948 &Qgif,
10949 gif_image_p,
10950 gif_load,
10951 x_clear_image,
10952 NULL
10955 /* Return non-zero if OBJECT is a valid GIF image specification. */
10957 static int
10958 gif_image_p (object)
10959 Lisp_Object object;
10961 struct image_keyword fmt[GIF_LAST];
10962 bcopy (gif_format, fmt, sizeof fmt);
10964 if (!parse_image_spec (object, fmt, GIF_LAST, Qgif)
10965 || (fmt[GIF_ASCENT].count
10966 && XFASTINT (fmt[GIF_ASCENT].value) > 100))
10967 return 0;
10969 /* Must specify either the :data or :file keyword. */
10970 return fmt[GIF_FILE].count + fmt[GIF_DATA].count == 1;
10973 /* Reading a GIF image from memory
10974 Based on the PNG memory stuff to a certain extent. */
10976 typedef struct
10978 unsigned char *bytes;
10979 size_t len;
10980 int index;
10982 gif_memory_source;
10984 /* Make the current memory source available to gif_read_from_memory.
10985 It's done this way because not all versions of libungif support
10986 a UserData field in the GifFileType structure. */
10987 static gif_memory_source *current_gif_memory_src;
10989 static int
10990 gif_read_from_memory (file, buf, len)
10991 GifFileType *file;
10992 GifByteType *buf;
10993 int len;
10995 gif_memory_source *src = current_gif_memory_src;
10997 if (len > src->len - src->index)
10998 return -1;
11000 bcopy (src->bytes + src->index, buf, len);
11001 src->index += len;
11002 return len;
11006 /* Load GIF image IMG for use on frame F. Value is non-zero if
11007 successful. */
11009 static int
11010 gif_load (f, img)
11011 struct frame *f;
11012 struct image *img;
11014 Lisp_Object file, specified_file;
11015 Lisp_Object specified_data;
11016 int rc, width, height, x, y, i;
11017 XImage *ximg;
11018 ColorMapObject *gif_color_map;
11019 unsigned long pixel_colors[256];
11020 GifFileType *gif;
11021 struct gcpro gcpro1;
11022 Lisp_Object image;
11023 int ino, image_left, image_top, image_width, image_height;
11024 gif_memory_source memsrc;
11025 unsigned char *raster;
11027 specified_file = image_spec_value (img->spec, QCfile, NULL);
11028 specified_data = image_spec_value (img->spec, QCdata, NULL);
11029 file = Qnil;
11031 if (NILP (specified_data))
11033 file = x_find_image_file (specified_file);
11034 GCPRO1 (file);
11035 if (!STRINGP (file))
11037 image_error ("Cannot find image file `%s'", specified_file, Qnil);
11038 UNGCPRO;
11039 return 0;
11042 /* Open the GIF file. */
11043 gif = DGifOpenFileName (XSTRING (file)->data);
11044 if (gif == NULL)
11046 image_error ("Cannot open `%s'", file, Qnil);
11047 UNGCPRO;
11048 return 0;
11051 else
11053 /* Read from memory! */
11054 current_gif_memory_src = &memsrc;
11055 memsrc.bytes = XSTRING (specified_data)->data;
11056 memsrc.len = STRING_BYTES (XSTRING (specified_data));
11057 memsrc.index = 0;
11059 gif = DGifOpen(&memsrc, gif_read_from_memory);
11060 if (!gif)
11062 image_error ("Cannot open memory source `%s'", img->spec, Qnil);
11063 UNGCPRO;
11064 return 0;
11068 /* Read entire contents. */
11069 rc = DGifSlurp (gif);
11070 if (rc == GIF_ERROR)
11072 image_error ("Error reading `%s'", img->spec, Qnil);
11073 DGifCloseFile (gif);
11074 UNGCPRO;
11075 return 0;
11078 image = image_spec_value (img->spec, QCindex, NULL);
11079 ino = INTEGERP (image) ? XFASTINT (image) : 0;
11080 if (ino >= gif->ImageCount)
11082 image_error ("Invalid image number `%s' in image `%s'",
11083 image, img->spec);
11084 DGifCloseFile (gif);
11085 UNGCPRO;
11086 return 0;
11089 width = img->width = gif->SWidth;
11090 height = img->height = gif->SHeight;
11092 BLOCK_INPUT;
11094 /* Create the X image and pixmap. */
11095 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
11097 UNBLOCK_INPUT;
11098 DGifCloseFile (gif);
11099 UNGCPRO;
11100 return 0;
11103 /* Allocate colors. */
11104 gif_color_map = gif->SavedImages[ino].ImageDesc.ColorMap;
11105 if (!gif_color_map)
11106 gif_color_map = gif->SColorMap;
11107 init_color_table ();
11108 bzero (pixel_colors, sizeof pixel_colors);
11110 for (i = 0; i < gif_color_map->ColorCount; ++i)
11112 int r = gif_color_map->Colors[i].Red << 8;
11113 int g = gif_color_map->Colors[i].Green << 8;
11114 int b = gif_color_map->Colors[i].Blue << 8;
11115 pixel_colors[i] = lookup_rgb_color (f, r, g, b);
11118 img->colors = colors_in_color_table (&img->ncolors);
11119 free_color_table ();
11121 /* Clear the part of the screen image that are not covered by
11122 the image from the GIF file. Full animated GIF support
11123 requires more than can be done here (see the gif89 spec,
11124 disposal methods). Let's simply assume that the part
11125 not covered by a sub-image is in the frame's background color. */
11126 image_top = gif->SavedImages[ino].ImageDesc.Top;
11127 image_left = gif->SavedImages[ino].ImageDesc.Left;
11128 image_width = gif->SavedImages[ino].ImageDesc.Width;
11129 image_height = gif->SavedImages[ino].ImageDesc.Height;
11131 for (y = 0; y < image_top; ++y)
11132 for (x = 0; x < width; ++x)
11133 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11135 for (y = image_top + image_height; y < height; ++y)
11136 for (x = 0; x < width; ++x)
11137 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11139 for (y = image_top; y < image_top + image_height; ++y)
11141 for (x = 0; x < image_left; ++x)
11142 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11143 for (x = image_left + image_width; x < width; ++x)
11144 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11147 /* Read the GIF image into the X image. We use a local variable
11148 `raster' here because RasterBits below is a char *, and invites
11149 problems with bytes >= 0x80. */
11150 raster = (unsigned char *) gif->SavedImages[ino].RasterBits;
11152 if (gif->SavedImages[ino].ImageDesc.Interlace)
11154 static int interlace_start[] = {0, 4, 2, 1};
11155 static int interlace_increment[] = {8, 8, 4, 2};
11156 int pass, inc;
11157 int row = interlace_start[0];
11159 pass = 0;
11161 for (y = 0; y < image_height; y++)
11163 if (row >= image_height)
11165 row = interlace_start[++pass];
11166 while (row >= image_height)
11167 row = interlace_start[++pass];
11170 for (x = 0; x < image_width; x++)
11172 int i = raster[(y * image_width) + x];
11173 XPutPixel (ximg, x + image_left, row + image_top,
11174 pixel_colors[i]);
11177 row += interlace_increment[pass];
11180 else
11182 for (y = 0; y < image_height; ++y)
11183 for (x = 0; x < image_width; ++x)
11185 int i = raster[y* image_width + x];
11186 XPutPixel (ximg, x + image_left, y + image_top, pixel_colors[i]);
11190 DGifCloseFile (gif);
11192 /* Put the image into the pixmap, then free the X image and its buffer. */
11193 x_put_x_image (f, ximg, img->pixmap, width, height);
11194 x_destroy_x_image (ximg);
11195 UNBLOCK_INPUT;
11197 UNGCPRO;
11198 return 1;
11201 #endif /* HAVE_GIF != 0 */
11205 /***********************************************************************
11206 Ghostscript
11207 ***********************************************************************/
11209 #ifdef HAVE_GHOSTSCRIPT
11210 static int gs_image_p P_ ((Lisp_Object object));
11211 static int gs_load P_ ((struct frame *f, struct image *img));
11212 static void gs_clear_image P_ ((struct frame *f, struct image *img));
11214 /* The symbol `postscript' identifying images of this type. */
11216 Lisp_Object Qpostscript;
11218 /* Keyword symbols. */
11220 Lisp_Object QCloader, QCbounding_box, QCpt_width, QCpt_height;
11222 /* Indices of image specification fields in gs_format, below. */
11224 enum gs_keyword_index
11226 GS_TYPE,
11227 GS_PT_WIDTH,
11228 GS_PT_HEIGHT,
11229 GS_FILE,
11230 GS_LOADER,
11231 GS_BOUNDING_BOX,
11232 GS_ASCENT,
11233 GS_MARGIN,
11234 GS_RELIEF,
11235 GS_ALGORITHM,
11236 GS_HEURISTIC_MASK,
11237 GS_LAST
11240 /* Vector of image_keyword structures describing the format
11241 of valid user-defined image specifications. */
11243 static struct image_keyword gs_format[GS_LAST] =
11245 {":type", IMAGE_SYMBOL_VALUE, 1},
11246 {":pt-width", IMAGE_POSITIVE_INTEGER_VALUE, 1},
11247 {":pt-height", IMAGE_POSITIVE_INTEGER_VALUE, 1},
11248 {":file", IMAGE_STRING_VALUE, 1},
11249 {":loader", IMAGE_FUNCTION_VALUE, 0},
11250 {":bounding-box", IMAGE_DONT_CHECK_VALUE_TYPE, 1},
11251 {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
11252 {":margin", IMAGE_POSITIVE_INTEGER_VALUE, 0},
11253 {":relief", IMAGE_INTEGER_VALUE, 0},
11254 {":algorithm", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
11255 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
11258 /* Structure describing the image type `ghostscript'. */
11260 static struct image_type gs_type =
11262 &Qpostscript,
11263 gs_image_p,
11264 gs_load,
11265 gs_clear_image,
11266 NULL
11270 /* Free X resources of Ghostscript image IMG which is used on frame F. */
11272 static void
11273 gs_clear_image (f, img)
11274 struct frame *f;
11275 struct image *img;
11277 /* IMG->data.ptr_val may contain a recorded colormap. */
11278 xfree (img->data.ptr_val);
11279 x_clear_image (f, img);
11283 /* Return non-zero if OBJECT is a valid Ghostscript image
11284 specification. */
11286 static int
11287 gs_image_p (object)
11288 Lisp_Object object;
11290 struct image_keyword fmt[GS_LAST];
11291 Lisp_Object tem;
11292 int i;
11294 bcopy (gs_format, fmt, sizeof fmt);
11296 if (!parse_image_spec (object, fmt, GS_LAST, Qpostscript)
11297 || (fmt[GS_ASCENT].count
11298 && XFASTINT (fmt[GS_ASCENT].value) > 100))
11299 return 0;
11301 /* Bounding box must be a list or vector containing 4 integers. */
11302 tem = fmt[GS_BOUNDING_BOX].value;
11303 if (CONSP (tem))
11305 for (i = 0; i < 4; ++i, tem = XCDR (tem))
11306 if (!CONSP (tem) || !INTEGERP (XCAR (tem)))
11307 return 0;
11308 if (!NILP (tem))
11309 return 0;
11311 else if (VECTORP (tem))
11313 if (XVECTOR (tem)->size != 4)
11314 return 0;
11315 for (i = 0; i < 4; ++i)
11316 if (!INTEGERP (XVECTOR (tem)->contents[i]))
11317 return 0;
11319 else
11320 return 0;
11322 return 1;
11326 /* Load Ghostscript image IMG for use on frame F. Value is non-zero
11327 if successful. */
11329 static int
11330 gs_load (f, img)
11331 struct frame *f;
11332 struct image *img;
11334 char buffer[100];
11335 Lisp_Object window_and_pixmap_id = Qnil, loader, pt_height, pt_width;
11336 struct gcpro gcpro1, gcpro2;
11337 Lisp_Object frame;
11338 double in_width, in_height;
11339 Lisp_Object pixel_colors = Qnil;
11341 /* Compute pixel size of pixmap needed from the given size in the
11342 image specification. Sizes in the specification are in pt. 1 pt
11343 = 1/72 in, xdpi and ydpi are stored in the frame's X display
11344 info. */
11345 pt_width = image_spec_value (img->spec, QCpt_width, NULL);
11346 in_width = XFASTINT (pt_width) / 72.0;
11347 img->width = in_width * FRAME_W32_DISPLAY_INFO (f)->resx;
11348 pt_height = image_spec_value (img->spec, QCpt_height, NULL);
11349 in_height = XFASTINT (pt_height) / 72.0;
11350 img->height = in_height * FRAME_W32_DISPLAY_INFO (f)->resy;
11352 /* Create the pixmap. */
11353 BLOCK_INPUT;
11354 xassert (img->pixmap == 0);
11355 img->pixmap = XCreatePixmap (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
11356 img->width, img->height,
11357 DefaultDepthOfScreen (FRAME_X_SCREEN (f)));
11358 UNBLOCK_INPUT;
11360 if (!img->pixmap)
11362 image_error ("Unable to create pixmap for `%s'", img->spec, Qnil);
11363 return 0;
11366 /* Call the loader to fill the pixmap. It returns a process object
11367 if successful. We do not record_unwind_protect here because
11368 other places in redisplay like calling window scroll functions
11369 don't either. Let the Lisp loader use `unwind-protect' instead. */
11370 GCPRO2 (window_and_pixmap_id, pixel_colors);
11372 sprintf (buffer, "%lu %lu",
11373 (unsigned long) FRAME_W32_WINDOW (f),
11374 (unsigned long) img->pixmap);
11375 window_and_pixmap_id = build_string (buffer);
11377 sprintf (buffer, "%lu %lu",
11378 FRAME_FOREGROUND_PIXEL (f),
11379 FRAME_BACKGROUND_PIXEL (f));
11380 pixel_colors = build_string (buffer);
11382 XSETFRAME (frame, f);
11383 loader = image_spec_value (img->spec, QCloader, NULL);
11384 if (NILP (loader))
11385 loader = intern ("gs-load-image");
11387 img->data.lisp_val = call6 (loader, frame, img->spec,
11388 make_number (img->width),
11389 make_number (img->height),
11390 window_and_pixmap_id,
11391 pixel_colors);
11392 UNGCPRO;
11393 return PROCESSP (img->data.lisp_val);
11397 /* Kill the Ghostscript process that was started to fill PIXMAP on
11398 frame F. Called from XTread_socket when receiving an event
11399 telling Emacs that Ghostscript has finished drawing. */
11401 void
11402 x_kill_gs_process (pixmap, f)
11403 Pixmap pixmap;
11404 struct frame *f;
11406 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
11407 int class, i;
11408 struct image *img;
11410 /* Find the image containing PIXMAP. */
11411 for (i = 0; i < c->used; ++i)
11412 if (c->images[i]->pixmap == pixmap)
11413 break;
11415 /* Kill the GS process. We should have found PIXMAP in the image
11416 cache and its image should contain a process object. */
11417 xassert (i < c->used);
11418 img = c->images[i];
11419 xassert (PROCESSP (img->data.lisp_val));
11420 Fkill_process (img->data.lisp_val, Qnil);
11421 img->data.lisp_val = Qnil;
11423 /* On displays with a mutable colormap, figure out the colors
11424 allocated for the image by looking at the pixels of an XImage for
11425 img->pixmap. */
11426 class = FRAME_W32_DISPLAY_INFO (f)->visual->class;
11427 if (class != StaticColor && class != StaticGray && class != TrueColor)
11429 XImage *ximg;
11431 BLOCK_INPUT;
11433 /* Try to get an XImage for img->pixmep. */
11434 ximg = XGetImage (FRAME_W32_DISPLAY (f), img->pixmap,
11435 0, 0, img->width, img->height, ~0, ZPixmap);
11436 if (ximg)
11438 int x, y;
11440 /* Initialize the color table. */
11441 init_color_table ();
11443 /* For each pixel of the image, look its color up in the
11444 color table. After having done so, the color table will
11445 contain an entry for each color used by the image. */
11446 for (y = 0; y < img->height; ++y)
11447 for (x = 0; x < img->width; ++x)
11449 unsigned long pixel = XGetPixel (ximg, x, y);
11450 lookup_pixel_color (f, pixel);
11453 /* Record colors in the image. Free color table and XImage. */
11454 img->colors = colors_in_color_table (&img->ncolors);
11455 free_color_table ();
11456 XDestroyImage (ximg);
11458 #if 0 /* This doesn't seem to be the case. If we free the colors
11459 here, we get a BadAccess later in x_clear_image when
11460 freeing the colors. */
11461 /* We have allocated colors once, but Ghostscript has also
11462 allocated colors on behalf of us. So, to get the
11463 reference counts right, free them once. */
11464 if (img->ncolors)
11466 Colormap cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
11467 XFreeColors (FRAME_W32_DISPLAY (f), cmap,
11468 img->colors, img->ncolors, 0);
11470 #endif
11472 else
11473 image_error ("Cannot get X image of `%s'; colors will not be freed",
11474 img->spec, Qnil);
11476 UNBLOCK_INPUT;
11480 #endif /* HAVE_GHOSTSCRIPT */
11483 /***********************************************************************
11484 Window properties
11485 ***********************************************************************/
11487 DEFUN ("x-change-window-property", Fx_change_window_property,
11488 Sx_change_window_property, 2, 3, 0,
11489 "Change window property PROP to VALUE on the X window of FRAME.\n\
11490 PROP and VALUE must be strings. FRAME nil or omitted means use the\n\
11491 selected frame. Value is VALUE.")
11492 (prop, value, frame)
11493 Lisp_Object frame, prop, value;
11495 #if 0 /* NTEMACS_TODO : port window properties to W32 */
11496 struct frame *f = check_x_frame (frame);
11497 Atom prop_atom;
11499 CHECK_STRING (prop, 1);
11500 CHECK_STRING (value, 2);
11502 BLOCK_INPUT;
11503 prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), XSTRING (prop)->data, False);
11504 XChangeProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
11505 prop_atom, XA_STRING, 8, PropModeReplace,
11506 XSTRING (value)->data, XSTRING (value)->size);
11508 /* Make sure the property is set when we return. */
11509 XFlush (FRAME_W32_DISPLAY (f));
11510 UNBLOCK_INPUT;
11512 #endif /* NTEMACS_TODO */
11514 return value;
11518 DEFUN ("x-delete-window-property", Fx_delete_window_property,
11519 Sx_delete_window_property, 1, 2, 0,
11520 "Remove window property PROP from X window of FRAME.\n\
11521 FRAME nil or omitted means use the selected frame. Value is PROP.")
11522 (prop, frame)
11523 Lisp_Object prop, frame;
11525 #if 0 /* NTEMACS_TODO : port window properties to W32 */
11527 struct frame *f = check_x_frame (frame);
11528 Atom prop_atom;
11530 CHECK_STRING (prop, 1);
11531 BLOCK_INPUT;
11532 prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), XSTRING (prop)->data, False);
11533 XDeleteProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), prop_atom);
11535 /* Make sure the property is removed when we return. */
11536 XFlush (FRAME_W32_DISPLAY (f));
11537 UNBLOCK_INPUT;
11538 #endif /* NTEMACS_TODO */
11540 return prop;
11544 DEFUN ("x-window-property", Fx_window_property, Sx_window_property,
11545 1, 2, 0,
11546 "Value is the value of window property PROP on FRAME.\n\
11547 If FRAME is nil or omitted, use the selected frame. Value is nil\n\
11548 if FRAME hasn't a property with name PROP or if PROP has no string\n\
11549 value.")
11550 (prop, frame)
11551 Lisp_Object prop, frame;
11553 #if 0 /* NTEMACS_TODO : port window properties to W32 */
11555 struct frame *f = check_x_frame (frame);
11556 Atom prop_atom;
11557 int rc;
11558 Lisp_Object prop_value = Qnil;
11559 char *tmp_data = NULL;
11560 Atom actual_type;
11561 int actual_format;
11562 unsigned long actual_size, bytes_remaining;
11564 CHECK_STRING (prop, 1);
11565 BLOCK_INPUT;
11566 prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), XSTRING (prop)->data, False);
11567 rc = XGetWindowProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
11568 prop_atom, 0, 0, False, XA_STRING,
11569 &actual_type, &actual_format, &actual_size,
11570 &bytes_remaining, (unsigned char **) &tmp_data);
11571 if (rc == Success)
11573 int size = bytes_remaining;
11575 XFree (tmp_data);
11576 tmp_data = NULL;
11578 rc = XGetWindowProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
11579 prop_atom, 0, bytes_remaining,
11580 False, XA_STRING,
11581 &actual_type, &actual_format,
11582 &actual_size, &bytes_remaining,
11583 (unsigned char **) &tmp_data);
11584 if (rc == Success)
11585 prop_value = make_string (tmp_data, size);
11587 XFree (tmp_data);
11590 UNBLOCK_INPUT;
11592 return prop_value;
11594 #endif /* NTEMACS_TODO */
11595 return Qnil;
11600 /***********************************************************************
11601 Busy cursor
11602 ***********************************************************************/
11604 /* If non-null, an asynchronous timer that, when it expires, displays
11605 a busy cursor on all frames. */
11607 static struct atimer *busy_cursor_atimer;
11609 /* Non-zero means a busy cursor is currently shown. */
11611 static int busy_cursor_shown_p;
11613 /* Number of seconds to wait before displaying a busy cursor. */
11615 static Lisp_Object Vbusy_cursor_delay;
11617 /* Default number of seconds to wait before displaying a busy
11618 cursor. */
11620 #define DEFAULT_BUSY_CURSOR_DELAY 1
11622 /* Function prototypes. */
11624 static void show_busy_cursor P_ ((struct atimer *));
11625 static void hide_busy_cursor P_ ((void));
11628 /* Cancel a currently active busy-cursor timer, and start a new one. */
11630 void
11631 start_busy_cursor ()
11633 #if 0 /* NTEMACS_TODO: cursor shape changes. */
11634 EMACS_TIME delay;
11635 int secs;
11637 cancel_busy_cursor ();
11639 if (INTEGERP (Vbusy_cursor_delay)
11640 && XINT (Vbusy_cursor_delay) > 0)
11641 secs = XFASTINT (Vbusy_cursor_delay);
11642 else
11643 secs = DEFAULT_BUSY_CURSOR_DELAY;
11645 EMACS_SET_SECS_USECS (delay, secs, 0);
11646 busy_cursor_atimer = start_atimer (ATIMER_RELATIVE, delay,
11647 show_busy_cursor, NULL);
11648 #endif
11652 /* Cancel the busy cursor timer if active, hide a busy cursor if
11653 shown. */
11655 void
11656 cancel_busy_cursor ()
11658 if (busy_cursor_atimer)
11659 cancel_atimer (busy_cursor_atimer);
11660 if (busy_cursor_shown_p)
11661 hide_busy_cursor ();
11665 /* Timer function of busy_cursor_atimer. TIMER is equal to
11666 busy_cursor_atimer.
11668 Display a busy cursor on all frames by mapping the frames'
11669 busy_window. Set the busy_p flag in the frames' output_data.x
11670 structure to indicate that a busy cursor is shown on the
11671 frames. */
11673 static void
11674 show_busy_cursor (timer)
11675 struct atimer *timer;
11677 #if 0 /* NTEMACS_TODO: cursor shape changes. */
11678 /* The timer implementation will cancel this timer automatically
11679 after this function has run. Set busy_cursor_atimer to null
11680 so that we know the timer doesn't have to be canceled. */
11681 busy_cursor_atimer = NULL;
11683 if (!busy_cursor_shown_p)
11685 Lisp_Object rest, frame;
11687 BLOCK_INPUT;
11689 FOR_EACH_FRAME (rest, frame)
11690 if (FRAME_X_P (XFRAME (frame)))
11692 struct frame *f = XFRAME (frame);
11694 f->output_data.w32->busy_p = 1;
11696 if (!f->output_data.w32->busy_window)
11698 unsigned long mask = CWCursor;
11699 XSetWindowAttributes attrs;
11701 attrs.cursor = f->output_data.w32->busy_cursor;
11703 f->output_data.w32->busy_window
11704 = XCreateWindow (FRAME_X_DISPLAY (f),
11705 FRAME_OUTER_WINDOW (f),
11706 0, 0, 32000, 32000, 0, 0,
11707 InputOnly,
11708 CopyFromParent,
11709 mask, &attrs);
11712 XMapRaised (FRAME_X_DISPLAY (f), f->output_data.w32->busy_window);
11713 XFlush (FRAME_X_DISPLAY (f));
11716 busy_cursor_shown_p = 1;
11717 UNBLOCK_INPUT;
11719 #endif
11723 /* Hide the busy cursor on all frames, if it is currently shown. */
11725 static void
11726 hide_busy_cursor ()
11728 #if 0 /* NTEMACS_TODO: cursor shape changes. */
11729 if (busy_cursor_shown_p)
11731 Lisp_Object rest, frame;
11733 BLOCK_INPUT;
11734 FOR_EACH_FRAME (rest, frame)
11736 struct frame *f = XFRAME (frame);
11738 if (FRAME_X_P (f)
11739 /* Watch out for newly created frames. */
11740 && f->output_data.x->busy_window)
11742 XUnmapWindow (FRAME_X_DISPLAY (f), f->output_data.x->busy_window);
11743 /* Sync here because XTread_socket looks at the busy_p flag
11744 that is reset to zero below. */
11745 XSync (FRAME_X_DISPLAY (f), False);
11746 f->output_data.x->busy_p = 0;
11750 busy_cursor_shown_p = 0;
11751 UNBLOCK_INPUT;
11753 #endif
11758 /***********************************************************************
11759 Tool tips
11760 ***********************************************************************/
11762 static Lisp_Object x_create_tip_frame P_ ((struct w32_display_info *,
11763 Lisp_Object));
11765 /* The frame of a currently visible tooltip, or null. */
11767 struct frame *tip_frame;
11769 /* If non-nil, a timer started that hides the last tooltip when it
11770 fires. */
11772 Lisp_Object tip_timer;
11773 Window tip_window;
11775 /* Create a frame for a tooltip on the display described by DPYINFO.
11776 PARMS is a list of frame parameters. Value is the frame. */
11778 static Lisp_Object
11779 x_create_tip_frame (dpyinfo, parms)
11780 struct w32_display_info *dpyinfo;
11781 Lisp_Object parms;
11783 #if 0 /* NTEMACS_TODO : w32 version */
11784 struct frame *f;
11785 Lisp_Object frame, tem;
11786 Lisp_Object name;
11787 long window_prompting = 0;
11788 int width, height;
11789 int count = specpdl_ptr - specpdl;
11790 struct gcpro gcpro1, gcpro2, gcpro3;
11791 struct kboard *kb;
11793 check_x ();
11795 /* Use this general default value to start with until we know if
11796 this frame has a specified name. */
11797 Vx_resource_name = Vinvocation_name;
11799 #ifdef MULTI_KBOARD
11800 kb = dpyinfo->kboard;
11801 #else
11802 kb = &the_only_kboard;
11803 #endif
11805 /* Get the name of the frame to use for resource lookup. */
11806 name = w32_get_arg (parms, Qname, "name", "Name", RES_TYPE_STRING);
11807 if (!STRINGP (name)
11808 && !EQ (name, Qunbound)
11809 && !NILP (name))
11810 error ("Invalid frame name--not a string or nil");
11811 Vx_resource_name = name;
11813 frame = Qnil;
11814 GCPRO3 (parms, name, frame);
11815 tip_frame = f = make_frame (1);
11816 XSETFRAME (frame, f);
11817 FRAME_CAN_HAVE_SCROLL_BARS (f) = 0;
11819 f->output_method = output_w32;
11820 f->output_data.w32 =
11821 (struct w32_output *) xmalloc (sizeof (struct w32_output));
11822 bzero (f->output_data.w32, sizeof (struct w32_output));
11823 #if 0
11824 f->output_data.w32->icon_bitmap = -1;
11825 #endif
11826 f->output_data.w32->fontset = -1;
11827 f->icon_name = Qnil;
11829 #ifdef MULTI_KBOARD
11830 FRAME_KBOARD (f) = kb;
11831 #endif
11832 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
11833 f->output_data.w32->explicit_parent = 0;
11835 /* Set the name; the functions to which we pass f expect the name to
11836 be set. */
11837 if (EQ (name, Qunbound) || NILP (name))
11839 f->name = build_string (dpyinfo->x_id_name);
11840 f->explicit_name = 0;
11842 else
11844 f->name = name;
11845 f->explicit_name = 1;
11846 /* use the frame's title when getting resources for this frame. */
11847 specbind (Qx_resource_name, name);
11850 /* Create fontsets from `global_fontset_alist' before handling fonts. */
11851 for (tem = Vglobal_fontset_alist; CONSP (tem); tem = XCDR (tem))
11852 fs_register_fontset (f, XCAR (tem));
11854 /* Extract the window parameters from the supplied values
11855 that are needed to determine window geometry. */
11857 Lisp_Object font;
11859 font = w32_get_arg (parms, Qfont, "font", "Font", RES_TYPE_STRING);
11861 BLOCK_INPUT;
11862 /* First, try whatever font the caller has specified. */
11863 if (STRINGP (font))
11865 tem = Fquery_fontset (font, Qnil);
11866 if (STRINGP (tem))
11867 font = x_new_fontset (f, XSTRING (tem)->data);
11868 else
11869 font = x_new_font (f, XSTRING (font)->data);
11872 /* Try out a font which we hope has bold and italic variations. */
11873 if (!STRINGP (font))
11874 font = x_new_font (f, "-adobe-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-1");
11875 if (!STRINGP (font))
11876 font = x_new_font (f, "-misc-fixed-medium-r-normal-*-*-140-*-*-c-*-iso8859-1");
11877 if (! STRINGP (font))
11878 font = x_new_font (f, "-*-*-medium-r-normal-*-*-140-*-*-c-*-iso8859-1");
11879 if (! STRINGP (font))
11880 /* This was formerly the first thing tried, but it finds too many fonts
11881 and takes too long. */
11882 font = x_new_font (f, "-*-*-medium-r-*-*-*-*-*-*-c-*-iso8859-1");
11883 /* If those didn't work, look for something which will at least work. */
11884 if (! STRINGP (font))
11885 font = x_new_font (f, "-*-fixed-*-*-*-*-*-140-*-*-c-*-iso8859-1");
11886 UNBLOCK_INPUT;
11887 if (! STRINGP (font))
11888 font = build_string ("fixed");
11890 x_default_parameter (f, parms, Qfont, font,
11891 "font", "Font", RES_TYPE_STRING);
11894 x_default_parameter (f, parms, Qborder_width, make_number (2),
11895 "borderWidth", "BorderWidth", RES_TYPE_NUMBER);
11897 /* This defaults to 2 in order to match xterm. We recognize either
11898 internalBorderWidth or internalBorder (which is what xterm calls
11899 it). */
11900 if (NILP (Fassq (Qinternal_border_width, parms)))
11902 Lisp_Object value;
11904 value = w32_get_arg (parms, Qinternal_border_width,
11905 "internalBorder", "internalBorder", RES_TYPE_NUMBER);
11906 if (! EQ (value, Qunbound))
11907 parms = Fcons (Fcons (Qinternal_border_width, value),
11908 parms);
11911 x_default_parameter (f, parms, Qinternal_border_width, make_number (1),
11912 "internalBorderWidth", "internalBorderWidth",
11913 RES_TYPE_NUMBER);
11915 /* Also do the stuff which must be set before the window exists. */
11916 x_default_parameter (f, parms, Qforeground_color, build_string ("black"),
11917 "foreground", "Foreground", RES_TYPE_STRING);
11918 x_default_parameter (f, parms, Qbackground_color, build_string ("white"),
11919 "background", "Background", RES_TYPE_STRING);
11920 x_default_parameter (f, parms, Qmouse_color, build_string ("black"),
11921 "pointerColor", "Foreground", RES_TYPE_STRING);
11922 x_default_parameter (f, parms, Qcursor_color, build_string ("black"),
11923 "cursorColor", "Foreground", RES_TYPE_STRING);
11924 x_default_parameter (f, parms, Qborder_color, build_string ("black"),
11925 "borderColor", "BorderColor", RES_TYPE_STRING);
11927 /* Init faces before x_default_parameter is called for scroll-bar
11928 parameters because that function calls x_set_scroll_bar_width,
11929 which calls change_frame_size, which calls Fset_window_buffer,
11930 which runs hooks, which call Fvertical_motion. At the end, we
11931 end up in init_iterator with a null face cache, which should not
11932 happen. */
11933 init_frame_faces (f);
11935 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
11936 window_prompting = x_figure_window_size (f, parms);
11938 if (window_prompting & XNegative)
11940 if (window_prompting & YNegative)
11941 f->output_data.w32->win_gravity = SouthEastGravity;
11942 else
11943 f->output_data.w32->win_gravity = NorthEastGravity;
11945 else
11947 if (window_prompting & YNegative)
11948 f->output_data.w32->win_gravity = SouthWestGravity;
11949 else
11950 f->output_data.w32->win_gravity = NorthWestGravity;
11953 f->output_data.w32->size_hint_flags = window_prompting;
11955 XSetWindowAttributes attrs;
11956 unsigned long mask;
11958 BLOCK_INPUT;
11959 mask = CWBackPixel | CWOverrideRedirect | CWSaveUnder | CWEventMask;
11960 /* Window managers looks at the override-redirect flag to
11961 determine whether or net to give windows a decoration (Xlib
11962 3.2.8). */
11963 attrs.override_redirect = True;
11964 attrs.save_under = True;
11965 attrs.background_pixel = FRAME_BACKGROUND_PIXEL (f);
11966 /* Arrange for getting MapNotify and UnmapNotify events. */
11967 attrs.event_mask = StructureNotifyMask;
11968 tip_window
11969 = FRAME_W32_WINDOW (f)
11970 = XCreateWindow (FRAME_W32_DISPLAY (f),
11971 FRAME_W32_DISPLAY_INFO (f)->root_window,
11972 /* x, y, width, height */
11973 0, 0, 1, 1,
11974 /* Border. */
11976 CopyFromParent, InputOutput, CopyFromParent,
11977 mask, &attrs);
11978 UNBLOCK_INPUT;
11981 x_make_gc (f);
11983 x_default_parameter (f, parms, Qauto_raise, Qnil,
11984 "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN);
11985 x_default_parameter (f, parms, Qauto_lower, Qnil,
11986 "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN);
11987 x_default_parameter (f, parms, Qcursor_type, Qbox,
11988 "cursorType", "CursorType", RES_TYPE_SYMBOL);
11990 /* Dimensions, especially f->height, must be done via change_frame_size.
11991 Change will not be effected unless different from the current
11992 f->height. */
11993 width = f->width;
11994 height = f->height;
11995 f->height = 0;
11996 SET_FRAME_WIDTH (f, 0);
11997 change_frame_size (f, height, width, 1, 0, 0);
11999 f->no_split = 1;
12001 UNGCPRO;
12003 /* It is now ok to make the frame official even if we get an error
12004 below. And the frame needs to be on Vframe_list or making it
12005 visible won't work. */
12006 Vframe_list = Fcons (frame, Vframe_list);
12008 /* Now that the frame is official, it counts as a reference to
12009 its display. */
12010 FRAME_W32_DISPLAY_INFO (f)->reference_count++;
12012 return unbind_to (count, frame);
12013 #endif /* NTEMACS_TODO */
12014 return Qnil;
12018 DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 4, 0,
12019 "Show STRING in a \"tooltip\" window on frame FRAME.\n\
12020 A tooltip window is a small X window displaying STRING at\n\
12021 the current mouse position.\n\
12022 FRAME nil or omitted means use the selected frame.\n\
12023 PARMS is an optional list of frame parameters which can be\n\
12024 used to change the tooltip's appearance.\n\
12025 Automatically hide the tooltip after TIMEOUT seconds.\n\
12026 TIMEOUT nil means use the default timeout of 5 seconds.")
12027 (string, frame, parms, timeout)
12028 Lisp_Object string, frame, parms, timeout;
12030 struct frame *f;
12031 struct window *w;
12032 Window root, child;
12033 Lisp_Object buffer;
12034 struct buffer *old_buffer;
12035 struct text_pos pos;
12036 int i, width, height;
12037 int root_x, root_y, win_x, win_y;
12038 unsigned pmask;
12039 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
12040 int old_windows_or_buffers_changed = windows_or_buffers_changed;
12041 int count = specpdl_ptr - specpdl;
12043 specbind (Qinhibit_redisplay, Qt);
12045 GCPRO3 (string, parms, frame, timeout);
12047 CHECK_STRING (string, 0);
12048 f = check_x_frame (frame);
12049 if (NILP (timeout))
12050 timeout = make_number (5);
12051 else
12052 CHECK_NATNUM (timeout, 2);
12054 /* Hide a previous tip, if any. */
12055 Fx_hide_tip ();
12057 /* Add default values to frame parameters. */
12058 if (NILP (Fassq (Qname, parms)))
12059 parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms);
12060 if (NILP (Fassq (Qinternal_border_width, parms)))
12061 parms = Fcons (Fcons (Qinternal_border_width, make_number (3)), parms);
12062 if (NILP (Fassq (Qborder_width, parms)))
12063 parms = Fcons (Fcons (Qborder_width, make_number (1)), parms);
12064 if (NILP (Fassq (Qborder_color, parms)))
12065 parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms);
12066 if (NILP (Fassq (Qbackground_color, parms)))
12067 parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")),
12068 parms);
12070 /* Create a frame for the tooltip, and record it in the global
12071 variable tip_frame. */
12072 frame = x_create_tip_frame (FRAME_W32_DISPLAY_INFO (f), parms);
12073 tip_frame = f = XFRAME (frame);
12075 /* Set up the frame's root window. Currently we use a size of 80
12076 columns x 40 lines. If someone wants to show a larger tip, he
12077 will loose. I don't think this is a realistic case. */
12078 w = XWINDOW (FRAME_ROOT_WINDOW (f));
12079 w->left = w->top = make_number (0);
12080 w->width = 80;
12081 w->height = 40;
12082 adjust_glyphs (f);
12083 w->pseudo_window_p = 1;
12085 /* Display the tooltip text in a temporary buffer. */
12086 buffer = Fget_buffer_create (build_string (" *tip*"));
12087 Fset_window_buffer (FRAME_ROOT_WINDOW (f), buffer);
12088 old_buffer = current_buffer;
12089 set_buffer_internal_1 (XBUFFER (buffer));
12090 Ferase_buffer ();
12091 Finsert (make_number (1), &string);
12092 clear_glyph_matrix (w->desired_matrix);
12093 clear_glyph_matrix (w->current_matrix);
12094 SET_TEXT_POS (pos, BEGV, BEGV_BYTE);
12095 try_window (FRAME_ROOT_WINDOW (f), pos);
12097 /* Compute width and height of the tooltip. */
12098 width = height = 0;
12099 for (i = 0; i < w->desired_matrix->nrows; ++i)
12101 struct glyph_row *row = &w->desired_matrix->rows[i];
12102 struct glyph *last;
12103 int row_width;
12105 /* Stop at the first empty row at the end. */
12106 if (!row->enabled_p || !row->displays_text_p)
12107 break;
12109 /* Let the row go over the full width of the frame. */
12110 row->full_width_p = 1;
12112 /* There's a glyph at the end of rows that is use to place
12113 the cursor there. Don't include the width of this glyph. */
12114 if (row->used[TEXT_AREA])
12116 last = &row->glyphs[TEXT_AREA][row->used[TEXT_AREA] - 1];
12117 row_width = row->pixel_width - last->pixel_width;
12119 else
12120 row_width = row->pixel_width;
12122 height += row->height;
12123 width = max (width, row_width);
12126 /* Add the frame's internal border to the width and height the X
12127 window should have. */
12128 height += 2 * FRAME_INTERNAL_BORDER_WIDTH (f);
12129 width += 2 * FRAME_INTERNAL_BORDER_WIDTH (f);
12131 /* Move the tooltip window where the mouse pointer is. Resize and
12132 show it. */
12133 #if 0 /* NTEMACS_TODO : W32 specifics */
12134 BLOCK_INPUT;
12135 XQueryPointer (FRAME_W32_DISPLAY (f), FRAME_W32_DISPLAY_INFO (f)->root_window,
12136 &root, &child, &root_x, &root_y, &win_x, &win_y, &pmask);
12137 XMoveResizeWindow (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
12138 root_x + 5, root_y - height - 5, width, height);
12139 XMapRaised (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f));
12140 UNBLOCK_INPUT;
12141 #endif /* NTEMACS_TODO */
12143 /* Draw into the window. */
12144 w->must_be_updated_p = 1;
12145 update_single_window (w, 1);
12147 /* Restore original current buffer. */
12148 set_buffer_internal_1 (old_buffer);
12149 windows_or_buffers_changed = old_windows_or_buffers_changed;
12151 /* Let the tip disappear after timeout seconds. */
12152 tip_timer = call3 (intern ("run-at-time"), timeout, Qnil,
12153 intern ("x-hide-tip"));
12154 UNGCPRO;
12156 return unbind_to (count, Qnil);
12160 DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0,
12161 "Hide the current tooltip window, if there is any.\n\
12162 Value is t is tooltip was open, nil otherwise.")
12165 int count = specpdl_ptr - specpdl;
12166 int deleted_p = 0;
12168 specbind (Qinhibit_redisplay, Qt);
12170 if (!NILP (tip_timer))
12172 call1 (intern ("cancel-timer"), tip_timer);
12173 tip_timer = Qnil;
12176 if (tip_frame)
12178 Lisp_Object frame;
12180 XSETFRAME (frame, tip_frame);
12181 Fdelete_frame (frame, Qt);
12182 tip_frame = NULL;
12183 deleted_p = 1;
12186 return unbind_to (count, deleted_p ? Qt : Qnil);
12191 /***********************************************************************
12192 File selection dialog
12193 ***********************************************************************/
12195 extern Lisp_Object Qfile_name_history;
12197 DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 4, 0,
12198 "Read file name, prompting with PROMPT in directory DIR.\n\
12199 Use a file selection dialog.\n\
12200 Select DEFAULT-FILENAME in the dialog's file selection box, if\n\
12201 specified. Don't let the user enter a file name in the file\n\
12202 selection dialog's entry field, if MUSTMATCH is non-nil.")
12203 (prompt, dir, default_filename, mustmatch)
12204 Lisp_Object prompt, dir, default_filename, mustmatch;
12206 struct frame *f = SELECTED_FRAME ();
12207 Lisp_Object file = Qnil;
12208 int count = specpdl_ptr - specpdl;
12209 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
12210 char filename[MAX_PATH + 1];
12211 char init_dir[MAX_PATH + 1];
12212 int use_dialog_p = 1;
12214 GCPRO5 (prompt, dir, default_filename, mustmatch, file);
12215 CHECK_STRING (prompt, 0);
12216 CHECK_STRING (dir, 1);
12218 /* Create the dialog with PROMPT as title, using DIR as initial
12219 directory and using "*" as pattern. */
12220 dir = Fexpand_file_name (dir, Qnil);
12221 strncpy (init_dir, XSTRING (dir)->data, MAX_PATH);
12222 init_dir[MAX_PATH] = '\0';
12223 unixtodos_filename (init_dir);
12225 if (STRINGP (default_filename))
12227 char *file_name_only;
12228 char *full_path_name = XSTRING (default_filename)->data;
12230 unixtodos_filename (full_path_name);
12232 file_name_only = strrchr (full_path_name, '\\');
12233 if (!file_name_only)
12234 file_name_only = full_path_name;
12235 else
12237 file_name_only++;
12239 /* If default_file_name is a directory, don't use the open
12240 file dialog, as it does not support selecting
12241 directories. */
12242 if (!(*file_name_only))
12243 use_dialog_p = 0;
12246 strncpy (filename, file_name_only, MAX_PATH);
12247 filename[MAX_PATH] = '\0';
12249 else
12250 filename[0] = '\0';
12252 if (use_dialog_p)
12254 OPENFILENAME file_details;
12255 char *filename_file;
12257 /* Prevent redisplay. */
12258 specbind (Qinhibit_redisplay, Qt);
12259 BLOCK_INPUT;
12261 bzero (&file_details, sizeof (file_details));
12262 file_details.lStructSize = sizeof (file_details);
12263 file_details.hwndOwner = FRAME_W32_WINDOW (f);
12264 file_details.lpstrFile = filename;
12265 file_details.nMaxFile = sizeof (filename);
12266 file_details.lpstrInitialDir = init_dir;
12267 file_details.lpstrTitle = XSTRING (prompt)->data;
12268 file_details.Flags = OFN_HIDEREADONLY | OFN_NOCHANGEDIR;
12270 if (!NILP (mustmatch))
12271 file_details.Flags |= OFN_FILEMUSTEXIST | OFN_PATHMUSTEXIST;
12273 if (GetOpenFileName (&file_details))
12275 dostounix_filename (filename);
12276 file = build_string (filename);
12278 else
12279 file = Qnil;
12281 UNBLOCK_INPUT;
12282 file = unbind_to (count, file);
12284 /* Open File dialog will not allow folders to be selected, so resort
12285 to minibuffer completing reads for directories. */
12286 else
12287 file = Fcompleting_read (prompt, intern ("read-file-name-internal"),
12288 dir, mustmatch, dir, Qfile_name_history,
12289 default_filename, Qnil);
12291 UNGCPRO;
12293 /* Make "Cancel" equivalent to C-g. */
12294 if (NILP (file))
12295 Fsignal (Qquit, Qnil);
12297 return file;
12302 /***********************************************************************
12303 Tests
12304 ***********************************************************************/
12306 #if GLYPH_DEBUG
12308 DEFUN ("imagep", Fimagep, Simagep, 1, 1, 0,
12309 "Value is non-nil if SPEC is a valid image specification.")
12310 (spec)
12311 Lisp_Object spec;
12313 return valid_image_p (spec) ? Qt : Qnil;
12317 DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0, "")
12318 (spec)
12319 Lisp_Object spec;
12321 int id = -1;
12323 if (valid_image_p (spec))
12324 id = lookup_image (SELECTED_FRAME (), spec);
12326 debug_print (spec);
12327 return make_number (id);
12330 #endif /* GLYPH_DEBUG != 0 */
12334 /***********************************************************************
12335 w32 specialized functions
12336 ***********************************************************************/
12338 DEFUN ("w32-select-font", Fw32_select_font, Sw32_select_font, 0, 1, 0,
12339 "This will display the W32 font dialog and return an X font string corresponding to the selection.")
12340 (frame)
12341 Lisp_Object frame;
12343 FRAME_PTR f = check_x_frame (frame);
12344 CHOOSEFONT cf;
12345 LOGFONT lf;
12346 TEXTMETRIC tm;
12347 HDC hdc;
12348 HANDLE oldobj;
12349 char buf[100];
12351 bzero (&cf, sizeof (cf));
12352 bzero (&lf, sizeof (lf));
12354 cf.lStructSize = sizeof (cf);
12355 cf.hwndOwner = FRAME_W32_WINDOW (f);
12356 cf.Flags = CF_FORCEFONTEXIST | CF_SCREENFONTS;
12357 cf.lpLogFont = &lf;
12359 /* Initialize as much of the font details as we can from the current
12360 default font. */
12361 hdc = GetDC (FRAME_W32_WINDOW (f));
12362 oldobj = SelectObject (hdc, FRAME_FONT (f)->hfont);
12363 GetTextFace (hdc, LF_FACESIZE, lf.lfFaceName);
12364 if (GetTextMetrics (hdc, &tm))
12366 lf.lfHeight = tm.tmInternalLeading - tm.tmHeight;
12367 lf.lfWeight = tm.tmWeight;
12368 lf.lfItalic = tm.tmItalic;
12369 lf.lfUnderline = tm.tmUnderlined;
12370 lf.lfStrikeOut = tm.tmStruckOut;
12371 lf.lfCharSet = tm.tmCharSet;
12372 cf.Flags |= CF_INITTOLOGFONTSTRUCT;
12374 SelectObject (hdc, oldobj);
12375 ReleaseDC (FRAME_W32_WINDOW (f), hdc);
12377 if (!ChooseFont (&cf) || !w32_to_x_font (&lf, buf, 100))
12378 return Qnil;
12380 return build_string (buf);
12383 DEFUN ("w32-send-sys-command", Fw32_send_sys_command, Sw32_send_sys_command, 1, 2, 0,
12384 "Send frame a Windows WM_SYSCOMMAND message of type COMMAND.\n\
12385 Some useful values for command are 0xf030 to maximise frame (0xf020\n\
12386 to minimize), 0xf120 to restore frame to original size, and 0xf100\n\
12387 to activate the menubar for keyboard access. 0xf140 activates the\n\
12388 screen saver if defined.\n\
12390 If optional parameter FRAME is not specified, use selected frame.")
12391 (command, frame)
12392 Lisp_Object command, frame;
12394 WPARAM code;
12395 FRAME_PTR f = check_x_frame (frame);
12397 CHECK_NUMBER (command, 0);
12399 PostMessage (FRAME_W32_WINDOW (f), WM_SYSCOMMAND, XINT (command), 0);
12401 return Qnil;
12404 DEFUN ("w32-shell-execute", Fw32_shell_execute, Sw32_shell_execute, 2, 4, 0,
12405 "Get Windows to perform OPERATION on DOCUMENT.\n\
12406 This is a wrapper around the ShellExecute system function, which\n\
12407 invokes the application registered to handle OPERATION for DOCUMENT.\n\
12408 OPERATION is typically \"open\", \"print\" or \"explore\" (but can be\n\
12409 nil for the default action), and DOCUMENT is typically the name of a\n\
12410 document file or URL, but can also be a program executable to run or\n\
12411 a directory to open in the Windows Explorer.\n\
12413 If DOCUMENT is a program executable, PARAMETERS can be a string\n\
12414 containing command line parameters, but otherwise should be nil.\n\
12416 SHOW-FLAG can be used to control whether the invoked application is hidden\n\
12417 or minimized. If SHOW-FLAG is nil, the application is displayed normally,\n\
12418 otherwise it is an integer representing a ShowWindow flag:\n\
12420 0 - start hidden\n\
12421 1 - start normally\n\
12422 3 - start maximized\n\
12423 6 - start minimized")
12424 (operation, document, parameters, show_flag)
12425 Lisp_Object operation, document, parameters, show_flag;
12427 Lisp_Object current_dir;
12429 CHECK_STRING (document, 0);
12431 /* Encode filename and current directory. */
12432 current_dir = ENCODE_FILE (current_buffer->directory);
12433 document = ENCODE_FILE (document);
12434 if ((int) ShellExecute (NULL,
12435 (STRINGP (operation) ?
12436 XSTRING (operation)->data : NULL),
12437 XSTRING (document)->data,
12438 (STRINGP (parameters) ?
12439 XSTRING (parameters)->data : NULL),
12440 XSTRING (current_dir)->data,
12441 (INTEGERP (show_flag) ?
12442 XINT (show_flag) : SW_SHOWDEFAULT))
12443 > 32)
12444 return Qt;
12445 error ("ShellExecute failed");
12448 /* Lookup virtual keycode from string representing the name of a
12449 non-ascii keystroke into the corresponding virtual key, using
12450 lispy_function_keys. */
12451 static int
12452 lookup_vk_code (char *key)
12454 int i;
12456 for (i = 0; i < 256; i++)
12457 if (lispy_function_keys[i] != 0
12458 && strcmp (lispy_function_keys[i], key) == 0)
12459 return i;
12461 return -1;
12464 /* Convert a one-element vector style key sequence to a hot key
12465 definition. */
12466 static int
12467 w32_parse_hot_key (key)
12468 Lisp_Object key;
12470 /* Copied from Fdefine_key and store_in_keymap. */
12471 register Lisp_Object c;
12472 int vk_code;
12473 int lisp_modifiers;
12474 int w32_modifiers;
12475 struct gcpro gcpro1;
12477 CHECK_VECTOR (key, 0);
12479 if (XFASTINT (Flength (key)) != 1)
12480 return Qnil;
12482 GCPRO1 (key);
12484 c = Faref (key, make_number (0));
12486 if (CONSP (c) && lucid_event_type_list_p (c))
12487 c = Fevent_convert_list (c);
12489 UNGCPRO;
12491 if (! INTEGERP (c) && ! SYMBOLP (c))
12492 error ("Key definition is invalid");
12494 /* Work out the base key and the modifiers. */
12495 if (SYMBOLP (c))
12497 c = parse_modifiers (c);
12498 lisp_modifiers = Fcar (Fcdr (c));
12499 c = Fcar (c);
12500 if (!SYMBOLP (c))
12501 abort ();
12502 vk_code = lookup_vk_code (XSYMBOL (c)->name->data);
12504 else if (INTEGERP (c))
12506 lisp_modifiers = XINT (c) & ~CHARACTERBITS;
12507 /* Many ascii characters are their own virtual key code. */
12508 vk_code = XINT (c) & CHARACTERBITS;
12511 if (vk_code < 0 || vk_code > 255)
12512 return Qnil;
12514 if ((lisp_modifiers & meta_modifier) != 0
12515 && !NILP (Vw32_alt_is_meta))
12516 lisp_modifiers |= alt_modifier;
12518 /* Convert lisp modifiers to Windows hot-key form. */
12519 w32_modifiers = (lisp_modifiers & hyper_modifier) ? MOD_WIN : 0;
12520 w32_modifiers |= (lisp_modifiers & alt_modifier) ? MOD_ALT : 0;
12521 w32_modifiers |= (lisp_modifiers & ctrl_modifier) ? MOD_CONTROL : 0;
12522 w32_modifiers |= (lisp_modifiers & shift_modifier) ? MOD_SHIFT : 0;
12524 return HOTKEY (vk_code, w32_modifiers);
12527 DEFUN ("w32-register-hot-key", Fw32_register_hot_key, Sw32_register_hot_key, 1, 1, 0,
12528 "Register KEY as a hot-key combination.\n\
12529 Certain key combinations like Alt-Tab are reserved for system use on\n\
12530 Windows, and therefore are normally intercepted by the system. However,\n\
12531 most of these key combinations can be received by registering them as\n\
12532 hot-keys, overriding their special meaning.\n\
12534 KEY must be a one element key definition in vector form that would be\n\
12535 acceptable to `define-key' (e.g. [A-tab] for Alt-Tab). The meta\n\
12536 modifier is interpreted as Alt if `w32-alt-is-meta' is t, and hyper\n\
12537 is always interpreted as the Windows modifier keys.\n\
12539 The return value is the hotkey-id if registered, otherwise nil.")
12540 (key)
12541 Lisp_Object key;
12543 key = w32_parse_hot_key (key);
12545 if (NILP (Fmemq (key, w32_grabbed_keys)))
12547 /* Reuse an empty slot if possible. */
12548 Lisp_Object item = Fmemq (Qnil, w32_grabbed_keys);
12550 /* Safe to add new key to list, even if we have focus. */
12551 if (NILP (item))
12552 w32_grabbed_keys = Fcons (key, w32_grabbed_keys);
12553 else
12554 XCAR (item) = key;
12556 /* Notify input thread about new hot-key definition, so that it
12557 takes effect without needing to switch focus. */
12558 PostThreadMessage (dwWindowsThreadId, WM_EMACS_REGISTER_HOT_KEY,
12559 (WPARAM) key, 0);
12562 return key;
12565 DEFUN ("w32-unregister-hot-key", Fw32_unregister_hot_key, Sw32_unregister_hot_key, 1, 1, 0,
12566 "Unregister HOTKEY as a hot-key combination.")
12567 (key)
12568 Lisp_Object key;
12570 Lisp_Object item;
12572 if (!INTEGERP (key))
12573 key = w32_parse_hot_key (key);
12575 item = Fmemq (key, w32_grabbed_keys);
12577 if (!NILP (item))
12579 /* Notify input thread about hot-key definition being removed, so
12580 that it takes effect without needing focus switch. */
12581 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_UNREGISTER_HOT_KEY,
12582 (WPARAM) XINT (XCAR (item)), (LPARAM) item))
12584 MSG msg;
12585 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
12587 return Qt;
12589 return Qnil;
12592 DEFUN ("w32-registered-hot-keys", Fw32_registered_hot_keys, Sw32_registered_hot_keys, 0, 0, 0,
12593 "Return list of registered hot-key IDs.")
12596 return Fcopy_sequence (w32_grabbed_keys);
12599 DEFUN ("w32-reconstruct-hot-key", Fw32_reconstruct_hot_key, Sw32_reconstruct_hot_key, 1, 1, 0,
12600 "Convert hot-key ID to a lisp key combination.")
12601 (hotkeyid)
12602 Lisp_Object hotkeyid;
12604 int vk_code, w32_modifiers;
12605 Lisp_Object key;
12607 CHECK_NUMBER (hotkeyid, 0);
12609 vk_code = HOTKEY_VK_CODE (hotkeyid);
12610 w32_modifiers = HOTKEY_MODIFIERS (hotkeyid);
12612 if (lispy_function_keys[vk_code])
12613 key = intern (lispy_function_keys[vk_code]);
12614 else
12615 key = make_number (vk_code);
12617 key = Fcons (key, Qnil);
12618 if (w32_modifiers & MOD_SHIFT)
12619 key = Fcons (Qshift, key);
12620 if (w32_modifiers & MOD_CONTROL)
12621 key = Fcons (Qctrl, key);
12622 if (w32_modifiers & MOD_ALT)
12623 key = Fcons (NILP (Vw32_alt_is_meta) ? Qalt : Qmeta, key);
12624 if (w32_modifiers & MOD_WIN)
12625 key = Fcons (Qhyper, key);
12627 return key;
12630 DEFUN ("w32-toggle-lock-key", Fw32_toggle_lock_key, Sw32_toggle_lock_key, 1, 2, 0,
12631 "Toggle the state of the lock key KEY.\n\
12632 KEY can be `capslock', `kp-numlock', or `scroll'.\n\
12633 If the optional parameter NEW-STATE is a number, then the state of KEY\n\
12634 is set to off if the low bit of NEW-STATE is zero, otherwise on.")
12635 (key, new_state)
12636 Lisp_Object key, new_state;
12638 int vk_code;
12639 int cur_state;
12641 if (EQ (key, intern ("capslock")))
12642 vk_code = VK_CAPITAL;
12643 else if (EQ (key, intern ("kp-numlock")))
12644 vk_code = VK_NUMLOCK;
12645 else if (EQ (key, intern ("scroll")))
12646 vk_code = VK_SCROLL;
12647 else
12648 return Qnil;
12650 if (!dwWindowsThreadId)
12651 return make_number (w32_console_toggle_lock_key (vk_code, new_state));
12653 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_TOGGLE_LOCK_KEY,
12654 (WPARAM) vk_code, (LPARAM) new_state))
12656 MSG msg;
12657 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
12658 return make_number (msg.wParam);
12660 return Qnil;
12663 syms_of_w32fns ()
12665 /* This is zero if not using MS-Windows. */
12666 w32_in_use = 0;
12668 /* The section below is built by the lisp expression at the top of the file,
12669 just above where these variables are declared. */
12670 /*&&& init symbols here &&&*/
12671 Qauto_raise = intern ("auto-raise");
12672 staticpro (&Qauto_raise);
12673 Qauto_lower = intern ("auto-lower");
12674 staticpro (&Qauto_lower);
12675 Qbar = intern ("bar");
12676 staticpro (&Qbar);
12677 Qborder_color = intern ("border-color");
12678 staticpro (&Qborder_color);
12679 Qborder_width = intern ("border-width");
12680 staticpro (&Qborder_width);
12681 Qbox = intern ("box");
12682 staticpro (&Qbox);
12683 Qcursor_color = intern ("cursor-color");
12684 staticpro (&Qcursor_color);
12685 Qcursor_type = intern ("cursor-type");
12686 staticpro (&Qcursor_type);
12687 Qgeometry = intern ("geometry");
12688 staticpro (&Qgeometry);
12689 Qicon_left = intern ("icon-left");
12690 staticpro (&Qicon_left);
12691 Qicon_top = intern ("icon-top");
12692 staticpro (&Qicon_top);
12693 Qicon_type = intern ("icon-type");
12694 staticpro (&Qicon_type);
12695 Qicon_name = intern ("icon-name");
12696 staticpro (&Qicon_name);
12697 Qinternal_border_width = intern ("internal-border-width");
12698 staticpro (&Qinternal_border_width);
12699 Qleft = intern ("left");
12700 staticpro (&Qleft);
12701 Qright = intern ("right");
12702 staticpro (&Qright);
12703 Qmouse_color = intern ("mouse-color");
12704 staticpro (&Qmouse_color);
12705 Qnone = intern ("none");
12706 staticpro (&Qnone);
12707 Qparent_id = intern ("parent-id");
12708 staticpro (&Qparent_id);
12709 Qscroll_bar_width = intern ("scroll-bar-width");
12710 staticpro (&Qscroll_bar_width);
12711 Qsuppress_icon = intern ("suppress-icon");
12712 staticpro (&Qsuppress_icon);
12713 Qundefined_color = intern ("undefined-color");
12714 staticpro (&Qundefined_color);
12715 Qvertical_scroll_bars = intern ("vertical-scroll-bars");
12716 staticpro (&Qvertical_scroll_bars);
12717 Qvisibility = intern ("visibility");
12718 staticpro (&Qvisibility);
12719 Qwindow_id = intern ("window-id");
12720 staticpro (&Qwindow_id);
12721 Qx_frame_parameter = intern ("x-frame-parameter");
12722 staticpro (&Qx_frame_parameter);
12723 Qx_resource_name = intern ("x-resource-name");
12724 staticpro (&Qx_resource_name);
12725 Quser_position = intern ("user-position");
12726 staticpro (&Quser_position);
12727 Quser_size = intern ("user-size");
12728 staticpro (&Quser_size);
12729 #if 0 /* Duplicate initialization in xdisp.c */
12730 Qdisplay = intern ("display");
12731 staticpro (&Qdisplay);
12732 #endif
12733 Qscreen_gamma = intern ("screen-gamma");
12734 staticpro (&Qscreen_gamma);
12735 /* This is the end of symbol initialization. */
12737 Qhyper = intern ("hyper");
12738 staticpro (&Qhyper);
12739 Qsuper = intern ("super");
12740 staticpro (&Qsuper);
12741 Qmeta = intern ("meta");
12742 staticpro (&Qmeta);
12743 Qalt = intern ("alt");
12744 staticpro (&Qalt);
12745 Qctrl = intern ("ctrl");
12746 staticpro (&Qctrl);
12747 Qcontrol = intern ("control");
12748 staticpro (&Qcontrol);
12749 Qshift = intern ("shift");
12750 staticpro (&Qshift);
12752 /* Text property `display' should be nonsticky by default. */
12753 Vtext_property_default_nonsticky
12754 = Fcons (Fcons (Qdisplay, Qt), Vtext_property_default_nonsticky);
12757 Qlaplace = intern ("laplace");
12758 staticpro (&Qlaplace);
12760 Qface_set_after_frame_default = intern ("face-set-after-frame-default");
12761 staticpro (&Qface_set_after_frame_default);
12763 Fput (Qundefined_color, Qerror_conditions,
12764 Fcons (Qundefined_color, Fcons (Qerror, Qnil)));
12765 Fput (Qundefined_color, Qerror_message,
12766 build_string ("Undefined color"));
12768 staticpro (&w32_grabbed_keys);
12769 w32_grabbed_keys = Qnil;
12771 DEFVAR_LISP ("w32-color-map", &Vw32_color_map,
12772 "An array of color name mappings for windows.");
12773 Vw32_color_map = Qnil;
12775 DEFVAR_LISP ("w32-pass-alt-to-system", &Vw32_pass_alt_to_system,
12776 "Non-nil if alt key presses are passed on to Windows.\n\
12777 When non-nil, for example, alt pressed and released and then space will\n\
12778 open the System menu. When nil, Emacs silently swallows alt key events.");
12779 Vw32_pass_alt_to_system = Qnil;
12781 DEFVAR_LISP ("w32-alt-is-meta", &Vw32_alt_is_meta,
12782 "Non-nil if the alt key is to be considered the same as the meta key.\n\
12783 When nil, Emacs will translate the alt key to the Alt modifier, and not Meta.");
12784 Vw32_alt_is_meta = Qt;
12786 DEFVAR_INT ("w32-quit-key", &Vw32_quit_key,
12787 "If non-zero, the virtual key code for an alternative quit key.");
12788 XSETINT (Vw32_quit_key, 0);
12790 DEFVAR_LISP ("w32-pass-lwindow-to-system",
12791 &Vw32_pass_lwindow_to_system,
12792 "Non-nil if the left \"Windows\" key is passed on to Windows.\n\
12793 When non-nil, the Start menu is opened by tapping the key.");
12794 Vw32_pass_lwindow_to_system = Qt;
12796 DEFVAR_LISP ("w32-pass-rwindow-to-system",
12797 &Vw32_pass_rwindow_to_system,
12798 "Non-nil if the right \"Windows\" key is passed on to Windows.\n\
12799 When non-nil, the Start menu is opened by tapping the key.");
12800 Vw32_pass_rwindow_to_system = Qt;
12802 DEFVAR_INT ("w32-phantom-key-code",
12803 &Vw32_phantom_key_code,
12804 "Virtual key code used to generate \"phantom\" key presses.\n\
12805 Value is a number between 0 and 255.\n\
12807 Phantom key presses are generated in order to stop the system from\n\
12808 acting on \"Windows\" key events when `w32-pass-lwindow-to-system' or\n\
12809 `w32-pass-rwindow-to-system' is nil.");
12810 /* Although 255 is technically not a valid key code, it works and
12811 means that this hack won't interfere with any real key code. */
12812 Vw32_phantom_key_code = 255;
12814 DEFVAR_LISP ("w32-enable-num-lock",
12815 &Vw32_enable_num_lock,
12816 "Non-nil if Num Lock should act normally.\n\
12817 Set to nil to see Num Lock as the key `kp-numlock'.");
12818 Vw32_enable_num_lock = Qt;
12820 DEFVAR_LISP ("w32-enable-caps-lock",
12821 &Vw32_enable_caps_lock,
12822 "Non-nil if Caps Lock should act normally.\n\
12823 Set to nil to see Caps Lock as the key `capslock'.");
12824 Vw32_enable_caps_lock = Qt;
12826 DEFVAR_LISP ("w32-scroll-lock-modifier",
12827 &Vw32_scroll_lock_modifier,
12828 "Modifier to use for the Scroll Lock on state.\n\
12829 The value can be hyper, super, meta, alt, control or shift for the\n\
12830 respective modifier, or nil to see Scroll Lock as the key `scroll'.\n\
12831 Any other value will cause the key to be ignored.");
12832 Vw32_scroll_lock_modifier = Qt;
12834 DEFVAR_LISP ("w32-lwindow-modifier",
12835 &Vw32_lwindow_modifier,
12836 "Modifier to use for the left \"Windows\" key.\n\
12837 The value can be hyper, super, meta, alt, control or shift for the\n\
12838 respective modifier, or nil to appear as the key `lwindow'.\n\
12839 Any other value will cause the key to be ignored.");
12840 Vw32_lwindow_modifier = Qnil;
12842 DEFVAR_LISP ("w32-rwindow-modifier",
12843 &Vw32_rwindow_modifier,
12844 "Modifier to use for the right \"Windows\" key.\n\
12845 The value can be hyper, super, meta, alt, control or shift for the\n\
12846 respective modifier, or nil to appear as the key `rwindow'.\n\
12847 Any other value will cause the key to be ignored.");
12848 Vw32_rwindow_modifier = Qnil;
12850 DEFVAR_LISP ("w32-apps-modifier",
12851 &Vw32_apps_modifier,
12852 "Modifier to use for the \"Apps\" key.\n\
12853 The value can be hyper, super, meta, alt, control or shift for the\n\
12854 respective modifier, or nil to appear as the key `apps'.\n\
12855 Any other value will cause the key to be ignored.");
12856 Vw32_apps_modifier = Qnil;
12858 DEFVAR_LISP ("w32-enable-synthesized_fonts", &Vw32_enable_synthesized_fonts,
12859 "Non-nil enables selection of artificially italicized and bold fonts.");
12860 Vw32_enable_synthesized_fonts = Qnil;
12862 DEFVAR_LISP ("w32-enable-palette", &Vw32_enable_palette,
12863 "Non-nil enables Windows palette management to map colors exactly.");
12864 Vw32_enable_palette = Qt;
12866 DEFVAR_INT ("w32-mouse-button-tolerance",
12867 &Vw32_mouse_button_tolerance,
12868 "Analogue of double click interval for faking middle mouse events.\n\
12869 The value is the minimum time in milliseconds that must elapse between\n\
12870 left/right button down events before they are considered distinct events.\n\
12871 If both mouse buttons are depressed within this interval, a middle mouse\n\
12872 button down event is generated instead.");
12873 XSETINT (Vw32_mouse_button_tolerance, GetDoubleClickTime () / 2);
12875 DEFVAR_INT ("w32-mouse-move-interval",
12876 &Vw32_mouse_move_interval,
12877 "Minimum interval between mouse move events.\n\
12878 The value is the minimum time in milliseconds that must elapse between\n\
12879 successive mouse move (or scroll bar drag) events before they are\n\
12880 reported as lisp events.");
12881 XSETINT (Vw32_mouse_move_interval, 0);
12883 init_x_parm_symbols ();
12885 DEFVAR_LISP ("x-bitmap-file-path", &Vx_bitmap_file_path,
12886 "List of directories to search for bitmap files for w32.");
12887 Vx_bitmap_file_path = decode_env_path ((char *) 0, "PATH");
12889 DEFVAR_LISP ("x-pointer-shape", &Vx_pointer_shape,
12890 "The shape of the pointer when over text.\n\
12891 Changing the value does not affect existing frames\n\
12892 unless you set the mouse color.");
12893 Vx_pointer_shape = Qnil;
12895 DEFVAR_LISP ("x-resource-name", &Vx_resource_name,
12896 "The name Emacs uses to look up resources; for internal use only.\n\
12897 `x-get-resource' uses this as the first component of the instance name\n\
12898 when requesting resource values.\n\
12899 Emacs initially sets `x-resource-name' to the name under which Emacs\n\
12900 was invoked, or to the value specified with the `-name' or `-rn'\n\
12901 switches, if present.");
12902 Vx_resource_name = Qnil;
12904 Vx_nontext_pointer_shape = Qnil;
12906 Vx_mode_pointer_shape = Qnil;
12908 DEFVAR_LISP ("x-busy-pointer-shape", &Vx_busy_pointer_shape,
12909 "The shape of the pointer when Emacs is busy.\n\
12910 This variable takes effect when you create a new frame\n\
12911 or when you set the mouse color.");
12912 Vx_busy_pointer_shape = Qnil;
12914 DEFVAR_BOOL ("display-busy-cursor", &display_busy_cursor_p,
12915 "Non-zero means Emacs displays a busy cursor on window systems.");
12916 display_busy_cursor_p = 1;
12918 DEFVAR_LISP ("busy-cursor-delay", &Vbusy_cursor_delay,
12919 "*Seconds to wait before displaying a busy-cursor.\n\
12920 Value must be an integer.");
12921 Vbusy_cursor_delay = make_number (DEFAULT_BUSY_CURSOR_DELAY);
12923 DEFVAR_LISP ("x-sensitive-text-pointer-shape",
12924 &Vx_sensitive_text_pointer_shape,
12925 "The shape of the pointer when over mouse-sensitive text.\n\
12926 This variable takes effect when you create a new frame\n\
12927 or when you set the mouse color.");
12928 Vx_sensitive_text_pointer_shape = Qnil;
12930 DEFVAR_LISP ("x-cursor-fore-pixel", &Vx_cursor_fore_pixel,
12931 "A string indicating the foreground color of the cursor box.");
12932 Vx_cursor_fore_pixel = Qnil;
12934 DEFVAR_LISP ("x-no-window-manager", &Vx_no_window_manager,
12935 "Non-nil if no window manager is in use.\n\
12936 Emacs doesn't try to figure this out; this is always nil\n\
12937 unless you set it to something else.");
12938 /* We don't have any way to find this out, so set it to nil
12939 and maybe the user would like to set it to t. */
12940 Vx_no_window_manager = Qnil;
12942 DEFVAR_LISP ("x-pixel-size-width-font-regexp",
12943 &Vx_pixel_size_width_font_regexp,
12944 "Regexp matching a font name whose width is the same as `PIXEL_SIZE'.\n\
12946 Since Emacs gets width of a font matching with this regexp from\n\
12947 PIXEL_SIZE field of the name, font finding mechanism gets faster for\n\
12948 such a font. This is especially effective for such large fonts as\n\
12949 Chinese, Japanese, and Korean.");
12950 Vx_pixel_size_width_font_regexp = Qnil;
12952 DEFVAR_LISP ("image-cache-eviction-delay", &Vimage_cache_eviction_delay,
12953 "Time after which cached images are removed from the cache.\n\
12954 When an image has not been displayed this many seconds, remove it\n\
12955 from the image cache. Value must be an integer or nil with nil\n\
12956 meaning don't clear the cache.");
12957 Vimage_cache_eviction_delay = make_number (30 * 60);
12959 DEFVAR_LISP ("image-types", &Vimage_types,
12960 "List of supported image types.\n\
12961 Each element of the list is a symbol for a supported image type.");
12962 Vimage_types = Qnil;
12964 DEFVAR_LISP ("w32-bdf-filename-alist",
12965 &Vw32_bdf_filename_alist,
12966 "List of bdf fonts and their corresponding filenames.");
12967 Vw32_bdf_filename_alist = Qnil;
12969 DEFVAR_BOOL ("w32-strict-fontnames",
12970 &w32_strict_fontnames,
12971 "Non-nil means only use fonts that are exact matches for those requested.\n\
12972 Default is nil, which allows old fontnames that are not XLFD compliant,\n\
12973 and allows third-party CJK display to work by specifying false charset\n\
12974 fields to trick Emacs into translating to Big5, SJIS etc.\n\
12975 Setting this to t will prevent wrong fonts being selected when\n\
12976 fontsets are automatically created.");
12977 w32_strict_fontnames = 0;
12979 DEFVAR_BOOL ("w32-strict-painting",
12980 &w32_strict_painting,
12981 "Non-nil means use strict rules for repainting frames.\n\
12982 Set this to nil to get the old behaviour for repainting; this should\n\
12983 only be necessary if the default setting causes problems.");
12984 w32_strict_painting = 1;
12986 DEFVAR_LISP ("w32-system-coding-system",
12987 &Vw32_system_coding_system,
12988 "Coding system used by Windows system functions, such as for font names.");
12989 Vw32_system_coding_system = Qnil;
12991 defsubr (&Sx_get_resource);
12992 #if 0 /* NTEMACS_TODO: Port to W32 */
12993 defsubr (&Sx_change_window_property);
12994 defsubr (&Sx_delete_window_property);
12995 defsubr (&Sx_window_property);
12996 #endif
12997 defsubr (&Sxw_display_color_p);
12998 defsubr (&Sx_display_grayscale_p);
12999 defsubr (&Sxw_color_defined_p);
13000 defsubr (&Sxw_color_values);
13001 defsubr (&Sx_server_max_request_size);
13002 defsubr (&Sx_server_vendor);
13003 defsubr (&Sx_server_version);
13004 defsubr (&Sx_display_pixel_width);
13005 defsubr (&Sx_display_pixel_height);
13006 defsubr (&Sx_display_mm_width);
13007 defsubr (&Sx_display_mm_height);
13008 defsubr (&Sx_display_screens);
13009 defsubr (&Sx_display_planes);
13010 defsubr (&Sx_display_color_cells);
13011 defsubr (&Sx_display_visual_class);
13012 defsubr (&Sx_display_backing_store);
13013 defsubr (&Sx_display_save_under);
13014 defsubr (&Sx_parse_geometry);
13015 defsubr (&Sx_create_frame);
13016 defsubr (&Sx_open_connection);
13017 defsubr (&Sx_close_connection);
13018 defsubr (&Sx_display_list);
13019 defsubr (&Sx_synchronize);
13021 /* W32 specific functions */
13023 defsubr (&Sw32_focus_frame);
13024 defsubr (&Sw32_select_font);
13025 defsubr (&Sw32_define_rgb_color);
13026 defsubr (&Sw32_default_color_map);
13027 defsubr (&Sw32_load_color_file);
13028 defsubr (&Sw32_send_sys_command);
13029 defsubr (&Sw32_shell_execute);
13030 defsubr (&Sw32_register_hot_key);
13031 defsubr (&Sw32_unregister_hot_key);
13032 defsubr (&Sw32_registered_hot_keys);
13033 defsubr (&Sw32_reconstruct_hot_key);
13034 defsubr (&Sw32_toggle_lock_key);
13035 defsubr (&Sw32_find_bdf_fonts);
13037 /* Setting callback functions for fontset handler. */
13038 get_font_info_func = w32_get_font_info;
13040 #if 0 /* This function pointer doesn't seem to be used anywhere.
13041 And the pointer assigned has the wrong type, anyway. */
13042 list_fonts_func = w32_list_fonts;
13043 #endif
13045 load_font_func = w32_load_font;
13046 find_ccl_program_func = w32_find_ccl_program;
13047 query_font_func = w32_query_font;
13048 set_frame_fontset_func = x_set_font;
13049 check_window_system_func = check_w32;
13051 #if 0 /* NTEMACS_TODO Image support for W32 */
13052 /* Images. */
13053 Qxbm = intern ("xbm");
13054 staticpro (&Qxbm);
13055 QCtype = intern (":type");
13056 staticpro (&QCtype);
13057 QCalgorithm = intern (":algorithm");
13058 staticpro (&QCalgorithm);
13059 QCheuristic_mask = intern (":heuristic-mask");
13060 staticpro (&QCheuristic_mask);
13061 QCcolor_symbols = intern (":color-symbols");
13062 staticpro (&QCcolor_symbols);
13063 QCdata = intern (":data");
13064 staticpro (&QCdata);
13065 QCascent = intern (":ascent");
13066 staticpro (&QCascent);
13067 QCmargin = intern (":margin");
13068 staticpro (&QCmargin);
13069 QCrelief = intern (":relief");
13070 staticpro (&QCrelief);
13071 Qpostscript = intern ("postscript");
13072 staticpro (&Qpostscript);
13073 QCloader = intern (":loader");
13074 staticpro (&QCloader);
13075 QCbounding_box = intern (":bounding-box");
13076 staticpro (&QCbounding_box);
13077 QCpt_width = intern (":pt-width");
13078 staticpro (&QCpt_width);
13079 QCpt_height = intern (":pt-height");
13080 staticpro (&QCpt_height);
13081 QCindex = intern (":index");
13082 staticpro (&QCindex);
13083 Qpbm = intern ("pbm");
13084 staticpro (&Qpbm);
13086 #if HAVE_XPM
13087 Qxpm = intern ("xpm");
13088 staticpro (&Qxpm);
13089 #endif
13091 #if HAVE_JPEG
13092 Qjpeg = intern ("jpeg");
13093 staticpro (&Qjpeg);
13094 #endif
13096 #if HAVE_TIFF
13097 Qtiff = intern ("tiff");
13098 staticpro (&Qtiff);
13099 #endif
13101 #if HAVE_GIF
13102 Qgif = intern ("gif");
13103 staticpro (&Qgif);
13104 #endif
13106 #if HAVE_PNG
13107 Qpng = intern ("png");
13108 staticpro (&Qpng);
13109 #endif
13111 defsubr (&Sclear_image_cache);
13113 #if GLYPH_DEBUG
13114 defsubr (&Simagep);
13115 defsubr (&Slookup_image);
13116 #endif
13117 #endif /* NTEMACS_TODO */
13119 defsubr (&Sx_show_tip);
13120 defsubr (&Sx_hide_tip);
13121 staticpro (&tip_timer);
13122 tip_timer = Qnil;
13124 defsubr (&Sx_file_dialog);
13128 void
13129 init_xfns ()
13131 image_types = NULL;
13132 Vimage_types = Qnil;
13134 #if 0 /* NTEMACS_TODO : Image support for W32 */
13135 define_image_type (&xbm_type);
13136 define_image_type (&gs_type);
13137 define_image_type (&pbm_type);
13139 #if HAVE_XPM
13140 define_image_type (&xpm_type);
13141 #endif
13143 #if HAVE_JPEG
13144 define_image_type (&jpeg_type);
13145 #endif
13147 #if HAVE_TIFF
13148 define_image_type (&tiff_type);
13149 #endif
13151 #if HAVE_GIF
13152 define_image_type (&gif_type);
13153 #endif
13155 #if HAVE_PNG
13156 define_image_type (&png_type);
13157 #endif
13158 #endif /* NTEMACS_TODO */
13161 #undef abort
13163 void
13164 w32_abort()
13166 int button;
13167 button = MessageBox (NULL,
13168 "A fatal error has occurred!\n\n"
13169 "Select Abort to exit, Retry to debug, Ignore to continue",
13170 "Emacs Abort Dialog",
13171 MB_ICONEXCLAMATION | MB_TASKMODAL
13172 | MB_SETFOREGROUND | MB_ABORTRETRYIGNORE);
13173 switch (button)
13175 case IDRETRY:
13176 DebugBreak ();
13177 break;
13178 case IDIGNORE:
13179 break;
13180 case IDABORT:
13181 default:
13182 abort ();
13183 break;
13187 /* For convenience when debugging. */
13189 w32_last_error()
13191 return GetLastError ();