/*
   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.  */

/* Code for Lisp X Resources */

/*
 * $Revisiou$
 * $Source: /import/kaplan/stable/distrib/epoch-4.2/src/RCS/xresource.c,v $
 * $Date: 91/10/16 16:21:31 $
 * $Author: love $
 */
#ifndef LINT
static char rcsid[] = "$Author: love $ $Date: 91/10/16 16:21:31 $ $Source: /import/kaplan/stable/distrib/epoch-4.2/src/RCS/xresource.c,v $ $Revision: 1.5 $";
#endif

#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 "xresource.h"
#include "screen.h"
#include "screenX.h"

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

extern int distinct_minibuffer;

extern int interrupt_input;

extern Atom XA_current;			/* current property atom */
extern Atom XA_screen_id;			/* root block sequence # */
extern Display *XD_display;
extern int XD_plane;

extern int consing_since_gc;

Lisp_Object Qepoch_resourcep;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* Allocation of X resource cells, in the manner of allocating cons blocks.
 * Depends on malloc having a constant 8 bytes of overhead.
 */

#define XRESOURCE_BLOCK_SIZE \
  ((1016 - sizeof (struct Xresource_block *)) / sizeof (struct Lisp_Xresource))

struct Xresource_block
  {
    struct Xresource_block *next;
    struct Lisp_Xresource xr_cell[XRESOURCE_BLOCK_SIZE];
  };

static struct Xresource_block *xr_block;
static int xr_block_index;

static struct Lisp_Xresource *xr_free_list;

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
void
init_Xresource ()
    {
    xr_block = (struct Xresource_block *) malloc (sizeof (struct Xresource_block));
    xr_block->next = 0;
    bzero (xr_block->xr_cell, sizeof xr_block->xr_cell);
    xr_block_index = 0;
    xr_free_list = 0;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
void
free_Xresource (ptr) struct Lisp_Xresource *ptr;
    {
    XSET(ptr->next, Lisp_Xresource, xr_free_list);
    xr_free_list = ptr;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* This function copied from GNU sources */
Lisp_Object
make_Xresource(dpy,plane,value,atom)
	Display *dpy;
	int plane;
	XID value;
	Atom atom;
    {
    register Lisp_Object val;
    register struct Lisp_Xresource *xr;

#ifdef DATA_SEG_BITS
    if (XUINT((int) xr_free_list))
#else
    if (xr_free_list)
#endif      
	{
	xr = xr_free_list;
	xr_free_list = XXRESOURCE(xr_free_list->next);
	}
    else
	{
	if (xr_block_index == XRESOURCE_BLOCK_SIZE)
	    {
	    register struct Xresource_block *new =
		(struct Xresource_block *) malloc (sizeof (struct Xresource_block));
	    if (!new) memory_full ();
	    new->next = xr_block;
	    xr_block = new;
	    xr_block_index = 0;
	    }
	xr = xr_block->xr_cell + xr_block_index++;
	}

    /* store the data into the resource object */
    XSET (val, Lisp_Xresource, xr);
    xr->id = value;
    xr->type = atom;
    if (dpy != 0)
      {	xr->dpy = dpy; xr->plane = plane; }
    else			/* use defaults */
      { xr->dpy = XD_display; xr->plane = XD_plane; }

    consing_since_gc += sizeof (struct Lisp_Xresource);
    return val;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
void mark_Xresource(xr) Lisp_Object xr; { XMARK(XXRESOURCE(xr)->next); }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* This function copied from GNU sources */
void
Xresource_sweep(total,total_free) int *total, *total_free;
    {
    /* Sweep up unused Xresource's */
    register struct Xresource_block *xrblk;
    register int lim = xr_block_index;
    register int num_free = 0, num_used = 0;

    xr_free_list = 0;
  
    for (xrblk = xr_block; xrblk; xrblk = xrblk->next)
	{
	register int i;
	for (i = 0; i < lim; i++)
	    if (!XMARKBIT (xrblk->xr_cell[i].next))
		{
		XSET(xrblk->xr_cell[i].next, Lisp_Xresource, xr_free_list);
		num_free++;
		xr_free_list = &xrblk->xr_cell[i];
		}
	    else
		{
		num_used++;
		XUNMARK (xrblk->xr_cell[i].next);
		}
	lim = XRESOURCE_BLOCK_SIZE;
	}
    *total = num_used;
    *total_free = num_free;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
int
EqualXresource(xr1,xr2) Lisp_Object xr1,xr2;
    { return XXRESOURCE(xr1)->id == XXRESOURCE(xr2)->id ? Qt : Qnil; }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* This function returns a pointer to an X resource structure. The argument
 * should be an X resource (in which case you get that back), or a screen,
 * in which case a static structure is filled in and the address returned.
 * If the arg is neither, an error is signaled. 0 is returned for valid type
 * but bad value (e.g., dead screen)
 */
static struct Lisp_Xresource ResourceOrScreenStruct;
/* can't have statics in functions! */
struct Lisp_Xresource *
ResourceOrScreen(thing,rb) Lisp_Object thing; struct Root_Block **rb;
    {
    struct X_Screen *xs;
    char * err_msg = "Argument must be a screen or x-window-resource";
    extern Lisp_Object Fcurrent_screen();

    if (rb) *rb = 0;		/* default to X resource */

    if (XTYPE(thing) == Lisp_Xresource)
	{
	if (XXRESOURCE(thing)->type == XA_WINDOW) return XXRESOURCE(thing);
	else error(err_msg);
	}
    else if (EQ(thing,Qnil)) thing = Fcurrent_screen(Qnil);
    else if (XTYPE(thing) == Lisp_Int || XTYPE(thing) == Lisp_Root_Block)
	thing = find_block(thing);
    else error(err_msg);
    
    if (EQ(Qnil,thing)) return 0;

    if (rb) *rb = XROOT(thing);
    xs = XXSCREEN(XROOT(thing)->x11);
    ResourceOrScreenStruct.dpy = xs->display;
    ResourceOrScreenStruct.plane = xs->plane;
    ResourceOrScreenStruct.id = xs->xid;
    ResourceOrScreenStruct.type = XA_WINDOW;
    return &ResourceOrScreenStruct;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
struct Atom_Name
    {
    Atom atom;
    char *name;
    };
/* Names should not be longer than 20 characters, otherwise the print function
 * will have problems.
 */
static struct Atom_Name Atom_List[] =
    {
    XA_ARC, "Arc",
    XA_ATOM, "Atom",
    XA_BITMAP, "Bitmap",
    XA_CARDINAL, "Cardinal",
    XA_CURSOR, "Cursor",
    XA_DRAWABLE, "Drawable",
    XA_FONT, "Font",
    XA_INTEGER, "Integer",
    XA_PIXMAP, "Pixmap",
    XA_POINT, "Point",
    XA_RECTANGLE, "Rectangle",
    XA_STRING, "String",
    XA_WINDOW, "Window",
    XA_WM_HINTS, "WM Hints",
    XA_WM_SIZE_HINTS, "WM Size Hints",
    } ;
#define ATOM_NAME_TABLE_SIZE (sizeof(Atom_List)/sizeof(struct Atom_Name))
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* Interface to the print routines for generating Xresource print output */
void
print_Xresource(xr,buff) Lisp_Object xr; char * buff;
    {
    char * atom_name_type = "Resource";
    int i;
    Atom xr_type = XXRESOURCE(xr)->type;

    for ( i=0 ; i < ATOM_NAME_TABLE_SIZE ; ++i )
	if (xr_type == Atom_List[i].atom)
	    {
	    atom_name_type = Atom_List[i].name;
	    break;
	    }

    /* Be careful! The buffer from print is only 30 characters long. */
    sprintf(buff,"%s %lx",atom_name_type,XXRESOURCE(xr)->id);
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::resourcep",Fepoch_resourcep,Sepoch_resourcep,1,1,0,
"Returns t if the argument is an X resource, nil otherwise")
        (xr) Lisp_Object xr;
    {
    return XTYPE(xr) == Lisp_Xresource ? Qt : Qnil;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::intern-atom",Fepoch_intern_atom,Sepoch_intern_atom,1,1,0,
"Convert a string into an X-window atom, and return it in a resource.")
	(name) Lisp_Object name;
    { 
    Atom atom;
    Display *dpy = XXSCREEN(root->x11)->display;
    int plane = XXSCREEN(root->x11)->plane;
    BLOCK_INPUT_DECLARE();

    CHECK_STRING(name,0);		/* must be a string */

    BLOCK_INPUT ();
    /* string types appear to be null terminated internally */
    atom = XInternAtom(dpy,XSTRING(name)->data,False);
    UNBLOCK_INPUT ();
    return atom ? make_Xresource(dpy,plane,atom,XA_ATOM) : Qnil;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::unintern-atom",Fepoch_unintern_atom,Sepoch_unintern_atom,1,1,0,
"Return the string name of an X-Resource atom.")
        (l_atom) Lisp_Object l_atom;
    {
    char * atom_name;
    Lisp_Object val;
    BLOCK_INPUT_DECLARE();

    CHECK_XRESOURCE(l_atom,1);
    if (XXRESOURCE(l_atom)->type != XA_ATOM)
	error("Resource is not an atom");

    BLOCK_INPUT();
    atom_name = XGetAtomName(XXSCREEN(root->x11)->display,
			     XXRESOURCE(l_atom)->id);
    UNBLOCK_INPUT();
    if (atom_name)
	{
	val = build_string(atom_name);
	XFree(atom_name);
	}
    else val = Qnil;

    return val;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::string-to-resource",Fepoch_string_to_resource,Sepoch_string_to_resource,2,3,0,
"Convert a numeric STRING to an X resource of TYPE,\
 and return the encapsulating X resource object.  Optional\
BASE argument should be a number between 2 and 36, specifying\
the base for converting STRING.")
        (str,type,base) Lisp_Object str,type;
{
  XID id;
  struct Lisp_Xresource *xr;
  unsigned char *ptr;
  int b;

  CHECK_STRING(str,0);
  CHECK_XRESOURCE(type,1);
    
  if (EQ(base,Qnil))
    b = 0;
  else
    {
      CHECK_NUMBER(base,2);
      b = XUINT(base);
      if ( b < 2 || b > 36 ) args_out_of_range_3(base,2,36);
    }
    
  if (XXRESOURCE(type)->type != XA_ATOM)
    error("Resource must be an atom");
  xr = XXRESOURCE(type);

  id = (XID) strtol(XSTRING(str)->data, &ptr, b);

  return (ptr == XSTRING(str)->data)
    ? Qnil
      :	make_Xresource(xr->dpy,xr->plane,id,xr->id);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static char LongToStringBuffer[33]; /* can't have statics inside functions! */
char *
LongToString(n,base)
     unsigned long n;
     unsigned int base;
{
  char *digit = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
  char *s = LongToStringBuffer + 32; /* at most 33 characters in binary */

  *s = 0;			/* terminate */
  while (n)			/* something there */
    {
    *--s = digit[n % base];		/* store bottom digit */
    n /= base;			/* shift right */
    }
  if (*s == 0) *--s = '0';		/* in case nothing was put in string */
  return s;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::resource-to-string",Fepoch_resource_to_string,Sepoch_resource_to_string,
       1,2,0,
"Convert the id of the RESOURCE to a numeric string. Optional BASE specifies the base for the conversion (2..36 inclusive)")
	(resource,base) Lisp_Object resource,base;
{
  int cbase = 10;

  CHECK_XRESOURCE(resource,0);
  if (!NIL(base))
    {
      CHECK_NUMBER(base,1);
      cbase = XUINT(base);
      if ((cbase < 2) || (cbase > 36))
	error("Base for conversation out of range");
    }
  return build_string(LongToString(XXRESOURCE(resource)->id,cbase));
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::resource-to-type",Fepoch_resource_to_type,Sepoch_resource_to_type,1,1,0,
"Return an X resource of type ATOM whose value is the type of the argument")
        (resource) Lisp_Object resource;
    {
    struct Lisp_Xresource *xr;

    CHECK_XRESOURCE(resource,0);
    xr = XXRESOURCE(resource);

    return make_Xresource(xr->dpy,xr->plane,xr->type,XA_ATOM);
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::set-resource-type",Fepoch_set_resource_type,Sepoch_set_resource_type,2,2,0,
"Set the type of the RESOURCE to ATOM.")
        (resource,type) Lisp_Object resource,type;
    {
    XID id;
    int count;
    struct Lisp_Xresource *xr;

    CHECK_XRESOURCE(resource,0);
    CHECK_XRESOURCE(type,1);
    if (XXRESOURCE(type)->type != XA_ATOM)
	error("New type must be an atom");

    XXRESOURCE(resource)->type = XXRESOURCE(type)->id;
    return resource;
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::xid-of-screen",Fepoch_xid_of_screen,Sepoch_xid_of_screen,0,1,0,
"Returns the X resource object for the screen, or nil on error")
(screen) Lisp_Object screen;
    {
    screen = find_block(screen);
    if (EQ(Qnil,screen)) return Qnil;
    return make_Xresource(XXSCREEN(XROOT(screen)->x11)->display,
			  XXSCREEN(XROOT(screen)->x11)->plane,
			  XXSCREEN(XROOT(screen)->x11)->xid,
			  XA_WINDOW);
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
void syms_of_xresource()
    {
    staticpro(&Qepoch_resourcep);		/* why? done in data.c */
    Qepoch_resourcep = intern("epoch::resource-p");

    defsubr(&Sepoch_resourcep);
    defsubr(&Sepoch_intern_atom);
    defsubr(&Sepoch_unintern_atom);
    defsubr(&Sepoch_xid_of_screen);

    defsubr(&Sepoch_string_to_resource);
    defsubr(&Sepoch_resource_to_string);
    defsubr(&Sepoch_set_resource_type);
    defsubr(&Sepoch_resource_to_type);
    }