Tcl Source Code

/* 
 * regc_locale.c --
 *
 *	This file contains the Unicode locale specific regexp routines.
 *	This file is #included by regcomp.c.
 *
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: regc_locale.c,v 1.1.2.6 1999/04/02 23:44:53 stanton Exp $
 */

/* ASCII character-name table */

static struct cname {
	char *name;
	char code;

	if (len == 1)
		return *startp;

	NOTE(REG_ULOCALE);

	/* search table */
	Tcl_DStringInit(&ds);
	np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
	for (cn = cnames; cn->name != NULL; cn++)
		if (strlen(cn->name) == len && strncmp(cn->name, np, len) == 0)
			break;		/* NOTE BREAK OUT */
	Tcl_DStringFree(&ds);
	if (cn->name != NULL)
		return CHR(cn->code);

    /*
     * Extract the class name
     */

    len = endp - startp;
    Tcl_DStringInit(&ds);
    np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);

    /*
     * Remap lower and upper to alpha if the match is case insensitive.
     */

    if (cases && len == 5 && (strncmp("lower", np, 5) == 0
	    || strncmp("upper", np, 5) == 0)) {

#define	CHR(c)	(UCHAR(c))	/* turn char literal into chr literal */
#define	DIGITVAL(c)	((c)-'0')	/* turn chr digit into its value */
#define	CHRBITS	16		/* bits in a chr; must not use sizeof */
#define	CHR_MIN	0x0000		/* smallest and largest chr; the value */
#define	CHR_MAX	0xffff		/*  CHR_MAX-CHR_MIN+1 should fit in uchr */

/* functions operating on chr */
#define	iscalnum(x)	Tcl_UniCharIsAlnum(x)
#define	iscalpha(x)	Tcl_UniCharIsAlpha(x)
#define	iscdigit(x)	Tcl_UniCharIsDigit(x)
#define	iscspace(x)	Tcl_UniCharIsSpace(x)

/* name the external functions */
#define	compile		TclReComp
#define	exec		TclReExec

/* enable/disable debugging code (by whether REG_DEBUG is defined or not) */
#ifdef notdef

# tcl.decls --
#
#	This file contains the declarations for all supported public
#	functions that are exported by the Tcl library via the stubs table.
#	This file is used to generate the tclDecls.h, tclPlatDecls.h,
#	tclStub.c, and tclPlatStub.c files.
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: tcl.decls,v 1.3.2.13 1999/04/02 23:44:53 stanton Exp $

library tcl

# Define the tcl interface with several sub interfaces:
#     tclPlat	 - platform specific public
#     tclInt	 - generic private
#     tclPlatInt - platform specific private

}
declare 343 generic {
    void Tcl_AlertNotifier(ClientData clientData)
}
declare 344 generic {
    void Tcl_ServiceModeHook(int mode)
}
declare 345 generic {
    int Tcl_UniCharIsAlnum(int ch)
}
declare 346 generic {
    int Tcl_UniCharIsAlpha(int ch)
}
declare 347 generic {
    int Tcl_UniCharIsDigit(int ch)
}
declare 348 generic {
    int Tcl_UniCharIsLower(int ch)
}
declare 349 generic {
    int Tcl_UniCharIsSpace(int ch)
}
declare 350 generic {
    int Tcl_UniCharIsUpper(int ch)
}
declare 351 generic {
    int Tcl_UniCharIsWordChar(int ch)
}
declare 352 generic {
    int Tcl_UniCharLen(Tcl_UniChar *str)
}
declare 353 generic {
    int Tcl_UniCharNcmp(const Tcl_UniChar *cs, const Tcl_UniChar *ct, size_t n)
}
declare 354 generic {
    char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *string, int numChars, \
 	    Tcl_DString *dsPtr)
}
declare 355 generic {
    Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *string, int length, \
	    Tcl_DString *dsPtr)
}

##############################################################################

# Define the platform specific public Tcl interface.  These functions are
# only available on the designated platform.

interface tclPlat

 * Copyright (c) 1993-1997 Lucent Technologies.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdIL.c,v 1.1.2.11 1999/04/02 23:44:54 stanton Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclCompile.h"
#include "tclRegexp.h"

	} else {
	    diff = UCHAR(*left) - UCHAR(*right);
	    break;
	}

        diff = uniLeft - uniRight;
        if (diff) {
	    if (Tcl_UniCharIsUpper(uniLeft) &&
		    Tcl_UniCharIsLower(uniRight)) {
		diff = Tcl_UniCharToLower(uniLeft) - uniRight;
		if (diff) {
		    return diff;
                } else if (secondaryDiff == 0) {
		    secondaryDiff = -1;
                }
	    } else if (Tcl_UniCharIsUpper(uniRight)
		    && Tcl_UniCharIsLower(uniLeft)) {
                diff = uniLeft - Tcl_UniCharToLower(uniRight);
                if (diff) {
		    return diff;
                } else if (secondaryDiff == 0) {
		    secondaryDiff = 1;
                }
            } else {

 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * 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.1.2.10 1999/04/02 23:44:55 stanton Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclCompile.h"
#include "tclRegexp.h"

    result = TCL_OK;
    string = Tcl_GetStringFromObj(objv[1], &stringLength);

    Tcl_DStringInit(&valueBuffer);
    
    Tcl_DStringInit(&stringBuffer);
    wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer);
    wLen = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar);

    match = TclRegExpExecUniChar(interp, regExpr, wStart, wLen, objc-2, eflags);
    if (match < 0) {
	result = TCL_ERROR;
	goto done;
    }

	} else {
	    if (indices) {
		char info[TCL_INTEGER_SPACE * 2];
		
		sprintf(info, "%d %d", start, end - 1);
		value = Tcl_SetVar(interp, varName, info, 0);
	    } else {
		value = Tcl_UniCharToUtfDString(wStart + start, end - start,
			&valueBuffer);
		value = Tcl_SetVar(interp, varName, value, 0);
		Tcl_DStringSetLength(&valueBuffer, 0);
	    }
	}
	if (value == NULL) {
	    Tcl_AppendResult(interp, "couldn't set variable \"",

     * The following loop is to handle multiple matches within the
     * same source string;  each iteration handles one match and its
     * corresponding substitution.  If "-all" hasn't been specified
     * then the loop body only gets executed once.
     */

    Tcl_DStringInit(&stringBuffer);
    wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer);
    wEnd = wStart + Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar);

    numMatches = 0;
    for (w = wStart; w < wEnd; ) {
	int start, end, subStart, subEnd, match;
	char *src, *firstChar;
	char c;

	/*
	 * Copy the portion of the source string before the match to the
	 * result variable.
	 */

	TclRegExpRangeUniChar(regExpr, 0, &start, &end);
	Tcl_UniCharToUtfDString(w, start, &resultBuffer);
    
	/*
	 * Append the subSpec argument to the variable, making appropriate
	 * substitutions.  This code is a bit hairy because of the backslash
	 * conventions and because the code saves up ranges of characters in
	 * subSpec to reduce the number of calls to Tcl_SetVar.
	 */

		continue;
	    }
	    if (firstChar != src) {
		Tcl_DStringAppend(&resultBuffer, firstChar, src - firstChar);
	    }
	    TclRegExpRangeUniChar(regExpr, index, &subStart, &subEnd);
	    if ((subStart >= 0) && (subEnd >= 0)) {
		Tcl_UniCharToUtfDString(w + subStart, subEnd - subStart,
			&resultBuffer);
	    }
	    if (*src == '\\') {
		src++;
	    }
	    firstChar = src + 1;
	}
	if (firstChar != src) {
	    Tcl_DStringAppend(&resultBuffer, firstChar, src - firstChar);
	}
	if (end == 0) {
	    /*
	     * Always consume at least one character of the input string
	     * in order to prevent infinite loops.
	     */

	    Tcl_UniCharToUtfDString(w, 1, &resultBuffer);
	    w++;
	}
	w += end;
	if (!all) {
	    break;
	}
    }

    /*
     * Copy the portion of the source string after the last match to the
     * result variable.
     */

    if ((w < wEnd) || (numMatches == 0)) {
	Tcl_UniCharToUtfDString(w, wEnd - w, &resultBuffer);
    }
    if (Tcl_SetVar(interp, varname, Tcl_DStringValue(&resultBuffer),
	    0) == NULL) {
	Tcl_AppendResult(interp, "couldn't set variable \"", varname, "\"",
		(char *) NULL);
	result = TCL_ERROR;
    } else {

	    }
	    numChars = Tcl_NumUtfChars(string1, length1);
	    if (index < numChars) {
		p = Tcl_UtfAtIndex(string1, index);
		end = string1+length1;
		for (cur = index; p < end; cur++) {
		    p += Tcl_UtfToUniChar(p, &ch);
		    if (!Tcl_UniCharIsWordChar(ch)) {
			break;
		    }
		}
		if (cur == index) {
		    cur++;
		}
	    } else {

		index = numChars - 1;
	    }
	    cur = 0;
	    if (index > 0) {
		p = Tcl_UtfAtIndex(string1, index);
	        for (cur = index; cur >= 0; cur--) {
		    Tcl_UtfToUniChar(p, &ch);
		    if (!Tcl_UniCharIsWordChar(ch)) {
			break;
		    }
		    p = Tcl_UtfPrev(p, string1);
		}
		if (cur != index) {
		    cur += 1;
		}

/*
 * tclDecls.h --
 *
 *	Declarations of functions in the platform independent public Tcl API.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDecls.h,v 1.3.2.14 1999/04/02 23:44:55 stanton Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

/*
 * WARNING: This file is automatically generated by the tools/genStubs.tcl

EXTERN char *		Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void));
/* 342 */
EXTERN void		Tcl_SetDefaultEncodingDir _ANSI_ARGS_((char * path));
/* 343 */
EXTERN void		Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData));
/* 344 */
EXTERN void		Tcl_ServiceModeHook _ANSI_ARGS_((int mode));
/* 345 */
EXTERN int		Tcl_UniCharIsAlnum _ANSI_ARGS_((int ch));
/* 346 */
EXTERN int		Tcl_UniCharIsAlpha _ANSI_ARGS_((int ch));
/* 347 */
EXTERN int		Tcl_UniCharIsDigit _ANSI_ARGS_((int ch));
/* 348 */
EXTERN int		Tcl_UniCharIsLower _ANSI_ARGS_((int ch));
/* 349 */
EXTERN int		Tcl_UniCharIsSpace _ANSI_ARGS_((int ch));
/* 350 */
EXTERN int		Tcl_UniCharIsUpper _ANSI_ARGS_((int ch));
/* 351 */
EXTERN int		Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch));
/* 352 */
EXTERN int		Tcl_UniCharLen _ANSI_ARGS_((Tcl_UniChar * str));
/* 353 */
EXTERN int		Tcl_UniCharNcmp _ANSI_ARGS_((const Tcl_UniChar * cs, 
				const Tcl_UniChar * ct, size_t n));
/* 354 */
EXTERN char *		Tcl_UniCharToUtfDString _ANSI_ARGS_((
				CONST Tcl_UniChar * string, int numChars, 
				Tcl_DString * dsPtr));
/* 355 */
EXTERN Tcl_UniChar *	Tcl_UtfToUniCharDString _ANSI_ARGS_((
				CONST char * string, int length, 
				Tcl_DString * dsPtr));

typedef struct TclStubHooks {
    struct TclPlatStubs *tclPlatStubs;
    struct TclIntStubs *tclIntStubs;
    struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;

    int (*tcl_WriteChars) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 338 */
    int (*tcl_WriteObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 339 */
    char * (*tcl_GetString) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 340 */
    char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */
    void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((char * path)); /* 342 */
    void (*tcl_AlertNotifier) _ANSI_ARGS_((ClientData clientData)); /* 343 */
    void (*tcl_ServiceModeHook) _ANSI_ARGS_((int mode)); /* 344 */
    int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */
    int (*tcl_UniCharIsAlpha) _ANSI_ARGS_((int ch)); /* 346 */
    int (*tcl_UniCharIsDigit) _ANSI_ARGS_((int ch)); /* 347 */
    int (*tcl_UniCharIsLower) _ANSI_ARGS_((int ch)); /* 348 */
    int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */
    int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */
    int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */
    int (*tcl_UniCharLen) _ANSI_ARGS_((Tcl_UniChar * str)); /* 352 */
    int (*tcl_UniCharNcmp) _ANSI_ARGS_((const Tcl_UniChar * cs, const Tcl_UniChar * ct, size_t n)); /* 353 */
    char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * string, int numChars, Tcl_DString * dsPtr)); /* 354 */
    Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * string, int length, Tcl_DString * dsPtr)); /* 355 */
} TclStubs;

extern TclStubs *tclStubsPtr;

#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)

/*

#define Tcl_AlertNotifier \
	(tclStubsPtr->tcl_AlertNotifier) /* 343 */
#endif
#ifndef Tcl_ServiceModeHook
#define Tcl_ServiceModeHook \
	(tclStubsPtr->tcl_ServiceModeHook) /* 344 */
#endif
#ifndef Tcl_UniCharIsAlnum
#define Tcl_UniCharIsAlnum \
	(tclStubsPtr->tcl_UniCharIsAlnum) /* 345 */
#endif
#ifndef Tcl_UniCharIsAlpha
#define Tcl_UniCharIsAlpha \
	(tclStubsPtr->tcl_UniCharIsAlpha) /* 346 */
#endif
#ifndef Tcl_UniCharIsDigit
#define Tcl_UniCharIsDigit \
	(tclStubsPtr->tcl_UniCharIsDigit) /* 347 */
#endif
#ifndef Tcl_UniCharIsLower
#define Tcl_UniCharIsLower \
	(tclStubsPtr->tcl_UniCharIsLower) /* 348 */
#endif
#ifndef Tcl_UniCharIsSpace
#define Tcl_UniCharIsSpace \
	(tclStubsPtr->tcl_UniCharIsSpace) /* 349 */
#endif
#ifndef Tcl_UniCharIsUpper
#define Tcl_UniCharIsUpper \
	(tclStubsPtr->tcl_UniCharIsUpper) /* 350 */
#endif
#ifndef Tcl_UniCharIsWordChar
#define Tcl_UniCharIsWordChar \
	(tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */
#endif
#ifndef Tcl_UniCharLen
#define Tcl_UniCharLen \
	(tclStubsPtr->tcl_UniCharLen) /* 352 */
#endif
#ifndef Tcl_UniCharNcmp
#define Tcl_UniCharNcmp \
	(tclStubsPtr->tcl_UniCharNcmp) /* 353 */
#endif
#ifndef Tcl_UniCharToUtfDString
#define Tcl_UniCharToUtfDString \
	(tclStubsPtr->tcl_UniCharToUtfDString) /* 354 */
#endif
#ifndef Tcl_UtfToUniCharDString
#define Tcl_UtfToUniCharDString \
	(tclStubsPtr->tcl_UtfToUniCharDString) /* 355 */
#endif

#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#endif /* _TCLDECLS */

/*
 * tclInt.h --
 *
 *	Declarations of things used internally by the Tcl interpreter.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1993-1997 Lucent Technologies.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.1.2.18 1999/04/02 23:44:56 stanton Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Common include files needed by most of the Tcl source files are

EXTERN int		TclTestChannelCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, char **argv));
EXTERN int		TclTestChannelEventCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int argc, char **argv));
EXTERN void		TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp,
			    int result, Tcl_Interp *targetInterp));










EXTERN int		TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr));






/*
 *----------------------------------------------------------------
 * Command procedures in the generic core:
 *----------------------------------------------------------------
 */

/* 
 * tclRegexp.c --
 *
 *	This file contains the public interfaces to the Tcl regular
 *	expression mechanism.
 *
 * Copyright (c) 1998 by Scriptics Corporation.
 * Copyright (c) 1998 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclRegexp.c,v 1.1.2.7 1999/04/02 23:44:57 stanton Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"

/*

     * Remember the UTF-8 string so Tcl_RegExpRange() can convert the
     * matches from character to byte offsets.
     */

    regexpPtr->string = string;

    Tcl_DStringInit(&stringBuffer);
    uniString = Tcl_UtfToUniCharDString(string, -1, &stringBuffer);
    numChars = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar);

    /*
     * Perform the regexp match.
     */

    result = TclRegExpExecUniChar(interp, re, uniString, numChars, -1,

    regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp));

    /*
     * Get the up-to-date string representation and map to unicode.
     */

    Tcl_DStringInit(&stringBuf);
    uniString = Tcl_UtfToUniCharDString(string, length, &stringBuf);
    numChars = Tcl_DStringLength(&stringBuf) / sizeof(Tcl_UniChar);

    /*
     * Compile the string and check for errors.
     */

    regexpPtr->flags = flags;

/* 
 * tclScan.c --
 *
 *	This file contains the implementation of the "scan" command.
 *
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclScan.c,v 1.1.2.4 1999/04/02 23:44:57 stanton Exp $
 */

#include "tclInt.h"

/*
 * Flag values used by Tcl_ScanObjCmd.
 */

	flags = 0;

	/*
	 * If we see whitespace in the format, skip whitespace in the string.
	 */

	if (Tcl_UniCharIsSpace(ch)) {
	    offset = Tcl_UtfToUniChar(string, &sch);
	    while (Tcl_UniCharIsSpace(sch)) {
		if (*string == '\0') {
		    goto done;
		}
		string += offset;
		offset = Tcl_UtfToUniChar(string, &sch);
	    }
	    continue;

	 * Skip any leading whitespace at the beginning of a field unless
	 * the format suppresses this behavior.
	 */

	if (!(flags & SCAN_NOSKIP)) {
	    while (*string != '\0') {
		offset = Tcl_UtfToUniChar(string, &sch);
		if (!Tcl_UniCharIsSpace(sch)) {
		    break;
		}
		string += offset;
	    }
	    if (*string == '\0') {
		underflow = 1;
		goto done;

		if (width == 0) {
		    width = (size_t) ~0;
		}
		end = string;
		while (*end != '\0') {
		    offset = Tcl_UtfToUniChar(end, &sch);
		    if (Tcl_UniCharIsSpace(sch)) {
			break;
		    }
		    end += offset;
		    if (--width == 0) {
			break;
		    }
		}

/* 
 * tclStubInit.c --
 *
 *	This file contains the initializers for the Tcl stub vectors.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStubInit.c,v 1.3.2.10 1999/04/02 23:44:57 stanton Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * Remove macros that will interfere with the definitions below.

    Tcl_WriteChars, /* 338 */
    Tcl_WriteObj, /* 339 */
    Tcl_GetString, /* 340 */
    Tcl_GetDefaultEncodingDir, /* 341 */
    Tcl_SetDefaultEncodingDir, /* 342 */
    Tcl_AlertNotifier, /* 343 */
    Tcl_ServiceModeHook, /* 344 */
    Tcl_UniCharIsAlnum, /* 345 */
    Tcl_UniCharIsAlpha, /* 346 */
    Tcl_UniCharIsDigit, /* 347 */
    Tcl_UniCharIsLower, /* 348 */
    Tcl_UniCharIsSpace, /* 349 */
    Tcl_UniCharIsUpper, /* 350 */
    Tcl_UniCharIsWordChar, /* 351 */
    Tcl_UniCharLen, /* 352 */
    Tcl_UniCharNcmp, /* 353 */
    Tcl_UniCharToUtfDString, /* 354 */
    Tcl_UtfToUniCharDString, /* 355 */
};

TclIntStubs tclIntStubs = {
    TCL_STUB_MAGIC,
    NULL,
    TclAccess, /* 0 */
    TclAccessDeleteProc, /* 1 */

 *
 * Copyright (c) 1993-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTest.c,v 1.1.2.14 1999/04/02 23:44:58 stanton Exp $
 */

#define TCL_TEST

#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"

    result = TCL_OK;
    string = Tcl_GetStringFromObj(objv[1], &stringLength);

    Tcl_DStringInit(&valueBuffer);
    
    Tcl_DStringInit(&stringBuffer);
    wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer);
    wLen = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar);

    match = TclRegExpExecUniChar(interp, regExpr, wStart, wLen, objc-2, eflags);
    if (match < 0) {
	result = TCL_ERROR;
	goto done;
    }

	} else {
	    if (indices) {
		char info[TCL_INTEGER_SPACE * 2];
		
		sprintf(info, "%d %d", start, end - 1);
		value = Tcl_SetVar(interp, varName, info, 0);
	    } else {
		value = Tcl_UniCharToUtfDString(wStart + start, end - start,
			&valueBuffer);
		value = Tcl_SetVar(interp, varName, value, 0);
		Tcl_DStringSetLength(&valueBuffer, 0);
	    }
	}
	if (value == NULL) {
	    Tcl_AppendResult(interp, "couldn't set variable \"",

/*
 * tclUtf.c --
 *
 *	Routines for manipulating UTF-8 strings.
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUtf.c,v 1.1.2.6 1999/04/02 23:44:58 stanton Exp $
 */

#include "tclInt.h"

/*
 * Include the static character classification tables and macros.
 */

    ch = 0xFFFD;
    goto three;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UniCharToUtfDString --
 *
 *	Convert the given Unicode string to UTF-8.
 *
 * Results:
 *	The return value is a pointer to the UTF-8 representation of the
 *	Unicode string.  Storage for the return value is appended to the
 *	end of dsPtr.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
 
char *
Tcl_UniCharToUtfDString(wString, numChars, dsPtr)
    CONST Tcl_UniChar *wString;	/* Unicode string to convert to UTF-8. */
    int numChars;		/* Length of Unicode string in Tcl_UniChars
				 * (must be >= 0). */
    Tcl_DString *dsPtr;		/* UTF-8 representation of string is
				 * appended to this previously initialized
				 * DString. */
{

    *chPtr = (Tcl_UniChar) byte;
    return 1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfToUniCharDString --
 *
 *	Convert the UTF-8 string to Unicode.
 *
 * Results:
 *	The return value is a pointer to the Unicode representation of the
 *	UTF-8 string.  Storage for the return value is appended to the
 *	end of dsPtr.  The Unicode string is terminated with a Unicode
 *	NULL character.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_UniChar *
Tcl_UtfToUniCharDString(string, length, dsPtr)
    CONST char *string;		/* UTF-8 string to convert to Unicode. */
    int length;			/* Length of UTF-8 string in bytes, or -1
				 * for strlen(). */
    Tcl_DString *dsPtr;		/* Unicode representation of string is
				 * appended to this previously initialized
				 * DString. */
{

	return ch;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharLen --
 *
 *	Find the length of a UniChar string.  The str input must be null
 *	terminated.
 *
 * Results:
 *	Returns the length of str in UniChars (not bytes).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharLen(str)
    Tcl_UniChar *str;		/* Unicode string to find length of. */
{
    int len = 0;
    
    while (*str != '\0') {
	len++;
	str++;
    }
    return len;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharNcmp --
 *
 *	Compare at most n unichars of string cs to string ct.  Both cs
 *	and ct are assumed to be at least n unichars long.
 *
 * Results:
 *	Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharNcmp(cs, ct, n)
    CONST Tcl_UniChar *cs;		/* Unicode string to compare to ct. */
    CONST Tcl_UniChar *ct;		/* Unicode string cs is compared to. */
    size_t n;				/* Number of unichars to compare. */
{
    for ( ; n != 0; n--, cs++, ct++) {
	if (*cs != *ct) {
	    return *cs - *ct;
	}
	if (*cs == '\0') {
	    break;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsAlnum --
 *
 *	Test if a character is an alphanumeric Unicode character.
 *
 * Results:
 *	Returns 1 if character is alphanumeric.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsAlnum(ch)
    int ch;			/* Unicode character to test. */
{
    register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK);

    return (((ALPHA_BITS | DIGIT_BITS) >> category) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsAlpha --
 *
 *	Test if a character is an alphabetic Unicode character.
 *
 * Results:
 *	Returns 1 if character is alphabetic.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsAlpha(ch)
    int ch;			/* Unicode character to test. */
{
    register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK);
    return ((ALPHA_BITS >> category) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsDigit --
 *
 *	Test if a character is a numeric Unicode character.
 *
 * Results:
 *	Returns non-zero if character is a digit.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsDigit(ch)
    int ch;			/* Unicode character to test. */
{
    return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK)
	    == DECIMAL_DIGIT_NUMBER);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsLower --
 *
 *	Test if a character is a lowercase Unicode character.
 *
 * Results:
 *	Returns non-zero if character is lowercase.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsLower(ch)
    int ch;			/* Unicode character to test. */
{
    return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) == LOWERCASE_LETTER);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsSpace --
 *
 *	Test if a character is a whitespace Unicode character.
 *
 * Results:
 *	Returns non-zero if character is a space.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsSpace(ch)
    int ch;			/* Unicode character to test. */
{
    register int category;

    /*
     * If the character is within the first 127 characters, just use the
     * standard C function, otherwise consult the Unicode table.
     */

    if (ch < 0x80) {
	return isspace(UCHAR(ch)); /* INTL: ISO space */
    } else {
	category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK);
	return ((SPACE_BITS >> category) & 1);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsUpper --
 *
 *	Test if a character is a uppercase Unicode character.
 *
 * Results:
 *	Returns non-zero if character is uppercase.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsUpper(ch)
    int ch;			/* Unicode character to test. */
{
    return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) == UPPERCASE_LETTER);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsWordChar --
 *
 *	Test if a character is alphanumeric or a connector punctuation
 *	mark.
 *
 * Results:
 *	Returns 1 if character is a word character.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsWordChar(ch)
    int ch;			/* Unicode character to test. */
{
    register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK);

    return (((ALPHA_BITS | DIGIT_BITS | CONNECTOR_BITS) >> category) & 1);
}

/*
 * tclWinFCmd.c
 *
 *      This file implements the Windows specific portion of file manipulation 
 *      subcommands of the "file" command. 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinFCmd.c,v 1.1.2.3 1999/04/02 23:44:59 stanton Exp $
 */

#include "tclWinInt.h"

/*
 * The following constants specify the type of callback when
 * TraverseWinTree() calls the traverseProc()

		    wp++;
		}
		if (*wp == '\0') {
		    continue;
		}
	    }
	    nativeName = (TCHAR *) data.w.cFileName;
	    len = Tcl_UniCharLen(data.w.cFileName) * sizeof(WCHAR);
	} else {
	    if ((strcmp(data.a.cFileName, ".") == 0) 
		    || (strcmp(data.a.cFileName, "..") == 0)) {
		continue;
	    }
	    nativeName = (TCHAR *) data.a.cFileName;
	    len = strlen(data.a.cFileName);

/* 
 * tclWinFile.c --
 *
 *      This file contains temporary wrappers around UNIX file handling
 *      functions. These wrappers map the UNIX functions to Win32 HANDLE-style
 *      files, which can be manipulated through the Win32 console redirection
 *      interfaces.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinFile.c,v 1.1.2.6 1999/04/02 23:45:00 stanton Exp $
 */

#include "tclWinInt.h"
#include <sys/stat.h>
#include <shlobj.h>
#include <lmaccess.h>		/* For TclpGetUserHome(). */

	    badDomain = 0;
	    nameLen = -1;
	    wDomain = NULL;
	    domain = strchr(name, '@');
	    if (domain != NULL) {
		Tcl_DStringInit(&ds);
		wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds);
		badDomain = (*netGetDCNameProc)(NULL, wName,
			(LPBYTE *) &wDomain);
		Tcl_DStringFree(&ds);
		nameLen = domain - name;
	    }
	    if (badDomain == 0) {
		Tcl_DStringInit(&ds);
		wName = Tcl_UtfToUniCharDString(name, nameLen, &ds);
		if ((*netUserGetInfoProc)(wDomain, wName, 1, 
			(LPBYTE *) &uiPtr) == 0) {
		    wHomeDir = uiPtr->usri1_home_dir;
		    if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
			Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
				bufferPtr);
		    } else {
			/* 
			 * User exists but has no home dir.  Return
			 * "{Windows Drive}:/users/default".
			 */

			GetWindowsDirectoryW(buf, MAX_PATH);
			Tcl_UniCharToUtfDString(buf, 2, bufferPtr);
			Tcl_DStringAppend(bufferPtr, "/users/default", -1);
		    }
		    result = Tcl_DStringValue(bufferPtr);
		    (*netApiBufferFreeProc)((void *) uiPtr);
		}
		Tcl_DStringFree(&ds);
	    }