/*
 * An AOLserver module interface to GNOME's libxml
 *
 * Curtis Galloway
 * curtisg@arsdigita.com
 * March 2000
 *
 * This is open-source software, copyright 2000 ArsDigita Corporation 
 * and licensed under the GNU General Public License. 
 *
 */

/*
 * ns_xml parse ?-persist? <string>
 * ns_xml parse_xslt ?-persist? <string>
 * ns_xml apply_xslt ?-persist? <xslt_template> <xml_doc>
 *
 * ns_xml doc create ?-persist? ?-validate? ?doc-version?
 * ns_xml doc free <doc_id>
 * ns_xml doc root <doc_id>
 * ns_xml doc new_root <doc_id> <node_name> <node_content>
 * ns_xml doc render <doc_id>
 *   
 * ns_xml node <cmd>
 * ns_xml node children <node_id>
 * ns_xml node getattr <node_id> <prop_name>
 * ns_xml node setattr <node_id> <prop_name> <value>
 * ns_xml node new_child <name> <content>
 * ns_xml node new_sibling <name> <content>
 * ns_xml node getcontent <node_id>
 * ns_xml node setcontent <node_id> <content>
 *
 * TODO:
 * - add SAX callback code
 * - use AOLserver 3 API when possible
 */

#include <ns.h>

#include <libxml/parser.h>
#include <libxml/xmlmemory.h>

#ifdef DO_XSLT
#include <libxslt/xslt.h>
#include <libxslt/xsltInternals.h>
#include <libxslt/transform.h>
#include <libxslt/xsltutils.h>
#endif 

#ifdef DMALLOC
#include <dmalloc.h>
#undef Ns_Malloc
#define Ns_Malloc malloc
#undef Ns_Free
#define Ns_Free free
#undef Ns_StrDup
#define Ns_StrDup strdup
#endif

extern
xmlParserInputPtr
xmlNewStringInputStream(xmlParserCtxtPtr ctxt, const xmlChar *buffer);

typedef struct _id_info {
  unsigned int next_doc_id;
  unsigned int next_node_id;
  /* Holds a doc_info structure, with doc ID as key */
  Tcl_HashTable doc_hash_byid;
  /* Holds a doc_info structure, with doc pointer as key */
  Tcl_HashTable doc_hash_bydoc;
  /* Holds the node pointer, with node ID as key */
  Tcl_HashTable node_hash_byid;
  /* Holds the node ID, with node pointer as key */
  Tcl_HashTable node_hash_bynode;
} id_info;


/* Used to create a linked list of nodes which have Tcl IDs
 * for this document.
 */
typedef struct _node_info {
  xmlNode *node;
  struct _node_info *next;
} node_info;

/* This holds a pointer to the document
 * and to a list of nodes that we have allocated
 * node IDs for this document.
 */
typedef struct _doc_info {
     xmlDoc *doc;
#ifdef DO_XSLT
     xsltStylesheetPtr xslt;
#endif
     struct _node_info *nodes;
} doc_info;

/*
 * For both persistent and temporary documents,
 * we need to keep track of the mapping of ids to
 * documents and nodes.
 * Node IDs are always temporary.
 */

static Ns_Mutex lock;
static id_info *perm_info=NULL;

static Tcl_HashTable interp_hash; /* For per-interp hash tables */

/* default values for the configuration parameters */

#define DEFAULT_DEBUG  			NS_FALSE

/* configurable parameters */

static int debug_p;

#ifdef WIN32
/* MSVC does not have __FUNCTION__ */
#define lexpos() \
  __FILE__, __LINE__, __FILE__
#else
#define lexpos() \
  __FILE__, __LINE__, __FUNCTION__
#endif

/* how big of a stack buffer to use for printing error messages
 */
#define STACK_BUFFER_SIZE 20000

/* for optional logging of all kinds of random stuff, turn on 
   debug in the [ns/server/<servername>/module/<modulename>] section
   of your nsd.ini
*/

static void
my_log (char *file, int line, char *fn, char *fmt, ...)
{
  char *buf1;
  char  *buf;
  va_list ap;
  
  if (!debug_p)
    return;

  buf1 = Ns_Malloc(STACK_BUFFER_SIZE);
  buf = Ns_Malloc(STACK_BUFFER_SIZE);

  va_start (ap, fmt);
  vsprintf (buf1, fmt, ap);
  va_end (ap);

#ifdef WIN32
  _snprintf (buf, STACK_BUFFER_SIZE, "%s:%d:%s: %s", file, line, fn, buf1);
#else
  snprintf (buf, STACK_BUFFER_SIZE, "%s:%d:%s: %s", file, line, fn, buf1);
#endif
  
  Ns_Log (Notice, "%s", buf);

  Ns_Free(buf);
  Ns_Free(buf1);

} /* my_log */

/*
 * Create a node_info structure.
 */

static node_info *
node_info_create(xmlNode *node, node_info *next)
{
  node_info *n_info;

  n_info = (node_info *)Ns_Malloc(sizeof(node_info));
  n_info->node = node;
  n_info->next = next;
  return n_info;
}

/*
 * Free a node_info structure
 * created by node_info_create().
 */

static void
node_info_free(node_info *n_info)
{
  Ns_Free(n_info);
}

static doc_info *
doc_info_create(xmlDoc *doc)
{
  doc_info *d_info;

  d_info = (doc_info *)Ns_Malloc(sizeof(doc_info));
  d_info->doc = doc;
  d_info->nodes = NULL;
#ifdef DO_XSLT
  d_info->xslt = NULL;
#endif
  my_log(lexpos(), "doc_info_create returns %x", d_info);
  return d_info;
}

#ifdef DO_XSLT
static void xsltNsGenericErrorFunc( void *ctx, const char *msg, ...)
{
     va_list args;

     if (!debug_p)
	  return;
     va_start(args, msg);
     my_log(lexpos(), (char *)msg, args);
     va_end(args);
}
#endif

#ifdef DO_XSLT
static doc_info *
doc_info_create_xslt(xsltStylesheetPtr xslt)
{
  doc_info *d_info;

  d_info = (doc_info *)Ns_Malloc(sizeof(doc_info));
  d_info->doc = NULL;
  d_info->nodes = NULL;
  d_info->xslt = xslt;
  my_log(lexpos(), "doc_info_create returns %x", d_info);
  return d_info;
}
#endif

/*
 * Frees the xmlDoc pointed to by the doc_info structure,
 * the associated node_info data,
 * and the doc_info structure itself.
 */
static void
doc_info_free(id_info *info, doc_info *d_info)
{
  node_info *n_info, *next_n_info;
  Tcl_HashEntry *entry;
  char *node_id;

  n_info = d_info->nodes;
  my_log(lexpos(), "doc_info_free %x", d_info);
  while (n_info != NULL) {
    next_n_info = n_info->next;
    /* Get the node ID for this node */
    entry = Tcl_FindHashEntry(&info->node_hash_bynode, (ClientData)n_info->node);
    node_id = (char *)Tcl_GetHashValue(entry);
    Tcl_DeleteHashEntry(entry);
    entry = Tcl_FindHashEntry(&info->node_hash_byid, node_id);
    Tcl_DeleteHashEntry(entry);
    Ns_Free(node_id);
    node_info_free(n_info);
    n_info = next_n_info;
  }
  /* Free the actual document and all its nodes */
  my_log(lexpos(), "xmlFreeDoc %x", d_info->doc);
#ifdef DO_XSLT
  if (d_info->doc)
       xmlFreeDoc(d_info->doc);
  if (d_info->xslt)
       xsltFreeStylesheet(d_info->xslt);
#else
  xmlFreeDoc(d_info->doc);
#endif
  Ns_Free(d_info);
}

/*
 * Create an id_info structure.
 */
 
static id_info *
id_info_create()
{
  id_info *info;

  info = (id_info *)Ns_Malloc(sizeof(id_info));
  info->next_doc_id = 0;
  info->next_node_id = 0;
  Tcl_InitHashTable(&info->doc_hash_byid, TCL_STRING_KEYS);
  Tcl_InitHashTable(&info->doc_hash_bydoc, TCL_ONE_WORD_KEYS);
  Tcl_InitHashTable(&info->node_hash_byid, TCL_STRING_KEYS);
  Tcl_InitHashTable(&info->node_hash_bynode, TCL_ONE_WORD_KEYS);
  return info;
}

/*
 * Free an id_info structure
 * created with id_info_create().
 */
static void
id_info_free(id_info *info)
{
  Tcl_HashEntry *entry;
  Tcl_HashSearch search;

  /* Clean up the docs */
  entry = Tcl_FirstHashEntry(&info->doc_hash_byid, &search);
  while (entry) {
    doc_info *d_info;

    d_info = (doc_info *)Tcl_GetHashValue(entry);
    doc_info_free(info, d_info);
    entry = Tcl_NextHashEntry(&search);
  }
  Tcl_DeleteHashTable(&info->doc_hash_byid);
  /* The bydoc hash table simply has pointers to the doc_info
   * structures we just freed, so don't free them again.
   */
  Tcl_DeleteHashTable(&info->doc_hash_bydoc);

  /* There shouldn't be any nodes left in the node hash tables,
   * but if there are, free the ID strings.
   */
  entry = Tcl_FirstHashEntry(&info->node_hash_bynode, &search);
  while (entry) {
    Ns_Free(Tcl_GetHashValue(entry));
    entry = Tcl_NextHashEntry(&search);
  }
  Tcl_DeleteHashTable(&info->node_hash_bynode);
  /* The byid table has pointers to the nodes,
   * which should bave been freed when the documents were freed.
   */
  Tcl_DeleteHashTable(&info->node_hash_byid);
  Ns_Free(info);
}


/*
 * This function is called when an interpreter is
 * about to be freed, and it cleans up all the data
 * we are keeping that's related to that interpreter,
 * such as the document id hash.
 */

static void
cleanup_interp_data(ClientData clientData, Tcl_Interp *interp)
{
  id_info *info;
  Tcl_HashEntry *entry;

  my_log(lexpos(), "cleaning up interp %x", interp);
  entry = Tcl_FindHashEntry(&interp_hash, (char *)interp);
  if (entry != NULL) {
    info = (id_info *)Tcl_GetHashValue(entry);
    id_info_free(info);
    Tcl_DeleteHashEntry(entry);
  }
}

/*
 * The connection is over.
 * Clean up all non-persistent handles.
 */
static void
cleanup_after_connection(Tcl_Interp *interp, void *arg)
{
  cleanup_interp_data(NULL, interp);
}

/*
 * Get the info structure associated with an interpreter.
 */

static id_info *
get_interp_info(Tcl_Interp *interp)
{
  Tcl_HashEntry *entry;
  id_info *info;
  int new;

  Ns_LockMutex(&lock);
  entry = Tcl_CreateHashEntry(&interp_hash, (ClientData)interp, &new);
  if (new) {
    my_log(lexpos(), "creating new interp info for %x", interp);
    info = id_info_create();
    Tcl_SetHashValue(entry, info);
    Tcl_CallWhenDeleted(interp, cleanup_interp_data, entry);
  } else {
    my_log(lexpos(), "reusing interp info for %x", interp);
    info = (id_info *)Tcl_GetHashValue(entry);
  }
  Ns_UnlockMutex(&lock);
  return info;
}

/*
 * Given an interpreter and a document id (e.g. "t0"),
 * find the xmlDoc pointer for it.
 * Returns NULL if not found.
 */

static doc_info *
xml_find_doc_info(Tcl_Interp *interp, char *docId)
{
  id_info *info=NULL;
  Tcl_HashEntry *entry;
  doc_info *d_info;

  if (docId[0] == 'p') {
    info = perm_info;
  } else if (docId[0] == 't') {
    info = get_interp_info(interp);
  }

  if ( NULL == info )
        return NULL;

  entry = Tcl_FindHashEntry(&info->doc_hash_byid, docId);
  if (entry == NULL)
    return NULL;
  d_info = (doc_info *)Tcl_GetHashValue(entry);
  return d_info;
}

static xmlDocPtr
xml_find_doc(Tcl_Interp *interp, char *docId)
{
     doc_info *info;

     info = xml_find_doc_info(interp, docId);
     if (NULL  == info )
        return NULL;
     return info->doc;
}

#ifdef DO_XSLT
static xsltStylesheetPtr
xml_find_xslt(Tcl_Interp *interp, char *docId)
{
     doc_info *info;

     info = xml_find_doc_info(interp, docId);
     if ( NULL == info)
        return NULL;
     return info->xslt;
}
#endif

/*
 * Given an interpreter and a node id,
 * find the xmlNode pointer for it.
 * Returns NULL if not found.
 */

static xmlNodePtr
xml_find_node_byid(Tcl_Interp *interp, char *nodeId)
{
  id_info *info;
  Tcl_HashEntry *entry;

  if ( 'N' == nodeId[0] ) {
    info = perm_info;
  } else if ( 'n' == nodeId[0] ) {
    info = get_interp_info(interp);
  } else {
    return NULL;
  }
  entry = Tcl_FindHashEntry(&info->node_hash_byid, nodeId);
  if (entry == NULL)
    return NULL;
  return (xmlNodePtr) Tcl_GetHashValue(entry);
}

#ifdef NEVER /* function not used anywhere */
/*
 * Given an interpreter and an xmlNode pointer,
 * returns the node ID (e.g. "n0") for that node
 * if it has already been entered for this interpreter.
 * Returns NULL if not found.
 */

static char *
xml_find_id_bynode(Tcl_Interp *interp, xmlNodePtr node)
{
  id_info *info;
  Tcl_HashEntry *entry;

  info = get_interp_info(interp);
  entry = Tcl_FindHashEntry(&info->node_hash_bynode, (ClientData)node);
  if (entry == NULL)
    return NULL;
  return (char *) Tcl_GetHashValue(entry);
}
#endif

#define ENTER_TRANSIENT 0
#define ENTER_PERSISTENT 1

/*
 * Create a document ID string for a document
 * and add it to the result for an interpreter.
 * The <flags> argument determines whether it is marked as
 * a transient document (ENTER_TRANSIENT), which will be cleaned up when
 * the current transaction ends, or a persistent document
 * (ENTER_PERSISTENT), which will persist across transactions
 * and must be freed explicitly.
 */

#ifdef DO_XSLT
static void
xml_enter_doc_or_xslt(Tcl_Interp *interp, xmlDocPtr xmlDoc, xsltStylesheetPtr xslt, int flags, int append_result_p)
#else
static void
xml_enter_doc(Tcl_Interp *interp, xmlDocPtr xmlDoc, int flags, int append_result_p)
#endif
{
     id_info *info;
     Tcl_HashEntry *entry;
     char prefix;
     int new;
     Ns_DString result;
     doc_info *d_info;

     Ns_DStringInit(&result);
     if (flags & ENTER_PERSISTENT) {
        /*
        * Lock the global mutex and use the global hashtable.
        */

        info = perm_info;
        prefix = 'p';
     } else {
        info = get_interp_info(interp);
        prefix = 't';
     }
     if (flags & ENTER_PERSISTENT) {
        Ns_LockMutex(&lock);
     }
     do {
        Ns_DStringTrunc(&result, 0);
        Ns_DStringPrintf(&result, "%c%u", prefix, info->next_doc_id);
        info->next_doc_id += 1;
        entry = Tcl_CreateHashEntry(&info->doc_hash_byid, Ns_DStringValue(&result),
                              &new);
     } while (!new);
#ifdef DO_XSLT
     if (xmlDoc)
        d_info = doc_info_create(xmlDoc);
     if (xslt)
        d_info = doc_info_create_xslt(xslt);
#else
     d_info = doc_info_create(xmlDoc);
#endif
     my_log(lexpos(), "set doc_hash_byid to %x", d_info);
     Tcl_SetHashValue(entry, d_info);
#ifdef DO_XSLT
     if (xmlDoc)
        entry = Tcl_CreateHashEntry(&info->doc_hash_bydoc, (ClientData)xmlDoc, &new);
     if (xslt)
        entry = Tcl_CreateHashEntry(&info->doc_hash_bydoc, (ClientData)xslt, &new);
#else
        entry = Tcl_CreateHashEntry(&info->doc_hash_bydoc, (ClientData)xmlDoc, &new);
#endif
     if (new) {
        my_log(lexpos(), "set doc_hash_bydoc to %x", d_info);
        Tcl_SetHashValue(entry, (ClientData)d_info);
     } else {
        d_info = (doc_info *)Tcl_GetHashValue(entry);
     }
     if (flags & ENTER_PERSISTENT) {
        Ns_UnlockMutex(&lock);
     } else {
#ifdef NS_AOLSERVER_3_PLUS
          Ns_TclRegisterDeferred(interp, cleanup_after_connection, NULL);
#else
          Ns_DString cmd;

          Ns_DStringInit(&cmd);
          Ns_DStringPrintf(&cmd, "ns_atclose {ns_xml doc cleanup %s}", Ns_DStringValue(&result));
          Tcl_Eval(interp, Ns_DStringValue(&cmd));
          Ns_DStringFree(&cmd);
#endif
          my_log( lexpos(), "entering doc value %s interp %x", Ns_DStringValue(&result),
                interp);
     }
     if ( append_result_p ) {
          Tcl_AppendResult(interp, Ns_DStringValue(&result), NULL);
          Ns_DStringFree(&result);
     }
}

#ifdef DO_XSLT
static void
xml_enter_doc(Tcl_Interp *interp, xmlDocPtr xmlDoc, int flags, int append_result_p)
{
     xml_enter_doc_or_xslt(interp, xmlDoc, NULL, flags, append_result_p );
}

static void
xml_enter_xslt(Tcl_Interp *interp, xsltStylesheetPtr xslt, int flags, int append_result_p)
{
     xml_enter_doc_or_xslt(interp, NULL, xslt, flags, append_result_p );
}
#endif

/*
 * Constructs a node ID string (e.g. "n0") for the given
 * node pointer and appends it to the result for this interpreter.
 * The determination as to whether it is a temporary node
 * or a persistent one is taken from the status of the document
 * the node is attached to.
 */

static void
xml_enter_node(Tcl_Interp *interp, xmlNodePtr node)
{
  id_info *info;
  Tcl_HashEntry *node_entry, *id_entry, *doc_entry;
  int new;
  xmlDoc *doc;
  doc_info *d_info;
  node_info *n_info;
  char prefix;

  if (node == NULL)
    return;

  /* Determine if node is attached to a temporary
   * or persistent doc
   */
  doc = node->doc;
  my_log(lexpos(), "node attached to doc %x", doc);
  /* Look for temporary first */
  info = get_interp_info(interp);
  doc_entry = Tcl_FindHashEntry(&info->doc_hash_bydoc, (ClientData) doc);
  my_log(lexpos(), "doc entry %x", doc_entry);
  if (doc_entry != NULL) {
    my_log(lexpos(), "doc is a temporary one");
    prefix = 'n';
  } else {
    info = perm_info;
    Ns_LockMutex(&lock);
    doc_entry = Tcl_FindHashEntry(&info->doc_hash_bydoc, (ClientData) doc);
    prefix = 'N';
    my_log(lexpos(), "doc is persistent");
    if (doc_entry == NULL) {
      my_log(lexpos(), "doc not found");
      Tcl_AppendResult(interp, "This should never happen", NULL);
      return;
    }
  }
  id_entry = Tcl_CreateHashEntry(&info->node_hash_bynode,
                                 (ClientData) node, &new);
  if (new) {
    Ns_DString result;

    Ns_DStringInit(&result);
    do {
      Ns_DStringTrunc(&result, 0);
      Ns_DStringPrintf(&result, "%c%u", prefix, info->next_node_id);
      info->next_node_id += 1;
      node_entry = Tcl_CreateHashEntry(&info->node_hash_byid,
                                       Ns_DStringValue(&result), &new);
    } while (!new);
    my_log( lexpos(), "Creating new node id %s", Ns_DStringValue(&result));
    Tcl_SetHashValue(node_entry, node);
    Tcl_AppendResult(interp, Ns_DStringValue(&result), NULL);
    Tcl_SetHashValue(id_entry, Ns_StrDup(Ns_DStringValue(&result)));
    Ns_DStringFree(&result);
    d_info = Tcl_GetHashValue(doc_entry);
    n_info = node_info_create(node, d_info->nodes);
    d_info->nodes = n_info;
  } else {
    char *value;

    value = (char *)Tcl_GetHashValue(id_entry);
    Tcl_AppendResult(interp, value, NULL);
  }
  if (prefix == 'N') {
    Ns_UnlockMutex(&lock);
  }
}

/*
 * Appends information about the location of a parse error
 * to the Tcl result.
 */

static void
xml_append_file_info(Ns_DString *str, xmlParserInputPtr input) {
  if (input != NULL) {
    if (input->filename)
      Ns_DStringPrintf(str, "%s:%d: ", input->filename,
              input->line);
    else
      Ns_DStringPrintf(str, "Entity: line %d: ", input->line);
  }
}

/*
 * Appends information about the context of a parse error
 * to the Tcl result.
 */

static void
xml_append_file_context(Ns_DString *str, xmlParserInputPtr input) {
  const xmlChar *cur, *base;
  int n;
  char buf[2];

  if (input == NULL) return;
  buf[1] = '\0';
  cur = input->cur;
  base = input->base;
  while ((cur > base) && ((*cur == '\n') || (*cur == '\r'))) {
    cur--;
  }
  n = 0;
  while ((n++ < 80) && (cur > base) && (*cur != '\n') && (*cur != '\r'))
    cur--;
  if ((*cur == '\n') || (*cur == '\r')) cur++;
  base = cur;
  n = 0;
  while ((*cur != 0) && (*cur != '\n') && (*cur != '\r') && (n < 79)) {
    buf[0] = (unsigned char )*cur++;
    Ns_DStringAppend(str, buf);
    n++;
  }
  Ns_DStringAppend(str, "\n");
  cur = input->cur;
  while ((*cur == '\n') || (*cur == '\r'))
    cur--;
  n = 0;
  while ((cur != base) && (n++ < 80)) {
    Ns_DStringAppend(str, " ");
    base++;
  }
  Ns_DStringAppend(str,"^\n");
}

/*
 * Custom warning message function that is called from the
 * XML parsing routine; it appends the message to the 
 * Tcl result.
 */

static void
xml_parse_warning(void *ctx, const char *msg, ...)
{
  xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr) ctx;
  xmlParserInputPtr input;
  xmlParserInputPtr cur = NULL;
  va_list args;
  Tcl_Interp *interp = (Tcl_Interp *)ctxt->_private;
  Ns_DString str;
  char buf[4096];

  Ns_DStringInit(&str);
  input = ctxt->input;
  if ((input != NULL) && (input->filename == NULL) && (ctxt->inputNr > 1)) {
    cur = input;
    input = ctxt->inputTab[ctxt->inputNr - 2];
  }
        
  xml_append_file_info(&str, input);

  Ns_DStringAppend(&str, "warning: ");
  va_start(args, msg);
  vsnprintf(buf, sizeof(buf), msg, args);
  va_end(args);
  Ns_DStringAppend(&str, buf);

  xml_append_file_context(&str, input);
  if (cur != NULL) {
    xml_append_file_info(&str, cur);
    Ns_DStringAppend(&str, "\n");
    xml_append_file_context(&str, cur);
  }
  Tcl_AppendResult(interp, Ns_DStringValue(&str), NULL);
  Ns_DStringFree(&str);
}

/*
 * Custom error message function that is called from the
 * XML parsing routine; it appends the message to the 
 * Tcl result.
 */

static void
xml_parse_error(void *ctx, const char *msg, ...)
{
  xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr) ctx;
  xmlParserInputPtr input;
  xmlParserInputPtr cur = NULL;
  va_list args;
  Tcl_Interp *interp = (Tcl_Interp *)ctxt->_private;
  Ns_DString str;
  char buf[4096];

  my_log(lexpos(), "parse error");
  Ns_DStringInit(&str);
  input = ctxt->input;
  if ((input != NULL) && (input->filename == NULL) && (ctxt->inputNr > 1)) {
    cur = input;
    input = ctxt->inputTab[ctxt->inputNr - 2];
  }
        
  xml_append_file_info(&str, input);

  Ns_DStringAppend(&str, "error: ");
  va_start(args, msg);
  vsnprintf(buf, sizeof(buf), msg, args);
  va_end(args);
  Ns_DStringAppend(&str, buf);

  xml_append_file_context(&str, input);
  if (cur != NULL) {
    xml_append_file_info(&str, cur);
    Ns_DStringAppend(&str, "\n");
    xml_append_file_context(&str, cur);
  }
  Tcl_AppendResult(interp, Ns_DStringValue(&str), NULL);
  Ns_DStringFree(&str);
}

/*
 * Retrieve an external entity (probably a DTD).
 *
 */
static xmlParserInputPtr
xml_load_entity(const char *url, const char *id, xmlParserCtxtPtr ctxt)
{
  xmlParserInputPtr input;
  Ns_DString str;
  int cc;
  char *buf;
  char *protocol, *host, *port, *path, *tail;

  buf = Ns_StrDup((char *)url);
  Ns_ParseUrl(buf, &protocol, &host, &port, &path, &tail);

  Ns_DStringInit(&str);
  if (protocol && strcmp(protocol, "http") == 0) {
    cc = Ns_FetchURL(&str, (char *)url, NULL);
  } else if (protocol == NULL || *protocol == '\0' 
             || strcmp(protocol, "file") == 0) {
    Ns_DString pathStr;
    char *newPath;

    if (path) {
        Ns_DStringInit(&pathStr);
        Ns_MakePath(&pathStr, path, tail, NULL);
        newPath = Ns_DStringValue(&pathStr);
    } else {
        newPath = tail;
    }
    cc = Ns_FetchPage(&str, newPath, NULL);
    if (path) {
        Ns_DStringFree(&pathStr);
    }
  } else {
    /* We must use Ns_Log here instead of appending a Tcl error
     * because we don't have access to the interp pointer;
     * we are in a sub-context of the parser context that has a valid
     * userData2 pointer.
     *
     * There is a problem here: we can't really signal an error
     * to the caller, since returning NULL will just result in this
     * input being skipped.
     */
    Ns_Log(Error,
      "ns_xml: error fetching external entity '%s': unsupported protocol '%s'",
           url,
           protocol ? protocol : "(null)");
    Ns_Free(buf);
    return NULL;
  }
  Ns_Free(buf);
  if (cc != NS_OK) {
    /* Must use Ns_Log as noted above. */
    Ns_Log(Error,
      "ns_xml: error fetching external entity URL '%s'",
           url);
    return NULL;
  }
  input = xmlNewStringInputStream(ctxt, Ns_DStringExport(&str));
  Ns_DStringFree(&str);
  return input;
}



/*
 * Parse an XML string and return a pointer
 * to an xmlDoc.
 * The validate flag determines whether the parser will
 * validate against a DTD;
 * if it is 0, it won't, if it's 1, it will,
 * and if it is -1, it will use the parser's default behavior.
 * Returns NULL if there was an error and appends
 * the error message to the Tcl result.
 */

static xmlDocPtr
xml_parse(Tcl_Interp *interp, char *buffer, int validate) {
    xmlDocPtr ret;
    xmlParserCtxtPtr ctxt;

    my_log(lexpos(), "xml_parse");

    if (buffer == NULL) return(NULL);
    
    ctxt = xmlCreateDocParserCtxt(buffer);
    if (ctxt == NULL) return(NULL);

    ctxt->_private = interp;
    /* Use our own custom error functions */
    ctxt->sax->warning = xml_parse_warning;
    ctxt->sax->error = xml_parse_error;
    ctxt->sax->fatalError = xml_parse_error;
    ctxt->vctxt.warning = xml_parse_warning;
    ctxt->vctxt.error = xml_parse_error;

    if (validate >= 0) {
        ctxt->validate = (validate > 0);
    }
    xmlParseDocument(ctxt);

    if (ctxt->wellFormed && ctxt->valid)
      ret = ctxt->myDoc;
    else {
      ret = NULL;
      xmlFreeDoc(ctxt->myDoc);
      ctxt->myDoc = NULL;
      if (!ctxt->wellFormed) {
        Tcl_AppendResult(interp, "document was not well formed\n", NULL);
      } else if (!ctxt->valid) {
        Tcl_AppendResult(interp, "document failed validation\n", NULL);
      }
    }
    xmlFreeParserCtxt(ctxt);
    
    return(ret);
}


/*
 * The "ns_xml doc" tcl command.
 */

static int
xml_doc_command (ClientData dummy, Tcl_Interp *interp,
                 int argc, char *argv[])
{
  if (argc < 3) {
    Tcl_AppendResult(interp, "bad # of args", NULL);
    return TCL_ERROR;
  }
  if (strcmp(argv[1], "root") == 0) {
    xmlDoc *doc;

    my_log(lexpos(), "find root of %s", argv[2]);
    doc = xml_find_doc(interp, argv[2]);
    if (doc == NULL) {
      Tcl_AppendResult(interp, "invalid doc ID ", argv[2], NULL);
      return TCL_ERROR;
    }
    my_log(lexpos(), "enter node");
    xml_enter_node(interp, (xmlNode *)doc);
  } else if (strcmp(argv[1], "create") == 0) {
    xmlDocPtr doc;
    int flags = ENTER_TRANSIENT;
    char **arg_ptr = &argv[2];
    char *version = "1.0";

    if (argc > 2) {
      if (strcmp(*arg_ptr, "-persist") == 0) {
        flags = ENTER_PERSISTENT;
        arg_ptr++;
        argc--;
      }
    }
    if (argc > 2) {
      version = *arg_ptr;
    }
    if (argc > 3) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    doc = xmlNewDoc(version);
    if (doc == NULL) {
      Tcl_AppendResult(interp, "error allocating new doc", NULL);
      return TCL_ERROR;
    }
    xml_enter_doc(interp, doc, flags, NS_TRUE);
  } else if (strcmp(argv[1], "free") == 0 ||
             strcmp(argv[1], "cleanup") == 0) {
    char *docId;
    id_info *info;
    Tcl_HashEntry *entry;
    doc_info *d_info;

    if (argc != 3) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    docId = argv[2];
    my_log(lexpos(), "freeing doc %s interp %x", docId, interp);
    if (docId[0] == 'p') {
      info = perm_info;
    } else if (docId[0] == 't') {
      info = get_interp_info(interp);
    } else {
      Tcl_AppendResult(interp, "invalid xml doc ID ", docId, NULL);
      return TCL_ERROR;
    }
    my_log(lexpos(), "free or cleanup %s %s", docId, interp);
    entry = Tcl_FindHashEntry(&info->doc_hash_byid, docId);
    if (entry == NULL) {
      if (argv[1][0] == 'c') {
        /* "cleanup" command is tolerant of errors */
        return TCL_OK;
      }
      Tcl_AppendResult(interp, "invalid xml doc ID ", docId, NULL);
      return TCL_ERROR;
    }
    d_info = (doc_info *)Tcl_GetHashValue(entry);
    if (d_info == NULL) {
      Tcl_AppendResult(interp, "hash table screwup", NULL);
      return TCL_ERROR;
    }
    my_log(lexpos(), "got d_info %x", d_info);
    Tcl_DeleteHashEntry(entry);
    entry = Tcl_FindHashEntry(&info->doc_hash_bydoc, (ClientData)d_info->doc);
    Tcl_DeleteHashEntry(entry);
    doc_info_free(info, d_info);
  } else if (strcmp(argv[1], "new_root") == 0) {
    xmlDocPtr xmlDoc;
    xmlNodePtr root;

    if (argc != 5) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    xmlDoc = xml_find_doc(interp, argv[2]);
    if (xmlDoc == NULL) {
      Tcl_AppendResult(interp, "invalid doc ID ", argv[2], NULL);
      return TCL_ERROR;
    }
    root = xmlNewDocNode(xmlDoc, NULL, argv[3], argv[4]);
    xmlDocSetRootElement(xmlDoc, root);
    xml_enter_node(interp, root);
  } else if (strcmp(argv[1], "render") == 0) {
    xmlDocPtr xmlDoc;
    xmlChar *buf;
    int size;

    if (argc != 3) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    xmlDoc = xml_find_doc(interp, argv[2]);
    if (xmlDoc == NULL) {
      Tcl_AppendResult(interp, "invalid doc ID ", argv[2], NULL);
      return TCL_ERROR;
    }

    xmlDocDumpMemory(xmlDoc, &buf, &size);
    Tcl_SetResult(interp, buf, (Tcl_FreeProc *)Ns_Free);
  } else {
    Tcl_AppendResult(interp, "unknown command", NULL);
    return TCL_ERROR;
  }
  return TCL_OK;
}

/*
 * Returns a static pointer to
 * the XML type name for a type number.
 */

static char *
xml_type_name(xmlElementType type)
{
  static char *type_names[] = {
    "element",
    "attribute",
    "text",
    "cdata_section",
    "entity_ref",
    "entity",
    "pi",
    "comment",
    "document",
    "document_type",
    "document_frag",
    "notation",
    "html_document",
    "dtd", 
    "element_decl", 
    "attribute_decl", 
    "entity_decl",
    "namespace_decl",
    "xinclude_start",
    "xinclude_end",
    "docb_document_node"
  };
  
  if ((int)type < 0 || (int)type >= (sizeof(type_names) / sizeof(char *))) {
    return "unknown";
  }
  return type_names[(int)type];
}

/*
 * The "ns_xml node" Tcl command.
 */

static int
xml_node_command (ClientData dummy, Tcl_Interp *interp,
                  int argc, char *argv[])
{
  if (strcmp(argv[1], "children") == 0) {
    xmlNode *node;
    int i;

    if (argc != 3) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    node = xml_find_node_byid(interp, argv[2]);
    if (node == NULL) {
      Tcl_AppendResult(interp, "invalid node ID ", argv[2], NULL);
      return TCL_ERROR;
    }
    for (i = 0, node=node->children; node != NULL; i++, node = node->next) {
      if (i > 0) {
        Tcl_AppendResult(interp, " ", NULL);
      }
      xml_enter_node(interp, node);
    }
  } else if (strcmp(argv[1], "name") == 0) {
    xmlNode *node;

    if (argc != 3) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    node = xml_find_node_byid(interp, argv[2]);
    if (node == NULL) {
      Tcl_AppendResult(interp, "invalid node ID ", argv[2], NULL);
      return TCL_ERROR;
    }
    Tcl_AppendResult(interp, node->name, NULL);
  } else if (strcmp(argv[1], "type") == 0) {
    xmlNode *node;

    if (argc != 3) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    node = xml_find_node_byid(interp, argv[2]);
    if (node == NULL) {
      Tcl_AppendResult(interp, "invalid node ID ", argv[2], NULL);
      return TCL_ERROR;
    }
    Tcl_SetResult(interp, xml_type_name(node->type), TCL_STATIC);
  } else if (strcmp(argv[1], "getcontent") == 0) {
    xmlNode *node;
    char *value;

    if (argc != 3) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    node = xml_find_node_byid(interp, argv[2]);
    if (node == NULL) {
      Tcl_AppendResult(interp, "invalid node ID ", argv[2], NULL);
      return TCL_ERROR;
    }
    value = xmlNodeGetContent(node);
    Tcl_SetResult(interp, value, (Tcl_FreeProc *)Ns_Free);
  } else if (strcmp(argv[1], "setcontent") == 0) {
    xmlNode *node;

    if (argc != 4) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    node = xml_find_node_byid(interp, argv[2]);
    if (node == NULL) {
      Tcl_AppendResult(interp, "invalid node ID ", argv[2], NULL);
      return TCL_ERROR;
    }
    (void) xmlNodeSetContent(node, argv[3]);
  } else if (strcmp(argv[1], "getattr") == 0) {
    xmlNode *node;
    char *value;

    if (argc != 4) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    node = xml_find_node_byid(interp, argv[2]);
    if (node == NULL) {
      Tcl_AppendResult(interp, "invalid node ID ", argv[2], NULL);
      return TCL_ERROR;
    }
    value = xmlGetProp(node, argv[3]);
    Tcl_SetResult(interp, value, (Tcl_FreeProc *)Ns_Free);
  } else if (strcmp(argv[1], "setattr") == 0) {
    xmlNode *node;

    if (argc != 5) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    node = xml_find_node_byid(interp, argv[2]);
    if (node == NULL) {
      Tcl_AppendResult(interp, "invalid node ID ", argv[2], NULL);
      return TCL_ERROR;
    }
    (void) xmlSetProp(node, argv[3], argv[4]);
  } else if (strcmp(argv[1], "new_child") == 0) {
    xmlNode *node;
    xmlNode *newNode;

    if (argc != 5) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    node = xml_find_node_byid(interp, argv[2]);
    if (node == NULL) {
      Tcl_AppendResult(interp, "invalid node ID ", argv[2], NULL);
      return TCL_ERROR;
    }
    newNode = xmlNewChild(node, NULL, argv[3], argv[4]);
    xml_enter_node(interp, newNode);
  } else if (strcmp(argv[1], "new_sibling") == 0) {
    xmlNode *node;
    xmlNode *newNode;

    if (argc != 5) {
      Tcl_AppendResult(interp, "bad # of args", NULL);
      return TCL_ERROR;
    }
    node = xml_find_node_byid(interp, argv[2]);
    if (node == NULL) {
      Tcl_AppendResult(interp, "invalid node ID ", argv[2], NULL);
      return TCL_ERROR;
    }
    newNode = xmlNewDocNode(node->doc, NULL, argv[3], argv[4]);
    xmlAddSibling(node, newNode);
    xml_enter_node(interp, newNode);
  } else {
    Tcl_AppendResult(interp, "unknown command", NULL);
    return TCL_ERROR;
  }
  return TCL_OK;
}

/*
 * Debugging function to print out statistics
 * on the various hash tables used internally
 * by the xml-module.
 */

static int
xml_info_stats(id_info *info)
{
  char *message;

  message = Tcl_HashStats(&info->doc_hash_byid);
  Ns_Log(Notice, "doc_hash_byid--> %s", message);
  ckfree(message);
  message = Tcl_HashStats(&info->doc_hash_bydoc);
  Ns_Log(Notice, "doc_hash_bydoc--> %s", message);
  ckfree(message);
  message = Tcl_HashStats(&info->node_hash_bynode);
  Ns_Log(Notice, "node_hash_byid--> %s", message);
  ckfree(message);
  message = Tcl_HashStats(&info->node_hash_bynode);
  Ns_Log(Notice, "node_hash_bynode--> %s", message);
  ckfree(message);
  return TCL_OK;
}

/*
 * The Tcl command for printing internal hash table
 * statistics to the AOLserver log.
 */

static int
xml_stats (ClientData dummy, Tcl_Interp *interp,
           int argc, char *argv[])
{
  Tcl_HashEntry *entry;
  Tcl_HashSearch search;
  char *message;

  Ns_LockMutex(&lock);
  message = Tcl_HashStats(&interp_hash);
  Ns_Log(Notice, "** interp hash: %s", message);
  ckfree(message);
  Ns_Log(Notice, "** perm_info **");
  xml_info_stats(perm_info);
  entry = Tcl_FirstHashEntry(&interp_hash, &search);
  while (entry) {
    Ns_Log(Notice, "** interp %x **", Tcl_GetHashKey(&interp_hash, entry));
    /* xml_info_stats(Tcl_GetHashValue(entry));*/
    entry = Tcl_NextHashEntry(&search);
  }
  Ns_UnlockMutex(&lock);
  return TCL_OK;
}

#ifdef DO_XSLT
/*
 * Tcl command for applying xslt to a xml document.
 * returns another xml document
 * xml_doc = ns_xml apply_xslt ?-persist? $xslt_doc $xml_doc
 */
static int
xml_apply_xslt( ClientData dummy, Tcl_Interp *interp,
                int argc, char *argv[] )
{
     const char *params[16+1];
     int nbparams = 0;
     xmlDocPtr  res, doc;
     xsltStylesheetPtr  xslt;
     int flags = ENTER_TRANSIENT;
     char **arg_ptr = &argv[1];

     my_log(lexpos(), "arg num: %d", argc);


     if (argc >= 3) {
       if (strcmp(*arg_ptr, "-persist") == 0) {
         flags = ENTER_PERSISTENT;
         arg_ptr++;
         argc--;
       }
     }
 
     if ( argc < 3 ) {
          Tcl_AppendResult(interp, "bad # of args", NULL);
          return TCL_ERROR;
     }

     my_log(lexpos(), "xslt %s xml %s", arg_ptr[0], arg_ptr[1]);

     xslt = xml_find_xslt(interp, arg_ptr[0] );
     if ( NULL == xslt ) {
          Tcl_AppendResult(interp, "invalid xslt doc ID ", arg_ptr[0], NULL );
          return TCL_ERROR;
     }

     doc = xml_find_doc(interp, arg_ptr[1] );
     if ( NULL == doc ) {
          Tcl_AppendResult(interp, "invalid xml doc ID ", arg_ptr[1], NULL );
          return TCL_ERROR;
     }

     params[nbparams] = NULL;
     res = xsltApplyStylesheet( xslt, doc, params);
     if ( NULL == res ) {
          Tcl_AppendResult(interp, "error applying stylesheet", NULL );
          return TCL_ERROR;
     }
     xml_enter_doc(interp, res, flags, NS_TRUE );
     return TCL_OK;
}
#endif

/*
 * The ns_xml Tcl command.
 */

static int
xml_tcl_command (ClientData dummy, Tcl_Interp *interp, 
                 int argc, char *argv[])
{
  xmlDocPtr xmlDoc;

  my_log( lexpos(), "xml_tcl_command: %d %s", argc, argv[1]);
  if (argc < 2) {
    Tcl_AppendResult(interp, "bad # of args", NULL);
    return TCL_ERROR;
  }
  if (strcmp(argv[1], "parse") == 0) {
    int flag;
    int validate = 0;
    char *xml_string;
    char **argp;

    flag = ENTER_TRANSIENT;
    argp = &argv[2];
    while (argc >= 3) {
        argc--;
        if (strcmp(*argp, "-persist") == 0) {
            flag = ENTER_PERSISTENT;
        } else if (strcmp(*argp, "-validate") == 0) {
            validate = 1;
        } else {
          xml_string = *argp;
          break;
        }
        argp++;
    }
    if (argc != 2) {
        Tcl_AppendResult(interp, "bad # of args", NULL);
        return TCL_ERROR;
    }
    xmlDoc = xml_parse(interp, xml_string, validate);
    if (xmlDoc == NULL) {
      Tcl_AppendResult(interp, "error while parsing XML", NULL);
      return TCL_ERROR;
    }
    xml_enter_doc(interp, xmlDoc, flag, NS_TRUE);
  } else if (strcmp(argv[1], "doc") == 0) {
    return xml_doc_command(dummy, interp, argc-1, argv+1);
  } else if (strcmp(argv[1], "node") == 0) {
    return xml_node_command(dummy, interp, argc-1, argv+1);
  } else if (strcmp(argv[1], "stats") == 0) {
    return xml_stats(dummy, interp, argc-1, argv+1);
#ifdef DO_XSLT
  } else if (strcmp(argv[1], "parse_xslt") == 0) {
       int flag;
       int validate = 0;
       char *xml_string;
       char **argp;
       xsltStylesheetPtr xslt=NULL;
       
       flag = ENTER_TRANSIENT;
       argp = &argv[2];
       while (argc >= 3) {
            argc--;
            if (strcmp(*argp, "-persist") == 0) {
                 flag = ENTER_PERSISTENT;
            } else if (strcmp(*argp, "-validate") == 0) {
                 validate = 1;
            } else {
                 xml_string = *argp;
                 break;
            }
            argp++;
       }
       if (argc != 2) {
            Tcl_AppendResult(interp, "bad # of args", NULL);
            return TCL_ERROR;
       }
       xmlDoc = xml_parse(interp, xml_string, validate);
       if (xmlDoc == NULL) {
            Tcl_AppendResult(interp, "error while parsing XML", NULL);
            return TCL_ERROR;
       }
       xslt = xsltParseStylesheetDoc(xmlDoc);
       if ( NULL == xslt ) {
            Tcl_AppendResult(interp, "error parsing xslt", NULL );
            return TCL_ERROR;
       }
       xml_enter_xslt(interp, xslt, flag, NS_TRUE);
  } else if (strcmp(argv[1], "apply_xslt") == 0) {
       my_log(lexpos(), "xslt %s xml %s", argv[1], argv[2]);
       return xml_apply_xslt(dummy,interp,argc-1,argv+1);
#endif
  } else {
    Tcl_AppendResult(interp, "unknown command", NULL);
    return TCL_ERROR;
  }

  return TCL_OK;
}


/*
 * Called during the initialization of a new interpreter;
 * adds our "ns_xml" Tcl command to the interpreter.
 */

static int
xml_interp_init (Tcl_Interp *interp, void *dummy)
{
  Tcl_CreateCommand (interp, "ns_xml", xml_tcl_command, NULL, NULL);
  
  return NS_OK;
}

/*
 * Called when the module is loaded.
 */

NS_EXPORT int
Ns_ModuleInit(char *hServer, char *hModule)
{
  char *configPath;

  Ns_Log( Notice, "%s module starting", hModule);

  configPath = Ns_ConfigGetPath(hServer, hModule, NULL);
  if (!Ns_ConfigGetBool (configPath, "Debug", &debug_p)) 
    debug_p = DEFAULT_DEBUG;

  perm_info = id_info_create();
  if ( NULL == perm_info ) {
        Ns_Log( Notice, "couldn't create perm_info in nsxml" );
        return NS_ERROR;
  }
  Tcl_InitHashTable(&interp_hash, TCL_ONE_WORD_KEYS);

  Ns_InitializeMutex(&lock);

  xmlMemSetup ((xmlFreeFunc) Ns_Free,
                (xmlMallocFunc) Ns_Malloc,
               (xmlReallocFunc) Ns_Realloc,
               (xmlStrdupFunc) Ns_StrDup);

  xmlInitMemory();

  xmlSetExternalEntityLoader(xml_load_entity);

  xmlInitParser();
#ifdef DO_XSLT
  xmlSubstituteEntitiesDefault(1);
  xsltSetGenericErrorFunc(NULL, xsltNsGenericErrorFunc);
#endif

  Ns_TclInitInterps (hServer, xml_interp_init, NULL);

  return NS_OK;
}

/* Required to identify the module version to AOLserver. */
NS_EXPORT int Ns_ModuleVersion = 1;

