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, &reg);
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