diff options
Diffstat (limited to 'tclxml/tclxslt-libxslt.c')
| -rw-r--r-- | tclxml/tclxslt-libxslt.c | 1872 |
1 files changed, 0 insertions, 1872 deletions
diff --git a/tclxml/tclxslt-libxslt.c b/tclxml/tclxslt-libxslt.c deleted file mode 100644 index 73e0f61..0000000 --- a/tclxml/tclxslt-libxslt.c +++ /dev/null @@ -1,1872 +0,0 @@ -/* - * 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-libxslt.c,v 1.2 2016/01/15 21:06:01 joye 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, ®); - 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, - "%s", 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); -} |