X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/e9e23e2348ae0770e9ba24296f0f6d2e48d4ecf8..296808a500931376ad44f071d801564ed1372d47:/src/w32fns.c diff --git a/src/w32fns.c b/src/w32fns.c index 67b45abcf6..113305ccc9 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -1,5 +1,6 @@ /* Graphical user interface functions for the Microsoft W32 API. - Copyright (C) 1989, 92, 93, 94, 95, 1996 Free Software Foundation, Inc. + Copyright (C) 1989, 92, 93, 94, 95, 1996, 1997, 1998, 1999, 2000, 2001 + Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -20,29 +21,64 @@ Boston, MA 02111-1307, USA. */ /* Added by Kevin Gallo */ -#include #include + +#include #include +#include +#include #include "lisp.h" +#include "charset.h" +#include "dispextern.h" #include "w32term.h" +#include "keyboard.h" #include "frame.h" #include "window.h" #include "buffer.h" -#include "dispextern.h" -#include "keyboard.h" +#include "fontset.h" +#include "intervals.h" #include "blockinput.h" -#include "paths.h" +#include "epaths.h" #include "w32heap.h" #include "termhooks.h" +#include "coding.h" +#include "ccl.h" +#include "systime.h" + +#include "bitmaps/gray.xbm" #include +#include +#include + +#define max(a, b) ((a) > (b) ? (a) : (b)) -extern void abort (); extern void free_frame_menubar (); -extern struct scroll_bar *x_window_to_scroll_bar (); +extern double atof (); +extern int w32_console_toggle_lock_key (int vk_code, Lisp_Object new_state); extern int quit_char; +/* A definition of XColor for non-X frames. */ +#ifndef HAVE_X_WINDOWS +typedef struct { + unsigned long pixel; + unsigned short red, green, blue; + char flags; + char pad; +} XColor; +#endif + +extern char *lispy_function_keys[]; + +/* The gray bitmap `bitmaps/gray'. This is done because w32term.c uses + it, and including `bitmaps/gray' more than once is a problem when + config.h defines `static' as an empty replacement string. */ + +int gray_bitmap_width = gray_width; +int gray_bitmap_height = gray_height; +unsigned char *gray_bitmap_bits = gray_bits; + /* The colormap for converting color names to RGB values */ Lisp_Object Vw32_color_map; @@ -53,13 +89,45 @@ Lisp_Object Vw32_pass_alt_to_system; to alt_modifier. */ Lisp_Object Vw32_alt_is_meta; -/* Non nil if left window, right window, and application key events - are passed on to Windows. */ -Lisp_Object Vw32_pass_optional_keys_to_system; +/* If non-zero, the windows virtual key code for an alternative quit key. */ +Lisp_Object Vw32_quit_key; + +/* Non nil if left window key events are passed on to Windows (this only + affects whether "tapping" the key opens the Start menu). */ +Lisp_Object Vw32_pass_lwindow_to_system; -/* Switch to control whether we inhibit requests for italicised fonts (which - are synthesized, look ugly, and are trashed by cursor movement under NT). */ -Lisp_Object Vw32_enable_italics; +/* Non nil if right window key events are passed on to Windows (this + only affects whether "tapping" the key opens the Start menu). */ +Lisp_Object Vw32_pass_rwindow_to_system; + +/* Virtual key code used to generate "phantom" key presses in order + to stop system from acting on Windows key events. */ +Lisp_Object Vw32_phantom_key_code; + +/* Modifier associated with the left "Windows" key, or nil to act as a + normal key. */ +Lisp_Object Vw32_lwindow_modifier; + +/* Modifier associated with the right "Windows" key, or nil to act as a + normal key. */ +Lisp_Object Vw32_rwindow_modifier; + +/* Modifier associated with the "Apps" key, or nil to act as a normal + key. */ +Lisp_Object Vw32_apps_modifier; + +/* Value is nil if Num Lock acts as a function key. */ +Lisp_Object Vw32_enable_num_lock; + +/* Value is nil if Caps Lock acts as a function key. */ +Lisp_Object Vw32_enable_caps_lock; + +/* Modifier associated with Scroll Lock, or nil to act as a normal key. */ +Lisp_Object Vw32_scroll_lock_modifier; + +/* Switch to control whether we inhibit requests for synthesized bold + and italic versions of fonts. */ +Lisp_Object Vw32_enable_synthesized_fonts; /* Enable palette management. */ Lisp_Object Vw32_enable_palette; @@ -78,63 +146,64 @@ Lisp_Object Vx_resource_name; /* Non nil if no window manager is in use. */ Lisp_Object Vx_no_window_manager; +/* Non-zero means we're allowed to display a hourglass pointer. */ + +int display_hourglass_p; + /* The background and shape of the mouse pointer, and shape when not over text or in the modeline. */ + Lisp_Object Vx_pointer_shape, Vx_nontext_pointer_shape, Vx_mode_pointer_shape; +Lisp_Object Vx_hourglass_pointer_shape, Vx_window_horizontal_drag_shape; + /* The shape when over mouse-sensitive text. */ + Lisp_Object Vx_sensitive_text_pointer_shape; /* Color of chars displayed in cursor box. */ + Lisp_Object Vx_cursor_fore_pixel; +/* Nonzero if using Windows. */ + +static int w32_in_use; + /* Search path for bitmap files. */ + Lisp_Object Vx_bitmap_file_path; -/* Evaluate this expression to rebuild the section of syms_of_w32fns - that initializes and staticpros the symbols declared below. Note - that Emacs 18 has a bug that keeps C-x C-e from being able to - evaluate this expression. - -(progn - ;; Accumulate a list of the symbols we want to initialize from the - ;; declarations at the top of the file. - (goto-char (point-min)) - (search-forward "/\*&&& symbols declared here &&&*\/\n") - (let (symbol-list) - (while (looking-at "Lisp_Object \\(Q[a-z_]+\\)") - (setq symbol-list - (cons (buffer-substring (match-beginning 1) (match-end 1)) - symbol-list)) - (forward-line 1)) - (setq symbol-list (nreverse symbol-list)) - ;; Delete the section of syms_of_... where we initialize the symbols. - (search-forward "\n /\*&&& init symbols here &&&*\/\n") - (let ((start (point))) - (while (looking-at "^ Q") - (forward-line 2)) - (kill-region start (point))) - ;; Write a new symbol initialization section. - (while symbol-list - (insert (format " %s = intern (\"" (car symbol-list))) - (let ((start (point))) - (insert (substring (car symbol-list) 1)) - (subst-char-in-region start (point) ?_ ?-)) - (insert (format "\");\n staticpro (&%s);\n" (car symbol-list))) - (setq symbol-list (cdr symbol-list))))) - - */ - -/*&&& symbols declared here &&&*/ +/* Regexp matching a font name whose width is the same as `PIXEL_SIZE'. */ + +Lisp_Object Vx_pixel_size_width_font_regexp; + +/* Alist of bdf fonts and the files that define them. */ +Lisp_Object Vw32_bdf_filename_alist; + +Lisp_Object Vw32_system_coding_system; + +/* A flag to control whether fonts are matched strictly or not. */ +int w32_strict_fontnames; + +/* A flag to control whether we should only repaint if GetUpdateRect + indicates there is an update region. */ +int w32_strict_painting; + +/* Associative list linking character set strings to Windows codepages. */ +Lisp_Object Vw32_charset_info_alist; + +/* VIETNAMESE_CHARSET is not defined in some versions of MSVC. */ +#ifndef VIETNAMESE_CHARSET +#define VIETNAMESE_CHARSET 163 +#endif + Lisp_Object Qauto_raise; Lisp_Object Qauto_lower; -Lisp_Object Qbackground_color; Lisp_Object Qbar; Lisp_Object Qborder_color; Lisp_Object Qborder_width; Lisp_Object Qbox; Lisp_Object Qcursor_color; Lisp_Object Qcursor_type; -Lisp_Object Qforeground_color; Lisp_Object Qgeometry; Lisp_Object Qicon_left; Lisp_Object Qicon_top; @@ -148,7 +217,6 @@ Lisp_Object Qnone; Lisp_Object Qparent_id; Lisp_Object Qscroll_bar_width; Lisp_Object Qsuppress_icon; -Lisp_Object Qtop; Lisp_Object Qundefined_color; Lisp_Object Qvertical_scroll_bars; Lisp_Object Qvisibility; @@ -157,7 +225,51 @@ Lisp_Object Qx_frame_parameter; Lisp_Object Qx_resource_name; Lisp_Object Quser_position; Lisp_Object Quser_size; -Lisp_Object Qdisplay; +Lisp_Object Qscreen_gamma; +Lisp_Object Qline_spacing; +Lisp_Object Qcenter; +Lisp_Object Qcancel_timer; +Lisp_Object Qhyper; +Lisp_Object Qsuper; +Lisp_Object Qmeta; +Lisp_Object Qalt; +Lisp_Object Qctrl; +Lisp_Object Qcontrol; +Lisp_Object Qshift; + +Lisp_Object Qw32_charset_ansi; +Lisp_Object Qw32_charset_default; +Lisp_Object Qw32_charset_symbol; +Lisp_Object Qw32_charset_shiftjis; +Lisp_Object Qw32_charset_hangeul; +Lisp_Object Qw32_charset_gb2312; +Lisp_Object Qw32_charset_chinesebig5; +Lisp_Object Qw32_charset_oem; + +#ifndef JOHAB_CHARSET +#define JOHAB_CHARSET 130 +#endif +#ifdef JOHAB_CHARSET +Lisp_Object Qw32_charset_easteurope; +Lisp_Object Qw32_charset_turkish; +Lisp_Object Qw32_charset_baltic; +Lisp_Object Qw32_charset_russian; +Lisp_Object Qw32_charset_arabic; +Lisp_Object Qw32_charset_greek; +Lisp_Object Qw32_charset_hebrew; +Lisp_Object Qw32_charset_vietnamese; +Lisp_Object Qw32_charset_thai; +Lisp_Object Qw32_charset_johab; +Lisp_Object Qw32_charset_mac; +#endif + +#ifdef UNICODE_CHARSET +Lisp_Object Qw32_charset_unicode; +#endif + +extern Lisp_Object Qtop; +extern Lisp_Object Qdisplay; +extern Lisp_Object Qtool_bar_lines; /* State variables for emulating a three button mouse. */ #define LMOUSE 1 @@ -170,24 +282,49 @@ static unsigned mouse_button_timer; /* non-zero when timer is active */ static W32Msg saved_mouse_move_msg; static unsigned mouse_move_timer; +/* W95 mousewheel handler */ +unsigned int msh_mousewheel = 0; + #define MOUSE_BUTTON_ID 1 #define MOUSE_MOVE_ID 2 /* The below are defined in frame.c. */ + extern Lisp_Object Qheight, Qminibuffer, Qname, Qonly, Qwidth; -extern Lisp_Object Qunsplittable, Qmenu_bar_lines; +extern Lisp_Object Qunsplittable, Qmenu_bar_lines, Qbuffer_predicate, Qtitle; +extern Lisp_Object Qtool_bar_lines; extern Lisp_Object Vwindow_system_version; -extern Lisp_Object last_mouse_scroll_bar; -extern int last_mouse_scroll_bar_pos; +Lisp_Object Qface_set_after_frame_default; + +#ifdef GLYPH_DEBUG +int image_cache_refcount, dpyinfo_refcount; +#endif + /* From w32term.c. */ extern Lisp_Object Vw32_num_mouse_buttons; - -Time last_mouse_movement_time; +extern Lisp_Object Vw32_recognize_altgr; +/* Error if we are not connected to MS-Windows. */ +void +check_w32 () +{ + if (! w32_in_use) + error ("MS-Windows not in use or not initialized"); +} + +/* Nonzero if we can use mouse menus. + You should not call this unless HAVE_MENUS is defined. */ + +int +have_menus_p () +{ + return w32_in_use; +} + /* Extract a frame as a FRAME_PTR, defaulting to the selected frame and checking validity for W32. */ @@ -198,12 +335,9 @@ check_x_frame (frame) FRAME_PTR f; if (NILP (frame)) - f = selected_frame; - else - { - CHECK_LIVE_FRAME (frame, 0); - f = XFRAME (frame); - } + frame = selected_frame; + CHECK_LIVE_FRAME (frame, 0); + f = XFRAME (frame); if (! FRAME_W32_P (f)) error ("non-w32 frame used"); return f; @@ -219,8 +353,10 @@ check_x_display_info (frame) { if (NILP (frame)) { - if (FRAME_W32_P (selected_frame)) - return FRAME_W32_DISPLAY_INFO (selected_frame); + struct frame *sf = XFRAME (selected_frame); + + if (FRAME_W32_P (sf) && FRAME_LIVE_P (sf)) + return FRAME_W32_DISPLAY_INFO (sf); else return &one_w32_display_info; } @@ -251,15 +387,18 @@ x_window_to_frame (dpyinfo, wdesc) Lisp_Object tail, frame; struct frame *f; - for (tail = Vframe_list; GC_CONSP (tail); tail = XCONS (tail)->cdr) + for (tail = Vframe_list; GC_CONSP (tail); tail = XCDR (tail)) { - frame = XCONS (tail)->car; + frame = XCAR (tail); if (!GC_FRAMEP (frame)) continue; f = XFRAME (frame); - if (f->output_data.nothing == 1 - || FRAME_W32_DISPLAY_INFO (f) != dpyinfo) + if (!FRAME_W32_P (f) || FRAME_W32_DISPLAY_INFO (f) != dpyinfo) continue; + if (f->output_data.w32->hourglass_window == wdesc) + return f; + + /* TODO: Check tooltips when supported. */ if (FRAME_W32_WINDOW (f) == wdesc) return f; } @@ -389,10 +528,10 @@ x_create_bitmap_from_file (f, file) Lisp_Object file; { return -1; -#if 0 +#if 0 /* TODO : bitmap support */ struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f); unsigned int width, height; - Pixmap bitmap; + HBITMAP bitmap; int xhot, yhot, result, id; Lisp_Object found; int fd; @@ -415,7 +554,7 @@ x_create_bitmap_from_file (f, file) fd = openp (Vx_bitmap_file_path, file, "", &found, 0); if (fd < 0) return -1; - close (fd); + emacs_close (fd); filename = (char *) XSTRING (found)->data; @@ -440,12 +579,12 @@ x_create_bitmap_from_file (f, file) strcpy (dpyinfo->bitmaps[id - 1].file, XSTRING (file)->data); return id; -#endif +#endif /* TODO */ } /* Remove reference to bitmap with id number ID. */ -int +void x_destroy_bitmap (f, id) FRAME_PTR f; int id; @@ -461,7 +600,7 @@ x_destroy_bitmap (f, id) DeleteObject (dpyinfo->bitmaps[id - 1].pixmap); if (dpyinfo->bitmaps[id - 1].file) { - free (dpyinfo->bitmaps[id - 1].file); + xfree (dpyinfo->bitmaps[id - 1].file); dpyinfo->bitmaps[id - 1].file = NULL; } UNBLOCK_INPUT; @@ -481,7 +620,7 @@ x_destroy_all_bitmaps (dpyinfo) { DeleteObject (dpyinfo->bitmaps[i].pixmap); if (dpyinfo->bitmaps[i].file) - free (dpyinfo->bitmaps[i].file); + xfree (dpyinfo->bitmaps[i].file); } dpyinfo->bitmaps_last = 0; } @@ -516,55 +655,70 @@ enum x_frame_parm struct x_frame_parm_table { char *name; - void (*setter)( /* struct frame *frame, Lisp_Object val, oldval */ ); + void (*setter) P_ ((struct frame *, Lisp_Object, Lisp_Object)); }; -void x_set_foreground_color (); -void x_set_background_color (); -void x_set_mouse_color (); -void x_set_cursor_color (); -void x_set_border_color (); -void x_set_cursor_type (); -void x_set_icon_type (); -void x_set_icon_name (); -void x_set_font (); -void x_set_border_width (); -void x_set_internal_border_width (); -void x_explicitly_set_name (); -void x_set_autoraise (); -void x_set_autolower (); -void x_set_vertical_scroll_bars (); -void x_set_visibility (); -void x_set_menu_bar_lines (); -void x_set_scroll_bar_width (); -void x_set_unsplittable (); +static Lisp_Object unwind_create_frame P_ ((Lisp_Object)); +static Lisp_Object unwind_create_tip_frame P_ ((Lisp_Object)); +static void x_change_window_heights P_ ((Lisp_Object, int)); +/* TODO: Native Input Method support; see x_create_im. */ +void x_set_foreground_color P_ ((struct frame *, Lisp_Object, Lisp_Object)); +static void x_set_line_spacing P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_background_color P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_mouse_color P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_cursor_color P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_border_color P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_cursor_type P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_icon_type P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_icon_name P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_font P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_border_width P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_internal_border_width P_ ((struct frame *, Lisp_Object, + Lisp_Object)); +void x_explicitly_set_name P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_autoraise P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_autolower P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_vertical_scroll_bars P_ ((struct frame *, Lisp_Object, + Lisp_Object)); +void x_set_visibility P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_menu_bar_lines P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_scroll_bar_width P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_title P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_unsplittable P_ ((struct frame *, Lisp_Object, Lisp_Object)); +void x_set_tool_bar_lines P_ ((struct frame *, Lisp_Object, Lisp_Object)); +static void x_set_screen_gamma P_ ((struct frame *, Lisp_Object, Lisp_Object)); static struct x_frame_parm_table x_frame_parms[] = { - "foreground-color", x_set_foreground_color, + "auto-raise", x_set_autoraise, + "auto-lower", x_set_autolower, "background-color", x_set_background_color, - "mouse-color", x_set_mouse_color, - "cursor-color", x_set_cursor_color, "border-color", x_set_border_color, + "border-width", x_set_border_width, + "cursor-color", x_set_cursor_color, "cursor-type", x_set_cursor_type, - "icon-type", x_set_icon_type, - "icon-name", x_set_icon_name, "font", x_set_font, - "border-width", x_set_border_width, + "foreground-color", x_set_foreground_color, + "icon-name", x_set_icon_name, + "icon-type", x_set_icon_type, "internal-border-width", x_set_internal_border_width, - "name", x_explicitly_set_name, - "auto-raise", x_set_autoraise, - "auto-lower", x_set_autolower, - "vertical-scroll-bars", x_set_vertical_scroll_bars, - "visibility", x_set_visibility, "menu-bar-lines", x_set_menu_bar_lines, + "mouse-color", x_set_mouse_color, + "name", x_explicitly_set_name, "scroll-bar-width", x_set_scroll_bar_width, + "title", x_set_title, "unsplittable", x_set_unsplittable, + "vertical-scroll-bars", x_set_vertical_scroll_bars, + "visibility", x_set_visibility, + "tool-bar-lines", x_set_tool_bar_lines, + "screen-gamma", x_set_screen_gamma, + "line-spacing", x_set_line_spacing }; /* Attach the `x-frame-parameter' properties to the Lisp symbol names of parameters relevant to W32. */ +void init_x_parm_symbols () { int i; @@ -574,7 +728,7 @@ init_x_parm_symbols () make_number (i)); } -/* Change the parameters of FRAME as specified by ALIST. +/* Change the parameters of frame F as specified by ALIST. If a parameter is not specially recognized, do nothing; otherwise call the `x_set_...' function for that parameter. */ @@ -599,10 +753,12 @@ x_set_frame_parameters (f, alist) /* Record in these vectors all the parms specified. */ Lisp_Object *parms; Lisp_Object *values; - int i; + int i, p; int left_no_change = 0, top_no_change = 0; int icon_left_no_change = 0, icon_top_no_change = 0; + struct gcpro gcpro1, gcpro2; + i = 0; for (tail = alist; CONSP (tail); tail = Fcdr (tail)) i++; @@ -615,20 +771,58 @@ x_set_frame_parameters (f, alist) i = 0; for (tail = alist; CONSP (tail); tail = Fcdr (tail)) { - Lisp_Object elt, prop, val; + Lisp_Object elt; elt = Fcar (tail); parms[i] = Fcar (elt); values[i] = Fcdr (elt); i++; } + /* TAIL and ALIST are not used again below here. */ + alist = tail = Qnil; + + GCPRO2 (*parms, *values); + gcpro1.nvars = i; + gcpro2.nvars = i; + /* There is no need to gcpro LEFT, TOP, ICON_LEFT, or ICON_TOP, + because their values appear in VALUES and strings are not valid. */ top = left = Qunbound; icon_left = icon_top = Qunbound; /* Provide default values for HEIGHT and WIDTH. */ - width = FRAME_WIDTH (f); - height = FRAME_HEIGHT (f); + if (FRAME_NEW_WIDTH (f)) + width = FRAME_NEW_WIDTH (f); + else + width = FRAME_WIDTH (f); + + if (FRAME_NEW_HEIGHT (f)) + height = FRAME_NEW_HEIGHT (f); + else + height = FRAME_HEIGHT (f); + + /* Process foreground_color and background_color before anything else. + They are independent of other properties, but other properties (e.g., + cursor_color) are dependent upon them. */ + for (p = 0; p < i; p++) + { + Lisp_Object prop, val; + + prop = parms[p]; + val = values[p]; + if (EQ (prop, Qforeground_color) || EQ (prop, Qbackground_color)) + { + register Lisp_Object param_index, old_value; + + param_index = Fget (prop, Qx_frame_parameter); + old_value = get_frame_param (f, prop); + store_frame_param (f, prop, val); + if (NATNUMP (param_index) + && (XFASTINT (param_index) + < sizeof (x_frame_parms)/sizeof (x_frame_parms[0]))) + (*x_frame_parms[XINT (param_index)].setter)(f, val, old_value); + } + } /* Now process them in reverse of specified order. */ for (i--; i >= 0; i--) @@ -650,6 +844,9 @@ x_set_frame_parameters (f, alist) icon_top = val; else if (EQ (prop, Qicon_left)) icon_left = val; + else if (EQ (prop, Qforeground_color) || EQ (prop, Qbackground_color)) + /* Processed above. */ + continue; else { register Lisp_Object param_index, old_value; @@ -713,8 +910,9 @@ x_set_frame_parameters (f, alist) XSETFRAME (frame, f); - if (XINT (width) != FRAME_WIDTH (f) - || XINT (height) != FRAME_HEIGHT (f)) + if (width != FRAME_WIDTH (f) + || height != FRAME_HEIGHT (f) + || FRAME_NEW_HEIGHT (f) || FRAME_NEW_WIDTH (f)) Fset_frame_size (frame, make_number (width), make_number (height)); if ((!NILP (left) || !NILP (top)) @@ -735,18 +933,18 @@ x_set_frame_parameters (f, alist) if (leftpos < 0) f->output_data.w32->size_hint_flags |= XNegative; } - else if (CONSP (left) && EQ (XCONS (left)->car, Qminus) - && CONSP (XCONS (left)->cdr) - && INTEGERP (XCONS (XCONS (left)->cdr)->car)) + else if (CONSP (left) && EQ (XCAR (left), Qminus) + && CONSP (XCDR (left)) + && INTEGERP (XCAR (XCDR (left)))) { - leftpos = - XINT (XCONS (XCONS (left)->cdr)->car); + leftpos = - XINT (XCAR (XCDR (left))); f->output_data.w32->size_hint_flags |= XNegative; } - else if (CONSP (left) && EQ (XCONS (left)->car, Qplus) - && CONSP (XCONS (left)->cdr) - && INTEGERP (XCONS (XCONS (left)->cdr)->car)) + else if (CONSP (left) && EQ (XCAR (left), Qplus) + && CONSP (XCDR (left)) + && INTEGERP (XCAR (XCDR (left)))) { - leftpos = XINT (XCONS (XCONS (left)->cdr)->car); + leftpos = XINT (XCAR (XCDR (left))); } if (EQ (top, Qminus)) @@ -757,18 +955,18 @@ x_set_frame_parameters (f, alist) if (toppos < 0) f->output_data.w32->size_hint_flags |= YNegative; } - else if (CONSP (top) && EQ (XCONS (top)->car, Qminus) - && CONSP (XCONS (top)->cdr) - && INTEGERP (XCONS (XCONS (top)->cdr)->car)) + else if (CONSP (top) && EQ (XCAR (top), Qminus) + && CONSP (XCDR (top)) + && INTEGERP (XCAR (XCDR (top)))) { - toppos = - XINT (XCONS (XCONS (top)->cdr)->car); + toppos = - XINT (XCAR (XCDR (top))); f->output_data.w32->size_hint_flags |= YNegative; } - else if (CONSP (top) && EQ (XCONS (top)->car, Qplus) - && CONSP (XCONS (top)->cdr) - && INTEGERP (XCONS (XCONS (top)->cdr)->car)) + else if (CONSP (top) && EQ (XCAR (top), Qplus) + && CONSP (XCDR (top)) + && INTEGERP (XCAR (XCDR (top)))) { - toppos = XINT (XCONS (XCONS (top)->cdr)->car); + toppos = XINT (XCAR (XCDR (top))); } @@ -786,6 +984,8 @@ x_set_frame_parameters (f, alist) && ! (icon_left_no_change && icon_top_no_change)) x_wm_set_icon_position (f, XINT (icon_left), XINT (icon_top)); } + + UNGCPRO; } /* Store the screen positions of frame F into XPTR and YPTR. @@ -821,6 +1021,7 @@ x_real_positions (f, xptr, yptr) and whose values are not correctly recorded in the frame's param_alist need to be considered here. */ +void x_report_frame_params (f, alistptr) struct frame *f; Lisp_Object *alistptr; @@ -855,7 +1056,7 @@ x_report_frame_params (f, alistptr) (FRAME_VISIBLE_P (f) ? Qt : FRAME_ICONIFIED_P (f) ? Qicon : Qnil)); store_in_alist (alistptr, Qdisplay, - XCONS (FRAME_W32_DISPLAY_INFO (f)->name_list_element)->car); + XCAR (FRAME_W32_DISPLAY_INFO (f)->name_list_element)); } @@ -1237,14 +1438,14 @@ w32_to_x_color (rgb) return Qnil; } -COLORREF -x_to_w32_color (colorname) - char * colorname; +COLORREF +w32_color_map_lookup (colorname) + char *colorname; { - register Lisp_Object tail, ret = Qnil; - + Lisp_Object tail, ret = Qnil; + BLOCK_INPUT; - + for (tail = Vw32_color_map; !NILP (tail); tail = Fcdr (tail)) { register Lisp_Object elt, tem; @@ -1256,15 +1457,207 @@ x_to_w32_color (colorname) if (lstrcmpi (XSTRING (tem)->data, colorname) == 0) { - ret = XUINT(Fcdr (elt)); + ret = XUINT (Fcdr (elt)); break; } QUIT; } - + + UNBLOCK_INPUT; + + return ret; +} + +COLORREF +x_to_w32_color (colorname) + char * colorname; +{ + register Lisp_Object ret = Qnil; + + BLOCK_INPUT; + + if (colorname[0] == '#') + { + /* Could be an old-style RGB Device specification. */ + char *color; + int size; + color = colorname + 1; + + size = strlen(color); + if (size == 3 || size == 6 || size == 9 || size == 12) + { + UINT colorval; + int i, pos; + pos = 0; + size /= 3; + colorval = 0; + + for (i = 0; i < 3; i++) + { + char *end; + char t; + unsigned long value; + + /* The check for 'x' in the following conditional takes into + account the fact that strtol allows a "0x" in front of + our numbers, and we don't. */ + if (!isxdigit(color[0]) || color[1] == 'x') + break; + t = color[size]; + color[size] = '\0'; + value = strtoul(color, &end, 16); + color[size] = t; + if (errno == ERANGE || end - color != size) + break; + switch (size) + { + case 1: + value = value * 0x10; + break; + case 2: + break; + case 3: + value /= 0x10; + break; + case 4: + value /= 0x100; + break; + } + colorval |= (value << pos); + pos += 0x8; + if (i == 2) + { + UNBLOCK_INPUT; + return (colorval); + } + color = end; + } + } + } + else if (strnicmp(colorname, "rgb:", 4) == 0) + { + char *color; + UINT colorval; + int i, pos; + pos = 0; + + colorval = 0; + color = colorname + 4; + for (i = 0; i < 3; i++) + { + char *end; + unsigned long value; + + /* The check for 'x' in the following conditional takes into + account the fact that strtol allows a "0x" in front of + our numbers, and we don't. */ + if (!isxdigit(color[0]) || color[1] == 'x') + break; + value = strtoul(color, &end, 16); + if (errno == ERANGE) + break; + switch (end - color) + { + case 1: + value = value * 0x10 + value; + break; + case 2: + break; + case 3: + value /= 0x10; + break; + case 4: + value /= 0x100; + break; + default: + value = ULONG_MAX; + } + if (value == ULONG_MAX) + break; + colorval |= (value << pos); + pos += 0x8; + if (i == 2) + { + if (*end != '\0') + break; + UNBLOCK_INPUT; + return (colorval); + } + if (*end != '/') + break; + color = end + 1; + } + } + else if (strnicmp(colorname, "rgbi:", 5) == 0) + { + /* This is an RGB Intensity specification. */ + char *color; + UINT colorval; + int i, pos; + pos = 0; + + colorval = 0; + color = colorname + 5; + for (i = 0; i < 3; i++) + { + char *end; + double value; + UINT val; + + value = strtod(color, &end); + if (errno == ERANGE) + break; + if (value < 0.0 || value > 1.0) + break; + val = (UINT)(0x100 * value); + /* We used 0x100 instead of 0xFF to give an continuous + range between 0.0 and 1.0 inclusive. The next statement + fixes the 1.0 case. */ + if (val == 0x100) + val = 0xFF; + colorval |= (val << pos); + pos += 0x8; + if (i == 2) + { + if (*end != '\0') + break; + UNBLOCK_INPUT; + return (colorval); + } + if (*end != '/') + break; + color = end + 1; + } + } + /* I am not going to attempt to handle any of the CIE color schemes + or TekHVC, since I don't know the algorithms for conversion to + RGB. */ + + /* If we fail to lookup the color name in w32_color_map, then check the + colorname to see if it can be crudely approximated: If the X color + ends in a number (e.g., "darkseagreen2"), strip the number and + return the result of looking up the base color name. */ + ret = w32_color_map_lookup (colorname); + if (NILP (ret)) + { + int len = strlen (colorname); + + if (isdigit (colorname[len - 1])) + { + char *ptr, *approx = alloca (len); + + strcpy (approx, colorname); + ptr = &approx[len - 1]; + while (ptr > approx && isdigit (*ptr)) + *ptr-- = '\0'; + + ret = w32_color_map_lookup (approx); + } + } + UNBLOCK_INPUT; return ret; } @@ -1384,29 +1777,57 @@ w32_unmap_color (FRAME_PTR f, COLORREF color) } #endif + +/* Gamma-correct COLOR on frame F. */ + +void +gamma_correct (f, color) + struct frame *f; + COLORREF *color; +{ + if (f->gamma) + { + *color = PALETTERGB ( + pow (GetRValue (*color) / 255.0, f->gamma) * 255.0 + 0.5, + pow (GetGValue (*color) / 255.0, f->gamma) * 255.0 + 0.5, + pow (GetBValue (*color) / 255.0, f->gamma) * 255.0 + 0.5); + } +} + + /* Decide if color named COLOR is valid for the display associated with the selected frame; if so, return the rgb values in COLOR_DEF. If ALLOC is nonzero, allocate a new colormap cell. */ int -defined_color (f, color, color_def, alloc) +w32_defined_color (f, color, color_def, alloc) FRAME_PTR f; char *color; - COLORREF *color_def; + XColor *color_def; int alloc; { register Lisp_Object tem; + COLORREF w32_color_ref; tem = x_to_w32_color (color); if (!NILP (tem)) { + if (f) + { + /* Apply gamma correction. */ + w32_color_ref = XUINT (tem); + gamma_correct (f, &w32_color_ref); + XSETINT (tem, w32_color_ref); + } + + /* Map this color to the palette if it is enabled. */ if (!NILP (Vw32_enable_palette)) { struct w32_palette_entry * entry = - FRAME_W32_DISPLAY_INFO (f)->color_list; + one_w32_display_info.color_list; struct w32_palette_entry ** prev = - &FRAME_W32_DISPLAY_INFO (f)->color_list; + &one_w32_display_info.color_list; /* check if color is already mapped */ while (entry) @@ -1425,16 +1846,22 @@ defined_color (f, color, color_def, alloc) SET_W32_COLOR (entry->entry, XUINT (tem)); entry->next = NULL; *prev = entry; - FRAME_W32_DISPLAY_INFO (f)->num_colors++; + one_w32_display_info.num_colors++; /* set flag that palette must be regenerated */ - FRAME_W32_DISPLAY_INFO (f)->regen_palette = TRUE; + one_w32_display_info.regen_palette = TRUE; } } /* Ensure COLORREF value is snapped to nearest color in (default) palette by simulating the PALETTERGB macro. This works whether or not the display device has a palette. */ - *color_def = XUINT (tem) | 0x2000000; + w32_color_ref = XUINT (tem) | 0x2000000; + + color_def->pixel = w32_color_ref; + color_def->red = GetRValue (w32_color_ref); + color_def->green = GetGValue (w32_color_ref); + color_def->blue = GetBValue (w32_color_ref); + return 1; } else @@ -1454,7 +1881,7 @@ x_decode_color (f, arg, def) Lisp_Object arg; int def; { - COLORREF cdef; + XColor cdef; CHECK_STRING (arg, 0); @@ -1466,15 +1893,56 @@ x_decode_color (f, arg, def) if ((FRAME_W32_DISPLAY_INFO (f)->n_planes * FRAME_W32_DISPLAY_INFO (f)->n_cbits) == 1) return def; - /* defined_color is responsible for coping with failures + /* w32_defined_color is responsible for coping with failures by looking for a near-miss. */ - if (defined_color (f, XSTRING (arg)->data, &cdef, 1)) - return cdef; + if (w32_defined_color (f, XSTRING (arg)->data, &cdef, 1)) + return cdef.pixel; /* defined_color failed; return an ultimate default. */ return def; } +/* Change the `line-spacing' frame parameter of frame F. OLD_VALUE is + the previous value of that parameter, NEW_VALUE is the new value. */ + +static void +x_set_line_spacing (f, new_value, old_value) + struct frame *f; + Lisp_Object new_value, old_value; +{ + if (NILP (new_value)) + f->extra_line_spacing = 0; + else if (NATNUMP (new_value)) + f->extra_line_spacing = XFASTINT (new_value); + else + Fsignal (Qerror, Fcons (build_string ("Invalid line-spacing"), + Fcons (new_value, Qnil))); + if (FRAME_VISIBLE_P (f)) + redraw_frame (f); +} + + +/* Change the `screen-gamma' frame parameter of frame F. OLD_VALUE is + the previous value of that parameter, NEW_VALUE is the new value. */ + +static void +x_set_screen_gamma (f, new_value, old_value) + struct frame *f; + Lisp_Object new_value, old_value; +{ + if (NILP (new_value)) + f->gamma = 0; + else if (NUMBERP (new_value) && XFLOATINT (new_value) > 0) + /* The value 0.4545 is the normal viewing gamma. */ + f->gamma = 1.0 / (0.4545 * XFLOATINT (new_value)); + else + Fsignal (Qerror, Fcons (build_string ("Invalid screen-gamma"), + Fcons (new_value, Qnil))); + + clear_face_cache (0); +} + + /* Functions called only from `x_set_frame_param' to set individual parameters. @@ -1488,12 +1956,12 @@ x_set_foreground_color (f, arg, oldval) struct frame *f; Lisp_Object arg, oldval; { - f->output_data.w32->foreground_pixel + FRAME_FOREGROUND_PIXEL (f) = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f)); if (FRAME_W32_WINDOW (f) != 0) { - recompute_basic_faces (f); + update_face_from_frame_parameter (f, Qforeground_color, arg); if (FRAME_VISIBLE_P (f)) redraw_frame (f); } @@ -1504,17 +1972,15 @@ x_set_background_color (f, arg, oldval) struct frame *f; Lisp_Object arg, oldval; { - Pixmap temp; - int mask; - - f->output_data.w32->background_pixel + FRAME_BACKGROUND_PIXEL (f) = x_decode_color (f, arg, WHITE_PIX_DEFAULT (f)); if (FRAME_W32_WINDOW (f) != 0) { - SetWindowLong (FRAME_W32_WINDOW (f), WND_BACKGROUND_INDEX, f->output_data.w32->background_pixel); + SetWindowLong (FRAME_W32_WINDOW (f), WND_BACKGROUND_INDEX, + FRAME_BACKGROUND_PIXEL (f)); - recompute_basic_faces (f); + update_face_from_frame_parameter (f, Qbackground_color, arg); if (FRAME_VISIBLE_P (f)) redraw_frame (f); @@ -1526,25 +1992,25 @@ x_set_mouse_color (f, arg, oldval) struct frame *f; Lisp_Object arg, oldval; { -#if 0 Cursor cursor, nontext_cursor, mode_cursor, cross_cursor; -#endif + int count; int mask_color; if (!EQ (Qnil, arg)) f->output_data.w32->mouse_pixel = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f)); - mask_color = f->output_data.w32->background_pixel; - /* No invisible pointers. */ + mask_color = FRAME_BACKGROUND_PIXEL (f); + + /* Don't let pointers be invisible. */ if (mask_color == f->output_data.w32->mouse_pixel - && mask_color == f->output_data.w32->background_pixel) - f->output_data.w32->mouse_pixel = f->output_data.w32->foreground_pixel; + && mask_color == FRAME_BACKGROUND_PIXEL (f)) + f->output_data.w32->mouse_pixel = FRAME_FOREGROUND_PIXEL (f); -#if 0 +#if 0 /* TODO : cursor changes */ BLOCK_INPUT; /* It's not okay to crash if the user selects a screwy cursor. */ - x_catch_errors (FRAME_W32_DISPLAY (f)); + count = x_catch_errors (FRAME_W32_DISPLAY (f)); if (!EQ (Qnil, Vx_pointer_shape)) { @@ -1565,6 +2031,17 @@ x_set_mouse_color (f, arg, oldval) nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_left_ptr); x_check_errors (FRAME_W32_DISPLAY (f), "bad nontext pointer cursor: %s"); + if (!EQ (Qnil, Vx_hourglass_pointer_shape)) + { + CHECK_NUMBER (Vx_hourglass_pointer_shape, 0); + hourglass_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), + XINT (Vx_hourglass_pointer_shape)); + } + else + hourglass_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_watch); + x_check_errors (FRAME_W32_DISPLAY (f), "bad busy pointer cursor: %s"); + + x_check_errors (FRAME_W32_DISPLAY (f), "bad nontext pointer cursor: %s"); if (!EQ (Qnil, Vx_mode_pointer_shape)) { CHECK_NUMBER (Vx_mode_pointer_shape, 0); @@ -1585,9 +2062,20 @@ x_set_mouse_color (f, arg, oldval) else cross_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_crosshair); + if (!NILP (Vx_window_horizontal_drag_shape)) + { + CHECK_NUMBER (Vx_window_horizontal_drag_shape, 0); + horizontal_drag_cursor + = XCreateFontCursor (FRAME_X_DISPLAY (f), + XINT (Vx_window_horizontal_drag_shape)); + } + else + horizontal_drag_cursor + = XCreateFontCursor (FRAME_X_DISPLAY (f), XC_sb_h_double_arrow); + /* Check and report errors with the above calls. */ x_check_errors (FRAME_W32_DISPLAY (f), "can't set cursor shape: %s"); - x_uncatch_errors (FRAME_W32_DISPLAY (f)); + x_uncatch_errors (FRAME_W32_DISPLAY (f), count); { XColor fore_color, back_color; @@ -1610,12 +2098,12 @@ x_set_mouse_color (f, arg, oldval) &fore_color, &back_color); XRecolorCursor (FRAME_W32_DISPLAY (f), cross_cursor, &fore_color, &back_color); + XRecolorCursor (FRAME_W32_DISPLAY (f), hourglass_cursor, + &fore_color, &back_color); } if (FRAME_W32_WINDOW (f) != 0) - { - XDefineCursor (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), cursor); - } + XDefineCursor (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), cursor); if (cursor != f->output_data.w32->text_cursor && f->output_data.w32->text_cursor != 0) XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->text_cursor); @@ -1626,10 +2114,16 @@ x_set_mouse_color (f, arg, oldval) XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->nontext_cursor); f->output_data.w32->nontext_cursor = nontext_cursor; + if (hourglass_cursor != f->output_data.w32->hourglass_cursor + && f->output_data.w32->hourglass_cursor != 0) + XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->hourglass_cursor); + f->output_data.w32->hourglass_cursor = hourglass_cursor; + if (mode_cursor != f->output_data.w32->modeline_cursor && f->output_data.w32->modeline_cursor != 0) XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->modeline_cursor); f->output_data.w32->modeline_cursor = mode_cursor; + if (cross_cursor != f->output_data.w32->cross_cursor && f->output_data.w32->cross_cursor != 0) XFreeCursor (FRAME_W32_DISPLAY (f), f->output_data.w32->cross_cursor); @@ -1637,69 +2131,57 @@ x_set_mouse_color (f, arg, oldval) XFlush (FRAME_W32_DISPLAY (f)); UNBLOCK_INPUT; -#endif + + update_face_from_frame_parameter (f, Qmouse_color, arg); +#endif /* TODO */ } +/* Defined in w32term.c. */ +void x_update_cursor (struct frame *f, int on_p); + void x_set_cursor_color (f, arg, oldval) struct frame *f; Lisp_Object arg, oldval; { - unsigned long fore_pixel; + unsigned long fore_pixel, pixel; - if (!EQ (Vx_cursor_fore_pixel, Qnil)) + if (!NILP (Vx_cursor_fore_pixel)) fore_pixel = x_decode_color (f, Vx_cursor_fore_pixel, - WHITE_PIX_DEFAULT (f)); + WHITE_PIX_DEFAULT (f)); else - fore_pixel = f->output_data.w32->background_pixel; - f->output_data.w32->cursor_pixel = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f)); + fore_pixel = FRAME_BACKGROUND_PIXEL (f); + + pixel = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f)); /* Make sure that the cursor color differs from the background color. */ - if (f->output_data.w32->cursor_pixel == f->output_data.w32->background_pixel) + if (pixel == FRAME_BACKGROUND_PIXEL (f)) { - f->output_data.w32->cursor_pixel = f->output_data.w32->mouse_pixel; - if (f->output_data.w32->cursor_pixel == fore_pixel) - fore_pixel = f->output_data.w32->background_pixel; + pixel = f->output_data.w32->mouse_pixel; + if (pixel == fore_pixel) + fore_pixel = FRAME_BACKGROUND_PIXEL (f); } - f->output_data.w32->cursor_foreground_pixel = fore_pixel; + + FRAME_FOREGROUND_PIXEL (f) = fore_pixel; + f->output_data.w32->cursor_pixel = pixel; if (FRAME_W32_WINDOW (f) != 0) { if (FRAME_VISIBLE_P (f)) { - x_display_cursor (f, 0); - x_display_cursor (f, 1); + x_update_cursor (f, 0); + x_update_cursor (f, 1); } } + + update_face_from_frame_parameter (f, Qcursor_color, arg); } -/* Set the border-color of frame F to value described by ARG. - ARG can be a string naming a color. - The border-color is used for the border that is drawn by the server. +/* Set the border-color of frame F to pixel value PIX. Note that this does not fully take effect if done before - F has a window; it must be redone when the window is created. */ - + F has an window. */ void -x_set_border_color (f, arg, oldval) - struct frame *f; - Lisp_Object arg, oldval; -{ - unsigned char *str; - int pix; - - CHECK_STRING (arg, 0); - str = XSTRING (arg)->data; - - pix = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f)); - - x_set_border_pixel (f, pix); -} - -/* Set the border-color of frame F to pixel value PIX. - Note that this does not fully take effect if done before - F has an window. */ - -x_set_border_pixel (f, pix) +x_set_border_pixel (f, pix) struct frame *f; int pix; { @@ -1712,78 +2194,102 @@ x_set_border_pixel (f, pix) } } +/* Set the border-color of frame F to value described by ARG. + ARG can be a string naming a color. + The border-color is used for the border that is drawn by the server. + Note that this does not fully take effect if done before + F has a window; it must be redone when the window is created. */ + void -x_set_cursor_type (f, arg, oldval) - FRAME_PTR f; +x_set_border_color (f, arg, oldval) + struct frame *f; Lisp_Object arg, oldval; { + int pix; + + CHECK_STRING (arg, 0); + pix = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f)); + x_set_border_pixel (f, pix); + update_face_from_frame_parameter (f, Qborder_color, arg); +} + +/* Value is the internal representation of the specified cursor type + ARG. If type is BAR_CURSOR, return in *WIDTH the specified width + of the bar cursor. */ + +enum text_cursor_kinds +x_specified_cursor_type (arg, width) + Lisp_Object arg; + int *width; +{ + enum text_cursor_kinds type; + if (EQ (arg, Qbar)) { - FRAME_DESIRED_CURSOR (f) = bar_cursor; - f->output_data.w32->cursor_width = 2; + type = BAR_CURSOR; + *width = 2; } - else if (CONSP (arg) && EQ (XCONS (arg)->car, Qbar) - && INTEGERP (XCONS (arg)->cdr)) + else if (CONSP (arg) + && EQ (XCAR (arg), Qbar) + && INTEGERP (XCDR (arg)) + && XINT (XCDR (arg)) >= 0) { - FRAME_DESIRED_CURSOR (f) = bar_cursor; - f->output_data.w32->cursor_width = XINT (XCONS (arg)->cdr); + type = BAR_CURSOR; + *width = XINT (XCDR (arg)); } + else if (NILP (arg)) + type = NO_CURSOR; else /* Treat anything unknown as "box cursor". It was bad to signal an error; people have trouble fixing .Xdefaults with Emacs, when it has something bad in it. */ - FRAME_DESIRED_CURSOR (f) = filled_box_cursor; + type = FILLED_BOX_CURSOR; + + return type; +} + +void +x_set_cursor_type (f, arg, oldval) + FRAME_PTR f; + Lisp_Object arg, oldval; +{ + int width; + + FRAME_DESIRED_CURSOR (f) = x_specified_cursor_type (arg, &width); + f->output_data.w32->cursor_width = width; /* Make sure the cursor gets redrawn. This is overkill, but how often do people change cursor types? */ update_mode_lines++; } - + void x_set_icon_type (f, arg, oldval) struct frame *f; Lisp_Object arg, oldval; { -#if 0 - Lisp_Object tem; int result; - if (STRINGP (arg)) - { - if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt)) - return; - } - else if (!STRINGP (oldval) && EQ (oldval, Qnil) == EQ (arg, Qnil)) + if (NILP (arg) && NILP (oldval)) + return; + + if (STRINGP (arg) && STRINGP (oldval) + && EQ (Fstring_equal (oldval, arg), Qt)) + return; + + if (SYMBOLP (arg) && SYMBOLP (oldval) && EQ (arg, oldval)) return; BLOCK_INPUT; - if (NILP (arg)) - result = x_text_icon (f, - (char *) XSTRING ((!NILP (f->icon_name) - ? f->icon_name - : f->name))->data); - else - result = x_bitmap_icon (f, arg); + result = x_bitmap_icon (f, arg); if (result) { UNBLOCK_INPUT; error ("No icon window available"); } - /* If the window was unmapped (and its icon was mapped), - the new icon is not mapped, so map the window in its stead. */ - if (FRAME_VISIBLE_P (f)) - { -#ifdef USE_X_TOOLKIT - XtPopup (f->output_data.w32->widget, XtGrabNone); -#endif - XMapWindow (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f)); - } - - XFlush (FRAME_W32_DISPLAY (f)); UNBLOCK_INPUT; -#endif } /* Return non-nil if frame F wants a bitmap icon. */ @@ -1796,7 +2302,7 @@ x_icon_type (f) tem = assq_no_quit (Qicon_type, f->param_alist); if (CONSP (tem)) - return XCONS (tem)->cdr; + return XCDR (tem); else return Qnil; } @@ -1806,9 +2312,6 @@ x_set_icon_name (f, arg, oldval) struct frame *f; Lisp_Object arg, oldval; { - Lisp_Object tem; - int result; - if (STRINGP (arg)) { if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt)) @@ -1826,8 +2329,10 @@ x_set_icon_name (f, arg, oldval) BLOCK_INPUT; result = x_text_icon (f, - (char *) XSTRING ((!NILP (f->icon_name) + (char *) XSTRING ((!NILP (f->icon_name) ? f->icon_name + : !NILP (f->title) + ? f->title : f->name))->data); if (result) @@ -1852,6 +2357,7 @@ x_set_icon_name (f, arg, oldval) } extern Lisp_Object x_new_font (); +extern Lisp_Object x_new_fontset(); void x_set_font (f, arg, oldval) @@ -1859,24 +2365,45 @@ x_set_font (f, arg, oldval) Lisp_Object arg, oldval; { Lisp_Object result; + Lisp_Object fontset_name; + Lisp_Object frame; CHECK_STRING (arg, 1); + fontset_name = Fquery_fontset (arg, Qnil); + BLOCK_INPUT; - result = x_new_font (f, XSTRING (arg)->data); + result = (STRINGP (fontset_name) + ? x_new_fontset (f, XSTRING (fontset_name)->data) + : x_new_font (f, XSTRING (arg)->data)); UNBLOCK_INPUT; if (EQ (result, Qnil)) - error ("Font \"%s\" is not defined", XSTRING (arg)->data); + error ("Font `%s' is not defined", XSTRING (arg)->data); else if (EQ (result, Qt)) - error ("the characters of the given font have varying widths"); + error ("The characters of the given font have varying widths"); else if (STRINGP (result)) { - recompute_basic_faces (f); + if (!NILP (Fequal (result, oldval))) + return; store_frame_param (f, Qfont, result); + recompute_basic_faces (f); } else abort (); + + do_pending_window_change (0); + + /* Don't call `face-set-after-frame-default' when faces haven't been + initialized yet. This is the case when called from + Fx_create_frame. In that case, the X widget or window doesn't + exist either, and we can end up in x_report_frame_params with a + null widget which gives a segfault. */ + if (FRAME_FACE_CACHE (f)) + { + XSETFRAME (frame, f); + call1 (Qface_set_after_frame_default, frame); + } } void @@ -1900,7 +2427,6 @@ x_set_internal_border_width (f, arg, oldval) struct frame *f; Lisp_Object arg, oldval; { - int mask; int old = f->output_data.w32->internal_border_width; CHECK_NUMBER (arg, 0); @@ -1913,10 +2439,9 @@ x_set_internal_border_width (f, arg, oldval) if (FRAME_W32_WINDOW (f) != 0) { - BLOCK_INPUT; x_set_window_size (f, 0, f->width, f->height); - UNBLOCK_INPUT; SET_FRAME_GARBAGED (f); + do_pending_window_change (0); } } @@ -1936,6 +2461,36 @@ x_set_visibility (f, value, oldval) Fmake_frame_visible (frame); } + +/* Change window heights in windows rooted in WINDOW by N lines. */ + +static void +x_change_window_heights (window, n) + Lisp_Object window; + int n; +{ + struct window *w = XWINDOW (window); + + XSETFASTINT (w->top, XFASTINT (w->top) + n); + XSETFASTINT (w->height, XFASTINT (w->height) - n); + + if (INTEGERP (w->orig_top)) + XSETFASTINT (w->orig_top, XFASTINT (w->orig_top) + n); + if (INTEGERP (w->orig_height)) + XSETFASTINT (w->orig_height, XFASTINT (w->orig_height) - n); + + /* Handle just the top child in a vertical split. */ + if (!NILP (w->vchild)) + x_change_window_heights (w->vchild, n); + + /* Adjust all children in a horizontal split. */ + for (window = w->hchild; !NILP (window); window = w->next) + { + w = XWINDOW (window); + x_change_window_heights (window, n); + } +} + void x_set_menu_bar_lines (f, value, oldval) struct frame *f; @@ -1946,7 +2501,7 @@ x_set_menu_bar_lines (f, value, oldval) /* Right now, menu bars don't work properly in minibuf-only frames; most of the commands try to apply themselves to the minibuffer - frame itslef, and get an error because you can't switch buffers + frame itself, and get an error because you can't switch buffers in or split the minibuffer window. */ if (FRAME_MINIBUF_ONLY_P (f)) return; @@ -1964,9 +2519,93 @@ x_set_menu_bar_lines (f, value, oldval) if (FRAME_EXTERNAL_MENU_BAR (f) == 1) free_frame_menubar (f); FRAME_EXTERNAL_MENU_BAR (f) = 0; + + /* Adjust the frame size so that the client (text) dimensions + remain the same. This depends on FRAME_EXTERNAL_MENU_BAR being + set correctly. */ + x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f)); + do_pending_window_change (0); + } + adjust_glyphs (f); +} + + +/* Set the number of lines used for the tool bar of frame F to VALUE. + VALUE not an integer, or < 0 means set the lines to zero. OLDVAL + is the old number of tool bar lines. This function changes the + height of all windows on frame F to match the new tool bar height. + The frame's height doesn't change. */ + +void +x_set_tool_bar_lines (f, value, oldval) + struct frame *f; + Lisp_Object value, oldval; +{ + int delta, nlines, root_height; + Lisp_Object root_window; + + /* Treat tool bars like menu bars. */ + if (FRAME_MINIBUF_ONLY_P (f)) + return; + + /* Use VALUE only if an integer >= 0. */ + if (INTEGERP (value) && XINT (value) >= 0) + nlines = XFASTINT (value); + else + nlines = 0; + + /* Make sure we redisplay all windows in this frame. */ + ++windows_or_buffers_changed; + + delta = nlines - FRAME_TOOL_BAR_LINES (f); + + /* Don't resize the tool-bar to more than we have room for. */ + root_window = FRAME_ROOT_WINDOW (f); + root_height = XINT (XWINDOW (root_window)->height); + if (root_height - delta < 1) + { + delta = root_height - 1; + nlines = FRAME_TOOL_BAR_LINES (f) + delta; + } + + FRAME_TOOL_BAR_LINES (f) = nlines; + x_change_window_heights (root_window, delta); + adjust_glyphs (f); + + /* We also have to make sure that the internal border at the top of + the frame, below the menu bar or tool bar, is redrawn when the + tool bar disappears. This is so because the internal border is + below the tool bar if one is displayed, but is below the menu bar + if there isn't a tool bar. The tool bar draws into the area + below the menu bar. */ + if (FRAME_W32_WINDOW (f) && FRAME_TOOL_BAR_LINES (f) == 0) + { + updating_frame = f; + clear_frame (); + clear_current_matrices (f); + updating_frame = NULL; + } + + /* If the tool bar gets smaller, the internal border below it + has to be cleared. It was formerly part of the display + of the larger tool bar, and updating windows won't clear it. */ + if (delta < 0) + { + int height = FRAME_INTERNAL_BORDER_WIDTH (f); + int width = PIXEL_WIDTH (f); + int y = nlines * CANON_Y_UNIT (f); + + BLOCK_INPUT; + { + HDC hdc = get_frame_dc (f); + w32_clear_area (f, hdc, 0, y, width, height); + release_frame_dc (f, hdc); + } + UNBLOCK_INPUT; } } + /* Change the name of frame F to NAME. If NAME is nil, set F's name to w32_id_name. @@ -2015,14 +2654,22 @@ x_set_name (f, name, explicit) if (! NILP (Fstring_equal (name, f->name))) return; + f->name = name; + + /* For setting the frame title, the title parameter should override + the name parameter. */ + if (! NILP (f->title)) + name = f->title; + if (FRAME_W32_WINDOW (f)) { + if (STRING_MULTIBYTE (name)) + name = ENCODE_SYSTEM (name); + BLOCK_INPUT; SetWindowText(FRAME_W32_WINDOW (f), XSTRING (name)->data); UNBLOCK_INPUT; } - - f->name = name; } /* This function should be called when the user's lisp code has @@ -2046,7 +2693,45 @@ x_implicitly_set_name (f, arg, oldval) { x_set_name (f, arg, 0); } + +/* Change the title of frame F to NAME. + If NAME is nil, use the frame name as the title. + + If EXPLICIT is non-zero, that indicates that lisp code is setting the + name; if NAME is a string, set F's name to NAME and set + F->explicit_name; if NAME is Qnil, then clear F->explicit_name. + + If EXPLICIT is zero, that indicates that Emacs redisplay code is + suggesting a new name, which lisp code should override; if + F->explicit_name is set, ignore the new name; otherwise, set it. */ + +void +x_set_title (f, name, old_name) + struct frame *f; + Lisp_Object name, old_name; +{ + /* Don't change the title if it's already NAME. */ + if (EQ (name, f->title)) + return; + + update_mode_lines = 1; + + f->title = name; + + if (NILP (name)) + name = f->name; + + if (FRAME_W32_WINDOW (f)) + { + if (STRING_MULTIBYTE (name)) + name = ENCODE_SYSTEM (name); + BLOCK_INPUT; + SetWindowText(FRAME_W32_WINDOW (f), XSTRING (name)->data); + UNBLOCK_INPUT; + } +} + void x_set_autoraise (f, arg, oldval) struct frame *f; @@ -2083,9 +2768,11 @@ x_set_vertical_scroll_bars (f, arg, oldval) { FRAME_VERTICAL_SCROLL_BAR_TYPE (f) = NILP (arg) ? vertical_scroll_bar_none : - EQ (Qright, arg) - ? vertical_scroll_bar_right - : vertical_scroll_bar_left; + /* Put scroll bars on the right by default, as is conventional + on MS-Windows. */ + EQ (Qleft, arg) + ? vertical_scroll_bar_left + : vertical_scroll_bar_right; /* We set this parameter before creating the window for the frame, so we can get the geometry right from the start. @@ -2093,6 +2780,7 @@ x_set_vertical_scroll_bars (f, arg, oldval) call x_set_window_size. */ if (FRAME_W32_WINDOW (f)) x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f)); + do_pending_window_change (0); } } @@ -2101,20 +2789,30 @@ x_set_scroll_bar_width (f, arg, oldval) struct frame *f; Lisp_Object arg, oldval; { + int wid = FONT_WIDTH (f->output_data.w32->font); + if (NILP (arg)) { - FRAME_SCROLL_BAR_PIXEL_WIDTH (f) = 0; - FRAME_SCROLL_BAR_COLS (f) = 2; + FRAME_SCROLL_BAR_PIXEL_WIDTH (f) = GetSystemMetrics (SM_CXVSCROLL); + FRAME_SCROLL_BAR_COLS (f) = (FRAME_SCROLL_BAR_PIXEL_WIDTH (f) + + wid - 1) / wid; + if (FRAME_W32_WINDOW (f)) + x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f)); + do_pending_window_change (0); } else if (INTEGERP (arg) && XINT (arg) > 0 && XFASTINT (arg) != FRAME_SCROLL_BAR_PIXEL_WIDTH (f)) { - int wid = FONT_WIDTH (f->output_data.w32->font); FRAME_SCROLL_BAR_PIXEL_WIDTH (f) = XFASTINT (arg); - FRAME_SCROLL_BAR_COLS (f) = (XFASTINT (arg) + wid-1) / wid; + FRAME_SCROLL_BAR_COLS (f) = (FRAME_SCROLL_BAR_PIXEL_WIDTH (f) + + wid-1) / wid; if (FRAME_W32_WINDOW (f)) x_set_window_size (f, 0, FRAME_WIDTH (f), FRAME_HEIGHT (f)); + do_pending_window_change (0); } + change_frame_size (f, 0, FRAME_WIDTH (f), 0, 0, 0); + XWINDOW (FRAME_SELECTED_WINDOW (f))->cursor.hpos = 0; + XWINDOW (FRAME_SELECTED_WINDOW (f))->cursor.x = 0; } /* Subroutines of creating an frame. */ @@ -2125,7 +2823,7 @@ x_set_scroll_bar_width (f, arg, oldval) static void validate_x_resource_name () { - int len; + int len = 0; /* Number of valid characters in the resource name. */ int good_count = 0; /* Number of invalid characters in the resource name. */ @@ -2138,7 +2836,7 @@ validate_x_resource_name () unsigned char *p = XSTRING (Vx_resource_name)->data; int i; - len = XSTRING (Vx_resource_name)->size; + len = STRING_BYTES (XSTRING (Vx_resource_name)); /* Only letters, digits, - and _ are valid in resource names. Count the valid characters and count the invalid ones. */ @@ -2220,16 +2918,16 @@ and the class is `Emacs.CLASS.SUBCLASS'.") /* Allocate space for the components, the dots which separate them, and the final '\0'. Make them big enough for the worst case. */ - name_key = (char *) alloca (XSTRING (Vx_resource_name)->size + name_key = (char *) alloca (STRING_BYTES (XSTRING (Vx_resource_name)) + (STRINGP (component) - ? XSTRING (component)->size : 0) - + XSTRING (attribute)->size + ? STRING_BYTES (XSTRING (component)) : 0) + + STRING_BYTES (XSTRING (attribute)) + 3); class_key = (char *) alloca ((sizeof (EMACS_CLASS) - 1) - + XSTRING (class)->size + + STRING_BYTES (XSTRING (class)) + (STRINGP (subclass) - ? XSTRING (subclass)->size : 0) + ? STRING_BYTES (XSTRING (subclass)) : 0) + 3); /* Start with emacs.FRAMENAME for the name (the specific one) @@ -2267,13 +2965,13 @@ char * x_get_resource_string (attribute, class) char *attribute, *class; { - register char *value; char *name_key; char *class_key; + struct frame *sf = SELECTED_FRAME (); /* Allocate space for the components, the dots which separate them, and the final '\0'. */ - name_key = (char *) alloca (XSTRING (Vinvocation_name)->size + name_key = (char *) alloca (STRING_BYTES (XSTRING (Vinvocation_name)) + strlen (attribute) + 2); class_key = (char *) alloca ((sizeof (EMACS_CLASS) - 1) + strlen (class) + 2); @@ -2283,15 +2981,18 @@ x_get_resource_string (attribute, class) attribute); sprintf (class_key, "%s.%s", EMACS_CLASS, class); - return x_get_string_resource (selected_frame, - name_key, class_key); + return x_get_string_resource (sf, name_key, class_key); } /* Types we might convert a resource string into. */ enum resource_types - { - number, boolean, string, symbol - }; +{ + RES_TYPE_NUMBER, + RES_TYPE_FLOAT, + RES_TYPE_BOOLEAN, + RES_TYPE_STRING, + RES_TYPE_SYMBOL +}; /* Return the value of parameter PARAM. @@ -2301,11 +3002,11 @@ enum resource_types Convert the resource to the type specified by desired_type. If no default is specified, return Qunbound. If you call - x_get_arg, make sure you deal with Qunbound in a reasonable way, + w32_get_arg, make sure you deal with Qunbound in a reasonable way, and don't let it get stored in any Lisp-visible variables! */ static Lisp_Object -x_get_arg (alist, param, attribute, class, type) +w32_get_arg (alist, param, attribute, class, type) Lisp_Object alist, param; char *attribute; char *class; @@ -2330,10 +3031,13 @@ x_get_arg (alist, param, attribute, class, type) switch (type) { - case number: + case RES_TYPE_NUMBER: return make_number (atoi (XSTRING (tem)->data)); - case boolean: + case RES_TYPE_FLOAT: + return make_float (atof (XSTRING (tem)->data)); + + case RES_TYPE_BOOLEAN: tem = Fdowncase (tem); if (!strcmp (XSTRING (tem)->data, "on") || !strcmp (XSTRING (tem)->data, "true")) @@ -2341,10 +3045,10 @@ x_get_arg (alist, param, attribute, class, type) else return Qnil; - case string: + case RES_TYPE_STRING: return tem; - case symbol: + case RES_TYPE_SYMBOL: /* As a special case, we map the values `true' and `on' to Qt, and `false' and `off' to Qnil. */ { @@ -2371,8 +3075,8 @@ x_get_arg (alist, param, attribute, class, type) } /* Record in frame F the specified or default value according to ALIST - of the parameter named PARAM (a Lisp symbol). - If no value is specified for PARAM, look for an X default for XPROP + of the parameter named PROP (a Lisp symbol). + If no value is specified for PROP, look for an X default for XPROP on the frame named NAME. If that is not found either, use the value DEFLT. */ @@ -2388,7 +3092,7 @@ x_default_parameter (f, alist, prop, deflt, xprop, xclass, type) { Lisp_Object tem; - tem = x_get_arg (alist, prop, xprop, xclass, type); + tem = w32_get_arg (alist, prop, xprop, xclass, type); if (EQ (tem, Qunbound)) tem = deflt; x_set_frame_parameters (f, Fcons (Fcons (prop, tem), Qnil)); @@ -2463,8 +3167,6 @@ x_figure_window_size (f, parms) Lisp_Object parms; { register Lisp_Object tem0, tem1, tem2; - int height, width, left, top; - register int geometry; long window_prompting = 0; /* Default values if we fall through. @@ -2477,9 +3179,14 @@ x_figure_window_size (f, parms) f->output_data.w32->top_pos = 0; f->output_data.w32->left_pos = 0; - tem0 = x_get_arg (parms, Qheight, 0, 0, number); - tem1 = x_get_arg (parms, Qwidth, 0, 0, number); - tem2 = x_get_arg (parms, Quser_size, 0, 0, number); + /* Ensure that old new_width and new_height will not override the + values set here. */ + FRAME_NEW_WIDTH (f) = 0; + FRAME_NEW_HEIGHT (f) = 0; + + tem0 = w32_get_arg (parms, Qheight, 0, 0, RES_TYPE_NUMBER); + tem1 = w32_get_arg (parms, Qwidth, 0, 0, RES_TYPE_NUMBER); + tem2 = w32_get_arg (parms, Quser_size, 0, 0, RES_TYPE_NUMBER); if (! EQ (tem0, Qunbound) || ! EQ (tem1, Qunbound)) { if (!EQ (tem0, Qunbound)) @@ -2504,12 +3211,14 @@ x_figure_window_size (f, parms) : FRAME_SCROLL_BAR_PIXEL_WIDTH (f) > 0 ? FRAME_SCROLL_BAR_PIXEL_WIDTH (f) : (FRAME_SCROLL_BAR_COLS (f) * FONT_WIDTH (f->output_data.w32->font))); + f->output_data.w32->flags_areas_extra + = FRAME_FLAGS_AREA_WIDTH (f); f->output_data.w32->pixel_width = CHAR_TO_PIXEL_WIDTH (f, f->width); f->output_data.w32->pixel_height = CHAR_TO_PIXEL_HEIGHT (f, f->height); - tem0 = x_get_arg (parms, Qtop, 0, 0, number); - tem1 = x_get_arg (parms, Qleft, 0, 0, number); - tem2 = x_get_arg (parms, Quser_position, 0, 0, number); + tem0 = w32_get_arg (parms, Qtop, 0, 0, RES_TYPE_NUMBER); + tem1 = w32_get_arg (parms, Qleft, 0, 0, RES_TYPE_NUMBER); + tem2 = w32_get_arg (parms, Quser_position, 0, 0, RES_TYPE_NUMBER); if (! EQ (tem0, Qunbound) || ! EQ (tem1, Qunbound)) { if (EQ (tem0, Qminus)) @@ -2517,18 +3226,18 @@ x_figure_window_size (f, parms) f->output_data.w32->top_pos = 0; window_prompting |= YNegative; } - else if (CONSP (tem0) && EQ (XCONS (tem0)->car, Qminus) - && CONSP (XCONS (tem0)->cdr) - && INTEGERP (XCONS (XCONS (tem0)->cdr)->car)) + else if (CONSP (tem0) && EQ (XCAR (tem0), Qminus) + && CONSP (XCDR (tem0)) + && INTEGERP (XCAR (XCDR (tem0)))) { - f->output_data.w32->top_pos = - XINT (XCONS (XCONS (tem0)->cdr)->car); + f->output_data.w32->top_pos = - XINT (XCAR (XCDR (tem0))); window_prompting |= YNegative; } - else if (CONSP (tem0) && EQ (XCONS (tem0)->car, Qplus) - && CONSP (XCONS (tem0)->cdr) - && INTEGERP (XCONS (XCONS (tem0)->cdr)->car)) + else if (CONSP (tem0) && EQ (XCAR (tem0), Qplus) + && CONSP (XCDR (tem0)) + && INTEGERP (XCAR (XCDR (tem0)))) { - f->output_data.w32->top_pos = XINT (XCONS (XCONS (tem0)->cdr)->car); + f->output_data.w32->top_pos = XINT (XCAR (XCDR (tem0))); } else if (EQ (tem0, Qunbound)) f->output_data.w32->top_pos = 0; @@ -2545,18 +3254,18 @@ x_figure_window_size (f, parms) f->output_data.w32->left_pos = 0; window_prompting |= XNegative; } - else if (CONSP (tem1) && EQ (XCONS (tem1)->car, Qminus) - && CONSP (XCONS (tem1)->cdr) - && INTEGERP (XCONS (XCONS (tem1)->cdr)->car)) + else if (CONSP (tem1) && EQ (XCAR (tem1), Qminus) + && CONSP (XCDR (tem1)) + && INTEGERP (XCAR (XCDR (tem1)))) { - f->output_data.w32->left_pos = - XINT (XCONS (XCONS (tem1)->cdr)->car); + f->output_data.w32->left_pos = - XINT (XCAR (XCDR (tem1))); window_prompting |= XNegative; } - else if (CONSP (tem1) && EQ (XCONS (tem1)->car, Qplus) - && CONSP (XCONS (tem1)->cdr) - && INTEGERP (XCONS (XCONS (tem1)->cdr)->car)) + else if (CONSP (tem1) && EQ (XCAR (tem1), Qplus) + && CONSP (XCDR (tem1)) + && INTEGERP (XCAR (XCDR (tem1)))) { - f->output_data.w32->left_pos = XINT (XCONS (XCONS (tem1)->cdr)->car); + f->output_data.w32->left_pos = XINT (XCAR (XCDR (tem1))); } else if (EQ (tem1, Qunbound)) f->output_data.w32->left_pos = 0; @@ -2594,7 +3303,7 @@ w32_init_class (hinst) wc.hInstance = hinst; wc.hIcon = LoadIcon (hinst, EMACS_CLASS); wc.hCursor = LoadCursor (NULL, IDC_ARROW); - wc.hbrBackground = NULL; // GetStockObject (WHITE_BRUSH); + wc.hbrBackground = NULL; /* GetStockObject (WHITE_BRUSH); */ wc.lpszMenuName = NULL; wc.lpszClassName = EMACS_CLASS; @@ -2608,8 +3317,10 @@ w32_createscrollbar (f, bar) { return (CreateWindow ("SCROLLBAR", "", SBS_VERT | WS_CHILD | WS_VISIBLE, /* Position and size of scroll bar. */ - XINT(bar->left), XINT(bar->top), - XINT(bar->width), XINT(bar->height), + XINT(bar->left) + VERTICAL_SCROLL_BAR_WIDTH_TRIM, + XINT(bar->top), + XINT(bar->width) - VERTICAL_SCROLL_BAR_WIDTH_TRIM * 2, + XINT(bar->height), FRAME_W32_WINDOW (f), NULL, hinst, @@ -2621,6 +3332,14 @@ w32_createwindow (f) struct frame *f; { HWND hwnd; + RECT rect; + + rect.left = rect.top = 0; + rect.right = PIXEL_WIDTH (f); + rect.bottom = PIXEL_HEIGHT (f); + + AdjustWindowRect (&rect, f->output_data.w32->dwStyle, + FRAME_EXTERNAL_MENU_BAR (f)); /* Do first time app init */ @@ -2629,40 +3348,35 @@ w32_createwindow (f) w32_init_class (hinst); } - FRAME_W32_WINDOW (f) = hwnd = CreateWindow (EMACS_CLASS, - f->namebuf, - f->output_data.w32->dwStyle | WS_CLIPCHILDREN, - f->output_data.w32->left_pos, - f->output_data.w32->top_pos, - PIXEL_WIDTH (f), - PIXEL_HEIGHT (f), - NULL, - NULL, - hinst, - NULL); - + FRAME_W32_WINDOW (f) = hwnd + = CreateWindow (EMACS_CLASS, + f->namebuf, + f->output_data.w32->dwStyle | WS_CLIPCHILDREN, + f->output_data.w32->left_pos, + f->output_data.w32->top_pos, + rect.right - rect.left, + rect.bottom - rect.top, + NULL, + NULL, + hinst, + NULL); + if (hwnd) { - SetWindowLong (hwnd, WND_X_UNITS_INDEX, FONT_WIDTH (f->output_data.w32->font)); - SetWindowLong (hwnd, WND_Y_UNITS_INDEX, f->output_data.w32->line_height); - SetWindowLong (hwnd, WND_BACKGROUND_INDEX, f->output_data.w32->background_pixel); - + SetWindowLong (hwnd, WND_FONTWIDTH_INDEX, FONT_WIDTH (f->output_data.w32->font)); + SetWindowLong (hwnd, WND_LINEHEIGHT_INDEX, f->output_data.w32->line_height); + SetWindowLong (hwnd, WND_BORDER_INDEX, f->output_data.w32->internal_border_width); + SetWindowLong (hwnd, WND_SCROLLBAR_INDEX, f->output_data.w32->vertical_scroll_bar_extra); + SetWindowLong (hwnd, WND_BACKGROUND_INDEX, FRAME_BACKGROUND_PIXEL (f)); + + /* Enable drag-n-drop. */ + DragAcceptFiles (hwnd, TRUE); + /* Do this to discard the default setting specified by our parent. */ ShowWindow (hwnd, SW_HIDE); } } -/* Convert between the modifier bits W32 uses and the modifier bits - Emacs uses. */ -unsigned int -w32_get_modifiers () -{ - return (((GetKeyState (VK_SHIFT)&0x8000) ? shift_modifier : 0) | - ((GetKeyState (VK_CONTROL)&0x8000) ? ctrl_modifier : 0) | - ((GetKeyState (VK_MENU)&0x8000) ? - ((NILP (Vw32_alt_is_meta)) ? alt_modifier : meta_modifier) : 0)); -} - void my_post_msg (wmsg, hwnd, msg, wParam, lParam) W32Msg * wmsg; @@ -2767,16 +3481,13 @@ reset_modifiers () { SHORT ctrl, alt; - if (!modifiers_recorded) + if (GetFocus () == NULL) + /* Emacs doesn't have keyboard focus. Do nothing. */ return; ctrl = GetAsyncKeyState (VK_CONTROL); alt = GetAsyncKeyState (VK_MENU); - if (ctrl == 0 || alt == 0) - /* Emacs doesn't have keyboard focus. Do nothing. */ - return; - if (!(ctrl & 0x08000)) /* Clear any recorded control modifier state. */ modifiers[EMACS_RCONTROL] = modifiers[EMACS_LCONTROL] = 0; @@ -2785,8 +3496,27 @@ reset_modifiers () /* Clear any recorded alt modifier state. */ modifiers[EMACS_RMENU] = modifiers[EMACS_LMENU] = 0; - /* Otherwise, leave the modifier state as it was when Emacs lost - keyboard focus. */ + /* Update the state of all modifier keys, because modifiers used in + hot-key combinations can get stuck on if Emacs loses focus as a + result of a hot-key being pressed. */ + { + BYTE keystate[256]; + +#define CURRENT_STATE(key) ((GetAsyncKeyState (key) & 0x8000) >> 8) + + GetKeyboardState (keystate); + keystate[VK_SHIFT] = CURRENT_STATE (VK_SHIFT); + keystate[VK_CONTROL] = CURRENT_STATE (VK_CONTROL); + keystate[VK_LCONTROL] = CURRENT_STATE (VK_LCONTROL); + keystate[VK_RCONTROL] = CURRENT_STATE (VK_RCONTROL); + keystate[VK_MENU] = CURRENT_STATE (VK_MENU); + keystate[VK_LMENU] = CURRENT_STATE (VK_LMENU); + keystate[VK_RMENU] = CURRENT_STATE (VK_RMENU); + keystate[VK_LWIN] = CURRENT_STATE (VK_LWIN); + keystate[VK_RWIN] = CURRENT_STATE (VK_RWIN); + keystate[VK_APPS] = CURRENT_STATE (VK_APPS); + SetKeyboardState (keystate); + } } /* Synchronize modifier state with what is reported with the current @@ -2809,7 +3539,7 @@ sync_modifiers () static int modifier_set (int vkey) { - if (vkey == VK_CAPITAL) + if (vkey == VK_CAPITAL || vkey == VK_SCROLL) return (GetKeyState (vkey) & 0x1); if (!modifiers_recorded) return (GetKeyState (vkey) & 0x8000); @@ -2824,105 +3554,472 @@ modifier_set (int vkey) return modifiers[EMACS_LMENU]; case VK_RMENU: return modifiers[EMACS_RMENU]; - default: - break; } return (GetKeyState (vkey) & 0x8000); } +/* Convert between the modifier bits W32 uses and the modifier bits + Emacs uses. */ + +unsigned int +w32_key_to_modifier (int key) +{ + Lisp_Object key_mapping; + + switch (key) + { + case VK_LWIN: + key_mapping = Vw32_lwindow_modifier; + break; + case VK_RWIN: + key_mapping = Vw32_rwindow_modifier; + break; + case VK_APPS: + key_mapping = Vw32_apps_modifier; + break; + case VK_SCROLL: + key_mapping = Vw32_scroll_lock_modifier; + break; + default: + key_mapping = Qnil; + } + + /* NB. This code runs in the input thread, asychronously to the lisp + thread, so we must be careful to ensure access to lisp data is + thread-safe. The following code is safe because the modifier + variable values are updated atomically from lisp and symbols are + not relocated by GC. Also, we don't have to worry about seeing GC + markbits here. */ + if (EQ (key_mapping, Qhyper)) + return hyper_modifier; + if (EQ (key_mapping, Qsuper)) + return super_modifier; + if (EQ (key_mapping, Qmeta)) + return meta_modifier; + if (EQ (key_mapping, Qalt)) + return alt_modifier; + if (EQ (key_mapping, Qctrl)) + return ctrl_modifier; + if (EQ (key_mapping, Qcontrol)) /* synonym for ctrl */ + return ctrl_modifier; + if (EQ (key_mapping, Qshift)) + return shift_modifier; + + /* Don't generate any modifier if not explicitly requested. */ + return 0; +} + +unsigned int +w32_get_modifiers () +{ + return ((modifier_set (VK_SHIFT) ? shift_modifier : 0) | + (modifier_set (VK_CONTROL) ? ctrl_modifier : 0) | + (modifier_set (VK_LWIN) ? w32_key_to_modifier (VK_LWIN) : 0) | + (modifier_set (VK_RWIN) ? w32_key_to_modifier (VK_RWIN) : 0) | + (modifier_set (VK_APPS) ? w32_key_to_modifier (VK_APPS) : 0) | + (modifier_set (VK_SCROLL) ? w32_key_to_modifier (VK_SCROLL) : 0) | + (modifier_set (VK_MENU) ? + ((NILP (Vw32_alt_is_meta)) ? alt_modifier : meta_modifier) : 0)); +} + /* We map the VK_* modifiers into console modifier constants so that we can use the same routines to handle both console and window input. */ static int -construct_modifiers (unsigned int wparam, unsigned int lparam) +construct_console_modifiers () { int mods; - if (wparam != VK_CONTROL && wparam != VK_MENU) - mods = GetLastError (); - mods = 0; mods |= (modifier_set (VK_SHIFT)) ? SHIFT_PRESSED : 0; mods |= (modifier_set (VK_CAPITAL)) ? CAPSLOCK_ON : 0; + mods |= (modifier_set (VK_SCROLL)) ? SCROLLLOCK_ON : 0; + mods |= (modifier_set (VK_NUMLOCK)) ? NUMLOCK_ON : 0; mods |= (modifier_set (VK_LCONTROL)) ? LEFT_CTRL_PRESSED : 0; mods |= (modifier_set (VK_RCONTROL)) ? RIGHT_CTRL_PRESSED : 0; mods |= (modifier_set (VK_LMENU)) ? LEFT_ALT_PRESSED : 0; mods |= (modifier_set (VK_RMENU)) ? RIGHT_ALT_PRESSED : 0; + mods |= (modifier_set (VK_LWIN)) ? LEFT_WIN_PRESSED : 0; + mods |= (modifier_set (VK_RWIN)) ? RIGHT_WIN_PRESSED : 0; + mods |= (modifier_set (VK_APPS)) ? APPS_PRESSED : 0; return mods; } -static unsigned int -map_keypad_keys (unsigned int wparam, unsigned int lparam) +static int +w32_get_key_modifiers (unsigned int wparam, unsigned int lparam) { - unsigned int extended = (lparam & 0x1000000L); + int mods; + + /* Convert to emacs modifiers. */ + mods = w32_kbd_mods_to_emacs (construct_console_modifiers (), wparam); + + return mods; +} - if (wparam < VK_CLEAR || wparam > VK_DELETE) - return wparam; +unsigned int +map_keypad_keys (unsigned int virt_key, unsigned int extended) +{ + if (virt_key < VK_CLEAR || virt_key > VK_DELETE) + return virt_key; - if (wparam == VK_RETURN) + if (virt_key == VK_RETURN) return (extended ? VK_NUMPAD_ENTER : VK_RETURN); - if (wparam >= VK_PRIOR && wparam <= VK_DOWN) - return (!extended ? (VK_NUMPAD_PRIOR + (wparam - VK_PRIOR)) : wparam); + if (virt_key >= VK_PRIOR && virt_key <= VK_DOWN) + return (!extended ? (VK_NUMPAD_PRIOR + (virt_key - VK_PRIOR)) : virt_key); - if (wparam == VK_INSERT || wparam == VK_DELETE) - return (!extended ? (VK_NUMPAD_INSERT + (wparam - VK_INSERT)) : wparam); + if (virt_key == VK_INSERT || virt_key == VK_DELETE) + return (!extended ? (VK_NUMPAD_INSERT + (virt_key - VK_INSERT)) : virt_key); - if (wparam == VK_CLEAR) - return (!extended ? VK_NUMPAD_CLEAR : wparam); + if (virt_key == VK_CLEAR) + return (!extended ? VK_NUMPAD_CLEAR : virt_key); - return wparam; + return virt_key; } -/* Main message dispatch loop. */ +/* List of special key combinations which w32 would normally capture, + but emacs should grab instead. Not directly visible to lisp, to + simplify synchronization. Each item is an integer encoding a virtual + key code and modifier combination to capture. */ +Lisp_Object w32_grabbed_keys; -DWORD -windows_msg_worker (dw) - DWORD dw; +#define HOTKEY(vk,mods) make_number (((vk) & 255) | ((mods) << 8)) +#define HOTKEY_ID(k) (XFASTINT (k) & 0xbfff) +#define HOTKEY_VK_CODE(k) (XFASTINT (k) & 255) +#define HOTKEY_MODIFIERS(k) (XFASTINT (k) >> 8) + +/* Register hot-keys for reserved key combinations when Emacs has + keyboard focus, since this is the only way Emacs can receive key + combinations like Alt-Tab which are used by the system. */ + +static void +register_hot_keys (hwnd) + HWND hwnd; { - MSG msg; - - /* Ensure our message queue is created */ - - PeekMessage (&msg, NULL, 0, 0, PM_NOREMOVE); - - PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0); - - while (GetMessage (&msg, NULL, 0, 0)) + Lisp_Object keylist; + + /* Use GC_CONSP, since we are called asynchronously. */ + for (keylist = w32_grabbed_keys; GC_CONSP (keylist); keylist = XCDR (keylist)) { - if (msg.hwnd == NULL) - { - switch (msg.message) - { - case WM_EMACS_CREATEWINDOW: - w32_createwindow ((struct frame *) msg.wParam); - PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0); - break; - case WM_EMACS_CREATESCROLLBAR: - { - HWND hwnd = w32_createscrollbar ((struct frame *) msg.wParam, - (struct scroll_bar *) msg.lParam); - PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, (WPARAM)hwnd, 0); - } + Lisp_Object key = XCAR (keylist); + + /* Deleted entries get set to nil. */ + if (!INTEGERP (key)) + continue; + + RegisterHotKey (hwnd, HOTKEY_ID (key), + HOTKEY_MODIFIERS (key), HOTKEY_VK_CODE (key)); + } +} + +static void +unregister_hot_keys (hwnd) + HWND hwnd; +{ + Lisp_Object keylist; + + /* Use GC_CONSP, since we are called asynchronously. */ + for (keylist = w32_grabbed_keys; GC_CONSP (keylist); keylist = XCDR (keylist)) + { + Lisp_Object key = XCAR (keylist); + + if (!INTEGERP (key)) + continue; + + UnregisterHotKey (hwnd, HOTKEY_ID (key)); + } +} + +/* Main message dispatch loop. */ + +static void +w32_msg_pump (deferred_msg * msg_buf) +{ + MSG msg; + int result; + HWND focus_window; + + msh_mousewheel = RegisterWindowMessage (MSH_MOUSEWHEEL); + + while (GetMessage (&msg, NULL, 0, 0)) + { + if (msg.hwnd == NULL) + { + switch (msg.message) + { + case WM_NULL: + /* Produced by complete_deferred_msg; just ignore. */ + break; + case WM_EMACS_CREATEWINDOW: + w32_createwindow ((struct frame *) msg.wParam); + if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0)) + abort (); + break; + case WM_EMACS_SETLOCALE: + SetThreadLocale (msg.wParam); + /* Reply is not expected. */ + break; + case WM_EMACS_SETKEYBOARDLAYOUT: + result = (int) ActivateKeyboardLayout ((HKL) msg.wParam, 0); + if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, + result, 0)) + abort (); + break; + case WM_EMACS_REGISTER_HOT_KEY: + focus_window = GetFocus (); + if (focus_window != NULL) + RegisterHotKey (focus_window, + HOTKEY_ID (msg.wParam), + HOTKEY_MODIFIERS (msg.wParam), + HOTKEY_VK_CODE (msg.wParam)); + /* Reply is not expected. */ + break; + case WM_EMACS_UNREGISTER_HOT_KEY: + focus_window = GetFocus (); + if (focus_window != NULL) + UnregisterHotKey (focus_window, HOTKEY_ID (msg.wParam)); + /* Mark item as erased. NB: this code must be + thread-safe. The next line is okay because the cons + cell is never made into garbage and is not relocated by + GC. */ + XCAR ((Lisp_Object) msg.lParam) = Qnil; + if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0)) + abort (); + break; + case WM_EMACS_TOGGLE_LOCK_KEY: + { + int vk_code = (int) msg.wParam; + int cur_state = (GetKeyState (vk_code) & 1); + Lisp_Object new_state = (Lisp_Object) msg.lParam; + + /* NB: This code must be thread-safe. It is safe to + call NILP because symbols are not relocated by GC, + and pointer here is not touched by GC (so the markbit + can't be set). Numbers are safe because they are + immediate values. */ + if (NILP (new_state) + || (NUMBERP (new_state) + && ((XUINT (new_state)) & 1) != cur_state)) + { + one_w32_display_info.faked_key = vk_code; + + keybd_event ((BYTE) vk_code, + (BYTE) MapVirtualKey (vk_code, 0), + KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0); + keybd_event ((BYTE) vk_code, + (BYTE) MapVirtualKey (vk_code, 0), + KEYEVENTF_EXTENDEDKEY | 0, 0); + keybd_event ((BYTE) vk_code, + (BYTE) MapVirtualKey (vk_code, 0), + KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0); + cur_state = !cur_state; + } + if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, + cur_state, 0)) + abort (); + } break; - case WM_EMACS_KILL: - return (0); + default: + DebPrint (("msg %x not expected by w32_msg_pump\n", msg.message)); } } else { DispatchMessage (&msg); } + + /* Exit nested loop when our deferred message has completed. */ + if (msg_buf->completed) + break; + } +} + +deferred_msg * deferred_msg_head; + +static deferred_msg * +find_deferred_msg (HWND hwnd, UINT msg) +{ + deferred_msg * item; + + /* Don't actually need synchronization for read access, since + modification of single pointer is always atomic. */ + /* enter_crit (); */ + + for (item = deferred_msg_head; item != NULL; item = item->next) + if (item->w32msg.msg.hwnd == hwnd + && item->w32msg.msg.message == msg) + break; + + /* leave_crit (); */ + + return item; +} + +static LRESULT +send_deferred_msg (deferred_msg * msg_buf, + HWND hwnd, + UINT msg, + WPARAM wParam, + LPARAM lParam) +{ + /* Only input thread can send deferred messages. */ + if (GetCurrentThreadId () != dwWindowsThreadId) + abort (); + + /* It is an error to send a message that is already deferred. */ + if (find_deferred_msg (hwnd, msg) != NULL) + abort (); + + /* Enforced synchronization is not needed because this is the only + function that alters deferred_msg_head, and the following critical + section is guaranteed to only be serially reentered (since only the + input thread can call us). */ + + /* enter_crit (); */ + + msg_buf->completed = 0; + msg_buf->next = deferred_msg_head; + deferred_msg_head = msg_buf; + my_post_msg (&msg_buf->w32msg, hwnd, msg, wParam, lParam); + + /* leave_crit (); */ + + /* Start a new nested message loop to process other messages until + this one is completed. */ + w32_msg_pump (msg_buf); + + deferred_msg_head = msg_buf->next; + + return msg_buf->result; +} + +void +complete_deferred_msg (HWND hwnd, UINT msg, LRESULT result) +{ + deferred_msg * msg_buf = find_deferred_msg (hwnd, msg); + + if (msg_buf == NULL) + /* Message may have been cancelled, so don't abort(). */ + return; + + msg_buf->result = result; + msg_buf->completed = 1; + + /* Ensure input thread is woken so it notices the completion. */ + PostThreadMessage (dwWindowsThreadId, WM_NULL, 0, 0); +} + +void +cancel_all_deferred_msgs () +{ + deferred_msg * item; + + /* Don't actually need synchronization for read access, since + modification of single pointer is always atomic. */ + /* enter_crit (); */ + + for (item = deferred_msg_head; item != NULL; item = item->next) + { + item->result = 0; + item->completed = 1; } + + /* leave_crit (); */ + + /* Ensure input thread is woken so it notices the completion. */ + PostThreadMessage (dwWindowsThreadId, WM_NULL, 0, 0); +} + +DWORD +w32_msg_worker (dw) + DWORD dw; +{ + MSG msg; + deferred_msg dummy_buf; + + /* Ensure our message queue is created */ + + PeekMessage (&msg, NULL, 0, 0, PM_NOREMOVE); - return (0); + if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0)) + abort (); + + memset (&dummy_buf, 0, sizeof (dummy_buf)); + dummy_buf.w32msg.msg.hwnd = NULL; + dummy_buf.w32msg.msg.message = WM_NULL; + + /* This is the inital message loop which should only exit when the + application quits. */ + w32_msg_pump (&dummy_buf); + + return 0; } -/* Main window procedure */ +static void +post_character_message (hwnd, msg, wParam, lParam, modifiers) + HWND hwnd; + UINT msg; + WPARAM wParam; + LPARAM lParam; + DWORD modifiers; -extern char *lispy_function_keys[]; +{ + W32Msg wmsg; + + wmsg.dwModifiers = modifiers; + + /* Detect quit_char and set quit-flag directly. Note that we + still need to post a message to ensure the main thread will be + woken up if blocked in sys_select(), but we do NOT want to post + the quit_char message itself (because it will usually be as if + the user had typed quit_char twice). Instead, we post a dummy + message that has no particular effect. */ + { + int c = wParam; + if (isalpha (c) && wmsg.dwModifiers == ctrl_modifier) + c = make_ctrl_char (c) & 0377; + if (c == quit_char + || (wmsg.dwModifiers == 0 && + XFASTINT (Vw32_quit_key) && wParam == XFASTINT (Vw32_quit_key))) + { + Vquit_flag = Qt; + + /* The choice of message is somewhat arbitrary, as long as + the main thread handler just ignores it. */ + msg = WM_NULL; + + /* Interrupt any blocking system calls. */ + signal_quit (); + + /* As a safety precaution, forcibly complete any deferred + messages. This is a kludge, but I don't see any particularly + clean way to handle the situation where a deferred message is + "dropped" in the lisp thread, and will thus never be + completed, eg. by the user trying to activate the menubar + when the lisp thread is busy, and then typing C-g when the + menubar doesn't open promptly (with the result that the + menubar never responds at all because the deferred + WM_INITMENU message is never completed). Another problem + situation is when the lisp thread calls SendMessage (to send + a window manager command) when a message has been deferred; + the lisp thread gets blocked indefinitely waiting for the + deferred message to be completed, which itself is waiting for + the lisp thread to respond. + + Note that we don't want to block the input thread waiting for + a reponse from the lisp thread (although that would at least + solve the deadlock problem above), because we want to be able + to receive C-g to interrupt the lisp thread. */ + cancel_all_deferred_msgs (); + } + } + + my_post_msg (&wmsg, hwnd, msg, wParam, lParam); +} + +/* Main window procedure */ LRESULT CALLBACK w32_wnd_proc (hwnd, msg, wParam, lParam) @@ -2932,10 +4029,10 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) LPARAM lParam; { struct frame *f; - LRESULT ret = 1; struct w32_display_info *dpyinfo = &one_w32_display_info; W32Msg wmsg; int windows_translate; + int key; /* Note that it is okay to call x_window_to_frame, even though we are not running in the main lisp thread, because frame deletion @@ -2959,8 +4056,16 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) f = x_window_to_frame (dpyinfo, hwnd); if (f) { + HDC hdc = get_frame_dc (f); GetUpdateRect (hwnd, &wmsg.rect, FALSE); - w32_clear_rect (f, NULL, &wmsg.rect); + w32_clear_rect (f, hdc, &wmsg.rect); + release_frame_dc (f, hdc); + +#if defined (W32_DEBUG_DISPLAY) + DebPrint (("WM_ERASEBKGND: erasing %d,%d-%d,%d\n", + wmsg.rect.left, wmsg.rect.top, wmsg.rect.right, + wmsg.rect.bottom)); +#endif /* W32_DEBUG_DISPLAY */ } return 1; case WM_PALETTECHANGED: @@ -2976,18 +4081,83 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) return 0; case WM_PAINT: { - PAINTSTRUCT paintStruct; + PAINTSTRUCT paintStruct; + RECT update_rect; + + /* MSDN Docs say not to call BeginPaint if GetUpdateRect + fails. Apparently this can happen under some + circumstances. */ + if (!w32_strict_painting || GetUpdateRect (hwnd, &update_rect, FALSE)) + { + enter_crit (); + BeginPaint (hwnd, &paintStruct); + + if (w32_strict_painting) + /* The rectangles returned by GetUpdateRect and BeginPaint + do not always match. GetUpdateRect seems to be the + more reliable of the two. */ + wmsg.rect = update_rect; + else + wmsg.rect = paintStruct.rcPaint; + +#if defined (W32_DEBUG_DISPLAY) + DebPrint (("WM_PAINT: painting %d,%d-%d,%d\n", wmsg.rect.left, + wmsg.rect.top, wmsg.rect.right, wmsg.rect.bottom)); + DebPrint (("WM_PAINT: update region is %d,%d-%d,%d\n", + update_rect.left, update_rect.top, + update_rect.right, update_rect.bottom)); +#endif + EndPaint (hwnd, &paintStruct); + leave_crit (); - enter_crit (); - BeginPaint (hwnd, &paintStruct); - wmsg.rect = paintStruct.rcPaint; - EndPaint (hwnd, &paintStruct); - leave_crit (); + my_post_msg (&wmsg, hwnd, msg, wParam, lParam); + + return 0; + } + /* If GetUpdateRect returns 0 (meaning there is no update + region), assume the whole window needs to be repainted. */ + GetClientRect(hwnd, &wmsg.rect); my_post_msg (&wmsg, hwnd, msg, wParam, lParam); - - return (0); + return 0; + } + + case WM_INPUTLANGCHANGE: + /* Inform lisp thread of keyboard layout changes. */ + my_post_msg (&wmsg, hwnd, msg, wParam, lParam); + + /* Clear dead keys in the keyboard state; for simplicity only + preserve modifier key states. */ + { + int i; + BYTE keystate[256]; + + GetKeyboardState (keystate); + for (i = 0; i < 256; i++) + if (1 + && i != VK_SHIFT + && i != VK_LSHIFT + && i != VK_RSHIFT + && i != VK_CAPITAL + && i != VK_NUMLOCK + && i != VK_SCROLL + && i != VK_CONTROL + && i != VK_LCONTROL + && i != VK_RCONTROL + && i != VK_MENU + && i != VK_LMENU + && i != VK_RMENU + && i != VK_LWIN + && i != VK_RWIN) + keystate[i] = 0; + SetKeyboardState (keystate); } + goto dflt; + + case WM_HOTKEY: + /* Synchronize hot keys with normal input. */ + PostMessage (hwnd, WM_KEYDOWN, HIWORD (lParam), 0); + return (0); case WM_KEYUP: case WM_SYSKEYUP: @@ -2996,41 +4166,203 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) case WM_KEYDOWN: case WM_SYSKEYDOWN: + /* Ignore keystrokes we fake ourself; see below. */ + if (dpyinfo->faked_key == wParam) + { + dpyinfo->faked_key = 0; + /* Make sure TranslateMessage sees them though (as long as + they don't produce WM_CHAR messages). This ensures that + indicator lights are toggled promptly on Windows 9x, for + example. */ + if (lispy_function_keys[wParam] != 0) + { + windows_translate = 1; + goto translate; + } + return 0; + } + /* Synchronize modifiers with current keystroke. */ sync_modifiers (); - record_keydown (wParam, lParam); - - wParam = map_keypad_keys (wParam, lParam); + wParam = map_keypad_keys (wParam, (lParam & 0x1000000L) != 0); windows_translate = 0; - switch (wParam) { - case VK_LWIN: - case VK_RWIN: - case VK_APPS: - /* More support for these keys will likely be necessary. */ - if (!NILP (Vw32_pass_optional_keys_to_system)) + + switch (wParam) + { + case VK_LWIN: + if (NILP (Vw32_pass_lwindow_to_system)) + { + /* Prevent system from acting on keyup (which opens the + Start menu if no other key was pressed) by simulating a + press of Space which we will ignore. */ + if (GetAsyncKeyState (wParam) & 1) + { + if (NUMBERP (Vw32_phantom_key_code)) + key = XUINT (Vw32_phantom_key_code) & 255; + else + key = VK_SPACE; + dpyinfo->faked_key = key; + keybd_event (key, (BYTE) MapVirtualKey (key, 0), 0, 0); + } + } + if (!NILP (Vw32_lwindow_modifier)) + return 0; + break; + case VK_RWIN: + if (NILP (Vw32_pass_rwindow_to_system)) + { + if (GetAsyncKeyState (wParam) & 1) + { + if (NUMBERP (Vw32_phantom_key_code)) + key = XUINT (Vw32_phantom_key_code) & 255; + else + key = VK_SPACE; + dpyinfo->faked_key = key; + keybd_event (key, (BYTE) MapVirtualKey (key, 0), 0, 0); + } + } + if (!NILP (Vw32_rwindow_modifier)) + return 0; + break; + case VK_APPS: + if (!NILP (Vw32_apps_modifier)) + return 0; + break; + case VK_MENU: + if (NILP (Vw32_pass_alt_to_system)) + /* Prevent DefWindowProc from activating the menu bar if an + Alt key is pressed and released by itself. */ + return 0; windows_translate = 1; - break; - case VK_MENU: - if (NILP (Vw32_pass_alt_to_system)) - return 0; - windows_translate = 1; - break; - case VK_CONTROL: - case VK_CAPITAL: - case VK_SHIFT: - case VK_NUMLOCK: - case VK_SCROLL: - windows_translate = 1; - break; - default: - /* If not defined as a function key, change it to a WM_CHAR message. */ - if (lispy_function_keys[wParam] == 0) - msg = WM_CHAR; - break; - } + break; + case VK_CAPITAL: + /* Decide whether to treat as modifier or function key. */ + if (NILP (Vw32_enable_caps_lock)) + goto disable_lock_key; + windows_translate = 1; + break; + case VK_NUMLOCK: + /* Decide whether to treat as modifier or function key. */ + if (NILP (Vw32_enable_num_lock)) + goto disable_lock_key; + windows_translate = 1; + break; + case VK_SCROLL: + /* Decide whether to treat as modifier or function key. */ + if (NILP (Vw32_scroll_lock_modifier)) + goto disable_lock_key; + windows_translate = 1; + break; + disable_lock_key: + /* Ensure the appropriate lock key state (and indicator light) + remains in the same state. We do this by faking another + press of the relevant key. Apparently, this really is the + only way to toggle the state of the indicator lights. */ + dpyinfo->faked_key = wParam; + keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0), + KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0); + keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0), + KEYEVENTF_EXTENDEDKEY | 0, 0); + keybd_event ((BYTE) wParam, (BYTE) MapVirtualKey (wParam, 0), + KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0); + /* Ensure indicator lights are updated promptly on Windows 9x + (TranslateMessage apparently does this), after forwarding + input event. */ + post_character_message (hwnd, msg, wParam, lParam, + w32_get_key_modifiers (wParam, lParam)); + windows_translate = 1; + break; + case VK_CONTROL: + case VK_SHIFT: + case VK_PROCESSKEY: /* Generated by IME. */ + windows_translate = 1; + break; + case VK_CANCEL: + /* Windows maps Ctrl-Pause (aka Ctrl-Break) into VK_CANCEL, + which is confusing for purposes of key binding; convert + VK_CANCEL events into VK_PAUSE events. */ + wParam = VK_PAUSE; + break; + case VK_PAUSE: + /* Windows maps Ctrl-NumLock into VK_PAUSE, which is confusing + for purposes of key binding; convert these back into + VK_NUMLOCK events, at least when we want to see NumLock key + presses. (Note that there is never any possibility that + VK_PAUSE with Ctrl really is C-Pause as per above.) */ + if (NILP (Vw32_enable_num_lock) && modifier_set (VK_CONTROL)) + wParam = VK_NUMLOCK; + break; + default: + /* If not defined as a function key, change it to a WM_CHAR message. */ + if (lispy_function_keys[wParam] == 0) + { + DWORD modifiers = construct_console_modifiers (); + + if (!NILP (Vw32_recognize_altgr) + && modifier_set (VK_LCONTROL) && modifier_set (VK_RMENU)) + { + /* Always let TranslateMessage handle AltGr key chords; + for some reason, ToAscii doesn't always process AltGr + chords correctly. */ + windows_translate = 1; + } + else if ((modifiers & (~SHIFT_PRESSED & ~CAPSLOCK_ON)) != 0) + { + /* Handle key chords including any modifiers other + than shift directly, in order to preserve as much + modifier information as possible. */ + if ('A' <= wParam && wParam <= 'Z') + { + /* Don't translate modified alphabetic keystrokes, + so the user doesn't need to constantly switch + layout to type control or meta keystrokes when + the normal layout translates alphabetic + characters to non-ascii characters. */ + if (!modifier_set (VK_SHIFT)) + wParam += ('a' - 'A'); + msg = WM_CHAR; + } + else + { + /* Try to handle other keystrokes by determining the + base character (ie. translating the base key plus + shift modifier). */ + int add; + int isdead = 0; + KEY_EVENT_RECORD key; + + key.bKeyDown = TRUE; + key.wRepeatCount = 1; + key.wVirtualKeyCode = wParam; + key.wVirtualScanCode = (lParam & 0xFF0000) >> 16; + key.uChar.AsciiChar = 0; + key.dwControlKeyState = modifiers; + + add = w32_kbd_patch_key (&key); + /* 0 means an unrecognised keycode, negative means + dead key. Ignore both. */ + while (--add >= 0) + { + /* Forward asciified character sequence. */ + post_character_message + (hwnd, WM_CHAR, key.uChar.AsciiChar, lParam, + w32_get_key_modifiers (wParam, lParam)); + w32_kbd_patch_key (&key); + } + return 0; + } + } + else + { + /* Let TranslateMessage handle everything else. */ + windows_translate = 1; + } + } + } + translate: if (windows_translate) { MSG windows_msg = { hwnd, msg, wParam, lParam, 0, {0,0} }; @@ -3044,40 +4376,15 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) case WM_SYSCHAR: case WM_CHAR: - wmsg.dwModifiers = construct_modifiers (wParam, lParam); - -#if 1 - /* Detect quit_char and set quit-flag directly. Note that we - still need to post a message to ensure the main thread will be - woken up if blocked in sys_select(), but we do NOT want to post - the quit_char message itself (because it will usually be as if - the user had typed quit_char twice). Instead, we post a dummy - message that has no particular effect. */ - { - int c = wParam; - if (isalpha (c) && (wmsg.dwModifiers == LEFT_CTRL_PRESSED - || wmsg.dwModifiers == RIGHT_CTRL_PRESSED)) - c = make_ctrl_char (c) & 0377; - if (c == quit_char) - { - Vquit_flag = Qt; - - /* The choice of message is somewhat arbitrary, as long as - the main thread handler just ignores it. */ - msg = WM_QUIT; - } - } -#endif - - my_post_msg (&wmsg, hwnd, msg, wParam, lParam); - + post_character_message (hwnd, msg, wParam, lParam, + w32_get_key_modifiers (wParam, lParam)); break; /* Simulate middle mouse button events when left and right buttons are used together, but only if user has two button mouse. */ case WM_LBUTTONDOWN: case WM_RBUTTONDOWN: - if (XINT (Vw32_num_mouse_buttons) == 3) + if (XINT (Vw32_num_mouse_buttons) > 2) goto handle_plain_button; { @@ -3126,7 +4433,8 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) { /* Hold onto message for now. */ mouse_button_timer = - SetTimer (hwnd, MOUSE_BUTTON_ID, XINT (Vw32_mouse_button_tolerance), NULL); + SetTimer (hwnd, MOUSE_BUTTON_ID, + XINT (Vw32_mouse_button_tolerance), NULL); saved_mouse_button_msg.msg.hwnd = hwnd; saved_mouse_button_msg.msg.message = msg; saved_mouse_button_msg.msg.wParam = wParam; @@ -3139,7 +4447,7 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) case WM_LBUTTONUP: case WM_RBUTTONUP: - if (XINT (Vw32_num_mouse_buttons) == 3) + if (XINT (Vw32_num_mouse_buttons) > 2) goto handle_plain_button; { @@ -3190,11 +4498,18 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) handle_plain_button: { BOOL up; + int button; - if (parse_button (msg, NULL, &up)) + if (parse_button (msg, &button, &up)) { if (up) ReleaseCapture (); else SetCapture (hwnd); + button = (button == 0) ? LMOUSE : + ((button == 1) ? MMOUSE : RMOUSE); + if (up) + button_state &= ~button; + else + button_state |= button; } } @@ -3219,7 +4534,8 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) if (saved_mouse_move_msg.msg.hwnd == 0) mouse_move_timer = - SetTimer (hwnd, MOUSE_MOVE_ID, XINT (Vw32_mouse_move_interval), NULL); + SetTimer (hwnd, MOUSE_MOVE_ID, + XINT (Vw32_mouse_move_interval), NULL); /* Hold onto message for now. */ saved_mouse_move_msg.msg.hwnd = hwnd; @@ -3231,6 +4547,16 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) return 0; + case WM_MOUSEWHEEL: + wmsg.dwModifiers = w32_get_modifiers (); + my_post_msg (&wmsg, hwnd, msg, wParam, lParam); + return 0; + + case WM_DROPFILES: + wmsg.dwModifiers = w32_get_modifiers (); + my_post_msg (&wmsg, hwnd, msg, wParam, lParam); + return 0; + case WM_TIMER: /* Flush out saved messages if necessary. */ if (wParam == mouse_button_timer) @@ -3264,13 +4590,174 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) reset_modifiers (); goto dflt; + case WM_INITMENU: + button_state = 0; + ReleaseCapture (); + /* We must ensure menu bar is fully constructed and up to date + before allowing user interaction with it. To achieve this + we send this message to the lisp thread and wait for a + reply (whose value is not actually needed) to indicate that + the menu bar is now ready for use, so we can now return. + + To remain responsive in the meantime, we enter a nested message + loop that can process all other messages. + + However, we skip all this if the message results from calling + TrackPopupMenu - in fact, we must NOT attempt to send the lisp + thread a message because it is blocked on us at this point. We + set menubar_active before calling TrackPopupMenu to indicate + this (there is no possibility of confusion with real menubar + being active). */ + + f = x_window_to_frame (dpyinfo, hwnd); + if (f + && (f->output_data.w32->menubar_active + /* We can receive this message even in the absence of a + menubar (ie. when the system menu is activated) - in this + case we do NOT want to forward the message, otherwise it + will cause the menubar to suddenly appear when the user + had requested it to be turned off! */ + || f->output_data.w32->menubar_widget == NULL)) + return 0; + + { + deferred_msg msg_buf; + + /* Detect if message has already been deferred; in this case + we cannot return any sensible value to ignore this. */ + if (find_deferred_msg (hwnd, msg) != NULL) + abort (); + + return send_deferred_msg (&msg_buf, hwnd, msg, wParam, lParam); + } + + case WM_EXITMENULOOP: + f = x_window_to_frame (dpyinfo, hwnd); + + /* Indicate that menubar can be modified again. */ + if (f) + f->output_data.w32->menubar_active = 0; + goto dflt; + + case WM_MENUSELECT: + wmsg.dwModifiers = w32_get_modifiers (); + my_post_msg (&wmsg, hwnd, msg, wParam, lParam); + return 0; + + case WM_MEASUREITEM: + f = x_window_to_frame (dpyinfo, hwnd); + if (f) + { + MEASUREITEMSTRUCT * pMis = (MEASUREITEMSTRUCT *) lParam; + + if (pMis->CtlType == ODT_MENU) + { + /* Work out dimensions for popup menu titles. */ + char * title = (char *) pMis->itemData; + HDC hdc = GetDC (hwnd); + HFONT menu_font = GetCurrentObject (hdc, OBJ_FONT); + LOGFONT menu_logfont; + HFONT old_font; + SIZE size; + + GetObject (menu_font, sizeof (menu_logfont), &menu_logfont); + menu_logfont.lfWeight = FW_BOLD; + menu_font = CreateFontIndirect (&menu_logfont); + old_font = SelectObject (hdc, menu_font); + + pMis->itemHeight = GetSystemMetrics (SM_CYMENUSIZE); + if (title) + { + GetTextExtentPoint32 (hdc, title, strlen (title), &size); + pMis->itemWidth = size.cx; + if (pMis->itemHeight < size.cy) + pMis->itemHeight = size.cy; + } + else + pMis->itemWidth = 0; + + SelectObject (hdc, old_font); + DeleteObject (menu_font); + ReleaseDC (hwnd, hdc); + return TRUE; + } + } + return 0; + + case WM_DRAWITEM: + f = x_window_to_frame (dpyinfo, hwnd); + if (f) + { + DRAWITEMSTRUCT * pDis = (DRAWITEMSTRUCT *) lParam; + + if (pDis->CtlType == ODT_MENU) + { + /* Draw popup menu title. */ + char * title = (char *) pDis->itemData; + if (title) + { + HDC hdc = pDis->hDC; + HFONT menu_font = GetCurrentObject (hdc, OBJ_FONT); + LOGFONT menu_logfont; + HFONT old_font; + + GetObject (menu_font, sizeof (menu_logfont), &menu_logfont); + menu_logfont.lfWeight = FW_BOLD; + menu_font = CreateFontIndirect (&menu_logfont); + old_font = SelectObject (hdc, menu_font); + + /* Always draw title as if not selected. */ + ExtTextOut (hdc, + pDis->rcItem.left + + GetSystemMetrics (SM_CXMENUCHECK), + pDis->rcItem.top, + ETO_OPAQUE, &pDis->rcItem, + title, strlen (title), NULL); + + SelectObject (hdc, old_font); + DeleteObject (menu_font); + } + return TRUE; + } + } + return 0; + +#if 0 + /* Still not right - can't distinguish between clicks in the + client area of the frame from clicks forwarded from the scroll + bars - may have to hook WM_NCHITTEST to remember the mouse + position and then check if it is in the client area ourselves. */ + case WM_MOUSEACTIVATE: + /* Discard the mouse click that activates a frame, allowing the + user to click anywhere without changing point (or worse!). + Don't eat mouse clicks on scrollbars though!! */ + if (LOWORD (lParam) == HTCLIENT ) + return MA_ACTIVATEANDEAT; + goto dflt; +#endif + + case WM_ACTIVATEAPP: + case WM_ACTIVATE: + case WM_WINDOWPOSCHANGED: + case WM_SHOWWINDOW: + /* Inform lisp thread that a frame might have just been obscured + or exposed, so should recheck visibility of all frames. */ + my_post_msg (&wmsg, hwnd, msg, wParam, lParam); + goto dflt; + case WM_SETFOCUS: + dpyinfo->faked_key = 0; reset_modifiers (); + register_hot_keys (hwnd); + goto command; case WM_KILLFOCUS: + unregister_hot_keys (hwnd); + button_state = 0; + ReleaseCapture (); case WM_MOVE: case WM_SIZE: - case WM_SYSCOMMAND: case WM_COMMAND: + command: wmsg.dwModifiers = w32_get_modifiers (); my_post_msg (&wmsg, hwnd, msg, wParam, lParam); goto dflt; @@ -3284,16 +4771,19 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) { WINDOWPLACEMENT wp; LPWINDOWPOS lppos = (WINDOWPOS *) lParam; - + + wp.length = sizeof (WINDOWPLACEMENT); GetWindowPlacement (hwnd, &wp); - if (wp.showCmd != SW_SHOWMINIMIZED && ! (lppos->flags & SWP_NOSIZE)) + if (wp.showCmd != SW_SHOWMINIMIZED && (lppos->flags & SWP_NOSIZE) == 0) { RECT rect; int wdiff; int hdiff; - DWORD dwXUnits; - DWORD dwYUnits; + DWORD font_width; + DWORD line_height; + DWORD internal_border; + DWORD scrollbar_extra; RECT wr; wp.length = sizeof(wp); @@ -3301,8 +4791,10 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) enter_crit (); - dwXUnits = GetWindowLong (hwnd, WND_X_UNITS_INDEX); - dwYUnits = GetWindowLong (hwnd, WND_Y_UNITS_INDEX); + font_width = GetWindowLong (hwnd, WND_FONTWIDTH_INDEX); + line_height = GetWindowLong (hwnd, WND_LINEHEIGHT_INDEX); + internal_border = GetWindowLong (hwnd, WND_BORDER_INDEX); + scrollbar_extra = GetWindowLong (hwnd, WND_SCROLLBAR_INDEX); leave_crit (); @@ -3310,10 +4802,14 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) AdjustWindowRect (&rect, GetWindowLong (hwnd, GWL_STYLE), GetMenu (hwnd) != NULL); - /* All windows have an extra pixel so subtract 1 */ - - wdiff = (lppos->cx - (rect.right - rect.left) - 0) % dwXUnits; - hdiff = (lppos->cy - (rect.bottom - rect.top) - 0) % dwYUnits; + /* Force width and height of client area to be exact + multiples of the character cell dimensions. */ + wdiff = (lppos->cx - (rect.right - rect.left) + - 2 * internal_border - scrollbar_extra) + % font_width; + hdiff = (lppos->cy - (rect.bottom - rect.top) + - 2 * internal_border) + % line_height; if (wdiff || hdiff) { @@ -3325,7 +4821,7 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) lppos->cy -= hdiff; if (wp.showCmd != SW_SHOWMAXIMIZED - && ! (lppos->flags & SWP_NOMOVE)) + && (lppos->flags & SWP_NOMOVE) == 0) { if (lppos->x != wr.left || lppos->y != wr.top) { @@ -3338,40 +4834,141 @@ w32_wnd_proc (hwnd, msg, wParam, lParam) } } - ret = 0; + return 0; } } } - - if (ret == 0) return (0); goto dflt; + + case WM_GETMINMAXINFO: + /* Hack to correct bug that allows Emacs frames to be resized + below the Minimum Tracking Size. */ + ((LPMINMAXINFO) lParam)->ptMinTrackSize.y++; + /* Hack to allow resizing the Emacs frame above the screen size. + Note that Windows 9x limits coordinates to 16-bits. */ + ((LPMINMAXINFO) lParam)->ptMaxTrackSize.x = 32767; + ((LPMINMAXINFO) lParam)->ptMaxTrackSize.y = 32767; + return 0; + + case WM_EMACS_CREATESCROLLBAR: + return (LRESULT) w32_createscrollbar ((struct frame *) wParam, + (struct scroll_bar *) lParam); + case WM_EMACS_SHOWWINDOW: - return ShowWindow (hwnd, wParam); + return ShowWindow ((HWND) wParam, (WPARAM) lParam); + + case WM_EMACS_SETFOREGROUND: + { + HWND foreground_window; + DWORD foreground_thread, retval; + + /* On NT 5.0, and apparently Windows 98, it is necessary to + attach to the thread that currently has focus in order to + pull the focus away from it. */ + foreground_window = GetForegroundWindow (); + foreground_thread = GetWindowThreadProcessId (foreground_window, NULL); + if (!foreground_window + || foreground_thread == GetCurrentThreadId () + || !AttachThreadInput (GetCurrentThreadId (), + foreground_thread, TRUE)) + foreground_thread = 0; + + retval = SetForegroundWindow ((HWND) wParam); + + /* Detach from the previous foreground thread. */ + if (foreground_thread) + AttachThreadInput (GetCurrentThreadId (), + foreground_thread, FALSE); + + return retval; + } + case WM_EMACS_SETWINDOWPOS: { - W32WindowPos * pos = (W32WindowPos *) wParam; - return SetWindowPos (hwnd, pos->hwndAfter, + WINDOWPOS * pos = (WINDOWPOS *) wParam; + return SetWindowPos (hwnd, pos->hwndInsertAfter, pos->x, pos->y, pos->cx, pos->cy, pos->flags); } + case WM_EMACS_DESTROYWINDOW: - DestroyWindow ((HWND) wParam); - break; - default: - dflt: - return DefWindowProc (hwnd, msg, wParam, lParam); - } - - return (1); -} + DragAcceptFiles ((HWND) wParam, FALSE); + return DestroyWindow ((HWND) wParam); -void -my_create_window (f) - struct frame * f; + case WM_EMACS_TRACKPOPUPMENU: + { + UINT flags; + POINT *pos; + int retval; + pos = (POINT *)lParam; + flags = TPM_CENTERALIGN; + if (button_state & LMOUSE) + flags |= TPM_LEFTBUTTON; + else if (button_state & RMOUSE) + flags |= TPM_RIGHTBUTTON; + + /* Remember we did a SetCapture on the initial mouse down event, + so for safety, we make sure the capture is cancelled now. */ + ReleaseCapture (); + button_state = 0; + + /* Use menubar_active to indicate that WM_INITMENU is from + TrackPopupMenu below, and should be ignored. */ + f = x_window_to_frame (dpyinfo, hwnd); + if (f) + f->output_data.w32->menubar_active = 1; + + if (TrackPopupMenu ((HMENU)wParam, flags, pos->x, pos->y, + 0, hwnd, NULL)) + { + MSG amsg; + /* Eat any mouse messages during popupmenu */ + while (PeekMessage (&amsg, hwnd, WM_MOUSEFIRST, WM_MOUSELAST, + PM_REMOVE)); + /* Get the menu selection, if any */ + if (PeekMessage (&amsg, hwnd, WM_COMMAND, WM_COMMAND, PM_REMOVE)) + { + retval = LOWORD (amsg.wParam); + } + else + { + retval = 0; + } + } + else + { + retval = -1; + } + + return retval; + } + + default: + /* Check for messages registered at runtime. */ + if (msg == msh_mousewheel) + { + wmsg.dwModifiers = w32_get_modifiers (); + my_post_msg (&wmsg, hwnd, msg, wParam, lParam); + return 0; + } + + dflt: + return DefWindowProc (hwnd, msg, wParam, lParam); + } + + + /* The most common default return code for handled messages is 0. */ + return 0; +} + +void +my_create_window (f) + struct frame * f; { MSG msg; - PostThreadMessage (dwWindowsThreadId, WM_EMACS_CREATEWINDOW, (WPARAM)f, 0); + if (!PostThreadMessage (dwWindowsThreadId, WM_EMACS_CREATEWINDOW, (WPARAM)f, 0)) + abort (); GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE); } @@ -3437,8 +5034,8 @@ x_icon (f, parms) /* Set the position of the icon. Note that Windows 95 groups all icons in the tray. */ - icon_x = x_get_arg (parms, Qicon_left, 0, 0, number); - icon_y = x_get_arg (parms, Qicon_top, 0, 0, number); + icon_x = w32_get_arg (parms, Qicon_left, 0, 0, RES_TYPE_NUMBER); + icon_y = w32_get_arg (parms, Qicon_top, 0, 0, RES_TYPE_NUMBER); if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound)) { CHECK_NUMBER (icon_x, 0); @@ -3452,9 +5049,82 @@ x_icon (f, parms) if (! EQ (icon_x, Qunbound)) x_wm_set_icon_position (f, XINT (icon_x), XINT (icon_y)); +#if 0 /* TODO */ + /* Start up iconic or window? */ + x_wm_set_window_state + (f, (EQ (w32_get_arg (parms, Qvisibility, 0, 0, RES_TYPE_SYMBOL), Qicon) + ? IconicState + : NormalState)); + + x_text_icon (f, (char *) XSTRING ((!NILP (f->icon_name) + ? f->icon_name + : f->name))->data); +#endif + + UNBLOCK_INPUT; +} + + +static void +x_make_gc (f) + struct frame *f; +{ + XGCValues gc_values; + + BLOCK_INPUT; + + /* Create the GC's of this frame. + Note that many default values are used. */ + + /* Normal video */ + gc_values.font = f->output_data.w32->font; + + /* Cursor has cursor-color background, background-color foreground. */ + gc_values.foreground = FRAME_BACKGROUND_PIXEL (f); + gc_values.background = f->output_data.w32->cursor_pixel; + f->output_data.w32->cursor_gc + = XCreateGC (NULL, FRAME_W32_WINDOW (f), + (GCFont | GCForeground | GCBackground), + &gc_values); + + /* Reliefs. */ + f->output_data.w32->white_relief.gc = 0; + f->output_data.w32->black_relief.gc = 0; + UNBLOCK_INPUT; } + +/* Handler for signals raised during x_create_frame and + x_create_top_frame. FRAME is the frame which is partially + constructed. */ + +static Lisp_Object +unwind_create_frame (frame) + Lisp_Object frame; +{ + struct frame *f = XFRAME (frame); + + /* If frame is ``official'', nothing to do. */ + if (!CONSP (Vframe_list) || !EQ (XCAR (Vframe_list), frame)) + { +#ifdef GLYPH_DEBUG + struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f); +#endif + + x_free_frame_resources (f); + + /* Check that reference counts are indeed correct. */ + xassert (dpyinfo->reference_count == dpyinfo_refcount); + xassert (dpyinfo->image_cache->refcount == image_cache_refcount); + + return Qt; + } + + return Qnil; +} + + DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, 1, 1, 0, "Make a new window, which is called a \"frame\" in Emacs terms.\n\ @@ -3475,18 +5145,20 @@ This function is an internal primitive--use `make-frame' instead.") int minibuffer_only = 0; long window_prompting = 0; int width, height; - int count = specpdl_ptr - specpdl; - struct gcpro gcpro1; + int count = BINDING_STACK_SIZE (); + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; Lisp_Object display; - struct w32_display_info *dpyinfo; + struct w32_display_info *dpyinfo = NULL; Lisp_Object parent; struct kboard *kb; + check_w32 (); + /* Use this general default value to start with until we know if this frame has a specified name. */ Vx_resource_name = Vinvocation_name; - display = x_get_arg (parms, Qdisplay, 0, 0, string); + display = w32_get_arg (parms, Qdisplay, 0, 0, RES_TYPE_STRING); if (EQ (display, Qunbound)) display = Qnil; dpyinfo = check_x_display_info (display); @@ -3496,7 +5168,7 @@ This function is an internal primitive--use `make-frame' instead.") kb = &the_only_kboard; #endif - name = x_get_arg (parms, Qname, "title", "Title", string); + name = w32_get_arg (parms, Qname, "name", "Name", RES_TYPE_STRING); if (!STRINGP (name) && ! EQ (name, Qunbound) && ! NILP (name)) @@ -3506,13 +5178,19 @@ This function is an internal primitive--use `make-frame' instead.") Vx_resource_name = name; /* See if parent window is specified. */ - parent = x_get_arg (parms, Qparent_id, NULL, NULL, number); + parent = w32_get_arg (parms, Qparent_id, NULL, NULL, RES_TYPE_NUMBER); if (EQ (parent, Qunbound)) parent = Qnil; if (! NILP (parent)) CHECK_NUMBER (parent, 0); - tem = x_get_arg (parms, Qminibuffer, 0, 0, symbol); + /* make_frame_without_minibuffer can run Lisp code and garbage collect. */ + /* No need to protect DISPLAY because that's not used after passing + it to make_frame_without_minibuffer. */ + frame = Qnil; + GCPRO4 (parms, parent, name, frame); + tem = w32_get_arg (parms, Qminibuffer, "minibuffer", "Minibuffer", + RES_TYPE_SYMBOL); if (EQ (tem, Qnone) || NILP (tem)) f = make_frame_without_minibuffer (Qnil, kb, display); else if (EQ (tem, Qonly)) @@ -3525,17 +5203,24 @@ This function is an internal primitive--use `make-frame' instead.") else f = make_frame (1); + XSETFRAME (frame, f); + /* Note that Windows does support scroll bars. */ FRAME_CAN_HAVE_SCROLL_BARS (f) = 1; /* By default, make scrollbars the system standard width. */ f->scroll_bar_pixel_width = GetSystemMetrics (SM_CXVSCROLL); - XSETFRAME (frame, f); - GCPRO1 (frame); - f->output_method = output_w32; - f->output_data.w32 = (struct w32_output *) xmalloc (sizeof (struct w32_output)); + f->output_data.w32 = + (struct w32_output *) xmalloc (sizeof (struct w32_output)); bzero (f->output_data.w32, sizeof (struct w32_output)); + FRAME_FONTSET (f) = -1; + record_unwind_protect (unwind_create_frame, frame); + + f->icon_name + = w32_get_arg (parms, Qicon_name, "iconName", "Title", RES_TYPE_STRING); + if (! STRINGP (f->icon_name)) + f->icon_name = Qnil; /* FRAME_W32_DISPLAY_INFO (f) = dpyinfo; */ #ifdef MULTI_KBOARD @@ -3546,7 +5231,7 @@ This function is an internal primitive--use `make-frame' instead.") if (!NILP (parent)) { - f->output_data.w32->parent_desc = (Window) parent; + f->output_data.w32->parent_desc = (Window) XFASTINT (parent); f->output_data.w32->explicit_parent = 1; } else @@ -3555,9 +5240,6 @@ This function is an internal primitive--use `make-frame' instead.") f->output_data.w32->explicit_parent = 0; } - /* Note that the frame has no physical cursor right now. */ - f->phys_cursor_x = -1; - /* Set the name; the functions to which we pass f expect the name to be set. */ if (EQ (name, Qunbound) || NILP (name)) @@ -3578,39 +5260,36 @@ This function is an internal primitive--use `make-frame' instead.") { Lisp_Object font; - font = x_get_arg (parms, Qfont, "font", "Font", string); + font = w32_get_arg (parms, Qfont, "font", "Font", RES_TYPE_STRING); + BLOCK_INPUT; /* First, try whatever font the caller has specified. */ if (STRINGP (font)) - font = x_new_font (f, XSTRING (font)->data); -#if 0 + { + tem = Fquery_fontset (font, Qnil); + if (STRINGP (tem)) + font = x_new_fontset (f, XSTRING (tem)->data); + else + font = x_new_font (f, XSTRING (font)->data); + } /* Try out a font which we hope has bold and italic variations. */ if (!STRINGP (font)) - font = x_new_font (f, "-misc-fixed-medium-r-normal-*-*-140-*-*-c-*-iso8859-1"); + font = x_new_font (f, "-*-Courier New-normal-r-*-*-*-100-*-*-c-*-iso8859-1"); if (! STRINGP (font)) - font = x_new_font (f, "-*-*-medium-r-normal-*-*-140-*-*-c-*-iso8859-1"); - if (! STRINGP (font)) - /* This was formerly the first thing tried, but it finds too many fonts - and takes too long. */ - font = x_new_font (f, "-*-*-medium-r-*-*-*-*-*-*-c-*-iso8859-1"); + font = x_new_font (f, "-*-Courier-normal-r-*-*-13-*-*-*-c-*-iso8859-1"); /* If those didn't work, look for something which will at least work. */ if (! STRINGP (font)) - font = x_new_font (f, "-*-fixed-*-*-*-*-*-140-*-*-c-*-iso8859-1"); - if (! STRINGP (font)) - font = x_new_font (f, "-*-system-medium-r-normal-*-*-200-*-*-c-120-*-*"); -#endif - if (! STRINGP (font)) - font = x_new_font (f, "-*-Fixedsys-*-r-*-*-12-90-*-*-c-*-*-*"); + font = x_new_font (f, "-*-Fixedsys-normal-r-*-*-12-*-*-*-c-*-iso8859-1"); UNBLOCK_INPUT; if (! STRINGP (font)) - font = build_string ("-*-system"); + font = build_string ("Fixedsys"); x_default_parameter (f, parms, Qfont, font, - "font", "Font", string); + "font", "Font", RES_TYPE_STRING); } x_default_parameter (f, parms, Qborder_width, make_number (2), - "borderwidth", "BorderWidth", number); + "borderWidth", "BorderWidth", RES_TYPE_NUMBER); /* This defaults to 2 in order to match xterm. We recognize either internalBorderWidth or internalBorder (which is what xterm calls it). */ @@ -3618,33 +5297,51 @@ This function is an internal primitive--use `make-frame' instead.") { Lisp_Object value; - value = x_get_arg (parms, Qinternal_border_width, - "internalBorder", "BorderWidth", number); + value = w32_get_arg (parms, Qinternal_border_width, + "internalBorder", "InternalBorder", RES_TYPE_NUMBER); if (! EQ (value, Qunbound)) parms = Fcons (Fcons (Qinternal_border_width, value), parms); } + /* Default internalBorderWidth to 0 on Windows to match other programs. */ x_default_parameter (f, parms, Qinternal_border_width, make_number (0), - "internalBorderWidth", "BorderWidth", number); - x_default_parameter (f, parms, Qvertical_scroll_bars, Qt, - "verticalScrollBars", "ScrollBars", boolean); + "internalBorderWidth", "InternalBorder", RES_TYPE_NUMBER); + x_default_parameter (f, parms, Qvertical_scroll_bars, Qright, + "verticalScrollBars", "ScrollBars", RES_TYPE_SYMBOL); /* Also do the stuff which must be set before the window exists. */ x_default_parameter (f, parms, Qforeground_color, build_string ("black"), - "foreground", "Foreground", string); + "foreground", "Foreground", RES_TYPE_STRING); x_default_parameter (f, parms, Qbackground_color, build_string ("white"), - "background", "Background", string); + "background", "Background", RES_TYPE_STRING); x_default_parameter (f, parms, Qmouse_color, build_string ("black"), - "pointerColor", "Foreground", string); + "pointerColor", "Foreground", RES_TYPE_STRING); x_default_parameter (f, parms, Qcursor_color, build_string ("black"), - "cursorColor", "Foreground", string); + "cursorColor", "Foreground", RES_TYPE_STRING); x_default_parameter (f, parms, Qborder_color, build_string ("black"), - "borderColor", "BorderColor", string); - + "borderColor", "BorderColor", RES_TYPE_STRING); + x_default_parameter (f, parms, Qscreen_gamma, Qnil, + "screenGamma", "ScreenGamma", RES_TYPE_FLOAT); + x_default_parameter (f, parms, Qline_spacing, Qnil, + "lineSpacing", "LineSpacing", RES_TYPE_NUMBER); + + + /* Init faces before x_default_parameter is called for scroll-bar + parameters because that function calls x_set_scroll_bar_width, + which calls change_frame_size, which calls Fset_window_buffer, + which runs hooks, which call Fvertical_motion. At the end, we + end up in init_iterator with a null face cache, which should not + happen. */ + init_frame_faces (f); + x_default_parameter (f, parms, Qmenu_bar_lines, make_number (1), - "menuBar", "MenuBar", number); - x_default_parameter (f, parms, Qscroll_bar_width, Qnil, - "scrollBarWidth", "ScrollBarWidth", number); + "menuBar", "MenuBar", RES_TYPE_NUMBER); + x_default_parameter (f, parms, Qtool_bar_lines, make_number (0), + "toolBar", "ToolBar", RES_TYPE_NUMBER); + x_default_parameter (f, parms, Qbuffer_predicate, Qnil, + "bufferPredicate", "BufferPredicate", RES_TYPE_SYMBOL); + x_default_parameter (f, parms, Qtitle, Qnil, + "title", "Title", RES_TYPE_STRING); f->output_data.w32->dwStyle = WS_OVERLAPPEDWINDOW; f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window; @@ -3667,60 +5364,92 @@ This function is an internal primitive--use `make-frame' instead.") f->output_data.w32->size_hint_flags = window_prompting; + tem = w32_get_arg (parms, Qunsplittable, 0, 0, RES_TYPE_BOOLEAN); + f->no_split = minibuffer_only || EQ (tem, Qt); + w32_window (f, window_prompting, minibuffer_only); x_icon (f, parms); - init_frame_faces (f); + + x_make_gc (f); + + /* Now consider the frame official. */ + FRAME_W32_DISPLAY_INFO (f)->reference_count++; + Vframe_list = Fcons (frame, Vframe_list); /* We need to do this after creating the window, so that the icon-creation functions can say whose icon they're describing. */ x_default_parameter (f, parms, Qicon_type, Qnil, - "bitmapIcon", "BitmapIcon", symbol); + "bitmapIcon", "BitmapIcon", RES_TYPE_SYMBOL); x_default_parameter (f, parms, Qauto_raise, Qnil, - "autoRaise", "AutoRaiseLower", boolean); + "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN); x_default_parameter (f, parms, Qauto_lower, Qnil, - "autoLower", "AutoRaiseLower", boolean); + "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN); x_default_parameter (f, parms, Qcursor_type, Qbox, - "cursorType", "CursorType", symbol); + "cursorType", "CursorType", RES_TYPE_SYMBOL); + x_default_parameter (f, parms, Qscroll_bar_width, Qnil, + "scrollBarWidth", "ScrollBarWidth", RES_TYPE_NUMBER); /* Dimensions, especially f->height, must be done via change_frame_size. Change will not be effected unless different from the current f->height. */ width = f->width; height = f->height; + + /* Add the tool-bar height to the initial frame height so that the + user gets a text display area of the size he specified with -g or + via .Xdefaults. Later changes of the tool-bar height don't + change the frame size. This is done so that users can create + tall Emacs frames without having to guess how tall the tool-bar + will get. */ + if (FRAME_TOOL_BAR_LINES (f)) + { + int margin, relief, bar_height; + + relief = (tool_bar_button_relief > 0 + ? tool_bar_button_relief + : DEFAULT_TOOL_BAR_BUTTON_RELIEF); + + if (INTEGERP (Vtool_bar_button_margin) + && XINT (Vtool_bar_button_margin) > 0) + margin = XFASTINT (Vtool_bar_button_margin); + else if (CONSP (Vtool_bar_button_margin) + && INTEGERP (XCDR (Vtool_bar_button_margin)) + && XINT (XCDR (Vtool_bar_button_margin)) > 0) + margin = XFASTINT (XCDR (Vtool_bar_button_margin)); + else + margin = 0; + + bar_height = DEFAULT_TOOL_BAR_IMAGE_HEIGHT + 2 * margin + 2 * relief; + height += (bar_height + CANON_Y_UNIT (f) - 1) / CANON_Y_UNIT (f); + } + f->height = 0; SET_FRAME_WIDTH (f, 0); - change_frame_size (f, height, width, 1, 0); + change_frame_size (f, height, width, 1, 0, 0); - /* Tell the server what size and position, etc, we want, - and how badly we want them. */ + /* Tell the server what size and position, etc, we want, and how + badly we want them. This should be done after we have the menu + bar so that its size can be taken into account. */ BLOCK_INPUT; x_wm_set_size_hint (f, window_prompting, 0); UNBLOCK_INPUT; - tem = x_get_arg (parms, Qunsplittable, 0, 0, boolean); - f->no_split = minibuffer_only || EQ (tem, Qt); - - UNGCPRO; - - /* It is now ok to make the frame official - even if we get an error below. - And the frame needs to be on Vframe_list - or making it visible won't work. */ - Vframe_list = Fcons (frame, Vframe_list); - - /* Now that the frame is official, it counts as a reference to - its display. */ - FRAME_W32_DISPLAY_INFO (f)->reference_count++; + /* Set up faces after all frame parameters are known. This call + also merges in face attributes specified for new frames. If we + don't do this, the `menu' face for instance won't have the right + colors, and the menu bar won't appear in the specified colors for + new frames. */ + call1 (Qface_set_after_frame_default, frame); - /* Make the window appear on the frame and enable display, - unless the caller says not to. However, with explicit parent, - Emacs cannot control visibility, so don't try. */ + /* Make the window appear on the frame and enable display, unless + the caller says not to. However, with explicit parent, Emacs + cannot control visibility, so don't try. */ if (! f->output_data.w32->explicit_parent) { Lisp_Object visibility; - visibility = x_get_arg (parms, Qvisibility, 0, 0, symbol); + visibility = w32_get_arg (parms, Qvisibility, 0, 0, RES_TYPE_SYMBOL); if (EQ (visibility, Qunbound)) visibility = Qt; @@ -3732,7 +5461,12 @@ This function is an internal primitive--use `make-frame' instead.") /* Must have been Qnil. */ ; } - + UNGCPRO; + + /* Make sure windows on this frame appear in calls to next-window + and similar functions. */ + Vwindow_list = Qnil; + return unbind_to (count, frame); } @@ -3751,54 +5485,276 @@ x_get_focus_frame (frame) XSETFRAME (xfocus, dpyinfo->w32_focus_frame); return xfocus; } + +DEFUN ("w32-focus-frame", Fw32_focus_frame, Sw32_focus_frame, 1, 1, 0, + "Give FRAME input focus, raising to foreground if necessary.") + (frame) + Lisp_Object frame; +{ + x_focus_on_frame (check_x_frame (frame)); + return Qnil; +} + -XFontStruct * -w32_load_font (dpyinfo,name) -struct w32_display_info *dpyinfo; -char * name; +/* Return the charset portion of a font name. */ +char * xlfd_charset_of_font (char * fontname) +{ + char *charset, *encoding; + + encoding = strrchr(fontname, '-'); + if (!encoding || encoding == fontname) + return NULL; + + for (charset = encoding - 1; charset >= fontname; charset--) + if (*charset == '-') + break; + + if (charset == fontname || strcmp(charset, "-*-*") == 0) + return NULL; + + return charset + 1; +} + +struct font_info *w32_load_bdf_font (struct frame *f, char *fontname, + int size, char* filename); +static Lisp_Object w32_list_bdf_fonts (Lisp_Object pattern, int max_names); +static BOOL w32_to_x_font (LOGFONT * lplf, char * lpxstr, int len, + char * charset); +static BOOL x_to_w32_font (char *lpxstr, LOGFONT *lplogfont); + +static struct font_info * +w32_load_system_font (f,fontname,size) + struct frame *f; + char * fontname; + int size; { - XFontStruct * font = NULL; - BOOL ok; + struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f); + Lisp_Object font_names; + + /* Get a list of all the fonts that match this name. Once we + have a list of matching fonts, we compare them against the fonts + we already have loaded by comparing names. */ + font_names = w32_list_fonts (f, build_string (fontname), size, 100); + + if (!NILP (font_names)) + { + Lisp_Object tail; + int i; + + /* First check if any are already loaded, as that is cheaper + than loading another one. */ + for (i = 0; i < dpyinfo->n_fonts; i++) + for (tail = font_names; CONSP (tail); tail = XCDR (tail)) + if (dpyinfo->font_table[i].name + && (!strcmp (dpyinfo->font_table[i].name, + XSTRING (XCAR (tail))->data) + || !strcmp (dpyinfo->font_table[i].full_name, + XSTRING (XCAR (tail))->data))) + return (dpyinfo->font_table + i); + + fontname = (char *) XSTRING (XCAR (font_names))->data; + } + else if (w32_strict_fontnames) + { + /* If EnumFontFamiliesEx was available, we got a full list of + fonts back so stop now to avoid the possibility of loading a + random font. If we had to fall back to EnumFontFamilies, the + list is incomplete, so continue whether the font we want was + listed or not. */ + HMODULE gdi32 = GetModuleHandle ("gdi32.dll"); + FARPROC enum_font_families_ex + = GetProcAddress (gdi32, "EnumFontFamiliesExA"); + if (enum_font_families_ex) + return NULL; + } + /* Load the font and add it to the table. */ { + char *full_name, *encoding, *charset; + XFontStruct *font; + struct font_info *fontp; LOGFONT lf; + BOOL ok; + int i; - if (!name || !x_to_w32_font (name, &lf)) + if (!fontname || !x_to_w32_font (fontname, &lf)) return (NULL); + if (!*lf.lfFaceName) + /* If no name was specified for the font, we get a random font + from CreateFontIndirect - this is not particularly + desirable, especially since CreateFontIndirect does not + fill out the missing name in lf, so we never know what we + ended up with. */ + return NULL; + font = (XFontStruct *) xmalloc (sizeof (XFontStruct)); + bzero (font, sizeof (*font)); - if (!font) return (NULL); + /* Set bdf to NULL to indicate that this is a Windows font. */ + font->bdf = NULL; BLOCK_INPUT; font->hfont = CreateFontIndirect (&lf); + + if (font->hfont == NULL) + { + ok = FALSE; + } + else + { + HDC hdc; + HANDLE oldobj; + int codepage = w32_codepage_for_font (fontname); + + hdc = GetDC (dpyinfo->root_window); + oldobj = SelectObject (hdc, font->hfont); + + ok = GetTextMetrics (hdc, &font->tm); + if (codepage == CP_UNICODE) + font->double_byte_p = 1; + else + font->double_byte_p = GetFontLanguageInfo(hdc) & GCP_DBCS; + + SelectObject (hdc, oldobj); + ReleaseDC (dpyinfo->root_window, hdc); + /* Fill out details in lf according to the font that was + actually loaded. */ + lf.lfHeight = font->tm.tmInternalLeading - font->tm.tmHeight; + lf.lfWidth = font->tm.tmAveCharWidth; + lf.lfWeight = font->tm.tmWeight; + lf.lfItalic = font->tm.tmItalic; + lf.lfCharSet = font->tm.tmCharSet; + lf.lfPitchAndFamily = ((font->tm.tmPitchAndFamily & TMPF_FIXED_PITCH) + ? VARIABLE_PITCH : FIXED_PITCH); + lf.lfOutPrecision = ((font->tm.tmPitchAndFamily & TMPF_VECTOR) + ? OUT_STROKE_PRECIS : OUT_STRING_PRECIS); + + w32_cache_char_metrics (font); + } + + UNBLOCK_INPUT; + + if (!ok) + { + w32_unload_font (dpyinfo, font); + return (NULL); + } + + /* Find a free slot in the font table. */ + for (i = 0; i < dpyinfo->n_fonts; ++i) + if (dpyinfo->font_table[i].name == NULL) + break; + + /* If no free slot found, maybe enlarge the font table. */ + if (i == dpyinfo->n_fonts + && dpyinfo->n_fonts == dpyinfo->font_table_size) + { + int sz; + dpyinfo->font_table_size = max (16, 2 * dpyinfo->font_table_size); + sz = dpyinfo->font_table_size * sizeof *dpyinfo->font_table; + dpyinfo->font_table + = (struct font_info *) xrealloc (dpyinfo->font_table, sz); + } + + fontp = dpyinfo->font_table + i; + if (i == dpyinfo->n_fonts) + ++dpyinfo->n_fonts; + + /* Now fill in the slots of *FONTP. */ + BLOCK_INPUT; + fontp->font = font; + fontp->font_idx = i; + fontp->name = (char *) xmalloc (strlen (fontname) + 1); + bcopy (fontname, fontp->name, strlen (fontname) + 1); + + charset = xlfd_charset_of_font (fontname); + + /* Work out the font's full name. */ + full_name = (char *)xmalloc (100); + if (full_name && w32_to_x_font (&lf, full_name, 100, charset)) + fontp->full_name = full_name; + else + { + /* If all else fails - just use the name we used to load it. */ + xfree (full_name); + fontp->full_name = fontp->name; + } + + fontp->size = FONT_WIDTH (font); + fontp->height = FONT_HEIGHT (font); + + /* The slot `encoding' specifies how to map a character + code-points (0x20..0x7F or 0x2020..0x7F7F) of each charset to + the font code-points (0:0x20..0x7F, 1:0xA0..0xFF), or + (0:0x20..0x7F, 1:0xA0..0xFF, + (0:0x2020..0x7F7F, 1:0xA0A0..0xFFFF, 3:0x20A0..0x7FFF, + 2:0xA020..0xFF7F). For the moment, we don't know which charset + uses this font. So, we set information in fontp->encoding[1] + which is never used by any charset. If mapping can't be + decided, set FONT_ENCODING_NOT_DECIDED. */ + + /* SJIS fonts need to be set to type 4, all others seem to work as + type FONT_ENCODING_NOT_DECIDED. */ + encoding = strrchr (fontp->name, '-'); + if (encoding && stricmp (encoding+1, "sjis") == 0) + fontp->encoding[1] = 4; + else + fontp->encoding[1] = FONT_ENCODING_NOT_DECIDED; + + /* The following three values are set to 0 under W32, which is + what they get set to if XGetFontProperty fails under X. */ + fontp->baseline_offset = 0; + fontp->relative_compose = 0; + fontp->default_ascent = 0; + + /* Set global flag fonts_changed_p to non-zero if the font loaded + has a character with a smaller width than any other character + before, or if the font loaded has a smalle>r height than any + other font loaded before. If this happens, it will make a + glyph matrix reallocation necessary. */ + fonts_changed_p = x_compute_min_glyph_bounds (f); + UNBLOCK_INPUT; + return fontp; } +} - if (font->hfont == NULL) - { - ok = FALSE; - } - else +/* Load font named FONTNAME of size SIZE for frame F, and return a + pointer to the structure font_info while allocating it dynamically. + If loading fails, return NULL. */ +struct font_info * +w32_load_font (f,fontname,size) +struct frame *f; +char * fontname; +int size; +{ + Lisp_Object bdf_fonts; + struct font_info *retval = NULL; + + bdf_fonts = w32_list_bdf_fonts (build_string (fontname), 1); + + while (!retval && CONSP (bdf_fonts)) { - HDC hdc; - HANDLE oldobj; + char *bdf_name, *bdf_file; + Lisp_Object bdf_pair; - hdc = GetDC (dpyinfo->root_window); - oldobj = SelectObject (hdc, font->hfont); - ok = GetTextMetrics (hdc, &font->tm); - SelectObject (hdc, oldobj); - ReleaseDC (dpyinfo->root_window, hdc); - } + bdf_name = XSTRING (XCAR (bdf_fonts))->data; + bdf_pair = Fassoc (XCAR (bdf_fonts), Vw32_bdf_filename_alist); + bdf_file = XSTRING (XCDR (bdf_pair))->data; - UNBLOCK_INPUT; + retval = w32_load_bdf_font (f, bdf_name, size, bdf_file); - if (ok) return (font); + bdf_fonts = XCDR (bdf_fonts); + } + + if (retval) + return retval; - w32_unload_font (dpyinfo, font); - return (NULL); + return w32_load_system_font(f, fontname, size); } + void w32_unload_font (dpyinfo, font) struct w32_display_info *dpyinfo; @@ -3806,6 +5762,9 @@ w32_unload_font (dpyinfo, font) { if (font) { + if (font->per_char) xfree (font->per_char); + if (font->bdf) w32_free_bdf_font (font->bdf); + if (font->hfont) DeleteObject(font->hfont); xfree (font); } @@ -3832,60 +5791,9 @@ w32_unload_font (dpyinfo, font) * (registry "[^-]+") * (encoding "[^-]+") * ) - * (setq x-font-regexp - * (concat "\\`\\*?[-?*]" - * foundry - family - weight\? - slant\? - swidth - adstyle - - * pixelsize - pointsize - resx - resy - spacing - registry - - * encoding "[-?*]\\*?\\'" - * )) - * (setq x-font-regexp-head - * (concat "\\`[-?*]" foundry - family - weight\? - slant\? - * "\\([-*?]\\|\\'\\)")) - * (setq x-font-regexp-slant (concat - slant -)) - * (setq x-font-regexp-weight (concat - weight -)) - * nil) */ - -#define FONT_START "[-?]" -#define FONT_FOUNDRY "[^-]+" -#define FONT_FAMILY "\\([^-]+\\)" /* 1 */ -#define FONT_WEIGHT "\\(bold\\|demibold\\|medium\\)" /* 2 */ -#define FONT_WEIGHT_Q "\\([^-]*\\)" /* 2 */ -#define FONT_SLANT "\\([ior]\\)" /* 3 */ -#define FONT_SLANT_Q "\\([^-]?\\)" /* 3 */ -#define FONT_SWIDTH "\\([^-]*\\)" /* 4 */ -#define FONT_ADSTYLE "[^-]*" -#define FONT_PIXELSIZE "[^-]*" -#define FONT_POINTSIZE "\\([0-9][0-9]+\\|\\*\\)" /* 5 */ -#define FONT_RESX "[0-9][0-9]+" -#define FONT_RESY "[0-9][0-9]+" -#define FONT_SPACING "[cmp?*]" -#define FONT_AVGWIDTH "[0-9]+" -#define FONT_REGISTRY "[^-]+" -#define FONT_ENCODING "[^-]+" - -#define FONT_REGEXP ("\\`\\*?[-?*]" \ - FONT_FOUNDRY "-" \ - FONT_FAMILY "-" \ - FONT_WEIGHT_Q "-" \ - FONT_SLANT_Q "-" \ - FONT_SWIDTH "-" \ - FONT_ADSTYLE "-" \ - FONT_PIXELSIZE "-" \ - FONT_POINTSIZE "-" \ - "[-?*]\\|\\'") - -#define FONT_REGEXP_HEAD ("\\`[-?*]" \ - FONT_FOUNDRY "-" \ - FONT_FAMILY "-" \ - FONT_WEIGHT_Q "-" \ - FONT_SLANT_Q \ - "\\([-*?]\\|\\'\\)") - -#define FONT_REGEXP_SLANT "-" FONT_SLANT "-" -#define FONT_REGEXP_WEIGHT "-" FONT_WEIGHT "-" - -LONG + +static LONG x_to_w32_weight (lpw) char * lpw; { @@ -3895,6 +5803,7 @@ x_to_w32_weight (lpw) else if (stricmp (lpw,"extrabold") == 0) return FW_EXTRABOLD; else if (stricmp (lpw,"bold") == 0) return FW_BOLD; else if (stricmp (lpw,"demibold") == 0) return FW_SEMIBOLD; + else if (stricmp (lpw,"semibold") == 0) return FW_SEMIBOLD; else if (stricmp (lpw,"medium") == 0) return FW_MEDIUM; else if (stricmp (lpw,"normal") == 0) return FW_NORMAL; else if (stricmp (lpw,"light") == 0) return FW_LIGHT; @@ -3905,14 +5814,14 @@ x_to_w32_weight (lpw) } -char * +static char * w32_to_x_weight (fnweight) int fnweight; { if (fnweight >= FW_HEAVY) return "heavy"; if (fnweight >= FW_EXTRABOLD) return "extrabold"; if (fnweight >= FW_BOLD) return "bold"; - if (fnweight >= FW_SEMIBOLD) return "semibold"; + if (fnweight >= FW_SEMIBOLD) return "demibold"; if (fnweight >= FW_MEDIUM) return "medium"; if (fnweight >= FW_NORMAL) return "normal"; if (fnweight >= FW_LIGHT) return "light"; @@ -3922,60 +5831,340 @@ w32_to_x_weight (fnweight) return "*"; } -LONG +static LONG x_to_w32_charset (lpcs) char * lpcs; { - if (!lpcs) return (0); + Lisp_Object this_entry, w32_charset; + + /* Look through w32-charset-info-alist for the character set. + Format of each entry is + (CHARSET_NAME . (WINDOWS_CHARSET . CODEPAGE)). + */ + this_entry = Fassoc (build_string(lpcs), Vw32_charset_info_alist); + + if (NILP(this_entry)) + { + /* At startup, we want iso8859-1 fonts to come up properly. */ + if (stricmp(lpcs, "iso8859-1") == 0) + return ANSI_CHARSET; + else + return DEFAULT_CHARSET; + } - if (stricmp (lpcs,"ansi") == 0) return ANSI_CHARSET; - else if (stricmp (lpcs,"iso8859-1") == 0) return ANSI_CHARSET; - else if (stricmp (lpcs,"iso8859") == 0) return ANSI_CHARSET; - else if (stricmp (lpcs,"oem") == 0) return OEM_CHARSET; + w32_charset = Fcar (Fcdr (this_entry)); + + // Translate Lisp symbol to number. + if (w32_charset == Qw32_charset_ansi) + return ANSI_CHARSET; + if (w32_charset == Qw32_charset_symbol) + return SYMBOL_CHARSET; + if (w32_charset == Qw32_charset_shiftjis) + return SHIFTJIS_CHARSET; + if (w32_charset == Qw32_charset_hangeul) + return HANGEUL_CHARSET; + if (w32_charset == Qw32_charset_chinesebig5) + return CHINESEBIG5_CHARSET; + if (w32_charset == Qw32_charset_gb2312) + return GB2312_CHARSET; + if (w32_charset == Qw32_charset_oem) + return OEM_CHARSET; +#ifdef JOHAB_CHARSET + if (w32_charset == Qw32_charset_johab) + return JOHAB_CHARSET; + if (w32_charset == Qw32_charset_easteurope) + return EASTEUROPE_CHARSET; + if (w32_charset == Qw32_charset_turkish) + return TURKISH_CHARSET; + if (w32_charset == Qw32_charset_baltic) + return BALTIC_CHARSET; + if (w32_charset == Qw32_charset_russian) + return RUSSIAN_CHARSET; + if (w32_charset == Qw32_charset_arabic) + return ARABIC_CHARSET; + if (w32_charset == Qw32_charset_greek) + return GREEK_CHARSET; + if (w32_charset == Qw32_charset_hebrew) + return HEBREW_CHARSET; + if (w32_charset == Qw32_charset_vietnamese) + return VIETNAMESE_CHARSET; + if (w32_charset == Qw32_charset_thai) + return THAI_CHARSET; + if (w32_charset == Qw32_charset_mac) + return MAC_CHARSET; +#endif /* JOHAB_CHARSET */ #ifdef UNICODE_CHARSET - else if (stricmp (lpcs,"unicode") == 0) return UNICODE_CHARSET; - else if (stricmp (lpcs,"iso10646") == 0) return UNICODE_CHARSET; + if (w32_charset == Qw32_charset_unicode) + return UNICODE_CHARSET; #endif - else - return 0; + + return DEFAULT_CHARSET; } -char * + +static char * w32_to_x_charset (fncharset) int fncharset; { + static char buf[16]; + Lisp_Object charset_type; + switch (fncharset) { - case ANSI_CHARSET: return "ansi"; - case OEM_CHARSET: return "oem"; - case SYMBOL_CHARSET: return "symbol"; + case ANSI_CHARSET: + /* Handle startup case of w32-charset-info-alist not + being set up yet. */ + if (NILP(Vw32_charset_info_alist)) + return "iso8859-1"; + charset_type = Qw32_charset_ansi; + break; + case DEFAULT_CHARSET: + charset_type = Qw32_charset_default; + break; + case SYMBOL_CHARSET: + charset_type = Qw32_charset_symbol; + break; + case SHIFTJIS_CHARSET: + charset_type = Qw32_charset_shiftjis; + break; + case HANGEUL_CHARSET: + charset_type = Qw32_charset_hangeul; + break; + case GB2312_CHARSET: + charset_type = Qw32_charset_gb2312; + break; + case CHINESEBIG5_CHARSET: + charset_type = Qw32_charset_chinesebig5; + break; + case OEM_CHARSET: + charset_type = Qw32_charset_oem; + break; + + /* More recent versions of Windows (95 and NT4.0) define more + character sets. */ +#ifdef EASTEUROPE_CHARSET + case EASTEUROPE_CHARSET: + charset_type = Qw32_charset_easteurope; + break; + case TURKISH_CHARSET: + charset_type = Qw32_charset_turkish; + break; + case BALTIC_CHARSET: + charset_type = Qw32_charset_baltic; + break; + case RUSSIAN_CHARSET: + charset_type = Qw32_charset_russian; + break; + case ARABIC_CHARSET: + charset_type = Qw32_charset_arabic; + break; + case GREEK_CHARSET: + charset_type = Qw32_charset_greek; + break; + case HEBREW_CHARSET: + charset_type = Qw32_charset_hebrew; + break; + case VIETNAMESE_CHARSET: + charset_type = Qw32_charset_vietnamese; + break; + case THAI_CHARSET: + charset_type = Qw32_charset_thai; + break; + case MAC_CHARSET: + charset_type = Qw32_charset_mac; + break; + case JOHAB_CHARSET: + charset_type = Qw32_charset_johab; + break; +#endif + #ifdef UNICODE_CHARSET - case UNICODE_CHARSET: return "unicode"; + case UNICODE_CHARSET: + charset_type = Qw32_charset_unicode; + break; #endif + default: + /* Encode numerical value of unknown charset. */ + sprintf (buf, "*-#%u", fncharset); + return buf; } - return "*"; + + { + Lisp_Object rest; + char * best_match = NULL; + + /* Look through w32-charset-info-alist for the character set. + Prefer ISO codepages, and prefer lower numbers in the ISO + range. Only return charsets for codepages which are installed. + + Format of each entry is + (CHARSET_NAME . (WINDOWS_CHARSET . CODEPAGE)). + */ + for (rest = Vw32_charset_info_alist; CONSP (rest); rest = XCDR (rest)) + { + char * x_charset; + Lisp_Object w32_charset; + Lisp_Object codepage; + + Lisp_Object this_entry = XCAR (rest); + + /* Skip invalid entries in alist. */ + if (!CONSP (this_entry) || !STRINGP (XCAR (this_entry)) + || !CONSP (XCDR (this_entry)) + || !SYMBOLP (XCAR (XCDR (this_entry)))) + continue; + + x_charset = XSTRING (XCAR (this_entry))->data; + w32_charset = XCAR (XCDR (this_entry)); + codepage = XCDR (XCDR (this_entry)); + + /* Look for Same charset and a valid codepage (or non-int + which means ignore). */ + if (w32_charset == charset_type + && (!INTEGERP (codepage) || codepage == CP_DEFAULT + || IsValidCodePage (XINT (codepage)))) + { + /* If we don't have a match already, then this is the + best. */ + if (!best_match) + best_match = x_charset; + /* If this is an ISO codepage, and the best so far isn't, + then this is better. */ + else if (stricmp (best_match, "iso") != 0 + && stricmp (x_charset, "iso") == 0) + best_match = x_charset; + /* If both are ISO8859 codepages, choose the one with the + lowest number in the encoding field. */ + else if (stricmp (best_match, "iso8859-") == 0 + && stricmp (x_charset, "iso8859-") == 0) + { + int best_enc = atoi (best_match + 8); + int this_enc = atoi (x_charset + 8); + if (this_enc > 0 && this_enc < best_enc) + best_match = x_charset; + } + } + } + + /* If no match, encode the numeric value. */ + if (!best_match) + { + sprintf (buf, "*-#%u", fncharset); + return buf; + } + + strncpy(buf, best_match, 15); + buf[15] = '\0'; + return buf; + } } -BOOL -w32_to_x_font (lplogfont, lpxstr, len) + +/* Get the Windows codepage corresponding to the specified font. The + charset info in the font name is used to look up + w32-charset-to-codepage-alist. */ +int +w32_codepage_for_font (char *fontname) +{ + Lisp_Object codepage, entry; + char *charset_str, *charset, *end; + + if (NILP (Vw32_charset_info_alist)) + return CP_DEFAULT; + + /* Extract charset part of font string. */ + charset = xlfd_charset_of_font (fontname); + + if (!charset) + return CP_UNKNOWN; + + charset_str = (char *) alloca (strlen (charset)); + strcpy (charset_str, charset); + + /* Remove leading "*-". */ + if (strncmp ("*-", charset_str, 2) == 0) + charset = charset_str + 2; + else + charset = charset_str; + + /* Stop match at wildcard (including preceding '-'). */ + if (end = strchr (charset, '*')) + { + if (end > charset && *(end-1) == '-') + end--; + *end = '\0'; + } + + entry = Fassoc (build_string(charset), Vw32_charset_info_alist); + if (NILP (entry)) + return CP_UNKNOWN; + + codepage = Fcdr (Fcdr (entry)); + + if (NILP (codepage)) + return CP_8BIT; + else if (XFASTINT (codepage) == XFASTINT (Qt)) + return CP_UNICODE; + else if (INTEGERP (codepage)) + return XINT (codepage); + else + return CP_UNKNOWN; +} + + +static BOOL +w32_to_x_font (lplogfont, lpxstr, len, specific_charset) LOGFONT * lplogfont; char * lpxstr; int len; + char * specific_charset; { + char* fonttype; + char *fontname; char height_pixels[8]; char height_dpi[8]; char width_pixels[8]; + char *fontname_dash; + int display_resy = one_w32_display_info.resy; + int display_resx = one_w32_display_info.resx; + int bufsz; + struct coding_system coding; if (!lpxstr) abort (); if (!lplogfont) return FALSE; + if (lplogfont->lfOutPrecision == OUT_STRING_PRECIS) + fonttype = "raster"; + else if (lplogfont->lfOutPrecision == OUT_STROKE_PRECIS) + fonttype = "outline"; + else + fonttype = "unknown"; + + setup_coding_system (Fcheck_coding_system (Vw32_system_coding_system), + &coding); + coding.src_multibyte = 0; + coding.dst_multibyte = 1; + coding.mode |= CODING_MODE_LAST_BLOCK; + bufsz = decoding_buffer_size (&coding, LF_FACESIZE); + + fontname = alloca(sizeof(*fontname) * bufsz); + decode_coding (&coding, lplogfont->lfFaceName, fontname, + strlen(lplogfont->lfFaceName), bufsz - 1); + *(fontname + coding.produced) = '\0'; + + /* Replace dashes with underscores so the dashes are not + misinterpreted. */ + fontname_dash = fontname; + while (fontname_dash = strchr (fontname_dash, '-')) + *fontname_dash = '_'; + if (lplogfont->lfHeight) { sprintf (height_pixels, "%u", abs (lplogfont->lfHeight)); sprintf (height_dpi, "%u", - (abs (lplogfont->lfHeight) * 720) / one_w32_display_info.height_in); + abs (lplogfont->lfHeight) * 720 / display_resy); } else { @@ -3988,30 +6177,41 @@ w32_to_x_font (lplogfont, lpxstr, len) strcpy (width_pixels, "*"); _snprintf (lpxstr, len - 1, - "-*-%s-%s-%c-*-*-%s-%s-*-*-%c-%s-*-%s-", - lplogfont->lfFaceName, - w32_to_x_weight (lplogfont->lfWeight), - lplogfont->lfItalic?'i':'r', - height_pixels, - height_dpi, - ((lplogfont->lfPitchAndFamily & 0x3) == VARIABLE_PITCH) ? 'p' : 'c', - width_pixels, - w32_to_x_charset (lplogfont->lfCharSet) + "-%s-%s-%s-%c-normal-normal-%s-%s-%d-%d-%c-%s-%s", + fonttype, /* foundry */ + fontname, /* family */ + w32_to_x_weight (lplogfont->lfWeight), /* weight */ + lplogfont->lfItalic?'i':'r', /* slant */ + /* setwidth name */ + /* add style name */ + height_pixels, /* pixel size */ + height_dpi, /* point size */ + display_resx, /* resx */ + display_resy, /* resy */ + ((lplogfont->lfPitchAndFamily & 0x3) == VARIABLE_PITCH) + ? 'p' : 'c', /* spacing */ + width_pixels, /* avg width */ + specific_charset ? specific_charset + : w32_to_x_charset (lplogfont->lfCharSet) + /* charset registry and encoding */ ); lpxstr[len - 1] = 0; /* just to be sure */ return (TRUE); } -BOOL +static BOOL x_to_w32_font (lpxstr, lplogfont) char * lpxstr; LOGFONT * lplogfont; { + struct coding_system coding; + if (!lplogfont) return (FALSE); - + memset (lplogfont, 0, sizeof (*lplogfont)); + /* Set default value for each field. */ #if 1 lplogfont->lfOutPrecision = OUT_DEFAULT_PRECIS; lplogfont->lfClipPrecision = CLIP_DEFAULT_PRECIS; @@ -4023,6 +6223,10 @@ x_to_w32_font (lpxstr, lplogfont) lplogfont->lfQuality = PROOF_QUALITY; #endif + lplogfont->lfCharSet = DEFAULT_CHARSET; + lplogfont->lfWeight = FW_DONTCARE; + lplogfont->lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE; + if (!lpxstr) return FALSE; @@ -4034,24 +6238,44 @@ x_to_w32_font (lpxstr, lplogfont) if (*lpxstr == '-') { - int fields; - char name[50], weight[20], slant, pitch, pixels[10], height[10], width[10], remainder[20]; + int fields, tem; + char name[50], weight[20], slant, pitch, pixels[10], height[10], + width[10], resy[10], remainder[20]; char * encoding; + int dpi = one_w32_display_info.resy; fields = sscanf (lpxstr, - "-%*[^-]-%49[^-]-%19[^-]-%c-%*[^-]-%*[^-]-%9[^-]-%9[^-]-%*[^-]-%*[^-]-%c-%9[^-]-%19s", - name, weight, &slant, pixels, height, &pitch, width, remainder); - + "-%*[^-]-%49[^-]-%19[^-]-%c-%*[^-]-%*[^-]-%9[^-]-%9[^-]-%*[^-]-%9[^-]-%c-%9[^-]-%19s", + name, weight, &slant, pixels, height, resy, &pitch, width, remainder); if (fields == EOF) return (FALSE); + /* If wildcards cover more than one field, we don't know which + field is which, so don't fill any in. */ + + if (fields < 9) + fields = 0; + if (fields > 0 && name[0] != '*') { - strncpy (lplogfont->lfFaceName,name, LF_FACESIZE); - lplogfont->lfFaceName[LF_FACESIZE-1] = 0; + int bufsize; + unsigned char *buf; + + setup_coding_system + (Fcheck_coding_system (Vw32_system_coding_system), &coding); + coding.src_multibyte = 1; + coding.dst_multibyte = 1; + bufsize = encoding_buffer_size (&coding, strlen (name)); + buf = (unsigned char *) alloca (bufsize); + coding.mode |= CODING_MODE_LAST_BLOCK; + encode_coding (&coding, name, buf, strlen (name), bufsize); + if (coding.produced >= LF_FACESIZE) + coding.produced = LF_FACESIZE - 1; + buf[coding.produced] = 0; + strcpy (lplogfont->lfFaceName, buf); } else { - lplogfont->lfFaceName[0] = 0; + lplogfont->lfFaceName[0] = '\0'; } fields--; @@ -4060,8 +6284,7 @@ x_to_w32_font (lpxstr, lplogfont) fields--; - if (!NILP (Vw32_enable_italics)) - lplogfont->lfItalic = (fields > 0 && slant == 'i'); + lplogfont->lfItalic = (fields > 0 && slant == 'i'); fields--; @@ -4069,13 +6292,17 @@ x_to_w32_font (lpxstr, lplogfont) lplogfont->lfHeight = atoi (pixels); fields--; - - if (fields > 0 && lplogfont->lfHeight == 0 && height[0] != '*') - lplogfont->lfHeight = (atoi (height) - * one_w32_display_info.height_in) / 720; - fields--; + if (fields > 0 && resy[0] != '*') + { + tem = atoi (resy); + if (tem > 0) dpi = tem; + } + if (fields > -1 && lplogfont->lfHeight == 0 && height[0] != '*') + lplogfont->lfHeight = atoi (height) * dpi / 720; + + if (fields > 0) lplogfont->lfPitchAndFamily = (fields > 0 && pitch == 'p') ? VARIABLE_PITCH : FIXED_PITCH; @@ -4086,9 +6313,8 @@ x_to_w32_font (lpxstr, lplogfont) fields--; - /* Not all font specs include the registry field, so we allow for an - optional registry field before the encoding when parsing - remainder. Also we strip the trailing '-' if present. */ + /* Strip the trailing '-' if present. (it shouldn't be, as it + fails the test against xlfd-tight-regexp in fontset.el). */ { int len = strlen (remainder); if (len > 0 && remainder[len-1] == '-') @@ -4137,44 +6363,193 @@ x_to_w32_font (lpxstr, lplogfont) /* This makes TrueType fonts work better. */ lplogfont->lfHeight = - abs (lplogfont->lfHeight); - + return (TRUE); } -BOOL -w32_font_match (lpszfont1, lpszfont2) - char * lpszfont1; - char * lpszfont2; +/* Strip the pixel height and point height from the given xlfd, and + return the pixel height. If no pixel height is specified, calculate + one from the point height, or if that isn't defined either, return + 0 (which usually signifies a scalable font). +*/ +static int +xlfd_strip_height (char *fontname) { - char * s1 = lpszfont1, *e1; - char * s2 = lpszfont2, *e2; - - if (s1 == NULL || s2 == NULL) return (FALSE); - - if (*s1 == '-') s1++; - if (*s2 == '-') s2++; - - while (1) + int pixel_height, field_number; + char *read_from, *write_to; + + xassert (fontname); + + pixel_height = field_number = 0; + write_to = NULL; + + /* Look for height fields. */ + for (read_from = fontname; *read_from; read_from++) + { + if (*read_from == '-') + { + field_number++; + if (field_number == 7) /* Pixel height. */ + { + read_from++; + write_to = read_from; + + /* Find end of field. */ + for (;*read_from && *read_from != '-'; read_from++) + ; + + /* Split the fontname at end of field. */ + if (*read_from) + { + *read_from = '\0'; + read_from++; + } + pixel_height = atoi (write_to); + /* Blank out field. */ + if (read_from > write_to) + { + *write_to = '-'; + write_to++; + } + /* If the pixel height field is at the end (partial xlfd), + return now. */ + else + return pixel_height; + + /* If we got a pixel height, the point height can be + ignored. Just blank it out and break now. */ + if (pixel_height) + { + /* Find end of point size field. */ + for (; *read_from && *read_from != '-'; read_from++) + ; + + if (*read_from) + read_from++; + + /* Blank out the point size field. */ + if (read_from > write_to) + { + *write_to = '-'; + write_to++; + } + else + return pixel_height; + + break; + } + /* If the point height is already blank, break now. */ + if (*read_from == '-') + { + read_from++; + break; + } + } + else if (field_number == 8) + { + /* If we didn't get a pixel height, try to get the point + height and convert that. */ + int point_size; + char *point_size_start = read_from++; + + /* Find end of field. */ + for (; *read_from && *read_from != '-'; read_from++) + ; + + if (*read_from) + { + *read_from = '\0'; + read_from++; + } + + point_size = atoi (point_size_start); + + /* Convert to pixel height. */ + pixel_height = point_size + * one_w32_display_info.height_in / 720; + + /* Blank out this field and break. */ + *write_to = '-'; + write_to++; + break; + } + } + } + + /* Shift the rest of the font spec into place. */ + if (write_to && read_from > write_to) { - int len1, len2; + for (; *read_from; read_from++, write_to++) + *write_to = *read_from; + *write_to = '\0'; + } - e1 = strchr (s1, '-'); - e2 = strchr (s2, '-'); + return pixel_height; +} - if (e1 == NULL || e2 == NULL) return (TRUE); +/* Assume parameter 1 is fully qualified, no wildcards. */ +static BOOL +w32_font_match (fontname, pattern) + char * fontname; + char * pattern; +{ + char *regex = alloca (strlen (pattern) * 2 + 3); + char *font_name_copy = alloca (strlen (fontname) + 1); + char *ptr; - len1 = e1 - s1; - len2 = e2 - s2; + /* Copy fontname so we can modify it during comparison. */ + strcpy (font_name_copy, fontname); - if (*s1 != '*' && *s2 != '*' - && (len1 != len2 || strnicmp (s1, s2, len1) != 0)) - return (FALSE); + ptr = regex; + *ptr++ = '^'; - s1 = e1 + 1; - s2 = e2 + 1; + /* Turn pattern into a regexp and do a regexp match. */ + for (; *pattern; pattern++) + { + if (*pattern == '?') + *ptr++ = '.'; + else if (*pattern == '*') + { + *ptr++ = '.'; + *ptr++ = '*'; + } + else + *ptr++ = *pattern; } + *ptr = '$'; + *(ptr + 1) = '\0'; + + /* Strip out font heights and compare them seperately, since + rounding error can cause mismatches. This also allows a + comparison between a font that declares only a pixel height and a + pattern that declares the point height. + */ + { + int font_height, pattern_height; + + font_height = xlfd_strip_height (font_name_copy); + pattern_height = xlfd_strip_height (regex); + + /* Compare now, and don't bother doing expensive regexp matching + if the heights differ. */ + if (font_height && pattern_height && (font_height != pattern_height)) + return FALSE; + } + + return (fast_c_string_match_ignore_case (build_string (regex), + font_name_copy) >= 0); } +/* Callback functions, and a structure holding info they need, for + listing system fonts on W32. We need one set of functions to do the + job properly, but these don't work on NT 3.51 and earlier, so we + have a second set which don't handle character sets properly to + fall back on. + + In both cases, there are two passes made. The first pass gets one + font from each family, the second pass lists all the fonts from + each family. */ + typedef struct enumfont_t { HDC hdc; @@ -4182,45 +6557,84 @@ typedef struct enumfont_t LOGFONT logfont; XFontStruct *size_ref; Lisp_Object *pattern; - Lisp_Object *head; Lisp_Object *tail; } enumfont_t; -int CALLBACK +static int CALLBACK enum_font_cb2 (lplf, lptm, FontType, lpef) ENUMLOGFONT * lplf; NEWTEXTMETRIC * lptm; int FontType; enumfont_t * lpef; { - if (lplf->elfLogFont.lfStrikeOut || lplf->elfLogFont.lfUnderline - || (lplf->elfLogFont.lfCharSet != ANSI_CHARSET && lplf->elfLogFont.lfCharSet != OEM_CHARSET)) + if (lplf->elfLogFont.lfStrikeOut || lplf->elfLogFont.lfUnderline) return (1); - /* if (!lpef->size_ref || lptm->tmMaxCharWidth == FONT_WIDTH (lpef->size_ref)) */ + /* Check that the character set matches if it was specified */ + if (lpef->logfont.lfCharSet != DEFAULT_CHARSET && + lplf->elfLogFont.lfCharSet != lpef->logfont.lfCharSet) + return (1); + { char buf[100]; + Lisp_Object width = Qnil; + char *charset = NULL; + + /* Truetype fonts do not report their true metrics until loaded */ + if (FontType != RASTER_FONTTYPE) + { + if (!NILP (*(lpef->pattern))) + { + /* Scalable fonts are as big as you want them to be. */ + lplf->elfLogFont.lfHeight = lpef->logfont.lfHeight; + lplf->elfLogFont.lfWidth = lpef->logfont.lfWidth; + width = make_number (lpef->logfont.lfWidth); + } + else + { + lplf->elfLogFont.lfHeight = 0; + lplf->elfLogFont.lfWidth = 0; + } + } + + /* Make sure the height used here is the same as everywhere + else (ie character height, not cell height). */ + if (lplf->elfLogFont.lfHeight > 0) + { + /* lptm can be trusted for RASTER fonts, but not scalable ones. */ + if (FontType == RASTER_FONTTYPE) + lplf->elfLogFont.lfHeight = lptm->tmInternalLeading - lptm->tmHeight; + else + lplf->elfLogFont.lfHeight = -lplf->elfLogFont.lfHeight; + } - if (!NILP (*(lpef->pattern)) && FontType == TRUETYPE_FONTTYPE) + if (!NILP (*(lpef->pattern))) { - lplf->elfLogFont.lfHeight = lpef->logfont.lfHeight; - lplf->elfLogFont.lfWidth = lpef->logfont.lfWidth; + charset = xlfd_charset_of_font (XSTRING(*(lpef->pattern))->data); + + /* Ensure that charset is valid for this font. */ + if (charset + && (x_to_w32_charset (charset) != lplf->elfLogFont.lfCharSet)) + charset = NULL; } - if (!w32_to_x_font (lplf, buf, 100)) return (0); + /* TODO: List all relevant charsets if charset not specified. */ + if (!w32_to_x_font (&(lplf->elfLogFont), buf, 100, charset)) + return (0); - if (NILP (*(lpef->pattern)) || w32_font_match (buf, XSTRING (*(lpef->pattern))->data)) + if (NILP (*(lpef->pattern)) + || w32_font_match (buf, XSTRING (*(lpef->pattern))->data)) { - *lpef->tail = Fcons (build_string (buf), Qnil); - lpef->tail = &XCONS (*lpef->tail)->cdr; + *lpef->tail = Fcons (Fcons (build_string (buf), width), Qnil); + lpef->tail = &(XCDR (*lpef->tail)); lpef->numFonts++; } } - + return (1); } -int CALLBACK +static int CALLBACK enum_font_cb1 (lplf, lptm, FontType, lpef) ENUMLOGFONT * lplf; NEWTEXTMETRIC * lptm; @@ -4234,212 +6648,494 @@ enum_font_cb1 (lplf, lptm, FontType, lpef) } -DEFUN ("x-list-fonts", Fx_list_fonts, Sx_list_fonts, 1, 3, 0, - "Return a list of the names of available fonts matching PATTERN.\n\ -If optional arguments FACE and FRAME are specified, return only fonts\n\ -the same size as FACE on FRAME.\n\ -\n\ -PATTERN is a string, perhaps with wildcard characters;\n\ - the * character matches any substring, and\n\ - the ? character matches any single character.\n\ - PATTERN is case-insensitive.\n\ -FACE is a face name--a symbol.\n\ -\n\ -The return value is a list of strings, suitable as arguments to\n\ -set-face-font.\n\ -\n\ -Fonts Emacs can't use (i.e. proportional fonts) may or may not be excluded\n\ -even if they match PATTERN and FACE.") - (pattern, face, frame) - Lisp_Object pattern, face, frame; -{ - int num_fonts; - char **names; - XFontStruct *info; - XFontStruct *size_ref; - Lisp_Object namelist; - Lisp_Object list; - FRAME_PTR f; - enumfont_t ef; +static int CALLBACK +enum_fontex_cb2 (lplf, lptm, font_type, lpef) + ENUMLOGFONTEX * lplf; + NEWTEXTMETRICEX * lptm; + int font_type; + enumfont_t * lpef; +{ + /* We are not interested in the extra info we get back from the 'Ex + version - only the fact that we get character set variations + enumerated seperately. */ + return enum_font_cb2 ((ENUMLOGFONT *) lplf, (NEWTEXTMETRIC *) lptm, + font_type, lpef); +} + +static int CALLBACK +enum_fontex_cb1 (lplf, lptm, font_type, lpef) + ENUMLOGFONTEX * lplf; + NEWTEXTMETRICEX * lptm; + int font_type; + enumfont_t * lpef; +{ + HMODULE gdi32 = GetModuleHandle ("gdi32.dll"); + FARPROC enum_font_families_ex + = GetProcAddress ( gdi32, "EnumFontFamiliesExA"); + /* We don't really expect EnumFontFamiliesEx to disappear once we + get here, so don't bother handling it gracefully. */ + if (enum_font_families_ex == NULL) + error ("gdi32.dll has disappeared!"); + return enum_font_families_ex (lpef->hdc, + &lplf->elfLogFont, + (FONTENUMPROC) enum_fontex_cb2, + (LPARAM) lpef, 0); +} - CHECK_STRING (pattern, 0); - if (!NILP (face)) - CHECK_SYMBOL (face, 1); +/* Interface to fontset handler. (adapted from mw32font.c in Meadow + and xterm.c in Emacs 20.3) */ - f = check_x_frame (frame); +static Lisp_Object w32_list_bdf_fonts (Lisp_Object pattern, int max_names) +{ + char *fontname, *ptnstr; + Lisp_Object list, tem, newlist = Qnil; + int n_fonts = 0; - /* Determine the width standard for comparison with the fonts we find. */ + list = Vw32_bdf_filename_alist; + ptnstr = XSTRING (pattern)->data; - if (NILP (face)) - size_ref = 0; - else + for ( ; CONSP (list); list = XCDR (list)) { - int face_id; + tem = XCAR (list); + if (CONSP (tem)) + fontname = XSTRING (XCAR (tem))->data; + else if (STRINGP (tem)) + fontname = XSTRING (tem)->data; + else + continue; - /* Don't die if we get called with a terminal frame. */ - if (! FRAME_W32_P (f)) - error ("non-w32 frame used in `x-list-fonts'"); + if (w32_font_match (fontname, ptnstr)) + { + newlist = Fcons (XCAR (tem), newlist); + n_fonts++; + if (n_fonts >= max_names) + break; + } + } - face_id = face_name_id_number (f, face); + return newlist; +} - if (face_id < 0 || face_id >= FRAME_N_PARAM_FACES (f) - || FRAME_PARAM_FACES (f) [face_id] == 0) - size_ref = f->output_data.w32->font; - else - { - size_ref = FRAME_PARAM_FACES (f) [face_id]->font; - if (size_ref == (XFontStruct *) (~0)) - size_ref = f->output_data.w32->font; - } - } +static Lisp_Object w32_list_synthesized_fonts (FRAME_PTR f, + Lisp_Object pattern, + int size, int max_names); + +/* Return a list of names of available fonts matching PATTERN on frame + F. If SIZE is not 0, it is the size (maximum bound width) of fonts + to be listed. Frame F NULL means we have not yet created any + frame, which means we can't get proper size info, as we don't have + a device context to use for GetTextMetrics. + MAXNAMES sets a limit on how many fonts to match. */ - /* See if we cached the result for this particular query. */ - list = Fassoc (pattern, - XCONS (FRAME_W32_DISPLAY_INFO (f)->name_list_element)->cdr); +Lisp_Object +w32_list_fonts (f, pattern, size, maxnames) + struct frame *f; + Lisp_Object pattern; + int size; + int maxnames; +{ + Lisp_Object patterns, key = Qnil, tem, tpat; + Lisp_Object list = Qnil, newlist = Qnil, second_best = Qnil; + struct w32_display_info *dpyinfo = &one_w32_display_info; + int n_fonts = 0; - /* We have info in the cache for this PATTERN. */ - if (!NILP (list)) + patterns = Fassoc (pattern, Valternate_fontname_alist); + if (NILP (patterns)) + patterns = Fcons (pattern, Qnil); + + for (; CONSP (patterns); patterns = XCDR (patterns)) { - Lisp_Object tem, newlist; + enumfont_t ef; + int codepage; + + tpat = XCAR (patterns); + + if (!STRINGP (tpat)) + continue; - /* We have info about this pattern. */ - list = XCONS (list)->cdr; + /* Avoid expensive EnumFontFamilies functions if we are not + going to be able to output one of these anyway. */ + codepage = w32_codepage_for_font (XSTRING (tpat)->data); + if (codepage != CP_8BIT && codepage != CP_UNICODE + && codepage != CP_DEFAULT && codepage != CP_UNKNOWN + && !IsValidCodePage(codepage)) + continue; - if (size_ref == 0) - return list; + /* See if we cached the result for this particular query. + The cache is an alist of the form: + ((PATTERN (FONTNAME . WIDTH) ...) ...) + */ + if (tem = XCDR (dpyinfo->name_list_element), + !NILP (list = Fassoc (tpat, tem))) + { + list = Fcdr_safe (list); + /* We have a cached list. Don't have to get the list again. */ + goto label_cached; + } BLOCK_INPUT; + /* At first, put PATTERN in the cache. */ + list = Qnil; + ef.pattern = &tpat; + ef.tail = &list; + ef.numFonts = 0; + + /* Use EnumFontFamiliesEx where it is available, as it knows + about character sets. Fall back to EnumFontFamilies for + older versions of NT that don't support the 'Ex function. */ + x_to_w32_font (XSTRING (tpat)->data, &ef.logfont); + { + LOGFONT font_match_pattern; + HMODULE gdi32 = GetModuleHandle ("gdi32.dll"); + FARPROC enum_font_families_ex + = GetProcAddress ( gdi32, "EnumFontFamiliesExA"); + + /* We do our own pattern matching so we can handle wildcards. */ + font_match_pattern.lfFaceName[0] = 0; + font_match_pattern.lfPitchAndFamily = 0; + /* We can use the charset, because if it is a wildcard it will + be DEFAULT_CHARSET anyway. */ + font_match_pattern.lfCharSet = ef.logfont.lfCharSet; + + ef.hdc = GetDC (dpyinfo->root_window); + + if (enum_font_families_ex) + enum_font_families_ex (ef.hdc, + &font_match_pattern, + (FONTENUMPROC) enum_fontex_cb1, + (LPARAM) &ef, 0); + else + EnumFontFamilies (ef.hdc, NULL, (FONTENUMPROC) enum_font_cb1, + (LPARAM)&ef); + + ReleaseDC (dpyinfo->root_window, ef.hdc); + } - /* Filter the cached info and return just the fonts that match FACE. */ - newlist = Qnil; - for (tem = list; CONSP (tem); tem = XCONS (tem)->cdr) - { - XFontStruct *thisinfo; + UNBLOCK_INPUT; - thisinfo = w32_load_font (FRAME_W32_DISPLAY_INFO (f), XSTRING (XCONS (tem)->car)->data); + /* Make a list of the fonts we got back. + Store that in the font cache for the display. */ + XCDR (dpyinfo->name_list_element) + = Fcons (Fcons (tpat, list), + XCDR (dpyinfo->name_list_element)); - if (thisinfo && same_size_fonts (thisinfo, size_ref)) - newlist = Fcons (XCONS (tem)->car, newlist); + label_cached: + if (NILP (list)) continue; /* Try the remaining alternatives. */ - w32_unload_font (FRAME_W32_DISPLAY_INFO (f), thisinfo); + newlist = second_best = Qnil; + + /* Make a list of the fonts that have the right width. */ + for (; CONSP (list); list = XCDR (list)) + { + int found_size; + tem = XCAR (list); + + if (!CONSP (tem)) + continue; + if (NILP (XCAR (tem))) + continue; + if (!size) + { + newlist = Fcons (XCAR (tem), newlist); + n_fonts++; + if (n_fonts >= maxnames) + break; + else + continue; + } + if (!INTEGERP (XCDR (tem))) + { + /* Since we don't yet know the size of the font, we must + load it and try GetTextMetrics. */ + W32FontStruct thisinfo; + LOGFONT lf; + HDC hdc; + HANDLE oldobj; + + if (!x_to_w32_font (XSTRING (XCAR (tem))->data, &lf)) + continue; + + BLOCK_INPUT; + thisinfo.bdf = NULL; + thisinfo.hfont = CreateFontIndirect (&lf); + if (thisinfo.hfont == NULL) + continue; + + hdc = GetDC (dpyinfo->root_window); + oldobj = SelectObject (hdc, thisinfo.hfont); + if (GetTextMetrics (hdc, &thisinfo.tm)) + XCDR (tem) = make_number (FONT_WIDTH (&thisinfo)); + else + XCDR (tem) = make_number (0); + SelectObject (hdc, oldobj); + ReleaseDC (dpyinfo->root_window, hdc); + DeleteObject(thisinfo.hfont); + UNBLOCK_INPUT; + } + found_size = XINT (XCDR (tem)); + if (found_size == size) + { + newlist = Fcons (XCAR (tem), newlist); + n_fonts++; + if (n_fonts >= maxnames) + break; + } + /* keep track of the closest matching size in case + no exact match is found. */ + else if (found_size > 0) + { + if (NILP (second_best)) + second_best = tem; + + else if (found_size < size) + { + if (XINT (XCDR (second_best)) > size + || XINT (XCDR (second_best)) < found_size) + second_best = tem; + } + else + { + if (XINT (XCDR (second_best)) > size + && XINT (XCDR (second_best)) > + found_size) + second_best = tem; + } + } } - UNBLOCK_INPUT; + if (!NILP (newlist)) + break; + else if (!NILP (second_best)) + { + newlist = Fcons (XCAR (second_best), Qnil); + break; + } + } + + /* Include any bdf fonts. */ + if (n_fonts < maxnames) + { + Lisp_Object combined[2]; + combined[0] = w32_list_bdf_fonts (pattern, maxnames - n_fonts); + combined[1] = newlist; + newlist = Fnconc(2, combined); + } + + /* If we can't find a font that matches, check if Windows would be + able to synthesize it from a different style. */ + if (NILP (newlist) && !NILP (Vw32_enable_synthesized_fonts)) + newlist = w32_list_synthesized_fonts (f, pattern, size, maxnames); + + return newlist; +} + +static Lisp_Object +w32_list_synthesized_fonts (f, pattern, size, max_names) + FRAME_PTR f; + Lisp_Object pattern; + int size; + int max_names; +{ + int fields; + char *full_pattn, *new_pattn, foundary[50], family[50], *pattn_part2; + char style[20], slant; + Lisp_Object matches, tem, synthed_matches = Qnil; + + full_pattn = XSTRING (pattern)->data; + + pattn_part2 = alloca (XSTRING (pattern)->size); + /* Allow some space for wildcard expansion. */ + new_pattn = alloca (XSTRING (pattern)->size + 100); + + fields = sscanf (full_pattn, "-%49[^-]-%49[^-]-%19[^-]-%c-%s", + foundary, family, style, &slant, pattn_part2); + if (fields == EOF || fields < 5) + return Qnil; + + /* If the style and slant are wildcards already there is no point + checking again (and we don't want to keep recursing). */ + if (*style == '*' && slant == '*') + return Qnil; + + sprintf (new_pattn, "-%s-%s-*-*-%s", foundary, family, pattn_part2); + + matches = w32_list_fonts (f, build_string (new_pattn), size, max_names); - return newlist; + for ( ; CONSP (matches); matches = XCDR (matches)) + { + tem = XCAR (matches); + if (!STRINGP (tem)) + continue; + + full_pattn = XSTRING (tem)->data; + fields = sscanf (full_pattn, "-%49[^-]-%49[^-]-%*[^-]-%*c-%s", + foundary, family, pattn_part2); + if (fields == EOF || fields < 3) + continue; + + sprintf (new_pattn, "-%s-%s-%s-%c-%s", foundary, family, style, + slant, pattn_part2); + + synthed_matches = Fcons (build_string (new_pattn), + synthed_matches); } - BLOCK_INPUT; + return synthed_matches; +} - namelist = Qnil; - ef.pattern = &pattern; - ef.tail = ef.head = &namelist; - ef.numFonts = 0; - x_to_w32_font (STRINGP (pattern) ? XSTRING (pattern)->data : NULL, &ef.logfont); - { - ef.hdc = GetDC (FRAME_W32_WINDOW (f)); +/* Return a pointer to struct font_info of font FONT_IDX of frame F. */ +struct font_info * +w32_get_font_info (f, font_idx) + FRAME_PTR f; + int font_idx; +{ + return (FRAME_W32_FONT_TABLE (f) + font_idx); +} - EnumFontFamilies (ef.hdc, NULL, (FONTENUMPROC) enum_font_cb1, (LPARAM)&ef); - - ReleaseDC (FRAME_W32_WINDOW (f), ef.hdc); - } - UNBLOCK_INPUT; +struct font_info* +w32_query_font (struct frame *f, char *fontname) +{ + int i; + struct font_info *pfi; + + pfi = FRAME_W32_FONT_TABLE (f); - if (ef.numFonts) + for (i = 0; i < one_w32_display_info.n_fonts ;i++, pfi++) { - int i; - Lisp_Object cur; + if (strcmp(pfi->name, fontname) == 0) return pfi; + } - /* Make a list of all the fonts we got back. - Store that in the font cache for the display. */ - XCONS (FRAME_W32_DISPLAY_INFO (f)->name_list_element)->cdr - = Fcons (Fcons (pattern, namelist), - XCONS (FRAME_W32_DISPLAY_INFO (f)->name_list_element)->cdr); + return NULL; +} - /* Make a list of the fonts that have the right width. */ - list = Qnil; - cur=namelist; - for (i = 0; i < ef.numFonts; i++) - { - int keeper; +/* Find a CCL program for a font specified by FONTP, and set the member + `encoder' of the structure. */ - if (!size_ref) - keeper = 1; - else - { - XFontStruct *thisinfo; +void +w32_find_ccl_program (fontp) + struct font_info *fontp; +{ + Lisp_Object list, elt; + + for (list = Vfont_ccl_encoder_alist; CONSP (list); list = XCDR (list)) + { + elt = XCAR (list); + if (CONSP (elt) + && STRINGP (XCAR (elt)) + && (fast_c_string_match_ignore_case (XCAR (elt), fontp->name) + >= 0)) + break; + } + if (! NILP (list)) + { + struct ccl_program *ccl + = (struct ccl_program *) xmalloc (sizeof (struct ccl_program)); - BLOCK_INPUT; - thisinfo = w32_load_font (FRAME_W32_DISPLAY_INFO (f), XSTRING (Fcar (cur))->data); + if (setup_ccl_program (ccl, XCDR (elt)) < 0) + xfree (ccl); + else + fontp->font_encoder = ccl; + } +} - keeper = thisinfo && same_size_fonts (thisinfo, size_ref); + +/* Find BDF files in a specified directory. (use GCPRO when calling, + as this calls lisp to get a directory listing). */ +static Lisp_Object +w32_find_bdf_fonts_in_dir (Lisp_Object directory) +{ + Lisp_Object filelist, list = Qnil; + char fontname[100]; - w32_unload_font (FRAME_W32_DISPLAY_INFO (f), thisinfo); + if (!STRINGP(directory)) + return Qnil; - UNBLOCK_INPUT; - } - if (keeper) - list = Fcons (build_string (XSTRING (Fcar (cur))->data), list); + filelist = Fdirectory_files (directory, Qt, + build_string (".*\\.[bB][dD][fF]"), Qt); - cur = Fcdr (cur); - } - list = Fnreverse (list); + for ( ; CONSP(filelist); filelist = XCDR (filelist)) + { + Lisp_Object filename = XCAR (filelist); + if (w32_BDF_to_x_font (XSTRING (filename)->data, fontname, 100)) + store_in_alist (&list, build_string (fontname), filename); } + return list; +} + +DEFUN ("w32-find-bdf-fonts", Fw32_find_bdf_fonts, Sw32_find_bdf_fonts, + 1, 1, 0, + "Return a list of BDF fonts in DIR, suitable for appending to\n\ +w32-bdf-filename-alist. Fonts which do not contain an xlfd description\n\ +will not be included in the list. DIR may be a list of directories.") + (directory) + Lisp_Object directory; +{ + Lisp_Object list = Qnil; + struct gcpro gcpro1, gcpro2; + if (!CONSP (directory)) + return w32_find_bdf_fonts_in_dir (directory); + + for ( ; CONSP (directory); directory = XCDR (directory)) + { + Lisp_Object pair[2]; + pair[0] = list; + pair[1] = Qnil; + GCPRO2 (directory, list); + pair[1] = w32_find_bdf_fonts_in_dir( XCAR (directory) ); + list = Fnconc( 2, pair ); + UNGCPRO; + } return list; } + -DEFUN ("x-color-defined-p", Fx_color_defined_p, Sx_color_defined_p, 1, 2, 0, - "Return non-nil if color COLOR is supported on frame FRAME.\n\ -If FRAME is omitted or nil, use the selected frame.") +DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, + "Internal function called by `color-defined-p', which see.") (color, frame) Lisp_Object color, frame; { - COLORREF foo; + XColor foo; FRAME_PTR f = check_x_frame (frame); CHECK_STRING (color, 1); - if (defined_color (f, XSTRING (color)->data, &foo, 0)) + if (w32_defined_color (f, XSTRING (color)->data, &foo, 0)) return Qt; else return Qnil; } -DEFUN ("x-color-values", Fx_color_values, Sx_color_values, 1, 2, 0, - "Return a description of the color named COLOR on frame FRAME.\n\ -The value is a list of integer RGB values--(RED GREEN BLUE).\n\ -These values appear to range from 0 to 65280 or 65535, depending\n\ -on the system; white is (65280 65280 65280) or (65535 65535 65535).\n\ -If FRAME is omitted or nil, use the selected frame.") +DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, + "Internal function called by `color-values', which see.") (color, frame) Lisp_Object color, frame; { - COLORREF foo; + XColor foo; FRAME_PTR f = check_x_frame (frame); CHECK_STRING (color, 1); - if (defined_color (f, XSTRING (color)->data, &foo, 0)) + if (w32_defined_color (f, XSTRING (color)->data, &foo, 0)) { Lisp_Object rgb[3]; - rgb[0] = make_number (GetRValue (foo)); - rgb[1] = make_number (GetGValue (foo)); - rgb[2] = make_number (GetBValue (foo)); + rgb[0] = make_number ((GetRValue (foo.pixel) << 8) + | GetRValue (foo.pixel)); + rgb[1] = make_number ((GetGValue (foo.pixel) << 8) + | GetGValue (foo.pixel)); + rgb[2] = make_number ((GetBValue (foo.pixel) << 8) + | GetBValue (foo.pixel)); return Flist (3, rgb); } else return Qnil; } -DEFUN ("x-display-color-p", Fx_display_color_p, Sx_display_color_p, 0, 1, 0, - "Return t if the X display supports color.\n\ -The optional argument DISPLAY specifies which display to ask about.\n\ -DISPLAY should be either a frame or a display name (a string).\n\ -If omitted or nil, that stands for the selected frame's display.") +DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0, + "Internal function called by `display-color-p', which see.") (display) Lisp_Object display; { @@ -4529,6 +7225,9 @@ If omitted or nil, that stands for the selected frame's display.") cap = GetDeviceCaps (hdc,SIZEPALETTE); else cap = GetDeviceCaps (hdc,NUMCOLORS); + + if (cap < 0) + cap = 1 << (dpyinfo->n_planes * dpyinfo->n_cbits); ReleaseDC (dpyinfo->root_window, hdc); @@ -4558,11 +7257,7 @@ If omitted or nil, that stands for the selected frame's display.") (display) Lisp_Object display; { - struct w32_display_info *dpyinfo = check_x_display_info (display); - char *vendor = "Microsoft Corp."; - - if (! vendor) vendor = ""; - return build_string (vendor); + return build_string ("Microsoft Corp."); } DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0, @@ -4576,10 +7271,9 @@ If omitted or nil, that stands for the selected frame's display.") (display) Lisp_Object display; { - struct w32_display_info *dpyinfo = check_x_display_info (display); - return Fcons (make_number (w32_major_version), - Fcons (make_number (w32_minor_version), Qnil)); + Fcons (make_number (w32_minor_version), + Fcons (make_number (w32_build_number), Qnil))); } DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0, @@ -4590,8 +7284,6 @@ If omitted or nil, that stands for the selected frame's display.") (display) Lisp_Object display; { - struct w32_display_info *dpyinfo = check_x_display_info (display); - return make_number (1); } @@ -4663,22 +7355,18 @@ If omitted or nil, that stands for the selected frame's display.") Lisp_Object display; { struct w32_display_info *dpyinfo = check_x_display_info (display); + Lisp_Object result = Qnil; -#if 0 - switch (dpyinfo->visual->class) - { - case StaticGray: return (intern ("static-gray")); - case GrayScale: return (intern ("gray-scale")); - case StaticColor: return (intern ("static-color")); - case PseudoColor: return (intern ("pseudo-color")); - case TrueColor: return (intern ("true-color")); - case DirectColor: return (intern ("direct-color")); - default: - error ("Display has an unknown visual class"); - } -#endif + if (dpyinfo->has_palette) + result = intern ("pseudo-color"); + else if (dpyinfo->n_planes * dpyinfo->n_cbits == 1) + result = intern ("static-grey"); + else if (dpyinfo->n_planes * dpyinfo->n_cbits == 4) + result = intern ("static-color"); + else if (dpyinfo->n_planes * dpyinfo->n_cbits > 8) + result = intern ("true-color"); - error ("Display has an unknown visual class"); + return result; } DEFUN ("x-display-save-under", Fx_display_save_under, @@ -4690,8 +7378,6 @@ If omitted or nil, that stands for the selected frame's display.") (display) Lisp_Object display; { - struct w32_display_info *dpyinfo = check_x_display_info (display); - return Qnil; } @@ -4724,11 +7410,10 @@ x_char_height (f) } int -x_screen_planes (frame) - Lisp_Object frame; +x_screen_planes (f) + register struct frame *f; { - return (FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_planes * - FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_cbits); + return FRAME_W32_DISPLAY_INFO (f)->n_planes; } /* Return the display structure for the display named NAME. @@ -4745,10 +7430,10 @@ x_display_info_for_name (name) for (dpyinfo = &one_w32_display_info, names = w32_display_name_list; dpyinfo; - dpyinfo = dpyinfo->next, names = XCONS (names)->cdr) + dpyinfo = dpyinfo->next, names = XCDR (names)) { Lisp_Object tem; - tem = Fstring_equal (XCONS (XCONS (names)->car)->car, name); + tem = Fstring_equal (XCAR (XCAR (names)), name); if (!NILP (tem)) return dpyinfo; } @@ -4764,6 +7449,7 @@ x_display_info_for_name (name) if (dpyinfo == 0) error ("Cannot connect to server %s", XSTRING (name)->data); + w32_in_use = 1; XSETFASTINT (Vwindow_system_version, 3); return dpyinfo; @@ -4778,7 +7464,6 @@ terminate Emacs if we can't open the connection.") (display, xrm_string, must_succeed) Lisp_Object display, xrm_string, must_succeed; { - unsigned int n_planes; unsigned char *xrm_option; struct w32_display_info *dpyinfo; @@ -4786,6 +7471,9 @@ terminate Emacs if we can't open the connection.") if (! NILP (xrm_string)) CHECK_STRING (xrm_string, 1); + if (! EQ (Vwindow_system, intern ("w32"))) + error ("Not using Microsoft Windows"); + /* Allow color mapping to be defined externally; first look in user's HOME directory, then in Emacs etc dir for a file called rgb.txt. */ { @@ -4841,6 +7529,8 @@ terminate Emacs if we can't open the connection.") error ("Cannot connect to server %s", XSTRING (display)->data); } + w32_in_use = 1; + XSETFASTINT (Vwindow_system_version, 3); return Qnil; } @@ -4854,7 +7544,6 @@ If DISPLAY is nil, that stands for the selected frame's display.") Lisp_Object display; { struct w32_display_info *dpyinfo = check_x_display_info (display); - struct w32_display_info *tail; int i; if (dpyinfo->reference_count > 0) @@ -4863,13 +7552,13 @@ If DISPLAY is nil, that stands for the selected frame's display.") BLOCK_INPUT; /* Free the fonts in the font table. */ for (i = 0; i < dpyinfo->n_fonts; i++) - { - if (dpyinfo->font_table[i].name) - free (dpyinfo->font_table[i].name); - /* Don't free the full_name string; - it is always shared with something else. */ - w32_unload_font (dpyinfo, dpyinfo->font_table[i].font); - } + if (dpyinfo->font_table[i].name) + { + if (dpyinfo->font_table[i].name != dpyinfo->font_table[i].full_name) + xfree (dpyinfo->font_table[i].full_name); + xfree (dpyinfo->font_table[i].name); + w32_unload_font (dpyinfo, dpyinfo->font_table[i].font); + } x_destroy_all_bitmaps (dpyinfo); x_delete_display (dpyinfo); @@ -4885,8 +7574,8 @@ DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0, Lisp_Object tail, result; result = Qnil; - for (tail = w32_display_name_list; ! NILP (tail); tail = XCONS (tail)->cdr) - result = Fcons (XCONS (XCONS (tail)->car)->car, result); + for (tail = w32_display_name_list; ! NILP (tail); tail = XCDR (tail)) + result = Fcons (XCAR (XCAR (tail)), result); return result; } @@ -4901,49 +7590,5820 @@ If DISPLAY is omitted or nil, that stands for the selected frame's display.") (on, display) Lisp_Object display, on; { - struct w32_display_info *dpyinfo = check_x_display_info (display); - return Qnil; } -/* These are the w32 specialized functions */ + +/*********************************************************************** + Image types + ***********************************************************************/ -DEFUN ("w32-select-font", Fw32_select_font, Sw32_select_font, 0, 1, 0, - "This will display the W32 font dialog and return an X font string corresponding to the selection.") - (frame) - Lisp_Object frame; +/* Value is the number of elements of vector VECTOR. */ + +#define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR)) + +/* List of supported image types. Use define_image_type to add new + types. Use lookup_image_type to find a type for a given symbol. */ + +static struct image_type *image_types; + +/* The symbol `image' which is the car of the lists used to represent + images in Lisp. */ + +extern Lisp_Object Qimage; + +/* The symbol `xbm' which is used as the type symbol for XBM images. */ + +Lisp_Object Qxbm; + +/* Keywords. */ + +extern Lisp_Object QCwidth, QCheight, QCforeground, QCbackground, QCfile; +extern Lisp_Object QCdata; +Lisp_Object QCtype, QCascent, QCmargin, QCrelief; +Lisp_Object QCconversion, QCcolor_symbols, QCheuristic_mask; +Lisp_Object QCindex; + +/* Other symbols. */ + +Lisp_Object Qlaplace; + +/* Time in seconds after which images should be removed from the cache + if not displayed. */ + +Lisp_Object Vimage_cache_eviction_delay; + +/* Function prototypes. */ + +static void define_image_type P_ ((struct image_type *type)); +static struct image_type *lookup_image_type P_ ((Lisp_Object symbol)); +static void image_error P_ ((char *format, Lisp_Object, Lisp_Object)); +static void x_laplace P_ ((struct frame *, struct image *)); +static int x_build_heuristic_mask P_ ((struct frame *, struct image *, + Lisp_Object)); + + +/* Define a new image type from TYPE. This adds a copy of TYPE to + image_types and adds the symbol *TYPE->type to Vimage_types. */ + +static void +define_image_type (type) + struct image_type *type; { - FRAME_PTR f = check_x_frame (frame); - CHOOSEFONT cf; - LOGFONT lf; - char buf[100]; + /* Make a copy of TYPE to avoid a bus error in a dumped Emacs. + The initialized data segment is read-only. */ + struct image_type *p = (struct image_type *) xmalloc (sizeof *p); + bcopy (type, p, sizeof *p); + p->next = image_types; + image_types = p; + Vimage_types = Fcons (*p->type, Vimage_types); +} - bzero (&cf, sizeof (cf)); - cf.lStructSize = sizeof (cf); - cf.hwndOwner = FRAME_W32_WINDOW (f); - cf.Flags = CF_FIXEDPITCHONLY | CF_FORCEFONTEXIST | CF_SCREENFONTS; - cf.lpLogFont = &lf; +/* Look up image type SYMBOL, and return a pointer to its image_type + structure. Value is null if SYMBOL is not a known image type. */ - if (!ChooseFont (&cf) || !w32_to_x_font (&lf, buf, 100)) - return Qnil; +static INLINE struct image_type * +lookup_image_type (symbol) + Lisp_Object symbol; +{ + struct image_type *type; - return build_string (buf); + for (type = image_types; type; type = type->next) + if (EQ (symbol, *type->type)) + break; + + return type; } - -syms_of_w32fns () + +/* Value is non-zero if OBJECT is a valid Lisp image specification. A + valid image specification is a list whose car is the symbol + `image', and whose rest is a property list. The property list must + contain a value for key `:type'. That value must be the name of a + supported image type. The rest of the property list depends on the + image type. */ + +int +valid_image_p (object) + Lisp_Object object; { - /* The section below is built by the lisp expression at the top of the file, - just above where these variables are declared. */ - /*&&& init symbols here &&&*/ - Qauto_raise = intern ("auto-raise"); - staticpro (&Qauto_raise); + int valid_p = 0; + + if (CONSP (object) && EQ (XCAR (object), Qimage)) + { + Lisp_Object symbol = Fplist_get (XCDR (object), QCtype); + struct image_type *type = lookup_image_type (symbol); + + if (type) + valid_p = type->valid_p (object); + } + + return valid_p; +} + + +/* Log error message with format string FORMAT and argument ARG. + Signaling an error, e.g. when an image cannot be loaded, is not a + good idea because this would interrupt redisplay, and the error + message display would lead to another redisplay. This function + therefore simply displays a message. */ + +static void +image_error (format, arg1, arg2) + char *format; + Lisp_Object arg1, arg2; +{ + add_to_log (format, arg1, arg2); +} + + + +/*********************************************************************** + Image specifications + ***********************************************************************/ + +enum image_value_type +{ + IMAGE_DONT_CHECK_VALUE_TYPE, + IMAGE_STRING_VALUE, + IMAGE_SYMBOL_VALUE, + IMAGE_POSITIVE_INTEGER_VALUE, + IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, + IMAGE_NON_NEGATIVE_INTEGER_VALUE, + IMAGE_ASCENT_VALUE, + IMAGE_INTEGER_VALUE, + IMAGE_FUNCTION_VALUE, + IMAGE_NUMBER_VALUE, + IMAGE_BOOL_VALUE +}; + +/* Structure used when parsing image specifications. */ + +struct image_keyword +{ + /* Name of keyword. */ + char *name; + + /* The type of value allowed. */ + enum image_value_type type; + + /* Non-zero means key must be present. */ + int mandatory_p; + + /* Used to recognize duplicate keywords in a property list. */ + int count; + + /* The value that was found. */ + Lisp_Object value; +}; + + +static int parse_image_spec P_ ((Lisp_Object, struct image_keyword *, + int, Lisp_Object)); +static Lisp_Object image_spec_value P_ ((Lisp_Object, Lisp_Object, int *)); + + +/* Parse image spec SPEC according to KEYWORDS. A valid image spec + has the format (image KEYWORD VALUE ...). One of the keyword/ + value pairs must be `:type TYPE'. KEYWORDS is a vector of + image_keywords structures of size NKEYWORDS describing other + allowed keyword/value pairs. Value is non-zero if SPEC is valid. */ + +static int +parse_image_spec (spec, keywords, nkeywords, type) + Lisp_Object spec; + struct image_keyword *keywords; + int nkeywords; + Lisp_Object type; +{ + int i; + Lisp_Object plist; + + if (!CONSP (spec) || !EQ (XCAR (spec), Qimage)) + return 0; + + plist = XCDR (spec); + while (CONSP (plist)) + { + Lisp_Object key, value; + + /* First element of a pair must be a symbol. */ + key = XCAR (plist); + plist = XCDR (plist); + if (!SYMBOLP (key)) + return 0; + + /* There must follow a value. */ + if (!CONSP (plist)) + return 0; + value = XCAR (plist); + plist = XCDR (plist); + + /* Find key in KEYWORDS. Error if not found. */ + for (i = 0; i < nkeywords; ++i) + if (strcmp (keywords[i].name, XSYMBOL (key)->name->data) == 0) + break; + + if (i == nkeywords) + continue; + + /* Record that we recognized the keyword. If a keywords + was found more than once, it's an error. */ + keywords[i].value = value; + ++keywords[i].count; + + if (keywords[i].count > 1) + return 0; + + /* Check type of value against allowed type. */ + switch (keywords[i].type) + { + case IMAGE_STRING_VALUE: + if (!STRINGP (value)) + return 0; + break; + + case IMAGE_SYMBOL_VALUE: + if (!SYMBOLP (value)) + return 0; + break; + + case IMAGE_POSITIVE_INTEGER_VALUE: + if (!INTEGERP (value) || XINT (value) <= 0) + return 0; + break; + + case IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR: + if (INTEGERP (value) && XINT (value) >= 0) + break; + if (CONSP (value) + && INTEGERP (XCAR (value)) && INTEGERP (XCDR (value)) + && XINT (XCAR (value)) >= 0 && XINT (XCDR (value)) >= 0) + break; + return 0; + + case IMAGE_ASCENT_VALUE: + if (SYMBOLP (value) && EQ (value, Qcenter)) + break; + else if (INTEGERP (value) + && XINT (value) >= 0 + && XINT (value) <= 100) + break; + return 0; + + case IMAGE_NON_NEGATIVE_INTEGER_VALUE: + if (!INTEGERP (value) || XINT (value) < 0) + return 0; + break; + + case IMAGE_DONT_CHECK_VALUE_TYPE: + break; + + case IMAGE_FUNCTION_VALUE: + value = indirect_function (value); + if (SUBRP (value) + || COMPILEDP (value) + || (CONSP (value) && EQ (XCAR (value), Qlambda))) + break; + return 0; + + case IMAGE_NUMBER_VALUE: + if (!INTEGERP (value) && !FLOATP (value)) + return 0; + break; + + case IMAGE_INTEGER_VALUE: + if (!INTEGERP (value)) + return 0; + break; + + case IMAGE_BOOL_VALUE: + if (!NILP (value) && !EQ (value, Qt)) + return 0; + break; + + default: + abort (); + break; + } + + if (EQ (key, QCtype) && !EQ (type, value)) + return 0; + } + + /* Check that all mandatory fields are present. */ + for (i = 0; i < nkeywords; ++i) + if (keywords[i].mandatory_p && keywords[i].count == 0) + return 0; + + return NILP (plist); +} + + +/* Return the value of KEY in image specification SPEC. Value is nil + if KEY is not present in SPEC. if FOUND is not null, set *FOUND + to 1 if KEY was found in SPEC, set it to 0 otherwise. */ + +static Lisp_Object +image_spec_value (spec, key, found) + Lisp_Object spec, key; + int *found; +{ + Lisp_Object tail; + + xassert (valid_image_p (spec)); + + for (tail = XCDR (spec); + CONSP (tail) && CONSP (XCDR (tail)); + tail = XCDR (XCDR (tail))) + { + if (EQ (XCAR (tail), key)) + { + if (found) + *found = 1; + return XCAR (XCDR (tail)); + } + } + + if (found) + *found = 0; + return Qnil; +} + + + + +/*********************************************************************** + Image type independent image structures + ***********************************************************************/ + +static struct image *make_image P_ ((Lisp_Object spec, unsigned hash)); +static void free_image P_ ((struct frame *f, struct image *img)); + + +/* Allocate and return a new image structure for image specification + SPEC. SPEC has a hash value of HASH. */ + +static struct image * +make_image (spec, hash) + Lisp_Object spec; + unsigned hash; +{ + struct image *img = (struct image *) xmalloc (sizeof *img); + + xassert (valid_image_p (spec)); + bzero (img, sizeof *img); + img->type = lookup_image_type (image_spec_value (spec, QCtype, NULL)); + xassert (img->type != NULL); + img->spec = spec; + img->data.lisp_val = Qnil; + img->ascent = DEFAULT_IMAGE_ASCENT; + img->hash = hash; + return img; +} + + +/* Free image IMG which was used on frame F, including its resources. */ + +static void +free_image (f, img) + struct frame *f; + struct image *img; +{ + if (img) + { + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + + /* Remove IMG from the hash table of its cache. */ + if (img->prev) + img->prev->next = img->next; + else + c->buckets[img->hash % IMAGE_CACHE_BUCKETS_SIZE] = img->next; + + if (img->next) + img->next->prev = img->prev; + + c->images[img->id] = NULL; + + /* Free resources, then free IMG. */ + img->type->free (f, img); + xfree (img); + } +} + + +/* Prepare image IMG for display on frame F. Must be called before + drawing an image. */ + +void +prepare_image_for_display (f, img) + struct frame *f; + struct image *img; +{ + EMACS_TIME t; + + /* We're about to display IMG, so set its timestamp to `now'. */ + EMACS_GET_TIME (t); + img->timestamp = EMACS_SECS (t); + + /* If IMG doesn't have a pixmap yet, load it now, using the image + type dependent loader function. */ + if (img->pixmap == 0 && !img->load_failed_p) + img->load_failed_p = img->type->load (f, img) == 0; +} + + +/* Value is the number of pixels for the ascent of image IMG when + drawn in face FACE. */ + +int +image_ascent (img, face) + struct image *img; + struct face *face; +{ + int height = img->height + img->vmargin; + int ascent; + + if (img->ascent == CENTERED_IMAGE_ASCENT) + { + if (face->font) + ascent = height / 2 - (FONT_DESCENT(face->font) + - FONT_BASE(face->font)) / 2; + else + ascent = height / 2; + } + else + ascent = height * img->ascent / 100.0; + + return ascent; +} + + + +/*********************************************************************** + Helper functions for X image types + ***********************************************************************/ + +static void x_clear_image P_ ((struct frame *f, struct image *img)); +static unsigned long x_alloc_image_color P_ ((struct frame *f, + struct image *img, + Lisp_Object color_name, + unsigned long dflt)); + +/* Free X resources of image IMG which is used on frame F. */ + +static void +x_clear_image (f, img) + struct frame *f; + struct image *img; +{ +#if 0 /* TODO: W32 image support */ + + if (img->pixmap) + { + BLOCK_INPUT; + XFreePixmap (NULL, img->pixmap); + img->pixmap = 0; + UNBLOCK_INPUT; + } + + if (img->ncolors) + { + int class = FRAME_W32_DISPLAY_INFO (f)->visual->class; + + /* If display has an immutable color map, freeing colors is not + necessary and some servers don't allow it. So don't do it. */ + if (class != StaticColor + && class != StaticGray + && class != TrueColor) + { + Colormap cmap; + BLOCK_INPUT; + cmap = DefaultColormapOfScreen (FRAME_W32_DISPLAY_INFO (f)->screen); + XFreeColors (FRAME_W32_DISPLAY (f), cmap, img->colors, + img->ncolors, 0); + UNBLOCK_INPUT; + } + + xfree (img->colors); + img->colors = NULL; + img->ncolors = 0; + } +#endif +} + + +/* Allocate color COLOR_NAME for image IMG on frame F. If color + cannot be allocated, use DFLT. Add a newly allocated color to + IMG->colors, so that it can be freed again. Value is the pixel + color. */ + +static unsigned long +x_alloc_image_color (f, img, color_name, dflt) + struct frame *f; + struct image *img; + Lisp_Object color_name; + unsigned long dflt; +{ +#if 0 /* TODO: allocing colors. */ + XColor color; + unsigned long result; + + xassert (STRINGP (color_name)); + + if (w32_defined_color (f, XSTRING (color_name)->data, &color, 1)) + { + /* This isn't called frequently so we get away with simply + reallocating the color vector to the needed size, here. */ + ++img->ncolors; + img->colors = + (unsigned long *) xrealloc (img->colors, + img->ncolors * sizeof *img->colors); + img->colors[img->ncolors - 1] = color.pixel; + result = color.pixel; + } + else + result = dflt; + return result; +#endif + return 0; +} + + + +/*********************************************************************** + Image Cache + ***********************************************************************/ + +static void cache_image P_ ((struct frame *f, struct image *img)); + + +/* Return a new, initialized image cache that is allocated from the + heap. Call free_image_cache to free an image cache. */ + +struct image_cache * +make_image_cache () +{ + struct image_cache *c = (struct image_cache *) xmalloc (sizeof *c); + int size; + + bzero (c, sizeof *c); + c->size = 50; + c->images = (struct image **) xmalloc (c->size * sizeof *c->images); + size = IMAGE_CACHE_BUCKETS_SIZE * sizeof *c->buckets; + c->buckets = (struct image **) xmalloc (size); + bzero (c->buckets, size); + return c; +} + + +/* Free image cache of frame F. Be aware that X frames share images + caches. */ + +void +free_image_cache (f) + struct frame *f; +{ + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + if (c) + { + int i; + + /* Cache should not be referenced by any frame when freed. */ + xassert (c->refcount == 0); + + for (i = 0; i < c->used; ++i) + free_image (f, c->images[i]); + xfree (c->images); + xfree (c); + xfree (c->buckets); + FRAME_X_IMAGE_CACHE (f) = NULL; + } +} + + +/* Clear image cache of frame F. FORCE_P non-zero means free all + images. FORCE_P zero means clear only images that haven't been + displayed for some time. Should be called from time to time to + reduce the number of loaded images. If image-eviction-seconds is + non-nil, this frees images in the cache which weren't displayed for + at least that many seconds. */ + +void +clear_image_cache (f, force_p) + struct frame *f; + int force_p; +{ + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + + if (c && INTEGERP (Vimage_cache_eviction_delay)) + { + EMACS_TIME t; + unsigned long old; + int i, any_freed_p = 0; + + EMACS_GET_TIME (t); + old = EMACS_SECS (t) - XFASTINT (Vimage_cache_eviction_delay); + + for (i = 0; i < c->used; ++i) + { + struct image *img = c->images[i]; + if (img != NULL + && (force_p + || (img->timestamp > old))) + { + free_image (f, img); + any_freed_p = 1; + } + } + + /* We may be clearing the image cache because, for example, + Emacs was iconified for a longer period of time. In that + case, current matrices may still contain references to + images freed above. So, clear these matrices. */ + if (any_freed_p) + { + clear_current_matrices (f); + ++windows_or_buffers_changed; + } + } +} + + +DEFUN ("clear-image-cache", Fclear_image_cache, Sclear_image_cache, + 0, 1, 0, + "Clear the image cache of FRAME.\n\ +FRAME nil or omitted means use the selected frame.\n\ +FRAME t means clear the image caches of all frames.") + (frame) + Lisp_Object frame; +{ + if (EQ (frame, Qt)) + { + Lisp_Object tail; + + FOR_EACH_FRAME (tail, frame) + if (FRAME_W32_P (XFRAME (frame))) + clear_image_cache (XFRAME (frame), 1); + } + else + clear_image_cache (check_x_frame (frame), 1); + + return Qnil; +} + + +/* Return the id of image with Lisp specification SPEC on frame F. + SPEC must be a valid Lisp image specification (see valid_image_p). */ + +int +lookup_image (f, spec) + struct frame *f; + Lisp_Object spec; +{ + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + struct image *img; + int i; + unsigned hash; + struct gcpro gcpro1; + EMACS_TIME now; + + /* F must be a window-system frame, and SPEC must be a valid image + specification. */ + xassert (FRAME_WINDOW_P (f)); + xassert (valid_image_p (spec)); + + GCPRO1 (spec); + + /* Look up SPEC in the hash table of the image cache. */ + hash = sxhash (spec, 0); + i = hash % IMAGE_CACHE_BUCKETS_SIZE; + + for (img = c->buckets[i]; img; img = img->next) + if (img->hash == hash && !NILP (Fequal (img->spec, spec))) + break; + + /* If not found, create a new image and cache it. */ + if (img == NULL) + { + BLOCK_INPUT; + img = make_image (spec, hash); + cache_image (f, img); + img->load_failed_p = img->type->load (f, img) == 0; + + /* If we can't load the image, and we don't have a width and + height, use some arbitrary width and height so that we can + draw a rectangle for it. */ + if (img->load_failed_p) + { + Lisp_Object value; + + value = image_spec_value (spec, QCwidth, NULL); + img->width = (INTEGERP (value) + ? XFASTINT (value) : DEFAULT_IMAGE_WIDTH); + value = image_spec_value (spec, QCheight, NULL); + img->height = (INTEGERP (value) + ? XFASTINT (value) : DEFAULT_IMAGE_HEIGHT); + } + else + { + /* Handle image type independent image attributes + `:ascent PERCENT', `:margin MARGIN', `:relief RELIEF'. */ + Lisp_Object ascent, margin, relief; + + ascent = image_spec_value (spec, QCascent, NULL); + if (INTEGERP (ascent)) + img->ascent = XFASTINT (ascent); + else if (EQ (ascent, Qcenter)) + img->ascent = CENTERED_IMAGE_ASCENT; + + margin = image_spec_value (spec, QCmargin, NULL); + if (INTEGERP (margin) && XINT (margin) >= 0) + img->vmargin = img->hmargin = XFASTINT (margin); + else if (CONSP (margin) && INTEGERP (XCAR (margin)) + && INTEGERP (XCDR (margin))) + { + if (XINT (XCAR (margin)) > 0) + img->hmargin = XFASTINT (XCAR (margin)); + if (XINT (XCDR (margin)) > 0) + img->vmargin = XFASTINT (XCDR (margin)); + } + + relief = image_spec_value (spec, QCrelief, NULL); + if (INTEGERP (relief)) + { + img->relief = XINT (relief); + img->hmargin += abs (img->relief); + img->vmargin += abs (img->relief); + } + +#if 0 /* TODO: image mask and algorithm. */ + /* Manipulation of the image's mask. */ + if (img->pixmap) + { + /* `:heuristic-mask t' + `:mask heuristic' + means build a mask heuristically. + `:heuristic-mask (R G B)' + `:mask (heuristic (R G B))' + means build a mask from color (R G B) in the + image. + `:mask nil' + means remove a mask, if any. */ + + Lisp_Object mask; + + mask = image_spec_value (spec, QCheuristic_mask, NULL); + if (!NILP (mask)) + x_build_heuristic_mask (f, img, mask); + else + { + int found_p; + + mask = image_spec_value (spec, QCmask, &found_p); + + if (EQ (mask, Qheuristic)) + x_build_heuristic_mask (f, img, Qt); + else if (CONSP (mask) + && EQ (XCAR (mask), Qheuristic)) + { + if (CONSP (XCDR (mask))) + x_build_heuristic_mask (f, img, XCAR (XCDR (mask))); + else + x_build_heuristic_mask (f, img, XCDR (mask)); + } + else if (NILP (mask) && found_p && img->mask) + { + XFreePixmap (FRAME_X_DISPLAY (f), img->mask); + img->mask = None; + } + } + } + + /* Should we apply an image transformation algorithm? */ + if (img->pixmap) + { + Lisp_Object conversion; + + algorithm = image_spec_value (spec, QCconversion, NULL); + if (EQ (conversion, Qdisabled)) + x_disable_image (f, img); + else if (EQ (conversion, Qlaplace)) + x_laplace (f, img); + else if (EQ (conversion, Qemboss)) + x_emboss (f, img); + else if (CONSP (conversion) + && EQ (XCAR (conversion), Qedge_detection)) + { + Lisp_Object tem; + tem = XCDR (conversion); + if (CONSP (tem)) + x_edge_detection (f, img, + Fplist_get (tem, QCmatrix), + Fplist_get (tem, QCcolor_adjustment)); + } + } +#endif /* TODO. */ + } + UNBLOCK_INPUT; + xassert (!interrupt_input_blocked); + } + + /* We're using IMG, so set its timestamp to `now'. */ + EMACS_GET_TIME (now); + img->timestamp = EMACS_SECS (now); + + UNGCPRO; + + /* Value is the image id. */ + return img->id; +} + + +/* Cache image IMG in the image cache of frame F. */ + +static void +cache_image (f, img) + struct frame *f; + struct image *img; +{ + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + int i; + + /* Find a free slot in c->images. */ + for (i = 0; i < c->used; ++i) + if (c->images[i] == NULL) + break; + + /* If no free slot found, maybe enlarge c->images. */ + if (i == c->used && c->used == c->size) + { + c->size *= 2; + c->images = (struct image **) xrealloc (c->images, + c->size * sizeof *c->images); + } + + /* Add IMG to c->images, and assign IMG an id. */ + c->images[i] = img; + img->id = i; + if (i == c->used) + ++c->used; + + /* Add IMG to the cache's hash table. */ + i = img->hash % IMAGE_CACHE_BUCKETS_SIZE; + img->next = c->buckets[i]; + if (img->next) + img->next->prev = img; + img->prev = NULL; + c->buckets[i] = img; +} + + +/* Call FN on every image in the image cache of frame F. Used to mark + Lisp Objects in the image cache. */ + +void +forall_images_in_image_cache (f, fn) + struct frame *f; + void (*fn) P_ ((struct image *img)); +{ + if (FRAME_LIVE_P (f) && FRAME_W32_P (f)) + { + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + if (c) + { + int i; + for (i = 0; i < c->used; ++i) + if (c->images[i]) + fn (c->images[i]); + } + } +} + + + +/*********************************************************************** + W32 support code + ***********************************************************************/ + +#if 0 /* TODO: W32 specific image code. */ + +static int x_create_x_image_and_pixmap P_ ((struct frame *, int, int, int, + XImage **, Pixmap *)); +static void x_destroy_x_image P_ ((XImage *)); +static void x_put_x_image P_ ((struct frame *, XImage *, Pixmap, int, int)); + + +/* Create an XImage and a pixmap of size WIDTH x HEIGHT for use on + frame F. Set *XIMG and *PIXMAP to the XImage and Pixmap created. + Set (*XIMG)->data to a raster of WIDTH x HEIGHT pixels allocated + via xmalloc. Print error messages via image_error if an error + occurs. Value is non-zero if successful. */ + +static int +x_create_x_image_and_pixmap (f, width, height, depth, ximg, pixmap) + struct frame *f; + int width, height, depth; + XImage **ximg; + Pixmap *pixmap; +{ +#if 0 /* TODO: Image support for W32 */ + Display *display = FRAME_W32_DISPLAY (f); + Screen *screen = FRAME_X_SCREEN (f); + Window window = FRAME_W32_WINDOW (f); + + xassert (interrupt_input_blocked); + + if (depth <= 0) + depth = DefaultDepthOfScreen (screen); + *ximg = XCreateImage (display, DefaultVisualOfScreen (screen), + depth, ZPixmap, 0, NULL, width, height, + depth > 16 ? 32 : depth > 8 ? 16 : 8, 0); + if (*ximg == NULL) + { + image_error ("Unable to allocate X image", Qnil, Qnil); + return 0; + } + + /* Allocate image raster. */ + (*ximg)->data = (char *) xmalloc ((*ximg)->bytes_per_line * height); + + /* Allocate a pixmap of the same size. */ + *pixmap = XCreatePixmap (display, window, width, height, depth); + if (*pixmap == 0) + { + x_destroy_x_image (*ximg); + *ximg = NULL; + image_error ("Unable to create X pixmap", Qnil, Qnil); + return 0; + } +#endif + return 1; +} + + +/* Destroy XImage XIMG. Free XIMG->data. */ + +static void +x_destroy_x_image (ximg) + XImage *ximg; +{ + xassert (interrupt_input_blocked); + if (ximg) + { + xfree (ximg->data); + ximg->data = NULL; + XDestroyImage (ximg); + } +} + + +/* Put XImage XIMG into pixmap PIXMAP on frame F. WIDTH and HEIGHT + are width and height of both the image and pixmap. */ + +static void +x_put_x_image (f, ximg, pixmap, width, height) + struct frame *f; + XImage *ximg; + Pixmap pixmap; +{ + GC gc; + + xassert (interrupt_input_blocked); + gc = XCreateGC (NULL, pixmap, 0, NULL); + XPutImage (NULL, pixmap, gc, ximg, 0, 0, 0, 0, width, height); + XFreeGC (NULL, gc); +} + +#endif + + +/*********************************************************************** + Searching files + ***********************************************************************/ + +static Lisp_Object x_find_image_file P_ ((Lisp_Object)); + +/* Find image file FILE. Look in data-directory, then + x-bitmap-file-path. Value is the full name of the file found, or + nil if not found. */ + +static Lisp_Object +x_find_image_file (file) + Lisp_Object file; +{ + Lisp_Object file_found, search_path; + struct gcpro gcpro1, gcpro2; + int fd; + + file_found = Qnil; + search_path = Fcons (Vdata_directory, Vx_bitmap_file_path); + GCPRO2 (file_found, search_path); + + /* Try to find FILE in data-directory, then x-bitmap-file-path. */ + fd = openp (search_path, file, "", &file_found, 0); + + if (fd == -1) + file_found = Qnil; + else + close (fd); + + UNGCPRO; + return file_found; +} + + + +/*********************************************************************** + XBM images + ***********************************************************************/ + +static int xbm_load P_ ((struct frame *f, struct image *img)); +static int xbm_load_image_from_file P_ ((struct frame *f, struct image *img, + Lisp_Object file)); +static int xbm_image_p P_ ((Lisp_Object object)); +static int xbm_read_bitmap_file_data P_ ((char *, int *, int *, + unsigned char **)); + + +/* Indices of image specification fields in xbm_format, below. */ + +enum xbm_keyword_index +{ + XBM_TYPE, + XBM_FILE, + XBM_WIDTH, + XBM_HEIGHT, + XBM_DATA, + XBM_FOREGROUND, + XBM_BACKGROUND, + XBM_ASCENT, + XBM_MARGIN, + XBM_RELIEF, + XBM_ALGORITHM, + XBM_HEURISTIC_MASK, + XBM_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid XBM image specifications. */ + +static struct image_keyword xbm_format[XBM_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":file", IMAGE_STRING_VALUE, 0}, + {":width", IMAGE_POSITIVE_INTEGER_VALUE, 0}, + {":height", IMAGE_POSITIVE_INTEGER_VALUE, 0}, + {":data", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":foreground", IMAGE_STRING_VALUE, 0}, + {":background", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0} +}; + +/* Structure describing the image type XBM. */ + +static struct image_type xbm_type = +{ + &Qxbm, + xbm_image_p, + xbm_load, + x_clear_image, + NULL +}; + +/* Tokens returned from xbm_scan. */ + +enum xbm_token +{ + XBM_TK_IDENT = 256, + XBM_TK_NUMBER +}; + + +/* Return non-zero if OBJECT is a valid XBM-type image specification. + A valid specification is a list starting with the symbol `image' + The rest of the list is a property list which must contain an + entry `:type xbm.. + + If the specification specifies a file to load, it must contain + an entry `:file FILENAME' where FILENAME is a string. + + If the specification is for a bitmap loaded from memory it must + contain `:width WIDTH', `:height HEIGHT', and `:data DATA', where + WIDTH and HEIGHT are integers > 0. DATA may be: + + 1. a string large enough to hold the bitmap data, i.e. it must + have a size >= (WIDTH + 7) / 8 * HEIGHT + + 2. a bool-vector of size >= WIDTH * HEIGHT + + 3. a vector of strings or bool-vectors, one for each line of the + bitmap. + + Both the file and data forms may contain the additional entries + `:background COLOR' and `:foreground COLOR'. If not present, + foreground and background of the frame on which the image is + displayed, is used. */ + +static int +xbm_image_p (object) + Lisp_Object object; +{ + struct image_keyword kw[XBM_LAST]; + + bcopy (xbm_format, kw, sizeof kw); + if (!parse_image_spec (object, kw, XBM_LAST, Qxbm)) + return 0; + + xassert (EQ (kw[XBM_TYPE].value, Qxbm)); + + if (kw[XBM_FILE].count) + { + if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_DATA].count) + return 0; + } + else + { + Lisp_Object data; + int width, height; + + /* Entries for `:width', `:height' and `:data' must be present. */ + if (!kw[XBM_WIDTH].count + || !kw[XBM_HEIGHT].count + || !kw[XBM_DATA].count) + return 0; + + data = kw[XBM_DATA].value; + width = XFASTINT (kw[XBM_WIDTH].value); + height = XFASTINT (kw[XBM_HEIGHT].value); + + /* Check type of data, and width and height against contents of + data. */ + if (VECTORP (data)) + { + int i; + + /* Number of elements of the vector must be >= height. */ + if (XVECTOR (data)->size < height) + return 0; + + /* Each string or bool-vector in data must be large enough + for one line of the image. */ + for (i = 0; i < height; ++i) + { + Lisp_Object elt = XVECTOR (data)->contents[i]; + + if (STRINGP (elt)) + { + if (XSTRING (elt)->size + < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR) + return 0; + } + else if (BOOL_VECTOR_P (elt)) + { + if (XBOOL_VECTOR (elt)->size < width) + return 0; + } + else + return 0; + } + } + else if (STRINGP (data)) + { + if (XSTRING (data)->size + < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR * height) + return 0; + } + else if (BOOL_VECTOR_P (data)) + { + if (XBOOL_VECTOR (data)->size < width * height) + return 0; + } + else + return 0; + } + + /* Baseline must be a value between 0 and 100 (a percentage). */ + if (kw[XBM_ASCENT].count + && XFASTINT (kw[XBM_ASCENT].value) > 100) + return 0; + + return 1; +} + + +/* Scan a bitmap file. FP is the stream to read from. Value is + either an enumerator from enum xbm_token, or a character for a + single-character token, or 0 at end of file. If scanning an + identifier, store the lexeme of the identifier in SVAL. If + scanning a number, store its value in *IVAL. */ + +static int +xbm_scan (fp, sval, ival) + FILE *fp; + char *sval; + int *ival; +{ + int c; + + /* Skip white space. */ + while ((c = fgetc (fp)) != EOF && isspace (c)) + ; + + if (c == EOF) + c = 0; + else if (isdigit (c)) + { + int value = 0, digit; + + if (c == '0') + { + c = fgetc (fp); + if (c == 'x' || c == 'X') + { + while ((c = fgetc (fp)) != EOF) + { + if (isdigit (c)) + digit = c - '0'; + else if (c >= 'a' && c <= 'f') + digit = c - 'a' + 10; + else if (c >= 'A' && c <= 'F') + digit = c - 'A' + 10; + else + break; + value = 16 * value + digit; + } + } + else if (isdigit (c)) + { + value = c - '0'; + while ((c = fgetc (fp)) != EOF + && isdigit (c)) + value = 8 * value + c - '0'; + } + } + else + { + value = c - '0'; + while ((c = fgetc (fp)) != EOF + && isdigit (c)) + value = 10 * value + c - '0'; + } + + if (c != EOF) + ungetc (c, fp); + *ival = value; + c = XBM_TK_NUMBER; + } + else if (isalpha (c) || c == '_') + { + *sval++ = c; + while ((c = fgetc (fp)) != EOF + && (isalnum (c) || c == '_')) + *sval++ = c; + *sval = 0; + if (c != EOF) + ungetc (c, fp); + c = XBM_TK_IDENT; + } + + return c; +} + + +/* Replacement for XReadBitmapFileData which isn't available under old + X versions. FILE is the name of the bitmap file to read. Set + *WIDTH and *HEIGHT to the width and height of the image. Return in + *DATA the bitmap data allocated with xmalloc. Value is non-zero if + successful. */ + +static int +xbm_read_bitmap_file_data (file, width, height, data) + char *file; + int *width, *height; + unsigned char **data; +{ + FILE *fp; + char buffer[BUFSIZ]; + int padding_p = 0; + int v10 = 0; + int bytes_per_line, i, nbytes; + unsigned char *p; + int value; + int LA1; + +#define match() \ + LA1 = xbm_scan (fp, buffer, &value) + +#define expect(TOKEN) \ + if (LA1 != (TOKEN)) \ + goto failure; \ + else \ + match () + +#define expect_ident(IDENT) \ + if (LA1 == XBM_TK_IDENT && strcmp (buffer, (IDENT)) == 0) \ + match (); \ + else \ + goto failure + + fp = fopen (file, "r"); + if (fp == NULL) + return 0; + + *width = *height = -1; + *data = NULL; + LA1 = xbm_scan (fp, buffer, &value); + + /* Parse defines for width, height and hot-spots. */ + while (LA1 == '#') + { + match (); + expect_ident ("define"); + expect (XBM_TK_IDENT); + + if (LA1 == XBM_TK_NUMBER); + { + char *p = strrchr (buffer, '_'); + p = p ? p + 1 : buffer; + if (strcmp (p, "width") == 0) + *width = value; + else if (strcmp (p, "height") == 0) + *height = value; + } + expect (XBM_TK_NUMBER); + } + + if (*width < 0 || *height < 0) + goto failure; + + /* Parse bits. Must start with `static'. */ + expect_ident ("static"); + if (LA1 == XBM_TK_IDENT) + { + if (strcmp (buffer, "unsigned") == 0) + { + match (); + expect_ident ("char"); + } + else if (strcmp (buffer, "short") == 0) + { + match (); + v10 = 1; + if (*width % 16 && *width % 16 < 9) + padding_p = 1; + } + else if (strcmp (buffer, "char") == 0) + match (); + else + goto failure; + } + else + goto failure; + + expect (XBM_TK_IDENT); + expect ('['); + expect (']'); + expect ('='); + expect ('{'); + + bytes_per_line = (*width + 7) / 8 + padding_p; + nbytes = bytes_per_line * *height; + p = *data = (char *) xmalloc (nbytes); + + if (v10) + { + + for (i = 0; i < nbytes; i += 2) + { + int val = value; + expect (XBM_TK_NUMBER); + + *p++ = val; + if (!padding_p || ((i + 2) % bytes_per_line)) + *p++ = value >> 8; + + if (LA1 == ',' || LA1 == '}') + match (); + else + goto failure; + } + } + else + { + for (i = 0; i < nbytes; ++i) + { + int val = value; + expect (XBM_TK_NUMBER); + + *p++ = val; + + if (LA1 == ',' || LA1 == '}') + match (); + else + goto failure; + } + } + + fclose (fp); + return 1; + + failure: + + fclose (fp); + if (*data) + { + xfree (*data); + *data = NULL; + } + return 0; + +#undef match +#undef expect +#undef expect_ident +} + + +/* Load XBM image IMG which will be displayed on frame F from file + SPECIFIED_FILE. Value is non-zero if successful. */ + +static int +xbm_load_image_from_file (f, img, specified_file) + struct frame *f; + struct image *img; + Lisp_Object specified_file; +{ + int rc; + unsigned char *data; + int success_p = 0; + Lisp_Object file; + struct gcpro gcpro1; + + xassert (STRINGP (specified_file)); + file = Qnil; + GCPRO1 (file); + + file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + UNGCPRO; + return 0; + } + + rc = xbm_read_bitmap_file_data (XSTRING (file)->data, &img->width, + &img->height, &data); + if (rc) + { + int depth = one_w32_display_info.n_cbits; + unsigned long foreground = FRAME_FOREGROUND_PIXEL (f); + unsigned long background = FRAME_BACKGROUND_PIXEL (f); + Lisp_Object value; + + xassert (img->width > 0 && img->height > 0); + + /* Get foreground and background colors, maybe allocate colors. */ + value = image_spec_value (img->spec, QCforeground, NULL); + if (!NILP (value)) + foreground = x_alloc_image_color (f, img, value, foreground); + + value = image_spec_value (img->spec, QCbackground, NULL); + if (!NILP (value)) + background = x_alloc_image_color (f, img, value, background); + +#if 0 /* TODO : Port image display to W32 */ + BLOCK_INPUT; + img->pixmap + = XCreatePixmapFromBitmapData (FRAME_W32_DISPLAY (f), + FRAME_W32_WINDOW (f), + data, + img->width, img->height, + foreground, background, + depth); + xfree (data); + + if (img->pixmap == 0) + { + x_clear_image (f, img); + image_error ("Unable to create X pixmap for `%s'", file, Qnil); + } + else + success_p = 1; + + UNBLOCK_INPUT; +#endif + } + else + image_error ("Error loading XBM image `%s'", img->spec, Qnil); + + UNGCPRO; + return success_p; +} + + +/* Fill image IMG which is used on frame F with pixmap data. Value is + non-zero if successful. */ + +static int +xbm_load (f, img) + struct frame *f; + struct image *img; +{ + int success_p = 0; + Lisp_Object file_name; + + xassert (xbm_image_p (img->spec)); + + /* If IMG->spec specifies a file name, create a non-file spec from it. */ + file_name = image_spec_value (img->spec, QCfile, NULL); + if (STRINGP (file_name)) + success_p = xbm_load_image_from_file (f, img, file_name); + else + { + struct image_keyword fmt[XBM_LAST]; + Lisp_Object data; + int depth; + unsigned long foreground = FRAME_FOREGROUND_PIXEL (f); + unsigned long background = FRAME_BACKGROUND_PIXEL (f); + char *bits; + int parsed_p; + + /* Parse the list specification. */ + bcopy (xbm_format, fmt, sizeof fmt); + parsed_p = parse_image_spec (img->spec, fmt, XBM_LAST, Qxbm); + xassert (parsed_p); + + /* Get specified width, and height. */ + img->width = XFASTINT (fmt[XBM_WIDTH].value); + img->height = XFASTINT (fmt[XBM_HEIGHT].value); + xassert (img->width > 0 && img->height > 0); + + BLOCK_INPUT; + + if (fmt[XBM_ASCENT].count) + img->ascent = XFASTINT (fmt[XBM_ASCENT].value); + + /* Get foreground and background colors, maybe allocate colors. */ + if (fmt[XBM_FOREGROUND].count) + foreground = x_alloc_image_color (f, img, fmt[XBM_FOREGROUND].value, + foreground); + if (fmt[XBM_BACKGROUND].count) + background = x_alloc_image_color (f, img, fmt[XBM_BACKGROUND].value, + background); + + /* Set bits to the bitmap image data. */ + data = fmt[XBM_DATA].value; + if (VECTORP (data)) + { + int i; + char *p; + int nbytes = (img->width + BITS_PER_CHAR - 1) / BITS_PER_CHAR; + + p = bits = (char *) alloca (nbytes * img->height); + for (i = 0; i < img->height; ++i, p += nbytes) + { + Lisp_Object line = XVECTOR (data)->contents[i]; + if (STRINGP (line)) + bcopy (XSTRING (line)->data, p, nbytes); + else + bcopy (XBOOL_VECTOR (line)->data, p, nbytes); + } + } + else if (STRINGP (data)) + bits = XSTRING (data)->data; + else + bits = XBOOL_VECTOR (data)->data; + +#if 0 /* TODO : W32 XPM code */ + /* Create the pixmap. */ + depth = DefaultDepthOfScreen (FRAME_X_SCREEN (f)); + img->pixmap + = XCreatePixmapFromBitmapData (FRAME_W32_DISPLAY (f), + FRAME_W32_WINDOW (f), + bits, + img->width, img->height, + foreground, background, + depth); +#endif /* TODO */ + + if (img->pixmap) + success_p = 1; + else + { + image_error ("Unable to create pixmap for XBM image `%s'", + img->spec, Qnil); + x_clear_image (f, img); + } + + UNBLOCK_INPUT; + } + + return success_p; +} + + + +/*********************************************************************** + XPM images + ***********************************************************************/ + +#if HAVE_XPM + +static int xpm_image_p P_ ((Lisp_Object object)); +static int xpm_load P_ ((struct frame *f, struct image *img)); +static int xpm_valid_color_symbols_p P_ ((Lisp_Object)); + +#include "X11/xpm.h" + +/* The symbol `xpm' identifying XPM-format images. */ + +Lisp_Object Qxpm; + +/* Indices of image specification fields in xpm_format, below. */ + +enum xpm_keyword_index +{ + XPM_TYPE, + XPM_FILE, + XPM_DATA, + XPM_ASCENT, + XPM_MARGIN, + XPM_RELIEF, + XPM_ALGORITHM, + XPM_HEURISTIC_MASK, + XPM_COLOR_SYMBOLS, + XPM_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid XPM image specifications. */ + +static struct image_keyword xpm_format[XPM_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":file", IMAGE_STRING_VALUE, 0}, + {":data", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0} +}; + +/* Structure describing the image type XBM. */ + +static struct image_type xpm_type = +{ + &Qxpm, + xpm_image_p, + xpm_load, + x_clear_image, + NULL +}; + + +/* Value is non-zero if COLOR_SYMBOLS is a valid color symbols list + for XPM images. Such a list must consist of conses whose car and + cdr are strings. */ + +static int +xpm_valid_color_symbols_p (color_symbols) + Lisp_Object color_symbols; +{ + while (CONSP (color_symbols)) + { + Lisp_Object sym = XCAR (color_symbols); + if (!CONSP (sym) + || !STRINGP (XCAR (sym)) + || !STRINGP (XCDR (sym))) + break; + color_symbols = XCDR (color_symbols); + } + + return NILP (color_symbols); +} + + +/* Value is non-zero if OBJECT is a valid XPM image specification. */ + +static int +xpm_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[XPM_LAST]; + bcopy (xpm_format, fmt, sizeof fmt); + return (parse_image_spec (object, fmt, XPM_LAST, Qxpm) + /* Either `:file' or `:data' must be present. */ + && fmt[XPM_FILE].count + fmt[XPM_DATA].count == 1 + /* Either no `:color-symbols' or it's a list of conses + whose car and cdr are strings. */ + && (fmt[XPM_COLOR_SYMBOLS].count == 0 + || xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value)) + && (fmt[XPM_ASCENT].count == 0 + || XFASTINT (fmt[XPM_ASCENT].value) < 100)); +} + + +/* Load image IMG which will be displayed on frame F. Value is + non-zero if successful. */ + +static int +xpm_load (f, img) + struct frame *f; + struct image *img; +{ + int rc, i; + XpmAttributes attrs; + Lisp_Object specified_file, color_symbols; + + /* Configure the XPM lib. Use the visual of frame F. Allocate + close colors. Return colors allocated. */ + bzero (&attrs, sizeof attrs); + attrs.visual = FRAME_X_VISUAL (f); + attrs.colormap = FRAME_X_COLORMAP (f); + attrs.valuemask |= XpmVisual; + attrs.valuemask |= XpmColormap; + attrs.valuemask |= XpmReturnAllocPixels; +#ifdef XpmAllocCloseColors + attrs.alloc_close_colors = 1; + attrs.valuemask |= XpmAllocCloseColors; +#else + attrs.closeness = 600; + attrs.valuemask |= XpmCloseness; +#endif + + /* If image specification contains symbolic color definitions, add + these to `attrs'. */ + color_symbols = image_spec_value (img->spec, QCcolor_symbols, NULL); + if (CONSP (color_symbols)) + { + Lisp_Object tail; + XpmColorSymbol *xpm_syms; + int i, size; + + attrs.valuemask |= XpmColorSymbols; + + /* Count number of symbols. */ + attrs.numsymbols = 0; + for (tail = color_symbols; CONSP (tail); tail = XCDR (tail)) + ++attrs.numsymbols; + + /* Allocate an XpmColorSymbol array. */ + size = attrs.numsymbols * sizeof *xpm_syms; + xpm_syms = (XpmColorSymbol *) alloca (size); + bzero (xpm_syms, size); + attrs.colorsymbols = xpm_syms; + + /* Fill the color symbol array. */ + for (tail = color_symbols, i = 0; + CONSP (tail); + ++i, tail = XCDR (tail)) + { + Lisp_Object name = XCAR (XCAR (tail)); + Lisp_Object color = XCDR (XCAR (tail)); + xpm_syms[i].name = (char *) alloca (XSTRING (name)->size + 1); + strcpy (xpm_syms[i].name, XSTRING (name)->data); + xpm_syms[i].value = (char *) alloca (XSTRING (color)->size + 1); + strcpy (xpm_syms[i].value, XSTRING (color)->data); + } + } + + /* Create a pixmap for the image, either from a file, or from a + string buffer containing data in the same format as an XPM file. */ + BLOCK_INPUT; + specified_file = image_spec_value (img->spec, QCfile, NULL); + if (STRINGP (specified_file)) + { + Lisp_Object file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + UNBLOCK_INPUT; + return 0; + } + + rc = XpmReadFileToPixmap (NULL, FRAME_W32_WINDOW (f), + XSTRING (file)->data, &img->pixmap, &img->mask, + &attrs); + } + else + { + Lisp_Object buffer = image_spec_value (img->spec, QCdata, NULL); + rc = XpmCreatePixmapFromBuffer (NULL, FRAME_W32_WINDOW (f), + XSTRING (buffer)->data, + &img->pixmap, &img->mask, + &attrs); + } + UNBLOCK_INPUT; + + if (rc == XpmSuccess) + { + /* Remember allocated colors. */ + img->ncolors = attrs.nalloc_pixels; + img->colors = (unsigned long *) xmalloc (img->ncolors + * sizeof *img->colors); + for (i = 0; i < attrs.nalloc_pixels; ++i) + img->colors[i] = attrs.alloc_pixels[i]; + + img->width = attrs.width; + img->height = attrs.height; + xassert (img->width > 0 && img->height > 0); + + /* The call to XpmFreeAttributes below frees attrs.alloc_pixels. */ + BLOCK_INPUT; + XpmFreeAttributes (&attrs); + UNBLOCK_INPUT; + } + else + { + switch (rc) + { + case XpmOpenFailed: + image_error ("Error opening XPM file (%s)", img->spec, Qnil); + break; + + case XpmFileInvalid: + image_error ("Invalid XPM file (%s)", img->spec, Qnil); + break; + + case XpmNoMemory: + image_error ("Out of memory (%s)", img->spec, Qnil); + break; + + case XpmColorFailed: + image_error ("Color allocation error (%s)", img->spec, Qnil); + break; + + default: + image_error ("Unknown error (%s)", img->spec, Qnil); + break; + } + } + + return rc == XpmSuccess; +} + +#endif /* HAVE_XPM != 0 */ + + +#if 0 /* TODO : Color tables on W32. */ +/*********************************************************************** + Color table + ***********************************************************************/ + +/* An entry in the color table mapping an RGB color to a pixel color. */ + +struct ct_color +{ + int r, g, b; + unsigned long pixel; + + /* Next in color table collision list. */ + struct ct_color *next; +}; + +/* The bucket vector size to use. Must be prime. */ + +#define CT_SIZE 101 + +/* Value is a hash of the RGB color given by R, G, and B. */ + +#define CT_HASH_RGB(R, G, B) (((R) << 16) ^ ((G) << 8) ^ (B)) + +/* The color hash table. */ + +struct ct_color **ct_table; + +/* Number of entries in the color table. */ + +int ct_colors_allocated; + +/* Function prototypes. */ + +static void init_color_table P_ ((void)); +static void free_color_table P_ ((void)); +static unsigned long *colors_in_color_table P_ ((int *n)); +static unsigned long lookup_rgb_color P_ ((struct frame *f, int r, int g, int b)); +static unsigned long lookup_pixel_color P_ ((struct frame *f, unsigned long p)); + + +/* Initialize the color table. */ + +static void +init_color_table () +{ + int size = CT_SIZE * sizeof (*ct_table); + ct_table = (struct ct_color **) xmalloc (size); + bzero (ct_table, size); + ct_colors_allocated = 0; +} + + +/* Free memory associated with the color table. */ + +static void +free_color_table () +{ + int i; + struct ct_color *p, *next; + + for (i = 0; i < CT_SIZE; ++i) + for (p = ct_table[i]; p; p = next) + { + next = p->next; + xfree (p); + } + + xfree (ct_table); + ct_table = NULL; +} + + +/* Value is a pixel color for RGB color R, G, B on frame F. If an + entry for that color already is in the color table, return the + pixel color of that entry. Otherwise, allocate a new color for R, + G, B, and make an entry in the color table. */ + +static unsigned long +lookup_rgb_color (f, r, g, b) + struct frame *f; + int r, g, b; +{ + unsigned hash = CT_HASH_RGB (r, g, b); + int i = hash % CT_SIZE; + struct ct_color *p; + + for (p = ct_table[i]; p; p = p->next) + if (p->r == r && p->g == g && p->b == b) + break; + + if (p == NULL) + { + COLORREF color; + Colormap cmap; + int rc; + + color = PALETTERGB (r, g, b); + + ++ct_colors_allocated; + + p = (struct ct_color *) xmalloc (sizeof *p); + p->r = r; + p->g = g; + p->b = b; + p->pixel = color; + p->next = ct_table[i]; + ct_table[i] = p; + } + + return p->pixel; +} + + +/* Look up pixel color PIXEL which is used on frame F in the color + table. If not already present, allocate it. Value is PIXEL. */ + +static unsigned long +lookup_pixel_color (f, pixel) + struct frame *f; + unsigned long pixel; +{ + int i = pixel % CT_SIZE; + struct ct_color *p; + + for (p = ct_table[i]; p; p = p->next) + if (p->pixel == pixel) + break; + + if (p == NULL) + { + XColor color; + Colormap cmap; + int rc; + + BLOCK_INPUT; + + cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f)); + color.pixel = pixel; + XQueryColor (NULL, cmap, &color); + rc = x_alloc_nearest_color (f, cmap, &color); + UNBLOCK_INPUT; + + if (rc) + { + ++ct_colors_allocated; + + p = (struct ct_color *) xmalloc (sizeof *p); + p->r = color.red; + p->g = color.green; + p->b = color.blue; + p->pixel = pixel; + p->next = ct_table[i]; + ct_table[i] = p; + } + else + return FRAME_FOREGROUND_PIXEL (f); + } + return p->pixel; +} + + +/* Value is a vector of all pixel colors contained in the color table, + allocated via xmalloc. Set *N to the number of colors. */ + +static unsigned long * +colors_in_color_table (n) + int *n; +{ + int i, j; + struct ct_color *p; + unsigned long *colors; + + if (ct_colors_allocated == 0) + { + *n = 0; + colors = NULL; + } + else + { + colors = (unsigned long *) xmalloc (ct_colors_allocated + * sizeof *colors); + *n = ct_colors_allocated; + + for (i = j = 0; i < CT_SIZE; ++i) + for (p = ct_table[i]; p; p = p->next) + colors[j++] = p->pixel; + } + + return colors; +} + +#endif /* TODO */ + + +/*********************************************************************** + Algorithms + ***********************************************************************/ + +#if 0 /* TODO : W32 versions of low level algorithms */ +static void x_laplace_write_row P_ ((struct frame *, long *, + int, XImage *, int)); +static void x_laplace_read_row P_ ((struct frame *, Colormap, + XColor *, int, XImage *, int)); + + +/* Fill COLORS with RGB colors from row Y of image XIMG. F is the + frame we operate on, CMAP is the color-map in effect, and WIDTH is + the width of one row in the image. */ + +static void +x_laplace_read_row (f, cmap, colors, width, ximg, y) + struct frame *f; + Colormap cmap; + XColor *colors; + int width; + XImage *ximg; + int y; +{ + int x; + + for (x = 0; x < width; ++x) + colors[x].pixel = XGetPixel (ximg, x, y); + + XQueryColors (NULL, cmap, colors, width); +} + + +/* Write row Y of image XIMG. PIXELS is an array of WIDTH longs + containing the pixel colors to write. F is the frame we are + working on. */ + +static void +x_laplace_write_row (f, pixels, width, ximg, y) + struct frame *f; + long *pixels; + int width; + XImage *ximg; + int y; +{ + int x; + + for (x = 0; x < width; ++x) + XPutPixel (ximg, x, y, pixels[x]); +} +#endif + +/* Transform image IMG which is used on frame F with a Laplace + edge-detection algorithm. The result is an image that can be used + to draw disabled buttons, for example. */ + +static void +x_laplace (f, img) + struct frame *f; + struct image *img; +{ +#if 0 /* TODO : W32 version */ + Colormap cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f)); + XImage *ximg, *oimg; + XColor *in[3]; + long *out; + Pixmap pixmap; + int x, y, i; + long pixel; + int in_y, out_y, rc; + int mv2 = 45000; + + BLOCK_INPUT; + + /* Get the X image IMG->pixmap. */ + ximg = XGetImage (NULL, img->pixmap, + 0, 0, img->width, img->height, ~0, ZPixmap); + + /* Allocate 3 input rows, and one output row of colors. */ + for (i = 0; i < 3; ++i) + in[i] = (XColor *) alloca (img->width * sizeof (XColor)); + out = (long *) alloca (img->width * sizeof (long)); + + /* Create an X image for output. */ + rc = x_create_x_image_and_pixmap (f, img->width, img->height, 0, + &oimg, &pixmap); + + /* Fill first two rows. */ + x_laplace_read_row (f, cmap, in[0], img->width, ximg, 0); + x_laplace_read_row (f, cmap, in[1], img->width, ximg, 1); + in_y = 2; + + /* Write first row, all zeros. */ + init_color_table (); + pixel = lookup_rgb_color (f, 0, 0, 0); + for (x = 0; x < img->width; ++x) + out[x] = pixel; + x_laplace_write_row (f, out, img->width, oimg, 0); + out_y = 1; + + for (y = 2; y < img->height; ++y) + { + int rowa = y % 3; + int rowb = (y + 2) % 3; + + x_laplace_read_row (f, cmap, in[rowa], img->width, ximg, in_y++); + + for (x = 0; x < img->width - 2; ++x) + { + int r = in[rowa][x].red + mv2 - in[rowb][x + 2].red; + int g = in[rowa][x].green + mv2 - in[rowb][x + 2].green; + int b = in[rowa][x].blue + mv2 - in[rowb][x + 2].blue; + + out[x + 1] = lookup_rgb_color (f, r & 0xffff, g & 0xffff, + b & 0xffff); + } + + x_laplace_write_row (f, out, img->width, oimg, out_y++); + } + + /* Write last line, all zeros. */ + for (x = 0; x < img->width; ++x) + out[x] = pixel; + x_laplace_write_row (f, out, img->width, oimg, out_y); + + /* Free the input image, and free resources of IMG. */ + XDestroyImage (ximg); + x_clear_image (f, img); + + /* Put the output image into pixmap, and destroy it. */ + x_put_x_image (f, oimg, pixmap, img->width, img->height); + x_destroy_x_image (oimg); + + /* Remember new pixmap and colors in IMG. */ + img->pixmap = pixmap; + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); + + UNBLOCK_INPUT; +#endif /* TODO */ +} + + +/* Build a mask for image IMG which is used on frame F. FILE is the + name of an image file, for error messages. HOW determines how to + determine the background color of IMG. If it is a list '(R G B)', + with R, G, and B being integers >= 0, take that as the color of the + background. Otherwise, determine the background color of IMG + heuristically. Value is non-zero if successful. */ + +static int +x_build_heuristic_mask (f, img, how) + struct frame *f; + struct image *img; + Lisp_Object how; +{ +#if 0 /* TODO : W32 version */ + Display *dpy = FRAME_W32_DISPLAY (f); + XImage *ximg, *mask_img; + int x, y, rc, look_at_corners_p; + unsigned long bg; + + BLOCK_INPUT; + + /* Create an image and pixmap serving as mask. */ + rc = x_create_x_image_and_pixmap (f, img->width, img->height, 1, + &mask_img, &img->mask); + if (!rc) + { + UNBLOCK_INPUT; + return 0; + } + + /* Get the X image of IMG->pixmap. */ + ximg = XGetImage (dpy, img->pixmap, 0, 0, img->width, img->height, + ~0, ZPixmap); + + /* Determine the background color of ximg. If HOW is `(R G B)' + take that as color. Otherwise, try to determine the color + heuristically. */ + look_at_corners_p = 1; + + if (CONSP (how)) + { + int rgb[3], i = 0; + + while (i < 3 + && CONSP (how) + && NATNUMP (XCAR (how))) + { + rgb[i] = XFASTINT (XCAR (how)) & 0xffff; + how = XCDR (how); + } + + if (i == 3 && NILP (how)) + { + char color_name[30]; + XColor exact, color; + Colormap cmap; + + sprintf (color_name, "#%04x%04x%04x", rgb[0], rgb[1], rgb[2]); + + cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f)); + if (XLookupColor (dpy, cmap, color_name, &exact, &color)) + { + bg = color.pixel; + look_at_corners_p = 0; + } + } + } + + if (look_at_corners_p) + { + unsigned long corners[4]; + int i, best_count; + + /* Get the colors at the corners of ximg. */ + corners[0] = XGetPixel (ximg, 0, 0); + corners[1] = XGetPixel (ximg, img->width - 1, 0); + corners[2] = XGetPixel (ximg, img->width - 1, img->height - 1); + corners[3] = XGetPixel (ximg, 0, img->height - 1); + + /* Choose the most frequently found color as background. */ + for (i = best_count = 0; i < 4; ++i) + { + int j, n; + + for (j = n = 0; j < 4; ++j) + if (corners[i] == corners[j]) + ++n; + + if (n > best_count) + bg = corners[i], best_count = n; + } + } + + /* Set all bits in mask_img to 1 whose color in ximg is different + from the background color bg. */ + for (y = 0; y < img->height; ++y) + for (x = 0; x < img->width; ++x) + XPutPixel (mask_img, x, y, XGetPixel (ximg, x, y) != bg); + + /* Put mask_img into img->mask. */ + x_put_x_image (f, mask_img, img->mask, img->width, img->height); + x_destroy_x_image (mask_img); + XDestroyImage (ximg); + + UNBLOCK_INPUT; +#endif /* TODO */ + + return 1; +} + + + +/*********************************************************************** + PBM (mono, gray, color) + ***********************************************************************/ +#ifdef HAVE_PBM + +static int pbm_image_p P_ ((Lisp_Object object)); +static int pbm_load P_ ((struct frame *f, struct image *img)); +static int pbm_scan_number P_ ((unsigned char **, unsigned char *)); + +/* The symbol `pbm' identifying images of this type. */ + +Lisp_Object Qpbm; + +/* Indices of image specification fields in gs_format, below. */ + +enum pbm_keyword_index +{ + PBM_TYPE, + PBM_FILE, + PBM_DATA, + PBM_ASCENT, + PBM_MARGIN, + PBM_RELIEF, + PBM_ALGORITHM, + PBM_HEURISTIC_MASK, + PBM_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static struct image_keyword pbm_format[PBM_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":file", IMAGE_STRING_VALUE, 0}, + {":data", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0} +}; + +/* Structure describing the image type `pbm'. */ + +static struct image_type pbm_type = +{ + &Qpbm, + pbm_image_p, + pbm_load, + x_clear_image, + NULL +}; + + +/* Return non-zero if OBJECT is a valid PBM image specification. */ + +static int +pbm_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[PBM_LAST]; + + bcopy (pbm_format, fmt, sizeof fmt); + + if (!parse_image_spec (object, fmt, PBM_LAST, Qpbm) + || (fmt[PBM_ASCENT].count + && XFASTINT (fmt[PBM_ASCENT].value) > 100)) + return 0; + + /* Must specify either :data or :file. */ + return fmt[PBM_DATA].count + fmt[PBM_FILE].count == 1; +} + + +/* Scan a decimal number from *S and return it. Advance *S while + reading the number. END is the end of the string. Value is -1 at + end of input. */ + +static int +pbm_scan_number (s, end) + unsigned char **s, *end; +{ + int c, val = -1; + + while (*s < end) + { + /* Skip white-space. */ + while (*s < end && (c = *(*s)++, isspace (c))) + ; + + if (c == '#') + { + /* Skip comment to end of line. */ + while (*s < end && (c = *(*s)++, c != '\n')) + ; + } + else if (isdigit (c)) + { + /* Read decimal number. */ + val = c - '0'; + while (*s < end && (c = *(*s)++, isdigit (c))) + val = 10 * val + c - '0'; + break; + } + else + break; + } + + return val; +} + + +/* Read FILE into memory. Value is a pointer to a buffer allocated + with xmalloc holding FILE's contents. Value is null if an error + occured. *SIZE is set to the size of the file. */ + +static char * +pbm_read_file (file, size) + Lisp_Object file; + int *size; +{ + FILE *fp = NULL; + char *buf = NULL; + struct stat st; + + if (stat (XSTRING (file)->data, &st) == 0 + && (fp = fopen (XSTRING (file)->data, "r")) != NULL + && (buf = (char *) xmalloc (st.st_size), + fread (buf, 1, st.st_size, fp) == st.st_size)) + { + *size = st.st_size; + fclose (fp); + } + else + { + if (fp) + fclose (fp); + if (buf) + { + xfree (buf); + buf = NULL; + } + } + + return buf; +} + + +/* Load PBM image IMG for use on frame F. */ + +static int +pbm_load (f, img) + struct frame *f; + struct image *img; +{ + int raw_p, x, y; + int width, height, max_color_idx = 0; + XImage *ximg; + Lisp_Object file, specified_file; + enum {PBM_MONO, PBM_GRAY, PBM_COLOR} type; + struct gcpro gcpro1; + unsigned char *contents = NULL; + unsigned char *end, *p; + int size; + + specified_file = image_spec_value (img->spec, QCfile, NULL); + file = Qnil; + GCPRO1 (file); + + if (STRINGP (specified_file)) + { + file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + UNGCPRO; + return 0; + } + + contents = pbm_read_file (file, &size); + if (contents == NULL) + { + image_error ("Error reading `%s'", file, Qnil); + UNGCPRO; + return 0; + } + + p = contents; + end = contents + size; + } + else + { + Lisp_Object data; + data = image_spec_value (img->spec, QCdata, NULL); + p = XSTRING (data)->data; + end = p + STRING_BYTES (XSTRING (data)); + } + + /* Check magic number. */ + if (end - p < 2 || *p++ != 'P') + { + image_error ("Not a PBM image: `%s'", img->spec, Qnil); + error: + xfree (contents); + UNGCPRO; + return 0; + } + + switch (*p++) + { + case '1': + raw_p = 0, type = PBM_MONO; + break; + + case '2': + raw_p = 0, type = PBM_GRAY; + break; + + case '3': + raw_p = 0, type = PBM_COLOR; + break; + + case '4': + raw_p = 1, type = PBM_MONO; + break; + + case '5': + raw_p = 1, type = PBM_GRAY; + break; + + case '6': + raw_p = 1, type = PBM_COLOR; + break; + + default: + image_error ("Not a PBM image: `%s'", img->spec, Qnil); + goto error; + } + + /* Read width, height, maximum color-component. Characters + starting with `#' up to the end of a line are ignored. */ + width = pbm_scan_number (&p, end); + height = pbm_scan_number (&p, end); + + if (type != PBM_MONO) + { + max_color_idx = pbm_scan_number (&p, end); + if (raw_p && max_color_idx > 255) + max_color_idx = 255; + } + + if (width < 0 + || height < 0 + || (type != PBM_MONO && max_color_idx < 0)) + goto error; + + BLOCK_INPUT; + if (!x_create_x_image_and_pixmap (f, width, height, 0, + &ximg, &img->pixmap)) + { + UNBLOCK_INPUT; + goto error; + } + + /* Initialize the color hash table. */ + init_color_table (); + + if (type == PBM_MONO) + { + int c = 0, g; + + for (y = 0; y < height; ++y) + for (x = 0; x < width; ++x) + { + if (raw_p) + { + if ((x & 7) == 0) + c = *p++; + g = c & 0x80; + c <<= 1; + } + else + g = pbm_scan_number (&p, end); + + XPutPixel (ximg, x, y, (g + ? FRAME_FOREGROUND_PIXEL (f) + : FRAME_BACKGROUND_PIXEL (f))); + } + } + else + { + for (y = 0; y < height; ++y) + for (x = 0; x < width; ++x) + { + int r, g, b; + + if (type == PBM_GRAY) + r = g = b = raw_p ? *p++ : pbm_scan_number (&p, end); + else if (raw_p) + { + r = *p++; + g = *p++; + b = *p++; + } + else + { + r = pbm_scan_number (&p, end); + g = pbm_scan_number (&p, end); + b = pbm_scan_number (&p, end); + } + + if (r < 0 || g < 0 || b < 0) + { + xfree (ximg->data); + ximg->data = NULL; + XDestroyImage (ximg); + UNBLOCK_INPUT; + image_error ("Invalid pixel value in image `%s'", + img->spec, Qnil); + goto error; + } + + /* RGB values are now in the range 0..max_color_idx. + Scale this to the range 0..0xffff supported by X. */ + r = (double) r * 65535 / max_color_idx; + g = (double) g * 65535 / max_color_idx; + b = (double) b * 65535 / max_color_idx; + XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b)); + } + } + + /* Store in IMG->colors the colors allocated for the image, and + free the color table. */ + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); + + /* Put the image into a pixmap. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + UNBLOCK_INPUT; + + img->width = width; + img->height = height; + + UNGCPRO; + xfree (contents); + return 1; +} +#endif /* HAVE_PBM */ + + +/*********************************************************************** + PNG + ***********************************************************************/ + +#if HAVE_PNG + +#include + +/* Function prototypes. */ + +static int png_image_p P_ ((Lisp_Object object)); +static int png_load P_ ((struct frame *f, struct image *img)); + +/* The symbol `png' identifying images of this type. */ + +Lisp_Object Qpng; + +/* Indices of image specification fields in png_format, below. */ + +enum png_keyword_index +{ + PNG_TYPE, + PNG_DATA, + PNG_FILE, + PNG_ASCENT, + PNG_MARGIN, + PNG_RELIEF, + PNG_ALGORITHM, + PNG_HEURISTIC_MASK, + PNG_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static struct image_keyword png_format[PNG_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":data", IMAGE_STRING_VALUE, 0}, + {":file", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0} +}; + +/* Structure describing the image type `png'. */ + +static struct image_type png_type = +{ + &Qpng, + png_image_p, + png_load, + x_clear_image, + NULL +}; + + +/* Return non-zero if OBJECT is a valid PNG image specification. */ + +static int +png_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[PNG_LAST]; + bcopy (png_format, fmt, sizeof fmt); + + if (!parse_image_spec (object, fmt, PNG_LAST, Qpng) + || (fmt[PNG_ASCENT].count + && XFASTINT (fmt[PNG_ASCENT].value) > 100)) + return 0; + + /* Must specify either the :data or :file keyword. */ + return fmt[PNG_FILE].count + fmt[PNG_DATA].count == 1; +} + + +/* Error and warning handlers installed when the PNG library + is initialized. */ + +static void +my_png_error (png_ptr, msg) + png_struct *png_ptr; + char *msg; +{ + xassert (png_ptr != NULL); + image_error ("PNG error: %s", build_string (msg), Qnil); + longjmp (png_ptr->jmpbuf, 1); +} + + +static void +my_png_warning (png_ptr, msg) + png_struct *png_ptr; + char *msg; +{ + xassert (png_ptr != NULL); + image_error ("PNG warning: %s", build_string (msg), Qnil); +} + +/* Memory source for PNG decoding. */ + +struct png_memory_storage +{ + unsigned char *bytes; /* The data */ + size_t len; /* How big is it? */ + int index; /* Where are we? */ +}; + + +/* Function set as reader function when reading PNG image from memory. + PNG_PTR is a pointer to the PNG control structure. Copy LENGTH + bytes from the input to DATA. */ + +static void +png_read_from_memory (png_ptr, data, length) + png_structp png_ptr; + png_bytep data; + png_size_t length; +{ + struct png_memory_storage *tbr + = (struct png_memory_storage *) png_get_io_ptr (png_ptr); + + if (length > tbr->len - tbr->index) + png_error (png_ptr, "Read error"); + + bcopy (tbr->bytes + tbr->index, data, length); + tbr->index = tbr->index + length; +} + +/* Load PNG image IMG for use on frame F. Value is non-zero if + successful. */ + +static int +png_load (f, img) + struct frame *f; + struct image *img; +{ + Lisp_Object file, specified_file; + Lisp_Object specified_data; + int x, y, i; + XImage *ximg, *mask_img = NULL; + struct gcpro gcpro1; + png_struct *png_ptr = NULL; + png_info *info_ptr = NULL, *end_info = NULL; + FILE *fp = NULL; + png_byte sig[8]; + png_byte *pixels = NULL; + png_byte **rows = NULL; + png_uint_32 width, height; + int bit_depth, color_type, interlace_type; + png_byte channels; + png_uint_32 row_bytes; + int transparent_p; + char *gamma_str; + double screen_gamma, image_gamma; + int intent; + struct png_memory_storage tbr; /* Data to be read */ + + /* Find out what file to load. */ + specified_file = image_spec_value (img->spec, QCfile, NULL); + specified_data = image_spec_value (img->spec, QCdata, NULL); + file = Qnil; + GCPRO1 (file); + + if (NILP (specified_data)) + { + file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + UNGCPRO; + return 0; + } + + /* Open the image file. */ + fp = fopen (XSTRING (file)->data, "rb"); + if (!fp) + { + image_error ("Cannot open image file `%s'", file, Qnil); + UNGCPRO; + fclose (fp); + return 0; + } + + /* Check PNG signature. */ + if (fread (sig, 1, sizeof sig, fp) != sizeof sig + || !png_check_sig (sig, sizeof sig)) + { + image_error ("Not a PNG file:` %s'", file, Qnil); + UNGCPRO; + fclose (fp); + return 0; + } + } + else + { + /* Read from memory. */ + tbr.bytes = XSTRING (specified_data)->data; + tbr.len = STRING_BYTES (XSTRING (specified_data)); + tbr.index = 0; + + /* Check PNG signature. */ + if (tbr.len < sizeof sig + || !png_check_sig (tbr.bytes, sizeof sig)) + { + image_error ("Not a PNG image: `%s'", img->spec, Qnil); + UNGCPRO; + return 0; + } + + /* Need to skip past the signature. */ + tbr.bytes += sizeof (sig); + } + + /* Initialize read and info structs for PNG lib. */ + png_ptr = png_create_read_struct (PNG_LIBPNG_VER_STRING, NULL, + my_png_error, my_png_warning); + if (!png_ptr) + { + if (fp) fclose (fp); + UNGCPRO; + return 0; + } + + info_ptr = png_create_info_struct (png_ptr); + if (!info_ptr) + { + png_destroy_read_struct (&png_ptr, NULL, NULL); + if (fp) fclose (fp); + UNGCPRO; + return 0; + } + + end_info = png_create_info_struct (png_ptr); + if (!end_info) + { + png_destroy_read_struct (&png_ptr, &info_ptr, NULL); + if (fp) fclose (fp); + UNGCPRO; + return 0; + } + + /* Set error jump-back. We come back here when the PNG library + detects an error. */ + if (setjmp (png_ptr->jmpbuf)) + { + error: + if (png_ptr) + png_destroy_read_struct (&png_ptr, &info_ptr, &end_info); + xfree (pixels); + xfree (rows); + if (fp) fclose (fp); + UNGCPRO; + return 0; + } + + /* Read image info. */ + if (!NILP (specified_data)) + png_set_read_fn (png_ptr, (void *) &tbr, png_read_from_memory); + else + png_init_io (png_ptr, fp); + + png_set_sig_bytes (png_ptr, sizeof sig); + png_read_info (png_ptr, info_ptr); + png_get_IHDR (png_ptr, info_ptr, &width, &height, &bit_depth, &color_type, + &interlace_type, NULL, NULL); + + /* If image contains simply transparency data, we prefer to + construct a clipping mask. */ + if (png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS)) + transparent_p = 1; + else + transparent_p = 0; + + /* This function is easier to write if we only have to handle + one data format: RGB or RGBA with 8 bits per channel. Let's + transform other formats into that format. */ + + /* Strip more than 8 bits per channel. */ + if (bit_depth == 16) + png_set_strip_16 (png_ptr); + + /* Expand data to 24 bit RGB, or 8 bit grayscale, with alpha channel + if available. */ + png_set_expand (png_ptr); + + /* Convert grayscale images to RGB. */ + if (color_type == PNG_COLOR_TYPE_GRAY + || color_type == PNG_COLOR_TYPE_GRAY_ALPHA) + png_set_gray_to_rgb (png_ptr); + + /* The value 2.2 is a guess for PC monitors from PNG example.c. */ + gamma_str = getenv ("SCREEN_GAMMA"); + screen_gamma = gamma_str ? atof (gamma_str) : 2.2; + + /* Tell the PNG lib to handle gamma correction for us. */ + +#if defined(PNG_READ_sRGB_SUPPORTED) || defined(PNG_WRITE_sRGB_SUPPORTED) + if (png_get_sRGB (png_ptr, info_ptr, &intent)) + /* There is a special chunk in the image specifying the gamma. */ + png_set_sRGB (png_ptr, info_ptr, intent); + else +#endif + if (png_get_gAMA (png_ptr, info_ptr, &image_gamma)) + /* Image contains gamma information. */ + png_set_gamma (png_ptr, screen_gamma, image_gamma); + else + /* Use a default of 0.5 for the image gamma. */ + png_set_gamma (png_ptr, screen_gamma, 0.5); + + /* Handle alpha channel by combining the image with a background + color. Do this only if a real alpha channel is supplied. For + simple transparency, we prefer a clipping mask. */ + if (!transparent_p) + { + png_color_16 *image_background; + + if (png_get_bKGD (png_ptr, info_ptr, &image_background)) + /* Image contains a background color with which to + combine the image. */ + png_set_background (png_ptr, image_background, + PNG_BACKGROUND_GAMMA_FILE, 1, 1.0); + else + { + /* Image does not contain a background color with which + to combine the image data via an alpha channel. Use + the frame's background instead. */ + XColor color; + Colormap cmap; + png_color_16 frame_background; + + BLOCK_INPUT; + cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f)); + color.pixel = FRAME_BACKGROUND_PIXEL (f); + XQueryColor (FRAME_W32_DISPLAY (f), cmap, &color); + UNBLOCK_INPUT; + + bzero (&frame_background, sizeof frame_background); + frame_background.red = color.red; + frame_background.green = color.green; + frame_background.blue = color.blue; + + png_set_background (png_ptr, &frame_background, + PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0); + } + } + + /* Update info structure. */ + png_read_update_info (png_ptr, info_ptr); + + /* Get number of channels. Valid values are 1 for grayscale images + and images with a palette, 2 for grayscale images with transparency + information (alpha channel), 3 for RGB images, and 4 for RGB + images with alpha channel, i.e. RGBA. If conversions above were + sufficient we should only have 3 or 4 channels here. */ + channels = png_get_channels (png_ptr, info_ptr); + xassert (channels == 3 || channels == 4); + + /* Number of bytes needed for one row of the image. */ + row_bytes = png_get_rowbytes (png_ptr, info_ptr); + + /* Allocate memory for the image. */ + pixels = (png_byte *) xmalloc (row_bytes * height * sizeof *pixels); + rows = (png_byte **) xmalloc (height * sizeof *rows); + for (i = 0; i < height; ++i) + rows[i] = pixels + i * row_bytes; + + /* Read the entire image. */ + png_read_image (png_ptr, rows); + png_read_end (png_ptr, info_ptr); + if (fp) + { + fclose (fp); + fp = NULL; + } + + BLOCK_INPUT; + + /* Create the X image and pixmap. */ + if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, + &img->pixmap)) + { + UNBLOCK_INPUT; + goto error; + } + + /* Create an image and pixmap serving as mask if the PNG image + contains an alpha channel. */ + if (channels == 4 + && !transparent_p + && !x_create_x_image_and_pixmap (f, width, height, 1, + &mask_img, &img->mask)) + { + x_destroy_x_image (ximg); + XFreePixmap (FRAME_W32_DISPLAY (f), img->pixmap); + img->pixmap = 0; + UNBLOCK_INPUT; + goto error; + } + + /* Fill the X image and mask from PNG data. */ + init_color_table (); + + for (y = 0; y < height; ++y) + { + png_byte *p = rows[y]; + + for (x = 0; x < width; ++x) + { + unsigned r, g, b; + + r = *p++ << 8; + g = *p++ << 8; + b = *p++ << 8; + XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b)); + + /* An alpha channel, aka mask channel, associates variable + transparency with an image. Where other image formats + support binary transparency---fully transparent or fully + opaque---PNG allows up to 254 levels of partial transparency. + The PNG library implements partial transparency by combining + the image with a specified background color. + + I'm not sure how to handle this here nicely: because the + background on which the image is displayed may change, for + real alpha channel support, it would be necessary to create + a new image for each possible background. + + What I'm doing now is that a mask is created if we have + boolean transparency information. Otherwise I'm using + the frame's background color to combine the image with. */ + + if (channels == 4) + { + if (mask_img) + XPutPixel (mask_img, x, y, *p > 0); + ++p; + } + } + } + + /* Remember colors allocated for this image. */ + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); + + /* Clean up. */ + png_destroy_read_struct (&png_ptr, &info_ptr, &end_info); + xfree (rows); + xfree (pixels); + + img->width = width; + img->height = height; + + /* Put the image into the pixmap, then free the X image and its buffer. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + + /* Same for the mask. */ + if (mask_img) + { + x_put_x_image (f, mask_img, img->mask, img->width, img->height); + x_destroy_x_image (mask_img); + } + + UNBLOCK_INPUT; + UNGCPRO; + return 1; +} + +#endif /* HAVE_PNG != 0 */ + + + +/*********************************************************************** + JPEG + ***********************************************************************/ + +#if HAVE_JPEG + +/* Work around a warning about HAVE_STDLIB_H being redefined in + jconfig.h. */ +#ifdef HAVE_STDLIB_H +#define HAVE_STDLIB_H_1 +#undef HAVE_STDLIB_H +#endif /* HAVE_STLIB_H */ + +#include +#include +#include + +#ifdef HAVE_STLIB_H_1 +#define HAVE_STDLIB_H 1 +#endif + +static int jpeg_image_p P_ ((Lisp_Object object)); +static int jpeg_load P_ ((struct frame *f, struct image *img)); + +/* The symbol `jpeg' identifying images of this type. */ + +Lisp_Object Qjpeg; + +/* Indices of image specification fields in gs_format, below. */ + +enum jpeg_keyword_index +{ + JPEG_TYPE, + JPEG_DATA, + JPEG_FILE, + JPEG_ASCENT, + JPEG_MARGIN, + JPEG_RELIEF, + JPEG_ALGORITHM, + JPEG_HEURISTIC_MASK, + JPEG_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static struct image_keyword jpeg_format[JPEG_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":data", IMAGE_STRING_VALUE, 0}, + {":file", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0} +}; + +/* Structure describing the image type `jpeg'. */ + +static struct image_type jpeg_type = +{ + &Qjpeg, + jpeg_image_p, + jpeg_load, + x_clear_image, + NULL +}; + + +/* Return non-zero if OBJECT is a valid JPEG image specification. */ + +static int +jpeg_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[JPEG_LAST]; + + bcopy (jpeg_format, fmt, sizeof fmt); + + if (!parse_image_spec (object, fmt, JPEG_LAST, Qjpeg) + || (fmt[JPEG_ASCENT].count + && XFASTINT (fmt[JPEG_ASCENT].value) > 100)) + return 0; + + /* Must specify either the :data or :file keyword. */ + return fmt[JPEG_FILE].count + fmt[JPEG_DATA].count == 1; +} + + +struct my_jpeg_error_mgr +{ + struct jpeg_error_mgr pub; + jmp_buf setjmp_buffer; +}; + +static void +my_error_exit (cinfo) + j_common_ptr cinfo; +{ + struct my_jpeg_error_mgr *mgr = (struct my_jpeg_error_mgr *) cinfo->err; + longjmp (mgr->setjmp_buffer, 1); +} + +/* Init source method for JPEG data source manager. Called by + jpeg_read_header() before any data is actually read. See + libjpeg.doc from the JPEG lib distribution. */ + +static void +our_init_source (cinfo) + j_decompress_ptr cinfo; +{ +} + + +/* Fill input buffer method for JPEG data source manager. Called + whenever more data is needed. We read the whole image in one step, + so this only adds a fake end of input marker at the end. */ + +static boolean +our_fill_input_buffer (cinfo) + j_decompress_ptr cinfo; +{ + /* Insert a fake EOI marker. */ + struct jpeg_source_mgr *src = cinfo->src; + static JOCTET buffer[2]; + + buffer[0] = (JOCTET) 0xFF; + buffer[1] = (JOCTET) JPEG_EOI; + + src->next_input_byte = buffer; + src->bytes_in_buffer = 2; + return TRUE; +} + + +/* Method to skip over NUM_BYTES bytes in the image data. CINFO->src + is the JPEG data source manager. */ + +static void +our_skip_input_data (cinfo, num_bytes) + j_decompress_ptr cinfo; + long num_bytes; +{ + struct jpeg_source_mgr *src = (struct jpeg_source_mgr *) cinfo->src; + + if (src) + { + if (num_bytes > src->bytes_in_buffer) + ERREXIT (cinfo, JERR_INPUT_EOF); + + src->bytes_in_buffer -= num_bytes; + src->next_input_byte += num_bytes; + } +} + + +/* Method to terminate data source. Called by + jpeg_finish_decompress() after all data has been processed. */ + +static void +our_term_source (cinfo) + j_decompress_ptr cinfo; +{ +} + + +/* Set up the JPEG lib for reading an image from DATA which contains + LEN bytes. CINFO is the decompression info structure created for + reading the image. */ + +static void +jpeg_memory_src (cinfo, data, len) + j_decompress_ptr cinfo; + JOCTET *data; + unsigned int len; +{ + struct jpeg_source_mgr *src; + + if (cinfo->src == NULL) + { + /* First time for this JPEG object? */ + cinfo->src = (struct jpeg_source_mgr *) + (*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT, + sizeof (struct jpeg_source_mgr)); + src = (struct jpeg_source_mgr *) cinfo->src; + src->next_input_byte = data; + } + + src = (struct jpeg_source_mgr *) cinfo->src; + src->init_source = our_init_source; + src->fill_input_buffer = our_fill_input_buffer; + src->skip_input_data = our_skip_input_data; + src->resync_to_restart = jpeg_resync_to_restart; /* Use default method. */ + src->term_source = our_term_source; + src->bytes_in_buffer = len; + src->next_input_byte = data; +} + + +/* Load image IMG for use on frame F. Patterned after example.c + from the JPEG lib. */ + +static int +jpeg_load (f, img) + struct frame *f; + struct image *img; +{ + struct jpeg_decompress_struct cinfo; + struct my_jpeg_error_mgr mgr; + Lisp_Object file, specified_file; + Lisp_Object specified_data; + FILE *fp = NULL; + JSAMPARRAY buffer; + int row_stride, x, y; + XImage *ximg = NULL; + int rc; + unsigned long *colors; + int width, height; + struct gcpro gcpro1; + + /* Open the JPEG file. */ + specified_file = image_spec_value (img->spec, QCfile, NULL); + specified_data = image_spec_value (img->spec, QCdata, NULL); + file = Qnil; + GCPRO1 (file); + + if (NILP (specified_data)) + { + file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + UNGCPRO; + return 0; + } + + fp = fopen (XSTRING (file)->data, "r"); + if (fp == NULL) + { + image_error ("Cannot open `%s'", file, Qnil); + UNGCPRO; + return 0; + } + } + + /* Customize libjpeg's error handling to call my_error_exit when an + error is detected. This function will perform a longjmp. */ + mgr.pub.error_exit = my_error_exit; + cinfo.err = jpeg_std_error (&mgr.pub); + + if ((rc = setjmp (mgr.setjmp_buffer)) != 0) + { + if (rc == 1) + { + /* Called from my_error_exit. Display a JPEG error. */ + char buffer[JMSG_LENGTH_MAX]; + cinfo.err->format_message ((j_common_ptr) &cinfo, buffer); + image_error ("Error reading JPEG image `%s': %s", img->spec, + build_string (buffer)); + } + + /* Close the input file and destroy the JPEG object. */ + if (fp) + fclose (fp); + jpeg_destroy_decompress (&cinfo); + + BLOCK_INPUT; + + /* If we already have an XImage, free that. */ + x_destroy_x_image (ximg); + + /* Free pixmap and colors. */ + x_clear_image (f, img); + + UNBLOCK_INPUT; + UNGCPRO; + return 0; + } + + /* Create the JPEG decompression object. Let it read from fp. + Read the JPEG image header. */ + jpeg_create_decompress (&cinfo); + + if (NILP (specified_data)) + jpeg_stdio_src (&cinfo, fp); + else + jpeg_memory_src (&cinfo, XSTRING (specified_data)->data, + STRING_BYTES (XSTRING (specified_data))); + + jpeg_read_header (&cinfo, TRUE); + + /* Customize decompression so that color quantization will be used. + Start decompression. */ + cinfo.quantize_colors = TRUE; + jpeg_start_decompress (&cinfo); + width = img->width = cinfo.output_width; + height = img->height = cinfo.output_height; + + BLOCK_INPUT; + + /* Create X image and pixmap. */ + if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, + &img->pixmap)) + { + UNBLOCK_INPUT; + longjmp (mgr.setjmp_buffer, 2); + } + + /* Allocate colors. When color quantization is used, + cinfo.actual_number_of_colors has been set with the number of + colors generated, and cinfo.colormap is a two-dimensional array + of color indices in the range 0..cinfo.actual_number_of_colors. + No more than 255 colors will be generated. */ + { + int i, ir, ig, ib; + + if (cinfo.out_color_components > 2) + ir = 0, ig = 1, ib = 2; + else if (cinfo.out_color_components > 1) + ir = 0, ig = 1, ib = 0; + else + ir = 0, ig = 0, ib = 0; + + /* Use the color table mechanism because it handles colors that + cannot be allocated nicely. Such colors will be replaced with + a default color, and we don't have to care about which colors + can be freed safely, and which can't. */ + init_color_table (); + colors = (unsigned long *) alloca (cinfo.actual_number_of_colors + * sizeof *colors); + + for (i = 0; i < cinfo.actual_number_of_colors; ++i) + { + /* Multiply RGB values with 255 because X expects RGB values + in the range 0..0xffff. */ + int r = cinfo.colormap[ir][i] << 8; + int g = cinfo.colormap[ig][i] << 8; + int b = cinfo.colormap[ib][i] << 8; + colors[i] = lookup_rgb_color (f, r, g, b); + } + + /* Remember those colors actually allocated. */ + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); + } + + /* Read pixels. */ + row_stride = width * cinfo.output_components; + buffer = cinfo.mem->alloc_sarray ((j_common_ptr) &cinfo, JPOOL_IMAGE, + row_stride, 1); + for (y = 0; y < height; ++y) + { + jpeg_read_scanlines (&cinfo, buffer, 1); + for (x = 0; x < cinfo.output_width; ++x) + XPutPixel (ximg, x, y, colors[buffer[0][x]]); + } + + /* Clean up. */ + jpeg_finish_decompress (&cinfo); + jpeg_destroy_decompress (&cinfo); + if (fp) + fclose (fp); + + /* Put the image into the pixmap. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + UNBLOCK_INPUT; + UNGCPRO; + return 1; +} + +#endif /* HAVE_JPEG */ + + + +/*********************************************************************** + TIFF + ***********************************************************************/ + +#if HAVE_TIFF + +#include + +static int tiff_image_p P_ ((Lisp_Object object)); +static int tiff_load P_ ((struct frame *f, struct image *img)); + +/* The symbol `tiff' identifying images of this type. */ + +Lisp_Object Qtiff; + +/* Indices of image specification fields in tiff_format, below. */ + +enum tiff_keyword_index +{ + TIFF_TYPE, + TIFF_DATA, + TIFF_FILE, + TIFF_ASCENT, + TIFF_MARGIN, + TIFF_RELIEF, + TIFF_ALGORITHM, + TIFF_HEURISTIC_MASK, + TIFF_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static struct image_keyword tiff_format[TIFF_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":data", IMAGE_STRING_VALUE, 0}, + {":file", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0} +}; + +/* Structure describing the image type `tiff'. */ + +static struct image_type tiff_type = +{ + &Qtiff, + tiff_image_p, + tiff_load, + x_clear_image, + NULL +}; + + +/* Return non-zero if OBJECT is a valid TIFF image specification. */ + +static int +tiff_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[TIFF_LAST]; + bcopy (tiff_format, fmt, sizeof fmt); + + if (!parse_image_spec (object, fmt, TIFF_LAST, Qtiff) + || (fmt[TIFF_ASCENT].count + && XFASTINT (fmt[TIFF_ASCENT].value) > 100)) + return 0; + + /* Must specify either the :data or :file keyword. */ + return fmt[TIFF_FILE].count + fmt[TIFF_DATA].count == 1; +} + + +/* Reading from a memory buffer for TIFF images Based on the PNG + memory source, but we have to provide a lot of extra functions. + Blah. + + We really only need to implement read and seek, but I am not + convinced that the TIFF library is smart enough not to destroy + itself if we only hand it the function pointers we need to + override. */ + +typedef struct +{ + unsigned char *bytes; + size_t len; + int index; +} +tiff_memory_source; + +static size_t +tiff_read_from_memory (data, buf, size) + thandle_t data; + tdata_t buf; + tsize_t size; +{ + tiff_memory_source *src = (tiff_memory_source *) data; + + if (size > src->len - src->index) + return (size_t) -1; + bcopy (src->bytes + src->index, buf, size); + src->index += size; + return size; +} + +static size_t +tiff_write_from_memory (data, buf, size) + thandle_t data; + tdata_t buf; + tsize_t size; +{ + return (size_t) -1; +} + +static toff_t +tiff_seek_in_memory (data, off, whence) + thandle_t data; + toff_t off; + int whence; +{ + tiff_memory_source *src = (tiff_memory_source *) data; + int idx; + + switch (whence) + { + case SEEK_SET: /* Go from beginning of source. */ + idx = off; + break; + + case SEEK_END: /* Go from end of source. */ + idx = src->len + off; + break; + + case SEEK_CUR: /* Go from current position. */ + idx = src->index + off; + break; + + default: /* Invalid `whence'. */ + return -1; + } + + if (idx > src->len || idx < 0) + return -1; + + src->index = idx; + return src->index; +} + +static int +tiff_close_memory (data) + thandle_t data; +{ + /* NOOP */ + return 0; +} + +static int +tiff_mmap_memory (data, pbase, psize) + thandle_t data; + tdata_t *pbase; + toff_t *psize; +{ + /* It is already _IN_ memory. */ + return 0; +} + +static void +tiff_unmap_memory (data, base, size) + thandle_t data; + tdata_t base; + toff_t size; +{ + /* We don't need to do this. */ +} + +static toff_t +tiff_size_of_memory (data) + thandle_t data; +{ + return ((tiff_memory_source *) data)->len; +} + +/* Load TIFF image IMG for use on frame F. Value is non-zero if + successful. */ + +static int +tiff_load (f, img) + struct frame *f; + struct image *img; +{ + Lisp_Object file, specified_file; + Lisp_Object specified_data; + TIFF *tiff; + int width, height, x, y; + uint32 *buf; + int rc; + XImage *ximg; + struct gcpro gcpro1; + tiff_memory_source memsrc; + + specified_file = image_spec_value (img->spec, QCfile, NULL); + specified_data = image_spec_value (img->spec, QCdata, NULL); + file = Qnil; + GCPRO1 (file); + + if (NILP (specified_data)) + { + /* Read from a file */ + file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", file, Qnil); + UNGCPRO; + return 0; + } + + /* Try to open the image file. */ + tiff = TIFFOpen (XSTRING (file)->data, "r"); + if (tiff == NULL) + { + image_error ("Cannot open `%s'", file, Qnil); + UNGCPRO; + return 0; + } + } + else + { + /* Memory source! */ + memsrc.bytes = XSTRING (specified_data)->data; + memsrc.len = STRING_BYTES (XSTRING (specified_data)); + memsrc.index = 0; + + tiff = TIFFClientOpen ("memory_source", "r", &memsrc, + (TIFFReadWriteProc) tiff_read_from_memory, + (TIFFReadWriteProc) tiff_write_from_memory, + tiff_seek_in_memory, + tiff_close_memory, + tiff_size_of_memory, + tiff_mmap_memory, + tiff_unmap_memory); + + if (!tiff) + { + image_error ("Cannot open memory source for `%s'", img->spec, Qnil); + UNGCPRO; + return 0; + } + } + + /* Get width and height of the image, and allocate a raster buffer + of width x height 32-bit values. */ + TIFFGetField (tiff, TIFFTAG_IMAGEWIDTH, &width); + TIFFGetField (tiff, TIFFTAG_IMAGELENGTH, &height); + buf = (uint32 *) xmalloc (width * height * sizeof *buf); + + rc = TIFFReadRGBAImage (tiff, width, height, buf, 0); + TIFFClose (tiff); + if (!rc) + { + image_error ("Error reading TIFF image `%s'", img->spec, Qnil); + xfree (buf); + UNGCPRO; + return 0; + } + + BLOCK_INPUT; + + /* Create the X image and pixmap. */ + if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) + { + UNBLOCK_INPUT; + xfree (buf); + UNGCPRO; + return 0; + } + + /* Initialize the color table. */ + init_color_table (); + + /* Process the pixel raster. Origin is in the lower-left corner. */ + for (y = 0; y < height; ++y) + { + uint32 *row = buf + y * width; + + for (x = 0; x < width; ++x) + { + uint32 abgr = row[x]; + int r = TIFFGetR (abgr) << 8; + int g = TIFFGetG (abgr) << 8; + int b = TIFFGetB (abgr) << 8; + XPutPixel (ximg, x, height - 1 - y, lookup_rgb_color (f, r, g, b)); + } + } + + /* Remember the colors allocated for the image. Free the color table. */ + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); + + /* Put the image into the pixmap, then free the X image and its buffer. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + xfree (buf); + UNBLOCK_INPUT; + + img->width = width; + img->height = height; + + UNGCPRO; + return 1; +} + +#endif /* HAVE_TIFF != 0 */ + + + +/*********************************************************************** + GIF + ***********************************************************************/ + +#if HAVE_GIF + +#include + +static int gif_image_p P_ ((Lisp_Object object)); +static int gif_load P_ ((struct frame *f, struct image *img)); + +/* The symbol `gif' identifying images of this type. */ + +Lisp_Object Qgif; + +/* Indices of image specification fields in gif_format, below. */ + +enum gif_keyword_index +{ + GIF_TYPE, + GIF_DATA, + GIF_FILE, + GIF_ASCENT, + GIF_MARGIN, + GIF_RELIEF, + GIF_ALGORITHM, + GIF_HEURISTIC_MASK, + GIF_IMAGE, + GIF_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static struct image_keyword gif_format[GIF_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":data", IMAGE_STRING_VALUE, 0}, + {":file", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":image", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0} +}; + +/* Structure describing the image type `gif'. */ + +static struct image_type gif_type = +{ + &Qgif, + gif_image_p, + gif_load, + x_clear_image, + NULL +}; + +/* Return non-zero if OBJECT is a valid GIF image specification. */ + +static int +gif_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[GIF_LAST]; + bcopy (gif_format, fmt, sizeof fmt); + + if (!parse_image_spec (object, fmt, GIF_LAST, Qgif) + || (fmt[GIF_ASCENT].count + && XFASTINT (fmt[GIF_ASCENT].value) > 100)) + return 0; + + /* Must specify either the :data or :file keyword. */ + return fmt[GIF_FILE].count + fmt[GIF_DATA].count == 1; +} + +/* Reading a GIF image from memory + Based on the PNG memory stuff to a certain extent. */ + +typedef struct +{ + unsigned char *bytes; + size_t len; + int index; +} +gif_memory_source; + +/* Make the current memory source available to gif_read_from_memory. + It's done this way because not all versions of libungif support + a UserData field in the GifFileType structure. */ +static gif_memory_source *current_gif_memory_src; + +static int +gif_read_from_memory (file, buf, len) + GifFileType *file; + GifByteType *buf; + int len; +{ + gif_memory_source *src = current_gif_memory_src; + + if (len > src->len - src->index) + return -1; + + bcopy (src->bytes + src->index, buf, len); + src->index += len; + return len; +} + + +/* Load GIF image IMG for use on frame F. Value is non-zero if + successful. */ + +static int +gif_load (f, img) + struct frame *f; + struct image *img; +{ + Lisp_Object file, specified_file; + Lisp_Object specified_data; + int rc, width, height, x, y, i; + XImage *ximg; + ColorMapObject *gif_color_map; + unsigned long pixel_colors[256]; + GifFileType *gif; + struct gcpro gcpro1; + Lisp_Object image; + int ino, image_left, image_top, image_width, image_height; + gif_memory_source memsrc; + unsigned char *raster; + + specified_file = image_spec_value (img->spec, QCfile, NULL); + specified_data = image_spec_value (img->spec, QCdata, NULL); + file = Qnil; + GCPRO1 (file); + + if (NILP (specified_data)) + { + file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + UNGCPRO; + return 0; + } + + /* Open the GIF file. */ + gif = DGifOpenFileName (XSTRING (file)->data); + if (gif == NULL) + { + image_error ("Cannot open `%s'", file, Qnil); + UNGCPRO; + return 0; + } + } + else + { + /* Read from memory! */ + current_gif_memory_src = &memsrc; + memsrc.bytes = XSTRING (specified_data)->data; + memsrc.len = STRING_BYTES (XSTRING (specified_data)); + memsrc.index = 0; + + gif = DGifOpen(&memsrc, gif_read_from_memory); + if (!gif) + { + image_error ("Cannot open memory source `%s'", img->spec, Qnil); + UNGCPRO; + return 0; + } + } + + /* Read entire contents. */ + rc = DGifSlurp (gif); + if (rc == GIF_ERROR) + { + image_error ("Error reading `%s'", img->spec, Qnil); + DGifCloseFile (gif); + UNGCPRO; + return 0; + } + + image = image_spec_value (img->spec, QCindex, NULL); + ino = INTEGERP (image) ? XFASTINT (image) : 0; + if (ino >= gif->ImageCount) + { + image_error ("Invalid image number `%s' in image `%s'", + image, img->spec); + DGifCloseFile (gif); + UNGCPRO; + return 0; + } + + width = img->width = gif->SWidth; + height = img->height = gif->SHeight; + + BLOCK_INPUT; + + /* Create the X image and pixmap. */ + if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) + { + UNBLOCK_INPUT; + DGifCloseFile (gif); + UNGCPRO; + return 0; + } + + /* Allocate colors. */ + gif_color_map = gif->SavedImages[ino].ImageDesc.ColorMap; + if (!gif_color_map) + gif_color_map = gif->SColorMap; + init_color_table (); + bzero (pixel_colors, sizeof pixel_colors); + + for (i = 0; i < gif_color_map->ColorCount; ++i) + { + int r = gif_color_map->Colors[i].Red << 8; + int g = gif_color_map->Colors[i].Green << 8; + int b = gif_color_map->Colors[i].Blue << 8; + pixel_colors[i] = lookup_rgb_color (f, r, g, b); + } + + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); + + /* Clear the part of the screen image that are not covered by + the image from the GIF file. Full animated GIF support + requires more than can be done here (see the gif89 spec, + disposal methods). Let's simply assume that the part + not covered by a sub-image is in the frame's background color. */ + image_top = gif->SavedImages[ino].ImageDesc.Top; + image_left = gif->SavedImages[ino].ImageDesc.Left; + image_width = gif->SavedImages[ino].ImageDesc.Width; + image_height = gif->SavedImages[ino].ImageDesc.Height; + + for (y = 0; y < image_top; ++y) + for (x = 0; x < width; ++x) + XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); + + for (y = image_top + image_height; y < height; ++y) + for (x = 0; x < width; ++x) + XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); + + for (y = image_top; y < image_top + image_height; ++y) + { + for (x = 0; x < image_left; ++x) + XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); + for (x = image_left + image_width; x < width; ++x) + XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); + } + + /* Read the GIF image into the X image. We use a local variable + `raster' here because RasterBits below is a char *, and invites + problems with bytes >= 0x80. */ + raster = (unsigned char *) gif->SavedImages[ino].RasterBits; + + if (gif->SavedImages[ino].ImageDesc.Interlace) + { + static int interlace_start[] = {0, 4, 2, 1}; + static int interlace_increment[] = {8, 8, 4, 2}; + int pass, inc; + int row = interlace_start[0]; + + pass = 0; + + for (y = 0; y < image_height; y++) + { + if (row >= image_height) + { + row = interlace_start[++pass]; + while (row >= image_height) + row = interlace_start[++pass]; + } + + for (x = 0; x < image_width; x++) + { + int i = raster[(y * image_width) + x]; + XPutPixel (ximg, x + image_left, row + image_top, + pixel_colors[i]); + } + + row += interlace_increment[pass]; + } + } + else + { + for (y = 0; y < image_height; ++y) + for (x = 0; x < image_width; ++x) + { + int i = raster[y* image_width + x]; + XPutPixel (ximg, x + image_left, y + image_top, pixel_colors[i]); + } + } + + DGifCloseFile (gif); + + /* Put the image into the pixmap, then free the X image and its buffer. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + UNBLOCK_INPUT; + + UNGCPRO; + return 1; +} + +#endif /* HAVE_GIF != 0 */ + + + +/*********************************************************************** + Ghostscript + ***********************************************************************/ + +#ifdef HAVE_GHOSTSCRIPT +static int gs_image_p P_ ((Lisp_Object object)); +static int gs_load P_ ((struct frame *f, struct image *img)); +static void gs_clear_image P_ ((struct frame *f, struct image *img)); + +/* The symbol `postscript' identifying images of this type. */ + +Lisp_Object Qpostscript; + +/* Keyword symbols. */ + +Lisp_Object QCloader, QCbounding_box, QCpt_width, QCpt_height; + +/* Indices of image specification fields in gs_format, below. */ + +enum gs_keyword_index +{ + GS_TYPE, + GS_PT_WIDTH, + GS_PT_HEIGHT, + GS_FILE, + GS_LOADER, + GS_BOUNDING_BOX, + GS_ASCENT, + GS_MARGIN, + GS_RELIEF, + GS_ALGORITHM, + GS_HEURISTIC_MASK, + GS_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static struct image_keyword gs_format[GS_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":pt-width", IMAGE_POSITIVE_INTEGER_VALUE, 1}, + {":pt-height", IMAGE_POSITIVE_INTEGER_VALUE, 1}, + {":file", IMAGE_STRING_VALUE, 1}, + {":loader", IMAGE_FUNCTION_VALUE, 0}, + {":bounding-box", IMAGE_DONT_CHECK_VALUE_TYPE, 1}, + {":ascent", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0} +}; + +/* Structure describing the image type `ghostscript'. */ + +static struct image_type gs_type = +{ + &Qpostscript, + gs_image_p, + gs_load, + gs_clear_image, + NULL +}; + + +/* Free X resources of Ghostscript image IMG which is used on frame F. */ + +static void +gs_clear_image (f, img) + struct frame *f; + struct image *img; +{ + /* IMG->data.ptr_val may contain a recorded colormap. */ + xfree (img->data.ptr_val); + x_clear_image (f, img); +} + + +/* Return non-zero if OBJECT is a valid Ghostscript image + specification. */ + +static int +gs_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[GS_LAST]; + Lisp_Object tem; + int i; + + bcopy (gs_format, fmt, sizeof fmt); + + if (!parse_image_spec (object, fmt, GS_LAST, Qpostscript) + || (fmt[GS_ASCENT].count + && XFASTINT (fmt[GS_ASCENT].value) > 100)) + return 0; + + /* Bounding box must be a list or vector containing 4 integers. */ + tem = fmt[GS_BOUNDING_BOX].value; + if (CONSP (tem)) + { + for (i = 0; i < 4; ++i, tem = XCDR (tem)) + if (!CONSP (tem) || !INTEGERP (XCAR (tem))) + return 0; + if (!NILP (tem)) + return 0; + } + else if (VECTORP (tem)) + { + if (XVECTOR (tem)->size != 4) + return 0; + for (i = 0; i < 4; ++i) + if (!INTEGERP (XVECTOR (tem)->contents[i])) + return 0; + } + else + return 0; + + return 1; +} + + +/* Load Ghostscript image IMG for use on frame F. Value is non-zero + if successful. */ + +static int +gs_load (f, img) + struct frame *f; + struct image *img; +{ + char buffer[100]; + Lisp_Object window_and_pixmap_id = Qnil, loader, pt_height, pt_width; + struct gcpro gcpro1, gcpro2; + Lisp_Object frame; + double in_width, in_height; + Lisp_Object pixel_colors = Qnil; + + /* Compute pixel size of pixmap needed from the given size in the + image specification. Sizes in the specification are in pt. 1 pt + = 1/72 in, xdpi and ydpi are stored in the frame's X display + info. */ + pt_width = image_spec_value (img->spec, QCpt_width, NULL); + in_width = XFASTINT (pt_width) / 72.0; + img->width = in_width * FRAME_W32_DISPLAY_INFO (f)->resx; + pt_height = image_spec_value (img->spec, QCpt_height, NULL); + in_height = XFASTINT (pt_height) / 72.0; + img->height = in_height * FRAME_W32_DISPLAY_INFO (f)->resy; + + /* Create the pixmap. */ + BLOCK_INPUT; + xassert (img->pixmap == 0); + img->pixmap = XCreatePixmap (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), + img->width, img->height, + DefaultDepthOfScreen (FRAME_X_SCREEN (f))); + UNBLOCK_INPUT; + + if (!img->pixmap) + { + image_error ("Unable to create pixmap for `%s'", img->spec, Qnil); + return 0; + } + + /* Call the loader to fill the pixmap. It returns a process object + if successful. We do not record_unwind_protect here because + other places in redisplay like calling window scroll functions + don't either. Let the Lisp loader use `unwind-protect' instead. */ + GCPRO2 (window_and_pixmap_id, pixel_colors); + + sprintf (buffer, "%lu %lu", + (unsigned long) FRAME_W32_WINDOW (f), + (unsigned long) img->pixmap); + window_and_pixmap_id = build_string (buffer); + + sprintf (buffer, "%lu %lu", + FRAME_FOREGROUND_PIXEL (f), + FRAME_BACKGROUND_PIXEL (f)); + pixel_colors = build_string (buffer); + + XSETFRAME (frame, f); + loader = image_spec_value (img->spec, QCloader, NULL); + if (NILP (loader)) + loader = intern ("gs-load-image"); + + img->data.lisp_val = call6 (loader, frame, img->spec, + make_number (img->width), + make_number (img->height), + window_and_pixmap_id, + pixel_colors); + UNGCPRO; + return PROCESSP (img->data.lisp_val); +} + + +/* Kill the Ghostscript process that was started to fill PIXMAP on + frame F. Called from XTread_socket when receiving an event + telling Emacs that Ghostscript has finished drawing. */ + +void +x_kill_gs_process (pixmap, f) + Pixmap pixmap; + struct frame *f; +{ + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + int class, i; + struct image *img; + + /* Find the image containing PIXMAP. */ + for (i = 0; i < c->used; ++i) + if (c->images[i]->pixmap == pixmap) + break; + + /* Kill the GS process. We should have found PIXMAP in the image + cache and its image should contain a process object. */ + xassert (i < c->used); + img = c->images[i]; + xassert (PROCESSP (img->data.lisp_val)); + Fkill_process (img->data.lisp_val, Qnil); + img->data.lisp_val = Qnil; + + /* On displays with a mutable colormap, figure out the colors + allocated for the image by looking at the pixels of an XImage for + img->pixmap. */ + class = FRAME_W32_DISPLAY_INFO (f)->visual->class; + if (class != StaticColor && class != StaticGray && class != TrueColor) + { + XImage *ximg; + + BLOCK_INPUT; + + /* Try to get an XImage for img->pixmep. */ + ximg = XGetImage (FRAME_W32_DISPLAY (f), img->pixmap, + 0, 0, img->width, img->height, ~0, ZPixmap); + if (ximg) + { + int x, y; + + /* Initialize the color table. */ + init_color_table (); + + /* For each pixel of the image, look its color up in the + color table. After having done so, the color table will + contain an entry for each color used by the image. */ + for (y = 0; y < img->height; ++y) + for (x = 0; x < img->width; ++x) + { + unsigned long pixel = XGetPixel (ximg, x, y); + lookup_pixel_color (f, pixel); + } + + /* Record colors in the image. Free color table and XImage. */ + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); + XDestroyImage (ximg); + +#if 0 /* This doesn't seem to be the case. If we free the colors + here, we get a BadAccess later in x_clear_image when + freeing the colors. */ + /* We have allocated colors once, but Ghostscript has also + allocated colors on behalf of us. So, to get the + reference counts right, free them once. */ + if (img->ncolors) + { + Colormap cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f)); + XFreeColors (FRAME_W32_DISPLAY (f), cmap, + img->colors, img->ncolors, 0); + } +#endif + } + else + image_error ("Cannot get X image of `%s'; colors will not be freed", + img->spec, Qnil); + + UNBLOCK_INPUT; + } +} + +#endif /* HAVE_GHOSTSCRIPT */ + + +/*********************************************************************** + Window properties + ***********************************************************************/ + +DEFUN ("x-change-window-property", Fx_change_window_property, + Sx_change_window_property, 2, 3, 0, + "Change window property PROP to VALUE on the X window of FRAME.\n\ +PROP and VALUE must be strings. FRAME nil or omitted means use the\n\ +selected frame. Value is VALUE.") + (prop, value, frame) + Lisp_Object frame, prop, value; +{ +#if 0 /* TODO : port window properties to W32 */ + struct frame *f = check_x_frame (frame); + Atom prop_atom; + + CHECK_STRING (prop, 1); + CHECK_STRING (value, 2); + + BLOCK_INPUT; + prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), XSTRING (prop)->data, False); + XChangeProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), + prop_atom, XA_STRING, 8, PropModeReplace, + XSTRING (value)->data, XSTRING (value)->size); + + /* Make sure the property is set when we return. */ + XFlush (FRAME_W32_DISPLAY (f)); + UNBLOCK_INPUT; + +#endif /* TODO */ + + return value; +} + + +DEFUN ("x-delete-window-property", Fx_delete_window_property, + Sx_delete_window_property, 1, 2, 0, + "Remove window property PROP from X window of FRAME.\n\ +FRAME nil or omitted means use the selected frame. Value is PROP.") + (prop, frame) + Lisp_Object prop, frame; +{ +#if 0 /* TODO : port window properties to W32 */ + + struct frame *f = check_x_frame (frame); + Atom prop_atom; + + CHECK_STRING (prop, 1); + BLOCK_INPUT; + prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), XSTRING (prop)->data, False); + XDeleteProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), prop_atom); + + /* Make sure the property is removed when we return. */ + XFlush (FRAME_W32_DISPLAY (f)); + UNBLOCK_INPUT; +#endif /* TODO */ + + return prop; +} + + +DEFUN ("x-window-property", Fx_window_property, Sx_window_property, + 1, 2, 0, + "Value is the value of window property PROP on FRAME.\n\ +If FRAME is nil or omitted, use the selected frame. Value is nil\n\ +if FRAME hasn't a property with name PROP or if PROP has no string\n\ +value.") + (prop, frame) + Lisp_Object prop, frame; +{ +#if 0 /* TODO : port window properties to W32 */ + + struct frame *f = check_x_frame (frame); + Atom prop_atom; + int rc; + Lisp_Object prop_value = Qnil; + char *tmp_data = NULL; + Atom actual_type; + int actual_format; + unsigned long actual_size, bytes_remaining; + + CHECK_STRING (prop, 1); + BLOCK_INPUT; + prop_atom = XInternAtom (FRAME_W32_DISPLAY (f), XSTRING (prop)->data, False); + rc = XGetWindowProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), + prop_atom, 0, 0, False, XA_STRING, + &actual_type, &actual_format, &actual_size, + &bytes_remaining, (unsigned char **) &tmp_data); + if (rc == Success) + { + int size = bytes_remaining; + + XFree (tmp_data); + tmp_data = NULL; + + rc = XGetWindowProperty (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), + prop_atom, 0, bytes_remaining, + False, XA_STRING, + &actual_type, &actual_format, + &actual_size, &bytes_remaining, + (unsigned char **) &tmp_data); + if (rc == Success) + prop_value = make_string (tmp_data, size); + + XFree (tmp_data); + } + + UNBLOCK_INPUT; + + return prop_value; + +#endif /* TODO */ + return Qnil; +} + + + +/*********************************************************************** + Busy cursor + ***********************************************************************/ + +/* If non-null, an asynchronous timer that, when it expires, displays + an hourglass cursor on all frames. */ + +static struct atimer *hourglass_atimer; + +/* Non-zero means an hourglass cursor is currently shown. */ + +static int hourglass_shown_p; + +/* Number of seconds to wait before displaying an hourglass cursor. */ + +static Lisp_Object Vhourglass_delay; + +/* Default number of seconds to wait before displaying an hourglass + cursor. */ + +#define DEFAULT_HOURGLASS_DELAY 1 + +/* Function prototypes. */ + +static void show_hourglass P_ ((struct atimer *)); +static void hide_hourglass P_ ((void)); + + +/* Cancel a currently active hourglass timer, and start a new one. */ + +void +start_hourglass () +{ +#if 0 /* TODO: cursor shape changes. */ + EMACS_TIME delay; + int secs, usecs = 0; + + cancel_hourglass (); + + if (INTEGERP (Vhourglass_delay) + && XINT (Vhourglass_delay) > 0) + secs = XFASTINT (Vhourglass_delay); + else if (FLOATP (Vhourglass_delay) + && XFLOAT_DATA (Vhourglass_delay) > 0) + { + Lisp_Object tem; + tem = Ftruncate (Vhourglass_delay, Qnil); + secs = XFASTINT (tem); + usecs = (XFLOAT_DATA (Vhourglass_delay) - secs) * 1000000; + } + else + secs = DEFAULT_HOURGLASS_DELAY; + + EMACS_SET_SECS_USECS (delay, secs, usecs); + hourglass_atimer = start_atimer (ATIMER_RELATIVE, delay, + show_hourglass, NULL); +#endif +} + + +/* Cancel the hourglass cursor timer if active, hide an hourglass + cursor if shown. */ + +void +cancel_hourglass () +{ + if (hourglass_atimer) + { + cancel_atimer (hourglass_atimer); + hourglass_atimer = NULL; + } + + if (hourglass_shown_p) + hide_hourglass (); +} + + +/* Timer function of hourglass_atimer. TIMER is equal to + hourglass_atimer. + + Display an hourglass cursor on all frames by mapping the frames' + hourglass_window. Set the hourglass_p flag in the frames' + output_data.x structure to indicate that an hourglass cursor is + shown on the frames. */ + +static void +show_hourglass (timer) + struct atimer *timer; +{ +#if 0 /* TODO: cursor shape changes. */ + /* The timer implementation will cancel this timer automatically + after this function has run. Set hourglass_atimer to null + so that we know the timer doesn't have to be canceled. */ + hourglass_atimer = NULL; + + if (!hourglass_shown_p) + { + Lisp_Object rest, frame; + + BLOCK_INPUT; + + FOR_EACH_FRAME (rest, frame) + if (FRAME_W32_P (XFRAME (frame))) + { + struct frame *f = XFRAME (frame); + + f->output_data.w32->hourglass_p = 1; + + if (!f->output_data.w32->hourglass_window) + { + unsigned long mask = CWCursor; + XSetWindowAttributes attrs; + + attrs.cursor = f->output_data.w32->hourglass_cursor; + + f->output_data.w32->hourglass_window + = XCreateWindow (FRAME_X_DISPLAY (f), + FRAME_OUTER_WINDOW (f), + 0, 0, 32000, 32000, 0, 0, + InputOnly, + CopyFromParent, + mask, &attrs); + } + + XMapRaised (FRAME_X_DISPLAY (f), + f->output_data.w32->hourglass_window); + XFlush (FRAME_X_DISPLAY (f)); + } + + hourglass_shown_p = 1; + UNBLOCK_INPUT; + } +#endif +} + + +/* Hide the hourglass cursor on all frames, if it is currently shown. */ + +static void +hide_hourglass () +{ +#if 0 /* TODO: cursor shape changes. */ + if (hourglass_shown_p) + { + Lisp_Object rest, frame; + + BLOCK_INPUT; + FOR_EACH_FRAME (rest, frame) + { + struct frame *f = XFRAME (frame); + + if (FRAME_W32_P (f) + /* Watch out for newly created frames. */ + && f->output_data.x->hourglass_window) + { + XUnmapWindow (FRAME_X_DISPLAY (f), + f->output_data.x->hourglass_window); + /* Sync here because XTread_socket looks at the + hourglass_p flag that is reset to zero below. */ + XSync (FRAME_X_DISPLAY (f), False); + f->output_data.x->hourglass_p = 0; + } + } + + hourglass_shown_p = 0; + UNBLOCK_INPUT; + } +#endif +} + + + +/*********************************************************************** + Tool tips + ***********************************************************************/ + +static Lisp_Object x_create_tip_frame P_ ((struct w32_display_info *, + Lisp_Object)); + +/* The frame of a currently visible tooltip, or null. */ + +Lisp_Object tip_frame; + +/* If non-nil, a timer started that hides the last tooltip when it + fires. */ + +Lisp_Object tip_timer; +Window tip_window; + +static Lisp_Object +unwind_create_tip_frame (frame) + Lisp_Object frame; +{ + Lisp_Object deleted; + + deleted = unwind_create_frame (frame); + if (EQ (deleted, Qt)) + { + tip_window = NULL; + tip_frame = Qnil; + } + + return deleted; +} + + +/* Create a frame for a tooltip on the display described by DPYINFO. + PARMS is a list of frame parameters. Value is the frame. + + Note that functions called here, esp. x_default_parameter can + signal errors, for instance when a specified color name is + undefined. We have to make sure that we're in a consistent state + when this happens. */ + +static Lisp_Object +x_create_tip_frame (dpyinfo, parms) + struct w32_display_info *dpyinfo; + Lisp_Object parms; +{ +#if 0 /* TODO : w32 version */ + struct frame *f; + Lisp_Object frame, tem; + Lisp_Object name; + long window_prompting = 0; + int width, height; + int count = BINDING_STACK_SIZE (); + struct gcpro gcpro1, gcpro2, gcpro3; + struct kboard *kb; + + check_x (); + + /* Use this general default value to start with until we know if + this frame has a specified name. */ + Vx_resource_name = Vinvocation_name; + +#ifdef MULTI_KBOARD + kb = dpyinfo->kboard; +#else + kb = &the_only_kboard; +#endif + + /* Get the name of the frame to use for resource lookup. */ + name = w32_get_arg (parms, Qname, "name", "Name", RES_TYPE_STRING); + if (!STRINGP (name) + && !EQ (name, Qunbound) + && !NILP (name)) + error ("Invalid frame name--not a string or nil"); + Vx_resource_name = name; + + frame = Qnil; + GCPRO3 (parms, name, frame); + f = make_frame (1); + XSETFRAME (frame, f); + FRAME_CAN_HAVE_SCROLL_BARS (f) = 0; + record_unwind_protect (unwind_create_tip_frame, frame); + + f->output_method = output_w32; + f->output_data.w32 = + (struct w32_output *) xmalloc (sizeof (struct w32_output)); + bzero (f->output_data.w32, sizeof (struct w32_output)); +#if 0 + f->output_data.w32->icon_bitmap = -1; +#endif + f->output_data.w32->fontset = -1; + f->icon_name = Qnil; + +#ifdef GLYPH_DEBUG + image_cache_refcount = FRAME_X_IMAGE_CACHE (f)->refcount; + dpyinfo_refcount = dpyinfo->reference_count; +#endif /* GLYPH_DEBUG */ +#ifdef MULTI_KBOARD + FRAME_KBOARD (f) = kb; +#endif + f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window; + f->output_data.w32->explicit_parent = 0; + + /* Set the name; the functions to which we pass f expect the name to + be set. */ + if (EQ (name, Qunbound) || NILP (name)) + { + f->name = build_string (dpyinfo->x_id_name); + f->explicit_name = 0; + } + else + { + f->name = name; + f->explicit_name = 1; + /* use the frame's title when getting resources for this frame. */ + specbind (Qx_resource_name, name); + } + + /* Extract the window parameters from the supplied values + that are needed to determine window geometry. */ + { + Lisp_Object font; + + font = w32_get_arg (parms, Qfont, "font", "Font", RES_TYPE_STRING); + + BLOCK_INPUT; + /* First, try whatever font the caller has specified. */ + if (STRINGP (font)) + { + tem = Fquery_fontset (font, Qnil); + if (STRINGP (tem)) + font = x_new_fontset (f, XSTRING (tem)->data); + else + font = x_new_font (f, XSTRING (font)->data); + } + + /* Try out a font which we hope has bold and italic variations. */ + if (!STRINGP (font)) + font = x_new_font (f, "-*-courier new-normal-r-*-*-*-100-*-*-*-*-iso8859-1"); + if (!STRINGP (font)) + font = x_new_font (f, "-misc-fixed-medium-r-normal-*-*-140-*-*-c-*-iso8859-1"); + if (! STRINGP (font)) + font = x_new_font (f, "-*-*-medium-r-normal-*-*-140-*-*-c-*-iso8859-1"); + if (! STRINGP (font)) + /* This was formerly the first thing tried, but it finds too many fonts + and takes too long. */ + font = x_new_font (f, "-*-*-medium-r-*-*-*-*-*-*-c-*-iso8859-1"); + /* If those didn't work, look for something which will at least work. */ + if (! STRINGP (font)) + font = x_new_font (f, "-*-fixed-*-*-*-*-*-140-*-*-c-*-iso8859-1"); + UNBLOCK_INPUT; + if (! STRINGP (font)) + font = build_string ("fixed"); + + x_default_parameter (f, parms, Qfont, font, + "font", "Font", RES_TYPE_STRING); + } + + x_default_parameter (f, parms, Qborder_width, make_number (2), + "borderWidth", "BorderWidth", RES_TYPE_NUMBER); + + /* This defaults to 2 in order to match xterm. We recognize either + internalBorderWidth or internalBorder (which is what xterm calls + it). */ + if (NILP (Fassq (Qinternal_border_width, parms))) + { + Lisp_Object value; + + value = w32_get_arg (parms, Qinternal_border_width, + "internalBorder", "internalBorder", RES_TYPE_NUMBER); + if (! EQ (value, Qunbound)) + parms = Fcons (Fcons (Qinternal_border_width, value), + parms); + } + + x_default_parameter (f, parms, Qinternal_border_width, make_number (1), + "internalBorderWidth", "internalBorderWidth", + RES_TYPE_NUMBER); + + /* Also do the stuff which must be set before the window exists. */ + x_default_parameter (f, parms, Qforeground_color, build_string ("black"), + "foreground", "Foreground", RES_TYPE_STRING); + x_default_parameter (f, parms, Qbackground_color, build_string ("white"), + "background", "Background", RES_TYPE_STRING); + x_default_parameter (f, parms, Qmouse_color, build_string ("black"), + "pointerColor", "Foreground", RES_TYPE_STRING); + x_default_parameter (f, parms, Qcursor_color, build_string ("black"), + "cursorColor", "Foreground", RES_TYPE_STRING); + x_default_parameter (f, parms, Qborder_color, build_string ("black"), + "borderColor", "BorderColor", RES_TYPE_STRING); + + /* Init faces before x_default_parameter is called for scroll-bar + parameters because that function calls x_set_scroll_bar_width, + which calls change_frame_size, which calls Fset_window_buffer, + which runs hooks, which call Fvertical_motion. At the end, we + end up in init_iterator with a null face cache, which should not + happen. */ + init_frame_faces (f); + + f->output_data.w32->parent_desc = FRAME_W32_DISPLAY_INFO (f)->root_window; + window_prompting = x_figure_window_size (f, parms); + + if (window_prompting & XNegative) + { + if (window_prompting & YNegative) + f->output_data.w32->win_gravity = SouthEastGravity; + else + f->output_data.w32->win_gravity = NorthEastGravity; + } + else + { + if (window_prompting & YNegative) + f->output_data.w32->win_gravity = SouthWestGravity; + else + f->output_data.w32->win_gravity = NorthWestGravity; + } + + f->output_data.w32->size_hint_flags = window_prompting; + { + XSetWindowAttributes attrs; + unsigned long mask; + + BLOCK_INPUT; + mask = CWBackPixel | CWOverrideRedirect | CWSaveUnder | CWEventMask; + /* Window managers looks at the override-redirect flag to + determine whether or net to give windows a decoration (Xlib + 3.2.8). */ + attrs.override_redirect = True; + attrs.save_under = True; + attrs.background_pixel = FRAME_BACKGROUND_PIXEL (f); + /* Arrange for getting MapNotify and UnmapNotify events. */ + attrs.event_mask = StructureNotifyMask; + tip_window + = FRAME_W32_WINDOW (f) + = XCreateWindow (FRAME_W32_DISPLAY (f), + FRAME_W32_DISPLAY_INFO (f)->root_window, + /* x, y, width, height */ + 0, 0, 1, 1, + /* Border. */ + 1, + CopyFromParent, InputOutput, CopyFromParent, + mask, &attrs); + UNBLOCK_INPUT; + } + + x_make_gc (f); + + x_default_parameter (f, parms, Qauto_raise, Qnil, + "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN); + x_default_parameter (f, parms, Qauto_lower, Qnil, + "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN); + x_default_parameter (f, parms, Qcursor_type, Qbox, + "cursorType", "CursorType", RES_TYPE_SYMBOL); + + /* Dimensions, especially f->height, must be done via change_frame_size. + Change will not be effected unless different from the current + f->height. */ + width = f->width; + height = f->height; + f->height = 0; + SET_FRAME_WIDTH (f, 0); + change_frame_size (f, height, width, 1, 0, 0); + + f->no_split = 1; + + UNGCPRO; + + /* It is now ok to make the frame official even if we get an error + below. And the frame needs to be on Vframe_list or making it + visible won't work. */ + Vframe_list = Fcons (frame, Vframe_list); + tip_frame = frame; + + /* Now that the frame is official, it counts as a reference to + its display. */ + FRAME_W32_DISPLAY_INFO (f)->reference_count++; + + return unbind_to (count, frame); +#endif /* TODO */ + return Qnil; +} + +#ifdef TODO /* Tooltip support not complete. */ +DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, + "Show STRING in a \"tooltip\" window on frame FRAME.\n\ +A tooltip window is a small window displaying a string.\n\ +\n\ +FRAME nil or omitted means use the selected frame.\n\ +\n\ +PARMS is an optional list of frame parameters which can be\n\ +used to change the tooltip's appearance.\n\ +\n\ +Automatically hide the tooltip after TIMEOUT seconds.\n\ +TIMEOUT nil means use the default timeout of 5 seconds.\n\ +\n\ +If the list of frame parameters PARAMS contains a `left' parameters,\n\ +the tooltip is displayed at that x-position. Otherwise it is\n\ +displayed at the mouse position, with offset DX added (default is 5 if\n\ +DX isn't specified). Likewise for the y-position; if a `top' frame\n\ +parameter is specified, it determines the y-position of the tooltip\n\ +window, otherwise it is displayed at the mouse position, with offset\n\ +DY added (default is 10).") + (string, frame, parms, timeout, dx, dy) + Lisp_Object string, frame, parms, timeout, dx, dy; +{ + struct frame *f; + struct window *w; + Window root, child; + Lisp_Object buffer, top, left; + struct buffer *old_buffer; + struct text_pos pos; + int i, width, height; + int root_x, root_y, win_x, win_y; + unsigned pmask; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + int old_windows_or_buffers_changed = windows_or_buffers_changed; + int count = specpdl_ptr - specpdl; + + specbind (Qinhibit_redisplay, Qt); + + GCPRO4 (string, parms, frame, timeout); + + CHECK_STRING (string, 0); + f = check_x_frame (frame); + if (NILP (timeout)) + timeout = make_number (5); + else + CHECK_NATNUM (timeout, 2); + + if (NILP (dx)) + dx = make_number (5); + else + CHECK_NUMBER (dx, 5); + + if (NILP (dy)) + dy = make_number (-10); + else + CHECK_NUMBER (dy, 6); + + if (NILP (last_show_tip_args)) + last_show_tip_args = Fmake_vector (make_number (3), Qnil); + + if (!NILP (tip_frame)) + { + Lisp_Object last_string = AREF (last_show_tip_args, 0); + Lisp_Object last_frame = AREF (last_show_tip_args, 1); + Lisp_Object last_parms = AREF (last_show_tip_args, 2); + + if (EQ (frame, last_frame) + && !NILP (Fequal (last_string, string)) + && !NILP (Fequal (last_parms, parms))) + { + struct frame *f = XFRAME (tip_frame); + + /* Only DX and DY have changed. */ + if (!NILP (tip_timer)) + { + Lisp_Object timer = tip_timer; + tip_timer = Qnil; + call1 (Qcancel_timer, timer); + } + + BLOCK_INPUT; + compute_tip_xy (f, parms, dx, dy, &root_x, &root_y); + XMoveWindow (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + root_x, root_y - PIXEL_HEIGHT (f)); + UNBLOCK_INPUT; + goto start_timer; + } + } + + /* Hide a previous tip, if any. */ + Fx_hide_tip (); + + ASET (last_show_tip_args, 0, string); + ASET (last_show_tip_args, 1, frame); + ASET (last_show_tip_args, 2, parms); + + /* Add default values to frame parameters. */ + if (NILP (Fassq (Qname, parms))) + parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms); + if (NILP (Fassq (Qinternal_border_width, parms))) + parms = Fcons (Fcons (Qinternal_border_width, make_number (3)), parms); + if (NILP (Fassq (Qborder_width, parms))) + parms = Fcons (Fcons (Qborder_width, make_number (1)), parms); + if (NILP (Fassq (Qborder_color, parms))) + parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms); + if (NILP (Fassq (Qbackground_color, parms))) + parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")), + parms); + + /* Create a frame for the tooltip, and record it in the global + variable tip_frame. */ + frame = x_create_tip_frame (FRAME_W32_DISPLAY_INFO (f), parms); + f = XFRAME (frame); + + /* Set up the frame's root window. Currently we use a size of 80 + columns x 40 lines. If someone wants to show a larger tip, he + will loose. I don't think this is a realistic case. */ + w = XWINDOW (FRAME_ROOT_WINDOW (f)); + w->left = w->top = make_number (0); + w->width = make_number (80); + w->height = make_number (40); + adjust_glyphs (f); + w->pseudo_window_p = 1; + + /* Display the tooltip text in a temporary buffer. */ + buffer = Fget_buffer_create (build_string (" *tip*")); + Fset_window_buffer (FRAME_ROOT_WINDOW (f), buffer); + old_buffer = current_buffer; + set_buffer_internal_1 (XBUFFER (buffer)); + Ferase_buffer (); + Finsert (1, &string); + clear_glyph_matrix (w->desired_matrix); + clear_glyph_matrix (w->current_matrix); + SET_TEXT_POS (pos, BEGV, BEGV_BYTE); + try_window (FRAME_ROOT_WINDOW (f), pos); + + /* Compute width and height of the tooltip. */ + width = height = 0; + for (i = 0; i < w->desired_matrix->nrows; ++i) + { + struct glyph_row *row = &w->desired_matrix->rows[i]; + struct glyph *last; + int row_width; + + /* Stop at the first empty row at the end. */ + if (!row->enabled_p || !row->displays_text_p) + break; + + /* Let the row go over the full width of the frame. */ + row->full_width_p = 1; + + /* There's a glyph at the end of rows that is use to place + the cursor there. Don't include the width of this glyph. */ + if (row->used[TEXT_AREA]) + { + last = &row->glyphs[TEXT_AREA][row->used[TEXT_AREA] - 1]; + row_width = row->pixel_width - last->pixel_width; + } + else + row_width = row->pixel_width; + + height += row->height; + width = max (width, row_width); + } + + /* Add the frame's internal border to the width and height the X + window should have. */ + height += 2 * FRAME_INTERNAL_BORDER_WIDTH (f); + width += 2 * FRAME_INTERNAL_BORDER_WIDTH (f); + + /* Move the tooltip window where the mouse pointer is. Resize and + show it. */ + compute_tip_xy (f, parms, dx, dy, &root_x, &root_y); + +#if 0 /* TODO : W32 specifics */ + BLOCK_INPUT; + XMoveResizeWindow (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + root_x, root_y - height, width, height); + XMapRaised (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); + UNBLOCK_INPUT; +#endif /* TODO */ + + /* Draw into the window. */ + w->must_be_updated_p = 1; + update_single_window (w, 1); + + /* Restore original current buffer. */ + set_buffer_internal_1 (old_buffer); + windows_or_buffers_changed = old_windows_or_buffers_changed; + + start_timer: + /* Let the tip disappear after timeout seconds. */ + tip_timer = call3 (intern ("run-at-time"), timeout, Qnil, + intern ("x-hide-tip")); + + UNGCPRO; + return unbind_to (count, Qnil); +} + + +DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0, + "Hide the current tooltip window, if there is any.\n\ +Value is t is tooltip was open, nil otherwise.") + () +{ + int count; + Lisp_Object deleted, frame, timer; + struct gcpro gcpro1, gcpro2; + + /* Return quickly if nothing to do. */ + if (NILP (tip_timer) && NILP (tip_frame)) + return Qnil; + + frame = tip_frame; + timer = tip_timer; + GCPRO2 (frame, timer); + tip_frame = tip_timer = deleted = Qnil; + + count = BINDING_STACK_SIZE (); + specbind (Qinhibit_redisplay, Qt); + specbind (Qinhibit_quit, Qt); + + if (!NILP (timer)) + call1 (Qcancel_timer, timer); + + if (FRAMEP (frame)) + { + Fdelete_frame (frame, Qnil); + deleted = Qt; + } + + UNGCPRO; + return unbind_to (count, deleted); +} +#endif + + + +/*********************************************************************** + File selection dialog + ***********************************************************************/ + +extern Lisp_Object Qfile_name_history; + +DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 4, 0, + "Read file name, prompting with PROMPT in directory DIR.\n\ +Use a file selection dialog.\n\ +Select DEFAULT-FILENAME in the dialog's file selection box, if\n\ +specified. Don't let the user enter a file name in the file\n\ +selection dialog's entry field, if MUSTMATCH is non-nil.") + (prompt, dir, default_filename, mustmatch) + Lisp_Object prompt, dir, default_filename, mustmatch; +{ + struct frame *f = SELECTED_FRAME (); + Lisp_Object file = Qnil; + int count = specpdl_ptr - specpdl; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; + char filename[MAX_PATH + 1]; + char init_dir[MAX_PATH + 1]; + int use_dialog_p = 1; + + GCPRO5 (prompt, dir, default_filename, mustmatch, file); + CHECK_STRING (prompt, 0); + CHECK_STRING (dir, 1); + + /* Create the dialog with PROMPT as title, using DIR as initial + directory and using "*" as pattern. */ + dir = Fexpand_file_name (dir, Qnil); + strncpy (init_dir, XSTRING (dir)->data, MAX_PATH); + init_dir[MAX_PATH] = '\0'; + unixtodos_filename (init_dir); + + if (STRINGP (default_filename)) + { + char *file_name_only; + char *full_path_name = XSTRING (default_filename)->data; + + unixtodos_filename (full_path_name); + + file_name_only = strrchr (full_path_name, '\\'); + if (!file_name_only) + file_name_only = full_path_name; + else + { + file_name_only++; + + /* If default_file_name is a directory, don't use the open + file dialog, as it does not support selecting + directories. */ + if (!(*file_name_only)) + use_dialog_p = 0; + } + + strncpy (filename, file_name_only, MAX_PATH); + filename[MAX_PATH] = '\0'; + } + else + filename[0] = '\0'; + + if (use_dialog_p) + { + OPENFILENAME file_details; + + /* Prevent redisplay. */ + specbind (Qinhibit_redisplay, Qt); + BLOCK_INPUT; + + bzero (&file_details, sizeof (file_details)); + file_details.lStructSize = sizeof (file_details); + file_details.hwndOwner = FRAME_W32_WINDOW (f); + file_details.lpstrFile = filename; + file_details.nMaxFile = sizeof (filename); + file_details.lpstrInitialDir = init_dir; + file_details.lpstrTitle = XSTRING (prompt)->data; + file_details.Flags = OFN_HIDEREADONLY | OFN_NOCHANGEDIR; + + if (!NILP (mustmatch)) + file_details.Flags |= OFN_FILEMUSTEXIST | OFN_PATHMUSTEXIST; + + if (GetOpenFileName (&file_details)) + { + dostounix_filename (filename); + file = build_string (filename); + } + else + file = Qnil; + + UNBLOCK_INPUT; + file = unbind_to (count, file); + } + /* Open File dialog will not allow folders to be selected, so resort + to minibuffer completing reads for directories. */ + else + file = Fcompleting_read (prompt, intern ("read-file-name-internal"), + dir, mustmatch, dir, Qfile_name_history, + default_filename, Qnil); + + UNGCPRO; + + /* Make "Cancel" equivalent to C-g. */ + if (NILP (file)) + Fsignal (Qquit, Qnil); + + return unbind_to (count, file); +} + + + +/*********************************************************************** + Tests + ***********************************************************************/ + +#if GLYPH_DEBUG + +DEFUN ("imagep", Fimagep, Simagep, 1, 1, 0, + "Value is non-nil if SPEC is a valid image specification.") + (spec) + Lisp_Object spec; +{ + return valid_image_p (spec) ? Qt : Qnil; +} + + +DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0, "") + (spec) + Lisp_Object spec; +{ + int id = -1; + + if (valid_image_p (spec)) + id = lookup_image (SELECTED_FRAME (), spec); + + debug_print (spec); + return make_number (id); +} + +#endif /* GLYPH_DEBUG != 0 */ + + + +/*********************************************************************** + w32 specialized functions + ***********************************************************************/ + +DEFUN ("w32-select-font", Fw32_select_font, Sw32_select_font, 0, 1, 0, + "This will display the W32 font dialog and return an X font string corresponding to the selection.") + (frame) + Lisp_Object frame; +{ + FRAME_PTR f = check_x_frame (frame); + CHOOSEFONT cf; + LOGFONT lf; + TEXTMETRIC tm; + HDC hdc; + HANDLE oldobj; + char buf[100]; + + bzero (&cf, sizeof (cf)); + bzero (&lf, sizeof (lf)); + + cf.lStructSize = sizeof (cf); + cf.hwndOwner = FRAME_W32_WINDOW (f); + cf.Flags = CF_FORCEFONTEXIST | CF_SCREENFONTS; + cf.lpLogFont = &lf; + + /* Initialize as much of the font details as we can from the current + default font. */ + hdc = GetDC (FRAME_W32_WINDOW (f)); + oldobj = SelectObject (hdc, FRAME_FONT (f)->hfont); + GetTextFace (hdc, LF_FACESIZE, lf.lfFaceName); + if (GetTextMetrics (hdc, &tm)) + { + lf.lfHeight = tm.tmInternalLeading - tm.tmHeight; + lf.lfWeight = tm.tmWeight; + lf.lfItalic = tm.tmItalic; + lf.lfUnderline = tm.tmUnderlined; + lf.lfStrikeOut = tm.tmStruckOut; + lf.lfCharSet = tm.tmCharSet; + cf.Flags |= CF_INITTOLOGFONTSTRUCT; + } + SelectObject (hdc, oldobj); + ReleaseDC (FRAME_W32_WINDOW (f), hdc); + + if (!ChooseFont (&cf) || !w32_to_x_font (&lf, buf, 100, NULL)) + return Qnil; + + return build_string (buf); +} + +DEFUN ("w32-send-sys-command", Fw32_send_sys_command, Sw32_send_sys_command, 1, 2, 0, + "Send frame a Windows WM_SYSCOMMAND message of type COMMAND.\n\ +Some useful values for command are 0xf030 to maximise frame (0xf020\n\ +to minimize), 0xf120 to restore frame to original size, and 0xf100\n\ +to activate the menubar for keyboard access. 0xf140 activates the\n\ +screen saver if defined.\n\ +\n\ +If optional parameter FRAME is not specified, use selected frame.") + (command, frame) + Lisp_Object command, frame; +{ + FRAME_PTR f = check_x_frame (frame); + + CHECK_NUMBER (command, 0); + + PostMessage (FRAME_W32_WINDOW (f), WM_SYSCOMMAND, XINT (command), 0); + + return Qnil; +} + +DEFUN ("w32-shell-execute", Fw32_shell_execute, Sw32_shell_execute, 2, 4, 0, + "Get Windows to perform OPERATION on DOCUMENT.\n\ +This is a wrapper around the ShellExecute system function, which\n\ +invokes the application registered to handle OPERATION for DOCUMENT.\n\ +OPERATION is typically \"open\", \"print\" or \"explore\" (but can be\n\ +nil for the default action), and DOCUMENT is typically the name of a\n\ +document file or URL, but can also be a program executable to run or\n\ +a directory to open in the Windows Explorer.\n\ +\n\ +If DOCUMENT is a program executable, PARAMETERS can be a string\n\ +containing command line parameters, but otherwise should be nil.\n\ +\n\ +SHOW-FLAG can be used to control whether the invoked application is hidden\n\ +or minimized. If SHOW-FLAG is nil, the application is displayed normally,\n\ +otherwise it is an integer representing a ShowWindow flag:\n\ +\n\ + 0 - start hidden\n\ + 1 - start normally\n\ + 3 - start maximized\n\ + 6 - start minimized") + (operation, document, parameters, show_flag) + Lisp_Object operation, document, parameters, show_flag; +{ + Lisp_Object current_dir; + + CHECK_STRING (document, 0); + + /* Encode filename and current directory. */ + current_dir = ENCODE_FILE (current_buffer->directory); + document = ENCODE_FILE (document); + if ((int) ShellExecute (NULL, + (STRINGP (operation) ? + XSTRING (operation)->data : NULL), + XSTRING (document)->data, + (STRINGP (parameters) ? + XSTRING (parameters)->data : NULL), + XSTRING (current_dir)->data, + (INTEGERP (show_flag) ? + XINT (show_flag) : SW_SHOWDEFAULT)) + > 32) + return Qt; + error ("ShellExecute failed: %s", w32_strerror (0)); +} + +/* Lookup virtual keycode from string representing the name of a + non-ascii keystroke into the corresponding virtual key, using + lispy_function_keys. */ +static int +lookup_vk_code (char *key) +{ + int i; + + for (i = 0; i < 256; i++) + if (lispy_function_keys[i] != 0 + && strcmp (lispy_function_keys[i], key) == 0) + return i; + + return -1; +} + +/* Convert a one-element vector style key sequence to a hot key + definition. */ +static int +w32_parse_hot_key (key) + Lisp_Object key; +{ + /* Copied from Fdefine_key and store_in_keymap. */ + register Lisp_Object c; + int vk_code; + int lisp_modifiers; + int w32_modifiers; + struct gcpro gcpro1; + + CHECK_VECTOR (key, 0); + + if (XFASTINT (Flength (key)) != 1) + return Qnil; + + GCPRO1 (key); + + c = Faref (key, make_number (0)); + + if (CONSP (c) && lucid_event_type_list_p (c)) + c = Fevent_convert_list (c); + + UNGCPRO; + + if (! INTEGERP (c) && ! SYMBOLP (c)) + error ("Key definition is invalid"); + + /* Work out the base key and the modifiers. */ + if (SYMBOLP (c)) + { + c = parse_modifiers (c); + lisp_modifiers = Fcar (Fcdr (c)); + c = Fcar (c); + if (!SYMBOLP (c)) + abort (); + vk_code = lookup_vk_code (XSYMBOL (c)->name->data); + } + else if (INTEGERP (c)) + { + lisp_modifiers = XINT (c) & ~CHARACTERBITS; + /* Many ascii characters are their own virtual key code. */ + vk_code = XINT (c) & CHARACTERBITS; + } + + if (vk_code < 0 || vk_code > 255) + return Qnil; + + if ((lisp_modifiers & meta_modifier) != 0 + && !NILP (Vw32_alt_is_meta)) + lisp_modifiers |= alt_modifier; + + /* Supply defs missing from mingw32. */ +#ifndef MOD_ALT +#define MOD_ALT 0x0001 +#define MOD_CONTROL 0x0002 +#define MOD_SHIFT 0x0004 +#define MOD_WIN 0x0008 +#endif + + /* Convert lisp modifiers to Windows hot-key form. */ + w32_modifiers = (lisp_modifiers & hyper_modifier) ? MOD_WIN : 0; + w32_modifiers |= (lisp_modifiers & alt_modifier) ? MOD_ALT : 0; + w32_modifiers |= (lisp_modifiers & ctrl_modifier) ? MOD_CONTROL : 0; + w32_modifiers |= (lisp_modifiers & shift_modifier) ? MOD_SHIFT : 0; + + return HOTKEY (vk_code, w32_modifiers); +} + +DEFUN ("w32-register-hot-key", Fw32_register_hot_key, Sw32_register_hot_key, 1, 1, 0, + "Register KEY as a hot-key combination.\n\ +Certain key combinations like Alt-Tab are reserved for system use on\n\ +Windows, and therefore are normally intercepted by the system. However,\n\ +most of these key combinations can be received by registering them as\n\ +hot-keys, overriding their special meaning.\n\ +\n\ +KEY must be a one element key definition in vector form that would be\n\ +acceptable to `define-key' (e.g. [A-tab] for Alt-Tab). The meta\n\ +modifier is interpreted as Alt if `w32-alt-is-meta' is t, and hyper\n\ +is always interpreted as the Windows modifier keys.\n\ +\n\ +The return value is the hotkey-id if registered, otherwise nil.") + (key) + Lisp_Object key; +{ + key = w32_parse_hot_key (key); + + if (NILP (Fmemq (key, w32_grabbed_keys))) + { + /* Reuse an empty slot if possible. */ + Lisp_Object item = Fmemq (Qnil, w32_grabbed_keys); + + /* Safe to add new key to list, even if we have focus. */ + if (NILP (item)) + w32_grabbed_keys = Fcons (key, w32_grabbed_keys); + else + XCAR (item) = key; + + /* Notify input thread about new hot-key definition, so that it + takes effect without needing to switch focus. */ + PostThreadMessage (dwWindowsThreadId, WM_EMACS_REGISTER_HOT_KEY, + (WPARAM) key, 0); + } + + return key; +} + +DEFUN ("w32-unregister-hot-key", Fw32_unregister_hot_key, Sw32_unregister_hot_key, 1, 1, 0, + "Unregister HOTKEY as a hot-key combination.") + (key) + Lisp_Object key; +{ + Lisp_Object item; + + if (!INTEGERP (key)) + key = w32_parse_hot_key (key); + + item = Fmemq (key, w32_grabbed_keys); + + if (!NILP (item)) + { + /* Notify input thread about hot-key definition being removed, so + that it takes effect without needing focus switch. */ + if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_UNREGISTER_HOT_KEY, + (WPARAM) XINT (XCAR (item)), (LPARAM) item)) + { + MSG msg; + GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE); + } + return Qt; + } + return Qnil; +} + +DEFUN ("w32-registered-hot-keys", Fw32_registered_hot_keys, Sw32_registered_hot_keys, 0, 0, 0, + "Return list of registered hot-key IDs.") + () +{ + return Fcopy_sequence (w32_grabbed_keys); +} + +DEFUN ("w32-reconstruct-hot-key", Fw32_reconstruct_hot_key, Sw32_reconstruct_hot_key, 1, 1, 0, + "Convert hot-key ID to a lisp key combination.") + (hotkeyid) + Lisp_Object hotkeyid; +{ + int vk_code, w32_modifiers; + Lisp_Object key; + + CHECK_NUMBER (hotkeyid, 0); + + vk_code = HOTKEY_VK_CODE (hotkeyid); + w32_modifiers = HOTKEY_MODIFIERS (hotkeyid); + + if (lispy_function_keys[vk_code]) + key = intern (lispy_function_keys[vk_code]); + else + key = make_number (vk_code); + + key = Fcons (key, Qnil); + if (w32_modifiers & MOD_SHIFT) + key = Fcons (Qshift, key); + if (w32_modifiers & MOD_CONTROL) + key = Fcons (Qctrl, key); + if (w32_modifiers & MOD_ALT) + key = Fcons (NILP (Vw32_alt_is_meta) ? Qalt : Qmeta, key); + if (w32_modifiers & MOD_WIN) + key = Fcons (Qhyper, key); + + return key; +} + +DEFUN ("w32-toggle-lock-key", Fw32_toggle_lock_key, Sw32_toggle_lock_key, 1, 2, 0, + "Toggle the state of the lock key KEY.\n\ +KEY can be `capslock', `kp-numlock', or `scroll'.\n\ +If the optional parameter NEW-STATE is a number, then the state of KEY\n\ +is set to off if the low bit of NEW-STATE is zero, otherwise on.") + (key, new_state) + Lisp_Object key, new_state; +{ + int vk_code; + + if (EQ (key, intern ("capslock"))) + vk_code = VK_CAPITAL; + else if (EQ (key, intern ("kp-numlock"))) + vk_code = VK_NUMLOCK; + else if (EQ (key, intern ("scroll"))) + vk_code = VK_SCROLL; + else + return Qnil; + + if (!dwWindowsThreadId) + return make_number (w32_console_toggle_lock_key (vk_code, new_state)); + + if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_TOGGLE_LOCK_KEY, + (WPARAM) vk_code, (LPARAM) new_state)) + { + MSG msg; + GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE); + return make_number (msg.wParam); + } + return Qnil; +} + +DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0, + "Return storage information about the file system FILENAME is on.\n\ +Value is a list of floats (TOTAL FREE AVAIL), where TOTAL is the total\n\ +storage of the file system, FREE is the free storage, and AVAIL is the\n\ +storage available to a non-superuser. All 3 numbers are in bytes.\n\ +If the underlying system call fails, value is nil.") + (filename) + Lisp_Object filename; +{ + Lisp_Object encoded, value; + + CHECK_STRING (filename, 0); + filename = Fexpand_file_name (filename, Qnil); + encoded = ENCODE_FILE (filename); + + value = Qnil; + + /* Determining the required information on Windows turns out, sadly, + to be more involved than one would hope. The original Win32 api + call for this will return bogus information on some systems, but we + must dynamically probe for the replacement api, since that was + added rather late on. */ + { + HMODULE hKernel = GetModuleHandle ("kernel32"); + BOOL (*pfn_GetDiskFreeSpaceEx) + (char *, PULARGE_INTEGER, PULARGE_INTEGER, PULARGE_INTEGER) + = (void *) GetProcAddress (hKernel, "GetDiskFreeSpaceEx"); + + /* On Windows, we may need to specify the root directory of the + volume holding FILENAME. */ + char rootname[MAX_PATH]; + char *name = XSTRING (encoded)->data; + + /* find the root name of the volume if given */ + if (isalpha (name[0]) && name[1] == ':') + { + rootname[0] = name[0]; + rootname[1] = name[1]; + rootname[2] = '\\'; + rootname[3] = 0; + } + else if (IS_DIRECTORY_SEP (name[0]) && IS_DIRECTORY_SEP (name[1])) + { + char *str = rootname; + int slashes = 4; + do + { + if (IS_DIRECTORY_SEP (*name) && --slashes == 0) + break; + *str++ = *name++; + } + while ( *name ); + + *str++ = '\\'; + *str = 0; + } + + if (pfn_GetDiskFreeSpaceEx) + { + LARGE_INTEGER availbytes; + LARGE_INTEGER freebytes; + LARGE_INTEGER totalbytes; + + if (pfn_GetDiskFreeSpaceEx(rootname, + &availbytes, + &totalbytes, + &freebytes)) + value = list3 (make_float ((double) totalbytes.QuadPart), + make_float ((double) freebytes.QuadPart), + make_float ((double) availbytes.QuadPart)); + } + else + { + DWORD sectors_per_cluster; + DWORD bytes_per_sector; + DWORD free_clusters; + DWORD total_clusters; + + if (GetDiskFreeSpace(rootname, + §ors_per_cluster, + &bytes_per_sector, + &free_clusters, + &total_clusters)) + value = list3 (make_float ((double) total_clusters + * sectors_per_cluster * bytes_per_sector), + make_float ((double) free_clusters + * sectors_per_cluster * bytes_per_sector), + make_float ((double) free_clusters + * sectors_per_cluster * bytes_per_sector)); + } + } + + return value; +} + +syms_of_w32fns () +{ + /* This is zero if not using MS-Windows. */ + w32_in_use = 0; + + /* The section below is built by the lisp expression at the top of the file, + just above where these variables are declared. */ + /*&&& init symbols here &&&*/ + Qauto_raise = intern ("auto-raise"); + staticpro (&Qauto_raise); Qauto_lower = intern ("auto-lower"); staticpro (&Qauto_lower); - Qbackground_color = intern ("background-color"); - staticpro (&Qbackground_color); Qbar = intern ("bar"); staticpro (&Qbar); Qborder_color = intern ("border-color"); @@ -4956,8 +13416,6 @@ syms_of_w32fns () staticpro (&Qcursor_color); Qcursor_type = intern ("cursor-type"); staticpro (&Qcursor_type); - Qforeground_color = intern ("foreground-color"); - staticpro (&Qforeground_color); Qgeometry = intern ("geometry"); staticpro (&Qgeometry); Qicon_left = intern ("icon-left"); @@ -4984,8 +13442,6 @@ syms_of_w32fns () staticpro (&Qscroll_bar_width); Qsuppress_icon = intern ("suppress-icon"); staticpro (&Qsuppress_icon); - Qtop = intern ("top"); - staticpro (&Qtop); Qundefined_color = intern ("undefined-color"); staticpro (&Qundefined_color); Qvertical_scroll_bars = intern ("vertical-scroll-bars"); @@ -5002,17 +13458,52 @@ syms_of_w32fns () staticpro (&Quser_position); Quser_size = intern ("user-size"); staticpro (&Quser_size); - Qdisplay = intern ("display"); - staticpro (&Qdisplay); + Qscreen_gamma = intern ("screen-gamma"); + staticpro (&Qscreen_gamma); + Qline_spacing = intern ("line-spacing"); + staticpro (&Qline_spacing); + Qcenter = intern ("center"); + staticpro (&Qcenter); + Qcancel_timer = intern ("cancel-timer"); + staticpro (&Qcancel_timer); /* This is the end of symbol initialization. */ + Qhyper = intern ("hyper"); + staticpro (&Qhyper); + Qsuper = intern ("super"); + staticpro (&Qsuper); + Qmeta = intern ("meta"); + staticpro (&Qmeta); + Qalt = intern ("alt"); + staticpro (&Qalt); + Qctrl = intern ("ctrl"); + staticpro (&Qctrl); + Qcontrol = intern ("control"); + staticpro (&Qcontrol); + Qshift = intern ("shift"); + staticpro (&Qshift); + + /* Text property `display' should be nonsticky by default. */ + Vtext_property_default_nonsticky + = Fcons (Fcons (Qdisplay, Qt), Vtext_property_default_nonsticky); + + + Qlaplace = intern ("laplace"); + staticpro (&Qlaplace); + + Qface_set_after_frame_default = intern ("face-set-after-frame-default"); + staticpro (&Qface_set_after_frame_default); + Fput (Qundefined_color, Qerror_conditions, Fcons (Qundefined_color, Fcons (Qerror, Qnil))); Fput (Qundefined_color, Qerror_message, build_string ("Undefined color")); + staticpro (&w32_grabbed_keys); + w32_grabbed_keys = Qnil; + DEFVAR_LISP ("w32-color-map", &Vw32_color_map, - "A array of color name mappings for windows."); + "An array of color name mappings for windows."); Vw32_color_map = Qnil; DEFVAR_LISP ("w32-pass-alt-to-system", &Vw32_pass_alt_to_system, @@ -5026,23 +13517,89 @@ open the System menu. When nil, Emacs silently swallows alt key events."); When nil, Emacs will translate the alt key to the Alt modifier, and not Meta."); Vw32_alt_is_meta = Qt; - DEFVAR_LISP ("w32-pass-optional-keys-to-system", - &Vw32_pass_optional_keys_to_system, - "Non-nil if the 'optional' keys (left window, right window,\n\ -and application keys) are passed on to Windows."); - Vw32_pass_optional_keys_to_system = Qnil; - - DEFVAR_LISP ("w32-enable-italics", &Vw32_enable_italics, - "Non-nil enables selection of artificially italicized fonts."); - Vw32_enable_italics = Qnil; + DEFVAR_INT ("w32-quit-key", &Vw32_quit_key, + "If non-zero, the virtual key code for an alternative quit key."); + XSETINT (Vw32_quit_key, 0); + + DEFVAR_LISP ("w32-pass-lwindow-to-system", + &Vw32_pass_lwindow_to_system, + "Non-nil if the left \"Windows\" key is passed on to Windows.\n\ +When non-nil, the Start menu is opened by tapping the key."); + Vw32_pass_lwindow_to_system = Qt; + + DEFVAR_LISP ("w32-pass-rwindow-to-system", + &Vw32_pass_rwindow_to_system, + "Non-nil if the right \"Windows\" key is passed on to Windows.\n\ +When non-nil, the Start menu is opened by tapping the key."); + Vw32_pass_rwindow_to_system = Qt; + + DEFVAR_INT ("w32-phantom-key-code", + &Vw32_phantom_key_code, + "Virtual key code used to generate \"phantom\" key presses.\n\ +Value is a number between 0 and 255.\n\ +\n\ +Phantom key presses are generated in order to stop the system from\n\ +acting on \"Windows\" key events when `w32-pass-lwindow-to-system' or\n\ +`w32-pass-rwindow-to-system' is nil."); + /* Although 255 is technically not a valid key code, it works and + means that this hack won't interfere with any real key code. */ + Vw32_phantom_key_code = 255; + + DEFVAR_LISP ("w32-enable-num-lock", + &Vw32_enable_num_lock, + "Non-nil if Num Lock should act normally.\n\ +Set to nil to see Num Lock as the key `kp-numlock'."); + Vw32_enable_num_lock = Qt; + + DEFVAR_LISP ("w32-enable-caps-lock", + &Vw32_enable_caps_lock, + "Non-nil if Caps Lock should act normally.\n\ +Set to nil to see Caps Lock as the key `capslock'."); + Vw32_enable_caps_lock = Qt; + + DEFVAR_LISP ("w32-scroll-lock-modifier", + &Vw32_scroll_lock_modifier, + "Modifier to use for the Scroll Lock on state.\n\ +The value can be hyper, super, meta, alt, control or shift for the\n\ +respective modifier, or nil to see Scroll Lock as the key `scroll'.\n\ +Any other value will cause the key to be ignored."); + Vw32_scroll_lock_modifier = Qt; + + DEFVAR_LISP ("w32-lwindow-modifier", + &Vw32_lwindow_modifier, + "Modifier to use for the left \"Windows\" key.\n\ +The value can be hyper, super, meta, alt, control or shift for the\n\ +respective modifier, or nil to appear as the key `lwindow'.\n\ +Any other value will cause the key to be ignored."); + Vw32_lwindow_modifier = Qnil; + + DEFVAR_LISP ("w32-rwindow-modifier", + &Vw32_rwindow_modifier, + "Modifier to use for the right \"Windows\" key.\n\ +The value can be hyper, super, meta, alt, control or shift for the\n\ +respective modifier, or nil to appear as the key `rwindow'.\n\ +Any other value will cause the key to be ignored."); + Vw32_rwindow_modifier = Qnil; + + DEFVAR_LISP ("w32-apps-modifier", + &Vw32_apps_modifier, + "Modifier to use for the \"Apps\" key.\n\ +The value can be hyper, super, meta, alt, control or shift for the\n\ +respective modifier, or nil to appear as the key `apps'.\n\ +Any other value will cause the key to be ignored."); + Vw32_apps_modifier = Qnil; + + DEFVAR_LISP ("w32-enable-synthesized-fonts", &Vw32_enable_synthesized_fonts, + "Non-nil enables selection of artificially italicized and bold fonts."); + Vw32_enable_synthesized_fonts = Qnil; DEFVAR_LISP ("w32-enable-palette", &Vw32_enable_palette, - "Non-nil enables Windows palette management to map colors exactly."); + "Non-nil enables Windows palette management to map colors exactly."); Vw32_enable_palette = Qt; DEFVAR_INT ("w32-mouse-button-tolerance", &Vw32_mouse_button_tolerance, - "Analogue of double click interval for faking middle mouse events.\n\ + "Analogue of double click interval for faking middle mouse events.\n\ The value is the minimum time in milliseconds that must elapse between\n\ left/right button down events before they are considered distinct events.\n\ If both mouse buttons are depressed within this interval, a middle mouse\n\ @@ -5055,7 +13612,7 @@ button down event is generated instead."); The value is the minimum time in milliseconds that must elapse between\n\ successive mouse move (or scroll bar drag) events before they are\n\ reported as lisp events."); - XSETINT (Vw32_mouse_move_interval, 50); + XSETINT (Vw32_mouse_move_interval, 0); init_x_parm_symbols (); @@ -5082,13 +13639,35 @@ switches, if present."); Vx_mode_pointer_shape = Qnil; - DEFVAR_INT ("x-sensitive-text-pointer-shape", + DEFVAR_LISP ("x-hourglass-pointer-shape", &Vx_hourglass_pointer_shape, + "The shape of the pointer when Emacs is busy.\n\ +This variable takes effect when you create a new frame\n\ +or when you set the mouse color."); + Vx_hourglass_pointer_shape = Qnil; + + DEFVAR_BOOL ("display-hourglass", &display_hourglass_p, + "Non-zero means Emacs displays an hourglass pointer on window systems."); + display_hourglass_p = 1; + + DEFVAR_LISP ("hourglass-delay", &Vhourglass_delay, + "*Seconds to wait before displaying an hourglass pointer.\n\ +Value must be an integer or float."); + Vhourglass_delay = make_number (DEFAULT_HOURGLASS_DELAY); + + DEFVAR_LISP ("x-sensitive-text-pointer-shape", &Vx_sensitive_text_pointer_shape, "The shape of the pointer when over mouse-sensitive text.\n\ This variable takes effect when you create a new frame\n\ or when you set the mouse color."); Vx_sensitive_text_pointer_shape = Qnil; + DEFVAR_LISP ("x-window-horizontal-drag-cursor", + &Vx_window_horizontal_drag_shape, + "Pointer shape to use for indicating a window can be dragged horizontally.\n\ +This variable takes effect when you create a new frame\n\ +or when you set the mouse color."); + Vx_window_horizontal_drag_shape = Qnil; + DEFVAR_LISP ("x-cursor-fore-pixel", &Vx_cursor_fore_pixel, "A string indicating the foreground color of the cursor box."); Vx_cursor_fore_pixel = Qnil; @@ -5101,12 +13680,143 @@ unless you set it to something else."); and maybe the user would like to set it to t. */ Vx_no_window_manager = Qnil; + DEFVAR_LISP ("x-pixel-size-width-font-regexp", + &Vx_pixel_size_width_font_regexp, + "Regexp matching a font name whose width is the same as `PIXEL_SIZE'.\n\ +\n\ +Since Emacs gets width of a font matching with this regexp from\n\ +PIXEL_SIZE field of the name, font finding mechanism gets faster for\n\ +such a font. This is especially effective for such large fonts as\n\ +Chinese, Japanese, and Korean."); + Vx_pixel_size_width_font_regexp = Qnil; + + DEFVAR_LISP ("image-cache-eviction-delay", &Vimage_cache_eviction_delay, + "Time after which cached images are removed from the cache.\n\ +When an image has not been displayed this many seconds, remove it\n\ +from the image cache. Value must be an integer or nil with nil\n\ +meaning don't clear the cache."); + Vimage_cache_eviction_delay = make_number (30 * 60); + + DEFVAR_LISP ("w32-bdf-filename-alist", + &Vw32_bdf_filename_alist, + "List of bdf fonts and their corresponding filenames."); + Vw32_bdf_filename_alist = Qnil; + + DEFVAR_BOOL ("w32-strict-fontnames", + &w32_strict_fontnames, + "Non-nil means only use fonts that are exact matches for those requested.\n\ +Default is nil, which allows old fontnames that are not XLFD compliant,\n\ +and allows third-party CJK display to work by specifying false charset\n\ +fields to trick Emacs into translating to Big5, SJIS etc.\n\ +Setting this to t will prevent wrong fonts being selected when\n\ +fontsets are automatically created."); + w32_strict_fontnames = 0; + + DEFVAR_BOOL ("w32-strict-painting", + &w32_strict_painting, + "Non-nil means use strict rules for repainting frames.\n\ +Set this to nil to get the old behaviour for repainting; this should\n\ +only be necessary if the default setting causes problems."); + w32_strict_painting = 1; + + DEFVAR_LISP ("w32-system-coding-system", + &Vw32_system_coding_system, + "Coding system used by Windows system functions, such as for font names."); + Vw32_system_coding_system = Qnil; + + DEFVAR_LISP ("w32-charset-info-alist", + &Vw32_charset_info_alist, + "Alist linking Emacs character sets to Windows fonts\n\ +and codepages. Each entry should be of the form:\n\ +\n\ + (CHARSET_NAME . (WINDOWS_CHARSET . CODEPAGE))\n\ +\n\ +where CHARSET_NAME is a string used in font names to identify the charset,\n\ +WINDOWS_CHARSET is a symbol that can be one of:\n\ +w32-charset-ansi, w32-charset-default, w32-charset-symbol,\n\ +w32-charset-shiftjis, w32-charset-hangeul, w32-charset-gb2312,\n\ +w32-charset-chinesebig5, " +#ifdef JOHAB_CHARSET +"w32-charset-johab, w32-charset-hebrew,\n\ +w32-charset-arabic, w32-charset-greek, w32-charset-turkish,\n\ +w32-charset-vietnamese, w32-charset-thai, w32-charset-easteurope,\n\ +w32-charset-russian, w32-charset-mac, w32-charset-baltic,\n" +#endif +#ifdef UNICODE_CHARSET +"w32-charset-unicode, " +#endif +"or w32-charset-oem.\n\ +CODEPAGE should be an integer specifying the codepage that should be used\n\ +to display the character set, t to do no translation and output as Unicode,\n\ +or nil to do no translation and output as 8 bit (or multibyte on far-east\n\ +versions of Windows) characters."); + Vw32_charset_info_alist = Qnil; + + staticpro (&Qw32_charset_ansi); + Qw32_charset_ansi = intern ("w32-charset-ansi"); + staticpro (&Qw32_charset_symbol); + Qw32_charset_symbol = intern ("w32-charset-symbol"); + staticpro (&Qw32_charset_shiftjis); + Qw32_charset_shiftjis = intern ("w32-charset-shiftjis"); + staticpro (&Qw32_charset_hangeul); + Qw32_charset_hangeul = intern ("w32-charset-hangeul"); + staticpro (&Qw32_charset_chinesebig5); + Qw32_charset_chinesebig5 = intern ("w32-charset-chinesebig5"); + staticpro (&Qw32_charset_gb2312); + Qw32_charset_gb2312 = intern ("w32-charset-gb2312"); + staticpro (&Qw32_charset_oem); + Qw32_charset_oem = intern ("w32-charset-oem"); + +#ifdef JOHAB_CHARSET + { + static int w32_extra_charsets_defined = 1; + DEFVAR_BOOL ("w32-extra-charsets-defined", &w32_extra_charsets_defined, ""); + + staticpro (&Qw32_charset_johab); + Qw32_charset_johab = intern ("w32-charset-johab"); + staticpro (&Qw32_charset_easteurope); + Qw32_charset_easteurope = intern ("w32-charset-easteurope"); + staticpro (&Qw32_charset_turkish); + Qw32_charset_turkish = intern ("w32-charset-turkish"); + staticpro (&Qw32_charset_baltic); + Qw32_charset_baltic = intern ("w32-charset-baltic"); + staticpro (&Qw32_charset_russian); + Qw32_charset_russian = intern ("w32-charset-russian"); + staticpro (&Qw32_charset_arabic); + Qw32_charset_arabic = intern ("w32-charset-arabic"); + staticpro (&Qw32_charset_greek); + Qw32_charset_greek = intern ("w32-charset-greek"); + staticpro (&Qw32_charset_hebrew); + Qw32_charset_hebrew = intern ("w32-charset-hebrew"); + staticpro (&Qw32_charset_vietnamese); + Qw32_charset_vietnamese = intern ("w32-charset-vietnamese"); + staticpro (&Qw32_charset_thai); + Qw32_charset_thai = intern ("w32-charset-thai"); + staticpro (&Qw32_charset_mac); + Qw32_charset_mac = intern ("w32-charset-mac"); + } +#endif + +#ifdef UNICODE_CHARSET + { + static int w32_unicode_charset_defined = 1; + DEFVAR_BOOL ("w32-unicode-charset-defined", + &w32_unicode_charset_defined, ""); + + staticpro (&Qw32_charset_unicode); + Qw32_charset_unicode = intern ("w32-charset-unicode"); +#endif + defsubr (&Sx_get_resource); - defsubr (&Sx_list_fonts); - defsubr (&Sx_display_color_p); +#if 0 /* TODO: Port to W32 */ + defsubr (&Sx_change_window_property); + defsubr (&Sx_delete_window_property); + defsubr (&Sx_window_property); +#endif + defsubr (&Sxw_display_color_p); defsubr (&Sx_display_grayscale_p); - defsubr (&Sx_color_defined_p); - defsubr (&Sx_color_values); + defsubr (&Sxw_color_defined_p); + defsubr (&Sxw_color_values); defsubr (&Sx_server_max_request_size); defsubr (&Sx_server_vendor); defsubr (&Sx_server_version); @@ -5122,8 +13832,6 @@ unless you set it to something else."); defsubr (&Sx_display_save_under); defsubr (&Sx_parse_geometry); defsubr (&Sx_create_frame); - defsubr (&Sfocus_frame); - defsubr (&Sunfocus_frame); defsubr (&Sx_open_connection); defsubr (&Sx_close_connection); defsubr (&Sx_display_list); @@ -5131,10 +13839,148 @@ unless you set it to something else."); /* W32 specific functions */ + defsubr (&Sw32_focus_frame); defsubr (&Sw32_select_font); defsubr (&Sw32_define_rgb_color); defsubr (&Sw32_default_color_map); defsubr (&Sw32_load_color_file); + defsubr (&Sw32_send_sys_command); + defsubr (&Sw32_shell_execute); + defsubr (&Sw32_register_hot_key); + defsubr (&Sw32_unregister_hot_key); + defsubr (&Sw32_registered_hot_keys); + defsubr (&Sw32_reconstruct_hot_key); + defsubr (&Sw32_toggle_lock_key); + defsubr (&Sw32_find_bdf_fonts); + + defsubr (&Sfile_system_info); + + /* Setting callback functions for fontset handler. */ + get_font_info_func = w32_get_font_info; + +#if 0 /* This function pointer doesn't seem to be used anywhere. + And the pointer assigned has the wrong type, anyway. */ + list_fonts_func = w32_list_fonts; +#endif + + load_font_func = w32_load_font; + find_ccl_program_func = w32_find_ccl_program; + query_font_func = w32_query_font; + set_frame_fontset_func = x_set_font; + check_window_system_func = check_w32; + +#if 0 /* TODO Image support for W32 */ + /* Images. */ + Qxbm = intern ("xbm"); + staticpro (&Qxbm); + QCtype = intern (":type"); + staticpro (&QCtype); + QCconversion = intern (":conversion"); + staticpro (&QCconversion); + QCheuristic_mask = intern (":heuristic-mask"); + staticpro (&QCheuristic_mask); + QCcolor_symbols = intern (":color-symbols"); + staticpro (&QCcolor_symbols); + QCascent = intern (":ascent"); + staticpro (&QCascent); + QCmargin = intern (":margin"); + staticpro (&QCmargin); + QCrelief = intern (":relief"); + staticpro (&QCrelief); + Qpostscript = intern ("postscript"); + staticpro (&Qpostscript); + QCloader = intern (":loader"); + staticpro (&QCloader); + QCbounding_box = intern (":bounding-box"); + staticpro (&QCbounding_box); + QCpt_width = intern (":pt-width"); + staticpro (&QCpt_width); + QCpt_height = intern (":pt-height"); + staticpro (&QCpt_height); + QCindex = intern (":index"); + staticpro (&QCindex); + Qpbm = intern ("pbm"); + staticpro (&Qpbm); + +#if HAVE_XPM + Qxpm = intern ("xpm"); + staticpro (&Qxpm); +#endif + +#if HAVE_JPEG + Qjpeg = intern ("jpeg"); + staticpro (&Qjpeg); +#endif + +#if HAVE_TIFF + Qtiff = intern ("tiff"); + staticpro (&Qtiff); +#endif + +#if HAVE_GIF + Qgif = intern ("gif"); + staticpro (&Qgif); +#endif + +#if HAVE_PNG + Qpng = intern ("png"); + staticpro (&Qpng); +#endif + + defsubr (&Sclear_image_cache); + +#if GLYPH_DEBUG + defsubr (&Simagep); + defsubr (&Slookup_image); +#endif +#endif /* TODO */ + + hourglass_atimer = NULL; + hourglass_shown_p = 0; +#ifdef TODO /* Tooltip support not complete. */ + defsubr (&Sx_show_tip); + defsubr (&Sx_hide_tip); +#endif + tip_timer = Qnil; + staticpro (&tip_timer); + tip_frame = Qnil; + staticpro (&tip_frame); + + defsubr (&Sx_file_dialog); +} + + +void +init_xfns () +{ + image_types = NULL; + Vimage_types = Qnil; + +#if 0 /* TODO : Image support for W32 */ + define_image_type (&xbm_type); + define_image_type (&gs_type); + define_image_type (&pbm_type); + +#if HAVE_XPM + define_image_type (&xpm_type); +#endif + +#if HAVE_JPEG + define_image_type (&jpeg_type); +#endif + +#if HAVE_TIFF + define_image_type (&tiff_type); +#endif + +#if HAVE_GIF + define_image_type (&gif_type); +#endif + +#if HAVE_PNG + define_image_type (&png_type); +#endif +#endif /* TODO */ } #undef abort @@ -5163,3 +14009,9 @@ w32_abort() } } +/* For convenience when debugging. */ +int +w32_last_error() +{ + return GetLastError (); +}