/*
   Copyright (C) 1985, 1986, 1987, 1988, 1989, 1990
                 Free Software Foundation, Inc.

This file is part of Epoch, a modified version of GNU Emacs.

Epoch is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY.  No author or distributor
accepts responsibility to anyone for the consequences of using it
or for whether it serves any particular purpose or works at all,
unless he says so in writing.  Refer to the GNU Emacs General Public
License for full details.

Everyone is granted permission to copy, modify and redistribute
Epoch, but only under the conditions described in the
GNU Emacs General Public License.   A copy of this license is
supposed to have been given to you along with Epoch so you
can know your rights and responsibilities.  It should be in a
file named COPYING.  Among other things, the copyright notice
and this notice must be preserved on all copies.  */


#include <stdio.h>
#undef NULL

#include <signal.h>
#include <sys/ioctl.h>
/* load sys/types.h, but make sure we haven't done it twice */
#ifndef makedev
#include <sys/types.h>
#endif

#include "config.h"
#include "lisp.h"
#include "x11term.h"
#include "dispextern.h"
#include "screen.h"
#include "screenW.h"
#include "screenX.h"
#include "xdefault.h"
#include "xresource.h"

extern int in_display;
extern int interrupt_input;
void DEBUG();

/* variables first */

extern struct X_Screen *cur_Xscreen;    /* current active screen */
extern struct W_Screen *cur_Wscreen;
extern struct Root_Block *cur_root;

/* Default values - set up Lisp Objects later to point into these */
extern Display *XD_display;                    /* default display */
extern char XD_is_color;                        /* color display? */
extern char * XD_display_name;                 /* its name */
extern char * XD_resource_name;                /* process resource name */
extern char * XD_resource_class;                /* resource class */
extern int XD_plane;

extern Atom XA_current;                 /* current property atom */
extern Atom XA_rootblock;                       /* root block sequence # */

/* mini buffer statics -
 * The mini buff serves as an anchor for the whole display structure.
 * Minibuff->root is the root structure for the minibuff, and it has
 * pointers into a ring of all the other root blocks
 */
extern struct Root_Block *mini_root;
extern Lisp_Object minibuf_rootblock;

extern Lisp_Object Vx_screen_properties;

/* external object */

/* CODE */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* list of symbols recognized for screen property alist */
extern Lisp_Object Qx_cursor_glyph;
extern Lisp_Object Qx_title;
extern Lisp_Object Qx_name,Qx_icon_name;
extern Lisp_Object Qx_class;
extern Lisp_Object Qx_font;
extern Lisp_Object Qx_geometry;
extern Lisp_Object Qx_foreground,Qx_background,Qx_border_color;
extern Lisp_Object Qx_cursor_foreground,Qx_cursor_background;
extern Lisp_Object Qx_cursor_color;
extern Lisp_Object Qx_initial_state,Qx_update;
extern Lisp_Object Qx_reverse,Qx_in_border_width,Qx_ex_border_width;
extern Lisp_Object Qx_motion_hints;
extern Lisp_Object Qx_parent;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
struct Alist_Entry
    {
    Lisp_Object *symbol;
    char *name;
    VOID *slot;
    XDefaultType type;
    } ;

/* static variables for use in alist reader */

static struct Default_Set alist_xd;

static struct Alist_Entry alistkey[] = {
    { &Qx_cursor_glyph, "Cursor glyph", (VOID *) &alist_xd.cursor_glyph, XDT_Int } ,
    { &Qx_title, "Title", (VOID *) &alist_xd.name, XDT_String } ,
    { &Qx_name, "Name", (VOID *) &alist_xd.resource, XDT_String } ,
    { &Qx_class, "Class", (VOID *) &alist_xd.class, XDT_String },
    { &Qx_icon_name, "Icon Name", (VOID *) &alist_xd.icon_name, XDT_String },
    { &Qx_geometry, "Geometry", (VOID *) &alist_xd.requested_geometry, XDT_String } ,
    { &Qx_foreground, "Foreground", (VOID *) &alist_xd.foreground, XDT_String } ,
    { &Qx_background, "Background", (VOID *) &alist_xd.background, XDT_String } ,
    { &Qx_cursor_color, "Text cursor color", (VOID *) &alist_xd.cursor, XDT_String } ,
    { &Qx_border_color, "Border Color", (VOID *) &alist_xd.color_border, XDT_String },
    { &Qx_cursor_foreground, "Cursor Foreground Color", (VOID *) &alist_xd.xfcursor, XDT_String } ,
    { &Qx_cursor_background, "Cursor Background Color", (VOID *) &alist_xd.xbcursor, XDT_String } ,
    { &Qx_in_border_width, "In border width", (VOID *) &alist_xd.in_border, XDT_Int },
    { &Qx_ex_border_width, "Ex border width", (VOID *) &alist_xd.out_border, XDT_Int },
    { &Qx_initial_state, "Initial State", (VOID *) &alist_xd.initial_state, XDT_Flag },
    { &Qx_reverse, "Reverse", (VOID *) &alist_xd.reverse, XDT_Flag },
    { &Qx_font, "Font", (VOID *) &alist_xd.font, XDT_String },
    { &Qx_update, "Update", (VOID *) &alist_xd.update_screen, XDT_Flag },
    { &Qx_motion_hints, "Motion Hints", (VOID *) &alist_xd.motion_hints, XDT_Flag },
    { &Qx_parent, "Parent Window", (VOID *) &alist_xd.parent, XDT_Window },
    };
#define alist_size (sizeof(alistkey)/sizeof(struct Alist_Entry))

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* given a default set, read the passed alist and
 * put the values set into the default structure
 */
void x_read_screen_alist(xd,alist)
        Lisp_Object alist;
        struct Default_Set *xd;
    {
    register int ai;
    register struct Alist_Entry *ap;
    Lisp_Object cpair,cvalue,ckey;
    char aflag[alist_size];

    memset(aflag,0,sizeof(aflag)); /* clear flags */

    /* because we need to store the address of the members, we have to
     * copy the structure over, fill it in, and then copy it back
     */
    memcpy(&alist_xd,xd,sizeof(alist_xd));

    for (; !EQ(Qnil,alist) && XTYPE(alist) == Lisp_Cons ; alist = Fcdr(alist))
        {

        QUIT;                   /* allow emergency exit */

        cpair = XCONS(alist)->car;
        if (XTYPE(cpair) != Lisp_Cons) continue;
        ckey = XCONS(cpair)->car;
        cvalue = XCONS(cpair)->cdr;

        for (ai = 0 , ap = alistkey; ai < alist_size ; ++ai, ++ap)
            {
            if (EQ(ckey,*(ap->symbol)) && !aflag[ai])
                {
                switch (ap->type)
                    {
                    case XDT_Int :
                        if (XTYPE(cvalue) != Lisp_Int)
                            error("%s must be an integer",ap->name);
                        *( (int *) (ap->slot) ) = XFASTINT(cvalue);
                        break;
                    case XDT_String :
                        if (XTYPE(cvalue) != Lisp_String)
                            error("%s must be a string",ap->name);
                        *( (unsigned char **) (ap->slot) )
                            = XSTRING(cvalue)->data;
                        break;
                    case XDT_Flag :
                        *((char *)(ap->slot)) = EQ(Qnil,cvalue) ? 0 : 1;
                        break;
                    case XDT_Window :
                        if (XTYPE(cvalue) != Lisp_Xresource ||
                            XXRESOURCE(cvalue)->type != XA_WINDOW)
                            error("Parent must be X-resource window");
                        *((Window *)(ap->slot)) = XXRESOURCE(cvalue)->id;
                        break;
                    }
                aflag[ai] = 1;
                break;          /* leave the for loop */
                }
            }
        }

    /* one bit of special handling */

    memcpy(xd,&alist_xd,sizeof(alist_xd));
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* various utility functions to change the attributes of a screen */
extern Lisp_Object Fepoch_get_color();
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::color-components",
       Fepoch_color_components,Sepoch_color_components,
       1,1,0, "Return a 3-vector containing the red, green and blue components of the COLOR, which should be an X-cardinal resource")
     (color) Lisp_Object color;
{
  XColor c;
  Lisp_Object result;
  BLOCK_INPUT_DECLARE();
  
  if (!XRESOURCEP(color) || XXRESOURCE(color)->type != XA_CARDINAL)
    error("Color argument should be an X-cardinal resource");

  c.pixel = cur_Xscreen->foreground;
  BLOCK_INPUT();
  XQueryColor(cur_Xscreen->display,cur_Xscreen->colormap,&c);
  UNBLOCK_INPUT();
  result = Fmake_vector(make_number(3),Qnil);
  XVECTOR(result)->contents[0] = make_number(c.red);
  XVECTOR(result)->contents[1] = make_number(c.green);
  XVECTOR(result)->contents[2] = make_number(c.blue);
  return result;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::foreground",Fx_foreground,Sx_foreground,0,2,0,
"Set / get the foreground color of a screen")
        (color,seq) Lisp_Object color,seq;
{
  Lisp_Object block;
  struct X_Screen *xs;
  struct Lisp_Vector *v;
  unsigned long pixel;
  Lisp_Object result = Qnil;

  block = find_block(seq);
  if (EQ(block,Qnil)) return Qnil;
  xs = XXSCREEN(XROOT(block)->x11);

  if (EQ(Qnil,color))
    return make_Xresource(xs->display,xs->plane,xs->foreground,XA_CARDINAL);

  color = Fepoch_get_color(color);
  if (EQ(Qnil,color)) return Qnil;
  pixel = XXRESOURCE(color)->id;
        
  XSetForeground(xs->display,xs->gc_norm,pixel);
  XSetBackground(xs->display,xs->gc_rev,pixel);
  result = Qt;
  xs->foreground = pixel;

  return result;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::background",Fx_background,Sx_background,0,2,0,
"Set the background color of a screen") (color,seq) Lisp_Object color,seq;
{
  Lisp_Object block;
  struct X_Screen *xs;
  struct Lisp_Vector *v;
  Lisp_Object result = Qnil;
  XSetWindowAttributes attribs;
  unsigned long pixel;

  block = find_block(seq);
  if (EQ(block,Qnil)) return Qnil;
  xs = XXSCREEN(XROOT(block)->x11);

  if (EQ(Qnil,color))
    return make_Xresource(xs->display,xs->plane,xs->background,XA_CARDINAL);

  color = Fepoch_get_color(color);
  if (EQ(Qnil,color)) return Qnil;
  pixel = XXRESOURCE(color)->id;

  XSetBackground(xs->display,xs->gc_norm,pixel);
  XSetForeground(xs->display,xs->gc_rev,pixel);
  XSetForeground(xs->display,xs->gc_curs,pixel);
  attribs.background_pixel = pixel;
  XChangeWindowAttributes(xs->display,xs->xid,CWBackPixel,&attribs);
  result = Qt;
  xs->background = pixel;

  return result;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::cursor-color",
      Fx_cursor_color,Sx_cursor_color,0,2,0,
"Set the color of the text cursor.") (color,seq) Lisp_Object color,seq;
{
  Lisp_Object block;
  struct X_Screen *xs;
  struct Lisp_Vector *v;
  Lisp_Object result = Qnil;
  unsigned long pixel;

  block = find_block(seq);
  if (EQ(block,Qnil)) return Qnil;
  xs = XXSCREEN(XROOT(block)->x11);

  if (EQ(Qnil,color))
    return make_Xresource(xs->display,xs->plane,xs->foreground,XA_CARDINAL);
    
  color = Fepoch_get_color(color);
  if (EQ(Qnil,color)) return Qnil;
  pixel = XXRESOURCE(color)->id;

  XSetBackground(xs->display,xs->gc_curs,pixel);
  result = Qt;
  xs->cursor_color = pixel;

  return result;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::cursor-glyph",Fx_cursor_glyph,Sx_cursor_glyph,0,2,0,
"Set the cursor glyph of a screen") (glyph,seq) Lisp_Object glyph,seq;
    {
    Lisp_Object block;
    struct X_Screen *xs;
    BLOCK_INPUT_DECLARE();

    block = find_block(seq);
    if (EQ(block,Qnil)) return Qnil;
    xs = XXSCREEN(XROOT(block)->x11);

    if (EQ(Qnil,glyph))
        {
        return make_number(xs->cursor_glyph);
        }

    CHECK_NUMBER(glyph,0);

    BLOCK_INPUT();
    XFreeCursor(xs->display,xs->the_cursor);
    xs->the_cursor = XCreateFontCursor(xs->display, XFASTINT(glyph));
    xs->cursor_glyph = XFASTINT(glyph);

    XDefineCursor (xs->display, xs->xid, xs->the_cursor);
    XRecolorCursor(xs->display,xs->the_cursor,&(xs->xfcursor),&(xs->xbcursor));
    UNBLOCK_INPUT();

    return Qt;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::title",Fx_title,Sx_title,0,2,0,
"Set the title of a screen") (title,seq) Lisp_Object title,seq;
    {
    Lisp_Object block;
    struct X_Screen *xs;
    Lisp_Object result = Qnil;
    char *t;
    BLOCK_INPUT_DECLARE();

    block = find_block(seq);
    if (EQ(block,Qnil)) return Qnil;
    xs = XXSCREEN(XROOT(block)->x11);

    if (EQ(Qnil,title))
        {
        BLOCK_INPUT();
        XFetchName(xs->display,xs->xid,&t);
        UNBLOCK_INPUT();
        result = t ? build_string(t) : build_string("");
        if (t) XFree(t);
        }
    else
        {
        CHECK_STRING(title,0);
        BLOCK_INPUT();
        XStoreName(xs->display,xs->xid,XSTRING(title)->data);
        UNBLOCK_INPUT();
        result = Qt;
        }
    
    return result;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::icon-name",Fx_icon_name,Sx_icon_name,0,2,0,
"Set / get the icon name of a screen")
        (icon_name,seq) Lisp_Object icon_name,seq;
    {
    Lisp_Object block;
    struct X_Screen *xs;
    Lisp_Object result = Qnil;
    char *t;
    BLOCK_INPUT_DECLARE();

    block = find_block(seq);
    if (EQ(block,Qnil)) return Qnil;
    xs = XXSCREEN(XROOT(block)->x11);

    if (EQ(Qnil,icon_name))
        {
        BLOCK_INPUT();
        XGetIconName(xs->display,xs->xid,&t);
        UNBLOCK_INPUT();
        result = t ? build_string(t) : build_string("");
        if (t) XFree(t);
        }
    else
        {
        CHECK_STRING(icon_name,0);
        BLOCK_INPUT();
        XSetIconName(xs->display,xs->xid,XSTRING(icon_name)->data);
        UNBLOCK_INPUT();
        result = Qt;
        }
    
    return result;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* This code provided by my lovely wife Susan. Blame her when it crashes */
char *
x_make_command_line(argc, argv)
int argc;
char *argv[];
    {
    char * cmd_line;
    int  cmd_length = 0;
    int  i;
    int  offset  = 0;

    for (i = 0; i < argc; i++)
        cmd_length += strlen(argv[i]) + 1; /* space for word and space */

    cmd_line = (char *) xmalloc(cmd_length + 1);

    for (i = 0; i < argc; i++)
        {
        sprintf(cmd_line+offset, "%s ", argv[i]);
        offset += strlen(argv[i]) + 1;
        }
    cmd_line[cmd_length-1] = '\0';
    return cmd_line;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::screen-information",Fx_screen_information,Sx_screen_information,
      0,1,0,
      "Returns a list consisting of (x y width height border-width map-state)")
        (screen) Lisp_Object screen;
    {
    Lisp_Object block;
    struct Lisp_Xresource *xr;
    struct Root_Block *rb;
    XWindowAttributes data;
    int real_x,real_y;
    Window child;
    BLOCK_INPUT_DECLARE();

    if (! (xr = ResourceOrScreen(screen,&rb))) return Qnil;

    BLOCK_INPUT();
    XGetWindowAttributes(xr->dpy,xr->id,&data);
    /* x,y returned are relative to parent, but we want root co-ords */
    XTranslateCoordinates(xr->dpy,xr->id,
                          RootWindow(xr->dpy,xr->plane),
                          0,0,&real_x,&real_y,&child);
    UNBLOCK_INPUT();

    /* now we have to create the list of the items */
    return Fcons(make_number(real_x),
                 Fcons(make_number(real_y),
                       Fcons(make_number(data.width),
                             Fcons(make_number(data.height),
                                   Fcons(make_number(data.border_width),
                                         Fcons(make_number(rb ? XXSCREEN(rb->x11)->in_border : 0),
                                               Fcons(data.map_state == IsUnmapped ? Qnil : Qt,
                                                     Qnil)))))));

    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::plane-size",Fx_plane_size,Sx_plane_size,0,0,0,
      "Return the size of the display plane in pixels") ()
    {
    return Fcons(make_number(DisplayWidth(XD_display,XD_plane)),
                 make_number(DisplayHeight(XD_display,XD_plane)));
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::font",Fx_font,Sx_font,0,2,0,
"Takes optional arguments of FONT-NAME and SCREEN. If FONT-NAME is nil,\
 returns current font information. If not nil, it should be string naming\
 a font to load. If SCREEN is nil, the current screen is used, otherwise the\
 screen specified is used.")
        (font_name,seq) Lisp_Object font_name,seq;
{
  Lisp_Object block;
  struct X_Screen *xs;
  struct W_Screen *ws;
  XSizeHints size_hints;
  int minx,miny,z,i;
  BLOCK_INPUT_DECLARE();

  block = find_block(seq);
  if (EQ(block,Qnil)) return Qnil;
  xs = XXSCREEN(XROOT(block)->x11);
  ws = XWSCREEN(XROOT(block)->win);

  if (!NULL(font_name))
    {
      /* stash the current hints for later re-use */
      BLOCK_INPUT();
      z = XGetNormalHints(xs->display,xs->xid,&size_hints);
      UNBLOCK_INPUT();
      if (!z) error("No normal size hints! Can't change font.");

      minx = (size_hints.min_width - xs->in_border) / xs->font_width;
      miny = (size_hints.min_height - xs->in_border) / xs->font_height;

      if (!SetScreenFont(XROOT(block),XSTRING(font_name)->data))
	error("Bad font name");

      xs->pixwidth = ws->width*xs->font_width + 2*xs->in_border;
      xs->pixheight = ws->height*xs->font_height + 2*xs->in_border;

      /* set new size hints */
      size_hints.width = xs->pixwidth;
      size_hints.height = xs->pixheight;
      size_hints.width_inc = xs->font_width;
      size_hints.height_inc = xs->font_height;
      size_hints.min_width = minx*xs->font_width + 2*xs->in_border;
      size_hints.min_height = miny*xs->font_height + 2*xs->in_border;
      BLOCK_INPUT();
      XSetNormalHints(xs->display,xs->xid,&size_hints);

      /* Update all of the GC's hanging about on the screen */
      XSetFont(xs->display,xs->gc_norm,xs->font_id);
      XSetFont(xs->display,xs->gc_rev,xs->font_id);
      XSetFont(xs->display,xs->gc_curs,xs->font_id);

      XResizeWindow(xs->display,xs->xid,xs->pixwidth,xs->pixheight);
      UNBLOCK_INPUT();
    }

  return Fcons(build_string(xs->font_name),
	       Fcons(make_number(xs->font_width),
		     Fcons(make_number(xs->font_height),
			   Qnil)));
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::get-font", Fepoch_get_font, Sepoch_get_font, 1, 1, 0,
       "Get the FONT by name")
     (name) Lisp_Object name;
{
  Font font;
  BLOCK_INPUT_DECLARE();

  if (XRESOURCEP(name) && XXRESOURCE(name)->type == XA_FONT) return name;

  CHECK_STRING(name,0);

  BLOCK_INPUT();
  font = XLoadFont(XD_display,XSTRING(name)->data);
  UNBLOCK_INPUT();

  return font ? make_Xresource(XD_display,XD_plane,font,XA_FONT) : Qnil;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::make-bitmap", Fepoch_make_bitmap, Sepoch_make_bitmap,
       3,3,0,
       "Create an X-bitmap, WIDTH by HEIGHT, with DATA.\n\
DATA should be a string (char vector)")
     (width,height,data) Lisp_Object width,height,data;
{
  Pixmap b;
  BLOCK_INPUT_DECLARE();

  CHECK_STRING(data,2);
  CHECK_NUMBER(width,0);
  CHECK_NUMBER(height,0);

  BLOCK_INPUT();
  b = XCreateBitmapFromData(XD_display,cur_Xscreen->xid,
			    XSTRING(data)->data,
			    XFASTINT(width),XFASTINT(height));
  UNBLOCK_INPUT();

  return b == None ? Qnil : make_Xresource(XD_display, XD_plane, b, XA_BITMAP);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::free-bitmap", Fepoch_free_bitmap, Sepoch_free_bitmap, 1, 1, 0,
       "Free BITMAP in the X server")
     (bitmap) Lisp_Object bitmap;
{
  extern Lisp_Object QXbitmapp;
  if (!XRESOURCEP(bitmap) || XXRESOURCE(bitmap)->type != XA_BITMAP)
    bitmap = wrong_type_argument(QXbitmapp,bitmap);
  XFreePixmap(XXRESOURCE(bitmap)->dpy, XXRESOURCE(bitmap)->id);
  return Qnil;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
raw_query_pointer(dpy,win,xs)
     Display *dpy;
     Window win;
     struct X_Screen *xs;		/* if not-0, use to convert to chars */
{
  Lisp_Object result = Qnil;
  Bool z;
  Window root_win, child_win;
  int rx,ry,x,y;
  unsigned int bstate;
  BLOCK_INPUT_DECLARE();

  BLOCK_INPUT();
  z = XQueryPointer(dpy,win,&root_win, &child_win, &rx, &ry,&x,&y,&bstate);
  UNBLOCK_INPUT();

  if (z == True)
    {
      if (xs)
	{  
	  x = ( x - xs->in_border ) / xs->font_width;
	  y = ( y - xs->in_border ) / xs->font_height;
	}
      result = Fcons(make_number(x),
		     Fcons(make_number(y),
			   Fcons(make_number(bstate),Qnil)));
    }

  return result;
}
/* - - */
DEFUN ("epoch::query-pointer",Fepoch_query_pointer,Sepoch_query_pointer,0,1,0,
"Query the location of the X-window cursor.\
 Returns the list (X Y MOD-STATE). Raw X-coordinates.")
	(scr) Lisp_Object scr;
{
  struct Lisp_Xresource *xr;

  xr = ResourceOrScreen(scr,0);
  return xr ? raw_query_pointer(xr->dpy,xr->id,0) : Qnil;
}
/* - - */
DEFUN ("epoch::query-mouse",Fepoch_query_mouse,Sepoch_query_mouse,0,1,0,
"Query the location of the X-window cursor.\
 Returns the list (X Y MOD-STATE). Character coordinates")
	(screen) Lisp_Object screen;
{
  struct X_Screen *xs;
  
  screen = find_block(screen);
  if (NULL(screen)) return Qnil;
  xs = XXSCREEN(XROOT(screen)->x11);
  return raw_query_pointer(xs->display,xs->xid,xs);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
raw_warp_pointer(dpy,win,x,y,xs)
     Display *dpy;
     Window win;
     int x,y;
     struct X_Screen *xs;		/* if not-0, use to convert to chars */
{
  if (xs)
    {
      x = xs->in_border + XINT(x)*xs->font_width  + xs->font_width/2;
      y = xs->in_border + XINT(y)*xs->font_height + xs->font_height/2;
    }
  XWarpPointer(dpy,None,win,0,0,0,0,x,y);
  return Qt;
}
/* - - */
DEFUN ("epoch::warp-pointer",Fepoch_warp_pointer,Sepoch_warp_pointer,2,3,0,
"Warp the X pointer to X, Y (in pixels) relative to SCREEN.")
        (x,y,screen) Lisp_Object x,y,screen;
{
  struct Lisp_Xresource *xr;

  CHECK_NUMBER(x,0); CHECK_NUMBER(y,0);

  xr = ResourceOrScreen(screen,0);

  return xr ? raw_warp_pointer(xr->dpy,xr->id,XINT(x),XINT(y),0) : Qnil;
}
/* - - */
DEFUN("epoch::warp-mouse",Fepoch_warp_mouse,Sepoch_warp_mouse,2,3,0,
"Warp the X pointer to X,Y (in characters) relative to SCREEN.")
	(x,y,screen) Lisp_Object x,y,screen;
{
  struct X_Screen *xs;

  CHECK_NUMBER(x,0);  CHECK_NUMBER(y,0);

  screen = find_block(screen);
  if (NULL(screen)) return Qnil;
  xs = XXSCREEN(XROOT(screen)->x11);
  return raw_warp_pointer(xs->display,xs->xid,XINT(x),XINT(y),xs);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::query-cursor",Fepoch_query_cursor,Sepoch_query_cursor,0,1,0,
"Return the X, Y character location of the Epoch cursor in a cons pair.\n\
The argument is an optional SCREEN. This location generally corresponds to \n\
point for the selected window on the SCREEN, if it has been updated.")
	(screen) Lisp_Object screen;
{
  struct W_Screen *ws;

  screen = find_block(screen);
  if (NULL(screen)) return Qnil;
  ws = XWSCREEN(XROOT(screen)->win);
  return Fcons(make_number(ws->cursor_x),make_number(ws->cursor_y));
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::send-client-message",
       Fx_send_client_message, Sx_send_client_message, 1,5,0,
"Send a client message to DEST, marking it as being from SOURCE (nil->current screen), with [ DATA ] of [ TYPE ], with [ FORMAT ]. If TYPE and FORMAT are omitted, they are deduced from DATA.")
        (dest,source,data,type,format)
	Lisp_Object dest,source,type,format,data;
{
  int actual_format = 0;
  Atom actual_type;
  unsigned long count;
  VOID * addr;
  int free_storage;
  XEvent ev;
  struct Lisp_Xresource *xr;
  Lisp_Object result;

  /* find our destination first */
  if (! (xr = ResourceOrScreen(dest,0))) return Qnil;

  /* find our source - all we need from this is the window id */
  if (XRESOURCEP(source))
    {
      if (XXRESOURCE(source)->type != XA_WINDOW)
	error("X-resource must be a WINDOW");
      ev.xclient.window = XXRESOURCE(source)->id;
    }
  else
    {
      source = find_block(source);
      if (NULL(source)) error("Source must be screen or X-window resource");
      ev.xclient.window = XXSCREEN(XROOT(source)->x11)->xid;
    }

  /* check format before data, because it can cause the data format to vary */
  if (!NULL(format))
    {
      CHECK_NUMBER(format,2);
      actual_format = XFASTINT(format);
      if (actual_format != 8 && actual_format != 16 && actual_format != 32)
	error("Format must be 8, 16, or 32, or nil");
    }

  /* clear out any cruft */
  bzero((char *) &ev.xclient.data,20);

  /* look for the data */
  if (!NULL(data))
    {
      ConvertEtoX(data,&addr,&count,&actual_type,&actual_format,&free_storage);
      if ((count * actual_format) > 20*8)
	{
	  if (free_storage) free(addr);
	  error("Data is too big to fit in a client message");
	}
      bcopy((char *)addr,&ev.xclient.data,count * (actual_format/8));
      if (free_storage) free(addr);
    }

  if (!NULL(type))
    {
      CHECK_XRESOURCE(type,2);
      if (XXRESOURCE(type)->type != XA_ATOM)
        error("Resource for message type must be an atom");
      actual_type = XXRESOURCE(type)->id;
    }
      
  ev.xany.type = ClientMessage;
  ev.xclient.message_type = actual_type;
  ev.xclient.format = actual_format;
  /* There's no better way to set the mask than to hard code the correct
   * width bit pattern. 1L<<24 == OwnerGrabButtonMask, is the largest
   * This is the word from the X-consortium.
   */
  result = XSendEvent(xr->dpy,xr->id,False,(1L<<25)-1L,&ev) ? Qt : Qnil;
  XFlush(xr->dpy);
  return result;
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::query-tree",Fepoch_query_tree,Sepoch_query_tree,0,1,0,
       "Return the portion of the window tree adjacent to SCREEN. Value is the list ( ROOT PARENT . CHILDREN ).")
    (screen) Lisp_Object screen;
{
  Lisp_Object block;
  Display *dpy;
  Window win;
  int plane;
  Window root,parent,*children;
  unsigned int count;
  int zret;
  Lisp_Object value;
  
  BLOCK_INPUT_DECLARE();
  
  if (XRESOURCEP(screen))
    {
      if (XXRESOURCE(screen)->type != XA_WINDOW)
	error("Screen resource must be of type WINDOW");
      dpy = XXRESOURCE(screen)->dpy;
      plane = XXRESOURCE(screen)->plane;
      win = XXRESOURCE(screen)->id;
    }
  else
    {
      block = find_block(screen);
      if (NULL(block)) return Qnil;
      dpy = XXSCREEN(XROOT(block)->x11)->display;
      plane = XXSCREEN(XROOT(block)->x11)->plane;
      win = XXSCREEN(XROOT(block)->x11)->xid;
    }

  BLOCK_INPUT();
  zret = XQueryTree(dpy,win,&root,&parent,&children,&count);
  UNBLOCK_INPUT();
  /* Thank you, X-Consortium. XQueryTree doesn't return Success like everyone
   * else, it returns 1. (Success is defined to be 0 in the standard header
   * files)
   */

  if (!zret) return Qnil;

  value = Qnil;
  while (count)
    value = Fcons(make_Xresource(dpy,plane,children[--count],XA_WINDOW),value);

  XFree(children);

  return Fcons(make_Xresource(dpy,plane,root,XA_WINDOW),
	       Fcons(parent ?
		     make_Xresource(dpy,plane,parent,XA_WINDOW) : Qnil,
		     value));
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#ifdef DENYS_ALARM
DEFUN ("epoch::set-timer",Fset_timer,Sset_timer,1,1,0,
      "sets up a timer to wake up in ARG milliseconds. When that happens\n\
an event of type timer is entered in the queue.")
     (delay)
     Lisp_Object delay;
{
  extern void set_alarm();
  CHECK_NUMBER (delay,0);
  if (XINT (delay) < 0)
    Fsignal(Qerror,Fcons(build_string("epoch::set-timer expects an argument >= 0"),Fcons(delay,Qnil)));
  set_alarm ((long) XFASTINT(delay),1);
  return Qt;
}
#endif /* DENYS_ALARM */

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#ifdef HAVE_TIMEVAL
#include <sys/time.h>
#define TIMEMODULO 8388607L /* 2^23 - 1 */
DEFUN ("the-time",Fthe_time,Sthe_time,0,0,0,
       "an integer denoting the current time in milliseconds (modulo 2^23 - 1).")
     ()
{
  struct timeval tv;
  unsigned long time;
  gettimeofday(&tv,0);
  time = tv.tv_sec*1000 + tv.tv_usec/1000;
  return (make_number(time % TIMEMODULO));
}
#endif /* HAVE_TIMEVAL */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
void syms_of_xutil()
{
  defsubr(&Sepoch_color_components);
  defsubr(&Sx_foreground);
  defsubr(&Sx_background);
  defsubr(&Sx_cursor_color);
  defsubr(&Sx_cursor_glyph);
  defsubr(&Sx_title);
  defsubr(&Sx_icon_name);
  defsubr(&Sx_font);
  defsubr(&Sepoch_get_font);
  defsubr(&Sepoch_make_bitmap);
  defsubr(&Sepoch_free_bitmap);
  defsubr(&Sx_screen_information);
  defsubr(&Sx_plane_size);
  defsubr(&Sepoch_query_pointer);
  defsubr(&Sepoch_query_mouse);
  defsubr(&Sepoch_warp_pointer);
  defsubr(&Sepoch_warp_mouse);
  defsubr(&Sepoch_query_cursor);
  defsubr(&Sx_send_client_message);
  /*
    defsubr(&Sx_cursor_foreground);
    defsubr(&Sx_cursor_background);
    */
#ifdef DENYS_ALARM
  defsubr(&Sset_timer);
#endif				/* DENYS_ALARM */
#ifdef HAVE_TIMEVAL
  defsubr(&Sthe_time);
#endif
  defsubr(&Sepoch_query_tree);
}
