This is device-x.c in view mode; [Download] [Up]
/* Device functions for X windows.
Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
Copyright (C) 1994, 1995 Amdahl Corporation.
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 authors: Jamie Zawinski and the FSF */
/* Rewritten by Ben Wing and Chuck Thompson. */
#include <config.h>
#include "lisp.h"
#include "device-x.h"
#include "frame-x.h"
#include "xintrinsicp.h" /* CoreP.h needs this */
#include <X11/CoreP.h> /* Numerous places access the fields of
a core widget directly. We could
use XtVaGetValues(), but ... */
#include "xgccache.h"
#include <X11/Shell.h>
#include "xmu.h"
#include "glyphs-x.h"
#include "objects-x.h"
#include "buffer.h"
#include "events.h"
#include "faces.h"
#include "redisplay.h"
#include "sysdep.h"
#include "window.h"
#include "sysfile.h"
#include "systime.h"
Lisp_Object Vdefault_x_device;
DEFINE_DEVICE_TYPE (x);
/* Qdisplay in general.c */
Lisp_Object Qargv_list;
Lisp_Object Qx_error;
/* The application class of Emacs. */
Lisp_Object Vx_emacs_application_class;
static XrmOptionDescRec emacs_options[] = {
{"-geometry", ".geometry", XrmoptionSepArg, NULL},
{"-iconic", ".iconic", XrmoptionNoArg, (XtPointer) "yes"},
{"-internal-border-width", "*EmacsFrame.internalBorderWidth",
XrmoptionSepArg, NULL},
{"-ib", "*EmacsFrame.internalBorderWidth", XrmoptionSepArg, NULL},
{"-scrollbar-width", "*EmacsFrame.scrollBarWidth", XrmoptionSepArg, NULL},
{"-scrollbar-height", "*EmacsFrame.scrollBarHeight", XrmoptionSepArg, NULL},
/* #### Beware! If the type of the shell changes, update this. */
{"-T", "*EmacsShell.title", XrmoptionSepArg, (XtPointer) NULL},
{"-wn", "*EmacsShell.title", XrmoptionSepArg, (XtPointer) NULL},
{"-title", "*EmacsShell.title", XrmoptionSepArg, (XtPointer) NULL},
{"-iconname", "*EmacsShell.iconName", XrmoptionSepArg, (XtPointer) NULL},
{"-in", "*EmacsShell.iconName", XrmoptionSepArg, (XtPointer) NULL},
{"-mc", "*pointerColor", XrmoptionSepArg, (XtPointer) NULL},
{"-cr", "*cursorColor", XrmoptionSepArg, (XtPointer) NULL}
};
#ifdef I18N4
extern void init_input (CONST char *res_name, CONST char *res_class,
Display *display);
#endif
static void validify_resource_string (char *str);
/* Functions to synchronize mirroring resources and specifiers */
int in_resource_setting;
int in_specifier_change_function;
/************************************************************************/
/* helper functions */
/************************************************************************/
struct device *
get_device_from_display (Display *dpy)
{
Lisp_Object dev;
DEVICE_LOOP (dev)
{
struct device *d = XDEVICE (XCAR (dev));
if (DEVICE_IS_X (d) && DEVICE_X_DISPLAY (d) == dpy)
return d;
}
/* Only devices we are actually managing should ever be used as an
argument to this function. */
abort ();
return 0; /* suppress compiler warning */
}
struct device *
get_x_device (Lisp_Object device)
{
if (NILP (device))
device = Fselected_device ();
/* quietly accept frames for the device arg */
if (FRAMEP (device))
device = XFRAME (device)->device;
CHECK_X_DEVICE (device, 0);
return XDEVICE (device);
}
Display *
get_x_display (Lisp_Object device)
{
return DEVICE_X_DISPLAY (get_x_device (device));
}
/************************************************************************/
/* initializing an X connection */
/************************************************************************/
static void
allocate_x_device_struct (struct device *d)
{
d->device_data = (struct x_device *) xmalloc (sizeof (struct x_device));
/* zero out all slots. */
memset (d->device_data, 0, sizeof (struct x_device));
}
static void
Xatoms_of_device_x (struct device *d)
{
Display *display = DEVICE_X_DISPLAY (d);
#define ATOM(x) XInternAtom (display, (x), False)
DEVICE_XATOM_WM_PROTOCOLS (d) = ATOM ("WM_PROTOCOLS");
DEVICE_XATOM_WM_DELETE_WINDOW (d) = ATOM ("WM_DELETE_WINDOW");
DEVICE_XATOM_WM_SAVE_YOURSELF (d) = ATOM ("WM_SAVE_YOURSELF");
DEVICE_XATOM_WM_TAKE_FOCUS (d) = ATOM ("WM_TAKE_FOCUS");
DEVICE_XATOM_WM_STATE (d) = ATOM ("WM_STATE");
}
static void
sanity_check_geometry_resource (Display *dpy)
{
char *app_name, *app_class, *s;
char buf1 [255], buf2 [255];
char *type;
XrmValue value;
XtGetApplicationNameAndClass (dpy, &app_name, &app_class);
strcpy (buf1, app_name);
strcpy (buf2, app_class);
for (s = buf1; *s; s++) if (*s == '.') *s = '_';
strcat (buf1, "._no_._such_._resource_.geometry");
strcat (buf2, "._no_._such_._resource_.Geometry");
if (XrmGetResource (XtDatabase (dpy), buf1, buf2, &type, &value) == True)
{
warn_when_safe (Qgeometry, Qerror,
"\n\
Apparently \"%s*geometry: %s\" or \"%s*geometry: %s\" was\n\
specified in the resource database. Specifying \"*geometry\" will make\n\
XEmacs (and most other X programs) malfunction in obscure ways. (i.e.\n\
the Xt or Xm libraries will probably crash, which is a very bad thing.)\n\
You should always use \".geometry\" or \"*EmacsFrame.geometry\" instead.\n",
app_name, (char *) value.addr,
app_class, (char *) value.addr);
suppress_early_backtrace = 1;
error ("Invalid geometry resource");
}
}
static void
x_init_device_class (struct device *d)
{
Display *dpy = DEVICE_X_DISPLAY (d);
if (DisplayCells (dpy, DefaultScreen (dpy)) > 2)
{
switch (DefaultVisualOfScreen (DefaultScreenOfDisplay (dpy))->class)
{
case StaticGray:
case GrayScale:
DEVICE_CLASS (d) = Qgrayscale;
default:
DEVICE_CLASS (d) = Qcolor;
}
}
else
DEVICE_CLASS (d) = Qmono;
}
/* #### We either need to fix this to correctly handle multiple
connections to the same display (really fucking hard) or have it
return the already existing connection if one exists. */
static void
x_init_device (struct device *d, Lisp_Object params)
{
Lisp_Object display;
Lisp_Object argv_list;
Lisp_Object device;
Display *dpy;
int argc;
char *disp_name;
char **argv;
char *app_class;
XSETDEVICE (device, d);
display = Fcdr_safe (Fassq (Qdisplay, params));
argv_list = Fcdr_safe (Fassq (Qargv_list, params));
if (!NILP (display))
CHECK_STRING (display, 0);
allocate_x_device_struct (d);
if (NILP (Vdefault_x_device))
Vdefault_x_device = device;
make_argc_argv (argv_list, &argc, &argv);
/* no encapsulation of X functions: use string_ext_data() */
if (STRINGP (Vx_emacs_application_class) &&
string_length (XSTRING (Vx_emacs_application_class)) > 0)
app_class = string_ext_data (XSTRING (Vx_emacs_application_class));
else
app_class = "Emacs";
if (NILP (display))
{
/* If the user didn't explicitly specifify a display to use when
they called make-x-device, then we first check to see if a
display was specified on the command line with -display. If
so, we set disp_name to it. Otherwise we use XDisplayName to
see what DISPLAY is set to. XtOpenDisplay knows how to do
both of these things, but we want to know the name to use in
the error message if XtOpenDisplay fails. */
if (display_arg)
{
int elt;
disp_name = NULL;
for (elt = 0; elt < argc; elt++)
{
if (!strcmp (argv[elt], "-d") || !strcmp (argv[elt], "-display"))
{
if (elt + 1 == argc)
{
suppress_early_backtrace = 1;
error ("-display specified with no arg");
}
else
{
disp_name = argv[elt + 1];
break;
}
}
}
/* assert: display_arg is only set if we found the display
arg earlier so we can't fail to find it now. */
assert (disp_name != NULL);
}
else
disp_name = XDisplayName (0);
}
else
disp_name = string_ext_data2 (XSTRING (display));
slow_down_interrupts ();
/* The Xt code can't deal with signals here. Yuck. */
dpy = DEVICE_X_DISPLAY (d) = XtOpenDisplay (Xt_app_con, disp_name, NULL,
app_class, emacs_options,
XtNumber (emacs_options),
&argc, argv);
speed_up_interrupts ();
if (dpy == 0)
{
suppress_early_backtrace = 1;
error ("X server \"%s\" not responding\n", disp_name);
}
if (NILP (DEVICE_NAME (d)))
DEVICE_NAME (d) = build_string (disp_name);
else
/* We're going to modify the string in-place, so be a nice XEmacs */
DEVICE_NAME (d) = Fcopy_sequence (DEVICE_NAME (d));
/* colons and periods can't appear in individual elements of resource
strings */
validify_resource_string ((char *) string_data (XSTRING (DEVICE_NAME (d))));
DEVICE_XT_APP_SHELL (d) = XtAppCreateShell (NULL, app_class,
applicationShellWidgetClass,
dpy, NULL, 0);
DEVICE_X_DATA (d)->display_name = xstrdup (disp_name);
#ifdef I18N4
init_input (*argv, app_class, dpy);
#endif
DEVICE_X_DATA (d)->argv_list = make_arg_list (argc, argv);
free_argc_argv (argv);
DEVICE_X_WM_COMMAND_FRAME (d) = Qnil;
sanity_check_geometry_resource (dpy);
/* In event-Xt.c */
x_init_modifier_mapping (d);
DEVICE_INFD (d) = DEVICE_OUTFD (d) = ConnectionNumber (dpy);
init_baud_rate (d);
init_one_device (d);
DEVICE_X_GC_CACHE (d) =
make_gc_cache (dpy, RootWindow (dpy, DefaultScreen (dpy)));
DEVICE_X_GRAY_PIXMAP (d) = None;
Xatoms_of_device_x (d);
Xatoms_of_xselect (d);
Xatoms_of_objects_x (d);
x_init_device_class (d);
/* This will cause the elisp side of the X device intialization to
be loaded. At this point we consider the two parts to be one.
They are split up because of requirements in lisp/prim/startup.el */
Frequire (intern ("pre-x-win"), Qnil);
Frequire (intern ("post-x-win"), Qnil);
}
static void
x_mark_device (struct device *d, void (*markobj) (Lisp_Object))
{
((markobj) (DEVICE_X_DATA (d)->argv_list));
((markobj) (DEVICE_X_DATA (d)->WM_COMMAND_frame));
}
static int
x_initially_selected_for_input (struct device *d)
{
return 1;
}
/************************************************************************/
/* closing an X connection */
/************************************************************************/
static void
free_x_device_struct (struct device *d)
{
struct x_device *x_data = DEVICE_X_DATA (d);
if (x_data->display_name)
xfree (x_data->display_name);
xfree (d->device_data);
}
static void
x_delete_device (struct device *d)
{
Lisp_Object rest, device;
Display *display;
#ifdef FREE_CHECKING
extern void (*__free_hook)();
int checking_free;
#endif
XSETDEVICE (device, d);
display = DEVICE_X_DISPLAY (d);
if (display)
{
#ifdef FREE_CHECKING
checking_free = (__free_hook != 0);
/* Disable strict free checking, to avoid bug in X library */
if (checking_free)
disable_strict_free_check ();
#endif
free_gc_cache (DEVICE_X_GC_CACHE (d));
if (DEVICE_X_DATA (d)->x_modifier_keymap)
XFreeModifiermap (DEVICE_X_DATA (d)->x_modifier_keymap);
if (DEVICE_X_DATA (d)->x_keysym_map)
XFree ((char *) DEVICE_X_DATA (d)->x_keysym_map);
XtCloseDisplay (display);
DEVICE_X_DISPLAY (d) = 0;
#ifdef FREE_CHECKING
if (checking_free)
enable_strict_free_check ();
#endif
}
if (EQ (device, Vdefault_x_device))
{
/* #### handle deleting last X device */
Vdefault_x_device = Qnil;
DEVICE_LOOP (rest)
{
if (DEVICE_IS_X (XDEVICE (XCAR (rest))))
{
Vdefault_x_device = XCAR (rest);
break;
}
}
}
free_x_device_struct (d);
}
/************************************************************************/
/* handle X errors */
/************************************************************************/
static CONST char *events[] =
{
"0: ERROR!",
"1: REPLY",
"KeyPress",
"KeyRelease",
"ButtonPress",
"ButtonRelease",
"MotionNotify",
"EnterNotify",
"LeaveNotify",
"FocusIn",
"FocusOut",
"KeymapNotify",
"Expose",
"GraphicsExpose",
"NoExpose",
"VisibilityNotify",
"CreateNotify",
"DestroyNotify",
"UnmapNotify",
"MapNotify",
"MapRequest",
"ReparentNotify",
"ConfigureNotify",
"ConfigureRequest",
"GravityNotify",
"ResizeRequest",
"CirculateNotify",
"CirculateRequest",
"PropertyNotify",
"SelectionClear",
"SelectionRequest",
"SelectionNotify",
"ColormapNotify",
"ClientMessage",
"MappingNotify",
"LASTEvent"
};
CONST char *
x_event_name (int event_type)
{
if (event_type < 0) return 0;
if (event_type >= (sizeof (events) / sizeof (char *))) return 0;
return events [event_type];
}
/* Handling errors.
If an X error occurs which we are not expecting, we have no alternative
but to print it to stderr. It would be nice to stuff it into a pop-up
buffer, or to print it in the minibuffer, but that's not possible, because
one is not allowed to do any I/O on the display connection from an error
handler. The guts of Xlib expect these functions to either return or exit.
However, there are occasions when we might expect an error to reasonably
occur. The interface to this is as follows:
Before calling some X routine which may error, call
expect_x_error (dpy);
Just after calling the X routine, call either:
x_error_occurred_p (dpy);
to ask whether an error happened (and was ignored), or:
signal_if_x_error (dpy, resumable_p);
which will call Fsignal() with args appropriate to the X error, if there
was one. (Resumable_p is whether the debugger should be allowed to
continue from the call to signal.)
You must call one of these two routines immediately after calling the X
routine; think of them as bookends like BLOCK_INPUT and UNBLOCK_INPUT.
*/
static int error_expected;
static int error_occurred;
static XErrorEvent last_error;
extern Lisp_Object Qdelete_frame;
/* OVERKILL! */
#ifdef EXTERNAL_WIDGET
static Lisp_Object
x_error_handler_do_enqueue (Lisp_Object frame)
{
Fenqueue_eval_event (Qdelete_frame, frame);
return Qt;
}
static Lisp_Object
x_error_handler_error (Lisp_Object data, Lisp_Object dummy)
{
return Qnil;
}
#endif /* EXTERNAL_WIDGET */
int
x_error_handler (Display *disp, XErrorEvent *event)
{
if (error_expected)
{
error_expected = 0;
error_occurred = 1;
last_error = *event;
}
else
{
#ifdef EXTERNAL_WIDGET
struct frame *f;
struct device *d = get_device_from_display (disp);
if ((event->error_code == BadWindow ||
event->error_code == BadDrawable)
&& ((f = x_any_window_to_frame (d, event->resourceid)) != 0))
{
Lisp_Object frame;
/* one of the windows comprising one of our frames has died.
This occurs particularly with ExternalShell frames when the
client that owns the ExternalShell's window dies.
We cannot do any I/O on the display connection so we need
to enqueue an eval event so that the deletion happens
later.
Furthermore, we need to trap any errors (out-of-memory) that
may occur when Fenqueue_eval_event is called.
*/
if (f->being_deleted)
return 0;
XSETFRAME (frame, f);
if (!NILP (condition_case_1 (Qerror, x_error_handler_do_enqueue,
frame, x_error_handler_error, Qnil)))
{
f->being_deleted = 1;
f->visible = 0;
}
return 0;
}
#endif /* EXTERNAL_WIDGET */
stderr_out ("\n%s: ",
(STRINGP (Vinvocation_name)
? (char *) string_data (XSTRING (Vinvocation_name))
: "xemacs"));
XmuPrintDefaultErrorMessage (disp, event, stderr);
}
return 0;
}
void
expect_x_error (Display *dpy)
{
assert (!error_expected);
XSync (dpy, 0); /* handle pending errors before setting flag */
error_expected = 1;
error_occurred = 0;
}
int
x_error_occurred_p (Display *dpy)
{
int val;
XSync (dpy, 0); /* handle pending errors before setting flag */
val = error_occurred;
error_expected = 0;
error_occurred = 0;
return val;
}
int
signal_if_x_error (Display *dpy, int resumable_p)
{
char buf[1024];
Lisp_Object data;
if (! x_error_occurred_p (dpy))
return 0;
data = Qnil;
sprintf (buf, "0x%X", (unsigned int) last_error.resourceid);
data = Fcons (build_string (buf), data);
{
char num [32];
sprintf (num, "%d", last_error.request_code);
XGetErrorDatabaseText (last_error.display, "XRequest", num, "",
buf, sizeof (buf));
if (! *buf)
sprintf (buf, "Request-%d", last_error.request_code);
data = Fcons (build_string (buf), data);
}
XGetErrorText (last_error.display, last_error.error_code, buf, sizeof (buf));
data = Fcons (build_string (buf), data);
again:
Fsignal (Qx_error, data);
if (! resumable_p) goto again;
return 1;
}
int
x_IO_error_handler (Display *disp)
{
/* This function can GC */
Lisp_Object dev;
struct device *d = get_device_from_display (disp);
if (XINT (Flength (Vdevice_list)) == 1)
{
stderr_out
("\n%s: Fatal I/O Error %d (%s) on display connection \"%s\"\n",
(STRINGP (Vinvocation_name) ?
(char *) string_data (XSTRING (Vinvocation_name)) : "xemacs"),
errno, strerror (errno), DisplayString (disp));
stderr_out
(" after %lu requests (%lu known processed) with %d events remaining.\n",
NextRequest (disp) - 1, LastKnownRequestProcessed (disp),
QLength (disp));
/* assert (!_Xdebug); */
}
else
{
warn_when_safe
(Qx, Qcritical,
"I/O Error %d (%s) on display connection \"%s\"\n"
" after %lu requests (%lu known processed) with "
"%d events remaining.\n",
errno, strerror (errno), DisplayString (disp),
NextRequest (disp) - 1, LastKnownRequestProcessed (disp),
QLength (disp));
}
XSETDEVICE (dev, d);
Fenqueue_eval_event (Qdelete_device, Fcons (Qunbound, dev));
return 0;
}
DEFUN ("x-debug-mode", Fx_debug_mode, Sx_debug_mode, 1, 2, 0,
"With a true arg, make the connection to the X server synchronous.\n\
With false, make it asynchronous. Synchronous connections are much slower,\n\
but are useful for debugging. (If you get X errors, make the connection\n\
synchronous, and use a debugger to set a breakpoint on `x_error_handler'.\n\
Your backtrace of the C stack will now be useful. In asynchronous mode,\n\
the stack above `x_error_handler' isn't helpful because of buffering.)\n\
If DEVICE is not specified, the selected device is assumed.\n\
\n\
Calling this function is the same as calling the C function `XSynchronize',\n\
or starting the program with the `-sync' command line argument.")
(arg, device)
Lisp_Object arg, device;
{
struct device *d = get_x_device (device);
XSynchronize (DEVICE_X_DISPLAY (d), !NILP (arg));
if (!NILP (arg))
message ("X connection is synchronous");
else
message ("X connection is asynchronous");
return arg;
}
/************************************************************************/
/* X resources */
/************************************************************************/
#if 0 /* bah humbug. The whole "widget == resource" stuff is such
a crock of shit that I'm just going to ignore it all. */
/* If widget is NULL, we are retrieving device or global face data. */
static void
construct_name_list (Display *display, Widget widget, char *fake_name,
char *fake_class, char *name, char *class)
{
char *stack [100][2];
Widget this;
int count = 0;
char *name_tail, *class_tail;
if (widget)
{
for (this = widget; this; this = XtParent (this))
{
stack [count][0] = this->core.name;
stack [count][1] = XtClass (this)->core_class.class_name;
count++;
}
count--;
}
else if (fake_name && fake_class)
{
stack [count][0] = fake_name;
stack [count][1] = fake_class;
count++;
}
/* The root widget is an application shell; resource lookups use the
specified application name and application class in preference to
the name/class of that widget (which is argv[0] / "ApplicationShell").
Generally the app name and class will be argv[0] / "Emacs" but
the former can be set via the -name command-line option, and the
latter can be set by changing `x-emacs-application-class' in
lisp/term/x-win.el.
*/
XtGetApplicationNameAndClass (display,
&stack [count][0],
&stack [count][1]);
name [0] = 0;
class [0] = 0;
name_tail = name;
class_tail = class;
for (; count >= 0; count--)
{
strcat (name_tail, stack [count][0]);
for (; *name_tail; name_tail++)
if (*name_tail == '.') *name_tail = '_';
strcat (name_tail, ".");
name_tail++;
strcat (class_tail, stack [count][1]);
for (; *class_tail; class_tail++)
if (*class_tail == '.') *class_tail = '_';
strcat (class_tail, ".");
class_tail++;
}
}
#endif
/* Only the characters [-_A-Za-z0-9] are allowed in the individual
sections of a resource. Convert invalid characters to -. */
static void
validify_resource_string (char *str)
{
while (*str)
{
if (!strchr ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"abcdefghijklmnopqrstuvwxyz"
"0123456789-_", *str))
*str = '-';
str++;
}
}
/* Given a locale and device specification from x-get-resource or
x-get-resource-prefix, return the resource prefix and display to
fetch the resource on. */
static void
x_get_resource_prefix (Lisp_Object locale, Lisp_Object device,
Display **display_out, char *name_out,
char *class_out)
{
char *appname, *appclass;
if (NILP (locale))
locale = Qglobal;
if (NILP (Fvalid_specifier_locale_p (locale)))
signal_simple_error ("Invalid locale", locale);
if (WINDOWP (locale))
/* #### I can't come up with any coherent way of naming windows.
By relative position? That seems tricky because windows
can change position, be split, etc. By order of creation?
That seems less than useful. */
signal_simple_error ("Windows currently can't be resourced", locale);
if (!NILP (device) && !DEVICEP (device))
CHECK_DEVICE (device, 0);
if (DEVICEP (device) && !DEVICE_IS_X (XDEVICE (device)))
device = Qnil;
if (NILP (device))
{
device = DFW_DEVICE (locale);
if (DEVICEP (device) && !DEVICE_IS_X (XDEVICE (device)))
device = Qnil;
if (NILP (device))
device = Vdefault_x_device;
if (NILP (device))
{
*display_out = 0;
return;
}
}
*display_out = DEVICE_X_DISPLAY (XDEVICE (device));
XtGetApplicationNameAndClass (*display_out, &appname, &appclass);
strcpy (name_out, appname);
strcpy (class_out, appclass);
validify_resource_string (name_out);
validify_resource_string (class_out);
if (EQ (locale, Qglobal))
return;
if (BUFFERP (locale))
{
strcat (name_out, ".buffer.");
/* we know buffer is live; otherwise we got an error above. */
strcat (name_out,
(CONST char *) string_data (XSTRING (Fbuffer_name (locale))));
strcat (class_out, ".EmacsLocaleType.EmacsBuffer");
}
else if (FRAMEP (locale))
{
strcat (name_out, ".frame.");
/* we know frame is live; otherwise we got an error above. */
strcat (name_out,
(CONST char *) string_data (XSTRING (Fframe_name (locale))));
strcat (class_out, ".EmacsLocaleType.EmacsFrame");
}
else
{
assert (DEVICEP (locale));
strcat (name_out, ".device.");
/* we know device is live; otherwise we got an error above. */
strcat (name_out,
(CONST char *) string_data (XSTRING (Fdevice_name (locale))));
strcat (class_out, ".EmacsLocaleType.EmacsDevice");
}
return;
}
DEFUN ("x-get-resource", Fx_get_resource, Sx_get_resource, 3, 6, 0,
"Retrieve an X resource from the resource manager.\n\
\n\
The first arg is the name of the resource to retrieve, such as \"font\".\n\
The second arg is the class of the resource to retrieve, like \"Font\".\n\
The third arg should be one of the symbols 'string, 'integer, 'natnum, or\n\
'boolean, specifying the type of object that the database is searched for.\n\
The fourth arg is the locale to search for the resources on, and can\n\
currently be a a buffer, a frame, a device, or 'global. If omitted, it\n\
defaults to 'global.\n\
The fifth arg is the device to search for the resources on. (The resource\n\
database for a particular device is constructed by combining non-device-\n\
specific resources such any command-line resources specified and any\n\
app-defaults files found [or the fallback resources supplied by XEmacs,\n\
if no app-defaults file is found] with device-specific resources such as\n\
those supplied using xrdb.) If omitted, it defaults to the device of\n\
LOCALE, if a device can be derived (i.e. if LOCALE is a frame or device),\n\
and otherwise defaults to the value of `default-x-device'.\n\
The sixth arg NOERROR, if non-nil, means do not signal an error if a\n\
bogus resource specification was retrieved (e.g. if a non-integer was\n\
given when an integer was requested). In this case, a warning is issued\n\
instead.\n\
\n\
The resource names passed to this function are looked up relative to the\n\
locale.\n\
\n\
If you want to search for a subresource, you just need to specify the\n\
resource levels in NAME and CLASS. For example, NAME could be\n\
\"modeline.attributeFont\", and CLASS \"Face.AttributeFont\".\n\
\n\
Specifically,\n\
\n\
1) If LOCALE is a buffer, a call\n\
\n\
(x-get-resource \"foreground\" \"Foreground\" 'string SOME-BUFFER)\n\
\n\
is an interface to a C call something like\n\
\n\
XrmGetResource (db, \"xemacs.buffer.BUFFER-NAME.foreground\",\n\
\"Emacs.EmacsLocaleType.EmacsBuffer.Foreground\",\n\
\"String\");\n\
\n\
2) If LOCALE is a frame, a call\n\
\n\
(x-get-resource \"foreground\" \"Foreground\" 'string SOME-FRAME)\n\
\n\
is an interface to a C call something like\n\
\n\
XrmGetResource (db, \"xemacs.frame.FRAME-NAME.foreground\",\n\
\"Emacs.EmacsLocaleType.EmacsFrame.Foreground\",\n\
\"String\");\n\
\n\
3) If LOCALE is a device, a call\n\
\n\
(x-get-resource \"foreground\" \"Foreground\" 'string SOME-DEVICE)\n\
\n\
is an interface to a C call something like\n\
\n\
XrmGetResource (db, \"xemacs.device.DEVICE-NAME.foreground\",\n\
\"Emacs.EmacsLocaleType.EmacsDevice.Foreground\",\n\
\"String\");\n\
\n\
4) If LOCALE is 'global, a call\n\
\n\
(x-get-resource \"foreground\" \"Foreground\" 'string 'global)\n\
\n\
is an interface to a C call something like\n\
\n\
XrmGetResource (db, \"xemacs.foreground\",\n\
\"Emacs.Foreground\",\n\
\"String\");\n\
\n\
Note that for 'global, no prefix is added other than that of the\n\
application itself; thus, you can use this locale to retrieve\n\
arbitrary application resources, if you really want to.\n\
\n\
The returned value of this function is nil if the queried resource is not\n\
found. If the third arg is `string', a string is returned, and if it is\n\
`integer', an integer is returned. If the third arg is `boolean', then the\n\
returned value is the list (t) for true, (nil) for false, and is nil to\n\
mean ``unspecified.''")
(name, class, type, locale, device, no_error)
Lisp_Object name, class, type, locale, device, no_error;
{
/* #### fixed limit, could be overflowed */
char name_string[1024], class_string[1024];
char *raw_result;
XrmDatabase db;
Display *display;
CHECK_STRING (name, 0);
CHECK_STRING (class, 0);
CHECK_SYMBOL (type, 0);
if (!EQ (type, Qstring) && !EQ (type, Qboolean) &&
!EQ (type, Qinteger) && !EQ (type, Qnatnum))
return
Fsignal (Qwrong_type_argument,
list2 (build_translated_string
("should be string, integer, natnum or boolean"),
type));
x_get_resource_prefix (locale, device, &display, name_string,
class_string);
if (!display)
return Qnil;
db = XtDatabase (display);
strcat (name_string, ".");
strcat (name_string, (CONST char *) string_data (XSTRING (name)));
strcat (class_string, ".");
strcat (class_string, (CONST char *) string_data (XSTRING (class)));
{
XrmValue xrm_value;
XrmName namelist[100];
XrmClass classlist[100];
XrmName *namerest = namelist;
XrmClass *classrest = classlist;
XrmRepresentation xrm_type;
XrmRepresentation string_quark;
int result;
XrmStringToNameList (name_string, namelist);
XrmStringToClassList (class_string, classlist);
string_quark = XrmStringToQuark ("String");
/* ensure that they have the same length */
while (namerest[0] && classrest[0])
namerest++, classrest++;
if (namerest[0] || classrest[0])
signal_simple_error_2
("class list and name list must be the same length", name, class);
result = XrmQGetResource (db, namelist, classlist, &xrm_type, &xrm_value);
if (result != True || xrm_type != string_quark)
return Qnil;
raw_result = (char *) xrm_value.addr;
}
if (EQ (type, Qstring))
return build_string (raw_result);
else if (EQ (type, Qboolean))
{
if (!strcasecmp (raw_result, "off") ||
!strcasecmp (raw_result, "false") ||
!strcasecmp (raw_result,"no"))
return Fcons (Qnil, Qnil);
else if (!strcasecmp (raw_result, "on") ||
!strcasecmp (raw_result, "true") ||
!strcasecmp (raw_result, "yes"))
return Fcons (Qt, Qnil);
else
{
char str[1255];
sprintf (str, "can't convert %s: %s to a Boolean",
name_string, raw_result);
if (!NILP (no_error))
{
warn_when_safe (Qresource, Qwarning, str);
return Qnil;
}
else
{
return Fsignal (Qerror, list1 (build_string (str)));
}
}
}
else if (EQ (type, Qinteger) || EQ (type, Qnatnum))
{
int i;
char c;
if (1 != sscanf (raw_result, "%d%c", &i, &c))
{
char str[1255];
sprintf (str, "can't convert %s: %s to an integer",
name_string, raw_result);
if (!NILP (no_error))
{
warn_when_safe (Qresource, Qwarning, str);
return Qnil;
}
else
{
return Fsignal (Qerror, list1 (build_string (str)));
}
}
else if (EQ (type, Qnatnum) && i < 0)
{
char str[1255];
sprintf (str, "invalid numerical value %d for resource %s",
i, name_string);
if (!NILP (no_error))
{
warn_when_safe (Qresource, Qwarning, str);
return Qnil;
}
else
{
return Fsignal (Qerror, list1 (build_string (str)));
}
}
else
return make_number (i);
}
else
abort ();
/* Can't get here. */
return Qnil; /* shut up compiler */
}
DEFUN ("x-get-resource-prefix", Fx_get_resource_prefix,
Sx_get_resource_prefix, 1, 2, 0,
"Return the resource prefix for LOCALE on DEVICE.\n\
The resource prefix is the strings used to prefix resources if\n\
the LOCALE and DEVICE arguments were passed to `x-get-resource'.\n\
The returned value is a cons of a name prefix and a class prefix.\n\
For example, if LOCALE is a frame, the returned value might be\n\
(\"xemacs.frame.FRAME-NAME\" . \"Emacs.EmacsLocaleType.EmacsFrame\").\n\
If no valid X device for resourcing can be obtained, this function\n\
returns nil. (In such a case, `x-get-resource' would always return nil.)")
(locale, device)
Lisp_Object locale, device;
{
/* #### fixed limit, could be overflowed */
char name[1024], class[1024];
Display *display;
x_get_resource_prefix (locale, device, &display, name, class);
if (!display)
return Qnil;
return Fcons (build_string (name), build_string (class));
}
DEFUN ("x-put-resource", Fx_put_resource, Sx_put_resource, 1, 2, 0,
"Add a resource to the resource database for DEVICE.\n\
RESOURCE-LINE specifies the resource to add and should be a\n\
standard resource specification.")
(resource_line, device)
Lisp_Object resource_line, device;
{
struct device *d = get_device (device);
char *str, *colon_pos;
CHECK_STRING (resource_line, 0);
str = (char *) string_data (XSTRING (resource_line));
if (!(colon_pos = strchr (str, ':')) || strchr (str, '\n'))
invalid:
signal_simple_error ("Invalid resource line", resource_line);
if (strspn (str,
/* Only the following chars are allowed before the colon */
" \t.*?abcdefghijklmnopqrstuvwxyz"
"ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_-") != colon_pos - str)
goto invalid;
if (DEVICE_IS_X (d))
{
XrmDatabase db = XtDatabase (DEVICE_X_DISPLAY (d));
XrmPutLineResource (&db, str);
}
return Qnil;
}
/************************************************************************/
/* display information functions */
/************************************************************************/
DEFUN ("default-x-device", Fdefault_x_device, Sdefault_x_device, 0, 0, 0,
"Return the default X device for resourcing.\n\
This is the first-created X device that still exists.")
()
{
return Vdefault_x_device;
}
DEFUN ("device-x-display", Fdevice_x_display, Sdevice_x_display, 0, 1, 0,
"Return the X display which DEVICE is connected to, as a string.")
(device)
Lisp_Object device;
{
struct device *d = get_x_device (device);
return (make_string ((Bufbyte *) DEVICE_X_DATA (d)->display_name,
strlen (DEVICE_X_DATA (d)->display_name)));
}
DEFUN ("device-x-argv-list", Fdevice_x_argv_list, Sdevice_x_argv_list, 0, 1, 0,
"You should probably not be using this function.")
(device)
Lisp_Object device;
{
struct device *d = get_x_device (device);
return Fcopy_sequence (DEVICE_X_DATA (d)->argv_list);
}
DEFUN ("x-display-visual-class", Fx_display_visual_class,
Sx_display_visual_class, 0, 1, 0,
"Return the visual class of the X display `device' is on.\n\
The returned value will be one of the symbols `static-gray', `gray-scale',\n\
`static-color', `pseudo-color', `true-color', or `direct-color'.")
(device)
Lisp_Object device;
{
switch (DefaultVisualOfScreen
(DefaultScreenOfDisplay (get_x_display (device)))->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");
}
return Qnil; /* suppress compiler warning */
}
static int
x_device_pixel_width (struct device *d)
{
Display *dpy = DEVICE_X_DISPLAY (d);
return DisplayWidth (dpy, DefaultScreen (dpy));
}
static int
x_device_pixel_height (struct device *d)
{
Display *dpy = DEVICE_X_DISPLAY (d);
return DisplayHeight (dpy, DefaultScreen (dpy));
}
static int
x_device_mm_width (struct device *d)
{
Display *dpy = DEVICE_X_DISPLAY (d);
return DisplayWidthMM (dpy, DefaultScreen (dpy));
}
static int
x_device_mm_height (struct device *d)
{
Display *dpy = DEVICE_X_DISPLAY (d);
return DisplayHeightMM (dpy, DefaultScreen (dpy));
}
static int
x_device_bitplanes (struct device *d)
{
Display *dpy = DEVICE_X_DISPLAY (d);
return DisplayPlanes (dpy, DefaultScreen (dpy));
}
static int
x_device_color_cells (struct device *d)
{
Display *dpy = DEVICE_X_DISPLAY (d);
return DisplayCells (dpy, DefaultScreen (dpy));
}
DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
"Return the vendor ID string of the X server `device' on.")
(device)
Lisp_Object device;
{
Display *dpy = get_x_display (device);
char *vendor = ServerVendor (dpy);
if (vendor)
return (build_string (vendor));
else
return (build_string (""));
}
DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0,
"Return the version numbers of the X server `device' is on.\n\
The returned value is a list of three integers: the major and minor\n\
version numbers of the X Protocol in use, and the vendor-specific release\n\
number. See also `x-server-vendor'.")
(device)
Lisp_Object device;
{
Display *dpy = get_x_display (device);
return list3 (make_number (ProtocolVersion (dpy)),
make_number (ProtocolRevision (dpy)),
make_number (VendorRelease (dpy)));
}
DEFUN ("x-valid-keysym-name-p", Fx_valid_keysym_name_p, Sx_valid_keysym_name_p,
1, 1, 0,
"Return true if KEYSYM names a keysym that the X library knows about.\n\
Valid keysyms are listed in the files /usr/include/X11/keysymdef.h and in\n\
/usr/lib/X11/XKeysymDB, or whatever the equivalents are on your system.")
(keysym)
Lisp_Object keysym;
{
CHECK_STRING (keysym, 0);
if (XStringToKeysym (string_ext_data (XSTRING (keysym))))
return Qt;
return Qnil;
}
/************************************************************************/
/* grabs and ungrabs */
/************************************************************************/
DEFUN ("x-grab-pointer", Fx_grab_pointer, Sx_grab_pointer, 0, 3, 0,
"Grab the pointer and restrict it to its current window.\n\
If optional DEVICE argument is nil, the default device will be used.\n\
If optional CURSOR argument is non-nil, change the pointer shape to that\n\
until `x-ungrab-pointer' is called (it should be an object returned by the\n\
`make-cursor' function).\n\
If the second optional argument IGNORE-KEYBOARD is non-nil, ignore all\n\
keyboard events during the grab.\n\
Returns t if the grab is successful, nil otherwise.")
(device, cursor, ignore_keyboard)
Lisp_Object device, cursor, ignore_keyboard;
{
Window w;
int pointer_mode, result;
struct device *d = get_x_device (device);
if (! NILP (cursor))
CHECK_CURSOR (cursor, 0);
if (! NILP (ignore_keyboard))
pointer_mode = GrabModeSync;
else
pointer_mode = GrabModeAsync;
w = XtWindow (FRAME_X_TEXT_WIDGET (device_selected_frame (d)));
/* #### Possibly this needs to gcpro the cursor somehow, but it doesn't
seem to cause a problem if XFreeCursor is called on a cursor in use
in a grab; I suppose the X server counts the grab as a reference
and doesn't free it until it exits? */
result = XGrabPointer (DEVICE_X_DISPLAY (d), w,
False,
ButtonMotionMask | ButtonPressMask
| ButtonReleaseMask | PointerMotionHintMask,
GrabModeAsync, /* Keep pointer events flowing */
pointer_mode, /* Stall keyboard events */
w, /* Stay in this window */
(NILP (cursor) ? 0 : XCURSOR (cursor)->cursor),
CurrentTime);
return ((result == GrabSuccess) ? Qt : Qnil);
}
DEFUN ("x-ungrab-pointer", Fx_ungrab_pointer, Sx_ungrab_pointer, 0, 1, 0,
"Release a pointer grab made with `x-grab-pointer'.\n\
If optional first arg DEVICE is nil the default device is used.\n\
If it is t the pointer will be released on all X devices.")
(device)
Lisp_Object device;
{
if (!EQ (device, Qt))
{
Display *dpy = get_x_display (device);
XUngrabPointer (dpy, CurrentTime);
}
else
{
Lisp_Object rest;
DEVICE_LOOP (rest)
{
struct device *d = XDEVICE (XCAR (rest));
if (DEVICE_IS_X (d))
XUngrabPointer (DEVICE_X_DISPLAY (d), CurrentTime);
}
}
return Qnil;
}
DEFUN ("x-grab-keyboard", Fx_grab_keyboard, Sx_grab_keyboard, 0, 1, 0,
"Grab the keyboard on the given device (defaulting to the selected one).\n\
So long as the keyboard is grabbed, all keyboard events will be delivered\n\
to emacs -- it is not possible for other X clients to eavesdrop on them.\n\
Ungrab the keyboard with `x-ungrab-keyboard' (use an unwind-protect).\n\
Returns t if the grab was successful; nil otherwise.")
(device)
Lisp_Object device;
{
struct device *d = get_x_device (device);
Window w = XtWindow (FRAME_X_TEXT_WIDGET (device_selected_frame (d)));
Display *dpy = DEVICE_X_DISPLAY (d);
Status status;
XSync (dpy, False);
status = XGrabKeyboard (dpy, w, True,
/* I don't really understand sync-vs-async
grabs, but this is what xterm does. */
GrabModeAsync, GrabModeAsync,
/* Use the timestamp of the last user action
read by emacs proper; xterm uses CurrentTime
but there's a comment that says "wrong"...
(Despite the name this is the time of the
last key or mouse event.) */
DEVICE_X_MOUSE_TIMESTAMP (d));
if (status == GrabSuccess)
{
/* The XUngrabKeyboard should generate a FocusIn back to this
window but it doesn't unless we explicitly set focus to the
window first (which should already have it. The net result
is that without this call when x-ungrab-keyboard is called
the selected frame ends up not having focus. */
XSetInputFocus (dpy, w, RevertToParent, DEVICE_X_MOUSE_TIMESTAMP (d));
return Qt;
}
else
return Qnil;
}
DEFUN ("x-ungrab-keyboard", Fx_ungrab_keyboard, Sx_ungrab_keyboard, 0, 1, 0,
"Release a keyboard grab made with `x-grab-keyboard'.")
(device)
Lisp_Object device;
{
Display *dpy = get_x_display (device);
XUngrabKeyboard (dpy, CurrentTime);
return Qnil;
}
/************************************************************************/
/* initialization */
/************************************************************************/
void
syms_of_device_x (void)
{
defsubr (&Sx_debug_mode);
defsubr (&Sx_get_resource);
defsubr (&Sx_get_resource_prefix);
defsubr (&Sx_put_resource);
defsubr (&Sdefault_x_device);
defsubr (&Sdevice_x_display);
defsubr (&Sdevice_x_argv_list);
defsubr (&Sx_display_visual_class);
defsubr (&Sx_server_vendor);
defsubr (&Sx_server_version);
defsubr (&Sx_valid_keysym_name_p);
defsubr (&Sx_grab_pointer);
defsubr (&Sx_ungrab_pointer);
defsubr (&Sx_grab_keyboard);
defsubr (&Sx_ungrab_keyboard);
defsymbol (&Qargv_list, "argv-list");
defsymbol (&Qx_error, "x-error");
}
void
device_type_create_x (void)
{
INITIALIZE_DEVICE_TYPE (x, "x", "device-x-p");
DEVICE_HAS_METHOD (x, init_device);
DEVICE_HAS_METHOD (x, initially_selected_for_input);
DEVICE_HAS_METHOD (x, mark_device);
DEVICE_HAS_METHOD (x, delete_device);
DEVICE_HAS_METHOD (x, device_pixel_width);
DEVICE_HAS_METHOD (x, device_pixel_height);
DEVICE_HAS_METHOD (x, device_mm_width);
DEVICE_HAS_METHOD (x, device_mm_height);
DEVICE_HAS_METHOD (x, device_bitplanes);
DEVICE_HAS_METHOD (x, device_color_cells);
}
void
vars_of_device_x (void)
{
DEFVAR_LISP ("x-emacs-application-class", &Vx_emacs_application_class,
"The X application class of the XEmacs process.\n\
This controls, among other things, the name of the `app-defaults' file\n\
that XEmacs will use. For changes to this variable to take effect, they\n\
must be made before the connection to the X server is initialized, that is,\n\
this variable may only be changed before emacs is dumped, or by setting it\n\
in the file lisp/term/x-win.el.");
Vx_emacs_application_class = Fpurecopy (build_string ("Emacs"));
Fprovide (Qx);
staticpro (&Vdefault_x_device);
Vdefault_x_device = Qnil;
error_expected = 0;
error_occurred = 0;
in_resource_setting = 0;
in_specifier_change_function = 0;
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.