tclxslt.c   [plain text]


/*
 * tclxslt.c --
 *
 *  Interface to Gnome libxslt.
 *
 * Copyright (c) 2001-2002 Zveno Pty Ltd
 * http://www.zveno.com/
 *
 * Zveno Pty Ltd makes this software and associated documentation
 * available free of charge for any purpose.  You may make copies
 * of the software but you must include all of this notice on any copy.
 *
 * Zveno Pty Ltd does not warrant that this software is error free
 * or fit for any purpose.  Zveno Pty Ltd disclaims any liability for
 * all claims, expenses, losses, damages and costs any user may incur
 * as a result of using, copying or modifying the software.
 *
 * $Id: tclxslt.c,v 1.20 2002/11/29 23:29:24 rnurmi Exp $
 *
 */

#include "tclxslt.h"

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT

#ifdef __WIN32__
#     include "win/win32config.h"
#endif

/*
 * For Darwin (MacOS X) in particular, but also others
 */
 
#ifndef __WIN32__
#	define DLLIMPORT EXTERN
#endif

/*
 * Manage stylesheet objects
 */

typedef struct TclXSLT_Stylesheet {
  Tcl_Interp *interp;
  char *name;
  xsltStylesheetPtr stylesheet;

  Tcl_Obj *messagecommand;
} TclXSLT_Stylesheet;

static int ssheetCntr = 0;

/*
 * Extension management
 */

typedef struct TclXSLT_Extension {
  Tcl_Interp *interp;
  Tcl_Obj *nsuri;
  Tcl_Obj *tclns;
  xsltTransformContextPtr xformCtxt;
} TclXSLT_Extension;

Tcl_HashTable extensions;

/*
 * Prototypes for procedures defined later in this file:
 */

/*
 * Declarations for externally visible functions.
 */

EXTERN int      Xslt_Init _ANSI_ARGS_((Tcl_Interp *interp));

/*
 * Forward declarations for private functions.
 */

static void TclXSLTGenericError _ANSI_ARGS_((void *ctx, const char *msg, ...));

static int TclXSLTCompileCommand _ANSI_ARGS_((ClientData dummy,
						Tcl_Interp *interp,
						int objc,
						Tcl_Obj *CONST objv[]));
static int TclXSLTInstanceCommand _ANSI_ARGS_((ClientData ssheet,
						Tcl_Interp *interp,
						int objc,
						Tcl_Obj *CONST objv[]));
static void TclXSLTDeleteStylesheet _ANSI_ARGS_((ClientData ssheet));
static int TclXSLTExtensionCommand _ANSI_ARGS_((ClientData dummy,
						Tcl_Interp *interp,
						int objc,
						Tcl_Obj *CONST objv[]));

static int TclXSLTTransform _ANSI_ARGS_((TclXSLT_Stylesheet *stylesheet,
                                         Tcl_Obj *source,
                                         int paramc,
                                         Tcl_Obj *CONST paramv[]));

static void TclXSLT_RegisterAll _ANSI_ARGS_((TclXSLT_Extension *extinfo,
						const xmlChar *nsuri));

/* static xsltExtInitFunction TclXSLTExtInit; */
static void *TclXSLTExtInit _ANSI_ARGS_((xsltTransformContextPtr ctxt,
					const xmlChar *URI));
/* static xsltExtShutdownFunction TclXSLTExtShutdown; */
static void TclXSLTExtShutdown _ANSI_ARGS_((xsltTransformContextPtr ctxt,
					    const xmlChar *URI,
					    void *userdata));
/* static xmlXPathEvalFunc TclXSLTExtFunction; */
static void TclXSLTExtFunction _ANSI_ARGS_((xmlXPathParserContextPtr xpathCtxt,
					    int nargs));
/* static xsltPreComputeFunction TclXSLTExtElementPreComp; */
static void TclXSLTExtElementPreComp _ANSI_ARGS_((xsltStylesheetPtr style,
						  xmlNodePtr inst,
						  xsltTransformFunction function));
/* static xsltTransformFunction TclXSLTExtElementTransform; */
static void TclXSLTExtElementTransform _ANSI_ARGS_((xsltTransformContextPtr ctxt,
					            xmlNodePtr node,
					            xmlNodePtr inst,
					            xsltStylePreCompPtr comp));

static Tcl_Obj * TclXSLT_ConvertXPathObjToTclObj _ANSI_ARGS_((Tcl_Interp *interp,
                                                              xmlXPathObjectPtr xpobj));
static xmlXPathObjectPtr TclXSLT_ConvertTclObjToXPathObj _ANSI_ARGS_((Tcl_Interp *interp,
                                                              Tcl_Obj *objPtr));

/*
 * Error context for passing error result back to caller.
 */

typedef struct GenericError_Info {
  Tcl_Interp *interp;
  TclXSLT_Stylesheet *stylesheet;
  int code;
  Tcl_Obj *msg;
} GenericError_Info;

/*
 * Switch tables
 */

#ifndef CONST84
#define CONST84 /* Before 8.4 no 'const' required */
#endif

static CONST84 char *instanceCommandMethods[] = {
  "cget",
  "configure",
  "transform",
  (char *) NULL
};
enum instanceCommandMethods {
  TCLXSLT_CGET,
  TCLXSLT_CONFIGURE,
  TCLXSLT_TRANSFORM
};
static CONST84 char *instanceCommandOptions[] = {
  "-messagecommand",
  "-method",
  (char *) NULL
};
enum instanceCommandOptions {
  TCLXSLT_OPTION_MESSAGECOMMAND,
  TCLXSLT_OPTION_METHOD
};

static CONST84 char *extensionCommandMethods[] = {
  "add",
  "remove",
  (char *) NULL
};
enum extensionCommandMethods {
  TCLXSLT_EXT_ADD,
  TCLXSLT_EXT_REMOVE
};

/*
 * Debugging
 */

static Tcl_Channel stderrChan;
static char dbgbuf[200];

/*
static void DumpTclObj(objPtr)
    Tcl_Obj *objPtr;
{
  Tcl_Obj *elPtr;
  int idx, len;
  
  if (objPtr->typePtr == Tcl_GetObjType("list")) {
    Tcl_WriteChars(stderrChan, " list(", -1);
    Tcl_ListObjLength(NULL, objPtr, &len);
    for (idx = 0; idx < len; idx++) {
      Tcl_ListObjIndex(NULL, objPtr, idx, &elPtr);
      DumpTclObj(elPtr);
    }
    Tcl_WriteChars(stderrChan, ")", -1);
  } else if (objPtr->typePtr == Tcl_GetObjType("libxml2-node")) {
    xmlNodePtr nodePtr = (xmlNodePtr) objPtr->internalRep.otherValuePtr;
    sprintf(dbgbuf, " nodePtr x%x name \"%s\" value \"%s\"", nodePtr, nodePtr->name, xmlNodeGetContent(nodePtr));
    Tcl_WriteChars(stderrChan, dbgbuf, -1);
  } else {
    sprintf(dbgbuf, " obj x%x \"%s\"", objPtr, Tcl_GetStringFromObj(objPtr, NULL));
    Tcl_WriteChars(stderrChan, dbgbuf, -1);
  }
}

static void DumpTree(nodePtr)
    xmlNodePtr nodePtr;
{
  xmlNodePtr child;
          switch (nodePtr->type) {
      case XML_ELEMENT_NODE:
	sprintf(dbgbuf, "adding element \"%s\" x%x (%s)\n", nodePtr->name, nodePtr, XML_GET_CONTENT(nodePtr));
        Tcl_WriteChars(stderrChan, dbgbuf, -1);
        for (child = nodePtr->children; child != NULL; child = child->next) {
          DumpTree(child);
        }
	break;
      case XML_ATTRIBUTE_NODE:
	Tcl_WriteChars(stderrChan, "adding attribute\n", -1);
	break;
      case XML_TEXT_NODE:
      case XML_CDATA_SECTION_NODE:
	sprintf(dbgbuf, "adding textNode \"%s\" x%x\n", XML_GET_CONTENT(nodePtr), nodePtr);
        Tcl_WriteChars(stderrChan, dbgbuf, -1);
	break;
      case XML_ENTITY_REF_NODE:
	Tcl_WriteChars(stderrChan, "adding entityReference\n", -1);
	break;
      case XML_ENTITY_NODE:
	Tcl_WriteChars(stderrChan, "adding entity\n", -1);
	break;
      case XML_PI_NODE:
	Tcl_WriteChars(stderrChan, "adding processingInstruction\n", -1);
	break;
      case XML_COMMENT_NODE:
	Tcl_WriteChars(stderrChan, "adding comment\n", -1);
	break;
      case XML_DOCUMENT_NODE:
	Tcl_WriteChars(stderrChan, "adding document\n", -1);
	break;
      case XML_DOCUMENT_TYPE_NODE:
	Tcl_WriteChars(stderrChan, "adding docType\n", -1);
	break;
      case XML_DOCUMENT_FRAG_NODE:
	Tcl_WriteChars(stderrChan, "adding documentFragment\n", -1);
	break;
      case XML_NOTATION_NODE:
	Tcl_WriteChars(stderrChan, "adding notation\n", -1);
	break;
      case XML_HTML_DOCUMENT_NODE:
	Tcl_WriteChars(stderrChan, "adding HTMLdocument\n", -1);
	break;
      case XML_DTD_NODE:
	Tcl_WriteChars(stderrChan, "adding dtd\n", -1);
	break;
      case XML_ELEMENT_DECL:
	Tcl_WriteChars(stderrChan, "adding elementDecl\n", -1);
	break;
      case XML_ATTRIBUTE_DECL:
	Tcl_WriteChars(stderrChan, "adding attributeDecl\n", -1);
	break;
      case XML_ENTITY_DECL:
	Tcl_WriteChars(stderrChan, "adding entityDecl\n", -1);
	break;
      case XML_NAMESPACE_DECL:
	Tcl_WriteChars(stderrChan, "adding namespaceDecl\n", -1);
	break;
      case XML_XINCLUDE_START:
	Tcl_WriteChars(stderrChan, "adding xincludeStart\n", -1);
	break;
      case XML_XINCLUDE_END:
	Tcl_WriteChars(stderrChan, "adding xincludeEnd\n", -1);
	break;
      default:
	Tcl_WriteChars(stderrChan, "adding unknown\n", -1);
        }
}
*/

/*
 *----------------------------------------------------------------------------
 *
 * Xslt_Init --
 *
 *  Initialisation routine for loadable module
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  Creates commands in the interpreter,
 *
 *----------------------------------------------------------------------------
 */

int
Xslt_Init (interp)
     Tcl_Interp *interp;	/* Interpreter to initialise */
{
  int dbgMode;

#ifdef USE_TCL_STUBS
  if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
    return TCL_ERROR;
  }
#endif
#ifdef USE_TCLDOMXML_STUBS
  /* This is  "dom::libxml2"
   */
  if (Tcldomxml_InitStubs(interp, TCLDOMXML_VERSION, 1) == NULL) {
    return TCL_ERROR;
  }
#endif

  Tcl_CreateObjCommand(interp, "xslt::compile", TclXSLTCompileCommand, NULL, NULL);
  Tcl_CreateObjCommand(interp, "xslt::extension", TclXSLTExtensionCommand, NULL, NULL);

  Tcl_InitHashTable(&extensions, TCL_STRING_KEYS);

  exsltRegisterAll();

  stderrChan = Tcl_GetChannel(interp, "stderr", &dbgMode);

  Tcl_PkgProvide(interp, "xslt", TCLXSLT_VERSION);

  return TCL_OK;
}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLTCompileCommand --
 *
 *  Class creation command for xslt stylesheet objects.
 *
 * Results:
 *  Compiles the XSLT stylesheet.
 *  Creates a Tcl command associated with that stylesheet.
 *
 * Side effects:
 *  Memory allocated, stylesheet is compiled.
 *
 *----------------------------------------------------------------------------
 */

static int
TclXSLTCompileCommand(dummy, interp, objc, objv)
     ClientData dummy;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  TclXSLT_Stylesheet *info;
  xmlDocPtr origDoc, doc;
  xsltStylesheetPtr ssheetPtr = NULL;
  GenericError_Info *errorInfoPtr;

  if (objc != 2) {
    Tcl_WrongNumArgs(interp, 1, objv, "stylesheet-doc");
    return TCL_ERROR;
  }

  /* Copy the document object, since libxslt clobbers the _private field */
  if (TclDOM_GetDocFromObj(interp, objv[1], &origDoc) != TCL_OK) {
    return TCL_ERROR;
  }
  doc = xmlCopyDoc(origDoc, 1);
  /*
   * xmlCopyDoc doesn't copy some of the fields.
   */
  if (origDoc->URL) {
    doc->URL = Tcl_Alloc(strlen(origDoc->URL) + 1);
    strcpy((char *) doc->URL, origDoc->URL);
  }

  /*
   * Prepare for compiling stylesheet
   */

  errorInfoPtr = (GenericError_Info *) Tcl_Alloc(sizeof(GenericError_Info));
  errorInfoPtr->interp = interp;
  errorInfoPtr->stylesheet = NULL;
  errorInfoPtr->code = TCL_OK;
  errorInfoPtr->msg = NULL;

  /*
   * Compile stylesheet
   */

  if ((ssheetPtr = xsltParseStylesheetDoc(doc)) == NULL) {
    Tcl_SetResult(interp, "error compiling stylesheet", NULL);
    goto error;
  }

  if (ssheetPtr->errors > 0) {
    Tcl_SetResult(interp, "error compiling XSLT stylesheet", NULL);
    goto error;
  }

  if (errorInfoPtr->code != TCL_OK) {

    if (errorInfoPtr->msg) {
      Tcl_SetObjResult(interp, errorInfoPtr->msg);
    }

    goto error;
  }

  info = (TclXSLT_Stylesheet *) Tcl_Alloc(sizeof(TclXSLT_Stylesheet));
  info->interp = interp;
  info->name = Tcl_Alloc(20);
  sprintf(info->name, "style%d", ssheetCntr++);
  info->stylesheet = ssheetPtr;
  info->messagecommand = NULL;

  Tcl_CreateObjCommand(interp, info->name, TclXSLTInstanceCommand, (ClientData) info, TclXSLTDeleteStylesheet);

  Tcl_SetObjResult(interp, Tcl_NewStringObj(info->name, -1));

  return TCL_OK;

error:

  if (errorInfoPtr->msg) {
    Tcl_DecrRefCount(errorInfoPtr->msg);
  }
  Tcl_Free((char *) errorInfoPtr);

  if (ssheetPtr) {
    xsltFreeStylesheet(ssheetPtr);
  } else {
    xmlFreeDoc(doc);
  }
  
  return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLTDeleteStylesheet --
 *
 *  Class destruction command for xslt stylesheet objects.
 *
 * Results:
 *  Frees memory associated with a stylesheet.
 *
 * Side effects:
 *  Memory deallocated.
 *
 *----------------------------------------------------------------------------
 */

static void
TclXSLTDeleteStylesheet(clientData)
     ClientData clientData;
{
  TclXSLT_Stylesheet *ssheet = (TclXSLT_Stylesheet *) clientData;
  
  Tcl_Free(ssheet->name);
  if (ssheet->messagecommand) {
    Tcl_DecrRefCount(ssheet->messagecommand);
  }
  xsltFreeStylesheet(ssheet->stylesheet); /* Also frees document */
  Tcl_Free((char *) ssheet);
}
/*
 *----------------------------------------------------------------------------
 *
 * TclXSLTInstanceCommand --
 *
 *  Handles the stylesheet object command.
 *
 * Results:
 *  Depends on method.
 *
 * Side effects:
 *  Depends on method.
 *
 *----------------------------------------------------------------------------
 */

static int
TclXSLTInstanceCommand(clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  TclXSLT_Stylesheet *ssheet = (TclXSLT_Stylesheet *) clientData;
  int method, option;

  if (objc < 3) {
    Tcl_WrongNumArgs(interp, 1, objv, "method ?args ...?");
    return TCL_ERROR;
  }

  if (Tcl_GetIndexFromObj(interp, objv[1], instanceCommandMethods, 
			    "method", 0, &method) != TCL_OK) {
    return TCL_ERROR;
  }

  switch ((enum instanceCommandMethods) method) {
  case TCLXSLT_CGET:

    if (objc != 3) {
      Tcl_WrongNumArgs(interp, 2, objv, "option");
      return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[2], instanceCommandOptions, 
			    "option", 0, &option) != TCL_OK) {
      return TCL_ERROR;
    }

    switch ((enum instanceCommandOptions) option) {

    case TCLXSLT_OPTION_METHOD:
      if (ssheet->stylesheet->method != NULL) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(ssheet->stylesheet->method, -1));
      }
      break;

    case TCLXSLT_OPTION_MESSAGECOMMAND:
      if (ssheet->messagecommand != NULL) {
        Tcl_SetObjResult(interp, ssheet->messagecommand);
      }
      break;

    default:
      Tcl_SetResult(interp, "unknown option", NULL);
      return TCL_ERROR;
    }

    break;

  case TCLXSLT_CONFIGURE:
    
    if (objc != 4) {
      Tcl_WrongNumArgs(interp, 2, objv, "option value");
      return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[2], instanceCommandOptions, 
			    "option", 0, &option) != TCL_OK) {
      return TCL_ERROR;
    }

    switch ((enum instanceCommandOptions) option) {

    case TCLXSLT_OPTION_METHOD:
      Tcl_SetResult(interp, "read-only option", NULL);
      return TCL_ERROR;
      break;

    case TCLXSLT_OPTION_MESSAGECOMMAND:
      if (ssheet->messagecommand != NULL) {
        Tcl_DecrRefCount(ssheet->messagecommand);
      }
      ssheet->messagecommand = objv[3];
      Tcl_IncrRefCount(ssheet->messagecommand);
      break;

    default:
      Tcl_SetResult(interp, "unknown option", NULL);
      return TCL_ERROR;
    }

    break;

  case TCLXSLT_TRANSFORM:
    if (objc < 3) {
      Tcl_WrongNumArgs(interp, 2, objv, "source ?param value...?");
      return TCL_ERROR;
    }

    return TclXSLTTransform(ssheet, objv[2], objc - 3, &objv[3]);

    break;

  default:
    Tcl_SetResult(interp, "unknown method", NULL);
    return TCL_OK;
  }

  return TCL_OK;
}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLTTransform --
 *
 *  Performs an XSL transformation.
 *
 * Results:
 *  Result document created.
 *
 * Side effects:
 *  Memory allocated for result document.
 *
 *----------------------------------------------------------------------------
 */

static int
TclXSLTTransform(stylesheet, source, paramc, paramv)
    TclXSLT_Stylesheet *stylesheet;
    Tcl_Obj *source;
    int paramc;
    Tcl_Obj *CONST paramv[];
{
  xmlDocPtr doc, result;
  char **params = NULL;
  int nbparams = 0, i;
  GenericError_Info *errorInfoPtr;
  void *oldErrorCtx;
  xmlGenericErrorFunc old_xsltGenericError;

  errorInfoPtr = (GenericError_Info *) Tcl_Alloc(sizeof(GenericError_Info));
  errorInfoPtr->interp = stylesheet->interp;
  errorInfoPtr->stylesheet = stylesheet;
  errorInfoPtr->code = TCL_OK;
  errorInfoPtr->msg = NULL;

  if (TclDOM_GetDocFromObj(stylesheet->interp, source, &doc) != TCL_OK) {
    goto error;
  }

  params = (char **) Tcl_Alloc(sizeof(char **) * (paramc + 1));
  for (i = 0; i < paramc; i++) {
    params[nbparams++] = Tcl_GetStringFromObj(paramv[i++], NULL);
    params[nbparams++] = Tcl_GetStringFromObj(paramv[i], NULL);
  }
  params[nbparams] = NULL;

  /*
   * Perform the transformation
   */

  /*
   * Save the previous error context so that it can
   * be restored upon completion of the transformation.
   * This is necessary because transformations may occur
   * recursively (usually due to extensions).
   */
  old_xsltGenericError = xsltGenericError;
  oldErrorCtx = xsltGenericErrorContext;

  xsltSetGenericErrorFunc((void *) errorInfoPtr, TclXSLTGenericError);

  result = xsltApplyStylesheet(stylesheet->stylesheet, doc, (const char **)params);

  xsltSetGenericErrorFunc((void *) oldErrorCtx, old_xsltGenericError);

  if (result == NULL) {
    Tcl_Obj *resultPtr = Tcl_NewStringObj("no result document", -1);

    if (errorInfoPtr->msg) {
      Tcl_AppendToObj(resultPtr, ":\n", -1);
      Tcl_AppendObjToObj(resultPtr, errorInfoPtr->msg);
    }

    Tcl_SetObjResult(stylesheet->interp, resultPtr);
    goto error;
  }

  if (errorInfoPtr->code != TCL_OK && errorInfoPtr->msg && stylesheet->messagecommand) {

    /* We have produced a result, but there may possibly
     * have been errors.  Trouble is, there might also
     * have been some completely innocent messages.
     * -messageCommand is the only way to find out about these.
     */

    Tcl_Obj *cmdPtr = Tcl_DuplicateObj(stylesheet->messagecommand);
    if (Tcl_ListObjAppendElement(stylesheet->interp, cmdPtr, errorInfoPtr->msg) != TCL_OK) {
      goto error;
    }
    if (Tcl_GlobalEvalObj(stylesheet->interp, cmdPtr) != TCL_OK) {
      goto error;
    }

  }

  Tcl_SetObjResult(stylesheet->interp, TclDOM_CreateObjFromDoc(result));

  if (errorInfoPtr->msg) {
    Tcl_DecrRefCount(errorInfoPtr->msg);
  }
  Tcl_Free((char *) errorInfoPtr);
  Tcl_Free(params);

  return TCL_OK;

 error:

  if (errorInfoPtr->msg) {
    Tcl_DecrRefCount(errorInfoPtr->msg);
  }
  if (params) {
    Tcl_Free(params);
  }
  Tcl_Free((char *) errorInfoPtr);

  return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLTGenericError --
 *
 *  Handler for stylesheet errors.
 *
 *  NB. Cannot distinguish between errors and use of xsl:message element.
 *
 * Results:
 *  Stores error message.
 *
 * Side effects:
 *  Transform will return error condition.
 *
 *----------------------------------------------------------------------------
 */

static void
TclXSLTGenericError (void *ctx, const char *msg, ...)
{
  va_list args;
  char buf[2048];
  int len;
  GenericError_Info *errorInfoPtr = (GenericError_Info *) ctx;

  if (ctx < (void *) 0x1000) {
    fprintf(stderr, "TclXSLT: bad context\n");
    va_start(args,msg);
    vfprintf(stderr, msg, args);
    va_end(args);
    return;
  }

  va_start(args,msg);
  len = vsnprintf(buf, 2047, msg, args);
  va_end(args);

  if (!errorInfoPtr->interp) {
    sprintf(dbgbuf, "TclXSLTGenericError: NULL interp, msg \"%s\"\n", buf);
    return;
  }

  if (errorInfoPtr->stylesheet->messagecommand) {

    Tcl_Obj *cmdPtr = Tcl_DuplicateObj(errorInfoPtr->stylesheet->messagecommand);
    if (Tcl_ListObjAppendElement(errorInfoPtr->interp, cmdPtr, Tcl_NewStringObj(buf, len)) != TCL_OK) {
      Tcl_BackgroundError(errorInfoPtr->interp);
      return;
    }
    if (Tcl_GlobalEvalObj(errorInfoPtr->interp, cmdPtr) != TCL_OK) {
      Tcl_BackgroundError(errorInfoPtr->interp);
      return;
    }

  } else {

    if (!errorInfoPtr->msg) {
      errorInfoPtr->msg = Tcl_NewObj();
      Tcl_IncrRefCount(errorInfoPtr->msg);
    }

    errorInfoPtr->code = TCL_ERROR;

    Tcl_AppendToObj(errorInfoPtr->msg, buf, len);

  }
}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLTExtensionCommand --
 *
 *  Command for xslt::extension command.
 *
 * Results:
 *  Depends on method.
 *
 * Side effects:
 *  Depends on method
 *
 *----------------------------------------------------------------------------
 */

static int
TclXSLTExtensionCommand(dummy, interp, objc, objv)
     ClientData dummy;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  int method, new;
  TclXSLT_Extension *extinfo;
  Tcl_HashEntry *entry;

  if (objc < 2) {
    Tcl_WrongNumArgs(interp, 1, objv, "method ?args ...?");
    return TCL_ERROR;
  }

  if (Tcl_GetIndexFromObj(interp, objv[1], extensionCommandMethods,
			  "method", 0, &method) != TCL_OK) {
    return TCL_ERROR;
  }

  switch ((enum extensionCommandMethods) method) {

  case TCLXSLT_EXT_ADD:
    if (objc != 4) {
      Tcl_WrongNumArgs(interp, 2, objv, "nsuri tcl-namespace");
      return TCL_ERROR;
    }

    if (xsltRegisterExtModule(Tcl_GetStringFromObj(objv[2], NULL),
			      TclXSLTExtInit,
			      TclXSLTExtShutdown)) {
      Tcl_SetResult(interp, "cannot register extension module", NULL);
    }

    extinfo = (TclXSLT_Extension *) Tcl_Alloc(sizeof(TclXSLT_Extension));
    extinfo->interp = interp;
    extinfo->nsuri = objv[2];
    Tcl_IncrRefCount(objv[2]);
    extinfo->tclns = objv[3];
    Tcl_IncrRefCount(objv[3]);

    extinfo->xformCtxt = NULL;

    entry = Tcl_CreateHashEntry(&extensions, Tcl_GetStringFromObj(objv[2], NULL), &new);

    if (!new) {
      Tcl_SetResult(interp, "extension already exists", NULL);
      Tcl_Free((char *) extinfo);
      return TCL_ERROR;
    }

    Tcl_SetHashValue(entry, extinfo);

    TclXSLT_RegisterAll(extinfo, (const xmlChar *) Tcl_GetStringFromObj(objv[2], NULL));

    Tcl_ResetResult(interp);

    break;

  case TCLXSLT_EXT_REMOVE:
    if (objc != 3) {
      Tcl_WrongNumArgs(interp, 2, objv, "nsuri");
      return TCL_ERROR;
    }

    /*
     * TODO: Remove previously registered elements and functions.
    */

    entry = Tcl_FindHashEntry(&extensions, Tcl_GetStringFromObj(objv[2], NULL));
    if (entry == NULL) {
      Tcl_SetResult(interp, "unknown XML Namespace URI", NULL);
      return TCL_ERROR;
    }

    extinfo = (TclXSLT_Extension *) Tcl_GetHashValue(entry);
    Tcl_DecrRefCount(extinfo->nsuri);
    Tcl_DecrRefCount(extinfo->tclns);
    Tcl_Free((char *) extinfo);

    Tcl_DeleteHashEntry(entry);

    break;

  default:
    Tcl_SetResult(interp, "unknown method", NULL);
    return TCL_ERROR;
  }

  return TCL_OK;
}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLTExtInit --
 *
 *  Load extensions into a transformation context.
 *
 * Results:
 *  Returns pointer to extension data.
 *  Elements and functions are pre-registered.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------------
 */

static void *
TclXSLTExtInit(ctxt, URI)
     xsltTransformContextPtr ctxt;
     const xmlChar *URI;
{
  Tcl_HashEntry *entry;
  TclXSLT_Extension *extinfo;

  entry = Tcl_FindHashEntry(&extensions, URI);
  if (entry == NULL) {
    /* Extension module was removed */
    return NULL;
  }

  extinfo = (TclXSLT_Extension *) Tcl_GetHashValue(entry);
  extinfo->xformCtxt = ctxt;

  return (void *) extinfo;
}

void
TclXSLT_RegisterAll(extinfo, nsuri)
    TclXSLT_Extension *extinfo;
    const xmlChar *nsuri;
{
  Tcl_Obj *cmdPtr, *objPtr;
  Tcl_Obj **reg;
  int ret, i, len;

  /*
   * Q: How to distinguish between extension elements and functions?
   * A: Use the formal parameters.  If the command can accept
   * a variable argument list, then it is registered as a function.
   * Otherwise it will be registered as an extension (and expected
   * to accept certain arguments).
   */

  cmdPtr = Tcl_NewStringObj("::xslt::getprocs ", -1);
  Tcl_IncrRefCount(cmdPtr);
  Tcl_AppendObjToObj(cmdPtr, extinfo->tclns);
  ret = Tcl_EvalObjEx(extinfo->interp, cmdPtr, TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT);
  objPtr = Tcl_GetObjResult(extinfo->interp);
  Tcl_IncrRefCount(objPtr);
  Tcl_DecrRefCount(cmdPtr);

  if (ret != TCL_OK || objPtr == NULL) {
    /*
     * Something went wrong, therefore nothing to register.
     */
    return;
  }

  ret = Tcl_ListObjGetElements(extinfo->interp, objPtr, &len, &reg);
  if (ret != TCL_OK || len != 2) {
    /*
     * Something went wrong, therefore nothing to register.
     */
    return;
  }

  /*
   * reg[0] contains extension elements
   * reg[1] contains extension functions
   */

  /*
   * First register the extension elements.
   */

  ret = Tcl_ListObjLength(extinfo->interp, reg[0], &len);
  if (ret == TCL_OK && len > 0) {
    for (i = 0; i < len; i++) {

      if (Tcl_ListObjIndex(extinfo->interp, reg[0], i, &objPtr) != TCL_OK) {
        continue;
      }

      xsltRegisterExtModuleElement((const xmlChar *) Tcl_GetStringFromObj(objPtr, NULL),
                             nsuri,
                             (xsltPreComputeFunction) TclXSLTExtElementPreComp,
                             (xsltTransformFunction) TclXSLTExtElementTransform);
    }
  }

  /*
   * Now register the extension functions.
   */

  ret = Tcl_ListObjLength(extinfo->interp, reg[1], &len);
  if (ret != TCL_OK || len == 0) {
    return;
  }

  for (i = 0; i < len; i++) {

    if (Tcl_ListObjIndex(extinfo->interp, reg[1], i, &objPtr) != TCL_OK) {
      continue;
    }

    xsltRegisterExtModuleFunction((const xmlChar *) Tcl_GetStringFromObj(objPtr, NULL),
    	nsuri,
    	TclXSLTExtFunction);
  }

  Tcl_DecrRefCount(objPtr);

  return;
}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLTExtElementPreComp --
 *
 *  Compilation step for extension element.
 *
 * Results:
 *  Not currently used.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------------
 */

static void 
TclXSLTExtElementPreComp(style, inst, function)
    xsltStylesheetPtr style;
    xmlNodePtr inst;
    xsltTransformFunction function;
{
  return;
}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLTExtElementTransform --
 *
 *  Implements extension element.
 *
 * Results:
 *  Returns string returned by Tcl command evaluation.
 *
 * Side effects:
 *  Depends on Tcl command evaluated.
 *
 *----------------------------------------------------------------------------
 */

static void 
TclXSLTExtElementTransform(ctxt, node, inst, comp)
    xsltTransformContextPtr ctxt; /* unused */
    xmlNodePtr node;
    xmlNodePtr inst;
    xsltStylePreCompPtr comp; /* unused */
{
  TclXSLT_Extension *extinfo;
  Tcl_HashEntry *entry;
  Tcl_Obj *cmdPtr;
  int ret;

  if (inst == NULL) {
    return;
  }

  entry = Tcl_FindHashEntry(&extensions, inst->ns->href);
  if (entry == NULL) {
    /*
     * Cannot find extension module.
     * Must have been removed.
     */
    return;
  }

  extinfo = (TclXSLT_Extension *) Tcl_GetHashValue(entry);

  /*
   * Start constructing the script by first defining the command.
   */

  cmdPtr = Tcl_DuplicateObj(extinfo->tclns);
  Tcl_AppendStringsToObj(cmdPtr, "::", inst->name, NULL);

  if (Tcl_ListObjAppendElement(extinfo->interp, cmdPtr, TclDOM_CreateObjFromNode(node)) != TCL_OK) {
    Tcl_DecrRefCount(cmdPtr);
    return;
  }

  /*
   * Converting the stylesheet node to a TclDOM node may clobber the
   * _private pointer.  It would be nice to find the equivalent node
   * in the original DOM tree, but it may not even exist anymore :-(
   *
   * TODO: make extension elements more effective, and allow
   * pre-computation.
   */

  /*
   * Now evaluate the complete command.
   * Can't propagqte a return error result to
   * XSLT, so flag background error instead.
   */
  ret = Tcl_EvalObjEx(extinfo->interp, cmdPtr, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
  if (ret != TCL_OK) {
    Tcl_BackgroundError(extinfo->interp);
  }
}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLTExtFunction --
 *
 *  Handles evaluation of an extension function.
 *
 * Results:
 *  Returns string returned by Tcl command evaluation.
 *
 * Side effects:
 *  Depends on Tcl command evaluated.
 *
 *----------------------------------------------------------------------------
 */

static void 
TclXSLTExtFunction(xpathCtxt, nargs)
     xmlXPathParserContextPtr xpathCtxt;
     int nargs;
{
  xsltTransformContextPtr xformCtxt;
  TclXSLT_Extension *extinfo;
  Tcl_Obj *cmdPtr, *resultPtr;
  xmlXPathObjectPtr obj;
  int ret, len;

  xformCtxt = xsltXPathGetTransformContext(xpathCtxt);

  /*
   * In order to find the instance data we need the
   * XML Namespace URI of this function.
   */

  extinfo = (TclXSLT_Extension *) xsltGetExtData(xformCtxt,
						 xpathCtxt->context->functionURI);

  /*
   * Start constructing the script by first defining the command.
   */

  cmdPtr = Tcl_DuplicateObj(extinfo->tclns);
  Tcl_IncrRefCount(cmdPtr);
  Tcl_AppendStringsToObj(cmdPtr, "::", xpathCtxt->context->function, NULL);

  /*
   * Each argument on the stack is converted to a Tcl_Obj
   * of an appropriate type and passed as an argument to the Tcl command.
   */

  while (nargs) {
    Tcl_Obj *objv[2];

    obj = (xmlXPathObjectPtr) valuePop(xpathCtxt);
    if (obj == NULL) {
      xmlXPathSetError(xpathCtxt, XPATH_INVALID_OPERAND);
      Tcl_DecrRefCount(cmdPtr);
      return;
    }

    objv[0] = TclXSLT_ConvertXPathObjToTclObj(extinfo->interp, obj);
    objv[1] = NULL;
    if (Tcl_ListObjReplace(extinfo->interp, cmdPtr, 1, 0, 1, objv) != TCL_OK) {
      Tcl_BackgroundError(extinfo->interp);
      Tcl_DecrRefCount(objv[0]);
      Tcl_DecrRefCount(cmdPtr);
      return;
    }

    /* When should this XPath object be freed?
     * Immediately before returning from the function call?
     * What if the application retains a pointer to it?
     * If the application destroys the contents, then memory
     * will leak because the XPath object is not freed.
     *
     * TODO: take a copy of the object's content and pass that
     * to the application callback.  That would allow this object
     * to be freed and allow the application to manage the copy.
     
     xmlXPathFreeObject(obj);
     */

    nargs--;
  }

  ret = Tcl_EvalObjEx(extinfo->interp, cmdPtr, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
  resultPtr = Tcl_GetObjResult(extinfo->interp);
  Tcl_DecrRefCount(cmdPtr);
  Tcl_IncrRefCount(resultPtr);

  if (ret == TCL_OK) {
    obj = TclXSLT_ConvertTclObjToXPathObj(extinfo->interp, resultPtr);
    valuePush(xpathCtxt, obj);
  } else {
    xmlGenericError(xmlGenericErrorContext,
		    Tcl_GetStringFromObj(resultPtr, NULL));
    /* Need to define a new error code - this is the closest in meaning */
    xpathCtxt->error = XPATH_UNKNOWN_FUNC_ERROR;
  }

  Tcl_DecrRefCount(resultPtr);

}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLT_ConvertTclObjToXPathObj --
 *
 *  Convert a Tcl Object to an XPath object.
 *  Data type is preserved, with nodesets being
 *  mapped from a list of nodes.
 *
 * Results:
 *  XPath Object.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------------
 */

static xmlXPathObjectPtr
TclXSLT_ConvertTclObjToXPathObj(interp, objPtr)
     Tcl_Interp *interp;
     Tcl_Obj *objPtr;
{
  xmlNodePtr nodePtr;
  xmlDocPtr docPtr;

  if (TclDOM_GetNodeFromObj(interp, objPtr, &nodePtr) == TCL_OK) {
    return xmlXPathNewNodeSet(nodePtr);
  }
  
  /*
   * BUG: This is corrupting objPtr for some unknown reason.
   */
   if (TclDOM_GetDocFromObj(interp, objPtr, &docPtr) == TCL_OK) {
    return xmlXPathNewNodeSet((xmlNodePtr) docPtr);

  }
  
  if (objPtr->typePtr == Tcl_GetObjType("int") ||
      objPtr->typePtr == Tcl_GetObjType("double")) {
    double number;

    if (Tcl_GetDoubleFromObj(interp, objPtr, &number) == TCL_OK) {
      return xmlXPathNewFloat(number);
    } else {
      return NULL;
    }
  } else if (objPtr->typePtr == Tcl_GetObjType("boolean")) {
    int bool;

    if (Tcl_GetBooleanFromObj(interp, objPtr, &bool) == TCL_OK) {
      return xmlXPathNewBoolean(bool);
    } else {
      return NULL;
    }
  } else if (objPtr->typePtr == Tcl_GetObjType("list")) {
    /*
     * If each of the elements can be converted to a node,
     * then return a nodeset.
     */

    int i, len;
    Tcl_Obj **listPtr;
    xmlNodeSetPtr nset;

    Tcl_ListObjGetElements(interp, objPtr, &len, &listPtr);
    if (len == 0) {
      return xmlXPathNewNodeSet(NULL);
    }

    /*
     * First pass: check that the elements are all nodes.
     */
    for (i = 0; i < len; i++) {
      if (TclDOM_GetDocFromObj(interp, listPtr[i], &docPtr) == TCL_OK) {
        continue;
      }
      if (TclDOM_GetNodeFromObj(interp, listPtr[i], &nodePtr) != TCL_OK) {
        return xmlXPathNewString(Tcl_GetStringFromObj(objPtr, NULL));
      }
    }
    /*
     * Now go ahead and create the nodeset (we already did the hard
     * work to create internal reps in pass 1).
     */
    if (TclDOM_GetDocFromObj(interp, listPtr[0], &docPtr) == TCL_OK) {
      nset = xmlXPathNodeSetCreate((xmlNodePtr) docPtr);
    } else {
      TclDOM_GetNodeFromObj(interp, listPtr[0], &nodePtr);
      nset = xmlXPathNodeSetCreate(nodePtr);
    }
    for (i = 1; i < len; i++) {
      if (TclDOM_GetDocFromObj(interp, listPtr[i], &docPtr) == TCL_OK) {
        xmlXPathNodeSetAdd(nset, (xmlNodePtr) docPtr);
      } else {
        TclDOM_GetNodeFromObj(interp, listPtr[i], &nodePtr);
        xmlXPathNodeSetAdd(nset, nodePtr);
      }
    }
    return xmlXPathWrapNodeSet(nset);

  } else {
    return xmlXPathNewString(Tcl_GetStringFromObj(objPtr, NULL));
  }
}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLT_ConvertXPathObjToTclObj --
 *
 *  Convert an XPath object to a Tcl Object.
 *  Data type is preserved, with nodesets being
 *  mapped to a list of nodes.
 *
 * Results:
 *  Tcl Object.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------------
 */

static Tcl_Obj *
TclXSLT_ConvertXPathObjToTclObj(interp, xpobj)
     Tcl_Interp *interp;
     xmlXPathObjectPtr xpobj;
{
  Tcl_Obj *objPtr;
  int i;

  switch (xpobj->type) {
    case XPATH_XSLT_TREE:
    case XPATH_NODESET:

      objPtr = Tcl_NewListObj(0, NULL);
      for (i = 0; i < xpobj->nodesetval->nodeNr; i++) {
        Tcl_Obj *nodeObjPtr;
        nodeObjPtr = TclDOM_CreateObjFromNode(xpobj->nodesetval->nodeTab[i]);
        Tcl_ListObjAppendElement(interp, objPtr, nodeObjPtr);
      }

      break;

    case XPATH_BOOLEAN:
      objPtr = Tcl_NewBooleanObj(xpobj->boolval);
      break;
      
    case XPATH_NUMBER:
      objPtr = Tcl_NewDoubleObj(xpobj->floatval);
      break;

    case XPATH_STRING:
    case XPATH_UNDEFINED:
    case XPATH_POINT:
    case XPATH_RANGE:
    case XPATH_LOCATIONSET:
    case XPATH_USERS:
    default:
      objPtr = Tcl_NewStringObj(xmlXPathCastToString(xpobj), -1);

      break;
  }

  return objPtr;
}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLTExtShutdown --
 *
 *  Clean up.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------------
 */

static void
TclXSLTExtShutdown(ctxt, URI, userdata)
     xsltTransformContextPtr ctxt;
     const xmlChar *URI;
     void *userdata;
{
  /* Nothing to do */
}