/*
 * Epoch 4.0 : X-window property handling
 */
/*
 * $Revision: 1.5 $
 * $Source: /import/kaplan/stable/distrib/epoch-4.2/src/RCS/property.c,v $
 * $Date: 92/03/27 14:53:43 $
 * $Author: love $
 */
#ifndef LINT
static char rcsid[] = "$Author: love $ $Date: 92/03/27 14:53:43 $ $Source: /import/kaplan/stable/distrib/epoch-4.2/src/RCS/property.c,v $ $Revision: 1.5 $";
#endif


#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
#ifdef __convex__
extern char *memchr();
#else
#include <memory.h>
#endif /* Convex */

#include "config.h"
#include "lisp.h"
#include "x11term.h"
#include "screen.h"
#include "screenX.h"
#include "xresource.h"

extern Lisp_Object find_block();

/* X11 includes used; use NIL rather than NULL from lisp.h */

extern int interrupt_input;

extern Display *XD_display;

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

#define BYTESIZE 8		/* size of a byte in bits */
/* 16 bit types */
typedef short int int16;
typedef short unsigned int uint16;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static Lisp_Object
FormatSizeHints(hints) XSizeHints *hints;
    {
    Lisp_Object result;
    struct Lisp_Vector *v;

    result = Fmake_vector(make_number(6),Qnil);
    v = XVECTOR(result);

    /* ugly but straightforward - just step through the members and flags
     * and stick in the ones that are there
     */
    if (hints->flags & (PPosition|USPosition))
        v->contents[0] = Fcons(make_number(hints->x),make_number(hints->y));
    if (hints->flags & (PSize|USSize))
        v->contents[1] = Fcons(make_number(hints->width),
                               make_number(hints->height));
    if (hints->flags & PMinSize)
        v->contents[2] = Fcons(make_number(hints->min_width),
                               make_number(hints->min_height));
    if (hints->flags & PMaxSize)
        v->contents[3] = Fcons(make_number(hints->max_width),
                               make_number(hints->max_height));
    if (hints->flags & PResizeInc)
        v->contents[4] = Fcons(make_number(hints->width_inc),
                               make_number(hints->height_inc));
    if (hints->flags & PAspect)
        v->contents[5] = Fcons(make_number(hints->min_aspect.x),
                               Fcons(make_number(hints->min_aspect.y),
                                     Fcons(make_number(hints->max_aspect.x),
                                           make_number(hints->max_aspect.y))));

    return result;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
Lisp_Object
FormatStringProperty(buff,count)
	char *buff;		/* data */
	unsigned long count;	/* actual size of data */
{
    Lisp_Object value = Qnil;	/* return value */
    Lisp_Object temp;		/* temp value holder */
    int len;			/* length of current string */
    char * strend;

    while (count)
      {
	strend = memchr(buff,0,(int)count);
	len = strend ? strend - buff : count;
	if (len)
	  {
	    temp = make_string(buff,len);
	    value = Fcons(temp,value);
	  }
	buff = strend + 1;	/* skip null, or leaving loop if no null */
	count -= len + !!strend;
	}

    return EQ(Qnil,Fcdr(value)) ? Fcar(value) : Fnreverse(value);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
Lisp_Object
FormatInteger32Property(buff,count)
     long *buff; unsigned long count;
{
  Lisp_Object value = Qnil;	/* return value */
  while (count) value = Fcons(make_number(buff[--count]),value);
  return EQ(Qnil,Fcdr(value)) ? Fcar(value) : value;
}
/* - - - */
Lisp_Object
FormatInteger16Property(buff,count)
     int16 *buff; unsigned long count;
{
  Lisp_Object value = Qnil;	/* return value */
  while (count) value = Fcons(make_number(buff[--count]),value);
  return EQ(Qnil,Fcdr(value)) ? Fcar(value) : value;
}
/* - - - */
Lisp_Object
FormatInteger8Property(buff,count)
     char *buff; unsigned long count;
{
  Lisp_Object value = Qnil;	/* return value */
  while (count) value = Fcons(make_number(buff[--count]),value);
  return EQ(Qnil,Fcdr(value)) ? Fcar(value) : value;
}
/* - - - */
Lisp_Object
FormatIntegerProperty(buff,count,format)
     VOID *buff;
     unsigned long count;
     int format;
{
  switch (format)
    {
    case 8 : return FormatInteger8Property((char *)buff,count);
    case 16 : return FormatInteger16Property((int16 *)buff,count);
    case 32 : return FormatInteger32Property((long *)buff,count);
    default : return Qnil;
    }
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
Lisp_Object
FormatCardinal32Property(buff,count)
     unsigned long *buff; unsigned long count;
{
  Lisp_Object value = Qnil;	/* return value */
  while (count) value = Fcons(make_number(buff[--count]),value);
  return EQ(Qnil,Fcdr(value)) ? Fcar(value) : value;
}
/* - - - */
Lisp_Object
FormatCardinal16Property(buff,count)
     uint16 *buff; unsigned long count;
{
  Lisp_Object value = Qnil;	/* return value */
  while (count) value = Fcons(make_number(buff[--count]),value);
  return EQ(Qnil,Fcdr(value)) ? Fcar(value) : value;
}
/* - - - */
Lisp_Object
FormatCardinal8Property(buff,count)
     unsigned char *buff; unsigned long count;
{
  Lisp_Object value = Qnil;	/* return value */
  while (count) value = Fcons(make_number(buff[--count]),value);
  return EQ(Qnil,Fcdr(value)) ? Fcar(value) : value;
}
/* - - -*/
Lisp_Object
FormatCardinalProperty(buff,count,format)
     VOID *buff;
     unsigned long count;
     int format;
{
  switch (format)
    {
    case 8 : return FormatCardinal8Property((unsigned char *)buff,count);
    case 16 : return FormatCardinal16Property((uint16 *)buff,count);
    case 32 : return FormatCardinal32Property((unsigned long *)buff,count);
    default : return Qnil;
    }
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
FormatUnknownProperty(buff,count,type,format)
     VOID *buff;
     unsigned long count;
     Atom type;
     int format;
{
  Lisp_Object value = Qnil;	/* return value */

  switch (format)
    {
    case 32 :
      {
	XID *xid = (XID *) buff;
	int non_zero = 0;
	while (count--)
	  if (non_zero || xid[count])
	    {
	      value = Fcons(make_Xresource(0,0,xid[count],type),value);
	      non_zero = 1;
	    }
      }
      break;
    }

  return EQ(Qnil,Fcdr(value)) ? Fcar(value) : value;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
Lisp_Object
ConvertXtoE(buffer,count,type,format)
     VOID *buffer;
     unsigned long count;
     Atom type;
     int format;
{
  Lisp_Object value = Qnil;

  switch (type)
    {
    case None : value = Qnil; break;
    case XA_STRING : value = FormatStringProperty(buffer,count); break;
    case XA_INTEGER :
      value = FormatIntegerProperty((long *)buffer,count,format);
      break;
    case XA_CARDINAL :
      value = FormatCardinalProperty((unsigned long *)buffer,
				     count,format);
      break;
    case XA_WM_SIZE_HINTS :
      value = FormatSizeHints((XSizeHints *)buffer);
      break;
    default :
      value = FormatUnknownProperty((VOID *)buffer,count,type,format);
      break;
    }
  return value;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* Get a property given its atom, display, and window */
Lisp_Object
raw_get_property(dpy,win,prop)
	Display *dpy;
	Window win;
        Atom prop;
{
  Lisp_Object value = Qnil;
  Atom actual_type;
  int actual_format;
  unsigned char *buffer;
  unsigned long count, remaining;
  int zret;
  BLOCK_INPUT_DECLARE();
  
  BLOCK_INPUT ();
  zret = XGetWindowProperty(dpy, win, prop,
			    0L, 1024L, False, AnyPropertyType,
			    &actual_type, &actual_format,
			    &count, &remaining, &buffer);
  /* if remaining is set, then there's more of the property to get. Let's
   * just do the whole read again, this time with enough space to get it
   * all.
   */
  if (zret == Success && remaining > 0)
    {
      XFree(buffer);
      zret = XGetWindowProperty(dpy,win,prop,
				0L, 1024L + ((remaining + 3) / 4),
				False, AnyPropertyType,
				&actual_type, &actual_format,
				&count, &remaining, &buffer);
    }
  UNBLOCK_INPUT ();
  
  if (zret != Success) return Qnil;   /* failed */

  value = ConvertXtoE(buffer,count,actual_type,actual_format);

  XFree(buffer);
  return value;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::get-property",Fepoch_get_property,Sepoch_get_property,1,2,0,
       "Retrieve the X window property for a screen. Arguments are\n\
PROPERTY: must be a string or an X-resource of type ATOM.\n\
SCREEN: (optional) If present, must be a screen object, a screen id, or and X-resource of type WINDOW. Defaults to the current screen.\n\
Returns the value of the property, or nil if the property couldn't be retrieved.")
        (name,seq) Lisp_Object name,seq;
{
  Lisp_Object block;
  Atom prop = None;
  Display *dpy;
  Window win;
  
  BLOCK_INPUT_DECLARE();
  
  if (XRESOURCEP(seq))
    {
      if (XXRESOURCE(seq)->type != XA_WINDOW)
	error("Screen resource must be of type WINDOW");
      dpy = XXRESOURCE(seq)->dpy;
      win = XXRESOURCE(seq)->id;
    }
  else
    {
      block = find_block(seq);
      if (NIL(block)) return Qnil;
      dpy = XXSCREEN(XROOT(block)->x11)->display;
      win = XXSCREEN(XROOT(block)->x11)->xid;
    }

  if (XTYPE(name) == Lisp_String)
    {
      BLOCK_INPUT ();
      prop = XInternAtom(dpy,XSTRING(name)->data,True);
      UNBLOCK_INPUT ();
    }
  else if (XRESOURCEP(name))
    {
      if (XXRESOURCE(name)->type != XA_ATOM)
	error("Property must be an ATOM X-resource");
      prop = XXRESOURCE(name)->id;
    }
  else
    error("Property must be a string or X-resource ATOM");

  if (prop == None) return Qnil;

  /* now we have the atom, let's ask for the property! */
  return raw_get_property(dpy,win,prop);
}
/* ------------------------------------------------------------------------- */
/* Now, the support for setting properties!
   Need to be able to accept sequences for property values, although we will
   restrict sequences to be of uniform type, otherwise things get confused.
*/
/* ------------------------------------------------------------------------- */
static VOID
VerifyVectorHasConsistentType (vector) Lisp_Object vector;
{
  int i;			/* vector index */
  int type;			/* base type of vector elements */
  XID rtype;			/* Xresource type (if vector of Xresources) */
  int length;			/* vector length */
  struct Lisp_Vector *v = XVECTOR(vector);
  Lisp_Object *element;
  Lisp_Object sample;

  sample = v->contents[0];
  type = XTYPE(sample);
  if (type == Lisp_Xresource) rtype = XXRESOURCE(sample)->type;
  length = v->size;
  element = v->contents;

  for ( i = 1 ; i < length ; ++i, ++element )
    if (XTYPE(*element) != type
	|| (type == Lisp_Xresource && rtype != XXRESOURCE(*element)->type))
      error("Vector has inconsistent types");

}
/* ------------------------------------------------------------------------- */
static VOID
VerifyListHasConsistentType (list) Lisp_Object list;
{
  int type;
  XID rtype;			/* Xresource type (if vector of Xresources) */
  Lisp_Object temp = Fcar(list);

  type = XTYPE(temp);
  if (XRESOURCEP(temp)) rtype = XXRESOURCE(temp)->type;
  list = Fcdr(list);

  for ( ; !NIL(list) ; list = Fcdr(list))
    {
      QUIT;
      temp = Fcar(list);
      if (XTYPE(temp) != type
	  || (type == Lisp_Xresource && XXRESOURCE(temp)->type != rtype))
	error("List has inconsistent types");
    }
}
/* ------------------------------------------------------------------------- */
/* the Calculate functions return allocated memory that must be free'd.
   I tried to use alloca, but that fails. Sigh.
*/
VOID *
CalculateVectorProperty(vector,count,type,format)
     Lisp_Object vector;	/* the vector */
     unsigned long *count;		/* # of items */
     Atom *type;		/* type of data */
     int *format;		/* data format (8,16,32) */
{
  int length;
  unsigned int size,tsize;
  int i;
  struct Lisp_Vector *v;
  VOID *addr;

  v = XVECTOR(vector);
  *count = length = v->size;

  switch (XTYPE(v->contents[0]))
    {
    case Lisp_Int :
      *type = XA_INTEGER;
      if (*format != 8 && *format != 16) *format = 32;
      size = *format * length;
      addr = (VOID *) xmalloc(size);
      for ( i = 0 ; i < length ; ++i )
	switch (*format)
	  {
	  case 32 : ((int *)addr)[i] = XINT(v->contents[i]); break;
	  case 16 : ((int16 *)addr)[i] = XINT(v->contents[i]); break;
	  case 8 : ((char *)addr)[i] = XINT(v->contents[i]); break;
	  }
      break;
    case Lisp_Xresource :
      size = BYTESIZE * sizeof(XID) * length;
      *format = BYTESIZE * sizeof(XID);
      *type = XXRESOURCE(v->contents[0])->type;
      addr = (VOID *) xmalloc(size);
      for ( i = 0 ; i < length ; ++i )
	( (XID *) addr) [i] = XXRESOURCE(v->contents[i])->id;
      break;
    case Lisp_String :
      *format = BYTESIZE * sizeof(char);
      *type = XA_STRING;
      for ( i=0, size=0 ; i < length ; ++i )
	size += XSTRING(v->contents[i])->size + 1; /* include null */
      addr = (VOID *) xmalloc(size);
      *count = size;
      for ( i = 0 , size = 0 ; i < length ; ++i )
	{
	  tsize = XSTRING(v->contents[i])->size + 1;
	  bcopy(XSTRING(v->contents[i])->data, ((char *)addr) + size, tsize);
	  size += tsize;
	}
      break;
    default : error("Invalid type for conversion");
    }
  return addr;
}
/* ------------------------------------------------------------------------- */
VOID *
CalculateListProperty(list,count,type,format)
     Lisp_Object list;	/* the list */
     unsigned long *count;		/* # of items */
     Atom *type;		/* data type */
     int *format;		/* data format (8,16,32) */
{
  int length;
  unsigned int size, tsize;
  int i;
  Lisp_Object tlist,temp;
  VOID *addr;

  *count = length = Flength(list);

  switch (XTYPE(Fcar(list)))
    {
    case Lisp_Int :
      *type = XA_INTEGER;
      if (*format != 8 && *format != 16) *format = 32;
      size = *format * length;
      addr = (VOID *) xmalloc(size);
      for ( i = 0 ; i < length ; ++i, list = Fcdr(list))
	switch (*format)
	  {
	  case 32 : ((int *)addr)[i] = XINT(Fcar(list)); break;
	  case 16 : ((int16 *)addr)[i] = XINT(Fcar(list)); break;
	  case 8 : ((char *)addr)[i] = XINT(Fcar(list)); break;
	  }
      break;
    case Lisp_Xresource :
      size = BYTESIZE * sizeof(XID) * length;
      *format = BYTESIZE * sizeof(XID);
      *type = XXRESOURCE(Fcar(list))->type;
      addr = (VOID *) xmalloc(size);
      for ( i = 0 ; i < length ; ++i, list = Fcdr(list))
	((XID *)addr)[i] = XXRESOURCE(Fcar(list))->id;
      break;
    case Lisp_String :
      *format = BYTESIZE * sizeof(char);
      *type = XA_STRING;
      for ( i=0, size=0 , tlist=list ; i < length ; ++i, tlist = Fcdr(tlist) )
	size += XSTRING(Fcar(tlist))->size + 1; /* include null */
      addr = (VOID *) xmalloc(size);
      *count = size;
      for ( i=0, size=0, tlist=list ; i < length  ; ++i , tlist = Fcdr(tlist) )
	{
	  temp = Fcar(tlist);
	  tsize = XSTRING(temp)->size + 1;
	  bcopy(XSTRING(temp)->data, ((char *)addr) + size, tsize);
	  size += tsize;
	}
      break;
    default : error("Invalid type for conversion");
    }
  return addr;
}
/* ------------------------------------------------------------------------- */
/* Returns whether the conversion was successful or not */
int
ConvertEtoX(value,addr,count,type,format,free_storage)
     Lisp_Object value;
     VOID **addr;		/* pointer to storage */
     unsigned long *count;	/* number of items */
     Atom *type;		/* type of storage */
     int *format;		/* item size */
     int *free_storage;		/* should free() be called after use? */
{

  if (VECTORP(value)) VerifyVectorHasConsistentType(value);
  else if (CONSP(value)) VerifyListHasConsistentType(value);

  *free_storage = 0;
  switch (XTYPE(value))
    {
    case Lisp_String :
      *format = BYTESIZE;
      *type = XA_STRING;
      *count = strlen(XSTRING(value)->data)+1;
      *addr = (VOID *) XSTRING(value)->data;
      break;
    case Lisp_Int :
      *type = XA_INTEGER;
      *count = 1;
      *free_storage = 1;
      *addr = (VOID *) xmalloc(sizeof(int));
      /* This is ugly -
       * we have to deal with the possibility of different formats
       */
      switch (*format)
	{
	default :
	case 32 : *format = 32; *((int *)(*addr)) = XINT(value); break;
	case 16 : *((int16 *)(*addr)) = XINT(value); break;
	case 8 :  *((char *)(*addr)) = XINT(value); break;
	}
      break;
    case Lisp_Xresource :
      *format = sizeof(XID) * BYTESIZE;
      *type = XXRESOURCE(value)->type;
      *count = 1;
      *addr = (VOID *) & (XXRESOURCE(value)->id);
      break;
    case Lisp_Cons :
      *addr = CalculateListProperty(value,count,type,format);
      *free_storage = 1;	/* above allocates storage */
      break;
    case Lisp_Vector :
      *addr = CalculateVectorProperty(value,count,type,format);
      *free_storage = 1;	/* above allocates storage */
      break;
    default :
      error("Improper type for conversion");
    }

  return 1;
}

/* ------------------------------------------------------------------------- */
static Lisp_Object
raw_set_property(dpy,win,prop,value)
     Display *dpy;
     Window win;
     Atom prop;
     Lisp_Object value;
{
  Atom actual_type;		/* X type of items */
  int actual_format;		/* size of data items (8,16,32) */
  unsigned long count;		/* Number of data items */
  VOID * addr;			/* address of data item array */
  int zret;			/* X call return value */
  int free_storage;		/* set if addr points at non-malloc'd store */
  BLOCK_INPUT_DECLARE();

  actual_format = 0;		/* don't force a particular format */
  ConvertEtoX(value,&addr,&count,&actual_type,&actual_format,&free_storage);

  BLOCK_INPUT ();
  zret = XChangeProperty(dpy, win, prop, actual_type, actual_format,
			 PropModeReplace, (char *) addr, count);
  XFlush(dpy);
  UNBLOCK_INPUT ();

  if (free_storage) free(addr);
  return value;
}
/* ------------------------------------------------------------------------- */
DEFUN ("epoch::set-property",Fepoch_set_property,Sepoch_set_property,2,3,0,
      "Set a named property for a screen. The first argument (required)\
is the name of the property. The second is the value to set the propery\
to. The third (optional) is the screen, default is\
the current screen.") (name,value,seq) Lisp_Object name,value,seq;
{
  Lisp_Object block;		/* holder for screen object */
  Atom prop = None;		/* name of the property */
  Window win;			/* window to put property on */
  Display *dpy;			/* display for window */
  BLOCK_INPUT_DECLARE();

  if (XRESOURCEP(seq))
    {
      if (XXRESOURCE(seq)->type != XA_WINDOW)
	error("Screen resource must be of type WINDOW");
      dpy = XXRESOURCE(seq)->dpy;
      win = XXRESOURCE(seq)->id;
    }
  else
    {
      block = find_block(seq);
      if (NIL(block)) return Qnil;
      dpy = XXSCREEN(XROOT(block)->x11)->display;
      win = XXSCREEN(XROOT(block)->x11)->xid;
    }

  /* parse the atom name, either a string or an actual atom */
  if (XTYPE(name) == Lisp_String)
    {
      BLOCK_INPUT ();
      prop = XInternAtom(dpy,XSTRING(name)->data,False);
      UNBLOCK_INPUT ();
    }
  else if (XRESOURCEP(name))
    {
      if (XXRESOURCE(name)->type != XA_ATOM)
	error("Property must be an X-resource ATOM");
      prop = XXRESOURCE(name)->id;
    }
  else
    error("Property must be a string or X-resource ATOM");

  if (prop == None) return Qnil;

  /* that's it. Now set it */
  return raw_set_property(dpy,win,prop,value);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
void syms_of_property()
    {

    defsubr(&Sepoch_get_property);
    defsubr(&Sepoch_set_property);

    }