Logo Search packages:      
Sourcecode: tclxml version File versions  Download package

tclxslt-libxslt.c

/*
 * tclxslt.c --
 *
 *  Interface to Gnome libxslt.
 *
 * Copyright (c) 2005-2007 Explain
 * http://www.explain.com.au/
 * Copyright (c) 2001-2004 Zveno Pty Ltd
 * http://www.zveno.com/
 *
 * See the file "LICENSE" for information on usage and
 * redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * $Id: tclxslt.c,v 1.30.2.2 2005/12/30 02:40:41 balls Exp $
 *
 */

#include <tclxslt/tclxslt.h>
#include <string.h>
#include <libxslt/imports.h>
#include <libxslt/security.h>

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT

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

/*
 * Manage stylesheet objects
 */

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

  Tcl_Obj *resulturi;
  Tcl_Obj *profilechannelObj;

  Tcl_Obj *messagecommand;
} TclXSLT_Stylesheet;

/*
 * Extension management
 */

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

typedef struct ThreadSpecificData {
  int initialised;
  Tcl_Interp *interp;
  int ssheetCntr;
  Tcl_HashTable *stylesheets;
  Tcl_HashTable *extensions;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

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

/*
 * 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 Tcl_Obj * GetParameters _ANSI_ARGS_((Tcl_Interp *interp,
                                  xsltStylesheetPtr stylesheet));
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 xsltSecurityCheck TclXSLTSecurityReadFile; */
static int TclXSLTSecurityReadFile _ANSI_ARGS_((xsltSecurityPrefsPtr sec,
                                    xsltTransformContextPtr ctxt,
                                    const char *value));
/* static xsltSecurityCheck TclXSLTSecurityWriteFile; */
static int TclXSLTSecurityWriteFile _ANSI_ARGS_((xsltSecurityPrefsPtr sec,
                                     xsltTransformContextPtr ctxt,
                                     const char *value));
/* static xsltSecurityCheck TclXSLTSecurityCreateDirectory; */
static int TclXSLTSecurityCreateDirectory _ANSI_ARGS_((xsltSecurityPrefsPtr sec,
                                           xsltTransformContextPtr ctxt,
                                           const char *value));
/* static xsltSecurityCheck TclXSLTSecurityReadNetwork; */
static int TclXSLTSecurityReadNetwork _ANSI_ARGS_((xsltSecurityPrefsPtr sec,
                                       xsltTransformContextPtr ctxt,
                                       const char *value));
/* static xsltSecurityCheck TclXSLTSecurityWriteNetwork; */
static int TclXSLTSecurityWriteNetwork _ANSI_ARGS_((xsltSecurityPrefsPtr sec,
                                        xsltTransformContextPtr ctxt,
                                        const char *value));

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",
  "get",
  "transform",
  (char *) NULL
};
enum instanceCommandMethods {
  TCLXSLT_CGET,
  TCLXSLT_CONFIGURE,
  TCLXSLT_GET,
  TCLXSLT_TRANSFORM
};
static CONST84 char *instanceCommandOptions[] = {
  "-messagecommand",
  "-method",
  "-indent",
  "-resulturi",
  "-profilechannel",
  "-encoding",
  "-omitxmldeclaration",
  (char *) NULL
};
enum instanceCommandOptions {
  TCLXSLT_OPTION_MESSAGECOMMAND,
  TCLXSLT_OPTION_METHOD,
  TCLXSLT_OPTION_INDENT,
  TCLXSLT_OPTION_RESULTURI,
  TCLXSLT_OPTION_PROFILECHANNEL,
  TCLXSLT_OPTION_ENCODING,
  TCLXSLT_OPTION_OMITXMLDECLARATION
};

static CONST84 char *instanceGetMethods[] = {
  "parameters",
  (char *) NULL
};
enum instanceGetMethods {
  TCLXSLT_GET_PARAMETERS
};

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

/*
 * libxml2 and libxslt are mostly thread-safe,
 * but there are issues with error callbacks.
 */

TCL_DECLARE_MUTEX(libxslt)

/*
 *----------------------------------------------------------------------------
 *
 * Tclxslt_libxslt_Init --
 *
 *  Initialisation routine for loadable module
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  Creates commands in the interpreter,
 *
 *----------------------------------------------------------------------------
 */

int
Tclxslt_libxslt_Init (interp)
     Tcl_Interp *interp;      /* Interpreter to initialise */
{
  ThreadSpecificData *tsdPtr;
  xsltSecurityPrefsPtr sec;

  tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
  if (!tsdPtr->initialised) {
    tsdPtr->initialised = 1;
    tsdPtr->interp = interp;
    tsdPtr->ssheetCntr = 0;
    tsdPtr->stylesheets = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable));
    Tcl_InitHashTable(tsdPtr->stylesheets, TCL_ONE_WORD_KEYS);
    tsdPtr->extensions = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable));
    Tcl_InitHashTable(tsdPtr->extensions, TCL_STRING_KEYS);
  } /* only need to init the library once per process */

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

  Tcl_MutexLock(&libxslt);
#ifndef TCLXML_STATIC_TCLXSLT
  exsltRegisterAll();
#endif /* TCLXML_STATIC_TCLXSLT */

  /*
   * Setup security preferences
   */
  sec = xsltNewSecurityPrefs();
  if (xsltSetSecurityPrefs(sec, XSLT_SECPREF_READ_FILE,
                     TclXSLTSecurityReadFile)) {
    Tcl_SetResult(interp, "unable to set readfile security", NULL);
    return TCL_ERROR;
  }
  if (xsltSetSecurityPrefs(sec, XSLT_SECPREF_WRITE_FILE,
                     TclXSLTSecurityWriteFile)) {
    Tcl_SetResult(interp, "unable to set writefile security", NULL);
    return TCL_ERROR;
  }
  if (xsltSetSecurityPrefs(sec, XSLT_SECPREF_CREATE_DIRECTORY,
                     TclXSLTSecurityCreateDirectory)) {
    Tcl_SetResult(interp, "unable to set createdirectory security", NULL);
    return TCL_ERROR;
  }
  if (xsltSetSecurityPrefs(sec, XSLT_SECPREF_READ_NETWORK,
                     TclXSLTSecurityReadNetwork)) {
    Tcl_SetResult(interp, "unable to set readnetwork security", NULL);
    return TCL_ERROR;
  }
  if (xsltSetSecurityPrefs(sec, XSLT_SECPREF_WRITE_NETWORK,
                     TclXSLTSecurityWriteNetwork)) {
    Tcl_SetResult(interp, "unable to set writenetwork security", NULL);
    return TCL_ERROR;
  }
  /* xsltSetCtxtSecurityPrefs(sec, userCtxt); */
  xsltSetDefaultSecurityPrefs(sec);

  Tcl_MutexUnlock(&libxslt);

  Tcl_SetVar2Ex(interp, "::xslt::libxsltversion", NULL, Tcl_NewStringObj(xsltEngineVersion, -1), 0);
  Tcl_SetVar2Ex(interp, "::xslt::libexsltversion", NULL, Tcl_NewStringObj(exsltLibraryVersion, -1), 0);

  return TCL_OK;
}

/*
 * XSLT is not safe due to the document(), xsl:include and xsl:import functions/elements.
 * However, libxslt checks whether access is permitted to external resources.
 *
 * NOTE: need to make sure decision to allow access to resources is made by a trusted interpreter, not the untrusted slave.  Even better, use a mechanism similar to TclXML/libxml2 to access external resources.
 */

int
Tclxslt_libxslt_SafeInit (interp)
     Tcl_Interp *interp;      /* Interpreter to initialise */
{
  return Tclxslt_libxslt_Init(interp);
}

/*
 *----------------------------------------------------------------------------
 *
 * 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[];
{
  ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
  TclXSLT_Stylesheet *info;
  xmlDocPtr origDoc, doc;
  xsltStylesheetPtr ssheetPtr = NULL;
  void *oldxsltErrorCtx, *oldxmlErrorCtx;
  xmlGenericErrorFunc old_xsltGenericError, old_xmlGenericError;
  GenericError_Info *errorInfoPtr;
  Tcl_Obj *errObjPtr = NULL;
  int new;

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

  if (TclXML_libxml2_GetDocFromObj(interp, objv[1], &origDoc) != TCL_OK) {
    return TCL_ERROR;
  }

  Tcl_MutexLock(&libxslt);
  doc = xmlCopyDoc(origDoc, 1);
  /*
   * xmlCopyDoc doesn't copy some of the fields.
   */
  if (origDoc->URL) {
    doc->URL = (const xmlChar *) Tcl_Alloc(strlen((char *) origDoc->URL) + 1);
    strcpy((char *) doc->URL, (char *) origDoc->URL);
  }

  /*
   * Prepare for compiling stylesheet
   */

  TclXML_libxml2_ResetError(interp);

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

  /*
   * Save the previous error context so that it can
   * be restored upon completion of the operation.
   */
  old_xsltGenericError = xsltGenericError;
  oldxsltErrorCtx = xsltGenericErrorContext;
  old_xmlGenericError = xmlGenericError;
  oldxmlErrorCtx = xmlGenericErrorContext;

  xmlSetGenericErrorFunc((void *) errorInfoPtr,
                   TclXSLTGenericError);
  xsltSetGenericErrorFunc((void *) errorInfoPtr, TclXSLTGenericError);

  /*
   * Compile stylesheet
   */

  ssheetPtr = xsltParseStylesheetDoc(doc);

  xmlSetGenericErrorFunc((void *) oldxmlErrorCtx, old_xmlGenericError);
  xsltSetGenericErrorFunc((void *) oldxsltErrorCtx, old_xsltGenericError);

  Tcl_MutexUnlock(&libxslt);

  errObjPtr = TclXML_libxml2_GetErrorObj(interp);

  if (ssheetPtr == 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) {
    goto error;
  }

  /* TODO: notify app of any warnings */

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

  /*
   * Create reverse mapping of stylesheet to name of stylesheet command.
   */
  info->entryPtr = Tcl_CreateHashEntry(tsdPtr->stylesheets, (ClientData) ssheetPtr, &new);
  /* sanity check: new == 1 */
  Tcl_SetHashValue(info->entryPtr, (ClientData) info->name);

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

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

  return TCL_OK;

error:

  if (errObjPtr) {
    Tcl_SetObjResult(interp, errObjPtr);
  } else if (errorInfoPtr->msg) {
    Tcl_SetObjResult(interp, errorInfoPtr->msg);
    Tcl_DecrRefCount(errorInfoPtr->msg);
  }
  Tcl_Free((char *) errorInfoPtr);

  Tcl_MutexLock(&libxslt);
  if (ssheetPtr) {
    xsltFreeStylesheet(ssheetPtr);
  } else {
    xmlFreeDoc(doc);
  }
  Tcl_MutexUnlock(&libxslt);
  
  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_DeleteHashEntry(ssheet->entryPtr);
  
  Tcl_Free(ssheet->name);
  if (ssheet->messagecommand) {
    Tcl_DecrRefCount(ssheet->messagecommand);
  }
  if (ssheet->resulturi) {
    Tcl_DecrRefCount(ssheet->resulturi);
  }
  if (ssheet->profilechannelObj) {
    Tcl_DecrRefCount(ssheet->profilechannelObj);
  }
  Tcl_MutexLock(&libxslt);
  xsltFreeStylesheet(ssheet->stylesheet); /* Also frees document */
  Tcl_MutexUnlock(&libxslt);
  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, indent = 0, theOmitXMLDeclaration = 0;
  const xmlChar *theMethod, *theEncoding;

  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:
      XSLT_GET_IMPORT_PTR(theMethod, ssheet->stylesheet, method);
      if (theMethod != NULL) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj((CONST char *) theMethod, -1));
      } /* theMethod == NULL means XML method; result should be empty.
         EXCEPTION: if the result document is of type XML_HTML_DOCUMENT_NODE
         then the method should be "html".
       */
      break;

    case TCLXSLT_OPTION_ENCODING:
      XSLT_GET_IMPORT_PTR(theEncoding, ssheet->stylesheet, encoding);
      if (theEncoding != NULL) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj((CONST char *) theEncoding, -1));
      } /* theEncoding == NULL means default (UTF-8) encoding; result should be empty.
       */
      break;

    case TCLXSLT_OPTION_OMITXMLDECLARATION:
      XSLT_GET_IMPORT_INT(theOmitXMLDeclaration, ssheet->stylesheet, omitXmlDeclaration);
      Tcl_SetObjResult(interp, Tcl_NewBooleanObj(theOmitXMLDeclaration == 1));
      break;

    case TCLXSLT_OPTION_INDENT:
      XSLT_GET_IMPORT_INT(indent, ssheet->stylesheet, indent);
      Tcl_SetObjResult(interp, Tcl_NewBooleanObj(indent));
      break;

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

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

    case TCLXSLT_OPTION_PROFILECHANNEL:
      if (ssheet->profilechannelObj != NULL) {
        Tcl_SetObjResult(interp, ssheet->profilechannelObj);
      }
      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:
    case TCLXSLT_OPTION_INDENT:
    case TCLXSLT_OPTION_ENCODING:
    case TCLXSLT_OPTION_OMITXMLDECLARATION:
      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;

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

    case TCLXSLT_OPTION_PROFILECHANNEL:
      if (ssheet->profilechannelObj != NULL) {
        Tcl_DecrRefCount(ssheet->profilechannelObj);
      }
#ifdef __WIN32__
      Tcl_SetResult(interp, "profiling not available", NULL);
      return TCL_ERROR;
#else
      ssheet->profilechannelObj = objv[3];
      Tcl_IncrRefCount(ssheet->profilechannelObj);
#endif
      break;

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

    break;

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

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

    switch ((enum instanceGetMethods) option) {
    case TCLXSLT_GET_PARAMETERS:

      Tcl_SetObjResult(interp, GetParameters(interp, ssheet->stylesheet));
      break;

    default:
      Tcl_SetResult(interp, "unknown name", 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 *oldxsltErrorCtx, *oldxmlErrorCtx;
  xmlGenericErrorFunc old_xsltGenericError, old_xmlGenericError;
  Tcl_Obj *resultObjPtr, *errObjPtr = NULL;
  char *resulturi = NULL;
  FILE *profile = NULL;
  xsltTransformContextPtr userCtxt = NULL;

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

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

  TclXML_libxml2_ResetError(stylesheet->interp);

  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;

  if (stylesheet->resulturi) {
    resulturi = Tcl_GetStringFromObj(stylesheet->resulturi, NULL);
  }
#ifdef __WIN32__
  /* Tcl_GetOpenFile not available on Windows */
#else
  if (stylesheet->profilechannelObj) {
    if (Tcl_GetOpenFile(stylesheet->interp,
                  Tcl_GetStringFromObj(stylesheet->profilechannelObj, NULL),
                  1, 1,
                  (ClientData *) &profile) != TCL_OK) {
      goto error;
    }
  }
#endif

  /*
   * Perform the transformation
   */

  Tcl_MutexLock(&libxslt);

  /*
   * 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;
  oldxsltErrorCtx = xsltGenericErrorContext;
  old_xmlGenericError = xmlGenericError;
  oldxmlErrorCtx = xmlGenericErrorContext;

  xmlSetGenericErrorFunc((void *) errorInfoPtr,
                   TclXSLTGenericError);
  xsltSetGenericErrorFunc((void *) errorInfoPtr, TclXSLTGenericError);

  userCtxt = xsltNewTransformContext(stylesheet->stylesheet, doc);
  if (userCtxt == NULL) {
    xmlSetGenericErrorFunc((void *) oldxmlErrorCtx, old_xmlGenericError);
    xsltSetGenericErrorFunc((void *) oldxsltErrorCtx, old_xsltGenericError);

    Tcl_MutexUnlock(&libxslt);
    Tcl_SetResult(stylesheet->interp, "unable to create transformation context", NULL);
    goto error;
  }

  result = xsltApplyStylesheetUser(stylesheet->stylesheet,
                           doc,
                           (const char **)params,
                           resulturi,
                           profile,
                           userCtxt);

  xsltFreeTransformContext(userCtxt);

  xmlSetGenericErrorFunc((void *) oldxmlErrorCtx, old_xmlGenericError);
  xsltSetGenericErrorFunc((void *) oldxsltErrorCtx, old_xsltGenericError);

  Tcl_MutexUnlock(&libxslt);

  errObjPtr = TclXML_libxml2_GetErrorObj(stylesheet->interp);

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

    if (errObjPtr) {
      Tcl_AppendObjToObj(resultPtr, errObjPtr);
      Tcl_SetObjResult(stylesheet->interp, resultPtr);
      goto error;
    } else {
      if (errorInfoPtr->msg) {
      Tcl_AppendObjToObj(resultPtr, errorInfoPtr->msg);
      }

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

  if ((errObjPtr || (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 (errObjPtr) {
      if (Tcl_ListObjAppendElement(stylesheet->interp, cmdPtr, errObjPtr) != TCL_OK) {
      goto error;
      }
    } else {
      if (Tcl_ListObjAppendElement(stylesheet->interp, cmdPtr, errorInfoPtr->msg) != TCL_OK) {
      goto error;
      }
    }
    if (Tcl_GlobalEvalObj(stylesheet->interp, cmdPtr) != TCL_OK) {
      Tcl_Obj *resultPtr = Tcl_NewStringObj("message command failed: ", -1);

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

  }

  resultObjPtr = TclDOM_libxml2_CreateObjFromDoc(stylesheet->interp, result);
  Tcl_SetObjResult(stylesheet->interp, resultObjPtr);

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

  return TCL_OK;

 error:

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

  return TCL_ERROR;
}

void
ListObjAppendUniqueList(interp, tablePtr, listPtr, newElementsPtr)
     Tcl_Interp *interp;
     Tcl_HashTable *tablePtr;
     Tcl_Obj *listPtr;
     Tcl_Obj *newElementsPtr;
{
  int len, idx;
  Tcl_Obj *elementPtr, *keyPtr, *namePtr, *nameURIPtr;
  Tcl_HashEntry *entryPtr;

  Tcl_ListObjLength(interp, newElementsPtr, &len);
  for (idx = 0; idx < len; idx++) {
      Tcl_ListObjIndex(interp, newElementsPtr, idx, &elementPtr);
      Tcl_ListObjIndex(interp, elementPtr, 0, &namePtr);
      Tcl_ListObjIndex(interp, elementPtr, 1, &nameURIPtr);

      keyPtr = Tcl_NewObj();
      Tcl_AppendStringsToObj(keyPtr,
                                       Tcl_GetStringFromObj(nameURIPtr, NULL), 
                                       "^", 
                                       Tcl_GetStringFromObj(namePtr, NULL),
                                       NULL);
      entryPtr = Tcl_FindHashEntry(tablePtr, (CONST char *) keyPtr);
      if (entryPtr == NULL) {
        Tcl_ListObjAppendElement(interp, listPtr, elementPtr);
      }
      Tcl_DecrRefCount(keyPtr);
  }
}

/*
 *----------------------------------------------------------------------------
 *
 * GetParameters --
 *
 *  Retrieves the parameters for a stylesheet.
 *
 * Results:
 *  Returns a Tcl list object.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------------
 */

static Tcl_Obj *
GetParameters(interp, stylesheet)
     Tcl_Interp *interp;
     xsltStylesheetPtr stylesheet;
{
  Tcl_Obj *resultPtr, *objPtr, *keyPtr;
  xsltStackElemPtr varPtr;
  Tcl_HashTable entries;  /* to keep track of parameter qnames */
  int new;

  if (stylesheet == NULL) {
    return NULL;
  }

  resultPtr = Tcl_NewListObj(0, NULL);
  Tcl_InitObjHashTable(&entries);

  for (varPtr = stylesheet->variables; varPtr; varPtr = varPtr->next) {
    Tcl_Obj *listPtr;

    if (strcmp((char *) varPtr->comp->inst->name, "param") == 0) {
      listPtr = Tcl_NewListObj(0, NULL);
      Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj((CONST char *) varPtr->name, -1));
      Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj((CONST char *) varPtr->nameURI, -1));
      Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj((CONST char *) varPtr->select, -1));

      Tcl_ListObjAppendElement(interp, resultPtr, listPtr);

        keyPtr = Tcl_NewStringObj((CONST char *) varPtr->nameURI, -1);
        Tcl_AppendStringsToObj(keyPtr, "^", varPtr->name, NULL);
        Tcl_CreateHashEntry(&entries, (CONST char *) keyPtr, &new);
    }
  }

  objPtr = GetParameters(interp, stylesheet->next);
  if (objPtr) {
    ListObjAppendUniqueList(interp, &entries, resultPtr, objPtr);
  }
  objPtr = GetParameters(interp, stylesheet->imports);
  if (objPtr) {
    ListObjAppendUniqueList(interp, &entries, resultPtr, objPtr);
  }

  Tcl_DeleteHashTable(&entries);

  return resultPtr;
}

/*
 *----------------------------------------------------------------------------
 *
 * 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) {
    return;
  }

  if (errorInfoPtr->stylesheet && 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[];
{
  ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
  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;
    }

    Tcl_MutexLock(&libxslt);

    if (xsltRegisterExtModule((const xmlChar *) Tcl_GetStringFromObj(objv[2], NULL),
                        TclXSLTExtInit,
                        TclXSLTExtShutdown)) {
      Tcl_MutexUnlock(&libxslt);
      Tcl_SetResult(interp, "cannot register extension module", NULL);
    }

    Tcl_MutexUnlock(&libxslt);

    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(tsdPtr->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(tsdPtr->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;
{
  ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
  Tcl_HashEntry *entry;
  TclXSLT_Extension *extinfo;

  entry = Tcl_FindHashEntry(tsdPtr->extensions, (CONST char *) 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
   */

  Tcl_MutexLock(&libxslt);

  /*
   * 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) {
    Tcl_MutexUnlock(&libxslt);
    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_MutexUnlock(&libxslt);

  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 */
{
  ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
  TclXSLT_Extension *extinfo;
  Tcl_HashEntry *entry;
  Tcl_Obj *cmdPtr;
  int ret;

  if (inst == NULL) {
    return;
  }

  entry = Tcl_FindHashEntry(tsdPtr->extensions, (CONST char *) 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_libxml2_CreateObjFromNode(extinfo->interp, 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;

  Tcl_MutexLock(&libxslt);

  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);
      Tcl_MutexUnlock(&libxslt);
      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);
      Tcl_MutexUnlock(&libxslt);
      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_MutexUnlock(&libxslt);

  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.
 *
 * NB. Mutex is assumed to be locked when invoking this routine.
 *
 * Results:
 *  XPath Object.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------------
 */

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

  if (TclDOM_libxml2_GetNodeFromObj(interp, objPtr, &nodePtr) == TCL_OK) {
    return xmlXPathNewNodeSet(nodePtr);
  }
  
   if (TclXML_libxml2_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 (TclXML_libxml2_GetDocFromObj(interp, listPtr[i], &docPtr) == TCL_OK) {
        continue;
      }
      if (TclDOM_libxml2_GetNodeFromObj(interp, listPtr[i], &nodePtr) != TCL_OK) {
        return xmlXPathNewString((const xmlChar *) 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 (TclXML_libxml2_GetDocFromObj(interp, listPtr[0], &docPtr) == TCL_OK) {
      nset = xmlXPathNodeSetCreate((xmlNodePtr) docPtr);
    } else {
      TclDOM_libxml2_GetNodeFromObj(interp, listPtr[0], &nodePtr);
      nset = xmlXPathNodeSetCreate(nodePtr);
    }
    for (i = 1; i < len; i++) {
      if (TclXML_libxml2_GetDocFromObj(interp, listPtr[i], &docPtr) == TCL_OK) {
        xmlXPathNodeSetAdd(nset, (xmlNodePtr) docPtr);
      } else {
        TclDOM_libxml2_GetNodeFromObj(interp, listPtr[i], &nodePtr);
        xmlXPathNodeSetAdd(nset, nodePtr);
      }
    }
    return xmlXPathWrapNodeSet(nset);

  } else {
    return xmlXPathNewString((const xmlChar *) 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);
      if (xpobj->nodesetval) {
      for (i = 0; i < xpobj->nodesetval->nodeNr; i++) {
        Tcl_Obj *nodeObjPtr = NULL;
        if (xpobj->nodesetval->nodeTab[i] &&
            xpobj->nodesetval->nodeTab[i]->type == XML_DOCUMENT_NODE) {
          nodeObjPtr = TclXML_libxml2_CreateObjFromDoc((xmlDocPtr) xpobj->nodesetval->nodeTab[i]);
        } else if (xpobj->nodesetval->nodeTab[i]) {
          nodeObjPtr = TclDOM_libxml2_CreateObjFromNode(interp, 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((CONST char *) 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 */
}

/*
 *----------------------------------------------------------------------------
 *
 * TclXSLTSecurity --
 * TclXSLTSecurityReadFile --
 * TclXSLTSecurityWriteFile --
 * TclXSLTSecurityCreateDirectory --
 * TclXSLTSecurityReadNetwork --
 * TclXSLTSecurityWriteNetwork --
 *
 *  Check if external operations are permitted.
 *
 * Results:
 *  Returns boolean value.
 *
 * Side effects:
 *  Depends on callback.
 *
 *----------------------------------------------------------------------------
 */

static int
TclXSLTSecurity(name, method, value)
     Tcl_Obj *name;
     const char *method;
     const char *value;
{
  ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
  Tcl_Interp *master;
  Tcl_Obj *cmdPtr, *pathPtr;
  int result, permitted;

  if (Tcl_IsSafe(tsdPtr->interp)) {

    /*
     * Invoke hidden command
     */

    master = Tcl_GetMaster(tsdPtr->interp);

    if (!Tcl_IsSafe(master)) {
      return 0;
    }

    if (Tcl_GetInterpPath(master, tsdPtr->interp) != TCL_OK) {
      return 0;
    }
    pathPtr = Tcl_GetObjResult(master);

    cmdPtr = Tcl_NewListObj(0, NULL);
    Tcl_IncrRefCount(cmdPtr);
    Tcl_ListObjAppendElement(master, cmdPtr, Tcl_NewStringObj("interp", -1));
    Tcl_ListObjAppendElement(master, cmdPtr, Tcl_NewStringObj("invokehidden", -1));
    Tcl_ListObjAppendElement(master, cmdPtr, pathPtr);
    Tcl_ListObjAppendElement(master, cmdPtr, Tcl_NewStringObj("-global", -1));
    Tcl_ListObjAppendElement(master, cmdPtr, Tcl_NewStringObj("::xslt::security", -1));
    Tcl_ListObjAppendElement(master, cmdPtr, name);
    Tcl_ListObjAppendElement(master, cmdPtr, Tcl_NewStringObj(method, -1));
    Tcl_ListObjAppendElement(master, cmdPtr, Tcl_NewStringObj(value, -1));

    result = Tcl_EvalObjEx(master, cmdPtr, TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT);

    Tcl_DecrRefCount(cmdPtr);
  } else {

    /*
     * Invoke command normally
     */

    cmdPtr = Tcl_NewListObj(0, NULL);
    Tcl_IncrRefCount(cmdPtr);
    Tcl_ListObjAppendElement(tsdPtr->interp, cmdPtr, Tcl_NewStringObj("::xslt::security", -1));
    Tcl_ListObjAppendElement(tsdPtr->interp, cmdPtr, name);
    Tcl_ListObjAppendElement(tsdPtr->interp, cmdPtr, Tcl_NewStringObj(method, -1));
    Tcl_ListObjAppendElement(tsdPtr->interp, cmdPtr, Tcl_NewStringObj(value, -1));

    result = Tcl_EvalObjEx(tsdPtr->interp, cmdPtr, TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT);

    Tcl_DecrRefCount(cmdPtr);
  }

  if (result == TCL_OK) {
    if (Tcl_GetBooleanFromObj(tsdPtr->interp, Tcl_GetObjResult(tsdPtr->interp), &permitted) == TCL_OK) {
      return permitted;
    } else if (Tcl_IsSafe(tsdPtr->interp)) {
      return 0;
    } else {
      return 1;
    }
  } else if (Tcl_IsSafe(tsdPtr->interp)) {
    return 0;
  } else {
    return 1;
  }
}
static Tcl_Obj *
TclXSLTSecurityGetName(ctxt)
     xsltTransformContextPtr ctxt;
{
  ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
  Tcl_HashEntry *entryPtr;

  if (ctxt) {
    entryPtr = Tcl_FindHashEntry(tsdPtr->stylesheets, (ClientData) ctxt->style);
    if (entryPtr) {
      return Tcl_NewStringObj((char *) Tcl_GetHashValue(entryPtr), -1);
    } else {
      return Tcl_NewObj();
    }
  } else {
    return Tcl_NewObj();
  }
}
static int
TclXSLTSecurityReadFile(sec, ctxt, value)
     xsltSecurityPrefsPtr sec;
     xsltTransformContextPtr ctxt;
     const char *value;
{
  return TclXSLTSecurity(TclXSLTSecurityGetName(ctxt), "readfile", value);
}
static int
TclXSLTSecurityWriteFile(sec, ctxt, value)
     xsltSecurityPrefsPtr sec;
     xsltTransformContextPtr ctxt;
     const char *value;
{
  return TclXSLTSecurity(TclXSLTSecurityGetName(ctxt), "writefile", value);
}
static int
TclXSLTSecurityCreateDirectory(sec, ctxt, value)
     xsltSecurityPrefsPtr sec;
     xsltTransformContextPtr ctxt;
     const char *value;
{
  return TclXSLTSecurity(TclXSLTSecurityGetName(ctxt), "createdirectory", value);
}
static int
TclXSLTSecurityReadNetwork(sec, ctxt, value)
     xsltSecurityPrefsPtr sec;
     xsltTransformContextPtr ctxt;
     const char *value;
{
  return TclXSLTSecurity(TclXSLTSecurityGetName(ctxt), "readnetwork", value);
}
static int
TclXSLTSecurityWriteNetwork(sec, ctxt, value)
     xsltSecurityPrefsPtr sec;
     xsltTransformContextPtr ctxt;
     const char *value;
{
  return TclXSLTSecurity(TclXSLTSecurityGetName(ctxt), "writenetwork", value);
}

Generated by  Doxygen 1.6.0   Back to index