(struct skp): New struct, to pass args through map_keymap.
[emacs.git] / src / w32fns.c
blobdeff9d85d8653c6c9dcfe68f2070d60516e1de91
1 /* Graphical user interface functions for the Microsoft W32 API.
2 Copyright (C) 1989, 92, 93, 94, 95, 1996, 1997, 1998, 1999, 2000, 2001
3 Free Software Foundation, Inc.
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 "dispextern.h"
34 #include "w32term.h"
35 #include "keyboard.h"
36 #include "frame.h"
37 #include "window.h"
38 #include "buffer.h"
39 #include "fontset.h"
40 #include "intervals.h"
41 #include "blockinput.h"
42 #include "epaths.h"
43 #include "w32heap.h"
44 #include "termhooks.h"
45 #include "coding.h"
46 #include "ccl.h"
47 #include "systime.h"
49 #include "bitmaps/gray.xbm"
51 #include <commdlg.h>
52 #include <shellapi.h>
53 #include <ctype.h>
55 #include <dlgs.h>
56 #define FILE_NAME_TEXT_FIELD edt1
58 void syms_of_w32fns ();
59 void globals_of_w32fns ();
60 static void init_external_image_libraries ();
62 extern void free_frame_menubar ();
63 extern double atof ();
64 extern int w32_console_toggle_lock_key P_ ((int, Lisp_Object));
65 extern void w32_menu_display_help P_ ((HWND, HMENU, UINT, UINT));
66 extern void w32_free_menu_strings P_ ((HWND));
68 extern int quit_char;
70 extern char *lispy_function_keys[];
72 /* The gray bitmap `bitmaps/gray'. This is done because w32term.c uses
73 it, and including `bitmaps/gray' more than once is a problem when
74 config.h defines `static' as an empty replacement string. */
76 int gray_bitmap_width = gray_width;
77 int gray_bitmap_height = gray_height;
78 unsigned char *gray_bitmap_bits = gray_bits;
80 /* The colormap for converting color names to RGB values */
81 Lisp_Object Vw32_color_map;
83 /* Non nil if alt key presses are passed on to Windows. */
84 Lisp_Object Vw32_pass_alt_to_system;
86 /* Non nil if alt key is translated to meta_modifier, nil if it is translated
87 to alt_modifier. */
88 Lisp_Object Vw32_alt_is_meta;
90 /* If non-zero, the windows virtual key code for an alternative quit key. */
91 Lisp_Object Vw32_quit_key;
93 /* Non nil if left window key events are passed on to Windows (this only
94 affects whether "tapping" the key opens the Start menu). */
95 Lisp_Object Vw32_pass_lwindow_to_system;
97 /* Non nil if right window key events are passed on to Windows (this
98 only affects whether "tapping" the key opens the Start menu). */
99 Lisp_Object Vw32_pass_rwindow_to_system;
101 /* Virtual key code used to generate "phantom" key presses in order
102 to stop system from acting on Windows key events. */
103 Lisp_Object Vw32_phantom_key_code;
105 /* Modifier associated with the left "Windows" key, or nil to act as a
106 normal key. */
107 Lisp_Object Vw32_lwindow_modifier;
109 /* Modifier associated with the right "Windows" key, or nil to act as a
110 normal key. */
111 Lisp_Object Vw32_rwindow_modifier;
113 /* Modifier associated with the "Apps" key, or nil to act as a normal
114 key. */
115 Lisp_Object Vw32_apps_modifier;
117 /* Value is nil if Num Lock acts as a function key. */
118 Lisp_Object Vw32_enable_num_lock;
120 /* Value is nil if Caps Lock acts as a function key. */
121 Lisp_Object Vw32_enable_caps_lock;
123 /* Modifier associated with Scroll Lock, or nil to act as a normal key. */
124 Lisp_Object Vw32_scroll_lock_modifier;
126 /* Switch to control whether we inhibit requests for synthesized bold
127 and italic versions of fonts. */
128 int w32_enable_synthesized_fonts;
130 /* Enable palette management. */
131 Lisp_Object Vw32_enable_palette;
133 /* Control how close left/right button down events must be to
134 be converted to a middle button down event. */
135 Lisp_Object Vw32_mouse_button_tolerance;
137 /* Minimum interval between mouse movement (and scroll bar drag)
138 events that are passed on to the event loop. */
139 Lisp_Object Vw32_mouse_move_interval;
141 /* Flag to indicate if XBUTTON events should be passed on to Windows. */
142 int w32_pass_extra_mouse_buttons_to_system;
144 /* Non nil if no window manager is in use. */
145 Lisp_Object Vx_no_window_manager;
147 /* Non-zero means we're allowed to display a hourglass pointer. */
149 int display_hourglass_p;
151 /* The background and shape of the mouse pointer, and shape when not
152 over text or in the modeline. */
154 Lisp_Object Vx_pointer_shape, Vx_nontext_pointer_shape, Vx_mode_pointer_shape;
155 Lisp_Object Vx_hourglass_pointer_shape, Vx_window_horizontal_drag_shape, Vx_hand_shape;
157 /* The shape when over mouse-sensitive text. */
159 Lisp_Object Vx_sensitive_text_pointer_shape;
161 #ifndef IDC_HAND
162 #define IDC_HAND MAKEINTRESOURCE(32649)
163 #endif
165 /* Color of chars displayed in cursor box. */
167 Lisp_Object Vx_cursor_fore_pixel;
169 /* Nonzero if using Windows. */
171 static int w32_in_use;
173 /* Search path for bitmap files. */
175 Lisp_Object Vx_bitmap_file_path;
177 /* Regexp matching a font name whose width is the same as `PIXEL_SIZE'. */
179 Lisp_Object Vx_pixel_size_width_font_regexp;
181 /* Alist of bdf fonts and the files that define them. */
182 Lisp_Object Vw32_bdf_filename_alist;
184 /* A flag to control whether fonts are matched strictly or not. */
185 int w32_strict_fontnames;
187 /* A flag to control whether we should only repaint if GetUpdateRect
188 indicates there is an update region. */
189 int w32_strict_painting;
191 /* Associative list linking character set strings to Windows codepages. */
192 Lisp_Object Vw32_charset_info_alist;
194 /* VIETNAMESE_CHARSET is not defined in some versions of MSVC. */
195 #ifndef VIETNAMESE_CHARSET
196 #define VIETNAMESE_CHARSET 163
197 #endif
199 Lisp_Object Qnone;
200 Lisp_Object Qsuppress_icon;
201 Lisp_Object Qundefined_color;
202 Lisp_Object Qcenter;
203 Lisp_Object Qcancel_timer;
204 Lisp_Object Qhyper;
205 Lisp_Object Qsuper;
206 Lisp_Object Qmeta;
207 Lisp_Object Qalt;
208 Lisp_Object Qctrl;
209 Lisp_Object Qcontrol;
210 Lisp_Object Qshift;
212 Lisp_Object Qw32_charset_ansi;
213 Lisp_Object Qw32_charset_default;
214 Lisp_Object Qw32_charset_symbol;
215 Lisp_Object Qw32_charset_shiftjis;
216 Lisp_Object Qw32_charset_hangeul;
217 Lisp_Object Qw32_charset_gb2312;
218 Lisp_Object Qw32_charset_chinesebig5;
219 Lisp_Object Qw32_charset_oem;
221 #ifndef JOHAB_CHARSET
222 #define JOHAB_CHARSET 130
223 #endif
224 #ifdef JOHAB_CHARSET
225 Lisp_Object Qw32_charset_easteurope;
226 Lisp_Object Qw32_charset_turkish;
227 Lisp_Object Qw32_charset_baltic;
228 Lisp_Object Qw32_charset_russian;
229 Lisp_Object Qw32_charset_arabic;
230 Lisp_Object Qw32_charset_greek;
231 Lisp_Object Qw32_charset_hebrew;
232 Lisp_Object Qw32_charset_vietnamese;
233 Lisp_Object Qw32_charset_thai;
234 Lisp_Object Qw32_charset_johab;
235 Lisp_Object Qw32_charset_mac;
236 #endif
238 #ifdef UNICODE_CHARSET
239 Lisp_Object Qw32_charset_unicode;
240 #endif
242 /* State variables for emulating a three button mouse. */
243 #define LMOUSE 1
244 #define MMOUSE 2
245 #define RMOUSE 4
247 static int button_state = 0;
248 static W32Msg saved_mouse_button_msg;
249 static unsigned mouse_button_timer = 0; /* non-zero when timer is active */
250 static W32Msg saved_mouse_move_msg;
251 static unsigned mouse_move_timer = 0;
253 /* Window that is tracking the mouse. */
254 static HWND track_mouse_window;
256 typedef BOOL (WINAPI * TrackMouseEvent_Proc) (
257 IN OUT LPTRACKMOUSEEVENT lpEventTrack
260 TrackMouseEvent_Proc track_mouse_event_fn=NULL;
262 /* W95 mousewheel handler */
263 unsigned int msh_mousewheel = 0;
265 /* Timers */
266 #define MOUSE_BUTTON_ID 1
267 #define MOUSE_MOVE_ID 2
268 #define MENU_FREE_ID 3
269 /* The delay (milliseconds) before a menu is freed after WM_EXITMENULOOP
270 is received. */
271 #define MENU_FREE_DELAY 1000
272 static unsigned menu_free_timer = 0;
274 /* The below are defined in frame.c. */
276 extern Lisp_Object Vwindow_system_version;
278 #ifdef GLYPH_DEBUG
279 int image_cache_refcount, dpyinfo_refcount;
280 #endif
283 /* From w32term.c. */
284 extern Lisp_Object Vw32_num_mouse_buttons;
285 extern Lisp_Object Vw32_recognize_altgr;
287 extern HWND w32_system_caret_hwnd;
289 extern int w32_system_caret_height;
290 extern int w32_system_caret_x;
291 extern int w32_system_caret_y;
292 extern int w32_use_visible_system_caret;
294 static HWND w32_visible_system_caret_hwnd;
297 /* Error if we are not connected to MS-Windows. */
298 void
299 check_w32 ()
301 if (! w32_in_use)
302 error ("MS-Windows not in use or not initialized");
305 /* Nonzero if we can use mouse menus.
306 You should not call this unless HAVE_MENUS is defined. */
309 have_menus_p ()
311 return w32_in_use;
314 /* Extract a frame as a FRAME_PTR, defaulting to the selected frame
315 and checking validity for W32. */
317 FRAME_PTR
318 check_x_frame (frame)
319 Lisp_Object frame;
321 FRAME_PTR f;
323 if (NILP (frame))
324 frame = selected_frame;
325 CHECK_LIVE_FRAME (frame);
326 f = XFRAME (frame);
327 if (! FRAME_W32_P (f))
328 error ("non-w32 frame used");
329 return f;
332 /* Let the user specify a display with a frame.
333 nil stands for the selected frame--or, if that is not a w32 frame,
334 the first display on the list. */
336 struct w32_display_info *
337 check_x_display_info (frame)
338 Lisp_Object frame;
340 if (NILP (frame))
342 struct frame *sf = XFRAME (selected_frame);
344 if (FRAME_W32_P (sf) && FRAME_LIVE_P (sf))
345 return FRAME_W32_DISPLAY_INFO (sf);
346 else
347 return &one_w32_display_info;
349 else if (STRINGP (frame))
350 return x_display_info_for_name (frame);
351 else
353 FRAME_PTR f;
355 CHECK_LIVE_FRAME (frame);
356 f = XFRAME (frame);
357 if (! FRAME_W32_P (f))
358 error ("non-w32 frame used");
359 return FRAME_W32_DISPLAY_INFO (f);
363 /* Return the Emacs frame-object corresponding to an w32 window.
364 It could be the frame's main window or an icon window. */
366 /* This function can be called during GC, so use GC_xxx type test macros. */
368 struct frame *
369 x_window_to_frame (dpyinfo, wdesc)
370 struct w32_display_info *dpyinfo;
371 HWND wdesc;
373 Lisp_Object tail, frame;
374 struct frame *f;
376 for (tail = Vframe_list; GC_CONSP (tail); tail = XCDR (tail))
378 frame = XCAR (tail);
379 if (!GC_FRAMEP (frame))
380 continue;
381 f = XFRAME (frame);
382 if (!FRAME_W32_P (f) || FRAME_W32_DISPLAY_INFO (f) != dpyinfo)
383 continue;
384 if (f->output_data.w32->hourglass_window == wdesc)
385 return f;
387 if (FRAME_W32_WINDOW (f) == wdesc)
388 return f;
390 return 0;
395 /* Code to deal with bitmaps. Bitmaps are referenced by their bitmap
396 id, which is just an int that this section returns. Bitmaps are
397 reference counted so they can be shared among frames.
399 Bitmap indices are guaranteed to be > 0, so a negative number can
400 be used to indicate no bitmap.
402 If you use x_create_bitmap_from_data, then you must keep track of
403 the bitmaps yourself. That is, creating a bitmap from the same
404 data more than once will not be caught. */
407 /* Functions to access the contents of a bitmap, given an id. */
410 x_bitmap_height (f, id)
411 FRAME_PTR f;
412 int id;
414 return FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].height;
418 x_bitmap_width (f, id)
419 FRAME_PTR f;
420 int id;
422 return FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].width;
426 x_bitmap_pixmap (f, id)
427 FRAME_PTR f;
428 int id;
430 return (int) FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].pixmap;
434 /* Allocate a new bitmap record. Returns index of new record. */
436 static int
437 x_allocate_bitmap_record (f)
438 FRAME_PTR f;
440 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
441 int i;
443 if (dpyinfo->bitmaps == NULL)
445 dpyinfo->bitmaps_size = 10;
446 dpyinfo->bitmaps
447 = (struct w32_bitmap_record *) xmalloc (dpyinfo->bitmaps_size * sizeof (struct w32_bitmap_record));
448 dpyinfo->bitmaps_last = 1;
449 return 1;
452 if (dpyinfo->bitmaps_last < dpyinfo->bitmaps_size)
453 return ++dpyinfo->bitmaps_last;
455 for (i = 0; i < dpyinfo->bitmaps_size; ++i)
456 if (dpyinfo->bitmaps[i].refcount == 0)
457 return i + 1;
459 dpyinfo->bitmaps_size *= 2;
460 dpyinfo->bitmaps
461 = (struct w32_bitmap_record *) xrealloc (dpyinfo->bitmaps,
462 dpyinfo->bitmaps_size * sizeof (struct w32_bitmap_record));
463 return ++dpyinfo->bitmaps_last;
466 /* Add one reference to the reference count of the bitmap with id ID. */
468 void
469 x_reference_bitmap (f, id)
470 FRAME_PTR f;
471 int id;
473 ++FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].refcount;
476 /* Create a bitmap for frame F from a HEIGHT x WIDTH array of bits at BITS. */
479 x_create_bitmap_from_data (f, bits, width, height)
480 struct frame *f;
481 char *bits;
482 unsigned int width, height;
484 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
485 Pixmap bitmap;
486 int id;
488 bitmap = CreateBitmap (width, height,
489 FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_planes,
490 FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_cbits,
491 bits);
493 if (! bitmap)
494 return -1;
496 id = x_allocate_bitmap_record (f);
497 dpyinfo->bitmaps[id - 1].pixmap = bitmap;
498 dpyinfo->bitmaps[id - 1].file = NULL;
499 dpyinfo->bitmaps[id - 1].hinst = NULL;
500 dpyinfo->bitmaps[id - 1].refcount = 1;
501 dpyinfo->bitmaps[id - 1].depth = 1;
502 dpyinfo->bitmaps[id - 1].height = height;
503 dpyinfo->bitmaps[id - 1].width = width;
505 return id;
508 /* Create bitmap from file FILE for frame F. */
511 x_create_bitmap_from_file (f, file)
512 struct frame *f;
513 Lisp_Object file;
515 return -1;
516 #if 0 /* TODO : bitmap support */
517 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
518 unsigned int width, height;
519 HBITMAP bitmap;
520 int xhot, yhot, result, id;
521 Lisp_Object found;
522 int fd;
523 char *filename;
524 HINSTANCE hinst;
526 /* Look for an existing bitmap with the same name. */
527 for (id = 0; id < dpyinfo->bitmaps_last; ++id)
529 if (dpyinfo->bitmaps[id].refcount
530 && dpyinfo->bitmaps[id].file
531 && !strcmp (dpyinfo->bitmaps[id].file, (char *) SDATA (file)))
533 ++dpyinfo->bitmaps[id].refcount;
534 return id + 1;
538 /* Search bitmap-file-path for the file, if appropriate. */
539 fd = openp (Vx_bitmap_file_path, file, Qnil, &found, Qnil);
540 if (fd < 0)
541 return -1;
542 emacs_close (fd);
544 filename = (char *) SDATA (found);
546 hinst = LoadLibraryEx (filename, NULL, LOAD_LIBRARY_AS_DATAFILE);
548 if (hinst == NULL)
549 return -1;
552 result = XReadBitmapFile (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
553 filename, &width, &height, &bitmap, &xhot, &yhot);
554 if (result != BitmapSuccess)
555 return -1;
557 id = x_allocate_bitmap_record (f);
558 dpyinfo->bitmaps[id - 1].pixmap = bitmap;
559 dpyinfo->bitmaps[id - 1].refcount = 1;
560 dpyinfo->bitmaps[id - 1].file = (char *) xmalloc (SCHARS (file) + 1);
561 dpyinfo->bitmaps[id - 1].depth = 1;
562 dpyinfo->bitmaps[id - 1].height = height;
563 dpyinfo->bitmaps[id - 1].width = width;
564 strcpy (dpyinfo->bitmaps[id - 1].file, SDATA (file));
566 return id;
567 #endif /* TODO */
570 /* Remove reference to bitmap with id number ID. */
572 void
573 x_destroy_bitmap (f, id)
574 FRAME_PTR f;
575 int id;
577 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
579 if (id > 0)
581 --dpyinfo->bitmaps[id - 1].refcount;
582 if (dpyinfo->bitmaps[id - 1].refcount == 0)
584 BLOCK_INPUT;
585 DeleteObject (dpyinfo->bitmaps[id - 1].pixmap);
586 if (dpyinfo->bitmaps[id - 1].file)
588 xfree (dpyinfo->bitmaps[id - 1].file);
589 dpyinfo->bitmaps[id - 1].file = NULL;
591 UNBLOCK_INPUT;
596 /* Free all the bitmaps for the display specified by DPYINFO. */
598 static void
599 x_destroy_all_bitmaps (dpyinfo)
600 struct w32_display_info *dpyinfo;
602 int i;
603 for (i = 0; i < dpyinfo->bitmaps_last; i++)
604 if (dpyinfo->bitmaps[i].refcount > 0)
606 DeleteObject (dpyinfo->bitmaps[i].pixmap);
607 if (dpyinfo->bitmaps[i].file)
608 xfree (dpyinfo->bitmaps[i].file);
610 dpyinfo->bitmaps_last = 0;
613 BOOL my_show_window P_ ((struct frame *, HWND, int));
614 void my_set_window_pos P_ ((HWND, HWND, int, int, int, int, UINT));
615 static Lisp_Object unwind_create_frame P_ ((Lisp_Object));
616 static Lisp_Object unwind_create_tip_frame P_ ((Lisp_Object));
618 /* TODO: Native Input Method support; see x_create_im. */
619 void x_set_foreground_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
620 void x_set_background_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
621 void x_set_mouse_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
622 void x_set_cursor_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
623 void x_set_border_color P_ ((struct frame *, Lisp_Object, Lisp_Object));
624 void x_set_cursor_type P_ ((struct frame *, Lisp_Object, Lisp_Object));
625 void x_set_icon_type P_ ((struct frame *, Lisp_Object, Lisp_Object));
626 void x_set_icon_name P_ ((struct frame *, Lisp_Object, Lisp_Object));
627 void x_explicitly_set_name P_ ((struct frame *, Lisp_Object, Lisp_Object));
628 void x_set_menu_bar_lines P_ ((struct frame *, Lisp_Object, Lisp_Object));
629 void x_set_title P_ ((struct frame *, Lisp_Object, Lisp_Object));
630 void x_set_tool_bar_lines P_ ((struct frame *, Lisp_Object, Lisp_Object));
631 static void x_edge_detection P_ ((struct frame *, struct image *, Lisp_Object,
632 Lisp_Object));
637 /* Store the screen positions of frame F into XPTR and YPTR.
638 These are the positions of the containing window manager window,
639 not Emacs's own window. */
641 void
642 x_real_positions (f, xptr, yptr)
643 FRAME_PTR f;
644 int *xptr, *yptr;
646 POINT pt;
647 RECT rect;
649 GetClientRect(FRAME_W32_WINDOW(f), &rect);
650 AdjustWindowRect(&rect, f->output_data.w32->dwStyle, FRAME_EXTERNAL_MENU_BAR(f));
652 pt.x = rect.left;
653 pt.y = rect.top;
655 ClientToScreen (FRAME_W32_WINDOW(f), &pt);
657 /* Remember x_pixels_diff and y_pixels_diff. */
658 f->output_data.w32->x_pixels_diff = pt.x - rect.left;
659 f->output_data.w32->y_pixels_diff = pt.y - rect.top;
661 *xptr = pt.x;
662 *yptr = pt.y;
667 DEFUN ("w32-define-rgb-color", Fw32_define_rgb_color,
668 Sw32_define_rgb_color, 4, 4, 0,
669 doc: /* Convert RGB numbers to a windows color reference and associate with NAME.
670 This adds or updates a named color to w32-color-map, making it
671 available for use. The original entry's RGB ref is returned, or nil
672 if the entry is new. */)
673 (red, green, blue, name)
674 Lisp_Object red, green, blue, name;
676 Lisp_Object rgb;
677 Lisp_Object oldrgb = Qnil;
678 Lisp_Object entry;
680 CHECK_NUMBER (red);
681 CHECK_NUMBER (green);
682 CHECK_NUMBER (blue);
683 CHECK_STRING (name);
685 XSET (rgb, Lisp_Int, RGB(XUINT (red), XUINT (green), XUINT (blue)));
687 BLOCK_INPUT;
689 /* replace existing entry in w32-color-map or add new entry. */
690 entry = Fassoc (name, Vw32_color_map);
691 if (NILP (entry))
693 entry = Fcons (name, rgb);
694 Vw32_color_map = Fcons (entry, Vw32_color_map);
696 else
698 oldrgb = Fcdr (entry);
699 Fsetcdr (entry, rgb);
702 UNBLOCK_INPUT;
704 return (oldrgb);
707 DEFUN ("w32-load-color-file", Fw32_load_color_file,
708 Sw32_load_color_file, 1, 1, 0,
709 doc: /* Create an alist of color entries from an external file.
710 Assign this value to w32-color-map to replace the existing color map.
712 The file should define one named RGB color per line like so:
713 R G B name
714 where R,G,B are numbers between 0 and 255 and name is an arbitrary string. */)
715 (filename)
716 Lisp_Object filename;
718 FILE *fp;
719 Lisp_Object cmap = Qnil;
720 Lisp_Object abspath;
722 CHECK_STRING (filename);
723 abspath = Fexpand_file_name (filename, Qnil);
725 fp = fopen (SDATA (filename), "rt");
726 if (fp)
728 char buf[512];
729 int red, green, blue;
730 int num;
732 BLOCK_INPUT;
734 while (fgets (buf, sizeof (buf), fp) != NULL) {
735 if (sscanf (buf, "%u %u %u %n", &red, &green, &blue, &num) == 3)
737 char *name = buf + num;
738 num = strlen (name) - 1;
739 if (name[num] == '\n')
740 name[num] = 0;
741 cmap = Fcons (Fcons (build_string (name),
742 make_number (RGB (red, green, blue))),
743 cmap);
746 fclose (fp);
748 UNBLOCK_INPUT;
751 return cmap;
754 /* The default colors for the w32 color map */
755 typedef struct colormap_t
757 char *name;
758 COLORREF colorref;
759 } colormap_t;
761 colormap_t w32_color_map[] =
763 {"snow" , PALETTERGB (255,250,250)},
764 {"ghost white" , PALETTERGB (248,248,255)},
765 {"GhostWhite" , PALETTERGB (248,248,255)},
766 {"white smoke" , PALETTERGB (245,245,245)},
767 {"WhiteSmoke" , PALETTERGB (245,245,245)},
768 {"gainsboro" , PALETTERGB (220,220,220)},
769 {"floral white" , PALETTERGB (255,250,240)},
770 {"FloralWhite" , PALETTERGB (255,250,240)},
771 {"old lace" , PALETTERGB (253,245,230)},
772 {"OldLace" , PALETTERGB (253,245,230)},
773 {"linen" , PALETTERGB (250,240,230)},
774 {"antique white" , PALETTERGB (250,235,215)},
775 {"AntiqueWhite" , PALETTERGB (250,235,215)},
776 {"papaya whip" , PALETTERGB (255,239,213)},
777 {"PapayaWhip" , PALETTERGB (255,239,213)},
778 {"blanched almond" , PALETTERGB (255,235,205)},
779 {"BlanchedAlmond" , PALETTERGB (255,235,205)},
780 {"bisque" , PALETTERGB (255,228,196)},
781 {"peach puff" , PALETTERGB (255,218,185)},
782 {"PeachPuff" , PALETTERGB (255,218,185)},
783 {"navajo white" , PALETTERGB (255,222,173)},
784 {"NavajoWhite" , PALETTERGB (255,222,173)},
785 {"moccasin" , PALETTERGB (255,228,181)},
786 {"cornsilk" , PALETTERGB (255,248,220)},
787 {"ivory" , PALETTERGB (255,255,240)},
788 {"lemon chiffon" , PALETTERGB (255,250,205)},
789 {"LemonChiffon" , PALETTERGB (255,250,205)},
790 {"seashell" , PALETTERGB (255,245,238)},
791 {"honeydew" , PALETTERGB (240,255,240)},
792 {"mint cream" , PALETTERGB (245,255,250)},
793 {"MintCream" , PALETTERGB (245,255,250)},
794 {"azure" , PALETTERGB (240,255,255)},
795 {"alice blue" , PALETTERGB (240,248,255)},
796 {"AliceBlue" , PALETTERGB (240,248,255)},
797 {"lavender" , PALETTERGB (230,230,250)},
798 {"lavender blush" , PALETTERGB (255,240,245)},
799 {"LavenderBlush" , PALETTERGB (255,240,245)},
800 {"misty rose" , PALETTERGB (255,228,225)},
801 {"MistyRose" , PALETTERGB (255,228,225)},
802 {"white" , PALETTERGB (255,255,255)},
803 {"black" , PALETTERGB ( 0, 0, 0)},
804 {"dark slate gray" , PALETTERGB ( 47, 79, 79)},
805 {"DarkSlateGray" , PALETTERGB ( 47, 79, 79)},
806 {"dark slate grey" , PALETTERGB ( 47, 79, 79)},
807 {"DarkSlateGrey" , PALETTERGB ( 47, 79, 79)},
808 {"dim gray" , PALETTERGB (105,105,105)},
809 {"DimGray" , PALETTERGB (105,105,105)},
810 {"dim grey" , PALETTERGB (105,105,105)},
811 {"DimGrey" , PALETTERGB (105,105,105)},
812 {"slate gray" , PALETTERGB (112,128,144)},
813 {"SlateGray" , PALETTERGB (112,128,144)},
814 {"slate grey" , PALETTERGB (112,128,144)},
815 {"SlateGrey" , PALETTERGB (112,128,144)},
816 {"light slate gray" , PALETTERGB (119,136,153)},
817 {"LightSlateGray" , PALETTERGB (119,136,153)},
818 {"light slate grey" , PALETTERGB (119,136,153)},
819 {"LightSlateGrey" , PALETTERGB (119,136,153)},
820 {"gray" , PALETTERGB (190,190,190)},
821 {"grey" , PALETTERGB (190,190,190)},
822 {"light grey" , PALETTERGB (211,211,211)},
823 {"LightGrey" , PALETTERGB (211,211,211)},
824 {"light gray" , PALETTERGB (211,211,211)},
825 {"LightGray" , PALETTERGB (211,211,211)},
826 {"midnight blue" , PALETTERGB ( 25, 25,112)},
827 {"MidnightBlue" , PALETTERGB ( 25, 25,112)},
828 {"navy" , PALETTERGB ( 0, 0,128)},
829 {"navy blue" , PALETTERGB ( 0, 0,128)},
830 {"NavyBlue" , PALETTERGB ( 0, 0,128)},
831 {"cornflower blue" , PALETTERGB (100,149,237)},
832 {"CornflowerBlue" , PALETTERGB (100,149,237)},
833 {"dark slate blue" , PALETTERGB ( 72, 61,139)},
834 {"DarkSlateBlue" , PALETTERGB ( 72, 61,139)},
835 {"slate blue" , PALETTERGB (106, 90,205)},
836 {"SlateBlue" , PALETTERGB (106, 90,205)},
837 {"medium slate blue" , PALETTERGB (123,104,238)},
838 {"MediumSlateBlue" , PALETTERGB (123,104,238)},
839 {"light slate blue" , PALETTERGB (132,112,255)},
840 {"LightSlateBlue" , PALETTERGB (132,112,255)},
841 {"medium blue" , PALETTERGB ( 0, 0,205)},
842 {"MediumBlue" , PALETTERGB ( 0, 0,205)},
843 {"royal blue" , PALETTERGB ( 65,105,225)},
844 {"RoyalBlue" , PALETTERGB ( 65,105,225)},
845 {"blue" , PALETTERGB ( 0, 0,255)},
846 {"dodger blue" , PALETTERGB ( 30,144,255)},
847 {"DodgerBlue" , PALETTERGB ( 30,144,255)},
848 {"deep sky blue" , PALETTERGB ( 0,191,255)},
849 {"DeepSkyBlue" , PALETTERGB ( 0,191,255)},
850 {"sky blue" , PALETTERGB (135,206,235)},
851 {"SkyBlue" , PALETTERGB (135,206,235)},
852 {"light sky blue" , PALETTERGB (135,206,250)},
853 {"LightSkyBlue" , PALETTERGB (135,206,250)},
854 {"steel blue" , PALETTERGB ( 70,130,180)},
855 {"SteelBlue" , PALETTERGB ( 70,130,180)},
856 {"light steel blue" , PALETTERGB (176,196,222)},
857 {"LightSteelBlue" , PALETTERGB (176,196,222)},
858 {"light blue" , PALETTERGB (173,216,230)},
859 {"LightBlue" , PALETTERGB (173,216,230)},
860 {"powder blue" , PALETTERGB (176,224,230)},
861 {"PowderBlue" , PALETTERGB (176,224,230)},
862 {"pale turquoise" , PALETTERGB (175,238,238)},
863 {"PaleTurquoise" , PALETTERGB (175,238,238)},
864 {"dark turquoise" , PALETTERGB ( 0,206,209)},
865 {"DarkTurquoise" , PALETTERGB ( 0,206,209)},
866 {"medium turquoise" , PALETTERGB ( 72,209,204)},
867 {"MediumTurquoise" , PALETTERGB ( 72,209,204)},
868 {"turquoise" , PALETTERGB ( 64,224,208)},
869 {"cyan" , PALETTERGB ( 0,255,255)},
870 {"light cyan" , PALETTERGB (224,255,255)},
871 {"LightCyan" , PALETTERGB (224,255,255)},
872 {"cadet blue" , PALETTERGB ( 95,158,160)},
873 {"CadetBlue" , PALETTERGB ( 95,158,160)},
874 {"medium aquamarine" , PALETTERGB (102,205,170)},
875 {"MediumAquamarine" , PALETTERGB (102,205,170)},
876 {"aquamarine" , PALETTERGB (127,255,212)},
877 {"dark green" , PALETTERGB ( 0,100, 0)},
878 {"DarkGreen" , PALETTERGB ( 0,100, 0)},
879 {"dark olive green" , PALETTERGB ( 85,107, 47)},
880 {"DarkOliveGreen" , PALETTERGB ( 85,107, 47)},
881 {"dark sea green" , PALETTERGB (143,188,143)},
882 {"DarkSeaGreen" , PALETTERGB (143,188,143)},
883 {"sea green" , PALETTERGB ( 46,139, 87)},
884 {"SeaGreen" , PALETTERGB ( 46,139, 87)},
885 {"medium sea green" , PALETTERGB ( 60,179,113)},
886 {"MediumSeaGreen" , PALETTERGB ( 60,179,113)},
887 {"light sea green" , PALETTERGB ( 32,178,170)},
888 {"LightSeaGreen" , PALETTERGB ( 32,178,170)},
889 {"pale green" , PALETTERGB (152,251,152)},
890 {"PaleGreen" , PALETTERGB (152,251,152)},
891 {"spring green" , PALETTERGB ( 0,255,127)},
892 {"SpringGreen" , PALETTERGB ( 0,255,127)},
893 {"lawn green" , PALETTERGB (124,252, 0)},
894 {"LawnGreen" , PALETTERGB (124,252, 0)},
895 {"green" , PALETTERGB ( 0,255, 0)},
896 {"chartreuse" , PALETTERGB (127,255, 0)},
897 {"medium spring green" , PALETTERGB ( 0,250,154)},
898 {"MediumSpringGreen" , PALETTERGB ( 0,250,154)},
899 {"green yellow" , PALETTERGB (173,255, 47)},
900 {"GreenYellow" , PALETTERGB (173,255, 47)},
901 {"lime green" , PALETTERGB ( 50,205, 50)},
902 {"LimeGreen" , PALETTERGB ( 50,205, 50)},
903 {"yellow green" , PALETTERGB (154,205, 50)},
904 {"YellowGreen" , PALETTERGB (154,205, 50)},
905 {"forest green" , PALETTERGB ( 34,139, 34)},
906 {"ForestGreen" , PALETTERGB ( 34,139, 34)},
907 {"olive drab" , PALETTERGB (107,142, 35)},
908 {"OliveDrab" , PALETTERGB (107,142, 35)},
909 {"dark khaki" , PALETTERGB (189,183,107)},
910 {"DarkKhaki" , PALETTERGB (189,183,107)},
911 {"khaki" , PALETTERGB (240,230,140)},
912 {"pale goldenrod" , PALETTERGB (238,232,170)},
913 {"PaleGoldenrod" , PALETTERGB (238,232,170)},
914 {"light goldenrod yellow" , PALETTERGB (250,250,210)},
915 {"LightGoldenrodYellow" , PALETTERGB (250,250,210)},
916 {"light yellow" , PALETTERGB (255,255,224)},
917 {"LightYellow" , PALETTERGB (255,255,224)},
918 {"yellow" , PALETTERGB (255,255, 0)},
919 {"gold" , PALETTERGB (255,215, 0)},
920 {"light goldenrod" , PALETTERGB (238,221,130)},
921 {"LightGoldenrod" , PALETTERGB (238,221,130)},
922 {"goldenrod" , PALETTERGB (218,165, 32)},
923 {"dark goldenrod" , PALETTERGB (184,134, 11)},
924 {"DarkGoldenrod" , PALETTERGB (184,134, 11)},
925 {"rosy brown" , PALETTERGB (188,143,143)},
926 {"RosyBrown" , PALETTERGB (188,143,143)},
927 {"indian red" , PALETTERGB (205, 92, 92)},
928 {"IndianRed" , PALETTERGB (205, 92, 92)},
929 {"saddle brown" , PALETTERGB (139, 69, 19)},
930 {"SaddleBrown" , PALETTERGB (139, 69, 19)},
931 {"sienna" , PALETTERGB (160, 82, 45)},
932 {"peru" , PALETTERGB (205,133, 63)},
933 {"burlywood" , PALETTERGB (222,184,135)},
934 {"beige" , PALETTERGB (245,245,220)},
935 {"wheat" , PALETTERGB (245,222,179)},
936 {"sandy brown" , PALETTERGB (244,164, 96)},
937 {"SandyBrown" , PALETTERGB (244,164, 96)},
938 {"tan" , PALETTERGB (210,180,140)},
939 {"chocolate" , PALETTERGB (210,105, 30)},
940 {"firebrick" , PALETTERGB (178,34, 34)},
941 {"brown" , PALETTERGB (165,42, 42)},
942 {"dark salmon" , PALETTERGB (233,150,122)},
943 {"DarkSalmon" , PALETTERGB (233,150,122)},
944 {"salmon" , PALETTERGB (250,128,114)},
945 {"light salmon" , PALETTERGB (255,160,122)},
946 {"LightSalmon" , PALETTERGB (255,160,122)},
947 {"orange" , PALETTERGB (255,165, 0)},
948 {"dark orange" , PALETTERGB (255,140, 0)},
949 {"DarkOrange" , PALETTERGB (255,140, 0)},
950 {"coral" , PALETTERGB (255,127, 80)},
951 {"light coral" , PALETTERGB (240,128,128)},
952 {"LightCoral" , PALETTERGB (240,128,128)},
953 {"tomato" , PALETTERGB (255, 99, 71)},
954 {"orange red" , PALETTERGB (255, 69, 0)},
955 {"OrangeRed" , PALETTERGB (255, 69, 0)},
956 {"red" , PALETTERGB (255, 0, 0)},
957 {"hot pink" , PALETTERGB (255,105,180)},
958 {"HotPink" , PALETTERGB (255,105,180)},
959 {"deep pink" , PALETTERGB (255, 20,147)},
960 {"DeepPink" , PALETTERGB (255, 20,147)},
961 {"pink" , PALETTERGB (255,192,203)},
962 {"light pink" , PALETTERGB (255,182,193)},
963 {"LightPink" , PALETTERGB (255,182,193)},
964 {"pale violet red" , PALETTERGB (219,112,147)},
965 {"PaleVioletRed" , PALETTERGB (219,112,147)},
966 {"maroon" , PALETTERGB (176, 48, 96)},
967 {"medium violet red" , PALETTERGB (199, 21,133)},
968 {"MediumVioletRed" , PALETTERGB (199, 21,133)},
969 {"violet red" , PALETTERGB (208, 32,144)},
970 {"VioletRed" , PALETTERGB (208, 32,144)},
971 {"magenta" , PALETTERGB (255, 0,255)},
972 {"violet" , PALETTERGB (238,130,238)},
973 {"plum" , PALETTERGB (221,160,221)},
974 {"orchid" , PALETTERGB (218,112,214)},
975 {"medium orchid" , PALETTERGB (186, 85,211)},
976 {"MediumOrchid" , PALETTERGB (186, 85,211)},
977 {"dark orchid" , PALETTERGB (153, 50,204)},
978 {"DarkOrchid" , PALETTERGB (153, 50,204)},
979 {"dark violet" , PALETTERGB (148, 0,211)},
980 {"DarkViolet" , PALETTERGB (148, 0,211)},
981 {"blue violet" , PALETTERGB (138, 43,226)},
982 {"BlueViolet" , PALETTERGB (138, 43,226)},
983 {"purple" , PALETTERGB (160, 32,240)},
984 {"medium purple" , PALETTERGB (147,112,219)},
985 {"MediumPurple" , PALETTERGB (147,112,219)},
986 {"thistle" , PALETTERGB (216,191,216)},
987 {"gray0" , PALETTERGB ( 0, 0, 0)},
988 {"grey0" , PALETTERGB ( 0, 0, 0)},
989 {"dark grey" , PALETTERGB (169,169,169)},
990 {"DarkGrey" , PALETTERGB (169,169,169)},
991 {"dark gray" , PALETTERGB (169,169,169)},
992 {"DarkGray" , PALETTERGB (169,169,169)},
993 {"dark blue" , PALETTERGB ( 0, 0,139)},
994 {"DarkBlue" , PALETTERGB ( 0, 0,139)},
995 {"dark cyan" , PALETTERGB ( 0,139,139)},
996 {"DarkCyan" , PALETTERGB ( 0,139,139)},
997 {"dark magenta" , PALETTERGB (139, 0,139)},
998 {"DarkMagenta" , PALETTERGB (139, 0,139)},
999 {"dark red" , PALETTERGB (139, 0, 0)},
1000 {"DarkRed" , PALETTERGB (139, 0, 0)},
1001 {"light green" , PALETTERGB (144,238,144)},
1002 {"LightGreen" , PALETTERGB (144,238,144)},
1005 DEFUN ("w32-default-color-map", Fw32_default_color_map, Sw32_default_color_map,
1006 0, 0, 0, doc: /* Return the default color map. */)
1009 int i;
1010 colormap_t *pc = w32_color_map;
1011 Lisp_Object cmap;
1013 BLOCK_INPUT;
1015 cmap = Qnil;
1017 for (i = 0; i < sizeof (w32_color_map) / sizeof (w32_color_map[0]);
1018 pc++, i++)
1019 cmap = Fcons (Fcons (build_string (pc->name),
1020 make_number (pc->colorref)),
1021 cmap);
1023 UNBLOCK_INPUT;
1025 return (cmap);
1028 Lisp_Object
1029 w32_to_x_color (rgb)
1030 Lisp_Object rgb;
1032 Lisp_Object color;
1034 CHECK_NUMBER (rgb);
1036 BLOCK_INPUT;
1038 color = Frassq (rgb, Vw32_color_map);
1040 UNBLOCK_INPUT;
1042 if (!NILP (color))
1043 return (Fcar (color));
1044 else
1045 return Qnil;
1048 COLORREF
1049 w32_color_map_lookup (colorname)
1050 char *colorname;
1052 Lisp_Object tail, ret = Qnil;
1054 BLOCK_INPUT;
1056 for (tail = Vw32_color_map; !NILP (tail); tail = Fcdr (tail))
1058 register Lisp_Object elt, tem;
1060 elt = Fcar (tail);
1061 if (!CONSP (elt)) continue;
1063 tem = Fcar (elt);
1065 if (lstrcmpi (SDATA (tem), colorname) == 0)
1067 ret = XUINT (Fcdr (elt));
1068 break;
1071 QUIT;
1075 UNBLOCK_INPUT;
1077 return ret;
1080 COLORREF
1081 x_to_w32_color (colorname)
1082 char * colorname;
1084 register Lisp_Object ret = Qnil;
1086 BLOCK_INPUT;
1088 if (colorname[0] == '#')
1090 /* Could be an old-style RGB Device specification. */
1091 char *color;
1092 int size;
1093 color = colorname + 1;
1095 size = strlen(color);
1096 if (size == 3 || size == 6 || size == 9 || size == 12)
1098 UINT colorval;
1099 int i, pos;
1100 pos = 0;
1101 size /= 3;
1102 colorval = 0;
1104 for (i = 0; i < 3; i++)
1106 char *end;
1107 char t;
1108 unsigned long value;
1110 /* The check for 'x' in the following conditional takes into
1111 account the fact that strtol allows a "0x" in front of
1112 our numbers, and we don't. */
1113 if (!isxdigit(color[0]) || color[1] == 'x')
1114 break;
1115 t = color[size];
1116 color[size] = '\0';
1117 value = strtoul(color, &end, 16);
1118 color[size] = t;
1119 if (errno == ERANGE || end - color != size)
1120 break;
1121 switch (size)
1123 case 1:
1124 value = value * 0x10;
1125 break;
1126 case 2:
1127 break;
1128 case 3:
1129 value /= 0x10;
1130 break;
1131 case 4:
1132 value /= 0x100;
1133 break;
1135 colorval |= (value << pos);
1136 pos += 0x8;
1137 if (i == 2)
1139 UNBLOCK_INPUT;
1140 return (colorval);
1142 color = end;
1146 else if (strnicmp(colorname, "rgb:", 4) == 0)
1148 char *color;
1149 UINT colorval;
1150 int i, pos;
1151 pos = 0;
1153 colorval = 0;
1154 color = colorname + 4;
1155 for (i = 0; i < 3; i++)
1157 char *end;
1158 unsigned long value;
1160 /* The check for 'x' in the following conditional takes into
1161 account the fact that strtol allows a "0x" in front of
1162 our numbers, and we don't. */
1163 if (!isxdigit(color[0]) || color[1] == 'x')
1164 break;
1165 value = strtoul(color, &end, 16);
1166 if (errno == ERANGE)
1167 break;
1168 switch (end - color)
1170 case 1:
1171 value = value * 0x10 + value;
1172 break;
1173 case 2:
1174 break;
1175 case 3:
1176 value /= 0x10;
1177 break;
1178 case 4:
1179 value /= 0x100;
1180 break;
1181 default:
1182 value = ULONG_MAX;
1184 if (value == ULONG_MAX)
1185 break;
1186 colorval |= (value << pos);
1187 pos += 0x8;
1188 if (i == 2)
1190 if (*end != '\0')
1191 break;
1192 UNBLOCK_INPUT;
1193 return (colorval);
1195 if (*end != '/')
1196 break;
1197 color = end + 1;
1200 else if (strnicmp(colorname, "rgbi:", 5) == 0)
1202 /* This is an RGB Intensity specification. */
1203 char *color;
1204 UINT colorval;
1205 int i, pos;
1206 pos = 0;
1208 colorval = 0;
1209 color = colorname + 5;
1210 for (i = 0; i < 3; i++)
1212 char *end;
1213 double value;
1214 UINT val;
1216 value = strtod(color, &end);
1217 if (errno == ERANGE)
1218 break;
1219 if (value < 0.0 || value > 1.0)
1220 break;
1221 val = (UINT)(0x100 * value);
1222 /* We used 0x100 instead of 0xFF to give a continuous
1223 range between 0.0 and 1.0 inclusive. The next statement
1224 fixes the 1.0 case. */
1225 if (val == 0x100)
1226 val = 0xFF;
1227 colorval |= (val << pos);
1228 pos += 0x8;
1229 if (i == 2)
1231 if (*end != '\0')
1232 break;
1233 UNBLOCK_INPUT;
1234 return (colorval);
1236 if (*end != '/')
1237 break;
1238 color = end + 1;
1241 /* I am not going to attempt to handle any of the CIE color schemes
1242 or TekHVC, since I don't know the algorithms for conversion to
1243 RGB. */
1245 /* If we fail to lookup the color name in w32_color_map, then check the
1246 colorname to see if it can be crudely approximated: If the X color
1247 ends in a number (e.g., "darkseagreen2"), strip the number and
1248 return the result of looking up the base color name. */
1249 ret = w32_color_map_lookup (colorname);
1250 if (NILP (ret))
1252 int len = strlen (colorname);
1254 if (isdigit (colorname[len - 1]))
1256 char *ptr, *approx = alloca (len + 1);
1258 strcpy (approx, colorname);
1259 ptr = &approx[len - 1];
1260 while (ptr > approx && isdigit (*ptr))
1261 *ptr-- = '\0';
1263 ret = w32_color_map_lookup (approx);
1267 UNBLOCK_INPUT;
1268 return ret;
1272 void
1273 w32_regenerate_palette (FRAME_PTR f)
1275 struct w32_palette_entry * list;
1276 LOGPALETTE * log_palette;
1277 HPALETTE new_palette;
1278 int i;
1280 /* don't bother trying to create palette if not supported */
1281 if (! FRAME_W32_DISPLAY_INFO (f)->has_palette)
1282 return;
1284 log_palette = (LOGPALETTE *)
1285 alloca (sizeof (LOGPALETTE) +
1286 FRAME_W32_DISPLAY_INFO (f)->num_colors * sizeof (PALETTEENTRY));
1287 log_palette->palVersion = 0x300;
1288 log_palette->palNumEntries = FRAME_W32_DISPLAY_INFO (f)->num_colors;
1290 list = FRAME_W32_DISPLAY_INFO (f)->color_list;
1291 for (i = 0;
1292 i < FRAME_W32_DISPLAY_INFO (f)->num_colors;
1293 i++, list = list->next)
1294 log_palette->palPalEntry[i] = list->entry;
1296 new_palette = CreatePalette (log_palette);
1298 enter_crit ();
1300 if (FRAME_W32_DISPLAY_INFO (f)->palette)
1301 DeleteObject (FRAME_W32_DISPLAY_INFO (f)->palette);
1302 FRAME_W32_DISPLAY_INFO (f)->palette = new_palette;
1304 /* Realize display palette and garbage all frames. */
1305 release_frame_dc (f, get_frame_dc (f));
1307 leave_crit ();
1310 #define W32_COLOR(pe) RGB (pe.peRed, pe.peGreen, pe.peBlue)
1311 #define SET_W32_COLOR(pe, color) \
1312 do \
1314 pe.peRed = GetRValue (color); \
1315 pe.peGreen = GetGValue (color); \
1316 pe.peBlue = GetBValue (color); \
1317 pe.peFlags = 0; \
1318 } while (0)
1320 #if 0
1321 /* Keep these around in case we ever want to track color usage. */
1322 void
1323 w32_map_color (FRAME_PTR f, COLORREF color)
1325 struct w32_palette_entry * list = FRAME_W32_DISPLAY_INFO (f)->color_list;
1327 if (NILP (Vw32_enable_palette))
1328 return;
1330 /* check if color is already mapped */
1331 while (list)
1333 if (W32_COLOR (list->entry) == color)
1335 ++list->refcount;
1336 return;
1338 list = list->next;
1341 /* not already mapped, so add to list and recreate Windows palette */
1342 list = (struct w32_palette_entry *)
1343 xmalloc (sizeof (struct w32_palette_entry));
1344 SET_W32_COLOR (list->entry, color);
1345 list->refcount = 1;
1346 list->next = FRAME_W32_DISPLAY_INFO (f)->color_list;
1347 FRAME_W32_DISPLAY_INFO (f)->color_list = list;
1348 FRAME_W32_DISPLAY_INFO (f)->num_colors++;
1350 /* set flag that palette must be regenerated */
1351 FRAME_W32_DISPLAY_INFO (f)->regen_palette = TRUE;
1354 void
1355 w32_unmap_color (FRAME_PTR f, COLORREF color)
1357 struct w32_palette_entry * list = FRAME_W32_DISPLAY_INFO (f)->color_list;
1358 struct w32_palette_entry **prev = &FRAME_W32_DISPLAY_INFO (f)->color_list;
1360 if (NILP (Vw32_enable_palette))
1361 return;
1363 /* check if color is already mapped */
1364 while (list)
1366 if (W32_COLOR (list->entry) == color)
1368 if (--list->refcount == 0)
1370 *prev = list->next;
1371 xfree (list);
1372 FRAME_W32_DISPLAY_INFO (f)->num_colors--;
1373 break;
1375 else
1376 return;
1378 prev = &list->next;
1379 list = list->next;
1382 /* set flag that palette must be regenerated */
1383 FRAME_W32_DISPLAY_INFO (f)->regen_palette = TRUE;
1385 #endif
1388 /* Gamma-correct COLOR on frame F. */
1390 void
1391 gamma_correct (f, color)
1392 struct frame *f;
1393 COLORREF *color;
1395 if (f->gamma)
1397 *color = PALETTERGB (
1398 pow (GetRValue (*color) / 255.0, f->gamma) * 255.0 + 0.5,
1399 pow (GetGValue (*color) / 255.0, f->gamma) * 255.0 + 0.5,
1400 pow (GetBValue (*color) / 255.0, f->gamma) * 255.0 + 0.5);
1405 /* Decide if color named COLOR is valid for the display associated with
1406 the selected frame; if so, return the rgb values in COLOR_DEF.
1407 If ALLOC is nonzero, allocate a new colormap cell. */
1410 w32_defined_color (f, color, color_def, alloc)
1411 FRAME_PTR f;
1412 char *color;
1413 XColor *color_def;
1414 int alloc;
1416 register Lisp_Object tem;
1417 COLORREF w32_color_ref;
1419 tem = x_to_w32_color (color);
1421 if (!NILP (tem))
1423 if (f)
1425 /* Apply gamma correction. */
1426 w32_color_ref = XUINT (tem);
1427 gamma_correct (f, &w32_color_ref);
1428 XSETINT (tem, w32_color_ref);
1431 /* Map this color to the palette if it is enabled. */
1432 if (!NILP (Vw32_enable_palette))
1434 struct w32_palette_entry * entry =
1435 one_w32_display_info.color_list;
1436 struct w32_palette_entry ** prev =
1437 &one_w32_display_info.color_list;
1439 /* check if color is already mapped */
1440 while (entry)
1442 if (W32_COLOR (entry->entry) == XUINT (tem))
1443 break;
1444 prev = &entry->next;
1445 entry = entry->next;
1448 if (entry == NULL && alloc)
1450 /* not already mapped, so add to list */
1451 entry = (struct w32_palette_entry *)
1452 xmalloc (sizeof (struct w32_palette_entry));
1453 SET_W32_COLOR (entry->entry, XUINT (tem));
1454 entry->next = NULL;
1455 *prev = entry;
1456 one_w32_display_info.num_colors++;
1458 /* set flag that palette must be regenerated */
1459 one_w32_display_info.regen_palette = TRUE;
1462 /* Ensure COLORREF value is snapped to nearest color in (default)
1463 palette by simulating the PALETTERGB macro. This works whether
1464 or not the display device has a palette. */
1465 w32_color_ref = XUINT (tem) | 0x2000000;
1467 color_def->pixel = w32_color_ref;
1468 color_def->red = GetRValue (w32_color_ref) * 256;
1469 color_def->green = GetGValue (w32_color_ref) * 256;
1470 color_def->blue = GetBValue (w32_color_ref) * 256;
1472 return 1;
1474 else
1476 return 0;
1480 /* Given a string ARG naming a color, compute a pixel value from it
1481 suitable for screen F.
1482 If F is not a color screen, return DEF (default) regardless of what
1483 ARG says. */
1486 x_decode_color (f, arg, def)
1487 FRAME_PTR f;
1488 Lisp_Object arg;
1489 int def;
1491 XColor cdef;
1493 CHECK_STRING (arg);
1495 if (strcmp (SDATA (arg), "black") == 0)
1496 return BLACK_PIX_DEFAULT (f);
1497 else if (strcmp (SDATA (arg), "white") == 0)
1498 return WHITE_PIX_DEFAULT (f);
1500 if ((FRAME_W32_DISPLAY_INFO (f)->n_planes * FRAME_W32_DISPLAY_INFO (f)->n_cbits) == 1)
1501 return def;
1503 /* w32_defined_color is responsible for coping with failures
1504 by looking for a near-miss. */
1505 if (w32_defined_color (f, SDATA (arg), &cdef, 1))
1506 return cdef.pixel;
1508 /* defined_color failed; return an ultimate default. */
1509 return def;
1514 /* Functions called only from `x_set_frame_param'
1515 to set individual parameters.
1517 If FRAME_W32_WINDOW (f) is 0,
1518 the frame is being created and its window does not exist yet.
1519 In that case, just record the parameter's new value
1520 in the standard place; do not attempt to change the window. */
1522 void
1523 x_set_foreground_color (f, arg, oldval)
1524 struct frame *f;
1525 Lisp_Object arg, oldval;
1527 struct w32_output *x = f->output_data.w32;
1528 PIX_TYPE fg, old_fg;
1530 fg = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
1531 old_fg = FRAME_FOREGROUND_PIXEL (f);
1532 FRAME_FOREGROUND_PIXEL (f) = fg;
1534 if (FRAME_W32_WINDOW (f) != 0)
1536 if (x->cursor_pixel == old_fg)
1537 x->cursor_pixel = fg;
1539 update_face_from_frame_parameter (f, Qforeground_color, arg);
1540 if (FRAME_VISIBLE_P (f))
1541 redraw_frame (f);
1545 void
1546 x_set_background_color (f, arg, oldval)
1547 struct frame *f;
1548 Lisp_Object arg, oldval;
1550 FRAME_BACKGROUND_PIXEL (f)
1551 = x_decode_color (f, arg, WHITE_PIX_DEFAULT (f));
1553 if (FRAME_W32_WINDOW (f) != 0)
1555 SetWindowLong (FRAME_W32_WINDOW (f), WND_BACKGROUND_INDEX,
1556 FRAME_BACKGROUND_PIXEL (f));
1558 update_face_from_frame_parameter (f, Qbackground_color, arg);
1560 if (FRAME_VISIBLE_P (f))
1561 redraw_frame (f);
1565 void
1566 x_set_mouse_color (f, arg, oldval)
1567 struct frame *f;
1568 Lisp_Object arg, oldval;
1570 Cursor cursor, nontext_cursor, mode_cursor, hand_cursor;
1571 int count;
1572 int mask_color;
1574 if (!EQ (Qnil, arg))
1575 f->output_data.w32->mouse_pixel
1576 = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
1577 mask_color = FRAME_BACKGROUND_PIXEL (f);
1579 /* Don't let pointers be invisible. */
1580 if (mask_color == f->output_data.w32->mouse_pixel
1581 && mask_color == FRAME_BACKGROUND_PIXEL (f))
1582 f->output_data.w32->mouse_pixel = FRAME_FOREGROUND_PIXEL (f);
1584 #if 0 /* TODO : cursor changes */
1585 BLOCK_INPUT;
1587 /* It's not okay to crash if the user selects a screwy cursor. */
1588 count = x_catch_errors (FRAME_W32_DISPLAY (f));
1590 if (!EQ (Qnil, Vx_pointer_shape))
1592 CHECK_NUMBER (Vx_pointer_shape);
1593 cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XINT (Vx_pointer_shape));
1595 else
1596 cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_xterm);
1597 x_check_errors (FRAME_W32_DISPLAY (f), "bad text pointer cursor: %s");
1599 if (!EQ (Qnil, Vx_nontext_pointer_shape))
1601 CHECK_NUMBER (Vx_nontext_pointer_shape);
1602 nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
1603 XINT (Vx_nontext_pointer_shape));
1605 else
1606 nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_left_ptr);
1607 x_check_errors (FRAME_W32_DISPLAY (f), "bad nontext pointer cursor: %s");
1609 if (!EQ (Qnil, Vx_hourglass_pointer_shape))
1611 CHECK_NUMBER (Vx_hourglass_pointer_shape);
1612 hourglass_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
1613 XINT (Vx_hourglass_pointer_shape));
1615 else
1616 hourglass_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_watch);
1617 x_check_errors (FRAME_W32_DISPLAY (f), "bad busy pointer cursor: %s");
1619 x_check_errors (FRAME_W32_DISPLAY (f), "bad nontext pointer cursor: %s");
1620 if (!EQ (Qnil, Vx_mode_pointer_shape))
1622 CHECK_NUMBER (Vx_mode_pointer_shape);
1623 mode_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f),
1624 XINT (Vx_mode_pointer_shape));
1626 else
1627 mode_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_xterm);
1628 x_check_errors (FRAME_W32_DISPLAY (f), "bad modeline pointer cursor: %s");
1630 if (!EQ (Qnil, Vx_sensitive_text_pointer_shape))
1632 CHECK_NUMBER (Vx_sensitive_text_pointer_shape);
1633 hand_cursor
1634 = XCreateFontCursor (FRAME_W32_DISPLAY (f),
1635 XINT (Vx_sensitive_text_pointer_shape));
1637 else
1638 hand_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_crosshair);
1640 if (!NILP (Vx_window_horizontal_drag_shape))
1642 CHECK_NUMBER (Vx_window_horizontal_drag_shape);
1643 horizontal_drag_cursor
1644 = XCreateFontCursor (FRAME_X_DISPLAY (f),
1645 XINT (Vx_window_horizontal_drag_shape));
1647 else
1648 horizontal_drag_cursor
1649 = XCreateFontCursor (FRAME_X_DISPLAY (f), XC_sb_h_double_arrow);
1651 /* Check and report errors with the above calls. */
1652 x_check_errors (FRAME_W32_DISPLAY (f), "can't set cursor shape: %s");
1653 x_uncatch_errors (FRAME_W32_DISPLAY (f), count);
1656 XColor fore_color, back_color;
1658 fore_color.pixel = f->output_data.w32->mouse_pixel;
1659 back_color.pixel = mask_color;
1660 XQueryColor (FRAME_W32_DISPLAY (f),
1661 DefaultColormap (FRAME_W32_DISPLAY (f),
1662 DefaultScreen (FRAME_W32_DISPLAY (f))),
1663 &fore_color);
1664 XQueryColor (FRAME_W32_DISPLAY (f),
1665 DefaultColormap (FRAME_W32_DISPLAY (f),
1666 DefaultScreen (FRAME_W32_DISPLAY (f))),
1667 &back_color);
1668 XRecolorCursor (FRAME_W32_DISPLAY (f), cursor,
1669 &fore_color, &back_color);
1670 XRecolorCursor (FRAME_W32_DISPLAY (f), nontext_cursor,
1671 &fore_color, &back_color);
1672 XRecolorCursor (FRAME_W32_DISPLAY (f), mode_cursor,
1673 &fore_color, &back_color);
1674 XRecolorCursor (FRAME_W32_DISPLAY (f), hand_cursor,
1675 &fore_color, &back_color);
1676 XRecolorCursor (FRAME_W32_DISPLAY (f), hourglass_cursor,
1677 &fore_color, &back_color);
1680 if (FRAME_W32_WINDOW (f) != 0)
1681 XDefineCursor (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), cursor);
1683 if (cursor != f->output_data.w32->text_cursor && f->output_data.w32->text_cursor != 0)
1684 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->text_cursor);
1685 f->output_data.w32->text_cursor = cursor;
1687 if (nontext_cursor != f->output_data.w32->nontext_cursor
1688 && f->output_data.w32->nontext_cursor != 0)
1689 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->nontext_cursor);
1690 f->output_data.w32->nontext_cursor = nontext_cursor;
1692 if (hourglass_cursor != f->output_data.w32->hourglass_cursor
1693 && f->output_data.w32->hourglass_cursor != 0)
1694 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->hourglass_cursor);
1695 f->output_data.w32->hourglass_cursor = hourglass_cursor;
1697 if (mode_cursor != f->output_data.w32->modeline_cursor
1698 && f->output_data.w32->modeline_cursor != 0)
1699 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->modeline_cursor);
1700 f->output_data.w32->modeline_cursor = mode_cursor;
1702 if (hand_cursor != f->output_data.w32->hand_cursor
1703 && f->output_data.w32->hand_cursor != 0)
1704 XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->hand_cursor);
1705 f->output_data.w32->hand_cursor = hand_cursor;
1707 XFlush (FRAME_W32_DISPLAY (f));
1708 UNBLOCK_INPUT;
1710 update_face_from_frame_parameter (f, Qmouse_color, arg);
1711 #endif /* TODO */
1714 /* Defined in w32term.c. */
1715 void
1716 x_set_cursor_color (f, arg, oldval)
1717 struct frame *f;
1718 Lisp_Object arg, oldval;
1720 unsigned long fore_pixel, pixel;
1722 if (!NILP (Vx_cursor_fore_pixel))
1723 fore_pixel = x_decode_color (f, Vx_cursor_fore_pixel,
1724 WHITE_PIX_DEFAULT (f));
1725 else
1726 fore_pixel = FRAME_BACKGROUND_PIXEL (f);
1728 pixel = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
1730 /* Make sure that the cursor color differs from the background color. */
1731 if (pixel == FRAME_BACKGROUND_PIXEL (f))
1733 pixel = f->output_data.w32->mouse_pixel;
1734 if (pixel == fore_pixel)
1735 fore_pixel = FRAME_BACKGROUND_PIXEL (f);
1738 f->output_data.w32->cursor_foreground_pixel = fore_pixel;
1739 f->output_data.w32->cursor_pixel = pixel;
1741 if (FRAME_W32_WINDOW (f) != 0)
1743 BLOCK_INPUT;
1744 /* Update frame's cursor_gc. */
1745 f->output_data.w32->cursor_gc->foreground = fore_pixel;
1746 f->output_data.w32->cursor_gc->background = pixel;
1748 UNBLOCK_INPUT;
1750 if (FRAME_VISIBLE_P (f))
1752 x_update_cursor (f, 0);
1753 x_update_cursor (f, 1);
1757 update_face_from_frame_parameter (f, Qcursor_color, arg);
1760 /* Set the border-color of frame F to pixel value PIX.
1761 Note that this does not fully take effect if done before
1762 F has a window. */
1764 void
1765 x_set_border_pixel (f, pix)
1766 struct frame *f;
1767 int pix;
1770 f->output_data.w32->border_pixel = pix;
1772 if (FRAME_W32_WINDOW (f) != 0 && f->output_data.w32->border_width > 0)
1774 if (FRAME_VISIBLE_P (f))
1775 redraw_frame (f);
1779 /* Set the border-color of frame F to value described by ARG.
1780 ARG can be a string naming a color.
1781 The border-color is used for the border that is drawn by the server.
1782 Note that this does not fully take effect if done before
1783 F has a window; it must be redone when the window is created. */
1785 void
1786 x_set_border_color (f, arg, oldval)
1787 struct frame *f;
1788 Lisp_Object arg, oldval;
1790 int pix;
1792 CHECK_STRING (arg);
1793 pix = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
1794 x_set_border_pixel (f, pix);
1795 update_face_from_frame_parameter (f, Qborder_color, arg);
1799 void
1800 x_set_cursor_type (f, arg, oldval)
1801 FRAME_PTR f;
1802 Lisp_Object arg, oldval;
1804 set_frame_cursor_types (f, arg);
1806 /* Make sure the cursor gets redrawn. */
1807 cursor_type_changed = 1;
1810 void
1811 x_set_icon_type (f, arg, oldval)
1812 struct frame *f;
1813 Lisp_Object arg, oldval;
1815 int result;
1817 if (NILP (arg) && NILP (oldval))
1818 return;
1820 if (STRINGP (arg) && STRINGP (oldval)
1821 && EQ (Fstring_equal (oldval, arg), Qt))
1822 return;
1824 if (SYMBOLP (arg) && SYMBOLP (oldval) && EQ (arg, oldval))
1825 return;
1827 BLOCK_INPUT;
1829 result = x_bitmap_icon (f, arg);
1830 if (result)
1832 UNBLOCK_INPUT;
1833 error ("No icon window available");
1836 UNBLOCK_INPUT;
1839 void
1840 x_set_icon_name (f, arg, oldval)
1841 struct frame *f;
1842 Lisp_Object arg, oldval;
1844 if (STRINGP (arg))
1846 if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt))
1847 return;
1849 else if (!STRINGP (oldval) && EQ (oldval, Qnil) == EQ (arg, Qnil))
1850 return;
1852 f->icon_name = arg;
1854 #if 0
1855 if (f->output_data.w32->icon_bitmap != 0)
1856 return;
1858 BLOCK_INPUT;
1860 result = x_text_icon (f,
1861 (char *) SDATA ((!NILP (f->icon_name)
1862 ? f->icon_name
1863 : !NILP (f->title)
1864 ? f->title
1865 : f->name)));
1867 if (result)
1869 UNBLOCK_INPUT;
1870 error ("No icon window available");
1873 /* If the window was unmapped (and its icon was mapped),
1874 the new icon is not mapped, so map the window in its stead. */
1875 if (FRAME_VISIBLE_P (f))
1877 #ifdef USE_X_TOOLKIT
1878 XtPopup (f->output_data.w32->widget, XtGrabNone);
1879 #endif
1880 XMapWindow (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f));
1883 XFlush (FRAME_W32_DISPLAY (f));
1884 UNBLOCK_INPUT;
1885 #endif
1889 void
1890 x_set_menu_bar_lines (f, value, oldval)
1891 struct frame *f;
1892 Lisp_Object value, oldval;
1894 int nlines;
1895 int olines = FRAME_MENU_BAR_LINES (f);
1897 /* Right now, menu bars don't work properly in minibuf-only frames;
1898 most of the commands try to apply themselves to the minibuffer
1899 frame itself, and get an error because you can't switch buffers
1900 in or split the minibuffer window. */
1901 if (FRAME_MINIBUF_ONLY_P (f))
1902 return;
1904 if (INTEGERP (value))
1905 nlines = XINT (value);
1906 else
1907 nlines = 0;
1909 FRAME_MENU_BAR_LINES (f) = 0;
1910 if (nlines)
1911 FRAME_EXTERNAL_MENU_BAR (f) = 1;
1912 else
1914 if (FRAME_EXTERNAL_MENU_BAR (f) == 1)
1915 free_frame_menubar (f);
1916 FRAME_EXTERNAL_MENU_BAR (f) = 0;
1918 /* Adjust the frame size so that the client (text) dimensions
1919 remain the same. This depends on FRAME_EXTERNAL_MENU_BAR being
1920 set correctly. */
1921 x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f));
1922 do_pending_window_change (0);
1924 adjust_glyphs (f);
1928 /* Set the number of lines used for the tool bar of frame F to VALUE.
1929 VALUE not an integer, or < 0 means set the lines to zero. OLDVAL
1930 is the old number of tool bar lines. This function changes the
1931 height of all windows on frame F to match the new tool bar height.
1932 The frame's height doesn't change. */
1934 void
1935 x_set_tool_bar_lines (f, value, oldval)
1936 struct frame *f;
1937 Lisp_Object value, oldval;
1939 int delta, nlines, root_height;
1940 Lisp_Object root_window;
1942 /* Treat tool bars like menu bars. */
1943 if (FRAME_MINIBUF_ONLY_P (f))
1944 return;
1946 /* Use VALUE only if an integer >= 0. */
1947 if (INTEGERP (value) && XINT (value) >= 0)
1948 nlines = XFASTINT (value);
1949 else
1950 nlines = 0;
1952 /* Make sure we redisplay all windows in this frame. */
1953 ++windows_or_buffers_changed;
1955 delta = nlines - FRAME_TOOL_BAR_LINES (f);
1957 /* Don't resize the tool-bar to more than we have room for. */
1958 root_window = FRAME_ROOT_WINDOW (f);
1959 root_height = XINT (XWINDOW (root_window)->height);
1960 if (root_height - delta < 1)
1962 delta = root_height - 1;
1963 nlines = FRAME_TOOL_BAR_LINES (f) + delta;
1966 FRAME_TOOL_BAR_LINES (f) = nlines;
1967 change_window_heights (root_window, delta);
1968 adjust_glyphs (f);
1970 /* We also have to make sure that the internal border at the top of
1971 the frame, below the menu bar or tool bar, is redrawn when the
1972 tool bar disappears. This is so because the internal border is
1973 below the tool bar if one is displayed, but is below the menu bar
1974 if there isn't a tool bar. The tool bar draws into the area
1975 below the menu bar. */
1976 if (FRAME_W32_WINDOW (f) && FRAME_TOOL_BAR_LINES (f) == 0)
1978 updating_frame = f;
1979 clear_frame ();
1980 clear_current_matrices (f);
1981 updating_frame = NULL;
1984 /* If the tool bar gets smaller, the internal border below it
1985 has to be cleared. It was formerly part of the display
1986 of the larger tool bar, and updating windows won't clear it. */
1987 if (delta < 0)
1989 int height = FRAME_INTERNAL_BORDER_WIDTH (f);
1990 int width = PIXEL_WIDTH (f);
1991 int y = nlines * CANON_Y_UNIT (f);
1993 BLOCK_INPUT;
1995 HDC hdc = get_frame_dc (f);
1996 w32_clear_area (f, hdc, 0, y, width, height);
1997 release_frame_dc (f, hdc);
1999 UNBLOCK_INPUT;
2001 if (WINDOWP (f->tool_bar_window))
2002 clear_glyph_matrix (XWINDOW (f->tool_bar_window)->current_matrix);
2007 /* Change the name of frame F to NAME. If NAME is nil, set F's name to
2008 w32_id_name.
2010 If EXPLICIT is non-zero, that indicates that lisp code is setting the
2011 name; if NAME is a string, set F's name to NAME and set
2012 F->explicit_name; if NAME is Qnil, then clear F->explicit_name.
2014 If EXPLICIT is zero, that indicates that Emacs redisplay code is
2015 suggesting a new name, which lisp code should override; if
2016 F->explicit_name is set, ignore the new name; otherwise, set it. */
2018 void
2019 x_set_name (f, name, explicit)
2020 struct frame *f;
2021 Lisp_Object name;
2022 int explicit;
2024 /* Make sure that requests from lisp code override requests from
2025 Emacs redisplay code. */
2026 if (explicit)
2028 /* If we're switching from explicit to implicit, we had better
2029 update the mode lines and thereby update the title. */
2030 if (f->explicit_name && NILP (name))
2031 update_mode_lines = 1;
2033 f->explicit_name = ! NILP (name);
2035 else if (f->explicit_name)
2036 return;
2038 /* If NAME is nil, set the name to the w32_id_name. */
2039 if (NILP (name))
2041 /* Check for no change needed in this very common case
2042 before we do any consing. */
2043 if (!strcmp (FRAME_W32_DISPLAY_INFO (f)->w32_id_name,
2044 SDATA (f->name)))
2045 return;
2046 name = build_string (FRAME_W32_DISPLAY_INFO (f)->w32_id_name);
2048 else
2049 CHECK_STRING (name);
2051 /* Don't change the name if it's already NAME. */
2052 if (! NILP (Fstring_equal (name, f->name)))
2053 return;
2055 f->name = name;
2057 /* For setting the frame title, the title parameter should override
2058 the name parameter. */
2059 if (! NILP (f->title))
2060 name = f->title;
2062 if (FRAME_W32_WINDOW (f))
2064 if (STRING_MULTIBYTE (name))
2065 name = ENCODE_SYSTEM (name);
2067 BLOCK_INPUT;
2068 SetWindowText(FRAME_W32_WINDOW (f), SDATA (name));
2069 UNBLOCK_INPUT;
2073 /* This function should be called when the user's lisp code has
2074 specified a name for the frame; the name will override any set by the
2075 redisplay code. */
2076 void
2077 x_explicitly_set_name (f, arg, oldval)
2078 FRAME_PTR f;
2079 Lisp_Object arg, oldval;
2081 x_set_name (f, arg, 1);
2084 /* This function should be called by Emacs redisplay code to set the
2085 name; names set this way will never override names set by the user's
2086 lisp code. */
2087 void
2088 x_implicitly_set_name (f, arg, oldval)
2089 FRAME_PTR f;
2090 Lisp_Object arg, oldval;
2092 x_set_name (f, arg, 0);
2095 /* Change the title of frame F to NAME.
2096 If NAME is nil, use the frame name as the title.
2098 If EXPLICIT is non-zero, that indicates that lisp code is setting the
2099 name; if NAME is a string, set F's name to NAME and set
2100 F->explicit_name; if NAME is Qnil, then clear F->explicit_name.
2102 If EXPLICIT is zero, that indicates that Emacs redisplay code is
2103 suggesting a new name, which lisp code should override; if
2104 F->explicit_name is set, ignore the new name; otherwise, set it. */
2106 void
2107 x_set_title (f, name, old_name)
2108 struct frame *f;
2109 Lisp_Object name, old_name;
2111 /* Don't change the title if it's already NAME. */
2112 if (EQ (name, f->title))
2113 return;
2115 update_mode_lines = 1;
2117 f->title = name;
2119 if (NILP (name))
2120 name = f->name;
2122 if (FRAME_W32_WINDOW (f))
2124 if (STRING_MULTIBYTE (name))
2125 name = ENCODE_SYSTEM (name);
2127 BLOCK_INPUT;
2128 SetWindowText(FRAME_W32_WINDOW (f), SDATA (name));
2129 UNBLOCK_INPUT;
2134 void x_set_scroll_bar_default_width (f)
2135 struct frame *f;
2137 int wid = FONT_WIDTH (f->output_data.w32->font);
2139 FRAME_SCROLL_BAR_PIXEL_WIDTH (f) = GetSystemMetrics (SM_CXVSCROLL);
2140 FRAME_SCROLL_BAR_COLS (f) = (FRAME_SCROLL_BAR_PIXEL_WIDTH (f) +
2141 wid - 1) / wid;
2145 /* Subroutines of creating a frame. */
2148 /* Return the value of parameter PARAM.
2150 First search ALIST, then Vdefault_frame_alist, then the X defaults
2151 database, using ATTRIBUTE as the attribute name and CLASS as its class.
2153 Convert the resource to the type specified by desired_type.
2155 If no default is specified, return Qunbound. If you call
2156 w32_get_arg, make sure you deal with Qunbound in a reasonable way,
2157 and don't let it get stored in any Lisp-visible variables! */
2159 static Lisp_Object
2160 w32_get_arg (alist, param, attribute, class, type)
2161 Lisp_Object alist, param;
2162 char *attribute;
2163 char *class;
2164 enum resource_types type;
2166 return x_get_arg (check_x_display_info (Qnil),
2167 alist, param, attribute, class, type);
2171 Cursor
2172 w32_load_cursor (LPCTSTR name)
2174 /* Try first to load cursor from application resource. */
2175 Cursor cursor = LoadImage ((HINSTANCE) GetModuleHandle(NULL),
2176 name, IMAGE_CURSOR, 0, 0,
2177 LR_DEFAULTCOLOR | LR_DEFAULTSIZE | LR_SHARED);
2178 if (!cursor)
2180 /* Then try to load a shared predefined cursor. */
2181 cursor = LoadImage (NULL, name, IMAGE_CURSOR, 0, 0,
2182 LR_DEFAULTCOLOR | LR_DEFAULTSIZE | LR_SHARED);
2184 return cursor;
2187 extern LRESULT CALLBACK w32_wnd_proc ();
2189 BOOL
2190 w32_init_class (hinst)
2191 HINSTANCE hinst;
2193 WNDCLASS wc;
2195 wc.style = CS_HREDRAW | CS_VREDRAW;
2196 wc.lpfnWndProc = (WNDPROC) w32_wnd_proc;
2197 wc.cbClsExtra = 0;
2198 wc.cbWndExtra = WND_EXTRA_BYTES;
2199 wc.hInstance = hinst;
2200 wc.hIcon = LoadIcon (hinst, EMACS_CLASS);
2201 wc.hCursor = w32_load_cursor (IDC_ARROW);
2202 wc.hbrBackground = NULL; /* GetStockObject (WHITE_BRUSH); */
2203 wc.lpszMenuName = NULL;
2204 wc.lpszClassName = EMACS_CLASS;
2206 return (RegisterClass (&wc));
2209 HWND
2210 w32_createscrollbar (f, bar)
2211 struct frame *f;
2212 struct scroll_bar * bar;
2214 return (CreateWindow ("SCROLLBAR", "", SBS_VERT | WS_CHILD | WS_VISIBLE,
2215 /* Position and size of scroll bar. */
2216 XINT(bar->left) + VERTICAL_SCROLL_BAR_WIDTH_TRIM,
2217 XINT(bar->top),
2218 XINT(bar->width) - VERTICAL_SCROLL_BAR_WIDTH_TRIM * 2,
2219 XINT(bar->height),
2220 FRAME_W32_WINDOW (f),
2221 NULL,
2222 hinst,
2223 NULL));
2226 void
2227 w32_createwindow (f)
2228 struct frame *f;
2230 HWND hwnd;
2231 RECT rect;
2233 rect.left = rect.top = 0;
2234 rect.right = PIXEL_WIDTH (f);
2235 rect.bottom = PIXEL_HEIGHT (f);
2237 AdjustWindowRect (&rect, f->output_data.w32->dwStyle,
2238 FRAME_EXTERNAL_MENU_BAR (f));
2240 /* Do first time app init */
2242 if (!hprevinst)
2244 w32_init_class (hinst);
2247 FRAME_W32_WINDOW (f) = hwnd
2248 = CreateWindow (EMACS_CLASS,
2249 f->namebuf,
2250 f->output_data.w32->dwStyle | WS_CLIPCHILDREN,
2251 f->output_data.w32->left_pos,
2252 f->output_data.w32->top_pos,
2253 rect.right - rect.left,
2254 rect.bottom - rect.top,
2255 NULL,
2256 NULL,
2257 hinst,
2258 NULL);
2260 if (hwnd)
2262 SetWindowLong (hwnd, WND_FONTWIDTH_INDEX, FONT_WIDTH (f->output_data.w32->font));
2263 SetWindowLong (hwnd, WND_LINEHEIGHT_INDEX, f->output_data.w32->line_height);
2264 SetWindowLong (hwnd, WND_BORDER_INDEX, f->output_data.w32->internal_border_width);
2265 SetWindowLong (hwnd, WND_SCROLLBAR_INDEX, f->output_data.w32->vertical_scroll_bar_extra);
2266 SetWindowLong (hwnd, WND_BACKGROUND_INDEX, FRAME_BACKGROUND_PIXEL (f));
2268 /* Enable drag-n-drop. */
2269 DragAcceptFiles (hwnd, TRUE);
2271 /* Do this to discard the default setting specified by our parent. */
2272 ShowWindow (hwnd, SW_HIDE);
2276 void
2277 my_post_msg (wmsg, hwnd, msg, wParam, lParam)
2278 W32Msg * wmsg;
2279 HWND hwnd;
2280 UINT msg;
2281 WPARAM wParam;
2282 LPARAM lParam;
2284 wmsg->msg.hwnd = hwnd;
2285 wmsg->msg.message = msg;
2286 wmsg->msg.wParam = wParam;
2287 wmsg->msg.lParam = lParam;
2288 wmsg->msg.time = GetMessageTime ();
2290 post_msg (wmsg);
2293 /* GetKeyState and MapVirtualKey on Windows 95 do not actually distinguish
2294 between left and right keys as advertised. We test for this
2295 support dynamically, and set a flag when the support is absent. If
2296 absent, we keep track of the left and right control and alt keys
2297 ourselves. This is particularly necessary on keyboards that rely
2298 upon the AltGr key, which is represented as having the left control
2299 and right alt keys pressed. For these keyboards, we need to know
2300 when the left alt key has been pressed in addition to the AltGr key
2301 so that we can properly support M-AltGr-key sequences (such as M-@
2302 on Swedish keyboards). */
2304 #define EMACS_LCONTROL 0
2305 #define EMACS_RCONTROL 1
2306 #define EMACS_LMENU 2
2307 #define EMACS_RMENU 3
2309 static int modifiers[4];
2310 static int modifiers_recorded;
2311 static int modifier_key_support_tested;
2313 static void
2314 test_modifier_support (unsigned int wparam)
2316 unsigned int l, r;
2318 if (wparam != VK_CONTROL && wparam != VK_MENU)
2319 return;
2320 if (wparam == VK_CONTROL)
2322 l = VK_LCONTROL;
2323 r = VK_RCONTROL;
2325 else
2327 l = VK_LMENU;
2328 r = VK_RMENU;
2330 if (!(GetKeyState (l) & 0x8000) && !(GetKeyState (r) & 0x8000))
2331 modifiers_recorded = 1;
2332 else
2333 modifiers_recorded = 0;
2334 modifier_key_support_tested = 1;
2337 static void
2338 record_keydown (unsigned int wparam, unsigned int lparam)
2340 int i;
2342 if (!modifier_key_support_tested)
2343 test_modifier_support (wparam);
2345 if ((wparam != VK_CONTROL && wparam != VK_MENU) || !modifiers_recorded)
2346 return;
2348 if (wparam == VK_CONTROL)
2349 i = (lparam & 0x1000000) ? EMACS_RCONTROL : EMACS_LCONTROL;
2350 else
2351 i = (lparam & 0x1000000) ? EMACS_RMENU : EMACS_LMENU;
2353 modifiers[i] = 1;
2356 static void
2357 record_keyup (unsigned int wparam, unsigned int lparam)
2359 int i;
2361 if ((wparam != VK_CONTROL && wparam != VK_MENU) || !modifiers_recorded)
2362 return;
2364 if (wparam == VK_CONTROL)
2365 i = (lparam & 0x1000000) ? EMACS_RCONTROL : EMACS_LCONTROL;
2366 else
2367 i = (lparam & 0x1000000) ? EMACS_RMENU : EMACS_LMENU;
2369 modifiers[i] = 0;
2372 /* Emacs can lose focus while a modifier key has been pressed. When
2373 it regains focus, be conservative and clear all modifiers since
2374 we cannot reconstruct the left and right modifier state. */
2375 static void
2376 reset_modifiers ()
2378 SHORT ctrl, alt;
2380 if (GetFocus () == NULL)
2381 /* Emacs doesn't have keyboard focus. Do nothing. */
2382 return;
2384 ctrl = GetAsyncKeyState (VK_CONTROL);
2385 alt = GetAsyncKeyState (VK_MENU);
2387 if (!(ctrl & 0x08000))
2388 /* Clear any recorded control modifier state. */
2389 modifiers[EMACS_RCONTROL] = modifiers[EMACS_LCONTROL] = 0;
2391 if (!(alt & 0x08000))
2392 /* Clear any recorded alt modifier state. */
2393 modifiers[EMACS_RMENU] = modifiers[EMACS_LMENU] = 0;
2395 /* Update the state of all modifier keys, because modifiers used in
2396 hot-key combinations can get stuck on if Emacs loses focus as a
2397 result of a hot-key being pressed. */
2399 BYTE keystate[256];
2401 #define CURRENT_STATE(key) ((GetAsyncKeyState (key) & 0x8000) >> 8)
2403 GetKeyboardState (keystate);
2404 keystate[VK_SHIFT] = CURRENT_STATE (VK_SHIFT);
2405 keystate[VK_CONTROL] = CURRENT_STATE (VK_CONTROL);
2406 keystate[VK_LCONTROL] = CURRENT_STATE (VK_LCONTROL);
2407 keystate[VK_RCONTROL] = CURRENT_STATE (VK_RCONTROL);
2408 keystate[VK_MENU] = CURRENT_STATE (VK_MENU);
2409 keystate[VK_LMENU] = CURRENT_STATE (VK_LMENU);
2410 keystate[VK_RMENU] = CURRENT_STATE (VK_RMENU);
2411 keystate[VK_LWIN] = CURRENT_STATE (VK_LWIN);
2412 keystate[VK_RWIN] = CURRENT_STATE (VK_RWIN);
2413 keystate[VK_APPS] = CURRENT_STATE (VK_APPS);
2414 SetKeyboardState (keystate);
2418 /* Synchronize modifier state with what is reported with the current
2419 keystroke. Even if we cannot distinguish between left and right
2420 modifier keys, we know that, if no modifiers are set, then neither
2421 the left or right modifier should be set. */
2422 static void
2423 sync_modifiers ()
2425 if (!modifiers_recorded)
2426 return;
2428 if (!(GetKeyState (VK_CONTROL) & 0x8000))
2429 modifiers[EMACS_RCONTROL] = modifiers[EMACS_LCONTROL] = 0;
2431 if (!(GetKeyState (VK_MENU) & 0x8000))
2432 modifiers[EMACS_RMENU] = modifiers[EMACS_LMENU] = 0;
2435 static int
2436 modifier_set (int vkey)
2438 if (vkey == VK_CAPITAL || vkey == VK_SCROLL)
2439 return (GetKeyState (vkey) & 0x1);
2440 if (!modifiers_recorded)
2441 return (GetKeyState (vkey) & 0x8000);
2443 switch (vkey)
2445 case VK_LCONTROL:
2446 return modifiers[EMACS_LCONTROL];
2447 case VK_RCONTROL:
2448 return modifiers[EMACS_RCONTROL];
2449 case VK_LMENU:
2450 return modifiers[EMACS_LMENU];
2451 case VK_RMENU:
2452 return modifiers[EMACS_RMENU];
2454 return (GetKeyState (vkey) & 0x8000);
2457 /* Convert between the modifier bits W32 uses and the modifier bits
2458 Emacs uses. */
2460 unsigned int
2461 w32_key_to_modifier (int key)
2463 Lisp_Object key_mapping;
2465 switch (key)
2467 case VK_LWIN:
2468 key_mapping = Vw32_lwindow_modifier;
2469 break;
2470 case VK_RWIN:
2471 key_mapping = Vw32_rwindow_modifier;
2472 break;
2473 case VK_APPS:
2474 key_mapping = Vw32_apps_modifier;
2475 break;
2476 case VK_SCROLL:
2477 key_mapping = Vw32_scroll_lock_modifier;
2478 break;
2479 default:
2480 key_mapping = Qnil;
2483 /* NB. This code runs in the input thread, asychronously to the lisp
2484 thread, so we must be careful to ensure access to lisp data is
2485 thread-safe. The following code is safe because the modifier
2486 variable values are updated atomically from lisp and symbols are
2487 not relocated by GC. Also, we don't have to worry about seeing GC
2488 markbits here. */
2489 if (EQ (key_mapping, Qhyper))
2490 return hyper_modifier;
2491 if (EQ (key_mapping, Qsuper))
2492 return super_modifier;
2493 if (EQ (key_mapping, Qmeta))
2494 return meta_modifier;
2495 if (EQ (key_mapping, Qalt))
2496 return alt_modifier;
2497 if (EQ (key_mapping, Qctrl))
2498 return ctrl_modifier;
2499 if (EQ (key_mapping, Qcontrol)) /* synonym for ctrl */
2500 return ctrl_modifier;
2501 if (EQ (key_mapping, Qshift))
2502 return shift_modifier;
2504 /* Don't generate any modifier if not explicitly requested. */
2505 return 0;
2508 unsigned int
2509 w32_get_modifiers ()
2511 return ((modifier_set (VK_SHIFT) ? shift_modifier : 0) |
2512 (modifier_set (VK_CONTROL) ? ctrl_modifier : 0) |
2513 (modifier_set (VK_LWIN) ? w32_key_to_modifier (VK_LWIN) : 0) |
2514 (modifier_set (VK_RWIN) ? w32_key_to_modifier (VK_RWIN) : 0) |
2515 (modifier_set (VK_APPS) ? w32_key_to_modifier (VK_APPS) : 0) |
2516 (modifier_set (VK_SCROLL) ? w32_key_to_modifier (VK_SCROLL) : 0) |
2517 (modifier_set (VK_MENU) ?
2518 ((NILP (Vw32_alt_is_meta)) ? alt_modifier : meta_modifier) : 0));
2521 /* We map the VK_* modifiers into console modifier constants
2522 so that we can use the same routines to handle both console
2523 and window input. */
2525 static int
2526 construct_console_modifiers ()
2528 int mods;
2530 mods = 0;
2531 mods |= (modifier_set (VK_SHIFT)) ? SHIFT_PRESSED : 0;
2532 mods |= (modifier_set (VK_CAPITAL)) ? CAPSLOCK_ON : 0;
2533 mods |= (modifier_set (VK_SCROLL)) ? SCROLLLOCK_ON : 0;
2534 mods |= (modifier_set (VK_NUMLOCK)) ? NUMLOCK_ON : 0;
2535 mods |= (modifier_set (VK_LCONTROL)) ? LEFT_CTRL_PRESSED : 0;
2536 mods |= (modifier_set (VK_RCONTROL)) ? RIGHT_CTRL_PRESSED : 0;
2537 mods |= (modifier_set (VK_LMENU)) ? LEFT_ALT_PRESSED : 0;
2538 mods |= (modifier_set (VK_RMENU)) ? RIGHT_ALT_PRESSED : 0;
2539 mods |= (modifier_set (VK_LWIN)) ? LEFT_WIN_PRESSED : 0;
2540 mods |= (modifier_set (VK_RWIN)) ? RIGHT_WIN_PRESSED : 0;
2541 mods |= (modifier_set (VK_APPS)) ? APPS_PRESSED : 0;
2543 return mods;
2546 static int
2547 w32_get_key_modifiers (unsigned int wparam, unsigned int lparam)
2549 int mods;
2551 /* Convert to emacs modifiers. */
2552 mods = w32_kbd_mods_to_emacs (construct_console_modifiers (), wparam);
2554 return mods;
2557 unsigned int
2558 map_keypad_keys (unsigned int virt_key, unsigned int extended)
2560 if (virt_key < VK_CLEAR || virt_key > VK_DELETE)
2561 return virt_key;
2563 if (virt_key == VK_RETURN)
2564 return (extended ? VK_NUMPAD_ENTER : VK_RETURN);
2566 if (virt_key >= VK_PRIOR && virt_key <= VK_DOWN)
2567 return (!extended ? (VK_NUMPAD_PRIOR + (virt_key - VK_PRIOR)) : virt_key);
2569 if (virt_key == VK_INSERT || virt_key == VK_DELETE)
2570 return (!extended ? (VK_NUMPAD_INSERT + (virt_key - VK_INSERT)) : virt_key);
2572 if (virt_key == VK_CLEAR)
2573 return (!extended ? VK_NUMPAD_CLEAR : virt_key);
2575 return virt_key;
2578 /* List of special key combinations which w32 would normally capture,
2579 but emacs should grab instead. Not directly visible to lisp, to
2580 simplify synchronization. Each item is an integer encoding a virtual
2581 key code and modifier combination to capture. */
2582 Lisp_Object w32_grabbed_keys;
2584 #define HOTKEY(vk,mods) make_number (((vk) & 255) | ((mods) << 8))
2585 #define HOTKEY_ID(k) (XFASTINT (k) & 0xbfff)
2586 #define HOTKEY_VK_CODE(k) (XFASTINT (k) & 255)
2587 #define HOTKEY_MODIFIERS(k) (XFASTINT (k) >> 8)
2589 /* Register hot-keys for reserved key combinations when Emacs has
2590 keyboard focus, since this is the only way Emacs can receive key
2591 combinations like Alt-Tab which are used by the system. */
2593 static void
2594 register_hot_keys (hwnd)
2595 HWND hwnd;
2597 Lisp_Object keylist;
2599 /* Use GC_CONSP, since we are called asynchronously. */
2600 for (keylist = w32_grabbed_keys; GC_CONSP (keylist); keylist = XCDR (keylist))
2602 Lisp_Object key = XCAR (keylist);
2604 /* Deleted entries get set to nil. */
2605 if (!INTEGERP (key))
2606 continue;
2608 RegisterHotKey (hwnd, HOTKEY_ID (key),
2609 HOTKEY_MODIFIERS (key), HOTKEY_VK_CODE (key));
2613 static void
2614 unregister_hot_keys (hwnd)
2615 HWND hwnd;
2617 Lisp_Object keylist;
2619 /* Use GC_CONSP, since we are called asynchronously. */
2620 for (keylist = w32_grabbed_keys; GC_CONSP (keylist); keylist = XCDR (keylist))
2622 Lisp_Object key = XCAR (keylist);
2624 if (!INTEGERP (key))
2625 continue;
2627 UnregisterHotKey (hwnd, HOTKEY_ID (key));
2631 /* Main message dispatch loop. */
2633 static void
2634 w32_msg_pump (deferred_msg * msg_buf)
2636 MSG msg;
2637 int result;
2638 HWND focus_window;
2640 msh_mousewheel = RegisterWindowMessage (MSH_MOUSEWHEEL);
2642 while (GetMessage (&msg, NULL, 0, 0))
2644 if (msg.hwnd == NULL)
2646 switch (msg.message)
2648 case WM_NULL:
2649 /* Produced by complete_deferred_msg; just ignore. */
2650 break;
2651 case WM_EMACS_CREATEWINDOW:
2652 w32_createwindow ((struct frame *) msg.wParam);
2653 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
2654 abort ();
2655 break;
2656 case WM_EMACS_SETLOCALE:
2657 SetThreadLocale (msg.wParam);
2658 /* Reply is not expected. */
2659 break;
2660 case WM_EMACS_SETKEYBOARDLAYOUT:
2661 result = (int) ActivateKeyboardLayout ((HKL) msg.wParam, 0);
2662 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE,
2663 result, 0))
2664 abort ();
2665 break;
2666 case WM_EMACS_REGISTER_HOT_KEY:
2667 focus_window = GetFocus ();
2668 if (focus_window != NULL)
2669 RegisterHotKey (focus_window,
2670 HOTKEY_ID (msg.wParam),
2671 HOTKEY_MODIFIERS (msg.wParam),
2672 HOTKEY_VK_CODE (msg.wParam));
2673 /* Reply is not expected. */
2674 break;
2675 case WM_EMACS_UNREGISTER_HOT_KEY:
2676 focus_window = GetFocus ();
2677 if (focus_window != NULL)
2678 UnregisterHotKey (focus_window, HOTKEY_ID (msg.wParam));
2679 /* Mark item as erased. NB: this code must be
2680 thread-safe. The next line is okay because the cons
2681 cell is never made into garbage and is not relocated by
2682 GC. */
2683 XSETCAR ((Lisp_Object) msg.lParam, Qnil);
2684 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
2685 abort ();
2686 break;
2687 case WM_EMACS_TOGGLE_LOCK_KEY:
2689 int vk_code = (int) msg.wParam;
2690 int cur_state = (GetKeyState (vk_code) & 1);
2691 Lisp_Object new_state = (Lisp_Object) msg.lParam;
2693 /* NB: This code must be thread-safe. It is safe to
2694 call NILP because symbols are not relocated by GC,
2695 and pointer here is not touched by GC (so the markbit
2696 can't be set). Numbers are safe because they are
2697 immediate values. */
2698 if (NILP (new_state)
2699 || (NUMBERP (new_state)
2700 && ((XUINT (new_state)) & 1) != cur_state))
2702 one_w32_display_info.faked_key = vk_code;
2704 keybd_event ((BYTE) vk_code,
2705 (BYTE) MapVirtualKey (vk_code, 0),
2706 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
2707 keybd_event ((BYTE) vk_code,
2708 (BYTE) MapVirtualKey (vk_code, 0),
2709 KEYEVENTF_EXTENDEDKEY | 0, 0);
2710 keybd_event ((BYTE) vk_code,
2711 (BYTE) MapVirtualKey (vk_code, 0),
2712 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
2713 cur_state = !cur_state;
2715 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE,
2716 cur_state, 0))
2717 abort ();
2719 break;
2720 default:
2721 DebPrint (("msg %x not expected by w32_msg_pump\n", msg.message));
2724 else
2726 DispatchMessage (&msg);
2729 /* Exit nested loop when our deferred message has completed. */
2730 if (msg_buf->completed)
2731 break;
2735 deferred_msg * deferred_msg_head;
2737 static deferred_msg *
2738 find_deferred_msg (HWND hwnd, UINT msg)
2740 deferred_msg * item;
2742 /* Don't actually need synchronization for read access, since
2743 modification of single pointer is always atomic. */
2744 /* enter_crit (); */
2746 for (item = deferred_msg_head; item != NULL; item = item->next)
2747 if (item->w32msg.msg.hwnd == hwnd
2748 && item->w32msg.msg.message == msg)
2749 break;
2751 /* leave_crit (); */
2753 return item;
2756 static LRESULT
2757 send_deferred_msg (deferred_msg * msg_buf,
2758 HWND hwnd,
2759 UINT msg,
2760 WPARAM wParam,
2761 LPARAM lParam)
2763 /* Only input thread can send deferred messages. */
2764 if (GetCurrentThreadId () != dwWindowsThreadId)
2765 abort ();
2767 /* It is an error to send a message that is already deferred. */
2768 if (find_deferred_msg (hwnd, msg) != NULL)
2769 abort ();
2771 /* Enforced synchronization is not needed because this is the only
2772 function that alters deferred_msg_head, and the following critical
2773 section is guaranteed to only be serially reentered (since only the
2774 input thread can call us). */
2776 /* enter_crit (); */
2778 msg_buf->completed = 0;
2779 msg_buf->next = deferred_msg_head;
2780 deferred_msg_head = msg_buf;
2781 my_post_msg (&msg_buf->w32msg, hwnd, msg, wParam, lParam);
2783 /* leave_crit (); */
2785 /* Start a new nested message loop to process other messages until
2786 this one is completed. */
2787 w32_msg_pump (msg_buf);
2789 deferred_msg_head = msg_buf->next;
2791 return msg_buf->result;
2794 void
2795 complete_deferred_msg (HWND hwnd, UINT msg, LRESULT result)
2797 deferred_msg * msg_buf = find_deferred_msg (hwnd, msg);
2799 if (msg_buf == NULL)
2800 /* Message may have been cancelled, so don't abort(). */
2801 return;
2803 msg_buf->result = result;
2804 msg_buf->completed = 1;
2806 /* Ensure input thread is woken so it notices the completion. */
2807 PostThreadMessage (dwWindowsThreadId, WM_NULL, 0, 0);
2810 void
2811 cancel_all_deferred_msgs ()
2813 deferred_msg * item;
2815 /* Don't actually need synchronization for read access, since
2816 modification of single pointer is always atomic. */
2817 /* enter_crit (); */
2819 for (item = deferred_msg_head; item != NULL; item = item->next)
2821 item->result = 0;
2822 item->completed = 1;
2825 /* leave_crit (); */
2827 /* Ensure input thread is woken so it notices the completion. */
2828 PostThreadMessage (dwWindowsThreadId, WM_NULL, 0, 0);
2831 DWORD
2832 w32_msg_worker (dw)
2833 DWORD dw;
2835 MSG msg;
2836 deferred_msg dummy_buf;
2838 /* Ensure our message queue is created */
2840 PeekMessage (&msg, NULL, 0, 0, PM_NOREMOVE);
2842 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
2843 abort ();
2845 memset (&dummy_buf, 0, sizeof (dummy_buf));
2846 dummy_buf.w32msg.msg.hwnd = NULL;
2847 dummy_buf.w32msg.msg.message = WM_NULL;
2849 /* This is the inital message loop which should only exit when the
2850 application quits. */
2851 w32_msg_pump (&dummy_buf);
2853 return 0;
2856 static void
2857 post_character_message (hwnd, msg, wParam, lParam, modifiers)
2858 HWND hwnd;
2859 UINT msg;
2860 WPARAM wParam;
2861 LPARAM lParam;
2862 DWORD modifiers;
2865 W32Msg wmsg;
2867 wmsg.dwModifiers = modifiers;
2869 /* Detect quit_char and set quit-flag directly. Note that we
2870 still need to post a message to ensure the main thread will be
2871 woken up if blocked in sys_select(), but we do NOT want to post
2872 the quit_char message itself (because it will usually be as if
2873 the user had typed quit_char twice). Instead, we post a dummy
2874 message that has no particular effect. */
2876 int c = wParam;
2877 if (isalpha (c) && wmsg.dwModifiers == ctrl_modifier)
2878 c = make_ctrl_char (c) & 0377;
2879 if (c == quit_char
2880 || (wmsg.dwModifiers == 0 &&
2881 XFASTINT (Vw32_quit_key) && wParam == XFASTINT (Vw32_quit_key)))
2883 Vquit_flag = Qt;
2885 /* The choice of message is somewhat arbitrary, as long as
2886 the main thread handler just ignores it. */
2887 msg = WM_NULL;
2889 /* Interrupt any blocking system calls. */
2890 signal_quit ();
2892 /* As a safety precaution, forcibly complete any deferred
2893 messages. This is a kludge, but I don't see any particularly
2894 clean way to handle the situation where a deferred message is
2895 "dropped" in the lisp thread, and will thus never be
2896 completed, eg. by the user trying to activate the menubar
2897 when the lisp thread is busy, and then typing C-g when the
2898 menubar doesn't open promptly (with the result that the
2899 menubar never responds at all because the deferred
2900 WM_INITMENU message is never completed). Another problem
2901 situation is when the lisp thread calls SendMessage (to send
2902 a window manager command) when a message has been deferred;
2903 the lisp thread gets blocked indefinitely waiting for the
2904 deferred message to be completed, which itself is waiting for
2905 the lisp thread to respond.
2907 Note that we don't want to block the input thread waiting for
2908 a reponse from the lisp thread (although that would at least
2909 solve the deadlock problem above), because we want to be able
2910 to receive C-g to interrupt the lisp thread. */
2911 cancel_all_deferred_msgs ();
2915 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
2918 /* Main window procedure */
2920 LRESULT CALLBACK
2921 w32_wnd_proc (hwnd, msg, wParam, lParam)
2922 HWND hwnd;
2923 UINT msg;
2924 WPARAM wParam;
2925 LPARAM lParam;
2927 struct frame *f;
2928 struct w32_display_info *dpyinfo = &one_w32_display_info;
2929 W32Msg wmsg;
2930 int windows_translate;
2931 int key;
2933 /* Note that it is okay to call x_window_to_frame, even though we are
2934 not running in the main lisp thread, because frame deletion
2935 requires the lisp thread to synchronize with this thread. Thus, if
2936 a frame struct is returned, it can be used without concern that the
2937 lisp thread might make it disappear while we are using it.
2939 NB. Walking the frame list in this thread is safe (as long as
2940 writes of Lisp_Object slots are atomic, which they are on Windows).
2941 Although delete-frame can destructively modify the frame list while
2942 we are walking it, a garbage collection cannot occur until after
2943 delete-frame has synchronized with this thread.
2945 It is also safe to use functions that make GDI calls, such as
2946 w32_clear_rect, because these functions must obtain a DC handle
2947 from the frame struct using get_frame_dc which is thread-aware. */
2949 switch (msg)
2951 case WM_ERASEBKGND:
2952 f = x_window_to_frame (dpyinfo, hwnd);
2953 if (f)
2955 HDC hdc = get_frame_dc (f);
2956 GetUpdateRect (hwnd, &wmsg.rect, FALSE);
2957 w32_clear_rect (f, hdc, &wmsg.rect);
2958 release_frame_dc (f, hdc);
2960 #if defined (W32_DEBUG_DISPLAY)
2961 DebPrint (("WM_ERASEBKGND (frame %p): erasing %d,%d-%d,%d\n",
2963 wmsg.rect.left, wmsg.rect.top,
2964 wmsg.rect.right, wmsg.rect.bottom));
2965 #endif /* W32_DEBUG_DISPLAY */
2967 return 1;
2968 case WM_PALETTECHANGED:
2969 /* ignore our own changes */
2970 if ((HWND)wParam != hwnd)
2972 f = x_window_to_frame (dpyinfo, hwnd);
2973 if (f)
2974 /* get_frame_dc will realize our palette and force all
2975 frames to be redrawn if needed. */
2976 release_frame_dc (f, get_frame_dc (f));
2978 return 0;
2979 case WM_PAINT:
2981 PAINTSTRUCT paintStruct;
2982 RECT update_rect;
2983 bzero (&update_rect, sizeof (update_rect));
2985 f = x_window_to_frame (dpyinfo, hwnd);
2986 if (f == 0)
2988 DebPrint (("WM_PAINT received for unknown window %p\n", hwnd));
2989 return 0;
2992 /* MSDN Docs say not to call BeginPaint if GetUpdateRect
2993 fails. Apparently this can happen under some
2994 circumstances. */
2995 if (GetUpdateRect (hwnd, &update_rect, FALSE) || !w32_strict_painting)
2997 enter_crit ();
2998 BeginPaint (hwnd, &paintStruct);
3000 /* The rectangles returned by GetUpdateRect and BeginPaint
3001 do not always match. Play it safe by assuming both areas
3002 are invalid. */
3003 UnionRect (&(wmsg.rect), &update_rect, &(paintStruct.rcPaint));
3005 #if defined (W32_DEBUG_DISPLAY)
3006 DebPrint (("WM_PAINT (frame %p): painting %d,%d-%d,%d\n",
3008 wmsg.rect.left, wmsg.rect.top,
3009 wmsg.rect.right, wmsg.rect.bottom));
3010 DebPrint ((" [update region is %d,%d-%d,%d]\n",
3011 update_rect.left, update_rect.top,
3012 update_rect.right, update_rect.bottom));
3013 #endif
3014 EndPaint (hwnd, &paintStruct);
3015 leave_crit ();
3017 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3019 return 0;
3022 /* If GetUpdateRect returns 0 (meaning there is no update
3023 region), assume the whole window needs to be repainted. */
3024 GetClientRect(hwnd, &wmsg.rect);
3025 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3026 return 0;
3029 case WM_INPUTLANGCHANGE:
3030 /* Inform lisp thread of keyboard layout changes. */
3031 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3033 /* Clear dead keys in the keyboard state; for simplicity only
3034 preserve modifier key states. */
3036 int i;
3037 BYTE keystate[256];
3039 GetKeyboardState (keystate);
3040 for (i = 0; i < 256; i++)
3041 if (1
3042 && i != VK_SHIFT
3043 && i != VK_LSHIFT
3044 && i != VK_RSHIFT
3045 && i != VK_CAPITAL
3046 && i != VK_NUMLOCK
3047 && i != VK_SCROLL
3048 && i != VK_CONTROL
3049 && i != VK_LCONTROL
3050 && i != VK_RCONTROL
3051 && i != VK_MENU
3052 && i != VK_LMENU
3053 && i != VK_RMENU
3054 && i != VK_LWIN
3055 && i != VK_RWIN)
3056 keystate[i] = 0;
3057 SetKeyboardState (keystate);
3059 goto dflt;
3061 case WM_HOTKEY:
3062 /* Synchronize hot keys with normal input. */
3063 PostMessage (hwnd, WM_KEYDOWN, HIWORD (lParam), 0);
3064 return (0);
3066 case WM_KEYUP:
3067 case WM_SYSKEYUP:
3068 record_keyup (wParam, lParam);
3069 goto dflt;
3071 case WM_KEYDOWN:
3072 case WM_SYSKEYDOWN:
3073 /* Ignore keystrokes we fake ourself; see below. */
3074 if (dpyinfo->faked_key == wParam)
3076 dpyinfo->faked_key = 0;
3077 /* Make sure TranslateMessage sees them though (as long as
3078 they don't produce WM_CHAR messages). This ensures that
3079 indicator lights are toggled promptly on Windows 9x, for
3080 example. */
3081 if (lispy_function_keys[wParam] != 0)
3083 windows_translate = 1;
3084 goto translate;
3086 return 0;
3089 /* Synchronize modifiers with current keystroke. */
3090 sync_modifiers ();
3091 record_keydown (wParam, lParam);
3092 wParam = map_keypad_keys (wParam, (lParam & 0x1000000L) != 0);
3094 windows_translate = 0;
3096 switch (wParam)
3098 case VK_LWIN:
3099 if (NILP (Vw32_pass_lwindow_to_system))
3101 /* Prevent system from acting on keyup (which opens the
3102 Start menu if no other key was pressed) by simulating a
3103 press of Space which we will ignore. */
3104 if (GetAsyncKeyState (wParam) & 1)
3106 if (NUMBERP (Vw32_phantom_key_code))
3107 key = XUINT (Vw32_phantom_key_code) & 255;
3108 else
3109 key = VK_SPACE;
3110 dpyinfo->faked_key = key;
3111 keybd_event (key, (BYTE) MapVirtualKey (key, 0), 0, 0);
3114 if (!NILP (Vw32_lwindow_modifier))
3115 return 0;
3116 break;
3117 case VK_RWIN:
3118 if (NILP (Vw32_pass_rwindow_to_system))
3120 if (GetAsyncKeyState (wParam) & 1)
3122 if (NUMBERP (Vw32_phantom_key_code))
3123 key = XUINT (Vw32_phantom_key_code) & 255;
3124 else
3125 key = VK_SPACE;
3126 dpyinfo->faked_key = key;
3127 keybd_event (key, (BYTE) MapVirtualKey (key, 0), 0, 0);
3130 if (!NILP (Vw32_rwindow_modifier))
3131 return 0;
3132 break;
3133 case VK_APPS:
3134 if (!NILP (Vw32_apps_modifier))
3135 return 0;
3136 break;
3137 case VK_MENU:
3138 if (NILP (Vw32_pass_alt_to_system))
3139 /* Prevent DefWindowProc from activating the menu bar if an
3140 Alt key is pressed and released by itself. */
3141 return 0;
3142 windows_translate = 1;
3143 break;
3144 case VK_CAPITAL:
3145 /* Decide whether to treat as modifier or function key. */
3146 if (NILP (Vw32_enable_caps_lock))
3147 goto disable_lock_key;
3148 windows_translate = 1;
3149 break;
3150 case VK_NUMLOCK:
3151 /* Decide whether to treat as modifier or function key. */
3152 if (NILP (Vw32_enable_num_lock))
3153 goto disable_lock_key;
3154 windows_translate = 1;
3155 break;
3156 case VK_SCROLL:
3157 /* Decide whether to treat as modifier or function key. */
3158 if (NILP (Vw32_scroll_lock_modifier))
3159 goto disable_lock_key;
3160 windows_translate = 1;
3161 break;
3162 disable_lock_key:
3163 /* Ensure the appropriate lock key state (and indicator light)
3164 remains in the same state. We do this by faking another
3165 press of the relevant key. Apparently, this really is the
3166 only way to toggle the state of the indicator lights. */
3167 dpyinfo->faked_key = wParam;
3168 keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0),
3169 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
3170 keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0),
3171 KEYEVENTF_EXTENDEDKEY | 0, 0);
3172 keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0),
3173 KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);
3174 /* Ensure indicator lights are updated promptly on Windows 9x
3175 (TranslateMessage apparently does this), after forwarding
3176 input event. */
3177 post_character_message (hwnd, msg, wParam, lParam,
3178 w32_get_key_modifiers (wParam, lParam));
3179 windows_translate = 1;
3180 break;
3181 case VK_CONTROL:
3182 case VK_SHIFT:
3183 case VK_PROCESSKEY: /* Generated by IME. */
3184 windows_translate = 1;
3185 break;
3186 case VK_CANCEL:
3187 /* Windows maps Ctrl-Pause (aka Ctrl-Break) into VK_CANCEL,
3188 which is confusing for purposes of key binding; convert
3189 VK_CANCEL events into VK_PAUSE events. */
3190 wParam = VK_PAUSE;
3191 break;
3192 case VK_PAUSE:
3193 /* Windows maps Ctrl-NumLock into VK_PAUSE, which is confusing
3194 for purposes of key binding; convert these back into
3195 VK_NUMLOCK events, at least when we want to see NumLock key
3196 presses. (Note that there is never any possibility that
3197 VK_PAUSE with Ctrl really is C-Pause as per above.) */
3198 if (NILP (Vw32_enable_num_lock) && modifier_set (VK_CONTROL))
3199 wParam = VK_NUMLOCK;
3200 break;
3201 default:
3202 /* If not defined as a function key, change it to a WM_CHAR message. */
3203 if (lispy_function_keys[wParam] == 0)
3205 DWORD modifiers = construct_console_modifiers ();
3207 if (!NILP (Vw32_recognize_altgr)
3208 && modifier_set (VK_LCONTROL) && modifier_set (VK_RMENU))
3210 /* Always let TranslateMessage handle AltGr key chords;
3211 for some reason, ToAscii doesn't always process AltGr
3212 chords correctly. */
3213 windows_translate = 1;
3215 else if ((modifiers & (~SHIFT_PRESSED & ~CAPSLOCK_ON)) != 0)
3217 /* Handle key chords including any modifiers other
3218 than shift directly, in order to preserve as much
3219 modifier information as possible. */
3220 if ('A' <= wParam && wParam <= 'Z')
3222 /* Don't translate modified alphabetic keystrokes,
3223 so the user doesn't need to constantly switch
3224 layout to type control or meta keystrokes when
3225 the normal layout translates alphabetic
3226 characters to non-ascii characters. */
3227 if (!modifier_set (VK_SHIFT))
3228 wParam += ('a' - 'A');
3229 msg = WM_CHAR;
3231 else
3233 /* Try to handle other keystrokes by determining the
3234 base character (ie. translating the base key plus
3235 shift modifier). */
3236 int add;
3237 int isdead = 0;
3238 KEY_EVENT_RECORD key;
3240 key.bKeyDown = TRUE;
3241 key.wRepeatCount = 1;
3242 key.wVirtualKeyCode = wParam;
3243 key.wVirtualScanCode = (lParam & 0xFF0000) >> 16;
3244 key.uChar.AsciiChar = 0;
3245 key.dwControlKeyState = modifiers;
3247 add = w32_kbd_patch_key (&key);
3248 /* 0 means an unrecognised keycode, negative means
3249 dead key. Ignore both. */
3250 while (--add >= 0)
3252 /* Forward asciified character sequence. */
3253 post_character_message
3254 (hwnd, WM_CHAR, key.uChar.AsciiChar, lParam,
3255 w32_get_key_modifiers (wParam, lParam));
3256 w32_kbd_patch_key (&key);
3258 return 0;
3261 else
3263 /* Let TranslateMessage handle everything else. */
3264 windows_translate = 1;
3269 translate:
3270 if (windows_translate)
3272 MSG windows_msg = { hwnd, msg, wParam, lParam, 0, {0,0} };
3274 windows_msg.time = GetMessageTime ();
3275 TranslateMessage (&windows_msg);
3276 goto dflt;
3279 /* Fall through */
3281 case WM_SYSCHAR:
3282 case WM_CHAR:
3283 post_character_message (hwnd, msg, wParam, lParam,
3284 w32_get_key_modifiers (wParam, lParam));
3285 break;
3287 /* Simulate middle mouse button events when left and right buttons
3288 are used together, but only if user has two button mouse. */
3289 case WM_LBUTTONDOWN:
3290 case WM_RBUTTONDOWN:
3291 if (XINT (Vw32_num_mouse_buttons) > 2)
3292 goto handle_plain_button;
3295 int this = (msg == WM_LBUTTONDOWN) ? LMOUSE : RMOUSE;
3296 int other = (msg == WM_LBUTTONDOWN) ? RMOUSE : LMOUSE;
3298 if (button_state & this)
3299 return 0;
3301 if (button_state == 0)
3302 SetCapture (hwnd);
3304 button_state |= this;
3306 if (button_state & other)
3308 if (mouse_button_timer)
3310 KillTimer (hwnd, mouse_button_timer);
3311 mouse_button_timer = 0;
3313 /* Generate middle mouse event instead. */
3314 msg = WM_MBUTTONDOWN;
3315 button_state |= MMOUSE;
3317 else if (button_state & MMOUSE)
3319 /* Ignore button event if we've already generated a
3320 middle mouse down event. This happens if the
3321 user releases and press one of the two buttons
3322 after we've faked a middle mouse event. */
3323 return 0;
3325 else
3327 /* Flush out saved message. */
3328 post_msg (&saved_mouse_button_msg);
3330 wmsg.dwModifiers = w32_get_modifiers ();
3331 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3333 /* Clear message buffer. */
3334 saved_mouse_button_msg.msg.hwnd = 0;
3336 else
3338 /* Hold onto message for now. */
3339 mouse_button_timer =
3340 SetTimer (hwnd, MOUSE_BUTTON_ID,
3341 XINT (Vw32_mouse_button_tolerance), NULL);
3342 saved_mouse_button_msg.msg.hwnd = hwnd;
3343 saved_mouse_button_msg.msg.message = msg;
3344 saved_mouse_button_msg.msg.wParam = wParam;
3345 saved_mouse_button_msg.msg.lParam = lParam;
3346 saved_mouse_button_msg.msg.time = GetMessageTime ();
3347 saved_mouse_button_msg.dwModifiers = w32_get_modifiers ();
3350 return 0;
3352 case WM_LBUTTONUP:
3353 case WM_RBUTTONUP:
3354 if (XINT (Vw32_num_mouse_buttons) > 2)
3355 goto handle_plain_button;
3358 int this = (msg == WM_LBUTTONUP) ? LMOUSE : RMOUSE;
3359 int other = (msg == WM_LBUTTONUP) ? RMOUSE : LMOUSE;
3361 if ((button_state & this) == 0)
3362 return 0;
3364 button_state &= ~this;
3366 if (button_state & MMOUSE)
3368 /* Only generate event when second button is released. */
3369 if ((button_state & other) == 0)
3371 msg = WM_MBUTTONUP;
3372 button_state &= ~MMOUSE;
3374 if (button_state) abort ();
3376 else
3377 return 0;
3379 else
3381 /* Flush out saved message if necessary. */
3382 if (saved_mouse_button_msg.msg.hwnd)
3384 post_msg (&saved_mouse_button_msg);
3387 wmsg.dwModifiers = w32_get_modifiers ();
3388 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3390 /* Always clear message buffer and cancel timer. */
3391 saved_mouse_button_msg.msg.hwnd = 0;
3392 KillTimer (hwnd, mouse_button_timer);
3393 mouse_button_timer = 0;
3395 if (button_state == 0)
3396 ReleaseCapture ();
3398 return 0;
3400 case WM_XBUTTONDOWN:
3401 case WM_XBUTTONUP:
3402 if (w32_pass_extra_mouse_buttons_to_system)
3403 goto dflt;
3404 /* else fall through and process them. */
3405 case WM_MBUTTONDOWN:
3406 case WM_MBUTTONUP:
3407 handle_plain_button:
3409 BOOL up;
3410 int button;
3412 if (parse_button (msg, HIWORD (wParam), &button, &up))
3414 if (up) ReleaseCapture ();
3415 else SetCapture (hwnd);
3416 button = (button == 0) ? LMOUSE :
3417 ((button == 1) ? MMOUSE : RMOUSE);
3418 if (up)
3419 button_state &= ~button;
3420 else
3421 button_state |= button;
3425 wmsg.dwModifiers = w32_get_modifiers ();
3426 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3428 /* Need to return true for XBUTTON messages, false for others,
3429 to indicate that we processed the message. */
3430 return (msg == WM_XBUTTONDOWN || msg == WM_XBUTTONUP);
3432 case WM_MOUSEMOVE:
3433 /* If the mouse has just moved into the frame, start tracking
3434 it, so we will be notified when it leaves the frame. Mouse
3435 tracking only works under W98 and NT4 and later. On earlier
3436 versions, there is no way of telling when the mouse leaves the
3437 frame, so we just have to put up with help-echo and mouse
3438 highlighting remaining while the frame is not active. */
3439 if (track_mouse_event_fn && !track_mouse_window)
3441 TRACKMOUSEEVENT tme;
3442 tme.cbSize = sizeof (tme);
3443 tme.dwFlags = TME_LEAVE;
3444 tme.hwndTrack = hwnd;
3446 track_mouse_event_fn (&tme);
3447 track_mouse_window = hwnd;
3449 case WM_VSCROLL:
3450 if (XINT (Vw32_mouse_move_interval) <= 0
3451 || (msg == WM_MOUSEMOVE && button_state == 0))
3453 wmsg.dwModifiers = w32_get_modifiers ();
3454 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3455 return 0;
3458 /* Hang onto mouse move and scroll messages for a bit, to avoid
3459 sending such events to Emacs faster than it can process them.
3460 If we get more events before the timer from the first message
3461 expires, we just replace the first message. */
3463 if (saved_mouse_move_msg.msg.hwnd == 0)
3464 mouse_move_timer =
3465 SetTimer (hwnd, MOUSE_MOVE_ID,
3466 XINT (Vw32_mouse_move_interval), NULL);
3468 /* Hold onto message for now. */
3469 saved_mouse_move_msg.msg.hwnd = hwnd;
3470 saved_mouse_move_msg.msg.message = msg;
3471 saved_mouse_move_msg.msg.wParam = wParam;
3472 saved_mouse_move_msg.msg.lParam = lParam;
3473 saved_mouse_move_msg.msg.time = GetMessageTime ();
3474 saved_mouse_move_msg.dwModifiers = w32_get_modifiers ();
3476 return 0;
3478 case WM_MOUSEWHEEL:
3479 wmsg.dwModifiers = w32_get_modifiers ();
3480 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3481 return 0;
3483 case WM_DROPFILES:
3484 wmsg.dwModifiers = w32_get_modifiers ();
3485 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3486 return 0;
3488 case WM_TIMER:
3489 /* Flush out saved messages if necessary. */
3490 if (wParam == mouse_button_timer)
3492 if (saved_mouse_button_msg.msg.hwnd)
3494 post_msg (&saved_mouse_button_msg);
3495 saved_mouse_button_msg.msg.hwnd = 0;
3497 KillTimer (hwnd, mouse_button_timer);
3498 mouse_button_timer = 0;
3500 else if (wParam == mouse_move_timer)
3502 if (saved_mouse_move_msg.msg.hwnd)
3504 post_msg (&saved_mouse_move_msg);
3505 saved_mouse_move_msg.msg.hwnd = 0;
3507 KillTimer (hwnd, mouse_move_timer);
3508 mouse_move_timer = 0;
3510 else if (wParam == menu_free_timer)
3512 KillTimer (hwnd, menu_free_timer);
3513 menu_free_timer = 0;
3514 f = x_window_to_frame (dpyinfo, hwnd);
3515 if (!f->output_data.w32->menu_command_in_progress)
3517 /* Free memory used by owner-drawn and help-echo strings. */
3518 w32_free_menu_strings (hwnd);
3519 f->output_data.w32->menubar_active = 0;
3522 return 0;
3524 case WM_NCACTIVATE:
3525 /* Windows doesn't send us focus messages when putting up and
3526 taking down a system popup dialog as for Ctrl-Alt-Del on Windows 95.
3527 The only indication we get that something happened is receiving
3528 this message afterwards. So this is a good time to reset our
3529 keyboard modifiers' state. */
3530 reset_modifiers ();
3531 goto dflt;
3533 case WM_INITMENU:
3534 button_state = 0;
3535 ReleaseCapture ();
3536 /* We must ensure menu bar is fully constructed and up to date
3537 before allowing user interaction with it. To achieve this
3538 we send this message to the lisp thread and wait for a
3539 reply (whose value is not actually needed) to indicate that
3540 the menu bar is now ready for use, so we can now return.
3542 To remain responsive in the meantime, we enter a nested message
3543 loop that can process all other messages.
3545 However, we skip all this if the message results from calling
3546 TrackPopupMenu - in fact, we must NOT attempt to send the lisp
3547 thread a message because it is blocked on us at this point. We
3548 set menubar_active before calling TrackPopupMenu to indicate
3549 this (there is no possibility of confusion with real menubar
3550 being active). */
3552 f = x_window_to_frame (dpyinfo, hwnd);
3553 if (f
3554 && (f->output_data.w32->menubar_active
3555 /* We can receive this message even in the absence of a
3556 menubar (ie. when the system menu is activated) - in this
3557 case we do NOT want to forward the message, otherwise it
3558 will cause the menubar to suddenly appear when the user
3559 had requested it to be turned off! */
3560 || f->output_data.w32->menubar_widget == NULL))
3561 return 0;
3564 deferred_msg msg_buf;
3566 /* Detect if message has already been deferred; in this case
3567 we cannot return any sensible value to ignore this. */
3568 if (find_deferred_msg (hwnd, msg) != NULL)
3569 abort ();
3571 return send_deferred_msg (&msg_buf, hwnd, msg, wParam, lParam);
3574 case WM_EXITMENULOOP:
3575 f = x_window_to_frame (dpyinfo, hwnd);
3577 /* If a menu command is not already in progress, check again
3578 after a short delay, since Windows often (always?) sends the
3579 WM_EXITMENULOOP before the corresponding WM_COMMAND message. */
3580 if (f && !f->output_data.w32->menu_command_in_progress)
3581 menu_free_timer = SetTimer (hwnd, MENU_FREE_ID, MENU_FREE_DELAY, NULL);
3582 goto dflt;
3584 case WM_MENUSELECT:
3585 /* Direct handling of help_echo in menus. Should be safe now
3586 that we generate the help_echo by placing a help event in the
3587 keyboard buffer. */
3589 HMENU menu = (HMENU) lParam;
3590 UINT menu_item = (UINT) LOWORD (wParam);
3591 UINT flags = (UINT) HIWORD (wParam);
3593 w32_menu_display_help (hwnd, menu, menu_item, flags);
3595 return 0;
3597 case WM_MEASUREITEM:
3598 f = x_window_to_frame (dpyinfo, hwnd);
3599 if (f)
3601 MEASUREITEMSTRUCT * pMis = (MEASUREITEMSTRUCT *) lParam;
3603 if (pMis->CtlType == ODT_MENU)
3605 /* Work out dimensions for popup menu titles. */
3606 char * title = (char *) pMis->itemData;
3607 HDC hdc = GetDC (hwnd);
3608 HFONT menu_font = GetCurrentObject (hdc, OBJ_FONT);
3609 LOGFONT menu_logfont;
3610 HFONT old_font;
3611 SIZE size;
3613 GetObject (menu_font, sizeof (menu_logfont), &menu_logfont);
3614 menu_logfont.lfWeight = FW_BOLD;
3615 menu_font = CreateFontIndirect (&menu_logfont);
3616 old_font = SelectObject (hdc, menu_font);
3618 pMis->itemHeight = GetSystemMetrics (SM_CYMENUSIZE);
3619 if (title)
3621 GetTextExtentPoint32 (hdc, title, strlen (title), &size);
3622 pMis->itemWidth = size.cx;
3623 if (pMis->itemHeight < size.cy)
3624 pMis->itemHeight = size.cy;
3626 else
3627 pMis->itemWidth = 0;
3629 SelectObject (hdc, old_font);
3630 DeleteObject (menu_font);
3631 ReleaseDC (hwnd, hdc);
3632 return TRUE;
3635 return 0;
3637 case WM_DRAWITEM:
3638 f = x_window_to_frame (dpyinfo, hwnd);
3639 if (f)
3641 DRAWITEMSTRUCT * pDis = (DRAWITEMSTRUCT *) lParam;
3643 if (pDis->CtlType == ODT_MENU)
3645 /* Draw popup menu title. */
3646 char * title = (char *) pDis->itemData;
3647 if (title)
3649 HDC hdc = pDis->hDC;
3650 HFONT menu_font = GetCurrentObject (hdc, OBJ_FONT);
3651 LOGFONT menu_logfont;
3652 HFONT old_font;
3654 GetObject (menu_font, sizeof (menu_logfont), &menu_logfont);
3655 menu_logfont.lfWeight = FW_BOLD;
3656 menu_font = CreateFontIndirect (&menu_logfont);
3657 old_font = SelectObject (hdc, menu_font);
3659 /* Always draw title as if not selected. */
3660 ExtTextOut (hdc,
3661 pDis->rcItem.left
3662 + GetSystemMetrics (SM_CXMENUCHECK),
3663 pDis->rcItem.top,
3664 ETO_OPAQUE, &pDis->rcItem,
3665 title, strlen (title), NULL);
3667 SelectObject (hdc, old_font);
3668 DeleteObject (menu_font);
3670 return TRUE;
3673 return 0;
3675 #if 0
3676 /* Still not right - can't distinguish between clicks in the
3677 client area of the frame from clicks forwarded from the scroll
3678 bars - may have to hook WM_NCHITTEST to remember the mouse
3679 position and then check if it is in the client area ourselves. */
3680 case WM_MOUSEACTIVATE:
3681 /* Discard the mouse click that activates a frame, allowing the
3682 user to click anywhere without changing point (or worse!).
3683 Don't eat mouse clicks on scrollbars though!! */
3684 if (LOWORD (lParam) == HTCLIENT )
3685 return MA_ACTIVATEANDEAT;
3686 goto dflt;
3687 #endif
3689 case WM_MOUSELEAVE:
3690 /* No longer tracking mouse. */
3691 track_mouse_window = NULL;
3693 case WM_ACTIVATEAPP:
3694 case WM_ACTIVATE:
3695 case WM_WINDOWPOSCHANGED:
3696 case WM_SHOWWINDOW:
3697 /* Inform lisp thread that a frame might have just been obscured
3698 or exposed, so should recheck visibility of all frames. */
3699 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3700 goto dflt;
3702 case WM_SETFOCUS:
3703 dpyinfo->faked_key = 0;
3704 reset_modifiers ();
3705 register_hot_keys (hwnd);
3706 goto command;
3707 case WM_KILLFOCUS:
3708 unregister_hot_keys (hwnd);
3709 button_state = 0;
3710 ReleaseCapture ();
3711 /* Relinquish the system caret. */
3712 if (w32_system_caret_hwnd)
3714 w32_visible_system_caret_hwnd = NULL;
3715 w32_system_caret_hwnd = NULL;
3716 DestroyCaret ();
3718 goto command;
3719 case WM_COMMAND:
3720 f = x_window_to_frame (dpyinfo, hwnd);
3721 if (f && HIWORD (wParam) == 0)
3723 f->output_data.w32->menu_command_in_progress = 1;
3724 if (menu_free_timer)
3726 KillTimer (hwnd, menu_free_timer);
3727 menu_free_timer = 0;
3730 case WM_MOVE:
3731 case WM_SIZE:
3732 command:
3733 wmsg.dwModifiers = w32_get_modifiers ();
3734 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3735 goto dflt;
3737 case WM_CLOSE:
3738 wmsg.dwModifiers = w32_get_modifiers ();
3739 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3740 return 0;
3742 case WM_WINDOWPOSCHANGING:
3743 /* Don't restrict the sizing of tip frames. */
3744 if (hwnd == tip_window)
3745 return 0;
3747 WINDOWPLACEMENT wp;
3748 LPWINDOWPOS lppos = (WINDOWPOS *) lParam;
3750 wp.length = sizeof (WINDOWPLACEMENT);
3751 GetWindowPlacement (hwnd, &wp);
3753 if (wp.showCmd != SW_SHOWMINIMIZED && (lppos->flags & SWP_NOSIZE) == 0)
3755 RECT rect;
3756 int wdiff;
3757 int hdiff;
3758 DWORD font_width;
3759 DWORD line_height;
3760 DWORD internal_border;
3761 DWORD scrollbar_extra;
3762 RECT wr;
3764 wp.length = sizeof(wp);
3765 GetWindowRect (hwnd, &wr);
3767 enter_crit ();
3769 font_width = GetWindowLong (hwnd, WND_FONTWIDTH_INDEX);
3770 line_height = GetWindowLong (hwnd, WND_LINEHEIGHT_INDEX);
3771 internal_border = GetWindowLong (hwnd, WND_BORDER_INDEX);
3772 scrollbar_extra = GetWindowLong (hwnd, WND_SCROLLBAR_INDEX);
3774 leave_crit ();
3776 memset (&rect, 0, sizeof (rect));
3777 AdjustWindowRect (&rect, GetWindowLong (hwnd, GWL_STYLE),
3778 GetMenu (hwnd) != NULL);
3780 /* Force width and height of client area to be exact
3781 multiples of the character cell dimensions. */
3782 wdiff = (lppos->cx - (rect.right - rect.left)
3783 - 2 * internal_border - scrollbar_extra)
3784 % font_width;
3785 hdiff = (lppos->cy - (rect.bottom - rect.top)
3786 - 2 * internal_border)
3787 % line_height;
3789 if (wdiff || hdiff)
3791 /* For right/bottom sizing we can just fix the sizes.
3792 However for top/left sizing we will need to fix the X
3793 and Y positions as well. */
3795 lppos->cx -= wdiff;
3796 lppos->cy -= hdiff;
3798 if (wp.showCmd != SW_SHOWMAXIMIZED
3799 && (lppos->flags & SWP_NOMOVE) == 0)
3801 if (lppos->x != wr.left || lppos->y != wr.top)
3803 lppos->x += wdiff;
3804 lppos->y += hdiff;
3806 else
3808 lppos->flags |= SWP_NOMOVE;
3812 return 0;
3817 goto dflt;
3819 case WM_GETMINMAXINFO:
3820 /* Hack to correct bug that allows Emacs frames to be resized
3821 below the Minimum Tracking Size. */
3822 ((LPMINMAXINFO) lParam)->ptMinTrackSize.y++;
3823 /* Hack to allow resizing the Emacs frame above the screen size.
3824 Note that Windows 9x limits coordinates to 16-bits. */
3825 ((LPMINMAXINFO) lParam)->ptMaxTrackSize.x = 32767;
3826 ((LPMINMAXINFO) lParam)->ptMaxTrackSize.y = 32767;
3827 return 0;
3829 case WM_SETCURSOR:
3830 if (LOWORD (lParam) == HTCLIENT)
3831 return 0;
3833 goto dflt;
3835 case WM_EMACS_SETCURSOR:
3837 Cursor cursor = (Cursor) wParam;
3838 if (cursor)
3839 SetCursor (cursor);
3840 return 0;
3843 case WM_EMACS_CREATESCROLLBAR:
3844 return (LRESULT) w32_createscrollbar ((struct frame *) wParam,
3845 (struct scroll_bar *) lParam);
3847 case WM_EMACS_SHOWWINDOW:
3848 return ShowWindow ((HWND) wParam, (WPARAM) lParam);
3850 case WM_EMACS_SETFOREGROUND:
3852 HWND foreground_window;
3853 DWORD foreground_thread, retval;
3855 /* On NT 5.0, and apparently Windows 98, it is necessary to
3856 attach to the thread that currently has focus in order to
3857 pull the focus away from it. */
3858 foreground_window = GetForegroundWindow ();
3859 foreground_thread = GetWindowThreadProcessId (foreground_window, NULL);
3860 if (!foreground_window
3861 || foreground_thread == GetCurrentThreadId ()
3862 || !AttachThreadInput (GetCurrentThreadId (),
3863 foreground_thread, TRUE))
3864 foreground_thread = 0;
3866 retval = SetForegroundWindow ((HWND) wParam);
3868 /* Detach from the previous foreground thread. */
3869 if (foreground_thread)
3870 AttachThreadInput (GetCurrentThreadId (),
3871 foreground_thread, FALSE);
3873 return retval;
3876 case WM_EMACS_SETWINDOWPOS:
3878 WINDOWPOS * pos = (WINDOWPOS *) wParam;
3879 return SetWindowPos (hwnd, pos->hwndInsertAfter,
3880 pos->x, pos->y, pos->cx, pos->cy, pos->flags);
3883 case WM_EMACS_DESTROYWINDOW:
3884 DragAcceptFiles ((HWND) wParam, FALSE);
3885 return DestroyWindow ((HWND) wParam);
3887 case WM_EMACS_HIDE_CARET:
3888 return HideCaret (hwnd);
3890 case WM_EMACS_SHOW_CARET:
3891 return ShowCaret (hwnd);
3893 case WM_EMACS_DESTROY_CARET:
3894 w32_system_caret_hwnd = NULL;
3895 w32_visible_system_caret_hwnd = NULL;
3896 return DestroyCaret ();
3898 case WM_EMACS_TRACK_CARET:
3899 /* If there is currently no system caret, create one. */
3900 if (w32_system_caret_hwnd == NULL)
3902 /* Use the default caret width, and avoid changing it
3903 unneccesarily, as it confuses screen reader software. */
3904 w32_system_caret_hwnd = hwnd;
3905 CreateCaret (hwnd, NULL, 0,
3906 w32_system_caret_height);
3909 if (!SetCaretPos (w32_system_caret_x, w32_system_caret_y))
3910 return 0;
3911 /* Ensure visible caret gets turned on when requested. */
3912 else if (w32_use_visible_system_caret
3913 && w32_visible_system_caret_hwnd != hwnd)
3915 w32_visible_system_caret_hwnd = hwnd;
3916 return ShowCaret (hwnd);
3918 /* Ensure visible caret gets turned off when requested. */
3919 else if (!w32_use_visible_system_caret
3920 && w32_visible_system_caret_hwnd)
3922 w32_visible_system_caret_hwnd = NULL;
3923 return HideCaret (hwnd);
3925 else
3926 return 1;
3928 case WM_EMACS_TRACKPOPUPMENU:
3930 UINT flags;
3931 POINT *pos;
3932 int retval;
3933 pos = (POINT *)lParam;
3934 flags = TPM_CENTERALIGN;
3935 if (button_state & LMOUSE)
3936 flags |= TPM_LEFTBUTTON;
3937 else if (button_state & RMOUSE)
3938 flags |= TPM_RIGHTBUTTON;
3940 /* Remember we did a SetCapture on the initial mouse down event,
3941 so for safety, we make sure the capture is cancelled now. */
3942 ReleaseCapture ();
3943 button_state = 0;
3945 /* Use menubar_active to indicate that WM_INITMENU is from
3946 TrackPopupMenu below, and should be ignored. */
3947 f = x_window_to_frame (dpyinfo, hwnd);
3948 if (f)
3949 f->output_data.w32->menubar_active = 1;
3951 if (TrackPopupMenu ((HMENU)wParam, flags, pos->x, pos->y,
3952 0, hwnd, NULL))
3954 MSG amsg;
3955 /* Eat any mouse messages during popupmenu */
3956 while (PeekMessage (&amsg, hwnd, WM_MOUSEFIRST, WM_MOUSELAST,
3957 PM_REMOVE));
3958 /* Get the menu selection, if any */
3959 if (PeekMessage (&amsg, hwnd, WM_COMMAND, WM_COMMAND, PM_REMOVE))
3961 retval = LOWORD (amsg.wParam);
3963 else
3965 retval = 0;
3968 else
3970 retval = -1;
3973 return retval;
3976 default:
3977 /* Check for messages registered at runtime. */
3978 if (msg == msh_mousewheel)
3980 wmsg.dwModifiers = w32_get_modifiers ();
3981 my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
3982 return 0;
3985 dflt:
3986 return DefWindowProc (hwnd, msg, wParam, lParam);
3990 /* The most common default return code for handled messages is 0. */
3991 return 0;
3994 void
3995 my_create_window (f)
3996 struct frame * f;
3998 MSG msg;
4000 if (!PostThreadMessage (dwWindowsThreadId, WM_EMACS_CREATEWINDOW, (WPARAM)f, 0))
4001 abort ();
4002 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
4006 /* Create a tooltip window. Unlike my_create_window, we do not do this
4007 indirectly via the Window thread, as we do not need to process Window
4008 messages for the tooltip. Creating tooltips indirectly also creates
4009 deadlocks when tooltips are created for menu items. */
4010 void
4011 my_create_tip_window (f)
4012 struct frame *f;
4014 RECT rect;
4016 rect.left = rect.top = 0;
4017 rect.right = PIXEL_WIDTH (f);
4018 rect.bottom = PIXEL_HEIGHT (f);
4020 AdjustWindowRect (&rect, f->output_data.w32->dwStyle,
4021 FRAME_EXTERNAL_MENU_BAR (f));
4023 tip_window = FRAME_W32_WINDOW (f)
4024 = CreateWindow (EMACS_CLASS,
4025 f->namebuf,
4026 f->output_data.w32->dwStyle,
4027 f->output_data.w32->left_pos,
4028 f->output_data.w32->top_pos,
4029 rect.right - rect.left,
4030 rect.bottom - rect.top,
4031 FRAME_W32_WINDOW (SELECTED_FRAME ()), /* owner */
4032 NULL,
4033 hinst,
4034 NULL);
4036 if (tip_window)
4038 SetWindowLong (tip_window, WND_FONTWIDTH_INDEX, FONT_WIDTH (f->output_data.w32->font));
4039 SetWindowLong (tip_window, WND_LINEHEIGHT_INDEX, f->output_data.w32->line_height);
4040 SetWindowLong (tip_window, WND_BORDER_INDEX, f->output_data.w32->internal_border_width);
4041 SetWindowLong (tip_window, WND_BACKGROUND_INDEX, FRAME_BACKGROUND_PIXEL (f));
4043 /* Tip frames have no scrollbars. */
4044 SetWindowLong (tip_window, WND_SCROLLBAR_INDEX, 0);
4046 /* Do this to discard the default setting specified by our parent. */
4047 ShowWindow (tip_window, SW_HIDE);
4052 /* Create and set up the w32 window for frame F. */
4054 static void
4055 w32_window (f, window_prompting, minibuffer_only)
4056 struct frame *f;
4057 long window_prompting;
4058 int minibuffer_only;
4060 BLOCK_INPUT;
4062 /* Use the resource name as the top-level window name
4063 for looking up resources. Make a non-Lisp copy
4064 for the window manager, so GC relocation won't bother it.
4066 Elsewhere we specify the window name for the window manager. */
4069 char *str = (char *) SDATA (Vx_resource_name);
4070 f->namebuf = (char *) xmalloc (strlen (str) + 1);
4071 strcpy (f->namebuf, str);
4074 my_create_window (f);
4076 validate_x_resource_name ();
4078 /* x_set_name normally ignores requests to set the name if the
4079 requested name is the same as the current name. This is the one
4080 place where that assumption isn't correct; f->name is set, but
4081 the server hasn't been told. */
4083 Lisp_Object name;
4084 int explicit = f->explicit_name;
4086 f->explicit_name = 0;
4087 name = f->name;
4088 f->name = Qnil;
4089 x_set_name (f, name, explicit);
4092 UNBLOCK_INPUT;
4094 if (!minibuffer_only && FRAME_EXTERNAL_MENU_BAR (f))
4095 initialize_frame_menubar (f);
4097 if (FRAME_W32_WINDOW (f) == 0)
4098 error ("Unable to create window");
4101 /* Handle the icon stuff for this window. Perhaps later we might
4102 want an x_set_icon_position which can be called interactively as
4103 well. */
4105 static void
4106 x_icon (f, parms)
4107 struct frame *f;
4108 Lisp_Object parms;
4110 Lisp_Object icon_x, icon_y;
4112 /* Set the position of the icon. Note that Windows 95 groups all
4113 icons in the tray. */
4114 icon_x = w32_get_arg (parms, Qicon_left, 0, 0, RES_TYPE_NUMBER);
4115 icon_y = w32_get_arg (parms, Qicon_top, 0, 0, RES_TYPE_NUMBER);
4116 if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound))
4118 CHECK_NUMBER (icon_x);
4119 CHECK_NUMBER (icon_y);
4121 else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound))
4122 error ("Both left and top icon corners of icon must be specified");
4124 BLOCK_INPUT;
4126 if (! EQ (icon_x, Qunbound))
4127 x_wm_set_icon_position (f, XINT (icon_x), XINT (icon_y));
4129 #if 0 /* TODO */
4130 /* Start up iconic or window? */
4131 x_wm_set_window_state
4132 (f, (EQ (w32_get_arg (parms, Qvisibility, 0, 0, RES_TYPE_SYMBOL), Qicon)
4133 ? IconicState
4134 : NormalState));
4136 x_text_icon (f, (char *) SDATA ((!NILP (f->icon_name)
4137 ? f->icon_name
4138 : f->name)));
4139 #endif
4141 UNBLOCK_INPUT;
4145 static void
4146 x_make_gc (f)
4147 struct frame *f;
4149 XGCValues gc_values;
4151 BLOCK_INPUT;
4153 /* Create the GC's of this frame.
4154 Note that many default values are used. */
4156 /* Normal video */
4157 gc_values.font = f->output_data.w32->font;
4159 /* Cursor has cursor-color background, background-color foreground. */
4160 gc_values.foreground = FRAME_BACKGROUND_PIXEL (f);
4161 gc_values.background = f->output_data.w32->cursor_pixel;
4162 f->output_data.w32->cursor_gc
4163 = XCreateGC (NULL, FRAME_W32_WINDOW (f),
4164 (GCFont | GCForeground | GCBackground),
4165 &gc_values);
4167 /* Reliefs. */
4168 f->output_data.w32->white_relief.gc = 0;
4169 f->output_data.w32->black_relief.gc = 0;
4171 UNBLOCK_INPUT;
4175 /* Handler for signals raised during x_create_frame and
4176 x_create_top_frame. FRAME is the frame which is partially
4177 constructed. */
4179 static Lisp_Object
4180 unwind_create_frame (frame)
4181 Lisp_Object frame;
4183 struct frame *f = XFRAME (frame);
4185 /* If frame is ``official'', nothing to do. */
4186 if (!CONSP (Vframe_list) || !EQ (XCAR (Vframe_list), frame))
4188 #ifdef GLYPH_DEBUG
4189 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
4190 #endif
4192 x_free_frame_resources (f);
4194 /* Check that reference counts are indeed correct. */
4195 xassert (dpyinfo->reference_count == dpyinfo_refcount);
4196 xassert (dpyinfo->image_cache->refcount == image_cache_refcount);
4198 return Qt;
4201 return Qnil;
4205 DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
4206 1, 1, 0,
4207 doc: /* Make a new window, which is called a \"frame\" in Emacs terms.
4208 Returns an Emacs frame object.
4209 ALIST is an alist of frame parameters.
4210 If the parameters specify that the frame should not have a minibuffer,
4211 and do not specify a specific minibuffer window to use,
4212 then `default-minibuffer-frame' must be a frame whose minibuffer can
4213 be shared by the new frame.
4215 This function is an internal primitive--use `make-frame' instead. */)
4216 (parms)
4217 Lisp_Object parms;
4219 struct frame *f;
4220 Lisp_Object frame, tem;
4221 Lisp_Object name;
4222 int minibuffer_only = 0;
4223 long window_prompting = 0;
4224 int width, height;
4225 int count = SPECPDL_INDEX ();
4226 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4227 Lisp_Object display;
4228 struct w32_display_info *dpyinfo = NULL;
4229 Lisp_Object parent;
4230 struct kboard *kb;
4232 check_w32 ();
4234 /* Use this general default value to start with
4235 until we know if this frame has a specified name. */
4236 Vx_resource_name = Vinvocation_name;
4238 display = w32_get_arg (parms, Qdisplay, 0, 0, RES_TYPE_STRING);
4239 if (EQ (display, Qunbound))
4240 display = Qnil;
4241 dpyinfo = check_x_display_info (display);
4242 #ifdef MULTI_KBOARD
4243 kb = dpyinfo->kboard;
4244 #else
4245 kb = &the_only_kboard;
4246 #endif
4248 name = w32_get_arg (parms, Qname, "name", "Name", RES_TYPE_STRING);
4249 if (!STRINGP (name)
4250 && ! EQ (name, Qunbound)
4251 && ! NILP (name))
4252 error ("Invalid frame name--not a string or nil");
4254 if (STRINGP (name))
4255 Vx_resource_name = name;
4257 /* See if parent window is specified. */
4258 parent = w32_get_arg (parms, Qparent_id, NULL, NULL, RES_TYPE_NUMBER);
4259 if (EQ (parent, Qunbound))
4260 parent = Qnil;
4261 if (! NILP (parent))
4262 CHECK_NUMBER (parent);
4264 /* make_frame_without_minibuffer can run Lisp code and garbage collect. */
4265 /* No need to protect DISPLAY because that's not used after passing
4266 it to make_frame_without_minibuffer. */
4267 frame = Qnil;
4268 GCPRO4 (parms, parent, name, frame);
4269 tem = w32_get_arg (parms, Qminibuffer, "minibuffer", "Minibuffer",
4270 RES_TYPE_SYMBOL);
4271 if (EQ (tem, Qnone) || NILP (tem))
4272 f = make_frame_without_minibuffer (Qnil, kb, display);
4273 else if (EQ (tem, Qonly))
4275 f = make_minibuffer_frame ();
4276 minibuffer_only = 1;
4278 else if (WINDOWP (tem))
4279 f = make_frame_without_minibuffer (tem, kb, display);
4280 else
4281 f = make_frame (1);
4283 XSETFRAME (frame, f);
4285 /* Note that Windows does support scroll bars. */
4286 FRAME_CAN_HAVE_SCROLL_BARS (f) = 1;
4288 /* By default, make scrollbars the system standard width. */
4289 f->scroll_bar_pixel_width = GetSystemMetrics (SM_CXVSCROLL);
4291 f->output_method = output_w32;
4292 f->output_data.w32 =
4293 (struct w32_output *) xmalloc (sizeof (struct w32_output));
4294 bzero (f->output_data.w32, sizeof (struct w32_output));
4295 FRAME_FONTSET (f) = -1;
4296 record_unwind_protect (unwind_create_frame, frame);
4298 f->icon_name
4299 = w32_get_arg (parms, Qicon_name, "iconName", "Title", RES_TYPE_STRING);
4300 if (! STRINGP (f->icon_name))
4301 f->icon_name = Qnil;
4303 /* FRAME_W32_DISPLAY_INFO (f) = dpyinfo; */
4304 #ifdef MULTI_KBOARD
4305 FRAME_KBOARD (f) = kb;
4306 #endif
4308 /* Specify the parent under which to make this window. */
4310 if (!NILP (parent))
4312 f->output_data.w32->parent_desc = (Window) XFASTINT (parent);
4313 f->output_data.w32->explicit_parent = 1;
4315 else
4317 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
4318 f->output_data.w32->explicit_parent = 0;
4321 /* Set the name; the functions to which we pass f expect the name to
4322 be set. */
4323 if (EQ (name, Qunbound) || NILP (name))
4325 f->name = build_string (dpyinfo->w32_id_name);
4326 f->explicit_name = 0;
4328 else
4330 f->name = name;
4331 f->explicit_name = 1;
4332 /* use the frame's title when getting resources for this frame. */
4333 specbind (Qx_resource_name, name);
4336 /* Extract the window parameters from the supplied values
4337 that are needed to determine window geometry. */
4339 Lisp_Object font;
4341 font = w32_get_arg (parms, Qfont, "font", "Font", RES_TYPE_STRING);
4343 BLOCK_INPUT;
4344 /* First, try whatever font the caller has specified. */
4345 if (STRINGP (font))
4347 tem = Fquery_fontset (font, Qnil);
4348 if (STRINGP (tem))
4349 font = x_new_fontset (f, SDATA (tem));
4350 else
4351 font = x_new_font (f, SDATA (font));
4353 /* Try out a font which we hope has bold and italic variations. */
4354 if (!STRINGP (font))
4355 font = x_new_font (f, "-*-Courier New-normal-r-*-*-*-100-*-*-c-*-iso8859-1");
4356 if (! STRINGP (font))
4357 font = x_new_font (f, "-*-Courier-normal-r-*-*-13-*-*-*-c-*-iso8859-1");
4358 /* If those didn't work, look for something which will at least work. */
4359 if (! STRINGP (font))
4360 font = x_new_font (f, "-*-Fixedsys-normal-r-*-*-12-*-*-*-c-*-iso8859-1");
4361 UNBLOCK_INPUT;
4362 if (! STRINGP (font))
4363 font = build_string ("Fixedsys");
4365 x_default_parameter (f, parms, Qfont, font,
4366 "font", "Font", RES_TYPE_STRING);
4369 x_default_parameter (f, parms, Qborder_width, make_number (2),
4370 "borderWidth", "BorderWidth", RES_TYPE_NUMBER);
4371 /* This defaults to 2 in order to match xterm. We recognize either
4372 internalBorderWidth or internalBorder (which is what xterm calls
4373 it). */
4374 if (NILP (Fassq (Qinternal_border_width, parms)))
4376 Lisp_Object value;
4378 value = w32_get_arg (parms, Qinternal_border_width,
4379 "internalBorder", "InternalBorder", RES_TYPE_NUMBER);
4380 if (! EQ (value, Qunbound))
4381 parms = Fcons (Fcons (Qinternal_border_width, value),
4382 parms);
4384 /* Default internalBorderWidth to 0 on Windows to match other programs. */
4385 x_default_parameter (f, parms, Qinternal_border_width, make_number (0),
4386 "internalBorderWidth", "InternalBorder", RES_TYPE_NUMBER);
4387 x_default_parameter (f, parms, Qvertical_scroll_bars, Qright,
4388 "verticalScrollBars", "ScrollBars", RES_TYPE_SYMBOL);
4390 /* Also do the stuff which must be set before the window exists. */
4391 x_default_parameter (f, parms, Qforeground_color, build_string ("black"),
4392 "foreground", "Foreground", RES_TYPE_STRING);
4393 x_default_parameter (f, parms, Qbackground_color, build_string ("white"),
4394 "background", "Background", RES_TYPE_STRING);
4395 x_default_parameter (f, parms, Qmouse_color, build_string ("black"),
4396 "pointerColor", "Foreground", RES_TYPE_STRING);
4397 x_default_parameter (f, parms, Qcursor_color, build_string ("black"),
4398 "cursorColor", "Foreground", RES_TYPE_STRING);
4399 x_default_parameter (f, parms, Qborder_color, build_string ("black"),
4400 "borderColor", "BorderColor", RES_TYPE_STRING);
4401 x_default_parameter (f, parms, Qscreen_gamma, Qnil,
4402 "screenGamma", "ScreenGamma", RES_TYPE_FLOAT);
4403 x_default_parameter (f, parms, Qline_spacing, Qnil,
4404 "lineSpacing", "LineSpacing", RES_TYPE_NUMBER);
4405 x_default_parameter (f, parms, Qleft_fringe, Qnil,
4406 "leftFringe", "LeftFringe", RES_TYPE_NUMBER);
4407 x_default_parameter (f, parms, Qright_fringe, Qnil,
4408 "rightFringe", "RightFringe", RES_TYPE_NUMBER);
4411 /* Init faces before x_default_parameter is called for scroll-bar
4412 parameters because that function calls x_set_scroll_bar_width,
4413 which calls change_frame_size, which calls Fset_window_buffer,
4414 which runs hooks, which call Fvertical_motion. At the end, we
4415 end up in init_iterator with a null face cache, which should not
4416 happen. */
4417 init_frame_faces (f);
4419 x_default_parameter (f, parms, Qmenu_bar_lines, make_number (1),
4420 "menuBar", "MenuBar", RES_TYPE_NUMBER);
4421 x_default_parameter (f, parms, Qtool_bar_lines, make_number (1),
4422 "toolBar", "ToolBar", RES_TYPE_NUMBER);
4424 x_default_parameter (f, parms, Qbuffer_predicate, Qnil,
4425 "bufferPredicate", "BufferPredicate", RES_TYPE_SYMBOL);
4426 x_default_parameter (f, parms, Qtitle, Qnil,
4427 "title", "Title", RES_TYPE_STRING);
4428 x_default_parameter (f, parms, Qfullscreen, Qnil,
4429 "fullscreen", "Fullscreen", RES_TYPE_SYMBOL);
4431 f->output_data.w32->dwStyle = WS_OVERLAPPEDWINDOW;
4432 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
4434 f->output_data.w32->text_cursor = w32_load_cursor (IDC_IBEAM);
4435 f->output_data.w32->nontext_cursor = w32_load_cursor (IDC_ARROW);
4436 f->output_data.w32->modeline_cursor = w32_load_cursor (IDC_ARROW);
4437 f->output_data.w32->hand_cursor = w32_load_cursor (IDC_HAND);
4438 f->output_data.w32->hourglass_cursor = w32_load_cursor (IDC_WAIT);
4439 f->output_data.w32->horizontal_drag_cursor = w32_load_cursor (IDC_SIZEWE);
4441 window_prompting = x_figure_window_size (f, parms, 1);
4443 tem = w32_get_arg (parms, Qunsplittable, 0, 0, RES_TYPE_BOOLEAN);
4444 f->no_split = minibuffer_only || EQ (tem, Qt);
4446 w32_window (f, window_prompting, minibuffer_only);
4447 x_icon (f, parms);
4449 x_make_gc (f);
4451 /* Now consider the frame official. */
4452 FRAME_W32_DISPLAY_INFO (f)->reference_count++;
4453 Vframe_list = Fcons (frame, Vframe_list);
4455 /* We need to do this after creating the window, so that the
4456 icon-creation functions can say whose icon they're describing. */
4457 x_default_parameter (f, parms, Qicon_type, Qnil,
4458 "bitmapIcon", "BitmapIcon", RES_TYPE_SYMBOL);
4460 x_default_parameter (f, parms, Qauto_raise, Qnil,
4461 "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN);
4462 x_default_parameter (f, parms, Qauto_lower, Qnil,
4463 "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN);
4464 x_default_parameter (f, parms, Qcursor_type, Qbox,
4465 "cursorType", "CursorType", RES_TYPE_SYMBOL);
4466 x_default_parameter (f, parms, Qscroll_bar_width, Qnil,
4467 "scrollBarWidth", "ScrollBarWidth", RES_TYPE_NUMBER);
4469 /* Dimensions, especially f->height, must be done via change_frame_size.
4470 Change will not be effected unless different from the current
4471 f->height. */
4472 width = f->width;
4473 height = f->height;
4475 f->height = 0;
4476 SET_FRAME_WIDTH (f, 0);
4477 change_frame_size (f, height, width, 1, 0, 0);
4479 /* Tell the server what size and position, etc, we want, and how
4480 badly we want them. This should be done after we have the menu
4481 bar so that its size can be taken into account. */
4482 BLOCK_INPUT;
4483 x_wm_set_size_hint (f, window_prompting, 0);
4484 UNBLOCK_INPUT;
4486 /* Avoid a bug that causes the new frame to never become visible if
4487 an echo area message is displayed during the following call1. */
4488 specbind(Qredisplay_dont_pause, Qt);
4490 /* Set up faces after all frame parameters are known. This call
4491 also merges in face attributes specified for new frames. If we
4492 don't do this, the `menu' face for instance won't have the right
4493 colors, and the menu bar won't appear in the specified colors for
4494 new frames. */
4495 call1 (Qface_set_after_frame_default, frame);
4497 /* Make the window appear on the frame and enable display, unless
4498 the caller says not to. However, with explicit parent, Emacs
4499 cannot control visibility, so don't try. */
4500 if (! f->output_data.w32->explicit_parent)
4502 Lisp_Object visibility;
4504 visibility = w32_get_arg (parms, Qvisibility, 0, 0, RES_TYPE_SYMBOL);
4505 if (EQ (visibility, Qunbound))
4506 visibility = Qt;
4508 if (EQ (visibility, Qicon))
4509 x_iconify_frame (f);
4510 else if (! NILP (visibility))
4511 x_make_frame_visible (f);
4512 else
4513 /* Must have been Qnil. */
4516 UNGCPRO;
4518 /* Make sure windows on this frame appear in calls to next-window
4519 and similar functions. */
4520 Vwindow_list = Qnil;
4522 return unbind_to (count, frame);
4525 /* FRAME is used only to get a handle on the X display. We don't pass the
4526 display info directly because we're called from frame.c, which doesn't
4527 know about that structure. */
4528 Lisp_Object
4529 x_get_focus_frame (frame)
4530 struct frame *frame;
4532 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (frame);
4533 Lisp_Object xfocus;
4534 if (! dpyinfo->w32_focus_frame)
4535 return Qnil;
4537 XSETFRAME (xfocus, dpyinfo->w32_focus_frame);
4538 return xfocus;
4541 DEFUN ("w32-focus-frame", Fw32_focus_frame, Sw32_focus_frame, 1, 1, 0,
4542 doc: /* Give FRAME input focus, raising to foreground if necessary. */)
4543 (frame)
4544 Lisp_Object frame;
4546 x_focus_on_frame (check_x_frame (frame));
4547 return Qnil;
4551 /* Return the charset portion of a font name. */
4552 char * xlfd_charset_of_font (char * fontname)
4554 char *charset, *encoding;
4556 encoding = strrchr(fontname, '-');
4557 if (!encoding || encoding == fontname)
4558 return NULL;
4560 for (charset = encoding - 1; charset >= fontname; charset--)
4561 if (*charset == '-')
4562 break;
4564 if (charset == fontname || strcmp(charset, "-*-*") == 0)
4565 return NULL;
4567 return charset + 1;
4570 struct font_info *w32_load_bdf_font (struct frame *f, char *fontname,
4571 int size, char* filename);
4572 static Lisp_Object w32_list_bdf_fonts (Lisp_Object pattern, int max_names);
4573 static BOOL w32_to_x_font (LOGFONT * lplf, char * lpxstr, int len,
4574 char * charset);
4575 static BOOL x_to_w32_font (char *lpxstr, LOGFONT *lplogfont);
4577 static struct font_info *
4578 w32_load_system_font (f,fontname,size)
4579 struct frame *f;
4580 char * fontname;
4581 int size;
4583 struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f);
4584 Lisp_Object font_names;
4586 /* Get a list of all the fonts that match this name. Once we
4587 have a list of matching fonts, we compare them against the fonts
4588 we already have loaded by comparing names. */
4589 font_names = w32_list_fonts (f, build_string (fontname), size, 100);
4591 if (!NILP (font_names))
4593 Lisp_Object tail;
4594 int i;
4596 /* First check if any are already loaded, as that is cheaper
4597 than loading another one. */
4598 for (i = 0; i < dpyinfo->n_fonts; i++)
4599 for (tail = font_names; CONSP (tail); tail = XCDR (tail))
4600 if (dpyinfo->font_table[i].name
4601 && (!strcmp (dpyinfo->font_table[i].name,
4602 SDATA (XCAR (tail)))
4603 || !strcmp (dpyinfo->font_table[i].full_name,
4604 SDATA (XCAR (tail)))))
4605 return (dpyinfo->font_table + i);
4607 fontname = (char *) SDATA (XCAR (font_names));
4609 else if (w32_strict_fontnames)
4611 /* If EnumFontFamiliesEx was available, we got a full list of
4612 fonts back so stop now to avoid the possibility of loading a
4613 random font. If we had to fall back to EnumFontFamilies, the
4614 list is incomplete, so continue whether the font we want was
4615 listed or not. */
4616 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
4617 FARPROC enum_font_families_ex
4618 = GetProcAddress (gdi32, "EnumFontFamiliesExA");
4619 if (enum_font_families_ex)
4620 return NULL;
4623 /* Load the font and add it to the table. */
4625 char *full_name, *encoding, *charset;
4626 XFontStruct *font;
4627 struct font_info *fontp;
4628 LOGFONT lf;
4629 BOOL ok;
4630 int codepage;
4631 int i;
4633 if (!fontname || !x_to_w32_font (fontname, &lf))
4634 return (NULL);
4636 if (!*lf.lfFaceName)
4637 /* If no name was specified for the font, we get a random font
4638 from CreateFontIndirect - this is not particularly
4639 desirable, especially since CreateFontIndirect does not
4640 fill out the missing name in lf, so we never know what we
4641 ended up with. */
4642 return NULL;
4644 lf.lfQuality = DEFAULT_QUALITY;
4646 font = (XFontStruct *) xmalloc (sizeof (XFontStruct));
4647 bzero (font, sizeof (*font));
4649 /* Set bdf to NULL to indicate that this is a Windows font. */
4650 font->bdf = NULL;
4652 BLOCK_INPUT;
4654 font->hfont = CreateFontIndirect (&lf);
4656 if (font->hfont == NULL)
4658 ok = FALSE;
4660 else
4662 HDC hdc;
4663 HANDLE oldobj;
4665 codepage = w32_codepage_for_font (fontname);
4667 hdc = GetDC (dpyinfo->root_window);
4668 oldobj = SelectObject (hdc, font->hfont);
4670 ok = GetTextMetrics (hdc, &font->tm);
4671 if (codepage == CP_UNICODE)
4672 font->double_byte_p = 1;
4673 else
4675 /* Unfortunately, some fonts (eg. MingLiU, a big5 ttf font)
4676 don't report themselves as double byte fonts, when
4677 patently they are. So instead of trusting
4678 GetFontLanguageInfo, we check the properties of the
4679 codepage directly, since that is ultimately what we are
4680 working from anyway. */
4681 /* font->double_byte_p = GetFontLanguageInfo(hdc) & GCP_DBCS; */
4682 CPINFO cpi = {0};
4683 GetCPInfo (codepage, &cpi);
4684 font->double_byte_p = cpi.MaxCharSize > 1;
4687 SelectObject (hdc, oldobj);
4688 ReleaseDC (dpyinfo->root_window, hdc);
4689 /* Fill out details in lf according to the font that was
4690 actually loaded. */
4691 lf.lfHeight = font->tm.tmInternalLeading - font->tm.tmHeight;
4692 lf.lfWidth = font->tm.tmAveCharWidth;
4693 lf.lfWeight = font->tm.tmWeight;
4694 lf.lfItalic = font->tm.tmItalic;
4695 lf.lfCharSet = font->tm.tmCharSet;
4696 lf.lfPitchAndFamily = ((font->tm.tmPitchAndFamily & TMPF_FIXED_PITCH)
4697 ? VARIABLE_PITCH : FIXED_PITCH);
4698 lf.lfOutPrecision = ((font->tm.tmPitchAndFamily & TMPF_VECTOR)
4699 ? OUT_STROKE_PRECIS : OUT_STRING_PRECIS);
4701 w32_cache_char_metrics (font);
4704 UNBLOCK_INPUT;
4706 if (!ok)
4708 w32_unload_font (dpyinfo, font);
4709 return (NULL);
4712 /* Find a free slot in the font table. */
4713 for (i = 0; i < dpyinfo->n_fonts; ++i)
4714 if (dpyinfo->font_table[i].name == NULL)
4715 break;
4717 /* If no free slot found, maybe enlarge the font table. */
4718 if (i == dpyinfo->n_fonts
4719 && dpyinfo->n_fonts == dpyinfo->font_table_size)
4721 int sz;
4722 dpyinfo->font_table_size = max (16, 2 * dpyinfo->font_table_size);
4723 sz = dpyinfo->font_table_size * sizeof *dpyinfo->font_table;
4724 dpyinfo->font_table
4725 = (struct font_info *) xrealloc (dpyinfo->font_table, sz);
4728 fontp = dpyinfo->font_table + i;
4729 if (i == dpyinfo->n_fonts)
4730 ++dpyinfo->n_fonts;
4732 /* Now fill in the slots of *FONTP. */
4733 BLOCK_INPUT;
4734 fontp->font = font;
4735 fontp->font_idx = i;
4736 fontp->name = (char *) xmalloc (strlen (fontname) + 1);
4737 bcopy (fontname, fontp->name, strlen (fontname) + 1);
4739 charset = xlfd_charset_of_font (fontname);
4741 /* Cache the W32 codepage for a font. This makes w32_encode_char
4742 (called for every glyph during redisplay) much faster. */
4743 fontp->codepage = codepage;
4745 /* Work out the font's full name. */
4746 full_name = (char *)xmalloc (100);
4747 if (full_name && w32_to_x_font (&lf, full_name, 100, charset))
4748 fontp->full_name = full_name;
4749 else
4751 /* If all else fails - just use the name we used to load it. */
4752 xfree (full_name);
4753 fontp->full_name = fontp->name;
4756 fontp->size = FONT_WIDTH (font);
4757 fontp->height = FONT_HEIGHT (font);
4759 /* The slot `encoding' specifies how to map a character
4760 code-points (0x20..0x7F or 0x2020..0x7F7F) of each charset to
4761 the font code-points (0:0x20..0x7F, 1:0xA0..0xFF), or
4762 (0:0x20..0x7F, 1:0xA0..0xFF,
4763 (0:0x2020..0x7F7F, 1:0xA0A0..0xFFFF, 3:0x20A0..0x7FFF,
4764 2:0xA020..0xFF7F). For the moment, we don't know which charset
4765 uses this font. So, we set information in fontp->encoding[1]
4766 which is never used by any charset. If mapping can't be
4767 decided, set FONT_ENCODING_NOT_DECIDED. */
4769 /* SJIS fonts need to be set to type 4, all others seem to work as
4770 type FONT_ENCODING_NOT_DECIDED. */
4771 encoding = strrchr (fontp->name, '-');
4772 if (encoding && strnicmp (encoding+1, "sjis", 4) == 0)
4773 fontp->encoding[1] = 4;
4774 else
4775 fontp->encoding[1] = FONT_ENCODING_NOT_DECIDED;
4777 /* The following three values are set to 0 under W32, which is
4778 what they get set to if XGetFontProperty fails under X. */
4779 fontp->baseline_offset = 0;
4780 fontp->relative_compose = 0;
4781 fontp->default_ascent = 0;
4783 /* Set global flag fonts_changed_p to non-zero if the font loaded
4784 has a character with a smaller width than any other character
4785 before, or if the font loaded has a smaller height than any
4786 other font loaded before. If this happens, it will make a
4787 glyph matrix reallocation necessary. */
4788 fonts_changed_p |= x_compute_min_glyph_bounds (f);
4789 UNBLOCK_INPUT;
4790 return fontp;
4794 /* Load font named FONTNAME of size SIZE for frame F, and return a
4795 pointer to the structure font_info while allocating it dynamically.
4796 If loading fails, return NULL. */
4797 struct font_info *
4798 w32_load_font (f,fontname,size)
4799 struct frame *f;
4800 char * fontname;
4801 int size;
4803 Lisp_Object bdf_fonts;
4804 struct font_info *retval = NULL;
4806 bdf_fonts = w32_list_bdf_fonts (build_string (fontname), 1);
4808 while (!retval && CONSP (bdf_fonts))
4810 char *bdf_name, *bdf_file;
4811 Lisp_Object bdf_pair;
4813 bdf_name = SDATA (XCAR (bdf_fonts));
4814 bdf_pair = Fassoc (XCAR (bdf_fonts), Vw32_bdf_filename_alist);
4815 bdf_file = SDATA (XCDR (bdf_pair));
4817 retval = w32_load_bdf_font (f, bdf_name, size, bdf_file);
4819 bdf_fonts = XCDR (bdf_fonts);
4822 if (retval)
4823 return retval;
4825 return w32_load_system_font(f, fontname, size);
4829 void
4830 w32_unload_font (dpyinfo, font)
4831 struct w32_display_info *dpyinfo;
4832 XFontStruct * font;
4834 if (font)
4836 if (font->per_char) xfree (font->per_char);
4837 if (font->bdf) w32_free_bdf_font (font->bdf);
4839 if (font->hfont) DeleteObject(font->hfont);
4840 xfree (font);
4844 /* The font conversion stuff between x and w32 */
4846 /* X font string is as follows (from faces.el)
4847 * (let ((- "[-?]")
4848 * (foundry "[^-]+")
4849 * (family "[^-]+")
4850 * (weight "\\(bold\\|demibold\\|medium\\)") ; 1
4851 * (weight\? "\\([^-]*\\)") ; 1
4852 * (slant "\\([ior]\\)") ; 2
4853 * (slant\? "\\([^-]?\\)") ; 2
4854 * (swidth "\\([^-]*\\)") ; 3
4855 * (adstyle "[^-]*") ; 4
4856 * (pixelsize "[0-9]+")
4857 * (pointsize "[0-9][0-9]+")
4858 * (resx "[0-9][0-9]+")
4859 * (resy "[0-9][0-9]+")
4860 * (spacing "[cmp?*]")
4861 * (avgwidth "[0-9]+")
4862 * (registry "[^-]+")
4863 * (encoding "[^-]+")
4867 static LONG
4868 x_to_w32_weight (lpw)
4869 char * lpw;
4871 if (!lpw) return (FW_DONTCARE);
4873 if (stricmp (lpw,"heavy") == 0) return FW_HEAVY;
4874 else if (stricmp (lpw,"extrabold") == 0) return FW_EXTRABOLD;
4875 else if (stricmp (lpw,"bold") == 0) return FW_BOLD;
4876 else if (stricmp (lpw,"demibold") == 0) return FW_SEMIBOLD;
4877 else if (stricmp (lpw,"semibold") == 0) return FW_SEMIBOLD;
4878 else if (stricmp (lpw,"medium") == 0) return FW_MEDIUM;
4879 else if (stricmp (lpw,"normal") == 0) return FW_NORMAL;
4880 else if (stricmp (lpw,"light") == 0) return FW_LIGHT;
4881 else if (stricmp (lpw,"extralight") == 0) return FW_EXTRALIGHT;
4882 else if (stricmp (lpw,"thin") == 0) return FW_THIN;
4883 else
4884 return FW_DONTCARE;
4888 static char *
4889 w32_to_x_weight (fnweight)
4890 int fnweight;
4892 if (fnweight >= FW_HEAVY) return "heavy";
4893 if (fnweight >= FW_EXTRABOLD) return "extrabold";
4894 if (fnweight >= FW_BOLD) return "bold";
4895 if (fnweight >= FW_SEMIBOLD) return "demibold";
4896 if (fnweight >= FW_MEDIUM) return "medium";
4897 if (fnweight >= FW_NORMAL) return "normal";
4898 if (fnweight >= FW_LIGHT) return "light";
4899 if (fnweight >= FW_EXTRALIGHT) return "extralight";
4900 if (fnweight >= FW_THIN) return "thin";
4901 else
4902 return "*";
4905 static LONG
4906 x_to_w32_charset (lpcs)
4907 char * lpcs;
4909 Lisp_Object this_entry, w32_charset;
4910 char *charset;
4911 int len = strlen (lpcs);
4913 /* Support "*-#nnn" format for unknown charsets. */
4914 if (strncmp (lpcs, "*-#", 3) == 0)
4915 return atoi (lpcs + 3);
4917 /* Handle wildcards by ignoring them; eg. treat "big5*-*" as "big5". */
4918 charset = alloca (len + 1);
4919 strcpy (charset, lpcs);
4920 lpcs = strchr (charset, '*');
4921 if (lpcs)
4922 *lpcs = 0;
4924 /* Look through w32-charset-info-alist for the character set.
4925 Format of each entry is
4926 (CHARSET_NAME . (WINDOWS_CHARSET . CODEPAGE)).
4928 this_entry = Fassoc (build_string(charset), Vw32_charset_info_alist);
4930 if (NILP(this_entry))
4932 /* At startup, we want iso8859-1 fonts to come up properly. */
4933 if (stricmp(charset, "iso8859-1") == 0)
4934 return ANSI_CHARSET;
4935 else
4936 return DEFAULT_CHARSET;
4939 w32_charset = Fcar (Fcdr (this_entry));
4941 /* Translate Lisp symbol to number. */
4942 if (w32_charset == Qw32_charset_ansi)
4943 return ANSI_CHARSET;
4944 if (w32_charset == Qw32_charset_symbol)
4945 return SYMBOL_CHARSET;
4946 if (w32_charset == Qw32_charset_shiftjis)
4947 return SHIFTJIS_CHARSET;
4948 if (w32_charset == Qw32_charset_hangeul)
4949 return HANGEUL_CHARSET;
4950 if (w32_charset == Qw32_charset_chinesebig5)
4951 return CHINESEBIG5_CHARSET;
4952 if (w32_charset == Qw32_charset_gb2312)
4953 return GB2312_CHARSET;
4954 if (w32_charset == Qw32_charset_oem)
4955 return OEM_CHARSET;
4956 #ifdef JOHAB_CHARSET
4957 if (w32_charset == Qw32_charset_johab)
4958 return JOHAB_CHARSET;
4959 if (w32_charset == Qw32_charset_easteurope)
4960 return EASTEUROPE_CHARSET;
4961 if (w32_charset == Qw32_charset_turkish)
4962 return TURKISH_CHARSET;
4963 if (w32_charset == Qw32_charset_baltic)
4964 return BALTIC_CHARSET;
4965 if (w32_charset == Qw32_charset_russian)
4966 return RUSSIAN_CHARSET;
4967 if (w32_charset == Qw32_charset_arabic)
4968 return ARABIC_CHARSET;
4969 if (w32_charset == Qw32_charset_greek)
4970 return GREEK_CHARSET;
4971 if (w32_charset == Qw32_charset_hebrew)
4972 return HEBREW_CHARSET;
4973 if (w32_charset == Qw32_charset_vietnamese)
4974 return VIETNAMESE_CHARSET;
4975 if (w32_charset == Qw32_charset_thai)
4976 return THAI_CHARSET;
4977 if (w32_charset == Qw32_charset_mac)
4978 return MAC_CHARSET;
4979 #endif /* JOHAB_CHARSET */
4980 #ifdef UNICODE_CHARSET
4981 if (w32_charset == Qw32_charset_unicode)
4982 return UNICODE_CHARSET;
4983 #endif
4985 return DEFAULT_CHARSET;
4989 static char *
4990 w32_to_x_charset (fncharset)
4991 int fncharset;
4993 static char buf[32];
4994 Lisp_Object charset_type;
4996 switch (fncharset)
4998 case ANSI_CHARSET:
4999 /* Handle startup case of w32-charset-info-alist not
5000 being set up yet. */
5001 if (NILP(Vw32_charset_info_alist))
5002 return "iso8859-1";
5003 charset_type = Qw32_charset_ansi;
5004 break;
5005 case DEFAULT_CHARSET:
5006 charset_type = Qw32_charset_default;
5007 break;
5008 case SYMBOL_CHARSET:
5009 charset_type = Qw32_charset_symbol;
5010 break;
5011 case SHIFTJIS_CHARSET:
5012 charset_type = Qw32_charset_shiftjis;
5013 break;
5014 case HANGEUL_CHARSET:
5015 charset_type = Qw32_charset_hangeul;
5016 break;
5017 case GB2312_CHARSET:
5018 charset_type = Qw32_charset_gb2312;
5019 break;
5020 case CHINESEBIG5_CHARSET:
5021 charset_type = Qw32_charset_chinesebig5;
5022 break;
5023 case OEM_CHARSET:
5024 charset_type = Qw32_charset_oem;
5025 break;
5027 /* More recent versions of Windows (95 and NT4.0) define more
5028 character sets. */
5029 #ifdef EASTEUROPE_CHARSET
5030 case EASTEUROPE_CHARSET:
5031 charset_type = Qw32_charset_easteurope;
5032 break;
5033 case TURKISH_CHARSET:
5034 charset_type = Qw32_charset_turkish;
5035 break;
5036 case BALTIC_CHARSET:
5037 charset_type = Qw32_charset_baltic;
5038 break;
5039 case RUSSIAN_CHARSET:
5040 charset_type = Qw32_charset_russian;
5041 break;
5042 case ARABIC_CHARSET:
5043 charset_type = Qw32_charset_arabic;
5044 break;
5045 case GREEK_CHARSET:
5046 charset_type = Qw32_charset_greek;
5047 break;
5048 case HEBREW_CHARSET:
5049 charset_type = Qw32_charset_hebrew;
5050 break;
5051 case VIETNAMESE_CHARSET:
5052 charset_type = Qw32_charset_vietnamese;
5053 break;
5054 case THAI_CHARSET:
5055 charset_type = Qw32_charset_thai;
5056 break;
5057 case MAC_CHARSET:
5058 charset_type = Qw32_charset_mac;
5059 break;
5060 case JOHAB_CHARSET:
5061 charset_type = Qw32_charset_johab;
5062 break;
5063 #endif
5065 #ifdef UNICODE_CHARSET
5066 case UNICODE_CHARSET:
5067 charset_type = Qw32_charset_unicode;
5068 break;
5069 #endif
5070 default:
5071 /* Encode numerical value of unknown charset. */
5072 sprintf (buf, "*-#%u", fncharset);
5073 return buf;
5077 Lisp_Object rest;
5078 char * best_match = NULL;
5080 /* Look through w32-charset-info-alist for the character set.
5081 Prefer ISO codepages, and prefer lower numbers in the ISO
5082 range. Only return charsets for codepages which are installed.
5084 Format of each entry is
5085 (CHARSET_NAME . (WINDOWS_CHARSET . CODEPAGE)).
5087 for (rest = Vw32_charset_info_alist; CONSP (rest); rest = XCDR (rest))
5089 char * x_charset;
5090 Lisp_Object w32_charset;
5091 Lisp_Object codepage;
5093 Lisp_Object this_entry = XCAR (rest);
5095 /* Skip invalid entries in alist. */
5096 if (!CONSP (this_entry) || !STRINGP (XCAR (this_entry))
5097 || !CONSP (XCDR (this_entry))
5098 || !SYMBOLP (XCAR (XCDR (this_entry))))
5099 continue;
5101 x_charset = SDATA (XCAR (this_entry));
5102 w32_charset = XCAR (XCDR (this_entry));
5103 codepage = XCDR (XCDR (this_entry));
5105 /* Look for Same charset and a valid codepage (or non-int
5106 which means ignore). */
5107 if (w32_charset == charset_type
5108 && (!INTEGERP (codepage) || codepage == CP_DEFAULT
5109 || IsValidCodePage (XINT (codepage))))
5111 /* If we don't have a match already, then this is the
5112 best. */
5113 if (!best_match)
5114 best_match = x_charset;
5115 /* If this is an ISO codepage, and the best so far isn't,
5116 then this is better. */
5117 else if (strnicmp (best_match, "iso", 3) != 0
5118 && strnicmp (x_charset, "iso", 3) == 0)
5119 best_match = x_charset;
5120 /* If both are ISO8859 codepages, choose the one with the
5121 lowest number in the encoding field. */
5122 else if (strnicmp (best_match, "iso8859-", 8) == 0
5123 && strnicmp (x_charset, "iso8859-", 8) == 0)
5125 int best_enc = atoi (best_match + 8);
5126 int this_enc = atoi (x_charset + 8);
5127 if (this_enc > 0 && this_enc < best_enc)
5128 best_match = x_charset;
5133 /* If no match, encode the numeric value. */
5134 if (!best_match)
5136 sprintf (buf, "*-#%u", fncharset);
5137 return buf;
5140 strncpy(buf, best_match, 31);
5141 buf[31] = '\0';
5142 return buf;
5147 /* Return all the X charsets that map to a font. */
5148 static Lisp_Object
5149 w32_to_all_x_charsets (fncharset)
5150 int fncharset;
5152 static char buf[32];
5153 Lisp_Object charset_type;
5154 Lisp_Object retval = Qnil;
5156 switch (fncharset)
5158 case ANSI_CHARSET:
5159 /* Handle startup case of w32-charset-info-alist not
5160 being set up yet. */
5161 if (NILP(Vw32_charset_info_alist))
5162 return Fcons (build_string ("iso8859-1"), Qnil);
5164 charset_type = Qw32_charset_ansi;
5165 break;
5166 case DEFAULT_CHARSET:
5167 charset_type = Qw32_charset_default;
5168 break;
5169 case SYMBOL_CHARSET:
5170 charset_type = Qw32_charset_symbol;
5171 break;
5172 case SHIFTJIS_CHARSET:
5173 charset_type = Qw32_charset_shiftjis;
5174 break;
5175 case HANGEUL_CHARSET:
5176 charset_type = Qw32_charset_hangeul;
5177 break;
5178 case GB2312_CHARSET:
5179 charset_type = Qw32_charset_gb2312;
5180 break;
5181 case CHINESEBIG5_CHARSET:
5182 charset_type = Qw32_charset_chinesebig5;
5183 break;
5184 case OEM_CHARSET:
5185 charset_type = Qw32_charset_oem;
5186 break;
5188 /* More recent versions of Windows (95 and NT4.0) define more
5189 character sets. */
5190 #ifdef EASTEUROPE_CHARSET
5191 case EASTEUROPE_CHARSET:
5192 charset_type = Qw32_charset_easteurope;
5193 break;
5194 case TURKISH_CHARSET:
5195 charset_type = Qw32_charset_turkish;
5196 break;
5197 case BALTIC_CHARSET:
5198 charset_type = Qw32_charset_baltic;
5199 break;
5200 case RUSSIAN_CHARSET:
5201 charset_type = Qw32_charset_russian;
5202 break;
5203 case ARABIC_CHARSET:
5204 charset_type = Qw32_charset_arabic;
5205 break;
5206 case GREEK_CHARSET:
5207 charset_type = Qw32_charset_greek;
5208 break;
5209 case HEBREW_CHARSET:
5210 charset_type = Qw32_charset_hebrew;
5211 break;
5212 case VIETNAMESE_CHARSET:
5213 charset_type = Qw32_charset_vietnamese;
5214 break;
5215 case THAI_CHARSET:
5216 charset_type = Qw32_charset_thai;
5217 break;
5218 case MAC_CHARSET:
5219 charset_type = Qw32_charset_mac;
5220 break;
5221 case JOHAB_CHARSET:
5222 charset_type = Qw32_charset_johab;
5223 break;
5224 #endif
5226 #ifdef UNICODE_CHARSET
5227 case UNICODE_CHARSET:
5228 charset_type = Qw32_charset_unicode;
5229 break;
5230 #endif
5231 default:
5232 /* Encode numerical value of unknown charset. */
5233 sprintf (buf, "*-#%u", fncharset);
5234 return Fcons (build_string (buf), Qnil);
5238 Lisp_Object rest;
5239 /* Look through w32-charset-info-alist for the character set.
5240 Only return charsets for codepages which are installed.
5242 Format of each entry in Vw32_charset_info_alist is
5243 (CHARSET_NAME . (WINDOWS_CHARSET . CODEPAGE)).
5245 for (rest = Vw32_charset_info_alist; CONSP (rest); rest = XCDR (rest))
5247 Lisp_Object x_charset;
5248 Lisp_Object w32_charset;
5249 Lisp_Object codepage;
5251 Lisp_Object this_entry = XCAR (rest);
5253 /* Skip invalid entries in alist. */
5254 if (!CONSP (this_entry) || !STRINGP (XCAR (this_entry))
5255 || !CONSP (XCDR (this_entry))
5256 || !SYMBOLP (XCAR (XCDR (this_entry))))
5257 continue;
5259 x_charset = XCAR (this_entry);
5260 w32_charset = XCAR (XCDR (this_entry));
5261 codepage = XCDR (XCDR (this_entry));
5263 /* Look for Same charset and a valid codepage (or non-int
5264 which means ignore). */
5265 if (w32_charset == charset_type
5266 && (!INTEGERP (codepage) || codepage == CP_DEFAULT
5267 || IsValidCodePage (XINT (codepage))))
5269 retval = Fcons (x_charset, retval);
5273 /* If no match, encode the numeric value. */
5274 if (NILP (retval))
5276 sprintf (buf, "*-#%u", fncharset);
5277 return Fcons (build_string (buf), Qnil);
5280 return retval;
5284 /* Get the Windows codepage corresponding to the specified font. The
5285 charset info in the font name is used to look up
5286 w32-charset-to-codepage-alist. */
5288 w32_codepage_for_font (char *fontname)
5290 Lisp_Object codepage, entry;
5291 char *charset_str, *charset, *end;
5293 if (NILP (Vw32_charset_info_alist))
5294 return CP_DEFAULT;
5296 /* Extract charset part of font string. */
5297 charset = xlfd_charset_of_font (fontname);
5299 if (!charset)
5300 return CP_UNKNOWN;
5302 charset_str = (char *) alloca (strlen (charset) + 1);
5303 strcpy (charset_str, charset);
5305 #if 0
5306 /* Remove leading "*-". */
5307 if (strncmp ("*-", charset_str, 2) == 0)
5308 charset = charset_str + 2;
5309 else
5310 #endif
5311 charset = charset_str;
5313 /* Stop match at wildcard (including preceding '-'). */
5314 if (end = strchr (charset, '*'))
5316 if (end > charset && *(end-1) == '-')
5317 end--;
5318 *end = '\0';
5321 entry = Fassoc (build_string(charset), Vw32_charset_info_alist);
5322 if (NILP (entry))
5323 return CP_UNKNOWN;
5325 codepage = Fcdr (Fcdr (entry));
5327 if (NILP (codepage))
5328 return CP_8BIT;
5329 else if (XFASTINT (codepage) == XFASTINT (Qt))
5330 return CP_UNICODE;
5331 else if (INTEGERP (codepage))
5332 return XINT (codepage);
5333 else
5334 return CP_UNKNOWN;
5338 static BOOL
5339 w32_to_x_font (lplogfont, lpxstr, len, specific_charset)
5340 LOGFONT * lplogfont;
5341 char * lpxstr;
5342 int len;
5343 char * specific_charset;
5345 char* fonttype;
5346 char *fontname;
5347 char height_pixels[8];
5348 char height_dpi[8];
5349 char width_pixels[8];
5350 char *fontname_dash;
5351 int display_resy = (int) one_w32_display_info.resy;
5352 int display_resx = (int) one_w32_display_info.resx;
5353 int bufsz;
5354 struct coding_system coding;
5356 if (!lpxstr) abort ();
5358 if (!lplogfont)
5359 return FALSE;
5361 if (lplogfont->lfOutPrecision == OUT_STRING_PRECIS)
5362 fonttype = "raster";
5363 else if (lplogfont->lfOutPrecision == OUT_STROKE_PRECIS)
5364 fonttype = "outline";
5365 else
5366 fonttype = "unknown";
5368 setup_coding_system (Fcheck_coding_system (Vlocale_coding_system),
5369 &coding);
5370 coding.src_multibyte = 0;
5371 coding.dst_multibyte = 1;
5372 coding.mode |= CODING_MODE_LAST_BLOCK;
5373 /* We explicitely disable composition handling because selection
5374 data should not contain any composition sequence. */
5375 coding.composing = COMPOSITION_DISABLED;
5376 bufsz = decoding_buffer_size (&coding, LF_FACESIZE);
5378 fontname = alloca(sizeof(*fontname) * bufsz);
5379 decode_coding (&coding, lplogfont->lfFaceName, fontname,
5380 strlen(lplogfont->lfFaceName), bufsz - 1);
5381 *(fontname + coding.produced) = '\0';
5383 /* Replace dashes with underscores so the dashes are not
5384 misinterpreted. */
5385 fontname_dash = fontname;
5386 while (fontname_dash = strchr (fontname_dash, '-'))
5387 *fontname_dash = '_';
5389 if (lplogfont->lfHeight)
5391 sprintf (height_pixels, "%u", abs (lplogfont->lfHeight));
5392 sprintf (height_dpi, "%u",
5393 abs (lplogfont->lfHeight) * 720 / display_resy);
5395 else
5397 strcpy (height_pixels, "*");
5398 strcpy (height_dpi, "*");
5400 if (lplogfont->lfWidth)
5401 sprintf (width_pixels, "%u", lplogfont->lfWidth * 10);
5402 else
5403 strcpy (width_pixels, "*");
5405 _snprintf (lpxstr, len - 1,
5406 "-%s-%s-%s-%c-normal-normal-%s-%s-%d-%d-%c-%s-%s",
5407 fonttype, /* foundry */
5408 fontname, /* family */
5409 w32_to_x_weight (lplogfont->lfWeight), /* weight */
5410 lplogfont->lfItalic?'i':'r', /* slant */
5411 /* setwidth name */
5412 /* add style name */
5413 height_pixels, /* pixel size */
5414 height_dpi, /* point size */
5415 display_resx, /* resx */
5416 display_resy, /* resy */
5417 ((lplogfont->lfPitchAndFamily & 0x3) == VARIABLE_PITCH)
5418 ? 'p' : 'c', /* spacing */
5419 width_pixels, /* avg width */
5420 specific_charset ? specific_charset
5421 : w32_to_x_charset (lplogfont->lfCharSet)
5422 /* charset registry and encoding */
5425 lpxstr[len - 1] = 0; /* just to be sure */
5426 return (TRUE);
5429 static BOOL
5430 x_to_w32_font (lpxstr, lplogfont)
5431 char * lpxstr;
5432 LOGFONT * lplogfont;
5434 struct coding_system coding;
5436 if (!lplogfont) return (FALSE);
5438 memset (lplogfont, 0, sizeof (*lplogfont));
5440 /* Set default value for each field. */
5441 #if 1
5442 lplogfont->lfOutPrecision = OUT_DEFAULT_PRECIS;
5443 lplogfont->lfClipPrecision = CLIP_DEFAULT_PRECIS;
5444 lplogfont->lfQuality = DEFAULT_QUALITY;
5445 #else
5446 /* go for maximum quality */
5447 lplogfont->lfOutPrecision = OUT_STROKE_PRECIS;
5448 lplogfont->lfClipPrecision = CLIP_STROKE_PRECIS;
5449 lplogfont->lfQuality = PROOF_QUALITY;
5450 #endif
5452 lplogfont->lfCharSet = DEFAULT_CHARSET;
5453 lplogfont->lfWeight = FW_DONTCARE;
5454 lplogfont->lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE;
5456 if (!lpxstr)
5457 return FALSE;
5459 /* Provide a simple escape mechanism for specifying Windows font names
5460 * directly -- if font spec does not beginning with '-', assume this
5461 * format:
5462 * "<font name>[:height in pixels[:width in pixels[:weight]]]"
5465 if (*lpxstr == '-')
5467 int fields, tem;
5468 char name[50], weight[20], slant, pitch, pixels[10], height[10],
5469 width[10], resy[10], remainder[50];
5470 char * encoding;
5471 int dpi = (int) one_w32_display_info.resy;
5473 fields = sscanf (lpxstr,
5474 "-%*[^-]-%49[^-]-%19[^-]-%c-%*[^-]-%*[^-]-%9[^-]-%9[^-]-%*[^-]-%9[^-]-%c-%9[^-]-%49s",
5475 name, weight, &slant, pixels, height, resy, &pitch, width, remainder);
5476 if (fields == EOF)
5477 return (FALSE);
5479 /* In the general case when wildcards cover more than one field,
5480 we don't know which field is which, so don't fill any in.
5481 However, we need to cope with this particular form, which is
5482 generated by font_list_1 (invoked by try_font_list):
5483 "-raster-6x10-*-gb2312*-*"
5484 and make sure to correctly parse the charset field. */
5485 if (fields == 3)
5487 fields = sscanf (lpxstr,
5488 "-%*[^-]-%49[^-]-*-%49s",
5489 name, remainder);
5491 else if (fields < 9)
5493 fields = 0;
5494 remainder[0] = 0;
5497 if (fields > 0 && name[0] != '*')
5499 int bufsize;
5500 unsigned char *buf;
5502 setup_coding_system
5503 (Fcheck_coding_system (Vlocale_coding_system), &coding);
5504 coding.src_multibyte = 1;
5505 coding.dst_multibyte = 1;
5506 bufsize = encoding_buffer_size (&coding, strlen (name));
5507 buf = (unsigned char *) alloca (bufsize);
5508 coding.mode |= CODING_MODE_LAST_BLOCK;
5509 encode_coding (&coding, name, buf, strlen (name), bufsize);
5510 if (coding.produced >= LF_FACESIZE)
5511 coding.produced = LF_FACESIZE - 1;
5512 buf[coding.produced] = 0;
5513 strcpy (lplogfont->lfFaceName, buf);
5515 else
5517 lplogfont->lfFaceName[0] = '\0';
5520 fields--;
5522 lplogfont->lfWeight = x_to_w32_weight ((fields > 0 ? weight : ""));
5524 fields--;
5526 lplogfont->lfItalic = (fields > 0 && slant == 'i');
5528 fields--;
5530 if (fields > 0 && pixels[0] != '*')
5531 lplogfont->lfHeight = atoi (pixels);
5533 fields--;
5534 fields--;
5535 if (fields > 0 && resy[0] != '*')
5537 tem = atoi (resy);
5538 if (tem > 0) dpi = tem;
5541 if (fields > -1 && lplogfont->lfHeight == 0 && height[0] != '*')
5542 lplogfont->lfHeight = atoi (height) * dpi / 720;
5544 if (fields > 0)
5545 lplogfont->lfPitchAndFamily =
5546 (fields > 0 && pitch == 'p') ? VARIABLE_PITCH : FIXED_PITCH;
5548 fields--;
5550 if (fields > 0 && width[0] != '*')
5551 lplogfont->lfWidth = atoi (width) / 10;
5553 fields--;
5555 /* Strip the trailing '-' if present. (it shouldn't be, as it
5556 fails the test against xlfd-tight-regexp in fontset.el). */
5558 int len = strlen (remainder);
5559 if (len > 0 && remainder[len-1] == '-')
5560 remainder[len-1] = 0;
5562 encoding = remainder;
5563 #if 0
5564 if (strncmp (encoding, "*-", 2) == 0)
5565 encoding += 2;
5566 #endif
5567 lplogfont->lfCharSet = x_to_w32_charset (encoding);
5569 else
5571 int fields;
5572 char name[100], height[10], width[10], weight[20];
5574 fields = sscanf (lpxstr,
5575 "%99[^:]:%9[^:]:%9[^:]:%19s",
5576 name, height, width, weight);
5578 if (fields == EOF) return (FALSE);
5580 if (fields > 0)
5582 strncpy (lplogfont->lfFaceName,name, LF_FACESIZE);
5583 lplogfont->lfFaceName[LF_FACESIZE-1] = 0;
5585 else
5587 lplogfont->lfFaceName[0] = 0;
5590 fields--;
5592 if (fields > 0)
5593 lplogfont->lfHeight = atoi (height);
5595 fields--;
5597 if (fields > 0)
5598 lplogfont->lfWidth = atoi (width);
5600 fields--;
5602 lplogfont->lfWeight = x_to_w32_weight ((fields > 0 ? weight : ""));
5605 /* This makes TrueType fonts work better. */
5606 lplogfont->lfHeight = - abs (lplogfont->lfHeight);
5608 return (TRUE);
5611 /* Strip the pixel height and point height from the given xlfd, and
5612 return the pixel height. If no pixel height is specified, calculate
5613 one from the point height, or if that isn't defined either, return
5614 0 (which usually signifies a scalable font).
5616 static int
5617 xlfd_strip_height (char *fontname)
5619 int pixel_height, field_number;
5620 char *read_from, *write_to;
5622 xassert (fontname);
5624 pixel_height = field_number = 0;
5625 write_to = NULL;
5627 /* Look for height fields. */
5628 for (read_from = fontname; *read_from; read_from++)
5630 if (*read_from == '-')
5632 field_number++;
5633 if (field_number == 7) /* Pixel height. */
5635 read_from++;
5636 write_to = read_from;
5638 /* Find end of field. */
5639 for (;*read_from && *read_from != '-'; read_from++)
5642 /* Split the fontname at end of field. */
5643 if (*read_from)
5645 *read_from = '\0';
5646 read_from++;
5648 pixel_height = atoi (write_to);
5649 /* Blank out field. */
5650 if (read_from > write_to)
5652 *write_to = '-';
5653 write_to++;
5655 /* If the pixel height field is at the end (partial xlfd),
5656 return now. */
5657 else
5658 return pixel_height;
5660 /* If we got a pixel height, the point height can be
5661 ignored. Just blank it out and break now. */
5662 if (pixel_height)
5664 /* Find end of point size field. */
5665 for (; *read_from && *read_from != '-'; read_from++)
5668 if (*read_from)
5669 read_from++;
5671 /* Blank out the point size field. */
5672 if (read_from > write_to)
5674 *write_to = '-';
5675 write_to++;
5677 else
5678 return pixel_height;
5680 break;
5682 /* If the point height is already blank, break now. */
5683 if (*read_from == '-')
5685 read_from++;
5686 break;
5689 else if (field_number == 8)
5691 /* If we didn't get a pixel height, try to get the point
5692 height and convert that. */
5693 int point_size;
5694 char *point_size_start = read_from++;
5696 /* Find end of field. */
5697 for (; *read_from && *read_from != '-'; read_from++)
5700 if (*read_from)
5702 *read_from = '\0';
5703 read_from++;
5706 point_size = atoi (point_size_start);
5708 /* Convert to pixel height. */
5709 pixel_height = point_size
5710 * one_w32_display_info.height_in / 720;
5712 /* Blank out this field and break. */
5713 *write_to = '-';
5714 write_to++;
5715 break;
5720 /* Shift the rest of the font spec into place. */
5721 if (write_to && read_from > write_to)
5723 for (; *read_from; read_from++, write_to++)
5724 *write_to = *read_from;
5725 *write_to = '\0';
5728 return pixel_height;
5731 /* Assume parameter 1 is fully qualified, no wildcards. */
5732 static BOOL
5733 w32_font_match (fontname, pattern)
5734 char * fontname;
5735 char * pattern;
5737 char *regex = alloca (strlen (pattern) * 2 + 3);
5738 char *font_name_copy = alloca (strlen (fontname) + 1);
5739 char *ptr;
5741 /* Copy fontname so we can modify it during comparison. */
5742 strcpy (font_name_copy, fontname);
5744 ptr = regex;
5745 *ptr++ = '^';
5747 /* Turn pattern into a regexp and do a regexp match. */
5748 for (; *pattern; pattern++)
5750 if (*pattern == '?')
5751 *ptr++ = '.';
5752 else if (*pattern == '*')
5754 *ptr++ = '.';
5755 *ptr++ = '*';
5757 else
5758 *ptr++ = *pattern;
5760 *ptr = '$';
5761 *(ptr + 1) = '\0';
5763 /* Strip out font heights and compare them seperately, since
5764 rounding error can cause mismatches. This also allows a
5765 comparison between a font that declares only a pixel height and a
5766 pattern that declares the point height.
5769 int font_height, pattern_height;
5771 font_height = xlfd_strip_height (font_name_copy);
5772 pattern_height = xlfd_strip_height (regex);
5774 /* Compare now, and don't bother doing expensive regexp matching
5775 if the heights differ. */
5776 if (font_height && pattern_height && (font_height != pattern_height))
5777 return FALSE;
5780 return (fast_c_string_match_ignore_case (build_string (regex),
5781 font_name_copy) >= 0);
5784 /* Callback functions, and a structure holding info they need, for
5785 listing system fonts on W32. We need one set of functions to do the
5786 job properly, but these don't work on NT 3.51 and earlier, so we
5787 have a second set which don't handle character sets properly to
5788 fall back on.
5790 In both cases, there are two passes made. The first pass gets one
5791 font from each family, the second pass lists all the fonts from
5792 each family. */
5794 typedef struct enumfont_t
5796 HDC hdc;
5797 int numFonts;
5798 LOGFONT logfont;
5799 XFontStruct *size_ref;
5800 Lisp_Object pattern;
5801 Lisp_Object list;
5802 } enumfont_t;
5805 static void
5806 enum_font_maybe_add_to_list (enumfont_t *, LOGFONT *, char *, Lisp_Object);
5809 static int CALLBACK
5810 enum_font_cb2 (lplf, lptm, FontType, lpef)
5811 ENUMLOGFONT * lplf;
5812 NEWTEXTMETRIC * lptm;
5813 int FontType;
5814 enumfont_t * lpef;
5816 /* Ignore struck out and underlined versions of fonts. */
5817 if (lplf->elfLogFont.lfStrikeOut || lplf->elfLogFont.lfUnderline)
5818 return 1;
5820 /* Only return fonts with names starting with @ if they were
5821 explicitly specified, since Microsoft uses an initial @ to
5822 denote fonts for vertical writing, without providing a more
5823 convenient way of identifying them. */
5824 if (lplf->elfLogFont.lfFaceName[0] == '@'
5825 && lpef->logfont.lfFaceName[0] != '@')
5826 return 1;
5828 /* Check that the character set matches if it was specified */
5829 if (lpef->logfont.lfCharSet != DEFAULT_CHARSET &&
5830 lplf->elfLogFont.lfCharSet != lpef->logfont.lfCharSet)
5831 return 1;
5833 if (FontType == RASTER_FONTTYPE)
5835 /* DBCS raster fonts have problems displaying, so skip them. */
5836 int charset = lplf->elfLogFont.lfCharSet;
5837 if (charset == SHIFTJIS_CHARSET
5838 || charset == HANGEUL_CHARSET
5839 || charset == CHINESEBIG5_CHARSET
5840 || charset == GB2312_CHARSET
5841 #ifdef JOHAB_CHARSET
5842 || charset == JOHAB_CHARSET
5843 #endif
5845 return 1;
5849 char buf[100];
5850 Lisp_Object width = Qnil;
5851 Lisp_Object charset_list = Qnil;
5852 char *charset = NULL;
5854 /* Truetype fonts do not report their true metrics until loaded */
5855 if (FontType != RASTER_FONTTYPE)
5857 if (!NILP (lpef->pattern))
5859 /* Scalable fonts are as big as you want them to be. */
5860 lplf->elfLogFont.lfHeight = lpef->logfont.lfHeight;
5861 lplf->elfLogFont.lfWidth = lpef->logfont.lfWidth;
5862 width = make_number (lpef->logfont.lfWidth);
5864 else
5866 lplf->elfLogFont.lfHeight = 0;
5867 lplf->elfLogFont.lfWidth = 0;
5871 /* Make sure the height used here is the same as everywhere
5872 else (ie character height, not cell height). */
5873 if (lplf->elfLogFont.lfHeight > 0)
5875 /* lptm can be trusted for RASTER fonts, but not scalable ones. */
5876 if (FontType == RASTER_FONTTYPE)
5877 lplf->elfLogFont.lfHeight = lptm->tmInternalLeading - lptm->tmHeight;
5878 else
5879 lplf->elfLogFont.lfHeight = -lplf->elfLogFont.lfHeight;
5882 if (!NILP (lpef->pattern))
5884 charset = xlfd_charset_of_font (SDATA (lpef->pattern));
5886 /* We already checked charsets above, but DEFAULT_CHARSET
5887 slipped through. So only allow exact matches for DEFAULT_CHARSET. */
5888 if (charset
5889 && strncmp (charset, "*-*", 3) != 0
5890 && lpef->logfont.lfCharSet == DEFAULT_CHARSET
5891 && strcmp (charset, w32_to_x_charset (DEFAULT_CHARSET)) != 0)
5892 return 1;
5895 if (charset)
5896 charset_list = Fcons (build_string (charset), Qnil);
5897 else
5898 charset_list = w32_to_all_x_charsets (lplf->elfLogFont.lfCharSet);
5900 /* Loop through the charsets. */
5901 for ( ; CONSP (charset_list); charset_list = Fcdr (charset_list))
5903 Lisp_Object this_charset = Fcar (charset_list);
5904 charset = SDATA (this_charset);
5906 /* List bold and italic variations if w32-enable-synthesized-fonts
5907 is non-nil and this is a plain font. */
5908 if (w32_enable_synthesized_fonts
5909 && lplf->elfLogFont.lfWeight == FW_NORMAL
5910 && lplf->elfLogFont.lfItalic == FALSE)
5912 enum_font_maybe_add_to_list (lpef, &(lplf->elfLogFont),
5913 charset, width);
5914 /* bold. */
5915 lplf->elfLogFont.lfWeight = FW_BOLD;
5916 enum_font_maybe_add_to_list (lpef, &(lplf->elfLogFont),
5917 charset, width);
5918 /* bold italic. */
5919 lplf->elfLogFont.lfItalic = TRUE;
5920 enum_font_maybe_add_to_list (lpef, &(lplf->elfLogFont),
5921 charset, width);
5922 /* italic. */
5923 lplf->elfLogFont.lfWeight = FW_NORMAL;
5924 enum_font_maybe_add_to_list (lpef, &(lplf->elfLogFont),
5925 charset, width);
5927 else
5928 enum_font_maybe_add_to_list (lpef, &(lplf->elfLogFont),
5929 charset, width);
5933 return 1;
5936 static void
5937 enum_font_maybe_add_to_list (lpef, logfont, match_charset, width)
5938 enumfont_t * lpef;
5939 LOGFONT * logfont;
5940 char * match_charset;
5941 Lisp_Object width;
5943 char buf[100];
5945 if (!w32_to_x_font (logfont, buf, 100, match_charset))
5946 return;
5948 if (NILP (lpef->pattern)
5949 || w32_font_match (buf, SDATA (lpef->pattern)))
5951 /* Check if we already listed this font. This may happen if
5952 w32_enable_synthesized_fonts is non-nil, and there are real
5953 bold and italic versions of the font. */
5954 Lisp_Object font_name = build_string (buf);
5955 if (NILP (Fmember (font_name, lpef->list)))
5957 Lisp_Object entry = Fcons (font_name, width);
5958 lpef->list = Fcons (entry, lpef->list);
5959 lpef->numFonts++;
5965 static int CALLBACK
5966 enum_font_cb1 (lplf, lptm, FontType, lpef)
5967 ENUMLOGFONT * lplf;
5968 NEWTEXTMETRIC * lptm;
5969 int FontType;
5970 enumfont_t * lpef;
5972 return EnumFontFamilies (lpef->hdc,
5973 lplf->elfLogFont.lfFaceName,
5974 (FONTENUMPROC) enum_font_cb2,
5975 (LPARAM) lpef);
5979 static int CALLBACK
5980 enum_fontex_cb2 (lplf, lptm, font_type, lpef)
5981 ENUMLOGFONTEX * lplf;
5982 NEWTEXTMETRICEX * lptm;
5983 int font_type;
5984 enumfont_t * lpef;
5986 /* We are not interested in the extra info we get back from the 'Ex
5987 version - only the fact that we get character set variations
5988 enumerated seperately. */
5989 return enum_font_cb2 ((ENUMLOGFONT *) lplf, (NEWTEXTMETRIC *) lptm,
5990 font_type, lpef);
5993 static int CALLBACK
5994 enum_fontex_cb1 (lplf, lptm, font_type, lpef)
5995 ENUMLOGFONTEX * lplf;
5996 NEWTEXTMETRICEX * lptm;
5997 int font_type;
5998 enumfont_t * lpef;
6000 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
6001 FARPROC enum_font_families_ex
6002 = GetProcAddress ( gdi32, "EnumFontFamiliesExA");
6003 /* We don't really expect EnumFontFamiliesEx to disappear once we
6004 get here, so don't bother handling it gracefully. */
6005 if (enum_font_families_ex == NULL)
6006 error ("gdi32.dll has disappeared!");
6007 return enum_font_families_ex (lpef->hdc,
6008 &lplf->elfLogFont,
6009 (FONTENUMPROC) enum_fontex_cb2,
6010 (LPARAM) lpef, 0);
6013 /* Interface to fontset handler. (adapted from mw32font.c in Meadow
6014 and xterm.c in Emacs 20.3) */
6016 static Lisp_Object w32_list_bdf_fonts (Lisp_Object pattern, int max_names)
6018 char *fontname, *ptnstr;
6019 Lisp_Object list, tem, newlist = Qnil;
6020 int n_fonts = 0;
6022 list = Vw32_bdf_filename_alist;
6023 ptnstr = SDATA (pattern);
6025 for ( ; CONSP (list); list = XCDR (list))
6027 tem = XCAR (list);
6028 if (CONSP (tem))
6029 fontname = SDATA (XCAR (tem));
6030 else if (STRINGP (tem))
6031 fontname = SDATA (tem);
6032 else
6033 continue;
6035 if (w32_font_match (fontname, ptnstr))
6037 newlist = Fcons (XCAR (tem), newlist);
6038 n_fonts++;
6039 if (max_names >= 0 && n_fonts >= max_names)
6040 break;
6044 return newlist;
6048 /* Return a list of names of available fonts matching PATTERN on frame
6049 F. If SIZE is not 0, it is the size (maximum bound width) of fonts
6050 to be listed. Frame F NULL means we have not yet created any
6051 frame, which means we can't get proper size info, as we don't have
6052 a device context to use for GetTextMetrics.
6053 MAXNAMES sets a limit on how many fonts to match. If MAXNAMES is
6054 negative, then all matching fonts are returned. */
6056 Lisp_Object
6057 w32_list_fonts (f, pattern, size, maxnames)
6058 struct frame *f;
6059 Lisp_Object pattern;
6060 int size;
6061 int maxnames;
6063 Lisp_Object patterns, key = Qnil, tem, tpat;
6064 Lisp_Object list = Qnil, newlist = Qnil, second_best = Qnil;
6065 struct w32_display_info *dpyinfo = &one_w32_display_info;
6066 int n_fonts = 0;
6068 patterns = Fassoc (pattern, Valternate_fontname_alist);
6069 if (NILP (patterns))
6070 patterns = Fcons (pattern, Qnil);
6072 for (; CONSP (patterns); patterns = XCDR (patterns))
6074 enumfont_t ef;
6075 int codepage;
6077 tpat = XCAR (patterns);
6079 if (!STRINGP (tpat))
6080 continue;
6082 /* Avoid expensive EnumFontFamilies functions if we are not
6083 going to be able to output one of these anyway. */
6084 codepage = w32_codepage_for_font (SDATA (tpat));
6085 if (codepage != CP_8BIT && codepage != CP_UNICODE
6086 && codepage != CP_DEFAULT && codepage != CP_UNKNOWN
6087 && !IsValidCodePage(codepage))
6088 continue;
6090 /* See if we cached the result for this particular query.
6091 The cache is an alist of the form:
6092 ((PATTERN (FONTNAME . WIDTH) ...) ...)
6094 if (tem = XCDR (dpyinfo->name_list_element),
6095 !NILP (list = Fassoc (tpat, tem)))
6097 list = Fcdr_safe (list);
6098 /* We have a cached list. Don't have to get the list again. */
6099 goto label_cached;
6102 BLOCK_INPUT;
6103 /* At first, put PATTERN in the cache. */
6104 ef.pattern = tpat;
6105 ef.list = Qnil;
6106 ef.numFonts = 0;
6108 /* Use EnumFontFamiliesEx where it is available, as it knows
6109 about character sets. Fall back to EnumFontFamilies for
6110 older versions of NT that don't support the 'Ex function. */
6111 x_to_w32_font (SDATA (tpat), &ef.logfont);
6113 LOGFONT font_match_pattern;
6114 HMODULE gdi32 = GetModuleHandle ("gdi32.dll");
6115 FARPROC enum_font_families_ex
6116 = GetProcAddress ( gdi32, "EnumFontFamiliesExA");
6118 /* We do our own pattern matching so we can handle wildcards. */
6119 font_match_pattern.lfFaceName[0] = 0;
6120 font_match_pattern.lfPitchAndFamily = 0;
6121 /* We can use the charset, because if it is a wildcard it will
6122 be DEFAULT_CHARSET anyway. */
6123 font_match_pattern.lfCharSet = ef.logfont.lfCharSet;
6125 ef.hdc = GetDC (dpyinfo->root_window);
6127 if (enum_font_families_ex)
6128 enum_font_families_ex (ef.hdc,
6129 &font_match_pattern,
6130 (FONTENUMPROC) enum_fontex_cb1,
6131 (LPARAM) &ef, 0);
6132 else
6133 EnumFontFamilies (ef.hdc, NULL, (FONTENUMPROC) enum_font_cb1,
6134 (LPARAM)&ef);
6136 ReleaseDC (dpyinfo->root_window, ef.hdc);
6139 UNBLOCK_INPUT;
6140 list = ef.list;
6142 /* Make a list of the fonts we got back.
6143 Store that in the font cache for the display. */
6144 XSETCDR (dpyinfo->name_list_element,
6145 Fcons (Fcons (tpat, list),
6146 XCDR (dpyinfo->name_list_element)));
6148 label_cached:
6149 if (NILP (list)) continue; /* Try the remaining alternatives. */
6151 newlist = second_best = Qnil;
6153 /* Make a list of the fonts that have the right width. */
6154 for (; CONSP (list); list = XCDR (list))
6156 int found_size;
6157 tem = XCAR (list);
6159 if (!CONSP (tem))
6160 continue;
6161 if (NILP (XCAR (tem)))
6162 continue;
6163 if (!size)
6165 newlist = Fcons (XCAR (tem), newlist);
6166 n_fonts++;
6167 if (maxnames >= 0 && n_fonts >= maxnames)
6168 break;
6169 else
6170 continue;
6172 if (!INTEGERP (XCDR (tem)))
6174 /* Since we don't yet know the size of the font, we must
6175 load it and try GetTextMetrics. */
6176 W32FontStruct thisinfo;
6177 LOGFONT lf;
6178 HDC hdc;
6179 HANDLE oldobj;
6181 if (!x_to_w32_font (SDATA (XCAR (tem)), &lf))
6182 continue;
6184 BLOCK_INPUT;
6185 thisinfo.bdf = NULL;
6186 thisinfo.hfont = CreateFontIndirect (&lf);
6187 if (thisinfo.hfont == NULL)
6188 continue;
6190 hdc = GetDC (dpyinfo->root_window);
6191 oldobj = SelectObject (hdc, thisinfo.hfont);
6192 if (GetTextMetrics (hdc, &thisinfo.tm))
6193 XSETCDR (tem, make_number (FONT_WIDTH (&thisinfo)));
6194 else
6195 XSETCDR (tem, make_number (0));
6196 SelectObject (hdc, oldobj);
6197 ReleaseDC (dpyinfo->root_window, hdc);
6198 DeleteObject(thisinfo.hfont);
6199 UNBLOCK_INPUT;
6201 found_size = XINT (XCDR (tem));
6202 if (found_size == size)
6204 newlist = Fcons (XCAR (tem), newlist);
6205 n_fonts++;
6206 if (maxnames >= 0 && n_fonts >= maxnames)
6207 break;
6209 /* keep track of the closest matching size in case
6210 no exact match is found. */
6211 else if (found_size > 0)
6213 if (NILP (second_best))
6214 second_best = tem;
6216 else if (found_size < size)
6218 if (XINT (XCDR (second_best)) > size
6219 || XINT (XCDR (second_best)) < found_size)
6220 second_best = tem;
6222 else
6224 if (XINT (XCDR (second_best)) > size
6225 && XINT (XCDR (second_best)) >
6226 found_size)
6227 second_best = tem;
6232 if (!NILP (newlist))
6233 break;
6234 else if (!NILP (second_best))
6236 newlist = Fcons (XCAR (second_best), Qnil);
6237 break;
6241 /* Include any bdf fonts. */
6242 if (n_fonts < maxnames || maxnames < 0)
6244 Lisp_Object combined[2];
6245 combined[0] = w32_list_bdf_fonts (pattern, maxnames - n_fonts);
6246 combined[1] = newlist;
6247 newlist = Fnconc(2, combined);
6250 return newlist;
6254 /* Return a pointer to struct font_info of font FONT_IDX of frame F. */
6255 struct font_info *
6256 w32_get_font_info (f, font_idx)
6257 FRAME_PTR f;
6258 int font_idx;
6260 return (FRAME_W32_FONT_TABLE (f) + font_idx);
6264 struct font_info*
6265 w32_query_font (struct frame *f, char *fontname)
6267 int i;
6268 struct font_info *pfi;
6270 pfi = FRAME_W32_FONT_TABLE (f);
6272 for (i = 0; i < one_w32_display_info.n_fonts ;i++, pfi++)
6274 if (strcmp(pfi->name, fontname) == 0) return pfi;
6277 return NULL;
6280 /* Find a CCL program for a font specified by FONTP, and set the member
6281 `encoder' of the structure. */
6283 void
6284 w32_find_ccl_program (fontp)
6285 struct font_info *fontp;
6287 Lisp_Object list, elt;
6289 for (list = Vfont_ccl_encoder_alist; CONSP (list); list = XCDR (list))
6291 elt = XCAR (list);
6292 if (CONSP (elt)
6293 && STRINGP (XCAR (elt))
6294 && (fast_c_string_match_ignore_case (XCAR (elt), fontp->name)
6295 >= 0))
6296 break;
6298 if (! NILP (list))
6300 struct ccl_program *ccl
6301 = (struct ccl_program *) xmalloc (sizeof (struct ccl_program));
6303 if (setup_ccl_program (ccl, XCDR (elt)) < 0)
6304 xfree (ccl);
6305 else
6306 fontp->font_encoder = ccl;
6311 /* Find BDF files in a specified directory. (use GCPRO when calling,
6312 as this calls lisp to get a directory listing). */
6313 static Lisp_Object
6314 w32_find_bdf_fonts_in_dir (Lisp_Object directory)
6316 Lisp_Object filelist, list = Qnil;
6317 char fontname[100];
6319 if (!STRINGP(directory))
6320 return Qnil;
6322 filelist = Fdirectory_files (directory, Qt,
6323 build_string (".*\\.[bB][dD][fF]"), Qt);
6325 for ( ; CONSP(filelist); filelist = XCDR (filelist))
6327 Lisp_Object filename = XCAR (filelist);
6328 if (w32_BDF_to_x_font (SDATA (filename), fontname, 100))
6329 store_in_alist (&list, build_string (fontname), filename);
6331 return list;
6334 DEFUN ("w32-find-bdf-fonts", Fw32_find_bdf_fonts, Sw32_find_bdf_fonts,
6335 1, 1, 0,
6336 doc: /* Return a list of BDF fonts in DIR.
6337 The list is suitable for appending to w32-bdf-filename-alist. Fonts
6338 which do not contain an xlfd description will not be included in the
6339 list. DIR may be a list of directories. */)
6340 (directory)
6341 Lisp_Object directory;
6343 Lisp_Object list = Qnil;
6344 struct gcpro gcpro1, gcpro2;
6346 if (!CONSP (directory))
6347 return w32_find_bdf_fonts_in_dir (directory);
6349 for ( ; CONSP (directory); directory = XCDR (directory))
6351 Lisp_Object pair[2];
6352 pair[0] = list;
6353 pair[1] = Qnil;
6354 GCPRO2 (directory, list);
6355 pair[1] = w32_find_bdf_fonts_in_dir( XCAR (directory) );
6356 list = Fnconc( 2, pair );
6357 UNGCPRO;
6359 return list;
6363 DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0,
6364 doc: /* Internal function called by `color-defined-p', which see. */)
6365 (color, frame)
6366 Lisp_Object color, frame;
6368 XColor foo;
6369 FRAME_PTR f = check_x_frame (frame);
6371 CHECK_STRING (color);
6373 if (w32_defined_color (f, SDATA (color), &foo, 0))
6374 return Qt;
6375 else
6376 return Qnil;
6379 DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0,
6380 doc: /* Internal function called by `color-values', which see. */)
6381 (color, frame)
6382 Lisp_Object color, frame;
6384 XColor foo;
6385 FRAME_PTR f = check_x_frame (frame);
6387 CHECK_STRING (color);
6389 if (w32_defined_color (f, SDATA (color), &foo, 0))
6391 Lisp_Object rgb[3];
6393 rgb[0] = make_number ((GetRValue (foo.pixel) << 8)
6394 | GetRValue (foo.pixel));
6395 rgb[1] = make_number ((GetGValue (foo.pixel) << 8)
6396 | GetGValue (foo.pixel));
6397 rgb[2] = make_number ((GetBValue (foo.pixel) << 8)
6398 | GetBValue (foo.pixel));
6399 return Flist (3, rgb);
6401 else
6402 return Qnil;
6405 DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0,
6406 doc: /* Internal function called by `display-color-p', which see. */)
6407 (display)
6408 Lisp_Object display;
6410 struct w32_display_info *dpyinfo = check_x_display_info (display);
6412 if ((dpyinfo->n_planes * dpyinfo->n_cbits) <= 2)
6413 return Qnil;
6415 return Qt;
6418 DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p,
6419 Sx_display_grayscale_p, 0, 1, 0,
6420 doc: /* Return t if the X display supports shades of gray.
6421 Note that color displays do support shades of gray.
6422 The optional argument DISPLAY specifies which display to ask about.
6423 DISPLAY should be either a frame or a display name (a string).
6424 If omitted or nil, that stands for the selected frame's display. */)
6425 (display)
6426 Lisp_Object display;
6428 struct w32_display_info *dpyinfo = check_x_display_info (display);
6430 if ((dpyinfo->n_planes * dpyinfo->n_cbits) <= 1)
6431 return Qnil;
6433 return Qt;
6436 DEFUN ("x-display-pixel-width", Fx_display_pixel_width,
6437 Sx_display_pixel_width, 0, 1, 0,
6438 doc: /* Returns the width in pixels of DISPLAY.
6439 The optional argument DISPLAY specifies which display to ask about.
6440 DISPLAY should be either a frame or a display name (a string).
6441 If omitted or nil, that stands for the selected frame's display. */)
6442 (display)
6443 Lisp_Object display;
6445 struct w32_display_info *dpyinfo = check_x_display_info (display);
6447 return make_number (dpyinfo->width);
6450 DEFUN ("x-display-pixel-height", Fx_display_pixel_height,
6451 Sx_display_pixel_height, 0, 1, 0,
6452 doc: /* Returns the height in pixels of DISPLAY.
6453 The optional argument DISPLAY specifies which display to ask about.
6454 DISPLAY should be either a frame or a display name (a string).
6455 If omitted or nil, that stands for the selected frame's display. */)
6456 (display)
6457 Lisp_Object display;
6459 struct w32_display_info *dpyinfo = check_x_display_info (display);
6461 return make_number (dpyinfo->height);
6464 DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes,
6465 0, 1, 0,
6466 doc: /* Returns the number of bitplanes of DISPLAY.
6467 The optional argument DISPLAY specifies which display to ask about.
6468 DISPLAY should be either a frame or a display name (a string).
6469 If omitted or nil, that stands for the selected frame's display. */)
6470 (display)
6471 Lisp_Object display;
6473 struct w32_display_info *dpyinfo = check_x_display_info (display);
6475 return make_number (dpyinfo->n_planes * dpyinfo->n_cbits);
6478 DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells,
6479 0, 1, 0,
6480 doc: /* Returns the number of color cells of DISPLAY.
6481 The optional argument DISPLAY specifies which display to ask about.
6482 DISPLAY should be either a frame or a display name (a string).
6483 If omitted or nil, that stands for the selected frame's display. */)
6484 (display)
6485 Lisp_Object display;
6487 struct w32_display_info *dpyinfo = check_x_display_info (display);
6488 HDC hdc;
6489 int cap;
6491 hdc = GetDC (dpyinfo->root_window);
6492 if (dpyinfo->has_palette)
6493 cap = GetDeviceCaps (hdc,SIZEPALETTE);
6494 else
6495 cap = GetDeviceCaps (hdc,NUMCOLORS);
6497 /* We force 24+ bit depths to 24-bit, both to prevent an overflow
6498 and because probably is more meaningful on Windows anyway */
6499 if (cap < 0)
6500 cap = 1 << min(dpyinfo->n_planes * dpyinfo->n_cbits, 24);
6502 ReleaseDC (dpyinfo->root_window, hdc);
6504 return make_number (cap);
6507 DEFUN ("x-server-max-request-size", Fx_server_max_request_size,
6508 Sx_server_max_request_size,
6509 0, 1, 0,
6510 doc: /* Returns the maximum request size of the server of DISPLAY.
6511 The optional argument DISPLAY specifies which display to ask about.
6512 DISPLAY should be either a frame or a display name (a string).
6513 If omitted or nil, that stands for the selected frame's display. */)
6514 (display)
6515 Lisp_Object display;
6517 struct w32_display_info *dpyinfo = check_x_display_info (display);
6519 return make_number (1);
6522 DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
6523 doc: /* Returns the vendor ID string of the W32 system (Microsoft).
6524 The optional argument DISPLAY specifies which display to ask about.
6525 DISPLAY should be either a frame or a display name (a string).
6526 If omitted or nil, that stands for the selected frame's display. */)
6527 (display)
6528 Lisp_Object display;
6530 return build_string ("Microsoft Corp.");
6533 DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0,
6534 doc: /* Returns the version numbers of the server of DISPLAY.
6535 The value is a list of three integers: the major and minor
6536 version numbers, and the vendor-specific release
6537 number. See also the function `x-server-vendor'.
6539 The optional argument DISPLAY specifies which display to ask about.
6540 DISPLAY should be either a frame or a display name (a string).
6541 If omitted or nil, that stands for the selected frame's display. */)
6542 (display)
6543 Lisp_Object display;
6545 return Fcons (make_number (w32_major_version),
6546 Fcons (make_number (w32_minor_version),
6547 Fcons (make_number (w32_build_number), Qnil)));
6550 DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0,
6551 doc: /* Returns the number of screens on the server of DISPLAY.
6552 The optional argument DISPLAY specifies which display to ask about.
6553 DISPLAY should be either a frame or a display name (a string).
6554 If omitted or nil, that stands for the selected frame's display. */)
6555 (display)
6556 Lisp_Object display;
6558 return make_number (1);
6561 DEFUN ("x-display-mm-height", Fx_display_mm_height,
6562 Sx_display_mm_height, 0, 1, 0,
6563 doc: /* Returns the height in millimeters of DISPLAY.
6564 The optional argument DISPLAY specifies which display to ask about.
6565 DISPLAY should be either a frame or a display name (a string).
6566 If omitted or nil, that stands for the selected frame's display. */)
6567 (display)
6568 Lisp_Object display;
6570 struct w32_display_info *dpyinfo = check_x_display_info (display);
6571 HDC hdc;
6572 int cap;
6574 hdc = GetDC (dpyinfo->root_window);
6576 cap = GetDeviceCaps (hdc, VERTSIZE);
6578 ReleaseDC (dpyinfo->root_window, hdc);
6580 return make_number (cap);
6583 DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0,
6584 doc: /* Returns the width in millimeters of DISPLAY.
6585 The optional argument DISPLAY specifies which display to ask about.
6586 DISPLAY should be either a frame or a display name (a string).
6587 If omitted or nil, that stands for the selected frame's display. */)
6588 (display)
6589 Lisp_Object display;
6591 struct w32_display_info *dpyinfo = check_x_display_info (display);
6593 HDC hdc;
6594 int cap;
6596 hdc = GetDC (dpyinfo->root_window);
6598 cap = GetDeviceCaps (hdc, HORZSIZE);
6600 ReleaseDC (dpyinfo->root_window, hdc);
6602 return make_number (cap);
6605 DEFUN ("x-display-backing-store", Fx_display_backing_store,
6606 Sx_display_backing_store, 0, 1, 0,
6607 doc: /* Returns an indication of whether DISPLAY does backing store.
6608 The value may be `always', `when-mapped', or `not-useful'.
6609 The optional argument DISPLAY specifies which display to ask about.
6610 DISPLAY should be either a frame or a display name (a string).
6611 If omitted or nil, that stands for the selected frame's display. */)
6612 (display)
6613 Lisp_Object display;
6615 return intern ("not-useful");
6618 DEFUN ("x-display-visual-class", Fx_display_visual_class,
6619 Sx_display_visual_class, 0, 1, 0,
6620 doc: /* Returns the visual class of DISPLAY.
6621 The value is one of the symbols `static-gray', `gray-scale',
6622 `static-color', `pseudo-color', `true-color', or `direct-color'.
6624 The optional argument DISPLAY specifies which display to ask about.
6625 DISPLAY should be either a frame or a display name (a string).
6626 If omitted or nil, that stands for the selected frame's display. */)
6627 (display)
6628 Lisp_Object display;
6630 struct w32_display_info *dpyinfo = check_x_display_info (display);
6631 Lisp_Object result = Qnil;
6633 if (dpyinfo->has_palette)
6634 result = intern ("pseudo-color");
6635 else if (dpyinfo->n_planes * dpyinfo->n_cbits == 1)
6636 result = intern ("static-grey");
6637 else if (dpyinfo->n_planes * dpyinfo->n_cbits == 4)
6638 result = intern ("static-color");
6639 else if (dpyinfo->n_planes * dpyinfo->n_cbits > 8)
6640 result = intern ("true-color");
6642 return result;
6645 DEFUN ("x-display-save-under", Fx_display_save_under,
6646 Sx_display_save_under, 0, 1, 0,
6647 doc: /* Returns t if DISPLAY supports the save-under feature.
6648 The optional argument DISPLAY specifies which display to ask about.
6649 DISPLAY should be either a frame or a display name (a string).
6650 If omitted or nil, that stands for the selected frame's display. */)
6651 (display)
6652 Lisp_Object display;
6654 return Qnil;
6658 x_pixel_width (f)
6659 register struct frame *f;
6661 return PIXEL_WIDTH (f);
6665 x_pixel_height (f)
6666 register struct frame *f;
6668 return PIXEL_HEIGHT (f);
6672 x_char_width (f)
6673 register struct frame *f;
6675 return FONT_WIDTH (f->output_data.w32->font);
6679 x_char_height (f)
6680 register struct frame *f;
6682 return f->output_data.w32->line_height;
6686 x_screen_planes (f)
6687 register struct frame *f;
6689 return FRAME_W32_DISPLAY_INFO (f)->n_planes;
6692 /* Return the display structure for the display named NAME.
6693 Open a new connection if necessary. */
6695 struct w32_display_info *
6696 x_display_info_for_name (name)
6697 Lisp_Object name;
6699 Lisp_Object names;
6700 struct w32_display_info *dpyinfo;
6702 CHECK_STRING (name);
6704 for (dpyinfo = &one_w32_display_info, names = w32_display_name_list;
6705 dpyinfo;
6706 dpyinfo = dpyinfo->next, names = XCDR (names))
6708 Lisp_Object tem;
6709 tem = Fstring_equal (XCAR (XCAR (names)), name);
6710 if (!NILP (tem))
6711 return dpyinfo;
6714 /* Use this general default value to start with. */
6715 Vx_resource_name = Vinvocation_name;
6717 validate_x_resource_name ();
6719 dpyinfo = w32_term_init (name, (unsigned char *)0,
6720 (char *) SDATA (Vx_resource_name));
6722 if (dpyinfo == 0)
6723 error ("Cannot connect to server %s", SDATA (name));
6725 w32_in_use = 1;
6726 XSETFASTINT (Vwindow_system_version, 3);
6728 return dpyinfo;
6731 DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection,
6732 1, 3, 0, doc: /* Open a connection to a server.
6733 DISPLAY is the name of the display to connect to.
6734 Optional second arg XRM-STRING is a string of resources in xrdb format.
6735 If the optional third arg MUST-SUCCEED is non-nil,
6736 terminate Emacs if we can't open the connection. */)
6737 (display, xrm_string, must_succeed)
6738 Lisp_Object display, xrm_string, must_succeed;
6740 unsigned char *xrm_option;
6741 struct w32_display_info *dpyinfo;
6743 /* If initialization has already been done, return now to avoid
6744 overwriting critical parts of one_w32_display_info. */
6745 if (w32_in_use)
6746 return Qnil;
6748 CHECK_STRING (display);
6749 if (! NILP (xrm_string))
6750 CHECK_STRING (xrm_string);
6752 if (! EQ (Vwindow_system, intern ("w32")))
6753 error ("Not using Microsoft Windows");
6755 /* Allow color mapping to be defined externally; first look in user's
6756 HOME directory, then in Emacs etc dir for a file called rgb.txt. */
6758 Lisp_Object color_file;
6759 struct gcpro gcpro1;
6761 color_file = build_string("~/rgb.txt");
6763 GCPRO1 (color_file);
6765 if (NILP (Ffile_readable_p (color_file)))
6766 color_file =
6767 Fexpand_file_name (build_string ("rgb.txt"),
6768 Fsymbol_value (intern ("data-directory")));
6770 Vw32_color_map = Fw32_load_color_file (color_file);
6772 UNGCPRO;
6774 if (NILP (Vw32_color_map))
6775 Vw32_color_map = Fw32_default_color_map ();
6777 if (! NILP (xrm_string))
6778 xrm_option = (unsigned char *) SDATA (xrm_string);
6779 else
6780 xrm_option = (unsigned char *) 0;
6782 /* Use this general default value to start with. */
6783 /* First remove .exe suffix from invocation-name - it looks ugly. */
6785 char basename[ MAX_PATH ], *str;
6787 strcpy (basename, SDATA (Vinvocation_name));
6788 str = strrchr (basename, '.');
6789 if (str) *str = 0;
6790 Vinvocation_name = build_string (basename);
6792 Vx_resource_name = Vinvocation_name;
6794 validate_x_resource_name ();
6796 /* This is what opens the connection and sets x_current_display.
6797 This also initializes many symbols, such as those used for input. */
6798 dpyinfo = w32_term_init (display, xrm_option,
6799 (char *) SDATA (Vx_resource_name));
6801 if (dpyinfo == 0)
6803 if (!NILP (must_succeed))
6804 fatal ("Cannot connect to server %s.\n",
6805 SDATA (display));
6806 else
6807 error ("Cannot connect to server %s", SDATA (display));
6810 w32_in_use = 1;
6812 XSETFASTINT (Vwindow_system_version, 3);
6813 return Qnil;
6816 DEFUN ("x-close-connection", Fx_close_connection,
6817 Sx_close_connection, 1, 1, 0,
6818 doc: /* Close the connection to DISPLAY's server.
6819 For DISPLAY, specify either a frame or a display name (a string).
6820 If DISPLAY is nil, that stands for the selected frame's display. */)
6821 (display)
6822 Lisp_Object display;
6824 struct w32_display_info *dpyinfo = check_x_display_info (display);
6825 int i;
6827 if (dpyinfo->reference_count > 0)
6828 error ("Display still has frames on it");
6830 BLOCK_INPUT;
6831 /* Free the fonts in the font table. */
6832 for (i = 0; i < dpyinfo->n_fonts; i++)
6833 if (dpyinfo->font_table[i].name)
6835 if (dpyinfo->font_table[i].name != dpyinfo->font_table[i].full_name)
6836 xfree (dpyinfo->font_table[i].full_name);
6837 xfree (dpyinfo->font_table[i].name);
6838 w32_unload_font (dpyinfo, dpyinfo->font_table[i].font);
6840 x_destroy_all_bitmaps (dpyinfo);
6842 x_delete_display (dpyinfo);
6843 UNBLOCK_INPUT;
6845 return Qnil;
6848 DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0,
6849 doc: /* Return the list of display names that Emacs has connections to. */)
6852 Lisp_Object tail, result;
6854 result = Qnil;
6855 for (tail = w32_display_name_list; ! NILP (tail); tail = XCDR (tail))
6856 result = Fcons (XCAR (XCAR (tail)), result);
6858 return result;
6861 DEFUN ("x-synchronize", Fx_synchronize, Sx_synchronize, 1, 2, 0,
6862 doc: /* This is a noop on W32 systems. */)
6863 (on, display)
6864 Lisp_Object display, on;
6866 return Qnil;
6870 /***********************************************************************
6871 Image types
6872 ***********************************************************************/
6874 /* Value is the number of elements of vector VECTOR. */
6876 #define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR))
6878 /* List of supported image types. Use define_image_type to add new
6879 types. Use lookup_image_type to find a type for a given symbol. */
6881 static struct image_type *image_types;
6883 /* The symbol `image' which is the car of the lists used to represent
6884 images in Lisp. */
6886 extern Lisp_Object Qimage;
6888 /* The symbol `xbm' which is used as the type symbol for XBM images. */
6890 Lisp_Object Qxbm;
6892 /* Keywords. */
6894 extern Lisp_Object QCwidth, QCheight, QCforeground, QCbackground, QCfile;
6895 extern Lisp_Object QCdata, QCtype;
6896 Lisp_Object QCascent, QCmargin, QCrelief;
6897 Lisp_Object QCconversion, QCcolor_symbols, QCheuristic_mask;
6898 Lisp_Object QCindex, QCmatrix, QCcolor_adjustment, QCmask;
6900 /* Other symbols. */
6902 Lisp_Object Qlaplace, Qemboss, Qedge_detection, Qheuristic;
6904 /* Time in seconds after which images should be removed from the cache
6905 if not displayed. */
6907 Lisp_Object Vimage_cache_eviction_delay;
6909 /* Function prototypes. */
6911 static void define_image_type P_ ((struct image_type *type));
6912 static struct image_type *lookup_image_type P_ ((Lisp_Object symbol));
6913 static void image_error P_ ((char *format, Lisp_Object, Lisp_Object));
6914 static void x_laplace P_ ((struct frame *, struct image *));
6915 static void x_emboss P_ ((struct frame *, struct image *));
6916 static int x_build_heuristic_mask P_ ((struct frame *, struct image *,
6917 Lisp_Object));
6920 /* Define a new image type from TYPE. This adds a copy of TYPE to
6921 image_types and adds the symbol *TYPE->type to Vimage_types. */
6923 static void
6924 define_image_type (type)
6925 struct image_type *type;
6927 /* Make a copy of TYPE to avoid a bus error in a dumped Emacs.
6928 The initialized data segment is read-only. */
6929 struct image_type *p = (struct image_type *) xmalloc (sizeof *p);
6930 bcopy (type, p, sizeof *p);
6931 p->next = image_types;
6932 image_types = p;
6933 Vimage_types = Fcons (*p->type, Vimage_types);
6937 /* Look up image type SYMBOL, and return a pointer to its image_type
6938 structure. Value is null if SYMBOL is not a known image type. */
6940 static INLINE struct image_type *
6941 lookup_image_type (symbol)
6942 Lisp_Object symbol;
6944 struct image_type *type;
6946 for (type = image_types; type; type = type->next)
6947 if (EQ (symbol, *type->type))
6948 break;
6950 return type;
6954 /* Value is non-zero if OBJECT is a valid Lisp image specification. A
6955 valid image specification is a list whose car is the symbol
6956 `image', and whose rest is a property list. The property list must
6957 contain a value for key `:type'. That value must be the name of a
6958 supported image type. The rest of the property list depends on the
6959 image type. */
6962 valid_image_p (object)
6963 Lisp_Object object;
6965 int valid_p = 0;
6967 if (CONSP (object) && EQ (XCAR (object), Qimage))
6969 Lisp_Object tem;
6971 for (tem = XCDR (object); CONSP (tem); tem = XCDR (tem))
6972 if (EQ (XCAR (tem), QCtype))
6974 tem = XCDR (tem);
6975 if (CONSP (tem) && SYMBOLP (XCAR (tem)))
6977 struct image_type *type;
6978 type = lookup_image_type (XCAR (tem));
6979 if (type)
6980 valid_p = type->valid_p (object);
6983 break;
6987 return valid_p;
6991 /* Log error message with format string FORMAT and argument ARG.
6992 Signaling an error, e.g. when an image cannot be loaded, is not a
6993 good idea because this would interrupt redisplay, and the error
6994 message display would lead to another redisplay. This function
6995 therefore simply displays a message. */
6997 static void
6998 image_error (format, arg1, arg2)
6999 char *format;
7000 Lisp_Object arg1, arg2;
7002 add_to_log (format, arg1, arg2);
7007 /***********************************************************************
7008 Image specifications
7009 ***********************************************************************/
7011 enum image_value_type
7013 IMAGE_DONT_CHECK_VALUE_TYPE,
7014 IMAGE_STRING_VALUE,
7015 IMAGE_STRING_OR_NIL_VALUE,
7016 IMAGE_SYMBOL_VALUE,
7017 IMAGE_POSITIVE_INTEGER_VALUE,
7018 IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR,
7019 IMAGE_NON_NEGATIVE_INTEGER_VALUE,
7020 IMAGE_ASCENT_VALUE,
7021 IMAGE_INTEGER_VALUE,
7022 IMAGE_FUNCTION_VALUE,
7023 IMAGE_NUMBER_VALUE,
7024 IMAGE_BOOL_VALUE
7027 /* Structure used when parsing image specifications. */
7029 struct image_keyword
7031 /* Name of keyword. */
7032 char *name;
7034 /* The type of value allowed. */
7035 enum image_value_type type;
7037 /* Non-zero means key must be present. */
7038 int mandatory_p;
7040 /* Used to recognize duplicate keywords in a property list. */
7041 int count;
7043 /* The value that was found. */
7044 Lisp_Object value;
7048 static int parse_image_spec P_ ((Lisp_Object, struct image_keyword *,
7049 int, Lisp_Object));
7050 static Lisp_Object image_spec_value P_ ((Lisp_Object, Lisp_Object, int *));
7053 /* Parse image spec SPEC according to KEYWORDS. A valid image spec
7054 has the format (image KEYWORD VALUE ...). One of the keyword/
7055 value pairs must be `:type TYPE'. KEYWORDS is a vector of
7056 image_keywords structures of size NKEYWORDS describing other
7057 allowed keyword/value pairs. Value is non-zero if SPEC is valid. */
7059 static int
7060 parse_image_spec (spec, keywords, nkeywords, type)
7061 Lisp_Object spec;
7062 struct image_keyword *keywords;
7063 int nkeywords;
7064 Lisp_Object type;
7066 int i;
7067 Lisp_Object plist;
7069 if (!CONSP (spec) || !EQ (XCAR (spec), Qimage))
7070 return 0;
7072 plist = XCDR (spec);
7073 while (CONSP (plist))
7075 Lisp_Object key, value;
7077 /* First element of a pair must be a symbol. */
7078 key = XCAR (plist);
7079 plist = XCDR (plist);
7080 if (!SYMBOLP (key))
7081 return 0;
7083 /* There must follow a value. */
7084 if (!CONSP (plist))
7085 return 0;
7086 value = XCAR (plist);
7087 plist = XCDR (plist);
7089 /* Find key in KEYWORDS. Error if not found. */
7090 for (i = 0; i < nkeywords; ++i)
7091 if (strcmp (keywords[i].name, SDATA (SYMBOL_NAME (key))) == 0)
7092 break;
7094 if (i == nkeywords)
7095 continue;
7097 /* Record that we recognized the keyword. If a keywords
7098 was found more than once, it's an error. */
7099 keywords[i].value = value;
7100 ++keywords[i].count;
7102 if (keywords[i].count > 1)
7103 return 0;
7105 /* Check type of value against allowed type. */
7106 switch (keywords[i].type)
7108 case IMAGE_STRING_VALUE:
7109 if (!STRINGP (value))
7110 return 0;
7111 break;
7113 case IMAGE_STRING_OR_NIL_VALUE:
7114 if (!STRINGP (value) && !NILP (value))
7115 return 0;
7116 break;
7118 case IMAGE_SYMBOL_VALUE:
7119 if (!SYMBOLP (value))
7120 return 0;
7121 break;
7123 case IMAGE_POSITIVE_INTEGER_VALUE:
7124 if (!INTEGERP (value) || XINT (value) <= 0)
7125 return 0;
7126 break;
7128 case IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR:
7129 if (INTEGERP (value) && XINT (value) >= 0)
7130 break;
7131 if (CONSP (value)
7132 && INTEGERP (XCAR (value)) && INTEGERP (XCDR (value))
7133 && XINT (XCAR (value)) >= 0 && XINT (XCDR (value)) >= 0)
7134 break;
7135 return 0;
7137 case IMAGE_ASCENT_VALUE:
7138 if (SYMBOLP (value) && EQ (value, Qcenter))
7139 break;
7140 else if (INTEGERP (value)
7141 && XINT (value) >= 0
7142 && XINT (value) <= 100)
7143 break;
7144 return 0;
7146 case IMAGE_NON_NEGATIVE_INTEGER_VALUE:
7147 if (!INTEGERP (value) || XINT (value) < 0)
7148 return 0;
7149 break;
7151 case IMAGE_DONT_CHECK_VALUE_TYPE:
7152 break;
7154 case IMAGE_FUNCTION_VALUE:
7155 value = indirect_function (value);
7156 if (SUBRP (value)
7157 || COMPILEDP (value)
7158 || (CONSP (value) && EQ (XCAR (value), Qlambda)))
7159 break;
7160 return 0;
7162 case IMAGE_NUMBER_VALUE:
7163 if (!INTEGERP (value) && !FLOATP (value))
7164 return 0;
7165 break;
7167 case IMAGE_INTEGER_VALUE:
7168 if (!INTEGERP (value))
7169 return 0;
7170 break;
7172 case IMAGE_BOOL_VALUE:
7173 if (!NILP (value) && !EQ (value, Qt))
7174 return 0;
7175 break;
7177 default:
7178 abort ();
7179 break;
7182 if (EQ (key, QCtype) && !EQ (type, value))
7183 return 0;
7186 /* Check that all mandatory fields are present. */
7187 for (i = 0; i < nkeywords; ++i)
7188 if (keywords[i].mandatory_p && keywords[i].count == 0)
7189 return 0;
7191 return NILP (plist);
7195 /* Return the value of KEY in image specification SPEC. Value is nil
7196 if KEY is not present in SPEC. if FOUND is not null, set *FOUND
7197 to 1 if KEY was found in SPEC, set it to 0 otherwise. */
7199 static Lisp_Object
7200 image_spec_value (spec, key, found)
7201 Lisp_Object spec, key;
7202 int *found;
7204 Lisp_Object tail;
7206 xassert (valid_image_p (spec));
7208 for (tail = XCDR (spec);
7209 CONSP (tail) && CONSP (XCDR (tail));
7210 tail = XCDR (XCDR (tail)))
7212 if (EQ (XCAR (tail), key))
7214 if (found)
7215 *found = 1;
7216 return XCAR (XCDR (tail));
7220 if (found)
7221 *found = 0;
7222 return Qnil;
7226 DEFUN ("image-size", Fimage_size, Simage_size, 1, 3, 0,
7227 doc: /* Return the size of image SPEC as pair (WIDTH . HEIGHT).
7228 PIXELS non-nil means return the size in pixels, otherwise return the
7229 size in canonical character units.
7230 FRAME is the frame on which the image will be displayed. FRAME nil
7231 or omitted means use the selected frame. */)
7232 (spec, pixels, frame)
7233 Lisp_Object spec, pixels, frame;
7235 Lisp_Object size;
7237 size = Qnil;
7238 if (valid_image_p (spec))
7240 struct frame *f = check_x_frame (frame);
7241 int id = lookup_image (f, spec);
7242 struct image *img = IMAGE_FROM_ID (f, id);
7243 int width = img->width + 2 * img->hmargin;
7244 int height = img->height + 2 * img->vmargin;
7246 if (NILP (pixels))
7247 size = Fcons (make_float ((double) width / CANON_X_UNIT (f)),
7248 make_float ((double) height / CANON_Y_UNIT (f)));
7249 else
7250 size = Fcons (make_number (width), make_number (height));
7252 else
7253 error ("Invalid image specification");
7255 return size;
7259 DEFUN ("image-mask-p", Fimage_mask_p, Simage_mask_p, 1, 2, 0,
7260 doc: /* Return t if image SPEC has a mask bitmap.
7261 FRAME is the frame on which the image will be displayed. FRAME nil
7262 or omitted means use the selected frame. */)
7263 (spec, frame)
7264 Lisp_Object spec, frame;
7266 Lisp_Object mask;
7268 mask = Qnil;
7269 if (valid_image_p (spec))
7271 struct frame *f = check_x_frame (frame);
7272 int id = lookup_image (f, spec);
7273 struct image *img = IMAGE_FROM_ID (f, id);
7274 if (img->mask)
7275 mask = Qt;
7277 else
7278 error ("Invalid image specification");
7280 return mask;
7284 /***********************************************************************
7285 Image type independent image structures
7286 ***********************************************************************/
7288 static struct image *make_image P_ ((Lisp_Object spec, unsigned hash));
7289 static void free_image P_ ((struct frame *f, struct image *img));
7290 static void x_destroy_x_image P_ ((XImage *));
7293 /* Allocate and return a new image structure for image specification
7294 SPEC. SPEC has a hash value of HASH. */
7296 static struct image *
7297 make_image (spec, hash)
7298 Lisp_Object spec;
7299 unsigned hash;
7301 struct image *img = (struct image *) xmalloc (sizeof *img);
7303 xassert (valid_image_p (spec));
7304 bzero (img, sizeof *img);
7305 img->type = lookup_image_type (image_spec_value (spec, QCtype, NULL));
7306 xassert (img->type != NULL);
7307 img->spec = spec;
7308 img->data.lisp_val = Qnil;
7309 img->ascent = DEFAULT_IMAGE_ASCENT;
7310 img->hash = hash;
7311 return img;
7315 /* Free image IMG which was used on frame F, including its resources. */
7317 static void
7318 free_image (f, img)
7319 struct frame *f;
7320 struct image *img;
7322 if (img)
7324 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7326 /* Remove IMG from the hash table of its cache. */
7327 if (img->prev)
7328 img->prev->next = img->next;
7329 else
7330 c->buckets[img->hash % IMAGE_CACHE_BUCKETS_SIZE] = img->next;
7332 if (img->next)
7333 img->next->prev = img->prev;
7335 c->images[img->id] = NULL;
7337 /* Free resources, then free IMG. */
7338 img->type->free (f, img);
7339 xfree (img);
7344 /* Prepare image IMG for display on frame F. Must be called before
7345 drawing an image. */
7347 void
7348 prepare_image_for_display (f, img)
7349 struct frame *f;
7350 struct image *img;
7352 EMACS_TIME t;
7354 /* We're about to display IMG, so set its timestamp to `now'. */
7355 EMACS_GET_TIME (t);
7356 img->timestamp = EMACS_SECS (t);
7358 /* If IMG doesn't have a pixmap yet, load it now, using the image
7359 type dependent loader function. */
7360 if (img->pixmap == 0 && !img->load_failed_p)
7361 img->load_failed_p = img->type->load (f, img) == 0;
7365 /* Value is the number of pixels for the ascent of image IMG when
7366 drawn in face FACE. */
7369 image_ascent (img, face)
7370 struct image *img;
7371 struct face *face;
7373 int height = img->height + img->vmargin;
7374 int ascent;
7376 if (img->ascent == CENTERED_IMAGE_ASCENT)
7378 if (face->font)
7379 ascent = height / 2 - (FONT_DESCENT(face->font)
7380 - FONT_BASE(face->font)) / 2;
7381 else
7382 ascent = height / 2;
7384 else
7385 ascent = (int) (height * img->ascent / 100.0);
7387 return ascent;
7392 /* Image background colors. */
7394 /* Find the "best" corner color of a bitmap. XIMG is assumed to a device
7395 context with the bitmap selected. */
7396 static COLORREF
7397 four_corners_best (img_dc, width, height)
7398 HDC img_dc;
7399 unsigned long width, height;
7401 COLORREF corners[4], best;
7402 int i, best_count;
7404 /* Get the colors at the corners of img_dc. */
7405 corners[0] = GetPixel (img_dc, 0, 0);
7406 corners[1] = GetPixel (img_dc, width - 1, 0);
7407 corners[2] = GetPixel (img_dc, width - 1, height - 1);
7408 corners[3] = GetPixel (img_dc, 0, height - 1);
7410 /* Choose the most frequently found color as background. */
7411 for (i = best_count = 0; i < 4; ++i)
7413 int j, n;
7415 for (j = n = 0; j < 4; ++j)
7416 if (corners[i] == corners[j])
7417 ++n;
7419 if (n > best_count)
7420 best = corners[i], best_count = n;
7423 return best;
7426 /* Return the `background' field of IMG. If IMG doesn't have one yet,
7427 it is guessed heuristically. If non-zero, IMG_DC is an existing
7428 device context with the image selected to use for the heuristic. */
7430 unsigned long
7431 image_background (img, f, img_dc)
7432 struct image *img;
7433 struct frame *f;
7434 HDC img_dc;
7436 if (! img->background_valid)
7437 /* IMG doesn't have a background yet, try to guess a reasonable value. */
7439 int free_ximg = !img_dc;
7440 HGDIOBJ prev;
7442 if (free_ximg)
7444 HDC frame_dc = get_frame_dc (f);
7445 img_dc = CreateCompatibleDC (frame_dc);
7446 release_frame_dc (f, frame_dc);
7448 prev = SelectObject (img_dc, img->pixmap);
7451 img->background = four_corners_best (img_dc, img->width, img->height);
7453 if (free_ximg)
7455 SelectObject (img_dc, prev);
7456 DeleteDC (img_dc);
7459 img->background_valid = 1;
7462 return img->background;
7465 /* Return the `background_transparent' field of IMG. If IMG doesn't
7466 have one yet, it is guessed heuristically. If non-zero, MASK is an
7467 existing XImage object to use for the heuristic. */
7470 image_background_transparent (img, f, mask)
7471 struct image *img;
7472 struct frame *f;
7473 HDC mask;
7475 if (! img->background_transparent_valid)
7476 /* IMG doesn't have a background yet, try to guess a reasonable value. */
7478 if (img->mask)
7480 int free_mask = !mask;
7481 HGDIOBJ prev;
7483 if (free_mask)
7485 HDC frame_dc = get_frame_dc (f);
7486 mask = CreateCompatibleDC (frame_dc);
7487 release_frame_dc (f, frame_dc);
7489 prev = SelectObject (mask, img->mask);
7492 img->background_transparent
7493 = !four_corners_best (mask, img->width, img->height);
7495 if (free_mask)
7497 SelectObject (mask, prev);
7498 DeleteDC (mask);
7501 else
7502 img->background_transparent = 0;
7504 img->background_transparent_valid = 1;
7507 return img->background_transparent;
7511 /***********************************************************************
7512 Helper functions for X image types
7513 ***********************************************************************/
7515 static void x_clear_image_1 P_ ((struct frame *, struct image *, int,
7516 int, int));
7517 static void x_clear_image P_ ((struct frame *f, struct image *img));
7518 static unsigned long x_alloc_image_color P_ ((struct frame *f,
7519 struct image *img,
7520 Lisp_Object color_name,
7521 unsigned long dflt));
7524 /* Clear X resources of image IMG on frame F. PIXMAP_P non-zero means
7525 free the pixmap if any. MASK_P non-zero means clear the mask
7526 pixmap if any. COLORS_P non-zero means free colors allocated for
7527 the image, if any. */
7529 static void
7530 x_clear_image_1 (f, img, pixmap_p, mask_p, colors_p)
7531 struct frame *f;
7532 struct image *img;
7533 int pixmap_p, mask_p, colors_p;
7535 if (pixmap_p && img->pixmap)
7537 DeleteObject (img->pixmap);
7538 img->pixmap = NULL;
7539 img->background_valid = 0;
7542 if (mask_p && img->mask)
7544 DeleteObject (img->mask);
7545 img->mask = NULL;
7546 img->background_transparent_valid = 0;
7549 if (colors_p && img->ncolors)
7551 #if 0 /* TODO: color table support. */
7552 x_free_colors (f, img->colors, img->ncolors);
7553 #endif
7554 xfree (img->colors);
7555 img->colors = NULL;
7556 img->ncolors = 0;
7560 /* Free X resources of image IMG which is used on frame F. */
7562 static void
7563 x_clear_image (f, img)
7564 struct frame *f;
7565 struct image *img;
7567 if (img->pixmap)
7569 BLOCK_INPUT;
7570 DeleteObject (img->pixmap);
7571 img->pixmap = 0;
7572 UNBLOCK_INPUT;
7575 if (img->ncolors)
7577 #if 0 /* TODO: color table support */
7579 int class = FRAME_W32_DISPLAY_INFO (f)->visual->class;
7581 /* If display has an immutable color map, freeing colors is not
7582 necessary and some servers don't allow it. So don't do it. */
7583 if (class != StaticColor
7584 && class != StaticGray
7585 && class != TrueColor)
7587 Colormap cmap;
7588 BLOCK_INPUT;
7589 cmap = DefaultColormapOfScreen (FRAME_W32_DISPLAY_INFO (f)->screen);
7590 XFreeColors (FRAME_W32_DISPLAY (f), cmap, img->colors,
7591 img->ncolors, 0);
7592 UNBLOCK_INPUT;
7594 #endif
7596 xfree (img->colors);
7597 img->colors = NULL;
7598 img->ncolors = 0;
7603 /* Allocate color COLOR_NAME for image IMG on frame F. If color
7604 cannot be allocated, use DFLT. Add a newly allocated color to
7605 IMG->colors, so that it can be freed again. Value is the pixel
7606 color. */
7608 static unsigned long
7609 x_alloc_image_color (f, img, color_name, dflt)
7610 struct frame *f;
7611 struct image *img;
7612 Lisp_Object color_name;
7613 unsigned long dflt;
7615 XColor color;
7616 unsigned long result;
7618 xassert (STRINGP (color_name));
7620 if (w32_defined_color (f, SDATA (color_name), &color, 1))
7622 /* This isn't called frequently so we get away with simply
7623 reallocating the color vector to the needed size, here. */
7624 ++img->ncolors;
7625 img->colors =
7626 (unsigned long *) xrealloc (img->colors,
7627 img->ncolors * sizeof *img->colors);
7628 img->colors[img->ncolors - 1] = color.pixel;
7629 result = color.pixel;
7631 else
7632 result = dflt;
7633 return result;
7638 /***********************************************************************
7639 Image Cache
7640 ***********************************************************************/
7642 static void cache_image P_ ((struct frame *f, struct image *img));
7643 static void postprocess_image P_ ((struct frame *, struct image *));
7644 static void x_disable_image P_ ((struct frame *, struct image *));
7647 /* Return a new, initialized image cache that is allocated from the
7648 heap. Call free_image_cache to free an image cache. */
7650 struct image_cache *
7651 make_image_cache ()
7653 struct image_cache *c = (struct image_cache *) xmalloc (sizeof *c);
7654 int size;
7656 bzero (c, sizeof *c);
7657 c->size = 50;
7658 c->images = (struct image **) xmalloc (c->size * sizeof *c->images);
7659 size = IMAGE_CACHE_BUCKETS_SIZE * sizeof *c->buckets;
7660 c->buckets = (struct image **) xmalloc (size);
7661 bzero (c->buckets, size);
7662 return c;
7666 /* Free image cache of frame F. Be aware that X frames share images
7667 caches. */
7669 void
7670 free_image_cache (f)
7671 struct frame *f;
7673 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7674 if (c)
7676 int i;
7678 /* Cache should not be referenced by any frame when freed. */
7679 xassert (c->refcount == 0);
7681 for (i = 0; i < c->used; ++i)
7682 free_image (f, c->images[i]);
7683 xfree (c->images);
7684 xfree (c);
7685 xfree (c->buckets);
7686 FRAME_X_IMAGE_CACHE (f) = NULL;
7691 /* Clear image cache of frame F. FORCE_P non-zero means free all
7692 images. FORCE_P zero means clear only images that haven't been
7693 displayed for some time. Should be called from time to time to
7694 reduce the number of loaded images. If image-eviction-seconds is
7695 non-nil, this frees images in the cache which weren't displayed for
7696 at least that many seconds. */
7698 void
7699 clear_image_cache (f, force_p)
7700 struct frame *f;
7701 int force_p;
7703 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7705 if (c && INTEGERP (Vimage_cache_eviction_delay))
7707 EMACS_TIME t;
7708 unsigned long old;
7709 int i, nfreed;
7711 EMACS_GET_TIME (t);
7712 old = EMACS_SECS (t) - XFASTINT (Vimage_cache_eviction_delay);
7714 /* Block input so that we won't be interrupted by a SIGIO
7715 while being in an inconsistent state. */
7716 BLOCK_INPUT;
7718 for (i = nfreed = 0; i < c->used; ++i)
7720 struct image *img = c->images[i];
7721 if (img != NULL
7722 && (force_p || (img->timestamp < old)))
7724 free_image (f, img);
7725 ++nfreed;
7729 /* We may be clearing the image cache because, for example,
7730 Emacs was iconified for a longer period of time. In that
7731 case, current matrices may still contain references to
7732 images freed above. So, clear these matrices. */
7733 if (nfreed)
7735 Lisp_Object tail, frame;
7737 FOR_EACH_FRAME (tail, frame)
7739 struct frame *f = XFRAME (frame);
7740 if (FRAME_W32_P (f)
7741 && FRAME_X_IMAGE_CACHE (f) == c)
7742 clear_current_matrices (f);
7745 ++windows_or_buffers_changed;
7748 UNBLOCK_INPUT;
7753 DEFUN ("clear-image-cache", Fclear_image_cache, Sclear_image_cache,
7754 0, 1, 0,
7755 doc: /* Clear the image cache of FRAME.
7756 FRAME nil or omitted means use the selected frame.
7757 FRAME t means clear the image caches of all frames. */)
7758 (frame)
7759 Lisp_Object frame;
7761 if (EQ (frame, Qt))
7763 Lisp_Object tail;
7765 FOR_EACH_FRAME (tail, frame)
7766 if (FRAME_W32_P (XFRAME (frame)))
7767 clear_image_cache (XFRAME (frame), 1);
7769 else
7770 clear_image_cache (check_x_frame (frame), 1);
7772 return Qnil;
7776 /* Compute masks and transform image IMG on frame F, as specified
7777 by the image's specification, */
7779 static void
7780 postprocess_image (f, img)
7781 struct frame *f;
7782 struct image *img;
7784 /* Manipulation of the image's mask. */
7785 if (img->pixmap)
7787 Lisp_Object conversion, spec;
7788 Lisp_Object mask;
7790 spec = img->spec;
7792 /* `:heuristic-mask t'
7793 `:mask heuristic'
7794 means build a mask heuristically.
7795 `:heuristic-mask (R G B)'
7796 `:mask (heuristic (R G B))'
7797 means build a mask from color (R G B) in the
7798 image.
7799 `:mask nil'
7800 means remove a mask, if any. */
7802 mask = image_spec_value (spec, QCheuristic_mask, NULL);
7803 if (!NILP (mask))
7804 x_build_heuristic_mask (f, img, mask);
7805 else
7807 int found_p;
7809 mask = image_spec_value (spec, QCmask, &found_p);
7811 if (EQ (mask, Qheuristic))
7812 x_build_heuristic_mask (f, img, Qt);
7813 else if (CONSP (mask)
7814 && EQ (XCAR (mask), Qheuristic))
7816 if (CONSP (XCDR (mask)))
7817 x_build_heuristic_mask (f, img, XCAR (XCDR (mask)));
7818 else
7819 x_build_heuristic_mask (f, img, XCDR (mask));
7821 else if (NILP (mask) && found_p && img->mask)
7823 DeleteObject (img->mask);
7824 img->mask = NULL;
7829 /* Should we apply an image transformation algorithm? */
7830 conversion = image_spec_value (spec, QCconversion, NULL);
7831 if (EQ (conversion, Qdisabled))
7832 x_disable_image (f, img);
7833 else if (EQ (conversion, Qlaplace))
7834 x_laplace (f, img);
7835 else if (EQ (conversion, Qemboss))
7836 x_emboss (f, img);
7837 else if (CONSP (conversion)
7838 && EQ (XCAR (conversion), Qedge_detection))
7840 Lisp_Object tem;
7841 tem = XCDR (conversion);
7842 if (CONSP (tem))
7843 x_edge_detection (f, img,
7844 Fplist_get (tem, QCmatrix),
7845 Fplist_get (tem, QCcolor_adjustment));
7851 /* Return the id of image with Lisp specification SPEC on frame F.
7852 SPEC must be a valid Lisp image specification (see valid_image_p). */
7855 lookup_image (f, spec)
7856 struct frame *f;
7857 Lisp_Object spec;
7859 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7860 struct image *img;
7861 int i;
7862 unsigned hash;
7863 struct gcpro gcpro1;
7864 EMACS_TIME now;
7866 /* F must be a window-system frame, and SPEC must be a valid image
7867 specification. */
7868 xassert (FRAME_WINDOW_P (f));
7869 xassert (valid_image_p (spec));
7871 GCPRO1 (spec);
7873 /* Look up SPEC in the hash table of the image cache. */
7874 hash = sxhash (spec, 0);
7875 i = hash % IMAGE_CACHE_BUCKETS_SIZE;
7877 for (img = c->buckets[i]; img; img = img->next)
7878 if (img->hash == hash && !NILP (Fequal (img->spec, spec)))
7879 break;
7881 /* If not found, create a new image and cache it. */
7882 if (img == NULL)
7884 extern Lisp_Object Qpostscript;
7886 BLOCK_INPUT;
7887 img = make_image (spec, hash);
7888 cache_image (f, img);
7889 img->load_failed_p = img->type->load (f, img) == 0;
7891 /* If we can't load the image, and we don't have a width and
7892 height, use some arbitrary width and height so that we can
7893 draw a rectangle for it. */
7894 if (img->load_failed_p)
7896 Lisp_Object value;
7898 value = image_spec_value (spec, QCwidth, NULL);
7899 img->width = (INTEGERP (value)
7900 ? XFASTINT (value) : DEFAULT_IMAGE_WIDTH);
7901 value = image_spec_value (spec, QCheight, NULL);
7902 img->height = (INTEGERP (value)
7903 ? XFASTINT (value) : DEFAULT_IMAGE_HEIGHT);
7905 else
7907 /* Handle image type independent image attributes
7908 `:ascent ASCENT', `:margin MARGIN', `:relief RELIEF',
7909 `:background COLOR'. */
7910 Lisp_Object ascent, margin, relief, bg;
7912 ascent = image_spec_value (spec, QCascent, NULL);
7913 if (INTEGERP (ascent))
7914 img->ascent = XFASTINT (ascent);
7915 else if (EQ (ascent, Qcenter))
7916 img->ascent = CENTERED_IMAGE_ASCENT;
7918 margin = image_spec_value (spec, QCmargin, NULL);
7919 if (INTEGERP (margin) && XINT (margin) >= 0)
7920 img->vmargin = img->hmargin = XFASTINT (margin);
7921 else if (CONSP (margin) && INTEGERP (XCAR (margin))
7922 && INTEGERP (XCDR (margin)))
7924 if (XINT (XCAR (margin)) > 0)
7925 img->hmargin = XFASTINT (XCAR (margin));
7926 if (XINT (XCDR (margin)) > 0)
7927 img->vmargin = XFASTINT (XCDR (margin));
7930 relief = image_spec_value (spec, QCrelief, NULL);
7931 if (INTEGERP (relief))
7933 img->relief = XINT (relief);
7934 img->hmargin += abs (img->relief);
7935 img->vmargin += abs (img->relief);
7938 if (! img->background_valid)
7940 bg = image_spec_value (img->spec, QCbackground, NULL);
7941 if (!NILP (bg))
7943 img->background
7944 = x_alloc_image_color (f, img, bg,
7945 FRAME_BACKGROUND_PIXEL (f));
7946 img->background_valid = 1;
7950 /* Do image transformations and compute masks, unless we
7951 don't have the image yet. */
7952 if (!EQ (*img->type->type, Qpostscript))
7953 postprocess_image (f, img);
7956 UNBLOCK_INPUT;
7957 xassert (!interrupt_input_blocked);
7960 /* We're using IMG, so set its timestamp to `now'. */
7961 EMACS_GET_TIME (now);
7962 img->timestamp = EMACS_SECS (now);
7964 UNGCPRO;
7966 /* Value is the image id. */
7967 return img->id;
7971 /* Cache image IMG in the image cache of frame F. */
7973 static void
7974 cache_image (f, img)
7975 struct frame *f;
7976 struct image *img;
7978 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
7979 int i;
7981 /* Find a free slot in c->images. */
7982 for (i = 0; i < c->used; ++i)
7983 if (c->images[i] == NULL)
7984 break;
7986 /* If no free slot found, maybe enlarge c->images. */
7987 if (i == c->used && c->used == c->size)
7989 c->size *= 2;
7990 c->images = (struct image **) xrealloc (c->images,
7991 c->size * sizeof *c->images);
7994 /* Add IMG to c->images, and assign IMG an id. */
7995 c->images[i] = img;
7996 img->id = i;
7997 if (i == c->used)
7998 ++c->used;
8000 /* Add IMG to the cache's hash table. */
8001 i = img->hash % IMAGE_CACHE_BUCKETS_SIZE;
8002 img->next = c->buckets[i];
8003 if (img->next)
8004 img->next->prev = img;
8005 img->prev = NULL;
8006 c->buckets[i] = img;
8010 /* Call FN on every image in the image cache of frame F. Used to mark
8011 Lisp Objects in the image cache. */
8013 void
8014 forall_images_in_image_cache (f, fn)
8015 struct frame *f;
8016 void (*fn) P_ ((struct image *img));
8018 if (FRAME_LIVE_P (f) && FRAME_W32_P (f))
8020 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
8021 if (c)
8023 int i;
8024 for (i = 0; i < c->used; ++i)
8025 if (c->images[i])
8026 fn (c->images[i]);
8033 /***********************************************************************
8034 W32 support code
8035 ***********************************************************************/
8037 /* Macro for defining functions that will be loaded from image DLLs. */
8038 #define DEF_IMGLIB_FN(func) FARPROC fn_##func
8040 /* Macro for loading those image functions from the library. */
8041 #define LOAD_IMGLIB_FN(lib,func) { \
8042 fn_##func = (void *) GetProcAddress (lib, #func); \
8043 if (!fn_##func) return 0; \
8046 static int x_create_x_image_and_pixmap P_ ((struct frame *, int, int, int,
8047 XImage **, Pixmap *));
8048 static void x_put_x_image P_ ((struct frame *, XImage *, Pixmap, int, int));
8051 /* Create an XImage and a pixmap of size WIDTH x HEIGHT for use on
8052 frame F. Set *XIMG and *PIXMAP to the XImage and Pixmap created.
8053 Set (*XIMG)->data to a raster of WIDTH x HEIGHT pixels allocated
8054 via xmalloc. DEPTH of zero signifies a 24 bit image, otherwise
8055 DEPTH should indicate the bit depth of the image. Print error
8056 messages via image_error if an error occurs. Value is non-zero if
8057 successful. */
8059 static int
8060 x_create_x_image_and_pixmap (f, width, height, depth, ximg, pixmap)
8061 struct frame *f;
8062 int width, height, depth;
8063 XImage **ximg;
8064 Pixmap *pixmap;
8066 BITMAPINFOHEADER *header;
8067 HDC hdc;
8068 int scanline_width_bits;
8069 int remainder;
8070 int palette_colors = 0;
8072 if (depth == 0)
8073 depth = 24;
8075 if (depth != 1 && depth != 4 && depth != 8
8076 && depth != 16 && depth != 24 && depth != 32)
8078 image_error ("Invalid image bit depth specified", Qnil, Qnil);
8079 return 0;
8082 scanline_width_bits = width * depth;
8083 remainder = scanline_width_bits % 32;
8085 if (remainder)
8086 scanline_width_bits += 32 - remainder;
8088 /* Bitmaps with a depth less than 16 need a palette. */
8089 /* BITMAPINFO structure already contains the first RGBQUAD. */
8090 if (depth < 16)
8091 palette_colors = 1 << depth - 1;
8093 *ximg = xmalloc (sizeof (XImage) + palette_colors * sizeof (RGBQUAD));
8094 if (*ximg == NULL)
8096 image_error ("Unable to allocate memory for XImage", Qnil, Qnil);
8097 return 0;
8100 header = &((*ximg)->info.bmiHeader);
8101 bzero (&((*ximg)->info), sizeof (BITMAPINFO));
8102 header->biSize = sizeof (*header);
8103 header->biWidth = width;
8104 header->biHeight = -height; /* negative indicates a top-down bitmap. */
8105 header->biPlanes = 1;
8106 header->biBitCount = depth;
8107 header->biCompression = BI_RGB;
8108 header->biClrUsed = palette_colors;
8110 /* TODO: fill in palette. */
8111 if (depth == 1)
8113 (*ximg)->info.bmiColors[0].rgbBlue = 0;
8114 (*ximg)->info.bmiColors[0].rgbGreen = 0;
8115 (*ximg)->info.bmiColors[0].rgbRed = 0;
8116 (*ximg)->info.bmiColors[0].rgbReserved = 0;
8117 (*ximg)->info.bmiColors[1].rgbBlue = 255;
8118 (*ximg)->info.bmiColors[1].rgbGreen = 255;
8119 (*ximg)->info.bmiColors[1].rgbRed = 255;
8120 (*ximg)->info.bmiColors[1].rgbReserved = 0;
8123 hdc = get_frame_dc (f);
8125 /* Create a DIBSection and raster array for the bitmap,
8126 and store its handle in *pixmap. */
8127 *pixmap = CreateDIBSection (hdc, &((*ximg)->info),
8128 (depth < 16) ? DIB_PAL_COLORS : DIB_RGB_COLORS,
8129 &((*ximg)->data), NULL, 0);
8131 /* Realize display palette and garbage all frames. */
8132 release_frame_dc (f, hdc);
8134 if (*pixmap == NULL)
8136 DWORD err = GetLastError();
8137 Lisp_Object errcode;
8138 /* All system errors are < 10000, so the following is safe. */
8139 XSETINT (errcode, (int) err);
8140 image_error ("Unable to create bitmap, error code %d", errcode, Qnil);
8141 x_destroy_x_image (*ximg);
8142 return 0;
8145 return 1;
8149 /* Destroy XImage XIMG. Free XIMG->data. */
8151 static void
8152 x_destroy_x_image (ximg)
8153 XImage *ximg;
8155 xassert (interrupt_input_blocked);
8156 if (ximg)
8158 /* Data will be freed by DestroyObject. */
8159 ximg->data = NULL;
8160 xfree (ximg);
8165 /* Put XImage XIMG into pixmap PIXMAP on frame F. WIDTH and HEIGHT
8166 are width and height of both the image and pixmap. */
8168 static void
8169 x_put_x_image (f, ximg, pixmap, width, height)
8170 struct frame *f;
8171 XImage *ximg;
8172 Pixmap pixmap;
8173 int width, height;
8175 #if 0 /* I don't think this is necessary looking at where it is used. */
8176 HDC hdc = get_frame_dc (f);
8177 SetDIBits (hdc, pixmap, 0, height, ximg->data, &(ximg->info), DIB_RGB_COLORS);
8178 release_frame_dc (f, hdc);
8179 #endif
8183 /***********************************************************************
8184 File Handling
8185 ***********************************************************************/
8187 static Lisp_Object x_find_image_file P_ ((Lisp_Object));
8188 static char *slurp_file P_ ((char *, int *));
8191 /* Find image file FILE. Look in data-directory, then
8192 x-bitmap-file-path. Value is the full name of the file found, or
8193 nil if not found. */
8195 static Lisp_Object
8196 x_find_image_file (file)
8197 Lisp_Object file;
8199 Lisp_Object file_found, search_path;
8200 struct gcpro gcpro1, gcpro2;
8201 int fd;
8203 file_found = Qnil;
8204 search_path = Fcons (Vdata_directory, Vx_bitmap_file_path);
8205 GCPRO2 (file_found, search_path);
8207 /* Try to find FILE in data-directory, then x-bitmap-file-path. */
8208 fd = openp (search_path, file, Qnil, &file_found, Qnil);
8210 if (fd == -1)
8211 file_found = Qnil;
8212 else
8213 close (fd);
8215 UNGCPRO;
8216 return file_found;
8220 /* Read FILE into memory. Value is a pointer to a buffer allocated
8221 with xmalloc holding FILE's contents. Value is null if an error
8222 occurred. *SIZE is set to the size of the file. */
8224 static char *
8225 slurp_file (file, size)
8226 char *file;
8227 int *size;
8229 FILE *fp = NULL;
8230 char *buf = NULL;
8231 struct stat st;
8233 if (stat (file, &st) == 0
8234 && (fp = fopen (file, "rb")) != NULL
8235 && (buf = (char *) xmalloc (st.st_size),
8236 fread (buf, 1, st.st_size, fp) == st.st_size))
8238 *size = st.st_size;
8239 fclose (fp);
8241 else
8243 if (fp)
8244 fclose (fp);
8245 if (buf)
8247 xfree (buf);
8248 buf = NULL;
8252 return buf;
8257 /***********************************************************************
8258 XBM images
8259 ***********************************************************************/
8261 static int xbm_scan P_ ((char **, char *, char *, int *));
8262 static int xbm_load P_ ((struct frame *f, struct image *img));
8263 static int xbm_load_image P_ ((struct frame *f, struct image *img,
8264 char *, char *));
8265 static int xbm_image_p P_ ((Lisp_Object object));
8266 static int xbm_read_bitmap_data P_ ((char *, char *, int *, int *,
8267 unsigned char **));
8268 static int xbm_file_p P_ ((Lisp_Object));
8271 /* Indices of image specification fields in xbm_format, below. */
8273 enum xbm_keyword_index
8275 XBM_TYPE,
8276 XBM_FILE,
8277 XBM_WIDTH,
8278 XBM_HEIGHT,
8279 XBM_DATA,
8280 XBM_FOREGROUND,
8281 XBM_BACKGROUND,
8282 XBM_ASCENT,
8283 XBM_MARGIN,
8284 XBM_RELIEF,
8285 XBM_ALGORITHM,
8286 XBM_HEURISTIC_MASK,
8287 XBM_MASK,
8288 XBM_LAST
8291 /* Vector of image_keyword structures describing the format
8292 of valid XBM image specifications. */
8294 static struct image_keyword xbm_format[XBM_LAST] =
8296 {":type", IMAGE_SYMBOL_VALUE, 1},
8297 {":file", IMAGE_STRING_VALUE, 0},
8298 {":width", IMAGE_POSITIVE_INTEGER_VALUE, 0},
8299 {":height", IMAGE_POSITIVE_INTEGER_VALUE, 0},
8300 {":data", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8301 {":foreground", IMAGE_STRING_OR_NIL_VALUE, 0},
8302 {":background", IMAGE_STRING_OR_NIL_VALUE, 0},
8303 {":ascent", IMAGE_ASCENT_VALUE, 0},
8304 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
8305 {":relief", IMAGE_INTEGER_VALUE, 0},
8306 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8307 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
8308 {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
8311 /* Structure describing the image type XBM. */
8313 static struct image_type xbm_type =
8315 &Qxbm,
8316 xbm_image_p,
8317 xbm_load,
8318 x_clear_image,
8319 NULL
8322 /* Tokens returned from xbm_scan. */
8324 enum xbm_token
8326 XBM_TK_IDENT = 256,
8327 XBM_TK_NUMBER
8331 /* Return non-zero if OBJECT is a valid XBM-type image specification.
8332 A valid specification is a list starting with the symbol `image'
8333 The rest of the list is a property list which must contain an
8334 entry `:type xbm..
8336 If the specification specifies a file to load, it must contain
8337 an entry `:file FILENAME' where FILENAME is a string.
8339 If the specification is for a bitmap loaded from memory it must
8340 contain `:width WIDTH', `:height HEIGHT', and `:data DATA', where
8341 WIDTH and HEIGHT are integers > 0. DATA may be:
8343 1. a string large enough to hold the bitmap data, i.e. it must
8344 have a size >= (WIDTH + 7) / 8 * HEIGHT
8346 2. a bool-vector of size >= WIDTH * HEIGHT
8348 3. a vector of strings or bool-vectors, one for each line of the
8349 bitmap.
8351 4. A string containing an in-memory XBM file. WIDTH and HEIGHT
8352 may not be specified in this case because they are defined in the
8353 XBM file.
8355 Both the file and data forms may contain the additional entries
8356 `:background COLOR' and `:foreground COLOR'. If not present,
8357 foreground and background of the frame on which the image is
8358 displayed is used. */
8360 static int
8361 xbm_image_p (object)
8362 Lisp_Object object;
8364 struct image_keyword kw[XBM_LAST];
8366 bcopy (xbm_format, kw, sizeof kw);
8367 if (!parse_image_spec (object, kw, XBM_LAST, Qxbm))
8368 return 0;
8370 xassert (EQ (kw[XBM_TYPE].value, Qxbm));
8372 if (kw[XBM_FILE].count)
8374 if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_DATA].count)
8375 return 0;
8377 else if (kw[XBM_DATA].count && xbm_file_p (kw[XBM_DATA].value))
8379 /* In-memory XBM file. */
8380 if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_FILE].count)
8381 return 0;
8383 else
8385 Lisp_Object data;
8386 int width, height;
8388 /* Entries for `:width', `:height' and `:data' must be present. */
8389 if (!kw[XBM_WIDTH].count
8390 || !kw[XBM_HEIGHT].count
8391 || !kw[XBM_DATA].count)
8392 return 0;
8394 data = kw[XBM_DATA].value;
8395 width = XFASTINT (kw[XBM_WIDTH].value);
8396 height = XFASTINT (kw[XBM_HEIGHT].value);
8398 /* Check type of data, and width and height against contents of
8399 data. */
8400 if (VECTORP (data))
8402 int i;
8404 /* Number of elements of the vector must be >= height. */
8405 if (XVECTOR (data)->size < height)
8406 return 0;
8408 /* Each string or bool-vector in data must be large enough
8409 for one line of the image. */
8410 for (i = 0; i < height; ++i)
8412 Lisp_Object elt = XVECTOR (data)->contents[i];
8414 if (STRINGP (elt))
8416 if (SCHARS (elt)
8417 < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR)
8418 return 0;
8420 else if (BOOL_VECTOR_P (elt))
8422 if (XBOOL_VECTOR (elt)->size < width)
8423 return 0;
8425 else
8426 return 0;
8429 else if (STRINGP (data))
8431 if (SCHARS (data)
8432 < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR * height)
8433 return 0;
8435 else if (BOOL_VECTOR_P (data))
8437 if (XBOOL_VECTOR (data)->size < width * height)
8438 return 0;
8440 else
8441 return 0;
8444 return 1;
8448 /* Scan a bitmap file. FP is the stream to read from. Value is
8449 either an enumerator from enum xbm_token, or a character for a
8450 single-character token, or 0 at end of file. If scanning an
8451 identifier, store the lexeme of the identifier in SVAL. If
8452 scanning a number, store its value in *IVAL. */
8454 static int
8455 xbm_scan (s, end, sval, ival)
8456 char **s, *end;
8457 char *sval;
8458 int *ival;
8460 int c;
8462 loop:
8464 /* Skip white space. */
8465 while (*s < end && (c = *(*s)++, isspace (c)))
8468 if (*s >= end)
8469 c = 0;
8470 else if (isdigit (c))
8472 int value = 0, digit;
8474 if (c == '0' && *s < end)
8476 c = *(*s)++;
8477 if (c == 'x' || c == 'X')
8479 while (*s < end)
8481 c = *(*s)++;
8482 if (isdigit (c))
8483 digit = c - '0';
8484 else if (c >= 'a' && c <= 'f')
8485 digit = c - 'a' + 10;
8486 else if (c >= 'A' && c <= 'F')
8487 digit = c - 'A' + 10;
8488 else
8489 break;
8490 value = 16 * value + digit;
8493 else if (isdigit (c))
8495 value = c - '0';
8496 while (*s < end
8497 && (c = *(*s)++, isdigit (c)))
8498 value = 8 * value + c - '0';
8501 else
8503 value = c - '0';
8504 while (*s < end
8505 && (c = *(*s)++, isdigit (c)))
8506 value = 10 * value + c - '0';
8509 if (*s < end)
8510 *s = *s - 1;
8511 *ival = value;
8512 c = XBM_TK_NUMBER;
8514 else if (isalpha (c) || c == '_')
8516 *sval++ = c;
8517 while (*s < end
8518 && (c = *(*s)++, (isalnum (c) || c == '_')))
8519 *sval++ = c;
8520 *sval = 0;
8521 if (*s < end)
8522 *s = *s - 1;
8523 c = XBM_TK_IDENT;
8525 else if (c == '/' && **s == '*')
8527 /* C-style comment. */
8528 ++*s;
8529 while (**s && (**s != '*' || *(*s + 1) != '/'))
8530 ++*s;
8531 if (**s)
8533 *s += 2;
8534 goto loop;
8538 return c;
8542 /* XBM bits seem to be backward within bytes compared with how
8543 Windows does things. */
8544 static unsigned char reflect_byte (unsigned char orig)
8546 int i;
8547 unsigned char reflected = 0x00;
8548 for (i = 0; i < 8; i++)
8550 if (orig & (0x01 << i))
8551 reflected |= 0x80 >> i;
8553 return reflected;
8557 /* Create a Windows bitmap from X bitmap data. */
8558 static HBITMAP
8559 w32_create_pixmap_from_bitmap_data (int width, int height, char *data)
8561 int i, j, w1, w2;
8562 char *bits, *p;
8563 HBITMAP bmp;
8565 w1 = (width + 7) / 8; /* nb of 8bits elt in X bitmap */
8566 w2 = ((width + 15) / 16) * 2; /* nb of 16bits elt in W32 bitmap */
8567 bits = (char *) alloca (height * w2);
8568 bzero (bits, height * w2);
8569 for (i = 0; i < height; i++)
8571 p = bits + i*w2;
8572 for (j = 0; j < w1; j++)
8573 *p++ = reflect_byte(*data++);
8575 bmp = CreateBitmap (width, height, 1, 1, bits);
8577 return bmp;
8581 /* Replacement for XReadBitmapFileData which isn't available under old
8582 X versions. CONTENTS is a pointer to a buffer to parse; END is the
8583 buffer's end. Set *WIDTH and *HEIGHT to the width and height of
8584 the image. Return in *DATA the bitmap data allocated with xmalloc.
8585 Value is non-zero if successful. DATA null means just test if
8586 CONTENTS looks like an in-memory XBM file. */
8588 static int
8589 xbm_read_bitmap_data (contents, end, width, height, data)
8590 char *contents, *end;
8591 int *width, *height;
8592 unsigned char **data;
8594 char *s = contents;
8595 char buffer[BUFSIZ];
8596 int padding_p = 0;
8597 int v10 = 0;
8598 int bytes_per_line, i, nbytes;
8599 unsigned char *p;
8600 int value;
8601 int LA1;
8603 #define match() \
8604 LA1 = xbm_scan (&s, end, buffer, &value)
8606 #define expect(TOKEN) \
8607 if (LA1 != (TOKEN)) \
8608 goto failure; \
8609 else \
8610 match ()
8612 #define expect_ident(IDENT) \
8613 if (LA1 == XBM_TK_IDENT && strcmp (buffer, (IDENT)) == 0) \
8614 match (); \
8615 else \
8616 goto failure
8618 *width = *height = -1;
8619 if (data)
8620 *data = NULL;
8621 LA1 = xbm_scan (&s, end, buffer, &value);
8623 /* Parse defines for width, height and hot-spots. */
8624 while (LA1 == '#')
8626 match ();
8627 expect_ident ("define");
8628 expect (XBM_TK_IDENT);
8630 if (LA1 == XBM_TK_NUMBER);
8632 char *p = strrchr (buffer, '_');
8633 p = p ? p + 1 : buffer;
8634 if (strcmp (p, "width") == 0)
8635 *width = value;
8636 else if (strcmp (p, "height") == 0)
8637 *height = value;
8639 expect (XBM_TK_NUMBER);
8642 if (*width < 0 || *height < 0)
8643 goto failure;
8644 else if (data == NULL)
8645 goto success;
8647 /* Parse bits. Must start with `static'. */
8648 expect_ident ("static");
8649 if (LA1 == XBM_TK_IDENT)
8651 if (strcmp (buffer, "unsigned") == 0)
8653 match ();
8654 expect_ident ("char");
8656 else if (strcmp (buffer, "short") == 0)
8658 match ();
8659 v10 = 1;
8660 if (*width % 16 && *width % 16 < 9)
8661 padding_p = 1;
8663 else if (strcmp (buffer, "char") == 0)
8664 match ();
8665 else
8666 goto failure;
8668 else
8669 goto failure;
8671 expect (XBM_TK_IDENT);
8672 expect ('[');
8673 expect (']');
8674 expect ('=');
8675 expect ('{');
8677 bytes_per_line = (*width + 7) / 8 + padding_p;
8678 nbytes = bytes_per_line * *height;
8679 p = *data = (char *) xmalloc (nbytes);
8681 if (v10)
8683 for (i = 0; i < nbytes; i += 2)
8685 int val = value;
8686 expect (XBM_TK_NUMBER);
8688 *p++ = ~ val;
8689 if (!padding_p || ((i + 2) % bytes_per_line))
8690 *p++ = ~ (value >> 8);
8692 if (LA1 == ',' || LA1 == '}')
8693 match ();
8694 else
8695 goto failure;
8698 else
8700 for (i = 0; i < nbytes; ++i)
8702 int val = value;
8703 expect (XBM_TK_NUMBER);
8705 *p++ = ~ val;
8707 if (LA1 == ',' || LA1 == '}')
8708 match ();
8709 else
8710 goto failure;
8714 success:
8715 return 1;
8717 failure:
8719 if (data && *data)
8721 xfree (*data);
8722 *data = NULL;
8724 return 0;
8726 #undef match
8727 #undef expect
8728 #undef expect_ident
8731 static void convert_mono_to_color_image (f, img, foreground, background)
8732 struct frame *f;
8733 struct image *img;
8734 COLORREF foreground, background;
8736 HDC hdc, old_img_dc, new_img_dc;
8737 HGDIOBJ old_prev, new_prev;
8738 HBITMAP new_pixmap;
8740 hdc = get_frame_dc (f);
8741 old_img_dc = CreateCompatibleDC (hdc);
8742 new_img_dc = CreateCompatibleDC (hdc);
8743 new_pixmap = CreateCompatibleBitmap (hdc, img->width, img->height);
8744 release_frame_dc (f, hdc);
8745 old_prev = SelectObject (old_img_dc, img->pixmap);
8746 new_prev = SelectObject (new_img_dc, new_pixmap);
8747 SetTextColor (new_img_dc, foreground);
8748 SetBkColor (new_img_dc, background);
8750 BitBlt (new_img_dc, 0, 0, img->width, img->height, old_img_dc,
8751 0, 0, SRCCOPY);
8753 SelectObject (old_img_dc, old_prev);
8754 SelectObject (new_img_dc, new_prev);
8755 DeleteDC (old_img_dc);
8756 DeleteDC (new_img_dc);
8757 DeleteObject (img->pixmap);
8758 if (new_pixmap == 0)
8759 fprintf (stderr, "Failed to convert image to color.\n");
8760 else
8761 img->pixmap = new_pixmap;
8764 /* Load XBM image IMG which will be displayed on frame F from buffer
8765 CONTENTS. END is the end of the buffer. Value is non-zero if
8766 successful. */
8768 static int
8769 xbm_load_image (f, img, contents, end)
8770 struct frame *f;
8771 struct image *img;
8772 char *contents, *end;
8774 int rc;
8775 unsigned char *data;
8776 int success_p = 0;
8778 rc = xbm_read_bitmap_data (contents, end, &img->width, &img->height, &data);
8779 if (rc)
8781 unsigned long foreground = FRAME_FOREGROUND_PIXEL (f);
8782 unsigned long background = FRAME_BACKGROUND_PIXEL (f);
8783 int non_default_colors = 0;
8784 Lisp_Object value;
8786 xassert (img->width > 0 && img->height > 0);
8788 /* Get foreground and background colors, maybe allocate colors. */
8789 value = image_spec_value (img->spec, QCforeground, NULL);
8790 if (!NILP (value))
8792 foreground = x_alloc_image_color (f, img, value, foreground);
8793 non_default_colors = 1;
8795 value = image_spec_value (img->spec, QCbackground, NULL);
8796 if (!NILP (value))
8798 background = x_alloc_image_color (f, img, value, background);
8799 img->background = background;
8800 img->background_valid = 1;
8801 non_default_colors = 1;
8803 img->pixmap
8804 = w32_create_pixmap_from_bitmap_data (img->width, img->height, data);
8806 /* If colors were specified, transfer the bitmap to a color one. */
8807 if (non_default_colors)
8808 convert_mono_to_color_image (f, img, foreground, background);
8810 xfree (data);
8812 if (img->pixmap == 0)
8814 x_clear_image (f, img);
8815 image_error ("Unable to create X pixmap for `%s'", img->spec, Qnil);
8817 else
8818 success_p = 1;
8820 else
8821 image_error ("Error loading XBM image `%s'", img->spec, Qnil);
8823 return success_p;
8827 /* Value is non-zero if DATA looks like an in-memory XBM file. */
8829 static int
8830 xbm_file_p (data)
8831 Lisp_Object data;
8833 int w, h;
8834 return (STRINGP (data)
8835 && xbm_read_bitmap_data (SDATA (data),
8836 (SDATA (data)
8837 + SBYTES (data)),
8838 &w, &h, NULL));
8842 /* Fill image IMG which is used on frame F with pixmap data. Value is
8843 non-zero if successful. */
8845 static int
8846 xbm_load (f, img)
8847 struct frame *f;
8848 struct image *img;
8850 int success_p = 0;
8851 Lisp_Object file_name;
8853 xassert (xbm_image_p (img->spec));
8855 /* If IMG->spec specifies a file name, create a non-file spec from it. */
8856 file_name = image_spec_value (img->spec, QCfile, NULL);
8857 if (STRINGP (file_name))
8859 Lisp_Object file;
8860 char *contents;
8861 int size;
8862 struct gcpro gcpro1;
8864 file = x_find_image_file (file_name);
8865 GCPRO1 (file);
8866 if (!STRINGP (file))
8868 image_error ("Cannot find image file `%s'", file_name, Qnil);
8869 UNGCPRO;
8870 return 0;
8873 contents = slurp_file (SDATA (file), &size);
8874 if (contents == NULL)
8876 image_error ("Error loading XBM image `%s'", img->spec, Qnil);
8877 UNGCPRO;
8878 return 0;
8881 success_p = xbm_load_image (f, img, contents, contents + size);
8882 UNGCPRO;
8884 else
8886 struct image_keyword fmt[XBM_LAST];
8887 Lisp_Object data;
8888 unsigned long foreground = FRAME_FOREGROUND_PIXEL (f);
8889 unsigned long background = FRAME_BACKGROUND_PIXEL (f);
8890 int non_default_colors = 0;
8891 char *bits;
8892 int parsed_p;
8893 int in_memory_file_p = 0;
8895 /* See if data looks like an in-memory XBM file. */
8896 data = image_spec_value (img->spec, QCdata, NULL);
8897 in_memory_file_p = xbm_file_p (data);
8899 /* Parse the image specification. */
8900 bcopy (xbm_format, fmt, sizeof fmt);
8901 parsed_p = parse_image_spec (img->spec, fmt, XBM_LAST, Qxbm);
8902 xassert (parsed_p);
8904 /* Get specified width, and height. */
8905 if (!in_memory_file_p)
8907 img->width = XFASTINT (fmt[XBM_WIDTH].value);
8908 img->height = XFASTINT (fmt[XBM_HEIGHT].value);
8909 xassert (img->width > 0 && img->height > 0);
8912 /* Get foreground and background colors, maybe allocate colors. */
8913 if (fmt[XBM_FOREGROUND].count
8914 && STRINGP (fmt[XBM_FOREGROUND].value))
8916 foreground = x_alloc_image_color (f, img, fmt[XBM_FOREGROUND].value,
8917 foreground);
8918 non_default_colors = 1;
8921 if (fmt[XBM_BACKGROUND].count
8922 && STRINGP (fmt[XBM_BACKGROUND].value))
8924 background = x_alloc_image_color (f, img, fmt[XBM_BACKGROUND].value,
8925 background);
8926 non_default_colors = 1;
8929 if (in_memory_file_p)
8930 success_p = xbm_load_image (f, img, SDATA (data),
8931 (SDATA (data)
8932 + SBYTES (data)));
8933 else
8935 if (VECTORP (data))
8937 int i;
8938 char *p;
8939 int nbytes = (img->width + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
8941 p = bits = (char *) alloca (nbytes * img->height);
8942 for (i = 0; i < img->height; ++i, p += nbytes)
8944 Lisp_Object line = XVECTOR (data)->contents[i];
8945 if (STRINGP (line))
8946 bcopy (SDATA (line), p, nbytes);
8947 else
8948 bcopy (XBOOL_VECTOR (line)->data, p, nbytes);
8951 else if (STRINGP (data))
8952 bits = SDATA (data);
8953 else
8954 bits = XBOOL_VECTOR (data)->data;
8956 /* Create the pixmap. */
8957 img->pixmap
8958 = w32_create_pixmap_from_bitmap_data (img->width, img->height,
8959 bits);
8961 /* If colors were specified, transfer the bitmap to a color one. */
8962 if (non_default_colors)
8963 convert_mono_to_color_image (f, img, foreground, background);
8965 if (img->pixmap)
8966 success_p = 1;
8967 else
8969 image_error ("Unable to create pixmap for XBM image `%s'",
8970 img->spec, Qnil);
8971 x_clear_image (f, img);
8976 return success_p;
8981 /***********************************************************************
8982 XPM images
8983 ***********************************************************************/
8985 #if HAVE_XPM
8987 static int xpm_image_p P_ ((Lisp_Object object));
8988 static int xpm_load P_ ((struct frame *f, struct image *img));
8989 static int xpm_valid_color_symbols_p P_ ((Lisp_Object));
8991 /* Indicate to xpm.h that we don't have Xlib. */
8992 #define FOR_MSW
8993 /* simx.h in xpm defines XColor and XImage differently than Emacs. */
8994 #define XColor xpm_XColor
8995 #define XImage xpm_XImage
8996 #define PIXEL_ALREADY_TYPEDEFED
8997 #include "X11/xpm.h"
8998 #undef FOR_MSW
8999 #undef XColor
9000 #undef XImage
9001 #undef PIXEL_ALREADY_TYPEDEFED
9003 /* The symbol `xpm' identifying XPM-format images. */
9005 Lisp_Object Qxpm;
9007 /* Indices of image specification fields in xpm_format, below. */
9009 enum xpm_keyword_index
9011 XPM_TYPE,
9012 XPM_FILE,
9013 XPM_DATA,
9014 XPM_ASCENT,
9015 XPM_MARGIN,
9016 XPM_RELIEF,
9017 XPM_ALGORITHM,
9018 XPM_HEURISTIC_MASK,
9019 XPM_MASK,
9020 XPM_COLOR_SYMBOLS,
9021 XPM_BACKGROUND,
9022 XPM_LAST
9025 /* Vector of image_keyword structures describing the format
9026 of valid XPM image specifications. */
9028 static struct image_keyword xpm_format[XPM_LAST] =
9030 {":type", IMAGE_SYMBOL_VALUE, 1},
9031 {":file", IMAGE_STRING_VALUE, 0},
9032 {":data", IMAGE_STRING_VALUE, 0},
9033 {":ascent", IMAGE_ASCENT_VALUE, 0},
9034 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
9035 {":relief", IMAGE_INTEGER_VALUE, 0},
9036 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
9037 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
9038 {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
9039 {":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
9040 {":background", IMAGE_STRING_OR_NIL_VALUE, 0}
9043 /* Structure describing the image type XPM. */
9045 static struct image_type xpm_type =
9047 &Qxpm,
9048 xpm_image_p,
9049 xpm_load,
9050 x_clear_image,
9051 NULL
9055 /* XPM library details. */
9057 DEF_IMGLIB_FN (XpmFreeAttributes);
9058 DEF_IMGLIB_FN (XpmCreateImageFromBuffer);
9059 DEF_IMGLIB_FN (XpmReadFileToImage);
9060 DEF_IMGLIB_FN (XImageFree);
9063 static int
9064 init_xpm_functions (library)
9065 HMODULE library;
9067 LOAD_IMGLIB_FN (library, XpmFreeAttributes);
9068 LOAD_IMGLIB_FN (library, XpmCreateImageFromBuffer);
9069 LOAD_IMGLIB_FN (library, XpmReadFileToImage);
9070 LOAD_IMGLIB_FN (library, XImageFree);
9072 return 1;
9075 /* Value is non-zero if COLOR_SYMBOLS is a valid color symbols list
9076 for XPM images. Such a list must consist of conses whose car and
9077 cdr are strings. */
9079 static int
9080 xpm_valid_color_symbols_p (color_symbols)
9081 Lisp_Object color_symbols;
9083 while (CONSP (color_symbols))
9085 Lisp_Object sym = XCAR (color_symbols);
9086 if (!CONSP (sym)
9087 || !STRINGP (XCAR (sym))
9088 || !STRINGP (XCDR (sym)))
9089 break;
9090 color_symbols = XCDR (color_symbols);
9093 return NILP (color_symbols);
9097 /* Value is non-zero if OBJECT is a valid XPM image specification. */
9099 static int
9100 xpm_image_p (object)
9101 Lisp_Object object;
9103 struct image_keyword fmt[XPM_LAST];
9104 bcopy (xpm_format, fmt, sizeof fmt);
9105 return (parse_image_spec (object, fmt, XPM_LAST, Qxpm)
9106 /* Either `:file' or `:data' must be present. */
9107 && fmt[XPM_FILE].count + fmt[XPM_DATA].count == 1
9108 /* Either no `:color-symbols' or it's a list of conses
9109 whose car and cdr are strings. */
9110 && (fmt[XPM_COLOR_SYMBOLS].count == 0
9111 || xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value)));
9115 /* Load image IMG which will be displayed on frame F. Value is
9116 non-zero if successful. */
9118 static int
9119 xpm_load (f, img)
9120 struct frame *f;
9121 struct image *img;
9123 HDC hdc;
9124 int rc;
9125 XpmAttributes attrs;
9126 Lisp_Object specified_file, color_symbols;
9127 xpm_XImage * xpm_image, * xpm_mask;
9129 /* Configure the XPM lib. Use the visual of frame F. Allocate
9130 close colors. Return colors allocated. */
9131 bzero (&attrs, sizeof attrs);
9132 xpm_image = xpm_mask = NULL;
9134 #if 0
9135 attrs.visual = FRAME_X_VISUAL (f);
9136 attrs.colormap = FRAME_X_COLORMAP (f);
9137 attrs.valuemask |= XpmVisual;
9138 attrs.valuemask |= XpmColormap;
9139 #endif
9140 attrs.valuemask |= XpmReturnAllocPixels;
9141 #ifdef XpmAllocCloseColors
9142 attrs.alloc_close_colors = 1;
9143 attrs.valuemask |= XpmAllocCloseColors;
9144 #else
9145 attrs.closeness = 600;
9146 attrs.valuemask |= XpmCloseness;
9147 #endif
9149 /* If image specification contains symbolic color definitions, add
9150 these to `attrs'. */
9151 color_symbols = image_spec_value (img->spec, QCcolor_symbols, NULL);
9152 if (CONSP (color_symbols))
9154 Lisp_Object tail;
9155 XpmColorSymbol *xpm_syms;
9156 int i, size;
9158 attrs.valuemask |= XpmColorSymbols;
9160 /* Count number of symbols. */
9161 attrs.numsymbols = 0;
9162 for (tail = color_symbols; CONSP (tail); tail = XCDR (tail))
9163 ++attrs.numsymbols;
9165 /* Allocate an XpmColorSymbol array. */
9166 size = attrs.numsymbols * sizeof *xpm_syms;
9167 xpm_syms = (XpmColorSymbol *) alloca (size);
9168 bzero (xpm_syms, size);
9169 attrs.colorsymbols = xpm_syms;
9171 /* Fill the color symbol array. */
9172 for (tail = color_symbols, i = 0;
9173 CONSP (tail);
9174 ++i, tail = XCDR (tail))
9176 Lisp_Object name = XCAR (XCAR (tail));
9177 Lisp_Object color = XCDR (XCAR (tail));
9178 xpm_syms[i].name = (char *) alloca (SCHARS (name) + 1);
9179 strcpy (xpm_syms[i].name, SDATA (name));
9180 xpm_syms[i].value = (char *) alloca (SCHARS (color) + 1);
9181 strcpy (xpm_syms[i].value, SDATA (color));
9185 /* Create a pixmap for the image, either from a file, or from a
9186 string buffer containing data in the same format as an XPM file. */
9188 specified_file = image_spec_value (img->spec, QCfile, NULL);
9191 HDC frame_dc = get_frame_dc (f);
9192 hdc = CreateCompatibleDC (frame_dc);
9193 release_frame_dc (f, frame_dc);
9196 if (STRINGP (specified_file))
9198 Lisp_Object file = x_find_image_file (specified_file);
9199 if (!STRINGP (file))
9201 image_error ("Cannot find image file `%s'", specified_file, Qnil);
9202 return 0;
9205 /* XpmReadFileToPixmap is not available in the Windows port of
9206 libxpm. But XpmReadFileToImage almost does what we want. */
9207 rc = fn_XpmReadFileToImage (&hdc, SDATA (file),
9208 &xpm_image, &xpm_mask,
9209 &attrs);
9211 else
9213 Lisp_Object buffer = image_spec_value (img->spec, QCdata, NULL);
9214 /* XpmCreatePixmapFromBuffer is not available in the Windows port
9215 of libxpm. But XpmCreateImageFromBuffer almost does what we want. */
9216 rc = fn_XpmCreateImageFromBuffer (&hdc, SDATA (buffer),
9217 &xpm_image, &xpm_mask,
9218 &attrs);
9221 if (rc == XpmSuccess)
9223 int i;
9225 /* W32 XPM uses XImage to wrap what W32 Emacs calls a Pixmap,
9226 plus some duplicate attributes. */
9227 if (xpm_image && xpm_image->bitmap)
9229 img->pixmap = xpm_image->bitmap;
9230 /* XImageFree in libXpm frees XImage struct without destroying
9231 the bitmap, which is what we want. */
9232 fn_XImageFree (xpm_image);
9234 if (xpm_mask && xpm_mask->bitmap)
9236 /* The mask appears to be inverted compared with what we expect.
9237 TODO: invert our expectations. See other places where we
9238 have to invert bits because our idea of masks is backwards. */
9239 HGDIOBJ old_obj;
9240 old_obj = SelectObject (hdc, xpm_mask->bitmap);
9242 PatBlt (hdc, 0, 0, xpm_mask->width, xpm_mask->height, DSTINVERT);
9243 SelectObject (hdc, old_obj);
9245 img->mask = xpm_mask->bitmap;
9246 fn_XImageFree (xpm_mask);
9247 DeleteDC (hdc);
9250 DeleteDC (hdc);
9252 /* Remember allocated colors. */
9253 img->ncolors = attrs.nalloc_pixels;
9254 img->colors = (unsigned long *) xmalloc (img->ncolors
9255 * sizeof *img->colors);
9256 for (i = 0; i < attrs.nalloc_pixels; ++i)
9257 img->colors[i] = attrs.alloc_pixels[i];
9259 img->width = attrs.width;
9260 img->height = attrs.height;
9261 xassert (img->width > 0 && img->height > 0);
9263 /* The call to XpmFreeAttributes below frees attrs.alloc_pixels. */
9264 fn_XpmFreeAttributes (&attrs);
9266 else
9268 DeleteDC (hdc);
9270 switch (rc)
9272 case XpmOpenFailed:
9273 image_error ("Error opening XPM file (%s)", img->spec, Qnil);
9274 break;
9276 case XpmFileInvalid:
9277 image_error ("Invalid XPM file (%s)", img->spec, Qnil);
9278 break;
9280 case XpmNoMemory:
9281 image_error ("Out of memory (%s)", img->spec, Qnil);
9282 break;
9284 case XpmColorFailed:
9285 image_error ("Color allocation error (%s)", img->spec, Qnil);
9286 break;
9288 default:
9289 image_error ("Unknown error (%s)", img->spec, Qnil);
9290 break;
9294 return rc == XpmSuccess;
9297 #endif /* HAVE_XPM != 0 */
9300 #if 0 /* TODO : Color tables on W32. */
9301 /***********************************************************************
9302 Color table
9303 ***********************************************************************/
9305 /* An entry in the color table mapping an RGB color to a pixel color. */
9307 struct ct_color
9309 int r, g, b;
9310 unsigned long pixel;
9312 /* Next in color table collision list. */
9313 struct ct_color *next;
9316 /* The bucket vector size to use. Must be prime. */
9318 #define CT_SIZE 101
9320 /* Value is a hash of the RGB color given by R, G, and B. */
9322 #define CT_HASH_RGB(R, G, B) (((R) << 16) ^ ((G) << 8) ^ (B))
9324 /* The color hash table. */
9326 struct ct_color **ct_table;
9328 /* Number of entries in the color table. */
9330 int ct_colors_allocated;
9332 /* Function prototypes. */
9334 static void init_color_table P_ ((void));
9335 static void free_color_table P_ ((void));
9336 static unsigned long *colors_in_color_table P_ ((int *n));
9337 static unsigned long lookup_rgb_color P_ ((struct frame *f, int r, int g, int b));
9338 static unsigned long lookup_pixel_color P_ ((struct frame *f, unsigned long p));
9341 /* Initialize the color table. */
9343 static void
9344 init_color_table ()
9346 int size = CT_SIZE * sizeof (*ct_table);
9347 ct_table = (struct ct_color **) xmalloc (size);
9348 bzero (ct_table, size);
9349 ct_colors_allocated = 0;
9353 /* Free memory associated with the color table. */
9355 static void
9356 free_color_table ()
9358 int i;
9359 struct ct_color *p, *next;
9361 for (i = 0; i < CT_SIZE; ++i)
9362 for (p = ct_table[i]; p; p = next)
9364 next = p->next;
9365 xfree (p);
9368 xfree (ct_table);
9369 ct_table = NULL;
9373 /* Value is a pixel color for RGB color R, G, B on frame F. If an
9374 entry for that color already is in the color table, return the
9375 pixel color of that entry. Otherwise, allocate a new color for R,
9376 G, B, and make an entry in the color table. */
9378 static unsigned long
9379 lookup_rgb_color (f, r, g, b)
9380 struct frame *f;
9381 int r, g, b;
9383 unsigned hash = CT_HASH_RGB (r, g, b);
9384 int i = hash % CT_SIZE;
9385 struct ct_color *p;
9387 for (p = ct_table[i]; p; p = p->next)
9388 if (p->r == r && p->g == g && p->b == b)
9389 break;
9391 if (p == NULL)
9393 COLORREF color;
9394 Colormap cmap;
9395 int rc;
9397 color = PALETTERGB (r, g, b);
9399 ++ct_colors_allocated;
9401 p = (struct ct_color *) xmalloc (sizeof *p);
9402 p->r = r;
9403 p->g = g;
9404 p->b = b;
9405 p->pixel = color;
9406 p->next = ct_table[i];
9407 ct_table[i] = p;
9410 return p->pixel;
9414 /* Look up pixel color PIXEL which is used on frame F in the color
9415 table. If not already present, allocate it. Value is PIXEL. */
9417 static unsigned long
9418 lookup_pixel_color (f, pixel)
9419 struct frame *f;
9420 unsigned long pixel;
9422 int i = pixel % CT_SIZE;
9423 struct ct_color *p;
9425 for (p = ct_table[i]; p; p = p->next)
9426 if (p->pixel == pixel)
9427 break;
9429 if (p == NULL)
9431 XColor color;
9432 Colormap cmap;
9433 int rc;
9435 BLOCK_INPUT;
9437 cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f));
9438 color.pixel = pixel;
9439 XQueryColor (NULL, cmap, &color);
9440 rc = x_alloc_nearest_color (f, cmap, &color);
9441 UNBLOCK_INPUT;
9443 if (rc)
9445 ++ct_colors_allocated;
9447 p = (struct ct_color *) xmalloc (sizeof *p);
9448 p->r = color.red;
9449 p->g = color.green;
9450 p->b = color.blue;
9451 p->pixel = pixel;
9452 p->next = ct_table[i];
9453 ct_table[i] = p;
9455 else
9456 return FRAME_FOREGROUND_PIXEL (f);
9458 return p->pixel;
9462 /* Value is a vector of all pixel colors contained in the color table,
9463 allocated via xmalloc. Set *N to the number of colors. */
9465 static unsigned long *
9466 colors_in_color_table (n)
9467 int *n;
9469 int i, j;
9470 struct ct_color *p;
9471 unsigned long *colors;
9473 if (ct_colors_allocated == 0)
9475 *n = 0;
9476 colors = NULL;
9478 else
9480 colors = (unsigned long *) xmalloc (ct_colors_allocated
9481 * sizeof *colors);
9482 *n = ct_colors_allocated;
9484 for (i = j = 0; i < CT_SIZE; ++i)
9485 for (p = ct_table[i]; p; p = p->next)
9486 colors[j++] = p->pixel;
9489 return colors;
9492 #endif /* TODO */
9495 /***********************************************************************
9496 Algorithms
9497 ***********************************************************************/
9498 static XColor *x_to_xcolors P_ ((struct frame *, struct image *, int));
9499 static void x_from_xcolors P_ ((struct frame *, struct image *, XColor *));
9500 static void x_detect_edges P_ ((struct frame *, struct image *, int[9], int));
9501 static void XPutPixel (XImage *, int, int, COLORREF);
9503 /* Non-zero means draw a cross on images having `:conversion
9504 disabled'. */
9506 int cross_disabled_images;
9508 /* Edge detection matrices for different edge-detection
9509 strategies. */
9511 static int emboss_matrix[9] = {
9512 /* x - 1 x x + 1 */
9513 2, -1, 0, /* y - 1 */
9514 -1, 0, 1, /* y */
9515 0, 1, -2 /* y + 1 */
9518 static int laplace_matrix[9] = {
9519 /* x - 1 x x + 1 */
9520 1, 0, 0, /* y - 1 */
9521 0, 0, 0, /* y */
9522 0, 0, -1 /* y + 1 */
9525 /* Value is the intensity of the color whose red/green/blue values
9526 are R, G, and B. */
9528 #define COLOR_INTENSITY(R, G, B) ((2 * (R) + 3 * (G) + (B)) / 6)
9531 /* On frame F, return an array of XColor structures describing image
9532 IMG->pixmap. Each XColor structure has its pixel color set. RGB_P
9533 non-zero means also fill the red/green/blue members of the XColor
9534 structures. Value is a pointer to the array of XColors structures,
9535 allocated with xmalloc; it must be freed by the caller. */
9537 static XColor *
9538 x_to_xcolors (f, img, rgb_p)
9539 struct frame *f;
9540 struct image *img;
9541 int rgb_p;
9543 int x, y;
9544 XColor *colors, *p;
9545 HDC hdc, bmpdc;
9546 HGDIOBJ prev;
9548 colors = (XColor *) xmalloc (img->width * img->height * sizeof *colors);
9550 /* Load the image into a memory device context. */
9551 hdc = get_frame_dc (f);
9552 bmpdc = CreateCompatibleDC (hdc);
9553 release_frame_dc (f, hdc);
9554 prev = SelectObject (bmpdc, img->pixmap);
9556 /* Fill the `pixel' members of the XColor array. I wished there
9557 were an easy and portable way to circumvent XGetPixel. */
9558 p = colors;
9559 for (y = 0; y < img->height; ++y)
9561 XColor *row = p;
9563 for (x = 0; x < img->width; ++x, ++p)
9565 /* TODO: palette support needed here? */
9566 p->pixel = GetPixel (bmpdc, x, y);
9568 if (rgb_p)
9570 p->red = 256 * GetRValue (p->pixel);
9571 p->green = 256 * GetGValue (p->pixel);
9572 p->blue = 256 * GetBValue (p->pixel);
9577 SelectObject (bmpdc, prev);
9578 DeleteDC (bmpdc);
9580 return colors;
9583 /* Put a pixel of COLOR at position X, Y in XIMG. XIMG must have been
9584 created with CreateDIBSection, with the pointer to the bit values
9585 stored in ximg->data. */
9587 static void XPutPixel (ximg, x, y, color)
9588 XImage * ximg;
9589 int x, y;
9590 COLORREF color;
9592 int width = ximg->info.bmiHeader.biWidth;
9593 int height = ximg->info.bmiHeader.biHeight;
9594 unsigned char * pixel;
9596 /* True color images. */
9597 if (ximg->info.bmiHeader.biBitCount == 24)
9599 int rowbytes = width * 3;
9600 /* Ensure scanlines are aligned on 4 byte boundaries. */
9601 if (rowbytes % 4)
9602 rowbytes += 4 - (rowbytes % 4);
9604 pixel = ximg->data + y * rowbytes + x * 3;
9605 /* Windows bitmaps are in BGR order. */
9606 *pixel = GetBValue (color);
9607 *(pixel + 1) = GetGValue (color);
9608 *(pixel + 2) = GetRValue (color);
9610 /* Monochrome images. */
9611 else if (ximg->info.bmiHeader.biBitCount == 1)
9613 int rowbytes = width / 8;
9614 /* Ensure scanlines are aligned on 4 byte boundaries. */
9615 if (rowbytes % 4)
9616 rowbytes += 4 - (rowbytes % 4);
9617 pixel = ximg->data + y * rowbytes + x / 8;
9618 /* Filter out palette info. */
9619 if (color & 0x00ffffff)
9620 *pixel = *pixel | (1 << x % 8);
9621 else
9622 *pixel = *pixel & ~(1 << x % 8);
9624 else
9625 image_error ("XPutPixel: palette image not supported.", Qnil, Qnil);
9628 /* Create IMG->pixmap from an array COLORS of XColor structures, whose
9629 RGB members are set. F is the frame on which this all happens.
9630 COLORS will be freed; an existing IMG->pixmap will be freed, too. */
9632 static void
9633 x_from_xcolors (f, img, colors)
9634 struct frame *f;
9635 struct image *img;
9636 XColor *colors;
9638 int x, y;
9639 XImage *oimg;
9640 Pixmap pixmap;
9641 XColor *p;
9642 #if 0 /* TODO: color tables. */
9643 init_color_table ();
9644 #endif
9645 x_create_x_image_and_pixmap (f, img->width, img->height, 0,
9646 &oimg, &pixmap);
9647 p = colors;
9648 for (y = 0; y < img->height; ++y)
9649 for (x = 0; x < img->width; ++x, ++p)
9651 unsigned long pixel;
9652 #if 0 /* TODO: color tables. */
9653 pixel = lookup_rgb_color (f, p->red, p->green, p->blue);
9654 #else
9655 pixel = PALETTERGB (p->red / 256, p->green / 256, p->blue / 256);
9656 #endif
9657 XPutPixel (oimg, x, y, pixel);
9660 xfree (colors);
9661 x_clear_image_1 (f, img, 1, 0, 1);
9663 x_put_x_image (f, oimg, pixmap, img->width, img->height);
9664 x_destroy_x_image (oimg);
9665 img->pixmap = pixmap;
9666 #if 0 /* TODO: color tables. */
9667 img->colors = colors_in_color_table (&img->ncolors);
9668 free_color_table ();
9669 #endif
9673 /* On frame F, perform edge-detection on image IMG.
9675 MATRIX is a nine-element array specifying the transformation
9676 matrix. See emboss_matrix for an example.
9678 COLOR_ADJUST is a color adjustment added to each pixel of the
9679 outgoing image. */
9681 static void
9682 x_detect_edges (f, img, matrix, color_adjust)
9683 struct frame *f;
9684 struct image *img;
9685 int matrix[9], color_adjust;
9687 XColor *colors = x_to_xcolors (f, img, 1);
9688 XColor *new, *p;
9689 int x, y, i, sum;
9691 for (i = sum = 0; i < 9; ++i)
9692 sum += abs (matrix[i]);
9694 #define COLOR(A, X, Y) ((A) + (Y) * img->width + (X))
9696 new = (XColor *) xmalloc (img->width * img->height * sizeof *new);
9698 for (y = 0; y < img->height; ++y)
9700 p = COLOR (new, 0, y);
9701 p->red = p->green = p->blue = 0xffff/2;
9702 p = COLOR (new, img->width - 1, y);
9703 p->red = p->green = p->blue = 0xffff/2;
9706 for (x = 1; x < img->width - 1; ++x)
9708 p = COLOR (new, x, 0);
9709 p->red = p->green = p->blue = 0xffff/2;
9710 p = COLOR (new, x, img->height - 1);
9711 p->red = p->green = p->blue = 0xffff/2;
9714 for (y = 1; y < img->height - 1; ++y)
9716 p = COLOR (new, 1, y);
9718 for (x = 1; x < img->width - 1; ++x, ++p)
9720 int r, g, b, y1, x1;
9722 r = g = b = i = 0;
9723 for (y1 = y - 1; y1 < y + 2; ++y1)
9724 for (x1 = x - 1; x1 < x + 2; ++x1, ++i)
9725 if (matrix[i])
9727 XColor *t = COLOR (colors, x1, y1);
9728 r += matrix[i] * t->red;
9729 g += matrix[i] * t->green;
9730 b += matrix[i] * t->blue;
9733 r = (r / sum + color_adjust) & 0xffff;
9734 g = (g / sum + color_adjust) & 0xffff;
9735 b = (b / sum + color_adjust) & 0xffff;
9736 p->red = p->green = p->blue = COLOR_INTENSITY (r, g, b);
9740 xfree (colors);
9741 x_from_xcolors (f, img, new);
9743 #undef COLOR
9747 /* Perform the pre-defined `emboss' edge-detection on image IMG
9748 on frame F. */
9750 static void
9751 x_emboss (f, img)
9752 struct frame *f;
9753 struct image *img;
9755 x_detect_edges (f, img, emboss_matrix, 0xffff / 2);
9759 /* Transform image IMG which is used on frame F with a Laplace
9760 edge-detection algorithm. The result is an image that can be used
9761 to draw disabled buttons, for example. */
9763 static void
9764 x_laplace (f, img)
9765 struct frame *f;
9766 struct image *img;
9768 x_detect_edges (f, img, laplace_matrix, 45000);
9772 /* Perform edge-detection on image IMG on frame F, with specified
9773 transformation matrix MATRIX and color-adjustment COLOR_ADJUST.
9775 MATRIX must be either
9777 - a list of at least 9 numbers in row-major form
9778 - a vector of at least 9 numbers
9780 COLOR_ADJUST nil means use a default; otherwise it must be a
9781 number. */
9783 static void
9784 x_edge_detection (f, img, matrix, color_adjust)
9785 struct frame *f;
9786 struct image *img;
9787 Lisp_Object matrix, color_adjust;
9789 int i = 0;
9790 int trans[9];
9792 if (CONSP (matrix))
9794 for (i = 0;
9795 i < 9 && CONSP (matrix) && NUMBERP (XCAR (matrix));
9796 ++i, matrix = XCDR (matrix))
9797 trans[i] = XFLOATINT (XCAR (matrix));
9799 else if (VECTORP (matrix) && ASIZE (matrix) >= 9)
9801 for (i = 0; i < 9 && NUMBERP (AREF (matrix, i)); ++i)
9802 trans[i] = XFLOATINT (AREF (matrix, i));
9805 if (NILP (color_adjust))
9806 color_adjust = make_number (0xffff / 2);
9808 if (i == 9 && NUMBERP (color_adjust))
9809 x_detect_edges (f, img, trans, (int) XFLOATINT (color_adjust));
9813 /* Transform image IMG on frame F so that it looks disabled. */
9815 static void
9816 x_disable_image (f, img)
9817 struct frame *f;
9818 struct image *img;
9820 struct w32_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f);
9822 if (dpyinfo->n_planes * dpyinfo->n_cbits >= 2)
9824 /* Color (or grayscale). Convert to gray, and equalize. Just
9825 drawing such images with a stipple can look very odd, so
9826 we're using this method instead. */
9827 XColor *colors = x_to_xcolors (f, img, 1);
9828 XColor *p, *end;
9829 const int h = 15000;
9830 const int l = 30000;
9832 for (p = colors, end = colors + img->width * img->height;
9833 p < end;
9834 ++p)
9836 int i = COLOR_INTENSITY (p->red, p->green, p->blue);
9837 int i2 = (0xffff - h - l) * i / 0xffff + l;
9838 p->red = p->green = p->blue = i2;
9841 x_from_xcolors (f, img, colors);
9844 /* Draw a cross over the disabled image, if we must or if we
9845 should. */
9846 if (dpyinfo->n_planes * dpyinfo->n_cbits < 2 || cross_disabled_images)
9848 HDC hdc, bmpdc;
9849 HGDIOBJ prev;
9851 hdc = get_frame_dc (f);
9852 bmpdc = CreateCompatibleDC (hdc);
9853 release_frame_dc (f, hdc);
9855 prev = SelectObject (bmpdc, img->pixmap);
9857 SetTextColor (bmpdc, BLACK_PIX_DEFAULT (f));
9858 MoveToEx (bmpdc, 0, 0, NULL);
9859 LineTo (bmpdc, img->width - 1, img->height - 1);
9860 MoveToEx (bmpdc, 0, img->height - 1, NULL);
9861 LineTo (bmpdc, img->width - 1, 0);
9863 if (img->mask)
9865 SelectObject (bmpdc, img->mask);
9866 SetTextColor (bmpdc, WHITE_PIX_DEFAULT (f));
9867 MoveToEx (bmpdc, 0, 0, NULL);
9868 LineTo (bmpdc, img->width - 1, img->height - 1);
9869 MoveToEx (bmpdc, 0, img->height - 1, NULL);
9870 LineTo (bmpdc, img->width - 1, 0);
9872 SelectObject (bmpdc, prev);
9873 DeleteDC (bmpdc);
9878 /* Build a mask for image IMG which is used on frame F. FILE is the
9879 name of an image file, for error messages. HOW determines how to
9880 determine the background color of IMG. If it is a list '(R G B)',
9881 with R, G, and B being integers >= 0, take that as the color of the
9882 background. Otherwise, determine the background color of IMG
9883 heuristically. Value is non-zero if successful. */
9885 static int
9886 x_build_heuristic_mask (f, img, how)
9887 struct frame *f;
9888 struct image *img;
9889 Lisp_Object how;
9891 HDC img_dc, frame_dc;
9892 HGDIOBJ prev;
9893 char *mask_img;
9894 int x, y, rc, use_img_background;
9895 unsigned long bg = 0;
9896 int row_width;
9898 if (img->mask)
9900 DeleteObject (img->mask);
9901 img->mask = NULL;
9902 img->background_transparent_valid = 0;
9905 /* Create the bit array serving as mask. */
9906 row_width = (img->width + 7) / 8;
9907 mask_img = xmalloc (row_width * img->height);
9908 bzero (mask_img, row_width * img->height);
9910 /* Create a memory device context for IMG->pixmap. */
9911 frame_dc = get_frame_dc (f);
9912 img_dc = CreateCompatibleDC (frame_dc);
9913 release_frame_dc (f, frame_dc);
9914 prev = SelectObject (img_dc, img->pixmap);
9916 /* Determine the background color of img_dc. If HOW is `(R G B)'
9917 take that as color. Otherwise, use the image's background color. */
9918 use_img_background = 1;
9920 if (CONSP (how))
9922 int rgb[3], i;
9924 for (i = 0; i < 3 && CONSP (how) && NATNUMP (XCAR (how)); ++i)
9926 rgb[i] = XFASTINT (XCAR (how)) & 0xffff;
9927 how = XCDR (how);
9930 if (i == 3 && NILP (how))
9932 char color_name[30];
9933 sprintf (color_name, "#%04x%04x%04x", rgb[0], rgb[1], rgb[2]);
9934 bg = x_alloc_image_color (f, img, build_string (color_name), 0)
9935 & 0x00ffffff; /* Filter out palette info. */
9936 use_img_background = 0;
9940 if (use_img_background)
9941 bg = four_corners_best (img_dc, img->width, img->height);
9943 /* Set all bits in mask_img to 1 whose color in ximg is different
9944 from the background color bg. */
9945 for (y = 0; y < img->height; ++y)
9946 for (x = 0; x < img->width; ++x)
9948 COLORREF p = GetPixel (img_dc, x, y);
9949 if (p != bg)
9950 mask_img[y * row_width + x / 8] |= 1 << (x % 8);
9953 /* Create the mask image. */
9954 img->mask = w32_create_pixmap_from_bitmap_data (img->width, img->height,
9955 mask_img);
9957 /* Fill in the background_transparent field while we have the mask handy. */
9958 SelectObject (img_dc, img->mask);
9960 image_background_transparent (img, f, img_dc);
9962 /* Put mask_img into img->mask. */
9963 x_destroy_x_image ((XImage *)mask_img);
9964 SelectObject (img_dc, prev);
9965 DeleteDC (img_dc);
9967 return 1;
9971 /***********************************************************************
9972 PBM (mono, gray, color)
9973 ***********************************************************************/
9975 static int pbm_image_p P_ ((Lisp_Object object));
9976 static int pbm_load P_ ((struct frame *f, struct image *img));
9977 static int pbm_scan_number P_ ((unsigned char **, unsigned char *));
9979 /* The symbol `pbm' identifying images of this type. */
9981 Lisp_Object Qpbm;
9983 /* Indices of image specification fields in gs_format, below. */
9985 enum pbm_keyword_index
9987 PBM_TYPE,
9988 PBM_FILE,
9989 PBM_DATA,
9990 PBM_ASCENT,
9991 PBM_MARGIN,
9992 PBM_RELIEF,
9993 PBM_ALGORITHM,
9994 PBM_HEURISTIC_MASK,
9995 PBM_MASK,
9996 PBM_FOREGROUND,
9997 PBM_BACKGROUND,
9998 PBM_LAST
10001 /* Vector of image_keyword structures describing the format
10002 of valid user-defined image specifications. */
10004 static struct image_keyword pbm_format[PBM_LAST] =
10006 {":type", IMAGE_SYMBOL_VALUE, 1},
10007 {":file", IMAGE_STRING_VALUE, 0},
10008 {":data", IMAGE_STRING_VALUE, 0},
10009 {":ascent", IMAGE_ASCENT_VALUE, 0},
10010 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
10011 {":relief", IMAGE_INTEGER_VALUE, 0},
10012 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10013 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10014 {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10015 {":foreground", IMAGE_STRING_OR_NIL_VALUE, 0},
10016 {":background", IMAGE_STRING_OR_NIL_VALUE, 0}
10019 /* Structure describing the image type `pbm'. */
10021 static struct image_type pbm_type =
10023 &Qpbm,
10024 pbm_image_p,
10025 pbm_load,
10026 x_clear_image,
10027 NULL
10031 /* Return non-zero if OBJECT is a valid PBM image specification. */
10033 static int
10034 pbm_image_p (object)
10035 Lisp_Object object;
10037 struct image_keyword fmt[PBM_LAST];
10039 bcopy (pbm_format, fmt, sizeof fmt);
10041 if (!parse_image_spec (object, fmt, PBM_LAST, Qpbm))
10042 return 0;
10044 /* Must specify either :data or :file. */
10045 return fmt[PBM_DATA].count + fmt[PBM_FILE].count == 1;
10049 /* Scan a decimal number from *S and return it. Advance *S while
10050 reading the number. END is the end of the string. Value is -1 at
10051 end of input. */
10053 static int
10054 pbm_scan_number (s, end)
10055 unsigned char **s, *end;
10057 int c, val = -1;
10059 while (*s < end)
10061 /* Skip white-space. */
10062 while (*s < end && (c = *(*s)++, isspace (c)))
10065 if (c == '#')
10067 /* Skip comment to end of line. */
10068 while (*s < end && (c = *(*s)++, c != '\n'))
10071 else if (isdigit (c))
10073 /* Read decimal number. */
10074 val = c - '0';
10075 while (*s < end && (c = *(*s)++, isdigit (c)))
10076 val = 10 * val + c - '0';
10077 break;
10079 else
10080 break;
10083 return val;
10087 /* Read FILE into memory. Value is a pointer to a buffer allocated
10088 with xmalloc holding FILE's contents. Value is null if an error
10089 occurred. *SIZE is set to the size of the file. */
10091 static char *
10092 pbm_read_file (file, size)
10093 Lisp_Object file;
10094 int *size;
10096 FILE *fp = NULL;
10097 char *buf = NULL;
10098 struct stat st;
10100 if (stat (SDATA (file), &st) == 0
10101 && (fp = fopen (SDATA (file), "rb")) != NULL
10102 && (buf = (char *) xmalloc (st.st_size),
10103 fread (buf, 1, st.st_size, fp) == st.st_size))
10105 *size = st.st_size;
10106 fclose (fp);
10108 else
10110 if (fp)
10111 fclose (fp);
10112 if (buf)
10114 xfree (buf);
10115 buf = NULL;
10119 return buf;
10123 /* Load PBM image IMG for use on frame F. */
10125 static int
10126 pbm_load (f, img)
10127 struct frame *f;
10128 struct image *img;
10130 int raw_p, x, y;
10131 int width, height, max_color_idx = 0;
10132 XImage *ximg;
10133 Lisp_Object file, specified_file;
10134 enum {PBM_MONO, PBM_GRAY, PBM_COLOR} type;
10135 struct gcpro gcpro1;
10136 unsigned char *contents = NULL;
10137 unsigned char *end, *p;
10138 int size;
10140 specified_file = image_spec_value (img->spec, QCfile, NULL);
10141 file = Qnil;
10142 GCPRO1 (file);
10144 if (STRINGP (specified_file))
10146 file = x_find_image_file (specified_file);
10147 if (!STRINGP (file))
10149 image_error ("Cannot find image file `%s'", specified_file, Qnil);
10150 UNGCPRO;
10151 return 0;
10154 contents = slurp_file (SDATA (file), &size);
10155 if (contents == NULL)
10157 image_error ("Error reading `%s'", file, Qnil);
10158 UNGCPRO;
10159 return 0;
10162 p = contents;
10163 end = contents + size;
10165 else
10167 Lisp_Object data;
10168 data = image_spec_value (img->spec, QCdata, NULL);
10169 p = SDATA (data);
10170 end = p + SBYTES (data);
10173 /* Check magic number. */
10174 if (end - p < 2 || *p++ != 'P')
10176 image_error ("Not a PBM image: `%s'", img->spec, Qnil);
10177 error:
10178 xfree (contents);
10179 UNGCPRO;
10180 return 0;
10183 switch (*p++)
10185 case '1':
10186 raw_p = 0, type = PBM_MONO;
10187 break;
10189 case '2':
10190 raw_p = 0, type = PBM_GRAY;
10191 break;
10193 case '3':
10194 raw_p = 0, type = PBM_COLOR;
10195 break;
10197 case '4':
10198 raw_p = 1, type = PBM_MONO;
10199 break;
10201 case '5':
10202 raw_p = 1, type = PBM_GRAY;
10203 break;
10205 case '6':
10206 raw_p = 1, type = PBM_COLOR;
10207 break;
10209 default:
10210 image_error ("Not a PBM image: `%s'", img->spec, Qnil);
10211 goto error;
10214 /* Read width, height, maximum color-component. Characters
10215 starting with `#' up to the end of a line are ignored. */
10216 width = pbm_scan_number (&p, end);
10217 height = pbm_scan_number (&p, end);
10219 if (type != PBM_MONO)
10221 max_color_idx = pbm_scan_number (&p, end);
10222 if (raw_p && max_color_idx > 255)
10223 max_color_idx = 255;
10226 if (width < 0
10227 || height < 0
10228 || (type != PBM_MONO && max_color_idx < 0))
10229 goto error;
10231 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
10232 goto error;
10234 #if 0 /* TODO: color tables. */
10235 /* Initialize the color hash table. */
10236 init_color_table ();
10237 #endif
10239 if (type == PBM_MONO)
10241 int c = 0, g;
10242 struct image_keyword fmt[PBM_LAST];
10243 unsigned long fg = FRAME_FOREGROUND_PIXEL (f);
10244 unsigned long bg = FRAME_BACKGROUND_PIXEL (f);
10246 /* Parse the image specification. */
10247 bcopy (pbm_format, fmt, sizeof fmt);
10248 parse_image_spec (img->spec, fmt, PBM_LAST, Qpbm);
10250 /* Get foreground and background colors, maybe allocate colors. */
10251 if (fmt[PBM_FOREGROUND].count
10252 && STRINGP (fmt[PBM_FOREGROUND].value))
10253 fg = x_alloc_image_color (f, img, fmt[PBM_FOREGROUND].value, fg);
10254 if (fmt[PBM_BACKGROUND].count
10255 && STRINGP (fmt[PBM_BACKGROUND].value))
10257 bg = x_alloc_image_color (f, img, fmt[PBM_BACKGROUND].value, bg);
10258 img->background = bg;
10259 img->background_valid = 1;
10262 for (y = 0; y < height; ++y)
10263 for (x = 0; x < width; ++x)
10265 if (raw_p)
10267 if ((x & 7) == 0)
10268 c = *p++;
10269 g = c & 0x80;
10270 c <<= 1;
10272 else
10273 g = pbm_scan_number (&p, end);
10275 XPutPixel (ximg, x, y, g ? fg : bg);
10278 else
10280 for (y = 0; y < height; ++y)
10281 for (x = 0; x < width; ++x)
10283 int r, g, b;
10285 if (type == PBM_GRAY)
10286 r = g = b = raw_p ? *p++ : pbm_scan_number (&p, end);
10287 else if (raw_p)
10289 r = *p++;
10290 g = *p++;
10291 b = *p++;
10293 else
10295 r = pbm_scan_number (&p, end);
10296 g = pbm_scan_number (&p, end);
10297 b = pbm_scan_number (&p, end);
10300 if (r < 0 || g < 0 || b < 0)
10302 x_destroy_x_image (ximg);
10303 image_error ("Invalid pixel value in image `%s'",
10304 img->spec, Qnil);
10305 goto error;
10308 /* RGB values are now in the range 0..max_color_idx.
10309 Scale this to the range 0..0xff supported by W32. */
10310 r = (int) ((double) r * 255 / max_color_idx);
10311 g = (int) ((double) g * 255 / max_color_idx);
10312 b = (int) ((double) b * 255 / max_color_idx);
10313 XPutPixel (ximg, x, y,
10314 #if 0 /* TODO: color tables. */
10315 lookup_rgb_color (f, r, g, b));
10316 #else
10317 PALETTERGB (r, g, b));
10318 #endif
10322 #if 0 /* TODO: color tables. */
10323 /* Store in IMG->colors the colors allocated for the image, and
10324 free the color table. */
10325 img->colors = colors_in_color_table (&img->ncolors);
10326 free_color_table ();
10327 #endif
10328 /* Maybe fill in the background field while we have ximg handy. */
10329 if (NILP (image_spec_value (img->spec, QCbackground, NULL)))
10330 IMAGE_BACKGROUND (img, f, ximg);
10332 /* Put the image into a pixmap. */
10333 x_put_x_image (f, ximg, img->pixmap, width, height);
10334 x_destroy_x_image (ximg);
10336 img->width = width;
10337 img->height = height;
10339 UNGCPRO;
10340 xfree (contents);
10341 return 1;
10345 /***********************************************************************
10347 ***********************************************************************/
10349 #if HAVE_PNG
10351 #include <png.h>
10353 /* Function prototypes. */
10355 static int png_image_p P_ ((Lisp_Object object));
10356 static int png_load P_ ((struct frame *f, struct image *img));
10358 /* The symbol `png' identifying images of this type. */
10360 Lisp_Object Qpng;
10362 /* Indices of image specification fields in png_format, below. */
10364 enum png_keyword_index
10366 PNG_TYPE,
10367 PNG_DATA,
10368 PNG_FILE,
10369 PNG_ASCENT,
10370 PNG_MARGIN,
10371 PNG_RELIEF,
10372 PNG_ALGORITHM,
10373 PNG_HEURISTIC_MASK,
10374 PNG_MASK,
10375 PNG_BACKGROUND,
10376 PNG_LAST
10379 /* Vector of image_keyword structures describing the format
10380 of valid user-defined image specifications. */
10382 static struct image_keyword png_format[PNG_LAST] =
10384 {":type", IMAGE_SYMBOL_VALUE, 1},
10385 {":data", IMAGE_STRING_VALUE, 0},
10386 {":file", IMAGE_STRING_VALUE, 0},
10387 {":ascent", IMAGE_ASCENT_VALUE, 0},
10388 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
10389 {":relief", IMAGE_INTEGER_VALUE, 0},
10390 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10391 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10392 {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10393 {":background", IMAGE_STRING_OR_NIL_VALUE, 0}
10396 /* Structure describing the image type `png'. */
10398 static struct image_type png_type =
10400 &Qpng,
10401 png_image_p,
10402 png_load,
10403 x_clear_image,
10404 NULL
10407 /* PNG library details. */
10409 DEF_IMGLIB_FN (png_get_io_ptr);
10410 DEF_IMGLIB_FN (png_check_sig);
10411 DEF_IMGLIB_FN (png_create_read_struct);
10412 DEF_IMGLIB_FN (png_create_info_struct);
10413 DEF_IMGLIB_FN (png_destroy_read_struct);
10414 DEF_IMGLIB_FN (png_set_read_fn);
10415 DEF_IMGLIB_FN (png_init_io);
10416 DEF_IMGLIB_FN (png_set_sig_bytes);
10417 DEF_IMGLIB_FN (png_read_info);
10418 DEF_IMGLIB_FN (png_get_IHDR);
10419 DEF_IMGLIB_FN (png_get_valid);
10420 DEF_IMGLIB_FN (png_set_strip_16);
10421 DEF_IMGLIB_FN (png_set_expand);
10422 DEF_IMGLIB_FN (png_set_gray_to_rgb);
10423 DEF_IMGLIB_FN (png_set_background);
10424 DEF_IMGLIB_FN (png_get_bKGD);
10425 DEF_IMGLIB_FN (png_read_update_info);
10426 DEF_IMGLIB_FN (png_get_channels);
10427 DEF_IMGLIB_FN (png_get_rowbytes);
10428 DEF_IMGLIB_FN (png_read_image);
10429 DEF_IMGLIB_FN (png_read_end);
10430 DEF_IMGLIB_FN (png_error);
10432 static int
10433 init_png_functions (library)
10434 HMODULE library;
10436 LOAD_IMGLIB_FN (library, png_get_io_ptr);
10437 LOAD_IMGLIB_FN (library, png_check_sig);
10438 LOAD_IMGLIB_FN (library, png_create_read_struct);
10439 LOAD_IMGLIB_FN (library, png_create_info_struct);
10440 LOAD_IMGLIB_FN (library, png_destroy_read_struct);
10441 LOAD_IMGLIB_FN (library, png_set_read_fn);
10442 LOAD_IMGLIB_FN (library, png_init_io);
10443 LOAD_IMGLIB_FN (library, png_set_sig_bytes);
10444 LOAD_IMGLIB_FN (library, png_read_info);
10445 LOAD_IMGLIB_FN (library, png_get_IHDR);
10446 LOAD_IMGLIB_FN (library, png_get_valid);
10447 LOAD_IMGLIB_FN (library, png_set_strip_16);
10448 LOAD_IMGLIB_FN (library, png_set_expand);
10449 LOAD_IMGLIB_FN (library, png_set_gray_to_rgb);
10450 LOAD_IMGLIB_FN (library, png_set_background);
10451 LOAD_IMGLIB_FN (library, png_get_bKGD);
10452 LOAD_IMGLIB_FN (library, png_read_update_info);
10453 LOAD_IMGLIB_FN (library, png_get_channels);
10454 LOAD_IMGLIB_FN (library, png_get_rowbytes);
10455 LOAD_IMGLIB_FN (library, png_read_image);
10456 LOAD_IMGLIB_FN (library, png_read_end);
10457 LOAD_IMGLIB_FN (library, png_error);
10458 return 1;
10461 /* Return non-zero if OBJECT is a valid PNG image specification. */
10463 static int
10464 png_image_p (object)
10465 Lisp_Object object;
10467 struct image_keyword fmt[PNG_LAST];
10468 bcopy (png_format, fmt, sizeof fmt);
10470 if (!parse_image_spec (object, fmt, PNG_LAST, Qpng))
10471 return 0;
10473 /* Must specify either the :data or :file keyword. */
10474 return fmt[PNG_FILE].count + fmt[PNG_DATA].count == 1;
10478 /* Error and warning handlers installed when the PNG library
10479 is initialized. */
10481 static void
10482 my_png_error (png_ptr, msg)
10483 png_struct *png_ptr;
10484 char *msg;
10486 xassert (png_ptr != NULL);
10487 image_error ("PNG error: %s", build_string (msg), Qnil);
10488 longjmp (png_ptr->jmpbuf, 1);
10492 static void
10493 my_png_warning (png_ptr, msg)
10494 png_struct *png_ptr;
10495 char *msg;
10497 xassert (png_ptr != NULL);
10498 image_error ("PNG warning: %s", build_string (msg), Qnil);
10501 /* Memory source for PNG decoding. */
10503 struct png_memory_storage
10505 unsigned char *bytes; /* The data */
10506 size_t len; /* How big is it? */
10507 int index; /* Where are we? */
10511 /* Function set as reader function when reading PNG image from memory.
10512 PNG_PTR is a pointer to the PNG control structure. Copy LENGTH
10513 bytes from the input to DATA. */
10515 static void
10516 png_read_from_memory (png_ptr, data, length)
10517 png_structp png_ptr;
10518 png_bytep data;
10519 png_size_t length;
10521 struct png_memory_storage *tbr
10522 = (struct png_memory_storage *) fn_png_get_io_ptr (png_ptr);
10524 if (length > tbr->len - tbr->index)
10525 fn_png_error (png_ptr, "Read error");
10527 bcopy (tbr->bytes + tbr->index, data, length);
10528 tbr->index = tbr->index + length;
10531 /* Load PNG image IMG for use on frame F. Value is non-zero if
10532 successful. */
10534 static int
10535 png_load (f, img)
10536 struct frame *f;
10537 struct image *img;
10539 Lisp_Object file, specified_file;
10540 Lisp_Object specified_data;
10541 int x, y, i;
10542 XImage *ximg, *mask_img = NULL;
10543 struct gcpro gcpro1;
10544 png_struct *png_ptr = NULL;
10545 png_info *info_ptr = NULL, *end_info = NULL;
10546 FILE *volatile fp = NULL;
10547 png_byte sig[8];
10548 png_byte * volatile pixels = NULL;
10549 png_byte ** volatile rows = NULL;
10550 png_uint_32 width, height;
10551 int bit_depth, color_type, interlace_type;
10552 png_byte channels;
10553 png_uint_32 row_bytes;
10554 int transparent_p;
10555 double screen_gamma, image_gamma;
10556 int intent;
10557 struct png_memory_storage tbr; /* Data to be read */
10559 /* Find out what file to load. */
10560 specified_file = image_spec_value (img->spec, QCfile, NULL);
10561 specified_data = image_spec_value (img->spec, QCdata, NULL);
10562 file = Qnil;
10563 GCPRO1 (file);
10565 if (NILP (specified_data))
10567 file = x_find_image_file (specified_file);
10568 if (!STRINGP (file))
10570 image_error ("Cannot find image file `%s'", specified_file, Qnil);
10571 UNGCPRO;
10572 return 0;
10575 /* Open the image file. */
10576 fp = fopen (SDATA (file), "rb");
10577 if (!fp)
10579 image_error ("Cannot open image file `%s'", file, Qnil);
10580 UNGCPRO;
10581 fclose (fp);
10582 return 0;
10585 /* Check PNG signature. */
10586 if (fread (sig, 1, sizeof sig, fp) != sizeof sig
10587 || !fn_png_check_sig (sig, sizeof sig))
10589 image_error ("Not a PNG file: `%s'", file, Qnil);
10590 UNGCPRO;
10591 fclose (fp);
10592 return 0;
10595 else
10597 /* Read from memory. */
10598 tbr.bytes = SDATA (specified_data);
10599 tbr.len = SBYTES (specified_data);
10600 tbr.index = 0;
10602 /* Check PNG signature. */
10603 if (tbr.len < sizeof sig
10604 || !fn_png_check_sig (tbr.bytes, sizeof sig))
10606 image_error ("Not a PNG image: `%s'", img->spec, Qnil);
10607 UNGCPRO;
10608 return 0;
10611 /* Need to skip past the signature. */
10612 tbr.bytes += sizeof (sig);
10615 /* Initialize read and info structs for PNG lib. */
10616 png_ptr = fn_png_create_read_struct (PNG_LIBPNG_VER_STRING, NULL,
10617 my_png_error, my_png_warning);
10618 if (!png_ptr)
10620 if (fp) fclose (fp);
10621 UNGCPRO;
10622 return 0;
10625 info_ptr = fn_png_create_info_struct (png_ptr);
10626 if (!info_ptr)
10628 fn_png_destroy_read_struct (&png_ptr, NULL, NULL);
10629 if (fp) fclose (fp);
10630 UNGCPRO;
10631 return 0;
10634 end_info = fn_png_create_info_struct (png_ptr);
10635 if (!end_info)
10637 fn_png_destroy_read_struct (&png_ptr, &info_ptr, NULL);
10638 if (fp) fclose (fp);
10639 UNGCPRO;
10640 return 0;
10643 /* Set error jump-back. We come back here when the PNG library
10644 detects an error. */
10645 if (setjmp (png_ptr->jmpbuf))
10647 error:
10648 if (png_ptr)
10649 fn_png_destroy_read_struct (&png_ptr, &info_ptr, &end_info);
10650 xfree (pixels);
10651 xfree (rows);
10652 if (fp) fclose (fp);
10653 UNGCPRO;
10654 return 0;
10657 /* Read image info. */
10658 if (!NILP (specified_data))
10659 fn_png_set_read_fn (png_ptr, (void *) &tbr, png_read_from_memory);
10660 else
10661 fn_png_init_io (png_ptr, fp);
10663 fn_png_set_sig_bytes (png_ptr, sizeof sig);
10664 fn_png_read_info (png_ptr, info_ptr);
10665 fn_png_get_IHDR (png_ptr, info_ptr, &width, &height, &bit_depth, &color_type,
10666 &interlace_type, NULL, NULL);
10668 /* If image contains simply transparency data, we prefer to
10669 construct a clipping mask. */
10670 if (fn_png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS))
10671 transparent_p = 1;
10672 else
10673 transparent_p = 0;
10675 /* This function is easier to write if we only have to handle
10676 one data format: RGB or RGBA with 8 bits per channel. Let's
10677 transform other formats into that format. */
10679 /* Strip more than 8 bits per channel. */
10680 if (bit_depth == 16)
10681 fn_png_set_strip_16 (png_ptr);
10683 /* Expand data to 24 bit RGB, or 8 bit grayscale, with alpha channel
10684 if available. */
10685 fn_png_set_expand (png_ptr);
10687 /* Convert grayscale images to RGB. */
10688 if (color_type == PNG_COLOR_TYPE_GRAY
10689 || color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
10690 fn_png_set_gray_to_rgb (png_ptr);
10692 screen_gamma = (f->gamma ? 1 / f->gamma / 0.45455 : 2.2);
10694 #if 0 /* Avoid double gamma correction for PNG images. */
10695 /* Tell the PNG lib to handle gamma correction for us. */
10696 #if defined(PNG_READ_sRGB_SUPPORTED) || defined(PNG_WRITE_sRGB_SUPPORTED)
10697 if (png_get_sRGB (png_ptr, info_ptr, &intent))
10698 /* The libpng documentation says this is right in this case. */
10699 png_set_gamma (png_ptr, screen_gamma, 0.45455);
10700 else
10701 #endif
10702 if (png_get_gAMA (png_ptr, info_ptr, &image_gamma))
10703 /* Image contains gamma information. */
10704 png_set_gamma (png_ptr, screen_gamma, image_gamma);
10705 else
10706 /* Use the standard default for the image gamma. */
10707 png_set_gamma (png_ptr, screen_gamma, 0.45455);
10708 #endif /* if 0 */
10710 /* Handle alpha channel by combining the image with a background
10711 color. Do this only if a real alpha channel is supplied. For
10712 simple transparency, we prefer a clipping mask. */
10713 if (!transparent_p)
10715 png_color_16 *image_bg;
10716 Lisp_Object specified_bg
10717 = image_spec_value (img->spec, QCbackground, NULL);
10719 if (STRINGP (specified_bg))
10720 /* The user specified `:background', use that. */
10722 COLORREF color;
10723 if (w32_defined_color (f, SDATA (specified_bg), &color, 0))
10725 png_color_16 user_bg;
10727 bzero (&user_bg, sizeof user_bg);
10728 user_bg.red = 256 * GetRValue (color);
10729 user_bg.green = 256 * GetGValue (color);
10730 user_bg.blue = 256 * GetBValue (color);
10732 fn_png_set_background (png_ptr, &user_bg,
10733 PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0);
10736 else if (fn_png_get_bKGD (png_ptr, info_ptr, &image_bg))
10737 /* Image contains a background color with which to
10738 combine the image. */
10739 fn_png_set_background (png_ptr, image_bg,
10740 PNG_BACKGROUND_GAMMA_FILE, 1, 1.0);
10741 else
10743 /* Image does not contain a background color with which
10744 to combine the image data via an alpha channel. Use
10745 the frame's background instead. */
10746 COLORREF color;
10747 png_color_16 frame_background;
10748 color = FRAME_BACKGROUND_PIXEL (f);
10749 #if 0 /* TODO : Colormap support. */
10750 Colormap cmap;
10752 cmap = FRAME_X_COLORMAP (f);
10753 x_query_color (f, &color);
10754 #endif
10756 bzero (&frame_background, sizeof frame_background);
10757 frame_background.red = 256 * GetRValue (color);
10758 frame_background.green = 256 * GetGValue (color);
10759 frame_background.blue = 256 * GetBValue (color);
10761 fn_png_set_background (png_ptr, &frame_background,
10762 PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0);
10766 /* Update info structure. */
10767 fn_png_read_update_info (png_ptr, info_ptr);
10769 /* Get number of channels. Valid values are 1 for grayscale images
10770 and images with a palette, 2 for grayscale images with transparency
10771 information (alpha channel), 3 for RGB images, and 4 for RGB
10772 images with alpha channel, i.e. RGBA. If conversions above were
10773 sufficient we should only have 3 or 4 channels here. */
10774 channels = fn_png_get_channels (png_ptr, info_ptr);
10775 xassert (channels == 3 || channels == 4);
10777 /* Number of bytes needed for one row of the image. */
10778 row_bytes = fn_png_get_rowbytes (png_ptr, info_ptr);
10780 /* Allocate memory for the image. */
10781 pixels = (png_byte *) xmalloc (row_bytes * height * sizeof *pixels);
10782 rows = (png_byte **) xmalloc (height * sizeof *rows);
10783 for (i = 0; i < height; ++i)
10784 rows[i] = pixels + i * row_bytes;
10786 /* Read the entire image. */
10787 fn_png_read_image (png_ptr, rows);
10788 fn_png_read_end (png_ptr, info_ptr);
10789 if (fp)
10791 fclose (fp);
10792 fp = NULL;
10795 /* Create the X image and pixmap. */
10796 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg,
10797 &img->pixmap))
10798 goto error;
10800 /* Create an image and pixmap serving as mask if the PNG image
10801 contains an alpha channel. */
10802 if (channels == 4
10803 && !transparent_p
10804 && !x_create_x_image_and_pixmap (f, width, height, 1,
10805 &mask_img, &img->mask))
10807 x_destroy_x_image (ximg);
10808 DeleteObject (img->pixmap);
10809 img->pixmap = 0;
10810 goto error;
10812 /* Fill the X image and mask from PNG data. */
10813 #if 0 /* TODO: Color tables. */
10814 init_color_table ();
10815 #endif
10817 for (y = 0; y < height; ++y)
10819 png_byte *p = rows[y];
10821 for (x = 0; x < width; ++x)
10823 unsigned r, g, b;
10825 r = *p++;
10826 g = *p++;
10827 b = *p++;
10828 #if 0 /* TODO: Color tables. */
10829 XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b));
10830 #else
10831 XPutPixel (ximg, x, y, PALETTERGB (r, g, b));
10832 #endif
10833 /* An alpha channel, aka mask channel, associates variable
10834 transparency with an image. Where other image formats
10835 support binary transparency---fully transparent or fully
10836 opaque---PNG allows up to 254 levels of partial transparency.
10837 The PNG library implements partial transparency by combining
10838 the image with a specified background color.
10840 I'm not sure how to handle this here nicely: because the
10841 background on which the image is displayed may change, for
10842 real alpha channel support, it would be necessary to create
10843 a new image for each possible background.
10845 What I'm doing now is that a mask is created if we have
10846 boolean transparency information. Otherwise I'm using
10847 the frame's background color to combine the image with. */
10849 if (channels == 4)
10851 if (mask_img)
10852 XPutPixel (mask_img, x, y, *p > 0);
10853 ++p;
10858 if (NILP (image_spec_value (img->spec, QCbackground, NULL)))
10859 /* Set IMG's background color from the PNG image, unless the user
10860 overrode it. */
10862 png_color_16 *bg;
10863 if (fn_png_get_bKGD (png_ptr, info_ptr, &bg))
10865 #if 0 /* TODO: Color tables. */
10866 img->background = lookup_rgb_color (f, bg->red, bg->green, bg->blue);
10867 #else
10868 img->background = PALETTERGB (bg->red / 256, bg->green / 256,
10869 bg->blue / 256);
10870 #endif
10871 img->background_valid = 1;
10875 #if 0 /* TODO: Color tables. */
10876 /* Remember colors allocated for this image. */
10877 img->colors = colors_in_color_table (&img->ncolors);
10878 free_color_table ();
10879 #endif
10881 /* Clean up. */
10882 fn_png_destroy_read_struct (&png_ptr, &info_ptr, &end_info);
10883 xfree (rows);
10884 xfree (pixels);
10886 img->width = width;
10887 img->height = height;
10889 /* Maybe fill in the background field while we have ximg handy. */
10890 IMAGE_BACKGROUND (img, f, ximg);
10892 /* Put the image into the pixmap, then free the X image and its buffer. */
10893 x_put_x_image (f, ximg, img->pixmap, width, height);
10894 x_destroy_x_image (ximg);
10896 /* Same for the mask. */
10897 if (mask_img)
10899 /* Fill in the background_transparent field while we have the mask
10900 handy. */
10901 image_background_transparent (img, f, mask_img);
10903 x_put_x_image (f, mask_img, img->mask, img->width, img->height);
10904 x_destroy_x_image (mask_img);
10907 UNGCPRO;
10908 return 1;
10911 #endif /* HAVE_PNG != 0 */
10915 /***********************************************************************
10916 JPEG
10917 ***********************************************************************/
10919 #if HAVE_JPEG
10921 /* Work around a warning about HAVE_STDLIB_H being redefined in
10922 jconfig.h. */
10923 #ifdef HAVE_STDLIB_H
10924 #define HAVE_STDLIB_H_1
10925 #undef HAVE_STDLIB_H
10926 #endif /* HAVE_STLIB_H */
10928 #include <jpeglib.h>
10929 #include <jerror.h>
10930 #include <setjmp.h>
10932 #ifdef HAVE_STLIB_H_1
10933 #define HAVE_STDLIB_H 1
10934 #endif
10936 static int jpeg_image_p P_ ((Lisp_Object object));
10937 static int jpeg_load P_ ((struct frame *f, struct image *img));
10939 /* The symbol `jpeg' identifying images of this type. */
10941 Lisp_Object Qjpeg;
10943 /* Indices of image specification fields in gs_format, below. */
10945 enum jpeg_keyword_index
10947 JPEG_TYPE,
10948 JPEG_DATA,
10949 JPEG_FILE,
10950 JPEG_ASCENT,
10951 JPEG_MARGIN,
10952 JPEG_RELIEF,
10953 JPEG_ALGORITHM,
10954 JPEG_HEURISTIC_MASK,
10955 JPEG_MASK,
10956 JPEG_BACKGROUND,
10957 JPEG_LAST
10960 /* Vector of image_keyword structures describing the format
10961 of valid user-defined image specifications. */
10963 static struct image_keyword jpeg_format[JPEG_LAST] =
10965 {":type", IMAGE_SYMBOL_VALUE, 1},
10966 {":data", IMAGE_STRING_VALUE, 0},
10967 {":file", IMAGE_STRING_VALUE, 0},
10968 {":ascent", IMAGE_ASCENT_VALUE, 0},
10969 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
10970 {":relief", IMAGE_INTEGER_VALUE, 0},
10971 {":conversions", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10972 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10973 {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
10974 {":background", IMAGE_STRING_OR_NIL_VALUE, 0}
10977 /* Structure describing the image type `jpeg'. */
10979 static struct image_type jpeg_type =
10981 &Qjpeg,
10982 jpeg_image_p,
10983 jpeg_load,
10984 x_clear_image,
10985 NULL
10989 /* JPEG library details. */
10990 DEF_IMGLIB_FN (jpeg_CreateDecompress);
10991 DEF_IMGLIB_FN (jpeg_start_decompress);
10992 DEF_IMGLIB_FN (jpeg_finish_decompress);
10993 DEF_IMGLIB_FN (jpeg_destroy_decompress);
10994 DEF_IMGLIB_FN (jpeg_read_header);
10995 DEF_IMGLIB_FN (jpeg_read_scanlines);
10996 DEF_IMGLIB_FN (jpeg_stdio_src);
10997 DEF_IMGLIB_FN (jpeg_std_error);
10998 DEF_IMGLIB_FN (jpeg_resync_to_restart);
11000 static int
11001 init_jpeg_functions (library)
11002 HMODULE library;
11004 LOAD_IMGLIB_FN (library, jpeg_finish_decompress);
11005 LOAD_IMGLIB_FN (library, jpeg_read_scanlines);
11006 LOAD_IMGLIB_FN (library, jpeg_start_decompress);
11007 LOAD_IMGLIB_FN (library, jpeg_read_header);
11008 LOAD_IMGLIB_FN (library, jpeg_stdio_src);
11009 LOAD_IMGLIB_FN (library, jpeg_CreateDecompress);
11010 LOAD_IMGLIB_FN (library, jpeg_destroy_decompress);
11011 LOAD_IMGLIB_FN (library, jpeg_std_error);
11012 LOAD_IMGLIB_FN (library, jpeg_resync_to_restart);
11013 return 1;
11016 /* Wrapper since we can't directly assign the function pointer
11017 to another function pointer that was declared more completely easily. */
11018 static boolean
11019 jpeg_resync_to_restart_wrapper(cinfo, desired)
11020 j_decompress_ptr cinfo;
11021 int desired;
11023 return fn_jpeg_resync_to_restart (cinfo, desired);
11027 /* Return non-zero if OBJECT is a valid JPEG image specification. */
11029 static int
11030 jpeg_image_p (object)
11031 Lisp_Object object;
11033 struct image_keyword fmt[JPEG_LAST];
11035 bcopy (jpeg_format, fmt, sizeof fmt);
11037 if (!parse_image_spec (object, fmt, JPEG_LAST, Qjpeg))
11038 return 0;
11040 /* Must specify either the :data or :file keyword. */
11041 return fmt[JPEG_FILE].count + fmt[JPEG_DATA].count == 1;
11045 struct my_jpeg_error_mgr
11047 struct jpeg_error_mgr pub;
11048 jmp_buf setjmp_buffer;
11052 static void
11053 my_error_exit (cinfo)
11054 j_common_ptr cinfo;
11056 struct my_jpeg_error_mgr *mgr = (struct my_jpeg_error_mgr *) cinfo->err;
11057 longjmp (mgr->setjmp_buffer, 1);
11061 /* Init source method for JPEG data source manager. Called by
11062 jpeg_read_header() before any data is actually read. See
11063 libjpeg.doc from the JPEG lib distribution. */
11065 static void
11066 our_init_source (cinfo)
11067 j_decompress_ptr cinfo;
11072 /* Fill input buffer method for JPEG data source manager. Called
11073 whenever more data is needed. We read the whole image in one step,
11074 so this only adds a fake end of input marker at the end. */
11076 static boolean
11077 our_fill_input_buffer (cinfo)
11078 j_decompress_ptr cinfo;
11080 /* Insert a fake EOI marker. */
11081 struct jpeg_source_mgr *src = cinfo->src;
11082 static JOCTET buffer[2];
11084 buffer[0] = (JOCTET) 0xFF;
11085 buffer[1] = (JOCTET) JPEG_EOI;
11087 src->next_input_byte = buffer;
11088 src->bytes_in_buffer = 2;
11089 return TRUE;
11093 /* Method to skip over NUM_BYTES bytes in the image data. CINFO->src
11094 is the JPEG data source manager. */
11096 static void
11097 our_skip_input_data (cinfo, num_bytes)
11098 j_decompress_ptr cinfo;
11099 long num_bytes;
11101 struct jpeg_source_mgr *src = (struct jpeg_source_mgr *) cinfo->src;
11103 if (src)
11105 if (num_bytes > src->bytes_in_buffer)
11106 ERREXIT (cinfo, JERR_INPUT_EOF);
11108 src->bytes_in_buffer -= num_bytes;
11109 src->next_input_byte += num_bytes;
11114 /* Method to terminate data source. Called by
11115 jpeg_finish_decompress() after all data has been processed. */
11117 static void
11118 our_term_source (cinfo)
11119 j_decompress_ptr cinfo;
11124 /* Set up the JPEG lib for reading an image from DATA which contains
11125 LEN bytes. CINFO is the decompression info structure created for
11126 reading the image. */
11128 static void
11129 jpeg_memory_src (cinfo, data, len)
11130 j_decompress_ptr cinfo;
11131 JOCTET *data;
11132 unsigned int len;
11134 struct jpeg_source_mgr *src;
11136 if (cinfo->src == NULL)
11138 /* First time for this JPEG object? */
11139 cinfo->src = (struct jpeg_source_mgr *)
11140 (*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT,
11141 sizeof (struct jpeg_source_mgr));
11142 src = (struct jpeg_source_mgr *) cinfo->src;
11143 src->next_input_byte = data;
11146 src = (struct jpeg_source_mgr *) cinfo->src;
11147 src->init_source = our_init_source;
11148 src->fill_input_buffer = our_fill_input_buffer;
11149 src->skip_input_data = our_skip_input_data;
11150 src->resync_to_restart = jpeg_resync_to_restart_wrapper; /* Use default method. */
11151 src->term_source = our_term_source;
11152 src->bytes_in_buffer = len;
11153 src->next_input_byte = data;
11157 /* Load image IMG for use on frame F. Patterned after example.c
11158 from the JPEG lib. */
11160 static int
11161 jpeg_load (f, img)
11162 struct frame *f;
11163 struct image *img;
11165 struct jpeg_decompress_struct cinfo;
11166 struct my_jpeg_error_mgr mgr;
11167 Lisp_Object file, specified_file;
11168 Lisp_Object specified_data;
11169 FILE * volatile fp = NULL;
11170 JSAMPARRAY buffer;
11171 int row_stride, x, y;
11172 XImage *ximg = NULL;
11173 int rc;
11174 unsigned long *colors;
11175 int width, height;
11176 struct gcpro gcpro1;
11178 /* Open the JPEG file. */
11179 specified_file = image_spec_value (img->spec, QCfile, NULL);
11180 specified_data = image_spec_value (img->spec, QCdata, NULL);
11181 file = Qnil;
11182 GCPRO1 (file);
11184 if (NILP (specified_data))
11186 file = x_find_image_file (specified_file);
11187 if (!STRINGP (file))
11189 image_error ("Cannot find image file `%s'", specified_file, Qnil);
11190 UNGCPRO;
11191 return 0;
11194 fp = fopen (SDATA (file), "rb");
11195 if (fp == NULL)
11197 image_error ("Cannot open `%s'", file, Qnil);
11198 UNGCPRO;
11199 return 0;
11203 /* Customize libjpeg's error handling to call my_error_exit when an
11204 error is detected. This function will perform a longjmp. */
11205 cinfo.err = fn_jpeg_std_error (&mgr.pub);
11206 mgr.pub.error_exit = my_error_exit;
11208 if ((rc = setjmp (mgr.setjmp_buffer)) != 0)
11210 if (rc == 1)
11212 /* Called from my_error_exit. Display a JPEG error. */
11213 char buffer[JMSG_LENGTH_MAX];
11214 cinfo.err->format_message ((j_common_ptr) &cinfo, buffer);
11215 image_error ("Error reading JPEG image `%s': %s", img->spec,
11216 build_string (buffer));
11219 /* Close the input file and destroy the JPEG object. */
11220 if (fp)
11221 fclose ((FILE *) fp);
11222 fn_jpeg_destroy_decompress (&cinfo);
11224 /* If we already have an XImage, free that. */
11225 x_destroy_x_image (ximg);
11227 /* Free pixmap and colors. */
11228 x_clear_image (f, img);
11230 UNGCPRO;
11231 return 0;
11234 /* Create the JPEG decompression object. Let it read from fp.
11235 Read the JPEG image header. */
11236 fn_jpeg_CreateDecompress (&cinfo, JPEG_LIB_VERSION, sizeof (cinfo));
11238 if (NILP (specified_data))
11239 fn_jpeg_stdio_src (&cinfo, (FILE *) fp);
11240 else
11241 jpeg_memory_src (&cinfo, SDATA (specified_data),
11242 SBYTES (specified_data));
11244 fn_jpeg_read_header (&cinfo, TRUE);
11246 /* Customize decompression so that color quantization will be used.
11247 Start decompression. */
11248 cinfo.quantize_colors = TRUE;
11249 fn_jpeg_start_decompress (&cinfo);
11250 width = img->width = cinfo.output_width;
11251 height = img->height = cinfo.output_height;
11253 /* Create X image and pixmap. */
11254 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
11255 longjmp (mgr.setjmp_buffer, 2);
11257 /* Allocate colors. When color quantization is used,
11258 cinfo.actual_number_of_colors has been set with the number of
11259 colors generated, and cinfo.colormap is a two-dimensional array
11260 of color indices in the range 0..cinfo.actual_number_of_colors.
11261 No more than 255 colors will be generated. */
11263 int i, ir, ig, ib;
11265 if (cinfo.out_color_components > 2)
11266 ir = 0, ig = 1, ib = 2;
11267 else if (cinfo.out_color_components > 1)
11268 ir = 0, ig = 1, ib = 0;
11269 else
11270 ir = 0, ig = 0, ib = 0;
11272 #if 0 /* TODO: Color tables. */
11273 /* Use the color table mechanism because it handles colors that
11274 cannot be allocated nicely. Such colors will be replaced with
11275 a default color, and we don't have to care about which colors
11276 can be freed safely, and which can't. */
11277 init_color_table ();
11278 #endif
11279 colors = (unsigned long *) alloca (cinfo.actual_number_of_colors
11280 * sizeof *colors);
11282 for (i = 0; i < cinfo.actual_number_of_colors; ++i)
11284 int r = cinfo.colormap[ir][i];
11285 int g = cinfo.colormap[ig][i];
11286 int b = cinfo.colormap[ib][i];
11287 #if 0 /* TODO: Color tables. */
11288 colors[i] = lookup_rgb_color (f, r, g, b);
11289 #else
11290 colors[i] = PALETTERGB (r, g, b);
11291 #endif
11294 #if 0 /* TODO: Color tables. */
11295 /* Remember those colors actually allocated. */
11296 img->colors = colors_in_color_table (&img->ncolors);
11297 free_color_table ();
11298 #endif
11301 /* Read pixels. */
11302 row_stride = width * cinfo.output_components;
11303 buffer = cinfo.mem->alloc_sarray ((j_common_ptr) &cinfo, JPOOL_IMAGE,
11304 row_stride, 1);
11305 for (y = 0; y < height; ++y)
11307 fn_jpeg_read_scanlines (&cinfo, buffer, 1);
11308 for (x = 0; x < cinfo.output_width; ++x)
11309 XPutPixel (ximg, x, y, colors[buffer[0][x]]);
11312 /* Clean up. */
11313 fn_jpeg_finish_decompress (&cinfo);
11314 fn_jpeg_destroy_decompress (&cinfo);
11315 if (fp)
11316 fclose ((FILE *) fp);
11318 /* Maybe fill in the background field while we have ximg handy. */
11319 if (NILP (image_spec_value (img->spec, QCbackground, NULL)))
11320 IMAGE_BACKGROUND (img, f, ximg);
11322 /* Put the image into the pixmap. */
11323 x_put_x_image (f, ximg, img->pixmap, width, height);
11324 x_destroy_x_image (ximg);
11325 UNGCPRO;
11326 return 1;
11329 #endif /* HAVE_JPEG */
11333 /***********************************************************************
11334 TIFF
11335 ***********************************************************************/
11337 #if HAVE_TIFF
11339 #include <tiffio.h>
11341 static int tiff_image_p P_ ((Lisp_Object object));
11342 static int tiff_load P_ ((struct frame *f, struct image *img));
11344 /* The symbol `tiff' identifying images of this type. */
11346 Lisp_Object Qtiff;
11348 /* Indices of image specification fields in tiff_format, below. */
11350 enum tiff_keyword_index
11352 TIFF_TYPE,
11353 TIFF_DATA,
11354 TIFF_FILE,
11355 TIFF_ASCENT,
11356 TIFF_MARGIN,
11357 TIFF_RELIEF,
11358 TIFF_ALGORITHM,
11359 TIFF_HEURISTIC_MASK,
11360 TIFF_MASK,
11361 TIFF_BACKGROUND,
11362 TIFF_LAST
11365 /* Vector of image_keyword structures describing the format
11366 of valid user-defined image specifications. */
11368 static struct image_keyword tiff_format[TIFF_LAST] =
11370 {":type", IMAGE_SYMBOL_VALUE, 1},
11371 {":data", IMAGE_STRING_VALUE, 0},
11372 {":file", IMAGE_STRING_VALUE, 0},
11373 {":ascent", IMAGE_ASCENT_VALUE, 0},
11374 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
11375 {":relief", IMAGE_INTEGER_VALUE, 0},
11376 {":conversions", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
11377 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
11378 {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
11379 {":background", IMAGE_STRING_OR_NIL_VALUE, 0}
11382 /* Structure describing the image type `tiff'. */
11384 static struct image_type tiff_type =
11386 &Qtiff,
11387 tiff_image_p,
11388 tiff_load,
11389 x_clear_image,
11390 NULL
11393 /* TIFF library details. */
11394 DEF_IMGLIB_FN (TIFFSetErrorHandler);
11395 DEF_IMGLIB_FN (TIFFSetWarningHandler);
11396 DEF_IMGLIB_FN (TIFFOpen);
11397 DEF_IMGLIB_FN (TIFFClientOpen);
11398 DEF_IMGLIB_FN (TIFFGetField);
11399 DEF_IMGLIB_FN (TIFFReadRGBAImage);
11400 DEF_IMGLIB_FN (TIFFClose);
11402 static int
11403 init_tiff_functions (library)
11404 HMODULE library;
11406 LOAD_IMGLIB_FN (library, TIFFSetErrorHandler);
11407 LOAD_IMGLIB_FN (library, TIFFSetWarningHandler);
11408 LOAD_IMGLIB_FN (library, TIFFOpen);
11409 LOAD_IMGLIB_FN (library, TIFFClientOpen);
11410 LOAD_IMGLIB_FN (library, TIFFGetField);
11411 LOAD_IMGLIB_FN (library, TIFFReadRGBAImage);
11412 LOAD_IMGLIB_FN (library, TIFFClose);
11413 return 1;
11416 /* Return non-zero if OBJECT is a valid TIFF image specification. */
11418 static int
11419 tiff_image_p (object)
11420 Lisp_Object object;
11422 struct image_keyword fmt[TIFF_LAST];
11423 bcopy (tiff_format, fmt, sizeof fmt);
11425 if (!parse_image_spec (object, fmt, TIFF_LAST, Qtiff))
11426 return 0;
11428 /* Must specify either the :data or :file keyword. */
11429 return fmt[TIFF_FILE].count + fmt[TIFF_DATA].count == 1;
11433 /* Reading from a memory buffer for TIFF images Based on the PNG
11434 memory source, but we have to provide a lot of extra functions.
11435 Blah.
11437 We really only need to implement read and seek, but I am not
11438 convinced that the TIFF library is smart enough not to destroy
11439 itself if we only hand it the function pointers we need to
11440 override. */
11442 typedef struct
11444 unsigned char *bytes;
11445 size_t len;
11446 int index;
11448 tiff_memory_source;
11450 static size_t
11451 tiff_read_from_memory (data, buf, size)
11452 thandle_t data;
11453 tdata_t buf;
11454 tsize_t size;
11456 tiff_memory_source *src = (tiff_memory_source *) data;
11458 if (size > src->len - src->index)
11459 return (size_t) -1;
11460 bcopy (src->bytes + src->index, buf, size);
11461 src->index += size;
11462 return size;
11465 static size_t
11466 tiff_write_from_memory (data, buf, size)
11467 thandle_t data;
11468 tdata_t buf;
11469 tsize_t size;
11471 return (size_t) -1;
11474 static toff_t
11475 tiff_seek_in_memory (data, off, whence)
11476 thandle_t data;
11477 toff_t off;
11478 int whence;
11480 tiff_memory_source *src = (tiff_memory_source *) data;
11481 int idx;
11483 switch (whence)
11485 case SEEK_SET: /* Go from beginning of source. */
11486 idx = off;
11487 break;
11489 case SEEK_END: /* Go from end of source. */
11490 idx = src->len + off;
11491 break;
11493 case SEEK_CUR: /* Go from current position. */
11494 idx = src->index + off;
11495 break;
11497 default: /* Invalid `whence'. */
11498 return -1;
11501 if (idx > src->len || idx < 0)
11502 return -1;
11504 src->index = idx;
11505 return src->index;
11508 static int
11509 tiff_close_memory (data)
11510 thandle_t data;
11512 /* NOOP */
11513 return 0;
11516 static int
11517 tiff_mmap_memory (data, pbase, psize)
11518 thandle_t data;
11519 tdata_t *pbase;
11520 toff_t *psize;
11522 /* It is already _IN_ memory. */
11523 return 0;
11526 static void
11527 tiff_unmap_memory (data, base, size)
11528 thandle_t data;
11529 tdata_t base;
11530 toff_t size;
11532 /* We don't need to do this. */
11535 static toff_t
11536 tiff_size_of_memory (data)
11537 thandle_t data;
11539 return ((tiff_memory_source *) data)->len;
11543 static void
11544 tiff_error_handler (title, format, ap)
11545 const char *title, *format;
11546 va_list ap;
11548 char buf[512];
11549 int len;
11551 len = sprintf (buf, "TIFF error: %s ", title);
11552 vsprintf (buf + len, format, ap);
11553 add_to_log (buf, Qnil, Qnil);
11557 static void
11558 tiff_warning_handler (title, format, ap)
11559 const char *title, *format;
11560 va_list ap;
11562 char buf[512];
11563 int len;
11565 len = sprintf (buf, "TIFF warning: %s ", title);
11566 vsprintf (buf + len, format, ap);
11567 add_to_log (buf, Qnil, Qnil);
11571 /* Load TIFF image IMG for use on frame F. Value is non-zero if
11572 successful. */
11574 static int
11575 tiff_load (f, img)
11576 struct frame *f;
11577 struct image *img;
11579 Lisp_Object file, specified_file;
11580 Lisp_Object specified_data;
11581 TIFF *tiff;
11582 int width, height, x, y;
11583 uint32 *buf;
11584 int rc;
11585 XImage *ximg;
11586 struct gcpro gcpro1;
11587 tiff_memory_source memsrc;
11589 specified_file = image_spec_value (img->spec, QCfile, NULL);
11590 specified_data = image_spec_value (img->spec, QCdata, NULL);
11591 file = Qnil;
11592 GCPRO1 (file);
11594 fn_TIFFSetErrorHandler (tiff_error_handler);
11595 fn_TIFFSetWarningHandler (tiff_warning_handler);
11597 if (NILP (specified_data))
11599 /* Read from a file */
11600 file = x_find_image_file (specified_file);
11601 if (!STRINGP (file))
11603 image_error ("Cannot find image file `%s'", file, Qnil);
11604 UNGCPRO;
11605 return 0;
11608 /* Try to open the image file. */
11609 tiff = fn_TIFFOpen (SDATA (file), "r");
11610 if (tiff == NULL)
11612 image_error ("Cannot open `%s'", file, Qnil);
11613 UNGCPRO;
11614 return 0;
11617 else
11619 /* Memory source! */
11620 memsrc.bytes = SDATA (specified_data);
11621 memsrc.len = SBYTES (specified_data);
11622 memsrc.index = 0;
11624 tiff = fn_TIFFClientOpen ("memory_source", "r", &memsrc,
11625 (TIFFReadWriteProc) tiff_read_from_memory,
11626 (TIFFReadWriteProc) tiff_write_from_memory,
11627 tiff_seek_in_memory,
11628 tiff_close_memory,
11629 tiff_size_of_memory,
11630 tiff_mmap_memory,
11631 tiff_unmap_memory);
11633 if (!tiff)
11635 image_error ("Cannot open memory source for `%s'", img->spec, Qnil);
11636 UNGCPRO;
11637 return 0;
11641 /* Get width and height of the image, and allocate a raster buffer
11642 of width x height 32-bit values. */
11643 fn_TIFFGetField (tiff, TIFFTAG_IMAGEWIDTH, &width);
11644 fn_TIFFGetField (tiff, TIFFTAG_IMAGELENGTH, &height);
11645 buf = (uint32 *) xmalloc (width * height * sizeof *buf);
11647 rc = fn_TIFFReadRGBAImage (tiff, width, height, buf, 0);
11648 fn_TIFFClose (tiff);
11649 if (!rc)
11651 image_error ("Error reading TIFF image `%s'", img->spec, Qnil);
11652 xfree (buf);
11653 UNGCPRO;
11654 return 0;
11657 /* Create the X image and pixmap. */
11658 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
11660 xfree (buf);
11661 UNGCPRO;
11662 return 0;
11665 #if 0 /* TODO: Color tables. */
11666 /* Initialize the color table. */
11667 init_color_table ();
11668 #endif
11670 /* Process the pixel raster. Origin is in the lower-left corner. */
11671 for (y = 0; y < height; ++y)
11673 uint32 *row = buf + y * width;
11675 for (x = 0; x < width; ++x)
11677 uint32 abgr = row[x];
11678 int r = TIFFGetR (abgr);
11679 int g = TIFFGetG (abgr);
11680 int b = TIFFGetB (abgr);
11681 #if 0 /* TODO: Color tables. */
11682 XPutPixel (ximg, x, height - 1 - y, lookup_rgb_color (f, r, g, b));
11683 #else
11684 XPutPixel (ximg, x, height - 1 - y, PALETTERGB (r, g, b));
11685 #endif
11689 #if 0 /* TODO: Color tables. */
11690 /* Remember the colors allocated for the image. Free the color table. */
11691 img->colors = colors_in_color_table (&img->ncolors);
11692 free_color_table ();
11693 #endif
11695 img->width = width;
11696 img->height = height;
11698 /* Maybe fill in the background field while we have ximg handy. */
11699 if (NILP (image_spec_value (img->spec, QCbackground, NULL)))
11700 IMAGE_BACKGROUND (img, f, ximg);
11702 /* Put the image into the pixmap, then free the X image and its buffer. */
11703 x_put_x_image (f, ximg, img->pixmap, width, height);
11704 x_destroy_x_image (ximg);
11705 xfree (buf);
11707 UNGCPRO;
11708 return 1;
11711 #endif /* HAVE_TIFF != 0 */
11715 /***********************************************************************
11717 ***********************************************************************/
11719 #if HAVE_GIF
11721 #define DrawText gif_DrawText
11722 #include <gif_lib.h>
11723 #undef DrawText
11725 static int gif_image_p P_ ((Lisp_Object object));
11726 static int gif_load P_ ((struct frame *f, struct image *img));
11728 /* The symbol `gif' identifying images of this type. */
11730 Lisp_Object Qgif;
11732 /* Indices of image specification fields in gif_format, below. */
11734 enum gif_keyword_index
11736 GIF_TYPE,
11737 GIF_DATA,
11738 GIF_FILE,
11739 GIF_ASCENT,
11740 GIF_MARGIN,
11741 GIF_RELIEF,
11742 GIF_ALGORITHM,
11743 GIF_HEURISTIC_MASK,
11744 GIF_MASK,
11745 GIF_IMAGE,
11746 GIF_BACKGROUND,
11747 GIF_LAST
11750 /* Vector of image_keyword structures describing the format
11751 of valid user-defined image specifications. */
11753 static struct image_keyword gif_format[GIF_LAST] =
11755 {":type", IMAGE_SYMBOL_VALUE, 1},
11756 {":data", IMAGE_STRING_VALUE, 0},
11757 {":file", IMAGE_STRING_VALUE, 0},
11758 {":ascent", IMAGE_ASCENT_VALUE, 0},
11759 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
11760 {":relief", IMAGE_INTEGER_VALUE, 0},
11761 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
11762 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
11763 {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
11764 {":image", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0},
11765 {":background", IMAGE_STRING_OR_NIL_VALUE, 0}
11768 /* Structure describing the image type `gif'. */
11770 static struct image_type gif_type =
11772 &Qgif,
11773 gif_image_p,
11774 gif_load,
11775 x_clear_image,
11776 NULL
11780 /* GIF library details. */
11781 DEF_IMGLIB_FN (DGifCloseFile);
11782 DEF_IMGLIB_FN (DGifSlurp);
11783 DEF_IMGLIB_FN (DGifOpen);
11784 DEF_IMGLIB_FN (DGifOpenFileName);
11786 static int
11787 init_gif_functions (library)
11788 HMODULE library;
11790 LOAD_IMGLIB_FN (library, DGifCloseFile);
11791 LOAD_IMGLIB_FN (library, DGifSlurp);
11792 LOAD_IMGLIB_FN (library, DGifOpen);
11793 LOAD_IMGLIB_FN (library, DGifOpenFileName);
11794 return 1;
11798 /* Return non-zero if OBJECT is a valid GIF image specification. */
11800 static int
11801 gif_image_p (object)
11802 Lisp_Object object;
11804 struct image_keyword fmt[GIF_LAST];
11805 bcopy (gif_format, fmt, sizeof fmt);
11807 if (!parse_image_spec (object, fmt, GIF_LAST, Qgif))
11808 return 0;
11810 /* Must specify either the :data or :file keyword. */
11811 return fmt[GIF_FILE].count + fmt[GIF_DATA].count == 1;
11814 /* Reading a GIF image from memory
11815 Based on the PNG memory stuff to a certain extent. */
11817 typedef struct
11819 unsigned char *bytes;
11820 size_t len;
11821 int index;
11823 gif_memory_source;
11825 /* Make the current memory source available to gif_read_from_memory.
11826 It's done this way because not all versions of libungif support
11827 a UserData field in the GifFileType structure. */
11828 static gif_memory_source *current_gif_memory_src;
11830 static int
11831 gif_read_from_memory (file, buf, len)
11832 GifFileType *file;
11833 GifByteType *buf;
11834 int len;
11836 gif_memory_source *src = current_gif_memory_src;
11838 if (len > src->len - src->index)
11839 return -1;
11841 bcopy (src->bytes + src->index, buf, len);
11842 src->index += len;
11843 return len;
11847 /* Load GIF image IMG for use on frame F. Value is non-zero if
11848 successful. */
11850 static int
11851 gif_load (f, img)
11852 struct frame *f;
11853 struct image *img;
11855 Lisp_Object file, specified_file;
11856 Lisp_Object specified_data;
11857 int rc, width, height, x, y, i;
11858 XImage *ximg;
11859 ColorMapObject *gif_color_map;
11860 unsigned long pixel_colors[256];
11861 GifFileType *gif;
11862 struct gcpro gcpro1;
11863 Lisp_Object image;
11864 int ino, image_left, image_top, image_width, image_height;
11865 gif_memory_source memsrc;
11866 unsigned char *raster;
11868 specified_file = image_spec_value (img->spec, QCfile, NULL);
11869 specified_data = image_spec_value (img->spec, QCdata, NULL);
11870 file = Qnil;
11871 GCPRO1 (file);
11873 if (NILP (specified_data))
11875 file = x_find_image_file (specified_file);
11876 if (!STRINGP (file))
11878 image_error ("Cannot find image file `%s'", specified_file, Qnil);
11879 UNGCPRO;
11880 return 0;
11883 /* Open the GIF file. */
11884 gif = fn_DGifOpenFileName (SDATA (file));
11885 if (gif == NULL)
11887 image_error ("Cannot open `%s'", file, Qnil);
11888 UNGCPRO;
11889 return 0;
11892 else
11894 /* Read from memory! */
11895 current_gif_memory_src = &memsrc;
11896 memsrc.bytes = SDATA (specified_data);
11897 memsrc.len = SBYTES (specified_data);
11898 memsrc.index = 0;
11900 gif = fn_DGifOpen(&memsrc, gif_read_from_memory);
11901 if (!gif)
11903 image_error ("Cannot open memory source `%s'", img->spec, Qnil);
11904 UNGCPRO;
11905 return 0;
11909 /* Read entire contents. */
11910 rc = fn_DGifSlurp (gif);
11911 if (rc == GIF_ERROR)
11913 image_error ("Error reading `%s'", img->spec, Qnil);
11914 fn_DGifCloseFile (gif);
11915 UNGCPRO;
11916 return 0;
11919 image = image_spec_value (img->spec, QCindex, NULL);
11920 ino = INTEGERP (image) ? XFASTINT (image) : 0;
11921 if (ino >= gif->ImageCount)
11923 image_error ("Invalid image number `%s' in image `%s'",
11924 image, img->spec);
11925 fn_DGifCloseFile (gif);
11926 UNGCPRO;
11927 return 0;
11930 width = img->width = max (gif->SWidth, gif->Image.Left + gif->Image.Width);
11931 height = img->height = max (gif->SHeight, gif->Image.Top + gif->Image.Height);
11933 /* Create the X image and pixmap. */
11934 if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap))
11936 fn_DGifCloseFile (gif);
11937 UNGCPRO;
11938 return 0;
11941 /* Allocate colors. */
11942 gif_color_map = gif->SavedImages[ino].ImageDesc.ColorMap;
11943 if (!gif_color_map)
11944 gif_color_map = gif->SColorMap;
11945 #if 0 /* TODO: Color tables */
11946 init_color_table ();
11947 #endif
11948 bzero (pixel_colors, sizeof pixel_colors);
11950 for (i = 0; i < gif_color_map->ColorCount; ++i)
11952 int r = gif_color_map->Colors[i].Red;
11953 int g = gif_color_map->Colors[i].Green;
11954 int b = gif_color_map->Colors[i].Blue;
11955 #if 0 /* TODO: Color tables */
11956 pixel_colors[i] = lookup_rgb_color (f, r, g, b);
11957 #else
11958 pixel_colors[i] = PALETTERGB (r, g, b);
11959 #endif
11962 #if 0 /* TODO: Color tables */
11963 img->colors = colors_in_color_table (&img->ncolors);
11964 free_color_table ();
11965 #endif
11967 /* Clear the part of the screen image that are not covered by
11968 the image from the GIF file. Full animated GIF support
11969 requires more than can be done here (see the gif89 spec,
11970 disposal methods). Let's simply assume that the part
11971 not covered by a sub-image is in the frame's background color. */
11972 image_top = gif->SavedImages[ino].ImageDesc.Top;
11973 image_left = gif->SavedImages[ino].ImageDesc.Left;
11974 image_width = gif->SavedImages[ino].ImageDesc.Width;
11975 image_height = gif->SavedImages[ino].ImageDesc.Height;
11977 for (y = 0; y < image_top; ++y)
11978 for (x = 0; x < width; ++x)
11979 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11981 for (y = image_top + image_height; y < height; ++y)
11982 for (x = 0; x < width; ++x)
11983 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11985 for (y = image_top; y < image_top + image_height; ++y)
11987 for (x = 0; x < image_left; ++x)
11988 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11989 for (x = image_left + image_width; x < width; ++x)
11990 XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f));
11993 /* Read the GIF image into the X image. We use a local variable
11994 `raster' here because RasterBits below is a char *, and invites
11995 problems with bytes >= 0x80. */
11996 raster = (unsigned char *) gif->SavedImages[ino].RasterBits;
11998 if (gif->SavedImages[ino].ImageDesc.Interlace)
12000 static int interlace_start[] = {0, 4, 2, 1};
12001 static int interlace_increment[] = {8, 8, 4, 2};
12002 int pass;
12003 int row = interlace_start[0];
12005 pass = 0;
12007 for (y = 0; y < image_height; y++)
12009 if (row >= image_height)
12011 row = interlace_start[++pass];
12012 while (row >= image_height)
12013 row = interlace_start[++pass];
12016 for (x = 0; x < image_width; x++)
12018 int i = raster[(y * image_width) + x];
12019 XPutPixel (ximg, x + image_left, row + image_top,
12020 pixel_colors[i]);
12023 row += interlace_increment[pass];
12026 else
12028 for (y = 0; y < image_height; ++y)
12029 for (x = 0; x < image_width; ++x)
12031 int i = raster[y* image_width + x];
12032 XPutPixel (ximg, x + image_left, y + image_top, pixel_colors[i]);
12036 fn_DGifCloseFile (gif);
12038 /* Maybe fill in the background field while we have ximg handy. */
12039 if (NILP (image_spec_value (img->spec, QCbackground, NULL)))
12040 IMAGE_BACKGROUND (img, f, ximg);
12042 /* Put the image into the pixmap, then free the X image and its buffer. */
12043 x_put_x_image (f, ximg, img->pixmap, width, height);
12044 x_destroy_x_image (ximg);
12046 UNGCPRO;
12047 return 1;
12050 #endif /* HAVE_GIF != 0 */
12054 /***********************************************************************
12055 Ghostscript
12056 ***********************************************************************/
12058 Lisp_Object Qpostscript;
12060 /* Keyword symbols. */
12062 Lisp_Object QCloader, QCbounding_box, QCpt_width, QCpt_height;
12064 #ifdef HAVE_GHOSTSCRIPT
12065 static int gs_image_p P_ ((Lisp_Object object));
12066 static int gs_load P_ ((struct frame *f, struct image *img));
12067 static void gs_clear_image P_ ((struct frame *f, struct image *img));
12069 /* The symbol `postscript' identifying images of this type. */
12071 /* Keyword symbols. */
12073 Lisp_Object QCloader, QCbounding_box, QCpt_width, QCpt_height;
12075 /* Indices of image specification fields in gs_format, below. */
12077 enum gs_keyword_index
12079 GS_TYPE,
12080 GS_PT_WIDTH,
12081 GS_PT_HEIGHT,
12082 GS_FILE,
12083 GS_LOADER,
12084 GS_BOUNDING_BOX,
12085 GS_ASCENT,
12086 GS_MARGIN,
12087 GS_RELIEF,
12088 GS_ALGORITHM,
12089 GS_HEURISTIC_MASK,
12090 GS_MASK,
12091 GS_BACKGROUND,
12092 GS_LAST
12095 /* Vector of image_keyword structures describing the format
12096 of valid user-defined image specifications. */
12098 static struct image_keyword gs_format[GS_LAST] =
12100 {":type", IMAGE_SYMBOL_VALUE, 1},
12101 {":pt-width", IMAGE_POSITIVE_INTEGER_VALUE, 1},
12102 {":pt-height", IMAGE_POSITIVE_INTEGER_VALUE, 1},
12103 {":file", IMAGE_STRING_VALUE, 1},
12104 {":loader", IMAGE_FUNCTION_VALUE, 0},
12105 {":bounding-box", IMAGE_DONT_CHECK_VALUE_TYPE, 1},
12106 {":ascent", IMAGE_ASCENT_VALUE, 0},
12107 {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
12108 {":relief", IMAGE_INTEGER_VALUE, 0},
12109 {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
12110 {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
12111 {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
12112 {":background", IMAGE_STRING_OR_NIL_VALUE, 0}
12115 /* Structure describing the image type `ghostscript'. */
12117 static struct image_type gs_type =
12119 &Qpostscript,
12120 gs_image_p,
12121 gs_load,
12122 gs_clear_image,
12123 NULL
12127 /* Free X resources of Ghostscript image IMG which is used on frame F. */
12129 static void
12130 gs_clear_image (f, img)
12131 struct frame *f;
12132 struct image *img;
12134 /* IMG->data.ptr_val may contain a recorded colormap. */
12135 xfree (img->data.ptr_val);
12136 x_clear_image (f, img);
12140 /* Return non-zero if OBJECT is a valid Ghostscript image
12141 specification. */
12143 static int
12144 gs_image_p (object)
12145 Lisp_Object object;
12147 struct image_keyword fmt[GS_LAST];
12148 Lisp_Object tem;
12149 int i;
12151 bcopy (gs_format, fmt, sizeof fmt);
12153 if (!parse_image_spec (object, fmt, GS_LAST, Qpostscript))
12154 return 0;
12156 /* Bounding box must be a list or vector containing 4 integers. */
12157 tem = fmt[GS_BOUNDING_BOX].value;
12158 if (CONSP (tem))
12160 for (i = 0; i < 4; ++i, tem = XCDR (tem))
12161 if (!CONSP (tem) || !INTEGERP (XCAR (tem)))
12162 return 0;
12163 if (!NILP (tem))
12164 return 0;
12166 else if (VECTORP (tem))
12168 if (XVECTOR (tem)->size != 4)
12169 return 0;
12170 for (i = 0; i < 4; ++i)
12171 if (!INTEGERP (XVECTOR (tem)->contents[i]))
12172 return 0;
12174 else
12175 return 0;
12177 return 1;
12181 /* Load Ghostscript image IMG for use on frame F. Value is non-zero
12182 if successful. */
12184 static int
12185 gs_load (f, img)
12186 struct frame *f;
12187 struct image *img;
12189 char buffer[100];
12190 Lisp_Object window_and_pixmap_id = Qnil, loader, pt_height, pt_width;
12191 struct gcpro gcpro1, gcpro2;
12192 Lisp_Object frame;
12193 double in_width, in_height;
12194 Lisp_Object pixel_colors = Qnil;
12196 /* Compute pixel size of pixmap needed from the given size in the
12197 image specification. Sizes in the specification are in pt. 1 pt
12198 = 1/72 in, xdpi and ydpi are stored in the frame's X display
12199 info. */
12200 pt_width = image_spec_value (img->spec, QCpt_width, NULL);
12201 in_width = XFASTINT (pt_width) / 72.0;
12202 img->width = in_width * FRAME_W32_DISPLAY_INFO (f)->resx;
12203 pt_height = image_spec_value (img->spec, QCpt_height, NULL);
12204 in_height = XFASTINT (pt_height) / 72.0;
12205 img->height = in_height * FRAME_W32_DISPLAY_INFO (f)->resy;
12207 /* Create the pixmap. */
12208 BLOCK_INPUT;
12209 xassert (img->pixmap == 0);
12210 img->pixmap = XCreatePixmap (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
12211 img->width, img->height,
12212 one_w32_display_info.n_cbits);
12213 UNBLOCK_INPUT;
12215 if (!img->pixmap)
12217 image_error ("Unable to create pixmap for `%s'", img->spec, Qnil);
12218 return 0;
12221 /* Call the loader to fill the pixmap. It returns a process object
12222 if successful. We do not record_unwind_protect here because
12223 other places in redisplay like calling window scroll functions
12224 don't either. Let the Lisp loader use `unwind-protect' instead. */
12225 GCPRO2 (window_and_pixmap_id, pixel_colors);
12227 sprintf (buffer, "%lu %lu",
12228 (unsigned long) FRAME_W32_WINDOW (f),
12229 (unsigned long) img->pixmap);
12230 window_and_pixmap_id = build_string (buffer);
12232 sprintf (buffer, "%lu %lu",
12233 FRAME_FOREGROUND_PIXEL (f),
12234 FRAME_BACKGROUND_PIXEL (f));
12235 pixel_colors = build_string (buffer);
12237 XSETFRAME (frame, f);
12238 loader = image_spec_value (img->spec, QCloader, NULL);
12239 if (NILP (loader))
12240 loader = intern ("gs-load-image");
12242 img->data.lisp_val = call6 (loader, frame, img->spec,
12243 make_number (img->width),
12244 make_number (img->height),
12245 window_and_pixmap_id,
12246 pixel_colors);
12247 UNGCPRO;
12248 return PROCESSP (img->data.lisp_val);
12252 /* Kill the Ghostscript process that was started to fill PIXMAP on
12253 frame F. Called from XTread_socket when receiving an event
12254 telling Emacs that Ghostscript has finished drawing. */
12256 void
12257 x_kill_gs_process (pixmap, f)
12258 Pixmap pixmap;
12259 struct frame *f;
12261 struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
12262 int class, i;
12263 struct image *img;
12265 /* Find the image containing PIXMAP. */
12266 for (i = 0; i < c->used; ++i)
12267 if (c->images[i]->pixmap == pixmap)
12268 break;
12270 /* Should someone in between have cleared the image cache, for
12271 instance, give up. */
12272 if (i == c->used)
12273 return;
12275 /* Kill the GS process. We should have found PIXMAP in the image
12276 cache and its image should contain a process object. */
12277 img = c->images[i];
12278 xassert (PROCESSP (img->data.lisp_val));
12279 Fkill_process (img->data.lisp_val, Qnil);
12280 img->data.lisp_val = Qnil;
12282 /* On displays with a mutable colormap, figure out the colors
12283 allocated for the image by looking at the pixels of an XImage for
12284 img->pixmap. */
12285 class = FRAME_W32_DISPLAY_INFO (f)->visual->class;
12286 if (class != StaticColor && class != StaticGray && class != TrueColor)
12288 XImage *ximg;
12290 BLOCK_INPUT;
12292 /* Try to get an XImage for img->pixmep. */
12293 ximg = XGetImage (FRAME_W32_DISPLAY (f), img->pixmap,
12294 0, 0, img->width, img->height, ~0, ZPixmap);
12295 if (ximg)
12297 int x, y;
12299 /* Initialize the color table. */
12300 init_color_table ();
12302 /* For each pixel of the image, look its color up in the
12303 color table. After having done so, the color table will
12304 contain an entry for each color used by the image. */
12305 for (y = 0; y < img->height; ++y)
12306 for (x = 0; x < img->width; ++x)
12308 unsigned long pixel = XGetPixel (ximg, x, y);
12309 lookup_pixel_color (f, pixel);
12312 /* Record colors in the image. Free color table and XImage. */
12313 img->colors = colors_in_color_table (&img->ncolors);
12314 free_color_table ();
12315 XDestroyImage (ximg);
12317 #if 0 /* This doesn't seem to be the case. If we free the colors
12318 here, we get a BadAccess later in x_clear_image when
12319 freeing the colors. */
12320 /* We have allocated colors once, but Ghostscript has also
12321 allocated colors on behalf of us. So, to get the
12322 reference counts right, free them once. */
12323 if (img->ncolors)
12324 x_free_colors (FRAME_W32_DISPLAY (f), cmap,
12325 img->colors, img->ncolors, 0);
12326 #endif
12328 else
12329 image_error ("Cannot get X image of `%s'; colors will not be freed",
12330 img->spec, Qnil);
12332 UNBLOCK_INPUT;
12335 /* Now that we have the pixmap, compute mask and transform the
12336 image if requested. */
12337 BLOCK_INPUT;
12338 postprocess_image (f, img);
12339 UNBLOCK_INPUT;
12342 #endif /* HAVE_GHOSTSCRIPT */
12345 /***********************************************************************
12346 Window properties
12347 ***********************************************************************/
12349 DEFUN ("x-change-window-property", Fx_change_window_property,
12350 Sx_change_window_property, 2, 3, 0,
12351 doc: /* Change window property PROP to VALUE on the X window of FRAME.
12352 PROP and VALUE must be strings. FRAME nil or omitted means use the
12353 selected frame. Value is VALUE. */)
12354 (prop, value, frame)
12355 Lisp_Object frame, prop, value;
12357 #if 0 /* TODO : port window properties to W32 */
12358 struct frame *f = check_x_frame (frame);
12359 Atom prop_atom;
12361 CHECK_STRING (prop);
12362 CHECK_STRING (value);
12364 BLOCK_INPUT;
12365 prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), SDATA (prop), False);
12366 XChangeProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
12367 prop_atom, XA_STRING, 8, PropModeReplace,
12368 SDATA (value), SCHARS (value));
12370 /* Make sure the property is set when we return. */
12371 XFlush (FRAME_W32_DISPLAY (f));
12372 UNBLOCK_INPUT;
12374 #endif /* TODO */
12376 return value;
12380 DEFUN ("x-delete-window-property", Fx_delete_window_property,
12381 Sx_delete_window_property, 1, 2, 0,
12382 doc: /* Remove window property PROP from X window of FRAME.
12383 FRAME nil or omitted means use the selected frame. Value is PROP. */)
12384 (prop, frame)
12385 Lisp_Object prop, frame;
12387 #if 0 /* TODO : port window properties to W32 */
12389 struct frame *f = check_x_frame (frame);
12390 Atom prop_atom;
12392 CHECK_STRING (prop);
12393 BLOCK_INPUT;
12394 prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), SDATA (prop), False);
12395 XDeleteProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), prop_atom);
12397 /* Make sure the property is removed when we return. */
12398 XFlush (FRAME_W32_DISPLAY (f));
12399 UNBLOCK_INPUT;
12400 #endif /* TODO */
12402 return prop;
12406 DEFUN ("x-window-property", Fx_window_property, Sx_window_property,
12407 1, 2, 0,
12408 doc: /* Value is the value of window property PROP on FRAME.
12409 If FRAME is nil or omitted, use the selected frame. Value is nil
12410 if FRAME hasn't a property with name PROP or if PROP has no string
12411 value. */)
12412 (prop, frame)
12413 Lisp_Object prop, frame;
12415 #if 0 /* TODO : port window properties to W32 */
12417 struct frame *f = check_x_frame (frame);
12418 Atom prop_atom;
12419 int rc;
12420 Lisp_Object prop_value = Qnil;
12421 char *tmp_data = NULL;
12422 Atom actual_type;
12423 int actual_format;
12424 unsigned long actual_size, bytes_remaining;
12426 CHECK_STRING (prop);
12427 BLOCK_INPUT;
12428 prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), SDATA (prop), False);
12429 rc = XGetWindowProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
12430 prop_atom, 0, 0, False, XA_STRING,
12431 &actual_type, &actual_format, &actual_size,
12432 &bytes_remaining, (unsigned char **) &tmp_data);
12433 if (rc == Success)
12435 int size = bytes_remaining;
12437 XFree (tmp_data);
12438 tmp_data = NULL;
12440 rc = XGetWindowProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f),
12441 prop_atom, 0, bytes_remaining,
12442 False, XA_STRING,
12443 &actual_type, &actual_format,
12444 &actual_size, &bytes_remaining,
12445 (unsigned char **) &tmp_data);
12446 if (rc == Success)
12447 prop_value = make_string (tmp_data, size);
12449 XFree (tmp_data);
12452 UNBLOCK_INPUT;
12454 return prop_value;
12456 #endif /* TODO */
12457 return Qnil;
12462 /***********************************************************************
12463 Busy cursor
12464 ***********************************************************************/
12466 /* If non-null, an asynchronous timer that, when it expires, displays
12467 an hourglass cursor on all frames. */
12469 static struct atimer *hourglass_atimer;
12471 /* Non-zero means an hourglass cursor is currently shown. */
12473 static int hourglass_shown_p;
12475 /* Number of seconds to wait before displaying an hourglass cursor. */
12477 static Lisp_Object Vhourglass_delay;
12479 /* Default number of seconds to wait before displaying an hourglass
12480 cursor. */
12482 #define DEFAULT_HOURGLASS_DELAY 1
12484 /* Function prototypes. */
12486 static void show_hourglass P_ ((struct atimer *));
12487 static void hide_hourglass P_ ((void));
12490 /* Cancel a currently active hourglass timer, and start a new one. */
12492 void
12493 start_hourglass ()
12495 #if 0 /* TODO: cursor shape changes. */
12496 EMACS_TIME delay;
12497 int secs, usecs = 0;
12499 cancel_hourglass ();
12501 if (INTEGERP (Vhourglass_delay)
12502 && XINT (Vhourglass_delay) > 0)
12503 secs = XFASTINT (Vhourglass_delay);
12504 else if (FLOATP (Vhourglass_delay)
12505 && XFLOAT_DATA (Vhourglass_delay) > 0)
12507 Lisp_Object tem;
12508 tem = Ftruncate (Vhourglass_delay, Qnil);
12509 secs = XFASTINT (tem);
12510 usecs = (XFLOAT_DATA (Vhourglass_delay) - secs) * 1000000;
12512 else
12513 secs = DEFAULT_HOURGLASS_DELAY;
12515 EMACS_SET_SECS_USECS (delay, secs, usecs);
12516 hourglass_atimer = start_atimer (ATIMER_RELATIVE, delay,
12517 show_hourglass, NULL);
12518 #endif
12522 /* Cancel the hourglass cursor timer if active, hide an hourglass
12523 cursor if shown. */
12525 void
12526 cancel_hourglass ()
12528 if (hourglass_atimer)
12530 cancel_atimer (hourglass_atimer);
12531 hourglass_atimer = NULL;
12534 if (hourglass_shown_p)
12535 hide_hourglass ();
12539 /* Timer function of hourglass_atimer. TIMER is equal to
12540 hourglass_atimer.
12542 Display an hourglass cursor on all frames by mapping the frames'
12543 hourglass_window. Set the hourglass_p flag in the frames'
12544 output_data.x structure to indicate that an hourglass cursor is
12545 shown on the frames. */
12547 static void
12548 show_hourglass (timer)
12549 struct atimer *timer;
12551 #if 0 /* TODO: cursor shape changes. */
12552 /* The timer implementation will cancel this timer automatically
12553 after this function has run. Set hourglass_atimer to null
12554 so that we know the timer doesn't have to be canceled. */
12555 hourglass_atimer = NULL;
12557 if (!hourglass_shown_p)
12559 Lisp_Object rest, frame;
12561 BLOCK_INPUT;
12563 FOR_EACH_FRAME (rest, frame)
12564 if (FRAME_W32_P (XFRAME (frame)))
12566 struct frame *f = XFRAME (frame);
12568 f->output_data.w32->hourglass_p = 1;
12570 if (!f->output_data.w32->hourglass_window)
12572 unsigned long mask = CWCursor;
12573 XSetWindowAttributes attrs;
12575 attrs.cursor = f->output_data.w32->hourglass_cursor;
12577 f->output_data.w32->hourglass_window
12578 = XCreateWindow (FRAME_X_DISPLAY (f),
12579 FRAME_OUTER_WINDOW (f),
12580 0, 0, 32000, 32000, 0, 0,
12581 InputOnly,
12582 CopyFromParent,
12583 mask, &attrs);
12586 XMapRaised (FRAME_X_DISPLAY (f),
12587 f->output_data.w32->hourglass_window);
12588 XFlush (FRAME_X_DISPLAY (f));
12591 hourglass_shown_p = 1;
12592 UNBLOCK_INPUT;
12594 #endif
12598 /* Hide the hourglass cursor on all frames, if it is currently shown. */
12600 static void
12601 hide_hourglass ()
12603 #if 0 /* TODO: cursor shape changes. */
12604 if (hourglass_shown_p)
12606 Lisp_Object rest, frame;
12608 BLOCK_INPUT;
12609 FOR_EACH_FRAME (rest, frame)
12611 struct frame *f = XFRAME (frame);
12613 if (FRAME_W32_P (f)
12614 /* Watch out for newly created frames. */
12615 && f->output_data.x->hourglass_window)
12617 XUnmapWindow (FRAME_X_DISPLAY (f),
12618 f->output_data.x->hourglass_window);
12619 /* Sync here because XTread_socket looks at the
12620 hourglass_p flag that is reset to zero below. */
12621 XSync (FRAME_X_DISPLAY (f), False);
12622 f->output_data.x->hourglass_p = 0;
12626 hourglass_shown_p = 0;
12627 UNBLOCK_INPUT;
12629 #endif
12634 /***********************************************************************
12635 Tool tips
12636 ***********************************************************************/
12638 static Lisp_Object x_create_tip_frame P_ ((struct w32_display_info *,
12639 Lisp_Object, Lisp_Object));
12640 static void compute_tip_xy P_ ((struct frame *, Lisp_Object, Lisp_Object,
12641 Lisp_Object, int, int, int *, int *));
12643 /* The frame of a currently visible tooltip. */
12645 Lisp_Object tip_frame;
12647 /* If non-nil, a timer started that hides the last tooltip when it
12648 fires. */
12650 Lisp_Object tip_timer;
12651 Window tip_window;
12653 /* If non-nil, a vector of 3 elements containing the last args
12654 with which x-show-tip was called. See there. */
12656 Lisp_Object last_show_tip_args;
12658 /* Maximum size for tooltips; a cons (COLUMNS . ROWS). */
12660 Lisp_Object Vx_max_tooltip_size;
12663 static Lisp_Object
12664 unwind_create_tip_frame (frame)
12665 Lisp_Object frame;
12667 Lisp_Object deleted;
12669 deleted = unwind_create_frame (frame);
12670 if (EQ (deleted, Qt))
12672 tip_window = NULL;
12673 tip_frame = Qnil;
12676 return deleted;
12680 /* Create a frame for a tooltip on the display described by DPYINFO.
12681 PARMS is a list of frame parameters. TEXT is the string to
12682 display in the tip frame. Value is the frame.
12684 Note that functions called here, esp. x_default_parameter can
12685 signal errors, for instance when a specified color name is
12686 undefined. We have to make sure that we're in a consistent state
12687 when this happens. */
12689 static Lisp_Object
12690 x_create_tip_frame (dpyinfo, parms, text)
12691 struct w32_display_info *dpyinfo;
12692 Lisp_Object parms, text;
12694 struct frame *f;
12695 Lisp_Object frame, tem;
12696 Lisp_Object name;
12697 long window_prompting = 0;
12698 int width, height;
12699 int count = SPECPDL_INDEX ();
12700 struct gcpro gcpro1, gcpro2, gcpro3;
12701 struct kboard *kb;
12702 int face_change_count_before = face_change_count;
12703 Lisp_Object buffer;
12704 struct buffer *old_buffer;
12706 check_w32 ();
12708 /* Use this general default value to start with until we know if
12709 this frame has a specified name. */
12710 Vx_resource_name = Vinvocation_name;
12712 #ifdef MULTI_KBOARD
12713 kb = dpyinfo->kboard;
12714 #else
12715 kb = &the_only_kboard;
12716 #endif
12718 /* Get the name of the frame to use for resource lookup. */
12719 name = w32_get_arg (parms, Qname, "name", "Name", RES_TYPE_STRING);
12720 if (!STRINGP (name)
12721 && !EQ (name, Qunbound)
12722 && !NILP (name))
12723 error ("Invalid frame name--not a string or nil");
12724 Vx_resource_name = name;
12726 frame = Qnil;
12727 GCPRO3 (parms, name, frame);
12728 /* Make a frame without minibuffer nor mode-line. */
12729 f = make_frame (0);
12730 f->wants_modeline = 0;
12731 XSETFRAME (frame, f);
12733 buffer = Fget_buffer_create (build_string (" *tip*"));
12734 Fset_window_buffer (FRAME_ROOT_WINDOW (f), buffer);
12735 old_buffer = current_buffer;
12736 set_buffer_internal_1 (XBUFFER (buffer));
12737 current_buffer->truncate_lines = Qnil;
12738 Ferase_buffer ();
12739 Finsert (1, &text);
12740 set_buffer_internal_1 (old_buffer);
12742 FRAME_CAN_HAVE_SCROLL_BARS (f) = 0;
12743 record_unwind_protect (unwind_create_tip_frame, frame);
12745 /* By setting the output method, we're essentially saying that
12746 the frame is live, as per FRAME_LIVE_P. If we get a signal
12747 from this point on, x_destroy_window might screw up reference
12748 counts etc. */
12749 f->output_method = output_w32;
12750 f->output_data.w32 =
12751 (struct w32_output *) xmalloc (sizeof (struct w32_output));
12752 bzero (f->output_data.w32, sizeof (struct w32_output));
12754 FRAME_FONTSET (f) = -1;
12755 f->icon_name = Qnil;
12757 #if 0 /* GLYPH_DEBUG TODO: image support. */
12758 image_cache_refcount = FRAME_X_IMAGE_CACHE (f)->refcount;
12759 dpyinfo_refcount = dpyinfo->reference_count;
12760 #endif /* GLYPH_DEBUG */
12761 #ifdef MULTI_KBOARD
12762 FRAME_KBOARD (f) = kb;
12763 #endif
12764 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
12765 f->output_data.w32->explicit_parent = 0;
12767 /* Set the name; the functions to which we pass f expect the name to
12768 be set. */
12769 if (EQ (name, Qunbound) || NILP (name))
12771 f->name = build_string (dpyinfo->w32_id_name);
12772 f->explicit_name = 0;
12774 else
12776 f->name = name;
12777 f->explicit_name = 1;
12778 /* use the frame's title when getting resources for this frame. */
12779 specbind (Qx_resource_name, name);
12782 /* Extract the window parameters from the supplied values
12783 that are needed to determine window geometry. */
12785 Lisp_Object font;
12787 font = w32_get_arg (parms, Qfont, "font", "Font", RES_TYPE_STRING);
12789 BLOCK_INPUT;
12790 /* First, try whatever font the caller has specified. */
12791 if (STRINGP (font))
12793 tem = Fquery_fontset (font, Qnil);
12794 if (STRINGP (tem))
12795 font = x_new_fontset (f, SDATA (tem));
12796 else
12797 font = x_new_font (f, SDATA (font));
12800 /* Try out a font which we hope has bold and italic variations. */
12801 if (!STRINGP (font))
12802 font = x_new_font (f, "-*-Courier New-normal-r-*-*-*-100-*-*-c-*-iso8859-1");
12803 if (! STRINGP (font))
12804 font = x_new_font (f, "-*-Courier-normal-r-*-*-13-*-*-*-c-*-iso8859-1");
12805 /* If those didn't work, look for something which will at least work. */
12806 if (! STRINGP (font))
12807 font = x_new_font (f, "-*-Fixedsys-normal-r-*-*-12-*-*-*-c-*-iso8859-1");
12808 UNBLOCK_INPUT;
12809 if (! STRINGP (font))
12810 font = build_string ("Fixedsys");
12812 x_default_parameter (f, parms, Qfont, font,
12813 "font", "Font", RES_TYPE_STRING);
12816 x_default_parameter (f, parms, Qborder_width, make_number (2),
12817 "borderWidth", "BorderWidth", RES_TYPE_NUMBER);
12818 /* This defaults to 2 in order to match xterm. We recognize either
12819 internalBorderWidth or internalBorder (which is what xterm calls
12820 it). */
12821 if (NILP (Fassq (Qinternal_border_width, parms)))
12823 Lisp_Object value;
12825 value = w32_get_arg (parms, Qinternal_border_width,
12826 "internalBorder", "internalBorder", RES_TYPE_NUMBER);
12827 if (! EQ (value, Qunbound))
12828 parms = Fcons (Fcons (Qinternal_border_width, value),
12829 parms);
12831 x_default_parameter (f, parms, Qinternal_border_width, make_number (1),
12832 "internalBorderWidth", "internalBorderWidth",
12833 RES_TYPE_NUMBER);
12835 /* Also do the stuff which must be set before the window exists. */
12836 x_default_parameter (f, parms, Qforeground_color, build_string ("black"),
12837 "foreground", "Foreground", RES_TYPE_STRING);
12838 x_default_parameter (f, parms, Qbackground_color, build_string ("white"),
12839 "background", "Background", RES_TYPE_STRING);
12840 x_default_parameter (f, parms, Qmouse_color, build_string ("black"),
12841 "pointerColor", "Foreground", RES_TYPE_STRING);
12842 x_default_parameter (f, parms, Qcursor_color, build_string ("black"),
12843 "cursorColor", "Foreground", RES_TYPE_STRING);
12844 x_default_parameter (f, parms, Qborder_color, build_string ("black"),
12845 "borderColor", "BorderColor", RES_TYPE_STRING);
12847 /* Init faces before x_default_parameter is called for scroll-bar
12848 parameters because that function calls x_set_scroll_bar_width,
12849 which calls change_frame_size, which calls Fset_window_buffer,
12850 which runs hooks, which call Fvertical_motion. At the end, we
12851 end up in init_iterator with a null face cache, which should not
12852 happen. */
12853 init_frame_faces (f);
12855 f->output_data.w32->dwStyle = WS_BORDER | WS_POPUP | WS_DISABLED;
12856 f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window;
12858 window_prompting = x_figure_window_size (f, parms, 0);
12860 /* No fringes on tip frame. */
12861 f->output_data.w32->fringes_extra = 0;
12862 f->output_data.w32->fringe_cols = 0;
12863 f->output_data.w32->left_fringe_width = 0;
12864 f->output_data.w32->right_fringe_width = 0;
12866 BLOCK_INPUT;
12867 my_create_tip_window (f);
12868 UNBLOCK_INPUT;
12870 x_make_gc (f);
12872 x_default_parameter (f, parms, Qauto_raise, Qnil,
12873 "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN);
12874 x_default_parameter (f, parms, Qauto_lower, Qnil,
12875 "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN);
12876 x_default_parameter (f, parms, Qcursor_type, Qbox,
12877 "cursorType", "CursorType", RES_TYPE_SYMBOL);
12879 /* Dimensions, especially f->height, must be done via change_frame_size.
12880 Change will not be effected unless different from the current
12881 f->height. */
12882 width = f->width;
12883 height = f->height;
12884 f->height = 0;
12885 SET_FRAME_WIDTH (f, 0);
12886 change_frame_size (f, height, width, 1, 0, 0);
12888 /* Add `tooltip' frame parameter's default value. */
12889 if (NILP (Fframe_parameter (frame, intern ("tooltip"))))
12890 Fmodify_frame_parameters (frame, Fcons (Fcons (intern ("tooltip"), Qt),
12891 Qnil));
12893 /* Set up faces after all frame parameters are known. This call
12894 also merges in face attributes specified for new frames.
12896 Frame parameters may be changed if .Xdefaults contains
12897 specifications for the default font. For example, if there is an
12898 `Emacs.default.attributeBackground: pink', the `background-color'
12899 attribute of the frame get's set, which let's the internal border
12900 of the tooltip frame appear in pink. Prevent this. */
12902 Lisp_Object bg = Fframe_parameter (frame, Qbackground_color);
12904 /* Set tip_frame here, so that */
12905 tip_frame = frame;
12906 call1 (Qface_set_after_frame_default, frame);
12908 if (!EQ (bg, Fframe_parameter (frame, Qbackground_color)))
12909 Fmodify_frame_parameters (frame, Fcons (Fcons (Qbackground_color, bg),
12910 Qnil));
12913 f->no_split = 1;
12915 UNGCPRO;
12917 /* It is now ok to make the frame official even if we get an error
12918 below. And the frame needs to be on Vframe_list or making it
12919 visible won't work. */
12920 Vframe_list = Fcons (frame, Vframe_list);
12922 /* Now that the frame is official, it counts as a reference to
12923 its display. */
12924 FRAME_W32_DISPLAY_INFO (f)->reference_count++;
12926 /* Setting attributes of faces of the tooltip frame from resources
12927 and similar will increment face_change_count, which leads to the
12928 clearing of all current matrices. Since this isn't necessary
12929 here, avoid it by resetting face_change_count to the value it
12930 had before we created the tip frame. */
12931 face_change_count = face_change_count_before;
12933 /* Discard the unwind_protect. */
12934 return unbind_to (count, frame);
12938 /* Compute where to display tip frame F. PARMS is the list of frame
12939 parameters for F. DX and DY are specified offsets from the current
12940 location of the mouse. WIDTH and HEIGHT are the width and height
12941 of the tooltip. Return coordinates relative to the root window of
12942 the display in *ROOT_X, and *ROOT_Y. */
12944 static void
12945 compute_tip_xy (f, parms, dx, dy, width, height, root_x, root_y)
12946 struct frame *f;
12947 Lisp_Object parms, dx, dy;
12948 int width, height;
12949 int *root_x, *root_y;
12951 Lisp_Object left, top;
12953 /* User-specified position? */
12954 left = Fcdr (Fassq (Qleft, parms));
12955 top = Fcdr (Fassq (Qtop, parms));
12957 /* Move the tooltip window where the mouse pointer is. Resize and
12958 show it. */
12959 if (!INTEGERP (left) || !INTEGERP (top))
12961 POINT pt;
12963 BLOCK_INPUT;
12964 GetCursorPos (&pt);
12965 *root_x = pt.x;
12966 *root_y = pt.y;
12967 UNBLOCK_INPUT;
12970 if (INTEGERP (top))
12971 *root_y = XINT (top);
12972 else if (*root_y + XINT (dy) - height < 0)
12973 *root_y -= XINT (dy);
12974 else
12976 *root_y -= height;
12977 *root_y += XINT (dy);
12980 if (INTEGERP (left))
12981 *root_x = XINT (left);
12982 else if (*root_x + XINT (dx) + width <= FRAME_W32_DISPLAY_INFO (f)->width)
12983 /* It fits to the right of the pointer. */
12984 *root_x += XINT (dx);
12985 else if (width + XINT (dx) <= *root_x)
12986 /* It fits to the left of the pointer. */
12987 *root_x -= width + XINT (dx);
12988 else
12989 /* Put it left justified on the screen -- it ought to fit that way. */
12990 *root_x = 0;
12994 DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0,
12995 doc: /* Show STRING in a \"tooltip\" window on frame FRAME.
12996 A tooltip window is a small window displaying a string.
12998 FRAME nil or omitted means use the selected frame.
13000 PARMS is an optional list of frame parameters which can be
13001 used to change the tooltip's appearance.
13003 Automatically hide the tooltip after TIMEOUT seconds. TIMEOUT nil
13004 means use the default timeout of 5 seconds.
13006 If the list of frame parameters PARAMS contains a `left' parameter,
13007 the tooltip is displayed at that x-position. Otherwise it is
13008 displayed at the mouse position, with offset DX added (default is 5 if
13009 DX isn't specified). Likewise for the y-position; if a `top' frame
13010 parameter is specified, it determines the y-position of the tooltip
13011 window, otherwise it is displayed at the mouse position, with offset
13012 DY added (default is -10).
13014 A tooltip's maximum size is specified by `x-max-tooltip-size'.
13015 Text larger than the specified size is clipped. */)
13016 (string, frame, parms, timeout, dx, dy)
13017 Lisp_Object string, frame, parms, timeout, dx, dy;
13019 struct frame *f;
13020 struct window *w;
13021 int root_x, root_y;
13022 struct buffer *old_buffer;
13023 struct text_pos pos;
13024 int i, width, height;
13025 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
13026 int old_windows_or_buffers_changed = windows_or_buffers_changed;
13027 int count = SPECPDL_INDEX ();
13029 specbind (Qinhibit_redisplay, Qt);
13031 GCPRO4 (string, parms, frame, timeout);
13033 CHECK_STRING (string);
13034 f = check_x_frame (frame);
13035 if (NILP (timeout))
13036 timeout = make_number (5);
13037 else
13038 CHECK_NATNUM (timeout);
13040 if (NILP (dx))
13041 dx = make_number (5);
13042 else
13043 CHECK_NUMBER (dx);
13045 if (NILP (dy))
13046 dy = make_number (-10);
13047 else
13048 CHECK_NUMBER (dy);
13050 if (NILP (last_show_tip_args))
13051 last_show_tip_args = Fmake_vector (make_number (3), Qnil);
13053 if (!NILP (tip_frame))
13055 Lisp_Object last_string = AREF (last_show_tip_args, 0);
13056 Lisp_Object last_frame = AREF (last_show_tip_args, 1);
13057 Lisp_Object last_parms = AREF (last_show_tip_args, 2);
13059 if (EQ (frame, last_frame)
13060 && !NILP (Fequal (last_string, string))
13061 && !NILP (Fequal (last_parms, parms)))
13063 struct frame *f = XFRAME (tip_frame);
13065 /* Only DX and DY have changed. */
13066 if (!NILP (tip_timer))
13068 Lisp_Object timer = tip_timer;
13069 tip_timer = Qnil;
13070 call1 (Qcancel_timer, timer);
13073 BLOCK_INPUT;
13074 compute_tip_xy (f, parms, dx, dy, PIXEL_WIDTH (f),
13075 PIXEL_HEIGHT (f), &root_x, &root_y);
13077 /* Put tooltip in topmost group and in position. */
13078 SetWindowPos (FRAME_W32_WINDOW (f), HWND_TOPMOST,
13079 root_x, root_y, 0, 0,
13080 SWP_NOSIZE | SWP_NOACTIVATE);
13082 /* Ensure tooltip is on top of other topmost windows (eg menus). */
13083 SetWindowPos (FRAME_W32_WINDOW (f), HWND_TOP,
13084 0, 0, 0, 0,
13085 SWP_NOMOVE | SWP_NOSIZE | SWP_NOACTIVATE);
13087 UNBLOCK_INPUT;
13088 goto start_timer;
13092 /* Hide a previous tip, if any. */
13093 Fx_hide_tip ();
13095 ASET (last_show_tip_args, 0, string);
13096 ASET (last_show_tip_args, 1, frame);
13097 ASET (last_show_tip_args, 2, parms);
13099 /* Add default values to frame parameters. */
13100 if (NILP (Fassq (Qname, parms)))
13101 parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms);
13102 if (NILP (Fassq (Qinternal_border_width, parms)))
13103 parms = Fcons (Fcons (Qinternal_border_width, make_number (3)), parms);
13104 if (NILP (Fassq (Qborder_width, parms)))
13105 parms = Fcons (Fcons (Qborder_width, make_number (1)), parms);
13106 if (NILP (Fassq (Qborder_color, parms)))
13107 parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms);
13108 if (NILP (Fassq (Qbackground_color, parms)))
13109 parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")),
13110 parms);
13112 /* Block input until the tip has been fully drawn, to avoid crashes
13113 when drawing tips in menus. */
13114 BLOCK_INPUT;
13116 /* Create a frame for the tooltip, and record it in the global
13117 variable tip_frame. */
13118 frame = x_create_tip_frame (FRAME_W32_DISPLAY_INFO (f), parms, string);
13119 f = XFRAME (frame);
13121 /* Set up the frame's root window. */
13122 w = XWINDOW (FRAME_ROOT_WINDOW (f));
13123 w->left = w->top = make_number (0);
13125 if (CONSP (Vx_max_tooltip_size)
13126 && INTEGERP (XCAR (Vx_max_tooltip_size))
13127 && XINT (XCAR (Vx_max_tooltip_size)) > 0
13128 && INTEGERP (XCDR (Vx_max_tooltip_size))
13129 && XINT (XCDR (Vx_max_tooltip_size)) > 0)
13131 w->width = XCAR (Vx_max_tooltip_size);
13132 w->height = XCDR (Vx_max_tooltip_size);
13134 else
13136 w->width = make_number (80);
13137 w->height = make_number (40);
13140 f->window_width = XINT (w->width);
13141 adjust_glyphs (f);
13142 w->pseudo_window_p = 1;
13144 /* Display the tooltip text in a temporary buffer. */
13145 old_buffer = current_buffer;
13146 set_buffer_internal_1 (XBUFFER (XWINDOW (FRAME_ROOT_WINDOW (f))->buffer));
13147 current_buffer->truncate_lines = Qnil;
13148 clear_glyph_matrix (w->desired_matrix);
13149 clear_glyph_matrix (w->current_matrix);
13150 SET_TEXT_POS (pos, BEGV, BEGV_BYTE);
13151 try_window (FRAME_ROOT_WINDOW (f), pos);
13153 /* Compute width and height of the tooltip. */
13154 width = height = 0;
13155 for (i = 0; i < w->desired_matrix->nrows; ++i)
13157 struct glyph_row *row = &w->desired_matrix->rows[i];
13158 struct glyph *last;
13159 int row_width;
13161 /* Stop at the first empty row at the end. */
13162 if (!row->enabled_p || !row->displays_text_p)
13163 break;
13165 /* Let the row go over the full width of the frame. */
13166 row->full_width_p = 1;
13168 #ifdef TODO /* Investigate why some fonts need more width than is
13169 calculated for some tooltips. */
13170 /* There's a glyph at the end of rows that is use to place
13171 the cursor there. Don't include the width of this glyph. */
13172 if (row->used[TEXT_AREA])
13174 last = &row->glyphs[TEXT_AREA][row->used[TEXT_AREA] - 1];
13175 row_width = row->pixel_width - last->pixel_width;
13177 else
13178 #endif
13179 row_width = row->pixel_width;
13181 /* TODO: find why tips do not draw along baseline as instructed. */
13182 height += row->height;
13183 width = max (width, row_width);
13186 /* Add the frame's internal border to the width and height the X
13187 window should have. */
13188 height += 2 * FRAME_INTERNAL_BORDER_WIDTH (f);
13189 width += 2 * FRAME_INTERNAL_BORDER_WIDTH (f);
13191 /* Move the tooltip window where the mouse pointer is. Resize and
13192 show it. */
13193 compute_tip_xy (f, parms, dx, dy, width, height, &root_x, &root_y);
13196 /* Adjust Window size to take border into account. */
13197 RECT rect;
13198 rect.left = rect.top = 0;
13199 rect.right = width;
13200 rect.bottom = height;
13201 AdjustWindowRect (&rect, f->output_data.w32->dwStyle,
13202 FRAME_EXTERNAL_MENU_BAR (f));
13204 /* Position and size tooltip, and put it in the topmost group. */
13205 SetWindowPos (FRAME_W32_WINDOW (f), HWND_TOPMOST,
13206 root_x, root_y, rect.right - rect.left,
13207 rect.bottom - rect.top, SWP_NOACTIVATE);
13209 /* Ensure tooltip is on top of other topmost windows (eg menus). */
13210 SetWindowPos (FRAME_W32_WINDOW (f), HWND_TOP,
13211 0, 0, 0, 0,
13212 SWP_NOMOVE | SWP_NOSIZE | SWP_NOACTIVATE);
13214 /* Let redisplay know that we have made the frame visible already. */
13215 f->async_visible = 1;
13217 ShowWindow (FRAME_W32_WINDOW (f), SW_SHOWNOACTIVATE);
13220 /* Draw into the window. */
13221 w->must_be_updated_p = 1;
13222 update_single_window (w, 1);
13224 UNBLOCK_INPUT;
13226 /* Restore original current buffer. */
13227 set_buffer_internal_1 (old_buffer);
13228 windows_or_buffers_changed = old_windows_or_buffers_changed;
13230 start_timer:
13231 /* Let the tip disappear after timeout seconds. */
13232 tip_timer = call3 (intern ("run-at-time"), timeout, Qnil,
13233 intern ("x-hide-tip"));
13235 UNGCPRO;
13236 return unbind_to (count, Qnil);
13240 DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0,
13241 doc: /* Hide the current tooltip window, if there is any.
13242 Value is t if tooltip was open, nil otherwise. */)
13245 int count;
13246 Lisp_Object deleted, frame, timer;
13247 struct gcpro gcpro1, gcpro2;
13249 /* Return quickly if nothing to do. */
13250 if (NILP (tip_timer) && NILP (tip_frame))
13251 return Qnil;
13253 frame = tip_frame;
13254 timer = tip_timer;
13255 GCPRO2 (frame, timer);
13256 tip_frame = tip_timer = deleted = Qnil;
13258 count = SPECPDL_INDEX ();
13259 specbind (Qinhibit_redisplay, Qt);
13260 specbind (Qinhibit_quit, Qt);
13262 if (!NILP (timer))
13263 call1 (Qcancel_timer, timer);
13265 if (FRAMEP (frame))
13267 Fdelete_frame (frame, Qnil);
13268 deleted = Qt;
13271 UNGCPRO;
13272 return unbind_to (count, deleted);
13277 /***********************************************************************
13278 File selection dialog
13279 ***********************************************************************/
13280 extern Lisp_Object Qfile_name_history;
13282 /* Callback for altering the behaviour of the Open File dialog.
13283 Makes the Filename text field contain "Current Directory" and be
13284 read-only when "Directories" is selected in the filter. This
13285 allows us to work around the fact that the standard Open File
13286 dialog does not support directories. */
13287 UINT CALLBACK
13288 file_dialog_callback (hwnd, msg, wParam, lParam)
13289 HWND hwnd;
13290 UINT msg;
13291 WPARAM wParam;
13292 LPARAM lParam;
13294 if (msg == WM_NOTIFY)
13296 OFNOTIFY * notify = (OFNOTIFY *)lParam;
13297 /* Detect when the Filter dropdown is changed. */
13298 if (notify->hdr.code == CDN_TYPECHANGE)
13300 HWND dialog = GetParent (hwnd);
13301 HWND edit_control = GetDlgItem (dialog, FILE_NAME_TEXT_FIELD);
13303 /* Directories is in index 2. */
13304 if (notify->lpOFN->nFilterIndex == 2)
13306 CommDlg_OpenSave_SetControlText (dialog, FILE_NAME_TEXT_FIELD,
13307 "Current Directory");
13308 EnableWindow (edit_control, FALSE);
13310 else
13312 CommDlg_OpenSave_SetControlText (dialog, FILE_NAME_TEXT_FIELD,
13313 "");
13314 EnableWindow (edit_control, TRUE);
13318 return 0;
13321 DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 4, 0,
13322 doc: /* Read file name, prompting with PROMPT in directory DIR.
13323 Use a file selection dialog.
13324 Select DEFAULT-FILENAME in the dialog's file selection box, if
13325 specified. Ensure that file exists if MUSTMATCH is non-nil. */)
13326 (prompt, dir, default_filename, mustmatch)
13327 Lisp_Object prompt, dir, default_filename, mustmatch;
13329 struct frame *f = SELECTED_FRAME ();
13330 Lisp_Object file = Qnil;
13331 int count = SPECPDL_INDEX ();
13332 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
13333 char filename[MAX_PATH + 1];
13334 char init_dir[MAX_PATH + 1];
13336 GCPRO5 (prompt, dir, default_filename, mustmatch, file);
13337 CHECK_STRING (prompt);
13338 CHECK_STRING (dir);
13340 /* Create the dialog with PROMPT as title, using DIR as initial
13341 directory and using "*" as pattern. */
13342 dir = Fexpand_file_name (dir, Qnil);
13343 strncpy (init_dir, SDATA (dir), MAX_PATH);
13344 init_dir[MAX_PATH] = '\0';
13345 unixtodos_filename (init_dir);
13347 if (STRINGP (default_filename))
13349 char *file_name_only;
13350 char *full_path_name = SDATA (default_filename);
13352 unixtodos_filename (full_path_name);
13354 file_name_only = strrchr (full_path_name, '\\');
13355 if (!file_name_only)
13356 file_name_only = full_path_name;
13357 else
13359 file_name_only++;
13362 strncpy (filename, file_name_only, MAX_PATH);
13363 filename[MAX_PATH] = '\0';
13365 else
13366 filename[0] = '\0';
13369 OPENFILENAME file_details;
13371 /* Prevent redisplay. */
13372 specbind (Qinhibit_redisplay, Qt);
13373 BLOCK_INPUT;
13375 bzero (&file_details, sizeof (file_details));
13376 file_details.lStructSize = sizeof (file_details);
13377 file_details.hwndOwner = FRAME_W32_WINDOW (f);
13378 /* Undocumented Bug in Common File Dialog:
13379 If a filter is not specified, shell links are not resolved. */
13380 file_details.lpstrFilter = "All Files (*.*)\0*.*\0Directories\0*|*\0\0";
13381 file_details.lpstrFile = filename;
13382 file_details.nMaxFile = sizeof (filename);
13383 file_details.lpstrInitialDir = init_dir;
13384 file_details.lpstrTitle = SDATA (prompt);
13385 file_details.Flags = (OFN_HIDEREADONLY | OFN_NOCHANGEDIR
13386 | OFN_EXPLORER | OFN_ENABLEHOOK);
13387 if (!NILP (mustmatch))
13388 file_details.Flags |= OFN_FILEMUSTEXIST | OFN_PATHMUSTEXIST;
13390 file_details.lpfnHook = (LPOFNHOOKPROC) file_dialog_callback;
13392 if (GetOpenFileName (&file_details))
13394 dostounix_filename (filename);
13395 if (file_details.nFilterIndex == 2)
13397 /* "Folder Only" selected - strip dummy file name. */
13398 char * last = strrchr (filename, '/');
13399 *last = '\0';
13402 file = DECODE_FILE(build_string (filename));
13404 /* User cancelled the dialog without making a selection. */
13405 else if (!CommDlgExtendedError ())
13406 file = Qnil;
13407 /* An error occurred, fallback on reading from the mini-buffer. */
13408 else
13409 file = Fcompleting_read (prompt, intern ("read-file-name-internal"),
13410 dir, mustmatch, dir, Qfile_name_history,
13411 default_filename, Qnil);
13413 UNBLOCK_INPUT;
13414 file = unbind_to (count, file);
13417 UNGCPRO;
13419 /* Make "Cancel" equivalent to C-g. */
13420 if (NILP (file))
13421 Fsignal (Qquit, Qnil);
13423 return unbind_to (count, file);
13428 /***********************************************************************
13429 w32 specialized functions
13430 ***********************************************************************/
13432 DEFUN ("w32-select-font", Fw32_select_font, Sw32_select_font, 0, 2, 0,
13433 doc: /* Select a font using the W32 font dialog.
13434 Returns an X font string corresponding to the selection. */)
13435 (frame, include_proportional)
13436 Lisp_Object frame, include_proportional;
13438 FRAME_PTR f = check_x_frame (frame);
13439 CHOOSEFONT cf;
13440 LOGFONT lf;
13441 TEXTMETRIC tm;
13442 HDC hdc;
13443 HANDLE oldobj;
13444 char buf[100];
13446 bzero (&cf, sizeof (cf));
13447 bzero (&lf, sizeof (lf));
13449 cf.lStructSize = sizeof (cf);
13450 cf.hwndOwner = FRAME_W32_WINDOW (f);
13451 cf.Flags = CF_FORCEFONTEXIST | CF_SCREENFONTS | CF_NOVERTFONTS;
13453 /* Unless include_proportional is non-nil, limit the selection to
13454 monospaced fonts. */
13455 if (NILP (include_proportional))
13456 cf.Flags |= CF_FIXEDPITCHONLY;
13458 cf.lpLogFont = &lf;
13460 /* Initialize as much of the font details as we can from the current
13461 default font. */
13462 hdc = GetDC (FRAME_W32_WINDOW (f));
13463 oldobj = SelectObject (hdc, FRAME_FONT (f)->hfont);
13464 GetTextFace (hdc, LF_FACESIZE, lf.lfFaceName);
13465 if (GetTextMetrics (hdc, &tm))
13467 lf.lfHeight = tm.tmInternalLeading - tm.tmHeight;
13468 lf.lfWeight = tm.tmWeight;
13469 lf.lfItalic = tm.tmItalic;
13470 lf.lfUnderline = tm.tmUnderlined;
13471 lf.lfStrikeOut = tm.tmStruckOut;
13472 lf.lfCharSet = tm.tmCharSet;
13473 cf.Flags |= CF_INITTOLOGFONTSTRUCT;
13475 SelectObject (hdc, oldobj);
13476 ReleaseDC (FRAME_W32_WINDOW (f), hdc);
13478 if (!ChooseFont (&cf) || !w32_to_x_font (&lf, buf, 100, NULL))
13479 return Qnil;
13481 return build_string (buf);
13484 DEFUN ("w32-send-sys-command", Fw32_send_sys_command,
13485 Sw32_send_sys_command, 1, 2, 0,
13486 doc: /* Send frame a Windows WM_SYSCOMMAND message of type COMMAND.
13487 Some useful values for command are #xf030 to maximise frame (#xf020
13488 to minimize), #xf120 to restore frame to original size, and #xf100
13489 to activate the menubar for keyboard access. #xf140 activates the
13490 screen saver if defined.
13492 If optional parameter FRAME is not specified, use selected frame. */)
13493 (command, frame)
13494 Lisp_Object command, frame;
13496 FRAME_PTR f = check_x_frame (frame);
13498 CHECK_NUMBER (command);
13500 PostMessage (FRAME_W32_WINDOW (f), WM_SYSCOMMAND, XINT (command), 0);
13502 return Qnil;
13505 DEFUN ("w32-shell-execute", Fw32_shell_execute, Sw32_shell_execute, 2, 4, 0,
13506 doc: /* Get Windows to perform OPERATION on DOCUMENT.
13507 This is a wrapper around the ShellExecute system function, which
13508 invokes the application registered to handle OPERATION for DOCUMENT.
13509 OPERATION is typically \"open\", \"print\" or \"explore\" (but can be
13510 nil for the default action), and DOCUMENT is typically the name of a
13511 document file or URL, but can also be a program executable to run or
13512 a directory to open in the Windows Explorer.
13514 If DOCUMENT is a program executable, PARAMETERS can be a string
13515 containing command line parameters, but otherwise should be nil.
13517 SHOW-FLAG can be used to control whether the invoked application is hidden
13518 or minimized. If SHOW-FLAG is nil, the application is displayed normally,
13519 otherwise it is an integer representing a ShowWindow flag:
13521 0 - start hidden
13522 1 - start normally
13523 3 - start maximized
13524 6 - start minimized */)
13525 (operation, document, parameters, show_flag)
13526 Lisp_Object operation, document, parameters, show_flag;
13528 Lisp_Object current_dir;
13530 CHECK_STRING (document);
13532 /* Encode filename and current directory. */
13533 current_dir = ENCODE_FILE (current_buffer->directory);
13534 document = ENCODE_FILE (document);
13535 if ((int) ShellExecute (NULL,
13536 (STRINGP (operation) ?
13537 SDATA (operation) : NULL),
13538 SDATA (document),
13539 (STRINGP (parameters) ?
13540 SDATA (parameters) : NULL),
13541 SDATA (current_dir),
13542 (INTEGERP (show_flag) ?
13543 XINT (show_flag) : SW_SHOWDEFAULT))
13544 > 32)
13545 return Qt;
13546 error ("ShellExecute failed: %s", w32_strerror (0));
13549 /* Lookup virtual keycode from string representing the name of a
13550 non-ascii keystroke into the corresponding virtual key, using
13551 lispy_function_keys. */
13552 static int
13553 lookup_vk_code (char *key)
13555 int i;
13557 for (i = 0; i < 256; i++)
13558 if (lispy_function_keys[i] != 0
13559 && strcmp (lispy_function_keys[i], key) == 0)
13560 return i;
13562 return -1;
13565 /* Convert a one-element vector style key sequence to a hot key
13566 definition. */
13567 static int
13568 w32_parse_hot_key (key)
13569 Lisp_Object key;
13571 /* Copied from Fdefine_key and store_in_keymap. */
13572 register Lisp_Object c;
13573 int vk_code;
13574 int lisp_modifiers;
13575 int w32_modifiers;
13576 struct gcpro gcpro1;
13578 CHECK_VECTOR (key);
13580 if (XFASTINT (Flength (key)) != 1)
13581 return Qnil;
13583 GCPRO1 (key);
13585 c = Faref (key, make_number (0));
13587 if (CONSP (c) && lucid_event_type_list_p (c))
13588 c = Fevent_convert_list (c);
13590 UNGCPRO;
13592 if (! INTEGERP (c) && ! SYMBOLP (c))
13593 error ("Key definition is invalid");
13595 /* Work out the base key and the modifiers. */
13596 if (SYMBOLP (c))
13598 c = parse_modifiers (c);
13599 lisp_modifiers = Fcar (Fcdr (c));
13600 c = Fcar (c);
13601 if (!SYMBOLP (c))
13602 abort ();
13603 vk_code = lookup_vk_code (SDATA (SYMBOL_NAME (c)));
13605 else if (INTEGERP (c))
13607 lisp_modifiers = XINT (c) & ~CHARACTERBITS;
13608 /* Many ascii characters are their own virtual key code. */
13609 vk_code = XINT (c) & CHARACTERBITS;
13612 if (vk_code < 0 || vk_code > 255)
13613 return Qnil;
13615 if ((lisp_modifiers & meta_modifier) != 0
13616 && !NILP (Vw32_alt_is_meta))
13617 lisp_modifiers |= alt_modifier;
13619 /* Supply defs missing from mingw32. */
13620 #ifndef MOD_ALT
13621 #define MOD_ALT 0x0001
13622 #define MOD_CONTROL 0x0002
13623 #define MOD_SHIFT 0x0004
13624 #define MOD_WIN 0x0008
13625 #endif
13627 /* Convert lisp modifiers to Windows hot-key form. */
13628 w32_modifiers = (lisp_modifiers & hyper_modifier) ? MOD_WIN : 0;
13629 w32_modifiers |= (lisp_modifiers & alt_modifier) ? MOD_ALT : 0;
13630 w32_modifiers |= (lisp_modifiers & ctrl_modifier) ? MOD_CONTROL : 0;
13631 w32_modifiers |= (lisp_modifiers & shift_modifier) ? MOD_SHIFT : 0;
13633 return HOTKEY (vk_code, w32_modifiers);
13636 DEFUN ("w32-register-hot-key", Fw32_register_hot_key,
13637 Sw32_register_hot_key, 1, 1, 0,
13638 doc: /* Register KEY as a hot-key combination.
13639 Certain key combinations like Alt-Tab are reserved for system use on
13640 Windows, and therefore are normally intercepted by the system. However,
13641 most of these key combinations can be received by registering them as
13642 hot-keys, overriding their special meaning.
13644 KEY must be a one element key definition in vector form that would be
13645 acceptable to `define-key' (e.g. [A-tab] for Alt-Tab). The meta
13646 modifier is interpreted as Alt if `w32-alt-is-meta' is t, and hyper
13647 is always interpreted as the Windows modifier keys.
13649 The return value is the hotkey-id if registered, otherwise nil. */)
13650 (key)
13651 Lisp_Object key;
13653 key = w32_parse_hot_key (key);
13655 if (NILP (Fmemq (key, w32_grabbed_keys)))
13657 /* Reuse an empty slot if possible. */
13658 Lisp_Object item = Fmemq (Qnil, w32_grabbed_keys);
13660 /* Safe to add new key to list, even if we have focus. */
13661 if (NILP (item))
13662 w32_grabbed_keys = Fcons (key, w32_grabbed_keys);
13663 else
13664 XSETCAR (item, key);
13666 /* Notify input thread about new hot-key definition, so that it
13667 takes effect without needing to switch focus. */
13668 PostThreadMessage (dwWindowsThreadId, WM_EMACS_REGISTER_HOT_KEY,
13669 (WPARAM) key, 0);
13672 return key;
13675 DEFUN ("w32-unregister-hot-key", Fw32_unregister_hot_key,
13676 Sw32_unregister_hot_key, 1, 1, 0,
13677 doc: /* Unregister HOTKEY as a hot-key combination. */)
13678 (key)
13679 Lisp_Object key;
13681 Lisp_Object item;
13683 if (!INTEGERP (key))
13684 key = w32_parse_hot_key (key);
13686 item = Fmemq (key, w32_grabbed_keys);
13688 if (!NILP (item))
13690 /* Notify input thread about hot-key definition being removed, so
13691 that it takes effect without needing focus switch. */
13692 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_UNREGISTER_HOT_KEY,
13693 (WPARAM) XINT (XCAR (item)), (LPARAM) item))
13695 MSG msg;
13696 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
13698 return Qt;
13700 return Qnil;
13703 DEFUN ("w32-registered-hot-keys", Fw32_registered_hot_keys,
13704 Sw32_registered_hot_keys, 0, 0, 0,
13705 doc: /* Return list of registered hot-key IDs. */)
13708 return Fcopy_sequence (w32_grabbed_keys);
13711 DEFUN ("w32-reconstruct-hot-key", Fw32_reconstruct_hot_key,
13712 Sw32_reconstruct_hot_key, 1, 1, 0,
13713 doc: /* Convert hot-key ID to a lisp key combination. */)
13714 (hotkeyid)
13715 Lisp_Object hotkeyid;
13717 int vk_code, w32_modifiers;
13718 Lisp_Object key;
13720 CHECK_NUMBER (hotkeyid);
13722 vk_code = HOTKEY_VK_CODE (hotkeyid);
13723 w32_modifiers = HOTKEY_MODIFIERS (hotkeyid);
13725 if (lispy_function_keys[vk_code])
13726 key = intern (lispy_function_keys[vk_code]);
13727 else
13728 key = make_number (vk_code);
13730 key = Fcons (key, Qnil);
13731 if (w32_modifiers & MOD_SHIFT)
13732 key = Fcons (Qshift, key);
13733 if (w32_modifiers & MOD_CONTROL)
13734 key = Fcons (Qctrl, key);
13735 if (w32_modifiers & MOD_ALT)
13736 key = Fcons (NILP (Vw32_alt_is_meta) ? Qalt : Qmeta, key);
13737 if (w32_modifiers & MOD_WIN)
13738 key = Fcons (Qhyper, key);
13740 return key;
13743 DEFUN ("w32-toggle-lock-key", Fw32_toggle_lock_key,
13744 Sw32_toggle_lock_key, 1, 2, 0,
13745 doc: /* Toggle the state of the lock key KEY.
13746 KEY can be `capslock', `kp-numlock', or `scroll'.
13747 If the optional parameter NEW-STATE is a number, then the state of KEY
13748 is set to off if the low bit of NEW-STATE is zero, otherwise on. */)
13749 (key, new_state)
13750 Lisp_Object key, new_state;
13752 int vk_code;
13754 if (EQ (key, intern ("capslock")))
13755 vk_code = VK_CAPITAL;
13756 else if (EQ (key, intern ("kp-numlock")))
13757 vk_code = VK_NUMLOCK;
13758 else if (EQ (key, intern ("scroll")))
13759 vk_code = VK_SCROLL;
13760 else
13761 return Qnil;
13763 if (!dwWindowsThreadId)
13764 return make_number (w32_console_toggle_lock_key (vk_code, new_state));
13766 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_TOGGLE_LOCK_KEY,
13767 (WPARAM) vk_code, (LPARAM) new_state))
13769 MSG msg;
13770 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
13771 return make_number (msg.wParam);
13773 return Qnil;
13776 DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0,
13777 doc: /* Return storage information about the file system FILENAME is on.
13778 Value is a list of floats (TOTAL FREE AVAIL), where TOTAL is the total
13779 storage of the file system, FREE is the free storage, and AVAIL is the
13780 storage available to a non-superuser. All 3 numbers are in bytes.
13781 If the underlying system call fails, value is nil. */)
13782 (filename)
13783 Lisp_Object filename;
13785 Lisp_Object encoded, value;
13787 CHECK_STRING (filename);
13788 filename = Fexpand_file_name (filename, Qnil);
13789 encoded = ENCODE_FILE (filename);
13791 value = Qnil;
13793 /* Determining the required information on Windows turns out, sadly,
13794 to be more involved than one would hope. The original Win32 api
13795 call for this will return bogus information on some systems, but we
13796 must dynamically probe for the replacement api, since that was
13797 added rather late on. */
13799 HMODULE hKernel = GetModuleHandle ("kernel32");
13800 BOOL (*pfn_GetDiskFreeSpaceEx)
13801 (char *, PULARGE_INTEGER, PULARGE_INTEGER, PULARGE_INTEGER)
13802 = (void *) GetProcAddress (hKernel, "GetDiskFreeSpaceEx");
13804 /* On Windows, we may need to specify the root directory of the
13805 volume holding FILENAME. */
13806 char rootname[MAX_PATH];
13807 char *name = SDATA (encoded);
13809 /* find the root name of the volume if given */
13810 if (isalpha (name[0]) && name[1] == ':')
13812 rootname[0] = name[0];
13813 rootname[1] = name[1];
13814 rootname[2] = '\\';
13815 rootname[3] = 0;
13817 else if (IS_DIRECTORY_SEP (name[0]) && IS_DIRECTORY_SEP (name[1]))
13819 char *str = rootname;
13820 int slashes = 4;
13823 if (IS_DIRECTORY_SEP (*name) && --slashes == 0)
13824 break;
13825 *str++ = *name++;
13827 while ( *name );
13829 *str++ = '\\';
13830 *str = 0;
13833 if (pfn_GetDiskFreeSpaceEx)
13835 /* Unsigned large integers cannot be cast to double, so
13836 use signed ones instead. */
13837 LARGE_INTEGER availbytes;
13838 LARGE_INTEGER freebytes;
13839 LARGE_INTEGER totalbytes;
13841 if (pfn_GetDiskFreeSpaceEx(rootname,
13842 (ULARGE_INTEGER *)&availbytes,
13843 (ULARGE_INTEGER *)&totalbytes,
13844 (ULARGE_INTEGER *)&freebytes))
13845 value = list3 (make_float ((double) totalbytes.QuadPart),
13846 make_float ((double) freebytes.QuadPart),
13847 make_float ((double) availbytes.QuadPart));
13849 else
13851 DWORD sectors_per_cluster;
13852 DWORD bytes_per_sector;
13853 DWORD free_clusters;
13854 DWORD total_clusters;
13856 if (GetDiskFreeSpace(rootname,
13857 &sectors_per_cluster,
13858 &bytes_per_sector,
13859 &free_clusters,
13860 &total_clusters))
13861 value = list3 (make_float ((double) total_clusters
13862 * sectors_per_cluster * bytes_per_sector),
13863 make_float ((double) free_clusters
13864 * sectors_per_cluster * bytes_per_sector),
13865 make_float ((double) free_clusters
13866 * sectors_per_cluster * bytes_per_sector));
13870 return value;
13873 /***********************************************************************
13874 Initialization
13875 ***********************************************************************/
13877 /* Keep this list in the same order as frame_parms in frame.c.
13878 Use 0 for unsupported frame parameters. */
13880 frame_parm_handler w32_frame_parm_handlers[] =
13882 x_set_autoraise,
13883 x_set_autolower,
13884 x_set_background_color,
13885 x_set_border_color,
13886 x_set_border_width,
13887 x_set_cursor_color,
13888 x_set_cursor_type,
13889 x_set_font,
13890 x_set_foreground_color,
13891 x_set_icon_name,
13892 x_set_icon_type,
13893 x_set_internal_border_width,
13894 x_set_menu_bar_lines,
13895 x_set_mouse_color,
13896 x_explicitly_set_name,
13897 x_set_scroll_bar_width,
13898 x_set_title,
13899 x_set_unsplittable,
13900 x_set_vertical_scroll_bars,
13901 x_set_visibility,
13902 x_set_tool_bar_lines,
13903 0, /* x_set_scroll_bar_foreground, */
13904 0, /* x_set_scroll_bar_background, */
13905 x_set_screen_gamma,
13906 x_set_line_spacing,
13907 x_set_fringe_width,
13908 x_set_fringe_width,
13909 0, /* x_set_wait_for_wm, */
13910 x_set_fullscreen,
13913 void
13914 syms_of_w32fns ()
13916 globals_of_w32fns ();
13917 /* This is zero if not using MS-Windows. */
13918 w32_in_use = 0;
13919 track_mouse_window = NULL;
13921 w32_visible_system_caret_hwnd = NULL;
13923 Qnone = intern ("none");
13924 staticpro (&Qnone);
13925 Qsuppress_icon = intern ("suppress-icon");
13926 staticpro (&Qsuppress_icon);
13927 Qundefined_color = intern ("undefined-color");
13928 staticpro (&Qundefined_color);
13929 Qcenter = intern ("center");
13930 staticpro (&Qcenter);
13931 Qcancel_timer = intern ("cancel-timer");
13932 staticpro (&Qcancel_timer);
13934 Qhyper = intern ("hyper");
13935 staticpro (&Qhyper);
13936 Qsuper = intern ("super");
13937 staticpro (&Qsuper);
13938 Qmeta = intern ("meta");
13939 staticpro (&Qmeta);
13940 Qalt = intern ("alt");
13941 staticpro (&Qalt);
13942 Qctrl = intern ("ctrl");
13943 staticpro (&Qctrl);
13944 Qcontrol = intern ("control");
13945 staticpro (&Qcontrol);
13946 Qshift = intern ("shift");
13947 staticpro (&Qshift);
13948 /* This is the end of symbol initialization. */
13950 /* Text property `display' should be nonsticky by default. */
13951 Vtext_property_default_nonsticky
13952 = Fcons (Fcons (Qdisplay, Qt), Vtext_property_default_nonsticky);
13955 Qlaplace = intern ("laplace");
13956 staticpro (&Qlaplace);
13957 Qemboss = intern ("emboss");
13958 staticpro (&Qemboss);
13959 Qedge_detection = intern ("edge-detection");
13960 staticpro (&Qedge_detection);
13961 Qheuristic = intern ("heuristic");
13962 staticpro (&Qheuristic);
13963 QCmatrix = intern (":matrix");
13964 staticpro (&QCmatrix);
13965 QCcolor_adjustment = intern (":color-adjustment");
13966 staticpro (&QCcolor_adjustment);
13967 QCmask = intern (":mask");
13968 staticpro (&QCmask);
13970 Fput (Qundefined_color, Qerror_conditions,
13971 Fcons (Qundefined_color, Fcons (Qerror, Qnil)));
13972 Fput (Qundefined_color, Qerror_message,
13973 build_string ("Undefined color"));
13975 staticpro (&w32_grabbed_keys);
13976 w32_grabbed_keys = Qnil;
13978 DEFVAR_LISP ("w32-color-map", &Vw32_color_map,
13979 doc: /* An array of color name mappings for windows. */);
13980 Vw32_color_map = Qnil;
13982 DEFVAR_LISP ("w32-pass-alt-to-system", &Vw32_pass_alt_to_system,
13983 doc: /* Non-nil if alt key presses are passed on to Windows.
13984 When non-nil, for example, alt pressed and released and then space will
13985 open the System menu. When nil, Emacs silently swallows alt key events. */);
13986 Vw32_pass_alt_to_system = Qnil;
13988 DEFVAR_LISP ("w32-alt-is-meta", &Vw32_alt_is_meta,
13989 doc: /* Non-nil if the alt key is to be considered the same as the meta key.
13990 When nil, Emacs will translate the alt key to the Alt modifier, and not Meta. */);
13991 Vw32_alt_is_meta = Qt;
13993 DEFVAR_INT ("w32-quit-key", &Vw32_quit_key,
13994 doc: /* If non-zero, the virtual key code for an alternative quit key. */);
13995 XSETINT (Vw32_quit_key, 0);
13997 DEFVAR_LISP ("w32-pass-lwindow-to-system",
13998 &Vw32_pass_lwindow_to_system,
13999 doc: /* Non-nil if the left \"Windows\" key is passed on to Windows.
14000 When non-nil, the Start menu is opened by tapping the key. */);
14001 Vw32_pass_lwindow_to_system = Qt;
14003 DEFVAR_LISP ("w32-pass-rwindow-to-system",
14004 &Vw32_pass_rwindow_to_system,
14005 doc: /* Non-nil if the right \"Windows\" key is passed on to Windows.
14006 When non-nil, the Start menu is opened by tapping the key. */);
14007 Vw32_pass_rwindow_to_system = Qt;
14009 DEFVAR_INT ("w32-phantom-key-code",
14010 &Vw32_phantom_key_code,
14011 doc: /* Virtual key code used to generate \"phantom\" key presses.
14012 Value is a number between 0 and 255.
14014 Phantom key presses are generated in order to stop the system from
14015 acting on \"Windows\" key events when `w32-pass-lwindow-to-system' or
14016 `w32-pass-rwindow-to-system' is nil. */);
14017 /* Although 255 is technically not a valid key code, it works and
14018 means that this hack won't interfere with any real key code. */
14019 Vw32_phantom_key_code = 255;
14021 DEFVAR_LISP ("w32-enable-num-lock",
14022 &Vw32_enable_num_lock,
14023 doc: /* Non-nil if Num Lock should act normally.
14024 Set to nil to see Num Lock as the key `kp-numlock'. */);
14025 Vw32_enable_num_lock = Qt;
14027 DEFVAR_LISP ("w32-enable-caps-lock",
14028 &Vw32_enable_caps_lock,
14029 doc: /* Non-nil if Caps Lock should act normally.
14030 Set to nil to see Caps Lock as the key `capslock'. */);
14031 Vw32_enable_caps_lock = Qt;
14033 DEFVAR_LISP ("w32-scroll-lock-modifier",
14034 &Vw32_scroll_lock_modifier,
14035 doc: /* Modifier to use for the Scroll Lock on state.
14036 The value can be hyper, super, meta, alt, control or shift for the
14037 respective modifier, or nil to see Scroll Lock as the key `scroll'.
14038 Any other value will cause the key to be ignored. */);
14039 Vw32_scroll_lock_modifier = Qt;
14041 DEFVAR_LISP ("w32-lwindow-modifier",
14042 &Vw32_lwindow_modifier,
14043 doc: /* Modifier to use for the left \"Windows\" key.
14044 The value can be hyper, super, meta, alt, control or shift for the
14045 respective modifier, or nil to appear as the key `lwindow'.
14046 Any other value will cause the key to be ignored. */);
14047 Vw32_lwindow_modifier = Qnil;
14049 DEFVAR_LISP ("w32-rwindow-modifier",
14050 &Vw32_rwindow_modifier,
14051 doc: /* Modifier to use for the right \"Windows\" key.
14052 The value can be hyper, super, meta, alt, control or shift for the
14053 respective modifier, or nil to appear as the key `rwindow'.
14054 Any other value will cause the key to be ignored. */);
14055 Vw32_rwindow_modifier = Qnil;
14057 DEFVAR_LISP ("w32-apps-modifier",
14058 &Vw32_apps_modifier,
14059 doc: /* Modifier to use for the \"Apps\" key.
14060 The value can be hyper, super, meta, alt, control or shift for the
14061 respective modifier, or nil to appear as the key `apps'.
14062 Any other value will cause the key to be ignored. */);
14063 Vw32_apps_modifier = Qnil;
14065 DEFVAR_BOOL ("w32-enable-synthesized-fonts", &w32_enable_synthesized_fonts,
14066 doc: /* Non-nil enables selection of artificially italicized and bold fonts. */);
14067 w32_enable_synthesized_fonts = 0;
14069 DEFVAR_LISP ("w32-enable-palette", &Vw32_enable_palette,
14070 doc: /* Non-nil enables Windows palette management to map colors exactly. */);
14071 Vw32_enable_palette = Qt;
14073 DEFVAR_INT ("w32-mouse-button-tolerance",
14074 &Vw32_mouse_button_tolerance,
14075 doc: /* Analogue of double click interval for faking middle mouse events.
14076 The value is the minimum time in milliseconds that must elapse between
14077 left/right button down events before they are considered distinct events.
14078 If both mouse buttons are depressed within this interval, a middle mouse
14079 button down event is generated instead. */);
14080 XSETINT (Vw32_mouse_button_tolerance, GetDoubleClickTime () / 2);
14082 DEFVAR_INT ("w32-mouse-move-interval",
14083 &Vw32_mouse_move_interval,
14084 doc: /* Minimum interval between mouse move events.
14085 The value is the minimum time in milliseconds that must elapse between
14086 successive mouse move (or scroll bar drag) events before they are
14087 reported as lisp events. */);
14088 XSETINT (Vw32_mouse_move_interval, 0);
14090 DEFVAR_BOOL ("w32-pass-extra-mouse-buttons-to-system",
14091 &w32_pass_extra_mouse_buttons_to_system,
14092 doc: /* Non-nil if the fourth and fifth mouse buttons are passed to Windows.
14093 Recent versions of Windows support mice with up to five buttons.
14094 Since most applications don't support these extra buttons, most mouse
14095 drivers will allow you to map them to functions at the system level.
14096 If this variable is non-nil, Emacs will pass them on, allowing the
14097 system to handle them. */);
14098 w32_pass_extra_mouse_buttons_to_system = 0;
14100 DEFVAR_LISP ("x-bitmap-file-path", &Vx_bitmap_file_path,
14101 doc: /* List of directories to search for window system bitmap files. */);
14102 Vx_bitmap_file_path = decode_env_path ((char *) 0, "PATH");
14104 DEFVAR_LISP ("x-pointer-shape", &Vx_pointer_shape,
14105 doc: /* The shape of the pointer when over text.
14106 Changing the value does not affect existing frames
14107 unless you set the mouse color. */);
14108 Vx_pointer_shape = Qnil;
14110 Vx_nontext_pointer_shape = Qnil;
14112 Vx_mode_pointer_shape = Qnil;
14114 DEFVAR_LISP ("x-hourglass-pointer-shape", &Vx_hourglass_pointer_shape,
14115 doc: /* The shape of the pointer when Emacs is busy.
14116 This variable takes effect when you create a new frame
14117 or when you set the mouse color. */);
14118 Vx_hourglass_pointer_shape = Qnil;
14120 DEFVAR_BOOL ("display-hourglass", &display_hourglass_p,
14121 doc: /* Non-zero means Emacs displays an hourglass pointer on window systems. */);
14122 display_hourglass_p = 1;
14124 DEFVAR_LISP ("hourglass-delay", &Vhourglass_delay,
14125 doc: /* *Seconds to wait before displaying an hourglass pointer.
14126 Value must be an integer or float. */);
14127 Vhourglass_delay = make_number (DEFAULT_HOURGLASS_DELAY);
14129 DEFVAR_LISP ("x-sensitive-text-pointer-shape",
14130 &Vx_sensitive_text_pointer_shape,
14131 doc: /* The shape of the pointer when over mouse-sensitive text.
14132 This variable takes effect when you create a new frame
14133 or when you set the mouse color. */);
14134 Vx_sensitive_text_pointer_shape = Qnil;
14136 DEFVAR_LISP ("x-window-horizontal-drag-cursor",
14137 &Vx_window_horizontal_drag_shape,
14138 doc: /* Pointer shape to use for indicating a window can be dragged horizontally.
14139 This variable takes effect when you create a new frame
14140 or when you set the mouse color. */);
14141 Vx_window_horizontal_drag_shape = Qnil;
14143 DEFVAR_LISP ("x-cursor-fore-pixel", &Vx_cursor_fore_pixel,
14144 doc: /* A string indicating the foreground color of the cursor box. */);
14145 Vx_cursor_fore_pixel = Qnil;
14147 DEFVAR_LISP ("x-max-tooltip-size", &Vx_max_tooltip_size,
14148 doc: /* Maximum size for tooltips.
14149 Value is a pair (COLUMNS . ROWS). Text larger than this is clipped. */);
14150 Vx_max_tooltip_size = Fcons (make_number (80), make_number (40));
14152 DEFVAR_LISP ("x-no-window-manager", &Vx_no_window_manager,
14153 doc: /* Non-nil if no window manager is in use.
14154 Emacs doesn't try to figure this out; this is always nil
14155 unless you set it to something else. */);
14156 /* We don't have any way to find this out, so set it to nil
14157 and maybe the user would like to set it to t. */
14158 Vx_no_window_manager = Qnil;
14160 DEFVAR_LISP ("x-pixel-size-width-font-regexp",
14161 &Vx_pixel_size_width_font_regexp,
14162 doc: /* Regexp matching a font name whose width is the same as `PIXEL_SIZE'.
14164 Since Emacs gets width of a font matching with this regexp from
14165 PIXEL_SIZE field of the name, font finding mechanism gets faster for
14166 such a font. This is especially effective for such large fonts as
14167 Chinese, Japanese, and Korean. */);
14168 Vx_pixel_size_width_font_regexp = Qnil;
14170 DEFVAR_LISP ("image-cache-eviction-delay", &Vimage_cache_eviction_delay,
14171 doc: /* Time after which cached images are removed from the cache.
14172 When an image has not been displayed this many seconds, remove it
14173 from the image cache. Value must be an integer or nil with nil
14174 meaning don't clear the cache. */);
14175 Vimage_cache_eviction_delay = make_number (30 * 60);
14177 DEFVAR_LISP ("w32-bdf-filename-alist",
14178 &Vw32_bdf_filename_alist,
14179 doc: /* List of bdf fonts and their corresponding filenames. */);
14180 Vw32_bdf_filename_alist = Qnil;
14182 DEFVAR_BOOL ("w32-strict-fontnames",
14183 &w32_strict_fontnames,
14184 doc: /* Non-nil means only use fonts that are exact matches for those requested.
14185 Default is nil, which allows old fontnames that are not XLFD compliant,
14186 and allows third-party CJK display to work by specifying false charset
14187 fields to trick Emacs into translating to Big5, SJIS etc.
14188 Setting this to t will prevent wrong fonts being selected when
14189 fontsets are automatically created. */);
14190 w32_strict_fontnames = 0;
14192 DEFVAR_BOOL ("w32-strict-painting",
14193 &w32_strict_painting,
14194 doc: /* Non-nil means use strict rules for repainting frames.
14195 Set this to nil to get the old behaviour for repainting; this should
14196 only be necessary if the default setting causes problems. */);
14197 w32_strict_painting = 1;
14199 DEFVAR_LISP ("w32-charset-info-alist",
14200 &Vw32_charset_info_alist,
14201 doc: /* Alist linking Emacs character sets to Windows fonts and codepages.
14202 Each entry should be of the form:
14204 (CHARSET_NAME . (WINDOWS_CHARSET . CODEPAGE))
14206 where CHARSET_NAME is a string used in font names to identify the charset,
14207 WINDOWS_CHARSET is a symbol that can be one of:
14208 w32-charset-ansi, w32-charset-default, w32-charset-symbol,
14209 w32-charset-shiftjis, w32-charset-hangeul, w32-charset-gb2312,
14210 w32-charset-chinesebig5,
14211 #ifdef JOHAB_CHARSET
14212 w32-charset-johab, w32-charset-hebrew,
14213 w32-charset-arabic, w32-charset-greek, w32-charset-turkish,
14214 w32-charset-vietnamese, w32-charset-thai, w32-charset-easteurope,
14215 w32-charset-russian, w32-charset-mac, w32-charset-baltic,
14216 #endif
14217 #ifdef UNICODE_CHARSET
14218 w32-charset-unicode,
14219 #endif
14220 or w32-charset-oem.
14221 CODEPAGE should be an integer specifying the codepage that should be used
14222 to display the character set, t to do no translation and output as Unicode,
14223 or nil to do no translation and output as 8 bit (or multibyte on far-east
14224 versions of Windows) characters. */);
14225 Vw32_charset_info_alist = Qnil;
14227 staticpro (&Qw32_charset_ansi);
14228 Qw32_charset_ansi = intern ("w32-charset-ansi");
14229 staticpro (&Qw32_charset_symbol);
14230 Qw32_charset_symbol = intern ("w32-charset-symbol");
14231 staticpro (&Qw32_charset_shiftjis);
14232 Qw32_charset_shiftjis = intern ("w32-charset-shiftjis");
14233 staticpro (&Qw32_charset_hangeul);
14234 Qw32_charset_hangeul = intern ("w32-charset-hangeul");
14235 staticpro (&Qw32_charset_chinesebig5);
14236 Qw32_charset_chinesebig5 = intern ("w32-charset-chinesebig5");
14237 staticpro (&Qw32_charset_gb2312);
14238 Qw32_charset_gb2312 = intern ("w32-charset-gb2312");
14239 staticpro (&Qw32_charset_oem);
14240 Qw32_charset_oem = intern ("w32-charset-oem");
14242 #ifdef JOHAB_CHARSET
14244 static int w32_extra_charsets_defined = 1;
14245 DEFVAR_BOOL ("w32-extra-charsets-defined", &w32_extra_charsets_defined,
14246 doc: /* Internal variable. */);
14248 staticpro (&Qw32_charset_johab);
14249 Qw32_charset_johab = intern ("w32-charset-johab");
14250 staticpro (&Qw32_charset_easteurope);
14251 Qw32_charset_easteurope = intern ("w32-charset-easteurope");
14252 staticpro (&Qw32_charset_turkish);
14253 Qw32_charset_turkish = intern ("w32-charset-turkish");
14254 staticpro (&Qw32_charset_baltic);
14255 Qw32_charset_baltic = intern ("w32-charset-baltic");
14256 staticpro (&Qw32_charset_russian);
14257 Qw32_charset_russian = intern ("w32-charset-russian");
14258 staticpro (&Qw32_charset_arabic);
14259 Qw32_charset_arabic = intern ("w32-charset-arabic");
14260 staticpro (&Qw32_charset_greek);
14261 Qw32_charset_greek = intern ("w32-charset-greek");
14262 staticpro (&Qw32_charset_hebrew);
14263 Qw32_charset_hebrew = intern ("w32-charset-hebrew");
14264 staticpro (&Qw32_charset_vietnamese);
14265 Qw32_charset_vietnamese = intern ("w32-charset-vietnamese");
14266 staticpro (&Qw32_charset_thai);
14267 Qw32_charset_thai = intern ("w32-charset-thai");
14268 staticpro (&Qw32_charset_mac);
14269 Qw32_charset_mac = intern ("w32-charset-mac");
14271 #endif
14273 #ifdef UNICODE_CHARSET
14275 static int w32_unicode_charset_defined = 1;
14276 DEFVAR_BOOL ("w32-unicode-charset-defined",
14277 &w32_unicode_charset_defined,
14278 doc: /* Internal variable. */);
14280 staticpro (&Qw32_charset_unicode);
14281 Qw32_charset_unicode = intern ("w32-charset-unicode");
14282 #endif
14284 #if 0 /* TODO: Port to W32 */
14285 defsubr (&Sx_change_window_property);
14286 defsubr (&Sx_delete_window_property);
14287 defsubr (&Sx_window_property);
14288 #endif
14289 defsubr (&Sxw_display_color_p);
14290 defsubr (&Sx_display_grayscale_p);
14291 defsubr (&Sxw_color_defined_p);
14292 defsubr (&Sxw_color_values);
14293 defsubr (&Sx_server_max_request_size);
14294 defsubr (&Sx_server_vendor);
14295 defsubr (&Sx_server_version);
14296 defsubr (&Sx_display_pixel_width);
14297 defsubr (&Sx_display_pixel_height);
14298 defsubr (&Sx_display_mm_width);
14299 defsubr (&Sx_display_mm_height);
14300 defsubr (&Sx_display_screens);
14301 defsubr (&Sx_display_planes);
14302 defsubr (&Sx_display_color_cells);
14303 defsubr (&Sx_display_visual_class);
14304 defsubr (&Sx_display_backing_store);
14305 defsubr (&Sx_display_save_under);
14306 defsubr (&Sx_create_frame);
14307 defsubr (&Sx_open_connection);
14308 defsubr (&Sx_close_connection);
14309 defsubr (&Sx_display_list);
14310 defsubr (&Sx_synchronize);
14312 /* W32 specific functions */
14314 defsubr (&Sw32_focus_frame);
14315 defsubr (&Sw32_select_font);
14316 defsubr (&Sw32_define_rgb_color);
14317 defsubr (&Sw32_default_color_map);
14318 defsubr (&Sw32_load_color_file);
14319 defsubr (&Sw32_send_sys_command);
14320 defsubr (&Sw32_shell_execute);
14321 defsubr (&Sw32_register_hot_key);
14322 defsubr (&Sw32_unregister_hot_key);
14323 defsubr (&Sw32_registered_hot_keys);
14324 defsubr (&Sw32_reconstruct_hot_key);
14325 defsubr (&Sw32_toggle_lock_key);
14326 defsubr (&Sw32_find_bdf_fonts);
14328 defsubr (&Sfile_system_info);
14330 /* Setting callback functions for fontset handler. */
14331 get_font_info_func = w32_get_font_info;
14333 #if 0 /* This function pointer doesn't seem to be used anywhere.
14334 And the pointer assigned has the wrong type, anyway. */
14335 list_fonts_func = w32_list_fonts;
14336 #endif
14338 load_font_func = w32_load_font;
14339 find_ccl_program_func = w32_find_ccl_program;
14340 query_font_func = w32_query_font;
14341 set_frame_fontset_func = x_set_font;
14342 check_window_system_func = check_w32;
14344 /* Images. */
14345 Qxbm = intern ("xbm");
14346 staticpro (&Qxbm);
14347 QCconversion = intern (":conversion");
14348 staticpro (&QCconversion);
14349 QCheuristic_mask = intern (":heuristic-mask");
14350 staticpro (&QCheuristic_mask);
14351 QCcolor_symbols = intern (":color-symbols");
14352 staticpro (&QCcolor_symbols);
14353 QCascent = intern (":ascent");
14354 staticpro (&QCascent);
14355 QCmargin = intern (":margin");
14356 staticpro (&QCmargin);
14357 QCrelief = intern (":relief");
14358 staticpro (&QCrelief);
14359 Qpostscript = intern ("postscript");
14360 staticpro (&Qpostscript);
14361 QCloader = intern (":loader");
14362 staticpro (&QCloader);
14363 QCbounding_box = intern (":bounding-box");
14364 staticpro (&QCbounding_box);
14365 QCpt_width = intern (":pt-width");
14366 staticpro (&QCpt_width);
14367 QCpt_height = intern (":pt-height");
14368 staticpro (&QCpt_height);
14369 QCindex = intern (":index");
14370 staticpro (&QCindex);
14371 Qpbm = intern ("pbm");
14372 staticpro (&Qpbm);
14374 #if HAVE_XPM
14375 Qxpm = intern ("xpm");
14376 staticpro (&Qxpm);
14377 #endif
14379 #if HAVE_JPEG
14380 Qjpeg = intern ("jpeg");
14381 staticpro (&Qjpeg);
14382 #endif
14384 #if HAVE_TIFF
14385 Qtiff = intern ("tiff");
14386 staticpro (&Qtiff);
14387 #endif
14389 #if HAVE_GIF
14390 Qgif = intern ("gif");
14391 staticpro (&Qgif);
14392 #endif
14394 #if HAVE_PNG
14395 Qpng = intern ("png");
14396 staticpro (&Qpng);
14397 #endif
14399 defsubr (&Sclear_image_cache);
14400 defsubr (&Simage_size);
14401 defsubr (&Simage_mask_p);
14403 #if GLYPH_DEBUG
14404 defsubr (&Simagep);
14405 defsubr (&Slookup_image);
14406 #endif
14408 hourglass_atimer = NULL;
14409 hourglass_shown_p = 0;
14410 defsubr (&Sx_show_tip);
14411 defsubr (&Sx_hide_tip);
14412 tip_timer = Qnil;
14413 staticpro (&tip_timer);
14414 tip_frame = Qnil;
14415 staticpro (&tip_frame);
14417 last_show_tip_args = Qnil;
14418 staticpro (&last_show_tip_args);
14420 defsubr (&Sx_file_dialog);
14425 globals_of_w32fns is used to initialize those global variables that
14426 must always be initialized on startup even when the global variable
14427 initialized is non zero (see the function main in emacs.c).
14428 globals_of_w32fns is called from syms_of_w32fns when the global
14429 variable initialized is 0 and directly from main when initialized
14430 is non zero.
14432 void globals_of_w32fns ()
14434 HMODULE user32_lib = GetModuleHandle ("user32.dll");
14436 TrackMouseEvent not available in all versions of Windows, so must load
14437 it dynamically. Do it once, here, instead of every time it is used.
14439 track_mouse_event_fn = (TrackMouseEvent_Proc) GetProcAddress (user32_lib, "TrackMouseEvent");
14442 /* Initialize image types. Based on which libraries are available. */
14443 static void
14444 init_external_image_libraries ()
14446 HINSTANCE library;
14448 #if HAVE_XPM
14449 if ((library = LoadLibrary ("libXpm.dll")))
14451 if (init_xpm_functions (library))
14452 define_image_type (&xpm_type);
14455 #endif
14457 #if HAVE_JPEG
14458 /* Try loading jpeg library under probable names. */
14459 if ((library = LoadLibrary ("libjpeg.dll"))
14460 || (library = LoadLibrary ("jpeg-62.dll"))
14461 || (library = LoadLibrary ("jpeg.dll")))
14463 if (init_jpeg_functions (library))
14464 define_image_type (&jpeg_type);
14466 #endif
14468 #if HAVE_TIFF
14469 if (library = LoadLibrary ("libtiff.dll"))
14471 if (init_tiff_functions (library))
14472 define_image_type (&tiff_type);
14474 #endif
14476 #if HAVE_GIF
14477 if (library = LoadLibrary ("libungif.dll"))
14479 if (init_gif_functions (library))
14480 define_image_type (&gif_type);
14482 #endif
14484 #if HAVE_PNG
14485 /* Ensure zlib is loaded. Try debug version first. */
14486 if (!LoadLibrary ("zlibd.dll"))
14487 LoadLibrary ("zlib.dll");
14489 /* Try loading libpng under probable names. */
14490 if ((library = LoadLibrary ("libpng13d.dll"))
14491 || (library = LoadLibrary ("libpng13.dll"))
14492 || (library = LoadLibrary ("libpng12d.dll"))
14493 || (library = LoadLibrary ("libpng12.dll"))
14494 || (library = LoadLibrary ("libpng.dll")))
14496 if (init_png_functions (library))
14497 define_image_type (&png_type);
14499 #endif
14502 void
14503 init_xfns ()
14505 image_types = NULL;
14506 Vimage_types = Qnil;
14508 define_image_type (&pbm_type);
14509 define_image_type (&xbm_type);
14511 #if 0 /* TODO : Ghostscript support for W32 */
14512 define_image_type (&gs_type);
14513 #endif
14515 /* Image types that rely on external libraries are loaded dynamically
14516 if the library is available. */
14517 init_external_image_libraries ();
14520 #undef abort
14522 void
14523 w32_abort()
14525 int button;
14526 button = MessageBox (NULL,
14527 "A fatal error has occurred!\n\n"
14528 "Select Abort to exit, Retry to debug, Ignore to continue",
14529 "Emacs Abort Dialog",
14530 MB_ICONEXCLAMATION | MB_TASKMODAL
14531 | MB_SETFOREGROUND | MB_ABORTRETRYIGNORE);
14532 switch (button)
14534 case IDRETRY:
14535 DebugBreak ();
14536 break;
14537 case IDIGNORE:
14538 break;
14539 case IDABORT:
14540 default:
14541 abort ();
14542 break;
14546 /* For convenience when debugging. */
14548 w32_last_error()
14550 return GetLastError ();