summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCmdMZ.c191
1 files changed, 172 insertions, 19 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 2a78838..d1961b7 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -10,11 +10,12 @@
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 Scriptics Corporation.
* Copyright (c) 2002 ActiveState Corporation.
+ * Copyright (c) 2003 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.96 2003/10/14 18:23:39 vincentdarley Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.97 2003/12/14 18:32:36 dkf Exp $
*/
#include "tclInt.h"
@@ -2561,19 +2562,23 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int i, j, index, mode, matched, result, splitObjs;
+ int i, j, index, mode, matched, result, splitObjs, numMatchesSaved;
char *string, *pattern;
- Tcl_Obj *stringObj;
+ Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
Tcl_Obj *CONST *savedObjv = objv;
+ Tcl_RegExp regExpr;
static CONST char *options[] = {
- "-exact", "-glob", "-regexp", "--",
+ "-exact", "-glob", "-indexvar", "-matchvar", "-regexp", "--",
NULL
};
enum options {
- OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST
+ OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_REGEXP, OPT_LAST
};
mode = OPT_EXACT;
+ indexVarObj = NULL;
+ matchVarObj = NULL;
+ numMatchesSaved = 0;
for (i = 1; i < objc; i++) {
string = Tcl_GetString(objv[i]);
if (string[0] != '-') {
@@ -2587,7 +2592,35 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
i++;
break;
}
- mode = index;
+
+ /*
+ * Check for TIP#75 options specifying the variables to write
+ * regexp information into.
+ */
+
+ if (index == OPT_INDEXV) {
+ i++;
+ if (i == objc) {
+ Tcl_AppendResult(interp,
+ "missing variable name argument to -indexvar option",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ indexVarObj = objv[i];
+ numMatchesSaved = -1;
+ } else if (index == OPT_MATCHV) {
+ i++;
+ if (i == objc) {
+ Tcl_AppendResult(interp,
+ "missing variable name argument to -matchvar option",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ matchVarObj = objv[i];
+ numMatchesSaved = -1;
+ } else {
+ mode = index;
+ }
}
if (objc - i < 2) {
@@ -2595,6 +2628,16 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
"?switches? string pattern body ... ?default body?");
return TCL_ERROR;
}
+ if (indexVarObj != NULL && mode != OPT_REGEXP) {
+ Tcl_AppendResult(interp,
+ "-indexvar option requires -regexp option", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (matchVarObj != NULL && mode != OPT_REGEXP) {
+ Tcl_AppendResult(interp,
+ "-matchvar option requires -regexp option", (char *) NULL);
+ return TCL_ERROR;
+ }
stringObj = objv[i];
objc -= i + 1;
@@ -2682,22 +2725,57 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
if ((i == objc - 2)
&& (*pattern == 'd')
&& (strcmp(pattern, "default") == 0)) {
+ Tcl_Obj *emptyObj = NULL;
+
matched = 1;
+ /*
+ * If either indexVarObj or matchVarObj are non-NULL,
+ * we're in REGEXP mode but have reached the default
+ * clause anyway. TIP#75 specifies that we set the
+ * variables to empty lists (== empty objects) in that
+ * case.
+ */
+ if (indexVarObj != NULL) {
+ TclNewObj(emptyObj);
+ if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, emptyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_DecrRefCount(emptyObj);
+ return TCL_ERROR;
+ }
+ }
+ if (matchVarObj != NULL) {
+ if (emptyObj == NULL) {
+ TclNewObj(emptyObj);
+ }
+ if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, emptyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ if (indexVarObj == NULL) {
+ Tcl_DecrRefCount(emptyObj);
+ }
+ return TCL_ERROR;
+ }
+ }
+ numMatchesSaved = 0;
} else {
switch (mode) {
- case OPT_EXACT:
- matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0);
- break;
- case OPT_GLOB:
- matched = Tcl_StringMatch(Tcl_GetString(stringObj),
- pattern);
- break;
- case OPT_REGEXP:
- matched = Tcl_RegExpMatchObj(interp, stringObj, objv[i]);
- if (matched < 0) {
- return TCL_ERROR;
- }
- break;
+ case OPT_EXACT:
+ matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0);
+ break;
+ case OPT_GLOB:
+ matched = Tcl_StringMatch(Tcl_GetString(stringObj), pattern);
+ break;
+ case OPT_REGEXP:
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[i],
+ TCL_REG_ADVANCED);
+ if (regExpr == NULL) {
+ return TCL_ERROR;
+ }
+ matched = Tcl_RegExpExecObj(interp, regExpr, stringObj, 0,
+ numMatchesSaved, 0);
+ if (matched < 0) {
+ return TCL_ERROR;
+ }
+ break;
}
}
if (matched == 0) {
@@ -2705,6 +2783,81 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
}
/*
+ * We are operating in REGEXP mode and we need to store
+ * information about what we matched in some user-nominated
+ * arrays. So build the lists of values and indices to write
+ * here. [TIP#75]
+ */
+
+ if (numMatchesSaved) {
+ Tcl_RegExpInfo info;
+ Tcl_Obj *matchesObj, *indicesObj;
+
+ Tcl_RegExpGetInfo(regExpr, &info);
+ if (matchVarObj != NULL) {
+ TclNewObj(matchesObj);
+ } else {
+ matchesObj = NULL;
+ }
+ if (indexVarObj != NULL) {
+ TclNewObj(indicesObj);
+ }
+ for (j=0 ; j<=info.nsubs ; j++) {
+ if (indexVarObj != NULL) {
+ Tcl_Obj *rangeObjAry[2];
+
+ rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start);
+ rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end);
+ /*
+ * Never fails; the object is always clean at this point.
+ */
+ Tcl_ListObjAppendElement(NULL, indicesObj,
+ Tcl_NewListObj(2, rangeObjAry));
+ }
+ if (matchVarObj != NULL) {
+ Tcl_Obj *substringObj;
+
+ substringObj = Tcl_GetRange(stringObj,
+ info.matches[j].start, info.matches[j].end-1);
+ /*
+ * Never fails; the object is always clean at this point.
+ */
+ Tcl_ListObjAppendElement(NULL, matchesObj, substringObj);
+ }
+ }
+ if (indexVarObj != NULL) {
+ if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, indicesObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_DecrRefCount(indicesObj);
+ /*
+ * Careful! Check to see if we have allocated the
+ * list of matched strings; if so (but there was
+ * an error assigning the indices list) we have a
+ * potential memory leak because the match list
+ * has not been written to a variable. Except
+ * that we'll clean that up right now.
+ */
+ if (matchesObj != NULL) {
+ Tcl_DecrRefCount(matchesObj);
+ }
+ return TCL_ERROR;
+ }
+ }
+ if (matchVarObj != NULL) {
+ if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, matchesObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_DecrRefCount(matchesObj);
+ /*
+ * Unlike above, if indicesObj is non-NULL at this
+ * point, it will have been written to a variable
+ * already and will hence not be leaked.
+ */
+ return TCL_ERROR;
+ }
+ }
+ }
+
+ /*
* We've got a match. Find a body to execute, skipping bodies
* that are "-".
*/
generated by cgit v0.12 at 2024-12-11 19:58:24 (GMT)