This is glyphs-x.c in view mode; [Download] [Up]
/* X-specific Lisp objects.
Copyright (C) 1993, 1994 Free Software Foundation, Inc.
Copyright (C) 1995 Board of Trustees, University of Illinois
Copyright (C) 1995 Tinker Systems
Copyright (C) 1995 Ben Wing
Copyright (C) 1995 Sun Microsystems
This file is part of XEmacs.
XEmacs is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.
XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING. If not, write to the Free
Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
/* Synched up with: Not in FSF. */
/* Original author: Jamie Zawinski for 19.8
font-truename stuff added by Jamie Zawinski for 19.10
subwindow support added by Chuck Thompson
additional XPM support added by Chuck Thompson
initial X-Face support added by Stig
rewritten/restructured by Ben Wing for 19.12/19.13
*/
#include <config.h>
#include "lisp.h"
#include "device-x.h"
#include "frame-x.h"
#include "glyphs-x.h"
#include "objects-x.h"
#include "xmu.h"
#include "buffer.h"
#include "insdel.h"
#include "sysfile.h"
/* #### This isn't going to be sufficient if we ever want to handle
multiple screens on a single display. */
#define LISP_DEVICE_TO_X_SCREEN(dev) \
XDefaultScreenOfDisplay (DEVICE_X_DISPLAY (XDEVICE (dev)))
DEFINE_IMAGE_INSTANTIATOR_TYPE (xbm);
Lisp_Object Qxbm;
Lisp_Object Q_mask_file, Q_mask_data, Q_hotspot_x, Q_hotspot_y;
Lisp_Object Q_foreground, Q_background;
#ifdef HAVE_XPM
DEFINE_IMAGE_INSTANTIATOR_TYPE (xpm);
Lisp_Object Qxpm;
Lisp_Object Q_color_symbols;
#endif
#ifdef HAVE_XFACE
DEFINE_IMAGE_INSTANTIATOR_TYPE (xface);
Lisp_Object Qxface;
#endif
#ifdef HAVE_JPEG
DEFINE_IMAGE_INSTANTIATOR_TYPE (jpeg);
Lisp_Object Qjpeg;
#endif
#ifdef HAVE_PNG
DEFINE_IMAGE_INSTANTIATOR_TYPE (png);
Lisp_Object Qpng;
#endif
#ifdef HAVE_GIF
DEFINE_IMAGE_INSTANTIATOR_TYPE (gif);
Lisp_Object Qgif;
#endif
DEFINE_IMAGE_INSTANTIATOR_TYPE (autodetect);
Lisp_Object Qautodetect;
#include "bitmaps.h"
/************************************************************************/
/* image instance methods */
/************************************************************************/
static void
x_print_image_instance (struct Lisp_Image_Instance *p,
Lisp_Object printcharfun,
int escapeflag)
{
char buf[100];
switch (IMAGE_INSTANCE_TYPE (p))
{
case IMAGE_MONO_PIXMAP:
case IMAGE_COLOR_PIXMAP:
case IMAGE_CURSOR:
sprintf (buf, " (0x%lx", (unsigned long) IMAGE_INSTANCE_X_PIXMAP (p));
write_c_string (buf, printcharfun);
if (IMAGE_INSTANCE_X_MASK (p))
{
sprintf (buf, "/0x%lx", (unsigned long) IMAGE_INSTANCE_X_MASK (p));
write_c_string (buf, printcharfun);
}
write_c_string (")", printcharfun);
break;
case IMAGE_SUBWINDOW:
/* #### implement me */
default:
break;
}
}
static void
x_finalize_image_instance (struct Lisp_Image_Instance *p)
{
Screen *scr = LISP_DEVICE_TO_X_SCREEN (IMAGE_INSTANCE_DEVICE (p));
if (!p->data)
return;
if (IMAGE_INSTANCE_X_PIXMAP (p))
XFreePixmap (DisplayOfScreen (scr), IMAGE_INSTANCE_X_PIXMAP (p));
if (IMAGE_INSTANCE_X_MASK (p) &&
IMAGE_INSTANCE_X_MASK (p) != IMAGE_INSTANCE_X_PIXMAP (p))
XFreePixmap (DisplayOfScreen (scr), IMAGE_INSTANCE_X_MASK (p));
IMAGE_INSTANCE_X_PIXMAP (p) = 0;
IMAGE_INSTANCE_X_MASK (p) = 0;
if (IMAGE_INSTANCE_X_CURSOR (p))
{
XFreeCursor (DisplayOfScreen (scr), IMAGE_INSTANCE_X_CURSOR (p));
IMAGE_INSTANCE_X_CURSOR (p) = 0;
}
if (IMAGE_INSTANCE_X_NPIXELS (p) != 0)
{
XFreeColors (DisplayOfScreen (scr),
DefaultColormapOfScreen (scr),
IMAGE_INSTANCE_X_PIXELS (p),
IMAGE_INSTANCE_X_NPIXELS (p), 0);
IMAGE_INSTANCE_X_NPIXELS (p) = 0;
}
if (IMAGE_INSTANCE_X_PIXELS (p))
{
xfree (IMAGE_INSTANCE_X_PIXELS (p));
IMAGE_INSTANCE_X_PIXELS (p) = 0;
}
xfree (p->data);
p->data = 0;
}
static int
x_image_instance_equal (struct Lisp_Image_Instance *p1,
struct Lisp_Image_Instance *p2, int depth)
{
switch (IMAGE_INSTANCE_TYPE (p1))
{
case IMAGE_MONO_PIXMAP:
case IMAGE_COLOR_PIXMAP:
case IMAGE_CURSOR:
if (IMAGE_INSTANCE_X_NPIXELS (p1) != IMAGE_INSTANCE_X_NPIXELS (p2))
return 0;
break;
case IMAGE_SUBWINDOW:
/* #### implement me */
break;
default:
break;
}
return 1;
}
static unsigned long
x_image_instance_hash (struct Lisp_Image_Instance *p, int depth)
{
switch (IMAGE_INSTANCE_TYPE (p))
{
case IMAGE_MONO_PIXMAP:
case IMAGE_COLOR_PIXMAP:
case IMAGE_CURSOR:
return IMAGE_INSTANCE_X_NPIXELS (p);
case IMAGE_SUBWINDOW:
/* #### implement me */
return 0;
default:
return 0;
}
}
/************************************************************************/
/* image instance utility functions */
/************************************************************************/
/* Where bitmaps are; initialized from resource database */
Lisp_Object Vx_bitmap_file_path;
#ifndef BITMAPDIR
#define BITMAPDIR "/usr/include/X11/bitmaps"
#endif
#define USE_XBMLANGPATH
/* Given a pixmap filename, look through all of the "standard" places
where the file might be located. Return a full pathname if found;
otherwise, return Qnil. */
static Lisp_Object
locate_pixmap_file (Lisp_Object name)
{
/* This function can GC if IN_REDISPLAY is false */
Display *display;
/* Check non-absolute pathnames with a directory component relative to
the search path; that's the way Xt does it. */
/* #### Unix-specific */
if (string_byte (XSTRING (name), 0) == '/' ||
(string_byte (XSTRING (name), 0) == '.' &&
(string_byte (XSTRING (name), 1) == '/' ||
(string_byte (XSTRING (name), 1) == '.' &&
(string_byte (XSTRING (name), 2) == '/')))))
{
if (!NILP (Ffile_readable_p (name)))
return name;
else
return Qnil;
}
if (NILP (Vdefault_x_device))
/* This may occur during intialization. */
return Qnil;
else
/* We only check the bitmapFilePath resource on the original X device. */
display = DEVICE_X_DISPLAY (XDEVICE (Vdefault_x_device));
#ifdef USE_XBMLANGPATH
{
char *path = egetenv ("XBMLANGPATH");
SubstitutionRec subs[1];
subs[0].match = 'B';
subs[0].substitution = (char *) string_data (XSTRING (name));
/* #### Motif uses a big hairy default if $XBMLANGPATH isn't set.
We don't. If you want it used, set it. */
if (path &&
(path = XtResolvePathname (display, "bitmaps", 0, 0, path,
subs, XtNumber (subs), 0)))
{
name = build_string (path);
XtFree (path);
return (name);
}
}
#endif
if (NILP (Vx_bitmap_file_path))
{
char *type = 0;
XrmValue value;
if (XrmGetResource (XtDatabase (display),
"bitmapFilePath", "BitmapFilePath", &type, &value)
&& !strcmp (type, "String"))
Vx_bitmap_file_path = decode_env_path (0, (char *) value.addr);
Vx_bitmap_file_path = nconc2 (Vx_bitmap_file_path,
(list1 (build_string (BITMAPDIR))));
}
{
Lisp_Object found;
if (locate_file (Vx_bitmap_file_path, name, "", &found, R_OK) < 0)
{
Lisp_Object temp = list1 (Vdata_directory);
struct gcpro gcpro1;
GCPRO1 (temp);
locate_file (temp, name, "", &found, R_OK);
UNGCPRO;
}
return found;
}
}
/* If INST refers to inline data, return Qnil.
If INST refers to data in a file, return the full filename
if it exists; otherwise, return t. */
static Lisp_Object
potential_pixmap_file_instantiator (Lisp_Object inst,
Lisp_Object file_keyword,
Lisp_Object data_keyword)
{
Lisp_Object file;
Lisp_Object data;
assert (VECTORP (inst));
data = find_keyword_in_vector (inst, data_keyword);
file = find_keyword_in_vector (inst, file_keyword);
if (!NILP (file) && NILP (data))
{
Lisp_Object retval = locate_pixmap_file (file);
if (!NILP (retval))
return retval;
else
return Qt; /* should have been file */
}
return Qnil;
}
static void
x_initialize_pixmap_image_instance (struct Lisp_Image_Instance *ii)
{
ii->data = malloc_type_and_zero (struct x_image_instance_data);
IMAGE_INSTANCE_TYPE (ii) = IMAGE_MONO_PIXMAP;
IMAGE_INSTANCE_PIXMAP_FILENAME (ii) = Qnil;
IMAGE_INSTANCE_PIXMAP_MASK_FILENAME (ii) = Qnil;
IMAGE_INSTANCE_PIXMAP_WIDTH (ii) = 0;
IMAGE_INSTANCE_PIXMAP_HEIGHT (ii) = 0;
IMAGE_INSTANCE_PIXMAP_DEPTH (ii) = 0;
IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (ii) = Qnil;
IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (ii) = Qnil;
}
/* Check that this server supports cursors of this size. */
static int
check_pointer_sizes (Screen *xs, unsigned int width, unsigned int height,
Lisp_Object instantiator, int no_error)
{
unsigned int best_width, best_height;
if (! XQueryBestCursor (DisplayOfScreen (xs), RootWindowOfScreen (xs),
width, height, &best_width, &best_height))
/* #### What does it mean when XQueryBestCursor() returns 0?
I can't find that documented anywhere. */
best_width = best_height = 0;
if (width > best_width || height > best_height)
{
if (!no_error)
{
char buf [255];
sprintf (buf, "cursor too large (%dx%d): "
"server requires %dx%d or smaller",
width, height, best_width, best_height);
signal_error (Qerror, list2 (build_string (buf), instantiator));
}
return 0;
}
return 1;
}
/**********************************************************************
* XBM *
**********************************************************************/
/* Check if DATA represents a valid inline XBM spec (i.e. a cons
of (width height bits), with checking done on the dimensions).
If so, return 1. If not, return 0 if NO_ERROR is non-zero;
otherwise, signal an error. */
static int
valid_xbm_inline_p (Lisp_Object data, int no_error)
{
Lisp_Object width, height, bits;
if (!CONSP (data))
{
if (!no_error)
CHECK_CONS (data, 0);
return 0;
}
if (!CONSP (XCDR (data)) || !CONSP (XCDR (XCDR (data))) ||
!NILP (XCDR (XCDR (XCDR (data)))))
{
if (!no_error)
signal_simple_error ("Must be list of 3 elements", data);
return 0;
}
width = XCAR (data);
height = XCAR (XCDR (data));
bits = XCAR (XCDR (XCDR (data)));
if (!INTP (width) || !INTP (height) || !STRINGP (bits))
{
if (!no_error)
signal_simple_error ("Must be (width height bits)",
vector3 (width, height, bits));
return 0;
}
if (XINT (width) <= 0)
{
if (!no_error)
signal_simple_error ("Width must be > 0", width);
return 0;
}
if (XINT (height) <= 0)
{
if (!no_error)
signal_simple_error ("Height must be > 0", height);
return 0;
}
if (((unsigned) (XINT (width) * XINT (height)) / 8)
> string_length (XSTRING (bits)))
{
if (!no_error)
signal_simple_error ("data is too short for W and H",
vector3 (width, height, bits));
return 0;
}
return 1;
}
/* Validate method for XBM's. */
static int
xbm_validate (Lisp_Object instantiator, int no_error)
{
return file_or_data_must_be_present (instantiator, no_error);
}
/* Given a filename that is supposed to contain XBM data, return
the inline representation of it as (width height bits). Return
the hotspot through XHOT and YHOT, if those pointers are not 0.
If there is no hotspot, XHOT and YHOT will contain -1.
If the function fails:
-- if OK_IF_DATA_INVALID is set and the data was invalid,
return Qt.
-- if NO_ERROR is set, return Qnil.
-- otherwise, signal an error.
*/
static Lisp_Object
bitmap_to_lisp_data (Lisp_Object name, int *xhot, int *yhot, int no_error,
int ok_if_data_invalid)
{
unsigned int w, h;
Bufbyte *data;
int result;
result = XmuReadBitmapDataFromFile ((char *) string_data (XSTRING (name)),
&w, &h, &data, xhot, yhot);
if (result == BitmapSuccess)
{
Lisp_Object retval;
int len = (w + 7) / 8 * h;
retval = list3 (make_number (w), make_number (h),
make_string (data, len));
XFree ((char *) data);
return retval;
}
switch (result)
{
case BitmapOpenFailed:
{
if (!no_error)
/* should never happen */
signal_double_file_error ("Opening bitmap file",
"no such file or directory",
name);
break;
}
case BitmapFileInvalid:
{
if (ok_if_data_invalid)
return Qt;
if (!no_error)
signal_double_file_error ("Reading bitmap file",
"invalid data in file",
name);
break;
}
case BitmapNoMemory:
{
if (!no_error)
signal_double_file_error ("Reading bitmap file",
"out of memory",
name);
break;
}
default:
{
if (!no_error)
signal_double_file_error_2 ("Reading bitmap file",
"unknown error code",
make_number (result), name);
break;
}
}
return Qnil;
}
/* Normalize method for XBM's. */
static Lisp_Object
xbm_normalize (Lisp_Object inst, Lisp_Object device_type, int no_error)
{
Lisp_Object file = Qnil, mask_file = Qnil;
struct gcpro gcpro1, gcpro2, gcpro3;
Lisp_Object alist = Qnil;
GCPRO3 (file, mask_file, alist);
/* Now, convert any file data into inline data for both the regular
data and the mask data. At the end of this, `data' will contain
the inline data (if any) or Qnil, and `file' will contain
the name this data was derived from (if known) or Qnil.
Likewise for `mask_file' and `mask_data'.
Note that if we cannot generate any regular inline data, we
skip out. */
file = potential_pixmap_file_instantiator (inst, Q_file, Q_data);
mask_file = potential_pixmap_file_instantiator (inst, Q_mask_file,
Q_mask_data);
if (EQ (file, Qt)) /* failure locating filename */
{
if (!no_error)
signal_double_file_error ("Opening bitmap file",
"no such file or directory",
file);
RETURN_UNGCPRO (Qnil);
}
if (NILP (file) && NILP (mask_file)) /* no conversion necessary */
RETURN_UNGCPRO (inst);
alist = tagged_vector_to_alist (inst);
if (!NILP (file))
{
int xhot, yhot;
Lisp_Object data = bitmap_to_lisp_data (file, &xhot, &yhot, no_error, 0);
if (NILP (data)) /* conversion failure; error should
already be signalled. */
RETURN_UNGCPRO (Qnil);
alist = remassq_no_quit (Q_file, alist);
/* there can't be a :data at this point. */
alist = Fcons (Fcons (Q_file, file),
Fcons (Fcons (Q_data, data), alist));
if (xhot != -1 && NILP (assq_no_quit (Q_hotspot_x, alist)))
alist = Fcons (Fcons (Q_hotspot_x, make_number (xhot)),
alist);
if (yhot != -1 && NILP (assq_no_quit (Q_hotspot_y, alist)))
alist = Fcons (Fcons (Q_hotspot_y, make_number (yhot)),
alist);
}
if (!NILP (mask_file))
{
Lisp_Object mask_data =
bitmap_to_lisp_data (mask_file, 0, 0, no_error, 0);
alist = remassq_no_quit (Q_mask_file, alist);
/* there can't be a :mask-data at this point. */
alist = Fcons (Fcons (Q_mask_file, mask_file),
Fcons (Fcons (Q_mask_data, mask_data), alist));
}
{
Lisp_Object result = alist_to_tagged_vector (Qxbm, alist);
free_alist (alist);
RETURN_UNGCPRO (result);
}
}
/* Given inline data for a mono pixmap, create and return the
corresponding X object. */
static Pixmap
pixmap_from_xbm_inline (Lisp_Object device, int width, int height,
char *bits)
{
Screen *screen = LISP_DEVICE_TO_X_SCREEN (device);
return XCreatePixmapFromBitmapData (DisplayOfScreen (screen),
RootWindowOfScreen (screen),
bits, width, height,
1, 0, 1);
}
/* Given inline data for a mono pixmap, initialize the given
image instance accordingly. */
static int
init_image_instance_from_xbm_inline (struct Lisp_Image_Instance *ii,
int width, int height,
unsigned char *bits,
Lisp_Object instantiator,
int dest_mask,
Pixmap mask,
Lisp_Object mask_filename,
int no_error)
{
Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii);
Lisp_Object foreground = find_keyword_in_vector (instantiator, Q_foreground);
Lisp_Object background = find_keyword_in_vector (instantiator, Q_background);
Display *dpy = DEVICE_X_DISPLAY (XDEVICE (device));
Screen *scr = DefaultScreenOfDisplay (dpy);
int free_count = 0;
unsigned long pixels_to_free[2];
enum image_instance_type type;
/* #### Hey Ben! Something is really screwy here. It is possible
to get in here with dest_mask == ~0 (anything). Even in a case
like this:
[xbm :file "/foo/bar/baz"]
and in that case this used to pick it up as a cursor because that
was the first check. Way bogus. For now I've moved the cursor
check to the end. I think that maybe there should be some
additional checks being made about setting dest_mask somewhere up
the call chain, though. */
if ((dest_mask & IMAGE_MONO_PIXMAP_MASK) &&
(dest_mask & IMAGE_COLOR_PIXMAP_MASK))
{
if (!NILP (foreground) || !NILP (background))
type = IMAGE_COLOR_PIXMAP;
else
type = IMAGE_MONO_PIXMAP;
}
else if (dest_mask & IMAGE_MONO_PIXMAP_MASK)
type = IMAGE_MONO_PIXMAP;
else if (dest_mask & IMAGE_COLOR_PIXMAP_MASK)
type = IMAGE_COLOR_PIXMAP;
else if (dest_mask & IMAGE_CURSOR_MASK)
type = IMAGE_CURSOR;
else
{
if (!no_error)
signal_simple_error ("No compatible image-instance types given",
instantiator);
return 0;
}
x_initialize_pixmap_image_instance (ii);
IMAGE_INSTANCE_PIXMAP_WIDTH (ii) = width;
IMAGE_INSTANCE_PIXMAP_HEIGHT (ii) = height;
IMAGE_INSTANCE_TYPE (ii) = type;
IMAGE_INSTANCE_PIXMAP_FILENAME (ii) =
find_keyword_in_vector (instantiator, Q_file);
IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (ii) =
find_keyword_in_vector (instantiator, Q_hotspot_x);
IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (ii) =
find_keyword_in_vector (instantiator, Q_hotspot_y);
switch (type)
{
case IMAGE_MONO_PIXMAP:
{
IMAGE_INSTANCE_X_PIXMAP (ii) =
XCreatePixmapFromBitmapData (DisplayOfScreen (scr),
RootWindowOfScreen (scr),
(char *) bits, width, height,
1, 0, 1);
}
break;
case IMAGE_COLOR_PIXMAP:
{
Dimension d = DefaultDepthOfScreen (scr);
unsigned long fg = BlackPixelOfScreen (scr);
unsigned long bg = WhitePixelOfScreen (scr);
XColor color;
Colormap cmap = DefaultColormapOfScreen (scr);
if (!NILP (foreground))
foreground = Fmake_color_instance (foreground, device,
no_error ? Qt : Qnil);
/* Duplicate the pixel values so that we still have a lock on them if
the pixels we were passed are later freed. */
if (!NILP (foreground))
{
color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (foreground));
if (! XAllocColor (dpy, cmap, &color))
abort ();
fg = color.pixel;
pixels_to_free[free_count++] = fg;
}
if (!NILP (background))
background = Fmake_color_instance (background, device,
no_error ? Qt : Qnil);
/* Duplicate the pixel values so that we still have a lock on them if
the pixels we were passed are later freed. */
if (!NILP (background))
{
color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (background));
if (! XAllocColor (dpy, cmap, &color))
abort ();
bg = color.pixel;
pixels_to_free[free_count++] = bg;
}
IMAGE_INSTANCE_X_PIXMAP (ii) =
XCreatePixmapFromBitmapData (DisplayOfScreen (scr),
RootWindowOfScreen (scr),
(char *) bits, width, height,
fg, bg, d);
IMAGE_INSTANCE_PIXMAP_DEPTH (ii) = d;
}
break;
case IMAGE_CURSOR:
{
XColor fg_color, bg_color;
Pixmap source =
XCreatePixmapFromBitmapData (DisplayOfScreen (scr),
RootWindowOfScreen (scr),
(char *) bits, width, height,
1, 0, 1);
if (!NILP (foreground))
foreground = Fmake_color_instance (foreground, device,
no_error ? Qt : Qnil);
if (!NILP (foreground))
fg_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (foreground));
else
{
fg_color.pixel = 0;
fg_color.red = fg_color.green = fg_color.blue = 0;
}
if (!NILP (background))
background = Fmake_color_instance (background, device,
no_error ? Qt : Qnil);
if (!NILP (background))
bg_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (background));
else
{
bg_color.pixel = 0;
bg_color.red = bg_color.green = bg_color.blue = ~0;
}
IMAGE_INSTANCE_X_CURSOR (ii) =
XCreatePixmapCursor
(dpy, source, mask, &fg_color, &bg_color,
!NILP (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (ii)) ?
XINT (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (ii)) : 0,
!NILP (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (ii)) ?
XINT (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (ii)) : 0);
}
break;
default:
abort ();
}
if (free_count)
{
IMAGE_INSTANCE_X_NPIXELS (ii) = free_count;
IMAGE_INSTANCE_X_PIXELS (ii) =
xmalloc (free_count * sizeof (unsigned long));
memcpy (IMAGE_INSTANCE_X_PIXELS (ii), pixels_to_free,
free_count * sizeof (unsigned long));
}
return 1;
}
/* Instantiate method for XBM's. */
static int
xbm_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
int dest_mask, int no_error)
{
Lisp_Object data = find_keyword_in_vector (instantiator, Q_data);
Lisp_Object mask_data = find_keyword_in_vector (instantiator, Q_mask_data);
struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
Pixmap mask = 0;
assert (!NILP (data));
if (!NILP (mask_data))
mask =
pixmap_from_xbm_inline (IMAGE_INSTANCE_DEVICE (ii),
XINT (XCAR (mask_data)),
XINT (XCAR (XCDR (mask_data))),
(char *) string_data
(XSTRING (XCAR (XCDR (XCDR (mask_data))))));
return (init_image_instance_from_xbm_inline
(ii, XINT (XCAR (data)), XINT (XCAR (XCDR (data))),
string_data (XSTRING (XCAR (XCDR (XCDR (data))))),
instantiator, dest_mask, mask,
find_keyword_in_vector (instantiator, Q_mask_file),
no_error));
}
#ifdef HAVE_JPEG
/**********************************************************************
* JPEG *
**********************************************************************/
static int
jpeg_validate (Lisp_Object instantiator, int no_error)
{
return file_or_data_must_be_present (instantiator, no_error);
}
static Lisp_Object
jpeg_to_lisp_data (Lisp_Object name, int no_error, int ok_if_data_invalid)
{
}
static Lisp_Object jpeg_normalize (Lisp_Object inst, Lisp_Object device_type,
int no_error)
{
return Qnil;
}
static int
jpeg_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
int dest_mask, int no_error)
{
return 0;
}
#endif /* HAVE_JPEG */
#ifdef HAVE_GIF
/**********************************************************************
* GIF *
**********************************************************************/
static int
gif_validate (Lisp_Object instantiator, int no_error)
{
return file_or_data_must_be_present (instantiator, no_error);
}
static Lisp_Object
gif_to_lisp_data (Lisp_Object name, int no_error, int ok_if_data_invalid)
{
}
static Lisp_Object
gif_normalize (Lisp_Object inst, Lisp_Object device_type,
int no_error)
{
return Qnil;
}
static int
gif_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
int dest_mask, int no_error)
{
return 0;
}
#endif /* HAVE_GIF */
#ifdef HAVE_PNG
/**********************************************************************
* PNG *
**********************************************************************/
static int
png_validate (Lisp_Object instantiator, int no_error)
{
return file_or_data_must_be_present (instantiator, no_error);
}
static Lisp_Object
png_to_lisp_data (Lisp_Object name, int no_error, int ok_if_data_invalid)
{
}
static Lisp_Object
png_normalize (Lisp_Object inst, Lisp_Object device_type,
int no_error)
{
return Qnil;
}
static int
png_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
int dest_mask, int no_error)
{
return 0;
}
#endif /* HAVE_PNG */
#ifdef HAVE_XPM
/**********************************************************************
* XPM *
**********************************************************************/
static int
valid_xpm_color_symbols_p (Lisp_Object data, int no_error)
{
Lisp_Object rest;
for (rest = data; !NILP (rest); rest = XCDR (rest))
{
if (!CONSP (rest) ||
!CONSP (XCAR (rest)) ||
!STRINGP (XCAR (XCAR (rest))) ||
(!STRINGP (XCDR (XCAR (rest))) &&
!COLOR_SPECIFIERP (XCDR (XCAR (rest)))))
{
if (!no_error)
signal_simple_error ("Invalid color symbol alist",
data);
return 0;
}
}
return 1;
}
static int
xpm_validate (Lisp_Object instantiator, int no_error)
{
return file_or_data_must_be_present (instantiator, no_error);
}
static Lisp_Object
pixmap_to_lisp_data (Lisp_Object name, int no_error, int ok_if_data_invalid)
{
char **data;
int result;
result = XpmReadFileToData ((char *) string_data (XSTRING (name)), &data);
if (result == XpmSuccess)
{
Lisp_Object retval = Qnil;
Lisp_Object old_inhibit_quit = Vinhibit_quit;
struct buffer *old_buffer = current_buffer;
Lisp_Object temp_buffer =
Fget_buffer_create (build_string (" *pixmap conversion*"));
int elt;
int height, width, ncolors;
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
GCPRO4 (name, retval, old_inhibit_quit, temp_buffer);
Vinhibit_quit = Qt;
set_buffer_internal (XBUFFER (temp_buffer));
Ferase_buffer (Fcurrent_buffer ());
buffer_insert_c_string (current_buffer, "/* XPM */\r");
buffer_insert_c_string (current_buffer, "static char *pixmap[] = {\r");
sscanf (data[0], "%d %d %d", &height, &width, &ncolors);
for (elt = 0; elt <= width + ncolors; elt++)
{
buffer_insert_c_string (current_buffer, "\"");
buffer_insert_c_string (current_buffer, data[elt]);
if (elt < width + ncolors)
buffer_insert_c_string (current_buffer, "\",\r");
else
buffer_insert_c_string (current_buffer, "\"};\r");
}
retval = Fbuffer_substring (Qnil, Qnil, Fcurrent_buffer ());
XpmFree (data);
set_buffer_internal (old_buffer);
Vinhibit_quit = old_inhibit_quit;
RETURN_UNGCPRO (retval);
}
switch (result)
{
case XpmFileInvalid:
{
if (ok_if_data_invalid)
return Qt;
if (!no_error)
signal_simple_error ("invalid XPM data in file", name);
break;
}
case XpmNoMemory:
{
if (!no_error)
signal_double_file_error ("Reading pixmap file",
"out of memory", name);
break;
}
case XpmOpenFailed:
{
/* should never happen? */
if (!no_error)
signal_double_file_error ("Opening pixmap file",
"no such file or directory", name);
break;
}
default:
{
if (!no_error)
signal_double_file_error_2 ("Parsing pixmap file",
"unknown error code",
make_number (result), name);
break;
}
}
return Qnil;
}
Lisp_Object Vxpm_color_symbols;
static Lisp_Object
evaluate_xpm_color_symbols (int no_error)
{
Lisp_Object rest, results = Qnil;
struct gcpro gcpro1, gcpro2;
GCPRO2 (rest, results);
for (rest = Vxpm_color_symbols; !NILP (rest); rest = XCDR (rest))
{
Lisp_Object name, value, cons;
if (!CONSP (rest))
{
if (!no_error)
CHECK_CONS (rest, 0);
UNGCPRO;
return Qnil;
}
cons = XCAR (rest);
if (!CONSP (cons))
{
if (!no_error)
CHECK_CONS (cons, 0);
UNGCPRO;
return Qnil;
}
name = XCAR (cons);
if (!STRINGP (name))
{
if (!no_error)
CHECK_STRING (name, 0);
UNGCPRO;
return Qnil;
}
value = XCDR (cons);
if (!CONSP (value))
{
if (!no_error)
CHECK_CONS (value, 0);
UNGCPRO;
return Qnil;
}
value = XCAR (value);
value = Feval (value);
if (NILP (value))
continue;
if (!STRINGP (value) && !COLOR_SPECIFIERP (value))
{
if (!no_error)
signal_simple_error
("Result from xpm-color-symbols eval must be nil, string, or color",
value);
UNGCPRO;
return Qnil;
}
results = Fcons (Fcons (name, value), results);
}
UNGCPRO; /* no more evaluation */
return results;
}
static Lisp_Object
xpm_normalize (Lisp_Object inst, Lisp_Object device_type,
int no_error)
{
Lisp_Object file = Qnil;
Lisp_Object color_symbols;
struct gcpro gcpro1, gcpro2;
Lisp_Object alist = Qnil;
GCPRO2 (file, alist);
/* Now, convert any file data into inline data. At the end of this,
`data' will contain the inline data (if any) or Qnil, and
`file' will contain the name this data was derived from (if
known) or Qnil.
Note that if we cannot generate any regular inline data, we
skip out. */
file = potential_pixmap_file_instantiator (inst, Q_file, Q_data);
if (EQ (file, Qt)) /* failure locating filename */
{
if (!no_error)
signal_double_file_error ("Opening pixmap file",
"no such file or directory",
file);
RETURN_UNGCPRO (Qnil);
}
color_symbols = find_keyword_in_vector_or_given (inst, Q_color_symbols,
Qunbound);
if (NILP (file) && !UNBOUNDP (color_symbols))
/* no conversion necessary */
RETURN_UNGCPRO (inst);
alist = tagged_vector_to_alist (inst);
if (!NILP (file))
{
Lisp_Object data = pixmap_to_lisp_data (file, no_error, 0);
if (NILP (data)) /* conversion failure; error should
already be signalled. */
RETURN_UNGCPRO (Qnil);
alist = remassq_no_quit (Q_file, alist);
/* there can't be a :data at this point. */
alist = Fcons (Fcons (Q_file, file),
Fcons (Fcons (Q_data, data), alist));
}
if (UNBOUNDP (color_symbols))
{
color_symbols = evaluate_xpm_color_symbols (no_error);
alist = Fcons (Fcons (Q_color_symbols, color_symbols),
alist);
}
{
Lisp_Object result = alist_to_tagged_vector (Qxpm, alist);
free_alist (alist);
RETURN_UNGCPRO (result);
}
}
/* xpm 3.2g and better has XpmCreatePixmapFromBuffer()...
There was no version number in xpm.h before 3.3, but this should do.
*/
#if (XpmVersion >= 3) || defined(XpmExactColors)
# define XPM_DOES_BUFFERS
#endif
#ifndef XPM_DOES_BUFFERS
Your version of XPM is too old. You cannot compile with it.
Upgrade to version 3.2g or better or compile with --with-xpm=no.
#endif /* !XPM_DOES_BUFFERS */
static XpmColorSymbol *
extract_xpm_color_names (XpmAttributes *xpmattrs, Lisp_Object device,
Lisp_Object color_symbol_alist, int no_error)
{
/* This function can GC */
Screen *xs = LISP_DEVICE_TO_X_SCREEN (device);
Display *dpy = DisplayOfScreen (xs);
Colormap cmap = DefaultColormapOfScreen (xs);
XColor color;
Lisp_Object rest;
Lisp_Object results = Qnil;
int i;
XpmColorSymbol *symbols;
struct gcpro gcpro1, gcpro2;
GCPRO2 (results, device);
/* We built up results to be (("name" . #<color>) ...) so that if an
error happens we don't lose any malloc()ed data, or more importantly,
leave any pixels allocated in the server. */
i = 0;
LIST_LOOP (rest, color_symbol_alist)
{
Lisp_Object cons = XCAR (rest);
Lisp_Object name = XCAR (cons);
Lisp_Object value = XCDR (cons);
if (NILP (value))
continue;
if (STRINGP (value))
value = Fmake_color_instance (value, device, no_error ? Qt : Qnil);
else
{
assert (COLOR_SPECIFIERP (value));
value = Fspecifier_instance (value, device, Qnil, Qnil);
}
if (NILP (value))
continue;
results = Fcons (Fcons (name, value), results);
i++;
}
UNGCPRO; /* no more evaluation */
if (i == 0) return 0;
symbols = (XpmColorSymbol *) xmalloc (i * sizeof (XpmColorSymbol));
xpmattrs->valuemask |= XpmColorSymbols;
xpmattrs->colorsymbols = symbols;
xpmattrs->numsymbols = i;
while (--i >= 0)
{
Lisp_Object cons = XCAR (results);
color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (XCDR (cons)));
/* Duplicate the pixel value so that we still have a lock on it if
the pixel we were passed is later freed. */
if (! XAllocColor (dpy, cmap, &color))
abort (); /* it must be allocable since we're just duplicating it */
symbols [i].name = (char *) string_data (XSTRING (XCAR (cons)));
symbols [i].pixel = color.pixel;
symbols [i].value = 0;
results = XCDR (results);
free_cons (XCONS (cons));
}
return symbols;
}
static void
xpm_free (XpmAttributes *xpmattrs)
{
/* Could conceivably lose if XpmXXX returned an error without first
initializing this structure, if we didn't know that initializing it
to all zeros was ok (and also that it's ok to call XpmFreeAttributes()
multiple times, since it zeros slots as it frees them...) */
XpmFreeAttributes (xpmattrs);
}
static int
xpm_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
int dest_mask, int no_error)
{
/* This function can GC */
struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
Lisp_Object data = find_keyword_in_vector (instantiator, Q_data);
int force_mono;
Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii);
Screen *xs = LISP_DEVICE_TO_X_SCREEN (device);
Pixmap pixmap;
Pixmap mask = 0;
XpmAttributes xpmattrs;
int result;
XpmColorSymbol *color_symbols;
Lisp_Object color_symbol_alist = find_keyword_in_vector (instantiator,
Q_color_symbols);
if (dest_mask & IMAGE_COLOR_PIXMAP_MASK)
force_mono = 0;
else if (dest_mask & IMAGE_MONO_PIXMAP_MASK)
force_mono = 1;
else
{
if (!no_error)
signal_simple_error ("No compatible image-instance types given",
instantiator);
return 0;
}
x_initialize_pixmap_image_instance (ii);
if (force_mono)
IMAGE_INSTANCE_TYPE (ii) = IMAGE_MONO_PIXMAP;
else
IMAGE_INSTANCE_TYPE (ii) = IMAGE_COLOR_PIXMAP;
assert (!NILP (data));
retry:
memset (&xpmattrs, 0, sizeof (xpmattrs)); /* want XpmInitAttributes() */
xpmattrs.valuemask = XpmReturnPixels;
if (force_mono)
{
/* Without this, we get a 1-bit version of the color image, which
isn't quite right. With this, we get the mono image, which might
be very different looking. */
xpmattrs.valuemask |= XpmColorKey;
xpmattrs.color_key = XPM_MONO;
xpmattrs.depth = 1;
xpmattrs.valuemask |= XpmDepth;
}
else
{
xpmattrs.closeness = 65535;
xpmattrs.valuemask |= XpmCloseness;
}
color_symbols = extract_xpm_color_names (&xpmattrs, device,
color_symbol_alist,
no_error);
result = XpmCreatePixmapFromBuffer (DisplayOfScreen (xs),
RootWindowOfScreen (xs),
(char *)
string_data (XSTRING (data)),
&pixmap, &mask, &xpmattrs);
if (color_symbols)
{
xfree (color_symbols);
xpmattrs.colorsymbols = 0; /* in case XpmFreeAttr is too smart... */
xpmattrs.numsymbols = 0;
}
switch (result)
{
case XpmSuccess:
break;
case XpmFileInvalid:
{
xpm_free (&xpmattrs);
if (!no_error)
signal_simple_error ("invalid XPM data", data);
return 0;
}
case XpmColorFailed:
case XpmColorError:
{
xpm_free (&xpmattrs);
if (force_mono)
{
if (!no_error)
/* second time; blow out. */
signal_double_file_error ("Reading pixmap data",
"color allocation failed",
data);
return 0;
}
else
{
if (! (dest_mask & IMAGE_MONO_PIXMAP_MASK))
{
if (!no_error)
/* second time; blow out. */
signal_double_file_error ("Reading pixmap data",
"color allocation failed",
data);
return 0;
}
force_mono = 1;
IMAGE_INSTANCE_TYPE (ii) = IMAGE_MONO_PIXMAP;
goto retry;
}
}
case XpmNoMemory:
{
xpm_free (&xpmattrs);
if (!no_error)
signal_double_file_error ("Parsing pixmap data",
"out of memory", data);
return 0;
}
default:
{
xpm_free (&xpmattrs);
if (!no_error)
signal_double_file_error_2 ("Parsing pixmap data",
"unknown error code",
make_number (result), data);
else
return 0;
}
}
{
/* XpmReadFileToPixmap() doesn't return the depth (bogus!) so we need to
get it ourself. (No, xpmattrs.depth is not it; that's an input slot,
not output.) We could just assume that it has the same depth as the
root window, but some devices allow more than one depth, so that isn't
necessarily correct (I guess?) */
Window root;
int x, y;
unsigned int w2, h2, bw;
unsigned int w = xpmattrs.width;
unsigned int h = xpmattrs.height;
unsigned int d;
int xhot = ((xpmattrs.valuemask & XpmHotspot) ? xpmattrs.x_hotspot : -1);
int yhot = ((xpmattrs.valuemask & XpmHotspot) ? xpmattrs.y_hotspot : -1);
int npixels = xpmattrs.npixels;
Pixel *pixels = 0;
if (npixels != 0)
{
pixels = xmalloc (npixels * sizeof (Pixel));
memcpy (pixels, xpmattrs.pixels, npixels * sizeof (Pixel));
}
else
pixels = 0;
xpm_free (&xpmattrs); /* after we've read pixels and hotspot */
if (!XGetGeometry (DisplayOfScreen (xs), pixmap, &root, &x, &y,
&w2, &h2, &bw, &d))
abort ();
if (w != w2 || h != h2)
abort ();
{
IMAGE_INSTANCE_PIXMAP_FILENAME (ii) =
find_keyword_in_vector (instantiator, Q_file);
if (xhot >= 0)
IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (ii) = make_number (xhot);
if (yhot >= 0)
IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (ii) = make_number (yhot);
IMAGE_INSTANCE_X_PIXMAP (ii) = pixmap;
IMAGE_INSTANCE_X_MASK (ii) = mask;
IMAGE_INSTANCE_PIXMAP_WIDTH (ii) = w;
IMAGE_INSTANCE_PIXMAP_HEIGHT (ii) = h;
IMAGE_INSTANCE_PIXMAP_DEPTH (ii) = d;
IMAGE_INSTANCE_X_PIXELS (ii) = pixels;
IMAGE_INSTANCE_X_NPIXELS (ii) = npixels;
}
}
return 1;
}
#endif /* HAVE_XPM */
#ifdef HAVE_XFACE
/**********************************************************************
* X-Face *
**********************************************************************/
static int
xface_validate (Lisp_Object instantiator, int no_error)
{
return file_or_data_must_be_present (instantiator, no_error);
}
static Lisp_Object
xface_normalize (Lisp_Object inst, Lisp_Object device_type,
int no_error)
{
Lisp_Object file = Qnil;
struct gcpro gcpro1, gcpro2;
Lisp_Object alist = Qnil;
GCPRO2 (file, alist);
/* Now, convert any file data into inline data for both the regular
data and the mask data. At the end of this, `data' will contain
the inline data (if any) or Qnil, and `file' will contain
the name this data was derived from (if known) or Qnil.
Likewise for `mask_file' and `mask_data'.
Note that if we cannot generate any regular inline data, we
skip out. */
file = potential_pixmap_file_instantiator (inst, Q_file, Q_data);
if (EQ (file, Qt)) /* failure locating filename */
{
if (!no_error)
signal_double_file_error ("Opening bitmap file",
"no such file or directory",
file);
RETURN_UNGCPRO (Qnil);
}
if (NILP (file)) /* no conversion necessary */
RETURN_UNGCPRO (inst);
alist = tagged_vector_to_alist (inst);
{
Lisp_Object data = make_string_from_file (file);
alist = remassq_no_quit (Q_file, alist);
/* there can't be a :data at this point. */
alist = Fcons (Fcons (Q_file, file),
Fcons (Fcons (Q_data, data), alist));
}
{
Lisp_Object result = alist_to_tagged_vector (Qxface, alist);
free_alist (alist);
RETURN_UNGCPRO (result);
}
}
/* We have to define SYSV32 so that compface.h includes string.h
instead of strings.h. */
#define SYSV32
#include <compface.h>
jmp_buf comp_env;
#undef SYSV32
static int
xface_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
int dest_mask, int no_error)
{
Lisp_Object data = find_keyword_in_vector (instantiator, Q_data);
struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
int i, status;
char *p, *bits, *bp, *emsg = NULL, *dstring;
assert (!NILP (data));
dstring = (char *) string_data (XSTRING (data));
if ((p = strchr (dstring, ':')))
{
dstring = p + 1;
}
if (!(status = setjmp (comp_env)))
{
UnCompAll (dstring);
UnGenFace ();
}
switch (status)
{
case -2:
emsg = "uncompface: internal error";
break;
case -1:
emsg = "uncompface: insufficient or invalid data";
break;
case 1:
emsg = "uncompface: excess data ignored";
break;
}
if (emsg)
{
if (!no_error)
signal_simple_error (emsg, data);
return 0;
}
bp = bits = (char *) alloca (PIXELS / 8);
/* the compface library exports char F[], which uses a single byte per
pixel to represent a 48x48 bitmap. Yuck. */
for (i = 0, p = F; i < (PIXELS / 8); ++i)
{
int n, b;
/* reverse the bit order of each byte... */
for (b = n = 0; b < 8; ++b)
{
n |= ((*p++) << b);
}
*bp++ = (char) n;
}
return init_image_instance_from_xbm_inline (ii, 48, 48,
(unsigned char *) bits,
instantiator, dest_mask,
0, Qnil, no_error);
}
#endif /* HAVE_XFACE */
/**********************************************************************
* Autodetect *
**********************************************************************/
static int
autodetect_validate (Lisp_Object instantiator, int no_error)
{
return data_must_be_present (instantiator, no_error);
}
static Lisp_Object
autodetect_normalize (Lisp_Object instantiator, Lisp_Object device_type,
int no_error)
{
Lisp_Object file = find_keyword_in_vector (instantiator, Q_data);
Lisp_Object filename = Qnil;
Lisp_Object data = Qnil;
struct gcpro gcpro1, gcpro2, gcpro3;
Lisp_Object alist = Qnil;
GCPRO3 (filename, data, alist);
if (NILP (file)) /* no conversion necessary */
RETURN_UNGCPRO (instantiator);
alist = tagged_vector_to_alist (instantiator);
filename = locate_pixmap_file (file);
if (!NILP (filename))
{
int xhot, yhot;
/* #### Apparently some versions of XpmReadFileToData which is
called by pixmap_to_lisp_data don't return an error value
if the given file is not a valid XPM file. Instead, they
just seg fault. It is definitely caused by passing a
bitmap. To try and avoid this we check for bitmaps first. */
data = bitmap_to_lisp_data (filename, &xhot, &yhot, no_error, 1);
if (NILP (data))
/* error in conversion, other than invalid data */
RETURN_UNGCPRO (Qnil);
if (!EQ (data, Qt))
{
alist = remassq_no_quit (Q_data, alist);
alist = Fcons (Fcons (Q_file, filename),
Fcons (Fcons (Q_data, data), alist));
if (xhot != -1)
alist = Fcons (Fcons (Q_hotspot_x, make_number (xhot)),
alist);
if (yhot != -1)
alist = Fcons (Fcons (Q_hotspot_y, make_number (yhot)),
alist);
{
Lisp_Object result = alist_to_tagged_vector (Qxbm, alist);
free_alist (alist);
RETURN_UNGCPRO (result);
}
}
#ifdef HAVE_XPM
data = pixmap_to_lisp_data (filename, no_error, 1);
if (NILP (data)) /* conversion failure; error should
already be signalled. */
RETURN_UNGCPRO (Qnil);
if (!EQ (data, Qt))
{
alist = remassq_no_quit (Q_data, alist);
alist = Fcons (Fcons (Q_file, filename),
Fcons (Fcons (Q_data, data), alist));
alist = Fcons (Fcons (Q_color_symbols,
evaluate_xpm_color_symbols (no_error)),
alist);
{
Lisp_Object result = alist_to_tagged_vector (Qxpm, alist);
free_alist (alist);
RETURN_UNGCPRO (result);
}
}
#endif
}
alist = remassq_no_quit (Q_data, alist);
alist = Fcons (Fcons (Q_data, file), alist);
{
Lisp_Object result = alist_to_tagged_vector (Qstring, alist);
free_alist (alist);
RETURN_UNGCPRO (result);
}
}
static int
autodetect_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
int dest_mask, int no_error)
{
abort (); /* Should never get here. Anything that was `autodetect'
should have been converted to something else by the
normalization code. */
return 0;
}
/**********************************************************************
* Misc image *
**********************************************************************/
/* #### This function could fuck with pixmap caches. Need to rethink. */
DEFUN ("colorize-image-instance", Fcolorize_image_instance,
Scolorize_image_instance, 3, 3, 0,
"Make the image instance be displayed in the given colors.\n\
Image instances come in two varieties: bitmaps, which are 1 bit deep which\n\
are rendered in the prevailing foreground and background colors; and\n\
pixmaps, which are of arbitrary depth (including 1) and which have the\n\
colors explicitly specified. This function converts a bitmap to a pixmap.\n\
If the image instance was a pixmap already, nothing is done (and nil is\n\
returned). Otherwise t is returned.")
(image_instance, foreground, background)
Lisp_Object image_instance, foreground, background;
{
struct Lisp_Image_Instance *p;
CHECK_IMAGE_INSTANCE (image_instance, 0);
CHECK_COLOR_INSTANCE (foreground, 0);
CHECK_COLOR_INSTANCE (background, 0);
p = XIMAGE_INSTANCE (image_instance);
if (IMAGE_INSTANCE_PIXMAP_DEPTH (p) > 0)
return Qnil;
{
Display *dpy = DEVICE_X_DISPLAY (XDEVICE (IMAGE_INSTANCE_DEVICE (p)));
Screen *scr = DefaultScreenOfDisplay (dpy);
Dimension d = DefaultDepthOfScreen (scr);
Colormap cmap = DefaultColormapOfScreen (scr);
Pixmap new = XCreatePixmap (dpy, RootWindowOfScreen (scr),
IMAGE_INSTANCE_PIXMAP_WIDTH (p),
IMAGE_INSTANCE_PIXMAP_HEIGHT (p), d);
XColor color;
XGCValues gcv;
GC gc;
/* Duplicate the pixel values so that we still have a lock on them if
the pixels we were passed are later freed. */
color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (foreground));
if (! XAllocColor (dpy, cmap, &color)) abort ();
gcv.foreground = color.pixel;
color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (background));
if (! XAllocColor (dpy, cmap, &color)) abort ();
gcv.background = color.pixel;
gc = XCreateGC (dpy, new, GCBackground|GCForeground, &gcv);
XCopyPlane (dpy, IMAGE_INSTANCE_X_PIXMAP (p), new, gc, 0, 0,
IMAGE_INSTANCE_PIXMAP_WIDTH (p), IMAGE_INSTANCE_PIXMAP_HEIGHT (p),
0, 0, 1);
XFreeGC (dpy, gc);
XFreePixmap (dpy, IMAGE_INSTANCE_X_PIXMAP (p));
IMAGE_INSTANCE_X_PIXMAP (p) = new;
IMAGE_INSTANCE_PIXMAP_DEPTH (p) = d;
}
return Qt;
}
/************************************************************************/
/* cursors */
/************************************************************************/
/* #### this shit needs overhauling and specifierifying */
Lisp_Object Qcursorp;
static Lisp_Object mark_cursor (Lisp_Object, void (*) (Lisp_Object));
static void print_cursor (Lisp_Object, Lisp_Object, int);
static void finalize_cursor (void *, int);
static int cursor_equal (Lisp_Object, Lisp_Object, int depth);
static unsigned long cursor_hash (Lisp_Object obj, int depth);
DEFINE_LRECORD_IMPLEMENTATION ("cursor", cursor,
mark_cursor, print_cursor, finalize_cursor,
cursor_equal, cursor_hash, struct Lisp_Cursor);
static Lisp_Object
mark_cursor (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
struct Lisp_Cursor *c = XCURSOR (obj);
((markobj) (c->fg));
((markobj) (c->bg));
((markobj) (c->name));
return c->device;
}
static void
print_cursor (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
char buf[200];
struct Lisp_Cursor *c = XCURSOR (obj);
if (print_readably)
error ("printing unreadable object #<cursor 0x%x>",
c->header.uid);
write_c_string ("#<cursor ", printcharfun);
print_internal (c->name, printcharfun, 1);
if (!NILP (c->fg))
{
write_c_string (" (", printcharfun);
print_internal (XCOLOR_INSTANCE (c->fg)->name, printcharfun, 0);
write_c_string ("/", printcharfun);
print_internal (XCOLOR_INSTANCE (c->bg)->name, printcharfun, 0);
write_c_string (")", printcharfun);
}
sprintf (buf, " 0x%x>", c->header.uid);
/* #### should print the device */
write_c_string (buf, printcharfun);
}
static void
finalize_cursor (void *header, int for_disksave)
{
struct Lisp_Cursor *c = (struct Lisp_Cursor *) header;
if (for_disksave) finalose (c);
if (c->cursor)
{
XFreeCursor (DEVICE_X_DISPLAY (XDEVICE (c->device)), c->cursor);
c->cursor = 0;
}
}
/* Cursors are equal if their names are equal. */
static int
cursor_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
return (internal_equal (XCURSOR (o1)->name, XCURSOR (o2)->name, depth + 1));
}
static unsigned long
cursor_hash (Lisp_Object obj, int depth)
{
return internal_hash (XCURSOR (obj)->name, depth + 1);
}
/* XmuCvtStringToCursor is bogus in the following ways:
- When it can't convert the given string to a real cursor, it will
sometimes return a "success" value, after triggering a BadPixmap
error. It then gives you a cursor that will itself generate BadCursor
errors. So we install this error handler to catch/notice the X error
and take that as meaning "couldn't convert."
- When you tell it to find a cursor file that doesn't exist, it prints
an error message on stderr. You can't make it not do that.
- Also, using Xmu means we can't properly hack Lisp_Image_Instance
objects, or XPM files, or $XBMLANGPATH.
*/
/* Duplicate the behavior of XmuCvtStringToCursor() to bypass its bogusness. */
static int XLoadFont_got_error;
static int XLoadFont_error_handler (Display *dpy, XErrorEvent *xerror)
{
XLoadFont_got_error = 1;
return 0;
}
static Font
safe_XLoadFont (Display *dpy, char *name)
{
Font font;
int (*old_handler) ();
XLoadFont_got_error = 0;
XSync (dpy, 0);
old_handler = XSetErrorHandler (XLoadFont_error_handler);
font = XLoadFont (dpy, name);
XSync (dpy, 0);
XSetErrorHandler (old_handler);
if (XLoadFont_got_error) return 0;
return font;
}
static Cursor
make_cursor_1 (Lisp_Object device, Lisp_Object name)
{
/* This function can GC */
Screen *xs = LISP_DEVICE_TO_X_SCREEN (device);
Display *dpy = DisplayOfScreen (xs);
XColor fg, bg;
Cursor cursor;
int i;
fg.pixel = bg.pixel = 0;
fg.red = fg.green = fg.blue = 0;
bg.red = bg.green = bg.blue = ~0;
if (STRINGP (name) &&
!strncmp ("FONT ", (char *) string_data (XSTRING (name)), 5))
{
Font source, mask;
char source_name [MAXPATHLEN], mask_name [MAXPATHLEN], dummy;
int source_char, mask_char;
int count = sscanf ((char *) string_data (XSTRING (name)),
"FONT %s %d %s %d %c",
source_name, &source_char,
mask_name, &mask_char, &dummy);
/* Allow "%s %d %d" as well... */
if (count == 3 && (1 == sscanf (mask_name, "%d %c", &mask_char, &dummy)))
count = 4, mask_name[0] = 0;
if (count != 2 && count != 4)
signal_simple_error ("invalid cursor specification", name);
source = safe_XLoadFont (dpy, source_name);
if (! source)
signal_simple_error_2 ("couldn't load font",
build_string (source_name),
name);
if (count == 2)
mask = 0;
else if (! mask_name[0])
mask = source;
else
{
mask = safe_XLoadFont (dpy, mask_name);
if (! mask) /* continuable */
Fsignal (Qerror, list3 (build_string ("couldn't load font"),
build_string (mask_name), name));
}
if (! mask) mask_char = 0;
/* #### call XQueryTextExtents() and check_pointer_sizes() here. */
cursor = XCreateGlyphCursor (dpy, source, mask, source_char, mask_char,
&fg, &bg);
XUnloadFont (dpy, source);
if (mask && mask != source) XUnloadFont (dpy, mask);
}
else if (STRINGP (name) &&
(i = XmuCursorNameToIndex (string_ext_data (XSTRING (name)))) != -1)
{
cursor = XCreateFontCursor (dpy, i);
}
else
{
struct gcpro gcpro1, gcpro2, gcpro3;
Lisp_Object lsource = Qnil;
Lisp_Object lmask = Qnil;
Lisp_Object mask_file = Qnil;
Pixmap source, mask;
GCPRO3 (lsource, lmask, mask_file);
if (IMAGE_INSTANCEP (name))
lsource = name;
else if (GLYPHP (name))
lsource = glyph_image_instance (name, device, 0);
else
/* #### We may not want this to error later on. */
lsource = Fmake_image_instance (name, device, Qmono_pixmap, Qnil);
if (!IMAGE_INSTANCEP (lsource))
signal_simple_error ("Could not obtain image instance", name);
if (XIMAGE_INSTANCE_TYPE (lsource) != IMAGE_MONO_PIXMAP)
signal_simple_error ("Invalid image-instance type", lsource);
source = XIMAGE_INSTANCE_X_PIXMAP (lsource);
mask = XIMAGE_INSTANCE_X_MASK (lsource);
if (XIMAGE_INSTANCE_PIXMAP_DEPTH (lsource) > 1)
signal_error (Qerror,
list3 (build_string ("cursor image instances must be 1 plane"),
name, lsource));
if (!mask && STRINGP (name))
{
mask_file =
locate_pixmap_file (concat2 (name, build_string ("Mask")));
if (NILP (mask_file))
mask_file =
locate_pixmap_file (concat2 (name, build_string ("msk")));
if (!NILP (mask_file))
{
/* #### We may not want this to error later on. */
lmask = Fmake_image_instance (mask_file, device, Qmono_pixmap,
Qnil);
if (!IMAGE_INSTANCEP (lmask))
signal_simple_error
("Could not obtain mask image instance", lmask);
if (XIMAGE_INSTANCE_PIXMAP_DEPTH (lmask) != 0)
signal_simple_error_2 ("mask must be 1 bit deep",
mask_file, lmask);
mask = XIMAGE_INSTANCE_X_PIXMAP (lmask);
mask_file = Qnil;
}
}
check_pointer_sizes (xs,
XIMAGE_INSTANCE_PIXMAP_WIDTH (lsource),
XIMAGE_INSTANCE_PIXMAP_HEIGHT (lsource),
name, 0);
/* If the loaded pixmap has colors allocated (meaning it came from an
XPM file), then use those as the default colors for the cursor we
create. Otherwise, default to black and white.
*/
if (XIMAGE_INSTANCE_X_NPIXELS (lsource) >= 2)
{
int npixels = XIMAGE_INSTANCE_X_NPIXELS (lsource);
unsigned long *pixels = XIMAGE_INSTANCE_X_PIXELS (lsource);
/* With an XBM file, it's obvious which bit is foreground and which
is background, or rather, it's implicit: in an XBM file, a 1 bit
is foreground, and a 0 bit is background.
XCreatePixmapCursor() assumes this property of the pixmap it is
called with as well; the `foreground' color argument is used for
the 1 bits.
With an XPM file, it's tricker, since the elements of the pixmap
don't represent FG and BG, but are actual pixel values. So we
need to figure out which of those pixels is the foreground color
and which is the background. We do it by comparing RGB and
assuming that the darker color is the foreground. This works
with the result of xbmtopbm|ppmtoxpm, at least.
It might be nice if there was some way to tag the colors in the
XPM file with whether they are the foreground - perhaps with
logical color names somehow?
Once we have decided which color is the foreground, we need to
ensure that that color corresponds to a `1' bit in the Pixmap.
The XPM library wrote into the (1-bit) pixmap with XPutPixel,
which will ignore all but the least significant bit.
This means that a 1 bit in the image corresponds to `fg' only if
`fg.pixel' is odd.
(This also means that the image will be all the same color if
both `fg' and `bg' are odd or even, but we can safely assume
that that won't happen if the XPM file is sensible I think.)
The desired result is that the image use `1' to represent the
foreground color, and `0' to represent the background color.
So, we may need to invert the image to accomplish this; we invert
if fg is odd. (Remember that WhitePixel and BlackPixel are not
necessarily 1 and 0 respectively, though I think it might be safe
to assume that one of them is always 1 and the other is always 0.
We also pretty much need to assume that one is even and the other
is odd.)
*/
fg.pixel = pixels [0]; /* pick a pixel at random. */
bg.pixel = fg.pixel;
for (i = 1; i < npixels; i++) /* Look for an "other" pixel value. */
{
bg.pixel = pixels [i];
if (fg.pixel != bg.pixel) break;
}
/* If (fg.pixel == bg.pixel) then probably something has gone wrong,
but I don't think signalling an error would be appropriate. */
XQueryColor (DisplayOfScreen(xs), DefaultColormapOfScreen(xs), &fg);
XQueryColor (DisplayOfScreen(xs), DefaultColormapOfScreen(xs), &bg);
/* If the foreground is lighter than the background, swap them.
(This occurs semi-randomly, depending on the ordering of the
color list in the XPM file.)
*/
{
unsigned short fg_total = ((fg.red / 3) + (fg.green / 3)
+ (fg.blue / 3));
unsigned short bg_total = ((bg.red / 3) + (bg.green / 3)
+ (bg.blue / 3));
if (fg_total > bg_total)
{
XColor swap;
swap = fg;
fg = bg;
bg = swap;
}
}
/* If the fg pixel corresponds to a `0' in the bitmap, invert it.
(This occurs (only?) on servers with Black=0, White=1.)
*/
if ((fg.pixel & 1) == 0)
{
XGCValues gcv;
GC gc;
gcv.function = GXxor;
gcv.foreground = 1;
gc = XCreateGC (dpy, source, (GCFunction | GCForeground), &gcv);
XFillRectangle (dpy, source, gc, 0, 0,
XIMAGE_INSTANCE_PIXMAP_WIDTH (lsource),
XIMAGE_INSTANCE_PIXMAP_HEIGHT (lsource));
XFreeGC (dpy, gc);
}
}
cursor = XCreatePixmapCursor
(dpy, source, mask, &fg, &bg,
!NILP (XIMAGE_INSTANCE_PIXMAP_HOTSPOT_X (lsource)) ?
XINT (XIMAGE_INSTANCE_PIXMAP_HOTSPOT_X (lsource)) : 0,
!NILP (XIMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (lsource)) ?
XINT (XIMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (lsource)) : 0);
UNGCPRO; /* can now collect and free `lsource', `lmask', and Pixmaps. */
}
return cursor;
}
DEFUN ("make-cursor", Fmake_cursor, Smake_cursor, 1, 4, 0,
"Creates a new `cursor' object of the specified name.\n\
The optional second and third arguments are the foreground and background\n\
colors. They may be color name strings or `pixel' objects.\n\
The optional fourth argument is the device on which to allocate the cursor\n\
(defaults to the selected device).\n\
This allocates a new cursor in the X server, and signals an error if the\n\
cursor is unknown or cannot be allocated.\n\
\n\
A cursor name can take many different forms. It can be:\n\
- any of the standard cursor names from appendix B of the Xlib manual\n\
(also known as the file <X11/cursorfont.h>) minus the XC_ prefix;\n\
- the name of a font, and glyph index into it of the form\n\
\"FONT fontname index [[mask-font] mask-index]\";\n\
- the name of a bitmap or pixmap file;\n\
- or an image instance object, as returned by `make-image-instance'.\n\
\n\
If it is an image instance or pixmap file, and that pixmap comes with a\n\
mask, then that mask will be used. If it is an image instance, it must\n\
have only one plane, since X cursors may only have two colors. If it is a\n\
pixmap file, then the file will be read in monochrome.\n\
\n\
If it is a bitmap file, and if a bitmap file whose name is the name of the\n\
cursor with \"msk\" or \"Mask\" appended exists, then that second bitmap\n\
will be used as the mask. For example, a pair of files might be named\n\
\"cursor.xbm\" and \"cursor.xbmmsk\".\n\
\n\
The returned object is a normal, first-class lisp object. The way you\n\
`deallocate' the cursor is the way you deallocate any other lisp object:\n\
you drop all pointers to it and allow it to be garbage collected. When\n\
these objects are GCed, the underlying X data is deallocated as well.")
(name, fg, bg, device)
Lisp_Object name, fg, bg, device;
{
/* This function can GC */
Screen *xs;
Cursor cursor;
XSETDEVICE (device, get_x_device (device));
xs = LISP_DEVICE_TO_X_SCREEN (device);
if ((NILP (fg)) != (NILP (bg)))
error ("must specify both foreground and background, or neither.");
if (STRINGP (fg))
fg = Fmake_color_instance (fg, device, Qnil);
else if (!NILP (fg) && !COLOR_INSTANCEP (fg))
CHECK_STRING (fg, 0);
if (STRINGP (bg))
bg = Fmake_color_instance (bg, device, Qnil);
else if (!NILP (bg) && !COLOR_INSTANCEP (bg))
CHECK_STRING (bg, 0);
cursor = make_cursor_1 (device, name);
if (! cursor)
signal_simple_error ("unknown cursor", name);
/* Got the cursor, now color it in.
(Either both are specified or neither.) */
if (!NILP (fg))
{
XColor xbg, xfg;
xbg = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (bg));
xfg = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (fg));
XRecolorCursor (DisplayOfScreen (xs), cursor,
&xfg, &xbg);
}
/* Now make the lisp object. */
{
struct Lisp_Cursor *c = alloc_lcrecord (sizeof (struct Lisp_Cursor),
lrecord_cursor);
Lisp_Object val;
c->device = device;
c->name = name;
c->cursor = cursor;
c->fg = fg;
c->bg = bg;
XSETCURSOR (val, c);
return val;
}
}
DEFUN ("cursorp", Fcursorp, Scursorp, 1, 1, 0,
"Return non-nil if OBJECT is a cursor.")
(object)
Lisp_Object object;
{
return (CURSORP (object) ? Qt : Qnil);
}
DEFUN ("cursor-name", Fcursor_name, Scursor_name, 1, 1, 0,
"Return the name used to allocate the given cursor.")
(cursor)
Lisp_Object cursor;
{
CHECK_CURSOR (cursor, 0);
return (XCURSOR (cursor)->name);
}
DEFUN ("cursor-foreground", Fcursor_foreground, Scursor_foreground, 1, 1, 0,
"Return the foreground color of the given cursor, or nil if unspecified.")
(cursor)
Lisp_Object cursor;
{
CHECK_CURSOR (cursor, 0);
return (XCURSOR (cursor)->fg);
}
DEFUN ("cursor-background", Fcursor_background, Scursor_background, 1, 1, 0,
"Return the background color of the given cursor, or nil if unspecified.")
(cursor)
Lisp_Object cursor;
{
CHECK_CURSOR (cursor, 0);
return (XCURSOR (cursor)->bg);
}
/************************************************************************/
/* subwindows */
/************************************************************************/
Lisp_Object Qsubwindowp;
static Lisp_Object mark_subwindow (Lisp_Object, void (*) (Lisp_Object));
static void print_subwindow (Lisp_Object, Lisp_Object, int);
static void finalize_subwindow (void *, int);
static int subwindow_equal (Lisp_Object o1, Lisp_Object o2, int depth);
static unsigned long subwindow_hash (Lisp_Object obj, int depth);
DEFINE_LRECORD_IMPLEMENTATION ("subwindow", subwindow,
mark_subwindow, print_subwindow,
finalize_subwindow, subwindow_equal,
subwindow_hash, struct Lisp_Subwindow);
static Lisp_Object
mark_subwindow (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
struct Lisp_Subwindow *sw = XSUBWINDOW (obj);
return sw->frame;
}
static void
print_subwindow (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
char buf[100];
struct Lisp_Subwindow *sw = XSUBWINDOW (obj);
struct frame *frm = XFRAME (sw->frame);
if (print_readably)
error ("printing unreadable object #<subwindow 0x%x>",
sw->header.uid);
write_c_string ("#<subwindow", printcharfun);
sprintf (buf, " %dx%d", sw->width, sw->height);
write_c_string (buf, printcharfun);
/* This is stolen from frame.c. Subwindows are strange in that they
are specific to a particular frame so we want to print in their
description what that frame is. */
write_c_string (" on #<", printcharfun);
if (!FRAME_LIVE_P (frm))
write_c_string ("dead", printcharfun);
else if (FRAME_IS_TTY (frm))
write_c_string ("tty", printcharfun);
else if (FRAME_IS_X (frm))
write_c_string ("x", printcharfun);
else
write_c_string ("UNKNOWN", printcharfun);
write_c_string ("-frame ", printcharfun);
print_internal (frm->name, printcharfun, 1);
sprintf (buf, " 0x%x>", frm->header.uid);
write_c_string (buf, printcharfun);
sprintf (buf, ") 0x%x>", sw->header.uid);
write_c_string (buf, printcharfun);
}
static void
finalize_subwindow (void *header, int for_disksave)
{
struct Lisp_Subwindow *sw = (struct Lisp_Subwindow *) header;
if (for_disksave) finalose (sw);
if (sw->subwindow)
{
XDestroyWindow (DisplayOfScreen (sw->xscreen), sw->subwindow);
sw->subwindow = 0;
}
}
/* subwindows are equal iff they have the same window XID */
static int
subwindow_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
return (XSUBWINDOW (o1)->subwindow == XSUBWINDOW (o2)->subwindow);
}
static unsigned long
subwindow_hash (Lisp_Object obj, int depth)
{
return XSUBWINDOW (obj)->subwindow;
}
/* #### PROBLEM: The display routines assume that the glyph is only
being displayed in one buffer. If it is in two different buffers
which are both being displayed simultaneously you will lose big time.
This can be dealt with in the new redisplay. */
/* #### These are completely un-re-implemented in 19.13. Get it done
for 19.14. */
DEFUN ("make-subwindow", Fmake_subwindow, Smake_subwindow,
0, 3, 0,
"Creates a new `x-window' object of size WIDTH x HEIGHT.\n\
The default is a window of size 1x1, which is also the minimum allowed\n\
window size. Subwindows are per-frame. A buffer being shown in two\n\
different frames will only display a subwindow glyph in the frame in\n\
which it was actually created. If two windows on the same frame are\n\
displaying the buffer then the most recently used window will actually\n\
display the window. If the frame is not specified, the selected frame\n\
is used.")
(width, height, frame)
Lisp_Object width, height, frame;
{
Display *dpy;
Screen *xs;
Window pw;
struct frame *f;
unsigned int iw, ih;
XSetWindowAttributes xswa;
Mask valueMask = 0;
error ("subwindows are not functional in 19.13; they will be in 19.14");
f = get_x_frame (frame);
xs = LISP_DEVICE_TO_X_SCREEN (FRAME_DEVICE (f));
dpy = DisplayOfScreen (xs);
pw = XtWindow (FRAME_X_TEXT_WIDGET (f));
if (NILP (width))
iw = 1;
else
{
CHECK_INT (width, 0);
iw = XINT (width);
if (iw < 1) iw = 1;
}
if (NILP (height))
ih = 1;
else
{
CHECK_INT (height, 0);
ih = XINT (height);
if (ih < 1) ih = 1;
}
{
struct Lisp_Subwindow *sw = alloc_lcrecord (sizeof (struct Lisp_Subwindow),
lrecord_subwindow);
Lisp_Object val;
sw->frame = frame;
sw->xscreen = xs;
sw->parent_window = pw;
sw->height = ih;
sw->width = iw;
xswa.backing_store = Always;
valueMask |= CWBackingStore;
xswa.colormap = DefaultColormapOfScreen (xs);
valueMask |= CWColormap;
sw->subwindow = XCreateWindow (dpy, pw, 0, 0, iw, ih, 0, CopyFromParent,
InputOutput, CopyFromParent, valueMask,
&xswa);
XSETSUBWINDOW (val, sw);
return val;
}
}
/* #### Should this function exist? */
DEFUN ("change-subwindow-property", Fchange_subwindow_property,
Schange_subwindow_property, 3, 3, 0,
"For the given SUBWINDOW, set PROPERTY to DATA, which is a string.")
(subwindow, property, data)
Lisp_Object subwindow, property, data;
{
Atom property_atom;
struct Lisp_Subwindow *sw;
Display *dpy;
CHECK_SUBWINDOW (subwindow, 0);
CHECK_STRING (property, 0);
CHECK_STRING (data, 0);
sw = XSUBWINDOW (subwindow);
dpy = DisplayOfScreen (LISP_DEVICE_TO_X_SCREEN
(FRAME_DEVICE (XFRAME (sw->frame))));
property_atom = XInternAtom (dpy, (char *) string_data (XSTRING (property)),
False);
XChangeProperty (dpy, sw->subwindow, property_atom, XA_STRING, 8,
PropModeReplace, string_data (XSTRING (data)),
string_length (XSTRING (data)));
return (property);
}
DEFUN ("subwindowp", Fsubwindowp, Ssubwindowp, 1, 1, 0,
"Return non-nil if OBJECT is a subwindow.")
(object)
Lisp_Object object;
{
return (SUBWINDOWP (object) ? Qt : Qnil);
}
DEFUN ("subwindow-width", Fsubwindow_width, Ssubwindow_width,
1, 1, 0,
"Width of SUBWINDOW.")
(subwindow)
Lisp_Object subwindow;
{
CHECK_SUBWINDOW (subwindow, 0);
return (make_number (XSUBWINDOW (subwindow)->width));
}
DEFUN ("subwindow-height", Fsubwindow_height, Ssubwindow_height,
1, 1, 0,
"Height of SUBWINDOW.")
(subwindow)
Lisp_Object subwindow;
{
CHECK_SUBWINDOW (subwindow, 0);
return (make_number (XSUBWINDOW (subwindow)->height));
}
DEFUN ("subwindow-xid", Fsubwindow_xid, Ssubwindow_xid, 1, 1, 0,
"Return the xid of SUBWINDOW as a number.")
(subwindow)
Lisp_Object subwindow;
{
CHECK_SUBWINDOW (subwindow, 0);
return (make_number (XSUBWINDOW (subwindow)->subwindow));
}
DEFUN ("resize-subwindow", Fresize_subwindow, Sresize_subwindow,
1, 3, 0,
"Resize SUBWINDOW to WIDTH x HEIGHT.\n\
If a value is nil that parameter is not changed.")
(subwindow, width, height)
Lisp_Object subwindow, width, height;
{
int neww, newh;
struct Lisp_Subwindow *sw;
CHECK_SUBWINDOW (subwindow, 0);
sw = XSUBWINDOW (subwindow);
if (NILP (width))
neww = sw->width;
else
neww = XINT (width);
if (NILP (height))
newh = sw->height;
else
newh = XINT (height);
XResizeWindow (DisplayOfScreen (sw->xscreen), sw->subwindow, neww, newh);
sw->height = newh;
sw->width = neww;
return subwindow;
}
DEFUN ("force-subwindow-map", Fforce_subwindow_map,
Sforce_subwindow_map, 1, 1, 0,
"Generate a Map event for SUBWINDOW.")
(subwindow)
Lisp_Object subwindow;
{
CHECK_SUBWINDOW (subwindow, 0);
XMapWindow (DisplayOfScreen (XSUBWINDOW (subwindow)->xscreen),
XSUBWINDOW (subwindow)->subwindow);
return subwindow;
}
/************************************************************************/
/* initialization */
/************************************************************************/
void
syms_of_glyphs_x (void)
{
defsymbol (&Qcursorp, "cursorp");
defsubr (&Smake_cursor);
defsubr (&Scursorp);
defsubr (&Scursor_name);
defsubr (&Scursor_foreground);
defsubr (&Scursor_background);
defsubr (&Scolorize_image_instance);
defsymbol (&Qsubwindowp, "subwindowp");
defsubr (&Smake_subwindow);
defsubr (&Schange_subwindow_property);
defsubr (&Ssubwindowp);
defsubr (&Ssubwindow_width);
defsubr (&Ssubwindow_height);
defsubr (&Ssubwindow_xid);
defsubr (&Sresize_subwindow);
defsubr (&Sforce_subwindow_map);
defkeyword (&Q_mask_file, ":mask-file");
defkeyword (&Q_mask_data, ":mask-data");
defkeyword (&Q_hotspot_x, ":hotspot-x");
defkeyword (&Q_hotspot_y, ":hotspot-y");
defkeyword (&Q_foreground, ":foreground");
defkeyword (&Q_background, ":background");
#ifdef HAVE_XPM
defkeyword (&Q_color_symbols, ":color-symbols");
#endif
}
void
device_type_create_glyphs_x (void)
{
/* image methods */
DEVICE_HAS_METHOD (x, print_image_instance);
DEVICE_HAS_METHOD (x, finalize_image_instance);
DEVICE_HAS_METHOD (x, image_instance_equal);
DEVICE_HAS_METHOD (x, image_instance_hash);
}
void
image_instantiator_type_create_glyphs_x (void)
{
/* image-instantiator types */
INITIALIZE_IMAGE_INSTANTIATOR_TYPE (xbm, "xbm");
IITYPE_HAS_METHOD (xbm, validate);
IITYPE_HAS_METHOD (xbm, normalize);
IITYPE_HAS_METHOD (xbm, instantiate);
IITYPE_VALID_KEYWORD (xbm, Q_data, valid_xbm_inline_p);
IITYPE_VALID_KEYWORD (xbm, Q_file, valid_string_p);
IITYPE_VALID_KEYWORD (xbm, Q_mask_data, valid_xbm_inline_p);
IITYPE_VALID_KEYWORD (xbm, Q_mask_file, valid_string_p);
IITYPE_VALID_KEYWORD (xbm, Q_hotspot_x, valid_int_p);
IITYPE_VALID_KEYWORD (xbm, Q_hotspot_y, valid_int_p);
IITYPE_VALID_KEYWORD (xbm, Q_foreground, valid_string_p);
IITYPE_VALID_KEYWORD (xbm, Q_background, valid_string_p);
#ifdef HAVE_JPEG
INITIALIZE_IMAGE_INSTANTIATOR_TYPE (jpeg, "jpeg");
IITYPE_HAS_METHOD (jpeg, validate);
IITYPE_HAS_METHOD (jpeg, normalize);
IITYPE_HAS_METHOD (jpeg, instantiate);
IITYPE_VALID_KEYWORD (jpeg, Q_data, valid_string_p);
IITYPE_VALID_KEYWORD (jpeg, Q_file, valid_string_p);
#endif
#ifdef HAVE_GIF
INITIALIZE_IMAGE_INSTANTIATOR_TYPE (gif, "gif");
IITYPE_HAS_METHOD (gif, validate);
IITYPE_HAS_METHOD (gif, normalize);
IITYPE_HAS_METHOD (gif, instantiate);
IITYPE_VALID_KEYWORD (gif, Q_data, valid_string_p);
IITYPE_VALID_KEYWORD (gif, Q_file, valid_string_p);
#endif
#ifdef HAVE_PNG
INITIALIZE_IMAGE_INSTANTIATOR_TYPE (png, "png");
IITYPE_HAS_METHOD (png, validate);
IITYPE_HAS_METHOD (png, normalize);
IITYPE_HAS_METHOD (png, instantiate);
IITYPE_VALID_KEYWORD (png, Q_data, valid_string_p);
IITYPE_VALID_KEYWORD (png, Q_file, valid_string_p);
#endif
#ifdef HAVE_XPM
INITIALIZE_IMAGE_INSTANTIATOR_TYPE (xpm, "xpm");
IITYPE_HAS_METHOD (xpm, validate);
IITYPE_HAS_METHOD (xpm, normalize);
IITYPE_HAS_METHOD (xpm, instantiate);
IITYPE_VALID_KEYWORD (xpm, Q_data, valid_string_p);
IITYPE_VALID_KEYWORD (xpm, Q_file, valid_string_p);
IITYPE_VALID_KEYWORD (xpm, Q_color_symbols, valid_xpm_color_symbols_p);
#endif
#ifdef HAVE_XFACE
INITIALIZE_IMAGE_INSTANTIATOR_TYPE (xface, "xface");
IITYPE_HAS_METHOD (xface, validate);
IITYPE_HAS_METHOD (xface, normalize);
IITYPE_HAS_METHOD (xface, instantiate);
IITYPE_VALID_KEYWORD (xface, Q_data, valid_string_p);
IITYPE_VALID_KEYWORD (xface, Q_file, valid_string_p);
IITYPE_VALID_KEYWORD (xface, Q_hotspot_x, valid_int_p);
IITYPE_VALID_KEYWORD (xface, Q_hotspot_y, valid_int_p);
IITYPE_VALID_KEYWORD (xface, Q_foreground, valid_string_p);
IITYPE_VALID_KEYWORD (xface, Q_background, valid_string_p);
#endif
INITIALIZE_IMAGE_INSTANTIATOR_TYPE (autodetect, "autodetect");
IITYPE_HAS_METHOD (autodetect, validate);
IITYPE_HAS_METHOD (autodetect, normalize);
IITYPE_HAS_METHOD (autodetect, instantiate);
IITYPE_VALID_KEYWORD (autodetect, Q_data, valid_string_p);
}
void
vars_of_glyphs_x (void)
{
#ifdef HAVE_JPEG
Fprovide (Qjpeg);
#endif
#ifdef HAVE_GIF
Fprovide (Qgif);
#endif
#ifdef HAVE_PNG
Fprovide (Qpng);
#endif
#ifdef HAVE_XPM
Fprovide (Qxpm);
DEFVAR_LISP ("xpm-color-symbols", &Vxpm_color_symbols,
"Definitions of logical color-names used when reading XPM files.\n\
Elements of this list should be of the form (COLOR-NAME FORM-TO-EVALUATE).\n\
The COLOR-NAME should be a string, which is the name of the color to define;\n\
the FORM should evaluate to a `color' specifier object, or a string to be\n\
passed to `make-color-instance'. If a loaded XPM file references a symbolic\n\
color called COLOR-NAME, it will display as the computed color instead.\n\
\n\
The default value of this variable defines the logical color names\n\
\"foreground\" and \"background\" to be the colors of the `default' face.");
Vxpm_color_symbols = Qnil; /* initialized in x-faces.el */
#endif
#ifdef HAVE_XFACE
Fprovide (Qxface);
#endif
DEFVAR_LISP ("x-bitmap-file-path", &Vx_bitmap_file_path,
"A list of the directories in which X bitmap files may be found.\n\
If nil, this is initialized from the \"*bitmapFilePath\" resource.\n\
This is used by the `make-image-instance' function (however, note that if\n\
the environment variable XBMLANGPATH is set, it is consulted first).");
Vx_bitmap_file_path = Qnil;
}
void
complex_vars_of_glyphs_x (void)
{
#define BUILD_GLYPH_INST(variable, name) \
Fadd_spec_to_specifier \
(GLYPH_IMAGE (XGLYPH (variable)), \
vector3 (Qxbm, Q_data, \
list3 (make_number (name##_width), \
make_number (name##_height), \
make_ext_string ((char *) name##_bits, \
sizeof (name##_bits)))), \
Qglobal, Qx, Qnil)
BUILD_GLYPH_INST (Vtruncation_glyph, truncator);
BUILD_GLYPH_INST (Vcontinuation_glyph, continuer);
BUILD_GLYPH_INST (Vxemacs_logo, xemacs);
#undef BUILD_GLYPH_INST
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.