#include <tcl.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <errno.h>
#include <string.h>
#include <mm.h>
#include "ns_basics.h"
#include "mm_hash.h"

/*
 * This file defines tcl commands which implement read-write locks
 * and the primitives of the mod_aolserver nsv implementation.  The
 * two are tied together a bit more than incidentally --- the shared
 * memory for nsv also holds the index of the next available rwlock
 * (these double as mutexes, BTW).
 */

static int BadArgs0(Tcl_Interp *interp, char *cmd, char *args)
{
    Tcl_AppendResult(interp, "wrong # of args: should be \"",
		     cmd, " ", args, "\"", NULL);

    return TCL_ERROR;
}

/* Global state for the locks and nsv */

static MM *shared_mem = NULL;
static mm_hash_table *shared_mem_symtab;
static int lock_fd = -1;

static struct shm_state {
    int next_lock;
} *state;

static void *mm_alloc_func (void *cookie, int sz) {
    return mm_malloc ((MM*)cookie, sz);
}

static void mm_free_func (void *cookie, void *ptr) {
    mm_free ((MM*)cookie, ptr);
}

/*
 * Tcl command: _nsv_shm_init memfile lockfile size
 *
 * memfile is the filename which mm may or may not use for its temp
 * file; size is the number of bytes to allocate, and should probably
 * be at least a megabyte just to give us some headroom.  (It is shared
 * among all servers, of course, so there's no need to worry about
 * duplication).
 *
 * lockfile is the dummy file that gets fcntl region locks to implement
 * our rwlocks.  Note that it is never written to at all --- fcntl locking
 * doesn't require that the bytes being locked have ever been written to.
 */

static int nsv_shm_init (ClientData ignored, Tcl_Interp *interp,
			int argc, char **argv)
{
    int sz;
    
    if (argc != 4) return BadArgs0 (interp, argv[0], "memfile lockfile size");

    if (Tcl_GetInt (interp, argv[3], &sz) == TCL_ERROR) return TCL_ERROR;
	
    /* Destroy old lock and shm state, if they exist (apache restart) */ 
    
    if (lock_fd >= 0) close (lock_fd);
    
    if (shared_mem != NULL) mm_destroy (shared_mem);

    /* open lock file */

    lock_fd = open (argv[2], O_CREAT|O_RDWR, 0700);

    if (lock_fd < 0) {
	Tcl_SetResult (interp, "couldn't open lock file!", TCL_STATIC);
	return TCL_ERROR;
    }

    /* Create shared memory object */
    
    shared_mem = mm_create (sz, argv[1]);

    if (shared_mem == NULL) {
	Tcl_SetResult (interp, "mm_create failed!", TCL_STATIC);
	close (lock_fd);
	lock_fd = -1;
	return TCL_ERROR;
    }

    /* Create our shared internal data structures */

    state = (struct shm_state *)mm_malloc(shared_mem,sizeof(struct shm_state));
    
    shared_mem_symtab =
	mm_hash_create (64, 0, (void*)shared_mem, mm_alloc_func, mm_free_func);

    if (state == NULL || shared_mem_symtab == NULL) {
	Tcl_SetResult (interp, "could not create hash table", TCL_STATIC);
	mm_destroy (shared_mem);
	close (lock_fd);
	lock_fd = -1;
	shared_mem = NULL;
	return TCL_ERROR;
    }

    state->next_lock = 1;	/* lock 0 guards creation of new locks */

    return TCL_OK;
}

/*
 * Locking primitive...
 */

static int set_lock (int idx, int how, Tcl_Interp *interp)
{
    struct flock lock, lock2;
    int ret;
    
    lock.l_whence = 0;
    lock.l_start = idx;
    lock.l_len = 1;
    lock.l_type = how;
    lock2 = lock;

    while ((ret = fcntl (lock_fd, F_SETLKW, &lock2)) == -1 && errno == EINTR)
	lock2 = lock;

    if (ret < 0 && interp != NULL) {
	Tcl_AppendResult (interp, "Lock failed: ", strerror (errno), NULL);
    }
    
    return ret;
}

/*
 * Tcl commands:
 *
 * ns_rwlock create          --- create a new rwlock
 * ns_rwlock destroy $lk     --- destroy an rwlock (no-op here)
 * ns_rwlock readlock $lk    --- lock for reading
 * ns_rwlock readunlock $lk  --- unlock after readlock
 * ns_rwlock writelock $lk   --- lock for writing
 * ns_rwlock writeunlock $lk --- unlock after writelock
 *
 * ns_mutex create      --- create a new mutex
 * ns_mutex destroy $lk --- destroy an mutex (no-op here)
 * ns_mutex lock $lk    --- lock a mutex
 * ns_mutex unlock $lk  --- unlock a locked mutex
 *
 * Mutexes are implemented simply as rwlocks that get write-locked.
 */

static int ns_rwlock (ClientData ignored, Tcl_Interp *interp,
		      int argc, char **argv)
{
    int lock_idx, cmd = 0;
    int badargs = 0;
    char *endptr;

    /* Most of this is just parsing the arguments.  create doesn't
     * take a lock-id as an argument, so we handle it first as a
     * special case.
     */
    
    if (argc == 2 && !strcmp (argv[1], "create")) {
	int next_lock;
	char resultbuf[100];
    
	if (set_lock (0, F_WRLCK, interp) < 0) return TCL_ERROR;
	next_lock = state->next_lock++;
	set_lock (0, F_UNLCK, NULL);

	sprintf (resultbuf, "mx%d", next_lock);
	Tcl_SetResult (interp, resultbuf, TCL_VOLATILE);
	return TCL_OK;
    }
    
    /* For the rest, identify subcommand.
     * Destroy is a no-op, discarded here, because there is no in-core
     * state at all associated with one of these rwlocks
     */
    
    if (argc != 3) badargs = 1;
    else if (!strcmp (argv[1], "readlock"))    cmd = F_RDLCK;
    else if (!strcmp (argv[1], "writelock"))   cmd = F_WRLCK;
    else if (!strcmp (argv[1], "lock"))        cmd = F_WRLCK;
    else if (!strcmp (argv[1], "readunlock"))  cmd = F_UNLCK;
    else if (!strcmp (argv[1], "writeunlock")) cmd = F_UNLCK;
    else if (!strcmp (argv[1], "unlock"))      cmd = F_UNLCK;
    else if (!strcmp (argv[1], "destroy"))     return TCL_OK;
    else badargs = 1;

    if (badargs) {
	return BadArgs0 (interp, argv[0],
			 "create | destroy rwlock | readlock rwlock | "
			 "readunlock rwlock | writelock rwlock | "
			 "writeunlock rwlock");
    }

    /* Get an offset for the lock primitive --- and do a validity check */
    
    if (argv[2][0] != 'm' || argv[2][1] != 'x') {
	Tcl_AppendResult (interp, "Bad rwlock: ", argv[2], NULL);
	return TCL_ERROR;
    }

    lock_idx = strtol (argv[2] + 2, &endptr, 10);

    if (endptr == NULL || endptr == argv[2] + 2 || *endptr != '\0') {
	Tcl_AppendResult (interp, "Bad rwlock: ", argv[2], NULL);
	return TCL_ERROR;
    }

    /* And after all that, what the job actually amounts to is this: */

    if (set_lock (lock_idx, cmd, interp) < 0)
	return TCL_ERROR;

    return TCL_OK;
}

/* Hash manipulation primitive.  Requires the caller to have grabbed
 * an appropriate lock.
 */

static mm_hash_table *find_hash_named (Tcl_Interp *interp, char *name,
				       int do_create)
{
    int created_p;
    mm_hash_elt *elt = mm_hash_get (shared_mem_symtab, name,
				    strlen(name) + 1, &created_p);

    if (elt == NULL) return NULL;

    if (do_create && elt->data == NULL) {
	elt->data = mm_hash_create (8, 1, (void*)shared_mem,
				    mm_alloc_func, mm_free_func);
	
	if (elt->data == NULL) {
	    mm_hash_elt_delete (shared_mem_symtab, elt);
	    Tcl_SetResult (interp, "Failed to create table", TCL_STATIC);
	    return NULL;
	}
    }

    return elt->data;
}

static mm_hash_table *lock_and_find(Tcl_Interp *interp, char *name,
    mm_lock_mode mode, int do_create)
{
    mm_hash_table *hash;

    if (!mm_lock (shared_mem, mode)) {
	Tcl_SetResult (interp, "Could not lock shared memory", TCL_STATIC);
	return NULL;
    }

    hash = find_hash_named (interp, name, do_create);

    if (hash == NULL) {
	mm_unlock(shared_mem);
    }

    return hash;
}

/*
 * Tcl commands:
 *
 * nsv_get    hash key --- Returns the value, if one exists, "" if not.
 * nsv_exists hash key --- Returns 1 if the key exists in the hash, else 0
 * nsv_unset  hash key --- Returns same; deletes the element.
 *
 * hashes come into existence by being referenced, and "vanish" when
 * their last element is deleted (at least as far as tcl is concerned);
 * see nsv_shm_table_exists below.
 */

static char nsv_get, nsv_exists, nsv_unset;

static int nsv_simple (ClientData cmd, Tcl_Interp *interp,
			   int argc, char **argv)
{
    mm_hash_table *hash;
    mm_hash_elt *elt;
    
    if (argc != 3) return BadArgs0 (interp, argv[0], "hashname key");
    
    if (!mm_lock (shared_mem,(cmd==&nsv_unset? MM_LOCK_RW: MM_LOCK_RD))) {
	Tcl_SetResult (interp, "Could not lock shared memory", TCL_STATIC);
	return TCL_ERROR;
    }
    
    hash = find_hash_named (interp, argv[1], 0);

    /* If no hash, no elements in the hash... */
    
    if (hash == NULL) {
	Tcl_SetResult (interp, (cmd == &nsv_get ? "" : "0"), TCL_STATIC);
	mm_unlock (shared_mem);
	return TCL_OK;
    }

    /* Find the element.  Return appropriate value if none;
     * otherwise, do... whatever.
     */
    
    elt = mm_hash_get (hash, argv[2], strlen(argv[2]) + 1, NULL);

    if (elt == NULL) {
	Tcl_SetResult (interp, (cmd == &nsv_get ? "" : "0"), TCL_STATIC);
    }
    else if (cmd == &nsv_get) {
	Tcl_SetResult (interp, elt->data, TCL_VOLATILE);
    }
    else if (cmd == &nsv_exists) {
	Tcl_SetResult (interp, "1", TCL_STATIC);
    }
    else if (cmd == &nsv_unset) {
	mm_hash_elt_delete (hash, elt);
	Tcl_SetResult (interp, "1", TCL_STATIC);
    }
    
    mm_unlock (shared_mem);
    return TCL_OK;
}

/*
 * Tcl commands:
 *
 * nsv_incr table key
 * nsv_set table key value
 * nsv_append table key value
 * nsv_lappend table key value
 *
 * Throws an error if mm ran out of shared memory; otherwise returns
 * new value for incr, append, and lappend, and nothing much for set.
 */

int nsv_set, nsv_incr, nsv_append, nsv_lappend;

static int internal_set (Tcl_Interp *interp, mm_hash_table *t,
			 mm_hash_elt *elt, char *value, int delete_on_error)
{
    if (!mm_hash_elt_set (t, elt, value, strlen(value) + 1)) {
	Tcl_SetResult (interp, "Out of shared memory setting nsv element",
		       TCL_STATIC);
	if (delete_on_error) mm_hash_elt_delete (t, elt);
	return TCL_ERROR;
    }

    return TCL_OK;
}

static int nsv_modify (ClientData cmd, Tcl_Interp *interp,
		       int argc, char **argv)
{
    mm_hash_table *hash;
    mm_hash_elt *elt;
    int created;
    char *arg = NULL;
    int rc = 0;

    /* Do some basic arg checks */
    
    if (cmd == &nsv_incr) {
	if (argc != 3 && argc != 4)
	    return BadArgs0 (interp, argv[0], "hashname key ?count?");
    } else {
	if (argc != 4) return BadArgs0 (interp, argv[0], "hashname key val");
    }

    arg = argc > 3? argv[3] : "1"; /* Default count for nsv_incr */
    
    /* Get the hash table */
    
    if (!mm_lock (shared_mem, MM_LOCK_RW)) {
	Tcl_SetResult (interp, "Could not lock shared memory", TCL_STATIC);
	return TCL_ERROR;
    }
    
    hash = find_hash_named (interp, argv[1], 1);

    /* if we got no table, it's because of failure to create...
     * find_hash already set up an error msg
     */

    if (hash == NULL) {
	mm_unlock (shared_mem);
	return TCL_ERROR;
    }

    /* Get the element, checking for out-of-memory errors on creation */
    
    elt = mm_hash_get (hash, argv[2], strlen(argv[2]) + 1, &created);

    if (elt == NULL) {
	Tcl_SetResult (interp, "Out of shared memory creating nsv element",
		       TCL_STATIC);
	mm_unlock (shared_mem);
	return TCL_ERROR;
    }

    /* Write or modify the value, with similar care */

    if (cmd == &nsv_set) {
	rc = internal_set (interp, hash, elt, arg, created);
    }
    else if (cmd == &nsv_append || cmd == &nsv_lappend) {

	/* If an element is being appended to repeatedly, we could use
	 * allocate extra space for it, and use mm_sizeof() to check
	 * whether we've gone beyond its bounds, to save on shared heap
	 * allocations... but not yet.
	 */
	
	Tcl_DString ds;
	char *newdata;
	
	Tcl_DStringInit (&ds);
	
	if (!created) Tcl_DStringAppend (&ds, elt->data, -1);

	if (cmd == &nsv_append)	Tcl_DStringAppend (&ds, arg, -1);
	else Tcl_DStringAppendElement (&ds, arg);

	newdata = Tcl_DStringValue (&ds);
	rc=internal_set(interp, hash, elt, newdata, created);

	if (rc == TCL_OK) Tcl_DStringResult (interp, &ds);
	
	Tcl_DStringFree (&ds);
    }
    else if (cmd == &nsv_incr) {

	int incr;
	
	if ((rc = Tcl_GetInt (interp, arg, &incr)) != TCL_OK) {
	    if (created) mm_hash_elt_delete (hash, elt);
	}
	else {
	    int val = 0;
	    char buf[40];	/* Long enough... */
	    
	    if (created || (rc =Tcl_GetInt(interp, elt->data, &val))==TCL_OK) {
		sprintf (buf, "%d", val + incr);
		rc = internal_set (interp, hash, elt, buf, created);
	    }

	    if (rc == TCL_OK) Tcl_SetResult (interp, buf, TCL_VOLATILE);
	}
    }

    /* Done */

    mm_unlock (shared_mem);
    return rc;
}

/*
 * Tcl commands:
 *
 * nsv_array set     table list
 * nsv_array reset   table list
 * nsv_array get     table ?pattern?
 * nsv_array names   table ?pattern?
 * nsv_array exists  table
 * nsv_array keys    table
 * nsv_array rawkeys table --- undocumented debug hook 
 *
 * "nsv_array keys" returns the list of all keys from a given shared table.
 * "nsv_array exists" returns 1 if "nsv_array keys" would return a
 *                    nonempty list.
 * "nsv_array rawkeys" is a debugging thing --- it returns the keys
 *                     in the order they are actually present, with
 *                     empty strings for free hash elements.
 */

static int
nsv_array(ClientData dummy, Tcl_Interp *interp, int argc, char **argv)
{
    char *pattern = 0, **largv;
    int i, created_p, cmd, largc, status = TCL_OK;
    mm_hash_table *hash;
    mm_hash_elt *elt;
    mm_hash_iter search;

    if (argc < 3) {
    	Tcl_AppendResult(interp, "wrong # args: should be: \"",
	    argv[0], " option array\"", NULL);
	return TCL_ERROR;
    }

    cmd = argv[1][0];
    if (STREQ(argv[1], "set") || STREQ(argv[1], "reset")) {

	if (argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be: \"",
		argv[0], " ", argv[1], " array valueList\"", NULL);
	    return TCL_ERROR;
	}
    	if (Tcl_SplitList(interp, argv[3], &largc, &largv) != TCL_OK) {
	    return TCL_ERROR;
    	}
    	if (largc & 1) {
	    Tcl_AppendResult(interp, "invalid list: ", argv[3], NULL);
	    ckfree((char *) largv);
	    return TCL_ERROR;
	}

	hash = lock_and_find(interp, argv[2], MM_LOCK_RW, 1);
	if (hash == NULL) {
	    return TCL_ERROR;
	}

    } else {

    	if (STREQ(argv[1], "get") || STREQ(argv[1], "names")) {

	    if (argc != 3 && argc != 4) {
		Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " ", argv[1], " array ?pattern?\"", NULL);
		return TCL_ERROR;
	    }
	    pattern = argv[3];

	} else if (STREQ(argv[1], "size") || STREQ(argv[1], "exists")) {

	    if (argc != 3) {
		Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " ", argv[1], " array\"", NULL);
		return TCL_ERROR;
	    }
	    if (cmd == 's') {
		cmd = 'z';
	    }

	} else {

	    Tcl_AppendResult(interp, "unkown command \"", argv[1],
		"\": should be exists, get, names, set, or size", NULL);
	    return TCL_ERROR;

	}

	hash = lock_and_find(interp, argv[2], MM_LOCK_RD, 0);
	if (hash == NULL) {
	    if (cmd == 'z' || cmd == 'e') {
	    	Tcl_SetResult(interp, "0", TCL_STATIC);
	    }
	    return TCL_OK;
	}

    }

    switch (cmd) {

    case 'e':
	Tcl_SetResult(interp, "1", TCL_STATIC);
	break;

    case 'z':
	sprintf(interp->result, "%d", hash->nelts - hash->nfree);
	break;

    case 'r':
	mm_hash_clear(hash);
	/* FALLTHROUGH */
    case 's':
    	for (i = 0; i < largc; i += 2) {
	    elt = mm_hash_get(hash, largv[i], strlen(largv[i]) + 1, &created_p);
	    if (!mm_hash_elt_set(hash, elt, largv[i+1],
		strlen(largv[i+1]) + 1))
	    {
		Tcl_AppendResult(interp, "error setting NSV element \"",
		    largv[i], "\" to \"", largv[i+1], "\"", NULL);
		status = TCL_ERROR;
		break;
	    }
	}
    	Tcl_Free((char *) largv);
	break;

    case 'g':
    case 'n':
	mm_hash_iter_init(hash, &search);
	while ((elt = mm_hash_iter_next(hash, &search))) {
	    if (pattern == NULL || Tcl_StringMatch(elt->key, pattern)) {
		Tcl_AppendElement(interp, elt->key);
		if (cmd == 'g') {
	    	    Tcl_AppendElement(interp, elt->data);
		}
	    }
	}
	break;
    }

    mm_unlock(shared_mem);
    return status;
}

/* Install all of our commands into a tcl interpreter */

void nsv_install_cmds (Tcl_Interp *interp, int add_unsafe)
{
    Tcl_CreateCommand (interp, "ns_rwlock", ns_rwlock, NULL, NULL);
    Tcl_CreateCommand (interp, "ns_mutex",  ns_rwlock, NULL, NULL);
    
    Tcl_CreateCommand (interp, "nsv_get",    nsv_simple, &nsv_get,    NULL);
    Tcl_CreateCommand (interp, "nsv_unset",  nsv_simple, &nsv_unset,  NULL);
    Tcl_CreateCommand (interp, "nsv_exists", nsv_simple, &nsv_exists, NULL);
    
    Tcl_CreateCommand (interp, "nsv_set",     nsv_modify, &nsv_set,     NULL);
    Tcl_CreateCommand (interp, "nsv_incr",    nsv_modify, &nsv_incr,    NULL);
    Tcl_CreateCommand (interp, "nsv_append",  nsv_modify, &nsv_append,  NULL);
    Tcl_CreateCommand (interp, "nsv_lappend", nsv_modify, &nsv_lappend, NULL);
    
    Tcl_CreateCommand (interp, "nsv_array", nsv_array, NULL, NULL);
    
    if (add_unsafe) {
	Tcl_CreateCommand (interp, "_nsv_shm_init", nsv_shm_init, NULL, NULL);
    }
}