1/* 2 * tclxslt.c -- 3 * 4 * Interface to Gnome libxslt. 5 * 6 * Copyright (c) 2001-2002 Zveno Pty Ltd 7 * http://www.zveno.com/ 8 * 9 * Zveno Pty Ltd makes this software and associated documentation 10 * available free of charge for any purpose. You may make copies 11 * of the software but you must include all of this notice on any copy. 12 * 13 * Zveno Pty Ltd does not warrant that this software is error free 14 * or fit for any purpose. Zveno Pty Ltd disclaims any liability for 15 * all claims, expenses, losses, damages and costs any user may incur 16 * as a result of using, copying or modifying the software. 17 * 18 * $Id: tclxslt.c,v 1.20 2002/11/29 23:29:24 rnurmi Exp $ 19 * 20 */ 21 22#include "tclxslt.h" 23 24#undef TCL_STORAGE_CLASS 25#define TCL_STORAGE_CLASS DLLEXPORT 26 27#ifdef __WIN32__ 28# include "win/win32config.h" 29#endif 30 31/* 32 * For Darwin (MacOS X) in particular, but also others 33 */ 34 35#ifndef __WIN32__ 36# define DLLIMPORT EXTERN 37#endif 38 39/* 40 * Manage stylesheet objects 41 */ 42 43typedef struct TclXSLT_Stylesheet { 44 Tcl_Interp *interp; 45 char *name; 46 xsltStylesheetPtr stylesheet; 47 48 Tcl_Obj *messagecommand; 49} TclXSLT_Stylesheet; 50 51static int ssheetCntr = 0; 52 53/* 54 * Extension management 55 */ 56 57typedef struct TclXSLT_Extension { 58 Tcl_Interp *interp; 59 Tcl_Obj *nsuri; 60 Tcl_Obj *tclns; 61 xsltTransformContextPtr xformCtxt; 62} TclXSLT_Extension; 63 64Tcl_HashTable extensions; 65 66/* 67 * Prototypes for procedures defined later in this file: 68 */ 69 70/* 71 * Declarations for externally visible functions. 72 */ 73 74EXTERN int Xslt_Init _ANSI_ARGS_((Tcl_Interp *interp)); 75 76/* 77 * Forward declarations for private functions. 78 */ 79 80static void TclXSLTGenericError _ANSI_ARGS_((void *ctx, const char *msg, ...)); 81 82static int TclXSLTCompileCommand _ANSI_ARGS_((ClientData dummy, 83 Tcl_Interp *interp, 84 int objc, 85 Tcl_Obj *CONST objv[])); 86static int TclXSLTInstanceCommand _ANSI_ARGS_((ClientData ssheet, 87 Tcl_Interp *interp, 88 int objc, 89 Tcl_Obj *CONST objv[])); 90static void TclXSLTDeleteStylesheet _ANSI_ARGS_((ClientData ssheet)); 91static int TclXSLTExtensionCommand _ANSI_ARGS_((ClientData dummy, 92 Tcl_Interp *interp, 93 int objc, 94 Tcl_Obj *CONST objv[])); 95 96static int TclXSLTTransform _ANSI_ARGS_((TclXSLT_Stylesheet *stylesheet, 97 Tcl_Obj *source, 98 int paramc, 99 Tcl_Obj *CONST paramv[])); 100 101static void TclXSLT_RegisterAll _ANSI_ARGS_((TclXSLT_Extension *extinfo, 102 const xmlChar *nsuri)); 103 104/* static xsltExtInitFunction TclXSLTExtInit; */ 105static void *TclXSLTExtInit _ANSI_ARGS_((xsltTransformContextPtr ctxt, 106 const xmlChar *URI)); 107/* static xsltExtShutdownFunction TclXSLTExtShutdown; */ 108static void TclXSLTExtShutdown _ANSI_ARGS_((xsltTransformContextPtr ctxt, 109 const xmlChar *URI, 110 void *userdata)); 111/* static xmlXPathEvalFunc TclXSLTExtFunction; */ 112static void TclXSLTExtFunction _ANSI_ARGS_((xmlXPathParserContextPtr xpathCtxt, 113 int nargs)); 114/* static xsltPreComputeFunction TclXSLTExtElementPreComp; */ 115static void TclXSLTExtElementPreComp _ANSI_ARGS_((xsltStylesheetPtr style, 116 xmlNodePtr inst, 117 xsltTransformFunction function)); 118/* static xsltTransformFunction TclXSLTExtElementTransform; */ 119static void TclXSLTExtElementTransform _ANSI_ARGS_((xsltTransformContextPtr ctxt, 120 xmlNodePtr node, 121 xmlNodePtr inst, 122 xsltStylePreCompPtr comp)); 123 124static Tcl_Obj * TclXSLT_ConvertXPathObjToTclObj _ANSI_ARGS_((Tcl_Interp *interp, 125 xmlXPathObjectPtr xpobj)); 126static xmlXPathObjectPtr TclXSLT_ConvertTclObjToXPathObj _ANSI_ARGS_((Tcl_Interp *interp, 127 Tcl_Obj *objPtr)); 128 129/* 130 * Error context for passing error result back to caller. 131 */ 132 133typedef struct GenericError_Info { 134 Tcl_Interp *interp; 135 TclXSLT_Stylesheet *stylesheet; 136 int code; 137 Tcl_Obj *msg; 138} GenericError_Info; 139 140/* 141 * Switch tables 142 */ 143 144#ifndef CONST84 145#define CONST84 /* Before 8.4 no 'const' required */ 146#endif 147 148static CONST84 char *instanceCommandMethods[] = { 149 "cget", 150 "configure", 151 "transform", 152 (char *) NULL 153}; 154enum instanceCommandMethods { 155 TCLXSLT_CGET, 156 TCLXSLT_CONFIGURE, 157 TCLXSLT_TRANSFORM 158}; 159static CONST84 char *instanceCommandOptions[] = { 160 "-messagecommand", 161 "-method", 162 (char *) NULL 163}; 164enum instanceCommandOptions { 165 TCLXSLT_OPTION_MESSAGECOMMAND, 166 TCLXSLT_OPTION_METHOD 167}; 168 169static CONST84 char *extensionCommandMethods[] = { 170 "add", 171 "remove", 172 (char *) NULL 173}; 174enum extensionCommandMethods { 175 TCLXSLT_EXT_ADD, 176 TCLXSLT_EXT_REMOVE 177}; 178 179/* 180 * Debugging 181 */ 182 183static Tcl_Channel stderrChan; 184static char dbgbuf[200]; 185 186/* 187static void DumpTclObj(objPtr) 188 Tcl_Obj *objPtr; 189{ 190 Tcl_Obj *elPtr; 191 int idx, len; 192 193 if (objPtr->typePtr == Tcl_GetObjType("list")) { 194 Tcl_WriteChars(stderrChan, " list(", -1); 195 Tcl_ListObjLength(NULL, objPtr, &len); 196 for (idx = 0; idx < len; idx++) { 197 Tcl_ListObjIndex(NULL, objPtr, idx, &elPtr); 198 DumpTclObj(elPtr); 199 } 200 Tcl_WriteChars(stderrChan, ")", -1); 201 } else if (objPtr->typePtr == Tcl_GetObjType("libxml2-node")) { 202 xmlNodePtr nodePtr = (xmlNodePtr) objPtr->internalRep.otherValuePtr; 203 sprintf(dbgbuf, " nodePtr x%x name \"%s\" value \"%s\"", nodePtr, nodePtr->name, xmlNodeGetContent(nodePtr)); 204 Tcl_WriteChars(stderrChan, dbgbuf, -1); 205 } else { 206 sprintf(dbgbuf, " obj x%x \"%s\"", objPtr, Tcl_GetStringFromObj(objPtr, NULL)); 207 Tcl_WriteChars(stderrChan, dbgbuf, -1); 208 } 209} 210 211static void DumpTree(nodePtr) 212 xmlNodePtr nodePtr; 213{ 214 xmlNodePtr child; 215 switch (nodePtr->type) { 216 case XML_ELEMENT_NODE: 217 sprintf(dbgbuf, "adding element \"%s\" x%x (%s)\n", nodePtr->name, nodePtr, XML_GET_CONTENT(nodePtr)); 218 Tcl_WriteChars(stderrChan, dbgbuf, -1); 219 for (child = nodePtr->children; child != NULL; child = child->next) { 220 DumpTree(child); 221 } 222 break; 223 case XML_ATTRIBUTE_NODE: 224 Tcl_WriteChars(stderrChan, "adding attribute\n", -1); 225 break; 226 case XML_TEXT_NODE: 227 case XML_CDATA_SECTION_NODE: 228 sprintf(dbgbuf, "adding textNode \"%s\" x%x\n", XML_GET_CONTENT(nodePtr), nodePtr); 229 Tcl_WriteChars(stderrChan, dbgbuf, -1); 230 break; 231 case XML_ENTITY_REF_NODE: 232 Tcl_WriteChars(stderrChan, "adding entityReference\n", -1); 233 break; 234 case XML_ENTITY_NODE: 235 Tcl_WriteChars(stderrChan, "adding entity\n", -1); 236 break; 237 case XML_PI_NODE: 238 Tcl_WriteChars(stderrChan, "adding processingInstruction\n", -1); 239 break; 240 case XML_COMMENT_NODE: 241 Tcl_WriteChars(stderrChan, "adding comment\n", -1); 242 break; 243 case XML_DOCUMENT_NODE: 244 Tcl_WriteChars(stderrChan, "adding document\n", -1); 245 break; 246 case XML_DOCUMENT_TYPE_NODE: 247 Tcl_WriteChars(stderrChan, "adding docType\n", -1); 248 break; 249 case XML_DOCUMENT_FRAG_NODE: 250 Tcl_WriteChars(stderrChan, "adding documentFragment\n", -1); 251 break; 252 case XML_NOTATION_NODE: 253 Tcl_WriteChars(stderrChan, "adding notation\n", -1); 254 break; 255 case XML_HTML_DOCUMENT_NODE: 256 Tcl_WriteChars(stderrChan, "adding HTMLdocument\n", -1); 257 break; 258 case XML_DTD_NODE: 259 Tcl_WriteChars(stderrChan, "adding dtd\n", -1); 260 break; 261 case XML_ELEMENT_DECL: 262 Tcl_WriteChars(stderrChan, "adding elementDecl\n", -1); 263 break; 264 case XML_ATTRIBUTE_DECL: 265 Tcl_WriteChars(stderrChan, "adding attributeDecl\n", -1); 266 break; 267 case XML_ENTITY_DECL: 268 Tcl_WriteChars(stderrChan, "adding entityDecl\n", -1); 269 break; 270 case XML_NAMESPACE_DECL: 271 Tcl_WriteChars(stderrChan, "adding namespaceDecl\n", -1); 272 break; 273 case XML_XINCLUDE_START: 274 Tcl_WriteChars(stderrChan, "adding xincludeStart\n", -1); 275 break; 276 case XML_XINCLUDE_END: 277 Tcl_WriteChars(stderrChan, "adding xincludeEnd\n", -1); 278 break; 279 default: 280 Tcl_WriteChars(stderrChan, "adding unknown\n", -1); 281 } 282} 283*/ 284 285/* 286 *---------------------------------------------------------------------------- 287 * 288 * Xslt_Init -- 289 * 290 * Initialisation routine for loadable module 291 * 292 * Results: 293 * None. 294 * 295 * Side effects: 296 * Creates commands in the interpreter, 297 * 298 *---------------------------------------------------------------------------- 299 */ 300 301int 302Xslt_Init (interp) 303 Tcl_Interp *interp; /* Interpreter to initialise */ 304{ 305 int dbgMode; 306 307#ifdef USE_TCL_STUBS 308 if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { 309 return TCL_ERROR; 310 } 311#endif 312#ifdef USE_TCLDOMXML_STUBS 313 /* This is "dom::libxml2" 314 */ 315 if (Tcldomxml_InitStubs(interp, TCLDOMXML_VERSION, 1) == NULL) { 316 return TCL_ERROR; 317 } 318#endif 319 320 Tcl_CreateObjCommand(interp, "xslt::compile", TclXSLTCompileCommand, NULL, NULL); 321 Tcl_CreateObjCommand(interp, "xslt::extension", TclXSLTExtensionCommand, NULL, NULL); 322 323 Tcl_InitHashTable(&extensions, TCL_STRING_KEYS); 324 325 exsltRegisterAll(); 326 327 stderrChan = Tcl_GetChannel(interp, "stderr", &dbgMode); 328 329 Tcl_PkgProvide(interp, "xslt", TCLXSLT_VERSION); 330 331 return TCL_OK; 332} 333 334/* 335 *---------------------------------------------------------------------------- 336 * 337 * TclXSLTCompileCommand -- 338 * 339 * Class creation command for xslt stylesheet objects. 340 * 341 * Results: 342 * Compiles the XSLT stylesheet. 343 * Creates a Tcl command associated with that stylesheet. 344 * 345 * Side effects: 346 * Memory allocated, stylesheet is compiled. 347 * 348 *---------------------------------------------------------------------------- 349 */ 350 351static int 352TclXSLTCompileCommand(dummy, interp, objc, objv) 353 ClientData dummy; 354 Tcl_Interp *interp; 355 int objc; 356 Tcl_Obj *CONST objv[]; 357{ 358 TclXSLT_Stylesheet *info; 359 xmlDocPtr origDoc, doc; 360 xsltStylesheetPtr ssheetPtr = NULL; 361 GenericError_Info *errorInfoPtr; 362 363 if (objc != 2) { 364 Tcl_WrongNumArgs(interp, 1, objv, "stylesheet-doc"); 365 return TCL_ERROR; 366 } 367 368 /* Copy the document object, since libxslt clobbers the _private field */ 369 if (TclDOM_GetDocFromObj(interp, objv[1], &origDoc) != TCL_OK) { 370 return TCL_ERROR; 371 } 372 doc = xmlCopyDoc(origDoc, 1); 373 /* 374 * xmlCopyDoc doesn't copy some of the fields. 375 */ 376 if (origDoc->URL) { 377 doc->URL = Tcl_Alloc(strlen(origDoc->URL) + 1); 378 strcpy((char *) doc->URL, origDoc->URL); 379 } 380 381 /* 382 * Prepare for compiling stylesheet 383 */ 384 385 errorInfoPtr = (GenericError_Info *) Tcl_Alloc(sizeof(GenericError_Info)); 386 errorInfoPtr->interp = interp; 387 errorInfoPtr->stylesheet = NULL; 388 errorInfoPtr->code = TCL_OK; 389 errorInfoPtr->msg = NULL; 390 391 /* 392 * Compile stylesheet 393 */ 394 395 if ((ssheetPtr = xsltParseStylesheetDoc(doc)) == NULL) { 396 Tcl_SetResult(interp, "error compiling stylesheet", NULL); 397 goto error; 398 } 399 400 if (ssheetPtr->errors > 0) { 401 Tcl_SetResult(interp, "error compiling XSLT stylesheet", NULL); 402 goto error; 403 } 404 405 if (errorInfoPtr->code != TCL_OK) { 406 407 if (errorInfoPtr->msg) { 408 Tcl_SetObjResult(interp, errorInfoPtr->msg); 409 } 410 411 goto error; 412 } 413 414 info = (TclXSLT_Stylesheet *) Tcl_Alloc(sizeof(TclXSLT_Stylesheet)); 415 info->interp = interp; 416 info->name = Tcl_Alloc(20); 417 sprintf(info->name, "style%d", ssheetCntr++); 418 info->stylesheet = ssheetPtr; 419 info->messagecommand = NULL; 420 421 Tcl_CreateObjCommand(interp, info->name, TclXSLTInstanceCommand, (ClientData) info, TclXSLTDeleteStylesheet); 422 423 Tcl_SetObjResult(interp, Tcl_NewStringObj(info->name, -1)); 424 425 return TCL_OK; 426 427error: 428 429 if (errorInfoPtr->msg) { 430 Tcl_DecrRefCount(errorInfoPtr->msg); 431 } 432 Tcl_Free((char *) errorInfoPtr); 433 434 if (ssheetPtr) { 435 xsltFreeStylesheet(ssheetPtr); 436 } else { 437 xmlFreeDoc(doc); 438 } 439 440 return TCL_ERROR; 441} 442 443/* 444 *---------------------------------------------------------------------------- 445 * 446 * TclXSLTDeleteStylesheet -- 447 * 448 * Class destruction command for xslt stylesheet objects. 449 * 450 * Results: 451 * Frees memory associated with a stylesheet. 452 * 453 * Side effects: 454 * Memory deallocated. 455 * 456 *---------------------------------------------------------------------------- 457 */ 458 459static void 460TclXSLTDeleteStylesheet(clientData) 461 ClientData clientData; 462{ 463 TclXSLT_Stylesheet *ssheet = (TclXSLT_Stylesheet *) clientData; 464 465 Tcl_Free(ssheet->name); 466 if (ssheet->messagecommand) { 467 Tcl_DecrRefCount(ssheet->messagecommand); 468 } 469 xsltFreeStylesheet(ssheet->stylesheet); /* Also frees document */ 470 Tcl_Free((char *) ssheet); 471} 472/* 473 *---------------------------------------------------------------------------- 474 * 475 * TclXSLTInstanceCommand -- 476 * 477 * Handles the stylesheet object command. 478 * 479 * Results: 480 * Depends on method. 481 * 482 * Side effects: 483 * Depends on method. 484 * 485 *---------------------------------------------------------------------------- 486 */ 487 488static int 489TclXSLTInstanceCommand(clientData, interp, objc, objv) 490 ClientData clientData; 491 Tcl_Interp *interp; 492 int objc; 493 Tcl_Obj *CONST objv[]; 494{ 495 TclXSLT_Stylesheet *ssheet = (TclXSLT_Stylesheet *) clientData; 496 int method, option; 497 498 if (objc < 3) { 499 Tcl_WrongNumArgs(interp, 1, objv, "method ?args ...?"); 500 return TCL_ERROR; 501 } 502 503 if (Tcl_GetIndexFromObj(interp, objv[1], instanceCommandMethods, 504 "method", 0, &method) != TCL_OK) { 505 return TCL_ERROR; 506 } 507 508 switch ((enum instanceCommandMethods) method) { 509 case TCLXSLT_CGET: 510 511 if (objc != 3) { 512 Tcl_WrongNumArgs(interp, 2, objv, "option"); 513 return TCL_ERROR; 514 } 515 516 if (Tcl_GetIndexFromObj(interp, objv[2], instanceCommandOptions, 517 "option", 0, &option) != TCL_OK) { 518 return TCL_ERROR; 519 } 520 521 switch ((enum instanceCommandOptions) option) { 522 523 case TCLXSLT_OPTION_METHOD: 524 if (ssheet->stylesheet->method != NULL) { 525 Tcl_SetObjResult(interp, Tcl_NewStringObj(ssheet->stylesheet->method, -1)); 526 } 527 break; 528 529 case TCLXSLT_OPTION_MESSAGECOMMAND: 530 if (ssheet->messagecommand != NULL) { 531 Tcl_SetObjResult(interp, ssheet->messagecommand); 532 } 533 break; 534 535 default: 536 Tcl_SetResult(interp, "unknown option", NULL); 537 return TCL_ERROR; 538 } 539 540 break; 541 542 case TCLXSLT_CONFIGURE: 543 544 if (objc != 4) { 545 Tcl_WrongNumArgs(interp, 2, objv, "option value"); 546 return TCL_ERROR; 547 } 548 549 if (Tcl_GetIndexFromObj(interp, objv[2], instanceCommandOptions, 550 "option", 0, &option) != TCL_OK) { 551 return TCL_ERROR; 552 } 553 554 switch ((enum instanceCommandOptions) option) { 555 556 case TCLXSLT_OPTION_METHOD: 557 Tcl_SetResult(interp, "read-only option", NULL); 558 return TCL_ERROR; 559 break; 560 561 case TCLXSLT_OPTION_MESSAGECOMMAND: 562 if (ssheet->messagecommand != NULL) { 563 Tcl_DecrRefCount(ssheet->messagecommand); 564 } 565 ssheet->messagecommand = objv[3]; 566 Tcl_IncrRefCount(ssheet->messagecommand); 567 break; 568 569 default: 570 Tcl_SetResult(interp, "unknown option", NULL); 571 return TCL_ERROR; 572 } 573 574 break; 575 576 case TCLXSLT_TRANSFORM: 577 if (objc < 3) { 578 Tcl_WrongNumArgs(interp, 2, objv, "source ?param value...?"); 579 return TCL_ERROR; 580 } 581 582 return TclXSLTTransform(ssheet, objv[2], objc - 3, &objv[3]); 583 584 break; 585 586 default: 587 Tcl_SetResult(interp, "unknown method", NULL); 588 return TCL_OK; 589 } 590 591 return TCL_OK; 592} 593 594/* 595 *---------------------------------------------------------------------------- 596 * 597 * TclXSLTTransform -- 598 * 599 * Performs an XSL transformation. 600 * 601 * Results: 602 * Result document created. 603 * 604 * Side effects: 605 * Memory allocated for result document. 606 * 607 *---------------------------------------------------------------------------- 608 */ 609 610static int 611TclXSLTTransform(stylesheet, source, paramc, paramv) 612 TclXSLT_Stylesheet *stylesheet; 613 Tcl_Obj *source; 614 int paramc; 615 Tcl_Obj *CONST paramv[]; 616{ 617 xmlDocPtr doc, result; 618 char **params = NULL; 619 int nbparams = 0, i; 620 GenericError_Info *errorInfoPtr; 621 void *oldErrorCtx; 622 xmlGenericErrorFunc old_xsltGenericError; 623 624 errorInfoPtr = (GenericError_Info *) Tcl_Alloc(sizeof(GenericError_Info)); 625 errorInfoPtr->interp = stylesheet->interp; 626 errorInfoPtr->stylesheet = stylesheet; 627 errorInfoPtr->code = TCL_OK; 628 errorInfoPtr->msg = NULL; 629 630 if (TclDOM_GetDocFromObj(stylesheet->interp, source, &doc) != TCL_OK) { 631 goto error; 632 } 633 634 params = (char **) Tcl_Alloc(sizeof(char **) * (paramc + 1)); 635 for (i = 0; i < paramc; i++) { 636 params[nbparams++] = Tcl_GetStringFromObj(paramv[i++], NULL); 637 params[nbparams++] = Tcl_GetStringFromObj(paramv[i], NULL); 638 } 639 params[nbparams] = NULL; 640 641 /* 642 * Perform the transformation 643 */ 644 645 /* 646 * Save the previous error context so that it can 647 * be restored upon completion of the transformation. 648 * This is necessary because transformations may occur 649 * recursively (usually due to extensions). 650 */ 651 old_xsltGenericError = xsltGenericError; 652 oldErrorCtx = xsltGenericErrorContext; 653 654 xsltSetGenericErrorFunc((void *) errorInfoPtr, TclXSLTGenericError); 655 656 result = xsltApplyStylesheet(stylesheet->stylesheet, doc, (const char **)params); 657 658 xsltSetGenericErrorFunc((void *) oldErrorCtx, old_xsltGenericError); 659 660 if (result == NULL) { 661 Tcl_Obj *resultPtr = Tcl_NewStringObj("no result document", -1); 662 663 if (errorInfoPtr->msg) { 664 Tcl_AppendToObj(resultPtr, ":\n", -1); 665 Tcl_AppendObjToObj(resultPtr, errorInfoPtr->msg); 666 } 667 668 Tcl_SetObjResult(stylesheet->interp, resultPtr); 669 goto error; 670 } 671 672 if (errorInfoPtr->code != TCL_OK && errorInfoPtr->msg && stylesheet->messagecommand) { 673 674 /* We have produced a result, but there may possibly 675 * have been errors. Trouble is, there might also 676 * have been some completely innocent messages. 677 * -messageCommand is the only way to find out about these. 678 */ 679 680 Tcl_Obj *cmdPtr = Tcl_DuplicateObj(stylesheet->messagecommand); 681 if (Tcl_ListObjAppendElement(stylesheet->interp, cmdPtr, errorInfoPtr->msg) != TCL_OK) { 682 goto error; 683 } 684 if (Tcl_GlobalEvalObj(stylesheet->interp, cmdPtr) != TCL_OK) { 685 goto error; 686 } 687 688 } 689 690 Tcl_SetObjResult(stylesheet->interp, TclDOM_CreateObjFromDoc(result)); 691 692 if (errorInfoPtr->msg) { 693 Tcl_DecrRefCount(errorInfoPtr->msg); 694 } 695 Tcl_Free((char *) errorInfoPtr); 696 Tcl_Free(params); 697 698 return TCL_OK; 699 700 error: 701 702 if (errorInfoPtr->msg) { 703 Tcl_DecrRefCount(errorInfoPtr->msg); 704 } 705 if (params) { 706 Tcl_Free(params); 707 } 708 Tcl_Free((char *) errorInfoPtr); 709 710 return TCL_ERROR; 711} 712 713/* 714 *---------------------------------------------------------------------------- 715 * 716 * TclXSLTGenericError -- 717 * 718 * Handler for stylesheet errors. 719 * 720 * NB. Cannot distinguish between errors and use of xsl:message element. 721 * 722 * Results: 723 * Stores error message. 724 * 725 * Side effects: 726 * Transform will return error condition. 727 * 728 *---------------------------------------------------------------------------- 729 */ 730 731static void 732TclXSLTGenericError (void *ctx, const char *msg, ...) 733{ 734 va_list args; 735 char buf[2048]; 736 int len; 737 GenericError_Info *errorInfoPtr = (GenericError_Info *) ctx; 738 739 if (ctx < (void *) 0x1000) { 740 fprintf(stderr, "TclXSLT: bad context\n"); 741 va_start(args,msg); 742 vfprintf(stderr, msg, args); 743 va_end(args); 744 return; 745 } 746 747 va_start(args,msg); 748 len = vsnprintf(buf, 2047, msg, args); 749 va_end(args); 750 751 if (!errorInfoPtr->interp) { 752 sprintf(dbgbuf, "TclXSLTGenericError: NULL interp, msg \"%s\"\n", buf); 753 return; 754 } 755 756 if (errorInfoPtr->stylesheet->messagecommand) { 757 758 Tcl_Obj *cmdPtr = Tcl_DuplicateObj(errorInfoPtr->stylesheet->messagecommand); 759 if (Tcl_ListObjAppendElement(errorInfoPtr->interp, cmdPtr, Tcl_NewStringObj(buf, len)) != TCL_OK) { 760 Tcl_BackgroundError(errorInfoPtr->interp); 761 return; 762 } 763 if (Tcl_GlobalEvalObj(errorInfoPtr->interp, cmdPtr) != TCL_OK) { 764 Tcl_BackgroundError(errorInfoPtr->interp); 765 return; 766 } 767 768 } else { 769 770 if (!errorInfoPtr->msg) { 771 errorInfoPtr->msg = Tcl_NewObj(); 772 Tcl_IncrRefCount(errorInfoPtr->msg); 773 } 774 775 errorInfoPtr->code = TCL_ERROR; 776 777 Tcl_AppendToObj(errorInfoPtr->msg, buf, len); 778 779 } 780} 781 782/* 783 *---------------------------------------------------------------------------- 784 * 785 * TclXSLTExtensionCommand -- 786 * 787 * Command for xslt::extension command. 788 * 789 * Results: 790 * Depends on method. 791 * 792 * Side effects: 793 * Depends on method 794 * 795 *---------------------------------------------------------------------------- 796 */ 797 798static int 799TclXSLTExtensionCommand(dummy, interp, objc, objv) 800 ClientData dummy; 801 Tcl_Interp *interp; 802 int objc; 803 Tcl_Obj *CONST objv[]; 804{ 805 int method, new; 806 TclXSLT_Extension *extinfo; 807 Tcl_HashEntry *entry; 808 809 if (objc < 2) { 810 Tcl_WrongNumArgs(interp, 1, objv, "method ?args ...?"); 811 return TCL_ERROR; 812 } 813 814 if (Tcl_GetIndexFromObj(interp, objv[1], extensionCommandMethods, 815 "method", 0, &method) != TCL_OK) { 816 return TCL_ERROR; 817 } 818 819 switch ((enum extensionCommandMethods) method) { 820 821 case TCLXSLT_EXT_ADD: 822 if (objc != 4) { 823 Tcl_WrongNumArgs(interp, 2, objv, "nsuri tcl-namespace"); 824 return TCL_ERROR; 825 } 826 827 if (xsltRegisterExtModule(Tcl_GetStringFromObj(objv[2], NULL), 828 TclXSLTExtInit, 829 TclXSLTExtShutdown)) { 830 Tcl_SetResult(interp, "cannot register extension module", NULL); 831 } 832 833 extinfo = (TclXSLT_Extension *) Tcl_Alloc(sizeof(TclXSLT_Extension)); 834 extinfo->interp = interp; 835 extinfo->nsuri = objv[2]; 836 Tcl_IncrRefCount(objv[2]); 837 extinfo->tclns = objv[3]; 838 Tcl_IncrRefCount(objv[3]); 839 840 extinfo->xformCtxt = NULL; 841 842 entry = Tcl_CreateHashEntry(&extensions, Tcl_GetStringFromObj(objv[2], NULL), &new); 843 844 if (!new) { 845 Tcl_SetResult(interp, "extension already exists", NULL); 846 Tcl_Free((char *) extinfo); 847 return TCL_ERROR; 848 } 849 850 Tcl_SetHashValue(entry, extinfo); 851 852 TclXSLT_RegisterAll(extinfo, (const xmlChar *) Tcl_GetStringFromObj(objv[2], NULL)); 853 854 Tcl_ResetResult(interp); 855 856 break; 857 858 case TCLXSLT_EXT_REMOVE: 859 if (objc != 3) { 860 Tcl_WrongNumArgs(interp, 2, objv, "nsuri"); 861 return TCL_ERROR; 862 } 863 864 /* 865 * TODO: Remove previously registered elements and functions. 866 */ 867 868 entry = Tcl_FindHashEntry(&extensions, Tcl_GetStringFromObj(objv[2], NULL)); 869 if (entry == NULL) { 870 Tcl_SetResult(interp, "unknown XML Namespace URI", NULL); 871 return TCL_ERROR; 872 } 873 874 extinfo = (TclXSLT_Extension *) Tcl_GetHashValue(entry); 875 Tcl_DecrRefCount(extinfo->nsuri); 876 Tcl_DecrRefCount(extinfo->tclns); 877 Tcl_Free((char *) extinfo); 878 879 Tcl_DeleteHashEntry(entry); 880 881 break; 882 883 default: 884 Tcl_SetResult(interp, "unknown method", NULL); 885 return TCL_ERROR; 886 } 887 888 return TCL_OK; 889} 890 891/* 892 *---------------------------------------------------------------------------- 893 * 894 * TclXSLTExtInit -- 895 * 896 * Load extensions into a transformation context. 897 * 898 * Results: 899 * Returns pointer to extension data. 900 * Elements and functions are pre-registered. 901 * 902 * Side effects: 903 * None. 904 * 905 *---------------------------------------------------------------------------- 906 */ 907 908static void * 909TclXSLTExtInit(ctxt, URI) 910 xsltTransformContextPtr ctxt; 911 const xmlChar *URI; 912{ 913 Tcl_HashEntry *entry; 914 TclXSLT_Extension *extinfo; 915 916 entry = Tcl_FindHashEntry(&extensions, URI); 917 if (entry == NULL) { 918 /* Extension module was removed */ 919 return NULL; 920 } 921 922 extinfo = (TclXSLT_Extension *) Tcl_GetHashValue(entry); 923 extinfo->xformCtxt = ctxt; 924 925 return (void *) extinfo; 926} 927 928void 929TclXSLT_RegisterAll(extinfo, nsuri) 930 TclXSLT_Extension *extinfo; 931 const xmlChar *nsuri; 932{ 933 Tcl_Obj *cmdPtr, *objPtr; 934 Tcl_Obj **reg; 935 int ret, i, len; 936 937 /* 938 * Q: How to distinguish between extension elements and functions? 939 * A: Use the formal parameters. If the command can accept 940 * a variable argument list, then it is registered as a function. 941 * Otherwise it will be registered as an extension (and expected 942 * to accept certain arguments). 943 */ 944 945 cmdPtr = Tcl_NewStringObj("::xslt::getprocs ", -1); 946 Tcl_IncrRefCount(cmdPtr); 947 Tcl_AppendObjToObj(cmdPtr, extinfo->tclns); 948 ret = Tcl_EvalObjEx(extinfo->interp, cmdPtr, TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT); 949 objPtr = Tcl_GetObjResult(extinfo->interp); 950 Tcl_IncrRefCount(objPtr); 951 Tcl_DecrRefCount(cmdPtr); 952 953 if (ret != TCL_OK || objPtr == NULL) { 954 /* 955 * Something went wrong, therefore nothing to register. 956 */ 957 return; 958 } 959 960 ret = Tcl_ListObjGetElements(extinfo->interp, objPtr, &len, ®); 961 if (ret != TCL_OK || len != 2) { 962 /* 963 * Something went wrong, therefore nothing to register. 964 */ 965 return; 966 } 967 968 /* 969 * reg[0] contains extension elements 970 * reg[1] contains extension functions 971 */ 972 973 /* 974 * First register the extension elements. 975 */ 976 977 ret = Tcl_ListObjLength(extinfo->interp, reg[0], &len); 978 if (ret == TCL_OK && len > 0) { 979 for (i = 0; i < len; i++) { 980 981 if (Tcl_ListObjIndex(extinfo->interp, reg[0], i, &objPtr) != TCL_OK) { 982 continue; 983 } 984 985 xsltRegisterExtModuleElement((const xmlChar *) Tcl_GetStringFromObj(objPtr, NULL), 986 nsuri, 987 (xsltPreComputeFunction) TclXSLTExtElementPreComp, 988 (xsltTransformFunction) TclXSLTExtElementTransform); 989 } 990 } 991 992 /* 993 * Now register the extension functions. 994 */ 995 996 ret = Tcl_ListObjLength(extinfo->interp, reg[1], &len); 997 if (ret != TCL_OK || len == 0) { 998 return; 999 } 1000 1001 for (i = 0; i < len; i++) { 1002 1003 if (Tcl_ListObjIndex(extinfo->interp, reg[1], i, &objPtr) != TCL_OK) { 1004 continue; 1005 } 1006 1007 xsltRegisterExtModuleFunction((const xmlChar *) Tcl_GetStringFromObj(objPtr, NULL), 1008 nsuri, 1009 TclXSLTExtFunction); 1010 } 1011 1012 Tcl_DecrRefCount(objPtr); 1013 1014 return; 1015} 1016 1017/* 1018 *---------------------------------------------------------------------------- 1019 * 1020 * TclXSLTExtElementPreComp -- 1021 * 1022 * Compilation step for extension element. 1023 * 1024 * Results: 1025 * Not currently used. 1026 * 1027 * Side effects: 1028 * None. 1029 * 1030 *---------------------------------------------------------------------------- 1031 */ 1032 1033static void 1034TclXSLTExtElementPreComp(style, inst, function) 1035 xsltStylesheetPtr style; 1036 xmlNodePtr inst; 1037 xsltTransformFunction function; 1038{ 1039 return; 1040} 1041 1042/* 1043 *---------------------------------------------------------------------------- 1044 * 1045 * TclXSLTExtElementTransform -- 1046 * 1047 * Implements extension element. 1048 * 1049 * Results: 1050 * Returns string returned by Tcl command evaluation. 1051 * 1052 * Side effects: 1053 * Depends on Tcl command evaluated. 1054 * 1055 *---------------------------------------------------------------------------- 1056 */ 1057 1058static void 1059TclXSLTExtElementTransform(ctxt, node, inst, comp) 1060 xsltTransformContextPtr ctxt; /* unused */ 1061 xmlNodePtr node; 1062 xmlNodePtr inst; 1063 xsltStylePreCompPtr comp; /* unused */ 1064{ 1065 TclXSLT_Extension *extinfo; 1066 Tcl_HashEntry *entry; 1067 Tcl_Obj *cmdPtr; 1068 int ret; 1069 1070 if (inst == NULL) { 1071 return; 1072 } 1073 1074 entry = Tcl_FindHashEntry(&extensions, inst->ns->href); 1075 if (entry == NULL) { 1076 /* 1077 * Cannot find extension module. 1078 * Must have been removed. 1079 */ 1080 return; 1081 } 1082 1083 extinfo = (TclXSLT_Extension *) Tcl_GetHashValue(entry); 1084 1085 /* 1086 * Start constructing the script by first defining the command. 1087 */ 1088 1089 cmdPtr = Tcl_DuplicateObj(extinfo->tclns); 1090 Tcl_AppendStringsToObj(cmdPtr, "::", inst->name, NULL); 1091 1092 if (Tcl_ListObjAppendElement(extinfo->interp, cmdPtr, TclDOM_CreateObjFromNode(node)) != TCL_OK) { 1093 Tcl_DecrRefCount(cmdPtr); 1094 return; 1095 } 1096 1097 /* 1098 * Converting the stylesheet node to a TclDOM node may clobber the 1099 * _private pointer. It would be nice to find the equivalent node 1100 * in the original DOM tree, but it may not even exist anymore :-( 1101 * 1102 * TODO: make extension elements more effective, and allow 1103 * pre-computation. 1104 */ 1105 1106 /* 1107 * Now evaluate the complete command. 1108 * Can't propagqte a return error result to 1109 * XSLT, so flag background error instead. 1110 */ 1111 ret = Tcl_EvalObjEx(extinfo->interp, cmdPtr, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1112 if (ret != TCL_OK) { 1113 Tcl_BackgroundError(extinfo->interp); 1114 } 1115} 1116 1117/* 1118 *---------------------------------------------------------------------------- 1119 * 1120 * TclXSLTExtFunction -- 1121 * 1122 * Handles evaluation of an extension function. 1123 * 1124 * Results: 1125 * Returns string returned by Tcl command evaluation. 1126 * 1127 * Side effects: 1128 * Depends on Tcl command evaluated. 1129 * 1130 *---------------------------------------------------------------------------- 1131 */ 1132 1133static void 1134TclXSLTExtFunction(xpathCtxt, nargs) 1135 xmlXPathParserContextPtr xpathCtxt; 1136 int nargs; 1137{ 1138 xsltTransformContextPtr xformCtxt; 1139 TclXSLT_Extension *extinfo; 1140 Tcl_Obj *cmdPtr, *resultPtr; 1141 xmlXPathObjectPtr obj; 1142 int ret, len; 1143 1144 xformCtxt = xsltXPathGetTransformContext(xpathCtxt); 1145 1146 /* 1147 * In order to find the instance data we need the 1148 * XML Namespace URI of this function. 1149 */ 1150 1151 extinfo = (TclXSLT_Extension *) xsltGetExtData(xformCtxt, 1152 xpathCtxt->context->functionURI); 1153 1154 /* 1155 * Start constructing the script by first defining the command. 1156 */ 1157 1158 cmdPtr = Tcl_DuplicateObj(extinfo->tclns); 1159 Tcl_IncrRefCount(cmdPtr); 1160 Tcl_AppendStringsToObj(cmdPtr, "::", xpathCtxt->context->function, NULL); 1161 1162 /* 1163 * Each argument on the stack is converted to a Tcl_Obj 1164 * of an appropriate type and passed as an argument to the Tcl command. 1165 */ 1166 1167 while (nargs) { 1168 Tcl_Obj *objv[2]; 1169 1170 obj = (xmlXPathObjectPtr) valuePop(xpathCtxt); 1171 if (obj == NULL) { 1172 xmlXPathSetError(xpathCtxt, XPATH_INVALID_OPERAND); 1173 Tcl_DecrRefCount(cmdPtr); 1174 return; 1175 } 1176 1177 objv[0] = TclXSLT_ConvertXPathObjToTclObj(extinfo->interp, obj); 1178 objv[1] = NULL; 1179 if (Tcl_ListObjReplace(extinfo->interp, cmdPtr, 1, 0, 1, objv) != TCL_OK) { 1180 Tcl_BackgroundError(extinfo->interp); 1181 Tcl_DecrRefCount(objv[0]); 1182 Tcl_DecrRefCount(cmdPtr); 1183 return; 1184 } 1185 1186 /* When should this XPath object be freed? 1187 * Immediately before returning from the function call? 1188 * What if the application retains a pointer to it? 1189 * If the application destroys the contents, then memory 1190 * will leak because the XPath object is not freed. 1191 * 1192 * TODO: take a copy of the object's content and pass that 1193 * to the application callback. That would allow this object 1194 * to be freed and allow the application to manage the copy. 1195 1196 xmlXPathFreeObject(obj); 1197 */ 1198 1199 nargs--; 1200 } 1201 1202 ret = Tcl_EvalObjEx(extinfo->interp, cmdPtr, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1203 resultPtr = Tcl_GetObjResult(extinfo->interp); 1204 Tcl_DecrRefCount(cmdPtr); 1205 Tcl_IncrRefCount(resultPtr); 1206 1207 if (ret == TCL_OK) { 1208 obj = TclXSLT_ConvertTclObjToXPathObj(extinfo->interp, resultPtr); 1209 valuePush(xpathCtxt, obj); 1210 } else { 1211 xmlGenericError(xmlGenericErrorContext, 1212 Tcl_GetStringFromObj(resultPtr, NULL)); 1213 /* Need to define a new error code - this is the closest in meaning */ 1214 xpathCtxt->error = XPATH_UNKNOWN_FUNC_ERROR; 1215 } 1216 1217 Tcl_DecrRefCount(resultPtr); 1218 1219} 1220 1221/* 1222 *---------------------------------------------------------------------------- 1223 * 1224 * TclXSLT_ConvertTclObjToXPathObj -- 1225 * 1226 * Convert a Tcl Object to an XPath object. 1227 * Data type is preserved, with nodesets being 1228 * mapped from a list of nodes. 1229 * 1230 * Results: 1231 * XPath Object. 1232 * 1233 * Side effects: 1234 * None. 1235 * 1236 *---------------------------------------------------------------------------- 1237 */ 1238 1239static xmlXPathObjectPtr 1240TclXSLT_ConvertTclObjToXPathObj(interp, objPtr) 1241 Tcl_Interp *interp; 1242 Tcl_Obj *objPtr; 1243{ 1244 xmlNodePtr nodePtr; 1245 xmlDocPtr docPtr; 1246 1247 if (TclDOM_GetNodeFromObj(interp, objPtr, &nodePtr) == TCL_OK) { 1248 return xmlXPathNewNodeSet(nodePtr); 1249 } 1250 1251 /* 1252 * BUG: This is corrupting objPtr for some unknown reason. 1253 */ 1254 if (TclDOM_GetDocFromObj(interp, objPtr, &docPtr) == TCL_OK) { 1255 return xmlXPathNewNodeSet((xmlNodePtr) docPtr); 1256 1257 } 1258 1259 if (objPtr->typePtr == Tcl_GetObjType("int") || 1260 objPtr->typePtr == Tcl_GetObjType("double")) { 1261 double number; 1262 1263 if (Tcl_GetDoubleFromObj(interp, objPtr, &number) == TCL_OK) { 1264 return xmlXPathNewFloat(number); 1265 } else { 1266 return NULL; 1267 } 1268 } else if (objPtr->typePtr == Tcl_GetObjType("boolean")) { 1269 int bool; 1270 1271 if (Tcl_GetBooleanFromObj(interp, objPtr, &bool) == TCL_OK) { 1272 return xmlXPathNewBoolean(bool); 1273 } else { 1274 return NULL; 1275 } 1276 } else if (objPtr->typePtr == Tcl_GetObjType("list")) { 1277 /* 1278 * If each of the elements can be converted to a node, 1279 * then return a nodeset. 1280 */ 1281 1282 int i, len; 1283 Tcl_Obj **listPtr; 1284 xmlNodeSetPtr nset; 1285 1286 Tcl_ListObjGetElements(interp, objPtr, &len, &listPtr); 1287 if (len == 0) { 1288 return xmlXPathNewNodeSet(NULL); 1289 } 1290 1291 /* 1292 * First pass: check that the elements are all nodes. 1293 */ 1294 for (i = 0; i < len; i++) { 1295 if (TclDOM_GetDocFromObj(interp, listPtr[i], &docPtr) == TCL_OK) { 1296 continue; 1297 } 1298 if (TclDOM_GetNodeFromObj(interp, listPtr[i], &nodePtr) != TCL_OK) { 1299 return xmlXPathNewString(Tcl_GetStringFromObj(objPtr, NULL)); 1300 } 1301 } 1302 /* 1303 * Now go ahead and create the nodeset (we already did the hard 1304 * work to create internal reps in pass 1). 1305 */ 1306 if (TclDOM_GetDocFromObj(interp, listPtr[0], &docPtr) == TCL_OK) { 1307 nset = xmlXPathNodeSetCreate((xmlNodePtr) docPtr); 1308 } else { 1309 TclDOM_GetNodeFromObj(interp, listPtr[0], &nodePtr); 1310 nset = xmlXPathNodeSetCreate(nodePtr); 1311 } 1312 for (i = 1; i < len; i++) { 1313 if (TclDOM_GetDocFromObj(interp, listPtr[i], &docPtr) == TCL_OK) { 1314 xmlXPathNodeSetAdd(nset, (xmlNodePtr) docPtr); 1315 } else { 1316 TclDOM_GetNodeFromObj(interp, listPtr[i], &nodePtr); 1317 xmlXPathNodeSetAdd(nset, nodePtr); 1318 } 1319 } 1320 return xmlXPathWrapNodeSet(nset); 1321 1322 } else { 1323 return xmlXPathNewString(Tcl_GetStringFromObj(objPtr, NULL)); 1324 } 1325} 1326 1327/* 1328 *---------------------------------------------------------------------------- 1329 * 1330 * TclXSLT_ConvertXPathObjToTclObj -- 1331 * 1332 * Convert an XPath object to a Tcl Object. 1333 * Data type is preserved, with nodesets being 1334 * mapped to a list of nodes. 1335 * 1336 * Results: 1337 * Tcl Object. 1338 * 1339 * Side effects: 1340 * None. 1341 * 1342 *---------------------------------------------------------------------------- 1343 */ 1344 1345static Tcl_Obj * 1346TclXSLT_ConvertXPathObjToTclObj(interp, xpobj) 1347 Tcl_Interp *interp; 1348 xmlXPathObjectPtr xpobj; 1349{ 1350 Tcl_Obj *objPtr; 1351 int i; 1352 1353 switch (xpobj->type) { 1354 case XPATH_XSLT_TREE: 1355 case XPATH_NODESET: 1356 1357 objPtr = Tcl_NewListObj(0, NULL); 1358 for (i = 0; i < xpobj->nodesetval->nodeNr; i++) { 1359 Tcl_Obj *nodeObjPtr; 1360 nodeObjPtr = TclDOM_CreateObjFromNode(xpobj->nodesetval->nodeTab[i]); 1361 Tcl_ListObjAppendElement(interp, objPtr, nodeObjPtr); 1362 } 1363 1364 break; 1365 1366 case XPATH_BOOLEAN: 1367 objPtr = Tcl_NewBooleanObj(xpobj->boolval); 1368 break; 1369 1370 case XPATH_NUMBER: 1371 objPtr = Tcl_NewDoubleObj(xpobj->floatval); 1372 break; 1373 1374 case XPATH_STRING: 1375 case XPATH_UNDEFINED: 1376 case XPATH_POINT: 1377 case XPATH_RANGE: 1378 case XPATH_LOCATIONSET: 1379 case XPATH_USERS: 1380 default: 1381 objPtr = Tcl_NewStringObj(xmlXPathCastToString(xpobj), -1); 1382 1383 break; 1384 } 1385 1386 return objPtr; 1387} 1388 1389/* 1390 *---------------------------------------------------------------------------- 1391 * 1392 * TclXSLTExtShutdown -- 1393 * 1394 * Clean up. 1395 * 1396 * Results: 1397 * None. 1398 * 1399 * Side effects: 1400 * None. 1401 * 1402 *---------------------------------------------------------------------------- 1403 */ 1404 1405static void 1406TclXSLTExtShutdown(ctxt, URI, userdata) 1407 xsltTransformContextPtr ctxt; 1408 const xmlChar *URI; 1409 void *userdata; 1410{ 1411 /* Nothing to do */ 1412} 1413