/* $Id: xml.c,v 1.10 2005/07/11 14:50:41 agraef Exp $ */

/* This file is part of the Q programming system.

   The Q programming system is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2, or (at your option)
   any later version.

   The Q programming system is distributed in the hope that it will be
   useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */

#if defined (HAVE_CONFIG_H)
#  include "config.h"
#endif

/* system headers */

#include <stdio.h>
#include <ctype.h>
#include <math.h>

/* check for standard C headers */
#if STDC_HEADERS
# include <stdlib.h>
# include <string.h>
#else
# ifndef HAVE_STRCHR
#  define strchr index
#  define strrchr rindex
# endif
char *strchr (), *strrchr ();
#endif

#ifdef HAVE_MALLOC_H
#include <stdlib.h>
#endif

#ifdef HAVE_LIMITS_H
#include <limits.h>
#endif

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

#ifdef DMALLOC
#include <dmalloc.h>
#endif

#include <libq.h>
#include <libxml/xmlmemory.h>
#include <libxml/parser.h>
#include <libxml/xpath.h>
#include <libxslt/xslt.h>
#include <libxslt/xsltInternals.h>
#include <libxslt/transform.h>
#include <libxslt/xsltutils.h>

MODULE(xml)

/* initialization *****************************************************************/

/* cache symbol names */

static int sym_element, sym_element_text, sym_text, sym_cdata, sym_comment,
  sym_attr, sym_entity_ref, sym_pi,
  
  sym_doctype,
  
  sym_undefined_element, sym_empty_element, sym_any_element, sym_std_element,
  sym_mixed_element,
  
  sym_pcdata, sym_mksequence, sym_mkunion, sym_opt, sym_mult, sym_plus,
  
  sym_cdata_attr, sym_id_attr, sym_idref_attr, sym_idrefs_attr,
  sym_entity_attr, sym_entities_attr, sym_nmtoken_attr,
  sym_nmtokens_attr, sym_enum_attr, sym_notation_attr,
  
  sym_default, sym_required, sym_implied, sym_fixed,
  
  sym_int_entity, sym_int_param_entity, sym_ext_entity, sym_ext_param_entity;

INIT(xml)
{
  sym_element = sym(element);
  sym_element_text = sym(element_text);
  sym_text = sym(text);
  sym_cdata = sym(cdata);
  sym_comment = sym(comment);
  sym_attr = sym(attr);
  sym_entity_ref = sym(entity_ref);
  sym_pi = sym(pi);
  
  sym_doctype = sym(doctype);
  
  sym_undefined_element = sym(undefined_element);
  sym_empty_element = sym(empty_element);
  sym_any_element = sym(any_element);
  sym_std_element = sym(std_element);
  sym_mixed_element = sym(mixed_element);
  
  sym_pcdata = sym(pcdata);
  sym_mksequence = sym(mksequence);
  sym_mkunion = sym(mkunion);
  sym_opt = sym(opt);
  sym_mult = sym(mult);
  sym_plus = sym(plus);
  
  sym_cdata_attr = sym(cdata_attr);
  sym_id_attr = sym(id_attr);
  sym_idref_attr = sym(idref_attr);
  sym_idrefs_attr = sym(idrefs_attr);
  sym_entity_attr = sym(entity_attr);
  sym_entities_attr = sym(entities_attr);
  sym_nmtoken_attr = sym(nmtoken_attr);
  sym_nmtokens_attr = sym(nmtokens_attr);
  sym_enum_attr = sym(enum_attr);
  sym_notation_attr = sym(notation_attr);
  
  sym_default = sym(default);
  sym_required = sym(required);
  sym_implied = sym(implied);
  sym_fixed = sym(fixed);
  
  sym_int_entity = sym(int_entity);
  sym_int_param_entity = sym(int_param_entity);
  sym_ext_entity = sym(ext_entity);
  sym_ext_param_entity = sym(ext_param_entity);
}

/* static buffer for parsing and constructing qualified names */

static int bufsz = -1;
static char *buf = NULL;

static char *mkbuf(int size)
{
  if (!buf) {
    buf = malloc(size+1);
    if (buf)
      bufsz = size+1;
    else
      return NULL;
  } else if (size+1 > bufsz) {
    char *buf1 = realloc(buf, size+1);
    if (buf1) {
      buf = buf1;
      bufsz = size+1;
    } else
      return NULL;
  }
  return buf;
}

FINI(xml)
{
  if (buf) {
    free(buf);
    buf = NULL;
    bufsz = -1;
  }
}

/* helper functions ***************************************************************/

/* parser flags */

#define XML_DTDLOAD	0x01
#define XML_DTDVALID	0x02
#define XML_PEDANTIC	0x04
#define XML_SUBENT	0x08
#define XML_NOBLANKS	0x10

#ifdef _WIN32
/* correct garbled declarations in libxml/globals.h */
__declspec(dllimport) int xmlLoadExtDtdDefaultValue;
__declspec(dllimport) int xmlDoValidityCheckingDefaultValue;
__declspec(dllimport) int xmlPedanticParserDefaultValue;
__declspec(dllimport) int xmlSubstituteEntitiesDefaultValue;
__declspec(dllimport) int xmlKeepBlanksDefaultValue;
__declspec(dllimport) int xmlIndentTreeOutput;
#endif

static unsigned set_flags(unsigned flags)
{
  unsigned oldflags = (!!xmlLoadExtDtdDefaultValue)*XML_DTDLOAD |
    (!!xmlDoValidityCheckingDefaultValue)*XML_DTDVALID |
    (!!xmlPedanticParserDefaultValue)*XML_PEDANTIC |
    (!!xmlSubstituteEntitiesDefaultValue)*XML_SUBENT |
    (!xmlKeepBlanksDefaultValue)*XML_NOBLANKS;
  xmlLoadExtDtdDefaultValue = !!(flags&XML_DTDLOAD);
  xmlDoValidityCheckingDefaultValue = !!(flags&XML_DTDVALID);
  xmlPedanticParserDefaultValue = !!(flags&XML_PEDANTIC);
  xmlSubstituteEntitiesDefaultValue = !!(flags&XML_SUBENT);
  xmlKeepBlanksDefaultValue = !(flags&XML_NOBLANKS);
  return oldflags;
}

/* supported node types */

static supported(xmlNodePtr node)
{
  switch (node->type) {
  case XML_ELEMENT_NODE:
  case XML_ATTRIBUTE_NODE:
  case XML_ENTITY_REF_NODE:
  case XML_TEXT_NODE:
  case XML_CDATA_SECTION_NODE:
  case XML_COMMENT_NODE:
  case XML_PI_NODE:
  case XML_DTD_NODE:
  case XML_ELEMENT_DECL:
  case XML_ATTRIBUTE_DECL:
  case XML_ENTITY_DECL:
    return 1;
  default:
    return 0;
  }
}

/* maintain node and doc references */

static void chknode(xmlNodePtr node)
{
  if (node->_private)
    xmlUnlinkNode(node);
  else {
    xmlNodePtr next;
    for (node = node->children; node; node = next) {
      next = node->next;
      chknode(node);
    }
  }
}

static void newdocref(xmlNodePtr node)
{
  if (node != (xmlNodePtr)node->doc && node->doc && node->doc->_private)
    newref(node->doc->_private);
}

static void freedocref(xmlNodePtr node)
{
  if (node != (xmlNodePtr)node->doc && node->doc && node->doc->_private)
    freeref(node->doc->_private);
}

static void freenode(xmlNodePtr node)
{
  if (!supported(node))
    /* Better don't touch this one ... There's a potential mem leak here, but
       we shouldn't get an unsupported node type in the first place. */
    ;
  else if (node->_private)
    /* Dangling reference -- will be collected later. */
    ;
  else if (node->type == XML_ATTRIBUTE_NODE)
    xmlFreeProp((xmlAttrPtr)node);
  else
    xmlFreeNode(node);
}

/* qualified element and attribute names */

static const char *splitname(const char *name, const char **prefix)
{
  char *pos = strchr(name, ':');
  if (pos) {
    int p = pos-name;
    char *buf = mkbuf(strlen(name));
    if (!buf) {
      *prefix = NULL;
      return NULL;
    }
    strcpy(buf, name);
    buf[p] = 0;
    *prefix = buf;
    return buf+p+1;
  } else {
    *prefix = NULL;
    return name;
  }
}

static const char *mkname(const char *name, const char *prefix)
{
  char *buf;
  if (!prefix || !*prefix)
    return name;
  buf = mkbuf(strlen(name)+strlen(prefix));
  if (buf) sprintf(buf, "%s:%s", prefix, name);
  return buf;
}

static const char *mkname2(const char *name, xmlNsPtr ns)
{
  if (ns)
    return mkname(name, ns->prefix);
  else
    return name;
}

static const char *nodename(xmlNodePtr node)
{
  return mkname2(node->name, node->ns);
}

static const char *attrname(xmlAttrPtr attr)
{
  return mkname2(attr->name, attr->ns);
}

/* namespaces */

static xmlNsPtr mkns(xmlDocPtr doc, xmlNodePtr parent, xmlNodePtr node,
		     const char *prefix)
{
  xmlNsPtr ns = xmlSearchNs(doc, node, prefix);
  if (!ns && parent && node->parent != parent)
    ns = xmlSearchNs(doc, parent, prefix);
  return ns;
}

/* parse namespaces, attributes and node infos */

static int parse_namespace(expr namespace, char **prefix, char **href)
{
  expr *xs;
  int n;
  *prefix = *href = NULL;
  return istuple(namespace, &n, &xs) && n == 2 &&
    (isvoid(xs[0]) || isstr(xs[0], prefix)) && isstr(xs[1], href);
}

static int parse_namespaces(xmlNodePtr node, expr namespaces)
{
  expr hd, tl;
  char *prefix, *href;
  while (iscons(namespaces, &hd, &tl) && parse_namespace(hd, &prefix, &href) &&
	 (prefix || href)) {
    xmlNsPtr ns = xmlNewNs(node, href, prefix);
    if (!ns)
      return 0;
    namespaces = tl;
  }
  return isnil(namespaces);
}

static int parse_attr(expr attr, char **key, char **val)
{
  expr *xs;
  int n;
  return istuple(attr, &n, &xs) && n == 2 &&
    isstr(xs[0], key) && isstr(xs[1], val);
}

static int parse_attrs(xmlDocPtr doc, xmlNodePtr parent, xmlNodePtr node, expr attrs)
{
  expr hd, tl;
  char *key, *val;
  while (iscons(attrs, &hd, &tl) && parse_attr(hd, &key, &val)) {
    const char *prefix, *name = splitname(key, &prefix);
    xmlNsPtr ns = mkns(doc, parent, node, prefix);
    if (prefix && !ns) return 0;
    if (!xmlNewNsProp(node, ns, name, val)) return 0;
    attrs = tl;
  }
  return isnil(attrs);
}

static xmlNodePtr parse_info(xmlDocPtr doc, xmlNodePtr parent, expr info)
{
  xmlNodePtr node = NULL;
  char *s, *t;
  expr f, g, h, k, x, y, z, u;
  if (!isapp(info, &f, &x))
    return NULL;
  if (issym(f, sym_text) && isstr(x, &s))
    node = xmlNewText(s);
  else if (issym(f, sym_cdata) && isstr(x, &s))
    node = xmlNewCDataBlock(doc, s, strlen(s));
  else if (issym(f, sym_comment) && isstr(x, &s))
    node = xmlNewComment(s);
  else if (issym(f, sym_entity_ref) && isstr(x, &s))
    node = xmlNewReference(doc, s);
  else if (!isapp(f, &g, &y))
    return NULL;
  else if (issym(g, sym_pi) && isstr(y, &s) && isstr(x, &t))
    node = xmlNewPI(s, t);
  else if (!isapp(g, &h, &z))
    return NULL;
  else if (issym(h, sym_element) && isstr(z, &s)) {
    const char *prefix, *name = splitname(s, &prefix);
    node = xmlNewNode(NULL, name);
    if (!node) return NULL;
    if (!parse_namespaces(node, y)) {
      xmlFreeNode(node);
      return NULL;
    }
    if (!parse_attrs(doc, parent, node, x)) {
      xmlFreeNode(node);
      return NULL;
    }
    node->ns = mkns(doc, parent, node, prefix);
    if (prefix && !node->ns) {
      xmlFreeNode(node);
      return NULL;
    }
  } else if (!isapp(h, &k, &u))
    return NULL;
  else if (issym(k, sym_element_text) && isstr(u, &s) && isstr(x, &t)) {
    const char *prefix, *name = splitname(s, &prefix);
    node = xmlNewNode(NULL, name);
    if (!node) return NULL;
    if (!parse_namespaces(node, z)) {
      xmlFreeNode(node);
      return NULL;
    }
    if (!parse_attrs(doc, parent, node, y)) {
      xmlFreeNode(node);
      return NULL;
    }
    node->ns = mkns(doc, parent, node, prefix);
    if (prefix && !node->ns) {
      xmlFreeNode(node);
      return NULL;
    }
    xmlNodeAddContent(node, t);
  }
  return node;
}

/* construct different kinds of return values */

static expr mkstr2(const char *s)
{
  if (s)
    return mkstr(strdup(s));
  else
    return mkvoid;
}

static expr mknode(xmlNodePtr node)
{
  if (!node)
    return mkvoid;
  else if (node->_private)
    return node->_private;
  else {
    node->_private = mkobj(type(XMLNode), node);
    newdocref(node);
    return node->_private;
  }
}

static expr mkextid(const char *extid, const char *sysid)
{
  if (extid && sysid)
    return mktuplel(2, mkstr2(extid), mkstr2(sysid));
  else if (extid)
    return mkstr2(extid);
  else if (sysid)
    return mkstr2(sysid);
  else
    return mkvoid;
}

static expr mkcontent(xmlElementContentPtr content)
{
  expr c;
  switch (content->type) {
  case XML_ELEMENT_CONTENT_PCDATA:
    c = mksym(sym_pcdata);
    break;
  case XML_ELEMENT_CONTENT_ELEMENT:
    c = mkstr2(mkname(content->name, content->prefix));
    break;
  case XML_ELEMENT_CONTENT_SEQ:
    c = mkapp(mkapp(mksym(sym_mksequence), mkcontent(content->c1)),
	      mkcontent(content->c2));
    break;
  case XML_ELEMENT_CONTENT_OR:
    c = mkapp(mkapp(mksym(sym_mkunion), mkcontent(content->c1)),
	      mkcontent(content->c2));
    break;
  default:
    return __FAIL;
  }
  switch (content->ocur) {
  case XML_ELEMENT_CONTENT_ONCE:
    return c;
  case XML_ELEMENT_CONTENT_OPT:
    return mkapp(mksym(sym_opt), c);
  case XML_ELEMENT_CONTENT_MULT:
    return mkapp(mksym(sym_mult), c);
  case XML_ELEMENT_CONTENT_PLUS:
    return mkapp(mksym(sym_plus), c);
  default:
    return __FAIL;
  }
}

static expr mkenum(xmlEnumerationPtr ptr)
{
  int n = 0;
  xmlEnumerationPtr p;
  for (p = ptr; p; p = p->next) n++;
  if (n >= 0) {
    expr *xs;
    xs = malloc(n*sizeof(expr));
    if (!xs) return NULL;
    for (n = 0, p = ptr; p; p = p->next)
      xs[n++] = mkstr2(p->name);
    return mklistv(n, xs);
  } else
    return mknil;
}

/* XML interface ******************************************************************/

DESTRUCTOR(xml,XMLDoc,ptr)
{
  xmlDocPtr doc = (xmlDocPtr)ptr;
  xmlFreeDoc(doc);
}

DESTRUCTOR(xml,XMLNode,ptr)
{
  xmlNodePtr node = (xmlNodePtr)ptr;
  node->_private = NULL;
  if (!node->parent &&
      (!node->doc ||
       (xmlNodePtr)node->doc->extSubset != node &&
       (xmlNodePtr)node->doc->intSubset != node)) {
    xmlNodePtr n, next;
    for (n = node->children; n; n = next) {
      next = n->next;
      chknode(n);
    }
    freedocref(node);
    freenode(node);
  } else 
    freedocref(node);
}

FUNCTION(xml,xml_new_doc,argc,argv)
{
  char *s = NULL;
  char *extid = NULL, *sysid = NULL;
  expr *xs;
  int n;
  if (argc == 3 && (isvoid(argv[0]) || isstr(argv[0], &s)) &&
      (isvoid(argv[1]) || isstr(argv[1], &sysid) ||
       istuple(argv[1], &n, &xs) && n==2 && isstr(xs[0], &extid) &&
       isstr(xs[1], &sysid))) {
    xmlDocPtr doc = xmlNewDoc(s);
    xmlNodePtr root;
    if (!doc) return __FAIL;
    root = parse_info(doc, (xmlNodePtr)doc, argv[2]);
    if (!root) {
      xmlFreeDoc(doc);
      return __FAIL;
    }
    xmlDocSetRootElement(doc, root);
    if (!root->name) {
      xmlFreeDoc(doc);
      return __FAIL;
    }
    root->parent = (xmlNodePtr)doc;
    root->doc = doc;
    if ((extid || sysid)) {
      xmlDtdPtr dtd = xmlParseDTD(extid, sysid);
      if (!dtd) {
	xmlFreeDoc(doc);
	return __FAIL;
      }
      dtd->name = xmlStrdup(root->name); /* FIXME: do we need a qualid here? */
      doc->intSubset = dtd;
      if (doc->children == NULL)
	xmlAddChild((xmlNodePtr)doc, (xmlNodePtr)dtd);
      else
	xmlAddPrevSibling(doc->children, (xmlNodePtr)dtd);
    }
    doc->_private = mkobj(type(XMLDoc), doc);
    return doc->_private;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_load_file,argc,argv)
{
  char *s;
  unsigned long flags;
  if (argc == 2 && isstr(argv[0], &s) &&
      isuint(argv[1], &flags)) {
    unsigned oldflags = set_flags(flags);
    xmlDocPtr doc = xmlParseFile(s);
    set_flags(oldflags);
    if (doc) {
      doc->_private = mkobj(type(XMLDoc), doc);
      return doc->_private;
    } else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_load_string,argc,argv)
{
  char *s;
  unsigned long flags;
  if (argc == 2 && isstr(argv[0], &s) &&
      isuint(argv[1], &flags)) {
    unsigned oldflags = set_flags(flags);
    xmlDocPtr doc = xmlParseDoc(s);
    set_flags(oldflags);
    if (doc) {
      doc->_private = mkobj(type(XMLDoc), doc);
      return doc->_private;
    } else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_save_file,argc,argv)
{
  char *s, *enc = NULL;
  long compression = -1;
  xmlDocPtr doc;
  if (argc == 4 && isstr(argv[0], &s) &&
      isobj(argv[1], type(XMLDoc), (void**)&doc) &&
      xmlDocGetRootElement(doc) &&
      (isvoid(argv[2]) || isstr(argv[2], &enc)) &&
      (isvoid(argv[3]) || isint(argv[3], &compression))) {
    int save_compression = doc->compression, res,
      save_indent = xmlIndentTreeOutput;
    if (compression >= 0) doc->compression = compression;
    xmlIndentTreeOutput = 1;
    res = xmlSaveFormatFileEnc(s, doc, enc, 1);
    xmlIndentTreeOutput = save_indent;
    doc->compression = save_compression;
    if (res >= 0)
      return mkvoid;
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_save_string,argc,argv)
{
  xmlDocPtr doc;
  char *enc = NULL;
  if (argc == 2 && isobj(argv[0], type(XMLDoc), (void**)&doc) &&
      xmlDocGetRootElement(doc) &&
      (isvoid(argv[1]) || isstr(argv[1], &enc))) {
    xmlChar *s = NULL;
    int len, save_indent = xmlIndentTreeOutput;
    xmlIndentTreeOutput = 1;
    xmlDocDumpFormatMemoryEnc(doc, &s, &len, enc, 1);
    xmlIndentTreeOutput = save_indent;
    if (s)
      return mkstr(s);
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_doc_info,argc,argv)
{
  xmlDocPtr doc;
  if (argc == 1 && isobj(argv[0], type(XMLDoc), (void**)&doc))
    return mktuplel(5, mkstr2(doc->version), mkstr2(doc->encoding),
		    mkstr2(doc->URL), mkint(doc->compression),
		    mkbool(doc->standalone));
  else
    return __FAIL;
}

FUNCTION(xml,xml_int_subset,argc,argv)
{
  xmlDocPtr doc;
  if (argc == 1 && isobj(argv[0], type(XMLDoc), (void**)&doc) &&
      doc->intSubset)
    return mknode((xmlNodePtr)doc->intSubset);
  else
    return __FAIL;
}

FUNCTION(xml,xml_ext_subset,argc,argv)
{
  xmlDocPtr doc;
  if (argc == 1 && isobj(argv[0], type(XMLDoc), (void**)&doc) &&
      doc->extSubset)
    return mknode((xmlNodePtr)doc->extSubset);
  else
    return __FAIL;
}

FUNCTION(xml,xml_root,argc,argv)
{
  xmlDocPtr doc;
  if (argc == 1 && isobj(argv[0], type(XMLDoc), (void**)&doc)) {
    xmlNodePtr root = xmlDocGetRootElement(doc);
    if (!root)
      return __FAIL;
    else
      return mknode(root);
  } else
    return __FAIL;
}

FUNCTION(xml,xml_doc,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      supported(node)) {
    xmlDocPtr doc = node->doc;
    if (!doc || !doc->_private)
      return __FAIL;
    else
      return doc->_private;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_parent,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      supported(node)) {
    xmlNodePtr parent = node->parent;
    if (!parent)
      return __FAIL;
    else
      return mknode(parent);
  } else
    return __FAIL;
}

FUNCTION(xml,xml_first,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      supported(node) && node->type != XML_ENTITY_REF_NODE &&
      node->type != XML_ATTRIBUTE_NODE) {
    xmlNodePtr first = node->children;
    if (!first)
      return __FAIL;
    else
      return mknode(first);
  } else
    return __FAIL;
}

FUNCTION(xml,xml_last,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      supported(node) && node->type != XML_ENTITY_REF_NODE &&
      node->type != XML_ATTRIBUTE_NODE) {
    xmlNodePtr last = node->last;
    if (!last)
      return __FAIL;
    else
      return mknode(last);
  } else
    return __FAIL;
}

FUNCTION(xml,xml_next,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      supported(node)) {
    xmlNodePtr next = node->next;
    if (!next)
      return __FAIL;
    else
      return mknode(next);
  } else
    return __FAIL;
}

FUNCTION(xml,xml_prev,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      supported(node)) {
    xmlNodePtr prev = node->prev;
    if (!prev)
      return __FAIL;
    else
      return mknode(prev);
  } else
    return __FAIL;
}

FUNCTION(xml,xml_first_attr,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node)) {
    xmlAttrPtr attr = node->properties;
    if (attr)
      return mknode((xmlNodePtr)attr);
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_last_attr,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node)) {
    xmlAttrPtr attr = node->properties;
    if (attr) {
      while (attr->next)
	attr = attr->next;
      return mknode((xmlNodePtr)attr);
    } else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_select,argc,argv)
{
  xmlDocPtr doc;
  char *s;
  if (argc == 2 && isobj(argv[0], type(XMLDoc), (void**)&doc) &&
      isstr(argv[1], &s)) {
    int i;
    expr nodes;
    xmlXPathContextPtr context;
    xmlXPathObjectPtr result;
    xmlNodeSetPtr nodeset;
    context = xmlXPathNewContext(doc);
    if (!context) return __FAIL;
    result = xmlXPathEvalExpression(s, context);
    xmlXPathFreeContext(context);
    if (!result || !(nodeset = result->nodesetval)) return __FAIL;
    nodes = mknil;
    for (i = nodeset->nodeNr; nodes && --i >= 0;) {
      xmlNodePtr nodeptr = nodeset->nodeTab[i];
      expr node;
      if (!nodeptr)
	node = NULL;
      else
	node = mknode(nodeptr);
      nodes = mkcons(node, nodes);
    }
    xmlXPathFreeObject(result);
    return nodes;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_node_info,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      supported(node)) {
    switch (node->type) {
    case XML_ELEMENT_NODE: {
      expr name = mkstr2(nodename(node));
      expr namespaces, attrs = mknil, val;
      xmlNsPtr nsdef = node->nsDef;
      xmlAttrPtr attr = node->properties;
      if (nsdef) {
	xmlNsPtr ns;
	expr *xs;
	int n = 0;
	for (ns = nsdef; ns; ns = ns->next) n++;
	xs = malloc(n*sizeof(expr));
	if (!xs) return __ERROR;
	for (n = 0, ns = nsdef; ns; ns = ns->next)
	  xs[n++] = mktuplel(2, mkstr2(ns->prefix), mkstr2(ns->href));
	namespaces = mklistv(n, xs);
      } else
	namespaces = mknil;
      if (attr) {
	while (attr->next)
	  attr = attr->next;
	while (attrs && attr) {
	  char *s = attr->children->content;
	  val = mkstr2(s);
	  attrs = mkcons(mktuplel(2, mkstr2(attrname(attr)), val), attrs);
	  attr = attr->prev;
	}
      }
      return mkapp(mkapp(mkapp(mksym(sym_element), name), namespaces), attrs);
    }
    case XML_ATTRIBUTE_NODE: {
      expr name = mkstr2(nodename(node));
      expr val = mkstr2(node->children->content);
      return mkapp(mkapp(mksym(sym_attr), name), val);
    }
    case XML_ENTITY_REF_NODE: {
      expr name = mkstr2(nodename(node));
      return mkapp(mksym(sym_entity_ref), name);
    }
    case XML_TEXT_NODE: {
      expr content = mkstr2(node->content);
      return mkapp(mksym(sym_text), content);
    }
    case XML_CDATA_SECTION_NODE: {
      expr content = mkstr2(node->content);
      return mkapp(mksym(sym_cdata), content);
    }
    case XML_COMMENT_NODE: {
      expr content = mkstr2(node->content);
      return mkapp(mksym(sym_comment), content);
    }
    case XML_PI_NODE: {
      expr name = mkstr2(nodename(node));
      expr content = mkstr2(node->content);
      return mkapp(mkapp(mksym(sym_pi), name), content);
    }
    case XML_DTD_NODE: {
      xmlDtdPtr dtd = (xmlDtdPtr)node;
      expr name = mkstr2(dtd->name);
      expr extid = mkextid(dtd->ExternalID, dtd->SystemID);
      return mkapp(mkapp(mksym(sym_doctype), name), extid);
    }
    case XML_ELEMENT_DECL: {
      xmlElementPtr element = (xmlElementPtr)node;
      expr name = mkstr2(mkname(element->name, element->prefix));
      switch (element->etype) {
      case XML_ELEMENT_TYPE_UNDEFINED:
	return mkapp(mksym(sym_undefined_element), name);
      case XML_ELEMENT_TYPE_EMPTY:
	return mkapp(mksym(sym_empty_element), name);
      case XML_ELEMENT_TYPE_ANY:
	return mkapp(mksym(sym_any_element), name);
      case XML_ELEMENT_TYPE_ELEMENT:
	return mkapp(mkapp(mksym(sym_std_element), name),
		     mkcontent(element->content));
      case XML_ELEMENT_TYPE_MIXED:
	return mkapp(mkapp(mksym(sym_mixed_element), name),
		     mkcontent(element->content));
      default:
	return __FAIL;
      }
    }
    case XML_ATTRIBUTE_DECL: {
      xmlAttributePtr attr = (xmlAttributePtr)node;
      expr name = mkstr2(mkname(attr->name, attr->prefix));
      expr elem_name = mkstr2(attr->elem);
      expr dflt;
      switch (attr->def) {
      case XML_ATTRIBUTE_NONE:
	dflt = mkapp(mksym(sym_default), mkstr2(attr->defaultValue));
	break;
      case XML_ATTRIBUTE_REQUIRED:
	dflt = mksym(sym_required);
	break;
      case XML_ATTRIBUTE_IMPLIED:
	dflt = mksym(sym_implied);
	break;
      case XML_ATTRIBUTE_FIXED:
	dflt = mkapp(mksym(sym_fixed), mkstr2(attr->defaultValue));
	break;
      default:
	return __FAIL;
      }
      switch (attr->atype) {
      case XML_ATTRIBUTE_CDATA:
	return mkapp(mkapp(mkapp(mksym(sym_cdata_attr), elem_name), name),
		     dflt);
      case XML_ATTRIBUTE_ID:
	return mkapp(mkapp(mkapp(mksym(sym_id_attr), elem_name), name),
		     dflt);
      case XML_ATTRIBUTE_IDREF:
	return mkapp(mkapp(mkapp(mksym(sym_idref_attr), elem_name), name),
		     dflt);
      case XML_ATTRIBUTE_IDREFS:
	return mkapp(mkapp(mkapp(mksym(sym_idrefs_attr), elem_name), name),
		     dflt);
      case XML_ATTRIBUTE_ENTITY:
	return mkapp(mkapp(mkapp(mksym(sym_entity_attr), elem_name), name),
		     dflt);
      case XML_ATTRIBUTE_ENTITIES:
	return mkapp(mkapp(mkapp(mksym(sym_entities_attr), elem_name), name),
		     dflt);
      case XML_ATTRIBUTE_NMTOKEN:
	return mkapp(mkapp(mkapp(mksym(sym_nmtoken_attr), elem_name), name),
		     dflt);
      case XML_ATTRIBUTE_NMTOKENS:
	return mkapp(mkapp(mkapp(mksym(sym_nmtokens_attr), elem_name), name),
		     dflt);
      case XML_ATTRIBUTE_ENUMERATION:
	return mkapp(mkapp(mkapp(mkapp(mksym(sym_enum_attr), elem_name), name),
			   mkenum(attr->tree)), dflt);
      case XML_ATTRIBUTE_NOTATION:
	return mkapp(mkapp(mkapp(mkapp(mksym(sym_notation_attr), elem_name),
				 name),
			   mkenum(attr->tree)), dflt);
      default:
	return __FAIL;
      }
    }
    case XML_ENTITY_DECL: {
      xmlEntityPtr entity = (xmlEntityPtr)node;
      expr name = mkstr2(entity->name);
      expr content = mkstr2(entity->content);
      switch (entity->etype) {
      case XML_INTERNAL_GENERAL_ENTITY:
	return mkapp(mkapp(mksym(sym_int_entity), name), content);
      case XML_INTERNAL_PARAMETER_ENTITY:
	return mkapp(mkapp(mksym(sym_int_param_entity), name), content);
      case XML_EXTERNAL_GENERAL_PARSED_ENTITY: {
	expr extid = mkextid(entity->ExternalID, entity->SystemID);
	return mkapp(mkapp(mkapp(mksym(sym_ext_entity), name), extid), content);
      }
      case XML_EXTERNAL_GENERAL_UNPARSED_ENTITY: {
	expr extid = mkextid(entity->ExternalID, entity->SystemID);
	return mkapp(mkapp(mkapp(mksym(sym_ext_entity), name), extid), content);
      }
      case XML_EXTERNAL_PARAMETER_ENTITY: {
	expr extid = mkextid(entity->ExternalID, entity->SystemID);
	return mkapp(mkapp(mkapp(mksym(sym_ext_param_entity), name), extid),
		     content);
      }
      default:
	return __FAIL;
      }
    }
    default:
      return __FAIL;
    }
  } else {
#if 0
    printf("unrecognized node type %d\n", node->type);
#endif
    return __FAIL;
  }
}

FUNCTION(xml,xml_is_blank_node,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node))
    return mkbool(xmlIsBlankNode(node));
  else
    return __FAIL;
}

FUNCTION(xml,xml_node_base,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node) && node->doc) {
    char *s = xmlNodeGetBase(node->doc, node);
    if (s)
      return mkstr(s);
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_node_path,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node)) {
    char *s = xmlGetNodePath(node);
    if (s)
      return mkstr(s);
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_node_content,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node)) {
    char *s = xmlNodeGetContent(node);
    if (s)
      return mkstr(s);
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_node_attr,argc,argv)
{
  char *s;
  xmlNodePtr node;
  if (argc == 2 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      node->type == XML_ELEMENT_NODE &&
      isstr(argv[1], &s)) {
    const char *prefix, *name = splitname(s, &prefix);
    xmlNsPtr ns = mkns(node->doc, node->parent, node, prefix);
    char *t;
    if (prefix && !ns) return __FAIL;
    t = xmlGetNsProp(node, name, ns?ns->href:NULL);
    if (t)
      return mkstr(t);
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_set_node_attr,argc,argv)
{
  char *s, *t;
  xmlNodePtr node;
  if (argc == 3 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      node->type == XML_ELEMENT_NODE &&
      isstr(argv[1], &s) && isstr(argv[2], &t)) {
    const char *prefix, *name = splitname(s, &prefix);
    xmlNsPtr ns = mkns(node->doc, node->parent, node, prefix);
    if (prefix && !ns) return __FAIL;
    if (xmlSetNsProp(node, ns, name, t))
      return mkvoid;
    else
      return __FAIL;
  } else
    return __FAIL;
}

/* These are reimplemented here, because the library versions are buggy
   (missing updates of prev pointers), and we also need to take care of
   dangling references in attribute node objects. */

static int
myxmlUnsetProp(xmlNodePtr node, const xmlChar *name)
{
  xmlAttrPtr prop = node->properties, prev = NULL;

  if ((node == NULL) || (name == NULL))
    return(-1);
  while (prop != NULL) {
    if ((xmlStrEqual(prop->name, name)) &&
	(prop->ns == NULL)) {
      if (prop->next) prop->next->prev = prev;
      if (prev == NULL)
	node->properties = prop->next;
      else
	prev->next = prop->next;
      prop->prev = prop->next = NULL;
      prop->parent = NULL;
      freenode((xmlNodePtr)prop);
      return(0);
    }
    prev = prop;
    prop = prop->next;
  }
  return(-1);
}

static int
myxmlUnsetNsProp(xmlNodePtr node, xmlNsPtr ns, const xmlChar *name)
{
  xmlAttrPtr prop = node->properties, prev = NULL;

  if ((node == NULL) || (name == NULL))
    return(-1);
  if (ns == NULL)
    return(myxmlUnsetProp(node, name));
  if (ns->href == NULL)
    return(-1);
  while (prop != NULL) {
    if ((xmlStrEqual(prop->name, name)) &&
	(((prop->ns == NULL) && (node->ns != NULL) &&
	  (xmlStrEqual(node->ns->href, ns->href))) ||
	 ((prop->ns != NULL) && (xmlStrEqual(prop->ns->href, ns->href))))) {
      if (prop->next) prop->next->prev = prev;
      if (prev == NULL)
	node->properties = prop->next;
      else
	prev->next = prop->next;
      prop->prev = prop->next = NULL;
      prop->parent = NULL;
      freenode((xmlNodePtr)prop);
      return(0);
    }
    prev = prop;
    prop = prop->next;
  }
  return(-1);
}

FUNCTION(xml,xml_unset_node_attr,argc,argv)
{
  char *s;
  xmlNodePtr node;
  if (argc == 2 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      node->type == XML_ELEMENT_NODE &&
      isstr(argv[1], &s)) {
    const char *prefix, *name = splitname(s, &prefix);
    xmlNsPtr ns = mkns(node->doc, node->parent, node, prefix);
    if (prefix && !ns) return __FAIL;
    if (!myxmlUnsetNsProp(node, ns, name))
      return mkvoid;
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xml_replace,argc,argv)
{
  xmlNodePtr node, new_node;
  if (argc == 2 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      supported(node) && node->type != XML_ATTRIBUTE_NODE &&
      (new_node = parse_info(node->doc, node->parent, argv[1]))) {
    xmlReplaceNode(node, new_node);
    return mknode(new_node);
  } else
    return __FAIL;
}

FUNCTION(xml,xml_add_first,argc,argv)
{
  xmlNodePtr node, new_node;
  if (argc == 2 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      supported(node) && node->type != XML_ENTITY_REF_NODE &&
      node->type != XML_ATTRIBUTE_NODE &&
      (new_node = parse_info(node->doc, node, argv[1]))) {
    xmlNodePtr res, first = node->children;
    if (first)
      res = xmlAddPrevSibling(first, new_node);
    else
      res = xmlAddChild(node, new_node);
    if (res)
      return mknode(res);
    else {
      xmlFreeNode(new_node);
      return __FAIL;
    }
  } else
    return __FAIL;
}

FUNCTION(xml,xml_add_last,argc,argv)
{
  xmlNodePtr node, new_node;
  if (argc == 2 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      supported(node) && node->type != XML_ENTITY_REF_NODE &&
      node->type != XML_ATTRIBUTE_NODE &&
      (new_node = parse_info(node->doc, node, argv[1]))) {
    xmlNodePtr res, last = node->last;
    if (last)
      res = xmlAddNextSibling(last, new_node);
    else
      res = xmlAddChild(node, new_node);
    if (res)
      return mknode(res);
    else {
      xmlFreeNode(new_node);
      return __FAIL;
    }
  } else
    return __FAIL;
}

FUNCTION(xml,xml_add_next,argc,argv)
{
  xmlNodePtr node, new_node;
  if (argc == 2 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      supported(node) && node->type != XML_ATTRIBUTE_NODE &&
      (new_node = parse_info(node->doc, node->parent, argv[1]))) {
    xmlNodePtr res = xmlAddNextSibling(node, new_node);
    if (res)
      return mknode(res);
    else {
      xmlFreeNode(new_node);
      return __FAIL;
    }
  } else
    return __FAIL;
}

FUNCTION(xml,xml_add_prev,argc,argv)
{
  xmlNodePtr node, new_node;
  if (argc == 2 && isobj(argv[0], type(XMLNode), (void**)&node) &&
      supported(node) && node->type != XML_ATTRIBUTE_NODE &&
      (new_node = parse_info(node->doc, node->parent, argv[1]))) {
    xmlNodePtr res = xmlAddPrevSibling(node, new_node);
    if (res)
      return mknode(res);
    else {
      xmlFreeNode(new_node);
      return __FAIL;
    }
  } else
    return __FAIL;
}

FUNCTION(xml,xml_unlink,argc,argv)
{
  xmlNodePtr node;
  if (argc == 1 && isobj(argv[0], type(XMLNode), (void**)&node)) {
    xmlUnlinkNode(node);
    return mkvoid;
  } else
    return __FAIL;
}

/* XSLT interface *****************************************************************/

DESTRUCTOR(xml,XSLTStylesheet,ptr)
{
  xsltStylesheetPtr style = (xsltStylesheetPtr)ptr;
  xsltFreeStylesheet(style);
}

FUNCTION(xml,xslt_load_stylesheet,argc,argv)
{
  char *s = NULL;
  xmlDocPtr doc = NULL;
  if (argc == 1 &&
      (isstr(argv[0], &s) || isobj(argv[0], type(XMLDoc), (void**)&doc))) {
    int sub_flag = xmlSubstituteEntitiesDefault(1),
      load_flag = xmlLoadExtDtdDefaultValue;
    xsltStylesheetPtr style;
    xmlLoadExtDtdDefaultValue = 1;
    if (s)
      style = xsltParseStylesheetFile(s);
    else {
      doc = xmlCopyDoc(doc, 1);
      if (!doc) return __ERROR;
      style = xsltParseStylesheetDoc(doc);
      /* FIXME: do we need to free doc here?? */
    }
    xmlSubstituteEntitiesDefault(sub_flag);
    xmlLoadExtDtdDefaultValue = load_flag;
    if (style)
      return mkobj(type(XSLTStylesheet), style);
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xslt_apply_stylesheet,argc,argv)
{
  xsltStylesheetPtr style;
  xmlDocPtr doc;
  expr *xs, *ys;
  int i, j, k, n = 0, m;
  if (argc == 3 && isobj(argv[0], type(XSLTStylesheet), (void**)&style) &&
      isobj(argv[1], type(XMLDoc), (void**)&doc) &&
      (isvoid(argv[2]) || istuple(argv[2], &n, &xs))) {
    char *key, *val;
    const char **params;
    xmlDocPtr res;
    if (n == 2 && isstr(xs[0], &key) && isstr(xs[1], &val)) {
      /* singleton (KEY,VAL) pair */
      n = 1;
      params = malloc((2*n+1)*sizeof(char*));
      if (!params) return __ERROR;
      k = 0;
      params[k++] = key;
      params[k++] = val;
    } else {
      params = malloc((2*n+1)*sizeof(char*));
      if (!params) return __ERROR;
      for (i = k = 0; i < n; i++)
	if (istuple(xs[i], &m, &ys) && m==2 &&
	    isstr(ys[0], &key) && isstr(ys[1], &val)) {
	  params[k++] = key;
	  params[k++] = val;
	} else {
	  free(params);
	  return __FAIL;
	}
    }
    params[k++] = NULL;
    res = xsltApplyStylesheet(style, doc, params);
    free(params);
    if (res) {
      res->_private = mkobj(type(XMLDoc), res);
      return res->_private;
    } else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xslt_save_result_file,argc,argv)
{
  char *s;
  xmlDocPtr doc;
  xsltStylesheetPtr style;
  long n = 0;
  if (argc == 4 && isstr(argv[0], &s) &&
      isobj(argv[1], type(XMLDoc), (void**)&doc) &&
      isobj(argv[2], type(XSLTStylesheet), (void**)&style) &&
      (isvoid(argv[3]) || isint(argv[3], &n))) {
    int res;
    res = xsltSaveResultToFilename(s, doc, style, n);
    if (res >= 0)
      return mkvoid;
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(xml,xslt_save_result_string,argc,argv)
{
  xmlDocPtr doc;
  xsltStylesheetPtr style;
  if (argc == 2 && isobj(argv[0], type(XMLDoc), (void**)&doc) &&
      isobj(argv[1], type(XSLTStylesheet), (void**)&style)) {
#ifdef HAVE_XSLTSAVERESULTTOSTRING
    xmlChar *s = NULL;
    int len;
    xsltSaveResultToString(&s, &len, doc, style);
#else
#define BUFSZ 1024
    char *name = tmpnam(NULL);
    int res = xsltSaveResultToFilename(name, doc, style, 0);
    FILE *fp = fopen(name, "r");
    char *s, *t;
    int a;
    if (!fp) goto error;
    s = malloc(BUFSZ); t = s;
    a = BUFSZ;
    if (!s) goto error;
    *s = 0;
    while (fgets(t, BUFSZ, fp)) {
      /* try to enlarge the buffer: */
      int l = strlen(t), k = t-s+l;
      char *s1;
      if (s1 = (char*) realloc(s, a+BUFSZ)) {
	s = s1;
	t = s+k;
	a += BUFSZ;
      } else
	goto error;
    }
    if ((t = realloc(s, strlen(s)+1)))
      s = t;
    goto done;
  error:
    if (s) free(s);
    s = NULL;
  done:
    if (fp) fclose(fp);
    unlink(name);
#endif
    if (s)
      return mkstr(s);
    else
      return __FAIL;
  } else
    return __FAIL;
}