/* gdbm-module.c
 * SLang bindings for gdbm
 * 
 * $Id: gdbm-module.c,v 1.8 2007/09/16 19:11:31 paul Exp paul $
 * 
 * Copyright (c) 2004, 2005, 2007 Paul Boekholt.
 * Released under the terms of the GNU GPL (version 2 or later).
 */
#include <stdio.h>
#include <string.h>
#include <slang.h>
#include <gdbm.h>

SLANG_MODULE(gdbm);

#define MODULE_MAJOR_VERSION	1
#define MODULE_MINOR_VERSION	7
#define MODULE_PATCH_LEVEL	1
static char *Module_Version_String = "1.7.1";
#define MODULE_VERSION_NUMBER	\
   (MODULE_MAJOR_VERSION*10000+MODULE_MINOR_VERSION*100+MODULE_PATCH_LEVEL)

static int GDBM_Type_Id = 0;
/*{{{ GDBM_Type */

typedef struct
{
   GDBM_FILE p;
   int inuse;
}
GDBM_Type;


static void free_gdbm_type (GDBM_Type *pt)
{
   if (pt->inuse)
     gdbm_close(pt->p);
   SLfree ((char *) pt);
}

/*}}}*/
/*{{{ open */

static SLang_MMT_Type *allocate_gdbm_type (GDBM_FILE p, int flags)
{
   GDBM_Type *pt;
   SLang_MMT_Type *mmt;

   pt = (GDBM_Type *) SLmalloc (sizeof (GDBM_Type));
   if (pt == NULL)
     return NULL;
   memset ((char *) pt, 0, sizeof (GDBM_Type));

   pt->p = p;
   pt->inuse=1;

   if (NULL == (mmt = SLang_create_mmt (GDBM_Type_Id, (VOID_STAR) pt)))
     {
	free_gdbm_type (pt);
	return NULL;
     }   
   return mmt;
}

static int slgdbm_open(char *name, int *flags, int *mode)
{
   SLang_MMT_Type *mmt;
   GDBM_FILE dbf;

   dbf = gdbm_open(name, 0, *flags, *mode, NULL);
   if (dbf==NULL)
     {
	(void) SLang_push_null();
	return -1;
     }
   if (NULL == (mmt = allocate_gdbm_type (dbf, *flags)))
     {
	(void) SLang_push_null();
	gdbm_close(dbf);
	return -1;
     }

   if (-1 == SLang_push_mmt (mmt))
     {
	SLang_free_mmt (mmt);
	(void) SLang_push_null();
	return -1;
     }
   return 0;
}


/*}}}*/
/*{{{ close */

static void slgdbm_close()
{
   GDBM_Type *pt;
   SLang_MMT_Type *mmt;

   if (NULL == (mmt = SLang_pop_mmt (GDBM_Type_Id)))
     return;
   pt = SLang_object_from_mmt (mmt);

   if (pt->inuse)
     {
	gdbm_close(pt->p);
	pt->inuse = 0;
     }
   SLang_free_mmt (mmt);
}


/*}}}*/
/*{{{ store */

static int slgdbm_store(char *key, char *value, int *flags)
{
   GDBM_Type *p;
   SLang_MMT_Type *mmt;
   int ret;
   datum k,v;
   k.dptr=key;
   k.dsize=strlen(key);
   v.dptr=value;
   v.dsize=strlen(value);

   if (NULL == (mmt = SLang_pop_mmt (GDBM_Type_Id)))
     {
	SLang_free_mmt (mmt);
	return -2;
     }
   p = SLang_object_from_mmt (mmt);

   if (p->inuse)
     ret = gdbm_store(p->p, k, v, *flags);
   SLang_free_mmt (mmt);
   return ret;
}

/*}}}*/
/*{{{ fetch */


static void slgdbm_fetch(char *key)
{
   GDBM_Type *p;
   SLang_MMT_Type *mmt;
   datum k,v;
   char *str;
   k.dptr=key;
   k.dsize=strlen(key);

   if (NULL == (mmt = SLang_pop_mmt (GDBM_Type_Id)))
     {
	SLang_free_mmt (mmt);
	(void) SLang_push_null();
	return;
     }
   
   p = SLang_object_from_mmt (mmt);

   if (p->inuse)
     {
	v = gdbm_fetch(p->p, k);
	if (v.dptr == NULL 
	    || (NULL == (str = SLang_create_nslstring((char *)v.dptr, (unsigned int)v.dsize))))
	  (void)SLang_push_null();
	else
	  {
	     (void) SLang_push_string(str);
	     SLang_free_slstring(str);
	  }
	SLfree(v.dptr);
     }
   else
     (void)SLang_push_null();
   SLang_free_mmt (mmt);
}

/*}}}*/
/*{{{ key exists */

static int slgdbm_exists(char *key)
{
   GDBM_Type *p;
   SLang_MMT_Type *mmt;
   datum k;
   int ret=-1;
   k.dptr=key;
   k.dsize=strlen(key);

   if (NULL == (mmt = SLang_pop_mmt (GDBM_Type_Id)))
     {
	SLang_free_mmt (mmt);
	return 0;
     }
   
   p = SLang_object_from_mmt (mmt);

   if (p->inuse)
     ret = gdbm_exists(p->p, k);
   SLang_free_mmt (mmt);
   return ret;
}

/*}}}*/
/*{{{ delete key */

static int slgdbm_delete(char *key)
{
   GDBM_Type *p;
   SLang_MMT_Type *mmt;
   datum k;
   int ret=-1;
   k.dptr=key;
   k.dsize=strlen(key);

   if (NULL == (mmt = SLang_pop_mmt (GDBM_Type_Id)))
     {
	SLang_free_mmt (mmt);
	return 0;
     }
   
   p = SLang_object_from_mmt (mmt);

   if (p->inuse)
     ret = gdbm_delete(p->p, k);
   SLang_free_mmt (mmt);
   return ret;
}

/*}}}*/
/*{{{ get keys */

/* this was adapted from stdio_fgetslines_internal */
static void gdbm_get_keys_internal (GDBM_Type *pt)
{
   unsigned int num_lines, max_num_lines;
   char **list;
   SLang_Array_Type *at;
   SLindex_Type inum_lines;
   datum key, nextkey;
   
   max_num_lines = 1024;

   list = (char **) SLmalloc (sizeof (char *) * max_num_lines);
   if (list == NULL)
     return;

   num_lines = 0;
   
   key = gdbm_firstkey (pt->p);

   while (key.dptr)
     {
	char *strp;
	if (max_num_lines == num_lines)
	  {
	     char **new_list;

	     max_num_lines += 4096;

	     new_list = (char **) SLrealloc ((char *)list, sizeof (char *) * max_num_lines);
	     if (new_list == NULL)
	       {
		  SLfree (key.dptr);
		  goto return_error;
	       }
	     list = new_list;
	  }
	strp = SLang_create_nslstring ((char *)key.dptr, (unsigned int) key.dsize);

	list[num_lines] = strp;
	num_lines++;
	nextkey = gdbm_nextkey (pt->p, key);
	SLfree(key.dptr);
	key = nextkey;
     }

   if (num_lines != max_num_lines)
     {
	char **new_list;

	new_list = (char **)SLrealloc ((char *)list, sizeof (char *) * (num_lines + 1));
	if (new_list == NULL)
	  goto return_error;

	list = new_list;
     }

   inum_lines = (SLindex_Type) num_lines;
   if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) list, &inum_lines, 1)))
     goto return_error;

   if (-1 == SLang_push_array (at, 1))
     SLang_push_null ();
   return;

   return_error:
   while (num_lines > 0)
     {
	num_lines--;
	SLang_free_slstring (list[num_lines]);
     }
   SLfree ((char *)list);
   SLang_push_null ();
}

static void slgdbm_get_keys()
{
   GDBM_Type *pt;
   SLang_MMT_Type *mmt;
   
   if (NULL == (mmt = SLang_pop_mmt (GDBM_Type_Id)))
     return;
   pt = SLang_object_from_mmt (mmt);

   if (pt->inuse)
     {
	gdbm_get_keys_internal(pt);
     }
   else SLang_push_null ();
   SLang_free_mmt (mmt);
}

/*}}}*/
/*{{{ get values */

static void gdbm_get_values_internal (GDBM_Type *pt)
{
   unsigned int num_lines, max_num_lines;
   char **list;
   SLang_Array_Type *at;
   SLindex_Type inum_lines;
   datum key, nextkey, value;
   
   max_num_lines = 1024;

   list = (char **) SLmalloc (sizeof (char *) * max_num_lines);
   if (list == NULL)
     return;

   num_lines = 0;
   
   key = gdbm_firstkey (pt->p);

   while (key.dptr)
     {
	char *strp;

	value = gdbm_fetch(pt->p, key);
	if (value.dptr == NULL)
	  {
	     nextkey = gdbm_nextkey (pt->p, key);
	     SLfree(key.dptr);
	     key = nextkey;
	     continue;
	  }
	     
	if (max_num_lines == num_lines)
	  {
	     char **new_list;

	     max_num_lines += 4096;

	     new_list = (char **) SLrealloc ((char *)list, sizeof (char *) * max_num_lines);
	     if (new_list == NULL)
	       {
		  SLfree (key.dptr);
		  SLfree (value.dptr);
		  goto return_error;
	       }
	     list = new_list;
	  }
	strp = SLang_create_nslstring ((char *)value.dptr, (unsigned int) value.dsize);

	list[num_lines] = strp;
	num_lines++;
	nextkey = gdbm_nextkey (pt->p, key);
	SLfree(key.dptr);
	SLfree(value.dptr);
	key = nextkey;
     }

   if (num_lines != max_num_lines)
     {
	char **new_list;

	new_list = (char **)SLrealloc ((char *)list, sizeof (char *) * (num_lines + 1));
	if (new_list == NULL)
	  goto return_error;

	list = new_list;
     }

   inum_lines = (SLindex_Type) num_lines;
   if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) list, &inum_lines, 1)))
     goto return_error;

   if (-1 == SLang_push_array (at, 1))
     SLang_push_null ();
   return;

   return_error:
   while (num_lines > 0)
     {
	num_lines--;
	SLang_free_slstring (list[num_lines]);
     }
   SLfree ((char *)list);
   SLang_push_null ();
}

static void slgdbm_get_values()
{
   GDBM_Type *pt;
   SLang_MMT_Type *mmt;
   
   if (NULL == (mmt = SLang_pop_mmt (GDBM_Type_Id)))
     return;
   pt = SLang_object_from_mmt (mmt);

   if (pt->inuse)
     {
	gdbm_get_values_internal(pt);
     }
   else SLang_push_null ();
   SLang_free_mmt (mmt);
}

/*}}}*/
/*{{{ get keys and values */
static void gdbm_get_keys_values_internal (GDBM_Type *pt)
{
   unsigned int num_lines, max_num_lines;
   char **list, **list2;
   SLang_Array_Type *at, *at2;
   SLindex_Type inum_lines;
   datum key, nextkey, value;
   
   max_num_lines = 1024;

   list = (char **) SLmalloc (sizeof (char *) * max_num_lines);
   if (list == NULL)
     return;

   list2 = (char **) SLmalloc (sizeof (char *) * max_num_lines);
   if (list2 == NULL)
     {
	SLfree ((char *)list);
	return;
     }

   num_lines = 0;
   
   key = gdbm_firstkey (pt->p);

   while (key.dptr)
     {
	char *strp, *strp2;

	value = gdbm_fetch(pt->p, key);
	if (value.dptr == NULL)
	  {
	     nextkey = gdbm_nextkey (pt->p, key);
	     SLfree(key.dptr);
	     key = nextkey;
	     continue;
	  }
	     
	if (max_num_lines == num_lines)
	  {
	     char **new_list, **new_list2;

	     max_num_lines += 4096;

	     new_list = (char **) SLrealloc ((char *)list, sizeof (char *) * max_num_lines);
	     if (new_list == NULL)
	       {
		  SLfree (key.dptr);
		  SLfree (value.dptr);
		  goto return_error;
	       }
	     list = new_list;
	     new_list2 = (char **) SLrealloc ((char *)list2, sizeof (char *) * max_num_lines);
	     if (new_list2 == NULL)
	       {
		  SLfree (key.dptr);
		  SLfree (value.dptr);
		  goto return_error;
	       }
	     list2 = new_list2;

	  }
	strp = SLang_create_nslstring ((char *)key.dptr, (unsigned int) key.dsize);
	strp2 = SLang_create_nslstring ((char *)value.dptr, (unsigned int) value.dsize);

	list[num_lines] = strp;
	list2[num_lines] = strp2;
	num_lines++;
	nextkey = gdbm_nextkey (pt->p, key);
	SLfree(key.dptr);
	SLfree(value.dptr);
	key = nextkey;
     }

   if (num_lines != max_num_lines)
     {
	char **new_list, **new_list2;

	new_list = (char **)SLrealloc ((char *)list, sizeof (char *) * (num_lines + 1));
	if (new_list == NULL)
	  goto return_error;

	list = new_list;
	
	new_list2 = (char **)SLrealloc ((char *)list2, sizeof (char *) * (num_lines + 1));
	if (new_list2 == NULL)
	  goto return_error;

	list2 = new_list2;
     }

   inum_lines = (SLindex_Type) num_lines;
   if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) list, &inum_lines, 1)))
     goto return_error;
   if (NULL == (at2 = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) list2, &inum_lines, 1)))
     {
	SLang_free_array(at);
	while (num_lines > 0)
	  {
	     num_lines--;
	     SLang_free_slstring (list2[num_lines]);
	  }
	SLfree ((char *)list2);
	SLang_push_null ();
	return;
     }

   if (-1 == SLang_push_array (at, 1))
     SLang_push_null ();
   if (-1 == SLang_push_array (at2, 1))
     SLang_push_null ();
   return;

   return_error:
   while (num_lines > 0)
     {
	num_lines--;
	SLang_free_slstring (list[num_lines]);
	SLang_free_slstring (list2[num_lines]);
     }
   SLfree ((char *)list);
   SLfree ((char *)list2);
   SLang_push_null ();
   SLang_push_null ();
}

static void slgdbm_get_keys_and_values()
{
   GDBM_Type *pt;
   SLang_MMT_Type *mmt;
   
   if (NULL == (mmt = SLang_pop_mmt (GDBM_Type_Id)))
     return;
   pt = SLang_object_from_mmt (mmt);

   if (pt->inuse)
     {
	gdbm_get_keys_values_internal(pt);
     }
   else 
     {
	SLang_push_null ();
	SLang_push_null ();
     }
   SLang_free_mmt (mmt);
}

/*}}}*/
/*{{{ aget/aput */

/* this is from slassoc.c */
static int pop_index (unsigned int num_indices,
		      SLang_MMT_Type **mmt,
		      GDBM_Type **a,
		      char **str)
{
   if (NULL == (*mmt = SLang_pop_mmt (GDBM_Type_Id)))
     {
	*a = NULL;
	*str = NULL;
	return -1;
     }

   if ((num_indices != 1)
       || (-1 == SLang_pop_slstring (str)))
     {
	SLang_verror (SL_NOT_IMPLEMENTED,
		      "GDBM_Types require a single string index");
	SLang_free_mmt (*mmt);
	*mmt = NULL;
	*a = NULL;
	*str = NULL;
	return -1;
     }

   *a = (GDBM_Type *) SLang_object_from_mmt (*mmt);
   return 0;
}

int _SLgdbm_aget (SLtype type, unsigned int num_indices)
{
   SLang_MMT_Type *mmt;
   char *key, *val;
   GDBM_Type *pt;
   int ret;
   datum k,v;


   (void) type;

   if (-1 == pop_index (num_indices, &mmt, &pt, &key))
     return -1;

   /* get the value */
   k.dptr=key;
   k.dsize=strlen(key);

   if (pt->inuse)
     {
	v = gdbm_fetch(pt->p, k);
	if (v.dptr == NULL 
	    || (NULL == (val = SLang_create_nslstring((char *)v.dptr, (unsigned int)v.dsize))))
	  (void)SLang_push_null();
	else
	  {
	     (void) SLang_push_string(val);
	     SLang_free_slstring(val);
	  }
	SLfree(v.dptr);
     }
   else
     (void)SLang_push_null();
   
   SLang_free_slstring (key);
   SLang_free_mmt (mmt);
   return ret;
}

int _SLgdbm_aput (SLtype type, unsigned int num_indices)
{
   SLang_MMT_Type *mmt;
   char *key, *val;
   GDBM_Type *pt;
   int ret;
   datum k,v;


   (void) type;

   if (-1 == pop_index (num_indices, &mmt, &pt, &key))
     return -1;
   
   if (-1 == SLpop_string (&val))
     {
	SLang_free_slstring (key);
	return -1;
     }

   ret = -1;
   
   /* put the value */
   k.dptr=key;
   k.dsize=strlen(key);

   v.dptr=val;
   v.dsize=strlen(val);
   
   if (pt->inuse)
     {
	ret = gdbm_store(pt->p, k, v, GDBM_REPLACE);
	if (ret)
#if SLANG_VERSION < 20000
	  SLang_verror(SL_INTRINSIC_ERROR, "Could not write to GDBM");
#else
	  SLang_verror(SL_RunTime_Error, "Could not write to GDBM");
#endif
     }
   SLang_free_slstring (key);
   SLfree (val);
   SLang_free_mmt (mmt);
   return ret;
}


/*}}}*/
/*{{{ foreach */
#if SLANG_VERSION < 20000
struct _SLang_Foreach_Context_Type
#else
struct _pSLang_Foreach_Context_Type
#endif
{
   SLang_MMT_Type *mmt;
   GDBM_Type *a;
   datum key;
#define CTX_WRITE_KEYS		1
#define CTX_WRITE_VALUES	2
   unsigned char flags;
};

static SLang_Foreach_Context_Type *
  cl_foreach_open (SLtype type, unsigned int num)
{
   SLang_Foreach_Context_Type *c;
   unsigned char flags;
   SLang_MMT_Type *mmt;

   (void) type;

   if (NULL == (mmt = SLang_pop_mmt (GDBM_Type_Id)))
     return NULL;

   flags = 0;

   while (num--)
     {
	char *s;

	if (-1 == SLang_pop_slstring (&s))
	  {
	     SLang_free_mmt (mmt);
	     return NULL;
	  }

	if (0 == strcmp (s, "keys"))
	  flags |= CTX_WRITE_KEYS;
	else if (0 == strcmp (s, "values"))
	  flags |= CTX_WRITE_VALUES;
	else
	  {
	     SLang_verror (SL_NOT_IMPLEMENTED,
			   "using '%s' not supported by GDBM_Type",
			   s);
	     SLang_free_slstring (s);
	     SLang_free_mmt (mmt);
	     return NULL;
	  }

	SLang_free_slstring (s);
     }

   if (NULL == (c = (SLang_Foreach_Context_Type *) SLmalloc (sizeof (SLang_Foreach_Context_Type))))
     {
	SLang_free_mmt (mmt);
	return NULL;
     }

   memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type));

   if (flags == 0) flags = CTX_WRITE_VALUES|CTX_WRITE_KEYS;

   c->flags = flags;
   c->mmt = mmt;
   c->a = (GDBM_Type *) SLang_object_from_mmt (mmt);
   c->key = gdbm_firstkey(c->a->p);
   return c;
}

static void cl_foreach_close (SLtype type, SLang_Foreach_Context_Type *c)
{
   (void) type;
   if (c == NULL) return;
   SLang_free_mmt (c->mmt);
   SLfree ((char *) c);
}

static int cl_foreach (SLtype type, SLang_Foreach_Context_Type *c)
{
   GDBM_Type *a;
   datum key, value;

   (void) type;

   if (c == NULL)
     return -1;

   key = c->key;
   if(key.dptr == NULL)
     return -1;
   
   a = c->a;

   if ((c->flags & CTX_WRITE_KEYS))
     {
	char *strp;
	if (NULL == (strp = SLang_create_nslstring ((char *)key.dptr, (unsigned int) key.dsize)))
	  (void)SLang_push_null();
	else
	  {
	     (void) SLang_push_string (strp);
	     SLang_free_slstring(strp);
	  }
     }

   if (c->flags & CTX_WRITE_VALUES)
     {
	char *strp2;
	value = gdbm_fetch(a->p, key);
	if (value.dptr == NULL)
	  {
	     SLfree(key.dptr);
	     return -1;
	  }
	if (NULL == (strp2 = SLang_create_nslstring((char *)value.dptr, (unsigned int)value.dsize)))
	  (void)SLang_push_null();
	else
	  {
	     (void) SLang_push_string(strp2);
	     SLang_free_slstring(strp2);
	  }
	SLfree(value.dptr);
     }
   c->key = gdbm_nextkey (a->p, key);

   SLfree(key.dptr);

   /* keep going */
   return 1;
}

/*}}}*/
/*{{{ gdbm error */

static void slgdbm_error()
{
   int error;
   if (SLang_Num_Function_Args ==1)
     {
	if (-1 == SLang_pop_integer(&error)) 
	  {
	     SLang_verror (SL_INTRINSIC_ERROR,
			   "Unable to validate arguments to: gdbm_error");
	     return;
	  }
     }
   else error = gdbm_errno;
     
   (void) SLang_push_string((char *)gdbm_strerror(error));
}

/*}}}*/
/*{{{ destructor */

static void destroy_gdbm (SLtype type, VOID_STAR f)
{
   GDBM_Type *pt;
   (void) type;
   
   pt = (GDBM_Type *) f;
   free_gdbm_type (pt);
}

/*}}}*/
/*{{{ reorganize */
static int slgdbm_reorganize()
{
   GDBM_Type *p;
   SLang_MMT_Type *mmt;
   int ret=-1;

   if (NULL == (mmt = SLang_pop_mmt (GDBM_Type_Id)))
     {
	SLang_free_mmt (mmt);
	return -1;
     }
   
   p = SLang_object_from_mmt (mmt);

   if (p->inuse)
     ret = gdbm_reorganize(p->p);
   SLang_free_mmt (mmt);
   return ret;
}

/*}}}*/
/*{{{ intrinsics */

#define DUMMY_GDBM_TYPE 255
#define P DUMMY_GDBM_TYPE
#define I SLANG_INT_TYPE
#define V SLANG_VOID_TYPE
#define S SLANG_STRING_TYPE

static SLang_Intrin_Fun_Type Module_Intrinsics [] =
{
   MAKE_INTRINSIC_SII("gdbm_open", slgdbm_open, V),
/*%+
 *\function{gdbm_open}
 *\synopsis{open a gdbm database}
 *\usage{GDBM_Type gdbm_open(String_Type file, Int_Type flags, Int_Type mode)}
 *\description
 *   The \var{gdbm_open} function opens a GDBM file and returns a GDBM_Type
 *   object.  On failure it returns NULL and sets \var{gdbm_errno}.
 *   The flags are GDBM_READER for opening read-only, GDBM_WRITER for a
 *   reader/writer, and GDBM_WRCREAT for creating the file if it does not
 *   exist.  There are other flags as well, see the info documentation for
 *   gdbm.  The mode specifies the file permissions of a newly created file.
 *\notes
 *   Only one application at a time can open a dbf for writing.  A dbf can
 *   be opened by many readers, but not if it is opened for writing.
 *\seealso{gdbm_close, gdbm_store, gdbm_fetch, gdbm_exists, gdbm_delete}
 *%-
 */
   MAKE_INTRINSIC_0("gdbm_close", slgdbm_close, V),
/*%+
 *\function{gdbm_close}
 *\synopsis{close a gdbm database}
 *\usage{gdbm_close(GDBM_Type dbf)}
 *\description
 *   closes a gdbm database.
 *\notes
 *   The database is also automatically closed when the \var{dbf} variable
 *   goes out of scope.
 *%-
 */
   MAKE_INTRINSIC_SSI("gdbm_store", slgdbm_store, I),
/*%+
 *\function{gdbm_store}
 *\synopsis{stores a key/value pair in a GDBM dbf}
 *\usage{Int_Type gdbm_store(GDBM_Type dbf, String_Type key, String_Type val, Int_Type flags)}
 *\description
 *  Inserts or replaces records in the database. If the flag is GDBM_INSERT,
 *  and the key is already in the database, it fails. If the flag is 
 *  GDBM_REPLACE, the old value is replaced. On success it returns 0.
 *\notes
 *  You can also write \exmp{dbf[key] = value;}
 *  This implies GDBM_REPLACE.
 *\seealso{gdbm_delete, gdbm_fetch, gdbm_exists}
 *%-
 */
   MAKE_INTRINSIC_S("gdbm_fetch", slgdbm_fetch, V),
/*%+
 *\function{gdbm_fetch}
 *\synopsis{fetch a value from a gdbm database}
 *\usage{String_Type gdbm_fetch(GDBM_Type dbf, String_Type key)}
 *\description
 *  Gets the value of the entry with key \var{key} from the GDBM file \var{dbf}.
 *  If the key does not exist it returns NULL.
 *\notes
 *  You can also fetch the value with the expression \exmp{dbf[key]}
 *\seealso{gdbm_exists}
 *%-
 */
   MAKE_INTRINSIC_S("gdbm_exists", slgdbm_exists, I),
/*%+
 *\function{gdbm_exists}
 *\synopsis{test if a value is present in a database}
 *\usage{Integer_Type gdbm_exists(GDBM_Type dbf, String_Type key)}
 *\description
 *  If the \var{key} exists in the database \var{dbf}, it returns 1.
 *  Otherwise 0.
 *%-
 */
   MAKE_INTRINSIC_S("gdbm_delete", slgdbm_delete, I),
/*%+
 *\function{gdbm_delete}
 *\synopsis{delete a record from a GDBM database}
 *\usage{Integer_Type gdbm_delete(GDBM_Type dbf, String_Type key)}
 *\description
 *  \var{gdbm_delete} removes the keyed item and the \var{key} from the database
 *   \var{dbf}.
 *  The ret value is -1 if the item is not present or the requester is a
 *  reader.  The ret value is 0 if there was a successful delete.
 *%-
 */
   MAKE_INTRINSIC_0("gdbm_get_keys", slgdbm_get_keys, V),
/*%+
 *\function{gdbm_get_keys}
 *\synopsis{get all keys in a GDBM dbf}
 *\usage{String_Type[] gdbm_get_keys(GDBM_Type dbf)}
 *\description
 *  This function returns all the key names of \var{dbf} as an ordinary 
 *  one dimensional array of strings.  If the \var{dbf} contains no records,
 *  an empty array will be returned.
 *\notes
 *   It is also possible to iterate over a dbf's records with
 *   \exmp{foreach (dbf) using (keys)} etc.
 *\seealso{gdbm_get_values, gdbm_get_keys_and_values}
 *%-
 */
   MAKE_INTRINSIC_0("gdbm_get_values", slgdbm_get_values, V),
/*%+
 *\function{gdbm_get_values}
 *\synopsis{get values from a gdbm}
 *\usage{String_Type[] gdbm_get_values(GDBM_Type)}
 *\description
 *  This function returns all the values in \var{dbf} as an ordinary 
 *  one dimensional array of strings.  If the \var{dbf} contains no records,
 *  an empty array will be returned.
 *\seealso{gdbm_get_keys, gdbm_get_keys_and_values}
 *%-
 */
   MAKE_INTRINSIC_0("gdbm_get_keys_and_values", slgdbm_get_keys_and_values, V),
/*%+
 *\function{gdbm_get_keys_and_values}
 *\synopsis{get keys and values from a gdbm}
 *\usage{(String_Typep[], String_Type[]) gdbm_get_keys_and_values(GDBM_Type)}
 *\description
 *  This function returns all the keys and values of \var{dbf} as two
 *  arrays of strings.  If the \var{dbf} contains no records, two empty arrays
 *  will be returned.
 *\seealso{gdbm_get_keys, gdbm_get_values}
 *%-
 */
   MAKE_INTRINSIC_0("gdbm_error", slgdbm_error, V),
/*%+
 *\function{gdbm_error}
 *\synopsis{get the gdbm error string}
 *\usage{String_Type gdbm_error([Integer_Type code])}
 *\description
 *  converts the gdbm error code \var{code} into English text. Without arguments
 *  it returns the error string of \var{gdbm_errno}.
 *\seealso{gdbm_errno}
 *%-
 */
/*%+
 *\function{gdbm_reorganize}
 *\synopsis{reorganize a gdbm}
 *\usage{Int_Type gdbm_reorganize(GDBM_Type)}
 *\description
 *  If you have had a lot of deletions and would like to shrink the space
 *  used by the \var{gdbm} file, this function will reorganize the database.
 *  If an error is detected, the return value is negative.  The value zero is
 *  returned after a successful reorganization.
 *%-
 */
   MAKE_INTRINSIC_0("gdbm_reorganize", slgdbm_reorganize, I),
   SLANG_END_INTRIN_FUN_TABLE
};

static SLang_Intrin_Var_Type Module_Variables [] =
{
   MAKE_VARIABLE("_gdbm_module_version_string", &Module_Version_String, SLANG_STRING_TYPE, 1),
   MAKE_VARIABLE("gdbm_errno", &gdbm_errno, SLANG_INT_TYPE, 1),
/*%+
 *\variable{gdbm_errno}
 *\synopsis{gdbm's error code}
 *\description
 *  When a gdbm functions fails it sets this variable to a non-zero value.
 *\seealso{gdbm_error}
 *%-
 */   SLANG_END_INTRIN_VAR_TABLE
};

static SLang_IConstant_Type Module_Constants [] =
{
   MAKE_ICONSTANT("_gdbm_module_version", MODULE_VERSION_NUMBER),
   MAKE_ICONSTANT("GDBM_READER", GDBM_READER ),
   MAKE_ICONSTANT("GDBM_WRITER", GDBM_WRITER ),
   MAKE_ICONSTANT("GDBM_WRCREAT", GDBM_WRCREAT),
   MAKE_ICONSTANT("GDBM_NEWDB", GDBM_NEWDB),
   MAKE_ICONSTANT("GDBM_FAST", GDBM_FAST),
   
   MAKE_ICONSTANT("GDBM_REPLACE", GDBM_REPLACE),
   MAKE_ICONSTANT("GDBM_INSERT", GDBM_INSERT),

   SLANG_END_ICONST_TABLE
};


#undef P
#undef I
#undef V
#undef S

/*}}}*/
/*{{{ register class */

static void patchup_intrinsic_table (SLang_Intrin_Fun_Type *table, 
				     unsigned char dummy, unsigned char type)
{
   while (table->name != NULL)
     {
	unsigned int i, nargs;
	SLtype *args;
	
	nargs = table->num_args;
	args = table->arg_types;
	for (i = 0; i < nargs; i++)
	  {
	     if (args[i] == dummy)
	       args[i] = type;
	  }
	
	/* For completeness */
	if (table->return_type == dummy)
	  table->return_type = type;

	table++;
     }
}


static int register_gdbm_type (void)
{
   SLang_Class_Type *cl;
   
   if (GDBM_Type_Id != 0)
     return 0;

   if (NULL == (cl = SLclass_allocate_class ("GDBM_Type")))
     return -1;
   
   if ((-1 == SLclass_set_destroy_function (cl, destroy_gdbm))
       || (-1 == SLclass_set_aget_function (cl, _SLgdbm_aget))
       || (-1 == SLclass_set_aput_function (cl, _SLgdbm_aput)))
     return -1;

#if SLANG_VERSION < 20000
   cl->cl_foreach_open = cl_foreach_open;
   cl->cl_foreach_close = cl_foreach_close;
   cl->cl_foreach = cl_foreach;
#else
   if (-1 == SLclass_set_foreach_functions(cl, cl_foreach_open, cl_foreach, cl_foreach_close))
     return -1;
#endif

   /* By registering as SLANG_VOID_TYPE, slang will dynamically allocate a
    * type.
    */
   if (-1 == SLclass_register_class (cl, SLANG_VOID_TYPE, sizeof (GDBM_Type), SLANG_CLASS_TYPE_MMT))
     return -1;

   GDBM_Type_Id = SLclass_get_class_id (cl);

   patchup_intrinsic_table (Module_Intrinsics, DUMMY_GDBM_TYPE, GDBM_Type_Id);

   return 0;
}

/*}}}*/
/*{{{ init module */


int init_gdbm_module_ns (char *ns_name)
{
   SLang_NameSpace_Type *ns = SLns_create_namespace (ns_name);
   if (ns == NULL)
     return -1;
   if (-1 == register_gdbm_type ())
     return -1;

   if ((-1 == SLns_add_intrin_fun_table (ns, Module_Intrinsics, "__GDBM__"))
       || (-1 == SLns_add_intrin_var_table (ns, Module_Variables, NULL))
       || (-1 == SLns_add_iconstant_table (ns, Module_Constants, NULL)))
     return -1;
   
   return 0;
}

/*}}}*/

